CCPP SciDoc v7.0.0  v7.0.0
Common Community Physics Package Developed at DTC
 
Loading...
Searching...
No Matches
module_sf_noahmplsm.F90
1#define CCPP
2
4
6module module_sf_noahmplsm
7#ifndef CCPP
8 use module_wrf_utl
9#endif
10use machine , only : kind_phys
11
12 implicit none
13
14 public :: noahmp_options
15 public :: noahmp_sflx
16 public :: sfcdif4
17 public :: psi_init
18
19
20 private :: atm
21 private :: phenology
22 private :: precip_heat
23 private :: energy
24 private :: thermoprop
25 private :: csnow
26 private :: tdfcnd
27 private :: radiation
28 private :: albedo
29 private :: snow_age
30 private :: snowalb_bats
31 private :: snowalb_class
32 private :: groundalb
33 private :: twostream
34 private :: surrad
35 private :: vege_flux
36 private :: sfcdif1
37 private :: sfcdif2
38 private :: stomata
39 private :: canres
40 private :: esat
41 private :: ragrb
42 private :: bare_flux
43 private :: tsnosoi
44 private :: hrt
45 private :: hstep
46 private :: rosr12
47 private :: phasechange
48 private :: frh2o
49
50 private :: water
51 private :: canwater
52 private :: snowwater
53 private :: snowfall
54 private :: combine
55 private :: divide
56 private :: combo
57 private :: compact
58 private :: snowh2o
59 private :: soilwater
60 private :: zwteq
61 private :: infil
62 private :: srt
63 private :: wdfcnd1
64 private :: wdfcnd2
65 private :: sstep
66 private :: groundwater
67 private :: shallowwatertable
68
69 private :: carbon
70 private :: co2flux
71! private :: bvocflux
72! private :: ch4flux
73
74 private :: error
75
76! =====================================options for different schemes================================
77! **recommended
78
79 integer :: dveg
80 ! 1 -> off (use table lai; use fveg = shdfac from input)
81 ! 2 -> on (together with opt_crs = 1)
82 ! 3 -> off (use table lai; calculate fveg)
83 ! **4 -> off (use table lai; use maximum vegetation fraction)
84 ! **5 -> on (use maximum vegetation fraction)
85 ! 6 -> on (use FVEG = SHDFAC from input)
86 ! 7 -> off (use input LAI; use FVEG = SHDFAC from input)
87 ! 8 -> off (use input LAI; calculate FVEG)
88 ! 9 -> off (use input LAI; use maximum vegetation fraction)
89 ! 10 -> crop model on (use maximum vegetation fraction)
90
91 integer :: opt_crs
92 ! **1 -> ball-berry
93 ! 2 -> jarvis
94
95 integer :: opt_btr
96 ! **1 -> noah (soil moisture)
97 ! 2 -> clm (matric potential)
98 ! 3 -> ssib (matric potential)
99
100 integer :: opt_run
101 ! **1 -> topmodel with groundwater (niu et al. 2007 jgr) ;
102 ! 2 -> topmodel with an equilibrium water table (niu et al. 2005 jgr) ;
103 ! 3 -> original surface and subsurface runoff (free drainage)
104 ! 4 -> bats surface and subsurface runoff (free drainage)
105 ! 5 -> miguez-macho&fan groundwater scheme (miguez-macho et al. 2007 jgr; fan et al. 2007 jgr)
106 ! (needs further testing for public use)
107
108 integer :: opt_sfc
109 ! **1 -> m-o
110 ! **2 -> original noah (chen97)
111 ! **3 -> myj consistent; 4->ysu consistent. mb: removed in v3.7 for further testing
112
113 integer :: opt_frz
114 ! **1 -> no iteration (niu and yang, 2006 jhm)
115 ! 2 -> koren's iteration
116
117 integer :: opt_inf
118 ! **1 -> linear effects, more permeable (niu and yang, 2006, jhm)
119 ! 2 -> nonlinear effects, less permeable (old)
120
121 integer :: opt_rad
122 ! 1 -> modified two-stream (gap = f(solar angle, 3d structure ...)<1-fveg)
123 ! 2 -> two-stream applied to grid-cell (gap = 0)
124 ! **3 -> two-stream applied to vegetated fraction (gap=1-fveg)
125
126 integer :: opt_alb
127 ! 1 -> bats
128 ! **2 -> class
129
130 integer :: opt_snf
131 ! **1 -> jordan (1991)
132 ! 2 -> bats: when sfctmp<tfrz+2.2
133 ! 3 -> sfctmp < tfrz
134 ! 4 -> use wrf microphysics output
135
136 integer :: opt_tbot
137 ! 1 -> zero heat flux from bottom (zbot and tbot not used)
138 ! **2 -> tbot at zbot (8m) read from a file (original noah)
139
140 integer :: opt_stc
141 ! **1 -> semi-implicit; flux top boundary condition
142 ! 2 -> full implicit (original noah); temperature top boundary condition
143 ! 3 -> same as 1, but fsno for ts calculation (generally improves snow; v3.7)
144
145 integer :: opt_rsf
146 ! **1 -> sakaguchi and zeng, 2009
147 ! 2 -> sellers (1992)
148 ! 3 -> adjusted sellers to decrease rsurf for wet soil
149 ! 4 -> option 1 for non-snow; rsurf = rsurf_snow for snow (set in mptable); ad v3.8
150
151 integer :: opt_soil
152 ! **1 -> use input dominant soil texture
153 ! 2 -> use input soil texture that varies with depth
154 ! 3 -> use soil composition (sand, clay, orgm) and pedotransfer functions (opt_pedo)
155 ! 4 -> use input soil properties (bexp_3d, smcmax_3d, etc.)
156
157 integer :: opt_pedo
158 ! **1 -> saxton and rawls (2006)
159
160 integer :: opt_crop
161 ! **0 -> no crop model, will run default dynamic vegetation
162 ! 1 -> liu, et al. 2016
163
164 integer :: opt_trs
165 ! **1 -> z0h=z0m
166 ! 2 -> czil = f(canopy height) from Chen09
167 ! 3 -> ec style from TESSEL
168 ! 4 -> kb inverse from Blumel99
169 integer :: opt_diag
170 ! 1 -> external GFS sfc_diag
171 ! **2 -> original NoahMP 2-title
172 ! 3 -> NoahMP 2-title + internal GFS sfc_diag
173
174 integer :: opt_z0m
175 ! **1 -> use z0m from MPTABLE
176 ! 2 -> z0m = f(canopy height, LAI/SAI)
177
178!------------------------------------------------------------------------------------------!
179! physical constants: !
180!------------------------------------------------------------------------------------------!
181
182 real (kind=kind_phys), parameter :: grav = 9.80616
183 real (kind=kind_phys), parameter :: sb = 5.67e-08
184 real (kind=kind_phys), parameter :: vkc = 0.40
185 real (kind=kind_phys), parameter :: tfrz = 273.16
186 real (kind=kind_phys), parameter :: hsub = 2.8440e06
187 real (kind=kind_phys), parameter :: hvap = 2.5104e06
188 real (kind=kind_phys), parameter :: hfus = 0.3336e06
189 real (kind=kind_phys), parameter :: cwat = 4.188e06
190 real (kind=kind_phys), parameter :: cice = 2.094e06
191 real (kind=kind_phys), parameter :: cpair = 1004.64
192 real (kind=kind_phys), parameter :: tkwat = 0.6
193 real (kind=kind_phys), parameter :: tkice = 2.2
194 real (kind=kind_phys), parameter :: tkair = 0.023
195 real (kind=kind_phys), parameter :: rair = 287.04
196 real (kind=kind_phys), parameter :: rw = 461.269
197 real (kind=kind_phys), parameter :: denh2o = 1000.
198 real (kind=kind_phys), parameter :: denice = 917.
199
200 integer, private, parameter :: mband = 2
201 integer, private, parameter :: nsoil = 4
202 integer, private, parameter :: nstage = 8
203
204 type noahmp_parameters ! define a noahmp parameters type
205
206!------------------------------------------------------------------------------------------!
207! from the veg section of mptable.tbl
208!------------------------------------------------------------------------------------------!
209
210 logical :: urban_flag
211 integer :: iswater
212 integer :: isbarren
213 integer :: isice
214 integer :: iscrop
215 integer :: eblforest
216
217 real (kind=kind_phys) :: ch2op
218 real (kind=kind_phys) :: dleaf
219 real (kind=kind_phys) :: z0mvt
220 real (kind=kind_phys) :: hvt
221 real (kind=kind_phys) :: hvb
222 real (kind=kind_phys) :: z0mhvt
223 real (kind=kind_phys) :: den
224 real (kind=kind_phys) :: rc
225 real (kind=kind_phys) :: mfsno
226 real (kind=kind_phys) :: scffac
227 real (kind=kind_phys) :: cbiom
228 real (kind=kind_phys) :: saim(12)
229 real (kind=kind_phys) :: laim(12)
230 real (kind=kind_phys) :: sla
231 real (kind=kind_phys) :: prcpiceden
232 real (kind=kind_phys) :: dilefc
233 real (kind=kind_phys) :: dilefw
234 real (kind=kind_phys) :: fragr
235 real (kind=kind_phys) :: ltovrc
236
237 real (kind=kind_phys) :: c3psn
238 real (kind=kind_phys) :: kc25
239 real (kind=kind_phys) :: akc
240 real (kind=kind_phys) :: ko25
241 real (kind=kind_phys) :: ako
242 real (kind=kind_phys) :: vcmx25
243 real (kind=kind_phys) :: avcmx
244 real (kind=kind_phys) :: bp
245 real (kind=kind_phys) :: mp
246 real (kind=kind_phys) :: qe25
247 real (kind=kind_phys) :: aqe
248 real (kind=kind_phys) :: rmf25
249 real (kind=kind_phys) :: rms25
250 real (kind=kind_phys) :: rmr25
251 real (kind=kind_phys) :: arm
252 real (kind=kind_phys) :: folnmx
253 real (kind=kind_phys) :: tmin
254
255 real (kind=kind_phys) :: xl
256 real (kind=kind_phys) :: rhol(mband)
257 real (kind=kind_phys) :: rhos(mband)
258 real (kind=kind_phys) :: taul(mband)
259 real (kind=kind_phys) :: taus(mband)
260
261 real (kind=kind_phys) :: mrp
262 real (kind=kind_phys) :: cwpvt
263
264 real (kind=kind_phys) :: wrrat
265 real (kind=kind_phys) :: wdpool
266 real (kind=kind_phys) :: tdlef
267
268 integer :: nroot
269 real (kind=kind_phys) :: rgl
270 real (kind=kind_phys) :: rsmin
271 real (kind=kind_phys) :: hs
272 real (kind=kind_phys) :: topt
273 real (kind=kind_phys) :: rsmax
274
275 real (kind=kind_phys) :: slarea
276 real (kind=kind_phys) :: eps(5)
277
278!------------------------------------------------------------------------------------------!
279! from the rad section of mptable.tbl
280!------------------------------------------------------------------------------------------!
281
282 real (kind=kind_phys) :: albsat(mband)
283 real (kind=kind_phys) :: albdry(mband)
284 real (kind=kind_phys) :: albice(mband)
285 real (kind=kind_phys) :: alblak(mband)
286 real (kind=kind_phys) :: omegas(mband)
287 real (kind=kind_phys) :: betads
288 real (kind=kind_phys) :: betais
289 real (kind=kind_phys) :: eg(2)
290
291!------------------------------------------------------------------------------------------!
292! from the globals section of mptable.tbl
293!------------------------------------------------------------------------------------------!
294
295 real (kind=kind_phys) :: co2
296 real (kind=kind_phys) :: o2
297 real (kind=kind_phys) :: timean
298 real (kind=kind_phys) :: fsatmx
299 real (kind=kind_phys) :: z0sno
300 real (kind=kind_phys) :: ssi
301 real (kind=kind_phys) :: snow_ret_fac
302 real (kind=kind_phys) :: swemx
303 real (kind=kind_phys) :: snow_emis
304 real (kind=kind_phys) :: tau0
305 real (kind=kind_phys) :: grain_growth
306 real (kind=kind_phys) :: extra_growth
307 real (kind=kind_phys) :: dirt_soot
308 real (kind=kind_phys) :: bats_cosz
309 real (kind=kind_phys) :: bats_vis_new
310 real (kind=kind_phys) :: bats_nir_new
311 real (kind=kind_phys) :: bats_vis_age
312 real (kind=kind_phys) :: bats_nir_age
313 real (kind=kind_phys) :: bats_vis_dir
314 real (kind=kind_phys) :: bats_nir_dir
315 real (kind=kind_phys) :: rsurf_snow
316 real (kind=kind_phys) :: rsurf_exp
317
318!------------------------------------------------------------------------------------------!
319! from the crop section of mptable.tbl
320!------------------------------------------------------------------------------------------!
321
322 integer :: pltday
323 integer :: hsday
324 real (kind=kind_phys) :: plantpop
325 real (kind=kind_phys) :: irri
326 real (kind=kind_phys) :: gddtbase
327 real (kind=kind_phys) :: gddtcut
328 real (kind=kind_phys) :: gdds1
329 real (kind=kind_phys) :: gdds2
330 real (kind=kind_phys) :: gdds3
331 real (kind=kind_phys) :: gdds4
332 real (kind=kind_phys) :: gdds5
333 integer :: c3c4
334 real (kind=kind_phys) :: aref
335 real (kind=kind_phys) :: psnrf
336 real (kind=kind_phys) :: i2par
337 real (kind=kind_phys) :: tassim0
338 real (kind=kind_phys) :: tassim1
339 real (kind=kind_phys) :: tassim2
340 real (kind=kind_phys) :: k
341 real (kind=kind_phys) :: epsi
342 real (kind=kind_phys) :: q10mr
343 real (kind=kind_phys) :: foln_mx
344 real (kind=kind_phys) :: lefreez
345 real (kind=kind_phys) :: dile_fc(nstage)
346 real (kind=kind_phys) :: dile_fw(nstage)
347 real (kind=kind_phys) :: fra_gr
348 real (kind=kind_phys) :: lf_ovrc(nstage)
349 real (kind=kind_phys) :: st_ovrc(nstage)
350 real (kind=kind_phys) :: rt_ovrc(nstage)
351 real (kind=kind_phys) :: lfmr25
352 real (kind=kind_phys) :: stmr25
353 real (kind=kind_phys) :: rtmr25
354 real (kind=kind_phys) :: grainmr25
355 real (kind=kind_phys) :: lfpt(nstage)
356 real (kind=kind_phys) :: stpt(nstage)
357 real (kind=kind_phys) :: rtpt(nstage)
358 real (kind=kind_phys) :: grainpt(nstage)
359 real (kind=kind_phys) :: bio2lai
360
361!------------------------------------------------------------------------------------------!
362! from the soilparm.tbl tables, as functions of soil category.
363!------------------------------------------------------------------------------------------!
364 real (kind=kind_phys) :: bexp(nsoil)
365 real (kind=kind_phys) :: smcdry(nsoil)
366 !layer ends (volumetric) (not used mb: 20140718)
367 real (kind=kind_phys) :: smcwlt(nsoil)
368 real (kind=kind_phys) :: smcref(nsoil)
369 real (kind=kind_phys) :: smcmax(nsoil)
370 real (kind=kind_phys) :: psisat(nsoil)
371 real (kind=kind_phys) :: dksat(nsoil)
372 real (kind=kind_phys) :: dwsat(nsoil)
373 real (kind=kind_phys) :: quartz(nsoil)
374 real (kind=kind_phys) :: f1
375!------------------------------------------------------------------------------------------!
376! from the genparm.tbl file
377!------------------------------------------------------------------------------------------!
378 real (kind=kind_phys) :: slope
379 real (kind=kind_phys) :: csoil
380 real (kind=kind_phys) :: zbot
381 real (kind=kind_phys) :: czil
382 real (kind=kind_phys) :: refdk
383 real (kind=kind_phys) :: refkdt
384
385 real (kind=kind_phys) :: kdt
386 real (kind=kind_phys) :: frzx
387
388 end type noahmp_parameters
389
390!
391! for sfcdif4
392!
393 real(kind=kind_phys), parameter :: prt=1. !prandtl number
394 real(kind=kind_phys), parameter :: p1000mb = 100000.
395
396 real(kind=kind_phys), parameter :: svp1 = 0.6112
397 real(kind=kind_phys), parameter :: svp2 = 17.67
398 real(kind=kind_phys), parameter :: svp3 = 29.65
399 real(kind=kind_phys), parameter :: svpt0 = 273.15
400 real(kind=kind_phys), parameter :: onethird = 1./3.
401 real(kind=kind_phys), parameter :: sqrt3 = 1.7320508075688773
402 real(kind=kind_phys), parameter :: atan1 = 0.785398163397 !in radians
403
404 real(kind=kind_phys), parameter :: vconvc=1.25
405
406 real(kind=kind_phys), parameter :: snowz0 = 0.011
407 real(kind=kind_phys), parameter :: wmin = 0.1
408
409 real(kind=kind_phys), dimension(0:1000 ),save :: psim_stab,psim_unstab, &
410 psih_stab,psih_unstab
411
412
413contains
414!
415!== begin noahmp_sflx ==============================================================================
416
419 subroutine noahmp_sflx (parameters, &
420 iloc , jloc , lat , yearlen , julian , cosz , & ! in : time/space-related
421 dt , dx , dz8w , nsoil , zsoil , nsnow , & ! in : model configuration
422 shdfac , shdmax , vegtyp , ice , ist , croptype, & ! in : vegetation/soil characteristics
423 smceq , & ! in : vegetation/soil characteristics
424 sfctmp , sfcprs , psfc , uu , vv , q2, garea1 , & ! in : forcing
425 qc , soldn , lwdn,thsfc_loc, prslkix,prsik1x,prslk1x,& ! in : forcing
426 pblhx , iz0tlnd , itime ,psi_opt ,&
427 prcpconv, prcpnonc, prcpshcv, prcpsnow, prcpgrpl, prcphail, & ! in : forcing
428 tbot , co2air , o2air , foln , ficeold , zlvl , & ! in : forcing
429 ep_1 , ep_2 , epsm1 , cp , & ! in : constants
430 albold , sneqvo , & ! in/out :
431 stc , sh2o , smc , tah , eah , fwet , & ! in/out :
432 canliq , canice , tv , tg , qsfc, qsnow, qrain, & ! in/out :
433 isnow , zsnso , snowh , sneqv , snice , snliq , & ! in/out :
434 zwt , wa , wt , wslake , lfmass , rtmass , & ! in/out :
435 stmass , wood , stblcp , fastcp , lai , sai , & ! in/out :
436 cm , ch , tauss , & ! in/out :
437 grain , gdd , pgs , & ! in/out
438 smcwtd ,deeprech , rech , ustarx , & ! in/out :
439 z0wrf , z0hwrf , ts , & ! out :
440 fsa , fsr , fira , fsh , ssoil , fcev , & ! out :
441 fgev , fctr , ecan , etran , edir , trad , & ! out :
442 tgb , tgv , t2mv , t2mb , q2v , q2b , & ! out :
443 runsrf , runsub , apar , psn , sav , sag , & ! out :
444 fsno , nee , gpp , npp , fveg , albedo , & ! out :
445 qsnbot , ponding , ponding1, ponding2, rssun , rssha , & ! out :
446 albd , albi , albsnd , albsni , & ! out :
447 bgap , wgap , chv , chb , emissi , & ! out :
448 shg , shc , shb , evg , evb , ghv , & ! out :
449 ghb , irg , irc , irb , tr , evc , & ! out :
450 chleaf , chuc , chv2 , chb2 , fpice , pahv , &
451 pahg , pahb , pah , esnow , canhs , laisun , &
452 laisha , rb , qsfcveg , qsfcbare &
453#ifdef CCPP
454 ,errmsg, errflg)
455#else
456 )
457#endif
458
459! --------------------------------------------------------------------------------------------------
460! initial code: guo-yue niu, oct. 2007
461! --------------------------------------------------------------------------------------------------
462
463 implicit none
464! --------------------------------------------------------------------------------------------------
465! input
466 type (noahmp_parameters), intent(in) :: parameters
467
468 integer , intent(in) :: ice
469 integer , intent(in) :: ist
470 integer , intent(in) :: vegtyp
471 INTEGER , INTENT(IN) :: CROPTYPE
472 integer , intent(in) :: nsnow
473 integer , intent(in) :: nsoil
474 integer , intent(in) :: iloc
475 integer , intent(in) :: jloc
476 real (kind=kind_phys) , intent(in) :: ep_1
477 real (kind=kind_phys) , intent(in) :: ep_2
478 real (kind=kind_phys) , intent(in) :: epsm1
479 real (kind=kind_phys) , intent(in) :: cp
480 real (kind=kind_phys) , intent(in) :: dt
481 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil
482 real (kind=kind_phys) , intent(in) :: q2
483 real (kind=kind_phys) , intent(in) :: sfctmp
484 real (kind=kind_phys) , intent(in) :: uu
485 real (kind=kind_phys) , intent(in) :: vv
486 real (kind=kind_phys) , intent(in) :: soldn
487 real (kind=kind_phys) , intent(in) :: lwdn
488 real (kind=kind_phys) , intent(in) :: sfcprs
489
490 logical , intent(in) :: thsfc_loc
491 real (kind=kind_phys) , intent(in) :: prslkix
492 real (kind=kind_phys) , intent(in) :: prsik1x
493 real (kind=kind_phys) , intent(in) :: prslk1x
494 real (kind=kind_phys) , intent(in) :: garea1
495
496 real (kind=kind_phys) , intent(in) :: pblhx
497 integer , intent(in) :: iz0tlnd
498 integer , intent(in) :: itime
499 integer , intent(in) :: psi_opt
500
501 real (kind=kind_phys) , intent(inout) :: zlvl
502 real (kind=kind_phys) , intent(in) :: cosz
503 real (kind=kind_phys) , intent(in) :: tbot
504 real (kind=kind_phys) , intent(in) :: foln
505 real (kind=kind_phys) , intent(in) :: shdfac
506 integer , intent(in) :: yearlen
507 real (kind=kind_phys) , intent(in) :: julian
508 real (kind=kind_phys) , intent(in) :: lat
509 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: ficeold
510 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smceq
511 real (kind=kind_phys) , intent(in) :: prcpconv
512 real (kind=kind_phys) , intent(in) :: prcpnonc
513 real (kind=kind_phys) , intent(in) :: prcpshcv
514 real (kind=kind_phys) , intent(in) :: prcpsnow
515 real (kind=kind_phys) , intent(in) :: prcpgrpl
516 real (kind=kind_phys) , intent(in) :: prcphail
517
518!jref:start; in
519 real (kind=kind_phys) , intent(in) :: qc
520 real (kind=kind_phys) , intent(inout) :: qsfc
521 real (kind=kind_phys) , intent(in) :: psfc
522 real (kind=kind_phys) , intent(in) :: dz8w
523 real (kind=kind_phys) , intent(in) :: dx
524 real (kind=kind_phys) , intent(in) :: shdmax
525!jref:end
526
527
528! input/output : need arbitary intial values
529 real (kind=kind_phys) , intent(inout) :: qsnow
530 REAL (kind=kind_phys) , INTENT(INOUT) :: qrain
531 real (kind=kind_phys) , intent(inout) :: fwet
532 real (kind=kind_phys) , intent(inout) :: sneqvo
533 real (kind=kind_phys) , intent(inout) :: eah
534 real (kind=kind_phys) , intent(inout) :: tah
535 real (kind=kind_phys) , intent(inout) :: albold
536 real (kind=kind_phys) , intent(inout) :: cm
537 real (kind=kind_phys) , intent(inout) :: ch
538 real (kind=kind_phys) , intent(inout) :: tauss
539 real (kind=kind_phys) , intent(inout) :: ustarx
540
541! prognostic variables
542 integer , intent(inout) :: isnow
543 real (kind=kind_phys) , intent(inout) :: canliq
544 real (kind=kind_phys) , intent(inout) :: canice
545 real (kind=kind_phys) , intent(inout) :: sneqv
546 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: smc
547 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: zsnso
548 real (kind=kind_phys) , intent(inout) :: snowh
549 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snice
550 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snliq
551 real (kind=kind_phys) , intent(inout) :: tv
552 real (kind=kind_phys) , intent(inout) :: tg
553 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
554 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sh2o
555 real (kind=kind_phys) , intent(inout) :: zwt
556 real (kind=kind_phys) , intent(inout) :: wa
557 real (kind=kind_phys) , intent(inout) :: wt
558 real (kind=kind_phys) , intent(inout) :: wslake
559 real (kind=kind_phys), intent(inout) :: smcwtd
560 real (kind=kind_phys), intent(inout) :: deeprech
561 real (kind=kind_phys), intent(inout) :: rech
562
563! output
564 real (kind=kind_phys) , intent(out) :: z0wrf
565 real (kind=kind_phys) , intent(out) :: z0hwrf
566 real (kind=kind_phys) , intent(out) :: fsa
567 real (kind=kind_phys) , intent(out) :: fsr
568 real (kind=kind_phys) , intent(out) :: fira
569 real (kind=kind_phys) , intent(out) :: fsh
570 real (kind=kind_phys) , intent(out) :: fcev
571 real (kind=kind_phys) , intent(out) :: fgev
572 real (kind=kind_phys) , intent(out) :: fctr
573 real (kind=kind_phys) , intent(out) :: ssoil
574 real (kind=kind_phys) , intent(out) :: trad
575 real (kind=kind_phys) , intent(out) :: ts
576 real (kind=kind_phys) , intent(out) :: ecan
577 real (kind=kind_phys) , intent(out) :: etran
578 real (kind=kind_phys) , intent(out) :: edir
579 real (kind=kind_phys) , intent(out) :: runsrf
580 real (kind=kind_phys) , intent(out) :: runsub
581 real (kind=kind_phys) , intent(out) :: psn
582 real (kind=kind_phys) , intent(out) :: apar
583 real (kind=kind_phys) , intent(out) :: sav
584 real (kind=kind_phys) , intent(out) :: sag
585 real (kind=kind_phys) , intent(out) :: fsno
586 real (kind=kind_phys) , intent(out) :: fveg
587 real (kind=kind_phys) , intent(out) :: albedo
588 real (kind=kind_phys) :: errwat
589 real (kind=kind_phys) , intent(out) :: qsnbot
590 real (kind=kind_phys) , intent(out) :: ponding
591 real (kind=kind_phys) , intent(out) :: ponding1
592 real (kind=kind_phys) , intent(out) :: ponding2
593 real (kind=kind_phys) , intent(out) :: esnow
594 real (kind=kind_phys) , intent(out) :: rb
595 real (kind=kind_phys) , intent(out) :: laisun
596 real (kind=kind_phys) , intent(out) :: laisha
597 real (kind=kind_phys) , intent(out) :: qsfcveg
598 real (kind=kind_phys) , intent(out) :: qsfcbare
599
600!jref:start; output
601 real (kind=kind_phys) , intent(out) :: t2mv
602 real (kind=kind_phys) , intent(out) :: t2mb
603 real (kind=kind_phys), intent(out) :: rssun
604 real (kind=kind_phys), intent(out) :: rssha
605 real (kind=kind_phys), intent(out) :: bgap
606 real (kind=kind_phys), intent(out) :: wgap
607 real (kind=kind_phys), dimension(1:2) , intent(out) :: albd
608 real (kind=kind_phys), dimension(1:2) , intent(out) :: albi
609 real (kind=kind_phys), dimension(1:2) , intent(out) :: albsnd
610 real (kind=kind_phys), dimension(1:2) , intent(out) :: albsni
611 real (kind=kind_phys), intent(out) :: tgv
612 real (kind=kind_phys), intent(out) :: tgb
613 real (kind=kind_phys) :: q1
614 real (kind=kind_phys), intent(out) :: emissi
615!jref:end
616#ifdef CCPP
617 character(len=*), intent(inout) :: errmsg
618 integer, intent(inout) :: errflg
619#endif
620
621! local
622 integer :: iz
623 integer, dimension(-nsnow+1:nsoil) :: imelt
624 real (kind=kind_phys) :: cmc
625 real (kind=kind_phys) :: taux
626 real (kind=kind_phys) :: tauy
627 real (kind=kind_phys) :: rhoair
628! real (kind=kind_phys), dimension( 1: 5) :: vocflx !< voc fluxes [ug c m-2 h-1]
629 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: dzsnso
630 real (kind=kind_phys) :: thair
631 real (kind=kind_phys) :: qair
632 real (kind=kind_phys) :: eair
633 real (kind=kind_phys), dimension( 1: 2) :: solad
634 real (kind=kind_phys), dimension( 1: 2) :: solai
635 real (kind=kind_phys) :: qprecc
636 real (kind=kind_phys) :: qprecl
637 real (kind=kind_phys) :: igs
638 real (kind=kind_phys) :: elai
639 real (kind=kind_phys) :: esai
640 real (kind=kind_phys) :: bevap
641 real (kind=kind_phys), dimension( 1:nsoil) :: btrani
642 real (kind=kind_phys) :: btran
643 real (kind=kind_phys) :: qin
644 real (kind=kind_phys) :: qdis
645 real (kind=kind_phys), dimension( 1:nsoil) :: sice
646 real (kind=kind_phys), dimension(-nsnow+1: 0) :: snicev
647 real (kind=kind_phys), dimension(-nsnow+1: 0) :: snliqv
648 real (kind=kind_phys), dimension(-nsnow+1: 0) :: epore
649 real (kind=kind_phys) :: totsc
650 real (kind=kind_phys) :: totlb
651 real (kind=kind_phys) :: t2m
652 real (kind=kind_phys) :: qdew
653 real (kind=kind_phys) :: qvap
654 real (kind=kind_phys) :: lathea
655 real (kind=kind_phys) :: swdown
656 real (kind=kind_phys) :: qmelt
657 real (kind=kind_phys) :: beg_wb
658 real (kind=kind_phys),intent(out) :: irc
659 real (kind=kind_phys),intent(out) :: irg
660 real (kind=kind_phys),intent(out) :: shc
661 real (kind=kind_phys),intent(out) :: shg
662 real (kind=kind_phys),intent(out) :: evg
663 real (kind=kind_phys),intent(out) :: ghv
664 real (kind=kind_phys),intent(out) :: irb
665 real (kind=kind_phys),intent(out) :: shb
666 real (kind=kind_phys),intent(out) :: evb
667 real (kind=kind_phys),intent(out) :: ghb
668 real (kind=kind_phys),intent(out) :: evc
669 real (kind=kind_phys),intent(out) :: tr
670 real (kind=kind_phys), intent(out) :: fpice
671 real (kind=kind_phys), intent(out) :: pahv
672 real (kind=kind_phys), intent(out) :: pahg
673 real (kind=kind_phys), intent(out) :: pahb
674 real (kind=kind_phys), intent(out) :: pah
675
676!jref:start
677 real (kind=kind_phys) :: fsrv
678 real (kind=kind_phys) :: fsrg
679 real (kind=kind_phys),intent(out) :: q2v
680 real (kind=kind_phys),intent(out) :: q2b
681 real (kind=kind_phys) :: q2e
682 real (kind=kind_phys) :: qfx
683 real (kind=kind_phys),intent(out) :: chv
684 real (kind=kind_phys),intent(out) :: chb
685 real (kind=kind_phys),intent(out) :: chleaf
686 real (kind=kind_phys),intent(out) :: chuc
687 real (kind=kind_phys),intent(out) :: chv2
688 real (kind=kind_phys),intent(out) :: chb2
689!jref:end
690
691! carbon
692! inputs
693 real (kind=kind_phys) , intent(in) :: co2air
694 real (kind=kind_phys) , intent(in) :: o2air
695
696! inputs and outputs : prognostic variables
697 real (kind=kind_phys) , intent(inout) :: lfmass
698 real (kind=kind_phys) , intent(inout) :: rtmass
699 real (kind=kind_phys) , intent(inout) :: stmass
700 real (kind=kind_phys) , intent(inout) :: wood
701 real (kind=kind_phys) , intent(inout) :: stblcp
702 real (kind=kind_phys) , intent(inout) :: fastcp
703 real (kind=kind_phys) , intent(inout) :: lai
704 real (kind=kind_phys) , intent(inout) :: sai
705 real (kind=kind_phys) , intent(inout) :: grain
706 real (kind=kind_phys) , intent(inout) :: gdd
707 integer , intent(inout) :: pgs
708
709! outputs
710 real (kind=kind_phys) , intent(out) :: nee
711 real (kind=kind_phys) , intent(out) :: gpp
712 real (kind=kind_phys) , intent(out) :: npp
713 real (kind=kind_phys) :: autors
714 real (kind=kind_phys) :: heters
715 real (kind=kind_phys) :: troot
716 real (kind=kind_phys) :: bdfall
717 real (kind=kind_phys) :: rain
718 real (kind=kind_phys) :: snow
719 real (kind=kind_phys) :: fp ! mb/an: v3.7
720 real (kind=kind_phys) :: prcp ! mb/an: v3.7
721!more local variables for precip heat mb
722 real (kind=kind_phys) :: qintr
723 real (kind=kind_phys) :: qdripr
724 real (kind=kind_phys) :: qthror
725 real (kind=kind_phys) :: qints
726 real (kind=kind_phys) :: qdrips
727 real (kind=kind_phys) :: qthros
728 real (kind=kind_phys) :: snowhin
729 real (kind=kind_phys) :: latheav
730 real (kind=kind_phys) :: latheag
731 logical :: frozen_ground
732 logical :: frozen_canopy
733 logical :: dveg_active
734 logical :: crop_active
735! add canopy heat storage (C.He added based on GY Niu's communication)
736 real (kind=kind_phys) , intent(out) :: canhs ! canopy heat storage change w/m2
737
738 ! intent (out) variables need to be assigned a value. these normally get assigned values
739 ! only if dveg == 2.
740 nee = 0.0
741 npp = 0.0
742 gpp = 0.0
743 pahv = 0.
744 pahg = 0.
745 pahb = 0.
746 pah = 0.
747 canhs = 0.
748
749! --------------------------------------------------------------------------------------------------
750! re-process atmospheric forcing
751
752 call atm (parameters,ep_2, epsm1, sfcprs ,sfctmp ,q2 , &
753 prcpconv, prcpnonc,prcpshcv,prcpsnow,prcpgrpl,prcphail, &
754 soldn ,cosz ,thair ,qair , &
755 eair ,rhoair ,qprecc ,qprecl ,solad ,solai , &
756 swdown ,bdfall ,rain ,snow ,fp ,fpice , prcp )
757
758! snow/soil layer thickness (m)
759
760 do iz = isnow+1, nsoil
761 if(iz == isnow+1) then
762 dzsnso(iz) = - zsnso(iz)
763 else
764 dzsnso(iz) = zsnso(iz-1) - zsnso(iz)
765 end if
766 end do
767
768! root-zone temperature
769
770 troot = 0.
771 do iz=1,parameters%nroot
772 troot = troot + stc(iz)*dzsnso(iz)/(-zsoil(parameters%nroot))
773 enddo
774
775! total water storage for water balance check
776
777 if(ist == 1) then
778 beg_wb = canliq + canice + sneqv + wa
779 do iz = 1,nsoil
780 beg_wb = beg_wb + smc(iz) * dzsnso(iz) * 1000.
781 end do
782 end if
783
784! vegetation phenology
785
786 call phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in
787 lai , sai , troot , elai , esai ,igs, pgs)
788
789!input gvf should be consistent with lai
790 if(dveg == 1 .or. dveg == 6 .or. dveg == 7) then
791 fveg = shdfac
792 if(fveg <= 0.05) fveg = 0.05
793 else if (dveg == 2 .or. dveg == 3 .or. dveg == 8) then
794 fveg = 1.-exp(-0.52*(lai+sai))
795 if(fveg <= 0.05) fveg = 0.05
796 else if (dveg == 4 .or. dveg == 5 .or. dveg == 9) then
797 fveg = shdmax
798 if(fveg <= 0.05) fveg = 0.05
799 else
800 write(*,*) "-------- fatal called in sflx -----------"
801#ifdef CCPP
802 errflg = 1
803 errmsg = "namelist parameter dveg unknown"
804 return
805#else
806 call wrf_error_fatal("namelist parameter dveg unknown")
807#endif
808 endif
809 if(opt_crop > 0 .and. croptype > 0) then
810 fveg = shdmax
811 if(fveg <= 0.05) fveg = 0.05
812 endif
813 if(parameters%urban_flag .or. vegtyp == parameters%isbarren) fveg = 0.0
814 if(elai+esai == 0.0) fveg = 0.0
815
816 call precip_heat(parameters,iloc ,jloc ,vegtyp ,dt ,uu ,vv , & !in
817 elai ,esai ,fveg ,ist , & !in
818 bdfall ,rain ,snow ,fp , & !in
819 canliq ,canice ,tv ,sfctmp ,tg , & !in
820 qintr ,qdripr ,qthror ,qints ,qdrips ,qthros , & !out
821 pahv ,pahg ,pahb ,qrain ,qsnow ,snowhin, & !out
822 fwet ,cmc ) !out
823
824! compute energy budget (momentum & energy fluxes and phase changes)
825
826 call energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in
827 isnow ,dt ,rhoair ,sfcprs ,qair , & !in
828 sfctmp ,thair ,lwdn ,uu ,vv ,zlvl , & !in
829 co2air ,o2air ,solad ,solai ,cosz ,igs , & !in
830 eair ,tbot ,zsnso ,zsoil , & !in
831 elai ,esai ,fwet ,foln , & !in
832 fveg ,shdfac, pahv ,pahg ,pahb , & !in
833 qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in
834 thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in
835 pblhx ,iz0tlnd, itime ,psi_opt, ep_1, ep_2, epsm1,cp, &
836 z0wrf ,z0hwrf , & !out
837 imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out
838 sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out
839 tauy ,fira ,fsh ,fcev ,fgev ,fctr , & !out
840 trad ,psn ,apar ,ssoil ,btrani ,btran , & !out
841 ponding,ts ,latheav , latheag , frozen_canopy,frozen_ground, & !out
842 tv ,tg ,stc ,snowh ,eah ,tah , & !inout
843 sneqvo ,sneqv ,sh2o ,smc ,snice ,snliq , & !inout
844 albold ,cm ,ch ,dx ,dz8w ,q2 , & !inout
845 ustarx , & !inout
846#ifdef CCPP
847 tauss ,laisun ,laisha ,rb , errmsg ,errflg , & !inout
848#else
849 tauss ,laisun ,laisha ,rb , & !inout
850#endif
851!jref:start
852 qc ,qsfc ,psfc , & !in
853 t2mv ,t2mb ,fsrv , &
854 fsrg ,rssun ,rssha ,albd ,albi ,albsnd,albsni, bgap ,wgap, tgv,tgb,&
855 q1 ,q2v ,q2b ,q2e ,chv ,chb , & !out
856 emissi ,pah ,canhs, &
857 shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out
858
859 qsfcveg = eah*ep_2/(sfcprs + epsm1*eah)
860 qsfcbare = qsfc
861 qsfc = q1
862!jref:end
863#ifdef CCPP
864 if (errflg /= 0) return
865#endif
866 sice(:) = max(0.0, smc(:) - sh2o(:))
867 sneqvo = sneqv
868
869 qvap = max( fgev/latheag, 0.) ! positive part of fgev; barlage change to ground v3.6
870 qdew = abs( min(fgev/latheag, 0.)) ! negative part of fgev
871 edir = qvap - qdew
872
873! compute water budgets (water storages, et components, and runoff)
874
875 call water (parameters,vegtyp ,nsnow ,nsoil ,imelt ,dt ,uu , & !in
876 vv ,fcev ,fctr ,qprecc ,qprecl ,elai , & !in
877 esai ,sfctmp ,qvap ,qdew ,zsoil ,btrani , & !in
878 ficeold,ponding,tg ,ist ,fveg ,iloc,jloc , smceq , & !in
879 bdfall ,fp ,rain ,snow , & !in mb/an: v3.7
880 qsnow ,qrain ,snowhin,latheav,latheag,frozen_canopy,frozen_ground, & !in mb
881 isnow ,canliq ,canice ,tv ,snowh ,sneqv , & !inout
882 snice ,snliq ,stc ,zsnso ,sh2o ,smc , & !inout
883 sice ,zwt ,wa ,wt ,dzsnso ,wslake , & !inout
884 smcwtd ,deeprech,rech , & !inout
885 cmc ,ecan ,etran ,fwet ,runsrf ,runsub , & !out
886 qin ,qdis ,ponding1 ,ponding2,&
887 qsnbot ,esnow ) !out
888
889! write(*,'(a20,10f15.5)') 'sflx:runoff=',runsrf*dt,runsub*dt,edir*dt
890
891! compute carbon budgets (carbon storages and co2 & bvoc fluxes)
892
893 crop_active = .false.
894 dveg_active = .false.
895 if (dveg == 2 .or. dveg == 5 .or. dveg == 6) dveg_active = .true.
896 if (opt_crop > 0 .and. croptype > 0) then
897 crop_active = .true.
898 dveg_active = .false.
899 endif
900
901 IF (dveg_active) THEN
902 call carbon (parameters,nsnow ,nsoil ,vegtyp ,dt ,zsoil , & !in
903 dzsnso ,stc ,smc ,tv ,tg ,psn , & !in
904 foln ,btran ,apar ,fveg ,igs , & !in
905 troot ,ist ,lat ,iloc ,jloc , & !in
906 lfmass ,rtmass ,stmass ,wood ,stblcp ,fastcp , & !inout
907 gpp ,npp ,nee ,autors ,heters ,totsc , & !out
908 totlb ,lai ,sai ) !out
909 end if
910
911 if (opt_crop == 1 .and. crop_active) then
912 call carbon_crop (parameters,nsnow ,nsoil ,vegtyp ,dt ,zsoil ,julian , & !in
913 dzsnso ,stc ,smc ,tv ,psn ,foln ,btran , & !in
914 soldn ,t2m , & !in
915 lfmass ,rtmass ,stmass ,wood ,stblcp ,fastcp ,grain , & !inout
916 lai ,sai ,gdd , & !inout
917 gpp ,npp ,nee ,autors ,heters ,totsc ,totlb, pgs ) !out
918 end if
919
920! water and energy balance check
921
922 call error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & !in
923 fgev ,fctr ,ssoil ,beg_wb ,canliq ,canice , & !in
924 sneqv ,wa ,smc ,dzsnso ,prcp ,ecan , & !in
925 etran ,edir ,runsrf ,runsub ,dt ,nsoil , & !in
926 nsnow ,ist ,errwat ,iloc , jloc ,fveg , &
927 sav ,sag ,fsrv ,fsrg ,zwt ,pah , &
928#ifdef CCPP
929 pahv ,pahg ,pahb ,canhs,errmsg, errflg) !in ( except errwat [out] and errmsg, errflg [inout] )
930#else
931 pahv ,pahg ,pahb, canhs ) !in ( except errwat, which is out )
932#endif
933
934#ifdef CCPP
935 if (errflg /= 0) return
936#endif
937
938! urban - jref
939 qfx = etran + ecan + edir
940 if ( parameters%urban_flag ) then
941 qsfc = qfx/(rhoair*ch) + qair
942 q2b = qsfc
943 end if
944
945 if(snowh <= 1.e-6 .or. sneqv <= 1.e-3) then
946 snowh = 0.0
947 sneqv = 0.0
948 end if
949
950 if(swdown.ne.0.) then
951 albedo = fsr / swdown
952 else
953 albedo = -999.9
954 end if
955
956
957 end subroutine noahmp_sflx
958
959!== begin atm ======================================================================================
960
963 subroutine atm (parameters,ep_2,epsm1,sfcprs ,sfctmp ,q2 , &
964 prcpconv,prcpnonc ,prcpshcv,prcpsnow,prcpgrpl,prcphail , &
965 soldn ,cosz ,thair ,qair , &
966 eair ,rhoair ,qprecc ,qprecl ,solad , solai , &
967 swdown ,bdfall ,rain ,snow ,fp , fpice ,prcp )
968! --------------------------------------------------------------------------------------------------
969! re-process atmospheric forcing
970! ----------------------------------------------------------------------
971 implicit none
972! --------------------------------------------------------------------------------------------------
973! inputs
974
975 type (noahmp_parameters), intent(in) :: parameters
976 real (kind=kind_phys) , intent(in) :: ep_2
977 real (kind=kind_phys) , intent(in) :: epsm1
978 real (kind=kind_phys) , intent(in) :: sfcprs
979 real (kind=kind_phys) , intent(in) :: sfctmp
980 real (kind=kind_phys) , intent(in) :: q2
981 real (kind=kind_phys) , intent(in) :: prcpconv
982 real (kind=kind_phys) , intent(in) :: prcpnonc
983 real (kind=kind_phys) , intent(in) :: prcpshcv
984 real (kind=kind_phys) , intent(in) :: prcpsnow
985 real (kind=kind_phys) , intent(in) :: prcpgrpl
986 real (kind=kind_phys) , intent(in) :: prcphail
987 real (kind=kind_phys) , intent(in) :: soldn
988 real (kind=kind_phys) , intent(in) :: cosz
989
990! outputs
991
992 real (kind=kind_phys) , intent(out) :: thair
993 real (kind=kind_phys) , intent(out) :: qair
994 real (kind=kind_phys) , intent(out) :: eair
995 real (kind=kind_phys) , intent(out) :: rhoair
996 real (kind=kind_phys) , intent(out) :: qprecc
997 real (kind=kind_phys) , intent(out) :: qprecl
998 real (kind=kind_phys), dimension( 1: 2), intent(out) :: solad
999 real (kind=kind_phys), dimension( 1: 2), intent(out) :: solai
1000 real (kind=kind_phys) , intent(out) :: swdown
1001 real (kind=kind_phys) , intent(out) :: bdfall
1002 real (kind=kind_phys) , intent(out) :: rain
1003 real (kind=kind_phys) , intent(out) :: snow
1004 real (kind=kind_phys) , intent(out) :: fp
1005 real (kind=kind_phys) , intent(out) :: fpice
1006 real (kind=kind_phys) , intent(out) :: prcp
1007
1008!locals
1009
1010 real (kind=kind_phys) :: pair !atm bottom level pressure (pa)
1011 real (kind=kind_phys) :: prcp_frozen !total frozen precipitation [mm/s] ! mb/an : v3.7
1012 real (kind=kind_phys), parameter :: rho_grpl = 500.0 ! graupel bulk density [kg/m3] ! mb/an : v3.7
1013 real (kind=kind_phys), parameter :: rho_hail = 917.0 ! hail bulk density [kg/m3] ! mb/an : v3.7
1014! --------------------------------------------------------------------------------------------------
1015
1016!jref: seems like pair should be p1000mb??
1017 pair = sfcprs ! atm bottom level pressure (pa)
1018 thair = sfctmp * (sfcprs/pair)**(rair/cpair)
1019
1020 qair = q2 ! in wrf, driver converts to specific humidity
1021
1022 eair = qair*sfcprs / (ep_2-epsm1*qair)
1023 rhoair = (sfcprs+epsm1*eair) / (rair*sfctmp)
1024
1025 if(cosz <= 0.) then
1026 swdown = 0.
1027 else
1028 swdown = soldn
1029 end if
1030
1031 solad(1) = swdown*0.7*0.5 ! direct vis
1032 solad(2) = swdown*0.7*0.5 ! direct nir
1033 solai(1) = swdown*0.3*0.5 ! diffuse vis
1034 solai(2) = swdown*0.3*0.5 ! diffuse nir
1035
1036 prcp = prcpconv + prcpnonc + prcpshcv
1037
1038 if(opt_snf == 4) then
1039 qprecc = prcpconv + prcpshcv
1040 qprecl = prcpnonc
1041 else
1042 qprecc = 0.10 * prcp ! should be from the atmospheric model
1043 qprecl = 0.90 * prcp ! should be from the atmospheric model
1044 end if
1045
1046! fractional area that receives precipitation (see, niu et al. 2005)
1047
1048 fp = 0.0
1049 if(qprecc + qprecl > 0.) &
1050 fp = (qprecc + qprecl) / (10.*qprecc + qprecl)
1051
1052! partition precipitation into rain and snow. moved from canwat mb/an: v3.7
1053
1054! jordan (1991)
1055
1056 if(opt_snf == 1) then
1057 if(sfctmp > tfrz+2.5)then
1058 fpice = 0.
1059 else
1060 if(sfctmp <= tfrz+0.5)then
1061 fpice = 1.0
1062 else if(sfctmp <= tfrz+2.)then
1063 fpice = 1.-(-54.632 + 0.2*sfctmp)
1064 else
1065 fpice = 0.6
1066 endif
1067 endif
1068 endif
1069
1070 if(opt_snf == 2) then
1071 if(sfctmp >= tfrz+2.2) then
1072 fpice = 0.
1073 else
1074 fpice = 1.0
1075 endif
1076 endif
1077
1078 if(opt_snf == 3) then
1079 if(sfctmp >= tfrz) then
1080 fpice = 0.
1081 else
1082 fpice = 1.0
1083 endif
1084 endif
1085
1086! hedstrom nr and jw pomeroy (1998), hydrol. processes, 12, 1611-1625
1087! fresh snow density
1088
1089 bdfall = min(120.,67.92+51.25*exp((sfctmp-tfrz)/2.59)) !mb/an: change to min
1090 if(opt_snf == 4 .or. opt_snf == 5) then
1091 prcp_frozen = prcpsnow + prcpgrpl + prcphail
1092 if(prcpnonc > 0. .and. prcp_frozen > 0.) then
1093 fpice = min(1.0,prcp_frozen/prcpnonc)
1094 fpice = max(0.0,fpice)
1095 if(opt_snf==4) bdfall = bdfall*(prcpsnow/prcp_frozen) + rho_grpl*(prcpgrpl/prcp_frozen) + &
1096 rho_hail*(prcphail/prcp_frozen)
1097 if(opt_snf==5) bdfall = parameters%prcpiceden
1098 else
1099 fpice = 0.0
1100 endif
1101
1102 endif
1103
1104 rain = prcp * (1.-fpice)
1105 snow = prcp * fpice
1106
1107
1108 end subroutine atm
1109
1110!== begin phenology ================================================================================
1111
1115 subroutine phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in
1116 lai , sai , troot , elai , esai , igs, pgs)
1117
1118! --------------------------------------------------------------------------------------------------
1119! vegetation phenology considering vegeation canopy being buries by snow and evolution in time
1120! --------------------------------------------------------------------------------------------------
1121 implicit none
1122! --------------------------------------------------------------------------------------------------
1123! inputs
1124 type (noahmp_parameters), intent(in) :: parameters
1125 integer , intent(in ) :: vegtyp
1126 integer , intent(in ) :: croptype
1127 real (kind=kind_phys) , intent(in ) :: snowh
1128 real (kind=kind_phys) , intent(in ) :: tv
1129 real (kind=kind_phys) , intent(in ) :: lat
1130 integer , intent(in ) :: yearlen
1131 real (kind=kind_phys) , intent(in ) :: julian
1132 real (kind=kind_phys) , intent(in ) :: troot
1133 real (kind=kind_phys) , intent(inout) :: lai
1134 real (kind=kind_phys) , intent(inout) :: sai
1135
1136! outputs
1137 real (kind=kind_phys) , intent(out ) :: elai
1138 real (kind=kind_phys) , intent(out ) :: esai
1139 real (kind=kind_phys) , intent(out ) :: igs
1140 integer , intent(in ) :: pgs
1141
1142! locals
1143
1144 real (kind=kind_phys) :: db !thickness of canopy buried by snow (m)
1145 real (kind=kind_phys) :: fb !fraction of canopy buried by snow
1146 real (kind=kind_phys) :: snowhc !critical snow depth at which short vege
1147 !is fully covered by snow
1148
1149 integer :: k !index
1150 integer :: it1,it2 !interpolation months
1151 real (kind=kind_phys) :: day !current day of year ( 0 <= day < yearlen )
1152 real (kind=kind_phys) :: wt1,wt2 !interpolation weights
1153 real (kind=kind_phys) :: t !current month (1.00, ..., 12.00)
1154! --------------------------------------------------------------------------------------------------
1155
1156if (croptype == 0) then
1157
1158 if ( dveg == 1 .or. dveg == 3 .or. dveg == 4 ) then
1159
1160 if (lat >= 0.) then
1161 ! northern hemisphere
1162 day = julian
1163 else
1164 ! southern hemisphere. day is shifted by 1/2 year.
1165 day = mod( julian + ( 0.5 * yearlen ) , real(yearlen) )
1166 endif
1167
1168 t = 12. * day / real(yearlen)
1169 it1 = t + 0.5
1170 it2 = it1 + 1
1171 wt1 = (it1+0.5) - t
1172 wt2 = 1.-wt1
1173 if (it1 .lt. 1) it1 = 12
1174 if (it2 .gt. 12) it2 = 1
1175
1176 lai = wt1*parameters%laim(it1) + wt2*parameters%laim(it2)
1177 sai = wt1*parameters%saim(it1) + wt2*parameters%saim(it2)
1178 endif
1179
1180 if(dveg == 7 .or. dveg == 8 .or. dveg == 9) then
1181 sai = max(0.05,0.1 * lai) ! when reading lai, set sai to 10% lai, but not below 0.05 mb: v3.8
1182 if (lai < 0.05) sai = 0.0 ! if lai below minimum, make sure sai = 0
1183 endif
1184
1185 if (sai < 0.05) sai = 0.0 ! mb: sai check, change to 0.05 v3.6
1186 if (lai < 0.05 .or. sai == 0.0) lai = 0.0 ! mb: lai check
1187
1188 if ( ( vegtyp == parameters%iswater ) .or. ( vegtyp == parameters%isbarren ) .or. &
1189 ( vegtyp == parameters%isice ) .or. ( parameters%urban_flag ) ) then
1190 lai = 0.
1191 sai = 0.
1192 endif
1193
1194endif ! croptype == 0
1195
1196!buried by snow
1197
1198 db = min( max(snowh - parameters%hvb,0.), parameters%hvt-parameters%hvb )
1199 fb = db / max(1.e-06,parameters%hvt-parameters%hvb)
1200
1201 if(parameters%hvt> 0. .and. parameters%hvt <= 1.0) then !mb: change to 1.0 and 0.2 to reflect
1202 snowhc = parameters%hvt*exp(-snowh/0.2) ! changes to hvt in mptable
1203! fb = min(snowh,snowhc)/snowhc
1204 if (snowh < snowhc) then
1205 fb = snowh/snowhc
1206 else
1207 fb = 1.0
1208 endif
1209 endif
1210
1211 elai = lai*(1.-fb)
1212 esai = sai*(1.-fb)
1213 if (esai < 0.05 .and. croptype == 0) esai = 0.0 ! mb: esai check, change to 0.05 v3.6
1214 if ((elai < 0.05 .or. esai == 0.0) .and. croptype == 0) elai = 0.0 ! mb: lai check
1215
1216! set growing season flag
1217
1218 if ((tv .gt. parameters%tmin .and. croptype == 0).or.(pgs > 2 .and. pgs < 7 .and. croptype > 0)) then
1219 igs = 1.
1220 else
1221 igs = 0.
1222 endif
1223
1224 end subroutine phenology
1225
1226!== begin precip_heat ==============================================================================
1227
1231 subroutine precip_heat (parameters,iloc ,jloc ,vegtyp ,dt ,uu ,vv , & !in
1232 elai ,esai ,fveg ,ist , & !in
1233 bdfall ,rain ,snow ,fp , & !in
1234 canliq ,canice ,tv ,sfctmp ,tg , & !in
1235 qintr ,qdripr ,qthror ,qints ,qdrips ,qthros , & !out
1236 pahv ,pahg ,pahb ,qrain ,qsnow ,snowhin, & !out
1237 fwet ,cmc ) !out
1238
1239! ------------------------ code history ------------------------------
1240! michael barlage: oct 2013 - split canwater to calculate precip movement for
1241! tracking of advected heat
1242! --------------------------------------------------------------------------------------------------
1243 implicit none
1244! ------------------------ input/output variables --------------------
1245! input
1246 type (noahmp_parameters), intent(in) :: parameters
1247 integer,intent(in) :: iloc
1248 integer,intent(in) :: jloc
1249 integer,intent(in) :: vegtyp
1250 integer,intent(in) :: ist
1251 real (kind=kind_phys), intent(in) :: dt
1252 real (kind=kind_phys), intent(in) :: uu
1253 real (kind=kind_phys), intent(in) :: vv
1254 real (kind=kind_phys), intent(in) :: elai
1255 real (kind=kind_phys), intent(in) :: esai
1256 real (kind=kind_phys), intent(in) :: fveg
1257 real (kind=kind_phys), intent(in) :: bdfall
1258 real (kind=kind_phys), intent(in) :: rain
1259 real (kind=kind_phys), intent(in) :: snow
1260 real (kind=kind_phys), intent(in) :: fp
1261 real (kind=kind_phys), intent(in) :: tv
1262 real (kind=kind_phys), intent(in) :: sfctmp
1263 real (kind=kind_phys), intent(in) :: tg
1264
1265! input & output
1266 real (kind=kind_phys), intent(inout) :: canliq
1267 real (kind=kind_phys), intent(inout) :: canice
1268
1269! output
1270 real (kind=kind_phys), intent(out) :: qintr
1271 real (kind=kind_phys), intent(out) :: qdripr
1272 real (kind=kind_phys), intent(out) :: qthror
1273 real (kind=kind_phys), intent(out) :: qints
1274 real (kind=kind_phys), intent(out) :: qdrips
1275 real (kind=kind_phys), intent(out) :: qthros
1276 real (kind=kind_phys), intent(out) :: pahv
1277 real (kind=kind_phys), intent(out) :: pahg
1278 real (kind=kind_phys), intent(out) :: pahb
1279 real (kind=kind_phys), intent(out) :: qrain
1280 real (kind=kind_phys), intent(out) :: qsnow
1281 real (kind=kind_phys), intent(out) :: snowhin
1282 real (kind=kind_phys), intent(out) :: fwet
1283 real (kind=kind_phys), intent(out) :: cmc
1284! --------------------------------------------------------------------
1285
1286! ------------------------ local variables ---------------------------
1287 real (kind=kind_phys) :: maxsno !canopy capacity for snow interception (mm)
1288 real (kind=kind_phys) :: maxliq !canopy capacity for rain interception (mm)
1289 real (kind=kind_phys) :: ft !temperature factor for unloading rate
1290 real (kind=kind_phys) :: fv !wind factor for unloading rate
1291 real (kind=kind_phys) :: pah_ac !precipitation advected heat - air to canopy (w/m2)
1292 real (kind=kind_phys) :: pah_cg !precipitation advected heat - canopy to ground (w/m2)
1293 real (kind=kind_phys) :: pah_ag !precipitation advected heat - air to ground (w/m2)
1294 real (kind=kind_phys) :: icedrip !canice unloading
1295! --------------------------------------------------------------------
1296! initialization
1297
1298 qintr = 0.
1299 qdripr = 0.
1300 qthror = 0.
1301 qintr = 0.
1302 qints = 0.
1303 qdrips = 0.
1304 qthros = 0.
1305 pah_ac = 0.
1306 pah_cg = 0.
1307 pah_ag = 0.
1308 pahv = 0.
1309 pahg = 0.
1310 pahb = 0.
1311 qrain = 0.0
1312 qsnow = 0.0
1313 snowhin = 0.0
1314 icedrip = 0.0
1315! print*, "precip_heat begin canopy balance:",canliq+canice+(rain+snow)*dt
1316! print*, "precip_heat snow*3600.0:",snow*3600.0
1317! print*, "precip_heat rain*3600.0:",rain*3600.0
1318! print*, "precip_heat canice:",canice
1319! print*, "precip_heat canliq:",canliq
1320
1321! --------------------------- liquid water ------------------------------
1322! maximum canopy water
1323
1324 maxliq = parameters%ch2op * (elai+ esai)
1325
1326! average interception and throughfall
1327
1328 if((elai+ esai).gt.0.) then
1329 qintr = fveg * rain * fp ! interception capability
1330 qintr = min(qintr, (maxliq - canliq)/dt * (1.-exp(-rain*dt/maxliq)) )
1331 qintr = max(qintr, 0.)
1332 qdripr = fveg * rain - qintr
1333 qthror = (1.-fveg) * rain
1334 canliq=max(0.,canliq+qintr*dt)
1335 else
1336 qintr = 0.
1337 qdripr = 0.
1338 qthror = rain
1339 if(canliq > 0.) then ! for case of canopy getting buried
1340 qdripr = qdripr + canliq/dt
1341 canliq = 0.0
1342 end if
1343 end if
1344
1345! heat transported by liquid water
1346
1347 pah_ac = fveg * rain * (cwat/1000.0) * (sfctmp - tv)
1348 pah_cg = qdripr * (cwat/1000.0) * (tv - tg)
1349 pah_ag = qthror * (cwat/1000.0) * (sfctmp - tg)
1350! print*, "precip_heat pah_ac:",pah_ac
1351! print*, "precip_heat pah_cg:",pah_cg
1352! print*, "precip_heat pah_ag:",pah_ag
1353
1354! --------------------------- canopy ice ------------------------------
1355! for canopy ice
1356
1357 maxsno = 6.6*(0.27+46./bdfall) * (elai+ esai)
1358
1359 if((elai+ esai).gt.0.) then
1360 qints = fveg * snow * fp
1361 qints = min(qints, (maxsno - canice)/dt * (1.-exp(-snow*dt/maxsno)) )
1362 qints = max(qints, 0.)
1363 ft = max(0.0,(tv - 270.15) / 1.87e5)
1364 fv = sqrt(uu*uu + vv*vv) / 1.56e5
1365 ! mb: changed below to reflect the rain assumption that all precip gets intercepted
1366 icedrip = max(0.,canice) * (fv+ft) !mb: removed /dt
1367 qdrips = (fveg * snow - qints) + icedrip
1368 qthros = (1.0-fveg) * snow
1369 canice= max(0.,canice + (qints - icedrip)*dt)
1370 else
1371 qints = 0.
1372 qdrips = 0.
1373 qthros = snow
1374 if(canice > 0.) then ! for case of canopy getting buried
1375 qdrips = qdrips + canice/dt
1376 canice = 0.0
1377 end if
1378 endif
1379! print*, "precip_heat canopy through:",3600.0*(fveg * snow - qints)
1380! print*, "precip_heat canopy drip:",3600.0*max(0.,canice) * (fv+ft)
1381
1382! wetted fraction of canopy
1383
1384 if(canice.gt.0.) then
1385 fwet = max(0.,canice) / max(maxsno,1.e-06)
1386 else
1387 fwet = max(0.,canliq) / max(maxliq,1.e-06)
1388 endif
1389 fwet = min(fwet, 1.) ** 0.667
1390
1391! total canopy water
1392
1393 cmc = canliq + canice
1394
1395! heat transported by snow/ice
1396
1397 pah_ac = pah_ac + fveg * snow * (cice/1000.0) * (sfctmp - tv)
1398 pah_cg = pah_cg + qdrips * (cice/1000.0) * (tv - tg)
1399 pah_ag = pah_ag + qthros * (cice/1000.0) * (sfctmp - tg)
1400
1401 pahv = pah_ac - pah_cg
1402 pahg = pah_cg
1403 pahb = pah_ag
1404
1405 if (fveg > 0.0 .and. fveg < 1.0) then
1406 pahg = pahg / fveg ! these will be multiplied by fraction later
1407 pahb = pahb / (1.0-fveg)
1408 elseif (fveg <= 0.0) then
1409 pahb = pahg + pahb ! for case of canopy getting buried
1410 pahg = 0.0
1411 pahv = 0.0
1412 elseif (fveg >= 1.0) then
1413 pahb = 0.0
1414 end if
1415
1416 pahv = max(pahv,-20.0) ! put some artificial limits here for stability
1417 pahv = min(pahv,20.0)
1418 pahg = max(pahg,-20.0)
1419 pahg = min(pahg,20.0)
1420 pahb = max(pahb,-20.0)
1421 pahb = min(pahb,20.0)
1422
1423! print*, 'precip_heat sfctmp,tv,tg:',sfctmp,tv,tg
1424! print*, 'precip_heat 3600.0*qints+qdrips+qthros:',3600.0*(qints+qdrips+qthros)
1425! print*, "precip_heat maxsno:",maxsno
1426! print*, "precip_heat pah_ac:",pah_ac
1427! print*, "precip_heat pah_cg:",pah_cg
1428! print*, "precip_heat pah_ag:",pah_ag
1429
1430! print*, "precip_heat pahv:",pahv
1431! print*, "precip_heat pahg:",pahg
1432! print*, "precip_heat pahb:",pahb
1433! print*, "precip_heat fveg:",fveg
1434! print*, "precip_heat qints*3600.0:",qints*3600.0
1435! print*, "precip_heat qdrips*3600.0:",qdrips*3600.0
1436! print*, "precip_heat qthros*3600.0:",qthros*3600.0
1437
1438! rain or snow on the ground
1439
1440 qrain = qdripr + qthror
1441 qsnow = qdrips + qthros
1442 snowhin = qsnow/bdfall
1443
1444 if (ist == 2 .and. tg > tfrz) then
1445 qsnow = 0.
1446 snowhin = 0.
1447 end if
1448! print*, "precip_heat qsnow*3600.0:",qsnow*3600.0
1449! print*, "precip_heat qrain*3600.0:",qrain*3600.0
1450! print*, "precip_heat snowhin:",snowhin
1451! print*, "precip_heat canice:",canice
1452! print*, "precip_heat canliq:",canliq
1453! print*, "precip_heat end canopy balance:",canliq+canice+(qrain+qsnow)*dt
1454
1455
1456 end subroutine precip_heat
1457
1458!== begin error ====================================================================================
1459
1462 subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , &
1463 fgev ,fctr ,ssoil ,beg_wb ,canliq ,canice , &
1464 sneqv ,wa ,smc ,dzsnso ,prcp ,ecan , &
1465 etran ,edir ,runsrf ,runsub ,dt ,nsoil , &
1466 nsnow ,ist ,errwat, iloc ,jloc ,fveg , &
1467 sav ,sag ,fsrv ,fsrg ,zwt ,pah , &
1468#ifdef CCPP
1469 pahv ,pahg ,pahb ,canhs,errmsg, errflg)
1470#else
1471 pahv ,pahg ,pahb ,canhs)
1472#endif
1473! --------------------------------------------------------------------------------------------------
1474! check surface energy balance and water balance
1475! --------------------------------------------------------------------------------------------------
1476 implicit none
1477! --------------------------------------------------------------------------------------------------
1478! inputs
1479 type (noahmp_parameters), intent(in) :: parameters
1480 integer , intent(in) :: nsnow
1481 integer , intent(in) :: nsoil
1482 integer , intent(in) :: ist
1483 integer , intent(in) :: iloc
1484 integer , intent(in) :: jloc
1485 real (kind=kind_phys) , intent(in) :: swdown
1486 real (kind=kind_phys) , intent(in) :: fsa
1487 real (kind=kind_phys) , intent(in) :: fsr
1488 real (kind=kind_phys) , intent(in) :: fira
1489 real (kind=kind_phys) , intent(in) :: fsh
1490 real (kind=kind_phys) , intent(in) :: fcev
1491 real (kind=kind_phys) , intent(in) :: fgev
1492 real (kind=kind_phys) , intent(in) :: fctr
1493 real (kind=kind_phys) , intent(in) :: ssoil
1494 real (kind=kind_phys) , intent(in) :: fveg
1495 real (kind=kind_phys) , intent(in) :: sav
1496 real (kind=kind_phys) , intent(in) :: sag
1497 real (kind=kind_phys) , intent(in) :: fsrv
1498 real (kind=kind_phys) , intent(in) :: fsrg
1499 real (kind=kind_phys) , intent(in) :: zwt
1500
1501 real (kind=kind_phys) , intent(in) :: prcp
1502 real (kind=kind_phys) , intent(in) :: ecan
1503 real (kind=kind_phys) , intent(in) :: etran
1504 real (kind=kind_phys) , intent(in) :: edir
1505 real (kind=kind_phys) , intent(in) :: runsrf
1506 real (kind=kind_phys) , intent(in) :: runsub
1507 real (kind=kind_phys) , intent(in) :: canliq
1508 real (kind=kind_phys) , intent(in) :: canice
1509 real (kind=kind_phys) , intent(in) :: sneqv
1510 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smc
1511 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
1512 real (kind=kind_phys) , intent(in) :: wa
1513 real (kind=kind_phys) , intent(in) :: dt
1514 real (kind=kind_phys) , intent(in) :: beg_wb
1515 real (kind=kind_phys) , intent(out) :: errwat
1516 real (kind=kind_phys), intent(in) :: pah
1517 real (kind=kind_phys), intent(in) :: pahv
1518 real (kind=kind_phys), intent(in) :: pahg
1519 real (kind=kind_phys), intent(in) :: pahb
1520 real (kind=kind_phys), intent(in) :: canhs
1521
1522#ifdef CCPP
1523 character(len=*) , intent(inout) :: errmsg
1524 integer , intent(inout) :: errflg
1525#endif
1526
1527 integer :: iz !do-loop index
1528 real (kind=kind_phys) :: end_wb !water storage at end of a timestep [mm]
1529 !kwm real (kind=kind_phys) :: errwat !error in water balance [mm/timestep]
1530 real (kind=kind_phys) :: erreng !error in surface energy balance [w/m2]
1531 real (kind=kind_phys) :: errsw !error in shortwave radiation balance [w/m2]
1532 real (kind=kind_phys) :: fsrvg
1533 character(len=256) :: message
1534! --------------------------------------------------------------------------------------------------
1535!jref:start
1536 errsw = swdown - (fsa + fsr)
1537! errsw = swdown - (sav+sag + fsrv+fsrg)
1538! write(*,*) "errsw =",errsw
1539 if (abs(errsw) > 0.01) then ! w/m2
1540 write(*,*) "vegetation!"
1541 write(*,*) "swdown*fveg =",swdown*fveg
1542 write(*,*) "fveg*(sav+sag) =",fveg*sav + sag
1543 write(*,*) "fveg*(fsrv +fsrg)=",fveg*fsrv + fsrg
1544 write(*,*) "ground!"
1545 write(*,*) "(1-.fveg)*swdown =",(1.-fveg)*swdown
1546 write(*,*) "(1.-fveg)*sag =",(1.-fveg)*sag
1547 write(*,*) "(1.-fveg)*fsrg=",(1.-fveg)*fsrg
1548 write(*,*) "fsrv =",fsrv
1549 write(*,*) "fsrg =",fsrg
1550 write(*,*) "fsr =",fsr
1551 write(*,*) "sav =",sav
1552 write(*,*) "sag =",sag
1553 write(*,*) "fsa =",fsa
1554!jref:end
1555 write(message,*) 'errsw =',errsw
1556#ifdef CCPP
1557 errflg = 1
1558 errmsg = trim(message)//new_line('A')//"stop in noah-mp"
1559 return
1560#else
1561 call wrf_message(trim(message))
1562 call wrf_error_fatal("stop in noah-mp")
1563#endif
1564 end if
1565
1566 erreng = sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil+canhs) +pah
1567! erreng = fveg*sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil)
1568 if(abs(erreng) > 0.01) then
1569 write(message,*) 'erreng =',erreng,' at i,j: ',iloc,jloc
1570#ifdef CCPP
1571 errmsg = trim(message)
1572#else
1573 call wrf_message(trim(message))
1574#endif
1575 write(message,'(a17,f10.4)') "net solar: ",fsa
1576#ifdef CCPP
1577 errmsg = trim(errmsg)//new_line('A')//trim(message)
1578#else
1579 call wrf_message(trim(message))
1580#endif
1581 write(message,'(a17,f10.4)') "net longwave: ",fira
1582#ifdef CCPP
1583 errmsg = trim(errmsg)//new_line('A')//trim(message)
1584#else
1585 call wrf_message(trim(message))
1586#endif
1587 write(message,'(a17,f10.4)') "total sensible: ",fsh
1588#ifdef CCPP
1589 errmsg = trim(errmsg)//new_line('A')//trim(message)
1590#else
1591 call wrf_message(trim(message))
1592#endif
1593 write(message,'(a17,f10.4)') "canopy evap: ",fcev
1594#ifdef CCPP
1595 errmsg = trim(errmsg)//new_line('A')//trim(message)
1596#else
1597 call wrf_message(trim(message))
1598#endif
1599 write(message,'(a17,f10.4)') "ground evap: ",fgev
1600#ifdef CCPP
1601 errmsg = trim(errmsg)//new_line('A')//trim(message)
1602#else
1603 call wrf_message(trim(message))
1604#endif
1605 write(message,'(a17,f10.4)') "transpiration: ",fctr
1606#ifdef CCPP
1607 errmsg = trim(errmsg)//new_line('A')//trim(message)
1608#else
1609 call wrf_message(trim(message))
1610#endif
1611 write(message,'(a17,f10.4)') "total ground: ",ssoil
1612#ifdef CCPP
1613 errmsg = trim(errmsg)//new_line('A')//trim(message)
1614#else
1615 call wrf_message(trim(message))
1616#endif
1617 write(message,'(a17,f10.4)') "canopy heat storage: ",canhs
1618#ifdef CCPP
1619 errmsg = trim(errmsg)//new_line('A')//trim(message)
1620#else
1621 call wrf_message(trim(message))
1622#endif
1623 write(message,'(a17,4f10.4)') "precip advected: ",pah,pahv,pahg,pahb
1624#ifdef CCPP
1625 errmsg = trim(errmsg)//new_line('A')//trim(message)
1626#else
1627 call wrf_message(trim(message))
1628#endif
1629 write(message,'(a17,f10.4)') "precip: ",prcp
1630#ifdef CCPP
1631 errmsg = trim(errmsg)//new_line('A')//trim(message)
1632#else
1633 call wrf_message(trim(message))
1634#endif
1635 write(message,'(a17,f10.4)') "veg fraction: ",fveg
1636#ifdef CCPP
1637 errflg = 1
1638 errmsg = trim(errmsg)//new_line('A')//trim(message)//new_line('A')//"energy budget problem in noahmp lsm"
1639 return
1640#else
1641 call wrf_message(trim(message))
1642 call wrf_error_fatal("energy budget problem in noahmp lsm")
1643#endif
1644
1645 end if
1646
1647 if (ist == 1) then !soil
1648 end_wb = canliq + canice + sneqv + wa
1649 do iz = 1,nsoil
1650 end_wb = end_wb + smc(iz) * dzsnso(iz) * 1000.
1651 end do
1652 errwat = end_wb-beg_wb-(prcp-ecan-etran-edir-runsrf-runsub)*dt
1653
1654 else !kwm
1655 errwat = 0.0 !kwm
1656 endif
1657
1658 end subroutine error
1659
1660!== begin energy ===================================================================================
1661
1670 subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in
1671 isnow ,dt ,rhoair ,sfcprs ,qair , & !in
1672 sfctmp ,thair ,lwdn ,uu ,vv ,zref , & !in
1673 co2air ,o2air ,solad ,solai ,cosz ,igs , & !in
1674 eair ,tbot ,zsnso ,zsoil , & !in
1675 elai ,esai ,fwet ,foln , & !in
1676 fveg ,shdfac, pahv ,pahg ,pahb , & !in
1677 qsnow ,dzsnso ,lat ,canliq ,canice ,iloc , jloc, & !in
1678 thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in
1679 pblhx , iz0tlnd, itime,psi_opt,ep_1, ep_2, epsm1, cp, &
1680 z0wrf ,z0hwrf , & !out
1681 imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out
1682 sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out
1683 tauy ,fira ,fsh ,fcev ,fgev ,fctr , & !out
1684 trad ,psn ,apar ,ssoil ,btrani ,btran , & !out
1685 ponding,ts ,latheav , latheag , frozen_canopy,frozen_ground, & !out
1686 tv ,tg ,stc ,snowh ,eah ,tah , & !inout
1687 sneqvo ,sneqv ,sh2o ,smc ,snice ,snliq , & !inout
1688 albold ,cm ,ch ,dx ,dz8w ,q2 , & !inout
1689 ustarx , & !inout
1690#ifdef CCPP
1691 tauss ,laisun ,laisha ,rb ,errmsg ,errflg, & !inout
1692#else
1693 tauss ,laisun ,laisha ,rb , & !inout
1694#endif
1695!jref:start
1696 qc ,qsfc ,psfc , & !in
1697 t2mv ,t2mb ,fsrv , &
1698 fsrg ,rssun ,rssha ,albd ,albi,albsnd ,albsni,bgap ,wgap,tgv,tgb,&
1699 q1 ,q2v ,q2b ,q2e ,chv ,chb, emissi,pah,canhs,&
1700 shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out
1701!jref:end
1702
1703! --------------------------------------------------------------------------------------------------
1704! we use different approaches to deal with subgrid features of radiation transfer and turbulent
1705! transfer. we use 'tile' approach to compute turbulent fluxes, while we use modified two-
1706! stream to compute radiation transfer. tile approach, assemblying vegetation canopies together,
1707! may expose too much ground surfaces (either covered by snow or grass) to solar radiation. the
1708! modified two-stream assumes vegetation covers fully the gridcell but with gaps between tree
1709! crowns.
1710! --------------------------------------------------------------------------------------------------
1711! turbulence transfer : 'tile' approach to compute energy fluxes in vegetated fraction and
1712! bare fraction separately and then sum them up weighted by fraction
1713! --------------------------------------
1714! / o o o o o o o o / /
1715! / | | | | | | | | / /
1716! / o o o o o o o o / /
1717! / | | |tile1| | | | / tile2 /
1718! / o o o o o o o o / bare /
1719! / | | | vegetated | | / /
1720! / o o o o o o o o / /
1721! / | | | | | | | | / /
1722! --------------------------------------
1723! --------------------------------------------------------------------------------------------------
1724! radiation transfer : modified two-stream (yang and friedl, 2003, jgr; niu ang yang, 2004, jgr)
1725! -------------------------------------- two-stream treats leaves as
1726! / o o o o o o o o / cloud over the entire grid-cell,
1727! / | | | | | | | | / while the modified two-stream
1728! / o o o o o o o o / aggregates cloudy leaves into
1729! / | | | | | | | | / tree crowns with gaps (as shown in
1730! / o o o o o o o o / the left figure). we assume these
1731! / | | | | | | | | / tree crowns are evenly distributed
1732! / o o o o o o o o / within the gridcell with 100% veg
1733! / | | | | | | | | / fraction, but with gaps. the 'tile'
1734! -------------------------------------- approach overlaps too much shadows.
1735! --------------------------------------------------------------------------------------------------
1736 implicit none
1737! --------------------------------------------------------------------------------------------------
1738! inputs
1739 type (noahmp_parameters), intent(in) :: parameters
1740 integer , intent(in) :: iloc
1741 integer , intent(in) :: jloc
1742 integer , intent(in) :: ice
1743 integer , intent(in) :: vegtyp
1744 integer , intent(in) :: ist
1745 integer , intent(in) :: nsnow
1746 integer , intent(in) :: nsoil
1747 integer , intent(in) :: isnow
1748 real (kind=kind_phys) , intent(in) :: dt
1749 real (kind=kind_phys) , intent(in) :: qsnow
1750 real (kind=kind_phys) , intent(in) :: rhoair
1751 real (kind=kind_phys) , intent(in) :: eair
1752 real (kind=kind_phys) , intent(in) :: sfcprs
1753
1754 logical , intent(in) :: thsfc_loc
1755 real (kind=kind_phys) , intent(in) :: prslkix
1756 real (kind=kind_phys) , intent(in) :: prsik1x
1757 real (kind=kind_phys) , intent(in) :: prslk1x
1758 real (kind=kind_phys) , intent(in) :: garea1
1759
1760 real (kind=kind_phys) , intent(in) :: pblhx
1761 real (kind=kind_phys) , intent(in) :: ep_1
1762 real (kind=kind_phys) , intent(in) :: ep_2
1763 real (kind=kind_phys) , intent(in) :: epsm1
1764 real (kind=kind_phys) , intent(in) :: cp
1765 integer , intent(in) :: iz0tlnd
1766 integer , intent(in) :: itime
1767 integer , intent(in) :: psi_opt
1768
1769 real (kind=kind_phys) , intent(in) :: qair
1770 real (kind=kind_phys) , intent(in) :: sfctmp
1771 real (kind=kind_phys) , intent(in) :: thair
1772 real (kind=kind_phys) , intent(in) :: lwdn
1773 real (kind=kind_phys) , intent(in) :: uu
1774 real (kind=kind_phys) , intent(in) :: vv
1775 real (kind=kind_phys) , dimension( 1: 2), intent(in) :: solad
1776 real (kind=kind_phys) , dimension( 1: 2), intent(in) :: solai
1777 real (kind=kind_phys) , intent(in) :: cosz
1778 real (kind=kind_phys) , intent(in) :: elai
1779 real (kind=kind_phys) , intent(in) :: esai
1780 real (kind=kind_phys) , intent(in) :: fwet
1781 real (kind=kind_phys) , intent(in) :: fveg
1782 real (kind=kind_phys) , intent(in) :: shdfac
1783 real (kind=kind_phys) , intent(in) :: lat
1784 real (kind=kind_phys) , intent(in) :: canliq
1785 real (kind=kind_phys) , intent(in) :: canice
1786 real (kind=kind_phys) , intent(in) :: foln
1787 real (kind=kind_phys) , intent(in) :: co2air
1788 real (kind=kind_phys) , intent(in) :: o2air
1789 real (kind=kind_phys) , intent(in) :: igs
1790
1791 real (kind=kind_phys) , intent(in) :: zref
1792 real (kind=kind_phys) , intent(in) :: tbot
1793 real (kind=kind_phys) , dimension(-nsnow+1:nsoil), intent(in) :: zsnso
1794 real (kind=kind_phys) , dimension( 1:nsoil), intent(in) :: zsoil
1795 real (kind=kind_phys) , dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
1796 real (kind=kind_phys), intent(in) :: pahv
1797 real (kind=kind_phys), intent(in) :: pahg
1798 real (kind=kind_phys), intent(in) :: pahb
1799
1800!jref:start; in
1801 real (kind=kind_phys) , intent(in) :: qc
1802 real (kind=kind_phys) , intent(inout) :: qsfc
1803 real (kind=kind_phys) , intent(in) :: psfc
1804 real (kind=kind_phys) , intent(in) :: dx
1805 real (kind=kind_phys) , intent(in) :: dz8w
1806 real (kind=kind_phys) , intent(in) :: q2
1807!jref:end
1808
1809! outputs
1810 real (kind=kind_phys) , intent(out) :: z0wrf
1811 real (kind=kind_phys) , intent(out) :: z0hwrf
1812 integer, dimension(-nsnow+1:nsoil), intent(out) :: imelt
1813 real (kind=kind_phys) , dimension(-nsnow+1: 0), intent(out) :: snicev
1814 real (kind=kind_phys) , dimension(-nsnow+1: 0), intent(out) :: snliqv
1815 real (kind=kind_phys) , dimension(-nsnow+1: 0), intent(out) :: epore
1816 real (kind=kind_phys) , intent(out) :: fsno
1817 real (kind=kind_phys) , intent(out) :: qmelt
1818 real (kind=kind_phys) , intent(out) :: ponding
1819 real (kind=kind_phys) , intent(out) :: sav
1820 real (kind=kind_phys) , intent(out) :: sag
1821 real (kind=kind_phys) , intent(out) :: fsa
1822 real (kind=kind_phys) , intent(out) :: fsr
1823 real (kind=kind_phys) , intent(out) :: taux
1824 real (kind=kind_phys) , intent(out) :: tauy
1825 real (kind=kind_phys) , intent(out) :: fira
1826 real (kind=kind_phys) , intent(out) :: fsh
1827 real (kind=kind_phys) , intent(out) :: fcev
1828 real (kind=kind_phys) , intent(out) :: fgev
1829 real (kind=kind_phys) , intent(out) :: fctr
1830 real (kind=kind_phys) , intent(out) :: trad
1831 real (kind=kind_phys) , intent(out) :: t2m
1832 real (kind=kind_phys) , intent(out) :: psn
1833 real (kind=kind_phys) , intent(out) :: apar
1834 real (kind=kind_phys) , intent(out) :: ssoil
1835 real (kind=kind_phys) , dimension( 1:nsoil), intent(out) :: btrani
1836 real (kind=kind_phys) , intent(out) :: btran
1837! real (kind=kind_phys) , intent(out) :: lathea !< latent heat vap./sublimation (j/kg)
1838 real (kind=kind_phys) , intent(out) :: latheav
1839 real (kind=kind_phys) , intent(out) :: latheag
1840 real (kind=kind_phys) , intent(out) :: ts
1841 logical , intent(out) :: frozen_ground
1842 logical , intent(out) :: frozen_canopy
1843
1844!jref:start
1845 real (kind=kind_phys) , intent(out) :: fsrv
1846 real (kind=kind_phys) , intent(out) :: fsrg
1847 real (kind=kind_phys), intent(out) :: rssun
1848 real (kind=kind_phys), intent(out) :: rssha
1849!jref:end - out for debug
1850
1851!jref:start; output
1852 real (kind=kind_phys) , intent(out) :: t2mv
1853 real (kind=kind_phys) , intent(out) :: t2mb
1854 real (kind=kind_phys) , intent(out) :: bgap
1855 real (kind=kind_phys) , intent(out) :: wgap
1856 real (kind=kind_phys) , intent(out) :: canhs
1857 real (kind=kind_phys), dimension(1:2) , intent(out) :: albd
1858 real (kind=kind_phys), dimension(1:2) , intent(out) :: albi
1859 real (kind=kind_phys), dimension(1:2) , intent(out) :: albsnd
1860 real (kind=kind_phys), dimension(1:2) , intent(out) :: albsni
1861!jref:end
1862
1863! input & output
1864 real (kind=kind_phys) , intent(inout) :: tv
1865 real (kind=kind_phys) , intent(inout) :: tg
1866 real (kind=kind_phys) , dimension(-nsnow+1:nsoil), intent(inout) :: stc
1867 real (kind=kind_phys) , intent(inout) :: snowh
1868 real (kind=kind_phys) , intent(inout) :: sneqv
1869 real (kind=kind_phys) , intent(inout) :: sneqvo
1870 real (kind=kind_phys) , dimension( 1:nsoil), intent(inout) :: sh2o
1871 real (kind=kind_phys) , dimension( 1:nsoil), intent(inout) :: smc
1872 real (kind=kind_phys) , dimension(-nsnow+1: 0), intent(inout) :: snice
1873 real (kind=kind_phys) , dimension(-nsnow+1: 0), intent(inout) :: snliq
1874 real (kind=kind_phys) , intent(inout) :: eah
1875 real (kind=kind_phys) , intent(inout) :: tah
1876 real (kind=kind_phys) , intent(inout) :: albold
1877 real (kind=kind_phys) , intent(inout) :: tauss
1878 real (kind=kind_phys) , intent(inout) :: cm
1879 real (kind=kind_phys) , intent(inout) :: ch
1880 real (kind=kind_phys) , intent(inout) :: q1
1881 real (kind=kind_phys) , intent(inout) :: ustarx
1882 real (kind=kind_phys) , intent(inout) :: rb
1883 real (kind=kind_phys) , intent(inout) :: laisun
1884 real (kind=kind_phys) , intent(inout) :: laisha
1885#ifdef CCPP
1886 character(len=*) , intent(inout) :: errmsg
1887 integer , intent(inout) :: errflg
1888#endif
1889! real (kind=kind_phys) :: q2e !<
1890 real (kind=kind_phys), intent(out) :: emissi
1891 real (kind=kind_phys), intent(out) :: pah
1892
1893! local
1894 integer :: iz !do-loop index
1895 logical :: veg !true if vegetated surface
1896 real (kind=kind_phys) :: ur !wind speed at height zlvl (m/s)
1897 real (kind=kind_phys) :: zlvl !reference height (m)
1898 real (kind=kind_phys) :: fsun !sunlit fraction of canopy [-]
1899 real (kind=kind_phys) :: rsurf !ground surface resistance (s/m)
1900 real (kind=kind_phys) :: l_rsurf!dry-layer thickness for computing rsurf (sakaguchi and zeng, 2009)
1901 real (kind=kind_phys) :: d_rsurf!reduced vapor diffusivity in soil for computing rsurf (sz09)
1902 real (kind=kind_phys) :: bevap !soil water evaporation factor (0- 1)
1903 real (kind=kind_phys) :: mol !monin-obukhov length (m)
1904 real (kind=kind_phys) :: vai !sum of lai + stem area index [m2/m2]
1905 real (kind=kind_phys) :: cwp !canopy wind extinction parameter
1906 real (kind=kind_phys) :: zpd !zero plane displacement (m)
1907 real (kind=kind_phys) :: z0m !z0 momentum (m)
1908 real (kind=kind_phys) :: zpdg !zero plane displacement (m)
1909 real (kind=kind_phys) :: z0mg !z0 momentum, ground (m)
1910 real (kind=kind_phys) :: emv !vegetation emissivity
1911 real (kind=kind_phys) :: emg !ground emissivity
1912 real (kind=kind_phys) :: fire !emitted ir (w/m2)
1913
1914 real (kind=kind_phys) :: psnsun !sunlit photosynthesis (umolco2/m2/s)
1915 real (kind=kind_phys) :: psnsha !shaded photosynthesis (umolco2/m2/s)
1916!jref:start - for debug
1917! real (kind=kind_phys) :: rssun !sunlit stomatal resistance (s/m)
1918! real (kind=kind_phys) :: rssha !shaded stomatal resistance (s/m)
1919!jref:end - for debug
1920 real (kind=kind_phys) :: parsun !par absorbed per sunlit lai (w/m2)
1921 real (kind=kind_phys) :: parsha !par absorbed per shaded lai (w/m2)
1922
1923 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: fact !temporary used in phase change
1924 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: df !thermal conductivity [w/m/k]
1925 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: hcpct !heat capacity [j/m3/k]
1926 real (kind=kind_phys) :: bdsno !bulk density of snow (kg/m3)
1927 real (kind=kind_phys) :: fmelt !melting factor for snow cover frac
1928 real (kind=kind_phys) :: gx !temporary variable
1929 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: phi !light through water (w/m2)
1930! real (kind=kind_phys) :: gamma !psychrometric constant (pa/k)
1931 real (kind=kind_phys) :: gammav !psychrometric constant (pa/k)
1932 real (kind=kind_phys) :: gammag !psychrometric constant (pa/k)
1933 real (kind=kind_phys) :: psi !surface layer soil matrix potential (m)
1934 real (kind=kind_phys) :: rhsur !raltive humidity in surface soil/snow air space (-)
1935
1936! temperature and fluxes over vegetated fraction
1937
1938 real (kind=kind_phys) :: tauxv !wind stress: e-w dir [n/m2]
1939 real (kind=kind_phys) :: tauyv !wind stress: n-s dir [n/m2]
1940 real (kind=kind_phys),intent(out) :: irc !canopy net lw rad. [w/m2] [+ to atm]
1941 real (kind=kind_phys),intent(out) :: irg !ground net lw rad. [w/m2] [+ to atm]
1942 real (kind=kind_phys),intent(out) :: shc !canopy sen. heat [w/m2] [+ to atm]
1943 real (kind=kind_phys),intent(out) :: shg !ground sen. heat [w/m2] [+ to atm]
1944!jref:start
1945 real (kind=kind_phys),intent(out) :: q2v
1946 real (kind=kind_phys),intent(out) :: q2b
1947 real (kind=kind_phys),intent(out) :: q2e
1948!jref:end
1949 real (kind=kind_phys),intent(out) :: evc !canopy evap. heat [w/m2] [+ to atm]
1950 real (kind=kind_phys),intent(out) :: evg !ground evap. heat [w/m2] [+ to atm]
1951 real (kind=kind_phys),intent(out) :: tr !transpiration heat [w/m2] [+ to atm]
1952 real (kind=kind_phys),intent(out) :: ghv !ground heat flux [w/m2] [+ to soil]
1953 real (kind=kind_phys),intent(out) :: tgv !ground surface temp. [k]
1954 real (kind=kind_phys) :: cmv !momentum drag coefficient
1955 real (kind=kind_phys),intent(out) :: chv !sensible heat exchange coefficient
1956
1957! temperature and fluxes over bare soil fraction
1958
1959 real (kind=kind_phys) :: tauxb !wind stress: e-w dir [n/m2]
1960 real (kind=kind_phys) :: tauyb !wind stress: n-s dir [n/m2]
1961 real (kind=kind_phys),intent(out) :: irb !net longwave rad. [w/m2] [+ to atm]
1962 real (kind=kind_phys),intent(out) :: shb !sensible heat [w/m2] [+ to atm]
1963 real (kind=kind_phys),intent(out) :: evb !evaporation heat [w/m2] [+ to atm]
1964 real (kind=kind_phys),intent(out) :: ghb !ground heat flux [w/m2] [+ to soil]
1965 real (kind=kind_phys),intent(out) :: tgb !ground surface temp. [k]
1966 real (kind=kind_phys) :: cmb !momentum drag coefficient
1967 real (kind=kind_phys),intent(out) :: chb !sensible heat exchange coefficient
1968 real (kind=kind_phys),intent(out) :: chleaf !leaf exchange coefficient
1969 real (kind=kind_phys),intent(out) :: chuc !under canopy exchange coefficient
1970!jref:start
1971 real (kind=kind_phys),intent(out) :: chv2 !sensible heat conductance, canopy air to zlvl air (m/s)
1972 real (kind=kind_phys),intent(out) :: chb2 !sensible heat conductance, canopy air to zlvl air (m/s)
1973 real (kind=kind_phys) :: noahmpres
1974! for new coupling
1975 real (kind=kind_phys) :: csigmaf0
1976 real (kind=kind_phys) :: csigmaf1
1977
1978 real (kind=kind_phys) :: cdmnv
1979 real (kind=kind_phys) :: ezpdv
1980 real (kind=kind_phys) :: cdmng
1981 real (kind=kind_phys) :: ezpdg
1982 real (kind=kind_phys) :: ezpd
1983 real (kind=kind_phys) :: aone
1984
1985 real (kind=kind_phys) :: canopy_density_factor
1986 real (kind=kind_phys) :: vai_limited
1987
1988!jref:end
1989
1990 real (kind=kind_phys), parameter :: mpe = 1.e-6
1991 real (kind=kind_phys), parameter :: psiwlt = -150. !metric potential for wilting point (m)
1992 real (kind=kind_phys), parameter :: z0 = 0.002 ! bare-soil roughness length (m) (i.e., under the canopy)
1993
1994! ---------------------------------------------------------------------------------------------------
1995! initialize fluxes from veg. fraction
1996
1997 tauxv = 0.
1998 tauyv = 0.
1999 irc = 0.
2000 shc = 0.
2001 irg = 0.
2002 shg = 0.
2003 evg = 0.
2004 evc = 0.
2005 tr = 0.
2006 ghv = 0.
2007 psnsun = 0.
2008 psnsha = 0.
2009 t2mv = 0.
2010 q2v = 0.
2011 chv = 0.
2012 chleaf = 0.
2013 chuc = 0.
2014 chv2 = 0.
2015 rb = 0.
2016 laisun = 0.
2017 laisha = 0.
2018
2019 cdmnv = 0.0
2020 ezpdv = 0.0
2021 cdmng = 0.0
2022 ezpdg = 0.0
2023 ezpd = 0.0
2024 z0hwrf = 0.0
2025 csigmaf1 = 0.0
2026 csigmaf0 = 0.0
2027 aone = 0.0
2028
2029 canopy_density_factor = 1.0
2030 vai_limited = 2.0
2031
2032!
2033
2034! wind speed at reference height: ur >= 1
2035
2036 ur = max( sqrt(uu**2.+vv**2.), 1. )
2037
2038! vegetated or non-vegetated
2039
2040 vai = elai + esai
2041 veg = .false.
2042 if(vai > 0.) veg = .true.
2043
2044! ground snow cover fraction [niu and yang, 2007, jgr]
2045
2046 fsno = 0.
2047 if(snowh <= 1.e-6 .or. sneqv <= 1.e-3) then
2048 snowh = 0.0
2049 sneqv = 0.0
2050 end if
2051 if(snowh.gt.0.) then
2052 bdsno = sneqv / snowh
2053 fmelt = (bdsno/100.)**parameters%mfsno
2054 fsno = tanh( snowh /(parameters%scffac * fmelt))
2055 endif
2056
2057! ground roughness length
2058
2059 if(ist == 2) then
2060 if(tg .le. tfrz) then
2061 z0mg = 0.01 * (1.0-fsno) + fsno * parameters%z0sno
2062 else
2063 z0mg = 0.01
2064 end if
2065 else
2066 z0mg = z0 * (1.0-fsno) + fsno * parameters%z0sno
2067 end if
2068
2069! roughness length and displacement height
2070
2071 zpdg = snowh
2072 if(veg) then
2073
2074 if(opt_z0m == 1) then
2075
2076 z0m = parameters%z0mvt
2077 zpd = 0.65 * parameters%hvt
2078
2079 elseif(opt_z0m == 2) then
2080
2081 z0m = parameters%z0mhvt * parameters%hvt
2082 zpd = 0.65 * parameters%hvt
2083 if(vegtyp /= 13) then
2084 vai_limited = min(vai, 2.0)
2085 canopy_density_factor = (1.0 - exp(-vai_limited)) / (1.0 - exp(-2.0))
2086 z0m = exp(canopy_density_factor * log(z0m) + (1.0 - canopy_density_factor) * log(z0mg))
2087 zpd = canopy_density_factor * zpd
2088 end if
2089
2090 end if
2091
2092 if(snowh.gt.zpd) zpd = snowh
2093
2094 else
2095
2096 z0m = z0mg
2097 zpd = zpdg
2098
2099 end if
2100
2101! special case for urban
2102
2103 IF (parameters%urban_flag) THEN
2104 z0mg = parameters%Z0MVT
2105 zpdg = 0.65 * parameters%HVT
2106 z0m = z0mg
2107 zpd = zpdg
2108 END IF
2109
2110 zlvl = max(zpd,parameters%hvt) + zref
2111 if(zpdg >= zlvl) zlvl = zpdg + zref
2112! ur = ur*log(zlvl/z0m)/log(10./z0m) !input ur is at 10m
2113
2114! canopy wind absorption coeffcient
2115
2116 cwp = parameters%cwpvt
2117
2118! thermal properties of soil, snow, lake, and frozen soil
2119
2120 call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in
2121 dt ,snowh ,snice ,snliq , shdfac, & !in
2122 smc ,sh2o ,tg ,stc ,ur , & !in
2123 lat ,z0m ,zlvl ,vegtyp , & !in
2124 df ,hcpct ,snicev ,snliqv ,epore , & !out
2125 fact ) !out
2126
2127! solar radiation: absorbed & reflected by the ground and canopy
2128
2129 call radiation (parameters,vegtyp ,ist ,ice ,nsoil , & !in
2130 sneqvo ,sneqv ,dt ,cosz ,snowh , & !in
2131 tg ,tv ,fsno ,qsnow ,fwet , & !in
2132 elai ,esai ,smc ,solad ,solai , & !in
2133 fveg ,iloc ,jloc , & !in
2134 albold ,tauss , & !inout
2135 fsun ,laisun ,laisha ,parsun ,parsha , & !out
2136 sav ,sag ,fsr ,fsa ,fsrv , &
2137 fsrg ,albd ,albi ,albsnd ,albsni ,bgap ,wgap ) ! out
2138
2139! vegetation and ground emissivity
2140
2141 emv = 1. - exp(-(elai+esai)/1.0)
2142 if (ice == 1) then
2143 emg = 0.98*(1.-fsno) + parameters%snow_emis*fsno
2144 else
2145 emg = parameters%eg(ist)*(1.-fsno) + parameters%snow_emis*fsno
2146 end if
2147
2148! soil moisture factor controlling stomatal resistance
2149
2150 btran = 0.
2151
2152 if(ist ==1 ) then
2153 do iz = 1, parameters%nroot
2154 if(opt_btr == 1) then ! noah
2155 gx = (sh2o(iz)-parameters%smcwlt(iz)) / (parameters%smcref(iz)-parameters%smcwlt(iz))
2156 end if
2157 if(opt_btr == 2) then ! clm
2158 psi = max(psiwlt,-parameters%psisat(iz)*(max(0.01,sh2o(iz))/parameters%smcmax(iz))**(-parameters%bexp(iz)) )
2159 gx = (1.-psi/psiwlt)/(1.+parameters%psisat(iz)/psiwlt)
2160 end if
2161 if(opt_btr == 3) then ! ssib
2162 psi = max(psiwlt,-parameters%psisat(iz)*(max(0.01,sh2o(iz))/parameters%smcmax(iz))**(-parameters%bexp(iz)) )
2163 gx = 1.-exp(-5.8*(log(psiwlt/psi)))
2164 end if
2165
2166 gx = min(1.,max(0.,gx))
2167 btrani(iz) = max(mpe,dzsnso(iz) / (-zsoil(parameters%nroot)) * gx)
2168 btran = btran + btrani(iz)
2169 end do
2170 btran = max(mpe,btran)
2171
2172 btrani(1:parameters%nroot) = btrani(1:parameters%nroot)/btran
2173 end if
2174
2175! soil surface resistance for ground evap.
2176
2177 bevap = max(0.0,sh2o(1)/parameters%smcmax(1))
2178 if(ist == 2) then
2179 rsurf = 1. ! avoid being divided by 0
2180 rhsur = 1.0
2181 else
2182
2183 if(opt_rsf == 1 .or. opt_rsf == 4) then
2184 ! rsurf based on sakaguchi and zeng, 2009
2185 ! taking the "residual water content" to be the wilting point,
2186 ! and correcting the exponent on the d term (typo in sz09 ?)
2187 l_rsurf = (-zsoil(1)) * ( exp( (1.0 - min(1.0,sh2o(1)/parameters%smcmax(1))) ** parameters%rsurf_exp ) - 1.0 ) / ( 2.71828 - 1.0 )
2188 d_rsurf = 2.2e-5 * parameters%smcmax(1) * parameters%smcmax(1) * ( 1.0 - parameters%smcwlt(1) / parameters%smcmax(1) ) ** (2.0+3.0/parameters%bexp(1))
2189 rsurf = l_rsurf / d_rsurf
2190 elseif(opt_rsf == 2) then
2191 rsurf = fsno * 1. + (1.-fsno)* exp(8.25-4.225*bevap) !sellers (1992) ! older rsurf computations
2192 elseif(opt_rsf == 3) then
2193 rsurf = fsno * 1. + (1.-fsno)* exp(8.25-6.0 *bevap) !adjusted to decrease rsurf for wet soil
2194 endif
2195
2196 if(opt_rsf == 4) then ! ad: fsno weighted; snow rsurf set in mptable v3.8
2197 rsurf = 1. / (fsno * (1./parameters%rsurf_snow) + (1.-fsno) * (1./max(rsurf, 0.001)))
2198 endif
2199
2200 if(sh2o(1) < 0.01 .and. snowh == 0.) rsurf = 1.e6
2201 psi = -parameters%psisat(1)*(max(0.01,sh2o(1))/parameters%smcmax(1))**(-parameters%bexp(1))
2202 rhsur = fsno + (1.-fsno) * exp(psi*grav/(rw*tg))
2203 end if
2204
2205! urban - jref
2206 if (parameters%urban_flag .and. snowh == 0. ) then
2207 rsurf = 1.e6
2208 endif
2209
2210! set psychrometric constant
2211
2212 if (tv .gt. tfrz) then ! barlage: add distinction between ground and
2213 latheav = hvap ! vegetation in v3.6
2214 frozen_canopy = .false.
2215 else
2216 latheav = hsub
2217 frozen_canopy = .true.
2218 end if
2219 gammav = cpair*sfcprs/(ep_2*latheav)
2220
2221 if (tg .gt. tfrz) then
2222 latheag = hvap
2223 frozen_ground = .false.
2224 else
2225 latheag = hsub
2226 frozen_ground = .true.
2227 end if
2228 gammag = cpair*sfcprs/(ep_2*latheag)
2229
2230! if (sfctmp .gt. tfrz) then
2231! lathea = hvap
2232! else
2233! lathea = hsub
2234! end if
2235! gamma = cpair*sfcprs/(ep_2*lathea)
2236
2237! surface temperatures of the ground and canopy and energy fluxes
2238
2239 if (veg .and. fveg > 0) then
2240 tgv = tg
2241 cmv = cm
2242 chv = ch
2243 call vege_flux (parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & !in
2244 dt ,sav ,sag ,lwdn ,ur , & !in
2245 uu ,vv ,sfctmp ,thair ,qair , & !in
2246 eair ,rhoair ,snowh ,vai ,gammav ,gammag , & !in
2247 fwet ,laisun ,laisha ,cwp ,dzsnso , & !in
2248 zlvl ,zpd ,z0m ,fveg ,shdfac, & !in
2249 z0mg ,emv ,emg ,canliq ,fsno, & !in
2250 canice ,stc ,df ,rssun ,rssha , & !in
2251 rsurf ,latheav ,latheag ,parsun ,parsha ,igs , & !in
2252 foln ,co2air ,o2air ,btran ,sfcprs , & !in
2253 rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in
2254 thsfc_loc, prslkix,prsik1x,prslk1x, garea1, & !in
2255 pblhx ,iz0tlnd ,itime ,psi_opt ,ep_1, ep_2, epsm1, cp, &
2256 eah ,tah ,tv ,tgv ,cmv, ustarx , & !inout
2257#ifdef CCPP
2258 chv ,dx ,dz8w ,errmsg ,errflg , & !inout
2259#else
2260 chv ,dx ,dz8w , & !inout
2261#endif
2262 tauxv ,tauyv ,irg ,irc ,shg , & !out
2263 shc ,evg ,evc ,tr ,ghv , & !out
2264 t2mv ,psnsun ,psnsha ,canhs , & !out
2265 csigmaf1, & !out
2266!jref:start
2267 qc ,qsfc ,psfc , & !in
2268 q2v ,chv2 ,chleaf ,chuc , &
2269 rb) !out
2270
2271! new coupling code
2272
2273 cdmnv = 0.4*0.4/log((zlvl-zpd)/z0m)**2
2274 aone = 2.6*(10.0*parameters%hvt/(zlvl-zpd))**0.355
2275 ezpdv = zpd*fveg !for the grid
2276
2277!jref:end
2278#ifdef CCPP
2279 if (errflg /= 0) return
2280#endif
2281 end if
2282
2283 tgb = tg
2284 cmb = cm
2285 chb = ch
2286 call bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & !in
2287 lwdn ,ur ,uu ,vv ,sfctmp , & !in
2288 thair ,qair ,eair ,rhoair ,snowh , & !in
2289 dzsnso ,zlvl ,zpdg ,z0mg ,fsno, & !in
2290 emg ,stc ,df ,rsurf ,latheag , & !in
2291 gammag ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in
2292 thsfc_loc, prslkix,prsik1x,prslk1x,vegtyp,fveg,shdfac,garea1, & !in
2293 pblhx ,iz0tlnd ,itime ,psi_opt ,ep_1, ep_2, epsm1, cp, &
2294#ifdef CCPP
2295 tgb ,cmb ,chb, ustarx,errmsg ,errflg , & !inout
2296#else
2297 tgb ,cmb ,chb, ustarx, & !inout
2298#endif
2299 tauxb ,tauyb ,irb ,shb ,evb,csigmaf0,& !out
2300 ghb ,t2mb ,dx ,dz8w , & !out
2301!jref:start
2302 qc ,qsfc ,psfc , & !in
2303 sfcprs ,q2b, chb2) !in
2304
2305! new coupling code
2306
2307 cdmng = 0.4*0.4/log((zlvl-zpdg)/z0mg)**2
2308 ezpdg = zpdg
2309!
2310! vegetation is optional; use the larger one
2311!
2312 if (ezpdv .ge. ezpdg ) then
2313 ezpd = ezpdv
2314 elseif (ezpdv .gt. 0.0 .and. ezpdv .lt. ezpdg) then
2315 ezpd = (1.0 -fveg)*ezpdg
2316 else
2317 ezpd = ezpdg
2318 endif
2319
2320!jref:end
2321#ifdef CCPP
2322 if (errflg /= 0) return
2323#endif
2324!energy balance at vege canopy: sav =(irc+shc+evc+tr) *fveg at fveg
2325!energy balance at vege ground: sag* fveg =(irg+shg+evg+ghv) *fveg at fveg
2326!energy balance at bare ground: sag*(1.-fveg)=(irb+shb+evb+ghb)*(1.-fveg) at 1-fveg
2327
2328 if (veg .and. fveg > 0) then
2329 taux = fveg * tauxv + (1.0 - fveg) * tauxb
2330 tauy = fveg * tauyv + (1.0 - fveg) * tauyb
2331 fira = fveg * irg + (1.0 - fveg) * irb + irc
2332 fsh = fveg * shg + (1.0 - fveg) * shb + shc
2333 fgev = fveg * evg + (1.0 - fveg) * evb
2334 ssoil = fveg * ghv + (1.0 - fveg) * ghb
2335 fcev = evc
2336 fctr = tr
2337 pah = fveg * pahg + (1.0 - fveg) * pahb + pahv
2338 tg = fveg * tgv + (1.0 - fveg) * tgb
2339 t2m = fveg * t2mv + (1.0 - fveg) * t2mb
2340 ts = fveg * tah + (1.0 - fveg) * tgb
2341 cm = fveg * cmv + (1.0 - fveg) * cmb ! better way to average?
2342 ch = fveg * chv + (1.0 - fveg) * chb
2343 q1 = fveg * (eah*ep_2/(sfcprs + epsm1*eah)) + (1.0 - fveg)*qsfc
2344 q2e = fveg * q2v + (1.0 - fveg) * q2b
2345
2346! effectibe skin temperature
2347
2348 ts = (fveg*chv*tah + (1.0-fveg)*chb*tgb ) / ch
2349
2350
2351! new coupling code
2352
2353 call thermalz0(parameters,fveg,z0m,z0mg,zlvl,zpd,ezpd,ustarx, & !in
2354 vegtyp,vai,ur,csigmaf0,csigmaf1,aone,cdmnv,cdmng,2, & !in
2355 z0wrf,z0hwrf)
2356 else
2357 taux = tauxb
2358 tauy = tauyb
2359 fira = irb
2360 fsh = shb
2361 fgev = evb
2362 ssoil = ghb
2363 tg = tgb
2364 t2m = t2mb
2365 fcev = 0.
2366 fctr = 0.
2367 pah = pahb
2368 ts = tg
2369 cm = cmb
2370 ch = chb
2371 q1 = qsfc
2372 q2e = q2b
2373 rssun = 0.0
2374 rssha = 0.0
2375 tgv = tgb
2376 chv = chb
2377
2378 call thermalz0(parameters,fveg,z0m,z0mg,zlvl,zpd,ezpd,ustarx, & !in
2379 vegtyp,vai,ur,csigmaf0,csigmaf1,aone,cdmnv,cdmng,0, & !in
2380 z0wrf,z0hwrf)
2381
2382 end if
2383
2384 fire = lwdn + fira
2385
2386 if(fire <=0.) then
2387 write(6,*) 'emitted longwave <0; skin t may be wrong due to inconsistent'
2388 write(6,*) 'input of shdfac with lai'
2389 write(6,*) iloc, jloc, 'shdfac=',fveg,'vai=',vai,'tv=',tv,'tg=',tg
2390 write(6,*) 'lwdn=',lwdn,'fira=',fira,'snowh=',snowh
2391#ifdef CCPP
2392 errflg = 1
2393 errmsg = "stop in noah-mp"
2394 return
2395#else
2396 call wrf_error_fatal("stop in noah-mp")
2397#endif
2398
2399 end if
2400
2401 ! compute a net emissivity
2402 emissi = fveg * ( emg*(1-emv) + emv + emv*(1-emv)*(1-emg) ) + &
2403 (1-fveg) * emg
2404
2405 ! when we're computing a trad, subtract from the emitted ir the
2406 ! reflected portion of the incoming lwdn, so we're just
2407 ! considering the ir originating in the canopy/ground system.
2408
2409 trad = ( ( fire - (1-emissi)*lwdn ) / (emissi*sb) ) ** 0.25
2410
2411 ! old trad calculation not taking into account emissivity:
2412 ! trad = (fire/sb)**0.25
2413
2414 apar = parsun*laisun + parsha*laisha
2415 psn = psnsun*laisun + psnsha*laisha
2416
2417! 3l snow & 4l soil temperatures
2418
2419 call tsnosoi (parameters,ice ,nsoil ,nsnow ,isnow ,ist , & !in
2420 tbot ,zsnso ,ssoil ,df ,hcpct , & !in
2421 sag ,dt ,snowh ,dzsnso , & !in
2422 tg ,iloc ,jloc , & !in
2423#ifdef CCPP
2424 stc ,errmsg ,errflg ) !inout
2425#else
2426 stc ) !inout
2427#endif
2428
2429#ifdef CCPP
2430 if (errflg /= 0) return
2431#endif
2432
2433! adjusting snow surface temperature
2434 if(opt_stc == 2) then
2435 if (snowh > 0.05 .and. tg > tfrz) then
2436 tgv = tfrz
2437 tgb = tfrz
2438 if (veg .and. fveg > 0) then
2439 tg = fveg * tgv + (1.0 - fveg) * tgb
2440 ts = fveg * tv + (1.0 - fveg) * tgb
2441 else
2442 tg = tgb
2443 ts = tgb
2444 end if
2445 end if
2446 end if
2447
2448! energy released or consumed by snow & frozen soil
2449
2450 call phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , & !in
2451 dzsnso ,hcpct ,ist ,iloc ,jloc , & !in
2452 stc ,snice ,snliq ,sneqv ,snowh , & !inout
2453#ifdef CCPP
2454 smc ,sh2o ,errmsg ,errflg , & !inout
2455#else
2456 smc ,sh2o , & !inout
2457#endif
2458 qmelt ,imelt ,ponding ) !out
2459#ifdef CCPP
2460 if (errflg /= 0) return
2461#endif
2462
2463 end subroutine energy
2464
2465!== begin thermoprop ===============================================================================
2466
2468 subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in
2469 dt ,snowh ,snice ,snliq , shdfac, & !in
2470 smc ,sh2o ,tg ,stc ,ur , & !in
2471 lat ,z0m ,zlvl ,vegtyp , & !in
2472 df ,hcpct ,snicev ,snliqv ,epore , & !out
2473 fact ) !out
2474! -------------------------------------------------------------------------------------------------
2475 implicit none
2476! --------------------------------------------------------------------------------------------------
2477! inputs
2478 type (noahmp_parameters), intent(in) :: parameters
2479 integer , intent(in) :: nsoil
2480 integer , intent(in) :: nsnow
2481 integer , intent(in) :: isnow
2482 integer , intent(in) :: ist
2483 real (kind=kind_phys) , intent(in) :: dt
2484 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snice
2485 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snliq
2486 real (kind=kind_phys) , intent(in) :: shdfac
2487 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
2488 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smc
2489 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: sh2o
2490 real (kind=kind_phys) , intent(in) :: snowh
2491 real (kind=kind_phys), intent(in) :: tg
2492 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc
2493 real (kind=kind_phys), intent(in) :: ur
2494 real (kind=kind_phys), intent(in) :: lat
2495 real (kind=kind_phys), intent(in) :: z0m
2496 real (kind=kind_phys), intent(in) :: zlvl
2497 integer , intent(in) :: vegtyp
2498
2499! outputs
2500 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: df
2501 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: hcpct
2502 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(out) :: snicev
2503 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(out) :: snliqv
2504 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(out) :: epore
2505 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: fact
2506! --------------------------------------------------------------------------------------------------
2507! locals
2508
2509 integer :: iz
2510 real (kind=kind_phys), dimension(-nsnow+1: 0) :: cvsno !volumetric specific heat (j/m3/k)
2511 real (kind=kind_phys), dimension(-nsnow+1: 0) :: tksno !snow thermal conductivity (j/m3/k)
2512 real (kind=kind_phys), dimension( 1:nsoil) :: sice !soil ice content
2513 real (kind=kind_phys), parameter :: sbeta = -2.0
2514! --------------------------------------------------------------------------------------------------
2515
2516! compute snow thermal conductivity and heat capacity
2517
2518 call csnow (parameters,isnow ,nsnow ,nsoil ,snice ,snliq ,dzsnso , & !in
2519 tksno ,cvsno ,snicev ,snliqv ,epore ) !out
2520
2521 do iz = isnow+1, 0
2522 df(iz) = tksno(iz)
2523 hcpct(iz) = cvsno(iz)
2524 end do
2525
2526! compute soil thermal properties
2527
2528 do iz = 1, nsoil
2529 sice(iz) = smc(iz) - sh2o(iz)
2530 hcpct(iz) = sh2o(iz)*cwat + (1.0-parameters%smcmax(iz))*parameters%csoil &
2531 + (parameters%smcmax(iz)-smc(iz))*cpair + sice(iz)*cice
2532 call tdfcnd (parameters,iz,df(iz), smc(iz), sh2o(iz))
2533 end do
2534
2535 if ( parameters%urban_flag ) then
2536 do iz = 1,nsoil
2537 df(iz) = 3.24
2538 end do
2539 endif
2540
2541! heat flux reduction effect from the overlying green canopy, adapted from
2542! section 2.1.2 of peters-lidard et al. (1997, jgr, vol 102(d4)).
2543! not in use because of the separation of the canopy layer from the ground.
2544! but this may represent the effects of leaf litter (niu comments)
2545! df1 = df1 * exp (sbeta * shdfac)
2546 df(1) = df(1) * exp(sbeta * shdfac)
2547
2548! compute lake thermal properties
2549! (no consideration of turbulent mixing for this version)
2550
2551 if(ist == 2) then
2552 do iz = 1, nsoil
2553 if(stc(iz) > tfrz) then
2554 hcpct(iz) = cwat
2555 df(iz) = tkwat !+ keddy * cwat
2556 else
2557 hcpct(iz) = cice
2558 df(iz) = tkice
2559 end if
2560 end do
2561 end if
2562
2563! combine a temporary variable used for melting/freezing of snow and frozen soil
2564
2565 do iz = isnow+1,nsoil
2566 fact(iz) = dt/(hcpct(iz)*dzsnso(iz))
2567 end do
2568
2569! snow/soil interface
2570
2571 if(isnow == 0) then
2572 df(1) = (df(1)*dzsnso(1)+0.35*snowh) / (snowh +dzsnso(1))
2573 else
2574 df(1) = (df(1)*dzsnso(1)+df(0)*dzsnso(0)) / (dzsnso(0)+dzsnso(1))
2575 end if
2576
2577
2578 end subroutine thermoprop
2579
2580!== begin csnow ====================================================================================
2581
2584 subroutine csnow (parameters,isnow ,nsnow ,nsoil ,snice ,snliq ,dzsnso , & !in
2585 tksno ,cvsno ,snicev ,snliqv ,epore ) !out
2586! --------------------------------------------------------------------------------------------------
2587! snow bulk density,volumetric capacity, and thermal conductivity
2588!---------------------------------------------------------------------------------------------------
2589 implicit none
2590!---------------------------------------------------------------------------------------------------
2591! inputs
2592
2593 type (noahmp_parameters), intent(in) :: parameters
2594 integer, intent(in) :: isnow
2595 integer , intent(in) :: nsnow
2596 integer , intent(in) :: nsoil
2597 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snice
2598 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snliq
2599 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
2600
2601! outputs
2602
2603 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(out) :: cvsno
2604 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(out) :: tksno
2605 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(out) :: snicev
2606 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(out) :: snliqv
2607 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(out) :: epore
2608
2609! locals
2610
2611 integer :: iz
2612 real (kind=kind_phys), dimension(-nsnow+1: 0) :: bdsnoi !bulk density of snow(kg/m3)
2613
2614!---------------------------------------------------------------------------------------------------
2615! thermal capacity of snow
2616
2617 do iz = isnow+1, 0
2618 snicev(iz) = min(1., snice(iz)/(dzsnso(iz)*denice) )
2619 epore(iz) = 1. - snicev(iz)
2620 snliqv(iz) = min(epore(iz),snliq(iz)/(dzsnso(iz)*denh2o))
2621 enddo
2622
2623 do iz = isnow+1, 0
2624 bdsnoi(iz) = (snice(iz)+snliq(iz))/dzsnso(iz)
2625 cvsno(iz) = cice*snicev(iz)+cwat*snliqv(iz)
2626! cvsno(iz) = 0.525e06 ! constant
2627 enddo
2628
2629! thermal conductivity of snow
2630
2631 do iz = isnow+1, 0
2632! tksno(iz) = 3.2217e-6*bdsnoi(iz)**2. ! stieglitz(yen,1965)
2633! tksno(iz) = 2e-2+2.5e-6*bdsnoi(iz)*bdsnoi(iz) ! anderson, 1976
2634! tksno(iz) = 0.35 ! constant
2635 tksno(iz) = 2.576e-6*bdsnoi(iz)**2. + 0.074 ! verseghy (1991)
2636! tksno(iz) = 2.22*(bdsnoi(iz)/1000.)**1.88 ! douvill(yen, 1981)
2637 enddo
2638
2639 end subroutine csnow
2640
2641!== begin tdfcnd ===================================================================================
2642
2646 subroutine tdfcnd (parameters, isoil, df, smc, sh2o)
2647! --------------------------------------------------------------------------------------------------
2648! calculate thermal diffusivity and conductivity of the soil.
2649! peters-lidard approach (peters-lidard et al., 1998)
2650! --------------------------------------------------------------------------------------------------
2651! code history:
2652! june 2001 changes: frozen soil condition.
2653! --------------------------------------------------------------------------------------------------
2654 implicit none
2655 type (noahmp_parameters), intent(in) :: parameters
2656 integer, intent(in) :: isoil
2657 real (kind=kind_phys), intent(in) :: smc
2658 real (kind=kind_phys), intent(in) :: sh2o
2659 real (kind=kind_phys), intent(out) :: df
2660
2661! local variables
2662 real (kind=kind_phys) :: ake
2663 real (kind=kind_phys) :: gammd
2664 real (kind=kind_phys) :: thkdry
2665 real (kind=kind_phys) :: thko ! thermal conductivity for other soil components
2666 real (kind=kind_phys) :: thkqtz ! thermal conductivity for quartz
2667 real (kind=kind_phys) :: thksat !
2668 real (kind=kind_phys) :: thks ! thermal conductivity for the solids
2669 real (kind=kind_phys) :: thkw ! water thermal conductivity
2670 real (kind=kind_phys) :: satratio
2671 real (kind=kind_phys) :: xu
2672 real (kind=kind_phys) :: xunfroz
2673! --------------------------------------------------------------------------------------------------
2674! we now get quartz as an input argument (set in routine redprm):
2675! data quartz /0.82, 0.10, 0.25, 0.60, 0.52,
2676! & 0.35, 0.60, 0.40, 0.82/
2677! --------------------------------------------------------------------------------------------------
2678! if the soil has any moisture content compute a partial sum/product
2679! otherwise use a constant value which works well with most soils
2680! --------------------------------------------------------------------------------------------------
2681! quartz ....quartz content (soil type dependent)
2682! --------------------------------------------------------------------------------------------------
2683! use as in peters-lidard, 1998 (modif. from johansen, 1975).
2684
2685! pablo grunmann, 08/17/98
2686! refs.:
2687! farouki, o.t.,1986: thermal properties of soils. series on rock
2688! and soil mechanics, vol. 11, trans tech, 136 pp.
2689! johansen, o., 1975: thermal conductivity of soils. ph.d. thesis,
2690! university of trondheim,
2691! peters-lidard, c. d., et al., 1998: the effect of soil thermal
2692! conductivity parameterization on surface energy fluxes
2693! and temperatures. journal of the atmospheric sciences,
2694! vol. 55, pp. 1209-1224.
2695! --------------------------------------------------------------------------------------------------
2696! needs parameters
2697! porosity(soil type):
2698! poros = smcmax
2699! saturation ratio:
2700! parameters w/(m.k)
2701 satratio = smc / parameters%smcmax(isoil)
2702 thkw = 0.57
2703! if (quartz .le. 0.2) thko = 3.0
2704 thko = 2.0
2705! solids' conductivity
2706! quartz' conductivity
2707 thkqtz = 7.7
2708
2709! unfrozen fraction (from 1., i.e., 100%liquid, to 0. (100% frozen))
2710 thks = (thkqtz ** parameters%quartz(isoil))* (thko ** (1. - parameters%quartz(isoil)))
2711
2712! unfrozen volume for saturation (porosity*xunfroz)
2713 xunfroz = 1.0 ! prevent divide by zero (suggested by d. mocko)
2714 if(smc > 0.) xunfroz = sh2o / smc
2715! saturated thermal conductivity
2716 xu = xunfroz * parameters%smcmax(isoil)
2717
2718! dry density in kg/m3
2719 thksat = thks ** (1. - parameters%smcmax(isoil))* tkice ** (parameters%smcmax(isoil) - xu)* thkw ** &
2720 (xu)
2721
2722! dry thermal conductivity in w.m-1.k-1
2723 gammd = (1. - parameters%smcmax(isoil))*2700.
2724
2725 thkdry = (0.135* gammd+ 64.7)/ (2700. - 0.947* gammd)
2726! frozen
2727 if ( (sh2o + 0.0005) < smc ) then
2728 ake = satratio
2729! unfrozen
2730! range of validity for the kersten number (ake)
2731 else
2732
2733! kersten number (using "fine" formula, valid for soils containing at
2734! least 5% of particles with diameter less than 2.e-6 meters.)
2735! (for "coarse" formula, see peters-lidard et al., 1998).
2736
2737 if ( satratio > 0.1 ) then
2738
2739 ake = log10(satratio) + 1.0
2740
2741! use k = kdry
2742 else
2743
2744 ake = 0.0
2745 end if
2746! thermal conductivity
2747
2748 end if
2749
2750 df = ake * (thksat - thkdry) + thkdry
2751
2752
2753 end subroutine tdfcnd
2754
2755!== begin radiation ================================================================================
2756
2759 subroutine radiation (parameters,vegtyp ,ist ,ice ,nsoil , & !in
2760 sneqvo ,sneqv ,dt ,cosz ,snowh , & !in
2761 tg ,tv ,fsno ,qsnow ,fwet , & !in
2762 elai ,esai ,smc ,solad ,solai , & !in
2763 fveg ,iloc ,jloc , & !in
2764 albold ,tauss , & !inout
2765 fsun ,laisun ,laisha ,parsun ,parsha , & !out
2766 sav ,sag ,fsr ,fsa ,fsrv , &
2767 fsrg ,albd ,albi ,albsnd ,albsni ,bgap ,wgap) !out
2768! --------------------------------------------------------------------------------------------------
2769 implicit none
2770! --------------------------------------------------------------------------------------------------
2771! input
2772 type (noahmp_parameters), intent(in) :: parameters
2773 integer, intent(in) :: iloc
2774 integer, intent(in) :: jloc
2775 integer, intent(in) :: vegtyp
2776 integer, intent(in) :: ist
2777 integer, intent(in) :: ice
2778 integer, intent(in) :: nsoil
2779
2780 real (kind=kind_phys), intent(in) :: dt
2781 real (kind=kind_phys), intent(in) :: qsnow
2782 real (kind=kind_phys), intent(in) :: sneqvo
2783 real (kind=kind_phys), intent(in) :: sneqv
2784 real (kind=kind_phys), intent(in) :: snowh
2785 real (kind=kind_phys), intent(in) :: cosz
2786 real (kind=kind_phys), intent(in) :: tg
2787 real (kind=kind_phys), intent(in) :: tv
2788 real (kind=kind_phys), intent(in) :: elai
2789 real (kind=kind_phys), intent(in) :: esai
2790 real (kind=kind_phys), intent(in) :: fwet
2791 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: smc
2792 real (kind=kind_phys), dimension(1:2) , intent(in) :: solad
2793 real (kind=kind_phys), dimension(1:2) , intent(in) :: solai
2794 real (kind=kind_phys), intent(in) :: fsno
2795 real (kind=kind_phys), intent(in) :: fveg
2796
2797! inout
2798 real (kind=kind_phys), intent(inout) :: albold
2799 real (kind=kind_phys), intent(inout) :: tauss
2800
2801! output
2802 real (kind=kind_phys), intent(out) :: fsun
2803 real (kind=kind_phys), intent(out) :: laisun
2804 real (kind=kind_phys), intent(out) :: laisha
2805 real (kind=kind_phys), intent(out) :: parsun
2806 real (kind=kind_phys), intent(out) :: parsha
2807 real (kind=kind_phys), intent(out) :: sav
2808 real (kind=kind_phys), intent(out) :: sag
2809 real (kind=kind_phys), intent(out) :: fsa
2810 real (kind=kind_phys), intent(out) :: fsr
2811
2812!jref:start
2813 real (kind=kind_phys), intent(out) :: fsrv
2814 real (kind=kind_phys), intent(out) :: fsrg
2815 real (kind=kind_phys), intent(out) :: bgap
2816 real (kind=kind_phys), intent(out) :: wgap
2817 real (kind=kind_phys), dimension(1:2), intent(out) :: albsnd
2818 real (kind=kind_phys), dimension(1:2), intent(out) :: albsni
2819!jref:end
2820
2821! local
2822 real (kind=kind_phys) :: fage !snow age function (0 - new snow)
2823 real (kind=kind_phys), dimension(1:2) :: albgrd !ground albedo (direct)
2824 real (kind=kind_phys), dimension(1:2) :: albgri !ground albedo (diffuse)
2825 real (kind=kind_phys), dimension(1:2) :: albd !surface albedo (direct)
2826 real (kind=kind_phys), dimension(1:2) :: albi !surface albedo (diffuse)
2827 real (kind=kind_phys), dimension(1:2) :: fabd !flux abs by veg (per unit direct flux)
2828 real (kind=kind_phys), dimension(1:2) :: fabi !flux abs by veg (per unit diffuse flux)
2829 real (kind=kind_phys), dimension(1:2) :: ftdd !down direct flux below veg (per unit dir flux)
2830 real (kind=kind_phys), dimension(1:2) :: ftid !down diffuse flux below veg (per unit dir flux)
2831 real (kind=kind_phys), dimension(1:2) :: ftii !down diffuse flux below veg (per unit dif flux)
2832!jref:start
2833 real (kind=kind_phys), dimension(1:2) :: frevi
2834 real (kind=kind_phys), dimension(1:2) :: frevd
2835 real (kind=kind_phys), dimension(1:2) :: fregi
2836 real (kind=kind_phys), dimension(1:2) :: fregd
2837!jref:end
2838
2839 real (kind=kind_phys) :: fsha !shaded fraction of canopy
2840 real (kind=kind_phys) :: vai !total lai + stem area index, one sided
2841
2842 real (kind=kind_phys),parameter :: mpe = 1.e-6
2843 logical veg !true: vegetated for surface temperature calculation
2844
2845! --------------------------------------------------------------------------------------------------
2846
2847! surface abeldo
2848
2849 call albedo (parameters,vegtyp ,ist ,ice ,nsoil , & !in
2850 dt ,cosz ,fage ,elai ,esai , & !in
2851 tg ,tv ,snowh ,fsno ,fwet , & !in
2852 smc ,sneqvo ,sneqv ,qsnow ,fveg , & !in
2853 iloc ,jloc , & !in
2854 albold ,tauss , & !inout
2855 albgrd ,albgri ,albd ,albi ,fabd , & !out
2856 fabi ,ftdd ,ftid ,ftii ,fsun , & !) !out
2857 frevi ,frevd ,fregd ,fregi ,bgap , & !inout
2858 wgap ,albsnd ,albsni )
2859
2860! surface radiation
2861
2862 fsha = 1.-fsun
2863 laisun = elai*fsun
2864 laisha = elai*fsha
2865 vai = elai+ esai
2866 if (vai .gt. 0.) then
2867 veg = .true.
2868 else
2869 veg = .false.
2870 end if
2871
2872 call surrad (parameters,mpe ,fsun ,fsha ,elai ,vai , & !in
2873 laisun ,laisha ,solad ,solai ,fabd , & !in
2874 fabi ,ftdd ,ftid ,ftii ,albgrd , & !in
2875 albgri ,albd ,albi ,iloc ,jloc , & !in
2876 parsun ,parsha ,sav ,sag ,fsa , & !out
2877 fsr , & !out
2878 frevi ,frevd ,fregd ,fregi ,fsrv , & !inout
2879 fsrg)
2880
2881 end subroutine radiation
2882
2883!== begin albedo ===================================================================================
2884
2889 subroutine albedo (parameters,vegtyp ,ist ,ice ,nsoil , & !in
2890 dt ,cosz ,fage ,elai ,esai , & !in
2891 tg ,tv ,snowh ,fsno ,fwet , & !in
2892 smc ,sneqvo ,sneqv ,qsnow ,fveg , & !in
2893 iloc ,jloc , & !in
2894 albold ,tauss , & !inout
2895 albgrd ,albgri ,albd ,albi ,fabd , & !out
2896 fabi ,ftdd ,ftid ,ftii ,fsun , & !out
2897 frevi ,frevd ,fregd ,fregi ,bgap , & !out
2898 wgap ,albsnd ,albsni )
2899
2900! --------------------------------------------------------------------------------------------------
2901! surface albedos. also fluxes (per unit incoming direct and diffuse
2902! radiation) reflected, transmitted, and absorbed by vegetation.
2903! also sunlit fraction of the canopy.
2904! --------------------------------------------------------------------------------------------------
2905 implicit none
2906! --------------------------------------------------------------------------------------------------
2907! input
2908 type (noahmp_parameters), intent(in) :: parameters
2909 integer, intent(in) :: iloc
2910 integer, intent(in) :: jloc
2911 integer, intent(in) :: nsoil
2912 integer, intent(in) :: vegtyp
2913 integer, intent(in) :: ist
2914 integer, intent(in) :: ice
2915
2916 real (kind=kind_phys), intent(in) :: dt
2917 real (kind=kind_phys), intent(in) :: qsnow
2918 real (kind=kind_phys), intent(in) :: cosz
2919 real (kind=kind_phys), intent(in) :: snowh
2920 real (kind=kind_phys), intent(in) :: tg
2921 real (kind=kind_phys), intent(in) :: tv
2922 real (kind=kind_phys), intent(in) :: elai
2923 real (kind=kind_phys), intent(in) :: esai
2924 real (kind=kind_phys), intent(in) :: fsno
2925 real (kind=kind_phys), intent(in) :: fwet
2926 real (kind=kind_phys), intent(in) :: sneqvo
2927 real (kind=kind_phys), intent(in) :: sneqv
2928 real (kind=kind_phys), intent(in) :: fveg
2929 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: smc
2930
2931! inout
2932 real (kind=kind_phys), intent(inout) :: albold
2933 real (kind=kind_phys), intent(inout) :: tauss
2934
2935! output
2936 real (kind=kind_phys), dimension(1: 2), intent(out) :: albgrd
2937 real (kind=kind_phys), dimension(1: 2), intent(out) :: albgri
2938 real (kind=kind_phys), dimension(1: 2), intent(out) :: albd
2939 real (kind=kind_phys), dimension(1: 2), intent(out) :: albi
2940 real (kind=kind_phys), dimension(1: 2), intent(out) :: fabd
2941 real (kind=kind_phys), dimension(1: 2), intent(out) :: fabi
2942 real (kind=kind_phys), dimension(1: 2), intent(out) :: ftdd
2943 real (kind=kind_phys), dimension(1: 2), intent(out) :: ftid
2944 real (kind=kind_phys), dimension(1: 2), intent(out) :: ftii
2945 real (kind=kind_phys), intent(out) :: fsun
2946!jref:start
2947 real (kind=kind_phys), dimension(1: 2), intent(out) :: frevd
2948 real (kind=kind_phys), dimension(1: 2), intent(out) :: frevi
2949 real (kind=kind_phys), dimension(1: 2), intent(out) :: fregd
2950 real (kind=kind_phys), dimension(1: 2), intent(out) :: fregi
2951 real (kind=kind_phys), intent(out) :: bgap
2952 real (kind=kind_phys), intent(out) :: wgap
2953!jref:end
2954
2955! ------------------------------------------------------------------------
2956! ------------------------ local variables -------------------------------
2957! local
2958 real (kind=kind_phys) :: fage !snow age function
2959 real (kind=kind_phys) :: alb
2960 integer :: ib !indices
2961 integer :: nband !number of solar radiation wave bands
2962 integer :: ic !direct beam: ic=0; diffuse: ic=1
2963
2964 real (kind=kind_phys) :: wl !fraction of lai+sai that is lai
2965 real (kind=kind_phys) :: ws !fraction of lai+sai that is sai
2966 real (kind=kind_phys) :: mpe !prevents overflow for division by zero
2967
2968 real (kind=kind_phys), dimension(1:2) :: rho !leaf/stem reflectance weighted by fraction lai and sai
2969 real (kind=kind_phys), dimension(1:2) :: tau !leaf/stem transmittance weighted by fraction lai and sai
2970 real (kind=kind_phys), dimension(1:2) :: ftdi !down direct flux below veg per unit dif flux = 0
2971 real (kind=kind_phys), dimension(1:2) :: albsnd !snow albedo (direct)
2972 real (kind=kind_phys), dimension(1:2) :: albsni !snow albedo (diffuse)
2973
2974 real (kind=kind_phys) :: vai !elai+esai
2975 real (kind=kind_phys) :: gdir !average projected leaf/stem area in solar direction
2976 real (kind=kind_phys) :: ext !optical depth direct beam per unit leaf + stem area
2977
2978! --------------------------------------------------------------------------------------------------
2979
2980 nband = 2
2981 mpe = 1.e-06
2982 bgap = 0.
2983 wgap = 0.
2984 frevd = 0.
2985 frevi = 0.
2986 fregd = 0.
2987 fregi = 0.
2988
2989! initialize output because solar radiation only done if cosz > 0
2990
2991 do ib = 1, nband
2992 albd(ib) = 0.
2993 albi(ib) = 0.
2994 albgrd(ib) = 0.
2995 albgri(ib) = 0.
2996 albsnd(ib) = 0.
2997 albsni(ib) = 0.
2998 fabd(ib) = 0.
2999 fabi(ib) = 0.
3000 ftdd(ib) = 0.
3001 ftid(ib) = 0.
3002 ftii(ib) = 0.
3003 if (ib.eq.1) fsun = 0.
3004 end do
3005
3006 if(cosz <= 0) goto 100
3007
3008! weight reflectance/transmittance by lai and sai
3009
3010 do ib = 1, nband
3011 vai = elai + esai
3012 wl = elai / max(vai,mpe)
3013 ws = esai / max(vai,mpe)
3014 rho(ib) = max(parameters%rhol(ib)*wl+parameters%rhos(ib)*ws, mpe)
3015 tau(ib) = max(parameters%taul(ib)*wl+parameters%taus(ib)*ws, mpe)
3016 end do
3017
3018! snow age
3019
3020 call snow_age (parameters,dt,tg,sneqvo,sneqv,tauss,fage)
3021
3022! snow albedos: only if cosz > 0 and fsno > 0
3023
3024 if(opt_alb == 1) &
3025 call snowalb_bats (parameters,nband, fsno,cosz,fage,albsnd,albsni)
3026 if(opt_alb == 2) then
3027 call snowalb_class (parameters,nband,qsnow,dt,alb,albold,albsnd,albsni,iloc,jloc)
3028 albold = alb
3029 end if
3030
3031! ground surface albedo
3032
3033 call groundalb (parameters,nsoil ,nband ,ice ,ist , & !in
3034 fsno ,smc ,albsnd ,albsni ,cosz , & !in
3035 tg ,iloc ,jloc , & !in
3036 albgrd ,albgri ) !out
3037
3038! loop over nband wavebands to calculate surface albedos and solar
3039! fluxes for unit incoming direct (ic=0) and diffuse flux (ic=1)
3040
3041 do ib = 1, nband
3042 ic = 0 ! direct
3043 call twostream (parameters,ib ,ic ,vegtyp ,cosz ,vai , & !in
3044 fwet ,tv ,albgrd ,albgri ,rho , & !in
3045 tau ,fveg ,ist ,iloc ,jloc , & !in
3046 fabd ,albd ,ftdd ,ftid ,gdir , &!) !out
3047 frevd ,fregd ,bgap ,wgap)
3048
3049 ic = 1 ! diffuse
3050 call twostream (parameters,ib ,ic ,vegtyp ,cosz ,vai , & !in
3051 fwet ,tv ,albgrd ,albgri ,rho , & !in
3052 tau ,fveg ,ist ,iloc ,jloc , & !in
3053 fabi ,albi ,ftdi ,ftii ,gdir , & !) !out
3054 frevi ,fregi ,bgap ,wgap)
3055
3056 end do
3057
3058! sunlit fraction of canopy. set fsun = 0 if fsun < 0.01.
3059
3060 ext = gdir/cosz * sqrt(1.-rho(1)-tau(1))
3061 fsun = (1.-exp(-ext*vai)) / max(ext*vai,mpe)
3062 ext = fsun
3063
3064 if (ext .lt. 0.01) then
3065 wl = 0.
3066 else
3067 wl = ext
3068 end if
3069 fsun = wl
3070
3071100 continue
3072
3073 end subroutine albedo
3074
3075!== begin surrad ===================================================================================
3076
3079 subroutine surrad (parameters,mpe ,fsun ,fsha ,elai ,vai , & !in
3080 laisun ,laisha ,solad ,solai ,fabd , & !in
3081 fabi ,ftdd ,ftid ,ftii ,albgrd , & !in
3082 albgri ,albd ,albi ,iloc ,jloc , & !in
3083 parsun ,parsha ,sav ,sag ,fsa , & !out
3084 fsr , & !) !out
3085 frevi ,frevd ,fregd ,fregi ,fsrv , &
3086 fsrg) !inout
3087
3088! --------------------------------------------------------------------------------------------------
3089 implicit none
3090! --------------------------------------------------------------------------------------------------
3091! input
3092
3093 type (noahmp_parameters), intent(in) :: parameters
3094 integer, intent(in) :: iloc
3095 integer, intent(in) :: jloc
3096 real (kind=kind_phys), intent(in) :: mpe
3097
3098 real (kind=kind_phys), intent(in) :: fsun
3099 real (kind=kind_phys), intent(in) :: fsha
3100 real (kind=kind_phys), intent(in) :: elai
3101 real (kind=kind_phys), intent(in) :: vai
3102 real (kind=kind_phys), intent(in) :: laisun
3103 real (kind=kind_phys), intent(in) :: laisha
3104
3105 real (kind=kind_phys), dimension(1:2), intent(in) :: solad
3106 real (kind=kind_phys), dimension(1:2), intent(in) :: solai
3107 real (kind=kind_phys), dimension(1:2), intent(in) :: fabd
3108 real (kind=kind_phys), dimension(1:2), intent(in) :: fabi
3109 real (kind=kind_phys), dimension(1:2), intent(in) :: ftdd
3110 real (kind=kind_phys), dimension(1:2), intent(in) :: ftid
3111 real (kind=kind_phys), dimension(1:2), intent(in) :: ftii
3112 real (kind=kind_phys), dimension(1:2), intent(in) :: albgrd
3113 real (kind=kind_phys), dimension(1:2), intent(in) :: albgri
3114 real (kind=kind_phys), dimension(1:2), intent(in) :: albd
3115 real (kind=kind_phys), dimension(1:2), intent(in) :: albi
3116
3117 real (kind=kind_phys), dimension(1:2), intent(in) :: frevd
3118 real (kind=kind_phys), dimension(1:2), intent(in) :: frevi
3119 real (kind=kind_phys), dimension(1:2), intent(in) :: fregd
3120 real (kind=kind_phys), dimension(1:2), intent(in) :: fregi
3121
3122! output
3123
3124 real (kind=kind_phys), intent(out) :: parsun
3125 real (kind=kind_phys), intent(out) :: parsha
3126 real (kind=kind_phys), intent(out) :: sav
3127 real (kind=kind_phys), intent(out) :: sag
3128 real (kind=kind_phys), intent(out) :: fsa
3129 real (kind=kind_phys), intent(out) :: fsr
3130 real (kind=kind_phys), intent(out) :: fsrv
3131 real (kind=kind_phys), intent(out) :: fsrg
3132
3133! ------------------------ local variables ----------------------------------------------------
3134 integer :: ib !waveband number (1=vis, 2=nir)
3135 integer :: nband !number of solar radiation waveband classes
3136
3137 real (kind=kind_phys) :: abs !absorbed solar radiation (w/m2)
3138 real (kind=kind_phys) :: rnir !reflected solar radiation [nir] (w/m2)
3139 real (kind=kind_phys) :: rvis !reflected solar radiation [vis] (w/m2)
3140 real (kind=kind_phys) :: laifra !leaf area fraction of canopy
3141 real (kind=kind_phys) :: trd !transmitted solar radiation: direct (w/m2)
3142 real (kind=kind_phys) :: tri !transmitted solar radiation: diffuse (w/m2)
3143 real (kind=kind_phys), dimension(1:2) :: cad !direct beam absorbed by canopy (w/m2)
3144 real (kind=kind_phys), dimension(1:2) :: cai !diffuse radiation absorbed by canopy (w/m2)
3145! ---------------------------------------------------------------------------------------------
3146 nband = 2
3147
3148! zero summed solar fluxes
3149
3150 sag = 0.
3151 sav = 0.
3152 fsa = 0.
3153
3154! loop over nband wavebands
3155
3156 do ib = 1, nband
3157
3158! absorbed by canopy
3159
3160 cad(ib) = solad(ib)*fabd(ib)
3161 cai(ib) = solai(ib)*fabi(ib)
3162 sav = sav + cad(ib) + cai(ib)
3163 fsa = fsa + cad(ib) + cai(ib)
3164
3165! transmitted solar fluxes incident on ground
3166
3167 trd = solad(ib)*ftdd(ib)
3168 tri = solad(ib)*ftid(ib) + solai(ib)*ftii(ib)
3169
3170! solar radiation absorbed by ground surface
3171
3172 abs = trd*(1.-albgrd(ib)) + tri*(1.-albgri(ib))
3173 sag = sag + abs
3174 fsa = fsa + abs
3175 end do
3176
3177! partition visible canopy absorption to sunlit and shaded fractions
3178! to get average absorbed par for sunlit and shaded leaves
3179
3180 laifra = elai / max(vai,mpe)
3181 if (fsun .gt. 0.) then
3182 parsun = (cad(1)+fsun*cai(1)) * laifra / max(laisun,mpe)
3183 parsha = (fsha*cai(1))*laifra / max(laisha,mpe)
3184 else
3185 parsun = 0.
3186 parsha = (cad(1)+cai(1))*laifra /max(laisha,mpe)
3187 endif
3188
3189! reflected solar radiation
3190
3191 rvis = albd(1)*solad(1) + albi(1)*solai(1)
3192 rnir = albd(2)*solad(2) + albi(2)*solai(2)
3193 fsr = rvis + rnir
3194
3195! reflected solar radiation of veg. and ground (combined ground)
3196 fsrv = frevd(1)*solad(1)+frevi(1)*solai(1)+frevd(2)*solad(2)+frevi(2)*solai(2)
3197 fsrg = fregd(1)*solad(1)+fregi(1)*solai(1)+fregd(2)*solad(2)+fregi(2)*solai(2)
3198
3199
3200 end subroutine surrad
3201
3202!== begin snow_age =================================================================================
3203
3206 subroutine snow_age (parameters,dt,tg,sneqvo,sneqv,tauss,fage)
3207! ----------------------------------------------------------------------
3208 implicit none
3209! ------------------------ code history ------------------------------------------------------------
3210! from bats
3211! ------------------------ input/output variables --------------------------------------------------
3212!input
3213 type (noahmp_parameters), intent(in) :: parameters
3214 real (kind=kind_phys), intent(in) :: dt
3215 real (kind=kind_phys), intent(in) :: tg
3216 real (kind=kind_phys), intent(in) :: sneqvo
3217 real (kind=kind_phys), intent(in) :: sneqv
3218
3219!output
3220 real (kind=kind_phys), intent(out) :: fage
3221
3222!input/output
3223 real (kind=kind_phys), intent(inout) :: tauss
3224!local
3225 real (kind=kind_phys) :: tage !total aging effects
3226 real (kind=kind_phys) :: age1 !effects of grain growth due to vapor diffusion
3227 real (kind=kind_phys) :: age2 !effects of grain growth at freezing of melt water
3228 real (kind=kind_phys) :: age3 !effects of soot
3229 real (kind=kind_phys) :: dela !temporary variable
3230 real (kind=kind_phys) :: sge !temporary variable
3231 real (kind=kind_phys) :: dels !temporary variable
3232 real (kind=kind_phys) :: dela0 !temporary variable
3233 real (kind=kind_phys) :: arg !temporary variable
3234! see yang et al. (1997) j.of climate for detail.
3235!---------------------------------------------------------------------------------------------------
3236
3237 if(sneqv.le.0.0) then
3238 tauss = 0.
3239 else
3240 dela0 = dt/parameters%tau0
3241 arg = parameters%grain_growth*(1./tfrz-1./tg)
3242 age1 = exp(arg)
3243 age2 = exp(amin1(0.,parameters%extra_growth*arg))
3244 age3 = parameters%dirt_soot
3245 tage = age1+age2+age3
3246 dela = dela0*tage
3247 dels = amax1(0.0,sneqv-sneqvo) / parameters%swemx
3248 sge = (tauss+dela)*(1.0-dels)
3249 tauss = amax1(0.,sge)
3250 endif
3251
3252 fage= tauss/(tauss+1.)
3253
3254 end subroutine snow_age
3255
3256!== begin snowalb_bats =============================================================================
3257
3260 subroutine snowalb_bats (parameters,nband,fsno,cosz,fage,albsnd,albsni)
3261! --------------------------------------------------------------------------------------------------
3262 implicit none
3263! --------------------------------------------------------------------------------------------------
3264! input
3265
3266 type (noahmp_parameters), intent(in) :: parameters
3267 integer,intent(in) :: nband
3268
3269 real (kind=kind_phys),intent(in) :: cosz
3270 real (kind=kind_phys),intent(in) :: fsno
3271 real (kind=kind_phys),intent(in) :: fage
3272
3273! output
3274
3275 real (kind=kind_phys), dimension(1:2),intent(out) :: albsnd
3276 real (kind=kind_phys), dimension(1:2),intent(out) :: albsni
3277! ---------------------------------------------------------------------------------------------
3278
3279! ------------------------ local variables ----------------------------------------------------
3280 integer :: ib !waveband class
3281
3282 real (kind=kind_phys) :: fzen !zenith angle correction
3283 real (kind=kind_phys) :: cf1 !temperary variable
3284 real (kind=kind_phys) :: sl2 !2.*sl
3285 real (kind=kind_phys) :: sl1 !1/sl
3286 real (kind=kind_phys) :: sl !adjustable parameter
3287! real (kind=kind_phys), parameter :: c1 = 0.2 !default in bats
3288! real (kind=kind_phys), parameter :: c2 = 0.5 !default in bats
3289! real (kind=kind_phys), parameter :: c1 = 0.2 * 2. ! double the default to match sleepers river's
3290! real (kind=kind_phys), parameter :: c2 = 0.5 * 2. ! snow surface albedo (double aging effects)
3291! ---------------------------------------------------------------------------------------------
3292! zero albedos for all points
3293
3294 albsnd(1: nband) = 0.
3295 albsni(1: nband) = 0.
3296
3297! when cosz > 0
3298
3299 sl=parameters%bats_cosz
3300 sl1=1./sl
3301 sl2=2.*sl
3302 cf1=((1.+sl1)/(1.+sl2*cosz)-sl1)
3303 fzen=amax1(cf1,0.)
3304
3305 albsni(1)=parameters%bats_vis_new*(1.-parameters%bats_vis_age*fage)
3306 albsni(2)=parameters%bats_nir_new*(1.-parameters%bats_nir_age*fage)
3307
3308 albsnd(1)=albsni(1)+parameters%bats_vis_dir*fzen*(1.-albsni(1)) ! vis direct
3309 albsnd(2)=albsni(2)+parameters%bats_vis_dir*fzen*(1.-albsni(2)) ! nir direct
3310
3311 end subroutine snowalb_bats
3312
3313!== begin snowalb_class ============================================================================
3314
3317 subroutine snowalb_class (parameters,nband,qsnow,dt,alb,albold,albsnd,albsni,iloc,jloc)
3318! ----------------------------------------------------------------------
3319 implicit none
3320! --------------------------------------------------------------------------------------------------
3321! input
3322
3323 type (noahmp_parameters), intent(in) :: parameters
3324 integer,intent(in) :: iloc
3325 integer,intent(in) :: jloc
3326 integer,intent(in) :: nband
3327
3328 real (kind=kind_phys),intent(in) :: qsnow
3329 real (kind=kind_phys),intent(in) :: dt
3330 real (kind=kind_phys),intent(in) :: albold
3331
3332! in & out
3333
3334 real (kind=kind_phys), intent(inout) :: alb
3335! output
3336
3337 real (kind=kind_phys), dimension(1:2),intent(out) :: albsnd
3338 real (kind=kind_phys), dimension(1:2),intent(out) :: albsni
3339! ---------------------------------------------------------------------------------------------
3340
3341! ------------------------ local variables ----------------------------------------------------
3342 integer :: ib !waveband class
3343
3344! ---------------------------------------------------------------------------------------------
3345! zero albedos for all points
3346
3347 albsnd(1: nband) = 0.
3348 albsni(1: nband) = 0.
3349
3350! when cosz > 0
3351
3352 alb = 0.55 + (albold-0.55) * exp(-0.01*dt/3600.)
3353
3354! 1 mm fresh snow(swe) -- 10mm snow depth, assumed the fresh snow density 100kg/m3
3355! here assume 1cm snow depth will fully cover the old snow
3356
3357 if (qsnow > 0.) then
3358 alb = alb + min(qsnow,parameters%swemx/dt) * (0.84-alb)/(parameters%swemx/dt)
3359 endif
3360
3361 albsni(1)= alb ! vis diffuse
3362 albsni(2)= alb ! nir diffuse
3363 albsnd(1)= alb ! vis direct
3364 albsnd(2)= alb ! nir direct
3365
3366 end subroutine snowalb_class
3367
3368!== begin groundalb ================================================================================
3369
3372 subroutine groundalb (parameters,nsoil ,nband ,ice ,ist , & !in
3373 fsno ,smc ,albsnd ,albsni ,cosz , & !in
3374 tg ,iloc ,jloc , & !in
3375 albgrd ,albgri ) !out
3376! --------------------------------------------------------------------------------------------------
3377 implicit none
3378! --------------------------------------------------------------------------------------------------
3379!input
3380
3381 type (noahmp_parameters), intent(in) :: parameters
3382 integer, intent(in) :: iloc
3383 integer, intent(in) :: jloc
3384 integer, intent(in) :: nsoil
3385 integer, intent(in) :: nband
3386 integer, intent(in) :: ice
3387 integer, intent(in) :: ist
3388 real (kind=kind_phys), intent(in) :: fsno
3389 real (kind=kind_phys), intent(in) :: tg
3390 real (kind=kind_phys), intent(in) :: cosz
3391 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: smc
3392 real (kind=kind_phys), dimension(1: 2), intent(in) :: albsnd
3393 real (kind=kind_phys), dimension(1: 2), intent(in) :: albsni
3394
3395!output
3396
3397 real (kind=kind_phys), dimension(1: 2), intent(out) :: albgrd
3398 real (kind=kind_phys), dimension(1: 2), intent(out) :: albgri
3399
3400!local
3401
3402 integer :: ib !waveband number (1=vis, 2=nir)
3403 real (kind=kind_phys) :: inc !soil water correction factor for soil albedo
3404 real (kind=kind_phys) :: albsod !soil albedo (direct)
3405 real (kind=kind_phys) :: albsoi !soil albedo (diffuse)
3406! --------------------------------------------------------------------------------------------------
3407
3408 do ib = 1, nband
3409 inc = max(0.11-0.40*smc(1), 0.)
3410 if (ist .eq. 1) then !soil
3411 albsod = min(parameters%albsat(ib)+inc,parameters%albdry(ib))
3412 albsoi = albsod
3413 else if (tg .gt. tfrz) then !unfrozen lake, wetland
3414 albsod = 0.06/(max(0.01,cosz)**1.7 + 0.15)
3415 albsoi = 0.06
3416 else !frozen lake, wetland
3417 albsod = parameters%alblak(ib)
3418 albsoi = albsod
3419 end if
3420
3421! increase desert and semi-desert albedos
3422
3423! if (ist .eq. 1 .and. isc .eq. 9) then
3424! albsod = albsod + 0.10
3425! albsoi = albsoi + 0.10
3426! end if
3427
3428 albgrd(ib) = albsod*(1.-fsno) + albsnd(ib)*fsno
3429 albgri(ib) = albsoi*(1.-fsno) + albsni(ib)*fsno
3430 end do
3431
3432 end subroutine groundalb
3433
3434!== begin twostream ================================================================================
3435
3442 subroutine twostream (parameters,ib ,ic ,vegtyp ,cosz ,vai , & !in
3443 fwet ,t ,albgrd ,albgri ,rho , & !in
3444 tau ,fveg ,ist ,iloc ,jloc , & !in
3445 fab ,fre ,ftd ,fti ,gdir , & !) !out
3446 frev ,freg ,bgap ,wgap)
3447
3448! --------------------------------------------------------------------------------------------------
3449! use two-stream approximation of dickinson (1983) adv geophysics
3450! 25:305-353 and sellers (1985) int j remote sensing 6:1335-1372
3451! to calculate fluxes absorbed by vegetation, reflected by vegetation,
3452! and transmitted through vegetation for unit incoming direct or diffuse
3453! flux given an underlying surface with known albedo.
3454! --------------------------------------------------------------------------------------------------
3455 implicit none
3456! --------------------------------------------------------------------------------------------------
3457! input
3458
3459 type (noahmp_parameters), intent(in) :: parameters
3460 integer, intent(in) :: iloc
3461 integer, intent(in) :: jloc
3462 integer, intent(in) :: ist
3463 integer, intent(in) :: ib
3464 integer, intent(in) :: ic
3465 integer, intent(in) :: vegtyp
3466
3467 real (kind=kind_phys), intent(in) :: cosz
3468 real (kind=kind_phys), intent(in) :: vai
3469 real (kind=kind_phys), intent(in) :: fwet
3470 real (kind=kind_phys), intent(in) :: t
3471
3472 real (kind=kind_phys), dimension(1:2), intent(in) :: albgrd
3473 real (kind=kind_phys), dimension(1:2), intent(in) :: albgri
3474 real (kind=kind_phys), dimension(1:2), intent(in) :: rho
3475 real (kind=kind_phys), dimension(1:2), intent(in) :: tau
3476 real (kind=kind_phys), intent(in) :: fveg
3477
3478! output
3479
3480 real (kind=kind_phys), dimension(1:2), intent(out) :: fab
3481 real (kind=kind_phys), dimension(1:2), intent(out) :: fre
3482 real (kind=kind_phys), dimension(1:2), intent(out) :: ftd
3483 real (kind=kind_phys), dimension(1:2), intent(out) :: fti
3484 real (kind=kind_phys), intent(out) :: gdir
3485 real (kind=kind_phys), dimension(1:2), intent(out) :: frev
3486 real (kind=kind_phys), dimension(1:2), intent(out) :: freg
3487
3488! local
3489 real (kind=kind_phys) :: omega !fraction of intercepted radiation that is scattered
3490 real (kind=kind_phys) :: omegal !omega for leaves
3491 real (kind=kind_phys) :: betai !upscatter parameter for diffuse radiation
3492 real (kind=kind_phys) :: betail !betai for leaves
3493 real (kind=kind_phys) :: betad !upscatter parameter for direct beam radiation
3494 real (kind=kind_phys) :: betadl !betad for leaves
3495 real (kind=kind_phys) :: ext !optical depth of direct beam per unit leaf area
3496 real (kind=kind_phys) :: avmu !average diffuse optical depth
3497
3498 real (kind=kind_phys) :: coszi !0.001 <= cosz <= 1.000
3499 real (kind=kind_phys) :: asu !single scattering albedo
3500 real (kind=kind_phys) :: chil ! -0.4 <= xl <= 0.6
3501
3502 real (kind=kind_phys) :: tmp0,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,tmp7,tmp8,tmp9
3503 real (kind=kind_phys) :: p1,p2,p3,p4,s1,s2,u1,u2,u3
3504 real (kind=kind_phys) :: b,c,d,d1,d2,f,h,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10
3505 real (kind=kind_phys) :: phi1,phi2,sigma
3506 real (kind=kind_phys) :: ftds,ftis,fres
3507 real (kind=kind_phys) :: denfveg
3508 real (kind=kind_phys) :: vai_spread
3509!jref:start
3510 real (kind=kind_phys) :: freveg,frebar,ftdveg,ftiveg,ftdbar,ftibar
3511 real (kind=kind_phys) :: thetaz
3512!jref:end
3513
3514! variables for the modified two-stream scheme
3515! niu and yang (2004), jgr
3516
3517 real (kind=kind_phys), parameter :: pai = 3.14159265
3518 real (kind=kind_phys) :: hd !crown depth (m)
3519 real (kind=kind_phys) :: bb !vertical crown radius (m)
3520 real (kind=kind_phys) :: thetap !angle conversion from sza
3521 real (kind=kind_phys) :: fa !foliage volume density (m-1)
3522 real (kind=kind_phys) :: newvai !effective lsai (-)
3523
3524 real (kind=kind_phys),intent(inout) :: bgap !between canopy gap fraction for beam (-)
3525 real (kind=kind_phys),intent(inout) :: wgap !within canopy gap fraction for beam (-)
3526
3527 real (kind=kind_phys) :: kopen !gap fraction for diffue light (-)
3528 real (kind=kind_phys) :: gap !total gap fraction for beam ( <=1-shafac )
3529
3530! -----------------------------------------------------------------
3531! compute within and between gaps
3532 vai_spread = vai
3533 if(vai == 0.0) then
3534 gap = 1.0
3535 kopen = 1.0
3536 else
3537 if(opt_rad == 1) then
3538 denfveg = -log(max(1.0-fveg,0.01))/(pai*parameters%rc**2)
3539 hd = parameters%hvt - parameters%hvb
3540 bb = 0.5 * hd
3541 thetap = atan(bb/parameters%rc * tan(acos(max(0.01,cosz))) )
3542 ! bgap = exp(-parameters%den * pai * parameters%rc**2/cos(thetap) )
3543 bgap = exp(-denfveg * pai * parameters%rc**2/cos(thetap) )
3544 fa = vai/(1.33 * pai * parameters%rc**3.0 *(bb/parameters%rc)*denfveg)
3545 newvai = hd*fa
3546 wgap = (1.0-bgap) * exp(-0.5*newvai/cosz)
3547 gap = min(1.0-fveg, bgap+wgap)
3548
3549 kopen = 0.05
3550 end if
3551
3552 if(opt_rad == 2) then
3553 gap = 0.0
3554 kopen = 0.0
3555 end if
3556
3557 if(opt_rad == 3) then
3558 gap = 1.0-fveg
3559 kopen = 1.0-fveg
3560 end if
3561 end if
3562
3563! calculate two-stream parameters omega, betad, betai, avmu, gdir, ext.
3564! omega, betad, betai are adjusted for snow. values for omega*betad
3565! and omega*betai are calculated and then divided by the new omega
3566! because the product omega*betai, omega*betad is used in solution.
3567! also, the transmittances and reflectances (tau, rho) are linear
3568! weights of leaf and stem values.
3569
3570 coszi = max(0.001, cosz)
3571 chil = min( max(parameters%xl, -0.4), 0.6)
3572 if (abs(chil) .le. 0.01) chil = 0.01
3573 phi1 = 0.5 - 0.633*chil - 0.330*chil*chil
3574 phi2 = 0.877 * (1.-2.*phi1)
3575 gdir = phi1 + phi2*coszi
3576 ext = gdir/coszi
3577 avmu = ( 1. - phi1/phi2 * log((phi1+phi2)/phi1) ) / phi2
3578 omegal = rho(ib) + tau(ib)
3579 tmp0 = gdir + phi2*coszi
3580 tmp1 = phi1*coszi
3581 asu = 0.5*omegal*gdir/tmp0 * ( 1.-tmp1/tmp0*log((tmp1+tmp0)/tmp1) )
3582 betadl = (1.+avmu*ext)/(omegal*avmu*ext)*asu
3583 betail = 0.5 * ( rho(ib)+tau(ib) + (rho(ib)-tau(ib)) &
3584 * ((1.+chil)/2.)**2 ) / omegal
3585
3586! adjust omega, betad, and betai for intercepted snow
3587
3588 if (t .gt. tfrz) then !no snow
3589 tmp0 = omegal
3590 tmp1 = betadl
3591 tmp2 = betail
3592 else
3593 tmp0 = (1.-fwet)*omegal + fwet*parameters%omegas(ib)
3594 tmp1 = ( (1.-fwet)*omegal*betadl + fwet*parameters%omegas(ib)*parameters%betads ) / tmp0
3595 tmp2 = ( (1.-fwet)*omegal*betail + fwet*parameters%omegas(ib)*parameters%betais ) / tmp0
3596 end if
3597
3598 omega = tmp0
3599 betad = tmp1
3600 betai = tmp2
3601
3602! absorbed, reflected, transmitted fluxes per unit incoming radiation
3603
3604 b = 1. - omega + omega*betai
3605 c = omega*betai
3606 tmp0 = avmu*ext
3607 d = tmp0 * omega*betad
3608 f = tmp0 * omega*(1.-betad)
3609 tmp1 = b*b - c*c
3610 h = sqrt(tmp1) / avmu
3611 sigma = tmp0*tmp0 - tmp1
3612 if ( abs(sigma) < 1.e-6 ) sigma = sign(1.e-6_kind_phys,sigma)
3613 p1 = b + avmu*h
3614 p2 = b - avmu*h
3615 p3 = b + tmp0
3616 p4 = b - tmp0
3617 s1 = exp(-h*vai)
3618 s2 = exp(-ext*vai)
3619 if (ic .eq. 0) then
3620 u1 = b - c/albgrd(ib)
3621 u2 = b - c*albgrd(ib)
3622 u3 = f + c*albgrd(ib)
3623 else
3624 u1 = b - c/albgri(ib)
3625 u2 = b - c*albgri(ib)
3626 u3 = f + c*albgri(ib)
3627 end if
3628 tmp2 = u1 - avmu*h
3629 tmp3 = u1 + avmu*h
3630 d1 = p1*tmp2/s1 - p2*tmp3*s1
3631 tmp4 = u2 + avmu*h
3632 tmp5 = u2 - avmu*h
3633 d2 = tmp4/s1 - tmp5*s1
3634 h1 = -d*p4 - c*f
3635 tmp6 = d - h1*p3/sigma
3636 tmp7 = ( d - c - h1/sigma*(u1+tmp0) ) * s2
3637 h2 = ( tmp6*tmp2/s1 - p2*tmp7 ) / d1
3638 h3 = - ( tmp6*tmp3*s1 - p1*tmp7 ) / d1
3639 h4 = -f*p3 - c*d
3640 tmp8 = h4/sigma
3641 tmp9 = ( u3 - tmp8*(u2-tmp0) ) * s2
3642 h5 = - ( tmp8*tmp4/s1 + tmp9 ) / d2
3643 h6 = ( tmp8*tmp5*s1 + tmp9 ) / d2
3644 h7 = (c*tmp2) / (d1*s1)
3645 h8 = (-c*tmp3*s1) / d1
3646 h9 = tmp4 / (d2*s1)
3647 h10 = (-tmp5*s1) / d2
3648
3649! downward direct and diffuse fluxes below vegetation
3650! niu and yang (2004), jgr.
3651
3652 if (ic .eq. 0) then
3653 ftds = s2 *(1.0-gap) + gap
3654 ftis = (h4*s2/sigma + h5*s1 + h6/s1)*(1.0-gap)
3655 else
3656 ftds = 0.
3657 ftis = (h9*s1 + h10/s1)*(1.0-kopen) + kopen
3658 end if
3659 ftd(ib) = ftds
3660 fti(ib) = ftis
3661
3662! flux reflected by the surface (veg. and ground)
3663
3664 if (ic .eq. 0) then
3665 fres = (h1/sigma + h2 + h3)*(1.0-gap ) + albgrd(ib)*gap
3666 freveg = (h1/sigma + h2 + h3)*(1.0-gap )
3667 frebar = albgrd(ib)*gap !jref - separate veg. and ground reflection
3668 else
3669 fres = (h7 + h8) *(1.0-kopen) + albgri(ib)*kopen
3670 freveg = (h7 + h8) *(1.0-kopen) + albgri(ib)*kopen
3671 frebar = 0 !jref - separate veg. and ground reflection
3672 end if
3673 fre(ib) = fres
3674
3675 frev(ib) = freveg
3676 freg(ib) = frebar
3677! flux absorbed by vegetation
3678
3679 fab(ib) = 1. - fre(ib) - (1.-albgrd(ib))*ftd(ib) &
3680 - (1.-albgri(ib))*fti(ib)
3681
3682!if(iloc == 1.and.jloc == 2) then
3683! write(*,'(a7,2i2,5(a6,f8.4),2(a9,f8.4))') "ib,ic: ",ib,ic," gap: ",gap," ftd: ",ftd(ib)," fti: ",fti(ib)," fre: ", &
3684! fre(ib)," fab: ",fab(ib)," albgrd: ",albgrd(ib)," albgri: ",albgri(ib)
3685!end if
3686
3687 end subroutine twostream
3688
3689!== begin vege_flux ================================================================================
3690
3694 subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & !in
3695 dt ,sav ,sag ,lwdn ,ur , & !in
3696 uu ,vv ,sfctmp ,thair ,qair , & !in
3697 eair ,rhoair ,snowh ,vai ,gammav ,gammag, & !in
3698 fwet ,laisun ,laisha ,cwp ,dzsnso , & !in
3699 zlvl ,zpd ,z0m ,fveg ,shdfac, & !in
3700 z0mg ,emv ,emg ,canliq ,fsno, & !in
3701 canice ,stc ,df ,rssun ,rssha , & !in
3702 rsurf ,latheav ,latheag ,parsun ,parsha ,igs , & !in
3703 foln ,co2air ,o2air ,btran ,sfcprs , & !in
3704 rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in
3705 thsfc_loc, prslkix,prsik1x,prslk1x, garea1, & !in
3706 pblhx ,iz0tlnd ,itime ,psi_opt ,ep_1, ep_2, epsm1, cp, &
3707 eah ,tah ,tv ,tg ,cm,ustarx,& !inout
3708#ifdef CCPP
3709 ch ,dx ,dz8w ,errmsg ,errflg , & !inout
3710#else
3711 ch ,dx ,dz8w , & !inout
3712#endif
3713 tauxv ,tauyv ,irg ,irc ,shg , & !out
3714 shc ,evg ,evc ,tr ,gh , & !out
3715 t2mv ,psnsun ,psnsha ,canhs , & !out
3716 csigmaf1, & !out
3717 qc ,qsfc ,psfc , & !in
3718 q2v ,cah2 ,chleaf ,chuc , & !inout
3719 rb) !out
3720
3721! --------------------------------------------------------------------------------------------------
3722! use newton-raphson iteration to solve for vegetation (tv) and
3723! ground (tg) temperatures that balance the surface energy budgets
3724
3725! vegetated:
3726! -sav + irc[tv] + shc[tv] + evc[tv] + tr[tv] + canhs[tv] = 0
3727! -sag + irg[tg] + shg[tg] + evg[tg] + gh[tg] = 0
3728! --------------------------------------------------------------------------------------------------
3729 use funcphys, only : fpvs
3730 implicit none
3731! --------------------------------------------------------------------------------------------------
3732! input
3733 type (noahmp_parameters), intent(in) :: parameters
3734 integer, intent(in) :: iloc
3735 integer, intent(in) :: jloc
3736 logical, intent(in) :: veg
3737 integer, intent(in) :: nsnow
3738 integer, intent(in) :: nsoil
3739 integer, intent(in) :: isnow
3740 integer, intent(in) :: vegtyp
3741 real (kind=kind_phys), intent(in) :: fveg
3742 real (kind=kind_phys), intent(in) :: sav
3743 real (kind=kind_phys), intent(in) :: sag
3744 real (kind=kind_phys), intent(in) :: lwdn
3745 real (kind=kind_phys), intent(in) :: ur
3746 real (kind=kind_phys), intent(in) :: uu
3747 real (kind=kind_phys), intent(in) :: vv
3748 real (kind=kind_phys), intent(in) :: sfctmp
3749 real (kind=kind_phys), intent(in) :: thair
3750 real (kind=kind_phys), intent(in) :: eair
3751 real (kind=kind_phys), intent(in) :: qair
3752 real (kind=kind_phys), intent(in) :: rhoair
3753 real (kind=kind_phys), intent(in) :: dt
3754 real (kind=kind_phys), intent(in) :: fsno
3755
3756 real (kind=kind_phys) , intent(in) :: pblhx
3757 real (kind=kind_phys) , intent(in) :: ep_1
3758 real (kind=kind_phys) , intent(in) :: ep_2
3759 real (kind=kind_phys) , intent(in) :: epsm1
3760 real (kind=kind_phys) , intent(in) :: cp
3761 integer , intent(in) :: iz0tlnd
3762 integer , intent(in) :: itime
3763 integer , intent(in) :: psi_opt
3764
3765
3766 real (kind=kind_phys), intent(in) :: snowh
3767 real (kind=kind_phys), intent(in) :: fwet
3768 real (kind=kind_phys), intent(in) :: cwp
3769
3770 real (kind=kind_phys), intent(in) :: vai
3771 real (kind=kind_phys), intent(in) :: laisun
3772 real (kind=kind_phys), intent(in) :: laisha
3773 real (kind=kind_phys), intent(in) :: zlvl
3774 real (kind=kind_phys), intent(in) :: zpd
3775 real (kind=kind_phys), intent(in) :: z0m
3776 real (kind=kind_phys), intent(in) :: z0mg
3777 real (kind=kind_phys), intent(in) :: emv
3778 real (kind=kind_phys), intent(in) :: emg
3779
3780 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc
3781 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: df
3782 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
3783 real (kind=kind_phys), intent(in) :: canliq
3784 real (kind=kind_phys), intent(in) :: canice
3785 real (kind=kind_phys), intent(in) :: rsurf
3786! real (kind=kind_phys), intent(in) :: gamma !< psychrometric constant (pa/k)
3787! real (kind=kind_phys), intent(in) :: lathea !< latent heat of vaporization/subli (j/kg)
3788 real (kind=kind_phys), intent(in) :: gammav
3789 real (kind=kind_phys), intent(in) :: latheav
3790 real (kind=kind_phys), intent(in) :: gammag
3791 real (kind=kind_phys), intent(in) :: latheag
3792 real (kind=kind_phys), intent(in) :: parsun
3793 real (kind=kind_phys), intent(in) :: parsha
3794 real (kind=kind_phys), intent(in) :: foln
3795 real (kind=kind_phys), intent(in) :: co2air
3796 real (kind=kind_phys), intent(in) :: o2air
3797 real (kind=kind_phys), intent(in) :: igs
3798 real (kind=kind_phys), intent(in) :: sfcprs
3799 real (kind=kind_phys), intent(in) :: btran
3800 real (kind=kind_phys), intent(in) :: rhsur
3801
3802 real (kind=kind_phys) , intent(in) :: qc
3803 real (kind=kind_phys) , intent(in) :: psfc
3804 real (kind=kind_phys) , intent(in) :: dx
3805 real (kind=kind_phys) , intent(in) :: q2
3806 real (kind=kind_phys) , intent(in) :: dz8w
3807 real (kind=kind_phys) , intent(inout) :: qsfc
3808 real (kind=kind_phys), intent(in) :: pahv
3809 real (kind=kind_phys), intent(in) :: pahg
3810
3811! input/output
3812 real (kind=kind_phys), intent(inout) :: eah
3813 real (kind=kind_phys), intent(inout) :: tah
3814 real (kind=kind_phys), intent(inout) :: tv
3815 real (kind=kind_phys), intent(inout) :: tg
3816 real (kind=kind_phys), intent(inout) :: cm
3817 real (kind=kind_phys), intent(inout) :: ch
3818
3819#ifdef CCPP
3820 character(len=*), intent(inout) :: errmsg
3821 integer, intent(inout) :: errflg
3822#endif
3823
3824! output
3825! -fsa + fira + fsh + (fcev + fctr + fgev) + fcst + ssoil + canhs = 0
3826 real (kind=kind_phys), intent(out) :: tauxv
3827 real (kind=kind_phys), intent(out) :: tauyv
3828 real (kind=kind_phys), intent(out) :: irc
3829 real (kind=kind_phys), intent(out) :: shc
3830 real (kind=kind_phys), intent(out) :: evc
3831 real (kind=kind_phys), intent(out) :: irg
3832 real (kind=kind_phys), intent(out) :: shg
3833 real (kind=kind_phys), intent(out) :: evg
3834 real (kind=kind_phys), intent(out) :: tr
3835 real (kind=kind_phys), intent(out) :: gh
3836 real (kind=kind_phys), intent(out) :: t2mv
3837 real (kind=kind_phys), intent(out) :: psnsun
3838 real (kind=kind_phys), intent(out) :: psnsha
3839 real (kind=kind_phys), intent(out) :: chleaf
3840 real (kind=kind_phys), intent(out) :: chuc
3841 real (kind=kind_phys), intent(out) :: canhs
3842 real (kind=kind_phys), intent(out) :: q2v
3843 real (kind=kind_phys), intent(out) :: rb
3844 real (kind=kind_phys) :: cah
3845 real (kind=kind_phys) :: u10v
3846 real (kind=kind_phys) :: v10v
3847 real (kind=kind_phys) :: wspd
3848
3849! ------------------------ local variables ----------------------------------------------------
3850 real (kind=kind_phys) :: gdx !grid dx
3851 real (kind=kind_phys) :: snwd ! snowdepth in mm
3852 integer :: mnice ! MYNN ice flag
3853
3854 real (kind=kind_phys) :: cw !water vapor exchange coefficient
3855 real (kind=kind_phys) :: fv !friction velocity (m/s)
3856 real (kind=kind_phys) :: wstar !friction velocity n vertical direction (m/s) (only for sfcdif2)
3857 real (kind=kind_phys) :: z0mo !roughness length for intermediate output only (m)
3858 real (kind=kind_phys) :: z0h !roughness length, sensible heat (m)
3859 real (kind=kind_phys) :: z0hg !roughness length, sensible heat (m)
3860 real (kind=kind_phys) :: ramc !aerodynamic resistance for momentum (s/m)
3861 real (kind=kind_phys) :: rahc !aerodynamic resistance for sensible heat (s/m)
3862 real (kind=kind_phys) :: rawc !aerodynamic resistance for water vapor (s/m)
3863 real (kind=kind_phys) :: ramg !aerodynamic resistance for momentum (s/m)
3864 real (kind=kind_phys) :: rahg !aerodynamic resistance for sensible heat (s/m)
3865 real (kind=kind_phys) :: rawg !aerodynamic resistance for water vapor (s/m)
3866
3867 real (kind=kind_phys), intent(out) :: rssun !sunlit leaf stomatal resistance (s/m)
3868 real (kind=kind_phys), intent(out) :: rssha !shaded leaf stomatal resistance (s/m)
3869
3870 real (kind=kind_phys) :: mol !monin-obukhov length (m)
3871 real (kind=kind_phys) :: dtv !change in tv, last iteration (k)
3872 real (kind=kind_phys) :: dtg !change in tg, last iteration (k)
3873
3874 real (kind=kind_phys) :: air,cir !coefficients for ir as function of ts**4
3875 real (kind=kind_phys) :: csh !coefficients for sh as function of ts
3876 real (kind=kind_phys) :: cev !coefficients for ev as function of esat[ts]
3877 real (kind=kind_phys) :: cgh !coefficients for st as function of ts
3878 real (kind=kind_phys) :: atr,ctr !coefficients for tr as function of esat[ts]
3879 real (kind=kind_phys) :: ata,bta !coefficients for tah as function of ts
3880 real (kind=kind_phys) :: aea,bea !coefficients for eah as function of esat[ts]
3881
3882 real (kind=kind_phys) :: estv !saturation vapor pressure at tv (pa)
3883 real (kind=kind_phys) :: estg !saturation vapor pressure at tg (pa)
3884 real (kind=kind_phys) :: destv !d(es)/dt at ts (pa/k)
3885 real (kind=kind_phys) :: destg !d(es)/dt at tg (pa/k)
3886 real (kind=kind_phys) :: esatw !es for water
3887 real (kind=kind_phys) :: esati !es for ice
3888 real (kind=kind_phys) :: dsatw !d(es)/dt at tg (pa/k) for water
3889 real (kind=kind_phys) :: dsati !d(es)/dt at tg (pa/k) for ice
3890
3891 real (kind=kind_phys) :: fm !momentum stability correction, weighted by prior iters
3892 real (kind=kind_phys) :: fh !sen heat stability correction, weighted by prior iters
3893 real (kind=kind_phys) :: fhg !sen heat stability correction, ground
3894 real (kind=kind_phys) :: fhgh !sen heat stability correction, canopy
3895 real (kind=kind_phys) :: hcan !canopy height (m) [note: hcan >= z0mg]
3896
3897 real (kind=kind_phys) :: a !temporary calculation
3898 real (kind=kind_phys) :: b !temporary calculation
3899 real (kind=kind_phys) :: cvh !sensible heat conductance, leaf surface to canopy air (m/s)
3900 real (kind=kind_phys) :: caw !latent heat conductance, canopy air zlvl air (m/s)
3901 real (kind=kind_phys) :: ctw !transpiration conductance, leaf to canopy air (m/s)
3902 real (kind=kind_phys) :: cew !evaporation conductance, leaf to canopy air (m/s)
3903 real (kind=kind_phys) :: cgw !latent heat conductance, ground to canopy air (m/s)
3904 real (kind=kind_phys) :: cond !sum of conductances (s/m)
3905 real (kind=kind_phys) :: uc !wind speed at top of canopy (m/s)
3906 real (kind=kind_phys) :: kh !turbulent transfer coefficient, sensible heat, (m2/s)
3907 real (kind=kind_phys) :: h !temporary sensible heat flux (w/m2)
3908 real (kind=kind_phys) :: hg !temporary sensible heat flux (w/m2)
3909 real (kind=kind_phys) :: moz !monin-obukhov stability parameter
3910 real (kind=kind_phys) :: mozg !monin-obukhov stability parameter
3911 real (kind=kind_phys) :: mozold !monin-obukhov stability parameter from prior iteration
3912 real (kind=kind_phys) :: fm2 !monin-obukhov momentum adjustment at 2m
3913 real (kind=kind_phys) :: fh2 !monin-obukhov heat adjustment at 2m
3914 real (kind=kind_phys) :: ch2 !surface exchange at 2m
3915 real (kind=kind_phys) :: thstar !surface exchange at 2m
3916
3917 real (kind=kind_phys) :: fm10
3918 real (kind=kind_phys) :: rb1v
3919 real (kind=kind_phys) :: stress1v
3920
3921
3922 real (kind=kind_phys) :: flhcv ! for MYNN
3923 real (kind=kind_phys) :: flqcv ! for MYNN
3924 real (kind=kind_phys) :: wspdv ! for MYNN
3925
3926 real (kind=kind_phys) :: thvair
3927 real (kind=kind_phys) :: thah
3928 real (kind=kind_phys) :: rahc2 !aerodynamic resistance for sensible heat (s/m)
3929 real (kind=kind_phys) :: rawc2 !aerodynamic resistance for water vapor (s/m)
3930 real (kind=kind_phys), intent(out):: cah2 !sensible heat conductance for diagnostics
3931 real (kind=kind_phys) :: ch2v !exchange coefficient for 2m over vegetation.
3932 real (kind=kind_phys) :: cq2v !exchange coefficient for 2m over vegetation.
3933 real (kind=kind_phys) :: eah2 !2m vapor pressure over canopy
3934 real (kind=kind_phys) :: qfx !moisture flux
3935 real (kind=kind_phys) :: e1
3936 real (kind=kind_phys) :: hcv !canopy heat capacity j/m2/k, C.He added
3937
3938 real (kind=kind_phys) :: vaie !total leaf area index + stem area index,effective
3939 real (kind=kind_phys) :: laisune !sunlit leaf area index, one-sided (m2/m2),effective
3940 real (kind=kind_phys) :: laishae !shaded leaf area index, one-sided (m2/m2),effective
3941
3942 integer :: k !index
3943 integer :: iter !iteration index
3944
3945!jref - niterc test from 5 to 20
3946 integer, parameter :: niterc = 20 !number of iterations for surface temperature
3947!jref - niterg test from 3-5
3948 integer, parameter :: niterg = 5 !number of iterations for ground temperature
3949 integer :: mozsgn !number of times moz changes sign
3950 real (kind=kind_phys) :: mpe !prevents overflow error if division by zero
3951
3952 integer :: liter !last iteration
3953
3954! New variables for sfcdif3
3955
3956 logical , intent(in ) :: thsfc_loc
3957 real (kind=kind_phys), intent(in ) :: prslkix ! in exner function
3958 real (kind=kind_phys), intent(in ) :: prsik1x ! in exner function
3959 real (kind=kind_phys), intent(in ) :: prslk1x ! in exner function
3960 real (kind=kind_phys), intent(in ) :: garea1
3961 real (kind=kind_phys), intent(in ) :: shdfac ! greeness vegetation fraction (-)
3962 real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity
3963 real (kind=kind_phys), intent( out) :: csigmaf1 !
3964 real (kind=kind_phys) :: csigmaf0 !
3965! dummy for thermal roughness scheme
3966 real (kind=kind_phys) :: temptrs
3967
3968
3969 real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50
3970
3971 real(kind=kind_phys) :: evpot
3972 real(kind=kind_phys) :: fhi, qss, wrk
3973 real(kind=kind_phys), parameter :: qmin=1.0e-8
3974
3975 character(len=80) :: message
3976
3977 tdc(t) = min( 50., max(-50.,(t-tfrz)) )
3978! ---------------------------------------------------------------------------------------------
3979
3980 mpe = 1e-6
3981 liter = 0
3982 temptrs = 1.
3983
3984 fv = ustarx
3985! ---------------------------------------------------------------------------------------------
3986! initialization variables that do not depend on stability iteration
3987! ---------------------------------------------------------------------------------------------
3988 dtv = 0.
3989 dtg = 0.
3990 moz = 0.
3991 mozsgn = 0
3992 mozold = 0.
3993 fh2 = 0.
3994 hg = 0.
3995 h = 0.
3996 qfx = 0.
3997
3998! limit lai
3999
4000 vaie = min(6.,vai )
4001 laisune = min(6.,laisun)
4002 laishae = min(6.,laisha)
4003
4004! saturation vapor pressure at ground temperature
4005
4006 t = tdc(tg)
4007 call esat(t, esatw, esati, dsatw, dsati)
4008 if (t .gt. 0.) then
4009 estg = esatw
4010 else
4011 estg = esati
4012 end if
4013
4014!jref - consistent surface specific humidity for sfcdif3 and sfcdif4
4015
4016 qsfc = ep_2*eair/(psfc+epsm1*eair)
4017
4018! canopy height
4019 hcan = parameters%hvt
4020 uc = ur*log(hcan/z0m)/log(zlvl/z0m)
4021 uc = ur*log((hcan-zpd+z0m)/z0m)/log(zlvl/z0m) ! mb: add zpd v3.7
4022 if((hcan-zpd) <= 0.) then
4023 write(message,*) "critical problem: hcan <= zpd"
4024#ifdef CCPP
4025 errmsg = trim(message)
4026#else
4027 call wrf_message ( message )
4028#endif
4029 write(message,*) 'i,j point=',iloc, jloc
4030#ifdef CCPP
4031 errmsg = trim(errmsg)//new_line('A')//trim(message)
4032#else
4033 call wrf_message ( message )
4034#endif
4035 write(message,*) 'hcan =',hcan
4036#ifdef CCPP
4037 errmsg = trim(errmsg)//new_line('A')//trim(message)
4038#else
4039 call wrf_message ( message )
4040#endif
4041 write(message,*) 'zpd =',zpd
4042#ifdef CCPP
4043 errmsg = trim(errmsg)//new_line('A')//trim(message)
4044#else
4045 call wrf_message ( message )
4046#endif
4047 write (message, *) 'snowh =',snowh
4048#ifdef CCPP
4049 errflg = 1
4050 errmsg = trim(errmsg)//new_line('A')//trim(message)//new_line('A')//"critical problem in module_sf_noahmplsm:vegeflux"
4051 return
4052#else
4053 call wrf_message ( message )
4054 call wrf_error_fatal ( "critical problem in module_sf_noahmplsm:vegeflux" )
4055#endif
4056
4057 end if
4058
4059! prepare for longwave rad.
4060
4061 air = -emv*(1.+(1.-emv)*(1.-emg))*lwdn - emv*emg*sb*tg**4
4062 cir = (2.-emv*(1.-emg))*emv*sb
4063!
4064 if(opt_sfc == 4) then
4065
4066 gdx = sqrt(garea1)
4067 snwd = snowh * 1000.0
4068 fv = ustarx !inout in sfcdif4
4069
4070 if (snowh .gt. 0.1) then
4071 mnice = 1
4072 else
4073 mnice = 0
4074 endif
4075
4076 endif
4077
4078! ---------------------------------------------------------------------------------------------
4079 loop1: do iter = 1, niterc ! begin stability iteration
4080
4081! if(iter == 1) then
4082! z0hg = z0mg
4083! else
4084! z0hg = z0mg !* exp(-czil*0.4*258.2*sqrt(fv*z0mg))
4085! end if
4086
4087
4088 call thermalz0(parameters,fveg,z0m,z0mg,zlvl,zpd,zpd,ustarx, & !in
4089 vegtyp,vaie,ur,csigmaf0,csigmaf1,temptrs,temptrs,temptrs,0, & !in
4090 z0mo,z0hg)
4091
4092 call thermalz0(parameters,fveg,z0m,z0mg,zlvl,zpd,zpd,ustarx, & !in
4093 vegtyp,vaie,ur,csigmaf0,csigmaf1,temptrs,temptrs,temptrs,1, & !in
4094 z0mo,z0h)
4095
4096! aerodyn resistances between heights zlvl and d+z0v
4097
4098 if(opt_sfc == 1) then
4099 call sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in
4100 zlvl ,zpd ,z0m ,z0h ,ur , & !in
4101 mpe ,iloc ,jloc , & !in
4102#ifdef CCPP
4103 moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,fv, errmsg ,errflg ,& !inout
4104#else
4105 moz ,mozsgn ,fm ,fh ,fm2,fh2, fv, & !inout
4106#endif
4107 cm ,ch ,ch2 ) !out
4108#ifdef CCPP
4109 if (errflg /= 0) return
4110#endif
4111 endif
4112
4113 if(opt_sfc == 2) then
4114 call sfcdif2(parameters,iter ,z0m ,tah ,thair ,ur , & !in
4115 zlvl ,iloc ,jloc , & !in
4116 cm ,ch ,moz ,wstar , & !in
4117 fv ) !out
4118 ! undo the multiplication by windspeed that sfcdif2
4119 ! applies to exchange coefficients ch and cm:
4120 ch = ch / ur
4121 cm = cm / ur
4122 endif
4123
4124 if(opt_sfc == 3) then
4125 call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in
4126 zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in
4127 z0h, zpd ,snowh ,shdfac ,garea1 , & !in
4128 ustarx ,fm ,fh ,fm2 ,fh2 , & !inout
4129 fv ,cm ,ch ) !out
4130
4131 endif
4132
4133 if(opt_sfc == 4) then
4134
4135 call sfcdif4(iloc ,jloc ,uu ,vv ,sfctmp , &
4136 sfcprs ,psfc ,pblhx ,gdx ,z0m , &
4137 ep_1, ep_2, cp, &
4138 itime ,snwd ,mnice ,psi_opt, &
4139 tah ,qair ,zlvl ,iz0tlnd,qsfc , &
4140 h ,qfx ,cm ,ch ,ch2v , &
4141 cq2v ,moz ,fv ,rb1v, fm, fh, &
4142 stress1v,fm10 ,fh2 ,wspdv ,flhcv ,flqcv)
4143
4144
4145 ! Undo the multiplication by windspeed that SFCDIF4
4146 ! applies to exchange coefficients CH and CM
4147
4148 ch = ch / wspdv
4149 cm = cm / wspdv
4150 ch2v = ch2v / wspdv
4151
4152 endif
4153
4154
4155 if(opt_sfc == 1 .or. opt_sfc == 2 .or. opt_sfc == 3) then
4156 ramc = max(1.,1./(cm*ur))
4157 rahc = max(1.,1./(ch*ur))
4158 elseif(opt_sfc == 4) then
4159 ramc = max(1.,1./(cm*wspdv) )
4160 rahc = max(1.,1./(ch*wspdv) )
4161 endif
4162
4163 rawc = rahc
4164
4165! aerodyn resistance between heights z0g and d+z0v, rag, and leaf
4166! boundary layer resistance, rb
4167
4168 call ragrb(parameters,iter ,vaie ,rhoair ,hg ,tah , & !in
4169 zpd ,z0mg ,z0hg ,hcan ,uc , & !in
4170 z0h ,fv ,cwp ,vegtyp ,mpe , & !in
4171 tv ,mozg ,fhg ,fhgh ,iloc ,jloc , & !inout
4172 ramg ,rahg ,rawg ,rb ) !out
4173
4174! es and d(es)/dt evaluated at tv
4175
4176 t = tdc(tv)
4177 call esat(t, esatw, esati, dsatw, dsati)
4178 if (t .gt. 0.) then
4179 estv = esatw
4180 destv = dsatw
4181 else
4182 estv = esati
4183 destv = dsati
4184 end if
4185
4186! stomatal resistance
4187
4188 if(iter == 1) then
4189 if (opt_crs == 1) then ! ball-berry
4190 call stomata (parameters,vegtyp,mpe ,parsun ,foln ,iloc , jloc , & !in
4191 tv ,estv ,eah ,sfctmp,sfcprs, & !in
4192 o2air ,co2air,igs ,btran ,rb , & !in
4193 rssun ,psnsun) !out
4194
4195 call stomata (parameters,vegtyp,mpe ,parsha ,foln ,iloc , jloc , & !in
4196 tv ,estv ,eah ,sfctmp,sfcprs, & !in
4197 o2air ,co2air,igs ,btran ,rb , & !in
4198 rssha ,psnsha) !out
4199 end if
4200
4201 if (opt_crs == 2) then ! jarvis
4202 call canres (parameters,ep_2, epsm1,parsun,tv ,btran ,eah ,sfcprs, & !in
4203 rssun ,psnsun,iloc ,jloc ) !out
4204
4205 call canres (parameters,ep_2, epsm1,parsha,tv ,btran ,eah ,sfcprs, & !in
4206 rssha ,psnsha,iloc ,jloc ) !out
4207 end if
4208 end if
4209
4210! prepare for sensible heat flux above veg.
4211
4212 cah = 1./rahc
4213 cvh = 2.*vaie/rb
4214 cgh = 1./rahg
4215 cond = cah + cvh + cgh
4216 ata = (sfctmp*cah + tg*cgh) / cond
4217 bta = cvh/cond
4218 csh = (1.-bta)*rhoair*cpair*cvh
4219
4220! prepare for latent heat flux above veg.
4221
4222 evpot= fveg*rhoair*cpair*vaie/rb * (estv-eah) / gammav
4223 caw = 1./rawc
4224 if(evpot > 0. .and. fwet > 0.) then
4225 if (tv > tfrz) then
4226 cew = min(fwet,canliq*latheav/dt/evpot) * vaie/rb
4227 else
4228 cew = min(fwet,canice*latheav/dt/evpot) * vaie/rb
4229 endif
4230 else
4231 cew= fwet * vaie/rb
4232 endif
4233 ctw = (1.-fwet)*(laisune/(rb+rssun) + laishae/(rb+rssha))
4234 cgw = 1./(rawg+rsurf)
4235 cond = caw + cew + ctw + cgw
4236 aea = (eair*caw + estg*cgw) / cond
4237 bea = (cew+ctw)/cond
4238 cev = (1.-bea)*cew*rhoair*cpair/gammav ! barlage: change to vegetation v3.6
4239 ctr = (1.-bea)*ctw*rhoair*cpair/gammav
4240
4241! evaluate surface fluxes with current temperature and solve for dts
4242
4243 tah = ata + bta*tv ! canopy air t.
4244 eah = aea + bea*estv ! canopy air e
4245
4246 irc = fveg*(air + cir*tv**4)
4247 shc = fveg*rhoair*cpair*cvh * ( tv-tah)
4248 evc = fveg*rhoair*cpair*cew * (estv-eah) / gammav ! barlage: change to v in v3.6
4249 tr = fveg*rhoair*cpair*ctw * (estv-eah) / gammav
4250 if (tv > tfrz) then
4251 evc = min(canliq*latheav/dt,evc) ! barlage: add if block for canice in v3.6
4252 else
4253 evc = min(canice*latheav/dt,evc)
4254 end if
4255
4256! canopy heat capacity
4257 hcv = fveg*(parameters%cbiom*vaie*cwat + canliq*cwat/denh2o + canice*cice/denice) !j/m2/k
4258
4259 b = sav-irc-shc-evc-tr+pahv !additional w/m2
4260! a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) !volumetric heat capacity
4261 a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) + hcv/dt !volumetric heat capacity
4262 dtv = b/a
4263
4264 irc = irc + fveg*4.*cir*tv**3*dtv
4265 shc = shc + fveg*csh*dtv
4266 evc = evc + fveg*cev*destv*dtv
4267 tr = tr + fveg*ctr*destv*dtv
4268 canhs = dtv*hcv/dt
4269
4270! update vegetation surface temperature
4271 tv = tv + dtv
4272! tah = ata + bta*tv ! canopy air t; update here for consistency
4273
4274! for computing m-o length in the next iteration
4275 h = rhoair*cpair*(tah - sfctmp) /rahc
4276 hg = rhoair*cpair*(tg - tah) /rahg
4277
4278! consistent specific humidity from canopy air vapor pressure
4279 qsfc = (ep_2*eah)/(sfcprs+epsm1*eah)
4280
4281 if ( opt_sfc == 4 ) then
4282 qfx = (qsfc-qair)*rhoair*caw
4283 endif
4284
4285
4286 if (liter == 1) then
4287 exit loop1
4288 endif
4289 if (iter >= 5 .and. abs(dtv) <= 0.01 .and. liter == 0) then
4290 liter = 1
4291 endif
4292
4293 end do loop1 ! end stability iteration
4294
4295! under-canopy fluxes and tg
4296
4297 air = - emg*(1.-emv)*lwdn - emg*emv*sb*tv**4
4298 cir = emg*sb
4299 csh = rhoair*cpair/rahg
4300 cev = rhoair*cpair / (gammag*(rawg+rsurf)) ! barlage: change to ground v3.6
4301 cgh = 2.*df(isnow+1)/dzsnso(isnow+1)
4302
4303 loop2: do iter = 1, niterg
4304
4305 t = tdc(tg)
4306 call esat(t, esatw, esati, dsatw, dsati)
4307 if (t .gt. 0.) then
4308 estg = esatw
4309 destg = dsatw
4310 else
4311 estg = esati
4312 destg = dsati
4313 end if
4314
4315 irg = cir*tg**4 + air
4316 shg = csh * (tg - tah )
4317 evg = cev * (estg*rhsur - eah )
4318 gh = cgh * (tg - stc(isnow+1))
4319
4320 b = sag-irg-shg-evg-gh+pahg
4321 a = 4.*cir*tg**3+csh+cev*destg+cgh
4322 dtg = b/a
4323
4324 irg = irg + 4.*cir*tg**3*dtg
4325 shg = shg + csh*dtg
4326 evg = evg + cev*destg*dtg
4327 gh = gh + cgh*dtg
4328 tg = tg + dtg
4329
4330 end do loop2
4331
4332! tah = (cah*sfctmp + cvh*tv + cgh*tg)/(cah + cvh + cgh)
4333
4334! if snow on ground and tg > tfrz: reset tg = tfrz. reevaluate ground fluxes.
4335
4336 if(opt_stc == 1 .or. opt_stc == 3) then
4337 if (snowh > 0.05 .and. tg > tfrz) then
4338 if(opt_stc == 1) tg = tfrz
4339 if(opt_stc == 3) tg = (1.-fsno)*tg + fsno*tfrz ! mb: allow tg>0c during melt v3.7
4340 irg = cir*tg**4 - emg*(1.-emv)*lwdn - emg*emv*sb*tv**4
4341 shg = csh * (tg - tah)
4342 evg = cev * (estg*rhsur - eah)
4343 gh = sag+pahg - (irg+shg+evg)
4344 end if
4345 end if
4346
4347! wind stresses
4348
4349 tauxv = -rhoair*cm*ur*uu
4350 tauyv = -rhoair*cm*ur*vv
4351
4352! consistent vegetation air temperature and vapor pressure since tg is not consistent with the tah/eah
4353! calculation.
4354! tah = sfctmp + (shg+shc)/(rhoair*cpair*cah)
4355! tah = sfctmp + (shg*fveg+shc)/(rhoair*cpair*cah) ! ground flux need fveg
4356! eah = eair + (evc+fveg*(tr+evg))/(rhoair*caw*cpair/gammag )
4357! qfx = (qsfc-qair)*rhoair*caw !*cpair/gammag
4358
4359! 2m temperature over vegetation ( corrected for low cq2v values )
4360 if (opt_sfc == 1 .or. opt_sfc == 2 ) then
4361! cah2 = fv*1./vkc*log((2.+z0h)/z0h)
4362 cah2 = fv*vkc/log((2.+z0h)/z0h)
4363 cah2 = fv*vkc/(log((2.+z0h)/z0h)-fh2)
4364 cq2v = cah2
4365 endif
4366
4367! opt_sfc 3: fh2 is the stability
4368 if (opt_sfc ==3) then
4369 cah2 = fv*vkc/fh2
4370 cq2v = cah2
4371 endif
4372
4373 if (opt_sfc == 4 ) then
4374 rahc2 = max(1.,1./(ch2v*wspdv))
4375 rawc2 = rahc2
4376 cah2 = 1./rahc2
4377 cq2v = 1./max(1.,1./(cq2v*wspdv))
4378 endif
4379
4380 if (cah2 .lt. 1.e-5 ) then
4381 t2mv = tah
4382! q2v = (eah*0.622/(sfcprs - 0.378*eah))
4383 q2v = qsfc
4384 else
4385 t2mv = tah - (shg+shc/fveg)/(rhoair*cpair) * 1./cah2
4386! q2v = (eah*0.622/(sfcprs - 0.378*eah))- qfx/(rhoair*fv)* 1./vkc * log((2.+z0h)/z0h)
4387 q2v = qsfc - ((evc+tr)/fveg+evg)/(latheav*rhoair) * 1./cq2v
4388 endif
4389
4390! use sfc_diag to calculate t2mv and q2v for opt_sfc=1&3
4391 if(opt_diag ==3) then
4392 if(opt_sfc == 1 .or. opt_sfc == 3) then
4393
4394 fhi = fh2/fh
4395 wrk = 1.0 - fhi
4396 if(thsfc_loc) then ! Use local potential temperature
4397 t2mv = tah*wrk + sfctmp*prslkix*fhi - (grav+grav)/cp
4398 else ! Use potential temperature referenced to 1000 hPa
4399 t2mv = tah*wrk + sfctmp*fhi - (grav+grav)/cp
4400 endif
4401
4402 if((evc+tr)/fveg+evg >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2v
4403 q2v = qsfc*wrk + max(qmin,qair)*fhi
4404 else ! for dew formation, use saturated q at tskin
4405 qss = fpvs(tah)
4406 qss = ep_2 * qss / (psfc + epsm1 * qss)
4407 q2v= qss*wrk + max(qmin,qair)*fhi
4408 endif
4409 qss = fpvs(t2mv)
4410 qss = ep_2 * qss / (psfc + epsm1 * qss)
4411 q2v = min(q2v,qss)
4412 else
4413 errmsg = 'Problem :opt_diag=3 is only applied for opt_sfc=1&3'
4414 errflg = 1
4415 return
4416 endif
4417 endif
4418! update ch for output
4419 ch = cah
4420 chleaf = cvh
4421 chuc = 1./rahg
4422
4423 end subroutine vege_flux
4424
4425!== begin bare_flux ================================================================================
4426
4430 subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & !in
4431 lwdn ,ur ,uu ,vv ,sfctmp , & !in
4432 thair ,qair ,eair ,rhoair ,snowh , & !in
4433 dzsnso ,zlvl ,zpd ,z0m ,fsno , & !in
4434 emg ,stc ,df ,rsurf ,lathea , & !in
4435 gamma ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in
4436 thsfc_loc, prslkix,prsik1x,prslk1x,vegtyp,fveg,shdfac,garea1, & !in
4437 pblhx , iz0tlnd , itime ,psi_opt,ep_1,ep_2,epsm1,cp ,&
4438#ifdef CCPP
4439 tgb ,cm ,ch,ustarx,errmsg ,errflg , & !inout
4440#else
4441 tgb ,cm ,ch,ustarx, & !inout
4442#endif
4443 tauxb ,tauyb ,irb ,shb ,evb , & !out
4444 csigmaf0, & !out
4445 ghb ,t2mb ,dx ,dz8w , & !out
4446 qc ,qsfc ,psfc , & !in
4447 sfcprs ,q2b ,ehb2 ) !in
4448
4449! --------------------------------------------------------------------------------------------------
4450! use newton-raphson iteration to solve ground (tg) temperature
4451! that balances the surface energy budgets for bare soil fraction.
4452
4453! bare soil:
4454! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0
4455! ----------------------------------------------------------------------
4456 use funcphys, only : fpvs
4457 implicit none
4458! ----------------------------------------------------------------------
4459! input
4460 type (noahmp_parameters), intent(in) :: parameters
4461 integer , intent(in) :: iloc
4462 integer , intent(in) :: jloc
4463 integer, intent(in) :: nsnow
4464 integer, intent(in) :: nsoil
4465 integer, intent(in) :: isnow
4466 real (kind=kind_phys), intent(in) :: dt
4467 real (kind=kind_phys), intent(in) :: sag
4468 real (kind=kind_phys), intent(in) :: lwdn
4469 real (kind=kind_phys), intent(in) :: ur
4470 real (kind=kind_phys), intent(in) :: uu
4471 real (kind=kind_phys), intent(in) :: vv
4472 real (kind=kind_phys), intent(in) :: sfctmp
4473 real (kind=kind_phys), intent(in) :: thair
4474 real (kind=kind_phys), intent(in) :: qair
4475 real (kind=kind_phys), intent(in) :: eair
4476 real (kind=kind_phys), intent(in) :: rhoair
4477 real (kind=kind_phys), intent(in) :: snowh
4478 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
4479 real (kind=kind_phys), intent(in) :: zlvl
4480 real (kind=kind_phys), intent(in) :: zpd
4481 real (kind=kind_phys), intent(in) :: z0m
4482 real (kind=kind_phys), intent(in) :: emg
4483 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc
4484 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: df
4485 real (kind=kind_phys), intent(in) :: rsurf
4486 real (kind=kind_phys), intent(in) :: lathea
4487 real (kind=kind_phys), intent(in) :: gamma
4488 real (kind=kind_phys), intent(in) :: rhsur
4489 real (kind=kind_phys), intent(in) :: fsno
4490
4491 real (kind=kind_phys), intent(in) :: pblhx
4492 real (kind=kind_phys), intent(in) :: ep_1
4493 real (kind=kind_phys), intent(in) :: ep_2
4494 real (kind=kind_phys), intent(in) :: epsm1
4495 real (kind=kind_phys), intent(in) :: cp
4496 integer, intent(in) :: iz0tlnd
4497 integer, intent(in) :: itime
4498 integer, intent(in) :: psi_opt
4499
4500
4501!jref:start; in
4502 real (kind=kind_phys) , intent(in) :: qc
4503 real (kind=kind_phys) , intent(inout) :: qsfc
4504 real (kind=kind_phys) , intent(in) :: psfc
4505 real (kind=kind_phys) , intent(in) :: sfcprs
4506 real (kind=kind_phys) , intent(in) :: dx
4507 real (kind=kind_phys) , intent(in) :: q2
4508 real (kind=kind_phys) , intent(in) :: dz8w
4509!jref:end
4510 real (kind=kind_phys), intent(in) :: pahb
4511
4512! input/output
4513 real (kind=kind_phys), intent(inout) :: tgb
4514 real (kind=kind_phys), intent(inout) :: cm
4515 real (kind=kind_phys), intent(inout) :: ch
4516#ifdef CCPP
4517 character(len=*), intent(inout) :: errmsg
4518 integer, intent(inout) :: errflg
4519#endif
4520
4521! output
4522! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0
4523
4524 real (kind=kind_phys), intent(out) :: tauxb
4525 real (kind=kind_phys), intent(out) :: tauyb
4526 real (kind=kind_phys), intent(out) :: irb
4527 real (kind=kind_phys), intent(out) :: shb
4528 real (kind=kind_phys), intent(out) :: evb
4529 real (kind=kind_phys), intent(out) :: ghb
4530 real (kind=kind_phys), intent(out) :: t2mb
4531!jref:start
4532 real (kind=kind_phys), intent(out) :: q2b
4533 real (kind=kind_phys) :: ehb !bare ground heat conductance
4534 real (kind=kind_phys) :: u10b !10 m wind speed in eastward dir (m/s)
4535 real (kind=kind_phys) :: v10b !10 m wind speed in eastward dir (m/s)
4536 real (kind=kind_phys) :: wspd
4537!jref:end
4538
4539! local variables
4540
4541 real (kind=kind_phys) :: gdx !grid dx
4542 real (kind=kind_phys) :: snwd ! snowdepth in mm
4543 integer :: mnice ! MYNN ice flag
4544
4545 real (kind=kind_phys) :: fm10
4546 real (kind=kind_phys) :: rb1b
4547 real (kind=kind_phys) :: stress1b
4548
4549 real (kind=kind_phys) :: wspdb
4550 real (kind=kind_phys) :: flhcb
4551 real (kind=kind_phys) :: flqcb
4552!
4553
4554 real (kind=kind_phys) :: taux !wind stress: e-w (n/m2)
4555 real (kind=kind_phys) :: tauy !wind stress: n-s (n/m2)
4556 real (kind=kind_phys) :: fira !total net longwave rad (w/m2) [+ to atm]
4557 real (kind=kind_phys) :: fsh !total sensible heat flux (w/m2) [+ to atm]
4558 real (kind=kind_phys) :: fgev !ground evaporation heat flux (w/m2)[+ to atm]
4559 real (kind=kind_phys) :: ssoil !soil heat flux (w/m2) [+ to soil]
4560 real (kind=kind_phys) :: fire !emitted ir (w/m2)
4561 real (kind=kind_phys) :: trad !radiative temperature (k)
4562 real (kind=kind_phys) :: tah !"surface" temperature at height z0h+zpd (k)
4563
4564 real (kind=kind_phys) :: cw !water vapor exchange coefficient
4565 real (kind=kind_phys) :: fv !friction velocity (m/s)
4566 real (kind=kind_phys) :: wstar !friction velocity n vertical direction (m/s) (only for sfcdif2)
4567 real (kind=kind_phys) :: z0mo !roughness length for intermediate output only (m)
4568 real (kind=kind_phys) :: z0h !roughness length, sensible heat, ground (m)
4569 real (kind=kind_phys) :: rb !bulk leaf boundary layer resistance (s/m)
4570 real (kind=kind_phys) :: ramb !aerodynamic resistance for momentum (s/m)
4571 real (kind=kind_phys) :: rahb !aerodynamic resistance for sensible heat (s/m)
4572 real (kind=kind_phys) :: rawb !aerodynamic resistance for water vapor (s/m)
4573 real (kind=kind_phys) :: mol !monin-obukhov length (m)
4574 real (kind=kind_phys) :: dtg !change in tg, last iteration (k)
4575
4576 real (kind=kind_phys) :: cir !coefficients for ir as function of ts**4
4577 real (kind=kind_phys) :: csh !coefficients for sh as function of ts
4578 real (kind=kind_phys) :: cev !coefficients for ev as function of esat[ts]
4579 real (kind=kind_phys) :: cgh !coefficients for st as function of ts
4580
4581 real(kind=kind_phys) :: kbsigmaf0
4582 real(kind=kind_phys) :: reynb
4583
4584
4585!jref:start
4586 real (kind=kind_phys) :: rahb2 !aerodynamic resistance for sensible heat 2m (s/m)
4587 real (kind=kind_phys) :: rawb2 !aerodynamic resistance for water vapor 2m (s/m)
4588 real (kind=kind_phys),intent(out) :: ehb2 !sensible heat conductance for diagnostics
4589 real (kind=kind_phys) :: ch2b !exchange coefficient for 2m temp.
4590 real (kind=kind_phys) :: cq2b !exchange coefficient for 2m temp.
4591 real (kind=kind_phys) :: thvair !virtual potential air temp
4592 real (kind=kind_phys) :: thgh !potential ground temp
4593 real (kind=kind_phys) :: emb !momentum conductance
4594 real (kind=kind_phys) :: qfx !moisture flux
4595 real (kind=kind_phys) :: estg2 !saturation vapor pressure at 2m (pa)
4596 real (kind=kind_phys) :: e1
4597!jref:end
4598
4599 real (kind=kind_phys) :: estg !saturation vapor pressure at tg (pa)
4600 real (kind=kind_phys) :: destg !d(es)/dt at tg (pa/k)
4601 real (kind=kind_phys) :: esatw !es for water
4602 real (kind=kind_phys) :: esati !es for ice
4603 real (kind=kind_phys) :: dsatw !d(es)/dt at tg (pa/k) for water
4604 real (kind=kind_phys) :: dsati !d(es)/dt at tg (pa/k) for ice
4605
4606 real (kind=kind_phys) :: a !temporary calculation
4607 real (kind=kind_phys) :: b !temporary calculation
4608 real (kind=kind_phys) :: h !temporary sensible heat flux (w/m2)
4609 real (kind=kind_phys) :: moz !monin-obukhov stability parameter
4610 real (kind=kind_phys) :: mozold !monin-obukhov stability parameter from prior iteration
4611 real (kind=kind_phys) :: fm !momentum stability correction, weighted by prior iters
4612 real (kind=kind_phys) :: fh !sen heat stability correction, weighted by prior iters
4613 integer :: mozsgn !number of times moz changes sign
4614 real (kind=kind_phys) :: fm2 !monin-obukhov momentum adjustment at 2m
4615 real (kind=kind_phys) :: fh2 !monin-obukhov heat adjustment at 2m
4616 real (kind=kind_phys) :: ch2 !surface exchange at 2m
4617
4618 integer :: iter !iteration index
4619 integer :: niterb !number of iterations for surface temperature
4620 real (kind=kind_phys) :: mpe !prevents overflow error if division by zero
4621!jref:start
4622! data niterb /3/
4623 data niterb /5/
4624 save niterb
4625
4626! New variables for sfcdif3
4627
4628 logical , intent(in ) :: thsfc_loc
4629 real (kind=kind_phys), intent(in ) :: prslkix ! in exner function
4630 real (kind=kind_phys), intent(in ) :: prsik1x ! in exner function
4631 real (kind=kind_phys), intent(in ) :: prslk1x ! in exner function
4632 integer , intent(in ) :: vegtyp
4633 real (kind=kind_phys), intent(in ) :: fveg
4634 real (kind=kind_phys), intent(in ) :: shdfac
4635 real (kind=kind_phys), intent(in ) :: garea1
4636 real (kind=kind_phys), intent(inout) :: ustarx !friction velocity
4637 real (kind=kind_phys), intent( out) :: csigmaf0 !
4638 real (kind=kind_phys) :: csigmaf1 !
4639! dummy for thermal roughness scheme
4640 real (kind=kind_phys) :: temptrs
4641
4642 real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50
4643
4644 real(kind=kind_phys) :: fhi, qss, wrk
4645 real(kind=kind_phys), parameter :: qmin=1.0e-8
4646
4647 tdc(t) = min( 50., max(-50.,(t-tfrz)) )
4648
4649! -----------------------------------------------------------------
4650! initialization variables that do not depend on stability iteration
4651! -----------------------------------------------------------------
4652 temptrs = 1.
4653 mpe = 1e-6
4654 dtg = 0.
4655 moz = 0.
4656 mozsgn = 0
4657 mozold = 0.
4658 fh2 = 0.
4659 h = 0.
4660 qfx = 0.
4661
4662 cir = emg*sb
4663 cgh = 2.*df(isnow+1)/dzsnso(isnow+1)
4664
4665 reynb = ustarx*z0m/(1.5e-05)
4666
4667 if (reynb .gt. 2.0) then
4668 kbsigmaf0 = 2.46*reynb**0.25 - log(7.4)
4669 else
4670 kbsigmaf0 = - log(0.397)
4671 endif
4672
4673 z0h = max(z0m/exp(kbsigmaf0),1.0e-6)
4674
4675 if (opt_sfc == 4) then
4676 fv = ustarx
4677 gdx = sqrt(garea1)
4678 snwd = snowh * 1000.0
4679
4680 if (snowh .gt. 0.1) then
4681 mnice = 1
4682 else
4683 mnice = 0
4684 endif
4685 endif
4686
4687! -----------------------------------------------------------------
4688 loop3: do iter = 1, niterb ! begin stability iteration
4689
4690! if(iter == 1) then
4691! z0h = z0m
4692! else
4693! z0h = z0m !* exp(-czil*0.4*258.2*sqrt(fv*z0m))
4694! end if
4695 call thermalz0(parameters,fveg,z0m,z0m,zlvl,zpd,zpd,ustarx, & !in
4696 vegtyp,0._kind_phys,ur,csigmaf0,csigmaf1,temptrs,temptrs,temptrs,0, & !in
4697 z0mo,z0h)
4698
4699 if(opt_sfc == 1) then
4700 call sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in
4701 zlvl ,zpd ,z0m ,z0h ,ur , & !in
4702 mpe ,iloc ,jloc , & !in
4703#ifdef CCPP
4704 moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,fv,errmsg ,errflg ,& !inout
4705#else
4706 moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,fv, & !inout
4707#endif
4708 cm ,ch ,ch2 ) !out
4709#ifdef CCPP
4710 if (errflg /= 0) return
4711#endif
4712 endif
4713
4714 if(opt_sfc == 2) then
4715 call sfcdif2(parameters,iter ,z0m ,tgb ,thair ,ur , & !in
4716 zlvl ,iloc ,jloc , & !in
4717 cm ,ch ,moz ,wstar , & !in
4718 fv ) !out
4719 ! undo the multiplication by windspeed that sfcdif2
4720 ! applies to exchange coefficients ch and cm:
4721 ch = ch / ur
4722 cm = cm / ur
4723 if(snowh > 0.) then
4724 cm = min(0.01,cm) ! cm & ch are too large, causing
4725 ch = min(0.01,ch) ! computational instability
4726 end if
4727
4728 endif
4729
4730 if(opt_sfc == 3) then
4731 call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in
4732 zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in
4733 z0h, zpd,snowh ,shdfac ,garea1 , & !in
4734 ustarx ,fm ,fh ,fm2 ,fh2 , & !inout
4735 fv ,cm ,ch ) !out
4736
4737 endif
4738
4739 if(opt_sfc == 4) then
4740
4741 call sfcdif4(iloc ,jloc ,uu ,vv ,sfctmp , &
4742 sfcprs ,psfc ,pblhx ,gdx ,z0m , &
4743 ep_1, ep_2, cp, &
4744 itime ,snwd ,mnice ,psi_opt , &
4745 tgb ,qair ,zlvl ,iz0tlnd,qsfc , &
4746 h ,qfx ,cm ,ch ,ch2b , &
4747 cq2b ,moz ,fv ,rb1b, fm, fh , &
4748 stress1b,fm10 ,fh2 , wspdb ,flhcb ,flqcb)
4749
4750 ! Undo the multiplication by windspeed that SFCDIF4
4751 ! applies to exchange coefficients CH and CM:
4752
4753 ch = ch / wspdb
4754 cm = cm / wspdb
4755 ch2b = ch2b / wspdb
4756 cq2b = cq2b / wspdb
4757
4758 if(snwd > 0.) then
4759 cm = min(0.01,cm)
4760 ch = min(0.01,ch)
4761 ch2b = min(0.01,ch2b)
4762 cq2b = min(0.01,cq2b)
4763 end if
4764
4765 endif ! 4
4766
4767 if(opt_sfc == 1 .or. opt_sfc == 2 .or. opt_sfc == 3) then
4768 ramb = max(1.,1./(cm*ur))
4769 rahb = max(1.,1./(ch*ur))
4770 elseif(opt_sfc == 4) then
4771 ramb = max(1.,1./(cm*wspdb) )
4772 rahb = max(1.,1./(ch*wspdb) )
4773 endif
4774
4775 rawb = rahb
4776
4777!jref - variables for diagnostics
4778 emb = 1./ramb
4779 ehb = 1./rahb
4780
4781! es and d(es)/dt evaluated at tg
4782
4783 t = tdc(tgb)
4784 call esat(t, esatw, esati, dsatw, dsati)
4785 if (t .gt. 0.) then
4786 estg = esatw
4787 destg = dsatw
4788 else
4789 estg = esati
4790 destg = dsati
4791 end if
4792
4793 csh = rhoair*cpair/rahb
4794 cev = rhoair*cpair/gamma/(rsurf+rawb)
4795
4796! surface fluxes and dtg
4797
4798 irb = cir * tgb**4 - emg*lwdn
4799 shb = csh * (tgb - sfctmp )
4800 evb = cev * (estg*rhsur - eair )
4801 ghb = cgh * (tgb - stc(isnow+1))
4802
4803 b = sag-irb-shb-evb-ghb+pahb
4804 a = 4.*cir*tgb**3 + csh + cev*destg + cgh
4805 dtg = b/a
4806
4807 irb = irb + 4.*cir*tgb**3*dtg
4808 shb = shb + csh*dtg
4809 evb = evb + cev*destg*dtg
4810 ghb = ghb + cgh*dtg
4811
4812! update ground surface temperature
4813 tgb = tgb + dtg
4814
4815! for m-o length
4816 h = csh * (tgb - sfctmp)
4817
4818 t = tdc(tgb)
4819 call esat(t, esatw, esati, dsatw, dsati)
4820 if (t .gt. 0.) then
4821 estg = esatw
4822 else
4823 estg = esati
4824 end if
4825 qsfc = ep_2*(estg*rhsur)/(psfc+epsm1*(estg*rhsur))
4826
4827 qfx = (qsfc-qair)*cev*gamma/cpair
4828
4829 end do loop3 ! end stability iteration
4830! -----------------------------------------------------------------
4831
4832! if snow on ground and tg > tfrz: reset tg = tfrz. reevaluate ground fluxes.
4833
4834 if(opt_stc == 1 .or. opt_stc == 3) then
4835 if (snowh > 0.05 .and. tgb > tfrz) then
4836 if(opt_stc == 1) tgb = tfrz
4837 if(opt_stc == 3) tgb = (1.-fsno)*tgb + fsno*tfrz ! mb: allow tg>0c during melt v3.7
4838 irb = cir * tgb**4 - emg*lwdn
4839 shb = csh * (tgb - sfctmp)
4840 evb = cev * (estg*rhsur - eair ) !estg reevaluate ?
4841 ghb = sag+pahb - (irb+shb+evb)
4842 end if
4843 end if
4844
4845! wind stresses
4846
4847 tauxb = -rhoair*cm*ur*uu
4848 tauyb = -rhoair*cm*ur*vv
4849
4850!jref:start; errors in original equation corrected.
4851! 2m air temperature
4852
4853 if(opt_sfc == 1 .or. opt_sfc ==2 ) then
4854 ehb2 = fv*vkc/log((2.+z0h)/z0h)
4855 ehb2 = fv*vkc/(log((2.+z0h)/z0h)-fh2)
4856 cq2b = ehb2
4857 if (ehb2.lt.1.e-5 ) then
4858 t2mb = tgb
4859 q2b = qsfc
4860 else
4861 t2mb = tgb - shb/(rhoair*cpair) * 1./ehb2
4862 q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf)
4863 endif
4864 if (parameters%urban_flag) q2b = qsfc
4865 end if
4866
4867! opt_sfc 3: fh2 is the stability
4868 if(opt_sfc == 3 ) then
4869 ehb2 = fv*vkc/fh2
4870 cq2b = ehb2
4871 if (ehb2.lt.1.e-5 ) then
4872 t2mb = tgb
4873 q2b = qsfc
4874 else
4875 t2mb = tgb - shb/(rhoair*cpair) * 1./ehb2
4876 q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf)
4877 endif
4878 if (parameters%urban_flag) q2b = qsfc
4879 end if
4880
4881 if(opt_sfc == 4) then ! consistent with veg
4882
4883 rahb2 = max(1.,1./(ch2b*wspdb))
4884 ehb2 = 1./rahb2
4885 cq2b = 1./max(1.,1./(cq2b*wspdb)) !
4886
4887 if (ehb2.lt.1.e-5 ) then
4888 t2mb = tgb
4889 q2b = qsfc
4890 else
4891 t2mb = tgb - shb/(rhoair*cpair*ehb2)
4892! q2b = qsfc - qfx/(rhoair*cq2b)
4893 q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf)
4894 end if
4895 endif ! 4
4896
4897! use sfc_diag to calculate t2mb and q2b for opt_sfc=1&3
4898 if(opt_diag ==3) then
4899 if(opt_sfc == 1 .or. opt_sfc == 3) then
4900
4901 fhi = fh2/fh
4902 wrk = 1.0 - fhi
4903 if(thsfc_loc) then ! Use local potential temperature
4904 t2mb = tgb*wrk + sfctmp*prslkix*fhi - (grav+grav)/cp
4905 else ! Use potential temperature referenced to 1000 hPa
4906 t2mb = tgb*wrk + sfctmp*fhi - (grav+grav)/cp
4907 endif
4908
4909 if(evb >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2v
4910 q2b = qsfc*wrk + max(qmin,qair)*fhi
4911 else ! for dew formation, use saturated q at tskin
4912 qss = fpvs(tgb)
4913 qss = ep_2 * qss / (psfc + epsm1 * qss)
4914 q2b= qss*wrk + max(qmin,qair)*fhi
4915 endif
4916 qss = fpvs(t2mb)
4917 qss = ep_2 * qss / (psfc + epsm1 * qss)
4918 q2b = min(q2b,qss)
4919 else
4920 errmsg = 'Problem :opt_diag=3 is only applied for opt_sfc=1&3'
4921 errflg = 1
4922 return
4923 endif
4924 endif
4925 if (parameters%urban_flag) q2b = qsfc
4926
4927! update ch
4928 ch = ehb
4929
4930 end subroutine bare_flux
4931
4932!== begin ragrb ====================================================================================
4933
4937 subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in
4938 zpd ,z0mg ,z0hg ,hcan ,uc , & !in
4939 z0h ,fv ,cwp ,vegtyp ,mpe , & !in
4940 tv ,mozg ,fhg ,fhgh ,iloc ,jloc , & !inout
4941 ramg ,rahg ,rawg ,rb ) !out
4942! --------------------------------------------------------------------------------------------------
4943! compute under-canopy aerodynamic resistance rag and leaf boundary layer
4944! resistance rb
4945! --------------------------------------------------------------------------------------------------
4946 implicit none
4947! --------------------------------------------------------------------------------------------------
4948! inputs
4949
4950 type (noahmp_parameters), intent(in) :: parameters
4951 integer, intent(in) :: iloc
4952 integer, intent(in) :: jloc
4953 integer, intent(in) :: iter
4954 integer, intent(in) :: vegtyp
4955 real (kind=kind_phys), intent(in) :: vai
4956 real (kind=kind_phys), intent(in) :: rhoair
4957 real (kind=kind_phys), intent(in) :: hg
4958 real (kind=kind_phys), intent(in) :: tv
4959 real (kind=kind_phys), intent(in) :: tah
4960 real (kind=kind_phys), intent(in) :: zpd
4961 real (kind=kind_phys), intent(in) :: z0mg
4962 real (kind=kind_phys), intent(in) :: hcan
4963 real (kind=kind_phys), intent(in) :: uc
4964 real (kind=kind_phys), intent(in) :: z0h
4965 real (kind=kind_phys), intent(in) :: z0hg
4966 real (kind=kind_phys), intent(in) :: fv
4967 real (kind=kind_phys), intent(in) :: cwp
4968 real (kind=kind_phys), intent(in) :: mpe
4969
4970! in & out
4971
4972 real (kind=kind_phys), intent(inout) :: mozg
4973 real (kind=kind_phys), intent(inout) :: fhg
4974 real (kind=kind_phys), intent(inout) :: fhgh
4975
4976! outputs
4977 real (kind=kind_phys) :: ramg
4978 real (kind=kind_phys) :: rahg
4979 real (kind=kind_phys) :: rawg
4980 real (kind=kind_phys) :: rb
4981
4982
4983 real (kind=kind_phys) :: kh !turbulent transfer coefficient, sensible heat, (m2/s)
4984 real (kind=kind_phys) :: tmp1 !temporary calculation
4985 real (kind=kind_phys) :: tmp2 !temporary calculation
4986 real (kind=kind_phys) :: tmprah2 !temporary calculation for aerodynamic resistances
4987 real (kind=kind_phys) :: tmprb !temporary calculation for rb
4988 real (kind=kind_phys) :: molg,fhgnew,cwpc
4989 real (kind=kind_phys) :: mozgh, fhgnewh
4990! --------------------------------------------------------------------------------------------------
4991! stability correction to below canopy resistance
4992
4993 mozg = 0.
4994 molg = 0.
4995 mozgh = 0.
4996
4997 if(iter > 1) then
4998 tmp1 = vkc * (grav/tah) * hg/(rhoair*cpair)
4999 if (abs(tmp1) .le. mpe) tmp1 = mpe
5000 molg = -1. * fv**3 / tmp1
5001 mozg = min( (zpd-z0mg)/molg, 1.)
5002 mozgh = min( (hcan - zpd)/molg, 1.)
5003 end if
5004
5005 if (mozg < 0.) then
5006 fhgnew = (1. - 15.*mozg)**(-0.25)
5007 fhgnewh = 0.74 * (1. - 9.*mozg)**(-0.5) ! PHIh
5008 else
5009 fhgnew = 1.+ 4.7*mozg
5010 fhgnewh = 0.74 + 4.7*mozgh ! PHIh
5011 endif
5012
5013 if (iter == 1) then
5014 fhg = fhgnew
5015 fhgh = fhgnewh
5016 else
5017 fhg = 0.5 * (fhg+fhgnew)
5018 fhgh = 0.5 * (fhgh+fhgnewh)
5019 endif
5020
5021 cwpc = (cwp * vai * hcan * fhg)**0.5
5022! cwpc = (cwp*fhg)**0.5
5023 cwpc = max(min(cwpc,5.0),1.0)
5024
5025 tmp1 = exp( -cwpc*z0hg/hcan )
5026 tmp2 = exp( -cwpc*(z0h+zpd)/hcan )
5027 tmprah2 = hcan*exp(cwpc) / cwpc * (tmp1-tmp2)
5028
5029! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg.
5030
5031 kh = max( vkc*fv*(hcan-zpd)/(max(fhgh,0.1)), mpe )
5032 ramg = 0.
5033 rahg = tmprah2 / kh
5034 rawg = rahg
5035
5036! leaf boundary layer resistance
5037
5038 tmprb = cwpc*50. / (1. - exp(-cwpc/2.))
5039 rb = tmprb * sqrt(parameters%dleaf/uc)
5040 rb = min(max(rb, 5.0),50.0) ! limit rb to 5-50, typically rb<50
5041
5042 end subroutine ragrb
5043
5044!== begin sfcdif1 ==================================================================================
5045
5048 subroutine sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in
5049 & zlvl ,zpd ,z0m ,z0h ,ur , & !in
5050 & mpe ,iloc ,jloc , & !in
5051#ifdef CCPP
5052 & moz ,mozsgn ,fm ,fh ,fm2,fh2,fv,errmsg,errflg, & !inout
5053#else
5054 & moz ,mozsgn ,fm ,fh ,fm2,fh2, fv, & !inout
5055#endif
5056 & cm ,ch ,ch2 ) !out
5057! -------------------------------------------------------------------------------------------------
5058! computing surface drag coefficient cm for momentum and ch for heat
5059! -------------------------------------------------------------------------------------------------
5060 implicit none
5061! -------------------------------------------------------------------------------------------------
5062! inputs
5063
5064 type (noahmp_parameters), intent(in) :: parameters
5065 integer, intent(in) :: iloc
5066 integer, intent(in) :: jloc
5067 integer, intent(in) :: iter
5068 real (kind=kind_phys), intent(in) :: sfctmp
5069 real (kind=kind_phys), intent(in) :: rhoair
5070 real (kind=kind_phys), intent(in) :: h
5071 real (kind=kind_phys), intent(in) :: qair
5072 real (kind=kind_phys), intent(in) :: zlvl
5073 real (kind=kind_phys), intent(in) :: zpd
5074 real (kind=kind_phys), intent(in) :: z0h
5075 real (kind=kind_phys), intent(in) :: z0m
5076 real (kind=kind_phys), intent(in) :: ur
5077 real (kind=kind_phys), intent(in) :: mpe
5078! in & out
5079
5080 integer, intent(inout) :: mozsgn
5081 real (kind=kind_phys), intent(inout) :: moz
5082 real (kind=kind_phys), intent(inout) :: fm
5083 real (kind=kind_phys), intent(inout) :: fh
5084 real (kind=kind_phys), intent(inout) :: fm2
5085 real (kind=kind_phys), intent(inout) :: fh2
5086 real (kind=kind_phys), intent(inout) :: fv
5087#ifdef CCPP
5088 character(len=*), intent(inout) :: errmsg
5089 integer, intent(inout) :: errflg
5090#endif
5091
5092! outputs
5093
5094 real (kind=kind_phys), intent(out) :: cm
5095 real (kind=kind_phys), intent(out) :: ch
5096 real (kind=kind_phys), intent(out) :: ch2
5097
5098! locals
5099 real (kind=kind_phys) :: mol !monin-obukhov length (m)
5100 real (kind=kind_phys) :: tmpcm !temporary calculation for cm
5101 real (kind=kind_phys) :: tmpch !temporary calculation for ch
5102 real (kind=kind_phys) :: fmnew !stability correction factor, momentum, for current moz
5103 real (kind=kind_phys) :: fhnew !stability correction factor, sen heat, for current moz
5104 real (kind=kind_phys) :: mozold !monin-obukhov stability parameter from prior iteration
5105 real (kind=kind_phys) :: tmp1,tmp2,tmp3,tmp4,tmp5 !temporary calculation
5106 real (kind=kind_phys) :: tvir !temporary virtual temperature (k)
5107 real (kind=kind_phys) :: moz2 !2/l
5108 real (kind=kind_phys) :: tmpcm2 !temporary calculation for cm2
5109 real (kind=kind_phys) :: tmpch2 !temporary calculation for ch2
5110 real (kind=kind_phys) :: fm2new !stability correction factor, momentum, for current moz
5111 real (kind=kind_phys) :: fh2new !stability correction factor, sen heat, for current moz
5112 real (kind=kind_phys) :: tmp12,tmp22,tmp32 !temporary calculation
5113
5114 real (kind=kind_phys) :: cmfm, chfh, cm2fm2, ch2fh2
5115! -------------------------------------------------------------------------------------------------
5116! monin-obukhov stability parameter moz for next iteration
5117
5118 mozold = moz
5119
5120 if(zlvl <= zpd) then
5121 write(*,*) 'critical problem: zlvl <= zpd; model stops'
5122#ifdef CCPP
5123 errflg = 1
5124 errmsg = "stop in noah-mp"
5125 return
5126#else
5127 call wrf_error_fatal("stop in noah-mp")
5128#endif
5129 endif
5130
5131 tmpcm = log((zlvl-zpd) / z0m)
5132 tmpch = log((zlvl-zpd) / z0h)
5133 tmpcm2 = log((2.0 + z0m) / z0m)
5134 tmpch2 = log((2.0 + z0h) / z0h)
5135
5136 if(iter == 1) then
5137 fv = 0.1
5138 moz = 0.0
5139 mol = 0.0
5140 moz2 = 0.0
5141 else
5142 tvir = (1. + 0.61*qair) * sfctmp
5143 tmp1 = vkc * (grav/tvir) * h/(rhoair*cpair)
5144 if (abs(tmp1) .le. mpe) tmp1 = mpe
5145 mol = -1. * fv**3 / tmp1
5146 moz = min( (zlvl-zpd)/mol, 1.)
5147 moz2 = min( (2.0 + z0h)/mol, 1.)
5148 endif
5149
5150! accumulate number of times moz changes sign.
5151
5152 if (mozold*moz .lt. 0.) mozsgn = mozsgn+1
5153 if (mozsgn .ge. 2) then
5154 moz = 0.
5155 fm = 0.
5156 fh = 0.
5157 moz2 = 0.
5158 fm2 = 0.
5159 fh2 = 0.
5160 endif
5161
5162! evaluate stability-dependent variables using moz from prior iteration
5163 if (moz .lt. 0.) then
5164 tmp1 = (1. - 16.*moz)**0.25
5165 tmp2 = log((1.+tmp1*tmp1)/2.)
5166 tmp3 = log((1.+tmp1)/2.)
5167 fmnew = 2.*tmp3 + tmp2 - 2.*atan(tmp1) + 1.5707963
5168 fhnew = 2*tmp2
5169
5170! 2-meter
5171 tmp12 = (1. - 16.*moz2)**0.25
5172 tmp22 = log((1.+tmp12*tmp12)/2.)
5173 tmp32 = log((1.+tmp12)/2.)
5174 fm2new = 2.*tmp32 + tmp22 - 2.*atan(tmp12) + 1.5707963
5175 fh2new = 2*tmp22
5176 else
5177 fmnew = -5.*moz
5178 fhnew = fmnew
5179 fm2new = -5.*moz2
5180 fh2new = fm2new
5181 endif
5182
5183! except for first iteration, weight stability factors for previous
5184! iteration to help avoid flip-flops from one iteration to the next
5185
5186 if (iter == 1) then
5187 fm = fmnew
5188 fh = fhnew
5189 fm2 = fm2new
5190 fh2 = fh2new
5191 else
5192 fm = 0.5 * (fm+fmnew)
5193 fh = 0.5 * (fh+fhnew)
5194 fm2 = 0.5 * (fm2+fm2new)
5195 fh2 = 0.5 * (fh2+fh2new)
5196 endif
5197
5198! exchange coefficients
5199
5200 fh = min(fh,0.9*tmpch)
5201 fm = min(fm,0.9*tmpcm)
5202 fh2 = min(fh2,0.9*tmpch2)
5203 fm2 = min(fm2,0.9*tmpcm2)
5204
5205 cmfm = tmpcm-fm
5206 chfh = tmpch-fh
5207 cm2fm2 = tmpcm2-fm2
5208 ch2fh2 = tmpch2-fh2
5209 if(abs(cmfm) <= mpe) cmfm = mpe
5210 if(abs(chfh) <= mpe) chfh = mpe
5211 if(abs(cm2fm2) <= mpe) cm2fm2 = mpe
5212 if(abs(ch2fh2) <= mpe) ch2fh2 = mpe
5213 cm = vkc*vkc/(cmfm*cmfm)
5214 ch = vkc*vkc/(cmfm*chfh)
5215 ch2 = vkc*vkc/(cm2fm2*ch2fh2)
5216
5217! friction velocity
5218
5219 fv = ur * sqrt(cm)
5220 ch2 = vkc*fv/ch2fh2
5221
5222 end subroutine sfcdif1
5223
5224!== begin sfcdif2 ==================================================================================
5225
5229 subroutine sfcdif2(parameters,iter ,z0 ,thz0 ,thlm ,sfcspd , & !in
5230 zlm ,iloc ,jloc , & !in
5231 akms ,akhs ,rlmo ,wstar2 , & !in
5232 ustar ) !out
5233
5234! -------------------------------------------------------------------------------------------------
5235! subroutine sfcdif (renamed sfcdif_off to avoid clash with eta pbl)
5236! -------------------------------------------------------------------------------------------------
5237! calculate surface layer exchange coefficients via iterative process.
5238! see chen et al (1997, blm)
5239! -------------------------------------------------------------------------------------------------
5240 implicit none
5241 type (noahmp_parameters), intent(in) :: parameters
5242 integer, intent(in) :: iloc
5243 integer, intent(in) :: jloc
5244 integer, intent(in) :: iter
5245 real (kind=kind_phys), intent(in) :: zlm, z0, thz0, thlm, sfcspd
5246 real (kind=kind_phys), intent(inout) :: akms
5247 real (kind=kind_phys), intent(inout) :: akhs
5248 real (kind=kind_phys), intent(inout) :: rlmo
5249 real (kind=kind_phys), intent(inout) :: wstar2
5250 real (kind=kind_phys), intent(inout) :: ustar
5251
5252 real (kind=kind_phys) zz, pslmu, pslms, pslhu, pslhs
5253 real (kind=kind_phys) xx, pspmu, yy, pspms, psphu, psphs
5254 real (kind=kind_phys) zilfc, zu, zt, rdz, cxch
5255 real (kind=kind_phys) dthv, du2, btgh, zslu, zslt, rlogu, rlogt
5256 real (kind=kind_phys) zetalt, zetalu, zetau, zetat, xlu4, xlt4, xu4, xt4
5257
5258 real (kind=kind_phys) xlu, xlt, xu, xt, psmz, simm, pshz, simh, ustark, rlmn, &
5259 & rlma
5260
5261 integer ilech, itr
5262
5263 integer, parameter :: itrmx = 5
5264 real (kind=kind_phys), parameter :: wwst = 1.2
5265 real (kind=kind_phys), parameter :: wwst2 = wwst * wwst
5266 real (kind=kind_phys), parameter :: vkrm = 0.40
5267 real (kind=kind_phys), parameter :: excm = 0.001
5268 real (kind=kind_phys), parameter :: beta = 1.0 / 270.0
5269 real (kind=kind_phys), parameter :: btg = beta * grav
5270 real (kind=kind_phys), parameter :: elfc = vkrm * btg
5271 real (kind=kind_phys), parameter :: wold = 0.15
5272 real (kind=kind_phys), parameter :: wnew = 1.0 - wold
5273 real (kind=kind_phys), parameter :: pihf = 3.14159265 / 2.
5274 real (kind=kind_phys), parameter :: epsu2 = 1.e-4
5275 real (kind=kind_phys), parameter :: epsust = 0.07
5276 real (kind=kind_phys), parameter :: epsit = 1.e-4
5277 real (kind=kind_phys), parameter :: epsa = 1.e-8
5278 real (kind=kind_phys), parameter :: ztmin = -5.0
5279 real (kind=kind_phys), parameter :: ztmax = 1.0
5280 real (kind=kind_phys), parameter :: hpbl = 1000.0
5281 real (kind=kind_phys), parameter :: sqvisc = 258.2
5282 real (kind=kind_phys), parameter :: ric = 0.183
5283 real (kind=kind_phys), parameter :: rric = 1.0 / ric
5284 real (kind=kind_phys), parameter :: fhneu = 0.8
5285 real (kind=kind_phys), parameter :: rfc = 0.191
5286 real (kind=kind_phys), parameter :: rfac = ric / ( fhneu * rfc * rfc )
5287
5288! ----------------------------------------------------------------------
5289! note: the two code blocks below define functions
5290! ----------------------------------------------------------------------
5291! lech's surface functions
5292 pslmu(zz)= -0.96* log(1.0-4.5* zz)
5293 pslms(zz)= zz * rric -2.076* (1. -1./ (zz +1.))
5294 pslhu(zz)= -0.96* log(1.0-4.5* zz)
5295 pslhs(zz)= zz * rfac -2.076* (1. -1./ (zz +1.))
5296! paulson's surface functions
5297 pspmu(xx)= -2.* log( (xx +1.)*0.5) - log( (xx * xx +1.)*0.5) &
5298 & +2.* atan(xx) &
5299 &- pihf
5300 pspms(yy)= 5.* yy
5301 psphu(xx)= -2.* log( (xx * xx +1.)*0.5)
5302 psphs(yy)= 5.* yy
5303
5304! this routine sfcdif can handle both over open water (sea, ocean) and
5305! over solid surface (land, sea-ice).
5306! ----------------------------------------------------------------------
5307! ztfc: ratio of zoh/zom less or equal than 1
5308! c......ztfc=0.1
5309! czil: constant c in zilitinkevich, s. s.1995,:note about zt
5310! ----------------------------------------------------------------------
5311 ilech = 0
5312
5313! ----------------------------------------------------------------------
5314 zilfc = - parameters%czil * vkrm * sqvisc
5315 zu = z0
5316 rdz = 1./ zlm
5317 cxch = excm * rdz
5318 dthv = thlm - thz0
5319
5320! beljars correction of ustar
5321 du2 = max(sfcspd * sfcspd,epsu2)
5322 btgh = btg * hpbl
5323
5324 if(iter == 1) then
5325 if (btgh * akhs * dthv .ne. 0.0) then
5326 wstar2 = wwst2* abs(btgh * akhs * dthv)** (2./3.)
5327 else
5328 wstar2 = 0.0
5329 end if
5330 ustar = max(sqrt(akms * sqrt(du2+ wstar2)),epsust)
5331 rlmo = elfc * akhs * dthv / ustar **3
5332 end if
5333
5334! zilitinkevitch approach for zt
5335 zt = max(1.e-6,exp(zilfc * sqrt(ustar * z0))* z0)
5336 zslu = zlm + zu
5337 zslt = zlm + zt
5338 rlogu = log(zslu / zu)
5339 rlogt = log(zslt / zt)
5340
5341! ----------------------------------------------------------------------
5342! 1./monin-obukkhov length-scale
5343! ----------------------------------------------------------------------
5344 zetalt = max(zslt * rlmo,ztmin)
5345 rlmo = zetalt / zslt
5346 zetalu = zslu * rlmo
5347 zetau = zu * rlmo
5348 zetat = zt * rlmo
5349
5350 if (ilech .eq. 0) then
5351 if (rlmo .lt. 0.)then
5352 xlu4 = 1. -16.* zetalu
5353 xlt4 = 1. -16.* zetalt
5354 xu4 = 1. -16.* zetau
5355 xt4 = 1. -16.* zetat
5356 xlu = sqrt(sqrt(xlu4))
5357 xlt = sqrt(sqrt(xlt4))
5358 xu = sqrt(sqrt(xu4))
5359
5360 xt = sqrt(sqrt(xt4))
5361 psmz = pspmu(xu)
5362 simm = pspmu(xlu) - psmz + rlogu
5363 pshz = psphu(xt)
5364 simh = psphu(xlt) - pshz + rlogt
5365 else
5366 zetalu = min(zetalu,ztmax)
5367 zetalt = min(zetalt,ztmax)
5368 zetau = min(zetau,ztmax/(zslu/zu)) ! barlage: add limit on zetau/zetat
5369 zetat = min(zetat,ztmax/(zslt/zt)) ! barlage: prevent simm/simh < 0
5370 psmz = pspms(zetau)
5371 simm = pspms(zetalu) - psmz + rlogu
5372 pshz = psphs(zetat)
5373 simh = psphs(zetalt) - pshz + rlogt
5374 end if
5375! ----------------------------------------------------------------------
5376! lech's functions
5377! ----------------------------------------------------------------------
5378 else
5379 if (rlmo .lt. 0.)then
5380 psmz = pslmu(zetau)
5381 simm = pslmu(zetalu) - psmz + rlogu
5382 pshz = pslhu(zetat)
5383 simh = pslhu(zetalt) - pshz + rlogt
5384 else
5385 zetalu = min(zetalu,ztmax)
5386 zetalt = min(zetalt,ztmax)
5387 psmz = pslms(zetau)
5388 simm = pslms(zetalu) - psmz + rlogu
5389 pshz = pslhs(zetat)
5390 simh = pslhs(zetalt) - pshz + rlogt
5391 end if
5392! ----------------------------------------------------------------------
5393 end if
5394
5395! ----------------------------------------------------------------------
5396! beljaars correction for ustar
5397! ----------------------------------------------------------------------
5398 ustar = max(sqrt(akms * sqrt(du2+ wstar2)),epsust)
5399
5400! zilitinkevitch fix for zt
5401 zt = max(1.e-6,exp(zilfc * sqrt(ustar * z0))* z0)
5402 zslt = zlm + zt
5403!-----------------------------------------------------------------------
5404 rlogt = log(zslt / zt)
5405 ustark = ustar * vkrm
5406 if(simm < 1.e-6) simm = 1.e-6 ! limit stability function
5407 akms = max(ustark / simm,cxch)
5408!-----------------------------------------------------------------------
5409! if statements to avoid tangent linear problems near zero
5410!-----------------------------------------------------------------------
5411 if(simh < 1.e-6) simh = 1.e-6 ! limit stability function
5412 akhs = max(ustark / simh,cxch)
5413
5414 if (btgh * akhs * dthv .ne. 0.0) then
5415 wstar2 = wwst2* abs(btgh * akhs * dthv)** (2./3.)
5416 else
5417 wstar2 = 0.0
5418 end if
5419!-----------------------------------------------------------------------
5420 rlmn = elfc * akhs * dthv / ustar **3
5421!-----------------------------------------------------------------------
5422! if(abs((rlmn-rlmo)/rlma).lt.epsit) go to 110
5423!-----------------------------------------------------------------------
5424 rlma = rlmo * wold+ rlmn * wnew
5425!-----------------------------------------------------------------------
5426 rlmo = rlma
5427
5428! write(*,'(a20,10f15.6)')'sfcdif: rlmo=',rlmo,rlmn,elfc , akhs , dthv , ustar
5429! end do
5430! ----------------------------------------------------------------------
5431 end subroutine sfcdif2
5432
5433!== begin sfcdif3 ==================================================================================
5434
5437 subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in
5438 zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in
5439 z0h,zpd ,snowh ,fveg ,garea1 , & !in
5440 ustarx ,fm ,fh ,fm2 ,fh2 , & !inout
5441 fv ,cm ,ch ) !out
5442
5443! -------------------------------------------------------------------------------------------------
5444! computing surface drag coefficient cm for momentum and ch for heat
5445! -------------------------------------------------------------------------------------------------
5446 implicit none
5447! -------------------------------------------------------------------------------------------------
5448! inputs
5449
5450 type (noahmp_parameters), intent(in) :: parameters
5451 integer, intent(in ) :: iloc
5452 integer, intent(in ) :: jloc
5453 integer, intent(in ) :: iter
5454 real (kind=kind_phys), intent(in ) :: sfctmp
5455 real (kind=kind_phys), intent(in ) :: qair
5456 real (kind=kind_phys), intent(in ) :: ur
5457 real (kind=kind_phys), intent(in ) :: zlvl
5458 real (kind=kind_phys), intent(in ) :: tgb
5459 logical, intent(in ) :: thsfc_loc
5460 real (kind=kind_phys), intent(in ) :: prslkix
5461 real (kind=kind_phys), intent(in ) :: prsik1x
5462 real (kind=kind_phys), intent(in ) :: prslk1x
5463 real (kind=kind_phys), intent(in ) :: z0m
5464 real (kind=kind_phys), intent(in ) :: z0h
5465 real (kind=kind_phys), intent(in ) :: zpd
5466 real (kind=kind_phys), intent(in ) :: snowh
5467 real (kind=kind_phys), intent(in ) :: fveg
5468 real (kind=kind_phys), intent(in ) :: garea1
5469 real (kind=kind_phys), intent(inout) :: ustarx
5470 real (kind=kind_phys), intent(inout) :: fm
5471 real (kind=kind_phys), intent(inout) :: fh
5472 real (kind=kind_phys), intent(inout) :: fm2
5473 real (kind=kind_phys), intent(inout) :: fh2
5474 real (kind=kind_phys), intent( out) :: fv
5475 real (kind=kind_phys), intent( out) :: cm
5476 real (kind=kind_phys), intent( out) :: ch
5477
5478 real (kind=kind_phys) :: snwd ! snow depth [mm]
5479 real (kind=kind_phys) :: zlvlb ! reference height - zpd [m]
5480 real (kind=kind_phys) :: virtfac ! virtual temperature factor [-]
5481 real (kind=kind_phys) :: tv1 ! virtual temperature at reference [K]
5482 real (kind=kind_phys) :: thv1 ! virtual theta at reference [K]
5483 real (kind=kind_phys) :: tvs ! virtural surface temperature [K]
5484 real (kind=kind_phys) :: rb1 ! bulk Richardson - stability output
5485 real (kind=kind_phys) :: stress1 ! stress - stability output
5486 real (kind=kind_phys) :: fm10 ! 10-m stability adjustment - stability output
5487 real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx
5488 real (kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0
5489
5490! -------------------------------------------------------------------------------------------------
5491
5492 fv = ustarx
5493! fv = ur*vkc/log((zlvl-zpd)/z0m)
5494
5495 snwd = snowh*1000.0
5496 zlvlb = zlvl - zpd
5497
5498 virtfac = 1.0 + 0.61 * max(qair, 1.0e-8)
5499 tv1 = sfctmp * virtfac
5500
5501 if(thsfc_loc) then ! Use local potential temperature
5502 thv1 = sfctmp * prslkix * virtfac
5503 else ! Use potential temperature reference to 1000 hPa
5504 thv1 = sfctmp / prslk1x * virtfac
5505 endif
5506
5507 tem1 = (z0m - z0lo) / (z0up - z0lo)
5508 tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys)
5509 tem2 = max(fveg, 0.1_kind_phys)
5510 zvfun1 = sqrt(tem1 * tem2)
5511 gdx = sqrt(garea1)
5512
5513 gdx = 3000.0 ! this will remove gdx effect
5514 zvfun1 = 1.0 ! this will remove zvfun effect
5515
5516 if(thsfc_loc) then ! Use local potential temperature
5517 tvs = tgb * virtfac
5518 else ! Use potential temperature referenced to 1000 hPa
5519 tvs = tgb/prsik1x * virtfac
5520 endif
5521
5522 call gfs_stability (zlvlb, zvfun1, gdx, tv1, thv1, ur, z0m, z0h, tvs, grav, thsfc_loc, &
5523 rb1, fm,fh,fm10,fh2,cm,ch,stress1,fv)
5524
5525 end subroutine sfcdif3
5526
5527!== begin gfs_stability ==================================================================================
5528
5529subroutine gfs_stability &
5530! --- inputs:
5531 ( z1, zvfun, gdx, tv1, thv1, wind, z0max, ztmax, tvs, grav, &
5532 thsfc_loc, &
5533! --- outputs:
5534 rb, fm, fh, fm10, fh2, cm, ch, stress, ustar)
5535
5536! Documentation below refers to UTN and STN which are:
5537! UTN (Unstable Tech Note) : NCEP Office Note 356
5538! STN (Stable Tech Note) : NCEP Office Note 321
5539
5540real(kind=kind_phys), parameter :: ca=0.4_kind_phys ! ca - von karman constant
5541
5542real(kind=kind_phys), intent(in) :: z1 ! height model level
5543real(kind=kind_phys), intent(in) :: zvfun ! vegetation adjustment factor
5544real(kind=kind_phys), intent(in) :: gdx ! grid spatial dimension
5545real(kind=kind_phys), intent(in) :: tv1 ! virtual temperature at model level
5546real(kind=kind_phys), intent(in) :: thv1 ! virtual potential temperature at model level
5547real(kind=kind_phys), intent(in) :: wind ! wind speed at model level
5548real(kind=kind_phys), intent(in) :: z0max ! momentum roughness length
5549real(kind=kind_phys), intent(in) :: ztmax ! thermal roughness length
5550real(kind=kind_phys), intent(in) :: tvs ! surface virtual temperature
5551real(kind=kind_phys), intent(in) :: grav ! local gravity
5552logical, intent(in) :: thsfc_loc ! use local theta reference flag
5553
5554real(kind=kind_phys), intent(out) :: rb ! bulk richardson number [-]
5555real(kind=kind_phys), intent(out) :: fm ! phi momentum function (UTN 1.1) [-]
5556real(kind=kind_phys), intent(out) :: fh ! phi heat function (UTN 1.2) [-]
5557real(kind=kind_phys), intent(out) :: fm10 ! 10-meter phi momentum function [-]
5558real(kind=kind_phys), intent(out) :: fh2 ! 2-meter phi heat function [-]
5559real(kind=kind_phys), intent(out) :: cm ! momentum exchange coeficient [-]
5560real(kind=kind_phys), intent(out) :: ch ! heat exchange coeficient [-]
5561real(kind=kind_phys), intent(out) :: stress ! surface stress [m2/s2]
5562real(kind=kind_phys), intent(out) :: ustar ! friction velocity [m/s]
5563
5564! --- locals:
5565real(kind=kind_phys), parameter :: a0 = -3.975 ! UTN 2.37
5566real(kind=kind_phys), parameter :: a1 = 12.32 ! UTN 2.37
5567real(kind=kind_phys), parameter :: b1 = -7.755 ! UTN 2.37
5568real(kind=kind_phys), parameter :: b2 = 6.041 ! UTN 2.37
5569real(kind=kind_phys), parameter :: a0p = -7.941 ! UTN 2.38
5570real(kind=kind_phys), parameter :: a1p = 24.75 ! UTN 2.38
5571real(kind=kind_phys), parameter :: b1p = -8.705 ! UTN 2.38
5572real(kind=kind_phys), parameter :: b2p = 7.899 ! UTN 2.38
5573
5574real(kind=kind_phys), parameter :: alpha = 5.0 ! alpha in e.g., STN 1.10
5575real(kind=kind_phys), parameter :: alpha4 = 4.0 * alpha ! term in aa
5576real(kind=kind_phys), parameter :: xkrefsqr = 0.3 ! baseline maximum z/L
5577real(kind=kind_phys), parameter :: xkmin = 0.05 ! min multiplier for grid size and vegetation
5578real(kind=kind_phys), parameter :: xkgdx = 3000.0 ! critical grid scale for diffusivity[m^0.5]
5579real(kind=kind_phys), parameter :: zolmin = -10.0 ! minimum z/L
5580real(kind=kind_phys), parameter :: zero = 0.0
5581real(kind=kind_phys), parameter :: one = 1.0
5582
5583real(kind=kind_phys) :: aa
5584real(kind=kind_phys) :: aa0
5585real(kind=kind_phys) :: bb
5586real(kind=kind_phys) :: bb0
5587real(kind=kind_phys) :: dtv
5588real(kind=kind_phys) :: adtv
5589real(kind=kind_phys) :: hl1
5590real(kind=kind_phys) :: hl12
5591real(kind=kind_phys) :: pm
5592real(kind=kind_phys) :: ph
5593real(kind=kind_phys) :: pm10
5594real(kind=kind_phys) :: ph2
5595real(kind=kind_phys) :: z1i
5596real(kind=kind_phys) :: fms
5597real(kind=kind_phys) :: fhs
5598real(kind=kind_phys) :: hl0
5599real(kind=kind_phys) :: hl0inf
5600real(kind=kind_phys) :: hlinf
5601real(kind=kind_phys) :: hl110
5602real(kind=kind_phys) :: hlt
5603real(kind=kind_phys) :: hltinf
5604real(kind=kind_phys) :: olinf
5605real(kind=kind_phys) :: tem1
5606real(kind=kind_phys) :: tem2
5607real(kind=kind_phys) :: zolmax
5608
5609real(kind=kind_phys) xkzo
5610
5611z1i = one / z1 ! inverse of model height
5612
5613!
5614! set background diffusivities with one for gdx >= xkgdx and
5615! as a function of horizontal grid size for gdx < xkgdx
5616! (i.e., gdx/xkgdx for gdx < xkgdx)
5617!
5618
5619if(gdx >= xkgdx) then
5620 xkzo = one
5621else
5622 xkzo = gdx / xkgdx
5623endif
5624
5625tem1 = tv1 - tvs
5626if(tem1 > zero) then ! for stable case, adjust for vegetation cover
5627 tem2 = xkzo * zvfun
5628 xkzo = min(max(tem2, xkmin), xkzo)
5629endif
5630
5631zolmax = xkrefsqr / sqrt(xkzo) ! maximum z/L
5632
5633! compute stability indices (rb and hlinf)
5634
5635 dtv = thv1 - tvs
5636 adtv = max(abs(dtv),0.001_kind_phys)
5637 dtv = sign(1.0_kind_phys,dtv) * adtv
5638
5639 if(thsfc_loc) then ! Use local potential temperature
5640 rb = max(-5000.0_kind_phys, (grav+grav) * dtv * z1 &
5641 / ((thv1 + tvs) * wind * wind))
5642 else ! Use potential temperature referenced to 1000 hPa
5643 rb = max(-5000.0_kind_phys, grav * dtv * z1 &
5644 / (tv1 * wind * wind))
5645 endif
5646
5647 tem1 = one / z0max ! 1/z0m
5648 tem2 = one / ztmax ! 1/z0t
5649 fm = log((z0max+z1) * tem1) ! neutral phi_m
5650 fh = log((ztmax+z1) * tem2) ! neutral phi_h
5651 fm10 = log((z0max+10.0_kind_phys) * tem1) ! neutral phi_m at 10 meters
5652 fh2 = log((ztmax+2.0_kind_phys) * tem2) ! neutral phi_h at 2 meters
5653 hlinf = rb * fm * fm / fh ! z/L STN 2.7
5654 hlinf = min(max(hlinf,zolmin),zolmax) ! z/L, xi in STN/UTN
5655!
5656! stable case
5657!
5658 if (dtv >= zero) then
5659 hl1 = hlinf ! z/L, xi in STN
5660 if(hlinf > 0.25_kind_phys) then ! z/L > 0.25, do two iterations
5661 tem1 = hlinf * z1i ! 1/L
5662 hl0inf = z0max * tem1 ! z0m/z1, zi_0 in STN
5663 hltinf = ztmax * tem1 ! z0t/z1, zi_0 in STN
5664 aa = sqrt(one + alpha4 * hlinf) ! sqrt term of STN 2.16 with z
5665 aa0 = sqrt(one + alpha4 * hl0inf) ! sqrt term of STN 2.16 with z0m
5666 bb = aa ! sqrt term of STN 2.16 with z
5667 bb0 = sqrt(one + alpha4 * hltinf) ! sqrt term of STN 2.16 with z0t
5668 pm = aa0 - aa + log( (aa + one)/(aa0 + one) ) ! psi_m STN 3.11
5669 ph = bb0 - bb + log( (bb + one)/(bb0 + one) ) ! psi_h STN 3.11
5670 fms = fm - pm ! phi_m STN 3.10
5671 fhs = fh - ph ! phi_h STN 3.10
5672 hl1 = fms * fms * rb / fhs ! z/L iteration STN 3.8
5673 hl1 = min(hl1, zolmax) ! z/L iteration
5674 endif
5675!
5676! second iteration
5677!
5678 tem1 = hl1 * z1i ! 1/L
5679 hl0 = z0max * tem1 ! z0m/z1
5680 hlt = ztmax * tem1 ! z0t/z1
5681 aa = sqrt(one + alpha4 * hl1) ! sqrt term of STN 2.16 with z
5682 aa0 = sqrt(one + alpha4 * hl0) ! sqrt term of STN 2.16 with z0m
5683 bb = aa ! sqrt term of STN 2.16 with z
5684 bb0 = sqrt(one + alpha4 * hlt) ! sqrt term of STN 2.16 with z0t
5685 pm = aa0 - aa + log( (one+aa)/(one+aa0) ) ! psi_m STN 3.11
5686 ph = bb0 - bb + log( (one+bb)/(one+bb0) ) ! psi_h STN 3.11
5687 hl110 = hl1 * 10.0_kind_phys * z1i ! 10/L
5688 aa = sqrt(one + alpha4 * hl110) ! sqrt term of STN 2.16 with z=10m
5689 pm10 = aa0 - aa + log( (one+aa)/(one+aa0) ) ! psi_m STN 3.11 with z=10m
5690 hl12 = (hl1+hl1) * z1i ! 2/L
5691! aa = sqrt(one + alpha4 * hl12)
5692 bb = sqrt(one + alpha4 * hl12) ! sqrt term of STN 2.16 with z=2m
5693 ph2 = bb0 - bb + log( (one+bb)/(one+bb0) ) ! psi_m STN 3.11 with z=2m
5694!
5695! unstable case - check for unphysical obukhov length
5696! see steps in UTN Sec. D
5697!
5698 else ! dtv < 0 case
5699
5700 olinf = z1 / hlinf ! z/L, xi in UTN
5701 tem1 = 50.0_kind_phys * z0max ! 50 * z0m, z/L limit for calc methods, see UTN Sec. E
5702 if(abs(olinf) <= tem1) then !
5703 hlinf = -z1 / tem1 !
5704 hlinf = max(hlinf, zolmin)
5705 endif
5706!
5707! get pm and ph
5708!
5709 if (hlinf >= -0.5_kind_phys) then
5710 hl1 = hlinf
5711 pm = (a0 + a1*hl1) * hl1 / (one+ (b1+b2*hl1) *hl1) ! psi_m UTN 2.37
5712 ph = (a0p + a1p*hl1) * hl1 / (one+ (b1p+b2p*hl1)*hl1) ! psi_h UTN 2.38
5713 hl110 = hl1 * 10.0_kind_phys * z1i ! 10/L
5714 pm10 = (a0 + a1*hl110) * hl110/(one+(b1+b2*hl110)*hl110) ! psi_m UTN 2.37 with z=10m
5715 hl12 = (hl1+hl1) * z1i ! 2/L
5716 ph2 = (a0p + a1p*hl12) * hl12/(one+(b1p+b2p*hl12)*hl12) ! psi_h UTN 2.38 with z=2m
5717 else ! z/L < -0.5
5718 hl1 = -hlinf ! -z/L
5719 tem1 = one / sqrt(hl1) ! sqrt(-z/L)
5720 pm = log(hl1) + 2.0_kind_phys * sqrt(tem1) - 0.8776_kind_phys ! UTN 2.64, first three terms
5721 ph = log(hl1) + 0.5_kind_phys * tem1 + 1.386_kind_phys ! UTN 2.65, first three terms
5722 hl110 = hl1 * 10.0_kind_phys * z1i ! 10/L
5723 pm10 = log(hl110) + 2.0_kind_phys/sqrt(sqrt(hl110)) - 0.8776_kind_phys ! psi_m UTN 2.64 with z=10m
5724 hl12 = (hl1+hl1) * z1i ! 2/L
5725 ph2 = log(hl12) + 0.5_kind_phys / sqrt(hl12) + 1.386_kind_phys ! psi_h UTN 2.65 with z=2m
5726 endif
5727
5728 endif ! end of if (dtv >= 0 ) then loop
5729!
5730! finish the exchange coefficient computation to provide fm and fh
5731!
5732 fm = fm - pm ! phi_m
5733 fh = fh - ph ! phi_h
5734 fm10 = fm10 - pm10 ! phi_m at 10m
5735 fh2 = fh2 - ph2 ! phi_h at 2m
5736 cm = ca * ca / (fm * fm) ! momentum exchange coef = k^2/phi_m^2
5737 ch = ca * ca / (fm * fh) ! heat exchange coef = k^2/phi_m/phi_h
5738 tem1 = 0.00001_kind_phys/z1 ! minimum exhange coef (?)
5739 cm = max(cm, tem1)
5740 ch = max(ch, tem1)
5741 stress = cm * wind * wind ! surface stress = Cm*U*U
5742 ustar = sqrt(stress) ! friction velocity
5743
5744 return
5745!.................................
5746 end subroutine gfs_stability
5747!---------------------------------
5748
5749!== begin thermalz0
5750!==================================================================================
5751
5753! compute thermal roughness length based on option opt_trs.
5754
5755 subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl, zpd, ezpd, & !in
5756 ustarx, vegtyp, vaie, ur, c_sigma_f0, c_sigma_f1, a1, & !in
5757 cdmn_v, cdmn_g, surface_flag, & !in
5758 z0m_out, z0h_out ) !out
5759
5760! compute thermal roughness length based on option opt_trs.
5761! -------------------------------------------------------------------------------------------------
5762 implicit none
5763! -------------------------------------------------------------------------------------------------
5764! inputs
5765
5766 type (noahmp_parameters),intent(in ) :: parameters ! parameters data structure
5767 integer , intent(in ) :: vegtyp ! vegetation type
5768 integer , intent(in ) :: surface_flag ! 0=bare 1=vegetation 2=composite
5769 real (kind=kind_phys), intent(in ) :: fveg ! vegetation fraction [0.0-1.0]
5770 real (kind=kind_phys), intent(in ) :: z0m ! z0 momentum [m]
5771 real (kind=kind_phys), intent(in ) :: z0mg ! z0 momentum, ground [m]
5772 real (kind=kind_phys), intent(in ) :: zlvl ! reference height [m]
5773 real (kind=kind_phys), intent(in ) :: zpd ! zero plane displacement [m]
5774 real (kind=kind_phys), intent(in ) :: ezpd ! grid zero plane displacement [m]
5775 real (kind=kind_phys), intent(in ) :: ustarx ! friction velocity [m/s]
5776 real (kind=kind_phys), intent(in ) :: vaie ! exposed LAI + SAI [m2/m2]
5777 real (kind=kind_phys), intent(in ) :: ur ! wind speed [m/s]
5778 real (kind=kind_phys), intent(in ) :: a1 ! Blumel 99 eqn 43
5779 real (kind=kind_phys), intent(in ) :: cdmn_v ! neutral momentum drag coefficient for vegetation
5780 real (kind=kind_phys), intent(in ) :: cdmn_g ! neutral momentum drag coefficient for bare ground
5781 real (kind=kind_phys), intent(inout) :: c_sigma_f0 ! C factor for no vegetation Blumel99 eqn 35
5782 real (kind=kind_phys), intent(inout) :: c_sigma_f1 ! C factor for full vegetation Blumel99 eqn 39
5783 real (kind=kind_phys), intent(out ) :: z0m_out ! output z0 momentum [m]
5784 real (kind=kind_phys), intent(out ) :: z0h_out ! output z0 heat [m]
5785
5786! local
5787 real (kind=kind_phys) :: czil ! Zilitinkevich factor
5788 real (kind=kind_phys) :: coeff_a ! slope of Blumel99 eqn 40 Blumel99 eqn 41
5789 real (kind=kind_phys) :: coeff_b ! intercept of Blumel99 eqn 40 Blumel99 eqn 42
5790 real (kind=kind_phys) :: c_sigma_fveg ! estimated C factor Blumel99 eqn 40
5791 real (kind=kind_phys) :: g_sigma ! weighting function Blumel99 eqn 22
5792 real (kind=kind_phys) :: sigma_a ! momentum partition factor Blumel99 eqn 8
5793 real (kind=kind_phys) :: cdmn ! grid neutral momentum drag coefficient Blumel99 eqn 21
5794 real (kind=kind_phys) :: reyn ! roughness Reynolds number Blumel99 eqn 36c
5795 real (kind=kind_phys) :: kb_sigma_f0 ! bare ground kb^-1 Blumel99 eqn 36ab
5796 real (kind=kind_phys) :: kb_sigma_f1 ! vegetated kb^-1 Blumel99 eqn 38
5797 real (kind=kind_phys) :: kb_sigma_fveg! grid estimated kb^-1 Blumel99 eqn 34
5798
5799 integer, parameter :: bare_flag = 0, vegetated_flag = 1, composite_flag = 2
5800 integer, parameter :: z0heqz0m = 1, &
5801 chen09 = 2, &
5802 tessel = 3, &
5803 blumel99 = 4
5804 real (kind=kind_phys), parameter :: blumel_gamma = 0.5, &
5805 blumel_zeta = 1.0, &
5806 viscosity = 1.5e-5
5807
5808! -------------------------------------------------------------------------------------------------
5809 czil = 0.5
5810 coeff_a = 0.0
5811 coeff_b = 0.0
5812 c_sigma_fveg = 0.0
5813 g_sigma = 0.0
5814 cdmn = 0.0
5815 reyn = 0.0
5816 sigma_a = 0.0
5817 kb_sigma_fveg = 0.0
5818 kb_sigma_f0 = 0.0
5819 kb_sigma_f1 = 0.0
5820
5821 surface_flag_select : select case(surface_flag)
5822
5823 case (composite_flag) ! calculate grid based z0m and z0h
5824
5825 if (opt_trs == z0heqz0m) then
5826
5827 z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg))
5828 z0h_out = z0m_out
5829
5830 elseif (opt_trs == chen09) then
5831
5832! z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg))
5833 z0m_out = fveg * z0m + (1.0 - fveg) * z0mg
5834 czil = 10.0 ** (- 0.4 * parameters%hvt)
5835
5836 reyn = ustarx*z0m_out/viscosity ! Blumel99 eqn 36c
5837 if (reyn > 2.0) then
5838 kb_sigma_f0 = 2.46*reyn**0.25 - log(7.4) ! Blumel99 eqn 36a
5839 else
5840 kb_sigma_f0 = - log(0.397) ! Blumel99 eqn 36b
5841 endif
5842
5843 z0h_out = exp( fveg * log(z0m * exp(-czil*0.4*258.2*sqrt(ustarx*z0m))) + &
5844 (1.0 - fveg) * log(max(z0m/exp(kb_sigma_f0),1.0e-6)) )
5845
5846 elseif (opt_trs == tessel) then
5847
5848 z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg))
5849 if (vegtyp <= 5) then
5850 z0h_out = fveg * log(z0m) + (1.0 - fveg) * log(z0mg * 0.1)
5851 else
5852 z0h_out = fveg * log(z0m * 0.01) + (1.0 - fveg) * log(z0mg * 0.1)
5853 endif
5854
5855 elseif (opt_trs == blumel99) then
5856
5857 coeff_a = (c_sigma_f0 - c_sigma_f1)/(1.0 - exp(-1.0*a1)) ! Blumel99 eqn 41
5858 coeff_b = c_sigma_f0 - coeff_a ! Blumel99 eqn 42
5859 c_sigma_fveg = coeff_a * exp(-1.0*a1*fveg) + coeff_b ! Blumel99 eqn 40
5860
5861! blumel_gamma = 0.5 ~ 1.0 and blumel_zeta = 0 ~ 1.0, adjustable empirical
5862! canopy roughness geometry parameter; currently fveg = 0.78 has the largest
5863! momentum flux; can test the fveg-based average by setting 0.5 to 1.0 and 1.0
5864! to 0.0 ! see Blumel; JAM,1999
5865
5866 g_sigma = fveg**blumel_gamma + fveg*(1.0-fveg)*blumel_zeta ! Blumel99 eqn 22
5867 cdmn = g_sigma*cdmn_v + (1.0-g_sigma)*cdmn_g ! Blumel99 eqn 21
5868 z0m_out = (zlvl - ezpd)*exp(-0.4/sqrt(cdmn)) ! Blumel99 eqn 24
5869 kb_sigma_fveg = c_sigma_fveg/log((zlvl-ezpd)/z0m_out) - &
5870 log((zlvl-ezpd)/z0m_out) ! Blumel99 eqn 34
5871 z0h_out = z0m_out/exp(kb_sigma_fveg)
5872
5873 endif
5874
5875 case (bare_flag) ! calculate z0m and z0h over bare tile
5876
5877 z0m_out = z0mg
5878
5879 if (opt_trs == z0heqz0m) then
5880
5881 z0h_out = z0m_out
5882
5883 elseif (opt_trs == chen09 .or. opt_trs == tessel) then
5884
5885 if (vegtyp <= 5) then
5886 z0h_out = z0m_out
5887 else
5888 z0h_out = z0m_out * 0.01
5889 endif
5890
5891 elseif (opt_trs == blumel99) then
5892
5893 reyn = ustarx*z0m_out/viscosity ! Blumel99 eqn 36c
5894 if (reyn > 2.0) then
5895 kb_sigma_f0 = 2.46*reyn**0.25 - log(7.4) ! Blumel99 eqn 36a
5896 else
5897 kb_sigma_f0 = - log(0.397) ! Blumel99 eqn 36b
5898 endif
5899
5900 z0h_out = max(z0m_out/exp(kb_sigma_f0),1.0e-6)
5901 c_sigma_f0 = log((zlvl-zpd)/z0m_out) * &
5902 (log((zlvl-zpd)/z0m_out) + kb_sigma_f0) ! Blumel99 eqn 35
5903
5904 endif
5905
5906 case (vegetated_flag) ! calculate z0m and z0h over vegetated tile
5907
5908 z0m_out = z0m
5909
5910 if (opt_trs == z0heqz0m) then
5911
5912 z0h_out = z0m_out
5913
5914 elseif (opt_trs == chen09) then
5915
5916 czil = 10.0 ** (- 0.4 * parameters%hvt)
5917 z0h_out = z0m_out * exp(-czil*0.4*258.2*sqrt(ustarx*z0m_out))
5918
5919 elseif (opt_trs == tessel) then
5920
5921 if (vegtyp <= 5) then
5922 z0h_out = z0m_out
5923 else
5924 z0h_out = z0m_out*0.01
5925 endif
5926
5927 elseif (opt_trs == blumel99) then
5928
5929 sigma_a = 1.0 - (0.5/(0.5+vaie)) * exp(-vaie**2/8.0) ! Blumel99 eqn 8
5930 kb_sigma_f1 = 16.4 * (sigma_a*vaie**3)**(-0.25) * & ! Blumel99 eqn 38
5931 sqrt(parameters%dleaf*ur/log((zlvl-zpd)/z0m_out))
5932 z0h_out = z0m_out/exp(kb_sigma_f1)
5933 c_sigma_f1 = log((zlvl-zpd)/z0m_out)*(log((zlvl-zpd)/z0m_out)+kb_sigma_f1) ! Blumel99 eqn 39
5934
5935 endif
5936
5937 end select surface_flag_select
5938
5939 end subroutine thermalz0
5940
5941!== begin esat =====================================================================================
5942
5946 subroutine esat(t, esw, esi, desw, desi)
5947!---------------------------------------------------------------------------------------------------
5948! use polynomials to calculate saturation vapor pressure and derivative with
5949! respect to temperature: over water when t > 0 c and over ice when t <= 0 c
5950 implicit none
5951!---------------------------------------------------------------------------------------------------
5952! in
5953
5954 real (kind=kind_phys), intent(in) :: t
5955
5956!out
5957
5958 real (kind=kind_phys), intent(out) :: esw
5959 real (kind=kind_phys), intent(out) :: esi
5960 real (kind=kind_phys), intent(out) :: desw
5961 real (kind=kind_phys), intent(out) :: desi
5962
5963! local
5964
5965 real (kind=kind_phys) :: a0,a1,a2,a3,a4,a5,a6 !coefficients for esat over water
5966 real (kind=kind_phys) :: b0,b1,b2,b3,b4,b5,b6 !coefficients for esat over ice
5967 real (kind=kind_phys) :: c0,c1,c2,c3,c4,c5,c6 !coefficients for dsat over water
5968 real (kind=kind_phys) :: d0,d1,d2,d3,d4,d5,d6 !coefficients for dsat over ice
5969
5970 parameter(a0=6.107799961 , a1=4.436518521e-01, &
5971 a2=1.428945805e-02, a3=2.650648471e-04, &
5972 a4=3.031240396e-06, a5=2.034080948e-08, &
5973 a6=6.136820929e-11)
5974
5975 parameter(b0=6.109177956 , b1=5.034698970e-01, &
5976 b2=1.886013408e-02, b3=4.176223716e-04, &
5977 b4=5.824720280e-06, b5=4.838803174e-08, &
5978 b6=1.838826904e-10)
5979
5980 parameter(c0= 4.438099984e-01, c1=2.857002636e-02, &
5981 c2= 7.938054040e-04, c3=1.215215065e-05, &
5982 c4= 1.036561403e-07, c5=3.532421810e-10, &
5983 c6=-7.090244804e-13)
5984
5985 parameter(d0=5.030305237e-01, d1=3.773255020e-02, &
5986 d2=1.267995369e-03, d3=2.477563108e-05, &
5987 d4=3.005693132e-07, d5=2.158542548e-09, &
5988 d6=7.131097725e-12)
5989
5990 esw = 100.*(a0+t*(a1+t*(a2+t*(a3+t*(a4+t*(a5+t*a6))))))
5991 esi = 100.*(b0+t*(b1+t*(b2+t*(b3+t*(b4+t*(b5+t*b6))))))
5992 desw = 100.*(c0+t*(c1+t*(c2+t*(c3+t*(c4+t*(c5+t*c6))))))
5993 desi = 100.*(d0+t*(d1+t*(d2+t*(d3+t*(d4+t*(d5+t*d6))))))
5994
5995 end subroutine esat
5996
5997!== begin stomata ==================================================================================
5998
6001 subroutine stomata (parameters,vegtyp ,mpe ,apar ,foln ,iloc , jloc, & !in
6002 tv ,ei ,ea ,sfctmp ,sfcprs , & !in
6003 o2 ,co2 ,igs ,btran ,rb , & !in
6004 rs ,psn ) !out
6005! --------------------------------------------------------------------------------------------------
6006 implicit none
6007! --------------------------------------------------------------------------------------------------
6008! input
6009 type (noahmp_parameters), intent(in) :: parameters
6010 integer,intent(in) :: iloc
6011 integer,intent(in) :: jloc
6012 integer,intent(in) :: vegtyp
6013
6014 real (kind=kind_phys), intent(in) :: igs
6015 real (kind=kind_phys), intent(in) :: mpe
6016
6017 real (kind=kind_phys), intent(in) :: tv
6018 real (kind=kind_phys), intent(in) :: ei
6019 real (kind=kind_phys), intent(in) :: ea
6020 real (kind=kind_phys), intent(in) :: apar
6021 real (kind=kind_phys), intent(in) :: o2
6022 real (kind=kind_phys), intent(in) :: co2
6023 real (kind=kind_phys), intent(in) :: sfcprs
6024 real (kind=kind_phys), intent(in) :: sfctmp
6025 real (kind=kind_phys), intent(in) :: btran
6026 real (kind=kind_phys), intent(in) :: foln
6027 real (kind=kind_phys), intent(in) :: rb
6028
6029! output
6030 real (kind=kind_phys), intent(out) :: rs
6031 real (kind=kind_phys), intent(out) :: psn
6032
6033! in&out
6034 real (kind=kind_phys) :: rlb !boundary layer resistance (s m2 / umol)
6035! ---------------------------------------------------------------------------------------------
6036
6037! ------------------------ local variables ----------------------------------------------------
6038 integer :: iter !iteration index
6039 integer :: niter !number of iterations
6040
6041 data niter /3/
6042 save niter
6043
6044 real (kind=kind_phys) :: ab !used in statement functions
6045 real (kind=kind_phys) :: bc !used in statement functions
6046 real (kind=kind_phys) :: f1 !generic temperature response (statement function)
6047 real (kind=kind_phys) :: f2 !generic temperature inhibition (statement function)
6048 real (kind=kind_phys) :: tc !foliage temperature (degree celsius)
6049 real (kind=kind_phys) :: cs !co2 concentration at leaf surface (pa)
6050 real (kind=kind_phys) :: kc !co2 michaelis-menten constant (pa)
6051 real (kind=kind_phys) :: ko !o2 michaelis-menten constant (pa)
6052 real (kind=kind_phys) :: a,b,c,q !intermediate calculations for rs
6053 real (kind=kind_phys) :: r1,r2 !roots for rs
6054 real (kind=kind_phys) :: fnf !foliage nitrogen adjustment factor (0 to 1)
6055 real (kind=kind_phys) :: ppf !absorb photosynthetic photon flux (umol photons/m2/s)
6056 real (kind=kind_phys) :: wc !rubisco limited photosynthesis (umol co2/m2/s)
6057 real (kind=kind_phys) :: wj !light limited photosynthesis (umol co2/m2/s)
6058 real (kind=kind_phys) :: we !export limited photosynthesis (umol co2/m2/s)
6059 real (kind=kind_phys) :: cp !co2 compensation point (pa)
6060 real (kind=kind_phys) :: ci !internal co2 (pa)
6061 real (kind=kind_phys) :: awc !intermediate calculation for wc
6062 real (kind=kind_phys) :: vcmx !maximum rate of carbonylation (umol co2/m2/s)
6063 real (kind=kind_phys) :: j !electron transport (umol co2/m2/s)
6064 real (kind=kind_phys) :: cea !constrain ea or else model blows up
6065 real (kind=kind_phys) :: cf !s m2/umol -> s/m
6066
6067 f1(ab,bc) = ab**((bc-25.)/10.)
6068 f2(ab) = 1. + exp((-2.2e05+710.*(ab+273.16))/(8.314*(ab+273.16)))
6069 real (kind=kind_phys) :: t
6070! ---------------------------------------------------------------------------------------------
6071
6072! initialize rs=rsmax and psn=0 because will only do calculations
6073! for apar > 0, in which case rs <= rsmax and psn >= 0
6074
6075 cf = sfcprs/(8.314*sfctmp)*1.e06
6076 rs = 1./parameters%bp * cf
6077 psn = 0.
6078
6079 if (apar .le. 0.) return
6080
6081 fnf = min( foln/max(mpe,parameters%folnmx), 1.0 )
6082 tc = tv-tfrz
6083 ppf = 4.6*apar
6084 j = ppf*parameters%qe25
6085 kc = parameters%kc25 * f1(parameters%akc,tc)
6086 ko = parameters%ko25 * f1(parameters%ako,tc)
6087 awc = kc * (1.+o2/ko)
6088 cp = 0.5*kc/ko*o2*0.21
6089 vcmx = parameters%vcmx25 / f2(tc) * fnf * btran * f1(parameters%avcmx,tc)
6090
6091! first guess ci
6092
6093 ci = 0.7*co2*parameters%c3psn + 0.4*co2*(1.-parameters%c3psn)
6094
6095! rb: s/m -> s m**2 / umol
6096
6097 rlb = rb/cf
6098
6099! constrain ea
6100
6101 cea = max(0.25*ei*parameters%c3psn+0.40*ei*(1.-parameters%c3psn), min(ea,ei) )
6102
6103! ci iteration
6104!jref: c3psn is equal to 1 for all veg types.
6105 do iter = 1, niter
6106 wj = max(ci-cp,0.)*j/(ci+2.*cp)*parameters%c3psn + j*(1.-parameters%c3psn)
6107 wc = max(ci-cp,0.)*vcmx/(ci+awc)*parameters%c3psn + vcmx*(1.-parameters%c3psn)
6108 we = 0.5*vcmx*parameters%c3psn + 4000.*vcmx*ci/sfcprs*(1.-parameters%c3psn)
6109 psn = min(wj,wc,we) * igs
6110
6111 cs = max( co2-1.37*rlb*sfcprs*psn, mpe )
6112 a = parameters%mp*psn*sfcprs*cea / (cs*ei) + parameters%bp
6113 b = ( parameters%mp*psn*sfcprs/cs + parameters%bp ) * rlb - 1.
6114 c = -rlb
6115 if (b .ge. 0.) then
6116 q = -0.5*( b + sqrt(b*b-4.*a*c) )
6117 else
6118 q = -0.5*( b - sqrt(b*b-4.*a*c) )
6119 end if
6120 r1 = q/a
6121 r2 = c/q
6122 rs = max(r1,r2)
6123 ci = max( cs-psn*sfcprs*1.65*rs, 0. )
6124 end do
6125
6126! rs, rb: s m**2 / umol -> s/m
6127
6128 rs = rs*cf
6129
6130 end subroutine stomata
6131
6132!== begin canres ===================================================================================
6133
6139 subroutine canres (parameters,ep_2,epsm1,par ,sfctmp,rcsoil ,eah ,sfcprs , & !in
6140 rc ,psn ,iloc ,jloc ) !out
6141
6142! --------------------------------------------------------------------------------------------------
6143! calculate canopy resistance which depends on incoming solar radiation,
6144! air temperature, atmospheric water vapor pressure deficit at the
6145! lowest model level, and soil moisture (preferably unfrozen soil
6146! moisture rather than total)
6147! --------------------------------------------------------------------------------------------------
6148! source: jarvis (1976), noilhan and planton (1989, mwr), jacquemin and
6149! noilhan (1990, blm). chen et al (1996, jgr, vol 101(d3), 7251-7268),
6150! eqns 12-14 and table 2 of sec. 3.1.2
6151! --------------------------------------------------------------------------------------------------
6152!niu use module_noahlsm_utility
6153! --------------------------------------------------------------------------------------------------
6154 implicit none
6155! --------------------------------------------------------------------------------------------------
6156! inputs
6157
6158 type (noahmp_parameters), intent(in) :: parameters
6159 integer, intent(in) :: iloc
6160 integer, intent(in) :: jloc
6161 real (kind=kind_phys), intent(in) :: ep_2
6162 real (kind=kind_phys), intent(in) :: epsm1
6163 real (kind=kind_phys), intent(in) :: par
6164 real (kind=kind_phys), intent(in) :: sfctmp
6165 real (kind=kind_phys), intent(in) :: sfcprs
6166 real (kind=kind_phys), intent(in) :: eah
6167 real (kind=kind_phys), intent(in) :: rcsoil
6168
6169!outputs
6170
6171 real (kind=kind_phys), intent(out) :: rc
6172 real (kind=kind_phys), intent(out) :: psn
6173
6174!local
6175
6176 real (kind=kind_phys) :: rcq
6177 real (kind=kind_phys) :: rcs
6178 real (kind=kind_phys) :: rct
6179 real (kind=kind_phys) :: ff
6180 real (kind=kind_phys) :: q2 !water vapor mixing ratio (kg/kg)
6181 real (kind=kind_phys) :: q2sat !saturation q2
6182 real (kind=kind_phys) :: dqsdt2 !d(q2sat)/d(t)
6183
6184! rsmin, rsmax, topt, rgl, hs are canopy stress parameters set in redprm
6185! ----------------------------------------------------------------------
6186! initialize canopy resistance multiplier terms.
6187! ----------------------------------------------------------------------
6188 rc = 0.0
6189 rcs = 0.0
6190 rct = 0.0
6191 rcq = 0.0
6192
6193! compute q2 and q2sat
6194
6195 q2 = ep_2 * eah / (sfcprs + epsm1 * eah) !specific humidity [kg/kg]
6196 q2 = q2 / (1.0 - q2) !mixing ratio [kg/kg]
6197
6198 call calhum(parameters,sfctmp, sfcprs, q2sat, dqsdt2)
6199
6200! contribution due to incoming solar radiation
6201
6202 ff = 2.0 * par / parameters%rgl
6203 rcs = (ff + parameters%rsmin / parameters%rsmax) / (1.0+ ff)
6204 rcs = max(rcs,0.0001)
6205
6206! contribution due to air temperature
6207
6208 rct = 1.0- 0.0016* ( (parameters%topt - sfctmp)**2.0)
6209 rct = max(rct,0.0001)
6210
6211! contribution due to vapor pressure deficit
6212
6213 rcq = 1.0/ (1.0+ parameters%hs * max(0.,q2sat-q2))
6214 rcq = max(rcq,0.01)
6215
6216! determine canopy resistance due to all factors
6217
6218 rc = parameters%rsmin / (rcs * rct * rcq * rcsoil)
6219 psn = -999.99 ! psn not applied for dynamic carbon
6220
6221 end subroutine canres
6222
6223!== begin calhum ===================================================================================
6224
6227 subroutine calhum(parameters,sfctmp, sfcprs, q2sat, dqsdt2)
6228
6229 implicit none
6230
6231 type (noahmp_parameters), intent(in) :: parameters
6232 real (kind=kind_phys), intent(in) :: sfctmp, sfcprs
6233 real (kind=kind_phys), intent(out) :: q2sat, dqsdt2
6234 real (kind=kind_phys), parameter :: a2=17.67,a3=273.15,a4=29.65, elwv=2.501e6, &
6235 a23m4=a2*(a3-a4), e0=0.611, rv=461.0, &
6236 epsilon=0.622
6237 real (kind=kind_phys) :: es, sfcprsx
6238
6239! q2sat: saturated mixing ratio
6240 es = e0 * exp( elwv/rv*(1./a3 - 1./sfctmp) )
6241! convert sfcprs from pa to kpa
6242 sfcprsx = sfcprs*1.e-3
6243 q2sat = epsilon * es / (sfcprsx-es)
6244! convert from g/g to g/kg
6245 q2sat = q2sat * 1.e3
6246! q2sat is currently a 'mixing ratio'
6247
6248! dqsdt2 is calculated assuming q2sat is a specific humidity
6249 dqsdt2=(q2sat/(1+q2sat))*a23m4/(sfctmp-a4)**2
6250
6251! dg q2sat needs to be in g/g when returned for sflx
6252 q2sat = q2sat / 1.e3
6253
6254 end subroutine calhum
6255
6256!== begin tsnosoi ==================================================================================
6257
6263 subroutine tsnosoi (parameters,ice ,nsoil ,nsnow ,isnow ,ist , & !in
6264 tbot ,zsnso ,ssoil ,df ,hcpct , & !in
6265 sag ,dt ,snowh ,dzsnso , & !in
6266 tg ,iloc ,jloc , & !in
6267#ifdef CCPP
6268 stc ,errmsg ,errflg) !inout
6269#else
6270 stc ) !inout
6271#endif
6272! --------------------------------------------------------------------------------------------------
6273! compute snow (up to 3l) and soil (4l) temperature. note that snow temperatures
6274! during melting season may exceed melting point (tfrz) but later in phasechange
6275! subroutine the snow temperatures are reset to tfrz for melting snow.
6276! --------------------------------------------------------------------------------------------------
6277 implicit none
6278! --------------------------------------------------------------------------------------------------
6279!input
6280
6281 type (noahmp_parameters), intent(in) :: parameters
6282 integer, intent(in) :: iloc
6283 integer, intent(in) :: jloc
6284 integer, intent(in) :: ice
6285 integer, intent(in) :: nsoil
6286 integer, intent(in) :: nsnow
6287 integer, intent(in) :: isnow
6288 integer, intent(in) :: ist
6289
6290 real (kind=kind_phys), intent(in) :: dt
6291 real (kind=kind_phys), intent(in) :: tbot
6292 real (kind=kind_phys), intent(in) :: ssoil
6293 real (kind=kind_phys), intent(in) :: sag
6294 real (kind=kind_phys), intent(in) :: snowh
6295 real (kind=kind_phys), intent(in) :: tg
6296 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: zsnso
6297 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
6298 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: df
6299 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: hcpct
6300
6301!input and output
6302
6303 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
6304#ifdef CCPP
6305 character(len=*) , intent(inout) :: errmsg
6306 integer , intent(inout) :: errflg
6307#endif
6308
6309!local
6310
6311 integer :: iz
6312 real (kind=kind_phys) :: zbotsno !zbot from snow surface
6313 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: ai, bi, ci, rhsts
6314 real (kind=kind_phys) :: eflxb !energy influx from soil bottom (w/m2)
6315 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: phi !light through water (w/m2)
6316
6317 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: tbeg
6318 real (kind=kind_phys) :: err_est !heat storage error (w/m2)
6319 real (kind=kind_phys) :: ssoil2 !ground heat flux (w/m2) (for energy check)
6320 real (kind=kind_phys) :: eflxb2 !heat flux from the bottom (w/m2) (for energy check)
6321 character(len=256) :: message
6322! ----------------------------------------------------------------------
6323! compute solar penetration through water, needs more work
6324
6325 phi(isnow+1:nsoil) = 0.
6326
6327! adjust zbot from soil surface to zbotsno from snow surface
6328
6329 zbotsno = parameters%zbot - snowh !from snow surface
6330
6331! snow/soil heat storage for energy balance check
6332
6333 do iz = isnow+1, nsoil
6334 tbeg(iz) = stc(iz)
6335 enddo
6336
6337! compute soil temperatures
6338
6339 call hrt (parameters,nsnow ,nsoil ,isnow ,zsnso , &
6340 stc ,tbot ,zbotsno ,dt , &
6341 df ,hcpct ,ssoil ,phi , &
6342 ai ,bi ,ci ,rhsts , &
6343 eflxb )
6344
6345 call hstep (parameters,nsnow ,nsoil ,isnow ,dt , &
6346 ai ,bi ,ci ,rhsts , &
6347 stc )
6348
6349! update ground heat flux just for energy check, but not for final output
6350! otherwise, it would break the surface energy balance
6351
6352 if(opt_tbot == 1) then
6353 eflxb2 = 0.
6354 else if(opt_tbot == 2) then
6355 eflxb2 = df(nsoil)*(tbot-stc(nsoil)) / &
6356 (0.5*(zsnso(nsoil-1)+zsnso(nsoil)) - zbotsno)
6357 end if
6358
6359 ! skip the energy balance check for now, until we can make it work
6360 ! right for small time steps.
6361 return
6362
6363! energy balance check
6364
6365 err_est = 0.0
6366 do iz = isnow+1, nsoil
6367 err_est = err_est + (stc(iz)-tbeg(iz)) * dzsnso(iz) * hcpct(iz) / dt
6368 enddo
6369
6370 if (opt_stc == 1 .or. opt_stc == 3) then ! semi-implicit
6371 err_est = err_est - (ssoil +eflxb)
6372 else ! full-implicit
6373 ssoil2 = df(isnow+1)*(tg-stc(isnow+1))/(0.5*dzsnso(isnow+1)) !m. barlage
6374 err_est = err_est - (ssoil2+eflxb2)
6375 endif
6376
6377 if (abs(err_est) > 1.) then ! w/m2
6378 write(message,*) 'tsnosoi is losing(-)/gaining(+) false energy',err_est,' w/m2'
6379#ifdef CCPP
6380 errmsg = trim(message)
6381#else
6382 call wrf_message(trim(message))
6383#endif
6384 write(message,'(i6,1x,i6,1x,i3,f18.13,5f20.12)') &
6385 iloc, jloc, ist,err_est,ssoil,snowh,tg,stc(isnow+1),eflxb
6386#ifdef CCPP
6387 errmsg = trim(errmsg)//new_line('A')//trim(message)
6388#else
6389 call wrf_message(trim(message))
6390#endif
6391 !niu stop
6392 end if
6393
6394 end subroutine tsnosoi
6395
6396!== begin hrt ======================================================================================
6397
6402 subroutine hrt (parameters,nsnow ,nsoil ,isnow ,zsnso , &
6403 stc ,tbot ,zbot ,dt , &
6404 df ,hcpct ,ssoil ,phi , &
6405 ai ,bi ,ci ,rhsts , &
6406 botflx )
6407! ----------------------------------------------------------------------
6408! ----------------------------------------------------------------------
6409! calculate the right hand side of the time tendency term of the soil
6410! thermal diffusion equation. also to compute ( prepare ) the matrix
6411! coefficients for the tri-diagonal matrix of the implicit time scheme.
6412! ----------------------------------------------------------------------
6413 implicit none
6414! ----------------------------------------------------------------------
6415! input
6416
6417 type (noahmp_parameters), intent(in) :: parameters
6418 integer, intent(in) :: nsoil
6419 integer, intent(in) :: nsnow
6420 integer, intent(in) :: isnow !, actual no of snow layers
6421 real (kind=kind_phys), intent(in) :: tbot
6422 real (kind=kind_phys), intent(in) :: zbot
6424 real (kind=kind_phys), intent(in) :: dt
6425 real (kind=kind_phys), intent(in) :: ssoil
6426 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: zsnso
6427 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc
6428 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: df
6429 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: hcpct
6430 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: phi
6431
6432! output
6433
6434 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: rhsts
6435 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: ai
6436 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: bi
6437 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: ci
6438 real (kind=kind_phys), intent(out) :: botflx
6439
6440! local
6441
6442 integer :: k
6443 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: ddz
6444 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: dz
6445 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: denom
6446 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: dtsdz
6447 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: eflux
6448 real (kind=kind_phys) :: temp1
6449! ----------------------------------------------------------------------
6450
6451 do k = isnow+1, nsoil
6452 if (k == isnow+1) then
6453 denom(k) = - zsnso(k) * hcpct(k)
6454 temp1 = - zsnso(k+1)
6455 ddz(k) = 2.0 / temp1
6456 dtsdz(k) = 2.0 * (stc(k) - stc(k+1)) / temp1
6457 eflux(k) = df(k) * dtsdz(k) - ssoil - phi(k)
6458 else if (k < nsoil) then
6459 denom(k) = (zsnso(k-1) - zsnso(k)) * hcpct(k)
6460 temp1 = zsnso(k-1) - zsnso(k+1)
6461 ddz(k) = 2.0 / temp1
6462 dtsdz(k) = 2.0 * (stc(k) - stc(k+1)) / temp1
6463 eflux(k) = (df(k)*dtsdz(k) - df(k-1)*dtsdz(k-1)) - phi(k)
6464 else if (k == nsoil) then
6465 denom(k) = (zsnso(k-1) - zsnso(k)) * hcpct(k)
6466 temp1 = zsnso(k-1) - zsnso(k)
6467 if(opt_tbot == 1) then
6468 botflx = 0.
6469 end if
6470 if(opt_tbot == 2) then
6471 dtsdz(k) = (stc(k) - tbot) / ( 0.5*(zsnso(k-1)+zsnso(k)) - zbot)
6472 botflx = -df(k) * dtsdz(k)
6473 end if
6474 eflux(k) = (-botflx - df(k-1)*dtsdz(k-1) ) - phi(k)
6475 end if
6476 end do
6477
6478 do k = isnow+1, nsoil
6479 if (k == isnow+1) then
6480 ai(k) = 0.0
6481 ci(k) = - df(k) * ddz(k) / denom(k)
6482 if (opt_stc == 1 .or. opt_stc == 3 ) then
6483 bi(k) = - ci(k)
6484 end if
6485 if (opt_stc == 2) then
6486 bi(k) = - ci(k) + df(k)/(0.5*zsnso(k)*zsnso(k)*hcpct(k))
6487 end if
6488 else if (k < nsoil) then
6489 ai(k) = - df(k-1) * ddz(k-1) / denom(k)
6490 ci(k) = - df(k ) * ddz(k ) / denom(k)
6491 bi(k) = - (ai(k) + ci(k))
6492 else if (k == nsoil) then
6493 ai(k) = - df(k-1) * ddz(k-1) / denom(k)
6494 ci(k) = 0.0
6495 bi(k) = - (ai(k) + ci(k))
6496 end if
6497 rhsts(k) = eflux(k)/ (-denom(k))
6498 end do
6499
6500 end subroutine hrt
6501
6502!== begin hstep ====================================================================================
6503
6506 subroutine hstep (parameters,nsnow ,nsoil ,isnow ,dt , &
6507 ai ,bi ,ci ,rhsts , &
6508 stc )
6509! ----------------------------------------------------------------------
6510! calculate/update the soil temperature field.
6511! ----------------------------------------------------------------------
6512 implicit none
6513! ----------------------------------------------------------------------
6514! input
6515
6516 type (noahmp_parameters), intent(in) :: parameters
6517 integer, intent(in) :: nsoil
6518 integer, intent(in) :: nsnow
6519 integer, intent(in) :: isnow
6520 real (kind=kind_phys), intent(in) :: dt
6521
6522! output & input
6523 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: rhsts
6524 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: ai
6525 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: bi
6526 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: ci
6527 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
6528
6529! local
6530 integer :: k
6531 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: rhstsin
6532 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: ciin
6533! ----------------------------------------------------------------------
6534
6535 do k = isnow+1,nsoil
6536 rhsts(k) = rhsts(k) * dt
6537 ai(k) = ai(k) * dt
6538 bi(k) = 1. + bi(k) * dt
6539 ci(k) = ci(k) * dt
6540 end do
6541
6542! copy values for input variables before call to rosr12
6543
6544 do k = isnow+1,nsoil
6545 rhstsin(k) = rhsts(k)
6546 ciin(k) = ci(k)
6547 end do
6548
6549! solve the tri-diagonal matrix equation
6550
6551 call rosr12 (ci,ai,bi,ciin,rhstsin,rhsts,isnow+1,nsoil,nsnow)
6552
6553! update snow & soil temperature
6554
6555 do k = isnow+1,nsoil
6556 stc(k) = stc(k) + ci(k)
6557 end do
6558
6559 end subroutine hstep
6560
6561!== begin rosr12 ===================================================================================
6562
6565 subroutine rosr12 (p,a,b,c,d,delta,ntop,nsoil,nsnow)
6566! ----------------------------------------------------------------------
6567! subroutine rosr12
6568! ----------------------------------------------------------------------
6569! invert (solve) the tri-diagonal matrix problem shown below:
6570! ### ### ### ### ### ###
6571! #b(1), c(1), 0 , 0 , 0 , . . . , 0 # # # # #
6572! #a(2), b(2), c(2), 0 , 0 , . . . , 0 # # # # #
6573! # 0 , a(3), b(3), c(3), 0 , . . . , 0 # # # # d(3) #
6574! # 0 , 0 , a(4), b(4), c(4), . . . , 0 # # p(4) # # d(4) #
6575! # 0 , 0 , 0 , a(5), b(5), . . . , 0 # # p(5) # # d(5) #
6576! # . . # # . # = # . #
6577! # . . # # . # # . #
6578! # . . # # . # # . #
6579! # 0 , . . . , 0 , a(m-2), b(m-2), c(m-2), 0 # #p(m-2)# #d(m-2)#
6580! # 0 , . . . , 0 , 0 , a(m-1), b(m-1), c(m-1)# #p(m-1)# #d(m-1)#
6581! # 0 , . . . , 0 , 0 , 0 , a(m) , b(m) # # p(m) # # d(m) #
6582! ### ### ### ### ### ###
6583! ----------------------------------------------------------------------
6584 implicit none
6585
6586 integer, intent(in) :: ntop
6587 integer, intent(in) :: nsoil,nsnow
6588 integer :: k, kk
6589
6590 real (kind=kind_phys), dimension(-nsnow+1:nsoil),intent(in):: a, b, d
6591 real (kind=kind_phys), dimension(-nsnow+1:nsoil),intent(inout):: c,p,delta
6592
6593! ----------------------------------------------------------------------
6594! initialize eqn coef c for the lowest soil layer
6595! ----------------------------------------------------------------------
6596 c(nsoil) = 0.0
6597 p(ntop) = - c(ntop) / b(ntop)
6598! ----------------------------------------------------------------------
6599! solve the coefs for the 1st soil layer
6600! ----------------------------------------------------------------------
6601 delta(ntop) = d(ntop) / b(ntop)
6602! ----------------------------------------------------------------------
6603! solve the coefs for soil layers 2 thru nsoil
6604! ----------------------------------------------------------------------
6605 do k = ntop+1,nsoil
6606 p(k) = - c(k) * ( 1.0 / (b(k) + a(k) * p(k -1)) )
6607 delta(k) = (d(k) - a(k)* delta(k -1))* (1.0/ (b(k) + a(k)&
6608 * p(k -1)))
6609 end do
6610! ----------------------------------------------------------------------
6611! set p to delta for lowest soil layer
6612! ----------------------------------------------------------------------
6613 p(nsoil) = delta(nsoil)
6614! ----------------------------------------------------------------------
6615! adjust p for soil layers 2 thru nsoil
6616! ----------------------------------------------------------------------
6617 do k = ntop+1,nsoil
6618 kk = nsoil - k + (ntop-1) + 1
6619 p(kk) = p(kk) * p(kk +1) + delta(kk)
6620 end do
6621! ----------------------------------------------------------------------
6622 end subroutine rosr12
6623
6624!== begin phasechange ==============================================================================
6625
6628 subroutine phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , & !in
6629 dzsnso ,hcpct ,ist ,iloc ,jloc , & !in
6630 stc ,snice ,snliq ,sneqv ,snowh , & !inout
6631#ifdef CCPP
6632 smc ,sh2o ,errmsg ,errflg , & !inout
6633#else
6634 smc ,sh2o , & !inout
6635#endif
6636 qmelt ,imelt ,ponding ) !out
6637! ----------------------------------------------------------------------
6638! melting/freezing of snow water and soil water
6639! ----------------------------------------------------------------------
6640 implicit none
6641! ----------------------------------------------------------------------
6642! inputs
6643
6644 type (noahmp_parameters), intent(in) :: parameters
6645 integer, intent(in) :: iloc
6646 integer, intent(in) :: jloc
6647 integer, intent(in) :: nsnow
6648 integer, intent(in) :: nsoil
6649 integer, intent(in) :: isnow
6650 integer, intent(in) :: ist
6651 real (kind=kind_phys), intent(in) :: dt
6652 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: fact
6653 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
6654 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: hcpct
6655
6656! outputs
6657 integer, dimension(-nsnow+1:nsoil), intent(out) :: imelt !phase change index
6658 real (kind=kind_phys), intent(out) :: qmelt
6659 real (kind=kind_phys), intent(out) :: ponding
6660
6661! inputs and outputs
6662
6663 real (kind=kind_phys), intent(inout) :: sneqv
6664 real (kind=kind_phys), intent(inout) :: snowh
6665 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
6666 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sh2o
6667 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: smc
6668 real (kind=kind_phys), dimension(-nsnow+1:0) , intent(inout) :: snice
6669 real (kind=kind_phys), dimension(-nsnow+1:0) , intent(inout) :: snliq
6670#ifdef CCPP
6671 character(len=*) , intent(inout) :: errmsg
6672 integer , intent(inout) :: errflg
6673#endif
6674
6675! local
6676
6677 integer :: j !do loop index
6678 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: hm !energy residual [w/m2]
6679 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: xm !melting or freezing water [kg/m2]
6680 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: wmass0
6681 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: wice0
6682 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: wliq0
6683 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: mice !soil/snow ice mass [mm]
6684 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: mliq !soil/snow liquid water mass [mm]
6685 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: supercool !supercooled water in soil (kg/m2)
6686 real (kind=kind_phys) :: heatr !energy residual or loss after melting/freezing
6687 real (kind=kind_phys) :: temp1 !temporary variables [kg/m2]
6688 real (kind=kind_phys) :: propor
6689 real (kind=kind_phys) :: smp !frozen water potential (mm)
6690 real (kind=kind_phys) :: xmf !total latent heat of phase change
6691
6692! ----------------------------------------------------------------------
6693! initialization
6694
6695 qmelt = 0.
6696 ponding = 0.
6697 xmf = 0.
6698
6699 do j = -nsnow+1, nsoil
6700 supercool(j) = 0.0
6701 end do
6702
6703 do j = isnow+1,0 ! all layers
6704 mice(j) = snice(j)
6705 mliq(j) = snliq(j)
6706 end do
6707
6708 do j = 1, nsoil ! soil
6709 mliq(j) = sh2o(j) * dzsnso(j) * 1000.
6710 mice(j) = (smc(j) - sh2o(j)) * dzsnso(j) * 1000.
6711 end do
6712
6713 do j = isnow+1,nsoil ! all layers
6714 imelt(j) = 0
6715 hm(j) = 0.
6716 xm(j) = 0.
6717 wice0(j) = mice(j)
6718 wliq0(j) = mliq(j)
6719 wmass0(j) = mice(j) + mliq(j)
6720 enddo
6721
6722 if(ist == 1) then
6723 do j = 1,nsoil
6724 if (opt_frz == 1) then
6725 if(stc(j) < tfrz) then
6726 smp = hfus*(tfrz-stc(j))/(grav*stc(j)) !(m)
6727 supercool(j) = parameters%smcmax(j)*(smp/parameters%psisat(j))**(-1./parameters%bexp(j))
6728 supercool(j) = supercool(j)*dzsnso(j)*1000. !(mm)
6729 end if
6730 end if
6731 if (opt_frz == 2) then
6732#ifdef CCPP
6733 call frh2o (parameters,j,supercool(j),stc(j),smc(j),sh2o(j),errmsg,errflg)
6734 if (errflg /=0) return
6735#else
6736 call frh2o (parameters,j,supercool(j),stc(j),smc(j),sh2o(j))
6737#endif
6738 supercool(j) = supercool(j)*dzsnso(j)*1000. !(mm)
6739 end if
6740 enddo
6741 end if
6742
6743 do j = isnow+1,nsoil
6744 if (mice(j) > 0. .and. stc(j) >= tfrz) then !melting
6745 imelt(j) = 1
6746 endif
6747 if (mliq(j) > supercool(j) .and. stc(j) < tfrz) then
6748 imelt(j) = 2
6749 endif
6750
6751 ! if snow exists, but its thickness is not enough to create a layer
6752 if (isnow == 0 .and. sneqv > 0. .and. j == 1) then
6753 if (stc(j) >= tfrz) then
6754 imelt(j) = 1
6755 endif
6756 endif
6757 enddo
6758
6759! calculate the energy surplus and loss for melting and freezing
6760
6761 do j = isnow+1,nsoil
6762 if (imelt(j) > 0) then
6763 hm(j) = (stc(j)-tfrz)/fact(j)
6764 stc(j) = tfrz
6765 endif
6766
6767 if (imelt(j) == 1 .and. hm(j) < 0.) then
6768 hm(j) = 0.
6769 imelt(j) = 0
6770 endif
6771 if (imelt(j) == 2 .and. hm(j) > 0.) then
6772 hm(j) = 0.
6773 imelt(j) = 0
6774 endif
6775 xm(j) = hm(j)*dt/hfus
6776 enddo
6777
6778! the rate of melting and freezing for snow without a layer, needs more work.
6779
6780 if (isnow == 0 .and. sneqv > 0. .and. xm(1) > 0.) then
6781 temp1 = sneqv
6782 sneqv = max(0.,temp1-xm(1))
6783 propor = sneqv/temp1
6784 snowh = max(0.,propor * snowh)
6785 snowh = min(max(snowh,sneqv/500.0),sneqv/50.0) ! limit adjustment to a reasonable density
6786 heatr = hm(1) - hfus*(temp1-sneqv)/dt
6787 if (heatr > 0.) then
6788 xm(1) = heatr*dt/hfus
6789 hm(1) = heatr
6790 else
6791 xm(1) = 0.
6792 hm(1) = 0.
6793 endif
6794 qmelt = max(0.,(temp1-sneqv))/dt
6795 xmf = hfus*qmelt
6796 ponding = temp1-sneqv
6797 endif
6798
6799! the rate of melting and freezing for snow and soil
6800
6801 do j = isnow+1,nsoil
6802 if (imelt(j) > 0 .and. abs(hm(j)) > 0.) then
6803
6804 heatr = 0.
6805 if (xm(j) > 0.) then
6806 mice(j) = max(0., wice0(j)-xm(j))
6807 heatr = hm(j) - hfus*(wice0(j)-mice(j))/dt
6808 else if (xm(j) < 0.) then
6809 if (j <= 0) then ! snow
6810 mice(j) = min(wmass0(j), wice0(j)-xm(j))
6811 else ! soil
6812 if (wmass0(j) < supercool(j)) then
6813 mice(j) = 0.
6814 else
6815 mice(j) = min(wmass0(j) - supercool(j),wice0(j)-xm(j))
6816 mice(j) = max(mice(j),0.0)
6817 endif
6818 endif
6819 heatr = hm(j) - hfus*(wice0(j)-mice(j))/dt
6820 endif
6821
6822 mliq(j) = max(0.,wmass0(j)-mice(j))
6823
6824 if (abs(heatr) > 0.) then
6825 stc(j) = stc(j) + fact(j)*heatr
6826 if (j <= 0) then ! snow
6827 if (mliq(j)*mice(j)>0.) stc(j) = tfrz
6828 if (mice(j) == 0.) then ! barlage
6829 stc(j) = tfrz ! barlage
6830 hm(j+1) = hm(j+1) + heatr ! barlage
6831 xm(j+1) = hm(j+1)*dt/hfus ! barlage
6832 endif
6833 end if
6834 endif
6835
6836 xmf = xmf + hfus * (wice0(j)-mice(j))/dt
6837
6838 if (j < 1) then
6839 qmelt = qmelt + max(0.,(wice0(j)-mice(j)))/dt
6840 endif
6841 endif
6842 enddo
6843
6844 do j = isnow+1,0 ! snow
6845 snliq(j) = mliq(j)
6846 snice(j) = mice(j)
6847 end do
6848
6849 do j = 1, nsoil ! soil
6850 sh2o(j) = mliq(j) / (1000. * dzsnso(j))
6851 smc(j) = (mliq(j) + mice(j)) / (1000. * dzsnso(j))
6852 end do
6853
6854 end subroutine phasechange
6855
6856!== begin frh2o ====================================================================================
6857
6863 subroutine frh2o (parameters,isoil,free,tkelv,smc,sh2o,&
6864#ifdef CCPP
6865 errmsg,errflg)
6866#else
6867 )
6868#endif
6869
6870! ----------------------------------------------------------------------
6871! subroutine frh2o
6872! ----------------------------------------------------------------------
6873! calculate amount of supercooled liquid soil water content if
6874! temperature is below 273.15k (tfrz). requires newton-type iteration
6875! to solve the nonlinear implicit equation given in eqn 17 of koren et al
6876! (1999, jgr, vol 104(d16), 19569-19585).
6877! ----------------------------------------------------------------------
6878! new version (june 2001): much faster and more accurate newton
6879! iteration achieved by first taking log of eqn cited above -- less than
6880! 4 (typically 1 or 2) iterations achieves convergence. also, explicit
6881! 1-step solution option for special case of parameter ck=0, which
6882! reduces the original implicit equation to a simpler explicit form,
6883! known as the "flerchinger eqn". improved handling of solution in the
6884! limit of freezing point temperature tfrz.
6885! ----------------------------------------------------------------------
6886! input:
6887
6888! tkelv.........temperature (kelvin)
6889! smc...........total soil moisture content (volumetric)
6890! sh2o..........liquid soil moisture content (volumetric)
6891! b.............soil type "b" parameter (from redprm)
6892! psisat........saturated soil matric potential (from redprm)
6893
6894! output:
6895! free..........supercooled liquid water content [m3/m3]
6896! ----------------------------------------------------------------------
6897 implicit none
6898 type (noahmp_parameters), intent(in) :: parameters
6899 integer,intent(in) :: isoil
6900 real (kind=kind_phys), intent(in) :: sh2o,smc,tkelv
6901 real (kind=kind_phys), intent(out) :: free
6902#ifdef CCPP
6903 character(len=*), intent(inout) :: errmsg
6904 integer, intent(inout) :: errflg
6905#endif
6906 real (kind=kind_phys) :: bx,denom,df,dswl,fk,swl,swlk
6907 integer :: nlog,kcount
6908! parameter(ck = 0.0)
6909 real (kind=kind_phys), parameter :: ck = 8.0, blim = 5.5, error = 0.005, &
6910 dice = 920.0
6911 character(len=80) :: message
6912
6913! ----------------------------------------------------------------------
6914! limits on parameter b: b < 5.5 (use parameter blim)
6915! simulations showed if b > 5.5 unfrozen water content is
6916! non-realistically high at very low temperatures.
6917! ----------------------------------------------------------------------
6918 bx = parameters%bexp(isoil)
6919! ----------------------------------------------------------------------
6920! initializing iterations counter and iterative solution flag.
6921! ----------------------------------------------------------------------
6922
6923 if (parameters%bexp(isoil) > blim) bx = blim
6924 nlog = 0
6925
6926! ----------------------------------------------------------------------
6927! if temperature not significantly below freezing (tfrz), sh2o = smc
6928! ----------------------------------------------------------------------
6929 kcount = 0
6930 if (tkelv > (tfrz- 1.e-3)) then
6931 free = smc
6932 else
6933
6934! ----------------------------------------------------------------------
6935! option 1: iterated solution in koren et al, jgr, 1999, eqn 17
6936! ----------------------------------------------------------------------
6937! initial guess for swl (frozen content)
6938! ----------------------------------------------------------------------
6939 if (ck /= 0.0) then
6940 swl = smc - sh2o
6941! ----------------------------------------------------------------------
6942! keep within bounds.
6943! ----------------------------------------------------------------------
6944 if (swl > (smc -0.02)) swl = smc -0.02
6945! ----------------------------------------------------------------------
6946! start of iterations
6947! ----------------------------------------------------------------------
6948 if (swl < 0.) swl = 0.
69491001 continue
6950 if (.not.( (nlog < 10) .and. (kcount == 0))) goto 1002
6951 nlog = nlog +1
6952 df = log( ( parameters%psisat(isoil) * grav / hfus ) * ( ( 1. + ck * swl )**2.) * &
6953 ( parameters%smcmax(isoil) / (smc - swl) )** bx) - log( - ( &
6954 tkelv - tfrz)/ tkelv)
6955 denom = 2. * ck / ( 1. + ck * swl ) + bx / ( smc - swl )
6956 swlk = swl - df / denom
6957! ----------------------------------------------------------------------
6958! bounds useful for mathematical solution.
6959! ----------------------------------------------------------------------
6960 if (swlk > (smc -0.02)) swlk = smc - 0.02
6961 if (swlk < 0.) swlk = 0.
6962
6963! ----------------------------------------------------------------------
6964! mathematical solution bounds applied.
6965! ----------------------------------------------------------------------
6966 dswl = abs(swlk - swl)
6967! if more than 10 iterations, use explicit method (ck=0 approx.)
6968! when dswl less or eq. error, no more iterations required.
6969! ----------------------------------------------------------------------
6970 swl = swlk
6971 if ( dswl <= error ) then
6972 kcount = kcount +1
6973 end if
6974! ----------------------------------------------------------------------
6975! end of iterations
6976! ----------------------------------------------------------------------
6977! bounds applied within do-block are valid for physical solution.
6978! ----------------------------------------------------------------------
6979 goto 1001
69801002 continue
6981 free = smc - swl
6982 end if
6983! ----------------------------------------------------------------------
6984! end option 1
6985! ----------------------------------------------------------------------
6986! ----------------------------------------------------------------------
6987! option 2: explicit solution for flerchinger eq. i.e. ck=0
6988! in koren et al., jgr, 1999, eqn 17
6989! apply physical bounds to flerchinger solution
6990! ----------------------------------------------------------------------
6991 if (kcount == 0) then
6992 write(message, '("flerchinger used in new version. iterations=", i6)') nlog
6993#ifdef CCPP
6994 errmsg = trim(message)
6995#else
6996 call wrf_message(trim(message))
6997#endif
6998 fk = ( ( (hfus / (grav * ( - parameters%psisat(isoil))))* &
6999 ( (tkelv - tfrz)/ tkelv))** ( -1/ bx))* parameters%smcmax(isoil)
7000 if (fk < 0.02) fk = 0.02
7001 free = min(fk, smc)
7002! ----------------------------------------------------------------------
7003! end option 2
7004! ----------------------------------------------------------------------
7005 end if
7006 end if
7007! ----------------------------------------------------------------------
7008 end subroutine frh2o
7009! ----------------------------------------------------------------------
7010! ==================================================================================================
7011! **********************end of energy subroutines***********************
7012! ==================================================================================================
7013
7014!== begin water ====================================================================================
7015
7018 subroutine water (parameters,vegtyp ,nsnow ,nsoil ,imelt ,dt ,uu , & !in
7019 vv ,fcev ,fctr ,qprecc ,qprecl ,elai , & !in
7020 esai ,sfctmp ,qvap ,qdew ,zsoil ,btrani , & !in
7021 ficeold,ponding,tg ,ist ,fveg ,iloc ,jloc ,smceq , & !in
7022 bdfall ,fp ,rain ,snow, & !in mb/an: v3.7
7023 qsnow ,qrain ,snowhin,latheav,latheag,frozen_canopy,frozen_ground, & !in mb
7024 isnow ,canliq ,canice ,tv ,snowh ,sneqv , & !inout
7025 snice ,snliq ,stc ,zsnso ,sh2o ,smc , & !inout
7026 sice ,zwt ,wa ,wt ,dzsnso ,wslake , & !inout
7027 smcwtd ,deeprech,rech , & !inout
7028 cmc ,ecan ,etran ,fwet ,runsrf ,runsub , & !out
7029 qin ,qdis ,ponding1 ,ponding2, &
7030 qsnbot ,esnow)
7031! ----------------------------------------------------------------------
7032! code history:
7033! initial code: guo-yue niu, oct. 2007
7034! ----------------------------------------------------------------------
7035 implicit none
7036! ----------------------------------------------------------------------
7037! input
7038 type (noahmp_parameters), intent(in) :: parameters
7039 integer, intent(in) :: iloc
7040 integer, intent(in) :: jloc
7041 integer, intent(in) :: vegtyp
7042 integer, intent(in) :: nsnow
7043 integer , intent(in) :: ist
7044 integer, intent(in) :: nsoil
7045 integer, dimension(-nsnow+1:0) , intent(in) :: imelt
7046 real (kind=kind_phys), intent(in) :: dt
7047 real (kind=kind_phys), intent(in) :: uu
7048 real (kind=kind_phys), intent(in) :: vv
7049 real (kind=kind_phys), intent(in) :: fcev
7050 real (kind=kind_phys), intent(in) :: fctr
7051 real (kind=kind_phys), intent(in) :: qprecc
7052 real (kind=kind_phys), intent(in) :: qprecl
7053 real (kind=kind_phys), intent(in) :: elai
7054 real (kind=kind_phys), intent(in) :: esai
7055 real (kind=kind_phys), intent(in) :: sfctmp
7056 real (kind=kind_phys), intent(in) :: qvap
7057 real (kind=kind_phys), intent(in) :: qdew
7058 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil
7059 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: btrani
7060 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: ficeold
7061! real (kind=kind_phys) , intent(in) :: ponding !< [mm]
7062 real (kind=kind_phys) , intent(in) :: tg
7063 real (kind=kind_phys) , intent(in) :: fveg
7064 real (kind=kind_phys) , intent(in) :: bdfall
7065 real (kind=kind_phys) , intent(in) :: fp
7066 real (kind=kind_phys) , intent(in) :: rain
7067 real (kind=kind_phys) , intent(in) :: snow
7068 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smceq
7069 real (kind=kind_phys) , intent(in) :: qsnow
7070 real (kind=kind_phys) , intent(in) :: qrain
7071 real (kind=kind_phys) , intent(in) :: snowhin
7072
7073! input/output
7074 integer, intent(inout) :: isnow
7075 real (kind=kind_phys), intent(inout) :: canliq
7076 real (kind=kind_phys), intent(inout) :: canice
7077 real (kind=kind_phys), intent(inout) :: tv
7078 real (kind=kind_phys), intent(inout) :: snowh
7079 real (kind=kind_phys), intent(inout) :: sneqv
7080 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snice
7081 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snliq
7082 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
7083 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: zsnso
7084 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
7085 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sh2o
7086 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sice
7087 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: smc
7088 real (kind=kind_phys), intent(inout) :: zwt
7089 real (kind=kind_phys), intent(inout) :: wa
7090 real (kind=kind_phys), intent(inout) :: wt
7092 real (kind=kind_phys), intent(inout) :: wslake
7093 real (kind=kind_phys) , intent(inout) :: ponding
7094 real (kind=kind_phys), intent(inout) :: smcwtd
7095 real (kind=kind_phys), intent(inout) :: deeprech
7096 real (kind=kind_phys), intent(inout) :: rech
7097
7098! output
7099 real (kind=kind_phys), intent(out) :: cmc
7100 real (kind=kind_phys), intent(out) :: ecan
7101 real (kind=kind_phys), intent(out) :: etran
7102 real (kind=kind_phys), intent(out) :: fwet
7103 real (kind=kind_phys), intent(out) :: runsrf
7104 real (kind=kind_phys), intent(out) :: runsub
7105 real (kind=kind_phys), intent(out) :: qin
7106 real (kind=kind_phys), intent(out) :: qdis
7107 real (kind=kind_phys), intent(out) :: ponding1
7108 real (kind=kind_phys), intent(out) :: ponding2
7109 real (kind=kind_phys), intent(out) :: esnow
7110 real (kind=kind_phys), intent(out) :: qsnbot
7111 real (kind=kind_phys) , intent(in) :: latheav
7112 real (kind=kind_phys) , intent(in) :: latheag
7113 logical , intent(in) :: frozen_ground
7114 logical , intent(in) :: frozen_canopy
7115
7116
7117! local
7118 integer :: iz
7119 real (kind=kind_phys) :: qinsur !water input on soil surface [m/s]
7120 real (kind=kind_phys) :: qseva !soil surface evap rate [mm/s]
7121 real (kind=kind_phys) :: qsdew !soil surface dew rate [mm/s]
7122 real (kind=kind_phys) :: qsnfro !snow surface frost rate[mm/s]
7123 real (kind=kind_phys) :: qsnsub !snow surface sublimation rate [mm/s]
7124 real (kind=kind_phys), dimension( 1:nsoil) :: etrani !transpiration rate (mm/s) [+]
7125 real (kind=kind_phys), dimension( 1:nsoil) :: wcnd !hydraulic conductivity (m/s)
7126 real (kind=kind_phys) :: qdrain !soil-bottom free drainage [mm/s]
7127 real (kind=kind_phys) :: snoflow !glacier flow [mm/s]
7128 real (kind=kind_phys) :: fcrmax !maximum of fcr (-)
7129
7130 real (kind=kind_phys), parameter :: wslmax = 5000. !maximum lake water storage (mm)
7131
7132
7133! ----------------------------------------------------------------------
7134! initialize
7135
7136 etrani(1:nsoil) = 0.
7137 snoflow = 0.
7138 runsub = 0.
7139 qinsur = 0.
7140
7141! canopy-intercepted snowfall/rainfall, drips, and throughfall
7142
7143 call canwater (parameters,vegtyp ,dt , & !in
7144 fcev ,fctr ,elai , & !in
7145 esai ,tg ,fveg ,iloc , jloc, & !in
7146 bdfall ,frozen_canopy , & !in
7147 canliq ,canice ,tv , & !inout
7148 cmc ,ecan ,etran , & !out
7149 fwet ) !out
7150
7151! sublimation, frost, evaporation, and dew
7152
7153 qsnsub = 0.
7154 if (sneqv > 0.) then
7155 qsnsub = min(qvap, sneqv/dt)
7156 endif
7157 qseva = qvap-qsnsub
7158 esnow = qsnsub*hsub
7159
7160 qsnfro = 0.
7161 if (sneqv > 0.) then
7162 qsnfro = qdew
7163 endif
7164 qsdew = qdew - qsnfro
7165
7166 call snowwater (parameters,nsnow ,nsoil ,imelt ,dt ,zsoil , & !in
7167 & sfctmp ,snowhin,qsnow ,qsnfro ,qsnsub , & !in
7168 & qrain ,ficeold,iloc ,jloc , & !in
7169 & isnow ,snowh ,sneqv ,snice ,snliq , & !inout
7170 & sh2o ,sice ,stc ,zsnso ,dzsnso , & !inout
7171 & qsnbot ,snoflow,ponding1 ,ponding2) !out
7172
7173 if(frozen_ground) then
7174 sice(1) = sice(1) + (qsdew-qseva)*dt/(dzsnso(1)*1000.)
7175 qsdew = 0.0
7176 qseva = 0.0
7177 if(sice(1) < 0.) then
7178 sh2o(1) = sh2o(1) + sice(1)
7179 sice(1) = 0.
7180 end if
7181 end if
7182
7183! convert units (mm/s -> m/s)
7184
7185 !ponding: melting water from snow when there is no layer
7186 qinsur = (ponding+ponding1+ponding2)/dt * 0.001
7187! qinsur = ponding/dt * 0.001
7188
7189 if(isnow == 0) then
7190 qinsur = qinsur+(qsnbot + qsdew + qrain) * 0.001
7191 else
7192 qinsur = qinsur+(qsnbot + qsdew) * 0.001
7193 endif
7194
7195 qseva = qseva * 0.001
7196
7197 do iz = 1, parameters%nroot
7198 etrani(iz) = etran * btrani(iz) * 0.001
7199 enddo
7200
7201
7202! lake/soil water balances
7203
7204 if (ist == 2) then ! lake
7205 runsrf = 0.
7206 if(wslake >= wslmax) runsrf = qinsur*1000. !mm/s
7207 wslake = wslake + (qinsur-qseva)*1000.*dt -runsrf*dt !mm
7208 else ! soil
7209 call soilwater (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in
7210 qinsur ,qseva ,etrani ,sice ,iloc , jloc , & !in
7211 sh2o ,smc ,zwt ,vegtyp , & !inout
7212 smcwtd, deeprech , & !inout
7213 runsrf ,qdrain ,runsub ,wcnd ,fcrmax ) !out
7214
7215 if(opt_run == 1) then
7216 call groundwater (parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in
7217 stc ,wcnd ,fcrmax ,iloc ,jloc , & !in
7218 sh2o ,zwt ,wa ,wt , & !inout
7219 qin ,qdis ) !out
7220 runsub = qdis !mm/s
7221 end if
7222
7223 if(opt_run == 3 .or. opt_run == 4) then
7224 runsub = runsub + qdrain !mm/s
7225 end if
7226
7227 do iz = 1,nsoil
7228 smc(iz) = sh2o(iz) + sice(iz)
7229 enddo
7230
7231 if(opt_run == 5) then
7232 call shallowwatertable (parameters,nsnow ,nsoil, zsoil, dt , & !in
7233 dzsnso ,smceq ,iloc , jloc , & !in
7234 smc ,zwt ,smcwtd ,rech, qdrain ) !inout
7235
7236 sh2o(nsoil) = smc(nsoil) - sice(nsoil)
7237 runsub = runsub + qdrain !it really comes from subroutine watertable, which is not called with the same frequency as the soil routines here
7238 wa = 0.
7239 endif
7240
7241 endif
7242
7243 runsub = runsub + snoflow !mm/s
7244
7245 end subroutine water
7246
7247!== begin canwater =================================================================================
7248
7251 subroutine canwater (parameters,vegtyp ,dt , & !in
7252 fcev ,fctr ,elai , & !in
7253 esai ,tg ,fveg ,iloc , jloc , & !in
7254 bdfall ,frozen_canopy , & !in
7255 canliq ,canice ,tv , & !inout
7256 cmc ,ecan ,etran , & !out
7257 fwet ) !out
7258
7259! ------------------------ code history ------------------------------
7260! canopy hydrology
7261! --------------------------------------------------------------------
7262 implicit none
7263! ------------------------ input/output variables --------------------
7264! input
7265 type (noahmp_parameters), intent(in) :: parameters
7266 integer,intent(in) :: iloc
7267 integer,intent(in) :: jloc
7268 integer,intent(in) :: vegtyp
7269 real (kind=kind_phys), intent(in) :: dt
7270 real (kind=kind_phys), intent(in) :: fcev
7271 real (kind=kind_phys), intent(in) :: fctr
7272 real (kind=kind_phys), intent(in) :: elai
7273 real (kind=kind_phys), intent(in) :: esai
7274 real (kind=kind_phys), intent(in) :: tg
7275 real (kind=kind_phys), intent(in) :: fveg
7276 logical , intent(in) :: frozen_canopy
7277 real (kind=kind_phys), intent(in) :: bdfall
7278
7279! input & output
7280 real (kind=kind_phys), intent(inout) :: canliq
7281 real (kind=kind_phys), intent(inout) :: canice
7282 real (kind=kind_phys), intent(inout) :: tv
7283
7284! output
7285 real (kind=kind_phys), intent(out) :: cmc
7286 real (kind=kind_phys), intent(out) :: ecan
7287 real (kind=kind_phys), intent(out) :: etran
7288 real (kind=kind_phys), intent(out) :: fwet
7289! --------------------------------------------------------------------
7290
7291! ------------------------ local variables ---------------------------
7292 real (kind=kind_phys) :: maxsno !canopy capacity for snow interception (mm)
7293 real (kind=kind_phys) :: maxliq !canopy capacity for rain interception (mm)
7294 real (kind=kind_phys) :: qevac !evaporation rate (mm/s)
7295 real (kind=kind_phys) :: qdewc !dew rate (mm/s)
7296 real (kind=kind_phys) :: qfroc !frost rate (mm/s)
7297 real (kind=kind_phys) :: qsubc !sublimation rate (mm/s)
7298 real (kind=kind_phys) :: qmeltc !melting rate of canopy snow (mm/s)
7299 real (kind=kind_phys) :: qfrzc !refreezing rate of canopy liquid water (mm/s)
7300 real (kind=kind_phys) :: canmas !total canopy mass (kg/m2)
7301! --------------------------------------------------------------------
7302! initialization
7303
7304 ecan = 0.0
7305
7306! --------------------------- liquid water ------------------------------
7307! maximum canopy water
7308
7309 maxliq = parameters%ch2op * (elai+ esai)
7310
7311! evaporation, transpiration, and dew
7312
7313 if (.not.frozen_canopy) then ! barlage: change to frozen_canopy
7314 etran = max( fctr/hvap, 0. )
7315 qevac = max( fcev/hvap, 0. )
7316 qdewc = abs( min( fcev/hvap, 0. ) )
7317 qsubc = 0.
7318 qfroc = 0.
7319 else
7320 etran = max( fctr/hsub, 0. )
7321 qevac = 0.
7322 qdewc = 0.
7323 qsubc = max( fcev/hsub, 0. )
7324 qfroc = abs( min( fcev/hsub, 0. ) )
7325 endif
7326
7327! canopy water balance. for convenience allow dew to bring canliq above
7328! maxh2o or else would have to re-adjust drip
7329
7330 qevac = min(canliq/dt,qevac)
7331 canliq=max(0.,canliq+(qdewc-qevac)*dt)
7332 if(canliq <= 1.e-06) canliq = 0.0
7333
7334! --------------------------- canopy ice ------------------------------
7335! for canopy ice
7336
7337 maxsno = 6.6*(0.27+46./bdfall) * (elai+ esai)
7338
7339 qsubc = min(canice/dt,qsubc)
7340 canice= max(0.,canice + (qfroc-qsubc)*dt)
7341 if(canice.le.1.e-6) canice = 0.
7342
7343! wetted fraction of canopy
7344
7345 if(canice.gt.0.) then
7346 fwet = max(0.,canice) / max(maxsno,1.e-06)
7347 else
7348 fwet = max(0.,canliq) / max(maxliq,1.e-06)
7349 endif
7350 fwet = min(fwet, 1.) ** 0.667
7351
7352! phase change
7353
7354 qmeltc = 0.
7355 qfrzc = 0.
7356
7357 if(canice.gt.1.e-6.and.tv.gt.tfrz) then
7358 qmeltc = min(canice/dt,(tv-tfrz)*cice*canice/denice/(dt*hfus))
7359 canice = max(0.,canice - qmeltc*dt)
7360 canliq = max(0.,canliq + qmeltc*dt)
7361 tv = fwet*tfrz + (1.-fwet)*tv
7362 endif
7363
7364 if(canliq.gt.1.e-6.and.tv.lt.tfrz) then
7365 qfrzc = min(canliq/dt,(tfrz-tv)*cwat*canliq/denh2o/(dt*hfus))
7366 canliq = max(0.,canliq - qfrzc*dt)
7367 canice = max(0.,canice + qfrzc*dt)
7368 tv = fwet*tfrz + (1.-fwet)*tv
7369 endif
7370
7371! total canopy water
7372
7373 cmc = canliq + canice
7374
7375! total canopy evaporation
7376
7377 ecan = qevac + qsubc - qdewc - qfroc
7378
7379 end subroutine canwater
7380
7381!== begin snowwater ================================================================================
7382
7385 subroutine snowwater (parameters,nsnow ,nsoil ,imelt ,dt ,zsoil , & !in
7386 sfctmp ,snowhin,qsnow ,qsnfro ,qsnsub , & !in
7387 qrain ,ficeold,iloc ,jloc , & !in
7388 isnow ,snowh ,sneqv ,snice ,snliq , & !inout
7389 sh2o ,sice ,stc ,zsnso ,dzsnso , & !inout
7390 qsnbot ,snoflow,ponding1 ,ponding2) !out
7391! ----------------------------------------------------------------------
7392 implicit none
7393! ----------------------------------------------------------------------
7394! input
7395 type (noahmp_parameters), intent(in) :: parameters
7396 integer, intent(in) :: iloc
7397 integer, intent(in) :: jloc
7398 integer, intent(in) :: nsnow
7399 integer, intent(in) :: nsoil
7400 integer, dimension(-nsnow+1:0) , intent(in) :: imelt
7401 real (kind=kind_phys), intent(in) :: dt
7402 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil
7403 real (kind=kind_phys), intent(in) :: sfctmp
7404 real (kind=kind_phys), intent(in) :: snowhin
7405 real (kind=kind_phys), intent(in) :: qsnow
7406 real (kind=kind_phys), intent(in) :: qsnfro
7407 real (kind=kind_phys), intent(in) :: qsnsub
7408 real (kind=kind_phys), intent(in) :: qrain
7409 real (kind=kind_phys), dimension(-nsnow+1:0) , intent(in) :: ficeold
7410
7411! input & output
7412 integer, intent(inout) :: isnow
7413 real (kind=kind_phys), intent(inout) :: snowh
7414 real (kind=kind_phys), intent(inout) :: sneqv
7415 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snice
7416 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snliq
7417 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sh2o
7418 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sice
7419 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
7420 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: zsnso
7421 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
7422
7423! output
7424 real (kind=kind_phys), intent(out) :: qsnbot
7425 real (kind=kind_phys), intent(out) :: snoflow
7426 real (kind=kind_phys), intent(out) :: ponding1
7427 real (kind=kind_phys), intent(out) :: ponding2
7428
7429! local
7430 integer :: iz,i
7431 real (kind=kind_phys) :: bdsnow !bulk density of snow (kg/m3)
7432! ----------------------------------------------------------------------
7433 snoflow = 0.0
7434 ponding1 = 0.0
7435 ponding2 = 0.0
7436
7437 call snowfall (parameters,nsoil ,nsnow ,dt ,qsnow ,snowhin, & !in
7438 sfctmp ,iloc ,jloc , & !in
7439 isnow ,snowh ,dzsnso ,stc ,snice , & !inout
7440 snliq ,sneqv ) !inout
7441
7442! mb: do each if block separately
7443
7444 if(isnow < 0) & ! when multi-layer
7445 call compact (parameters,nsnow ,nsoil ,dt ,stc ,snice , & !in
7446 snliq ,zsoil ,imelt ,ficeold,iloc , jloc ,& !in
7447 isnow ,dzsnso ,zsnso ) !inout
7448
7449 if(isnow < 0) & !when multi-layer
7450 call combine (parameters,nsnow ,nsoil ,iloc ,jloc , & !in
7451 isnow ,sh2o ,stc ,snice ,snliq , & !inout
7452 dzsnso ,sice ,snowh ,sneqv , & !inout
7453 ponding1 ,ponding2) !out
7454
7455 if(isnow < 0) & !when multi-layer
7456 call divide (parameters,nsnow ,nsoil , & !in
7457 isnow ,stc ,snice ,snliq ,dzsnso ) !inout
7458
7459 call snowh2o (parameters,nsnow ,nsoil ,dt ,qsnfro ,qsnsub , & !in
7460 qrain ,iloc ,jloc , & !in
7461 isnow ,dzsnso ,snowh ,sneqv ,snice , & !inout
7462 snliq ,sh2o ,sice ,stc , & !inout
7463 qsnbot ,ponding1 ,ponding2) !out
7464
7465!set empty snow layers to zero
7466
7467 do iz = -nsnow+1, isnow
7468 snice(iz) = 0.
7469 snliq(iz) = 0.
7470 stc(iz) = 0.
7471 dzsnso(iz)= 0.
7472 zsnso(iz) = 0.
7473 enddo
7474
7475!to obtain equilibrium state of snow in glacier region
7476
7477 if(sneqv > 5000.) then ! 5000 mm -> maximum water depth
7478 bdsnow = snice(0) / dzsnso(0)
7479 snoflow = (sneqv - 5000.)
7480 snice(0) = snice(0) - snoflow
7481 dzsnso(0) = dzsnso(0) - snoflow/bdsnow
7482 snoflow = snoflow / dt
7483 end if
7484
7485! sum up snow mass for layered snow
7486
7487 if(isnow < 0) then ! mb: only do for multi-layer
7488 sneqv = 0.
7489 snowh = 0.
7490 do iz = isnow+1,0
7491 sneqv = sneqv + snice(iz) + snliq(iz)
7492 snowh = snowh + dzsnso(iz)
7493 enddo
7494 end if
7495
7496! reset zsnso and layer thinkness dzsnso
7497
7498 do iz = isnow+1, 0
7499 dzsnso(iz) = -dzsnso(iz)
7500 end do
7501
7502 dzsnso(1) = zsoil(1)
7503 do iz = 2,nsoil
7504 dzsnso(iz) = (zsoil(iz) - zsoil(iz-1))
7505 end do
7506
7507 zsnso(isnow+1) = dzsnso(isnow+1)
7508 do iz = isnow+2 ,nsoil
7509 zsnso(iz) = zsnso(iz-1) + dzsnso(iz)
7510 enddo
7511
7512 do iz = isnow+1 ,nsoil
7513 dzsnso(iz) = -dzsnso(iz)
7514 end do
7515
7516 end subroutine snowwater
7517
7518!== begin snowfall =================================================================================
7519
7523 subroutine snowfall (parameters,nsoil ,nsnow ,dt ,qsnow ,snowhin , & !in
7524 sfctmp ,iloc ,jloc , & !in
7525 isnow ,snowh ,dzsnso ,stc ,snice , & !inout
7526 snliq ,sneqv ) !inout
7527! ----------------------------------------------------------------------
7528! snow depth and density to account for the new snowfall.
7529! new values of snow depth & density returned.
7530! ----------------------------------------------------------------------
7531 implicit none
7532! ----------------------------------------------------------------------
7533! input
7534
7535 type (noahmp_parameters), intent(in) :: parameters
7536 integer, intent(in) :: iloc
7537 integer, intent(in) :: jloc
7538 integer, intent(in) :: nsoil
7539 integer, intent(in) :: nsnow
7540 real (kind=kind_phys), intent(in) :: dt
7541 real (kind=kind_phys), intent(in) :: qsnow
7542 real (kind=kind_phys), intent(in) :: snowhin
7543 real (kind=kind_phys), intent(in) :: sfctmp
7544
7545! input and output
7546
7547 integer, intent(inout) :: isnow
7548 real (kind=kind_phys), intent(inout) :: snowh
7549 real (kind=kind_phys), intent(inout) :: sneqv
7550 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
7551 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
7552 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snice
7553 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snliq
7554
7555! local
7556
7557 integer :: newnode ! 0-no new layers, 1-creating new layers
7558! ----------------------------------------------------------------------
7559 newnode = 0
7560
7561! shallow snow / no layer
7562
7563 if(isnow == 0 .and. qsnow > 0.) then
7564 snowh = snowh + snowhin * dt
7565 sneqv = sneqv + qsnow * dt
7566 end if
7567
7568! creating a new layer
7569
7570 if(isnow == 0 .and. qsnow>0. .and. snowh >= 0.025) then !mb: change limit
7571! if(isnow == 0 .and. qsnow>0. .and. snowh >= 0.05) then
7572 isnow = -1
7573 newnode = 1
7574 dzsnso(0)= snowh
7575 snowh = 0.
7576 stc(0) = min(273.16, sfctmp) ! temporary setup
7577 snice(0) = sneqv
7578 snliq(0) = 0.
7579 end if
7580
7581! snow with layers
7582
7583 if(isnow < 0 .and. newnode == 0 .and. qsnow > 0.) then
7584 snice(isnow+1) = snice(isnow+1) + qsnow * dt
7585 dzsnso(isnow+1) = dzsnso(isnow+1) + snowhin * dt
7586 endif
7587
7588! ----------------------------------------------------------------------
7589 end subroutine snowfall
7590
7591!== begin combine ==================================================================================
7592
7595 subroutine combine (parameters,nsnow ,nsoil ,iloc ,jloc , & !in
7596 isnow ,sh2o ,stc ,snice ,snliq , & !inout
7597 dzsnso ,sice ,snowh ,sneqv , & !inout
7598 ponding1 ,ponding2) !out
7599! ----------------------------------------------------------------------
7600 implicit none
7601! ----------------------------------------------------------------------
7602! input
7603
7604 type (noahmp_parameters), intent(in) :: parameters
7605 integer, intent(in) :: iloc
7606 integer, intent(in) :: jloc
7607 integer, intent(in) :: nsnow
7608 integer, intent(in) :: nsoil
7609
7610! input and output
7611
7612 integer, intent(inout) :: isnow
7613 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sh2o
7614 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sice
7615 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
7616 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snice
7617 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snliq
7618 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
7619 real (kind=kind_phys), intent(inout) :: sneqv
7620 real (kind=kind_phys), intent(inout) :: snowh
7621 real (kind=kind_phys), intent(out) :: ponding1
7622 real (kind=kind_phys), intent(out) :: ponding2
7623
7624! local variables:
7625
7626 integer :: i,j,k,l ! node indices
7627 integer :: isnow_old ! number of top snow layer
7628 integer :: mssi ! node index
7629 integer :: neibor ! adjacent node selected for combination
7630 real (kind=kind_phys) :: zwice ! total ice mass in snow
7631 real (kind=kind_phys) :: zwliq ! total liquid water in snow
7632
7633 real (kind=kind_phys) :: dzmin(3) ! minimum of top snow layer
7634! data dzmin /0.045, 0.05, 0.2/
7635 data dzmin /0.025, 0.025, 0.1/ ! mb: change limit
7636!-----------------------------------------------------------------------
7637
7638 isnow_old = isnow
7639
7640 do j = isnow_old+1,0
7641 if (snice(j) <= .1) then
7642 if(j /= 0) then
7643 snliq(j+1) = snliq(j+1) + snliq(j)
7644 snice(j+1) = snice(j+1) + snice(j)
7645 dzsnso(j+1) = dzsnso(j+1) + dzsnso(j)
7646 else
7647 if (isnow_old < -1) then ! mb/km: change to isnow
7648 snliq(j-1) = snliq(j-1) + snliq(j)
7649 snice(j-1) = snice(j-1) + snice(j)
7650 dzsnso(j-1) = dzsnso(j-1) + dzsnso(j)
7651 else
7652 if(snice(j) >= 0.) then
7653 ponding1 = snliq(j) ! isnow will get set to zero below; ponding1 will get
7654 sneqv = snice(j) ! added to ponding from phasechange ponding should be
7655 snowh = dzsnso(j) ! zero here because it was calculated for thin snow
7656 else ! snice over-sublimated earlier
7657 ponding1 = snliq(j) + snice(j)
7658 if(ponding1 < 0.) then ! if snice and snliq sublimates remove from soil
7659 sice(1) = max(0.0,sice(1)+ponding1/(dzsnso(1)*1000.))
7660 ponding1 = 0.0
7661 end if
7662 sneqv = 0.0
7663 snowh = 0.0
7664 end if
7665 snliq(j) = 0.0
7666 snice(j) = 0.0
7667 dzsnso(j) = 0.0
7668 endif
7669! sh2o(1) = sh2o(1)+snliq(j)/(dzsnso(1)*1000.)
7670! sice(1) = sice(1)+snice(j)/(dzsnso(1)*1000.)
7671 endif
7672
7673 ! shift all elements above this down by one.
7674 if (j > isnow+1 .and. isnow < -1) then
7675 do i = j, isnow+2, -1
7676 stc(i) = stc(i-1)
7677 snliq(i) = snliq(i-1)
7678 snice(i) = snice(i-1)
7679 dzsnso(i)= dzsnso(i-1)
7680 end do
7681 end if
7682 isnow = isnow + 1
7683 end if
7684 end do
7685
7686! to conserve water in case of too large surface sublimation
7687
7688 if(sice(1) < 0.) then
7689 sh2o(1) = sh2o(1) + sice(1)
7690 sice(1) = 0.
7691 end if
7692
7693 if(isnow ==0) return ! mb: get out if no longer multi-layer
7694
7695 sneqv = 0.
7696 snowh = 0.
7697 zwice = 0.
7698 zwliq = 0.
7699
7700 do j = isnow+1,0
7701 sneqv = sneqv + snice(j) + snliq(j)
7702 snowh = snowh + dzsnso(j)
7703 zwice = zwice + snice(j)
7704 zwliq = zwliq + snliq(j)
7705 end do
7706
7707! check the snow depth - all snow gone
7708! the liquid water assumes ponding on soil surface.
7709
7710 if (snowh < 0.025 .and. isnow < 0 ) then ! mb: change limit
7711! if (snowh < 0.05 .and. isnow < 0 ) then
7712 isnow = 0
7713 sneqv = zwice
7714 ponding2 = zwliq ! limit of isnow < 0 means input ponding
7715 if(sneqv <= 0.) snowh = 0. ! should be zero; see above
7716 end if
7717
7718! if (snowh < 0.05 ) then
7719! isnow = 0
7720! sneqv = zwice
7721! sh2o(1) = sh2o(1) + zwliq / (dzsnso(1) * 1000.)
7722! if(sneqv <= 0.) snowh = 0.
7723! end if
7724
7725! check the snow depth - snow layers combined
7726
7727 if (isnow < -1) then
7728
7729 isnow_old = isnow
7730 mssi = 1
7731
7732 do i = isnow_old+1,0
7733 if (dzsnso(i) < dzmin(mssi)) then
7734
7735 if (i == isnow+1) then
7736 neibor = i + 1
7737 else if (i == 0) then
7738 neibor = i - 1
7739 else
7740 neibor = i + 1
7741 if ((dzsnso(i-1)+dzsnso(i)) < (dzsnso(i+1)+dzsnso(i))) neibor = i-1
7742 end if
7743
7744 ! node l and j are combined and stored as node j.
7745 if (neibor > i) then
7746 j = neibor
7747 l = i
7748 else
7749 j = i
7750 l = neibor
7751 end if
7752
7753 call combo (parameters,dzsnso(j), snliq(j), snice(j), &
7754 stc(j), dzsnso(l), snliq(l), snice(l), stc(l) )
7755
7756 ! now shift all elements above this down one.
7757 if (j-1 > isnow+1) then
7758 do k = j-1, isnow+2, -1
7759 stc(k) = stc(k-1)
7760 snice(k) = snice(k-1)
7761 snliq(k) = snliq(k-1)
7762 dzsnso(k) = dzsnso(k-1)
7763 end do
7764 end if
7765
7766 ! decrease the number of snow layers
7767 isnow = isnow + 1
7768 if (isnow >= -1) exit
7769 else
7770
7771 ! the layer thickness is greater than the prescribed minimum value
7772 mssi = mssi + 1
7773
7774 end if
7775 end do
7776
7777 end if
7778
7779 end subroutine combine
7780
7781!== begin divide ===================================================================================
7782
7785 subroutine divide (parameters,nsnow ,nsoil , & !in
7786 isnow ,stc ,snice ,snliq ,dzsnso ) !inout
7787! ----------------------------------------------------------------------
7788 implicit none
7789! ----------------------------------------------------------------------
7790! input
7791
7792 type (noahmp_parameters), intent(in) :: parameters
7793 integer, intent(in) :: nsnow
7794 integer, intent(in) :: nsoil
7795
7796! input and output
7797
7798 integer , intent(inout) :: isnow
7799 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
7800 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snice
7801 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snliq
7802 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
7803
7804! local variables:
7805
7806 integer :: j !indices
7807 integer :: msno !number of layer (top) to msno (bot)
7808 real (kind=kind_phys) :: drr !thickness of the combined [m]
7809 real (kind=kind_phys), dimension( 1:nsnow) :: dz !snow layer thickness [m]
7810 real (kind=kind_phys), dimension( 1:nsnow) :: swice !partial volume of ice [m3/m3]
7811 real (kind=kind_phys), dimension( 1:nsnow) :: swliq !partial volume of liquid water [m3/m3]
7812 real (kind=kind_phys), dimension( 1:nsnow) :: tsno !node temperature [k]
7813 real (kind=kind_phys) :: zwice !temporary
7814 real (kind=kind_phys) :: zwliq !temporary
7815 real (kind=kind_phys) :: propor!temporary
7816 real (kind=kind_phys) :: dtdz !temporary
7817! ----------------------------------------------------------------------
7818
7819 do j = 1,nsnow
7820 if (j <= abs(isnow)) then
7821 dz(j) = dzsnso(j+isnow)
7822 swice(j) = snice(j+isnow)
7823 swliq(j) = snliq(j+isnow)
7824 tsno(j) = stc(j+isnow)
7825 end if
7826 end do
7827
7828 msno = abs(isnow)
7829
7830 if (msno == 1) then
7831 ! specify a new snow layer
7832 if (dz(1) > 0.05) then
7833 msno = 2
7834 dz(1) = dz(1)/2.
7835 swice(1) = swice(1)/2.
7836 swliq(1) = swliq(1)/2.
7837 dz(2) = dz(1)
7838 swice(2) = swice(1)
7839 swliq(2) = swliq(1)
7840 tsno(2) = tsno(1)
7841 end if
7842 end if
7843
7844 if (msno > 1) then
7845 if (dz(1) > 0.05) then
7846 drr = dz(1) - 0.05
7847 propor = drr/dz(1)
7848 zwice = propor*swice(1)
7849 zwliq = propor*swliq(1)
7850 propor = 0.05/dz(1)
7851 swice(1) = propor*swice(1)
7852 swliq(1) = propor*swliq(1)
7853 dz(1) = 0.05
7854
7855 call combo (parameters,dz(2), swliq(2), swice(2), tsno(2), drr, &
7856 zwliq, zwice, tsno(1))
7857
7858 ! subdivide a new layer
7859 if (msno <= 2 .and. dz(2) > 0.20) then ! mb: change limit
7860! if (msno <= 2 .and. dz(2) > 0.10) then
7861 msno = 3
7862 dtdz = (tsno(1) - tsno(2))/((dz(1)+dz(2))/2.)
7863 dz(2) = dz(2)/2.
7864 swice(2) = swice(2)/2.
7865 swliq(2) = swliq(2)/2.
7866 dz(3) = dz(2)
7867 swice(3) = swice(2)
7868 swliq(3) = swliq(2)
7869 tsno(3) = tsno(2) - dtdz*dz(2)/2.
7870 if (tsno(3) >= tfrz) then
7871 tsno(3) = tsno(2)
7872 else
7873 tsno(2) = tsno(2) + dtdz*dz(2)/2.
7874 endif
7875
7876 end if
7877 end if
7878 end if
7879
7880 if (msno > 2) then
7881 if (dz(2) > 0.2) then
7882 drr = dz(2) - 0.2
7883 propor = drr/dz(2)
7884 zwice = propor*swice(2)
7885 zwliq = propor*swliq(2)
7886 propor = 0.2/dz(2)
7887 swice(2) = propor*swice(2)
7888 swliq(2) = propor*swliq(2)
7889 dz(2) = 0.2
7890 call combo (parameters,dz(3), swliq(3), swice(3), tsno(3), drr, &
7891 zwliq, zwice, tsno(2))
7892 end if
7893 end if
7894
7895 isnow = -msno
7896
7897 do j = isnow+1,0
7898 dzsnso(j) = dz(j-isnow)
7899 snice(j) = swice(j-isnow)
7900 snliq(j) = swliq(j-isnow)
7901 stc(j) = tsno(j-isnow)
7902 end do
7903
7904
7905! do j = isnow+1,nsoil
7906! write(*,'(i5,7f10.3)') j, dzsnso(j), snice(j), snliq(j),stc(j)
7907! end do
7908
7909 end subroutine divide
7910
7911!== begin combo ====================================================================================
7912
7915 subroutine combo(parameters,dz, wliq, wice, t, dz2, wliq2, wice2, t2)
7916! ----------------------------------------------------------------------
7917 implicit none
7918! ----------------------------------------------------------------------
7919
7920! ----------------------------------------------------------------------s
7921! input
7922
7923 type (noahmp_parameters), intent(in) :: parameters
7924 real (kind=kind_phys), intent(in) :: dz2
7925 real (kind=kind_phys), intent(in) :: wliq2
7926 real (kind=kind_phys), intent(in) :: wice2
7927 real (kind=kind_phys), intent(in) :: t2
7928 real (kind=kind_phys), intent(inout) :: dz
7929 real (kind=kind_phys), intent(inout) :: wliq
7930 real (kind=kind_phys), intent(inout) :: wice
7931 real (kind=kind_phys), intent(inout) :: t
7932
7933! local
7934
7935 real (kind=kind_phys) :: dzc !total thickness of nodes 1 and 2 (dzc=dz+dz2).
7936 real (kind=kind_phys) :: wliqc !combined liquid water [kg/m2]
7937 real (kind=kind_phys) :: wicec !combined ice [kg/m2]
7938 real (kind=kind_phys) :: tc !combined node temperature [k]
7939 real (kind=kind_phys) :: h !enthalpy of element 1 [j/m2]
7940 real (kind=kind_phys) :: h2 !enthalpy of element 2 [j/m2]
7941 real (kind=kind_phys) :: hc !temporary
7942
7943!-----------------------------------------------------------------------
7944
7945 dzc = dz+dz2
7946 wicec = (wice+wice2)
7947 wliqc = (wliq+wliq2)
7948 h = (cice*wice+cwat*wliq) * (t-tfrz)+hfus*wliq
7949 h2= (cice*wice2+cwat*wliq2) * (t2-tfrz)+hfus*wliq2
7950
7951 hc = h + h2
7952 if(hc < 0.)then
7953 tc = tfrz + hc/(cice*wicec + cwat*wliqc)
7954 else if (hc.le.hfus*wliqc) then
7955 tc = tfrz
7956 else
7957 tc = tfrz + (hc - hfus*wliqc) / (cice*wicec + cwat*wliqc)
7958 end if
7959
7960 dz = dzc
7961 wice = wicec
7962 wliq = wliqc
7963 t = tc
7964
7965 end subroutine combo
7966
7967!== begin compact ==================================================================================
7968
7971 subroutine compact (parameters,nsnow ,nsoil ,dt ,stc ,snice , & !in
7972 snliq ,zsoil ,imelt ,ficeold,iloc , jloc , & !in
7973 isnow ,dzsnso ,zsnso ) !inout
7974! ----------------------------------------------------------------------
7975 implicit none
7976! ----------------------------------------------------------------------
7977! input
7978 type (noahmp_parameters), intent(in) :: parameters
7979 integer, intent(in) :: iloc
7980 integer, intent(in) :: jloc
7981 integer, intent(in) :: nsoil
7982 integer, intent(in) :: nsnow
7983 integer, dimension(-nsnow+1:0) , intent(in) :: imelt
7984 real (kind=kind_phys), intent(in) :: dt
7985 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc
7986 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snice
7987 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snliq
7988 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil
7989 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: ficeold
7990
7991! input and output
7992 integer, intent(inout) :: isnow
7993 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
7994 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: zsnso
7995
7996! local
7997 real (kind=kind_phys), parameter :: c2 = 21.e-3 ![m3/kg] ! default 21.e-3
7998 real (kind=kind_phys), parameter :: c3 = 2.5e-6 ![1/s]
7999 real (kind=kind_phys), parameter :: c4 = 0.04 ![1/k]
8000 real (kind=kind_phys), parameter :: c5 = 2.0 !
8001 real (kind=kind_phys), parameter :: dm = 100.0 !upper limit on destructive metamorphism compaction [kg/m3]
8002 real (kind=kind_phys), parameter :: eta0 = 1.8e+6 !viscosity coefficient [kg-s/m2]
8003 !according to anderson, it is between 0.52e6~1.38e6
8004 real (kind=kind_phys) :: burden !pressure of overlying snow [kg/m2]
8005 real (kind=kind_phys) :: ddz1 !rate of settling of snow pack due to destructive metamorphism.
8006 real (kind=kind_phys) :: ddz2 !rate of compaction of snow pack due to overburden.
8007 real (kind=kind_phys) :: ddz3 !rate of compaction of snow pack due to melt [1/s]
8008 real (kind=kind_phys) :: dexpf !expf=exp(-c4*(273.15-stc)).
8009 real (kind=kind_phys) :: td !stc - tfrz [k]
8010 real (kind=kind_phys) :: pdzdtc !nodal rate of change in fractional-thickness due to compaction [fraction/s]
8011 real (kind=kind_phys) :: void !void (1 - snice - snliq)
8012 real (kind=kind_phys) :: wx !water mass (ice + liquid) [kg/m2]
8013 real (kind=kind_phys) :: bi !partial density of ice [kg/m3]
8014 real (kind=kind_phys), dimension(-nsnow+1:0) :: fice !fraction of ice at current time step
8015
8016 integer :: j
8017
8018! ----------------------------------------------------------------------
8019 burden = 0.0
8020
8021 do j = isnow+1, 0
8022
8023 wx = snice(j) + snliq(j)
8024 fice(j) = snice(j) / wx
8025 void = 1. - (snice(j)/denice + snliq(j)/denh2o) / dzsnso(j)
8026
8027 ! allow compaction only for non-saturated node and higher ice lens node.
8028 if (void > 0.001 .and. snice(j) > 0.1) then
8029 bi = snice(j) / dzsnso(j)
8030 td = max(0.,tfrz-stc(j))
8031 dexpf = exp(-c4*td)
8032
8033 ! settling as a result of destructive metamorphism
8034
8035 ddz1 = -c3*dexpf
8036
8037 if (bi > dm) ddz1 = ddz1*exp(-46.0e-3*(bi-dm))
8038
8039 ! liquid water term
8040
8041 if (snliq(j) > 0.01*dzsnso(j)) ddz1=ddz1*c5
8042
8043 ! compaction due to overburden
8044
8045 ddz2 = -(burden+0.5*wx)*exp(-0.08*td-c2*bi)/eta0 ! 0.5*wx -> self-burden
8046
8047 ! compaction occurring during melt
8048
8049 if (imelt(j) == 1) then
8050 ddz3 = max(0.,(ficeold(j) - fice(j))/max(1.e-6,ficeold(j)))
8051 ddz3 = - ddz3/dt ! sometimes too large
8052 else
8053 ddz3 = 0.
8054 end if
8055
8056 ! time rate of fractional change in dz (units of s-1)
8057
8058 pdzdtc = (ddz1 + ddz2 + ddz3)*dt
8059 pdzdtc = max(-0.5,pdzdtc)
8060
8061 ! the change in dz due to compaction
8062
8063 dzsnso(j) = dzsnso(j)*(1.+pdzdtc)
8064 dzsnso(j) = min(max(dzsnso(j),(snliq(j)+snice(j))/500.0),(snliq(j)+snice(j))/50.0) ! limit adjustment to a reasonable density
8065 end if
8066
8067 ! pressure of overlying snow
8068
8069 burden = burden + wx
8070
8071 end do
8072
8073 end subroutine compact
8074
8075!== begin snowh2o ==================================================================================
8076
8080 subroutine snowh2o (parameters,nsnow ,nsoil ,dt ,qsnfro ,qsnsub , & !in
8081 qrain ,iloc ,jloc , & !in
8082 isnow ,dzsnso ,snowh ,sneqv ,snice , & !inout
8083 snliq ,sh2o ,sice ,stc , & !inout
8084 qsnbot ,ponding1 ,ponding2) !out
8085! ----------------------------------------------------------------------
8086! renew the mass of ice lens (snice) and liquid (snliq) of the
8087! surface snow layer resulting from sublimation (frost) / evaporation (dew)
8088! ----------------------------------------------------------------------
8089 implicit none
8090! ----------------------------------------------------------------------
8091! input
8092
8093 type (noahmp_parameters), intent(in) :: parameters
8094 integer, intent(in) :: iloc
8095 integer, intent(in) :: jloc
8096 integer, intent(in) :: nsnow
8097 integer, intent(in) :: nsoil
8098 real (kind=kind_phys), intent(in) :: dt
8099 real (kind=kind_phys), intent(in) :: qsnfro
8100 real (kind=kind_phys), intent(in) :: qsnsub
8101 real (kind=kind_phys), intent(in) :: qrain
8102
8103! output
8104
8105 real (kind=kind_phys), intent(out) :: qsnbot
8106
8107! input and output
8108
8109 integer, intent(inout) :: isnow
8110 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
8111 real (kind=kind_phys), intent(inout) :: snowh
8112 real (kind=kind_phys), intent(inout) :: sneqv
8113 real (kind=kind_phys), dimension(-nsnow+1:0), intent(inout) :: snice
8114 real (kind=kind_phys), dimension(-nsnow+1:0), intent(inout) :: snliq
8115 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sh2o
8116 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sice
8117 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
8118
8119! local variables:
8120
8121 integer :: j !do loop/array indices
8122 real (kind=kind_phys) :: qin !water flow into the element (mm/s)
8123 real (kind=kind_phys) :: qout !water flow out of the element (mm/s)
8124 real (kind=kind_phys) :: wgdif !ice mass after minus sublimation
8125 real (kind=kind_phys), dimension(-nsnow+1:0) :: vol_liq !partial volume of liquid water in layer
8126 real (kind=kind_phys), dimension(-nsnow+1:0) :: vol_ice !partial volume of ice lens in layer
8127 real (kind=kind_phys), dimension(-nsnow+1:0) :: epore !effective porosity = porosity - vol_ice
8128 real (kind=kind_phys) :: propor, temp
8129 real (kind=kind_phys) :: ponding1, ponding2
8130 real (kind=kind_phys), parameter :: max_liq_mass_fraction = 0.4
8131! ----------------------------------------------------------------------
8132
8133!for the case when sneqv becomes '0' after 'combine'
8134
8135 if(sneqv == 0.) then
8136 sice(1) = sice(1) + (qsnfro-qsnsub)*dt/(dzsnso(1)*1000.) ! barlage: sh2o->sice v3.6
8137 if(sice(1) < 0.) then
8138 sh2o(1) = sh2o(1) + sice(1)
8139 sice(1) = 0.
8140 end if
8141 end if
8142
8143! for shallow snow without a layer
8144! snow surface sublimation may be larger than existing snow mass. to conserve water,
8145! excessive sublimation is used to reduce soil water. smaller time steps would tend
8146! to aviod this problem.
8147
8148 if(isnow == 0 .and. sneqv > 0.) then
8149 temp = sneqv
8150 sneqv = sneqv - qsnsub*dt + qsnfro*dt
8151 propor = sneqv/temp
8152 snowh = max(0.,propor * snowh)
8153 snowh = min(max(snowh,sneqv/500.0),sneqv/50.0) ! limit adjustment to a reasonable density
8154
8155 if(sneqv < 0.) then
8156 sice(1) = sice(1) + sneqv/(dzsnso(1)*1000.)
8157 sneqv = 0.
8158 snowh = 0.
8159 end if
8160 if(sice(1) < 0.) then
8161 sh2o(1) = sh2o(1) + sice(1)
8162 sice(1) = 0.
8163 end if
8164 end if
8165
8166 if(snowh <= 1.e-6 .or. sneqv <= 1.e-3) then
8167 snowh = 0.0
8168 sneqv = 0.0
8169 end if
8170
8171! for deep snow
8172
8173 if ( isnow < 0 ) then !kwm added this if statement to prevent out-of-bounds array references
8174
8175 wgdif = snice(isnow+1) - qsnsub*dt + qsnfro*dt
8176 snice(isnow+1) = wgdif
8177 if (wgdif < 1.e-6 .and. isnow <0) then
8178 call combine (parameters,nsnow ,nsoil ,iloc, jloc , & !in
8179 isnow ,sh2o ,stc ,snice ,snliq , & !inout
8180 dzsnso ,sice ,snowh ,sneqv , & !inout
8181 ponding1, ponding2 ) !out
8182 endif
8183 !kwm: subroutine combine can change isnow to make it 0 again?
8184 if ( isnow < 0 ) then !kwm added this if statement to prevent out-of-bounds array references
8185 snliq(isnow+1) = snliq(isnow+1) + qrain * dt
8186 snliq(isnow+1) = max(0., snliq(isnow+1))
8187 endif
8188
8189 endif !kwm -- can the endif be moved toward the end of the subroutine (just set qsnbot=0)?
8190
8191! porosity and partial volume
8192
8193 do j = isnow+1, 0
8194 vol_ice(j) = min(1., snice(j)/(dzsnso(j)*denice))
8195 epore(j) = 1. - vol_ice(j)
8196 end do
8197
8198 qin = 0.
8199 qout = 0.
8200
8201 do j = isnow+1, 0
8202 snliq(j) = snliq(j) + qin
8203 vol_liq(j) = snliq(j)/(dzsnso(j)*denh2o)
8204 qout = max(0.,(vol_liq(j)-parameters%ssi*epore(j))*dzsnso(j))
8205 if(j == 0) then
8206 qout = max((vol_liq(j)- epore(j))*dzsnso(j) , parameters%snow_ret_fac*dt*qout)
8207 end if
8208 qout = qout*denh2o
8209 snliq(j) = snliq(j) - qout
8210 if((snliq(j)/(snice(j)+snliq(j))) > max_liq_mass_fraction) then
8211 qout = qout + (snliq(j) - max_liq_mass_fraction/(1.0 - max_liq_mass_fraction)*snice(j))
8212 snliq(j) = max_liq_mass_fraction/(1.0 - max_liq_mass_fraction)*snice(j)
8213 endif
8214 qin = qout
8215 end do
8216
8217 do j = isnow+1, 0
8218 dzsnso(j) = min(max(dzsnso(j),(snliq(j)+snice(j))/500.0),(snliq(j)+snice(j))/50.0) ! limit adjustment to a reasonable density
8219 end do
8220
8221! liquid water from snow bottom to soil
8222
8223 qsnbot = qout / dt ! mm/s
8224
8225 end subroutine snowh2o
8226
8227!== begin soilwater ================================================================================
8228
8231 subroutine soilwater (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in
8232 qinsur ,qseva ,etrani ,sice ,iloc , jloc, & !in
8233 sh2o ,smc ,zwt ,vegtyp ,& !inout
8234 smcwtd, deeprech ,& !inout
8235 runsrf ,qdrain ,runsub ,wcnd ,fcrmax ) !out
8236
8237! ----------------------------------------------------------------------
8238! calculate surface runoff and soil moisture.
8239! ----------------------------------------------------------------------
8240! ----------------------------------------------------------------------
8241 implicit none
8242! ----------------------------------------------------------------------
8243! input
8244 type (noahmp_parameters), intent(in) :: parameters
8245 integer, intent(in) :: iloc
8246 integer, intent(in) :: jloc
8247 integer, intent(in) :: nsoil
8248 integer, intent(in) :: nsnow
8249 real (kind=kind_phys), intent(in) :: dt
8250 real (kind=kind_phys), intent(in) :: qinsur
8251 real (kind=kind_phys), intent(in) :: qseva
8252 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: zsoil
8253 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: etrani
8254 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
8255 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: sice
8256
8257 integer, intent(in) :: vegtyp
8258
8259! input & output
8260 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: sh2o
8261 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: smc
8262 real (kind=kind_phys), intent(inout) :: zwt
8263 real (kind=kind_phys), intent(inout) :: smcwtd
8264 real (kind=kind_phys) , intent(inout) :: deeprech
8265
8266! output
8267 real (kind=kind_phys), intent(out) :: qdrain
8268 real (kind=kind_phys), intent(out) :: runsrf
8269 real (kind=kind_phys), intent(out) :: runsub
8270 real (kind=kind_phys), intent(out) :: fcrmax
8271 real (kind=kind_phys), dimension(1:nsoil), intent(out) :: wcnd
8272
8273! local
8274 integer :: k,iz !do-loop index
8275 integer :: iter !iteration index
8276 real (kind=kind_phys) :: dtfine !fine time step (s)
8277 real (kind=kind_phys), dimension(1:nsoil) :: rhstt !right-hand side term of the matrix
8278 real (kind=kind_phys), dimension(1:nsoil) :: ai !left-hand side term
8279 real (kind=kind_phys), dimension(1:nsoil) :: bi !left-hand side term
8280 real (kind=kind_phys), dimension(1:nsoil) :: ci !left-hand side term
8281
8282 real (kind=kind_phys) :: fff !runoff decay factor (m-1)
8283 real (kind=kind_phys) :: rsbmx !baseflow coefficient [mm/s]
8284 real (kind=kind_phys) :: pddum !infiltration rate at surface (m/s)
8285 real (kind=kind_phys) :: fice !ice fraction in frozen soil
8286 real (kind=kind_phys) :: wplus !saturation excess of the total soil [m]
8287 real (kind=kind_phys) :: rsat !accumulation of wplus (saturation excess) [m]
8288 real (kind=kind_phys) :: sicemax!maximum soil ice content (m3/m3)
8289 real (kind=kind_phys) :: sh2omin!minimum soil liquid water content (m3/m3)
8290 real (kind=kind_phys) :: wtsub !sum of wcnd(k)*dzsnso(k)
8291 real (kind=kind_phys) :: mh2o !water mass removal (mm)
8292 real (kind=kind_phys) :: fsat !fractional saturated area (-)
8293 real (kind=kind_phys), dimension(1:nsoil) :: mliq !
8294 real (kind=kind_phys) :: xs !
8295 real (kind=kind_phys) :: watmin !
8296 real (kind=kind_phys) :: qdrain_save !
8297 real (kind=kind_phys) :: runsrf_save !
8298 real (kind=kind_phys) :: epore !effective porosity [m3/m3]
8299 real (kind=kind_phys), dimension(1:nsoil) :: fcr !impermeable fraction due to frozen soil
8300 integer :: niter !iteration times soil moisture (-)
8301 real (kind=kind_phys) :: smctot !2-m averaged soil moisture (m3/m3)
8302 real (kind=kind_phys) :: dztot !2-m soil depth (m)
8303 real (kind=kind_phys), parameter :: a = 4.0
8304! ----------------------------------------------------------------------
8305 runsrf = 0.0
8306 pddum = 0.0
8307 rsat = 0.0
8308
8309! for the case when snowmelt water is too large
8310
8311 do k = 1,nsoil
8312 epore = max( 1.e-4 , ( parameters%smcmax(k) - sice(k) ) )
8313 rsat = rsat + max(0.,sh2o(k)-epore)*dzsnso(k)
8314 sh2o(k) = min(epore,sh2o(k))
8315 end do
8316
8317!impermeable fraction due to frozen soil
8318
8319 do k = 1,nsoil
8320 fice = min(1.0,sice(k)/parameters%smcmax(k))
8321 fcr(k) = max(0.0,exp(-a*(1.-fice))- exp(-a)) / &
8322 (1.0 - exp(-a))
8323 end do
8324
8325! maximum soil ice content and minimum liquid water of all layers
8326
8327 sicemax = 0.0
8328 fcrmax = 0.0
8329 sh2omin = parameters%smcmax(1)
8330 do k = 1,nsoil
8331 if (sice(k) > sicemax) sicemax = sice(k)
8332 if (fcr(k) > fcrmax) fcrmax = fcr(k)
8333 if (sh2o(k) < sh2omin) sh2omin = sh2o(k)
8334 end do
8335
8336!subsurface runoff for runoff scheme option 2
8337
8338 if(opt_run == 2) then
8339 fff = 2.0
8340 rsbmx = 4.0
8341 call zwteq (parameters,nsoil ,nsnow ,zsoil ,dzsnso ,sh2o ,zwt)
8342 runsub = (1.0-fcrmax) * rsbmx * exp(-parameters%timean) * exp(-fff*zwt) ! mm/s
8343 end if
8344
8345!surface runoff and infiltration rate using different schemes
8346
8347!jref impermable surface at urban
8348 if ( parameters%urban_flag ) fcr(1)= 0.95
8349
8350 if(opt_run == 1) then
8351! fff = 6.0
8352 fff = parameters%bexp(1) / 3.0 ! calibratable, c.he changed based on gy niu's update
8353! fsat = parameters%fsatmx*exp(-0.5*fff*(zwt-2.0))
8354 fsat = parameters%fsatmx*exp(-0.5*fff*zwt) ! c.he changed based on gy niu's update
8355 if(qinsur > 0.) then
8356 runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) )
8357 pddum = qinsur - runsrf ! m/s
8358 end if
8359 end if
8360
8361 if(opt_run == 5) then
8362 fff = 6.0
8363 fsat = parameters%fsatmx*exp(-0.5*fff*max(-2.0-zwt,0.))
8364 if(qinsur > 0.) then
8365 runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) )
8366 pddum = qinsur - runsrf ! m/s
8367 end if
8368 end if
8369
8370 if(opt_run == 2) then
8371 fff = 2.0
8372 fsat = parameters%fsatmx*exp(-0.5*fff*zwt)
8373 if(qinsur > 0.) then
8374 runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) )
8375 pddum = qinsur - runsrf ! m/s
8376 end if
8377 end if
8378
8379 if(opt_run == 3) then
8380 call infil (parameters,nsoil ,dt ,zsoil ,sh2o ,sice , & !in
8381 sicemax,qinsur , & !in
8382 pddum ,runsrf ) !out
8383 end if
8384
8385 if(opt_run == 4) then
8386 smctot = 0.
8387 dztot = 0.
8388 do k = 1,nsoil
8389 dztot = dztot + dzsnso(k)
8390 smctot = smctot + smc(k)/parameters%smcmax(k)*dzsnso(k)
8391 if(dztot >= 2.0) exit
8392 end do
8393 smctot = smctot/dztot
8394 fsat = max(0.01,smctot) ** 4. !bats
8395
8396 if(qinsur > 0.) then
8397 runsrf = qinsur * ((1.0-fcr(1))*fsat+fcr(1))
8398 pddum = qinsur - runsrf ! m/s
8399 end if
8400 end if
8401
8402! determine iteration times and finer time step
8403
8404 niter = 1
8405
8406! if(opt_inf == 1) then !opt_inf =2 may cause water imbalance
8407 niter = 3
8408 if (pddum*dt>dzsnso(1)*parameters%smcmax(1) ) then
8409 niter = niter*2
8410 end if
8411! end if
8412
8413 dtfine = dt / niter
8414
8415! solve soil moisture
8416
8417 qdrain_save = 0.0
8418 runsrf_save = 0.0
8419 do iter = 1, niter
8420 if(qinsur > 0. .and. opt_run == 3) then
8421 call infil (parameters,nsoil ,dtfine ,zsoil ,sh2o ,sice , & !in
8422 sicemax,qinsur , & !in
8423 pddum ,runsrf ) !out
8424 end if
8425
8426 call srt (parameters,nsoil ,zsoil ,dtfine ,pddum ,etrani , & !in
8427 qseva ,sh2o ,smc ,zwt ,fcr , & !in
8428 sicemax,fcrmax ,iloc ,jloc ,smcwtd , & !in
8429 rhstt ,ai ,bi ,ci ,qdrain , & !out
8430 wcnd ) !out
8431
8432 call sstep (parameters,nsoil ,nsnow ,dtfine ,zsoil ,dzsnso , & !in
8433 sice ,iloc ,jloc ,zwt , & !in
8434 sh2o ,smc ,ai ,bi ,ci , & !inout
8435 rhstt ,smcwtd ,qdrain ,deeprech, & !inout
8436 wplus) !out
8437 rsat = rsat + wplus
8438 qdrain_save = qdrain_save + qdrain
8439 runsrf_save = runsrf_save + runsrf
8440 end do
8441
8442 qdrain = qdrain_save/niter
8443 runsrf = runsrf_save/niter
8444
8445 runsrf = runsrf * 1000. + rsat * 1000./dt ! m/s -> mm/s
8446 qdrain = qdrain * 1000.
8447
8448!wrf_hydro_djg...
8449!yw infxsrt = runsrf * dt !mm/s -> mm
8450
8451! removal of soil water due to groundwater flow (option 2)
8452
8453 if(opt_run == 2) then
8454 wtsub = 0.
8455 do k = 1, nsoil
8456 wtsub = wtsub + wcnd(k)*dzsnso(k)
8457 end do
8458
8459 do k = 1, nsoil
8460 mh2o = runsub*dt*(wcnd(k)*dzsnso(k))/wtsub ! mm
8461 sh2o(k) = sh2o(k) - mh2o/(dzsnso(k)*1000.)
8462 end do
8463 end if
8464
8465! limit mliq to be greater than or equal to watmin.
8466! get water needed to bring mliq equal watmin from lower layer.
8467
8468 if(opt_run /= 1) then
8469 do iz = 1, nsoil
8470 mliq(iz) = sh2o(iz)*dzsnso(iz)*1000.
8471 end do
8472
8473 watmin = 0.01 ! mm
8474 do iz = 1, nsoil-1
8475 if (mliq(iz) .lt. 0.) then
8476 xs = watmin-mliq(iz)
8477 else
8478 xs = 0.
8479 end if
8480 mliq(iz ) = mliq(iz ) + xs
8481 mliq(iz+1) = mliq(iz+1) - xs
8482 end do
8483
8484 iz = nsoil
8485 if (mliq(iz) .lt. watmin) then
8486 xs = watmin-mliq(iz)
8487 else
8488 xs = 0.
8489 end if
8490 mliq(iz) = mliq(iz) + xs
8491 runsub = runsub - xs/dt
8492 if(opt_run == 5)deeprech = deeprech - xs*1.e-3
8493
8494 do iz = 1, nsoil
8495 sh2o(iz) = mliq(iz) / (dzsnso(iz)*1000.)
8496 end do
8497 end if
8498
8499 end subroutine soilwater
8500
8501!== begin zwteq ====================================================================================
8502
8505 subroutine zwteq (parameters,nsoil ,nsnow ,zsoil ,dzsnso ,sh2o ,zwt)
8506! ----------------------------------------------------------------------
8507! calculate equilibrium water table depth (niu et al., 2005)
8508! ----------------------------------------------------------------------
8509 implicit none
8510! ----------------------------------------------------------------------
8511! input
8512
8513 type (noahmp_parameters), intent(in) :: parameters
8514 integer, intent(in) :: nsoil
8515 integer, intent(in) :: nsnow
8516 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: zsoil
8517 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
8518 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: sh2o
8519
8520! output
8521
8522 real (kind=kind_phys), intent(out) :: zwt
8523
8524! locals
8525
8526 integer :: k !do-loop index
8527 integer, parameter :: nfine = 100 !no. of fine soil layers of 6m soil
8528 real (kind=kind_phys) :: wd1 !water deficit from coarse (4-l) soil moisture profile
8529 real (kind=kind_phys) :: wd2 !water deficit from fine (100-l) soil moisture profile
8530 real (kind=kind_phys) :: dzfine !layer thickness of the 100-l soil layers to 6.0 m
8531 real (kind=kind_phys) :: temp !temporary variable
8532 real (kind=kind_phys), dimension(1:nfine) :: zfine !layer-bottom depth of the 100-l soil layers to 6.0 m
8533! ----------------------------------------------------------------------
8534
8535 wd1 = 0.
8536 do k = 1,nsoil
8537 wd1 = wd1 + (parameters%smcmax(1)-sh2o(k)) * dzsnso(k) ! [m]
8538 enddo
8539
8540 dzfine = 3.0 * (-zsoil(nsoil)) / nfine
8541 do k =1,nfine
8542 zfine(k) = float(k) * dzfine
8543 enddo
8544
8545 zwt = -3.*zsoil(nsoil) - 0.001 ! initial value [m]
8546
8547 wd2 = 0.
8548 do k = 1,nfine
8549 temp = 1. + (zwt-zfine(k))/parameters%psisat(1)
8550 wd2 = wd2 + parameters%smcmax(1)*(1.-temp**(-1./parameters%bexp(1)))*dzfine
8551 if(abs(wd2-wd1).le.0.01) then
8552 zwt = zfine(k)
8553 exit
8554 endif
8555 enddo
8556
8557 end subroutine zwteq
8558
8559!== begin infil ====================================================================================
8560
8563 subroutine infil (parameters,nsoil ,dt ,zsoil ,sh2o ,sice , & !in
8564 sicemax,qinsur , & !in
8565 pddum ,runsrf ) !out
8566! --------------------------------------------------------------------------------
8567! compute inflitration rate at soil surface and surface runoff
8568! --------------------------------------------------------------------------------
8569 implicit none
8570! --------------------------------------------------------------------------------
8571! inputs
8572 type (noahmp_parameters), intent(in) :: parameters
8573 integer, intent(in) :: nsoil
8574 real (kind=kind_phys), intent(in) :: dt
8575 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: zsoil
8576 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: sh2o
8577 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: sice
8578 real (kind=kind_phys), intent(in) :: qinsur
8579 real (kind=kind_phys), intent(in) :: sicemax
8580
8581! outputs
8582 real (kind=kind_phys), intent(out) :: runsrf
8583 real (kind=kind_phys), intent(out) :: pddum
8584
8585! locals
8586 integer :: ialp1, j, jj, k
8587 real (kind=kind_phys) :: val
8588 real (kind=kind_phys) :: ddt
8589 real (kind=kind_phys) :: px
8590 real (kind=kind_phys) :: dt1, dd, dice
8591 real (kind=kind_phys) :: fcr
8592 real (kind=kind_phys) :: sum
8593 real (kind=kind_phys) :: acrt
8594 real (kind=kind_phys) :: wdf
8595 real (kind=kind_phys) :: wcnd
8596 real (kind=kind_phys) :: smcav
8597 real (kind=kind_phys) :: infmax
8598 real (kind=kind_phys), dimension(1:nsoil) :: dmax
8599 integer, parameter :: cvfrz = 3
8600! --------------------------------------------------------------------------------
8601
8602 if (qinsur > 0.0) then
8603 dt1 = dt /86400.
8604 smcav = parameters%smcmax(1) - parameters%smcwlt(1)
8605
8606! maximum infiltration rate
8607
8608 dmax(1)= -zsoil(1) * smcav
8609 dice = -zsoil(1) * sice(1)
8610 dmax(1)= dmax(1)* (1.0-(sh2o(1) + sice(1) - parameters%smcwlt(1))/smcav)
8611
8612 dd = dmax(1)
8613
8614 do k = 2,nsoil
8615 dice = dice + (zsoil(k-1) - zsoil(k) ) * sice(k)
8616 dmax(k) = (zsoil(k-1) - zsoil(k)) * smcav
8617 dmax(k) = dmax(k) * (1.0-(sh2o(k) + sice(k) - parameters%smcwlt(k))/smcav)
8618 dd = dd + dmax(k)
8619 end do
8620
8621 val = (1. - exp( - parameters%kdt * dt1))
8622 ddt = dd * val
8623 px = max(0.,qinsur * dt)
8624 infmax = (px * (ddt / (px + ddt)))/ dt
8625
8626! impermeable fraction due to frozen soil
8627
8628 fcr = 1.
8629 if (dice > 1.e-2) then
8630 acrt = cvfrz * parameters%frzx / dice
8631 sum = 1.
8632 ialp1 = cvfrz - 1
8633 do j = 1,ialp1
8634 k = 1
8635 do jj = j +1,ialp1
8636 k = k * jj
8637 end do
8638 sum = sum + (acrt ** (cvfrz - j)) / float(k)
8639 end do
8640 fcr = 1. - exp(-acrt) * sum
8641 end if
8642
8643! correction of infiltration limitation
8644
8645 infmax = infmax * fcr
8646
8647! jref for urban areas
8648! if ( parameters%urban_flag ) infmax == infmax * 0.05
8649
8650 call wdfcnd2 (parameters,wdf,wcnd,sh2o(1),sicemax,1)
8651 infmax = max(infmax,wcnd)
8652 infmax = min(infmax,px/dt)
8653
8654 runsrf= max(0., qinsur - infmax)
8655 pddum = qinsur - runsrf
8656
8657 end if
8658
8659 end subroutine infil
8660
8661!== begin srt ======================================================================================
8662
8667 subroutine srt (parameters,nsoil ,zsoil ,dt ,pddum ,etrani , & !in
8668 qseva ,sh2o ,smc ,zwt ,fcr , & !in
8669 sicemax,fcrmax ,iloc ,jloc ,smcwtd , & !in
8670 rhstt ,ai ,bi ,ci ,qdrain , & !out
8671 wcnd ) !out
8672! ----------------------------------------------------------------------
8673! calculate the right hand side of the time tendency term of the soil
8674! water diffusion equation. also to compute ( prepare ) the matrix
8675! coefficients for the tri-diagonal matrix of the implicit time scheme.
8676! ----------------------------------------------------------------------
8677 implicit none
8678! ----------------------------------------------------------------------
8679!input
8680
8681 type (noahmp_parameters), intent(in) :: parameters
8682 integer, intent(in) :: iloc !grid index
8683 integer, intent(in) :: jloc !grid index
8684 integer, intent(in) :: nsoil
8685 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: zsoil
8686 real (kind=kind_phys), intent(in) :: dt
8687 real (kind=kind_phys), intent(in) :: pddum
8688 real (kind=kind_phys), intent(in) :: qseva
8689 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: etrani
8690 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: sh2o
8691 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: smc
8692 real (kind=kind_phys), intent(in) :: zwt ! water table depth [m]
8693 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: fcr
8694 real (kind=kind_phys), intent(in) :: fcrmax !maximum of fcr (-)
8695 real (kind=kind_phys), intent(in) :: sicemax!maximum soil ice content (m3/m3)
8696 real (kind=kind_phys), intent(in) :: smcwtd !soil moisture between bottom of the soil and the water table
8697
8698! output
8699
8700 real (kind=kind_phys), dimension(1:nsoil), intent(out) :: rhstt
8701 real (kind=kind_phys), dimension(1:nsoil), intent(out) :: ai
8702 real (kind=kind_phys), dimension(1:nsoil), intent(out) :: bi
8703 real (kind=kind_phys), dimension(1:nsoil), intent(out) :: ci
8704 real (kind=kind_phys), dimension(1:nsoil), intent(out) :: wcnd !hydraulic conductivity (m/s)
8705 real (kind=kind_phys), intent(out) :: qdrain !bottom drainage (m/s)
8706
8707! local
8708 integer :: k
8709 real (kind=kind_phys), dimension(1:nsoil) :: ddz
8710 real (kind=kind_phys), dimension(1:nsoil) :: denom
8711 real (kind=kind_phys), dimension(1:nsoil) :: dsmdz
8712 real (kind=kind_phys), dimension(1:nsoil) :: wflux
8713 real (kind=kind_phys), dimension(1:nsoil) :: wdf
8714 real (kind=kind_phys), dimension(1:nsoil) :: smx
8715 real (kind=kind_phys) :: temp1
8716 real (kind=kind_phys) :: smxwtd !soil moisture between bottom of the soil and water table
8717 real (kind=kind_phys) :: smxbot !soil moisture below bottom to calculate flux
8718
8719! niu and yang (2006), j. of hydrometeorology
8720! ----------------------------------------------------------------------
8721
8722 if(opt_inf == 1) then
8723 do k = 1, nsoil
8724 call wdfcnd1 (parameters,wdf(k),wcnd(k),smc(k),fcr(k),k)
8725 smx(k) = smc(k)
8726 end do
8727 if(opt_run == 5)smxwtd=smcwtd
8728 end if
8729
8730 if(opt_inf == 2) then
8731 do k = 1, nsoil
8732 call wdfcnd2 (parameters,wdf(k),wcnd(k),sh2o(k),sicemax,k)
8733 smx(k) = sh2o(k)
8734 end do
8735 if(opt_run == 5)smxwtd=smcwtd*sh2o(nsoil)/smc(nsoil) !same liquid fraction as in the bottom layer
8736 end if
8737
8738 do k = 1, nsoil
8739 if(k == 1) then
8740 denom(k) = - zsoil(k)
8741 temp1 = - zsoil(k+1)
8742 ddz(k) = 2.0 / temp1
8743 dsmdz(k) = 2.0 * (smx(k) - smx(k+1)) / temp1
8744 wflux(k) = wdf(k) * dsmdz(k) + wcnd(k) - pddum + etrani(k) + qseva
8745 else if (k < nsoil) then
8746 denom(k) = (zsoil(k-1) - zsoil(k))
8747 temp1 = (zsoil(k-1) - zsoil(k+1))
8748 ddz(k) = 2.0 / temp1
8749 dsmdz(k) = 2.0 * (smx(k) - smx(k+1)) / temp1
8750 wflux(k) = wdf(k ) * dsmdz(k ) + wcnd(k ) &
8751 - wdf(k-1) * dsmdz(k-1) - wcnd(k-1) + etrani(k)
8752 else
8753 denom(k) = (zsoil(k-1) - zsoil(k))
8754 if(opt_run == 1 .or. opt_run == 2) then
8755 qdrain = 0.
8756 end if
8757 if(opt_run == 3) then
8758 qdrain = parameters%slope*wcnd(k)
8759 end if
8760 if(opt_run == 4) then
8761 qdrain = (1.0-fcrmax)*wcnd(k)
8762 end if
8763 if(opt_run == 5) then !gmm new m-m&f water table dynamics formulation
8764 temp1 = 2.0 * denom(k)
8765 if(zwt < zsoil(nsoil)-denom(nsoil))then
8766!gmm interpolate from below, midway to the water table, to the middle of the auxiliary layer below the soil bottom
8767 smxbot = smx(k) - (smx(k)-smxwtd) * denom(k) * 2./ (denom(k) + zsoil(k) - zwt)
8768 else
8769 smxbot = smxwtd
8770 endif
8771 dsmdz(k) = 2.0 * (smx(k) - smxbot) / temp1
8772 qdrain = wdf(k ) * dsmdz(k ) + wcnd(k )
8773 end if
8774 wflux(k) = -(wdf(k-1)*dsmdz(k-1))-wcnd(k-1)+etrani(k) + qdrain
8775 end if
8776 end do
8777
8778 do k = 1, nsoil
8779 if(k == 1) then
8780 ai(k) = 0.0
8781 bi(k) = wdf(k ) * ddz(k ) / denom(k)
8782 ci(k) = - bi(k)
8783 else if (k < nsoil) then
8784 ai(k) = - wdf(k-1) * ddz(k-1) / denom(k)
8785 ci(k) = - wdf(k ) * ddz(k ) / denom(k)
8786 bi(k) = - ( ai(k) + ci(k) )
8787 else
8788 ai(k) = - wdf(k-1) * ddz(k-1) / denom(k)
8789 ci(k) = 0.0
8790 bi(k) = - ( ai(k) + ci(k) )
8791 end if
8792 rhstt(k) = wflux(k) / (-denom(k))
8793 end do
8794
8795! ----------------------------------------------------------------------
8796 end subroutine srt
8797
8798!== begin sstep ====================================================================================
8799
8802 subroutine sstep (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in
8803 sice ,iloc ,jloc ,zwt , & !in
8804 sh2o ,smc ,ai ,bi ,ci , & !inout
8805 rhstt ,smcwtd ,qdrain ,deeprech, & !inout
8806 wplus ) !out
8807
8808! ----------------------------------------------------------------------
8809! calculate/update soil moisture content values
8810! ----------------------------------------------------------------------
8811 implicit none
8812! ----------------------------------------------------------------------
8813!input
8814
8815 type (noahmp_parameters), intent(in) :: parameters
8816 integer, intent(in) :: iloc !grid index
8817 integer, intent(in) :: jloc !grid index
8818 integer, intent(in) :: nsoil !
8819 integer, intent(in) :: nsnow !
8820 real (kind=kind_phys), intent(in) :: dt
8821 real (kind=kind_phys), intent(in) :: zwt
8822 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil
8823 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: sice
8824 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso ! snow/soil layer thickness [m]
8825
8826!input and output
8827 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: sh2o
8828 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: smc
8829 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: ai
8830 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: bi
8831 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: ci
8832 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: rhstt
8833 real (kind=kind_phys) , intent(inout) :: smcwtd
8834 real (kind=kind_phys) , intent(inout) :: qdrain
8835 real (kind=kind_phys) , intent(inout) :: deeprech
8836
8837!output
8838 real (kind=kind_phys), intent(out) :: wplus !saturation excess water (m)
8839
8840!local
8841 integer :: k
8842 real (kind=kind_phys), dimension(1:nsoil) :: rhsttin
8843 real (kind=kind_phys), dimension(1:nsoil) :: ciin
8844 real (kind=kind_phys) :: stot
8845 real (kind=kind_phys) :: epore
8846 real (kind=kind_phys) :: wminus
8847! ----------------------------------------------------------------------
8848 wplus = 0.0
8849
8850 do k = 1,nsoil
8851 rhstt(k) = rhstt(k) * dt
8852 ai(k) = ai(k) * dt
8853 bi(k) = 1. + bi(k) * dt
8854 ci(k) = ci(k) * dt
8855 end do
8856
8857! copy values for input variables before calling rosr12
8858
8859 do k = 1,nsoil
8860 rhsttin(k) = rhstt(k)
8861 ciin(k) = ci(k)
8862 end do
8863
8864! call rosr12 to solve the tri-diagonal matrix
8865
8866 call rosr12 (ci,ai,bi,ciin,rhsttin,rhstt,1,nsoil,0)
8867
8868 do k = 1,nsoil
8869 sh2o(k) = sh2o(k) + ci(k)
8870 enddo
8871
8872! excessive water above saturation in a layer is moved to
8873! its unsaturated layer like in a bucket
8874
8875!gmmwith opt_run=5 there is soil moisture below nsoil, to the water table
8876 if(opt_run == 5) then
8877
8878!update smcwtd
8879
8880 if(zwt < zsoil(nsoil)-dzsnso(nsoil))then
8881!accumulate qdrain to update deep water table and soil moisture later
8882 deeprech = deeprech + dt * qdrain
8883 else
8884 smcwtd = smcwtd + dt * qdrain / dzsnso(nsoil)
8885 wplus = max((smcwtd-parameters%smcmax(nsoil)), 0.0) * dzsnso(nsoil)
8886 wminus = max((1.e-4-smcwtd), 0.0) * dzsnso(nsoil)
8887
8888 smcwtd = max( min(smcwtd,parameters%smcmax(nsoil)) , 1.e-4)
8889 sh2o(nsoil) = sh2o(nsoil) + wplus/dzsnso(nsoil)
8890
8891!reduce fluxes at the bottom boundaries accordingly
8892 qdrain = qdrain - wplus/dt
8893 deeprech = deeprech - wminus
8894 endif
8895
8896 endif
8897
8898 do k = nsoil,2,-1
8899 epore = max( 1.e-4 , ( parameters%smcmax(k) - sice(k) ) )
8900 wplus = max((sh2o(k)-epore), 0.0) * dzsnso(k)
8901 sh2o(k) = min(epore,sh2o(k))
8902 sh2o(k-1) = sh2o(k-1) + wplus/dzsnso(k-1)
8903 end do
8904
8905 epore = max( 1.e-4 , ( parameters%smcmax(1) - sice(1) ) )
8906 wplus = max((sh2o(1)-epore), 0.0) * dzsnso(1)
8907 sh2o(1) = min(epore,sh2o(1))
8908
8909 if(wplus > 0.0) then
8910 sh2o(2) = sh2o(2) + wplus/dzsnso(2)
8911 do k = 2,nsoil-1
8912 epore = max( 1.e-4 , ( parameters%smcmax(k) - sice(k) ) )
8913 wplus = max((sh2o(k)-epore), 0.0) * dzsnso(k)
8914 sh2o(k) = min(epore,sh2o(k))
8915 sh2o(k+1) = sh2o(k+1) + wplus/dzsnso(k+1)
8916 end do
8917
8918 epore = max( 1.e-4 , ( parameters%smcmax(nsoil) - sice(nsoil) ) )
8919 wplus = max((sh2o(nsoil)-epore), 0.0) * dzsnso(nsoil)
8920 sh2o(nsoil) = min(epore,sh2o(nsoil))
8921 end if
8922
8923 smc = sh2o + sice
8924
8925 end subroutine sstep
8926
8927!== begin wdfcnd1 ==================================================================================
8928
8931 subroutine wdfcnd1 (parameters,wdf,wcnd,smc,fcr,isoil)
8932! ----------------------------------------------------------------------
8933! calculate soil water diffusivity and soil hydraulic conductivity.
8934! ----------------------------------------------------------------------
8935 implicit none
8936! ----------------------------------------------------------------------
8937! input
8938 type (noahmp_parameters), intent(in) :: parameters
8939 real (kind=kind_phys),intent(in) :: smc
8940 real (kind=kind_phys),intent(in) :: fcr
8941 integer,intent(in) :: isoil
8942
8943! output
8944 real (kind=kind_phys),intent(out) :: wcnd
8945 real (kind=kind_phys),intent(out) :: wdf
8946
8947! local
8948 real (kind=kind_phys) :: expon
8949 real (kind=kind_phys) :: factr
8950 real (kind=kind_phys) :: vkwgt
8951! ----------------------------------------------------------------------
8952
8953! soil water diffusivity
8954
8955 factr = max(0.01, smc/parameters%smcmax(isoil))
8956 expon = parameters%bexp(isoil) + 2.0
8957 wdf = parameters%dwsat(isoil) * factr ** expon
8958 wdf = wdf * (1.0 - fcr)
8959
8960! hydraulic conductivity
8961
8962 expon = 2.0*parameters%bexp(isoil) + 3.0
8963 wcnd = parameters%dksat(isoil) * factr ** expon
8964 wcnd = wcnd * (1.0 - fcr)
8965
8966 end subroutine wdfcnd1
8967
8968!== begin wdfcnd2 ==================================================================================
8969
8972 subroutine wdfcnd2 (parameters,wdf,wcnd,smc,sice,isoil)
8973! ----------------------------------------------------------------------
8974! calculate soil water diffusivity and soil hydraulic conductivity.
8975! ----------------------------------------------------------------------
8976 implicit none
8977! ----------------------------------------------------------------------
8978! input
8979 type (noahmp_parameters), intent(in) :: parameters
8980 real (kind=kind_phys),intent(in) :: smc
8981 real (kind=kind_phys),intent(in) :: sice
8982 integer,intent(in) :: isoil
8983
8984! output
8985 real (kind=kind_phys),intent(out) :: wcnd
8986 real (kind=kind_phys),intent(out) :: wdf
8987
8988! local
8989 real (kind=kind_phys) :: expon
8990 real (kind=kind_phys) :: factr1,factr2
8991 real (kind=kind_phys) :: vkwgt
8992! ----------------------------------------------------------------------
8993
8994! soil water diffusivity
8995
8996 factr1 = 0.05/parameters%smcmax(isoil)
8997 factr2 = max(0.01, smc/parameters%smcmax(isoil))
8998 factr1 = min(factr1,factr2)
8999 expon = parameters%bexp(isoil) + 2.0
9000 wdf = parameters%dwsat(isoil) * factr2 ** expon
9001
9002 if (sice > 0.0) then
9003 vkwgt = 1./ (1. + (500.* sice)**3.)
9004 wdf = vkwgt * wdf + (1.-vkwgt)*parameters%dwsat(isoil)*(factr1)**expon
9005 end if
9006
9007! hydraulic conductivity
9008
9009 expon = 2.0*parameters%bexp(isoil) + 3.0
9010 wcnd = parameters%dksat(isoil) * factr2 ** expon
9011
9012 end subroutine wdfcnd2
9013
9014!== begin groundwater ==============================================================================
9015
9018 subroutine groundwater(parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in
9019 stc ,wcnd ,fcrmax ,iloc ,jloc , & !in
9020 sh2o ,zwt ,wa ,wt , & !inout
9021 qin ,qdis ) !out
9022! ----------------------------------------------------------------------
9023 implicit none
9024! ----------------------------------------------------------------------
9025! input
9026 type (noahmp_parameters), intent(in) :: parameters
9027 integer, intent(in) :: iloc !grid index
9028 integer, intent(in) :: jloc !grid index
9029 integer, intent(in) :: nsnow !maximum no. of snow layers
9030 integer, intent(in) :: nsoil !no. of soil layers
9031 real (kind=kind_phys), intent(in) :: dt !timestep [sec]
9032 real (kind=kind_phys), intent(in) :: fcrmax!maximum fcr (-)
9033 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: sice !soil ice content [m3/m3]
9034 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m]
9035 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: wcnd !hydraulic conductivity (m/s)
9036 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature (k)
9037
9038! input and output
9039 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sh2o !liquid soil water [m3/m3]
9040 real (kind=kind_phys), intent(inout) :: zwt !the depth to water table [m]
9041 real (kind=kind_phys), intent(inout) :: wa !water storage in aquifer [mm]
9042 real (kind=kind_phys), intent(inout) :: wt !water storage in aquifer
9043 !+ saturated soil [mm]
9044! output
9045 real (kind=kind_phys), intent(out) :: qin !groundwater recharge [mm/s]
9046 real (kind=kind_phys), intent(out) :: qdis !groundwater discharge [mm/s]
9047
9048! local
9049 real (kind=kind_phys) :: fff !runoff decay factor (m-1)
9050 real (kind=kind_phys) :: rsbmx !baseflow coefficient [mm/s]
9051 integer :: iz !do-loop index
9052 integer :: iwt !layer index above water table layer
9053 real (kind=kind_phys), dimension( 1:nsoil) :: dzmm !layer thickness [mm]
9054 real (kind=kind_phys), dimension( 1:nsoil) :: znode !node depth [m]
9055 real (kind=kind_phys), dimension( 1:nsoil) :: mliq !liquid water mass [kg/m2 or mm]
9056 real (kind=kind_phys), dimension( 1:nsoil) :: epore !effective porosity [-]
9057 real (kind=kind_phys), dimension( 1:nsoil) :: hk !hydraulic conductivity [mm/s]
9058 real (kind=kind_phys), dimension( 1:nsoil) :: smc !total soil water content [m3/m3]
9059 real (kind=kind_phys) :: s_node!degree of saturation of iwt layer
9060 real (kind=kind_phys) :: dzsum !cumulative depth above water table [m]
9061 real (kind=kind_phys) :: smpfz !matric potential (frozen effects) [mm]
9062 real (kind=kind_phys) :: ka !aquifer hydraulic conductivity [mm/s]
9063 real (kind=kind_phys) :: wh_zwt!water head at water table [mm]
9064 real (kind=kind_phys) :: wh !water head at layer above zwt [mm]
9065 real (kind=kind_phys) :: ws !water used to fill air pore [mm]
9066 real (kind=kind_phys) :: wtsub !sum of hk*dzmm
9067 real (kind=kind_phys) :: watmin!minimum soil vol soil moisture [m3/m3]
9068 real (kind=kind_phys) :: xs !excessive water above saturation [mm]
9069 real (kind=kind_phys), parameter :: rous = 0.2 !specific yield [-]
9070! real (kind=kind_phys), parameter :: cmic = 0.20 !microprore content (0.0-1.0)
9071 !0.0-close to free drainage
9072 real (kind=kind_phys), parameter :: cmic = 0.80 ! calibratable, c.he changed based on gy niu's update
9073! -------------------------------------------------------------
9074 qdis = 0.0
9075 qin = 0.0
9076
9077! derive layer-bottom depth in [mm]
9078!kwm: derive layer thickness in mm
9079
9080 dzmm(1) = -zsoil(1)*1.e3
9081 do iz = 2, nsoil
9082 dzmm(iz) = 1.e3 * (zsoil(iz - 1) - zsoil(iz))
9083 enddo
9084
9085! derive node (middle) depth in [m]
9086!kwm: positive number, depth below ground surface in m
9087 znode(1) = -zsoil(1) / 2.
9088 do iz = 2, nsoil
9089 znode(iz) = -zsoil(iz-1) + 0.5 * (zsoil(iz-1) - zsoil(iz))
9090 enddo
9091
9092! convert volumetric soil moisture "sh2o" to mass
9093
9094 do iz = 1, nsoil
9095 smc(iz) = sh2o(iz) + sice(iz)
9096 mliq(iz) = sh2o(iz) * dzmm(iz)
9097 epore(iz) = max(0.01,parameters%smcmax(iz) - sice(iz))
9098 hk(iz) = 1.e3*wcnd(iz)
9099 enddo
9100
9101! the layer index of the first unsaturated layer,
9102! i.e., the layer right above the water table
9103
9104 iwt = nsoil
9105 do iz = 2,nsoil
9106 if(zwt .le. -zsoil(iz) ) then
9107 iwt = iz-1
9108 exit
9109 end if
9110 enddo
9111
9112! groundwater discharge [mm/s]
9113
9114! fff = 6.0
9115! rsbmx = 5.0
9116 fff = parameters%bexp(iwt) / 3.0 ! calibratable, c.he changed based on gy niu's update
9117 rsbmx = hk(iwt) * 1.0e3 * exp(3.0) ! mm/s, calibratable, c.he changed based on gy niu's update
9118
9119! qdis = (1.0-fcrmax)*rsbmx*exp(-parameters%timean)*exp(-fff*(zwt-2.0))
9120 qdis = (1.0-fcrmax)*rsbmx*exp(-parameters%timean)*exp(-fff*zwt) ! c.he changed based on gy niu's update
9121
9122! matric potential at the layer above the water table
9123
9124 s_node = min(1.0,smc(iwt)/parameters%smcmax(iwt) )
9125 s_node = max(s_node,real(0.01,kind=8))
9126 smpfz = -parameters%psisat(iwt)*1000.*s_node**(-parameters%bexp(iwt)) ! m --> mm
9127 smpfz = max(-120000.0,cmic*smpfz)
9128
9129! recharge rate qin to groundwater
9130
9131! ka = hk(iwt)
9132! harmonic average, c.he changed based on gy niu's update
9133 ka = 2.0*(hk(iwt)*parameters%dksat(iwt)*1.0e3) / (hk(iwt)+parameters%dksat(iwt)*1.0e3)
9134
9135 wh_zwt = - zwt * 1.e3 !(mm)
9136 wh = smpfz - znode(iwt)*1.e3 !(mm)
9137 qin = - ka * (wh_zwt-wh) /((zwt-znode(iwt))*1.e3)
9138 qin = max(-10.0/dt,min(10./dt,qin))
9139
9140! water storage in the aquifer + saturated soil
9141
9142 wt = wt + (qin - qdis) * dt !(mm)
9143
9144 if(iwt.eq.nsoil) then
9145 wa = wa + (qin - qdis) * dt !(mm)
9146 wt = wa
9147 zwt = (-zsoil(nsoil) + 25.) - wa/1000./rous !(m)
9148 mliq(nsoil) = mliq(nsoil) - qin * dt ! [mm]
9149
9150 mliq(nsoil) = mliq(nsoil) + max(0.,(wa - 5000.))
9151 wa = min(wa, 5000.)
9152 else
9153
9154 if (iwt.eq.nsoil-1) then
9155 zwt = -zsoil(nsoil) &
9156 - (wt-rous*1000*25.) / (epore(nsoil))/1000.
9157 else
9158 ws = 0. ! water used to fill soil air pores
9159 do iz = iwt+2,nsoil
9160 ws = ws + epore(iz) * dzmm(iz)
9161 enddo
9162 zwt = -zsoil(iwt+1) &
9163 - (wt-rous*1000.*25.-ws) /(epore(iwt+1))/1000.
9164 endif
9165
9166 wtsub = 0.
9167 do iz = 1, nsoil
9168 wtsub = wtsub + hk(iz)*dzmm(iz)
9169 end do
9170
9171 do iz = 1, nsoil ! removing subsurface runoff
9172 mliq(iz) = mliq(iz) - qdis*dt*hk(iz)*dzmm(iz)/wtsub
9173 end do
9174 end if
9175
9176 zwt = max(1.5,zwt)
9177
9178!
9179! limit mliq to be greater than or equal to watmin.
9180! get water needed to bring mliq equal watmin from lower layer.
9181!
9182 watmin = 0.01
9183 do iz = 1, nsoil-1
9184 if (mliq(iz) .lt. 0.) then
9185 xs = watmin-mliq(iz)
9186 else
9187 xs = 0.
9188 end if
9189 mliq(iz ) = mliq(iz ) + xs
9190 mliq(iz+1) = mliq(iz+1) - xs
9191 end do
9192
9193 iz = nsoil
9194 if (mliq(iz) .lt. watmin) then
9195 xs = watmin-mliq(iz)
9196 else
9197 xs = 0.
9198 end if
9199 mliq(iz) = mliq(iz) + xs
9200 wa = wa - xs
9201 wt = wt - xs
9202
9203 do iz = 1, nsoil
9204 sh2o(iz) = mliq(iz) / dzmm(iz)
9205 end do
9206
9207 end subroutine groundwater
9208
9209!== begin shallowwatertable ========================================================================
9210
9214 subroutine shallowwatertable (parameters,nsnow ,nsoil ,zsoil, dt , & !in
9215 dzsnso ,smceq ,iloc ,jloc , & !in
9216 smc ,wtd ,smcwtd ,rech, qdrain ) !inout
9217! ----------------------------------------------------------------------
9218!diagnoses water table depth and computes recharge when the water table is within the resolved soil layers,
9219!according to the miguez-macho&fan scheme
9220! ----------------------------------------------------------------------
9221 implicit none
9222! ----------------------------------------------------------------------
9223! input
9224 type (noahmp_parameters), intent(in) :: parameters
9225 integer, intent(in) :: nsnow !maximum no. of snow layers
9226 integer, intent(in) :: nsoil !no. of soil layers
9227 integer, intent(in) :: iloc,jloc
9228 real (kind=kind_phys), intent(in) :: dt
9229 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m]
9230 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso ! snow/soil layer thickness [m]
9231 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smceq !equilibrium soil water content [m3/m3]
9232
9233! input and output
9234 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: smc !total soil water content [m3/m3]
9235 real (kind=kind_phys), intent(inout) :: wtd !the depth to water table [m]
9236 real (kind=kind_phys), intent(inout) :: smcwtd !soil moisture between bottom of the soil and the water table [m3/m3]
9237 real (kind=kind_phys), intent(out) :: rech ! groundwater recharge (net vertical flux across the water table), positive up
9238 real (kind=kind_phys), intent(inout) :: qdrain
9239
9240! local
9241 integer :: iz !do-loop index
9242 integer :: iwtd !layer index above water table layer
9243 integer :: kwtd !layer index where the water table layer is
9244 real (kind=kind_phys) :: wtdold
9245 real (kind=kind_phys) :: dzup
9246 real (kind=kind_phys) :: smceqdeep
9247 real (kind=kind_phys), dimension( 0:nsoil) :: zsoil0
9248! -------------------------------------------------------------
9249
9250
9251zsoil0(1:nsoil) = zsoil(1:nsoil)
9252zsoil0(0) = 0.
9253
9254!find the layer where the water table is
9255 do iz=nsoil,1,-1
9256 if(wtd + 1.e-6 < zsoil0(iz)) exit
9257 enddo
9258 iwtd=iz
9259
9260
9261 kwtd=iwtd+1 !layer where the water table is
9262 if(kwtd.le.nsoil)then !wtd in the resolved layers
9263 wtdold=wtd
9264 if(smc(kwtd).gt.smceq(kwtd))then
9265
9266 if(smc(kwtd).eq.parameters%smcmax(kwtd))then !wtd went to the layer above
9267 wtd=zsoil0(iwtd)
9268 rech=-(wtdold-wtd) * (parameters%smcmax(kwtd)-smceq(kwtd))
9269 iwtd=iwtd-1
9270 kwtd=kwtd-1
9271 if(kwtd.ge.1)then
9272 if(smc(kwtd).gt.smceq(kwtd))then
9273 wtdold=wtd
9274 wtd = min( ( smc(kwtd)*dzsnso(kwtd) &
9275 - smceq(kwtd)*zsoil0(iwtd) + parameters%smcmax(kwtd)*zsoil0(kwtd) ) / &
9276 ( parameters%smcmax(kwtd)-smceq(kwtd) ), zsoil0(iwtd))
9277 rech=rech-(wtdold-wtd) * (parameters%smcmax(kwtd)-smceq(kwtd))
9278 endif
9279 endif
9280 else !wtd stays in the layer
9281 wtd = min( ( smc(kwtd)*dzsnso(kwtd) &
9282 - smceq(kwtd)*zsoil0(iwtd) + parameters%smcmax(kwtd)*zsoil0(kwtd) ) / &
9283 ( parameters%smcmax(kwtd)-smceq(kwtd) ), zsoil0(iwtd))
9284 rech=-(wtdold-wtd) * (parameters%smcmax(kwtd)-smceq(kwtd))
9285 endif
9286
9287 else !wtd has gone down to the layer below
9288 wtd=zsoil0(kwtd)
9289 rech=-(wtdold-wtd) * (parameters%smcmax(kwtd)-smceq(kwtd))
9290 kwtd=kwtd+1
9291 iwtd=iwtd+1
9292!wtd crossed to the layer below. now adjust it there
9293 if(kwtd.le.nsoil)then
9294 wtdold=wtd
9295 if(smc(kwtd).gt.smceq(kwtd))then
9296 wtd = min( ( smc(kwtd)*dzsnso(kwtd) &
9297 - smceq(kwtd)*zsoil0(iwtd) + parameters%smcmax(kwtd)*zsoil0(kwtd) ) / &
9298 ( parameters%smcmax(kwtd)-smceq(kwtd) ) , zsoil0(iwtd) )
9299 else
9300 wtd=zsoil0(kwtd)
9301 endif
9302 rech = rech - (wtdold-wtd) * &
9303 (parameters%smcmax(kwtd)-smceq(kwtd))
9304
9305 else
9306 wtdold=wtd
9307!restore smoi to equilibrium value with water from the ficticious layer below
9308! smcwtd=smcwtd-(smceq(nsoil)-smc(nsoil))
9309! qdrain = qdrain - 1000 * (smceq(nsoil)-smc(nsoil)) * dzsnso(nsoil) / dt
9310! smc(nsoil)=smceq(nsoil)
9311!adjust wtd in the ficticious layer below
9312 smceqdeep = parameters%smcmax(nsoil) * ( -parameters%psisat(nsoil) / ( -parameters%psisat(nsoil) - dzsnso(nsoil) ) ) ** (1./parameters%bexp(nsoil))
9313 wtd = min( ( smcwtd*dzsnso(nsoil) &
9314 - smceqdeep*zsoil0(nsoil) + parameters%smcmax(nsoil)*(zsoil0(nsoil)-dzsnso(nsoil)) ) / &
9315 ( parameters%smcmax(nsoil)-smceqdeep ) , zsoil0(nsoil) )
9316 rech = rech - (wtdold-wtd) * &
9317 (parameters%smcmax(nsoil)-smceqdeep)
9318 endif
9319
9320 endif
9321 elseif(wtd.ge.zsoil0(nsoil)-dzsnso(nsoil))then
9322!if wtd was already below the bottom of the resolved soil crust
9323 wtdold=wtd
9324 smceqdeep = parameters%smcmax(nsoil) * ( -parameters%psisat(nsoil) / ( -parameters%psisat(nsoil) - dzsnso(nsoil) ) ) ** (1./parameters%bexp(nsoil))
9325 if(smcwtd.gt.smceqdeep)then
9326 wtd = min( ( smcwtd*dzsnso(nsoil) &
9327 - smceqdeep*zsoil0(nsoil) + parameters%smcmax(nsoil)*(zsoil0(nsoil)-dzsnso(nsoil)) ) / &
9328 ( parameters%smcmax(nsoil)-smceqdeep ) , zsoil0(nsoil) )
9329 rech = -(wtdold-wtd) * (parameters%smcmax(nsoil)-smceqdeep)
9330 else
9331 rech = -(wtdold-(zsoil0(nsoil)-dzsnso(nsoil))) * (parameters%smcmax(nsoil)-smceqdeep)
9332 wtdold=zsoil0(nsoil)-dzsnso(nsoil)
9333!and now even further down
9334 dzup=(smceqdeep-smcwtd)*dzsnso(nsoil)/(parameters%smcmax(nsoil)-smceqdeep)
9335 wtd=wtdold-dzup
9336 rech = rech - (parameters%smcmax(nsoil)-smceqdeep)*dzup
9337 smcwtd=smceqdeep
9338 endif
9339
9340
9341 endif
9342
9343if(iwtd.lt.nsoil .and. iwtd.gt.0) then
9344 smcwtd=parameters%smcmax(iwtd)
9345elseif(iwtd.lt.nsoil .and. iwtd.le.0) then
9346 smcwtd=parameters%smcmax(1)
9347end if
9348
9349end subroutine shallowwatertable
9350
9351! ==================================================================================================
9352! ********************* end of water subroutines ******************************************
9353! ==================================================================================================
9354
9355!== begin carbon ===================================================================================
9356
9359 subroutine carbon (parameters,nsnow ,nsoil ,vegtyp ,dt ,zsoil , & !in
9360 dzsnso ,stc ,smc ,tv ,tg ,psn , & !in
9361 foln ,btran ,apar ,fveg ,igs , & !in
9362 troot ,ist ,lat ,iloc ,jloc , & !in
9363 lfmass ,rtmass ,stmass ,wood ,stblcp ,fastcp , & !inout
9364 gpp ,npp ,nee ,autors ,heters ,totsc , & !out
9365 totlb ,xlai ,xsai ) !out
9366! ------------------------------------------------------------------------------------------
9367 implicit none
9368! ------------------------------------------------------------------------------------------
9369! inputs (carbon)
9370
9371 type (noahmp_parameters), intent(in) :: parameters
9372 integer , intent(in) :: iloc !grid index
9373 integer , intent(in) :: jloc !grid index
9374 integer , intent(in) :: vegtyp !vegetation type
9375 integer , intent(in) :: nsnow !number of snow layers
9376 integer , intent(in) :: nsoil !number of soil layers
9377 real (kind=kind_phys) , intent(in) :: lat !latitude (radians)
9378 real (kind=kind_phys) , intent(in) :: dt !time step (s)
9379 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil !depth of layer-bottom from soil surface
9380 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m]
9381 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature [k]
9382 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smc !soil moisture (ice + liq.) [m3/m3]
9383 real (kind=kind_phys) , intent(in) :: tv !vegetation temperature (k)
9384 real (kind=kind_phys) , intent(in) :: tg !ground temperature (k)
9385 real (kind=kind_phys) , intent(in) :: foln !foliage nitrogen (%)
9386 real (kind=kind_phys) , intent(in) :: btran !soil water transpiration factor (0 to 1)
9387 real (kind=kind_phys) , intent(in) :: psn !total leaf photosyn (umolco2/m2/s) [+]
9388 real (kind=kind_phys) , intent(in) :: apar !par by canopy (w/m2)
9389 real (kind=kind_phys) , intent(in) :: igs !growing season index (0=off, 1=on)
9390 real (kind=kind_phys) , intent(in) :: fveg !vegetation greenness fraction
9391 real (kind=kind_phys) , intent(in) :: troot !root-zone averaged temperature (k)
9392 integer , intent(in) :: ist !surface type 1->soil; 2->lake
9393
9394! input & output (carbon)
9395
9396 real (kind=kind_phys) , intent(inout) :: lfmass !leaf mass [g/m2]
9397 real (kind=kind_phys) , intent(inout) :: rtmass !mass of fine roots [g/m2]
9398 real (kind=kind_phys) , intent(inout) :: stmass !stem mass [g/m2]
9399 real (kind=kind_phys) , intent(inout) :: wood !mass of wood (incl. woody roots) [g/m2]
9400 real (kind=kind_phys) , intent(inout) :: stblcp !stable carbon in deep soil [g/m2]
9401 real (kind=kind_phys) , intent(inout) :: fastcp !short-lived carbon in shallow soil [g/m2]
9402
9403! outputs: (carbon)
9404
9405 real (kind=kind_phys) , intent(out) :: gpp !net instantaneous assimilation [g/m2/s c]
9406 real (kind=kind_phys) , intent(out) :: npp !net primary productivity [g/m2/s c]
9407 real (kind=kind_phys) , intent(out) :: nee !net ecosystem exchange [g/m2/s co2]
9408 real (kind=kind_phys) , intent(out) :: autors !net ecosystem respiration [g/m2/s c]
9409 real (kind=kind_phys) , intent(out) :: heters !organic respiration [g/m2/s c]
9410 real (kind=kind_phys) , intent(out) :: totsc !total soil carbon [g/m2 c]
9411 real (kind=kind_phys) , intent(out) :: totlb !total living carbon ([g/m2 c]
9412 real (kind=kind_phys) , intent(out) :: xlai !leaf area index [-]
9413 real (kind=kind_phys) , intent(out) :: xsai !stem area index [-]
9414! real (kind=kind_phys) , intent(out) :: vocflx(5) ! voc fluxes [ug c m-2 h-1]
9415
9416! local variables
9417
9418 integer :: j !do-loop index
9419 real (kind=kind_phys) :: wroot !root zone soil water [-]
9420 real (kind=kind_phys) :: wstres !water stress coeficient [-] (1. for wilting )
9421 real (kind=kind_phys) :: lapm !leaf area per unit mass [m2/g]
9422! ------------------------------------------------------------------------------------------
9423
9424 if ( ( vegtyp == parameters%iswater ) .or. ( vegtyp == parameters%isbarren ) .or. &
9425 ( vegtyp == parameters%isice ) .or. (parameters%urban_flag) ) then
9426 xlai = 0.
9427 xsai = 0.
9428 gpp = 0.
9429 npp = 0.
9430 nee = 0.
9431 autors = 0.
9432 heters = 0.
9433 totsc = 0.
9434 totlb = 0.
9435 lfmass = 0.
9436 rtmass = 0.
9437 stmass = 0.
9438 wood = 0.
9439 stblcp = 0.
9440 fastcp = 0.
9441
9442 return
9443 end if
9444
9445 lapm = parameters%sla / 1000. ! m2/kg -> m2/g
9446
9447! water stress
9448
9449 wstres = 1.- btran
9450
9451 wroot = 0.
9452 do j=1,parameters%nroot
9453 wroot = wroot + smc(j)/parameters%smcmax(j) * dzsnso(j) / (-zsoil(parameters%nroot))
9454 enddo
9455
9456 call co2flux (parameters,nsnow ,nsoil ,vegtyp ,igs ,dt , & !in
9457 dzsnso ,stc ,psn ,troot ,tv , & !in
9458 wroot ,wstres ,foln ,lapm , & !in
9459 lat ,iloc ,jloc ,fveg , & !in
9460 xlai ,xsai ,lfmass ,rtmass ,stmass , & !inout
9461 fastcp ,stblcp ,wood , & !inout
9462 gpp ,npp ,nee ,autors ,heters , & !out
9463 totsc ,totlb ) !out
9464
9465! call bvoc (parameters,vocflx, vegtyp, vegfac, apar, tv)
9466! call ch4
9467
9468 end subroutine carbon
9469
9470!== begin co2flux ==================================================================================
9471
9475 subroutine co2flux (parameters,nsnow ,nsoil ,vegtyp ,igs ,dt , & !in
9476 dzsnso ,stc ,psn ,troot ,tv , & !in
9477 wroot ,wstres ,foln ,lapm , & !in
9478 lat ,iloc ,jloc ,fveg , & !in
9479 xlai ,xsai ,lfmass ,rtmass ,stmass , & !inout
9480 fastcp ,stblcp ,wood , & !inout
9481 gpp ,npp ,nee ,autors ,heters , & !out
9482 totsc ,totlb ) !out
9483! -----------------------------------------------------------------------------------------
9484! the original code is from re dickinson et al.(1998), modifed by guo-yue niu, 2004
9485! -----------------------------------------------------------------------------------------
9486 implicit none
9487! -----------------------------------------------------------------------------------------
9488
9489! input
9490
9491 type (noahmp_parameters), intent(in) :: parameters
9492 integer , intent(in) :: iloc !grid index
9493 integer , intent(in) :: jloc !grid index
9494 integer , intent(in) :: vegtyp !vegetation physiology type
9495 integer , intent(in) :: nsnow !number of snow layers
9496 integer , intent(in) :: nsoil !number of soil layers
9497 real (kind=kind_phys) , intent(in) :: dt !time step (s)
9498 real (kind=kind_phys) , intent(in) :: lat !latitude (radians)
9499 real (kind=kind_phys) , intent(in) :: igs !growing season index (0=off, 1=on)
9500 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m]
9501 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature [k]
9502 real (kind=kind_phys) , intent(in) :: psn !total leaf photosynthesis (umolco2/m2/s)
9503 real (kind=kind_phys) , intent(in) :: troot !root-zone averaged temperature (k)
9504 real (kind=kind_phys) , intent(in) :: tv !leaf temperature (k)
9505 real (kind=kind_phys) , intent(in) :: wroot !root zone soil water
9506 real (kind=kind_phys) , intent(in) :: wstres !soil water stress
9507 real (kind=kind_phys) , intent(in) :: foln !foliage nitrogen (%)
9508 real (kind=kind_phys) , intent(in) :: lapm !leaf area per unit mass [m2/g]
9509 real (kind=kind_phys) , intent(in) :: fveg !vegetation greenness fraction
9510
9511! input and output
9512
9513 real (kind=kind_phys) , intent(inout) :: xlai !leaf area index from leaf carbon [-]
9514 real (kind=kind_phys) , intent(inout) :: xsai !stem area index from leaf carbon [-]
9515 real (kind=kind_phys) , intent(inout) :: lfmass !leaf mass [g/m2]
9516 real (kind=kind_phys) , intent(inout) :: rtmass !mass of fine roots [g/m2]
9517 real (kind=kind_phys) , intent(inout) :: stmass !stem mass [g/m2]
9518 real (kind=kind_phys) , intent(inout) :: fastcp !short lived carbon [g/m2]
9519 real (kind=kind_phys) , intent(inout) :: stblcp !stable carbon pool [g/m2]
9520 real (kind=kind_phys) , intent(inout) :: wood !mass of wood (incl. woody roots) [g/m2]
9521
9522! output
9523
9524 real (kind=kind_phys) , intent(out) :: gpp !net instantaneous assimilation [g/m2/s]
9525 real (kind=kind_phys) , intent(out) :: npp !net primary productivity [g/m2]
9526 real (kind=kind_phys) , intent(out) :: nee !net ecosystem exchange (autors+heters-gpp)
9527 real (kind=kind_phys) , intent(out) :: autors !net ecosystem resp. (maintance and growth)
9528 real (kind=kind_phys) , intent(out) :: heters !organic respiration
9529 real (kind=kind_phys) , intent(out) :: totsc !total soil carbon (g/m2)
9530 real (kind=kind_phys) , intent(out) :: totlb !total living carbon (g/m2)
9531
9532! local
9533
9534 real (kind=kind_phys) :: cflux !carbon flux to atmosphere [g/m2/s]
9535 real (kind=kind_phys) :: lfmsmn !minimum leaf mass [g/m2]
9536 real (kind=kind_phys) :: rswood !wood respiration [g/m2]
9537 real (kind=kind_phys) :: rsleaf !leaf maintenance respiration per timestep [g/m2]
9538 real (kind=kind_phys) :: rsroot !fine root respiration per time step [g/m2]
9539 real (kind=kind_phys) :: nppl !leaf net primary productivity [g/m2/s]
9540 real (kind=kind_phys) :: nppr !root net primary productivity [g/m2/s]
9541 real (kind=kind_phys) :: nppw !wood net primary productivity [g/m2/s]
9542 real (kind=kind_phys) :: npps !wood net primary productivity [g/m2/s]
9543 real (kind=kind_phys) :: dielf !death of leaf mass per time step [g/m2]
9544
9545 real (kind=kind_phys) :: addnpplf !leaf assimil after resp. losses removed [g/m2]
9546 real (kind=kind_phys) :: addnppst !stem assimil after resp. losses removed [g/m2]
9547 real (kind=kind_phys) :: carbfx !carbon assimilated per model step [g/m2]
9548 real (kind=kind_phys) :: grleaf !growth respiration rate for leaf [g/m2/s]
9549 real (kind=kind_phys) :: grroot !growth respiration rate for root [g/m2/s]
9550 real (kind=kind_phys) :: grwood !growth respiration rate for wood [g/m2/s]
9551 real (kind=kind_phys) :: grstem !growth respiration rate for stem [g/m2/s]
9552 real (kind=kind_phys) :: leafpt !fraction of carbon allocated to leaves [-]
9553 real (kind=kind_phys) :: lfdel !maximum leaf mass available to change [g/m2/s]
9554 real (kind=kind_phys) :: lftovr !stem turnover per time step [g/m2]
9555 real (kind=kind_phys) :: sttovr !stem turnover per time step [g/m2]
9556 real (kind=kind_phys) :: wdtovr !wood turnover per time step [g/m2]
9557 real (kind=kind_phys) :: rssoil !soil respiration per time step [g/m2]
9558 real (kind=kind_phys) :: rttovr !root carbon loss per time step by turnover [g/m2]
9559 real (kind=kind_phys) :: stablc !decay rate of fast carbon to slow carbon [g/m2/s]
9560 real (kind=kind_phys) :: woodf !calculated wood to root ratio [-]
9561 real (kind=kind_phys) :: nonlef !fraction of carbon to root and wood [-]
9562 real (kind=kind_phys) :: rootpt !fraction of carbon flux to roots [-]
9563 real (kind=kind_phys) :: woodpt !fraction of carbon flux to wood [-]
9564 real (kind=kind_phys) :: stempt !fraction of carbon flux to stem [-]
9565 real (kind=kind_phys) :: resp !leaf respiration [umol/m2/s]
9566 real (kind=kind_phys) :: rsstem !stem respiration [g/m2/s]
9567
9568 real (kind=kind_phys) :: fsw !soil water factor for microbial respiration
9569 real (kind=kind_phys) :: fst !soil temperature factor for microbial respiration
9570 real (kind=kind_phys) :: fnf !foliage nitrogen adjustemt to respiration (<= 1)
9571 real (kind=kind_phys) :: tf !temperature factor
9572 real (kind=kind_phys) :: rf !respiration reduction factor (<= 1)
9573 real (kind=kind_phys) :: stdel
9574 real (kind=kind_phys) :: stmsmn
9575 real (kind=kind_phys) :: sapm !stem area per unit mass (m2/g)
9576 real (kind=kind_phys) :: diest
9577! -------------------------- constants -------------------------------
9578 real (kind=kind_phys) :: bf !parameter for present wood allocation [-]
9579 real (kind=kind_phys) :: rswoodc !wood respiration coeficient [1/s]
9580 real (kind=kind_phys) :: stovrc !stem turnover coefficient [1/s]
9581 real (kind=kind_phys) :: rsdryc !degree of drying that reduces soil respiration [-]
9582 real (kind=kind_phys) :: rtovrc !root turnover coefficient [1/s]
9583 real (kind=kind_phys) :: wstrc !water stress coeficient [-]
9584 real (kind=kind_phys) :: laimin !minimum leaf area index [m2/m2]
9585 real (kind=kind_phys) :: xsamin !minimum leaf area index [m2/m2]
9586 real (kind=kind_phys) :: sc
9587 real (kind=kind_phys) :: sd
9588 real (kind=kind_phys) :: vegfrac
9589
9590! respiration as a function of temperature
9591
9592 real (kind=kind_phys) :: r,x
9593 r(x) = exp(0.08*(x-298.16))
9594! ---------------------------------------------------------------------------------
9595
9596! constants
9597 rtovrc = 2.0e-8 !original was 2.0e-8
9598 rsdryc = 40.0 !original was 40.0
9599 rswoodc = 3.0e-10 !
9600 bf = 0.90 !original was 0.90 ! carbon to roots
9601 wstrc = 100.0
9602 laimin = 0.05
9603 xsamin = 0.05 ! mb: change to prevent vegetation from not growing back in spring
9604
9605 sapm = 3.*0.001 ! m2/kg -->m2/g
9606 lfmsmn = laimin/lapm
9607 stmsmn = xsamin/sapm
9608! ---------------------------------------------------------------------------------
9609
9610! respiration
9611
9612 if(igs .eq. 0.) then
9613 rf = 0.5
9614 else
9615 rf = 1.0
9616 endif
9617
9618 fnf = min( foln/max(1.e-06,parameters%folnmx), 1.0 )
9619 tf = parameters%arm**( (tv-298.16)/10. )
9620 resp = parameters%rmf25 * tf * fnf * xlai * rf * (1.-wstres) ! umol/m2/s
9621 rsleaf = min((lfmass-lfmsmn)/dt,resp*12.e-6) ! g/m2/s
9622
9623 rsroot = parameters%rmr25*(rtmass*1e-3)*tf *rf* 12.e-6 ! g/m2/s
9624 rsstem = parameters%rms25*((stmass-stmsmn)*1e-3)*tf *rf* 12.e-6 ! g/m2/s
9625 rswood = rswoodc * r(tv) * wood*parameters%wdpool
9626
9627! carbon assimilation
9628! 1 mole -> 12 g carbon or 44 g co2; 1 umol -> 12.e-6 g carbon;
9629
9630 carbfx = psn * 12.e-6 ! umol co2 /m2/ s -> g/m2/s carbon
9631
9632! fraction of carbon into leaf versus nonleaf
9633
9634 leafpt = exp(0.01*(1.-exp(0.75*xlai))*xlai)
9635 if(vegtyp == parameters%eblforest) leafpt = exp(0.01*(1.-exp(0.50*xlai))*xlai)
9636
9637 nonlef = 1.0 - leafpt
9638 stempt = xlai/10.0*leafpt
9639 leafpt = leafpt - stempt
9640
9641! fraction of carbon into wood versus root
9642
9643 if(wood > 1.e-6) then
9644 woodf = (1.-exp(-bf*(parameters%wrrat*rtmass/wood))/bf)*parameters%wdpool
9645 else
9646 woodf = parameters%wdpool
9647 endif
9648
9649 rootpt = nonlef*(1.-woodf)
9650 woodpt = nonlef*woodf
9651
9652! leaf and root turnover per time step
9653
9654 lftovr = parameters%ltovrc*5.e-7*lfmass
9655 sttovr = parameters%ltovrc*5.e-7*stmass
9656 rttovr = rtovrc*rtmass
9657 wdtovr = 9.5e-10*wood
9658
9659! seasonal leaf die rate dependent on temp and water stress
9660! water stress is set to 1 at permanent wilting point
9661
9662 sc = exp(-0.3*max(0.,tv-parameters%tdlef)) * (lfmass/120.)
9663 sd = exp((wstres-1.)*wstrc)
9664 dielf = lfmass*1.e-6*(parameters%dilefw * sd + parameters%dilefc*sc)
9665 diest = stmass*1.e-6*(parameters%dilefw * sd + parameters%dilefc*sc)
9666
9667! calculate growth respiration for leaf, rtmass and wood
9668
9669 grleaf = max(0.0,parameters%fragr*(leafpt*carbfx - rsleaf))
9670 grstem = max(0.0,parameters%fragr*(stempt*carbfx - rsstem))
9671 grroot = max(0.0,parameters%fragr*(rootpt*carbfx - rsroot))
9672 grwood = max(0.0,parameters%fragr*(woodpt*carbfx - rswood))
9673
9674! impose lower t limit for photosynthesis
9675
9676 addnpplf = max(0.,leafpt*carbfx - grleaf-rsleaf)
9677 addnppst = max(0.,stempt*carbfx - grstem-rsstem)
9678! addnpplf = leafpt*carbfx - grleaf-rsleaf ! mb: test kjetil
9679! addnppst = stempt*carbfx - grstem-rsstem ! mb: test kjetil
9680 if(tv.lt.parameters%tmin) addnpplf =0.
9681 if(tv.lt.parameters%tmin) addnppst =0.
9682
9683! update leaf, root, and wood carbon
9684! avoid reducing leaf mass below its minimum value but conserve mass
9685
9686 lfdel = (lfmass - lfmsmn)/dt
9687 stdel = (stmass - stmsmn)/dt
9688 dielf = min(dielf,lfdel+addnpplf-lftovr)
9689 diest = min(diest,stdel+addnppst-sttovr)
9690
9691! net primary productivities
9692
9693 nppl = max(addnpplf,-lfdel)
9694 npps = max(addnppst,-stdel)
9695 nppr = rootpt*carbfx - rsroot - grroot
9696 nppw = woodpt*carbfx - rswood - grwood
9697
9698! masses of plant components
9699
9700 lfmass = lfmass + (nppl-lftovr-dielf)*dt
9701 stmass = stmass + (npps-sttovr-diest)*dt ! g/m2
9702 rtmass = rtmass + (nppr-rttovr) *dt
9703
9704 if(rtmass.lt.0.0) then
9705 rttovr = nppr
9706 rtmass = 0.0
9707 endif
9708 wood = (wood+(nppw-wdtovr)*dt)*parameters%wdpool
9709
9710! soil carbon budgets
9711
9712 fastcp = fastcp + (rttovr+lftovr+sttovr+wdtovr+dielf+diest)*dt ! mb: add diest v3.7
9713
9714 fst = 2.0**( (stc(1)-283.16)/10. )
9715 fsw = wroot / (0.20+wroot) * 0.23 / (0.23+wroot)
9716 rssoil = fsw * fst * parameters%mrp* max(0.,fastcp*1.e-3)*12.e-6
9717
9718 stablc = 0.1*rssoil
9719 fastcp = fastcp - (rssoil + stablc)*dt
9720 stblcp = stblcp + stablc*dt
9721
9722! total carbon flux
9723
9724 cflux = - carbfx + rsleaf + rsroot + rswood + rsstem & ! mb: add rsstem,grstem,0.9*rssoil v3.7
9725 + 0.9*rssoil + grleaf + grroot + grwood + grstem ! g/m2/s
9726
9727! for outputs
9728
9729 gpp = carbfx !g/m2/s c
9730 npp = nppl + nppw + nppr +npps !g/m2/s c
9731 autors = rsroot + rswood + rsleaf + rsstem + & !g/m2/s c mb: add rsstem, grstem v3.7
9732 grleaf + grroot + grwood + grstem !g/m2/s c mb: add 0.9* v3.7
9733 heters = 0.9*rssoil !g/m2/s c
9734 nee = (autors + heters - gpp)*44./12. !g/m2/s co2
9735 totsc = fastcp + stblcp !g/m2 c
9736 totlb = lfmass + rtmass +stmass + wood !g/m2 c mb: add stmass v3.7
9737
9738! leaf area index and stem area index
9739
9740 xlai = max(lfmass*lapm,laimin)
9741 xsai = max(stmass*sapm,xsamin)
9742
9743 end subroutine co2flux
9744
9745!== begin carbon_crop ==============================================================================
9749 subroutine carbon_crop (parameters,nsnow ,nsoil ,vegtyp ,dt ,zsoil ,julian , & !in
9750 dzsnso ,stc ,smc ,tv ,psn ,foln ,btran , & !in
9751 soldn ,t2m , & !in
9752 lfmass ,rtmass ,stmass ,wood ,stblcp ,fastcp ,grain , & !inout
9753 xlai ,xsai ,gdd , & !inout
9754 gpp ,npp ,nee ,autors ,heters ,totsc ,totlb, pgs ) !out
9755! ------------------------------------------------------------------------------------------
9756! initial crop version created by xing liu
9757! initial crop version added by barlage v3.8
9758
9759! ------------------------------------------------------------------------------------------
9760 implicit none
9761! ------------------------------------------------------------------------------------------
9762! inputs (carbon)
9763
9764 type (noahmp_parameters), intent(in) :: parameters
9765 integer , intent(in) :: nsnow !number of snow layers
9766 integer , intent(in) :: nsoil !number of soil layers
9767 integer , intent(in) :: vegtyp !vegetation type
9768 real (kind=kind_phys) , intent(in) :: dt !time step (s)
9769 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil !depth of layer-bottomfrom soil surface
9770 real (kind=kind_phys) , intent(in) :: julian !julian day of year(fractional) ( 0 <= julian < yearlen )
9771 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layerthickness [m]
9772 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature[k]
9773 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smc !soil moisture (ice +liq.) [m3/m3]
9774 real (kind=kind_phys) , intent(in) :: tv !vegetation temperature(k)
9775 real (kind=kind_phys) , intent(in) :: psn !total leaf photosyn(umolco2/m2/s) [+]
9776 real (kind=kind_phys) , intent(in) :: foln !foliage nitrogen (%)
9777 real (kind=kind_phys) , intent(in) :: btran !soil watertranspiration factor (0 to 1)
9778 real (kind=kind_phys) , intent(in) :: soldn !downward solar radiation
9779 real (kind=kind_phys) , intent(in) :: t2m !air temperature
9780
9781! input & output (carbon)
9782
9783 real (kind=kind_phys) , intent(inout) :: lfmass !leaf mass [g/m2]
9784 real (kind=kind_phys) , intent(inout) :: rtmass !mass of fine roots[g/m2]
9785 real (kind=kind_phys) , intent(inout) :: stmass !stem mass [g/m2]
9786 real (kind=kind_phys) , intent(inout) :: wood !mass of wood (incl.woody roots) [g/m2]
9787 real (kind=kind_phys) , intent(inout) :: stblcp !stable carbon in deepsoil [g/m2]
9788 real (kind=kind_phys) , intent(inout) :: fastcp !short-lived carbon inshallow soil [g/m2]
9789 real (kind=kind_phys) , intent(inout) :: grain !mass of grain [g/m2]
9790 real (kind=kind_phys) , intent(inout) :: xlai !leaf area index [-]
9791 real (kind=kind_phys) , intent(inout) :: xsai !stem area index [-]
9792 real (kind=kind_phys) , intent(inout) :: gdd !growing degree days
9793
9794! outout
9795 real (kind=kind_phys) , intent(out) :: gpp !net instantaneous assimilation [g/m2/s c]
9796 real (kind=kind_phys) , intent(out) :: npp !net primary productivity [g/m2/s c]
9797 real (kind=kind_phys) , intent(out) :: nee !net ecosystem exchange[g/m2/s co2]
9798 real (kind=kind_phys) , intent(out) :: autors !net ecosystem respiration [g/m2/s c]
9799 real (kind=kind_phys) , intent(out) :: heters !organic respiration[g/m2/s c]
9800 real (kind=kind_phys) , intent(out) :: totsc !total soil carbon [g/m2c]
9801 real (kind=kind_phys) , intent(out) :: totlb !total living carbon ([g/m2 c]
9802
9803! local variables
9804
9805 integer :: j !do-loop index
9806 real (kind=kind_phys) :: wroot !root zone soil water [-]
9807 real (kind=kind_phys) :: wstres !water stress coeficient [-] (1. for wilting )
9808 integer :: ipa !planting index
9809 integer :: iha !havestindex(0=on,1=off)
9810 integer, intent(out) :: pgs !plant growth stage
9811
9812 real (kind=kind_phys) :: psncrop
9813
9814! ------------------------------------------------------------------------------------------
9815 if ( ( vegtyp == parameters%iswater ) .or. ( vegtyp == parameters%isbarren ) .or. &
9816 ( vegtyp == parameters%isice ) .or. (parameters%urban_flag) ) then
9817 xlai = 0.
9818 xsai = 0.
9819 gpp = 0.
9820 npp = 0.
9821 nee = 0.
9822 autors = 0.
9823 heters = 0.
9824 totsc = 0.
9825 totlb = 0.
9826 lfmass = 0.
9827 rtmass = 0.
9828 stmass = 0.
9829 wood = 0.
9830 stblcp = 0.
9831 fastcp = 0.
9832 grain = 0.
9833 return
9834 end if
9835
9836! water stress
9837
9838
9839 wstres = 1.- btran
9840
9841 wroot = 0.
9842 do j=1,parameters%nroot
9843 wroot = wroot + smc(j)/parameters%smcmax(j) * dzsnso(j) / (-zsoil(parameters%nroot))
9844 enddo
9845
9846 call psn_crop ( parameters, & !in
9847 soldn, xlai, t2m, & !in
9848 psncrop ) !out
9849
9850 call growing_gdd (parameters, & !in
9851 t2m , dt, julian, & !in
9852 gdd , & !inout
9853 ipa , iha, pgs) !out
9854
9855 call co2flux_crop (parameters, & !in
9856 dt ,stc(1) ,psn ,tv ,wroot ,wstres ,foln , & !in
9857 ipa ,iha ,pgs , & !in xing
9858 xlai ,xsai ,lfmass ,rtmass ,stmass , & !inout
9859 fastcp ,stblcp ,wood ,grain ,gdd , & !inout
9860 gpp ,npp ,nee ,autors ,heters , & !out
9861 totsc ,totlb ) !out
9862
9863 end subroutine carbon_crop
9864
9865!== begin co2flux_crop =============================================================================
9869 subroutine co2flux_crop (parameters, & !in
9870 dt ,stc ,psn ,tv ,wroot ,wstres ,foln , & !in
9871 ipa ,iha ,pgs , & !in xing
9872 xlai ,xsai ,lfmass ,rtmass ,stmass , & !inout
9873 fastcp ,stblcp ,wood ,grain ,gdd, & !inout
9874 gpp ,npp ,nee ,autors ,heters , & !out
9875 totsc ,totlb ) !out
9876! -----------------------------------------------------------------------------------------
9877! the original code from re dickinson et al.(1998) and guo-yue niu(2004),
9878! modified by xing liu, 2014.
9879!
9880! -----------------------------------------------------------------------------------------
9881 implicit none
9882! -----------------------------------------------------------------------------------------
9883
9884! input
9885
9886 type (noahmp_parameters), intent(in) :: parameters
9887 real (kind=kind_phys) , intent(in) :: dt !time step (s)
9888 real (kind=kind_phys) , intent(in) :: stc !soil temperature[k]
9889 real (kind=kind_phys) , intent(in) :: psn !total leaf photosynthesis (umolco2/m2/s)
9890 real (kind=kind_phys) , intent(in) :: tv !leaf temperature (k)
9891 real (kind=kind_phys) , intent(in) :: wroot !root zone soil water
9892 real (kind=kind_phys) , intent(in) :: wstres !soil water stress
9893 real (kind=kind_phys) , intent(in) :: foln !foliage nitrogen (%)
9894 integer , intent(in) :: ipa
9895 integer , intent(in) :: iha
9896 integer , intent(in) :: pgs
9897
9898! input and output
9899
9900 real (kind=kind_phys) , intent(inout) :: xlai !leaf area index from leaf carbon [-]
9901 real (kind=kind_phys) , intent(inout) :: xsai !stem area index from leaf carbon [-]
9902 real (kind=kind_phys) , intent(inout) :: lfmass !leaf mass [g/m2]
9903 real (kind=kind_phys) , intent(inout) :: rtmass !mass of fine roots [g/m2]
9904 real (kind=kind_phys) , intent(inout) :: stmass !stem mass [g/m2]
9905 real (kind=kind_phys) , intent(inout) :: fastcp !short lived carbon [g/m2]
9906 real (kind=kind_phys) , intent(inout) :: stblcp !stable carbon pool [g/m2]
9907 real (kind=kind_phys) , intent(inout) :: wood !mass of wood (incl. woody roots) [g/m2]
9908 real (kind=kind_phys) , intent(inout) :: grain !mass of grain (xing) [g/m2]
9909 real (kind=kind_phys) , intent(inout) :: gdd !growing degree days (xing)
9910
9911! output
9912
9913 real (kind=kind_phys) , intent(out) :: gpp !net instantaneous assimilation [g/m2/s]
9914 real (kind=kind_phys) , intent(out) :: npp !net primary productivity [g/m2]
9915 real (kind=kind_phys) , intent(out) :: nee !net ecosystem exchange (autors+heters-gpp)
9916 real (kind=kind_phys) , intent(out) :: autors !net ecosystem resp. (maintance and growth)
9917 real (kind=kind_phys) , intent(out) :: heters !organic respiration
9918 real (kind=kind_phys) , intent(out) :: totsc !total soil carbon (g/m2)
9919 real (kind=kind_phys) , intent(out) :: totlb !total living carbon (g/m2)
9920
9921! local
9922
9923 real (kind=kind_phys) :: cflux !carbon flux to atmosphere [g/m2/s]
9924 real (kind=kind_phys) :: lfmsmn !minimum leaf mass [g/m2]
9925 real (kind=kind_phys) :: rswood !wood respiration [g/m2]
9926 real (kind=kind_phys) :: rsleaf !leaf maintenance respiration per timestep[g/m2]
9927 real (kind=kind_phys) :: rsroot !fine root respiration per time step [g/m2]
9928 real (kind=kind_phys) :: rsgrain !grain respiration [g/m2]
9929 real (kind=kind_phys) :: nppl !leaf net primary productivity [g/m2/s]
9930 real (kind=kind_phys) :: nppr !root net primary productivity [g/m2/s]
9931 real (kind=kind_phys) :: nppw !wood net primary productivity [g/m2/s]
9932 real (kind=kind_phys) :: npps !wood net primary productivity [g/m2/s]
9933 real (kind=kind_phys) :: nppg !grain net primary productivity [g/m2/s]
9934 real (kind=kind_phys) :: dielf !death of leaf mass per time step [g/m2]
9935
9936 real (kind=kind_phys) :: addnpplf !leaf assimil after resp. losses removed[g/m2]
9937 real (kind=kind_phys) :: addnppst !stem assimil after resp. losses removed[g/m2]
9938 real (kind=kind_phys) :: carbfx !carbon assimilated per model step [g/m2]
9939 real (kind=kind_phys) :: cbhydrafx!carbonhydrate assimilated per model step [g/m2]
9940 real (kind=kind_phys) :: grleaf !growth respiration rate for leaf [g/m2/s]
9941 real (kind=kind_phys) :: grroot !growth respiration rate for root [g/m2/s]
9942 real (kind=kind_phys) :: grwood !growth respiration rate for wood [g/m2/s]
9943 real (kind=kind_phys) :: grstem !growth respiration rate for stem [g/m2/s]
9944 real (kind=kind_phys) :: grgrain !growth respiration rate for stem [g/m2/s]
9945 real (kind=kind_phys) :: leafpt !fraction of carbon allocated to leaves [-]
9946 real (kind=kind_phys) :: lfdel !maximum leaf mass available to change[g/m2/s]
9947 real (kind=kind_phys) :: lftovr !stem turnover per time step [g/m2]
9948 real (kind=kind_phys) :: sttovr !stem turnover per time step [g/m2]
9949 real (kind=kind_phys) :: wdtovr !wood turnover per time step [g/m2]
9950 real (kind=kind_phys) :: grtovr !grainturnover per time step [g/m2]
9951 real (kind=kind_phys) :: rssoil !soil respiration per time step [g/m2]
9952 real (kind=kind_phys) :: rttovr !root carbon loss per time step by turnover[g/m2]
9953 real (kind=kind_phys) :: stablc !decay rate of fast carbon to slow carbon[g/m2/s]
9954 real (kind=kind_phys) :: woodf !calculated wood to root ratio [-]
9955 real (kind=kind_phys) :: nonlef !fraction of carbon to root and wood [-]
9956 real (kind=kind_phys) :: resp !leaf respiration [umol/m2/s]
9957 real (kind=kind_phys) :: rsstem !stem respiration [g/m2/s]
9958
9959 real (kind=kind_phys) :: fsw !soil water factor for microbial respiration
9960 real (kind=kind_phys) :: fst !soil temperature factor for microbialrespiration
9961 real (kind=kind_phys) :: fnf !foliage nitrogen adjustemt to respiration(<= 1)
9962 real (kind=kind_phys) :: tf !temperature factor
9963 real (kind=kind_phys) :: stdel
9964 real (kind=kind_phys) :: stmsmn
9965 real (kind=kind_phys) :: sapm !stem area per unit mass (m2/g)
9966 real (kind=kind_phys) :: diest
9967 real (kind=kind_phys) :: stconvert !stem to grain conversion [g/m2/s]
9968 real (kind=kind_phys) :: rtconvert !root to grain conversion [g/m2/s]
9969! -------------------------- constants -------------------------------
9970 real (kind=kind_phys) :: bf !parameter for present wood allocation [-]
9971 real (kind=kind_phys) :: rswoodc !wood respiration coeficient [1/s]
9972 real (kind=kind_phys) :: stovrc !stem turnover coefficient [1/s]
9973 real (kind=kind_phys) :: rsdryc !degree of drying that reduces soilrespiration [-]
9974 real (kind=kind_phys) :: rtovrc !root turnover coefficient [1/s]
9975 real (kind=kind_phys) :: wstrc !water stress coeficient [-]
9976 real (kind=kind_phys) :: laimin !minimum leaf area index [m2/m2]
9977 real (kind=kind_phys) :: xsamin !minimum leaf area index [m2/m2]
9978 real (kind=kind_phys) :: sc
9979 real (kind=kind_phys) :: sd
9980 real (kind=kind_phys) :: vegfrac
9981 real (kind=kind_phys) :: temp
9982
9983! respiration as a function of temperature
9984
9985 real (kind=kind_phys) :: r,x
9986 r(x) = exp(0.08*(x-298.16))
9987! ---------------------------------------------------------------------------------
9988
9989! constants
9990 rsdryc = 40.0 !original was 40.0
9991 rswoodc = 3.0e-10 !
9992 bf = 0.90 !original was 0.90 ! carbon to roots
9993 wstrc = 100.0
9994 laimin = 0.05
9995 xsamin = 0.05
9996
9997 sapm = 3.*0.001 ! m2/kg -->m2/g
9998 lfmsmn = laimin/0.035
9999 stmsmn = xsamin/sapm
10000! ---------------------------------------------------------------------------------
10001
10002! carbon assimilation
10003! 1 mole -> 12 g carbon or 44 g co2 or 30 g ch20
10004
10005 carbfx = psn*12.e-6!*ipa !umol co2 /m2/ s -> g/m2/s c
10006 cbhydrafx = psn*30.e-6!*ipa
10007
10008! mainteinance respiration
10009 fnf = min( foln/max(1.e-06,parameters%foln_mx), 1.0 )
10010 tf = parameters%q10mr**( (tv-298.16)/10. )
10011 resp = parameters%lfmr25 * tf * fnf * xlai * (1.-wstres) ! umol/m2/s
10012 rsleaf = min((lfmass-lfmsmn)/dt,resp*30.e-6) ! g/m2/s
10013 rsroot = parameters%rtmr25*(rtmass*1e-3)*tf * 30.e-6 ! g/m2/s
10014 rsstem = parameters%stmr25*(stmass*1e-3)*tf * 30.e-6 ! g/m2/s
10015 rsgrain = parameters%grainmr25*(grain*1e-3)*tf * 30.e-6 ! g/m2/s
10016
10017! calculate growth respiration for leaf, rtmass and grain
10018
10019 grleaf = max(0.0,parameters%fra_gr*(parameters%lfpt(pgs)*cbhydrafx - rsleaf))
10020 grstem = max(0.0,parameters%fra_gr*(parameters%stpt(pgs)*cbhydrafx - rsstem))
10021 grroot = max(0.0,parameters%fra_gr*(parameters%rtpt(pgs)*cbhydrafx - rsroot))
10022 grgrain = max(0.0,parameters%fra_gr*(parameters%grainpt(pgs)*cbhydrafx - rsgrain))
10023
10024! leaf turnover, stem turnover, root turnover and leaf death caused by soil
10025! water and soil temperature stress
10026
10027 lftovr = parameters%lf_ovrc(pgs)*1.e-6*lfmass
10028 rttovr = parameters%rt_ovrc(pgs)*1.e-6*rtmass
10029 sttovr = parameters%st_ovrc(pgs)*1.e-6*stmass
10030 sc = exp(-0.3*max(0.,tv-parameters%lefreez)) * (lfmass/120.)
10031 sd = exp((wstres-1.)*wstrc)
10032 dielf = lfmass*1.e-6*(parameters%dile_fw(pgs) * sd + parameters%dile_fc(pgs)*sc)
10033
10034! allocation of cbhydrafx to leaf, stem, root and grain at each growth stage
10035
10036
10037 addnpplf = max(0.,parameters%lfpt(pgs)*cbhydrafx - grleaf-rsleaf)
10038 addnpplf = parameters%lfpt(pgs)*cbhydrafx - grleaf-rsleaf
10039 addnppst = max(0.,parameters%stpt(pgs)*cbhydrafx - grstem-rsstem)
10040 addnppst = parameters%stpt(pgs)*cbhydrafx - grstem-rsstem
10041
10042
10043! avoid reducing leaf mass below its minimum value but conserve mass
10044
10045 lfdel = (lfmass - lfmsmn)/dt
10046 stdel = (stmass - stmsmn)/dt
10047 lftovr = min(lftovr,lfdel+addnpplf)
10048 sttovr = min(sttovr,stdel+addnppst)
10049 dielf = min(dielf,lfdel+addnpplf-lftovr)
10050
10051! net primary productivities
10052
10053 nppl = max(addnpplf,-lfdel)
10054 nppl = addnpplf
10055 npps = max(addnppst,-stdel)
10056 npps = addnppst
10057 nppr = parameters%rtpt(pgs)*cbhydrafx - rsroot - grroot
10058 nppg = parameters%grainpt(pgs)*cbhydrafx - rsgrain - grgrain
10059
10060! masses of plant components
10061
10062 lfmass = lfmass + (nppl-lftovr-dielf)*dt
10063 stmass = stmass + (npps-sttovr)*dt ! g/m2
10064 rtmass = rtmass + (nppr-rttovr)*dt
10065 grain = grain + nppg*dt
10066
10067 gpp = cbhydrafx* 0.4 !!g/m2/s c 0.4=12/30, ch20 to c
10068
10069 stconvert = 0.0
10070 rtconvert = 0.0
10071 if(pgs==6) then
10072 stconvert = stmass*(0.00005*dt/3600.0)
10073 stmass = stmass - stconvert
10074 rtconvert = rtmass*(0.0005*dt/3600.0)
10075 rtmass = rtmass - rtconvert
10076 grain = grain + stconvert + rtconvert
10077 end if
10078
10079 if(rtmass.lt.0.0) then
10080 rttovr = nppr
10081 rtmass = 0.0
10082 endif
10083
10084 if(grain.lt.0.0) then
10085 grain = 0.0
10086 endif
10087
10088 ! soil carbon budgets
10089
10090! if(pgs == 1 .or. pgs == 2 .or. pgs == 8) then
10091! fastcp=1000
10092! else
10093 fastcp = fastcp + (rttovr+lftovr+sttovr+dielf)*dt
10094! end if
10095 fst = 2.0**( (stc-283.16)/10. )
10096 fsw = wroot / (0.20+wroot) * 0.23 / (0.23+wroot)
10097 rssoil = fsw * fst * parameters%mrp* max(0.,fastcp*1.e-3)*12.e-6
10098
10099 stablc = 0.1*rssoil
10100 fastcp = fastcp - (rssoil + stablc)*dt
10101 stblcp = stblcp + stablc*dt
10102
10103! total carbon flux
10104
10105 cflux = - carbfx + rsleaf + rsroot + rsstem &
10106 + rssoil + grleaf + grroot ! g/m2/s 0.4=12/30, ch20 to c
10107
10108! for outputs
10109 !g/m2/s c
10110
10111 npp = (nppl + npps+ nppr +nppg)*0.4 !!g/m2/s c 0.4=12/30, ch20 to c
10112
10113
10114 autors = rsroot + rsgrain + rsleaf + & !g/m2/s c
10115 grleaf + grroot + grgrain !g/m2/s c
10116
10117 heters = rssoil !g/m2/s c
10118 nee = (autors + heters - gpp)*44./30. !g/m2/s co2
10119 totsc = fastcp + stblcp !g/m2 c
10120
10121 totlb = lfmass + rtmass + grain
10122
10123! leaf area index and stem area index
10124
10125 xlai = max(lfmass*parameters%bio2lai,laimin)
10126 xsai = max(stmass*sapm,xsamin)
10127
10128
10129!after harversting
10130! if(pgs == 8 ) then
10131! lfmass = 0.62
10132! stmass = 0
10133! grain = 0
10134! end if
10135
10136! if(pgs == 1 .or. pgs == 2 .or. pgs == 8) then
10137 if(pgs == 8 .and. (grain > 0. .or. lfmass > 0 .or. stmass > 0 .or. rtmass > 0)) then
10138 xlai = 0.05
10139 xsai = 0.05
10140 lfmass = lfmsmn
10141 stmass = stmsmn
10142 rtmass = 0
10143 grain = 0
10144 end if
10145
10146end subroutine co2flux_crop
10147
10148!== begin growing_gdd ==============================================================================
10151 subroutine growing_gdd (parameters, & !in
10152 t2m , dt, julian, & !in
10153 gdd , & !inout
10154 ipa, iha, pgs) !out
10155!===================================================================================================
10156
10157! input
10158
10159 type (noahmp_parameters), intent(in) :: parameters
10160 real (kind=kind_phys) , intent(in) :: t2m
10161 real (kind=kind_phys) , intent(in) :: dt
10162 real (kind=kind_phys) , intent(in) :: julian
10163
10164! input and output
10165
10166 real (kind=kind_phys) , intent(inout) :: gdd
10167
10168! output
10169
10170 integer , intent(out) :: ipa
10171 integer , intent(out) :: iha
10172 integer , intent(out) :: pgs
10173
10174!local
10175
10176 real (kind=kind_phys) :: gddday !gap bewtween gdd and gdd8
10177 real (kind=kind_phys) :: dayofs2 !days in stage2
10178 real (kind=kind_phys) :: tdiff !temperature difference for growing degree days calculation
10179 real (kind=kind_phys) :: tc
10180
10181 tc = t2m - 273.15
10182
10183!havestindex(0=on,1=off)
10184
10185 ipa = 1
10186 iha = 1
10187
10188!turn on/off the planting
10189
10190 if(julian < parameters%pltday) ipa = 0
10191
10192!turn on/off the harvesting
10193 if(julian >= parameters%hsday) iha = 0
10194
10195!calculate the growing degree days
10196
10197 if(tc < parameters%gddtbase) then
10198 tdiff = 0.0
10199 elseif(tc >= parameters%gddtcut) then
10200 tdiff = parameters%gddtcut - parameters%gddtbase
10201 else
10202 tdiff = tc - parameters%gddtbase
10203 end if
10204
10205 gdd = (gdd + tdiff * dt / 86400.0) * ipa * iha
10206
10207 gddday = gdd
10208
10209 ! decide corn growth stage, based on hybrid-maize
10210 ! pgs = 1 : before planting
10211 ! pgs = 2 : from tassel initiation to silking
10212 ! pgs = 3 : from silking to effective grain filling
10213 ! pgs = 4 : from effective grain filling to pysiological maturity
10214 ! pgs = 5 : gddm=1389
10215 ! pgs = 6 :
10216 ! pgs = 7 :
10217 ! pgs = 8 :
10218 ! gddm = 1389
10219 ! gddm = 1555
10220 ! gddsk = 0.41*gddm +145.4+150 !from hybrid-maize
10221 ! gdds1 = ((gddsk-96)/38.9-4)*21
10222 ! gdds1 = 0.77*gddsk
10223 ! gdds3 = gddsk+170
10224 ! gdds3 = 170
10225
10226 pgs = 1 ! mb: set pgs = 1 (for initialization during growing season when no gdd)
10227
10228 if(gddday > 0.0) pgs = 2
10229
10230 if(gddday >= parameters%gdds1) pgs = 3
10231
10232 if(gddday >= parameters%gdds2) pgs = 4
10233
10234 if(gddday >= parameters%gdds3) pgs = 5
10235
10236 if(gddday >= parameters%gdds4) pgs = 6
10237
10238 if(gddday >= parameters%gdds5) pgs = 7
10239
10240 if(julian >= parameters%hsday) pgs = 8
10241
10242 if(julian < parameters%pltday) pgs = 1
10243
10244end subroutine growing_gdd
10245
10246!== begin psn_crop =================================================================================
10249subroutine psn_crop ( parameters, & !in
10250 soldn, xlai,t2m, & !in
10251 psncrop ) !out
10252!===================================================================================================
10253
10254! input
10255
10256 type (noahmp_parameters), intent(in) :: parameters
10257 real (kind=kind_phys) , intent(in) :: soldn
10258 real (kind=kind_phys) , intent(in) :: xlai
10259 real (kind=kind_phys) , intent(in) :: t2m
10260 real (kind=kind_phys) , intent(out) :: psncrop
10261
10262!local
10263
10264 real (kind=kind_phys) :: par ! photosynthetically active radiation (w/m2) 1 w m-2 = 0.0864 mj m-2 day-1
10265 real (kind=kind_phys) :: amax ! maximum co2 assimulation rate g/co2/s
10266 real (kind=kind_phys) :: l1 ! three gaussian method
10267 real (kind=kind_phys) :: l2 ! three gaussian method
10268 real (kind=kind_phys) :: l3 ! three gaussian method
10269 real (kind=kind_phys) :: i1 ! three gaussian method
10270 real (kind=kind_phys) :: i2 ! three gaussian method
10271 real (kind=kind_phys) :: i3 ! three gaussian method
10272 real (kind=kind_phys) :: a1 ! three gaussian method
10273 real (kind=kind_phys) :: a2 ! three gaussian method
10274 real (kind=kind_phys) :: a3 ! three gaussian method
10275 real (kind=kind_phys) :: a ! co2 assimulation
10276 real (kind=kind_phys) :: tc
10277
10278 tc = t2m - 273.15
10279
10280 par = parameters%i2par * soldn * 0.0036 !w to mj m-2
10281
10282 if(tc < parameters%tassim0) then
10283 amax = 1e-10
10284 elseif(tc >= parameters%tassim0 .and. tc < parameters%tassim1) then
10285 amax = (tc - parameters%tassim0) * parameters%aref / (parameters%tassim1 - parameters%tassim0)
10286 elseif(tc >= parameters%tassim1 .and. tc < parameters%tassim2) then
10287 amax = parameters%aref
10288 else
10289 amax= parameters%aref - 0.2 * (t2m - parameters%tassim2)
10290 endif
10291
10292 amax = max(amax,0.01)
10293
10294 if(xlai <= 0.05) then
10295 l1 = 0.1127 * 0.05 !use initial lai(0.05), avoid error
10296 l2 = 0.5 * 0.05
10297 l3 = 0.8873 * 0.05
10298 else
10299 l1 = 0.1127 * xlai
10300 l2 = 0.5 * xlai
10301 l3 = 0.8873 * xlai
10302 end if
10303
10304 i1 = parameters%k * par * exp(-parameters%k * l1)
10305 i2 = parameters%k * par * exp(-parameters%k * l2)
10306 i3 = parameters%k * par * exp(-parameters%k * l3)
10307
10308 i1 = max(i1,1e-10)
10309 i2 = max(i2,1e-10)
10310 i3 = max(i3,1e-10)
10311
10312 a1 = amax * (1 - exp(-parameters%epsi * i1 / amax))
10313 a2 = amax * (1 - exp(-parameters%epsi * i2 / amax)) * 1.6
10314 a3 = amax * (1 - exp(-parameters%epsi * i3 / amax))
10315
10316 if (xlai <= 0.05) then
10317 a = (a1+a2+a3) / 3.6 * 0.05
10318 elseif (xlai > 0.05 .and. xlai <= 4.0) then
10319 a = (a1+a2+a3) / 3.6 * xlai
10320 else
10321 a = (a1+a2+a3) / 3.6 * 4
10322 end if
10323
10324 a = a * parameters%psnrf ! attainable
10325
10326 psncrop = 6.313 * a ! (1/44) * 1000000)/3600 = 6.313
10327
10328end subroutine psn_crop
10329
10330!== begin bvocflux =================================================================================
10331
10332! subroutine bvocflux(parameters,vocflx, vegtyp, vegfrac, apar, tv )
10333!
10334! ------------------------------------------------------------------------------------------
10335! implicit none
10336! ------------------------------------------------------------------------------------------
10337!
10338! ------------------------ code history ---------------------------
10339! source file: bvoc
10340! purpose: bvoc emissions
10341! description:
10342! volatile organic compound emission
10343! this code simulates volatile organic compound emissions
10344! following the algorithm presented in guenther, a., 1999: modeling
10345! biogenic volatile organic compound emissions to the atmosphere. in
10346! reactive hydrocarbons in the atmosphere, ch. 3
10347! this model relies on the assumption that 90% of isoprene and monoterpene
10348! emissions originate from canopy foliage:
10349! e = epsilon * gamma * density * delta
10350! the factor delta (longterm activity factor) applies to isoprene emission
10351! from deciduous plants only. we neglect this factor at the present time.
10352! this factor is discussed in guenther (1997).
10353! subroutine written to operate at the patch level.
10354! in final implementation, remember:
10355! 1. may wish to call this routine only as freq. as rad. calculations
10356! 2. may wish to place epsilon values directly in pft-physiology file
10357! ------------------------ input/output variables -----------------
10358! input
10359! integer ,intent(in) :: vegtyp !vegetation type
10360! real (kind=kind_phys) ,intent(in) :: vegfrac !green vegetation fraction [0.0-1.0]
10361! real (kind=kind_phys) ,intent(in) :: apar !photosynthesis active energy by canopy (w/m2)
10362! real (kind=kind_phys) ,intent(in) :: tv !vegetation canopy temperature (k)
10363!
10364! output
10365! real (kind=kind_phys) ,intent(out) :: vocflx(5) ! voc fluxes [ug c m-2 h-1]
10366!
10367! local variables
10368!
10369! real (kind=kind_phys), parameter :: r = 8.314 ! univ. gas constant [j k-1 mol-1]
10370! real (kind=kind_phys), parameter :: alpha = 0.0027 ! empirical coefficient
10371! real (kind=kind_phys), parameter :: cl1 = 1.066 ! empirical coefficient
10372! real (kind=kind_phys), parameter :: ct1 = 95000.0 ! empirical coefficient [j mol-1]
10373! real (kind=kind_phys), parameter :: ct2 = 230000.0 ! empirical coefficient [j mol-1]
10374! real (kind=kind_phys), parameter :: ct3 = 0.961 ! empirical coefficient
10375! real (kind=kind_phys), parameter :: tm = 314.0 ! empirical coefficient [k]
10376! real (kind=kind_phys), parameter :: tstd = 303.0 ! std temperature [k]
10377! real (kind=kind_phys), parameter :: bet = 0.09 ! beta empirical coefficient [k-1]
10378!
10379! integer ivoc ! do-loop index
10380! integer ityp ! do-loop index
10381! real (kind=kind_phys) epsilon(5)
10382! real (kind=kind_phys) gamma(5)
10383! real (kind=kind_phys) density
10384! real (kind=kind_phys) elai
10385! real (kind=kind_phys) par,cl,reciprod,ct
10386!
10387! epsilon :
10388!
10389! do ivoc = 1, 5
10390! epsilon(ivoc) = parameters%eps(vegtyp,ivoc)
10391! end do
10392!
10393! gamma : activity factor. units [dimensionless]
10394!
10395! reciprod = 1. / (r * tv * tstd)
10396! ct = exp(ct1 * (tv - tstd) * reciprod) / &
10397! (ct3 + exp(ct2 * (tv - tm) * reciprod))
10398!
10399! par = apar * 4.6 ! (multiply w/m2 by 4.6 to get umol/m2/s)
10400! cl = alpha * cl1 * par * (1. + alpha * alpha * par * par)**(-0.5)
10401!
10402! gamma(1) = cl * ct ! for isoprenes
10403!
10404! do ivoc = 2, 5
10405! gamma(ivoc) = exp(bet * (tv - tstd))
10406! end do
10407!
10408! foliage density
10409!
10410! transform vegfrac to lai
10411!
10412! elai = max(0.0,-6.5/2.5*alog((1.-vegfrac)))
10413! density = elai / (parameters%slarea(vegtyp) * 0.5)
10414!
10415! calculate the voc flux
10416!
10417! do ivoc = 1, 5
10418! vocflx(ivoc) = epsilon(ivoc) * gamma(ivoc) * density
10419! end do
10420!
10421! end subroutine bvocflux
10422! ==================================================================================================
10423! ********************************* end of carbon subroutines *****************************
10424! ==================================================================================================
10425
10426!== begin noahmp_options ===========================================================================
10427
10430 subroutine noahmp_options(idveg , iopt_crs , iopt_btr , iopt_run , iopt_sfc , iopt_frz , &
10431 iopt_inf, iopt_rad , iopt_alb , iopt_snf , iopt_tbot, iopt_stc , &
10432 iopt_rsf, iopt_soil, iopt_pedo, iopt_crop, iopt_trs , iopt_diag, &
10433 iopt_z0m )
10434
10435 implicit none
10436
10437 integer, intent(in) :: idveg
10438 integer, intent(in) :: iopt_crs
10439 integer, intent(in) :: iopt_btr
10440 integer, intent(in) :: iopt_run
10441 integer, intent(in) :: iopt_sfc
10442 integer, intent(in) :: iopt_frz
10443 integer, intent(in) :: iopt_inf
10444 integer, intent(in) :: iopt_rad
10445 integer, intent(in) :: iopt_alb
10446 integer, intent(in) :: iopt_snf
10447 integer, intent(in) :: iopt_tbot
10448
10449 integer, intent(in) :: iopt_stc
10451 integer, intent(in) :: iopt_rsf
10452 integer, intent(in) :: iopt_soil
10453 integer, intent(in) :: iopt_pedo
10454 integer, intent(in) :: iopt_crop
10455 integer, intent(in) :: iopt_trs
10456 integer, intent(in) :: iopt_diag
10457 integer, intent(in) :: iopt_z0m
10458
10459! -------------------------------------------------------------------------------------------------
10460
10461 dveg = idveg
10462
10463 opt_crs = iopt_crs
10464 opt_btr = iopt_btr
10465 opt_run = iopt_run
10466 opt_sfc = iopt_sfc
10467 opt_frz = iopt_frz
10468 opt_inf = iopt_inf
10469 opt_rad = iopt_rad
10470 opt_alb = iopt_alb
10471 opt_snf = iopt_snf
10472 opt_tbot = iopt_tbot
10473 opt_stc = iopt_stc
10474 opt_rsf = iopt_rsf
10475 opt_soil = iopt_soil
10476 opt_pedo = iopt_pedo
10477 opt_crop = iopt_crop
10478 opt_trs = iopt_trs
10479 opt_diag = iopt_diag
10480 opt_z0m = iopt_z0m
10481
10482 end subroutine noahmp_options
10483
10486 subroutine sfcdif4(iloc ,jloc ,ux ,vx ,t1d , &
10487 p1d ,psfcpa,pblhx ,dx ,znt , &
10488 ep_1, ep_2, cp, &
10489 itime ,snwh ,isice ,psi_opt, &
10490 tsk ,qx ,zlvl ,iz0tlnd,qsfc , &
10491 hfx ,qfx ,cm ,chs ,chs2 , &
10492 cqs2 , &
10493 rmolx ,ust , rbx, fmx, fhx,stressx,&
10494 fm10x, fh2x, wspdx,flhcx,flqcx)
10495
10496
10497
10498!-------------------------------------------------------------------
10499 implicit none
10500!-------------------------------------------------------------------
10501
10502! input
10503
10504 integer,intent(in ) :: iloc
10505 integer,intent(in ) :: jloc
10506 integer, intent(in) :: itime
10507
10508 integer, intent(in) :: psi_opt
10509
10510 integer, intent(in) :: isice
10511
10512 real(kind=kind_phys), intent(in ) :: pblhx
10513 real(kind=kind_phys), intent(in ) :: tsk
10514 real(kind=kind_phys), intent(in ) :: psfcpa
10515 real(kind=kind_phys), intent(in ) :: p1d
10516 real(kind=kind_phys), intent(in ) :: t1d
10517 real(kind=kind_phys), intent(in ) :: qx
10518 real(kind=kind_phys), intent(in ) :: zlvl
10519 real(kind=kind_phys), intent(in ) :: hfx
10520 real(kind=kind_phys), intent(in ) :: qfx
10521 real(kind=kind_phys), intent(in ) :: dx
10522 real(kind=kind_phys), intent(in ) :: ux
10523 real(kind=kind_phys), intent(in ) :: vx
10524 real(kind=kind_phys), intent(in ) :: znt
10525 real(kind=kind_phys), intent(in ) :: snwh
10526 real(kind=kind_phys), intent(in ) :: ep_1
10527 real(kind=kind_phys), intent(in ) :: ep_2
10528 real(kind=kind_phys), intent(in ) :: cp
10529
10530! optional vars
10531
10532 integer,optional,intent(in ) :: iz0tlnd
10533
10534 real(kind=kind_phys), intent(inout) :: qsfc
10535 real(kind=kind_phys), intent(inout) :: ust
10536 real(kind=kind_phys), intent(inout) :: chs
10537 real(kind=kind_phys), intent(inout) :: chs2
10538 real(kind=kind_phys), intent(inout) :: cqs2
10539 real(kind=kind_phys), intent(inout) :: cm
10540
10541 real(kind=kind_phys), intent(inout) :: rmolx
10542 real(kind=kind_phys), intent(inout) :: rbx
10543 real(kind=kind_phys), intent(inout) :: fmx
10544 real(kind=kind_phys), intent(inout) :: fhx
10545 real(kind=kind_phys), intent(inout) :: stressx
10546 real(kind=kind_phys), intent(inout) :: fm10x
10547 real(kind=kind_phys), intent(inout) :: fh2x
10548
10549 real(kind=kind_phys), intent(inout) :: wspdx
10550 real(kind=kind_phys), intent(inout) :: flhcx
10551 real(kind=kind_phys), intent(inout) :: flqcx
10552
10553 real(kind=kind_phys) :: zolx
10554 real(kind=kind_phys) :: molx
10555
10556! diagnostics out
10557! real, intent(out) :: u10
10558! real, intent(out) :: v10
10559! real, intent(out) :: th2
10560! real, intent(out) :: t2
10561! real, intent(out) :: q2
10562! real, intent(out) :: qsfc
10563
10564
10565! local
10566
10567 real(kind=kind_phys) :: za ! height of full-sigma level
10568 real(kind=kind_phys) :: thvx ! virtual potential temperature
10569 real(kind=kind_phys) :: zqkl ! height of upper half level
10570 real(kind=kind_phys) :: zqklp1 ! height of lower half level (surface)
10571 real(kind=kind_phys) :: thx ! potential temperature
10572 real(kind=kind_phys) :: psih ! similarity function for heat
10573 real(kind=kind_phys) :: psih2 ! similarity function for heat 2m
10574 real(kind=kind_phys) :: psih10 ! similarity function for heat 10m
10575 real(kind=kind_phys) :: psim ! similarity function for momentum
10576 real(kind=kind_phys) :: psim2 ! similarity function for momentum 2m
10577 real(kind=kind_phys) :: psim10 ! similarity function for momentum 10m
10578
10579 real(kind=kind_phys) :: gz1oz0 ! log(za/z0)
10580 real(kind=kind_phys) :: gz2oz0 ! log(z2/z0)
10581 real(kind=kind_phys) :: gz10oz0 ! log(z10/z0)
10582
10583 real(kind=kind_phys) :: rhox ! density
10584 real(kind=kind_phys) :: govrth ! g/theta for stability l
10585 real(kind=kind_phys) :: tgdsa ! tsk
10586 real(kind=kind_phys) :: tvir ! temporal variable src4 -> tvir
10587 real(kind=kind_phys) :: thgb ! potential temperature ground
10588 real(kind=kind_phys) :: psfcx ! surface pressure
10589 real(kind=kind_phys) :: cpm
10590 real(kind=kind_phys) :: qgh
10591
10592 integer :: n,i,k,kk,l,nzol,nk,nzol2,nzol10
10593
10594 real(kind=kind_phys) :: zolzt, zolz0, zolza
10595 real(kind=kind_phys) :: gz1ozt,gz2ozt,gz10ozt
10596
10597
10598 real(kind=kind_phys) :: pl,thcon,tvcon,e1
10599 real(kind=kind_phys) :: zl,tskv,dthvdz,dthvm,vconv,rzol,rzol2,rzol10,zol2,zol10
10600 real(kind=kind_phys) :: dtg,psix,dtthx,psix10,psit,psit2,psiq,psiq2,psiq10
10601 real(kind=kind_phys) :: fluxc,vsgd,z0q,visc,restar,czil,restar2
10602
10603 real(kind=kind_phys) :: dqg
10604 real(kind=kind_phys) :: tabs
10605 real(kind=kind_phys) :: qsfcmr
10606 real(kind=kind_phys) :: t1dc
10607 real(kind=kind_phys) :: zt
10608 real(kind=kind_phys) :: zq
10609 real(kind=kind_phys) :: zratio
10610 real(kind=kind_phys) :: qstar
10611 real(kind=kind_phys) :: ep2
10612 real(kind=kind_phys) :: ep_3
10613!-------------------------------------------------------------------
10614
10615 psfcx=psfcpa/1000. ! to kPa for saturation check
10616 ep2=ep_2
10617 ep_3=1.-ep_2
10618
10619 if (itime == 1) then !init SP, MR
10620 if (isice == 0) then
10621 tabs = 0.5*(tsk + t1d)
10622 if (tabs .lt. 273.15) then
10623 !saturation vapor pressure wrt ice (svp1=.6112; 10*mb)
10624 e1=svp1*exp(4648*(1./273.15 - 1./tabs) - &
10625 & 11.64*log(273.15/tabs) + 0.02265*(273.15 - tabs))
10626 else
10627 !saturation vapor pressure wrt water (bolton 1980)
10628 e1=svp1*exp(svp2*(tabs-svpt0)/(tabs-svp3))
10629 endif
10630
10631 qsfc =ep2*e1/(psfcx-ep_3*e1) !avg with the input?
10632 qsfcmr =qsfc/(1.-qsfc) !to mixing ratio
10633 endif
10634
10635 if (isice == 1) then
10636 if (tsk .lt. 273.15) then
10637 !saturation vapor pressure wrt ice (svp1=.6112; 10*mb)
10638 e1=svp1*exp(4648*(1./273.15 - 1./tsk) - &
10639 & 11.64*log(273.15/tsk) + 0.02265*(273.15 - tsk))
10640 else
10641 !saturation vapor pressure wrt water (bolton 1980)
10642 e1=svp1*exp(svp2*(tsk-svpt0)/(tsk-svp3))
10643 endif
10644
10645 qsfc=ep2*e1/(psfcx-ep_3*e1) !specific humidity
10646 qsfcmr=ep2*e1/(psfcx-e1) !mixing ratio
10647
10648 endif
10649
10650 else
10651 ! use what comes out of the lsm
10652 if (isice == 0) then
10653 tabs = 0.5*(tsk + t1d)
10654 if (tabs .lt. 273.15) then
10655 !saturation vapor pressure wrt ice (svp1=.6112; 10*mb)
10656 e1=svp1*exp(4648*(1./273.15 - 1./tabs) - &
10657 & 11.64*log(273.15/tabs) + 0.02265*(273.15 - tabs))
10658 else
10659 !saturation vapor pressure wrt water (bolton 1980)
10660 e1=svp1*exp(svp2*(tabs-svpt0)/(tabs-svp3))
10661 endif
10662
10663 qsfc =ep2*e1/(psfcx-ep_3*e1) ! avg with previous qsfc?
10664 qsfcmr=qsfc/(1.-qsfc)
10665
10666 endif
10667
10668 if (isice == 1) then
10669 if (tsk .lt. 273.15) then
10670 !saturation vapor pressure wrt ice (svp1=.6112; 10*mb)
10671 e1=svp1*exp(4648*(1./273.15 - 1./tsk) - &
10672 & 11.64*log(273.15/tsk) + 0.02265*(273.15 - tsk))
10673 else
10674 !saturation vapor pressure wrt water (bolton 1980)
10675 e1=svp1*exp(svp2*(tsk-svpt0)/(tsk-svp3))
10676 endif
10677
10678 qsfc=ep2*e1/(psfcx-ep_3*e1) !specific humidity
10679 qsfcmr=qsfc/(1.-qsfc)
10680
10681 endif
10682
10683 endif !done INIT if itime=1
10684! convert (tah or tgb = tsk) temperature to potential temperature.
10685 tgdsa = tsk
10686 thgb = tsk*(p1000mb/psfcpa)**(rair/cpair) !psfcpa is pa
10687
10688! store virtual, virtual potential and potential temperature
10689
10690 pl = p1d/1000.
10691 thx = t1d*(p1000mb*0.001/pl)**(rair/cpair)
10692 t1dc = t1d - 273.15
10693
10694 thvx = thx*(1.+ep_1*qx) !qx is SH from input
10695 tvir = t1d*(1.+ep_1*qx)
10696
10697 rhox=psfcx*1000./(rair*tvir)
10698 govrth=grav/thx
10699 za = zlvl
10700
10701 !za=0.5*dz8w
10702
10703
10704! directly from input; check units
10705
10706! qfx = qflx * rhox
10707! hfx = hflx * rhox * cp
10708
10709
10710
10711! q2sat = qgh in lsm
10712!jref: canres and esat is calculated in the loop so should that be changed??
10713! qgh=ep_2*e1/(pl-e1)
10714! cpm=cp*(1.+0.8*qx)
10715
10716
10717! qgh changed to use lowest-level air temp
10718
10719 if (t1d .lt. 273.15) then
10720 !saturation vapor pressure wrt ice
10721 e1=svp1*exp(4648.*(1./273.15 - 1./t1d) - &
10722 & 11.64*log(273.15/t1d) + 0.02265*(273.15 - t1d))
10723 else
10724 !saturation vapor pressure wrt water (bolton 1980)
10725 e1=svp1*exp(svp2*(t1d-svpt0)/(t1d-svp3))
10726 endif
10727
10728
10729 !qgh=ep2*e1/(pl-ep_3*e1) !specific humidity
10730
10731 qgh=ep2*e1/(pl-e1) !sat. mixing ratio ?
10732
10733! cpm=cp*(1.+0.84*qx) ! qx is SH
10734 cpm=cp*(1.+0.84*qx/(1.0-qx) )
10735
10736 wspdx=sqrt(ux*ux+vx*vx)
10737
10738 tskv=thgb*(1.+ep_1*qsfc) !avg with tsurf not used
10739 dthvdz=(thvx-tskv)
10740
10741 fluxc = max(hfx/rhox/cp + ep_1*tskv*qfx/rhox,0.) !hfx + qfx are fluxes units: wm^-2 and kg m^-2 s^-1
10742! vconv = vconvc*(g/tgdsa*pblh*fluxc)**.33
10743
10744 vconv = vconvc*(grav/tgdsa*min(1.5*pblhx,4000.0)*fluxc)**.33 !wstar
10745! vsgd = 0.32 * (max(dx/5000.-1.,0.))**.33
10746
10747 vsgd = min(0.32 * (max(dx/5000.-1.,0.))**.33,0.5)
10748 wspdx=sqrt(wspdx*wspdx+vconv*vconv+vsgd*vsgd)
10749 wspdx=max(wspdx,0.1) !0.1 is wmin
10750 rbx=govrth*za*dthvdz/(wspdx*wspdx) !buld rich #
10751
10752 if (itime == 1) then
10753 rbx=max(rbx,-2.0)
10754 rbx=min(rbx, 2.0)
10755 else
10756 rbx=max(rbx,-4.0)
10757 rbx=min(rbx, 4.0)
10758 endif
10759
10760
10761! visc=(1.32+0.009*(t1d-273.15))*1.e-5
10762! kinematic viscosity
10763
10764
10765 visc=1.326e-5*(1. + 6.542e-3*t1dc + 8.301e-6*t1dc*t1dc &
10766 - 4.84e-9*t1dc*t1dc*t1dc)
10767
10768!compute roughness reynolds number (restar) using default znt
10769!the GFS option has been removed
10770
10771 restar=max(ust*znt/visc,0.1)
10772
10773! get zt, zq based on the input
10774! the GFS roughness option and spp_pbl have been removed
10775
10776 if (snwh > 50. .or. isice == 1) then ! (mm) treat as snow cover - use andreas cover isice =1
10777 call andreas_2002(znt,visc,ust,zt,zq)
10778 else
10779 if ( present(iz0tlnd) ) then
10780 if ( iz0tlnd .le. 1 ) then
10781 call zilitinkevich_1995(znt,zt,zq,restar,&
10782 ust,vkc,1.0_kind_phys,iz0tlnd,0,0.0_kind_phys)
10783 elseif ( iz0tlnd .eq. 2 ) then
10784 call yang_2008(znt,zt,zq,ust,molx,&
10785 qstar,restar,visc)
10786 elseif ( iz0tlnd .eq. 3 ) then
10787 !original mynn in wrf-arw used this form:
10788 call garratt_1992(zt,zq,znt,restar,1.0_kind_phys)
10789 endif
10790
10791! the GFS option is removed along with gfs_z0_lnd
10792
10793 else
10794
10795 !default to zilitinkevich
10796 call zilitinkevich_1995(znt,zt,zq,restar,&
10797 ust,vkc,1.0_kind_phys,0,0,0.0_kind_phys)
10798 endif
10799 endif
10800
10801
10802! ---------
10803! calculate bulk richardson no. of surface layer,
10804! according to akb(1976), eq(12).
10805
10806
10807 gz1oz0= log((za+znt)/znt)
10808 gz1ozt= log((za+znt)/zt)
10809 gz2oz0= log((2.0+znt)/znt)
10810 gz2ozt= log((2.0+znt)/zt)
10811 gz10oz0=log((10.+znt)/znt)
10812! gz10ozt=log((10.+znt)/zt)
10813
10814 zratio=znt/zt !need estimate for li et al.
10815
10816
10817! vconv = 0.25*sqrt(g/tskv*pblh(i)*dthvm)
10818! if(mol.lt.0.) br=amin1(br,0.0) -> check the input mol later
10819! rmol=-govrth*dthvdz*za*vkc
10820
10821 if (rbx .gt. 0.0) then
10822
10823 !compute z/l first guess:
10824 call li_etal_2010(zolx,rbx,za/znt,zratio)
10825 !zol=za*vkc*grav*mol/(thx*max(ust*ust,0.0001))
10826 zolx=max(zolx,0.0)
10827 zolx=min(zolx,20.)
10828
10829
10830 !use pedros iterative function to find z/l
10831 !zol=zolri(rb_lnd,za,zntstoch_lnd,zt_lnd,zol,psi_opt)
10832 !use brute-force method
10833
10834 zolx=zolrib(rbx,za,znt,zt,gz1oz0,gz1ozt,zolx,psi_opt)
10835 zolx=max(zolx,0.0)
10836 zolx=min(zolx,20.)
10837
10838 zolzt = zolx*zt/za ! zt/l
10839 zolz0 = zolx*znt/za ! z0/l
10840 zolza = zolx*(za+znt)/za ! (z+z0/l
10841 zol10 = zolx*(10.+znt)/za ! (10+z0)/l
10842 zol2 = zolx*(2.+znt)/za ! (2+z0)/l
10843
10844 !compute psim and psih
10845 !call psi_beljaars_holtslag_1991(psim,psih,zol)
10846 !call psi_businger_1971(psim,psih,zol)
10847 !call psi_zilitinkevich_esau_2007(psim,psih,zol)
10848 !call psi_dyerhicks(psim,psih,zol,zt_lnd,zntstoch_lnd,za)
10849 !call psi_cb2005(psim,psih,zolza,zolz0)
10850
10851 psim=psim_stable(zolza,psi_opt)-psim_stable(zolz0,psi_opt)
10852 psih=psih_stable(zolza,psi_opt)-psih_stable(zolzt,psi_opt)
10853 psim10=psim_stable(zol10,psi_opt)-psim_stable(zolz0,psi_opt)
10854! psih10=psih_stable(zol10,psi_opt)-psih_stable(zolz0,psi_opt)
10855 psih2=psih_stable(zol2,psi_opt)-psih_stable(zolzt,psi_opt)
10856
10857 ! 1.0 over monin-obukhov length
10858
10859 rmolx= zolx/za
10860
10861 elseif(rbx .eq. 0.) then
10862 !=========================================================
10863 !-----class 3; forced convection/neutral:
10864 !=========================================================
10865
10866 psim=0.0
10867 psih=psim
10868 psim10=0.
10869! psih10=0.
10870 psih2=0.
10871
10872 zolx =0.
10873 rmolx =0.
10874
10875 elseif(rbx .lt. 0.)then
10876 !==========================================================
10877 !-----class 4; free convection:
10878 !==========================================================
10879
10880 !compute z/l first guess:
10881
10882 call li_etal_2010(zolx,rbx,za/znt,zratio)
10883
10884 !zol=za*vkc*grav*mol/(th1d*max(ust_lnd*ust_lnd,0.001))
10885
10886 zolx=max(zolx,-20.0)
10887 zolx=min(zolx,0.0)
10888
10889
10890 !use pedros iterative function to find z/l
10891 !zol=zolri(rb_lnd,za,zntstoch_lnd,zt_lnd,zol,psi_opt)
10892 !use brute-force method
10893
10894 zolx=zolrib(rbx,za,znt,zt,gz1oz0,gz1ozt,zolx,psi_opt)
10895 zolx=max(zolx,-20.0)
10896 zolx=min(zolx,0.0)
10897
10898 zolzt = zolx*zt/za ! zt/l
10899 zolz0 = zolx*znt/za ! z0/l
10900 zolza = zolx*(za+znt)/za ! (z+z0/l
10901 zol10 = zolx*(10.+znt)/za ! (10+z0)/l
10902 zol2 = zolx*(2.+znt)/za ! (2+z0)/l
10903
10904 !compute psim and psih
10905 !call psi_hogstrom_1996(psim,psih,zol, zt_lnd, zntstoch_lnd, za)
10906 !call psi_businger_1971(psim,psih,zol)
10907 !call psi_dyerhicks(psim,psih,zol,zt_lnd,zntstoch_lnd,za)
10908 ! use tables
10909
10910 psim=psim_unstable(zolza,psi_opt)-psim_unstable(zolz0,psi_opt)
10911 psih=psih_unstable(zolza,psi_opt)-psih_unstable(zolzt,psi_opt)
10912 psim10=psim_unstable(zol10,psi_opt)-psim_unstable(zolz0,psi_opt)
10913! psih10=psih_unstable(zol10,psi_opt)-psih_unstable(zolz0,psi_opt)
10914 psih2=psih_unstable(zol2,psi_opt)-psih_unstable(zolzt,psi_opt)
10915
10916 !---limit psih and psim in the case of thin layers and
10917 !---high roughness. this prevents denominator in fluxes
10918 !---from getting too small
10919
10920 psih=min(psih,0.9*gz1ozt)
10921 psim=min(psim,0.9*gz1oz0)
10922 psih2=min(psih2,0.9*gz2ozt)
10923 psim10=min(psim10,0.9*gz10oz0)
10924! psih10=min(psih10,0.9*gz10ozt)
10925
10926 rmolx = zolx/za
10927
10928 endif
10929
10930 ! calculate the resistance:
10931
10932 psix =max(gz1oz0-psim, 1.0)
10933 psix10=max(gz10oz0-psim10, 1.0)
10934 psit =max(gz1ozt-psih , 1.0)
10935 psit2 =max(gz2ozt-psih2, 1.0)
10936 psiq =max(log((za+zq)/zq)-psih ,1.0)
10937 psiq2 =max(log((2.0+zq)/zq)-psih2 ,1.0)
10938
10939 !------------------------------------------------------------
10940 !-----compute the frictional velocity:
10941 !------------------------------------------------------------
10942
10943
10944 ! to prevent oscillations average with old value
10945
10946! oldust = ust
10947
10948 ust=0.5*ust+0.5*vkc*wspdx/psix
10949 ust=max(ust,0.005)
10950
10951! stress=ust**2
10952
10953 !set ustm = ust over land.
10954
10955! ustmx=ust
10956
10957
10958 !----------------------------------------------------
10959 !----compute the temperature scale (a.k.a. friction temperature, t*, or mol)
10960 !----and compute the moisture scale (or q*)
10961 !----------------------------------------------------
10962
10963 dtg=thvx-tskv
10964
10965! oldtst=mol
10966
10967 molx=vkc*dtg/psit/prt !T*
10968
10969 !t_star = -hfx/(ust*cpm*rho1d)
10970 !t_star = mol
10971 !----------------------------------------------------
10972 ! dqg=(qvsh-qsfc)*1000. !(kg/kg -> g/kg)
10973
10974 dqg=(qx-qsfc)*1000. !(kg/kg -> g/kg)
10975 qstar=vkc*dqg/psiq/prt
10976
10977 cm = (vkc/psix)*(vkc/psix)*wspdx
10978
10979! cm = (vkc/psix)*(vkc/psix)
10980! ch = (vkc/psix)*(vkc/psit)
10981
10982 chs=ust*vkc/psit
10983 cqs2=ust*vkc/psiq2
10984 chs2=ust*vkc/psit2
10985
10986! u10=ux*psix10/psix
10987! v10=vx*psix10/psix
10988
10989 flhcx = rhox*cpm*ust*vkc/psit
10990 flqcx = rhox*1.0*ust*vkc/psiq
10991
10992! ch = flhcx/(cpm*rhox) !same chs
10993
10994 fmx = psix
10995 fhx = psit
10996 fm10x = psix10
10997 fh2x =psit2
10998
10999! ustmx = ust
11000
11001 stressx = ust**2 ! or cm*wind*wind
11002
11003 end subroutine sfcdif4
11004
11007 subroutine zilitinkevich_1995(z_0,zt,zq,restar,ustar,vkc,&
11008 & landsea,iz0tlnd2,spp_pbl,rstoch)
11009
11010 implicit none
11011 real (kind=kind_phys), intent(in) :: z_0,restar,ustar,vkc,landsea
11012 integer, optional, intent(in):: iz0tlnd2
11013 real (kind=kind_phys), intent(out) :: zt,zq
11014 real (kind=kind_phys) :: czil !=0.100 in chen et al. (1997)
11015 !=0.075 in zilitinkevich (1995)
11016 !=0.500 in lemone et al. (2008)
11017 integer, intent(in) :: spp_pbl
11018 real (kind=kind_phys), intent(in) :: rstoch
11019
11020
11021 if (landsea-1.5 .gt. 0) then !water
11022
11023 !this is based on zilitinkevich, grachev, and fairall (2001;
11024 !their equations 15 and 16).
11025 if (restar .lt. 0.1) then
11026 zt = z_0*exp(vkc*2.0)
11027 zt = min( zt, 6.0e-5)
11028 zt = max( zt, 2.0e-9)
11029 zq = z_0*exp(vkc*3.0)
11030 zq = min( zq, 6.0e-5)
11031 zq = max( zq, 2.0e-9)
11032 else
11033 zt = z_0*exp(-vkc*(4.0*sqrt(restar)-3.2))
11034 zt = min( zt, 6.0e-5)
11035 zt = max( zt, 2.0e-9)
11036 zq = z_0*exp(-vkc*(4.0*sqrt(restar)-4.2))
11037 zq = min( zt, 6.0e-5)
11038 zq = max( zt, 2.0e-9)
11039 endif
11040
11041 else !land
11042
11043 !option to modify czil according to chen & zhang, 2009
11044 if ( iz0tlnd2 .eq. 1 ) then
11045 czil = 10.0 ** ( -0.40 * ( z_0 / 0.07 ) )
11046 else
11047 czil = 0.085 !0.075 !0.10
11048 end if
11049
11050 zt = z_0*exp(-vkc*czil*sqrt(restar))
11051 zt = min( zt, 0.75*z_0)
11052
11053 zq = z_0*exp(-vkc*czil*sqrt(restar))
11054 zq = min( zq, 0.75*z_0)
11055
11056
11057! stochastically perturb thermal and moisture roughness length.
11058! currently set to half the amplitude:
11059 if (spp_pbl==1) then
11060 zt = zt + zt * 0.5 * rstoch
11061 zt = max(zt, 0.0001)
11062 zq = zt
11063 endif
11064
11065 endif
11066
11067 return
11068
11069 end subroutine zilitinkevich_1995
11070
11074 subroutine garratt_1992(zt,zq,z_0,ren,landsea)
11075
11076 implicit none
11077 real (kind=kind_phys), intent(in) :: ren, z_0,landsea
11078 real (kind=kind_phys), intent(out) :: zt,zq
11079 real (kind=kind_phys) :: rq
11080 real (kind=kind_phys), parameter :: e=2.71828183
11081
11082 if (landsea-1.5 .gt. 0) then !water
11083
11084 zt = z_0*exp(2.0 - (2.48*(ren**0.25)))
11085 zq = z_0*exp(2.0 - (2.28*(ren**0.25)))
11086
11087 zq = min( zq, 5.5e-5)
11088 zq = max( zq, 2.0e-9)
11089 zt = min( zt, 5.5e-5)
11090 zt = max( zt, 2.0e-9) !same lower limit as ecmwf
11091 else !land
11092 zq = z_0/(e**2.) !taken from garratt (1980,1992)
11093 zt = zq
11094 endif
11095
11096 return
11097
11098 end subroutine garratt_1992
11099!--------------------------------------------------------------------
11124 subroutine yang_2008(z_0,zt,zq,ustar,tstar,qst,ren,visc)
11125
11126 implicit none
11127 real (kind=kind_phys), intent(in) :: z_0, ren, ustar, tstar, qst, visc
11128 real (kind=kind_phys) :: ht, &! roughness height at critical reynolds number
11129 tstar2, &! bounded t*, forced to be non-positive
11130 qstar2, &! bounded q*, forced to be non-positive
11131 z_02, &! bounded z_0 for variable renc2 calc
11132 renc2 ! variable renc, function of z_0
11133 real (kind=kind_phys), intent(out) :: zt,zq
11134 real (kind=kind_phys), parameter :: renc=300., & !old constant renc
11135 beta=1.5, & !important for diurnal variation
11136 m=170., & !slope for renc2 function
11137 b=691. !y-intercept for renc2 function
11138
11139 z_02 = min(z_0,0.5)
11140 z_02 = max(z_02,0.04)
11141 renc2= b + m*log(z_02)
11142 ht = renc2*visc/max(ustar,0.01)
11143 tstar2 = min(tstar, 0.0)
11144 qstar2 = min(qst,0.0)
11145
11146 zt = ht * exp(-beta*(ustar**0.5)*(abs(tstar2)**1.0))
11147 zq = ht * exp(-beta*(ustar**0.5)*(abs(qstar2)**1.0))
11148 !zq = zt
11149
11150 zt = min(zt, z_0/2.0)
11151 zq = min(zq, z_0/2.0)
11152
11153 return
11154
11155 end subroutine yang_2008
11156
11162 subroutine andreas_2002(z_0,bvisc,ustar,zt,zq)
11163
11164 implicit none
11165 real (kind=kind_phys), intent(in) :: z_0, bvisc, ustar
11166 real (kind=kind_phys), intent(out) :: zt, zq
11167 real (kind=kind_phys):: ren2, zntsno
11168
11169 real (kind=kind_phys), parameter :: bt0_s=1.25, bt0_t=0.149, bt0_r=0.317, &
11170 bt1_s=0.0, bt1_t=-0.55, bt1_r=-0.565, &
11171 bt2_s=0.0, bt2_t=0.0, bt2_r=-0.183
11172
11173 real (kind=kind_phys), parameter :: bq0_s=1.61, bq0_t=0.351, bq0_r=0.396, &
11174 bq1_s=0.0, bq1_t=-0.628, bq1_r=-0.512, &
11175 bq2_s=0.0, bq2_t=0.0, bq2_r=-0.180
11176
11177 !calculate zo for snow (andreas et al. 2005, blm)
11178 zntsno = 0.135*bvisc/ustar + &
11179 (0.035*(ustar*ustar)/9.8) * &
11180 (5.*exp(-1.*(((ustar - 0.18)/0.1)*((ustar - 0.18)/0.1))) + 1.)
11181 ren2 = ustar*zntsno/bvisc
11182
11183 ! make sure that re is not outside of the range of validity
11184 ! for using their equations
11185 if (ren2 .gt. 1000.) ren2 = 1000.
11186
11187 if (ren2 .le. 0.135) then
11188
11189 zt = zntsno*exp(bt0_s + bt1_s*log(ren2) + bt2_s*log(ren2)**2)
11190 zq = zntsno*exp(bq0_s + bq1_s*log(ren2) + bq2_s*log(ren2)**2)
11191
11192 else if (ren2 .gt. 0.135 .and. ren2 .lt. 2.5) then
11193
11194 zt = zntsno*exp(bt0_t + bt1_t*log(ren2) + bt2_t*log(ren2)**2)
11195 zq = zntsno*exp(bq0_t + bq1_t*log(ren2) + bq2_t*log(ren2)**2)
11196
11197 else
11198
11199 zt = zntsno*exp(bt0_r + bt1_r*log(ren2) + bt2_r*log(ren2)**2)
11200 zq = zntsno*exp(bq0_r + bq1_r*log(ren2) + bq2_r*log(ren2)**2)
11201
11202 endif
11203
11204 return
11205
11206 end subroutine andreas_2002
11207!--------------------------------------------------------------------
11212 subroutine li_etal_2010(zl, rib, zaz0, z0zt)
11213
11214 implicit none
11215 real (kind=kind_phys), intent(out) :: zl
11216 real (kind=kind_phys), intent(in) :: rib, zaz0, z0zt
11217 real (kind=kind_phys) :: alfa, beta, zaz02, z0zt2
11218 real (kind=kind_phys), parameter :: au11=0.045, bu11=0.003, bu12=0.0059, &
11219 &bu21=-0.0828, bu22=0.8845, bu31=0.1739, &
11220 &bu32=-0.9213, bu33=-0.1057
11221 real (kind=kind_phys), parameter :: aw11=0.5738, aw12=-0.4399, aw21=-4.901,&
11222 &aw22=52.50, bw11=-0.0539, bw12=1.540, &
11223 &bw21=-0.669, bw22=-3.282
11224 real (kind=kind_phys), parameter :: as11=0.7529, as21=14.94, bs11=0.1569,&
11225 &bs21=-0.3091, bs22=-1.303
11226
11227 !set limits according to li et al (2010), p 157.
11228 zaz02=zaz0
11229 if (zaz0 .lt. 100.0) zaz02=100.
11230 if (zaz0 .gt. 100000.0) zaz02=100000.
11231
11232 !set more limits according to li et al (2010)
11233 z0zt2=z0zt
11234 if (z0zt .lt. 0.5) z0zt2=0.5
11235 if (z0zt .gt. 100.0) z0zt2=100.
11236
11237 alfa = log(zaz02)
11238 beta = log(z0zt2)
11239
11240 if (rib .le. 0.0) then
11241 zl = au11*alfa*rib**2 + ( &
11242 & (bu11*beta + bu12)*alfa**2 + &
11243 & (bu21*beta + bu22)*alfa + &
11244 & (bu31*beta**2 + bu32*beta + bu33))*rib
11245 !if(zl .lt. -15 .or. zl .gt. 0.)print*,"violation rib<0:",zl
11246 zl = max(zl,-15.) !limits set according to li et al (2010)
11247 zl = min(zl,0.) !figure 1.
11248 elseif (rib .gt. 0.0 .and. rib .le. 0.2) then
11249 zl = ((aw11*beta + aw12)*alfa + &
11250 & (aw21*beta + aw22))*rib**2 + &
11251 & ((bw11*beta + bw12)*alfa + &
11252 & (bw21*beta + bw22))*rib
11253 !if(zl .lt. 0 .or. zl .gt. 4)print*,"violation 0<rib<0.2:",zl
11254 zl = min(zl,4.) !limits approx set according to li et al (2010)
11255 zl = max(zl,0.) !their figure 1b.
11256 else
11257 zl = (as11*alfa + as21)*rib + bs11*alfa + &
11258 & bs21*beta + bs22
11259 !if(zl .le. 1 .or. zl .gt. 23)print*,"violation rib>0.2:",zl
11260 zl = min(zl,20.) !limits according to li et al (2010), thier
11261 !figue 1c.
11262 zl = max(zl,1.)
11263 endif
11264
11265 return
11266
11267 end subroutine li_etal_2010
11268!-------------------------------------------------------------------
11271 real*8 function zolri(ri,za,z0,zt,zol1,psi_opt)
11272
11278
11279 implicit none
11280 real (kind=kind_phys), intent(in) :: ri,za,z0,zt,zol1
11281 integer, intent(in) :: psi_opt
11282 real (kind=kind_phys) :: x1,x2,fx1,fx2
11283 integer :: n
11284 integer, parameter :: nmax = 20
11285 real(kind=kind_phys) zolri_iteration
11286 !real, dimension(nmax):: zlhux
11287! real :: zolri2
11288
11289 if (ri.lt.0.)then
11290 x1=zol1 - 0.02 !-5.
11291 x2=0.
11292 else
11293 x1=0.
11294 x2=zol1 + 0.02 !5.
11295 endif
11296
11297 n=1
11298 fx1=zolri2(x1,ri,za,z0,zt,psi_opt)
11299 fx2=zolri2(x2,ri,za,z0,zt,psi_opt)
11300
11301 do while (abs(x1 - x2) > 0.01 .and. n < nmax)
11302 if(abs(fx2).lt.abs(fx1))then
11303 x1=x1-fx1/(fx2-fx1)*(x2-x1)
11304 fx1=zolri2(x1,ri,za,z0,zt,psi_opt)
11305 zolri=x1
11306 else
11307 x2=x2-fx2/(fx2-fx1)*(x2-x1)
11308 fx2=zolri2(x2,ri,za,z0,zt,psi_opt)
11309 zolri=x2
11310 endif
11311 n=n+1
11312 !print*," n=",n," x1=",x1," x2=",x2
11313 !zlhux(n)=zolri
11314 enddo
11315
11316 if (n==nmax .and. abs(x1 - x2) >= 0.01) then
11317 !if convergence fails, use approximate values:
11318 zolri_iteration= zolri
11319 call li_etal_2010(zolri_iteration, ri, za/z0, z0/zt)
11320 zolri = zolri_iteration
11321 !zlhux(n)=zolri
11322 !print*,"iter fail, n=",n," ri=",ri," z0=",z0
11323 else
11324 !print*,"success,n=",n," ri=",ri," z0=",z0
11325 endif
11326
11327 return
11328 end function
11329!-------------------------------------------------------------------
11330 real*8 function zolri2(zol2,ri2,za,z0,zt,psi_opt)
11331
11332 ! input: =================================
11333 ! zol2 - estimated z/l
11334 ! ri2 - calculated bulk richardson number
11335 ! za - 1/2 depth of first model layer
11336 ! z0 - aerodynamic roughness length
11337 ! zt - thermal roughness length
11338 ! output: ================================
11339 ! zolri2 - delta ri
11340
11341 implicit none
11342 integer, intent(in) :: psi_opt
11343 real (kind=kind_phys), intent(in) :: ri2,za,z0,zt
11344 real (kind=kind_phys), intent(inout) :: zol2
11345 real (kind=kind_phys) :: zol20,zol3,psim1,psih1,psix2,psit2,zolt
11346
11347! real :: psih_unstable,psim_unstable,psih_stable, psim_stable
11348
11349 if(zol2*ri2 .lt. 0.)zol2=0. ! limit zol2 - must be same sign as ri2
11350
11351 zol20=zol2*z0/za ! z0/l
11352 zol3=zol2+zol20 ! (z+z0)/l
11353 zolt=zol2*zt/za ! zt/l
11354
11355 if (ri2.lt.0) then
11356 !psix2=log((za+z0)/z0)-(psim_unstable(zol3)-psim_unstable(zol20))
11357 !psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20))
11358 psit2=max(log((za+z0)/zt)-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0)
11359 psix2=max(log((za+z0)/z0)-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)),1.0)
11360 else
11361 !psix2=log((za+z0)/z0)-(psim_stable(zol3)-psim_stable(zol20))
11362 !psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20))
11363 psit2=max(log((za+z0)/zt)-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0)
11364 psix2=max(log((za+z0)/z0)-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)),1.0)
11365 endif
11366
11367 zolri2=zol2*psit2/psix2**2 - ri2
11368 !print*," target ri=",ri2," est ri=",zol2*psit2/psix2**2
11369
11370 return
11371 end function
11372!====================================================================
11373
11374 real*8 function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt)
11375
11376 ! this iterative algorithm to compute z/l from bulk-ri
11377
11378 implicit none
11379 real (kind=kind_phys), intent(in) :: ri,za,z0,zt,logz0,logzt
11380 integer, intent(in) :: psi_opt
11381 real (kind=kind_phys), intent(inout) :: zol1
11382 real (kind=kind_phys) :: zol20,zol3,zolt,zolold
11383 integer :: n
11384 integer, parameter :: nmax = 20
11385 real (kind=kind_phys), dimension(nmax):: zlhux
11386 real (kind=kind_phys) :: psit2,psix2,zolrib_iteration
11387
11388! real :: psim_unstable, psim_stable
11389! real :: psih_unstable, psih_stable
11390
11391 !print*,"+++++++incoming: z/l=",zol1," ri=",ri
11392 if (zol1*ri .lt. 0.) then
11393 !print*,"begin: wrong quadrants: z/l=",zol1," ri=",ri
11394 zol1=0.
11395 endif
11396
11397 if (ri .lt. 0.) then
11398 zolold=-99999.
11399 zolrib=-66666.
11400 else
11401 zolold=99999.
11402 zolrib=66666.
11403 endif
11404 n=1
11405
11406 do while (abs(zolold - zolrib) > 0.01 .and. n < nmax)
11407
11408 if(n==1)then
11409 zolold=zol1
11410 else
11411 zolold=zolrib
11412 endif
11413 zol20=zolold*z0/za ! z0/l
11414 zol3=zolold+zol20 ! (z+z0)/l
11415 zolt=zolold*zt/za ! zt/l
11416 !print*,"z0/l=",zol20," (z+z0)/l=",zol3," zt/l=",zolt
11417 if (ri.lt.0) then
11418 !psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20))
11419 !psit2=log((za+z0)/zt)-(psih_unstable(zol3)-psih_unstable(zol20))
11420 psit2=max(logzt-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0)
11421 psix2=max(logz0-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)), 1.0)
11422 else
11423 !psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20))
11424 !psit2=log((za+z0)/zt)-(psih_stable(zol3)-psih_stable(zol20))
11425 psit2=max(logzt-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0)
11426 psix2=max(logz0-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)), 1.0)
11427 endif
11428 !print*,"n=",n," psit2=",psit2," psix2=",psix2
11429 zolrib=ri*psix2**2/psit2
11430 zlhux(n)=zolrib
11431 n=n+1
11432 enddo
11433
11434 if (n==nmax .and. abs(zolold - zolrib) > 0.01 ) then
11435 !print*,"iter fail, n=",n," ri=",ri," z/l=",zolri
11436 !if convergence fails, use approximate values:
11437 zolrib_iteration = zolrib
11438 call li_etal_2010(zolrib_iteration, ri, za/z0, z0/zt)
11439 zolrib = zolrib_iteration
11440 zlhux(n)=zolrib
11441 !print*,"failed, n=",n," ri=",ri," z0=",z0
11442 !print*,"z/l=",zlhux(1:nmax)
11443 else
11444 !if(zolrib*ri .lt. 0.) then
11445 ! !print*,"end: wrong quadrants: z/l=",zolrib," ri=",ri
11446 ! !phys_temp = zolrib
11447 ! !call li_etal_2010(zolrib, ri, za/z0, z0/zt)
11448 ! !zolrib = phys_temp
11449 !endif
11450 !print*,"success,n=",n," ri=",ri," z0=",z0
11451 endif
11452
11453 return
11454 end function
11455!====================================================================
11456
11459 subroutine psi_init(psi_opt,errmsg,errflg)
11460
11461 integer :: n,psi_opt
11462 real (kind=kind_phys) :: zolf
11463 character(len=*), intent(out) :: errmsg
11464 integer, intent(out) :: errflg
11465
11466 if (psi_opt == 0) then
11467 do n=0,1000
11468 ! stable function tables
11469 zolf = float(n)*0.01
11470 psim_stab(n)=psim_stable_full(zolf)
11471 psih_stab(n)=psih_stable_full(zolf)
11472
11473 ! unstable function tables
11474 zolf = -float(n)*0.01
11475 psim_unstab(n)=psim_unstable_full(zolf)
11476 psih_unstab(n)=psih_unstable_full(zolf)
11477 enddo
11478 else
11479 do n=0,1000
11480 ! stable function tables
11481 zolf = float(n)*0.01
11482 psim_stab(n)=psim_stable_full_gfs(zolf)
11483 psih_stab(n)=psih_stable_full_gfs(zolf)
11484
11485 ! unstable function tables
11486 zolf = -float(n)*0.01
11487 psim_unstab(n)=psim_unstable_full_gfs(zolf)
11488 psih_unstab(n)=psih_unstable_full_gfs(zolf)
11489 enddo
11490 endif
11491
11492 !simple test to see if initialization worked:
11493 if (psim_stab(1) < 0. .and. psih_stab(1) < 0. .and. &
11494 psim_unstab(1) > 0. .and. psih_unstab(1) > 0.) then
11495 errmsg = 'in mynn sfc, psi tables have been initialized'
11496 errflg = 0
11497 else
11498 errmsg = 'error in mynn sfc: problem initializing psi tables'
11499 errflg = 1
11500 endif
11501
11502 end subroutine psi_init
11503! ==================================================================
11504! ... integrated similarity functions from mynn...
11505!
11507 real*8 function psim_stable_full(zolf)
11508 real (kind=kind_phys) :: zolf
11509
11510 !psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5))
11511 psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**0.4)
11512
11513 return
11514 end function
11515
11517 real*8 function psih_stable_full(zolf)
11518 real (kind=kind_phys) :: zolf
11519
11520 !psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1))
11521 psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**0.9090909090909090909)
11522
11523 return
11524 end function
11525
11527 real*8 function psim_unstable_full(zolf)
11528 real (kind=kind_phys) :: zolf,x,ym,psimc,psimk
11529
11530 x=(1.-16.*zolf)**.25
11531 !psimk=2*alog(0.5*(1+x))+alog(0.5*(1+x*x))-2.*atan(x)+2.*atan(1.)
11532 psimk=2.*log(0.5*(1+x))+log(0.5*(1+x*x))-2.*atan(x)+2.*atan1
11533
11534 ym=(1.-10.*zolf)**onethird
11535 !psimc=(3./2.)*log((ym**2.+ym+1.)/3.)-sqrt(3.)*atan((2.*ym+1)/sqrt(3.))+4.*atan(1.)/sqrt(3.)
11536 psimc=1.5*log((ym**2 + ym+1.)*onethird)-sqrt3*atan((2.*ym+1)/sqrt3)+4.*atan1/sqrt3
11537
11538 psim_unstable_full=(psimk+zolf**2*(psimc))/(1+zolf**2.)
11539
11540 return
11541 end function
11542
11544 real*8 function psih_unstable_full(zolf)
11545 real (kind=kind_phys) :: zolf,y,yh,psihc,psihk
11546
11547 y=(1.-16.*zolf)**.5
11548 !psihk=2.*log((1+y)/2.)
11549 psihk=2.*log((1+y)*0.5)
11550
11551 yh=(1.-34.*zolf)**onethird
11552 !psihc=(3./2.)*log((yh**2.+yh+1.)/3.)-sqrt(3.)*atan((2.*yh+1)/sqrt(3.))+4.*atan(1.)/sqrt(3.)
11553 psihc=1.5*log((yh**2.+yh+1.)*onethird)-sqrt3*atan((2.*yh+1)/sqrt3)+4.*atan1/sqrt3
11554
11555 psih_unstable_full=(psihk+zolf**2*(psihc))/(1+zolf**2)
11556
11557 return
11558 end function
11559
11560! ==================================================================
11561! ... integrated similarity functions from gfs...
11562!
11563 real*8 function psim_stable_full_gfs(zolf)
11564 real (kind=kind_phys) :: zolf
11565 real (kind=kind_phys), parameter :: alpha4 = 20.
11566 real (kind=kind_phys) :: aa
11567
11568 aa = sqrt(1. + alpha4 * zolf)
11569 psim_stable_full_gfs = -1.*aa + log(aa + 1.)
11570
11571 return
11572 end function
11573
11574 real*8 function psih_stable_full_gfs(zolf)
11575 real (kind=kind_phys) :: zolf
11576 real (kind=kind_phys), parameter :: alpha4 = 20.
11577 real (kind=kind_phys) :: bb
11578
11579 bb = sqrt(1. + alpha4 * zolf)
11580 psih_stable_full_gfs = -1.*bb + log(bb + 1.)
11581
11582 return
11583 end function
11584
11585 real*8 function psim_unstable_full_gfs(zolf)
11586 real (kind=kind_phys) :: zolf
11587 real (kind=kind_phys) :: hl1,tem1
11588 real (kind=kind_phys), parameter :: a0=-3.975, a1=12.32, &
11589 b1=-7.755, b2=6.041
11590
11591 if (zolf .ge. -0.5) then
11592 hl1 = zolf
11593 psim_unstable_full_gfs = (a0 + a1*hl1) * hl1 / (1.+ (b1+b2*hl1) *hl1)
11594 else
11595 hl1 = -zolf
11596 tem1 = 1.0 / sqrt(hl1)
11597 psim_unstable_full_gfs = log(hl1) + 2. * sqrt(tem1) - .8776
11598 end if
11599
11600 return
11601 end function
11602
11603 real*8 function psih_unstable_full_gfs(zolf)
11604 real (kind=kind_phys) :: zolf
11605 real (kind=kind_phys) :: hl1,tem1
11606 real (kind=kind_phys), parameter :: a0p=-7.941, a1p=24.75, &
11607 b1p=-8.705, b2p=7.899
11608
11609 if (zolf .ge. -0.5) then
11610 hl1 = zolf
11611 psih_unstable_full_gfs = (a0p + a1p*hl1) * hl1 / (1.+ (b1p+b2p*hl1)*hl1)
11612 else
11613 hl1 = -zolf
11614 tem1 = 1.0 / sqrt(hl1)
11615 psih_unstable_full_gfs = log(hl1) + .5 * tem1 + 1.386
11616 end if
11617
11618 return
11619 end function
11620
11621!=================================================================
11622! look-up table functions - or, if beyond -10 < z/l < 10, recalculate
11623!=================================================================
11624 real*8 function psim_stable(zolf,psi_opt)
11625 integer :: nzol,psi_opt
11626 real (kind=kind_phys) :: rzol,zolf
11627
11628 nzol = int(zolf*100.)
11629 rzol = zolf*100. - nzol
11630 if(nzol+1 .lt. 1000)then
11631 psim_stable = psim_stab(nzol) + rzol*(psim_stab(nzol+1)-psim_stab(nzol))
11632 else
11633 if (psi_opt == 0) then
11634 psim_stable = psim_stable_full(zolf)
11635 else
11636 psim_stable = psim_stable_full_gfs(zolf)
11637 endif
11638 endif
11639
11640 return
11641 end function
11642
11643 real*8 function psih_stable(zolf,psi_opt)
11644 integer :: nzol,psi_opt
11645 real (kind=kind_phys) :: rzol,zolf
11646
11647 nzol = int(zolf*100.)
11648 rzol = zolf*100. - nzol
11649 if(nzol+1 .lt. 1000)then
11650 psih_stable = psih_stab(nzol) + rzol*(psih_stab(nzol+1)-psih_stab(nzol))
11651 else
11652 if (psi_opt == 0) then
11653 psih_stable = psih_stable_full(zolf)
11654 else
11655 psih_stable = psih_stable_full_gfs(zolf)
11656 endif
11657 endif
11658
11659 return
11660 end function
11661
11662 real*8 function psim_unstable(zolf,psi_opt)
11663 integer :: nzol,psi_opt
11664 real (kind=kind_phys) :: rzol,zolf
11665
11666 nzol = int(-zolf*100.)
11667 rzol = -zolf*100. - nzol
11668 if(nzol+1 .lt. 1000)then
11669 psim_unstable = psim_unstab(nzol) + rzol*(psim_unstab(nzol+1)-psim_unstab(nzol))
11670 else
11671 if (psi_opt == 0) then
11672 psim_unstable = psim_unstable_full(zolf)
11673 else
11674 psim_unstable = psim_unstable_full_gfs(zolf)
11675 endif
11676 endif
11677
11678 return
11679 end function
11680
11681 real*8 function psih_unstable(zolf,psi_opt)
11682 integer :: nzol,psi_opt
11683 real (kind=kind_phys) :: rzol,zolf
11684
11685 nzol = int(-zolf*100.)
11686 rzol = -zolf*100. - nzol
11687 if(nzol+1 .lt. 1000)then
11688 psih_unstable = psih_unstab(nzol) + rzol*(psih_unstab(nzol+1)-psih_unstab(nzol))
11689 else
11690 if (psi_opt == 0) then
11691 psih_unstable = psih_unstable_full(zolf)
11692 else
11693 psih_unstable = psih_unstable_full_gfs(zolf)
11694 endif
11695 endif
11696
11697 return
11698 end function
11699!========================================================================
11700end module module_sf_noahmplsm
11701
csnow
subroutine csnow
This subroutine calculates snow termal conductivity.
Definition sflx.f:1229
sstep
subroutine sstep(nsoil, sh2oin, rhsct, dt, smcmax, cmcmax, zsoil, sice, cmc, rhstt, ai, bi, ci, sh2oout, runoff3, smc)
This subroutine calculates/updates soil moisture content values and canopy moisture content values.
Definition sflx.f:5298
rosr12
subroutine rosr12(nsoil, a, b, d, c, p, delta)
This subroutine inverts (solve) the tri-diagonal matrix problem.
Definition sflx.f:4743
frh2o
subroutine frh2o(tkelv, smc, sh2o, smcmax, bexp, psis, liqwat)
This subroutine calculates amount of supercooled liquid soil water content if temperature is below 27...
Definition sflx.f:3940
tdfcnd
subroutine tdfcnd(smc, qz, smcmax, sh2o, df)
This subroutine calculates thermal diffusivity and conductivity of the soil for a given point and tim...
Definition sflx.f:3015
snowz0
subroutine snowz0
This subroutine calculates total roughness length over snow.
Definition sflx.f:2957
canres
subroutine canres
This subroutine calculates canopy resistance which depends on incoming solar radiation,...
Definition sflx.f:1074
hrt
subroutine hrt(nsoil, stc, smc, smcmax, zsoil, yy, zz1, tbot, zbot, psisat, dt, bexp, df1, quartz, csoil, vegtyp, shdfac, lheatstrg, sh2o, rhsts, ai, bi, ci)
This subroutine calculates the right hand side of the time tendency term of the soil thermal diffusio...
Definition sflx.f:4099
hstep
subroutine hstep(nsoil, stcin, dt, rhsts, ai, bi, ci, stcout)
This subroutine calculates/updates the soil temperature field.
Definition sflx.f:4643
srt
subroutine srt(nsoil, edir, et, sh2o, sh2oa, pcpdrp, zsoil, dwsat, dksat, smcmax, bexp, dt, smcwlt, slope, kdt, frzx, sice, rhstt, runoff1, runoff2, ai, bi, ci)
This subroutine calculates the right hand side of the time tendency term of the soil water diffusion ...
Definition sflx.f:4985
shallowwatertable
subroutine shallowwatertable(parameters, nsnow, nsoil, zsoil, dt, dzsnso, smceq, iloc, jloc, smc, wtd, smcwtd, rech, qdrain)
diagnoses water table depth and computes recharge when the water table is within the resolved soil la...
Definition module_sf_noahmplsm.F90:9217
surrad
subroutine surrad(parameters, mpe, fsun, fsha, elai, vai, laisun, laisha, solad, solai, fabd, fabi, ftdd, ftid, ftii, albgrd, albgri, albd, albi, iloc, jloc, parsun, parsha, sav, sag, fsa, fsr, frevi, frevd, fregd, fregi, fsrv, fsrg)
surface raditiation
Definition module_sf_noahmplsm.F90:3087
combine
subroutine combine(parameters, nsnow, nsoil, iloc, jloc, isnow, sh2o, stc, snice, snliq, dzsnso, sice, snowh, sneqv, ponding1, ponding2)
Definition module_sf_noahmplsm.F90:7599
canwater
subroutine canwater(parameters, vegtyp, dt, fcev, fctr, elai, esai, tg, fveg, iloc, jloc, bdfall, frozen_canopy, canliq, canice, tv, cmc, ecan, etran, fwet)
canopy hydrology
Definition module_sf_noahmplsm.F90:7258
carbon_crop
subroutine carbon_crop(parameters, nsnow, nsoil, vegtyp, dt, zsoil, julian, dzsnso, stc, smc, tv, psn, foln, btran, soldn, t2m, lfmass, rtmass, stmass, wood, stblcp, fastcp, grain, xlai, xsai, gdd, gpp, npp, nee, autors, heters, totsc, totlb, pgs)
initial crop version created by xing liu initial crop version added by barlage v3....
Definition module_sf_noahmplsm.F90:9755
phasechange
subroutine phasechange(parameters, nsnow,nsoil,isnow,dt,fact, dzsnso,hcpct,ist,iloc,jloc, stc,snice,snliq,sneqv,snowh, ifdef ccpp
melting/freezing of snow water and soil water
Definition module_sf_noahmplsm.F90:6632
snowalb_bats
subroutine snowalb_bats(parameters, nband, fsno, cosz, fage, albsnd, albsni)
bats snow surface albedo
Definition module_sf_noahmplsm.F90:3261
energy
subroutine energy(parameters, ice,vegtyp,ist,nsnow,nsoil, isnow,dt,rhoair,sfcprs,qair, sfctmp,thair,lwdn,uu,vv,zref, co2air,o2air,solad,solai,cosz,igs, eair,tbot,zsnso,zsoil, elai,esai,fwet,foln, fveg,shdfac, pahv,pahg,pahb, qsnow,dzsnso,lat,canliq,canice,iloc, jloc, thsfc_loc, prslkix, prsik1x, prslk1x, garea1, pblhx, iz0tlnd, itime, psi_opt, ep_1, ep_2, epsm1, cp, z0wrf,z0hwrf, imelt,snicev,snliqv,epore,t2m,fsno, sav,sag,qmelt,fsa,fsr,taux, tauy,fira,fsh,fcev,fgev,fctr, trad,psn,apar,ssoil,btrani,btran, ponding, ts,latheav, latheag, frozen_canopy, frozen_ground, tv,tg,stc,snowh,eah,tah, sneqvo,sneqv,sh2o,smc,snice,snliq, albold,cm,ch,dx,dz8w,q2, ustarx, ifdef ccpp
We use different approaches to deal with subgrid features of radiation transfer and turbulent transfe...
Definition module_sf_noahmplsm.F90:1691
snowfall
subroutine snowfall(parameters, nsoil, nsnow, dt, qsnow, snowhin, sfctmp, iloc, jloc, isnow, snowh, dzsnso, stc, snice, snliq, sneqv)
snow depth and density to account for the new snowfall. new values of snow depth & density returned.
Definition module_sf_noahmplsm.F90:7527
growing_gdd
subroutine growing_gdd(parameters, t2m, dt, julian, gdd, ipa, iha, pgs)
Definition module_sf_noahmplsm.F90:10155
divide
subroutine divide(parameters, nsnow, nsoil, isnow, stc, snice, snliq, dzsnso)
Definition module_sf_noahmplsm.F90:7787
noahmp_options
subroutine noahmp_options(idveg, iopt_crs, iopt_btr, iopt_run, iopt_sfc, iopt_frz, iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, iopt_stc, iopt_rsf, iopt_soil, iopt_pedo, iopt_crop, iopt_trs, iopt_diag, iopt_z0m)
Definition module_sf_noahmplsm.F90:10434
water
subroutine water(parameters, vegtyp, nsnow, nsoil, imelt, dt, uu, vv, fcev, fctr, qprecc, qprecl, elai, esai, sfctmp, qvap, qdew, zsoil, btrani, ficeold, ponding, tg, ist, fveg, iloc, jloc, smceq, bdfall, fp, rain, snow, qsnow, qrain, snowhin, latheav, latheag, frozen_canopy, frozen_ground, isnow, canliq, canice, tv, snowh, sneqv, snice, snliq, stc, zsnso, sh2o, smc, sice, zwt, wa, wt, dzsnso, wslake, smcwtd, deeprech, rech, cmc, ecan, etran, fwet, runsrf, runsub, qin, qdis, ponding1, ponding2, qsnbot, esnow)
compute water budgets (water storages, et components, and runoff)
Definition module_sf_noahmplsm.F90:7031
snowalb_class
subroutine snowalb_class(parameters, nband, qsnow, dt, alb, albold, albsnd, albsni, iloc, jloc)
class snow surface albedo
Definition module_sf_noahmplsm.F90:3318
psi_init
subroutine psi_init(psi_opt, errmsg, errflg)
Definition module_sf_noahmplsm.F90:11460
infil
subroutine infil(parameters, nsoil, dt, zsoil, sh2o, sice, sicemax, qinsur, pddum, runsrf)
compute inflitration rate at soil surface and surface runoff
Definition module_sf_noahmplsm.F90:8566
carbon
subroutine carbon(parameters, nsnow, nsoil, vegtyp, dt, zsoil, dzsnso, stc, smc, tv, tg, psn, foln, btran, apar, fveg, igs, troot, ist, lat, iloc, jloc, lfmass, rtmass, stmass, wood, stblcp, fastcp, gpp, npp, nee, autors, heters, totsc, totlb, xlai, xsai)
Definition module_sf_noahmplsm.F90:9366
combo
subroutine combo(parameters, dz, wliq, wice, t, dz2, wliq2, wice2, t2)
Definition module_sf_noahmplsm.F90:7916
groundalb
subroutine groundalb(parameters, nsoil, nband, ice, ist, fsno, smc, albsnd, albsni, cosz, tg, iloc, jloc, albgrd, albgri)
ground surface albedo
Definition module_sf_noahmplsm.F90:3376
sfcdif4
subroutine sfcdif4(iloc, jloc, ux, vx, t1d, p1d, psfcpa, pblhx, dx, znt, ep_1, ep_2, cp, itime, snwh, isice, psi_opt, tsk, qx, zlvl, iz0tlnd, qsfc, hfx, qfx, cm, chs, chs2, cqs2, rmolx, ust, rbx, fmx, fhx, stressx, fm10x, fh2x, wspdx, flhcx, flqcx)
Definition module_sf_noahmplsm.F90:10495
sfcdif1
subroutine sfcdif1(parameters, iter,sfctmp,rhoair,h,qair, zlvl,zpd,z0m,z0h,ur, mpe,iloc,jloc, ifdef ccpp
compute surface drag coefficient cm for momentum and ch for heat.
Definition module_sf_noahmplsm.F90:5052
sfcdif3
subroutine sfcdif3(parameters, iloc, jloc, iter, sfctmp, qair, ur, zlvl, tgb, thsfc_loc, prslkix, prsik1x, prslk1x, z0m, z0h, zpd, snowh, fveg, garea1, ustarx, fm, fh, fm2, fh2, fv, cm, ch)
compute surface drag coefficient cm for momentum and ch for heat.
Definition module_sf_noahmplsm.F90:5442
phenology
subroutine phenology(parameters, vegtyp, croptype, snowh, tv, lat, yearlen, julian, lai, sai, troot, elai, esai, igs, pgs)
vegetation phenology considering vegetation canopy being buried by snow and evolution in time.
Definition module_sf_noahmplsm.F90:1117
groundwater
subroutine groundwater(parameters, nsnow, nsoil, dt, sice, zsoil, stc, wcnd, fcrmax, iloc, jloc, sh2o, zwt, wa, wt, qin, qdis)
Definition module_sf_noahmplsm.F90:9022
snow_age
subroutine snow_age(parameters, dt, tg, sneqvo, sneqv, tauss, fage)
Definition module_sf_noahmplsm.F90:3207
tsnosoi
subroutine tsnosoi(parameters, ice,nsoil,nsnow,isnow,ist, tbot,zsnso,ssoil,df,hcpct, sag,dt,snowh,dzsnso, tg,iloc,jloc, ifdef ccpp
compute snow (up to 3l) and soil (4l) temperature. note that snow temperatures during melting season ...
Definition module_sf_noahmplsm.F90:6268
snowwater
subroutine snowwater(parameters, nsnow, nsoil, imelt, dt, zsoil, sfctmp, snowhin, qsnow, qsnfro, qsnsub, qrain, ficeold, iloc, jloc, isnow, snowh, sneqv, snice, snliq, sh2o, sice, stc, zsnso, dzsnso, qsnbot, snoflow, ponding1, ponding2)
Definition module_sf_noahmplsm.F90:7391
garratt_1992
subroutine garratt_1992(zt, zq, z_0, ren, landsea)
data. the formula for land uses a constant ratio (z_0/7.4) taken from garratt (1992).
Definition module_sf_noahmplsm.F90:11075
sfcdif2
subroutine sfcdif2(parameters, iter, z0, thz0, thlm, sfcspd, zlm, iloc, jloc, akms, akhs, rlmo, wstar2, ustar)
calculate surface layer exchange coefficients via iteractive process (Chen et al. 1997,...
Definition module_sf_noahmplsm.F90:5233
albedo
subroutine albedo(parameters, vegtyp, ist, ice, nsoil, dt, cosz, fage, elai, esai, tg, tv, snowh, fsno, fwet, smc, sneqvo, sneqv, qsnow, fveg, iloc, jloc, albold, tauss, albgrd, albgri, albd, albi, fabd, fabi, ftdd, ftid, ftii, fsun, frevi, frevd, fregd, fregi, bgap, wgap, albsnd, albsni)
surface albedos. also fluxes (per unit incoming direct and diffuse radiation) reflected,...
Definition module_sf_noahmplsm.F90:2899
calhum
subroutine calhum(parameters, sfctmp, sfcprs, q2sat, dqsdt2)
Definition module_sf_noahmplsm.F90:6228
zilitinkevich_1995
subroutine zilitinkevich_1995(z_0, zt, zq, restar, ustar, vkc, landsea, iz0tlnd2, spp_pbl, rstoch)
Definition module_sf_noahmplsm.F90:11009
twostream
subroutine twostream(parameters, ib, ic, vegtyp, cosz, vai, fwet, t, albgrd, albgri, rho, tau, fveg, ist, iloc, jloc, fab, fre, ftd, fti, gdir, frev, freg, bgap, wgap)
use two-stream approximation of Dickinson (1983) adv geophysics 25: 305-353 and sellers (1985) int j ...
Definition module_sf_noahmplsm.F90:3447
atm
subroutine atm(parameters, ep_2, epsm1, sfcprs, sfctmp, q2, prcpconv, prcpnonc, prcpshcv, prcpsnow, prcpgrpl, prcphail, soldn, cosz, thair, qair, eair, rhoair, qprecc, qprecl, solad, solai, swdown, bdfall, rain, snow, fp, fpice, prcp)
re-precess atmospheric forcing.
Definition module_sf_noahmplsm.F90:968
radiation
subroutine radiation(parameters, vegtyp, ist, ice, nsoil, sneqvo, sneqv, dt, cosz, snowh, tg, tv, fsno, qsnow, fwet, elai, esai, smc, solad, solai, fveg, iloc, jloc, albold, tauss, fsun, laisun, laisha, parsun, parsha, sav, sag, fsr, fsa, fsrv, fsrg, albd, albi, albsnd, albsni, bgap, wgap)
Calculate solar radiation: absorbed & reflected by the ground and canopy.
Definition module_sf_noahmplsm.F90:2768
co2flux
subroutine co2flux(parameters, nsnow, nsoil, vegtyp, igs, dt, dzsnso, stc, psn, troot, tv, wroot, wstres, foln, lapm, lat, iloc, jloc, fveg, xlai, xsai, lfmass, rtmass, stmass, fastcp, stblcp, wood, gpp, npp, nee, autors, heters, totsc, totlb)
the original code is from Dickinson et al.(1998), modified by guo-yue niu, 2004
Definition module_sf_noahmplsm.F90:9483
thermoprop
subroutine thermoprop(parameters, nsoil, nsnow, isnow, ist, dzsnso, dt, snowh, snice, snliq, shdfac, smc, sh2o, tg, stc, ur, lat, z0m, zlvl, vegtyp, df, hcpct, snicev, snliqv, epore, fact)
Definition module_sf_noahmplsm.F90:2474
noahmp_sflx
subroutine noahmp_sflx(parameters, iloc, jloc, lat, yearlen, julian, cosz, dt, dx, dz8w, nsoil, zsoil, nsnow, shdfac, shdmax, vegtyp, ice, ist, croptype, smceq, sfctmp, sfcprs, psfc, uu, vv, q2, garea1, qc, soldn, lwdn, thsfc_loc, prslkix, prsik1x, prslk1x, pblhx, iz0tlnd, itime,psi_opt, prcpconv, prcpnonc, prcpshcv, prcpsnow, prcpgrpl, prcphail, tbot, co2air, o2air, foln, ficeold, zlvl, ep_1, ep_2, epsm1, cp, albold, sneqvo, stc, sh2o, smc, tah, eah, fwet, canliq, canice, tv, tg, qsfc, qsnow, qrain, isnow, zsnso, snowh, sneqv, snice, snliq, zwt, wa, wt, wslake, lfmass, rtmass, stmass, wood, stblcp, fastcp, lai, sai, cm, ch, tauss, grain, gdd, pgs, smcwtd,deeprech, rech, ustarx, z0wrf, z0hwrf, ts, fsa, fsr, fira, fsh, ssoil, fcev, fgev, fctr, ecan, etran, edir, trad, tgb, tgv, t2mv, t2mb, q2v, q2b, runsrf, runsub, apar, psn, sav, sag, fsno, nee, gpp, npp, fveg, albedo, qsnbot, ponding, ponding1, ponding2, rssun, rssha, albd, albi, albsnd, albsni, bgap, wgap, chv, chb, emissi, shg, shc, shb, evg, evb, ghv, ghb, irg, irc, irb, tr, evc, chleaf, chuc, chv2, chb2, fpice, pahv, pahg, pahb, pah, esnow, canhs, laisun, laisha, rb, qsfcveg, qsfcbare ifdef ccpp
Definition module_sf_noahmplsm.F90:454
compact
subroutine compact(parameters, nsnow, nsoil, dt, stc, snice, snliq, zsoil, imelt, ficeold, iloc, jloc, isnow, dzsnso, zsnso)
Definition module_sf_noahmplsm.F90:7974
wdfcnd2
subroutine wdfcnd2(parameters, wdf, wcnd, smc, sice, isoil)
calculate soil water diffusivity and soil hydraulic conductivity.
Definition module_sf_noahmplsm.F90:8973
ragrb
subroutine ragrb(parameters, iter, vai, rhoair, hg, tah, zpd, z0mg, z0hg, hcan, uc, z0h, fv, cwp, vegtyp, mpe, tv, mozg, fhg, fhgh, iloc, jloc, ramg, rahg, rawg, rb)
compute under-canopy aerodynamic resistance rag and leaf boundary layer resistance rb.
Definition module_sf_noahmplsm.F90:4942
error
subroutine error(parameters, swdown,fsa,fsr,fira,fsh,fcev, fgev,fctr,ssoil,beg_wb,canliq,canice, sneqv,wa,smc,dzsnso,prcp,ecan, etran,edir,runsrf,runsub,dt,nsoil, nsnow,ist,errwat, iloc,jloc,fveg, sav,sag,fsrv,fsrg,zwt,pah, ifdef ccpp
check surface energy balance and water balance.
Definition module_sf_noahmplsm.F90:1469
psn_crop
subroutine psn_crop(parameters, soldn, xlai, t2m, psncrop)
Definition module_sf_noahmplsm.F90:10252
snowh2o
subroutine snowh2o(parameters, nsnow, nsoil, dt, qsnfro, qsnsub, qrain, iloc, jloc, isnow, dzsnso, snowh, sneqv, snice, snliq, sh2o, sice, stc, qsnbot, ponding1, ponding2)
renew the mass of ice lens (snice) and liquid (snliq) of the surface snow layer resulting from sublim...
Definition module_sf_noahmplsm.F90:8085
precip_heat
subroutine precip_heat(parameters, iloc, jloc, vegtyp, dt, uu, vv, elai, esai, fveg, ist, bdfall, rain, snow, fp, canliq, canice, tv, sfctmp, tg, qintr, qdripr, qthror, qints, qdrips, qthros, pahv, pahg, pahb, qrain, qsnow, snowhin, fwet, cmc)
Michael Barlage: Oct 2013 - Split canwater to calculate precip movement for tracking of advected heat...
Definition module_sf_noahmplsm.F90:1238
zwteq
subroutine zwteq(parameters, nsoil, nsnow, zsoil, dzsnso, sh2o, zwt)
calculate equilibrium water table depth (niu et al., 2005)
Definition module_sf_noahmplsm.F90:8506
soilwater
subroutine soilwater(parameters, nsoil, nsnow, dt, zsoil, dzsnso, qinsur, qseva, etrani, sice, iloc, jloc, sh2o, smc, zwt, vegtyp, smcwtd, deeprech, runsrf, qdrain, runsub, wcnd, fcrmax)
calculate surface runoff and soil moisture.
Definition module_sf_noahmplsm.F90:8236
co2flux_crop
subroutine co2flux_crop(parameters, dt, stc, psn, tv, wroot, wstres, foln, ipa, iha, pgs, xlai, xsai, lfmass, rtmass, stmass, fastcp, stblcp, wood, grain, gdd, gpp, npp, nee, autors, heters, totsc, totlb)
the original code from re dickinson et al.(1998) and guo-yue niu (2004), modified by xing liu,...
Definition module_sf_noahmplsm.F90:9876
vege_flux
subroutine vege_flux(parameters, nsnow,nsoil,isnow,vegtyp,veg, dt,sav,sag,lwdn,ur, uu,vv,sfctmp,thair,qair, eair,rhoair,snowh,vai,gammav,gammag, fwet,laisun,laisha,cwp,dzsnso, zlvl,zpd,z0m,fveg,shdfac, z0mg,emv,emg,canliq,fsno, canice,stc,df,rssun,rssha, rsurf,latheav,latheag,parsun,parsha,igs, foln,co2air,o2air,btran,sfcprs, rhsur,iloc,jloc,q2,pahv,pahg, thsfc_loc, prslkix, prsik1x, prslk1x, garea1, pblhx,iz0tlnd,itime,psi_opt,ep_1, ep_2, epsm1, cp, eah,tah,tv,tg,cm, ustarx, ifdef ccpp
use newton-raphson iteration to solve for vegetation (tv) and ground (tg) temperatures that balance t...
Definition module_sf_noahmplsm.F90:3709
thermalz0
subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl, zpd, ezpd, ustarx, vegtyp, vaie, ur, c_sigma_f0, c_sigma_f1, a1, cdmn_v, cdmn_g, surface_flag, z0m_out, z0h_out)
Definition module_sf_noahmplsm.F90:5759
bare_flux
subroutine bare_flux(parameters, nsnow,nsoil,isnow,dt,sag, lwdn,ur,uu,vv,sfctmp, thair,qair,eair,rhoair,snowh, dzsnso,zlvl,zpd,z0m,fsno, emg,stc,df,rsurf,lathea, gamma,rhsur,iloc,jloc,q2,pahb, thsfc_loc, prslkix, prsik1x, prslk1x, vegtyp, fveg, shdfac, garea1, pblhx, iz0tlnd, itime,psi_opt, ep_1, ep_2, epsm1, cp,ifdef ccpp
use newton-raphson iteration to solve ground (tg) temperature that balances the surface energy budget...
Definition module_sf_noahmplsm.F90:4439
stomata
subroutine stomata(parameters, vegtyp, mpe, apar, foln, iloc, jloc, tv, ei, ea, sfctmp, sfcprs, o2, co2, igs, btran, rb, rs, psn)
Definition module_sf_noahmplsm.F90:6005
esat
subroutine esat(t, esw, esi, desw, desi)
use polynomials to calculate saturation vapor pressure and derivative with respect to temperature: ov...
Definition module_sf_noahmplsm.F90:5947
zolri
real *8 function zolri(ri, za, z0, zt, zol1, psi_opt)
Definition module_sf_noahmplsm.F90:11272
wdfcnd1
subroutine wdfcnd1(parameters, wdf, wcnd, smc, fcr, isoil)
calculate soil water diffusivity and soil hydraulic conductivity.
Definition module_sf_noahmplsm.F90:8932
yang_2008
subroutine yang_2008(z_0, zt, zq, ustar, tstar, qst, ren, visc)
this is a modified version of yang et al (2002 qjrms, 2008 jamc) and chen et al (2010,...
Definition module_sf_noahmplsm.F90:11125
psih_stable_full
real *8 function psih_stable_full(zolf)
Definition module_sf_noahmplsm.F90:11518
psim_unstable_full
real *8 function psim_unstable_full(zolf)
Definition module_sf_noahmplsm.F90:11528
li_etal_2010
subroutine li_etal_2010(zl, rib, zaz0, z0zt)
this subroutine returns a more robust z/l that best matches the z/l from hogstrom (1996) for unstable...
Definition module_sf_noahmplsm.F90:11213
psim_stable_full
real *8 function psim_stable_full(zolf)
Definition module_sf_noahmplsm.F90:11508
andreas_2002
subroutine andreas_2002(z_0, bvisc, ustar, zt, zq)
this is taken from andreas (2002; j. of hydromet) and andreas et al. (2005; blm).
Definition module_sf_noahmplsm.F90:11163
psih_unstable_full
real *8 function psih_unstable_full(zolf)
Definition module_sf_noahmplsm.F90:11545
noahmp_parameters
Definition module_sf_noahmplsm.F90:204