CCPP SciDoc v7.0.x  v7.0.0
Common Community Physics Package Developed at DTC
 
Loading...
Searching...
No Matches
module_sf_noahmplsm.F90
1#ifndef CCPP
2#define CCPP
3#endif
4
6
8module module_sf_noahmplsm
9#ifndef CCPP
10 use module_wrf_utl
11#endif
12use machine , only : kind_phys
13
14 implicit none
15
16 public :: noahmp_options
17 public :: noahmp_sflx
18 public :: sfcdif4
19 public :: psi_init
20
21
22 private :: atm
23 private :: phenology
24 private :: precip_heat
25 private :: energy
26 private :: thermoprop
27 private :: csnow
28 private :: tdfcnd
29 private :: radiation
30 private :: albedo
31 private :: snow_age
32 private :: snowalb_bats
33 private :: snowalb_class
34 private :: groundalb
35 private :: twostream
36 private :: surrad
37 private :: vege_flux
38 private :: sfcdif1
39 private :: sfcdif2
40 private :: stomata
41 private :: canres
42 private :: esat
43 private :: ragrb
44 private :: bare_flux
45 private :: tsnosoi
46 private :: hrt
47 private :: hstep
48 private :: rosr12
49 private :: phasechange
50 private :: frh2o
51
52 private :: water
53 private :: canwater
54 private :: snowwater
55 private :: snowfall
56 private :: combine
57 private :: divide
58 private :: combo
59 private :: compact
60 private :: snowh2o
61 private :: soilwater
62 private :: zwteq
63 private :: infil
64 private :: srt
65 private :: wdfcnd1
66 private :: wdfcnd2
67 private :: sstep
68 private :: groundwater
69 private :: shallowwatertable
70
71 private :: carbon
72 private :: co2flux
73! private :: bvocflux
74! private :: ch4flux
75
76 private :: error
77
78! =====================================options for different schemes================================
79! **recommended
80
81 integer :: dveg
82 ! 1 -> off (use table lai; use fveg = shdfac from input)
83 ! 2 -> on (together with opt_crs = 1)
84 ! 3 -> off (use table lai; calculate fveg)
85 ! **4 -> off (use table lai; use maximum vegetation fraction)
86 ! **5 -> on (use maximum vegetation fraction)
87 ! 6 -> on (use FVEG = SHDFAC from input)
88 ! 7 -> off (use input LAI; use FVEG = SHDFAC from input)
89 ! 8 -> off (use input LAI; calculate FVEG)
90 ! 9 -> off (use input LAI; use maximum vegetation fraction)
91 ! 10 -> crop model on (use maximum vegetation fraction)
92
93 integer :: opt_crs
94 ! **1 -> ball-berry
95 ! 2 -> jarvis
96
97 integer :: opt_btr
98 ! **1 -> noah (soil moisture)
99 ! 2 -> clm (matric potential)
100 ! 3 -> ssib (matric potential)
101
102 integer :: opt_run
103 ! **1 -> topmodel with groundwater (niu et al. 2007 jgr) ;
104 ! 2 -> topmodel with an equilibrium water table (niu et al. 2005 jgr) ;
105 ! 3 -> original surface and subsurface runoff (free drainage)
106 ! 4 -> bats surface and subsurface runoff (free drainage)
107 ! 5 -> miguez-macho&fan groundwater scheme (miguez-macho et al. 2007 jgr; fan et al. 2007 jgr)
108 ! (needs further testing for public use)
109
110 integer :: opt_sfc
111 ! **1 -> m-o
112 ! **2 -> original noah (chen97)
113 ! **3 -> myj consistent; 4->ysu consistent. mb: removed in v3.7 for further testing
114
115 integer :: opt_frz
116 ! **1 -> no iteration (niu and yang, 2006 jhm)
117 ! 2 -> koren's iteration
118
119 integer :: opt_inf
120 ! **1 -> linear effects, more permeable (niu and yang, 2006, jhm)
121 ! 2 -> nonlinear effects, less permeable (old)
122
123 integer :: opt_rad
124 ! 1 -> modified two-stream (gap = f(solar angle, 3d structure ...)<1-fveg)
125 ! 2 -> two-stream applied to grid-cell (gap = 0)
126 ! **3 -> two-stream applied to vegetated fraction (gap=1-fveg)
127
128 integer :: opt_alb
129 ! 1 -> bats
130 ! **2 -> class
131
132 integer :: opt_snf
133 ! **1 -> jordan (1991)
134 ! 2 -> bats: when sfctmp<tfrz+2.2
135 ! 3 -> sfctmp < tfrz
136 ! 4 -> use wrf microphysics output
137
138 integer :: opt_tbot
139 ! 1 -> zero heat flux from bottom (zbot and tbot not used)
140 ! **2 -> tbot at zbot (8m) read from a file (original noah)
141
142 integer :: opt_stc
143 ! **1 -> semi-implicit; flux top boundary condition
144 ! 2 -> full implicit (original noah); temperature top boundary condition
145 ! 3 -> same as 1, but fsno for ts calculation (generally improves snow; v3.7)
146
147 integer :: opt_rsf
148 ! **1 -> sakaguchi and zeng, 2009
149 ! 2 -> sellers (1992)
150 ! 3 -> adjusted sellers to decrease rsurf for wet soil
151 ! 4 -> option 1 for non-snow; rsurf = rsurf_snow for snow (set in mptable); ad v3.8
152
153 integer :: opt_soil
154 ! **1 -> use input dominant soil texture
155 ! 2 -> use input soil texture that varies with depth
156 ! 3 -> use soil composition (sand, clay, orgm) and pedotransfer functions (opt_pedo)
157 ! 4 -> use input soil properties (bexp_3d, smcmax_3d, etc.)
158
159 integer :: opt_pedo
160 ! **1 -> saxton and rawls (2006)
161
162 integer :: opt_crop
163 ! **0 -> no crop model, will run default dynamic vegetation
164 ! 1 -> liu, et al. 2016
165
166 integer :: opt_trs
167 ! **1 -> z0h=z0m
168 ! 2 -> czil = f(canopy height) from Chen09
169 ! 3 -> ec style from TESSEL
170 ! 4 -> kb inverse from Blumel99
171 integer :: opt_diag
172 ! 1 -> external GFS sfc_diag
173 ! **2 -> original NoahMP 2-title
174 ! 3 -> NoahMP 2-title + internal GFS sfc_diag
175
176 integer :: opt_z0m
177 ! **1 -> use z0m from MPTABLE
178 ! 2 -> z0m = f(canopy height, LAI/SAI)
179
180!------------------------------------------------------------------------------------------!
181! physical constants: !
182!------------------------------------------------------------------------------------------!
183
184 real (kind=kind_phys), parameter :: grav = 9.80616
185 real (kind=kind_phys), parameter :: sb = 5.67e-08
186 real (kind=kind_phys), parameter :: vkc = 0.40
187 real (kind=kind_phys), parameter :: tfrz = 273.16
188 real (kind=kind_phys), parameter :: hsub = 2.8440e06
189 real (kind=kind_phys), parameter :: hvap = 2.5104e06
190 real (kind=kind_phys), parameter :: hfus = 0.3336e06
191 real (kind=kind_phys), parameter :: cwat = 4.188e06
192 real (kind=kind_phys), parameter :: cice = 2.094e06
193 real (kind=kind_phys), parameter :: cpair = 1004.64
194 real (kind=kind_phys), parameter :: tkwat = 0.6
195 real (kind=kind_phys), parameter :: tkice = 2.2
196 real (kind=kind_phys), parameter :: tkair = 0.023
197 real (kind=kind_phys), parameter :: rair = 287.04
198 real (kind=kind_phys), parameter :: rw = 461.269
199 real (kind=kind_phys), parameter :: denh2o = 1000.
200 real (kind=kind_phys), parameter :: denice = 917.
201
202 integer, private, parameter :: mband = 2
203 integer, private, parameter :: nsoil = 4
204 integer, private, parameter :: nstage = 8
205
206 type noahmp_parameters ! define a noahmp parameters type
207
208!------------------------------------------------------------------------------------------!
209! from the veg section of mptable.tbl
210!------------------------------------------------------------------------------------------!
211
212 logical :: urban_flag
213 integer :: iswater
214 integer :: isbarren
215 integer :: isice
216 integer :: iscrop
217 integer :: eblforest
218
219 real (kind=kind_phys) :: ch2op
220 real (kind=kind_phys) :: dleaf
221 real (kind=kind_phys) :: z0mvt
222 real (kind=kind_phys) :: hvt
223 real (kind=kind_phys) :: hvb
224 real (kind=kind_phys) :: z0mhvt
225 real (kind=kind_phys) :: den
226 real (kind=kind_phys) :: rc
227 real (kind=kind_phys) :: mfsno
228 real (kind=kind_phys) :: scffac
229 real (kind=kind_phys) :: cbiom
230 real (kind=kind_phys) :: saim(12)
231 real (kind=kind_phys) :: laim(12)
232 real (kind=kind_phys) :: sla
233 real (kind=kind_phys) :: prcpiceden
234 real (kind=kind_phys) :: dilefc
235 real (kind=kind_phys) :: dilefw
236 real (kind=kind_phys) :: fragr
237 real (kind=kind_phys) :: ltovrc
238
239 real (kind=kind_phys) :: c3psn
240 real (kind=kind_phys) :: kc25
241 real (kind=kind_phys) :: akc
242 real (kind=kind_phys) :: ko25
243 real (kind=kind_phys) :: ako
244 real (kind=kind_phys) :: vcmx25
245 real (kind=kind_phys) :: avcmx
246 real (kind=kind_phys) :: bp
247 real (kind=kind_phys) :: mp
248 real (kind=kind_phys) :: qe25
249 real (kind=kind_phys) :: aqe
250 real (kind=kind_phys) :: rmf25
251 real (kind=kind_phys) :: rms25
252 real (kind=kind_phys) :: rmr25
253 real (kind=kind_phys) :: arm
254 real (kind=kind_phys) :: folnmx
255 real (kind=kind_phys) :: tmin
256
257 real (kind=kind_phys) :: xl
258 real (kind=kind_phys) :: rhol(mband)
259 real (kind=kind_phys) :: rhos(mband)
260 real (kind=kind_phys) :: taul(mband)
261 real (kind=kind_phys) :: taus(mband)
262
263 real (kind=kind_phys) :: mrp
264 real (kind=kind_phys) :: cwpvt
265
266 real (kind=kind_phys) :: wrrat
267 real (kind=kind_phys) :: wdpool
268 real (kind=kind_phys) :: tdlef
269
270 integer :: nroot
271 real (kind=kind_phys) :: rgl
272 real (kind=kind_phys) :: rsmin
273 real (kind=kind_phys) :: hs
274 real (kind=kind_phys) :: topt
275 real (kind=kind_phys) :: rsmax
276
277 real (kind=kind_phys) :: slarea
278 real (kind=kind_phys) :: eps(5)
279
280!------------------------------------------------------------------------------------------!
281! from the rad section of mptable.tbl
282!------------------------------------------------------------------------------------------!
283
284 real (kind=kind_phys) :: albsat(mband)
285 real (kind=kind_phys) :: albdry(mband)
286 real (kind=kind_phys) :: albice(mband)
287 real (kind=kind_phys) :: alblak(mband)
288 real (kind=kind_phys) :: omegas(mband)
289 real (kind=kind_phys) :: betads
290 real (kind=kind_phys) :: betais
291 real (kind=kind_phys) :: eg(2)
292
293!------------------------------------------------------------------------------------------!
294! from the globals section of mptable.tbl
295!------------------------------------------------------------------------------------------!
296
297 real (kind=kind_phys) :: co2
298 real (kind=kind_phys) :: o2
299 real (kind=kind_phys) :: timean
300 real (kind=kind_phys) :: fsatmx
301 real (kind=kind_phys) :: z0sno
302 real (kind=kind_phys) :: ssi
303 real (kind=kind_phys) :: snow_ret_fac
304 real (kind=kind_phys) :: swemx
305 real (kind=kind_phys) :: snow_emis
306 real (kind=kind_phys) :: tau0
307 real (kind=kind_phys) :: grain_growth
308 real (kind=kind_phys) :: extra_growth
309 real (kind=kind_phys) :: dirt_soot
310 real (kind=kind_phys) :: bats_cosz
311 real (kind=kind_phys) :: bats_vis_new
312 real (kind=kind_phys) :: bats_nir_new
313 real (kind=kind_phys) :: bats_vis_age
314 real (kind=kind_phys) :: bats_nir_age
315 real (kind=kind_phys) :: bats_vis_dir
316 real (kind=kind_phys) :: bats_nir_dir
317 real (kind=kind_phys) :: rsurf_snow
318 real (kind=kind_phys) :: rsurf_exp
319
320!------------------------------------------------------------------------------------------!
321! from the crop section of mptable.tbl
322!------------------------------------------------------------------------------------------!
323
324 integer :: pltday
325 integer :: hsday
326 real (kind=kind_phys) :: plantpop
327 real (kind=kind_phys) :: irri
328 real (kind=kind_phys) :: gddtbase
329 real (kind=kind_phys) :: gddtcut
330 real (kind=kind_phys) :: gdds1
331 real (kind=kind_phys) :: gdds2
332 real (kind=kind_phys) :: gdds3
333 real (kind=kind_phys) :: gdds4
334 real (kind=kind_phys) :: gdds5
335 integer :: c3c4
336 real (kind=kind_phys) :: aref
337 real (kind=kind_phys) :: psnrf
338 real (kind=kind_phys) :: i2par
339 real (kind=kind_phys) :: tassim0
340 real (kind=kind_phys) :: tassim1
341 real (kind=kind_phys) :: tassim2
342 real (kind=kind_phys) :: k
343 real (kind=kind_phys) :: epsi
344 real (kind=kind_phys) :: q10mr
345 real (kind=kind_phys) :: foln_mx
346 real (kind=kind_phys) :: lefreez
347 real (kind=kind_phys) :: dile_fc(nstage)
348 real (kind=kind_phys) :: dile_fw(nstage)
349 real (kind=kind_phys) :: fra_gr
350 real (kind=kind_phys) :: lf_ovrc(nstage)
351 real (kind=kind_phys) :: st_ovrc(nstage)
352 real (kind=kind_phys) :: rt_ovrc(nstage)
353 real (kind=kind_phys) :: lfmr25
354 real (kind=kind_phys) :: stmr25
355 real (kind=kind_phys) :: rtmr25
356 real (kind=kind_phys) :: grainmr25
357 real (kind=kind_phys) :: lfpt(nstage)
358 real (kind=kind_phys) :: stpt(nstage)
359 real (kind=kind_phys) :: rtpt(nstage)
360 real (kind=kind_phys) :: grainpt(nstage)
361 real (kind=kind_phys) :: bio2lai
362
363!------------------------------------------------------------------------------------------!
364! from the soilparm.tbl tables, as functions of soil category.
365!------------------------------------------------------------------------------------------!
366 real (kind=kind_phys) :: bexp(nsoil)
367 real (kind=kind_phys) :: smcdry(nsoil)
368 !layer ends (volumetric) (not used mb: 20140718)
369 real (kind=kind_phys) :: smcwlt(nsoil)
370 real (kind=kind_phys) :: smcref(nsoil)
371 real (kind=kind_phys) :: smcmax(nsoil)
372 real (kind=kind_phys) :: psisat(nsoil)
373 real (kind=kind_phys) :: dksat(nsoil)
374 real (kind=kind_phys) :: dwsat(nsoil)
375 real (kind=kind_phys) :: quartz(nsoil)
376 real (kind=kind_phys) :: f1
377!------------------------------------------------------------------------------------------!
378! from the genparm.tbl file
379!------------------------------------------------------------------------------------------!
380 real (kind=kind_phys) :: slope
381 real (kind=kind_phys) :: csoil
382 real (kind=kind_phys) :: zbot
383 real (kind=kind_phys) :: czil
384 real (kind=kind_phys) :: refdk
385 real (kind=kind_phys) :: refkdt
386
387 real (kind=kind_phys) :: kdt
388 real (kind=kind_phys) :: frzx
389
390 end type noahmp_parameters
391
392!
393! for sfcdif4
394!
395 real(kind=kind_phys), parameter :: prt=1. !prandtl number
396 real(kind=kind_phys), parameter :: p1000mb = 100000.
397
398 real(kind=kind_phys), parameter :: svp1 = 0.6112
399 real(kind=kind_phys), parameter :: svp2 = 17.67
400 real(kind=kind_phys), parameter :: svp3 = 29.65
401 real(kind=kind_phys), parameter :: svpt0 = 273.15
402 real(kind=kind_phys), parameter :: onethird = 1./3.
403 real(kind=kind_phys), parameter :: sqrt3 = 1.7320508075688773
404 real(kind=kind_phys), parameter :: atan1 = 0.785398163397 !in radians
405
406 real(kind=kind_phys), parameter :: vconvc=1.25
407
408 real(kind=kind_phys), parameter :: snowz0 = 0.011
409 real(kind=kind_phys), parameter :: wmin = 0.1
410
411 real(kind=kind_phys), dimension(0:1000 ),save :: psim_stab,psim_unstab, &
412 psih_stab,psih_unstab
413
414
415contains
416!
417!== begin noahmp_sflx ==============================================================================
418
421 subroutine noahmp_sflx (parameters, &
422 iloc , jloc , lat , yearlen , julian , cosz , & ! in : time/space-related
423 dt , dx , dz8w , nsoil , zsoil , nsnow , & ! in : model configuration
424 shdfac , shdmax , vegtyp , ice , ist , croptype, & ! in : vegetation/soil characteristics
425 smceq , & ! in : vegetation/soil characteristics
426 sfctmp , sfcprs , psfc , uu , vv , q2, garea1 , & ! in : forcing
427 qc , soldn , lwdn,thsfc_loc, prslkix,prsik1x,prslk1x,& ! in : forcing
428 pblhx , iz0tlnd , itime ,psi_opt ,&
429 prcpconv, prcpnonc, prcpshcv, prcpsnow, prcpgrpl, prcphail, & ! in : forcing
430 tbot , co2air , o2air , foln , ficeold , zlvl , & ! in : forcing
431 ep_1 , ep_2 , epsm1 , cp , & ! in : constants
432 albold , sneqvo , & ! in/out :
433 stc , sh2o , smc , tah , eah , fwet , & ! in/out :
434 canliq , canice , tv , tg , qsfc, qsnow, qrain, & ! in/out :
435 isnow , zsnso , snowh , sneqv , snice , snliq , & ! in/out :
436 zwt , wa , wt , wslake , lfmass , rtmass , & ! in/out :
437 stmass , wood , stblcp , fastcp , lai , sai , & ! in/out :
438 cm , ch , tauss , & ! in/out :
439 grain , gdd , pgs , & ! in/out
440 smcwtd ,deeprech , rech , ustarx , & ! in/out :
441 z0wrf , z0hwrf , ts , & ! out :
442 fsa , fsr , fira , fsh , ssoil , fcev , & ! out :
443 fgev , fctr , ecan , etran , edir , trad , & ! out :
444 tgb , tgv , t2mv , t2mb , q2v , q2b , & ! out :
445 runsrf , runsub , apar , psn , sav , sag , & ! out :
446 fsno , nee , gpp , npp , fveg , albedo , & ! out :
447 qsnbot , ponding , ponding1, ponding2, rssun , rssha , & ! out :
448 albd , albi , albsnd , albsni , & ! out :
449 bgap , wgap , chv , chb , emissi , & ! out :
450 shg , shc , shb , evg , evb , ghv , & ! out :
451 ghb , irg , irc , irb , tr , evc , & ! out :
452 chleaf , chuc , chv2 , chb2 , fpice , pahv , &
453 pahg , pahb , pah , esnow , canhs , laisun , &
454 laisha , rb , qsfcveg , qsfcbare &
455#ifdef CCPP
456 ,errmsg, errflg)
457#else
458 )
459#endif
460
461! --------------------------------------------------------------------------------------------------
462! initial code: guo-yue niu, oct. 2007
463! --------------------------------------------------------------------------------------------------
464
465 implicit none
466! --------------------------------------------------------------------------------------------------
467! input
468 type (noahmp_parameters), intent(in) :: parameters
469
470 integer , intent(in) :: ice
471 integer , intent(in) :: ist
472 integer , intent(in) :: vegtyp
473 INTEGER , INTENT(IN) :: CROPTYPE
474 integer , intent(in) :: nsnow
475 integer , intent(in) :: nsoil
476 integer , intent(in) :: iloc
477 integer , intent(in) :: jloc
478 real (kind=kind_phys) , intent(in) :: ep_1
479 real (kind=kind_phys) , intent(in) :: ep_2
480 real (kind=kind_phys) , intent(in) :: epsm1
481 real (kind=kind_phys) , intent(in) :: cp
482 real (kind=kind_phys) , intent(in) :: dt
483 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil
484 real (kind=kind_phys) , intent(in) :: q2
485 real (kind=kind_phys) , intent(in) :: sfctmp
486 real (kind=kind_phys) , intent(in) :: uu
487 real (kind=kind_phys) , intent(in) :: vv
488 real (kind=kind_phys) , intent(in) :: soldn
489 real (kind=kind_phys) , intent(in) :: lwdn
490 real (kind=kind_phys) , intent(in) :: sfcprs
491
492 logical , intent(in) :: thsfc_loc
493 real (kind=kind_phys) , intent(in) :: prslkix
494 real (kind=kind_phys) , intent(in) :: prsik1x
495 real (kind=kind_phys) , intent(in) :: prslk1x
496 real (kind=kind_phys) , intent(in) :: garea1
497
498 real (kind=kind_phys) , intent(in) :: pblhx
499 integer , intent(in) :: iz0tlnd
500 integer , intent(in) :: itime
501 integer , intent(in) :: psi_opt
502
503 real (kind=kind_phys) , intent(inout) :: zlvl
504 real (kind=kind_phys) , intent(in) :: cosz
505 real (kind=kind_phys) , intent(in) :: tbot
506 real (kind=kind_phys) , intent(in) :: foln
507 real (kind=kind_phys) , intent(in) :: shdfac
508 integer , intent(in) :: yearlen
509 real (kind=kind_phys) , intent(in) :: julian
510 real (kind=kind_phys) , intent(in) :: lat
511 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: ficeold
512 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smceq
513 real (kind=kind_phys) , intent(in) :: prcpconv
514 real (kind=kind_phys) , intent(in) :: prcpnonc
515 real (kind=kind_phys) , intent(in) :: prcpshcv
516 real (kind=kind_phys) , intent(in) :: prcpsnow
517 real (kind=kind_phys) , intent(in) :: prcpgrpl
518 real (kind=kind_phys) , intent(in) :: prcphail
519
520!jref:start; in
521 real (kind=kind_phys) , intent(in) :: qc
522 real (kind=kind_phys) , intent(inout) :: qsfc
523 real (kind=kind_phys) , intent(in) :: psfc
524 real (kind=kind_phys) , intent(in) :: dz8w
525 real (kind=kind_phys) , intent(in) :: dx
526 real (kind=kind_phys) , intent(in) :: shdmax
527!jref:end
528
529
530! input/output : need arbitary intial values
531 real (kind=kind_phys) , intent(inout) :: qsnow
532 REAL (kind=kind_phys) , INTENT(INOUT) :: qrain
533 real (kind=kind_phys) , intent(inout) :: fwet
534 real (kind=kind_phys) , intent(inout) :: sneqvo
535 real (kind=kind_phys) , intent(inout) :: eah
536 real (kind=kind_phys) , intent(inout) :: tah
537 real (kind=kind_phys) , intent(inout) :: albold
538 real (kind=kind_phys) , intent(inout) :: cm
539 real (kind=kind_phys) , intent(inout) :: ch
540 real (kind=kind_phys) , intent(inout) :: tauss
541 real (kind=kind_phys) , intent(inout) :: ustarx
542
543! prognostic variables
544 integer , intent(inout) :: isnow
545 real (kind=kind_phys) , intent(inout) :: canliq
546 real (kind=kind_phys) , intent(inout) :: canice
547 real (kind=kind_phys) , intent(inout) :: sneqv
548 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: smc
549 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: zsnso
550 real (kind=kind_phys) , intent(inout) :: snowh
551 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snice
552 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snliq
553 real (kind=kind_phys) , intent(inout) :: tv
554 real (kind=kind_phys) , intent(inout) :: tg
555 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
556 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sh2o
557 real (kind=kind_phys) , intent(inout) :: zwt
558 real (kind=kind_phys) , intent(inout) :: wa
559 real (kind=kind_phys) , intent(inout) :: wt
560 real (kind=kind_phys) , intent(inout) :: wslake
561 real (kind=kind_phys), intent(inout) :: smcwtd
562 real (kind=kind_phys), intent(inout) :: deeprech
563 real (kind=kind_phys), intent(inout) :: rech
564
565! output
566 real (kind=kind_phys) , intent(out) :: z0wrf
567 real (kind=kind_phys) , intent(out) :: z0hwrf
568 real (kind=kind_phys) , intent(out) :: fsa
569 real (kind=kind_phys) , intent(out) :: fsr
570 real (kind=kind_phys) , intent(out) :: fira
571 real (kind=kind_phys) , intent(out) :: fsh
572 real (kind=kind_phys) , intent(out) :: fcev
573 real (kind=kind_phys) , intent(out) :: fgev
574 real (kind=kind_phys) , intent(out) :: fctr
575 real (kind=kind_phys) , intent(out) :: ssoil
576 real (kind=kind_phys) , intent(out) :: trad
577 real (kind=kind_phys) , intent(out) :: ts
578 real (kind=kind_phys) , intent(out) :: ecan
579 real (kind=kind_phys) , intent(out) :: etran
580 real (kind=kind_phys) , intent(out) :: edir
581 real (kind=kind_phys) , intent(out) :: runsrf
582 real (kind=kind_phys) , intent(out) :: runsub
583 real (kind=kind_phys) , intent(out) :: psn
584 real (kind=kind_phys) , intent(out) :: apar
585 real (kind=kind_phys) , intent(out) :: sav
586 real (kind=kind_phys) , intent(out) :: sag
587 real (kind=kind_phys) , intent(out) :: fsno
588 real (kind=kind_phys) , intent(out) :: fveg
589 real (kind=kind_phys) , intent(out) :: albedo
590 real (kind=kind_phys) :: errwat
591 real (kind=kind_phys) , intent(out) :: qsnbot
592 real (kind=kind_phys) , intent(out) :: ponding
593 real (kind=kind_phys) , intent(out) :: ponding1
594 real (kind=kind_phys) , intent(out) :: ponding2
595 real (kind=kind_phys) , intent(out) :: esnow
596 real (kind=kind_phys) , intent(out) :: rb
597 real (kind=kind_phys) , intent(out) :: laisun
598 real (kind=kind_phys) , intent(out) :: laisha
599 real (kind=kind_phys) , intent(out) :: qsfcveg
600 real (kind=kind_phys) , intent(out) :: qsfcbare
601
602!jref:start; output
603 real (kind=kind_phys) , intent(out) :: t2mv
604 real (kind=kind_phys) , intent(out) :: t2mb
605 real (kind=kind_phys), intent(out) :: rssun
606 real (kind=kind_phys), intent(out) :: rssha
607 real (kind=kind_phys), intent(out) :: bgap
608 real (kind=kind_phys), intent(out) :: wgap
609 real (kind=kind_phys), dimension(1:2) , intent(out) :: albd
610 real (kind=kind_phys), dimension(1:2) , intent(out) :: albi
611 real (kind=kind_phys), dimension(1:2) , intent(out) :: albsnd
612 real (kind=kind_phys), dimension(1:2) , intent(out) :: albsni
613 real (kind=kind_phys), intent(out) :: tgv
614 real (kind=kind_phys), intent(out) :: tgb
615 real (kind=kind_phys) :: q1
616 real (kind=kind_phys), intent(out) :: emissi
617!jref:end
618#ifdef CCPP
619 character(len=*), intent(inout) :: errmsg
620 integer, intent(inout) :: errflg
621#endif
622
623! local
624 integer :: iz
625 integer, dimension(-nsnow+1:nsoil) :: imelt
626 real (kind=kind_phys) :: cmc
627 real (kind=kind_phys) :: taux
628 real (kind=kind_phys) :: tauy
629 real (kind=kind_phys) :: rhoair
630! real (kind=kind_phys), dimension( 1: 5) :: vocflx !< voc fluxes [ug c m-2 h-1]
631 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: dzsnso
632 real (kind=kind_phys) :: thair
633 real (kind=kind_phys) :: qair
634 real (kind=kind_phys) :: eair
635 real (kind=kind_phys), dimension( 1: 2) :: solad
636 real (kind=kind_phys), dimension( 1: 2) :: solai
637 real (kind=kind_phys) :: qprecc
638 real (kind=kind_phys) :: qprecl
639 real (kind=kind_phys) :: igs
640 real (kind=kind_phys) :: elai
641 real (kind=kind_phys) :: esai
642 real (kind=kind_phys) :: bevap
643 real (kind=kind_phys), dimension( 1:nsoil) :: btrani
644 real (kind=kind_phys) :: btran
645 real (kind=kind_phys) :: qin
646 real (kind=kind_phys) :: qdis
647 real (kind=kind_phys), dimension( 1:nsoil) :: sice
648 real (kind=kind_phys), dimension(-nsnow+1: 0) :: snicev
649 real (kind=kind_phys), dimension(-nsnow+1: 0) :: snliqv
650 real (kind=kind_phys), dimension(-nsnow+1: 0) :: epore
651 real (kind=kind_phys) :: totsc
652 real (kind=kind_phys) :: totlb
653 real (kind=kind_phys) :: t2m
654 real (kind=kind_phys) :: qdew
655 real (kind=kind_phys) :: qvap
656 real (kind=kind_phys) :: lathea
657 real (kind=kind_phys) :: swdown
658 real (kind=kind_phys) :: qmelt
659 real (kind=kind_phys) :: beg_wb
660 real (kind=kind_phys),intent(out) :: irc
661 real (kind=kind_phys),intent(out) :: irg
662 real (kind=kind_phys),intent(out) :: shc
663 real (kind=kind_phys),intent(out) :: shg
664 real (kind=kind_phys),intent(out) :: evg
665 real (kind=kind_phys),intent(out) :: ghv
666 real (kind=kind_phys),intent(out) :: irb
667 real (kind=kind_phys),intent(out) :: shb
668 real (kind=kind_phys),intent(out) :: evb
669 real (kind=kind_phys),intent(out) :: ghb
670 real (kind=kind_phys),intent(out) :: evc
671 real (kind=kind_phys),intent(out) :: tr
672 real (kind=kind_phys), intent(out) :: fpice
673 real (kind=kind_phys), intent(out) :: pahv
674 real (kind=kind_phys), intent(out) :: pahg
675 real (kind=kind_phys), intent(out) :: pahb
676 real (kind=kind_phys), intent(out) :: pah
677
678!jref:start
679 real (kind=kind_phys) :: fsrv
680 real (kind=kind_phys) :: fsrg
681 real (kind=kind_phys),intent(out) :: q2v
682 real (kind=kind_phys),intent(out) :: q2b
683 real (kind=kind_phys) :: q2e
684 real (kind=kind_phys) :: qfx
685 real (kind=kind_phys),intent(out) :: chv
686 real (kind=kind_phys),intent(out) :: chb
687 real (kind=kind_phys),intent(out) :: chleaf
688 real (kind=kind_phys),intent(out) :: chuc
689 real (kind=kind_phys),intent(out) :: chv2
690 real (kind=kind_phys),intent(out) :: chb2
691!jref:end
692
693! carbon
694! inputs
695 real (kind=kind_phys) , intent(in) :: co2air
696 real (kind=kind_phys) , intent(in) :: o2air
697
698! inputs and outputs : prognostic variables
699 real (kind=kind_phys) , intent(inout) :: lfmass
700 real (kind=kind_phys) , intent(inout) :: rtmass
701 real (kind=kind_phys) , intent(inout) :: stmass
702 real (kind=kind_phys) , intent(inout) :: wood
703 real (kind=kind_phys) , intent(inout) :: stblcp
704 real (kind=kind_phys) , intent(inout) :: fastcp
705 real (kind=kind_phys) , intent(inout) :: lai
706 real (kind=kind_phys) , intent(inout) :: sai
707 real (kind=kind_phys) , intent(inout) :: grain
708 real (kind=kind_phys) , intent(inout) :: gdd
709 integer , intent(inout) :: pgs
710
711! outputs
712 real (kind=kind_phys) , intent(out) :: nee
713 real (kind=kind_phys) , intent(out) :: gpp
714 real (kind=kind_phys) , intent(out) :: npp
715 real (kind=kind_phys) :: autors
716 real (kind=kind_phys) :: heters
717 real (kind=kind_phys) :: troot
718 real (kind=kind_phys) :: bdfall
719 real (kind=kind_phys) :: rain
720 real (kind=kind_phys) :: snow
721 real (kind=kind_phys) :: fp ! mb/an: v3.7
722 real (kind=kind_phys) :: prcp ! mb/an: v3.7
723!more local variables for precip heat mb
724 real (kind=kind_phys) :: qintr
725 real (kind=kind_phys) :: qdripr
726 real (kind=kind_phys) :: qthror
727 real (kind=kind_phys) :: qints
728 real (kind=kind_phys) :: qdrips
729 real (kind=kind_phys) :: qthros
730 real (kind=kind_phys) :: snowhin
731 real (kind=kind_phys) :: latheav
732 real (kind=kind_phys) :: latheag
733 logical :: frozen_ground
734 logical :: frozen_canopy
735 logical :: dveg_active
736 logical :: crop_active
737! add canopy heat storage (C.He added based on GY Niu's communication)
738 real (kind=kind_phys) , intent(out) :: canhs ! canopy heat storage change w/m2
739
740 ! intent (out) variables need to be assigned a value. these normally get assigned values
741 ! only if dveg == 2.
742 nee = 0.0
743 npp = 0.0
744 gpp = 0.0
745 pahv = 0.
746 pahg = 0.
747 pahb = 0.
748 pah = 0.
749 canhs = 0.
750
751! --------------------------------------------------------------------------------------------------
752! re-process atmospheric forcing
753
754 call atm (parameters,ep_2, epsm1, sfcprs ,sfctmp ,q2 , &
755 prcpconv, prcpnonc,prcpshcv,prcpsnow,prcpgrpl,prcphail, &
756 soldn ,cosz ,thair ,qair , &
757 eair ,rhoair ,qprecc ,qprecl ,solad ,solai , &
758 swdown ,bdfall ,rain ,snow ,fp ,fpice , prcp )
759
760! snow/soil layer thickness (m)
761
762 do iz = isnow+1, nsoil
763 if(iz == isnow+1) then
764 dzsnso(iz) = - zsnso(iz)
765 else
766 dzsnso(iz) = zsnso(iz-1) - zsnso(iz)
767 end if
768 end do
769
770! root-zone temperature
771
772 troot = 0.
773 do iz=1,parameters%nroot
774 troot = troot + stc(iz)*dzsnso(iz)/(-zsoil(parameters%nroot))
775 enddo
776
777! total water storage for water balance check
778
779 if(ist == 1) then
780 beg_wb = canliq + canice + sneqv + wa
781 do iz = 1,nsoil
782 beg_wb = beg_wb + smc(iz) * dzsnso(iz) * 1000.
783 end do
784 end if
785
786! vegetation phenology
787
788 call phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in
789 lai , sai , troot , elai , esai ,igs, pgs)
790
791!input gvf should be consistent with lai
792 if(dveg == 1 .or. dveg == 6 .or. dveg == 7) then
793 fveg = shdfac
794 if(fveg <= 0.05) fveg = 0.05
795 else if (dveg == 2 .or. dveg == 3 .or. dveg == 8) then
796 fveg = 1.-exp(-0.52*(lai+sai))
797 if(fveg <= 0.05) fveg = 0.05
798 else if (dveg == 4 .or. dveg == 5 .or. dveg == 9) then
799 fveg = shdmax
800 if(fveg <= 0.05) fveg = 0.05
801 else
802 write(*,*) "-------- fatal called in sflx -----------"
803#ifdef CCPP
804 errflg = 1
805 errmsg = "namelist parameter dveg unknown"
806 return
807#else
808 call wrf_error_fatal("namelist parameter dveg unknown")
809#endif
810 endif
811 if(opt_crop > 0 .and. croptype > 0) then
812 fveg = shdmax
813 if(fveg <= 0.05) fveg = 0.05
814 endif
815 if(parameters%urban_flag .or. vegtyp == parameters%isbarren) fveg = 0.0
816 if(elai+esai == 0.0) fveg = 0.0
817
818 call precip_heat(parameters,iloc ,jloc ,vegtyp ,dt ,uu ,vv , & !in
819 elai ,esai ,fveg ,ist , & !in
820 bdfall ,rain ,snow ,fp , & !in
821 canliq ,canice ,tv ,sfctmp ,tg , & !in
822 qintr ,qdripr ,qthror ,qints ,qdrips ,qthros , & !out
823 pahv ,pahg ,pahb ,qrain ,qsnow ,snowhin, & !out
824 fwet ,cmc ) !out
825
826! compute energy budget (momentum & energy fluxes and phase changes)
827
828 call energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in
829 isnow ,dt ,rhoair ,sfcprs ,qair , & !in
830 sfctmp ,thair ,lwdn ,uu ,vv ,zlvl , & !in
831 co2air ,o2air ,solad ,solai ,cosz ,igs , & !in
832 eair ,tbot ,zsnso ,zsoil , & !in
833 elai ,esai ,fwet ,foln , & !in
834 fveg ,shdfac, pahv ,pahg ,pahb , & !in
835 qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in
836 thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in
837 pblhx ,iz0tlnd, itime ,psi_opt, ep_1, ep_2, epsm1,cp, &
838 z0wrf ,z0hwrf , & !out
839 imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out
840 sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out
841 tauy ,fira ,fsh ,fcev ,fgev ,fctr , & !out
842 trad ,psn ,apar ,ssoil ,btrani ,btran , & !out
843 ponding,ts ,latheav , latheag , frozen_canopy,frozen_ground, & !out
844 tv ,tg ,stc ,snowh ,eah ,tah , & !inout
845 sneqvo ,sneqv ,sh2o ,smc ,snice ,snliq , & !inout
846 albold ,cm ,ch ,dx ,dz8w ,q2 , & !inout
847 ustarx , & !inout
848#ifdef CCPP
849 tauss ,laisun ,laisha ,rb , errmsg ,errflg , & !inout
850#else
851 tauss ,laisun ,laisha ,rb , & !inout
852#endif
853!jref:start
854 qc ,qsfc ,psfc , & !in
855 t2mv ,t2mb ,fsrv , &
856 fsrg ,rssun ,rssha ,albd ,albi ,albsnd,albsni, bgap ,wgap, tgv,tgb,&
857 q1 ,q2v ,q2b ,q2e ,chv ,chb , & !out
858 emissi ,pah ,canhs, &
859 shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out
860
861 qsfcveg = eah*ep_2/(sfcprs + epsm1*eah)
862 qsfcbare = qsfc
863 qsfc = q1
864!jref:end
865#ifdef CCPP
866 if (errflg /= 0) return
867#endif
868 sice(:) = max(0.0, smc(:) - sh2o(:))
869 sneqvo = sneqv
870
871 qvap = max( fgev/latheag, 0.) ! positive part of fgev; barlage change to ground v3.6
872 qdew = abs( min(fgev/latheag, 0.)) ! negative part of fgev
873 edir = qvap - qdew
874
875! compute water budgets (water storages, et components, and runoff)
876
877 call water (parameters,vegtyp ,nsnow ,nsoil ,imelt ,dt ,uu , & !in
878 vv ,fcev ,fctr ,qprecc ,qprecl ,elai , & !in
879 esai ,sfctmp ,qvap ,qdew ,zsoil ,btrani , & !in
880 ficeold,ponding,tg ,ist ,fveg ,iloc,jloc , smceq , & !in
881 bdfall ,fp ,rain ,snow , & !in mb/an: v3.7
882 qsnow ,qrain ,snowhin,latheav,latheag,frozen_canopy,frozen_ground, & !in mb
883 isnow ,canliq ,canice ,tv ,snowh ,sneqv , & !inout
884 snice ,snliq ,stc ,zsnso ,sh2o ,smc , & !inout
885 sice ,zwt ,wa ,wt ,dzsnso ,wslake , & !inout
886 smcwtd ,deeprech,rech , & !inout
887 cmc ,ecan ,etran ,fwet ,runsrf ,runsub , & !out
888 qin ,qdis ,ponding1 ,ponding2,&
889 qsnbot ,esnow ) !out
890
891! write(*,'(a20,10f15.5)') 'sflx:runoff=',runsrf*dt,runsub*dt,edir*dt
892
893! compute carbon budgets (carbon storages and co2 & bvoc fluxes)
894
895 crop_active = .false.
896 dveg_active = .false.
897 if (dveg == 2 .or. dveg == 5 .or. dveg == 6) dveg_active = .true.
898 if (opt_crop > 0 .and. croptype > 0) then
899 crop_active = .true.
900 dveg_active = .false.
901 endif
902
903 IF (dveg_active) THEN
904 call carbon (parameters,nsnow ,nsoil ,vegtyp ,dt ,zsoil , & !in
905 dzsnso ,stc ,smc ,tv ,tg ,psn , & !in
906 foln ,btran ,apar ,fveg ,igs , & !in
907 troot ,ist ,lat ,iloc ,jloc , & !in
908 lfmass ,rtmass ,stmass ,wood ,stblcp ,fastcp , & !inout
909 gpp ,npp ,nee ,autors ,heters ,totsc , & !out
910 totlb ,lai ,sai ) !out
911 end if
912
913 if (opt_crop == 1 .and. crop_active) then
914 call carbon_crop (parameters,nsnow ,nsoil ,vegtyp ,dt ,zsoil ,julian , & !in
915 dzsnso ,stc ,smc ,tv ,psn ,foln ,btran , & !in
916 soldn ,t2m , & !in
917 lfmass ,rtmass ,stmass ,wood ,stblcp ,fastcp ,grain , & !inout
918 lai ,sai ,gdd , & !inout
919 gpp ,npp ,nee ,autors ,heters ,totsc ,totlb, pgs ) !out
920 end if
921
922! water and energy balance check
923
924 call error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & !in
925 fgev ,fctr ,ssoil ,beg_wb ,canliq ,canice , & !in
926 sneqv ,wa ,smc ,dzsnso ,prcp ,ecan , & !in
927 etran ,edir ,runsrf ,runsub ,dt ,nsoil , & !in
928 nsnow ,ist ,errwat ,iloc , jloc ,fveg , &
929 sav ,sag ,fsrv ,fsrg ,zwt ,pah , &
930#ifdef CCPP
931 pahv ,pahg ,pahb ,canhs,errmsg, errflg) !in ( except errwat [out] and errmsg, errflg [inout] )
932#else
933 pahv ,pahg ,pahb, canhs ) !in ( except errwat, which is out )
934#endif
935
936#ifdef CCPP
937 if (errflg /= 0) return
938#endif
939
940! urban - jref
941 qfx = etran + ecan + edir
942 if ( parameters%urban_flag ) then
943 qsfc = qfx/(rhoair*ch) + qair
944 q2b = qsfc
945 end if
946
947 if(snowh <= 1.e-6 .or. sneqv <= 1.e-3) then
948 snowh = 0.0
949 sneqv = 0.0
950 end if
951
952 if(swdown.ne.0.) then
953 albedo = fsr / swdown
954 else
955 albedo = -999.9
956 end if
957
958
959 end subroutine noahmp_sflx
960
961!== begin atm ======================================================================================
962
965 subroutine atm (parameters,ep_2,epsm1,sfcprs ,sfctmp ,q2 , &
966 prcpconv,prcpnonc ,prcpshcv,prcpsnow,prcpgrpl,prcphail , &
967 soldn ,cosz ,thair ,qair , &
968 eair ,rhoair ,qprecc ,qprecl ,solad , solai , &
969 swdown ,bdfall ,rain ,snow ,fp , fpice ,prcp )
970! --------------------------------------------------------------------------------------------------
971! re-process atmospheric forcing
972! ----------------------------------------------------------------------
973 implicit none
974! --------------------------------------------------------------------------------------------------
975! inputs
976
977 type (noahmp_parameters), intent(in) :: parameters
978 real (kind=kind_phys) , intent(in) :: ep_2
979 real (kind=kind_phys) , intent(in) :: epsm1
980 real (kind=kind_phys) , intent(in) :: sfcprs
981 real (kind=kind_phys) , intent(in) :: sfctmp
982 real (kind=kind_phys) , intent(in) :: q2
983 real (kind=kind_phys) , intent(in) :: prcpconv
984 real (kind=kind_phys) , intent(in) :: prcpnonc
985 real (kind=kind_phys) , intent(in) :: prcpshcv
986 real (kind=kind_phys) , intent(in) :: prcpsnow
987 real (kind=kind_phys) , intent(in) :: prcpgrpl
988 real (kind=kind_phys) , intent(in) :: prcphail
989 real (kind=kind_phys) , intent(in) :: soldn
990 real (kind=kind_phys) , intent(in) :: cosz
991
992! outputs
993
994 real (kind=kind_phys) , intent(out) :: thair
995 real (kind=kind_phys) , intent(out) :: qair
996 real (kind=kind_phys) , intent(out) :: eair
997 real (kind=kind_phys) , intent(out) :: rhoair
998 real (kind=kind_phys) , intent(out) :: qprecc
999 real (kind=kind_phys) , intent(out) :: qprecl
1000 real (kind=kind_phys), dimension( 1: 2), intent(out) :: solad
1001 real (kind=kind_phys), dimension( 1: 2), intent(out) :: solai
1002 real (kind=kind_phys) , intent(out) :: swdown
1003 real (kind=kind_phys) , intent(out) :: bdfall
1004 real (kind=kind_phys) , intent(out) :: rain
1005 real (kind=kind_phys) , intent(out) :: snow
1006 real (kind=kind_phys) , intent(out) :: fp
1007 real (kind=kind_phys) , intent(out) :: fpice
1008 real (kind=kind_phys) , intent(out) :: prcp
1009
1010!locals
1011
1012 real (kind=kind_phys) :: pair !atm bottom level pressure (pa)
1013 real (kind=kind_phys) :: prcp_frozen !total frozen precipitation [mm/s] ! mb/an : v3.7
1014 real (kind=kind_phys), parameter :: rho_grpl = 500.0 ! graupel bulk density [kg/m3] ! mb/an : v3.7
1015 real (kind=kind_phys), parameter :: rho_hail = 917.0 ! hail bulk density [kg/m3] ! mb/an : v3.7
1016! --------------------------------------------------------------------------------------------------
1017
1018!jref: seems like pair should be p1000mb??
1019 pair = sfcprs ! atm bottom level pressure (pa)
1020 thair = sfctmp * (sfcprs/pair)**(rair/cpair)
1021
1022 qair = q2 ! in wrf, driver converts to specific humidity
1023
1024 eair = qair*sfcprs / (ep_2-epsm1*qair)
1025 rhoair = (sfcprs+epsm1*eair) / (rair*sfctmp)
1026
1027 if(cosz <= 0.) then
1028 swdown = 0.
1029 else
1030 swdown = soldn
1031 end if
1032
1033 solad(1) = swdown*0.7*0.5 ! direct vis
1034 solad(2) = swdown*0.7*0.5 ! direct nir
1035 solai(1) = swdown*0.3*0.5 ! diffuse vis
1036 solai(2) = swdown*0.3*0.5 ! diffuse nir
1037
1038 prcp = prcpconv + prcpnonc + prcpshcv
1039
1040 if(opt_snf == 4) then
1041 qprecc = prcpconv + prcpshcv
1042 qprecl = prcpnonc
1043 else
1044 qprecc = 0.10 * prcp ! should be from the atmospheric model
1045 qprecl = 0.90 * prcp ! should be from the atmospheric model
1046 end if
1047
1048! fractional area that receives precipitation (see, niu et al. 2005)
1049
1050 fp = 0.0
1051 if(qprecc + qprecl > 0.) &
1052 fp = (qprecc + qprecl) / (10.*qprecc + qprecl)
1053
1054! partition precipitation into rain and snow. moved from canwat mb/an: v3.7
1055
1056! jordan (1991)
1057
1058 if(opt_snf == 1) then
1059 if(sfctmp > tfrz+2.5)then
1060 fpice = 0.
1061 else
1062 if(sfctmp <= tfrz+0.5)then
1063 fpice = 1.0
1064 else if(sfctmp <= tfrz+2.)then
1065 fpice = 1.-(-54.632 + 0.2*sfctmp)
1066 else
1067 fpice = 0.6
1068 endif
1069 endif
1070 endif
1071
1072 if(opt_snf == 2) then
1073 if(sfctmp >= tfrz+2.2) then
1074 fpice = 0.
1075 else
1076 fpice = 1.0
1077 endif
1078 endif
1079
1080 if(opt_snf == 3) then
1081 if(sfctmp >= tfrz) then
1082 fpice = 0.
1083 else
1084 fpice = 1.0
1085 endif
1086 endif
1087
1088! hedstrom nr and jw pomeroy (1998), hydrol. processes, 12, 1611-1625
1089! fresh snow density
1090
1091 bdfall = min(120.,67.92+51.25*exp((sfctmp-tfrz)/2.59)) !mb/an: change to min
1092 if(opt_snf == 4 .or. opt_snf == 5) then
1093 prcp_frozen = prcpsnow + prcpgrpl + prcphail
1094 if(prcpnonc > 0. .and. prcp_frozen > 0.) then
1095 fpice = min(1.0,prcp_frozen/prcpnonc)
1096 fpice = max(0.0,fpice)
1097 if(opt_snf==4) bdfall = bdfall*(prcpsnow/prcp_frozen) + rho_grpl*(prcpgrpl/prcp_frozen) + &
1098 rho_hail*(prcphail/prcp_frozen)
1099 if(opt_snf==5) bdfall = parameters%prcpiceden
1100 else
1101 fpice = 0.0
1102 endif
1103
1104 endif
1105
1106 rain = prcp * (1.-fpice)
1107 snow = prcp * fpice
1108
1109
1110 end subroutine atm
1111
1112!== begin phenology ================================================================================
1113
1117 subroutine phenology (parameters,vegtyp ,croptype, snowh , tv , lat , yearlen , julian , & !in
1118 lai , sai , troot , elai , esai , igs, pgs)
1119
1120! --------------------------------------------------------------------------------------------------
1121! vegetation phenology considering vegeation canopy being buries by snow and evolution in time
1122! --------------------------------------------------------------------------------------------------
1123 implicit none
1124! --------------------------------------------------------------------------------------------------
1125! inputs
1126 type (noahmp_parameters), intent(in) :: parameters
1127 integer , intent(in ) :: vegtyp
1128 integer , intent(in ) :: croptype
1129 real (kind=kind_phys) , intent(in ) :: snowh
1130 real (kind=kind_phys) , intent(in ) :: tv
1131 real (kind=kind_phys) , intent(in ) :: lat
1132 integer , intent(in ) :: yearlen
1133 real (kind=kind_phys) , intent(in ) :: julian
1134 real (kind=kind_phys) , intent(in ) :: troot
1135 real (kind=kind_phys) , intent(inout) :: lai
1136 real (kind=kind_phys) , intent(inout) :: sai
1137
1138! outputs
1139 real (kind=kind_phys) , intent(out ) :: elai
1140 real (kind=kind_phys) , intent(out ) :: esai
1141 real (kind=kind_phys) , intent(out ) :: igs
1142 integer , intent(in ) :: pgs
1143
1144! locals
1145
1146 real (kind=kind_phys) :: db !thickness of canopy buried by snow (m)
1147 real (kind=kind_phys) :: fb !fraction of canopy buried by snow
1148 real (kind=kind_phys) :: snowhc !critical snow depth at which short vege
1149 !is fully covered by snow
1150
1151 integer :: k !index
1152 integer :: it1,it2 !interpolation months
1153 real (kind=kind_phys) :: day !current day of year ( 0 <= day < yearlen )
1154 real (kind=kind_phys) :: wt1,wt2 !interpolation weights
1155 real (kind=kind_phys) :: t !current month (1.00, ..., 12.00)
1156! --------------------------------------------------------------------------------------------------
1157
1158if (croptype == 0) then
1159
1160 if ( dveg == 1 .or. dveg == 3 .or. dveg == 4 ) then
1161
1162 if (lat >= 0.) then
1163 ! northern hemisphere
1164 day = julian
1165 else
1166 ! southern hemisphere. day is shifted by 1/2 year.
1167 day = mod( julian + ( 0.5 * yearlen ) , real(yearlen) )
1168 endif
1169
1170 t = 12. * day / real(yearlen)
1171 it1 = t + 0.5
1172 it2 = it1 + 1
1173 wt1 = (it1+0.5) - t
1174 wt2 = 1.-wt1
1175 if (it1 .lt. 1) it1 = 12
1176 if (it2 .gt. 12) it2 = 1
1177
1178 lai = wt1*parameters%laim(it1) + wt2*parameters%laim(it2)
1179 sai = wt1*parameters%saim(it1) + wt2*parameters%saim(it2)
1180 endif
1181
1182 if(dveg == 7 .or. dveg == 8 .or. dveg == 9) then
1183 sai = max(0.05,0.1 * lai) ! when reading lai, set sai to 10% lai, but not below 0.05 mb: v3.8
1184 if (lai < 0.05) sai = 0.0 ! if lai below minimum, make sure sai = 0
1185 endif
1186
1187 if (sai < 0.05) sai = 0.0 ! mb: sai check, change to 0.05 v3.6
1188 if (lai < 0.05 .or. sai == 0.0) lai = 0.0 ! mb: lai check
1189
1190 if ( ( vegtyp == parameters%iswater ) .or. ( vegtyp == parameters%isbarren ) .or. &
1191 ( vegtyp == parameters%isice ) .or. ( parameters%urban_flag ) ) then
1192 lai = 0.
1193 sai = 0.
1194 endif
1195
1196endif ! croptype == 0
1197
1198!buried by snow
1199
1200 db = min( max(snowh - parameters%hvb,0.), parameters%hvt-parameters%hvb )
1201 fb = db / max(1.e-06,parameters%hvt-parameters%hvb)
1202
1203 if(parameters%hvt> 0. .and. parameters%hvt <= 1.0) then !mb: change to 1.0 and 0.2 to reflect
1204 snowhc = parameters%hvt*exp(-snowh/0.2) ! changes to hvt in mptable
1205! fb = min(snowh,snowhc)/snowhc
1206 if (snowh < snowhc) then
1207 fb = snowh/snowhc
1208 else
1209 fb = 1.0
1210 endif
1211 endif
1212
1213 elai = lai*(1.-fb)
1214 esai = sai*(1.-fb)
1215 if (esai < 0.05 .and. croptype == 0) esai = 0.0 ! mb: esai check, change to 0.05 v3.6
1216 if ((elai < 0.05 .or. esai == 0.0) .and. croptype == 0) elai = 0.0 ! mb: lai check
1217
1218! set growing season flag
1219
1220 if ((tv .gt. parameters%tmin .and. croptype == 0).or.(pgs > 2 .and. pgs < 7 .and. croptype > 0)) then
1221 igs = 1.
1222 else
1223 igs = 0.
1224 endif
1225
1226 end subroutine phenology
1227
1228!== begin precip_heat ==============================================================================
1229
1233 subroutine precip_heat (parameters,iloc ,jloc ,vegtyp ,dt ,uu ,vv , & !in
1234 elai ,esai ,fveg ,ist , & !in
1235 bdfall ,rain ,snow ,fp , & !in
1236 canliq ,canice ,tv ,sfctmp ,tg , & !in
1237 qintr ,qdripr ,qthror ,qints ,qdrips ,qthros , & !out
1238 pahv ,pahg ,pahb ,qrain ,qsnow ,snowhin, & !out
1239 fwet ,cmc ) !out
1240
1241! ------------------------ code history ------------------------------
1242! michael barlage: oct 2013 - split canwater to calculate precip movement for
1243! tracking of advected heat
1244! --------------------------------------------------------------------------------------------------
1245 implicit none
1246! ------------------------ input/output variables --------------------
1247! input
1248 type (noahmp_parameters), intent(in) :: parameters
1249 integer,intent(in) :: iloc
1250 integer,intent(in) :: jloc
1251 integer,intent(in) :: vegtyp
1252 integer,intent(in) :: ist
1253 real (kind=kind_phys), intent(in) :: dt
1254 real (kind=kind_phys), intent(in) :: uu
1255 real (kind=kind_phys), intent(in) :: vv
1256 real (kind=kind_phys), intent(in) :: elai
1257 real (kind=kind_phys), intent(in) :: esai
1258 real (kind=kind_phys), intent(in) :: fveg
1259 real (kind=kind_phys), intent(in) :: bdfall
1260 real (kind=kind_phys), intent(in) :: rain
1261 real (kind=kind_phys), intent(in) :: snow
1262 real (kind=kind_phys), intent(in) :: fp
1263 real (kind=kind_phys), intent(in) :: tv
1264 real (kind=kind_phys), intent(in) :: sfctmp
1265 real (kind=kind_phys), intent(in) :: tg
1266
1267! input & output
1268 real (kind=kind_phys), intent(inout) :: canliq
1269 real (kind=kind_phys), intent(inout) :: canice
1270
1271! output
1272 real (kind=kind_phys), intent(out) :: qintr
1273 real (kind=kind_phys), intent(out) :: qdripr
1274 real (kind=kind_phys), intent(out) :: qthror
1275 real (kind=kind_phys), intent(out) :: qints
1276 real (kind=kind_phys), intent(out) :: qdrips
1277 real (kind=kind_phys), intent(out) :: qthros
1278 real (kind=kind_phys), intent(out) :: pahv
1279 real (kind=kind_phys), intent(out) :: pahg
1280 real (kind=kind_phys), intent(out) :: pahb
1281 real (kind=kind_phys), intent(out) :: qrain
1282 real (kind=kind_phys), intent(out) :: qsnow
1283 real (kind=kind_phys), intent(out) :: snowhin
1284 real (kind=kind_phys), intent(out) :: fwet
1285 real (kind=kind_phys), intent(out) :: cmc
1286! --------------------------------------------------------------------
1287
1288! ------------------------ local variables ---------------------------
1289 real (kind=kind_phys) :: maxsno !canopy capacity for snow interception (mm)
1290 real (kind=kind_phys) :: maxliq !canopy capacity for rain interception (mm)
1291 real (kind=kind_phys) :: ft !temperature factor for unloading rate
1292 real (kind=kind_phys) :: fv !wind factor for unloading rate
1293 real (kind=kind_phys) :: pah_ac !precipitation advected heat - air to canopy (w/m2)
1294 real (kind=kind_phys) :: pah_cg !precipitation advected heat - canopy to ground (w/m2)
1295 real (kind=kind_phys) :: pah_ag !precipitation advected heat - air to ground (w/m2)
1296 real (kind=kind_phys) :: icedrip !canice unloading
1297! --------------------------------------------------------------------
1298! initialization
1299
1300 qintr = 0.
1301 qdripr = 0.
1302 qthror = 0.
1303 qintr = 0.
1304 qints = 0.
1305 qdrips = 0.
1306 qthros = 0.
1307 pah_ac = 0.
1308 pah_cg = 0.
1309 pah_ag = 0.
1310 pahv = 0.
1311 pahg = 0.
1312 pahb = 0.
1313 qrain = 0.0
1314 qsnow = 0.0
1315 snowhin = 0.0
1316 icedrip = 0.0
1317! print*, "precip_heat begin canopy balance:",canliq+canice+(rain+snow)*dt
1318! print*, "precip_heat snow*3600.0:",snow*3600.0
1319! print*, "precip_heat rain*3600.0:",rain*3600.0
1320! print*, "precip_heat canice:",canice
1321! print*, "precip_heat canliq:",canliq
1322
1323! --------------------------- liquid water ------------------------------
1324! maximum canopy water
1325
1326 maxliq = parameters%ch2op * (elai+ esai)
1327
1328! average interception and throughfall
1329
1330 if((elai+ esai).gt.0.) then
1331 qintr = fveg * rain * fp ! interception capability
1332 qintr = min(qintr, (maxliq - canliq)/dt * (1.-exp(-rain*dt/maxliq)) )
1333 qintr = max(qintr, 0.)
1334 qdripr = fveg * rain - qintr
1335 qthror = (1.-fveg) * rain
1336 canliq=max(0.,canliq+qintr*dt)
1337 else
1338 qintr = 0.
1339 qdripr = 0.
1340 qthror = rain
1341 if(canliq > 0.) then ! for case of canopy getting buried
1342 qdripr = qdripr + canliq/dt
1343 canliq = 0.0
1344 end if
1345 end if
1346
1347! heat transported by liquid water
1348
1349 pah_ac = fveg * rain * (cwat/1000.0) * (sfctmp - tv)
1350 pah_cg = qdripr * (cwat/1000.0) * (tv - tg)
1351 pah_ag = qthror * (cwat/1000.0) * (sfctmp - tg)
1352! print*, "precip_heat pah_ac:",pah_ac
1353! print*, "precip_heat pah_cg:",pah_cg
1354! print*, "precip_heat pah_ag:",pah_ag
1355
1356! --------------------------- canopy ice ------------------------------
1357! for canopy ice
1358
1359 maxsno = 6.6*(0.27+46./bdfall) * (elai+ esai)
1360
1361 if((elai+ esai).gt.0.) then
1362 qints = fveg * snow * fp
1363 qints = min(qints, (maxsno - canice)/dt * (1.-exp(-snow*dt/maxsno)) )
1364 qints = max(qints, 0.)
1365 ft = max(0.0,(tv - 270.15) / 1.87e5)
1366 fv = sqrt(uu*uu + vv*vv) / 1.56e5
1367 ! mb: changed below to reflect the rain assumption that all precip gets intercepted
1368 icedrip = max(0.,canice) * (fv+ft) !mb: removed /dt
1369 qdrips = (fveg * snow - qints) + icedrip
1370 qthros = (1.0-fveg) * snow
1371 canice= max(0.,canice + (qints - icedrip)*dt)
1372 else
1373 qints = 0.
1374 qdrips = 0.
1375 qthros = snow
1376 if(canice > 0.) then ! for case of canopy getting buried
1377 qdrips = qdrips + canice/dt
1378 canice = 0.0
1379 end if
1380 endif
1381! print*, "precip_heat canopy through:",3600.0*(fveg * snow - qints)
1382! print*, "precip_heat canopy drip:",3600.0*max(0.,canice) * (fv+ft)
1383
1384! wetted fraction of canopy
1385
1386 if(canice.gt.0.) then
1387 fwet = max(0.,canice) / max(maxsno,1.e-06)
1388 else
1389 fwet = max(0.,canliq) / max(maxliq,1.e-06)
1390 endif
1391 fwet = min(fwet, 1.) ** 0.667
1392
1393! total canopy water
1394
1395 cmc = canliq + canice
1396
1397! heat transported by snow/ice
1398
1399 pah_ac = pah_ac + fveg * snow * (cice/1000.0) * (sfctmp - tv)
1400 pah_cg = pah_cg + qdrips * (cice/1000.0) * (tv - tg)
1401 pah_ag = pah_ag + qthros * (cice/1000.0) * (sfctmp - tg)
1402
1403 pahv = pah_ac - pah_cg
1404 pahg = pah_cg
1405 pahb = pah_ag
1406
1407 if (fveg > 0.0 .and. fveg < 1.0) then
1408 pahg = pahg / fveg ! these will be multiplied by fraction later
1409 pahb = pahb / (1.0-fveg)
1410 elseif (fveg <= 0.0) then
1411 pahb = pahg + pahb ! for case of canopy getting buried
1412 pahg = 0.0
1413 pahv = 0.0
1414 elseif (fveg >= 1.0) then
1415 pahb = 0.0
1416 end if
1417
1418 pahv = max(pahv,-20.0) ! put some artificial limits here for stability
1419 pahv = min(pahv,20.0)
1420 pahg = max(pahg,-20.0)
1421 pahg = min(pahg,20.0)
1422 pahb = max(pahb,-20.0)
1423 pahb = min(pahb,20.0)
1424
1425! print*, 'precip_heat sfctmp,tv,tg:',sfctmp,tv,tg
1426! print*, 'precip_heat 3600.0*qints+qdrips+qthros:',3600.0*(qints+qdrips+qthros)
1427! print*, "precip_heat maxsno:",maxsno
1428! print*, "precip_heat pah_ac:",pah_ac
1429! print*, "precip_heat pah_cg:",pah_cg
1430! print*, "precip_heat pah_ag:",pah_ag
1431
1432! print*, "precip_heat pahv:",pahv
1433! print*, "precip_heat pahg:",pahg
1434! print*, "precip_heat pahb:",pahb
1435! print*, "precip_heat fveg:",fveg
1436! print*, "precip_heat qints*3600.0:",qints*3600.0
1437! print*, "precip_heat qdrips*3600.0:",qdrips*3600.0
1438! print*, "precip_heat qthros*3600.0:",qthros*3600.0
1439
1440! rain or snow on the ground
1441
1442 qrain = qdripr + qthror
1443 qsnow = qdrips + qthros
1444 snowhin = qsnow/bdfall
1445
1446 if (ist == 2 .and. tg > tfrz) then
1447 qsnow = 0.
1448 snowhin = 0.
1449 end if
1450! print*, "precip_heat qsnow*3600.0:",qsnow*3600.0
1451! print*, "precip_heat qrain*3600.0:",qrain*3600.0
1452! print*, "precip_heat snowhin:",snowhin
1453! print*, "precip_heat canice:",canice
1454! print*, "precip_heat canliq:",canliq
1455! print*, "precip_heat end canopy balance:",canliq+canice+(qrain+qsnow)*dt
1456
1457
1458 end subroutine precip_heat
1459
1460!== begin error ====================================================================================
1461
1464 subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , &
1465 fgev ,fctr ,ssoil ,beg_wb ,canliq ,canice , &
1466 sneqv ,wa ,smc ,dzsnso ,prcp ,ecan , &
1467 etran ,edir ,runsrf ,runsub ,dt ,nsoil , &
1468 nsnow ,ist ,errwat, iloc ,jloc ,fveg , &
1469 sav ,sag ,fsrv ,fsrg ,zwt ,pah , &
1470#ifdef CCPP
1471 pahv ,pahg ,pahb ,canhs,errmsg, errflg)
1472#else
1473 pahv ,pahg ,pahb ,canhs)
1474#endif
1475! --------------------------------------------------------------------------------------------------
1476! check surface energy balance and water balance
1477! --------------------------------------------------------------------------------------------------
1478 implicit none
1479! --------------------------------------------------------------------------------------------------
1480! inputs
1481 type (noahmp_parameters), intent(in) :: parameters
1482 integer , intent(in) :: nsnow
1483 integer , intent(in) :: nsoil
1484 integer , intent(in) :: ist
1485 integer , intent(in) :: iloc
1486 integer , intent(in) :: jloc
1487 real (kind=kind_phys) , intent(in) :: swdown
1488 real (kind=kind_phys) , intent(in) :: fsa
1489 real (kind=kind_phys) , intent(in) :: fsr
1490 real (kind=kind_phys) , intent(in) :: fira
1491 real (kind=kind_phys) , intent(in) :: fsh
1492 real (kind=kind_phys) , intent(in) :: fcev
1493 real (kind=kind_phys) , intent(in) :: fgev
1494 real (kind=kind_phys) , intent(in) :: fctr
1495 real (kind=kind_phys) , intent(in) :: ssoil
1496 real (kind=kind_phys) , intent(in) :: fveg
1497 real (kind=kind_phys) , intent(in) :: sav
1498 real (kind=kind_phys) , intent(in) :: sag
1499 real (kind=kind_phys) , intent(in) :: fsrv
1500 real (kind=kind_phys) , intent(in) :: fsrg
1501 real (kind=kind_phys) , intent(in) :: zwt
1502
1503 real (kind=kind_phys) , intent(in) :: prcp
1504 real (kind=kind_phys) , intent(in) :: ecan
1505 real (kind=kind_phys) , intent(in) :: etran
1506 real (kind=kind_phys) , intent(in) :: edir
1507 real (kind=kind_phys) , intent(in) :: runsrf
1508 real (kind=kind_phys) , intent(in) :: runsub
1509 real (kind=kind_phys) , intent(in) :: canliq
1510 real (kind=kind_phys) , intent(in) :: canice
1511 real (kind=kind_phys) , intent(in) :: sneqv
1512 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smc
1513 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
1514 real (kind=kind_phys) , intent(in) :: wa
1515 real (kind=kind_phys) , intent(in) :: dt
1516 real (kind=kind_phys) , intent(in) :: beg_wb
1517 real (kind=kind_phys) , intent(out) :: errwat
1518 real (kind=kind_phys), intent(in) :: pah
1519 real (kind=kind_phys), intent(in) :: pahv
1520 real (kind=kind_phys), intent(in) :: pahg
1521 real (kind=kind_phys), intent(in) :: pahb
1522 real (kind=kind_phys), intent(in) :: canhs
1523
1524#ifdef CCPP
1525 character(len=*) , intent(inout) :: errmsg
1526 integer , intent(inout) :: errflg
1527#endif
1528
1529 integer :: iz !do-loop index
1530 real (kind=kind_phys) :: end_wb !water storage at end of a timestep [mm]
1531 !kwm real (kind=kind_phys) :: errwat !error in water balance [mm/timestep]
1532 real (kind=kind_phys) :: erreng !error in surface energy balance [w/m2]
1533 real (kind=kind_phys) :: errsw !error in shortwave radiation balance [w/m2]
1534 real (kind=kind_phys) :: fsrvg
1535 character(len=256) :: message
1536! --------------------------------------------------------------------------------------------------
1537!jref:start
1538 errsw = swdown - (fsa + fsr)
1539! errsw = swdown - (sav+sag + fsrv+fsrg)
1540! write(*,*) "errsw =",errsw
1541 if (abs(errsw) > 0.01) then ! w/m2
1542 write(*,*) "vegetation!"
1543 write(*,*) "swdown*fveg =",swdown*fveg
1544 write(*,*) "fveg*(sav+sag) =",fveg*sav + sag
1545 write(*,*) "fveg*(fsrv +fsrg)=",fveg*fsrv + fsrg
1546 write(*,*) "ground!"
1547 write(*,*) "(1-.fveg)*swdown =",(1.-fveg)*swdown
1548 write(*,*) "(1.-fveg)*sag =",(1.-fveg)*sag
1549 write(*,*) "(1.-fveg)*fsrg=",(1.-fveg)*fsrg
1550 write(*,*) "fsrv =",fsrv
1551 write(*,*) "fsrg =",fsrg
1552 write(*,*) "fsr =",fsr
1553 write(*,*) "sav =",sav
1554 write(*,*) "sag =",sag
1555 write(*,*) "fsa =",fsa
1556!jref:end
1557 write(message,*) 'errsw =',errsw
1558#ifdef CCPP
1559 errflg = 1
1560 errmsg = trim(message)//new_line('A')//"stop in noah-mp"
1561 return
1562#else
1563 call wrf_message(trim(message))
1564 call wrf_error_fatal("stop in noah-mp")
1565#endif
1566 end if
1567
1568 erreng = sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil+canhs) +pah
1569! erreng = fveg*sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil)
1570 if(abs(erreng) > 0.01) then
1571 write(message,*) 'erreng =',erreng,' at i,j: ',iloc,jloc
1572#ifdef CCPP
1573 errmsg = trim(message)
1574#else
1575 call wrf_message(trim(message))
1576#endif
1577 write(message,'(a17,f10.4)') "net solar: ",fsa
1578#ifdef CCPP
1579 errmsg = trim(errmsg)//new_line('A')//trim(message)
1580#else
1581 call wrf_message(trim(message))
1582#endif
1583 write(message,'(a17,f10.4)') "net longwave: ",fira
1584#ifdef CCPP
1585 errmsg = trim(errmsg)//new_line('A')//trim(message)
1586#else
1587 call wrf_message(trim(message))
1588#endif
1589 write(message,'(a17,f10.4)') "total sensible: ",fsh
1590#ifdef CCPP
1591 errmsg = trim(errmsg)//new_line('A')//trim(message)
1592#else
1593 call wrf_message(trim(message))
1594#endif
1595 write(message,'(a17,f10.4)') "canopy evap: ",fcev
1596#ifdef CCPP
1597 errmsg = trim(errmsg)//new_line('A')//trim(message)
1598#else
1599 call wrf_message(trim(message))
1600#endif
1601 write(message,'(a17,f10.4)') "ground evap: ",fgev
1602#ifdef CCPP
1603 errmsg = trim(errmsg)//new_line('A')//trim(message)
1604#else
1605 call wrf_message(trim(message))
1606#endif
1607 write(message,'(a17,f10.4)') "transpiration: ",fctr
1608#ifdef CCPP
1609 errmsg = trim(errmsg)//new_line('A')//trim(message)
1610#else
1611 call wrf_message(trim(message))
1612#endif
1613 write(message,'(a17,f10.4)') "total ground: ",ssoil
1614#ifdef CCPP
1615 errmsg = trim(errmsg)//new_line('A')//trim(message)
1616#else
1617 call wrf_message(trim(message))
1618#endif
1619 write(message,'(a17,f10.4)') "canopy heat storage: ",canhs
1620#ifdef CCPP
1621 errmsg = trim(errmsg)//new_line('A')//trim(message)
1622#else
1623 call wrf_message(trim(message))
1624#endif
1625 write(message,'(a17,4f10.4)') "precip advected: ",pah,pahv,pahg,pahb
1626#ifdef CCPP
1627 errmsg = trim(errmsg)//new_line('A')//trim(message)
1628#else
1629 call wrf_message(trim(message))
1630#endif
1631 write(message,'(a17,f10.4)') "precip: ",prcp
1632#ifdef CCPP
1633 errmsg = trim(errmsg)//new_line('A')//trim(message)
1634#else
1635 call wrf_message(trim(message))
1636#endif
1637 write(message,'(a17,f10.4)') "veg fraction: ",fveg
1638#ifdef CCPP
1639 errflg = 1
1640 errmsg = trim(errmsg)//new_line('A')//trim(message)//new_line('A')//"energy budget problem in noahmp lsm"
1641 return
1642#else
1643 call wrf_message(trim(message))
1644 call wrf_error_fatal("energy budget problem in noahmp lsm")
1645#endif
1646
1647 end if
1648
1649 if (ist == 1) then !soil
1650 end_wb = canliq + canice + sneqv + wa
1651 do iz = 1,nsoil
1652 end_wb = end_wb + smc(iz) * dzsnso(iz) * 1000.
1653 end do
1654 errwat = end_wb-beg_wb-(prcp-ecan-etran-edir-runsrf-runsub)*dt
1655
1656 else !kwm
1657 errwat = 0.0 !kwm
1658 endif
1659
1660 end subroutine error
1661
1662!== begin energy ===================================================================================
1663
1672 subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in
1673 isnow ,dt ,rhoair ,sfcprs ,qair , & !in
1674 sfctmp ,thair ,lwdn ,uu ,vv ,zref , & !in
1675 co2air ,o2air ,solad ,solai ,cosz ,igs , & !in
1676 eair ,tbot ,zsnso ,zsoil , & !in
1677 elai ,esai ,fwet ,foln , & !in
1678 fveg ,shdfac, pahv ,pahg ,pahb , & !in
1679 qsnow ,dzsnso ,lat ,canliq ,canice ,iloc , jloc, & !in
1680 thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in
1681 pblhx , iz0tlnd, itime,psi_opt,ep_1, ep_2, epsm1, cp, &
1682 z0wrf ,z0hwrf , & !out
1683 imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out
1684 sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out
1685 tauy ,fira ,fsh ,fcev ,fgev ,fctr , & !out
1686 trad ,psn ,apar ,ssoil ,btrani ,btran , & !out
1687 ponding,ts ,latheav , latheag , frozen_canopy,frozen_ground, & !out
1688 tv ,tg ,stc ,snowh ,eah ,tah , & !inout
1689 sneqvo ,sneqv ,sh2o ,smc ,snice ,snliq , & !inout
1690 albold ,cm ,ch ,dx ,dz8w ,q2 , & !inout
1691 ustarx , & !inout
1692#ifdef CCPP
1693 tauss ,laisun ,laisha ,rb ,errmsg ,errflg, & !inout
1694#else
1695 tauss ,laisun ,laisha ,rb , & !inout
1696#endif
1697!jref:start
1698 qc ,qsfc ,psfc , & !in
1699 t2mv ,t2mb ,fsrv , &
1700 fsrg ,rssun ,rssha ,albd ,albi,albsnd ,albsni,bgap ,wgap,tgv,tgb,&
1701 q1 ,q2v ,q2b ,q2e ,chv ,chb, emissi,pah,canhs,&
1702 shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out
1703!jref:end
1704
1705! --------------------------------------------------------------------------------------------------
1706! we use different approaches to deal with subgrid features of radiation transfer and turbulent
1707! transfer. we use 'tile' approach to compute turbulent fluxes, while we use modified two-
1708! stream to compute radiation transfer. tile approach, assemblying vegetation canopies together,
1709! may expose too much ground surfaces (either covered by snow or grass) to solar radiation. the
1710! modified two-stream assumes vegetation covers fully the gridcell but with gaps between tree
1711! crowns.
1712! --------------------------------------------------------------------------------------------------
1713! turbulence transfer : 'tile' approach to compute energy fluxes in vegetated fraction and
1714! bare fraction separately and then sum them up weighted by fraction
1715! --------------------------------------
1716! / o o o o o o o o / /
1717! / | | | | | | | | / /
1718! / o o o o o o o o / /
1719! / | | |tile1| | | | / tile2 /
1720! / o o o o o o o o / bare /
1721! / | | | vegetated | | / /
1722! / o o o o o o o o / /
1723! / | | | | | | | | / /
1724! --------------------------------------
1725! --------------------------------------------------------------------------------------------------
1726! radiation transfer : modified two-stream (yang and friedl, 2003, jgr; niu ang yang, 2004, jgr)
1727! -------------------------------------- two-stream treats leaves as
1728! / o o o o o o o o / cloud over the entire grid-cell,
1729! / | | | | | | | | / while the modified two-stream
1730! / o o o o o o o o / aggregates cloudy leaves into
1731! / | | | | | | | | / tree crowns with gaps (as shown in
1732! / o o o o o o o o / the left figure). we assume these
1733! / | | | | | | | | / tree crowns are evenly distributed
1734! / o o o o o o o o / within the gridcell with 100% veg
1735! / | | | | | | | | / fraction, but with gaps. the 'tile'
1736! -------------------------------------- approach overlaps too much shadows.
1737! --------------------------------------------------------------------------------------------------
1738 implicit none
1739! --------------------------------------------------------------------------------------------------
1740! inputs
1741 type (noahmp_parameters), intent(in) :: parameters
1742 integer , intent(in) :: iloc
1743 integer , intent(in) :: jloc
1744 integer , intent(in) :: ice
1745 integer , intent(in) :: vegtyp
1746 integer , intent(in) :: ist
1747 integer , intent(in) :: nsnow
1748 integer , intent(in) :: nsoil
1749 integer , intent(in) :: isnow
1750 real (kind=kind_phys) , intent(in) :: dt
1751 real (kind=kind_phys) , intent(in) :: qsnow
1752 real (kind=kind_phys) , intent(in) :: rhoair
1753 real (kind=kind_phys) , intent(in) :: eair
1754 real (kind=kind_phys) , intent(in) :: sfcprs
1755
1756 logical , intent(in) :: thsfc_loc
1757 real (kind=kind_phys) , intent(in) :: prslkix
1758 real (kind=kind_phys) , intent(in) :: prsik1x
1759 real (kind=kind_phys) , intent(in) :: prslk1x
1760 real (kind=kind_phys) , intent(in) :: garea1
1761
1762 real (kind=kind_phys) , intent(in) :: pblhx
1763 real (kind=kind_phys) , intent(in) :: ep_1
1764 real (kind=kind_phys) , intent(in) :: ep_2
1765 real (kind=kind_phys) , intent(in) :: epsm1
1766 real (kind=kind_phys) , intent(in) :: cp
1767 integer , intent(in) :: iz0tlnd
1768 integer , intent(in) :: itime
1769 integer , intent(in) :: psi_opt
1770
1771 real (kind=kind_phys) , intent(in) :: qair
1772 real (kind=kind_phys) , intent(in) :: sfctmp
1773 real (kind=kind_phys) , intent(in) :: thair
1774 real (kind=kind_phys) , intent(in) :: lwdn
1775 real (kind=kind_phys) , intent(in) :: uu
1776 real (kind=kind_phys) , intent(in) :: vv
1777 real (kind=kind_phys) , dimension( 1: 2), intent(in) :: solad
1778 real (kind=kind_phys) , dimension( 1: 2), intent(in) :: solai
1779 real (kind=kind_phys) , intent(in) :: cosz
1780 real (kind=kind_phys) , intent(in) :: elai
1781 real (kind=kind_phys) , intent(in) :: esai
1782 real (kind=kind_phys) , intent(in) :: fwet
1783 real (kind=kind_phys) , intent(in) :: fveg
1784 real (kind=kind_phys) , intent(in) :: shdfac
1785 real (kind=kind_phys) , intent(in) :: lat
1786 real (kind=kind_phys) , intent(in) :: canliq
1787 real (kind=kind_phys) , intent(in) :: canice
1788 real (kind=kind_phys) , intent(in) :: foln
1789 real (kind=kind_phys) , intent(in) :: co2air
1790 real (kind=kind_phys) , intent(in) :: o2air
1791 real (kind=kind_phys) , intent(in) :: igs
1792
1793 real (kind=kind_phys) , intent(in) :: zref
1794 real (kind=kind_phys) , intent(in) :: tbot
1795 real (kind=kind_phys) , dimension(-nsnow+1:nsoil), intent(in) :: zsnso
1796 real (kind=kind_phys) , dimension( 1:nsoil), intent(in) :: zsoil
1797 real (kind=kind_phys) , dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
1798 real (kind=kind_phys), intent(in) :: pahv
1799 real (kind=kind_phys), intent(in) :: pahg
1800 real (kind=kind_phys), intent(in) :: pahb
1801
1802!jref:start; in
1803 real (kind=kind_phys) , intent(in) :: qc
1804 real (kind=kind_phys) , intent(inout) :: qsfc
1805 real (kind=kind_phys) , intent(in) :: psfc
1806 real (kind=kind_phys) , intent(in) :: dx
1807 real (kind=kind_phys) , intent(in) :: dz8w
1808 real (kind=kind_phys) , intent(in) :: q2
1809!jref:end
1810
1811! outputs
1812 real (kind=kind_phys) , intent(out) :: z0wrf
1813 real (kind=kind_phys) , intent(out) :: z0hwrf
1814 integer, dimension(-nsnow+1:nsoil), intent(out) :: imelt
1815 real (kind=kind_phys) , dimension(-nsnow+1: 0), intent(out) :: snicev
1816 real (kind=kind_phys) , dimension(-nsnow+1: 0), intent(out) :: snliqv
1817 real (kind=kind_phys) , dimension(-nsnow+1: 0), intent(out) :: epore
1818 real (kind=kind_phys) , intent(out) :: fsno
1819 real (kind=kind_phys) , intent(out) :: qmelt
1820 real (kind=kind_phys) , intent(out) :: ponding
1821 real (kind=kind_phys) , intent(out) :: sav
1822 real (kind=kind_phys) , intent(out) :: sag
1823 real (kind=kind_phys) , intent(out) :: fsa
1824 real (kind=kind_phys) , intent(out) :: fsr
1825 real (kind=kind_phys) , intent(out) :: taux
1826 real (kind=kind_phys) , intent(out) :: tauy
1827 real (kind=kind_phys) , intent(out) :: fira
1828 real (kind=kind_phys) , intent(out) :: fsh
1829 real (kind=kind_phys) , intent(out) :: fcev
1830 real (kind=kind_phys) , intent(out) :: fgev
1831 real (kind=kind_phys) , intent(out) :: fctr
1832 real (kind=kind_phys) , intent(out) :: trad
1833 real (kind=kind_phys) , intent(out) :: t2m
1834 real (kind=kind_phys) , intent(out) :: psn
1835 real (kind=kind_phys) , intent(out) :: apar
1836 real (kind=kind_phys) , intent(out) :: ssoil
1837 real (kind=kind_phys) , dimension( 1:nsoil), intent(out) :: btrani
1838 real (kind=kind_phys) , intent(out) :: btran
1839! real (kind=kind_phys) , intent(out) :: lathea !< latent heat vap./sublimation (j/kg)
1840 real (kind=kind_phys) , intent(out) :: latheav
1841 real (kind=kind_phys) , intent(out) :: latheag
1842 real (kind=kind_phys) , intent(out) :: ts
1843 logical , intent(out) :: frozen_ground
1844 logical , intent(out) :: frozen_canopy
1845
1846!jref:start
1847 real (kind=kind_phys) , intent(out) :: fsrv
1848 real (kind=kind_phys) , intent(out) :: fsrg
1849 real (kind=kind_phys), intent(out) :: rssun
1850 real (kind=kind_phys), intent(out) :: rssha
1851!jref:end - out for debug
1852
1853!jref:start; output
1854 real (kind=kind_phys) , intent(out) :: t2mv
1855 real (kind=kind_phys) , intent(out) :: t2mb
1856 real (kind=kind_phys) , intent(out) :: bgap
1857 real (kind=kind_phys) , intent(out) :: wgap
1858 real (kind=kind_phys) , intent(out) :: canhs
1859 real (kind=kind_phys), dimension(1:2) , intent(out) :: albd
1860 real (kind=kind_phys), dimension(1:2) , intent(out) :: albi
1861 real (kind=kind_phys), dimension(1:2) , intent(out) :: albsnd
1862 real (kind=kind_phys), dimension(1:2) , intent(out) :: albsni
1863!jref:end
1864
1865! input & output
1866 real (kind=kind_phys) , intent(inout) :: tv
1867 real (kind=kind_phys) , intent(inout) :: tg
1868 real (kind=kind_phys) , dimension(-nsnow+1:nsoil), intent(inout) :: stc
1869 real (kind=kind_phys) , intent(inout) :: snowh
1870 real (kind=kind_phys) , intent(inout) :: sneqv
1871 real (kind=kind_phys) , intent(inout) :: sneqvo
1872 real (kind=kind_phys) , dimension( 1:nsoil), intent(inout) :: sh2o
1873 real (kind=kind_phys) , dimension( 1:nsoil), intent(inout) :: smc
1874 real (kind=kind_phys) , dimension(-nsnow+1: 0), intent(inout) :: snice
1875 real (kind=kind_phys) , dimension(-nsnow+1: 0), intent(inout) :: snliq
1876 real (kind=kind_phys) , intent(inout) :: eah
1877 real (kind=kind_phys) , intent(inout) :: tah
1878 real (kind=kind_phys) , intent(inout) :: albold
1879 real (kind=kind_phys) , intent(inout) :: tauss
1880 real (kind=kind_phys) , intent(inout) :: cm
1881 real (kind=kind_phys) , intent(inout) :: ch
1882 real (kind=kind_phys) , intent(inout) :: q1
1883 real (kind=kind_phys) , intent(inout) :: ustarx
1884 real (kind=kind_phys) , intent(inout) :: rb
1885 real (kind=kind_phys) , intent(inout) :: laisun
1886 real (kind=kind_phys) , intent(inout) :: laisha
1887#ifdef CCPP
1888 character(len=*) , intent(inout) :: errmsg
1889 integer , intent(inout) :: errflg
1890#endif
1891! real (kind=kind_phys) :: q2e !<
1892 real (kind=kind_phys), intent(out) :: emissi
1893 real (kind=kind_phys), intent(out) :: pah
1894
1895! local
1896 integer :: iz !do-loop index
1897 logical :: veg !true if vegetated surface
1898 real (kind=kind_phys) :: ur !wind speed at height zlvl (m/s)
1899 real (kind=kind_phys) :: zlvl !reference height (m)
1900 real (kind=kind_phys) :: fsun !sunlit fraction of canopy [-]
1901 real (kind=kind_phys) :: rsurf !ground surface resistance (s/m)
1902 real (kind=kind_phys) :: l_rsurf!dry-layer thickness for computing rsurf (sakaguchi and zeng, 2009)
1903 real (kind=kind_phys) :: d_rsurf!reduced vapor diffusivity in soil for computing rsurf (sz09)
1904 real (kind=kind_phys) :: bevap !soil water evaporation factor (0- 1)
1905 real (kind=kind_phys) :: mol !monin-obukhov length (m)
1906 real (kind=kind_phys) :: vai !sum of lai + stem area index [m2/m2]
1907 real (kind=kind_phys) :: cwp !canopy wind extinction parameter
1908 real (kind=kind_phys) :: zpd !zero plane displacement (m)
1909 real (kind=kind_phys) :: z0m !z0 momentum (m)
1910 real (kind=kind_phys) :: zpdg !zero plane displacement (m)
1911 real (kind=kind_phys) :: z0mg !z0 momentum, ground (m)
1912 real (kind=kind_phys) :: emv !vegetation emissivity
1913 real (kind=kind_phys) :: emg !ground emissivity
1914 real (kind=kind_phys) :: fire !emitted ir (w/m2)
1915
1916 real (kind=kind_phys) :: psnsun !sunlit photosynthesis (umolco2/m2/s)
1917 real (kind=kind_phys) :: psnsha !shaded photosynthesis (umolco2/m2/s)
1918!jref:start - for debug
1919! real (kind=kind_phys) :: rssun !sunlit stomatal resistance (s/m)
1920! real (kind=kind_phys) :: rssha !shaded stomatal resistance (s/m)
1921!jref:end - for debug
1922 real (kind=kind_phys) :: parsun !par absorbed per sunlit lai (w/m2)
1923 real (kind=kind_phys) :: parsha !par absorbed per shaded lai (w/m2)
1924
1925 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: fact !temporary used in phase change
1926 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: df !thermal conductivity [w/m/k]
1927 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: hcpct !heat capacity [j/m3/k]
1928 real (kind=kind_phys) :: bdsno !bulk density of snow (kg/m3)
1929 real (kind=kind_phys) :: fmelt !melting factor for snow cover frac
1930 real (kind=kind_phys) :: gx !temporary variable
1931 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: phi !light through water (w/m2)
1932! real (kind=kind_phys) :: gamma !psychrometric constant (pa/k)
1933 real (kind=kind_phys) :: gammav !psychrometric constant (pa/k)
1934 real (kind=kind_phys) :: gammag !psychrometric constant (pa/k)
1935 real (kind=kind_phys) :: psi !surface layer soil matrix potential (m)
1936 real (kind=kind_phys) :: rhsur !raltive humidity in surface soil/snow air space (-)
1937
1938! temperature and fluxes over vegetated fraction
1939
1940 real (kind=kind_phys) :: tauxv !wind stress: e-w dir [n/m2]
1941 real (kind=kind_phys) :: tauyv !wind stress: n-s dir [n/m2]
1942 real (kind=kind_phys),intent(out) :: irc !canopy net lw rad. [w/m2] [+ to atm]
1943 real (kind=kind_phys),intent(out) :: irg !ground net lw rad. [w/m2] [+ to atm]
1944 real (kind=kind_phys),intent(out) :: shc !canopy sen. heat [w/m2] [+ to atm]
1945 real (kind=kind_phys),intent(out) :: shg !ground sen. heat [w/m2] [+ to atm]
1946!jref:start
1947 real (kind=kind_phys),intent(out) :: q2v
1948 real (kind=kind_phys),intent(out) :: q2b
1949 real (kind=kind_phys),intent(out) :: q2e
1950!jref:end
1951 real (kind=kind_phys),intent(out) :: evc !canopy evap. heat [w/m2] [+ to atm]
1952 real (kind=kind_phys),intent(out) :: evg !ground evap. heat [w/m2] [+ to atm]
1953 real (kind=kind_phys),intent(out) :: tr !transpiration heat [w/m2] [+ to atm]
1954 real (kind=kind_phys),intent(out) :: ghv !ground heat flux [w/m2] [+ to soil]
1955 real (kind=kind_phys),intent(out) :: tgv !ground surface temp. [k]
1956 real (kind=kind_phys) :: cmv !momentum drag coefficient
1957 real (kind=kind_phys),intent(out) :: chv !sensible heat exchange coefficient
1958
1959! temperature and fluxes over bare soil fraction
1960
1961 real (kind=kind_phys) :: tauxb !wind stress: e-w dir [n/m2]
1962 real (kind=kind_phys) :: tauyb !wind stress: n-s dir [n/m2]
1963 real (kind=kind_phys),intent(out) :: irb !net longwave rad. [w/m2] [+ to atm]
1964 real (kind=kind_phys),intent(out) :: shb !sensible heat [w/m2] [+ to atm]
1965 real (kind=kind_phys),intent(out) :: evb !evaporation heat [w/m2] [+ to atm]
1966 real (kind=kind_phys),intent(out) :: ghb !ground heat flux [w/m2] [+ to soil]
1967 real (kind=kind_phys),intent(out) :: tgb !ground surface temp. [k]
1968 real (kind=kind_phys) :: cmb !momentum drag coefficient
1969 real (kind=kind_phys),intent(out) :: chb !sensible heat exchange coefficient
1970 real (kind=kind_phys),intent(out) :: chleaf !leaf exchange coefficient
1971 real (kind=kind_phys),intent(out) :: chuc !under canopy exchange coefficient
1972!jref:start
1973 real (kind=kind_phys),intent(out) :: chv2 !sensible heat conductance, canopy air to zlvl air (m/s)
1974 real (kind=kind_phys),intent(out) :: chb2 !sensible heat conductance, canopy air to zlvl air (m/s)
1975 real (kind=kind_phys) :: noahmpres
1976! for new coupling
1977 real (kind=kind_phys) :: csigmaf0
1978 real (kind=kind_phys) :: csigmaf1
1979
1980 real (kind=kind_phys) :: cdmnv
1981 real (kind=kind_phys) :: ezpdv
1982 real (kind=kind_phys) :: cdmng
1983 real (kind=kind_phys) :: ezpdg
1984 real (kind=kind_phys) :: ezpd
1985 real (kind=kind_phys) :: aone
1986
1987 real (kind=kind_phys) :: canopy_density_factor
1988 real (kind=kind_phys) :: vai_limited
1989
1990!jref:end
1991
1992 real (kind=kind_phys), parameter :: mpe = 1.e-6
1993 real (kind=kind_phys), parameter :: psiwlt = -150. !metric potential for wilting point (m)
1994 real (kind=kind_phys), parameter :: z0 = 0.015 ! bare-soil roughness length (m) (i.e., under the canopy)
1995
1996! ---------------------------------------------------------------------------------------------------
1997! initialize fluxes from veg. fraction
1998
1999 tauxv = 0.
2000 tauyv = 0.
2001 irc = 0.
2002 shc = 0.
2003 irg = 0.
2004 shg = 0.
2005 evg = 0.
2006 evc = 0.
2007 tr = 0.
2008 ghv = 0.
2009 psnsun = 0.
2010 psnsha = 0.
2011 t2mv = 0.
2012 q2v = 0.
2013 chv = 0.
2014 chleaf = 0.
2015 chuc = 0.
2016 chv2 = 0.
2017 rb = 0.
2018 laisun = 0.
2019 laisha = 0.
2020
2021 cdmnv = 0.0
2022 ezpdv = 0.0
2023 cdmng = 0.0
2024 ezpdg = 0.0
2025 ezpd = 0.0
2026 z0hwrf = 0.0
2027 csigmaf1 = 0.0
2028 csigmaf0 = 0.0
2029 aone = 0.0
2030
2031 canopy_density_factor = 1.0
2032 vai_limited = 2.0
2033
2034!
2035
2036! wind speed at reference height: ur >= 1
2037
2038 ur = max( sqrt(uu**2.+vv**2.), 1. )
2039
2040! vegetated or non-vegetated
2041
2042 vai = elai + esai
2043 veg = .false.
2044 if(vai > 0.) veg = .true.
2045
2046! ground snow cover fraction [niu and yang, 2007, jgr]
2047
2048 fsno = 0.
2049 if(snowh <= 1.e-6 .or. sneqv <= 1.e-3) then
2050 snowh = 0.0
2051 sneqv = 0.0
2052 end if
2053 if(snowh.gt.0.) then
2054 bdsno = sneqv / snowh
2055 fmelt = (bdsno/100.)**parameters%mfsno
2056 fsno = tanh( snowh /(parameters%scffac * fmelt))
2057 endif
2058
2059! ground roughness length
2060
2061 if(ist == 2) then
2062 if(tg .le. tfrz) then
2063 z0mg = 0.01 * (1.0-fsno) + fsno * parameters%z0sno
2064 else
2065 z0mg = 0.01
2066 end if
2067 else
2068 z0mg = z0 * (1.0-fsno) + fsno * parameters%z0sno
2069 end if
2070
2071! roughness length and displacement height
2072
2073 zpdg = snowh
2074 if(veg) then
2075
2076 if(opt_z0m == 1) then
2077
2078 z0m = parameters%z0mvt
2079 zpd = 0.65 * parameters%hvt
2080
2081 elseif(opt_z0m == 2) then
2082
2083 z0m = parameters%z0mhvt * parameters%hvt
2084 zpd = 0.65 * parameters%hvt
2085 if(vegtyp /= 13) then
2086 vai_limited = min(vai, 2.0)
2087 canopy_density_factor = (1.0 - exp(-vai_limited)) / (1.0 - exp(-2.0))
2088 z0m = exp(canopy_density_factor * log(z0m) + (1.0 - canopy_density_factor) * log(z0mg))
2089 zpd = canopy_density_factor * zpd
2090 end if
2091
2092 end if
2093
2094 if(snowh.gt.zpd) zpd = snowh
2095
2096 else
2097
2098 z0m = z0mg
2099 zpd = zpdg
2100
2101 end if
2102
2103! special case for urban
2104
2105 IF (parameters%urban_flag) THEN
2106 z0mg = parameters%Z0MVT
2107 zpdg = 0.65 * parameters%HVT
2108 z0m = z0mg
2109 zpd = zpdg
2110 END IF
2111
2112 zlvl = max(zpd,parameters%hvt) + zref
2113 if(zpdg >= zlvl) zlvl = zpdg + zref
2114! ur = ur*log(zlvl/z0m)/log(10./z0m) !input ur is at 10m
2115
2116! canopy wind absorption coeffcient
2117
2118 cwp = parameters%cwpvt
2119
2120! thermal properties of soil, snow, lake, and frozen soil
2121
2122 call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in
2123 dt ,snowh ,snice ,snliq , shdfac, & !in
2124 smc ,sh2o ,tg ,stc ,ur , & !in
2125 lat ,z0m ,zlvl ,vegtyp , & !in
2126 df ,hcpct ,snicev ,snliqv ,epore , & !out
2127 fact ) !out
2128
2129! solar radiation: absorbed & reflected by the ground and canopy
2130
2131 call radiation (parameters,vegtyp ,ist ,ice ,nsoil , & !in
2132 sneqvo ,sneqv ,dt ,cosz ,snowh , & !in
2133 tg ,tv ,fsno ,qsnow ,fwet , & !in
2134 elai ,esai ,smc ,solad ,solai , & !in
2135 fveg ,iloc ,jloc , & !in
2136 albold ,tauss , & !inout
2137 fsun ,laisun ,laisha ,parsun ,parsha , & !out
2138 sav ,sag ,fsr ,fsa ,fsrv , &
2139 fsrg ,albd ,albi ,albsnd ,albsni ,bgap ,wgap ) ! out
2140
2141! vegetation and ground emissivity
2142
2143 emv = 1. - exp(-(elai+esai)/1.0)
2144 if (ice == 1) then
2145 emg = 0.98*(1.-fsno) + parameters%snow_emis*fsno
2146 else
2147 emg = parameters%eg(ist)*(1.-fsno) + parameters%snow_emis*fsno
2148 end if
2149
2150! soil moisture factor controlling stomatal resistance
2151
2152 btran = 0.
2153
2154 if(ist ==1 ) then
2155 do iz = 1, parameters%nroot
2156 if(opt_btr == 1) then ! noah
2157 gx = (sh2o(iz)-parameters%smcwlt(iz)) / (parameters%smcref(iz)-parameters%smcwlt(iz))
2158 end if
2159 if(opt_btr == 2) then ! clm
2160 psi = max(psiwlt,-parameters%psisat(iz)*(max(0.01,sh2o(iz))/parameters%smcmax(iz))**(-parameters%bexp(iz)) )
2161 gx = (1.-psi/psiwlt)/(1.+parameters%psisat(iz)/psiwlt)
2162 end if
2163 if(opt_btr == 3) then ! ssib
2164 psi = max(psiwlt,-parameters%psisat(iz)*(max(0.01,sh2o(iz))/parameters%smcmax(iz))**(-parameters%bexp(iz)) )
2165 gx = 1.-exp(-5.8*(log(psiwlt/psi)))
2166 end if
2167
2168 gx = min(1.,max(0.,gx))
2169 btrani(iz) = max(mpe,dzsnso(iz) / (-zsoil(parameters%nroot)) * gx)
2170 btran = btran + btrani(iz)
2171 end do
2172 btran = max(mpe,btran)
2173
2174 btrani(1:parameters%nroot) = btrani(1:parameters%nroot)/btran
2175 end if
2176
2177! soil surface resistance for ground evap.
2178
2179 bevap = max(0.0,sh2o(1)/parameters%smcmax(1))
2180 if(ist == 2) then
2181 rsurf = 1. ! avoid being divided by 0
2182 rhsur = 1.0
2183 else
2184
2185 if(opt_rsf == 1 .or. opt_rsf == 4) then
2186 ! rsurf based on sakaguchi and zeng, 2009
2187 ! taking the "residual water content" to be the wilting point,
2188 ! and correcting the exponent on the d term (typo in sz09 ?)
2189 l_rsurf = (-zsoil(1)) * ( exp( (1.0 - min(1.0,sh2o(1)/parameters%smcmax(1))) ** parameters%rsurf_exp ) - 1.0 ) / ( 2.71828 - 1.0 )
2190 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))
2191 rsurf = l_rsurf / d_rsurf
2192 elseif(opt_rsf == 2) then
2193 rsurf = fsno * 1. + (1.-fsno)* exp(8.25-4.225*bevap) !sellers (1992) ! older rsurf computations
2194 elseif(opt_rsf == 3) then
2195 rsurf = fsno * 1. + (1.-fsno)* exp(8.25-6.0 *bevap) !adjusted to decrease rsurf for wet soil
2196 endif
2197
2198 if(opt_rsf == 4) then ! ad: fsno weighted; snow rsurf set in mptable v3.8
2199 rsurf = 1. / (fsno * (1./parameters%rsurf_snow) + (1.-fsno) * (1./max(rsurf, 0.001)))
2200 endif
2201
2202 if(sh2o(1) < 0.01 .and. snowh == 0.) rsurf = 1.e6
2203 psi = -parameters%psisat(1)*(max(0.01,sh2o(1))/parameters%smcmax(1))**(-parameters%bexp(1))
2204 rhsur = fsno + (1.-fsno) * exp(psi*grav/(rw*tg))
2205 end if
2206
2207! urban - jref
2208 if (parameters%urban_flag .and. snowh == 0. ) then
2209 rsurf = 1.e6
2210 endif
2211
2212! set psychrometric constant
2213
2214 if (tv .gt. tfrz) then ! barlage: add distinction between ground and
2215 latheav = hvap ! vegetation in v3.6
2216 frozen_canopy = .false.
2217 else
2218 latheav = hsub
2219 frozen_canopy = .true.
2220 end if
2221 gammav = cpair*sfcprs/(ep_2*latheav)
2222
2223 if (tg .gt. tfrz) then
2224 latheag = hvap
2225 frozen_ground = .false.
2226 else
2227 latheag = hsub
2228 frozen_ground = .true.
2229 end if
2230 gammag = cpair*sfcprs/(ep_2*latheag)
2231
2232! if (sfctmp .gt. tfrz) then
2233! lathea = hvap
2234! else
2235! lathea = hsub
2236! end if
2237! gamma = cpair*sfcprs/(ep_2*lathea)
2238
2239! surface temperatures of the ground and canopy and energy fluxes
2240
2241 if (veg .and. fveg > 0) then
2242 tgv = tg
2243 cmv = cm
2244 chv = ch
2245 call vege_flux (parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & !in
2246 dt ,sav ,sag ,lwdn ,ur , & !in
2247 uu ,vv ,sfctmp ,thair ,qair , & !in
2248 eair ,rhoair ,snowh ,vai ,gammav ,gammag , & !in
2249 fwet ,laisun ,laisha ,cwp ,dzsnso , & !in
2250 zlvl ,zpd ,z0m ,fveg ,shdfac, & !in
2251 z0mg ,emv ,emg ,canliq ,fsno, & !in
2252 canice ,stc ,df ,rssun ,rssha , & !in
2253 rsurf ,latheav ,latheag ,parsun ,parsha ,igs , & !in
2254 foln ,co2air ,o2air ,btran ,sfcprs , & !in
2255 rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in
2256 thsfc_loc, prslkix,prsik1x,prslk1x, garea1, & !in
2257 pblhx ,iz0tlnd ,itime ,psi_opt ,ep_1, ep_2, epsm1, cp, &
2258 eah ,tah ,tv ,tgv ,cmv, ustarx , & !inout
2259#ifdef CCPP
2260 chv ,dx ,dz8w ,errmsg ,errflg , & !inout
2261#else
2262 chv ,dx ,dz8w , & !inout
2263#endif
2264 tauxv ,tauyv ,irg ,irc ,shg , & !out
2265 shc ,evg ,evc ,tr ,ghv , & !out
2266 t2mv ,psnsun ,psnsha ,canhs , & !out
2267 csigmaf1, & !out
2268!jref:start
2269 qc ,qsfc ,psfc , & !in
2270 q2v ,chv2 ,chleaf ,chuc , &
2271 rb) !out
2272
2273! new coupling code
2274
2275 cdmnv = 0.4*0.4/log((zlvl-zpd)/z0m)**2
2276 aone = 2.6*(10.0*parameters%hvt/(zlvl-zpd))**0.355
2277 ezpdv = zpd*fveg !for the grid
2278
2279!jref:end
2280#ifdef CCPP
2281 if (errflg /= 0) return
2282#endif
2283 end if
2284
2285 tgb = tg
2286 cmb = cm
2287 chb = ch
2288 call bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & !in
2289 lwdn ,ur ,uu ,vv ,sfctmp , & !in
2290 thair ,qair ,eair ,rhoair ,snowh , & !in
2291 dzsnso ,zlvl ,zpdg ,z0mg ,fsno, & !in
2292 emg ,stc ,df ,rsurf ,latheag , & !in
2293 gammag ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in
2294 thsfc_loc, prslkix,prsik1x,prslk1x,vegtyp,fveg,shdfac,garea1, & !in
2295 pblhx ,iz0tlnd ,itime ,psi_opt ,ep_1, ep_2, epsm1, cp, &
2296#ifdef CCPP
2297 tgb ,cmb ,chb, ustarx,errmsg ,errflg , & !inout
2298#else
2299 tgb ,cmb ,chb, ustarx, & !inout
2300#endif
2301 tauxb ,tauyb ,irb ,shb ,evb,csigmaf0,& !out
2302 ghb ,t2mb ,dx ,dz8w , & !out
2303!jref:start
2304 qc ,qsfc ,psfc , & !in
2305 sfcprs ,q2b, chb2) !in
2306
2307! new coupling code
2308
2309 cdmng = 0.4*0.4/log((zlvl-zpdg)/z0mg)**2
2310 ezpdg = zpdg
2311!
2312! vegetation is optional; use the larger one
2313!
2314 if (ezpdv .ge. ezpdg ) then
2315 ezpd = ezpdv
2316 elseif (ezpdv .gt. 0.0 .and. ezpdv .lt. ezpdg) then
2317 ezpd = (1.0 -fveg)*ezpdg
2318 else
2319 ezpd = ezpdg
2320 endif
2321
2322!jref:end
2323#ifdef CCPP
2324 if (errflg /= 0) return
2325#endif
2326!energy balance at vege canopy: sav =(irc+shc+evc+tr) *fveg at fveg
2327!energy balance at vege ground: sag* fveg =(irg+shg+evg+ghv) *fveg at fveg
2328!energy balance at bare ground: sag*(1.-fveg)=(irb+shb+evb+ghb)*(1.-fveg) at 1-fveg
2329
2330 if (veg .and. fveg > 0) then
2331 taux = fveg * tauxv + (1.0 - fveg) * tauxb
2332 tauy = fveg * tauyv + (1.0 - fveg) * tauyb
2333 fira = fveg * irg + (1.0 - fveg) * irb + irc
2334 fsh = fveg * shg + (1.0 - fveg) * shb + shc
2335 fgev = fveg * evg + (1.0 - fveg) * evb
2336 ssoil = fveg * ghv + (1.0 - fveg) * ghb
2337 fcev = evc
2338 fctr = tr
2339 pah = fveg * pahg + (1.0 - fveg) * pahb + pahv
2340 tg = fveg * tgv + (1.0 - fveg) * tgb
2341 t2m = fveg * t2mv + (1.0 - fveg) * t2mb
2342 ts = fveg * tah + (1.0 - fveg) * tgb
2343 cm = fveg * cmv + (1.0 - fveg) * cmb ! better way to average?
2344 ch = fveg * chv + (1.0 - fveg) * chb
2345 q1 = fveg * (eah*ep_2/(sfcprs + epsm1*eah)) + (1.0 - fveg)*qsfc
2346 q2e = fveg * q2v + (1.0 - fveg) * q2b
2347
2348! effectibe skin temperature
2349
2350 ts = (fveg*chv*tah + (1.0-fveg)*chb*tgb ) / ch
2351
2352
2353! new coupling code
2354
2355 call thermalz0(parameters,fveg,z0m,z0mg,zlvl,zpd,ezpd,ustarx, & !in
2356 vegtyp,vai,ur,csigmaf0,csigmaf1,aone,cdmnv,cdmng,2, & !in
2357 z0wrf,z0hwrf)
2358 else
2359 taux = tauxb
2360 tauy = tauyb
2361 fira = irb
2362 fsh = shb
2363 fgev = evb
2364 ssoil = ghb
2365 tg = tgb
2366 t2m = t2mb
2367 fcev = 0.
2368 fctr = 0.
2369 pah = pahb
2370 ts = tg
2371 cm = cmb
2372 ch = chb
2373 q1 = qsfc
2374 q2e = q2b
2375 rssun = 0.0
2376 rssha = 0.0
2377 tgv = tgb
2378 chv = chb
2379
2380 call thermalz0(parameters,fveg,z0m,z0mg,zlvl,zpd,ezpd,ustarx, & !in
2381 vegtyp,vai,ur,csigmaf0,csigmaf1,aone,cdmnv,cdmng,0, & !in
2382 z0wrf,z0hwrf)
2383
2384 end if
2385
2386 fire = lwdn + fira
2387
2388 if(fire <=0.) then
2389 write(6,*) 'emitted longwave <0; skin t may be wrong due to inconsistent'
2390 write(6,*) 'input of shdfac with lai'
2391 write(6,*) iloc, jloc, 'shdfac=',fveg,'vai=',vai,'tv=',tv,'tg=',tg
2392 write(6,*) 'lwdn=',lwdn,'fira=',fira,'snowh=',snowh
2393#ifdef CCPP
2394 errflg = 1
2395 errmsg = "stop in noah-mp"
2396 return
2397#else
2398 call wrf_error_fatal("stop in noah-mp")
2399#endif
2400
2401 end if
2402
2403 ! compute a net emissivity
2404 emissi = fveg * ( emg*(1-emv) + emv + emv*(1-emv)*(1-emg) ) + &
2405 (1-fveg) * emg
2406
2407 ! when we're computing a trad, subtract from the emitted ir the
2408 ! reflected portion of the incoming lwdn, so we're just
2409 ! considering the ir originating in the canopy/ground system.
2410
2411 trad = ( ( fire - (1-emissi)*lwdn ) / (emissi*sb) ) ** 0.25
2412
2413 ! old trad calculation not taking into account emissivity:
2414 ! trad = (fire/sb)**0.25
2415
2416 apar = parsun*laisun + parsha*laisha
2417 psn = psnsun*laisun + psnsha*laisha
2418
2419! 3l snow & 4l soil temperatures
2420
2421 call tsnosoi (parameters,ice ,nsoil ,nsnow ,isnow ,ist , & !in
2422 tbot ,zsnso ,ssoil ,df ,hcpct , & !in
2423 sag ,dt ,snowh ,dzsnso , & !in
2424 tg ,iloc ,jloc , & !in
2425#ifdef CCPP
2426 stc ,errmsg ,errflg ) !inout
2427#else
2428 stc ) !inout
2429#endif
2430
2431#ifdef CCPP
2432 if (errflg /= 0) return
2433#endif
2434
2435! adjusting snow surface temperature
2436 if(opt_stc == 2) then
2437 if (snowh > 0.05 .and. tg > tfrz) then
2438 tgv = tfrz
2439 tgb = tfrz
2440 if (veg .and. fveg > 0) then
2441 tg = fveg * tgv + (1.0 - fveg) * tgb
2442 ts = fveg * tv + (1.0 - fveg) * tgb
2443 else
2444 tg = tgb
2445 ts = tgb
2446 end if
2447 end if
2448 end if
2449
2450! energy released or consumed by snow & frozen soil
2451
2452 call phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , & !in
2453 dzsnso ,hcpct ,ist ,iloc ,jloc , & !in
2454 stc ,snice ,snliq ,sneqv ,snowh , & !inout
2455#ifdef CCPP
2456 smc ,sh2o ,errmsg ,errflg , & !inout
2457#else
2458 smc ,sh2o , & !inout
2459#endif
2460 qmelt ,imelt ,ponding ) !out
2461#ifdef CCPP
2462 if (errflg /= 0) return
2463#endif
2464
2465 end subroutine energy
2466
2467!== begin thermoprop ===============================================================================
2468
2470 subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in
2471 dt ,snowh ,snice ,snliq , shdfac, & !in
2472 smc ,sh2o ,tg ,stc ,ur , & !in
2473 lat ,z0m ,zlvl ,vegtyp , & !in
2474 df ,hcpct ,snicev ,snliqv ,epore , & !out
2475 fact ) !out
2476! -------------------------------------------------------------------------------------------------
2477 implicit none
2478! --------------------------------------------------------------------------------------------------
2479! inputs
2480 type (noahmp_parameters), intent(in) :: parameters
2481 integer , intent(in) :: nsoil
2482 integer , intent(in) :: nsnow
2483 integer , intent(in) :: isnow
2484 integer , intent(in) :: ist
2485 real (kind=kind_phys) , intent(in) :: dt
2486 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snice
2487 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snliq
2488 real (kind=kind_phys) , intent(in) :: shdfac
2489 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
2490 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smc
2491 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: sh2o
2492 real (kind=kind_phys) , intent(in) :: snowh
2493 real (kind=kind_phys), intent(in) :: tg
2494 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc
2495 real (kind=kind_phys), intent(in) :: ur
2496 real (kind=kind_phys), intent(in) :: lat
2497 real (kind=kind_phys), intent(in) :: z0m
2498 real (kind=kind_phys), intent(in) :: zlvl
2499 integer , intent(in) :: vegtyp
2500
2501! outputs
2502 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: df
2503 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: hcpct
2504 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(out) :: snicev
2505 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(out) :: snliqv
2506 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(out) :: epore
2507 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: fact
2508! --------------------------------------------------------------------------------------------------
2509! locals
2510
2511 integer :: iz
2512 real (kind=kind_phys), dimension(-nsnow+1: 0) :: cvsno !volumetric specific heat (j/m3/k)
2513 real (kind=kind_phys), dimension(-nsnow+1: 0) :: tksno !snow thermal conductivity (j/m3/k)
2514 real (kind=kind_phys), dimension( 1:nsoil) :: sice !soil ice content
2515 real (kind=kind_phys), parameter :: sbeta = -2.0
2516 real (kind=kind_phys), dimension(4,20) :: soil_carbon ! soil carbon content [kg/m3]
2517 real (kind=kind_phys), parameter :: soil_carbon_df = 0.25 ! soil carbon therm cond (Lawrence and Slater)
2518 real (kind=kind_phys), parameter :: soil_carbon_hcpct = 2.5e6 ! soil carbon heat capacity (Lawrence and Slater)
2519! --------------------------------------------------------------------------------------------------
2520! soil carbon [kg/m3] by vegetation type estimated from global PNNL soil carbon dataset
2521! and VIIRS surface type
2522
2523 soil_carbon(1,:) = (/90,65,90,65,90,40,50,50,40,50,90,60,60,60,0,20,0,90,90,60/)
2524 soil_carbon(2,:) = (/40,30,40,30,40,25,30,30,25,30,40,30,30,30,0,15,0,60,60,40/)
2525 soil_carbon(3,:) = (/20,15,20,15,20,15,20,15,15,15,25,20,20,20,0,10,0,40,40,30/)
2526 soil_carbon(4,:) = (/15,10,15,10,15,10,15,10,10,10,20,10,10,10,0,10,0,40,30,20/)
2527
2528 soil_carbon = soil_carbon / 130.0 ! convert to soil carbon relative to peat
2529
2530! compute snow thermal conductivity and heat capacity
2531
2532 call csnow (parameters,isnow ,nsnow ,nsoil ,snice ,snliq ,dzsnso , & !in
2533 tksno ,cvsno ,snicev ,snliqv ,epore ) !out
2534
2535 do iz = isnow+1, 0
2536 df(iz) = tksno(iz)
2537 hcpct(iz) = cvsno(iz)
2538 end do
2539
2540! compute soil thermal properties
2541
2542 do iz = 1, nsoil
2543 sice(iz) = smc(iz) - sh2o(iz)
2544 hcpct(iz) = sh2o(iz)*cwat + (1.0-parameters%smcmax(iz))*parameters%csoil &
2545 + (parameters%smcmax(iz)-smc(iz))*cpair + sice(iz)*cice
2546 call tdfcnd (parameters,iz,df(iz), smc(iz), sh2o(iz))
2547
2548! adjust for soil carbon organic content
2549
2550! hcpct(iz) = (1.0 - soil_carbon(iz,vegtyp)) * hcpct(iz) + soil_carbon(iz,vegtyp) * soil_carbon_hcpct
2551 df(iz) = (1.0 - soil_carbon(iz,vegtyp)) * df(iz) + soil_carbon(iz,vegtyp) * soil_carbon_df
2552 end do
2553
2554 if ( parameters%urban_flag ) then
2555 do iz = 1,nsoil
2556 df(iz) = 3.24
2557 end do
2558 endif
2559
2560! heat flux reduction effect from the overlying green canopy, adapted from
2561! section 2.1.2 of peters-lidard et al. (1997, jgr, vol 102(d4)).
2562! not in use because of the separation of the canopy layer from the ground.
2563! but this may represent the effects of leaf litter (niu comments)
2564! df1 = df1 * exp (sbeta * shdfac)
2565 df(1) = df(1) * exp(sbeta * shdfac)
2566
2567! compute lake thermal properties
2568! (no consideration of turbulent mixing for this version)
2569
2570 if(ist == 2) then
2571 do iz = 1, nsoil
2572 if(stc(iz) > tfrz) then
2573 hcpct(iz) = cwat
2574 df(iz) = tkwat !+ keddy * cwat
2575 else
2576 hcpct(iz) = cice
2577 df(iz) = tkice
2578 end if
2579 end do
2580 end if
2581
2582! combine a temporary variable used for melting/freezing of snow and frozen soil
2583
2584 do iz = isnow+1,nsoil
2585 fact(iz) = dt/(hcpct(iz)*dzsnso(iz))
2586 end do
2587
2588! snow/soil interface
2589
2590 if(isnow == 0) then
2591 df(1) = (df(1)*dzsnso(1)+0.35*snowh) / (snowh +dzsnso(1))
2592 else
2593 df(1) = (df(1)*dzsnso(1)+df(0)*dzsnso(0)) / (dzsnso(0)+dzsnso(1))
2594 end if
2595
2596
2597 end subroutine thermoprop
2598
2599!== begin csnow ====================================================================================
2600
2603 subroutine csnow (parameters,isnow ,nsnow ,nsoil ,snice ,snliq ,dzsnso , & !in
2604 tksno ,cvsno ,snicev ,snliqv ,epore ) !out
2605! --------------------------------------------------------------------------------------------------
2606! snow bulk density,volumetric capacity, and thermal conductivity
2607!---------------------------------------------------------------------------------------------------
2608 implicit none
2609!---------------------------------------------------------------------------------------------------
2610! inputs
2611
2612 type (noahmp_parameters), intent(in) :: parameters
2613 integer, intent(in) :: isnow
2614 integer , intent(in) :: nsnow
2615 integer , intent(in) :: nsoil
2616 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snice
2617 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snliq
2618 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
2619
2620! outputs
2621
2622 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(out) :: cvsno
2623 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(out) :: tksno
2624 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(out) :: snicev
2625 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(out) :: snliqv
2626 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(out) :: epore
2627
2628! locals
2629
2630 integer :: iz
2631 real (kind=kind_phys), dimension(-nsnow+1: 0) :: bdsnoi !bulk density of snow(kg/m3)
2632
2633!---------------------------------------------------------------------------------------------------
2634! thermal capacity of snow
2635
2636 do iz = isnow+1, 0
2637 snicev(iz) = min(1., snice(iz)/(dzsnso(iz)*denice) )
2638 epore(iz) = 1. - snicev(iz)
2639 snliqv(iz) = min(epore(iz),snliq(iz)/(dzsnso(iz)*denh2o))
2640 enddo
2641
2642 do iz = isnow+1, 0
2643 bdsnoi(iz) = (snice(iz)+snliq(iz))/dzsnso(iz)
2644 cvsno(iz) = cice*snicev(iz)+cwat*snliqv(iz)
2645! cvsno(iz) = 0.525e06 ! constant
2646 enddo
2647
2648! thermal conductivity of snow
2649
2650 do iz = isnow+1, 0
2651! tksno(iz) = 3.2217e-6*bdsnoi(iz)**2. ! stieglitz(yen,1965)
2652! tksno(iz) = 2e-2+2.5e-6*bdsnoi(iz)*bdsnoi(iz) ! anderson, 1976
2653 tksno(iz) = 0.35 ! constant
2654! tksno(iz) = 2.576e-6*bdsnoi(iz)**2. + 0.074 ! verseghy (1991)
2655! tksno(iz) = 2.22*(bdsnoi(iz)/1000.)**1.88 ! douvill(yen, 1981)
2656 enddo
2657
2658 end subroutine csnow
2659
2660!== begin tdfcnd ===================================================================================
2661
2665 subroutine tdfcnd (parameters, isoil, df, smc, sh2o)
2666! --------------------------------------------------------------------------------------------------
2667! calculate thermal diffusivity and conductivity of the soil.
2668! peters-lidard approach (peters-lidard et al., 1998)
2669! --------------------------------------------------------------------------------------------------
2670! code history:
2671! june 2001 changes: frozen soil condition.
2672! --------------------------------------------------------------------------------------------------
2673 implicit none
2674 type (noahmp_parameters), intent(in) :: parameters
2675 integer, intent(in) :: isoil
2676 real (kind=kind_phys), intent(in) :: smc
2677 real (kind=kind_phys), intent(in) :: sh2o
2678 real (kind=kind_phys), intent(out) :: df
2679
2680! local variables
2681 real (kind=kind_phys) :: ake
2682 real (kind=kind_phys) :: gammd
2683 real (kind=kind_phys) :: thkdry
2684 real (kind=kind_phys) :: thko ! thermal conductivity for other soil components
2685 real (kind=kind_phys) :: thkqtz ! thermal conductivity for quartz
2686 real (kind=kind_phys) :: thksat !
2687 real (kind=kind_phys) :: thks ! thermal conductivity for the solids
2688 real (kind=kind_phys) :: thkw ! water thermal conductivity
2689 real (kind=kind_phys) :: satratio
2690 real (kind=kind_phys) :: xu
2691 real (kind=kind_phys) :: xunfroz
2692! --------------------------------------------------------------------------------------------------
2693! we now get quartz as an input argument (set in routine redprm):
2694! data quartz /0.82, 0.10, 0.25, 0.60, 0.52,
2695! & 0.35, 0.60, 0.40, 0.82/
2696! --------------------------------------------------------------------------------------------------
2697! if the soil has any moisture content compute a partial sum/product
2698! otherwise use a constant value which works well with most soils
2699! --------------------------------------------------------------------------------------------------
2700! quartz ....quartz content (soil type dependent)
2701! --------------------------------------------------------------------------------------------------
2702! use as in peters-lidard, 1998 (modif. from johansen, 1975).
2703
2704! pablo grunmann, 08/17/98
2705! refs.:
2706! farouki, o.t.,1986: thermal properties of soils. series on rock
2707! and soil mechanics, vol. 11, trans tech, 136 pp.
2708! johansen, o., 1975: thermal conductivity of soils. ph.d. thesis,
2709! university of trondheim,
2710! peters-lidard, c. d., et al., 1998: the effect of soil thermal
2711! conductivity parameterization on surface energy fluxes
2712! and temperatures. journal of the atmospheric sciences,
2713! vol. 55, pp. 1209-1224.
2714! --------------------------------------------------------------------------------------------------
2715! needs parameters
2716! porosity(soil type):
2717! poros = smcmax
2718! saturation ratio:
2719! parameters w/(m.k)
2720 satratio = smc / parameters%smcmax(isoil)
2721 thkw = 0.57
2722! if (quartz .le. 0.2) thko = 3.0
2723 thko = 2.0
2724! solids' conductivity
2725! quartz' conductivity
2726 thkqtz = 7.7
2727
2728! unfrozen fraction (from 1., i.e., 100%liquid, to 0. (100% frozen))
2729 thks = (thkqtz ** parameters%quartz(isoil))* (thko ** (1. - parameters%quartz(isoil)))
2730
2731! unfrozen volume for saturation (porosity*xunfroz)
2732 xunfroz = 1.0 ! prevent divide by zero (suggested by d. mocko)
2733 if(smc > 0.) xunfroz = sh2o / smc
2734! saturated thermal conductivity
2735 xu = xunfroz * parameters%smcmax(isoil)
2736
2737! dry density in kg/m3
2738 thksat = thks ** (1. - parameters%smcmax(isoil))* tkice ** (parameters%smcmax(isoil) - xu)* thkw ** &
2739 (xu)
2740
2741! dry thermal conductivity in w.m-1.k-1
2742 gammd = (1. - parameters%smcmax(isoil))*2700.
2743
2744 thkdry = (0.135* gammd+ 64.7)/ (2700. - 0.947* gammd)
2745! frozen
2746 if ( (sh2o + 0.0005) < smc ) then
2747 ake = satratio
2748! unfrozen
2749! range of validity for the kersten number (ake)
2750 else
2751
2752! kersten number (using "fine" formula, valid for soils containing at
2753! least 5% of particles with diameter less than 2.e-6 meters.)
2754! (for "coarse" formula, see peters-lidard et al., 1998).
2755
2756 if ( satratio > 0.1 ) then
2757
2758 ake = log10(satratio) + 1.0
2759
2760! use k = kdry
2761 else
2762
2763 ake = 0.0
2764 end if
2765! thermal conductivity
2766
2767 end if
2768
2769 df = ake * (thksat - thkdry) + thkdry
2770
2771
2772 end subroutine tdfcnd
2773
2774!== begin radiation ================================================================================
2775
2778 subroutine radiation (parameters,vegtyp ,ist ,ice ,nsoil , & !in
2779 sneqvo ,sneqv ,dt ,cosz ,snowh , & !in
2780 tg ,tv ,fsno ,qsnow ,fwet , & !in
2781 elai ,esai ,smc ,solad ,solai , & !in
2782 fveg ,iloc ,jloc , & !in
2783 albold ,tauss , & !inout
2784 fsun ,laisun ,laisha ,parsun ,parsha , & !out
2785 sav ,sag ,fsr ,fsa ,fsrv , &
2786 fsrg ,albd ,albi ,albsnd ,albsni ,bgap ,wgap) !out
2787! --------------------------------------------------------------------------------------------------
2788 implicit none
2789! --------------------------------------------------------------------------------------------------
2790! input
2791 type (noahmp_parameters), intent(in) :: parameters
2792 integer, intent(in) :: iloc
2793 integer, intent(in) :: jloc
2794 integer, intent(in) :: vegtyp
2795 integer, intent(in) :: ist
2796 integer, intent(in) :: ice
2797 integer, intent(in) :: nsoil
2798
2799 real (kind=kind_phys), intent(in) :: dt
2800 real (kind=kind_phys), intent(in) :: qsnow
2801 real (kind=kind_phys), intent(in) :: sneqvo
2802 real (kind=kind_phys), intent(in) :: sneqv
2803 real (kind=kind_phys), intent(in) :: snowh
2804 real (kind=kind_phys), intent(in) :: cosz
2805 real (kind=kind_phys), intent(in) :: tg
2806 real (kind=kind_phys), intent(in) :: tv
2807 real (kind=kind_phys), intent(in) :: elai
2808 real (kind=kind_phys), intent(in) :: esai
2809 real (kind=kind_phys), intent(in) :: fwet
2810 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: smc
2811 real (kind=kind_phys), dimension(1:2) , intent(in) :: solad
2812 real (kind=kind_phys), dimension(1:2) , intent(in) :: solai
2813 real (kind=kind_phys), intent(in) :: fsno
2814 real (kind=kind_phys), intent(in) :: fveg
2815
2816! inout
2817 real (kind=kind_phys), intent(inout) :: albold
2818 real (kind=kind_phys), intent(inout) :: tauss
2819
2820! output
2821 real (kind=kind_phys), intent(out) :: fsun
2822 real (kind=kind_phys), intent(out) :: laisun
2823 real (kind=kind_phys), intent(out) :: laisha
2824 real (kind=kind_phys), intent(out) :: parsun
2825 real (kind=kind_phys), intent(out) :: parsha
2826 real (kind=kind_phys), intent(out) :: sav
2827 real (kind=kind_phys), intent(out) :: sag
2828 real (kind=kind_phys), intent(out) :: fsa
2829 real (kind=kind_phys), intent(out) :: fsr
2830
2831!jref:start
2832 real (kind=kind_phys), intent(out) :: fsrv
2833 real (kind=kind_phys), intent(out) :: fsrg
2834 real (kind=kind_phys), intent(out) :: bgap
2835 real (kind=kind_phys), intent(out) :: wgap
2836 real (kind=kind_phys), dimension(1:2), intent(out) :: albsnd
2837 real (kind=kind_phys), dimension(1:2), intent(out) :: albsni
2838!jref:end
2839
2840! local
2841 real (kind=kind_phys) :: fage !snow age function (0 - new snow)
2842 real (kind=kind_phys), dimension(1:2) :: albgrd !ground albedo (direct)
2843 real (kind=kind_phys), dimension(1:2) :: albgri !ground albedo (diffuse)
2844 real (kind=kind_phys), dimension(1:2) :: albd !surface albedo (direct)
2845 real (kind=kind_phys), dimension(1:2) :: albi !surface albedo (diffuse)
2846 real (kind=kind_phys), dimension(1:2) :: fabd !flux abs by veg (per unit direct flux)
2847 real (kind=kind_phys), dimension(1:2) :: fabi !flux abs by veg (per unit diffuse flux)
2848 real (kind=kind_phys), dimension(1:2) :: ftdd !down direct flux below veg (per unit dir flux)
2849 real (kind=kind_phys), dimension(1:2) :: ftid !down diffuse flux below veg (per unit dir flux)
2850 real (kind=kind_phys), dimension(1:2) :: ftii !down diffuse flux below veg (per unit dif flux)
2851!jref:start
2852 real (kind=kind_phys), dimension(1:2) :: frevi
2853 real (kind=kind_phys), dimension(1:2) :: frevd
2854 real (kind=kind_phys), dimension(1:2) :: fregi
2855 real (kind=kind_phys), dimension(1:2) :: fregd
2856!jref:end
2857
2858 real (kind=kind_phys) :: fsha !shaded fraction of canopy
2859 real (kind=kind_phys) :: vai !total lai + stem area index, one sided
2860
2861 real (kind=kind_phys),parameter :: mpe = 1.e-6
2862 logical veg !true: vegetated for surface temperature calculation
2863
2864! --------------------------------------------------------------------------------------------------
2865
2866! surface abeldo
2867
2868 call albedo (parameters,vegtyp ,ist ,ice ,nsoil , & !in
2869 dt ,cosz ,fage ,elai ,esai , & !in
2870 tg ,tv ,snowh ,fsno ,fwet , & !in
2871 smc ,sneqvo ,sneqv ,qsnow ,fveg , & !in
2872 iloc ,jloc , & !in
2873 albold ,tauss , & !inout
2874 albgrd ,albgri ,albd ,albi ,fabd , & !out
2875 fabi ,ftdd ,ftid ,ftii ,fsun , & !) !out
2876 frevi ,frevd ,fregd ,fregi ,bgap , & !inout
2877 wgap ,albsnd ,albsni )
2878
2879! surface radiation
2880
2881 fsha = 1.-fsun
2882 laisun = elai*fsun
2883 laisha = elai*fsha
2884 vai = elai+ esai
2885 if (vai .gt. 0.) then
2886 veg = .true.
2887 else
2888 veg = .false.
2889 end if
2890
2891 call surrad (parameters,mpe ,fsun ,fsha ,elai ,vai , & !in
2892 laisun ,laisha ,solad ,solai ,fabd , & !in
2893 fabi ,ftdd ,ftid ,ftii ,albgrd , & !in
2894 albgri ,albd ,albi ,iloc ,jloc , & !in
2895 parsun ,parsha ,sav ,sag ,fsa , & !out
2896 fsr , & !out
2897 frevi ,frevd ,fregd ,fregi ,fsrv , & !inout
2898 fsrg)
2899
2900 end subroutine radiation
2901
2902!== begin albedo ===================================================================================
2903
2908 subroutine albedo (parameters,vegtyp ,ist ,ice ,nsoil , & !in
2909 dt ,cosz ,fage ,elai ,esai , & !in
2910 tg ,tv ,snowh ,fsno ,fwet , & !in
2911 smc ,sneqvo ,sneqv ,qsnow ,fveg , & !in
2912 iloc ,jloc , & !in
2913 albold ,tauss , & !inout
2914 albgrd ,albgri ,albd ,albi ,fabd , & !out
2915 fabi ,ftdd ,ftid ,ftii ,fsun , & !out
2916 frevi ,frevd ,fregd ,fregi ,bgap , & !out
2917 wgap ,albsnd ,albsni )
2918
2919! --------------------------------------------------------------------------------------------------
2920! surface albedos. also fluxes (per unit incoming direct and diffuse
2921! radiation) reflected, transmitted, and absorbed by vegetation.
2922! also sunlit fraction of the canopy.
2923! --------------------------------------------------------------------------------------------------
2924 implicit none
2925! --------------------------------------------------------------------------------------------------
2926! input
2927 type (noahmp_parameters), intent(in) :: parameters
2928 integer, intent(in) :: iloc
2929 integer, intent(in) :: jloc
2930 integer, intent(in) :: nsoil
2931 integer, intent(in) :: vegtyp
2932 integer, intent(in) :: ist
2933 integer, intent(in) :: ice
2934
2935 real (kind=kind_phys), intent(in) :: dt
2936 real (kind=kind_phys), intent(in) :: qsnow
2937 real (kind=kind_phys), intent(in) :: cosz
2938 real (kind=kind_phys), intent(in) :: snowh
2939 real (kind=kind_phys), intent(in) :: tg
2940 real (kind=kind_phys), intent(in) :: tv
2941 real (kind=kind_phys), intent(in) :: elai
2942 real (kind=kind_phys), intent(in) :: esai
2943 real (kind=kind_phys), intent(in) :: fsno
2944 real (kind=kind_phys), intent(in) :: fwet
2945 real (kind=kind_phys), intent(in) :: sneqvo
2946 real (kind=kind_phys), intent(in) :: sneqv
2947 real (kind=kind_phys), intent(in) :: fveg
2948 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: smc
2949
2950! inout
2951 real (kind=kind_phys), intent(inout) :: albold
2952 real (kind=kind_phys), intent(inout) :: tauss
2953
2954! output
2955 real (kind=kind_phys), dimension(1: 2), intent(out) :: albgrd
2956 real (kind=kind_phys), dimension(1: 2), intent(out) :: albgri
2957 real (kind=kind_phys), dimension(1: 2), intent(out) :: albd
2958 real (kind=kind_phys), dimension(1: 2), intent(out) :: albi
2959 real (kind=kind_phys), dimension(1: 2), intent(out) :: fabd
2960 real (kind=kind_phys), dimension(1: 2), intent(out) :: fabi
2961 real (kind=kind_phys), dimension(1: 2), intent(out) :: ftdd
2962 real (kind=kind_phys), dimension(1: 2), intent(out) :: ftid
2963 real (kind=kind_phys), dimension(1: 2), intent(out) :: ftii
2964 real (kind=kind_phys), intent(out) :: fsun
2965!jref:start
2966 real (kind=kind_phys), dimension(1: 2), intent(out) :: frevd
2967 real (kind=kind_phys), dimension(1: 2), intent(out) :: frevi
2968 real (kind=kind_phys), dimension(1: 2), intent(out) :: fregd
2969 real (kind=kind_phys), dimension(1: 2), intent(out) :: fregi
2970 real (kind=kind_phys), intent(out) :: bgap
2971 real (kind=kind_phys), intent(out) :: wgap
2972!jref:end
2973
2974! ------------------------------------------------------------------------
2975! ------------------------ local variables -------------------------------
2976! local
2977 real (kind=kind_phys) :: fage !snow age function
2978 real (kind=kind_phys) :: alb
2979 integer :: ib !indices
2980 integer :: nband !number of solar radiation wave bands
2981 integer :: ic !direct beam: ic=0; diffuse: ic=1
2982
2983 real (kind=kind_phys) :: wl !fraction of lai+sai that is lai
2984 real (kind=kind_phys) :: ws !fraction of lai+sai that is sai
2985 real (kind=kind_phys) :: mpe !prevents overflow for division by zero
2986
2987 real (kind=kind_phys), dimension(1:2) :: rho !leaf/stem reflectance weighted by fraction lai and sai
2988 real (kind=kind_phys), dimension(1:2) :: tau !leaf/stem transmittance weighted by fraction lai and sai
2989 real (kind=kind_phys), dimension(1:2) :: ftdi !down direct flux below veg per unit dif flux = 0
2990 real (kind=kind_phys), dimension(1:2) :: albsnd !snow albedo (direct)
2991 real (kind=kind_phys), dimension(1:2) :: albsni !snow albedo (diffuse)
2992
2993 real (kind=kind_phys) :: vai !elai+esai
2994 real (kind=kind_phys) :: gdir !average projected leaf/stem area in solar direction
2995 real (kind=kind_phys) :: ext !optical depth direct beam per unit leaf + stem area
2996
2997! --------------------------------------------------------------------------------------------------
2998
2999 nband = 2
3000 mpe = 1.e-06
3001 bgap = 0.
3002 wgap = 0.
3003 frevd = 0.
3004 frevi = 0.
3005 fregd = 0.
3006 fregi = 0.
3007
3008! initialize output because solar radiation only done if cosz > 0
3009
3010 do ib = 1, nband
3011 albd(ib) = 0.
3012 albi(ib) = 0.
3013 albgrd(ib) = 0.
3014 albgri(ib) = 0.
3015 albsnd(ib) = 0.
3016 albsni(ib) = 0.
3017 fabd(ib) = 0.
3018 fabi(ib) = 0.
3019 ftdd(ib) = 0.
3020 ftid(ib) = 0.
3021 ftii(ib) = 0.
3022 if (ib.eq.1) fsun = 0.
3023 end do
3024
3025! snow age
3026
3027 call snow_age (parameters,dt,tg,sneqvo,sneqv,tauss,fage)
3028
3029 if(cosz > 0) then
3030
3031! weight reflectance/transmittance by lai and sai
3032
3033 do ib = 1, nband
3034 vai = elai + esai
3035 wl = elai / max(vai,mpe)
3036 ws = esai / max(vai,mpe)
3037 rho(ib) = max(parameters%rhol(ib)*wl+parameters%rhos(ib)*ws, mpe)
3038 tau(ib) = max(parameters%taul(ib)*wl+parameters%taus(ib)*ws, mpe)
3039 end do
3040
3041! snow albedos: only if cosz > 0 and fsno > 0
3042
3043 if(opt_alb == 1) &
3044 call snowalb_bats (parameters,nband, fsno,cosz,fage,albsnd,albsni)
3045 if(opt_alb == 2) then
3046 call snowalb_class (parameters,nband,qsnow,dt,alb,albold,albsnd,albsni,iloc,jloc)
3047 albold = alb
3048 end if
3049
3050! ground surface albedo
3051
3052 call groundalb (parameters,nsoil ,nband ,ice ,ist , & !in
3053 fsno ,smc ,albsnd ,albsni ,cosz , & !in
3054 tg ,iloc ,jloc , & !in
3055 albgrd ,albgri ) !out
3056
3057! loop over nband wavebands to calculate surface albedos and solar
3058! fluxes for unit incoming direct (ic=0) and diffuse flux (ic=1)
3059
3060 do ib = 1, nband
3061 ic = 0 ! direct
3062 call twostream (parameters,ib ,ic ,vegtyp ,cosz ,vai , & !in
3063 fwet ,tv ,albgrd ,albgri ,rho , & !in
3064 tau ,fveg ,ist ,iloc ,jloc , & !in
3065 fabd ,albd ,ftdd ,ftid ,gdir , &!) !out
3066 frevd ,fregd ,bgap ,wgap)
3067
3068 ic = 1 ! diffuse
3069 call twostream (parameters,ib ,ic ,vegtyp ,cosz ,vai , & !in
3070 fwet ,tv ,albgrd ,albgri ,rho , & !in
3071 tau ,fveg ,ist ,iloc ,jloc , & !in
3072 fabi ,albi ,ftdi ,ftii ,gdir , & !) !out
3073 frevi ,fregi ,bgap ,wgap)
3074
3075 end do
3076
3077! sunlit fraction of canopy. set fsun = 0 if fsun < 0.01.
3078
3079 ext = gdir/cosz * sqrt(1.-rho(1)-tau(1))
3080 fsun = (1.-exp(-ext*vai)) / max(ext*vai,mpe)
3081 ext = fsun
3082
3083 if (ext .lt. 0.01) then
3084 wl = 0.
3085 else
3086 wl = ext
3087 end if
3088 fsun = wl
3089 end if
3090
3091 end subroutine albedo
3092
3093!== begin surrad ===================================================================================
3094
3097 subroutine surrad (parameters,mpe ,fsun ,fsha ,elai ,vai , & !in
3098 laisun ,laisha ,solad ,solai ,fabd , & !in
3099 fabi ,ftdd ,ftid ,ftii ,albgrd , & !in
3100 albgri ,albd ,albi ,iloc ,jloc , & !in
3101 parsun ,parsha ,sav ,sag ,fsa , & !out
3102 fsr , & !) !out
3103 frevi ,frevd ,fregd ,fregi ,fsrv , &
3104 fsrg) !inout
3105
3106! --------------------------------------------------------------------------------------------------
3107 implicit none
3108! --------------------------------------------------------------------------------------------------
3109! input
3110
3111 type (noahmp_parameters), intent(in) :: parameters
3112 integer, intent(in) :: iloc
3113 integer, intent(in) :: jloc
3114 real (kind=kind_phys), intent(in) :: mpe
3115
3116 real (kind=kind_phys), intent(in) :: fsun
3117 real (kind=kind_phys), intent(in) :: fsha
3118 real (kind=kind_phys), intent(in) :: elai
3119 real (kind=kind_phys), intent(in) :: vai
3120 real (kind=kind_phys), intent(in) :: laisun
3121 real (kind=kind_phys), intent(in) :: laisha
3122
3123 real (kind=kind_phys), dimension(1:2), intent(in) :: solad
3124 real (kind=kind_phys), dimension(1:2), intent(in) :: solai
3125 real (kind=kind_phys), dimension(1:2), intent(in) :: fabd
3126 real (kind=kind_phys), dimension(1:2), intent(in) :: fabi
3127 real (kind=kind_phys), dimension(1:2), intent(in) :: ftdd
3128 real (kind=kind_phys), dimension(1:2), intent(in) :: ftid
3129 real (kind=kind_phys), dimension(1:2), intent(in) :: ftii
3130 real (kind=kind_phys), dimension(1:2), intent(in) :: albgrd
3131 real (kind=kind_phys), dimension(1:2), intent(in) :: albgri
3132 real (kind=kind_phys), dimension(1:2), intent(in) :: albd
3133 real (kind=kind_phys), dimension(1:2), intent(in) :: albi
3134
3135 real (kind=kind_phys), dimension(1:2), intent(in) :: frevd
3136 real (kind=kind_phys), dimension(1:2), intent(in) :: frevi
3137 real (kind=kind_phys), dimension(1:2), intent(in) :: fregd
3138 real (kind=kind_phys), dimension(1:2), intent(in) :: fregi
3139
3140! output
3141
3142 real (kind=kind_phys), intent(out) :: parsun
3143 real (kind=kind_phys), intent(out) :: parsha
3144 real (kind=kind_phys), intent(out) :: sav
3145 real (kind=kind_phys), intent(out) :: sag
3146 real (kind=kind_phys), intent(out) :: fsa
3147 real (kind=kind_phys), intent(out) :: fsr
3148 real (kind=kind_phys), intent(out) :: fsrv
3149 real (kind=kind_phys), intent(out) :: fsrg
3150
3151! ------------------------ local variables ----------------------------------------------------
3152 integer :: ib !waveband number (1=vis, 2=nir)
3153 integer :: nband !number of solar radiation waveband classes
3154
3155 real (kind=kind_phys) :: abs !absorbed solar radiation (w/m2)
3156 real (kind=kind_phys) :: rnir !reflected solar radiation [nir] (w/m2)
3157 real (kind=kind_phys) :: rvis !reflected solar radiation [vis] (w/m2)
3158 real (kind=kind_phys) :: laifra !leaf area fraction of canopy
3159 real (kind=kind_phys) :: trd !transmitted solar radiation: direct (w/m2)
3160 real (kind=kind_phys) :: tri !transmitted solar radiation: diffuse (w/m2)
3161 real (kind=kind_phys), dimension(1:2) :: cad !direct beam absorbed by canopy (w/m2)
3162 real (kind=kind_phys), dimension(1:2) :: cai !diffuse radiation absorbed by canopy (w/m2)
3163! ---------------------------------------------------------------------------------------------
3164 nband = 2
3165
3166! zero summed solar fluxes
3167
3168 sag = 0.
3169 sav = 0.
3170 fsa = 0.
3171
3172! loop over nband wavebands
3173
3174 do ib = 1, nband
3175
3176! absorbed by canopy
3177
3178 cad(ib) = solad(ib)*fabd(ib)
3179 cai(ib) = solai(ib)*fabi(ib)
3180 sav = sav + cad(ib) + cai(ib)
3181 fsa = fsa + cad(ib) + cai(ib)
3182
3183! transmitted solar fluxes incident on ground
3184
3185 trd = solad(ib)*ftdd(ib)
3186 tri = solad(ib)*ftid(ib) + solai(ib)*ftii(ib)
3187
3188! solar radiation absorbed by ground surface
3189
3190 abs = trd*(1.-albgrd(ib)) + tri*(1.-albgri(ib))
3191 sag = sag + abs
3192 fsa = fsa + abs
3193 end do
3194
3195! partition visible canopy absorption to sunlit and shaded fractions
3196! to get average absorbed par for sunlit and shaded leaves
3197
3198 laifra = elai / max(vai,mpe)
3199 if (fsun .gt. 0.) then
3200 parsun = (cad(1)+fsun*cai(1)) * laifra / max(laisun,mpe)
3201 parsha = (fsha*cai(1))*laifra / max(laisha,mpe)
3202 else
3203 parsun = 0.
3204 parsha = (cad(1)+cai(1))*laifra /max(laisha,mpe)
3205 endif
3206
3207! reflected solar radiation
3208
3209 rvis = albd(1)*solad(1) + albi(1)*solai(1)
3210 rnir = albd(2)*solad(2) + albi(2)*solai(2)
3211 fsr = rvis + rnir
3212
3213! reflected solar radiation of veg. and ground (combined ground)
3214 fsrv = frevd(1)*solad(1)+frevi(1)*solai(1)+frevd(2)*solad(2)+frevi(2)*solai(2)
3215 fsrg = fregd(1)*solad(1)+fregi(1)*solai(1)+fregd(2)*solad(2)+fregi(2)*solai(2)
3216
3217
3218 end subroutine surrad
3219
3220!== begin snow_age =================================================================================
3221
3224 subroutine snow_age (parameters,dt,tg,sneqvo,sneqv,tauss,fage)
3225! ----------------------------------------------------------------------
3226 implicit none
3227! ------------------------ code history ------------------------------------------------------------
3228! from bats
3229! ------------------------ input/output variables --------------------------------------------------
3230!input
3231 type (noahmp_parameters), intent(in) :: parameters
3232 real (kind=kind_phys), intent(in) :: dt
3233 real (kind=kind_phys), intent(in) :: tg
3234 real (kind=kind_phys), intent(in) :: sneqvo
3235 real (kind=kind_phys), intent(in) :: sneqv
3236
3237!output
3238 real (kind=kind_phys), intent(out) :: fage
3239
3240!input/output
3241 real (kind=kind_phys), intent(inout) :: tauss
3242!local
3243 real (kind=kind_phys) :: tage !total aging effects
3244 real (kind=kind_phys) :: age1 !effects of grain growth due to vapor diffusion
3245 real (kind=kind_phys) :: age2 !effects of grain growth at freezing of melt water
3246 real (kind=kind_phys) :: age3 !effects of soot
3247 real (kind=kind_phys) :: dela !temporary variable
3248 real (kind=kind_phys) :: sge !temporary variable
3249 real (kind=kind_phys) :: dels !temporary variable
3250 real (kind=kind_phys) :: dela0 !temporary variable
3251 real (kind=kind_phys) :: arg !temporary variable
3252! see yang et al. (1997) j.of climate for detail.
3253!---------------------------------------------------------------------------------------------------
3254
3255 if(sneqv.le.0.0) then
3256 tauss = 0.
3257 else
3258 dela0 = dt/parameters%tau0
3259 arg = parameters%grain_growth*(1./tfrz-1./tg)
3260 age1 = exp(arg)
3261 age2 = exp(amin1(0.,parameters%extra_growth*arg))
3262 age3 = parameters%dirt_soot
3263 tage = age1+age2+age3
3264 dela = dela0*tage
3265 dels = amax1(0.0,sneqv-sneqvo) / parameters%swemx
3266 sge = (tauss+dela)*(1.0-dels)
3267 tauss = amax1(0.,sge)
3268 endif
3269
3270 fage= tauss/(tauss+1.)
3271
3272 end subroutine snow_age
3273
3274!== begin snowalb_bats =============================================================================
3275
3278 subroutine snowalb_bats (parameters,nband,fsno,cosz,fage,albsnd,albsni)
3279! --------------------------------------------------------------------------------------------------
3280 implicit none
3281! --------------------------------------------------------------------------------------------------
3282! input
3283
3284 type (noahmp_parameters), intent(in) :: parameters
3285 integer,intent(in) :: nband
3286
3287 real (kind=kind_phys),intent(in) :: cosz
3288 real (kind=kind_phys),intent(in) :: fsno
3289 real (kind=kind_phys),intent(in) :: fage
3290
3291! output
3292
3293 real (kind=kind_phys), dimension(1:2),intent(out) :: albsnd
3294 real (kind=kind_phys), dimension(1:2),intent(out) :: albsni
3295! ---------------------------------------------------------------------------------------------
3296
3297! ------------------------ local variables ----------------------------------------------------
3298 integer :: ib !waveband class
3299
3300 real (kind=kind_phys) :: fzen !zenith angle correction
3301 real (kind=kind_phys) :: cf1 !temperary variable
3302 real (kind=kind_phys) :: sl2 !2.*sl
3303 real (kind=kind_phys) :: sl1 !1/sl
3304 real (kind=kind_phys) :: sl !adjustable parameter
3305! real (kind=kind_phys), parameter :: c1 = 0.2 !default in bats
3306! real (kind=kind_phys), parameter :: c2 = 0.5 !default in bats
3307! real (kind=kind_phys), parameter :: c1 = 0.2 * 2. ! double the default to match sleepers river's
3308! real (kind=kind_phys), parameter :: c2 = 0.5 * 2. ! snow surface albedo (double aging effects)
3309! ---------------------------------------------------------------------------------------------
3310! zero albedos for all points
3311
3312 albsnd(1: nband) = 0.
3313 albsni(1: nband) = 0.
3314
3315! when cosz > 0
3316
3317 sl=parameters%bats_cosz
3318 sl1=1./sl
3319 sl2=2.*sl
3320 cf1=((1.+sl1)/(1.+sl2*cosz)-sl1)
3321 fzen=amax1(cf1,0.)
3322
3323 albsni(1)=parameters%bats_vis_new*(1.-parameters%bats_vis_age*fage)
3324 albsni(2)=parameters%bats_nir_new*(1.-parameters%bats_nir_age*fage)
3325
3326 albsnd(1)=albsni(1)+parameters%bats_vis_dir*fzen*(1.-albsni(1)) ! vis direct
3327 albsnd(2)=albsni(2)+parameters%bats_vis_dir*fzen*(1.-albsni(2)) ! nir direct
3328
3329 end subroutine snowalb_bats
3330
3331!== begin snowalb_class ============================================================================
3332
3335 subroutine snowalb_class (parameters,nband,qsnow,dt,alb,albold,albsnd,albsni,iloc,jloc)
3336! ----------------------------------------------------------------------
3337 implicit none
3338! --------------------------------------------------------------------------------------------------
3339! input
3340
3341 type (noahmp_parameters), intent(in) :: parameters
3342 integer,intent(in) :: iloc
3343 integer,intent(in) :: jloc
3344 integer,intent(in) :: nband
3345
3346 real (kind=kind_phys),intent(in) :: qsnow
3347 real (kind=kind_phys),intent(in) :: dt
3348 real (kind=kind_phys),intent(in) :: albold
3349
3350! in & out
3351
3352 real (kind=kind_phys), intent(inout) :: alb
3353! output
3354
3355 real (kind=kind_phys), dimension(1:2),intent(out) :: albsnd
3356 real (kind=kind_phys), dimension(1:2),intent(out) :: albsni
3357! ---------------------------------------------------------------------------------------------
3358
3359! ------------------------ local variables ----------------------------------------------------
3360 integer :: ib !waveband class
3361
3362! ---------------------------------------------------------------------------------------------
3363! zero albedos for all points
3364
3365 albsnd(1: nband) = 0.
3366 albsni(1: nband) = 0.
3367
3368! when cosz > 0
3369
3370 alb = 0.55 + (albold-0.55) * exp(-0.01*dt/3600.)
3371
3372! 1 mm fresh snow(swe) -- 10mm snow depth, assumed the fresh snow density 100kg/m3
3373! here assume 1cm snow depth will fully cover the old snow
3374
3375 if (qsnow > 0.) then
3376 alb = alb + min(qsnow,parameters%swemx/dt) * (0.84-alb)/(parameters%swemx/dt)
3377 endif
3378
3379 albsni(1)= alb ! vis diffuse
3380 albsni(2)= alb ! nir diffuse
3381 albsnd(1)= alb ! vis direct
3382 albsnd(2)= alb ! nir direct
3383
3384 end subroutine snowalb_class
3385
3386!== begin groundalb ================================================================================
3387
3390 subroutine groundalb (parameters,nsoil ,nband ,ice ,ist , & !in
3391 fsno ,smc ,albsnd ,albsni ,cosz , & !in
3392 tg ,iloc ,jloc , & !in
3393 albgrd ,albgri ) !out
3394! --------------------------------------------------------------------------------------------------
3395 implicit none
3396! --------------------------------------------------------------------------------------------------
3397!input
3398
3399 type (noahmp_parameters), intent(in) :: parameters
3400 integer, intent(in) :: iloc
3401 integer, intent(in) :: jloc
3402 integer, intent(in) :: nsoil
3403 integer, intent(in) :: nband
3404 integer, intent(in) :: ice
3405 integer, intent(in) :: ist
3406 real (kind=kind_phys), intent(in) :: fsno
3407 real (kind=kind_phys), intent(in) :: tg
3408 real (kind=kind_phys), intent(in) :: cosz
3409 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: smc
3410 real (kind=kind_phys), dimension(1: 2), intent(in) :: albsnd
3411 real (kind=kind_phys), dimension(1: 2), intent(in) :: albsni
3412
3413!output
3414
3415 real (kind=kind_phys), dimension(1: 2), intent(out) :: albgrd
3416 real (kind=kind_phys), dimension(1: 2), intent(out) :: albgri
3417
3418!local
3419
3420 integer :: ib !waveband number (1=vis, 2=nir)
3421 real (kind=kind_phys) :: inc !soil water correction factor for soil albedo
3422 real (kind=kind_phys) :: albsod !soil albedo (direct)
3423 real (kind=kind_phys) :: albsoi !soil albedo (diffuse)
3424! --------------------------------------------------------------------------------------------------
3425
3426 do ib = 1, nband
3427 inc = max(0.11-0.40*smc(1), 0.)
3428 if (ist .eq. 1) then !soil
3429 albsod = min(parameters%albsat(ib)+inc,parameters%albdry(ib))
3430 albsoi = albsod
3431 else if (tg .gt. tfrz) then !unfrozen lake, wetland
3432 albsod = 0.06/(max(0.01,cosz)**1.7 + 0.15)
3433 albsoi = 0.06
3434 else !frozen lake, wetland
3435 albsod = parameters%alblak(ib)
3436 albsoi = albsod
3437 end if
3438
3439! increase desert and semi-desert albedos
3440
3441! if (ist .eq. 1 .and. isc .eq. 9) then
3442! albsod = albsod + 0.10
3443! albsoi = albsoi + 0.10
3444! end if
3445
3446 albgrd(ib) = albsod*(1.-fsno) + albsnd(ib)*fsno
3447 albgri(ib) = albsoi*(1.-fsno) + albsni(ib)*fsno
3448 end do
3449
3450 end subroutine groundalb
3451
3452!== begin twostream ================================================================================
3453
3460 subroutine twostream (parameters,ib ,ic ,vegtyp ,cosz ,vai , & !in
3461 fwet ,t ,albgrd ,albgri ,rho , & !in
3462 tau ,fveg ,ist ,iloc ,jloc , & !in
3463 fab ,fre ,ftd ,fti ,gdir , & !) !out
3464 frev ,freg ,bgap ,wgap)
3465
3466! --------------------------------------------------------------------------------------------------
3467! use two-stream approximation of dickinson (1983) adv geophysics
3468! 25:305-353 and sellers (1985) int j remote sensing 6:1335-1372
3469! to calculate fluxes absorbed by vegetation, reflected by vegetation,
3470! and transmitted through vegetation for unit incoming direct or diffuse
3471! flux given an underlying surface with known albedo.
3472! --------------------------------------------------------------------------------------------------
3473 implicit none
3474! --------------------------------------------------------------------------------------------------
3475! input
3476
3477 type (noahmp_parameters), intent(in) :: parameters
3478 integer, intent(in) :: iloc
3479 integer, intent(in) :: jloc
3480 integer, intent(in) :: ist
3481 integer, intent(in) :: ib
3482 integer, intent(in) :: ic
3483 integer, intent(in) :: vegtyp
3484
3485 real (kind=kind_phys), intent(in) :: cosz
3486 real (kind=kind_phys), intent(in) :: vai
3487 real (kind=kind_phys), intent(in) :: fwet
3488 real (kind=kind_phys), intent(in) :: t
3489
3490 real (kind=kind_phys), dimension(1:2), intent(in) :: albgrd
3491 real (kind=kind_phys), dimension(1:2), intent(in) :: albgri
3492 real (kind=kind_phys), dimension(1:2), intent(in) :: rho
3493 real (kind=kind_phys), dimension(1:2), intent(in) :: tau
3494 real (kind=kind_phys), intent(in) :: fveg
3495
3496! output
3497
3498 real (kind=kind_phys), dimension(1:2), intent(out) :: fab
3499 real (kind=kind_phys), dimension(1:2), intent(out) :: fre
3500 real (kind=kind_phys), dimension(1:2), intent(out) :: ftd
3501 real (kind=kind_phys), dimension(1:2), intent(out) :: fti
3502 real (kind=kind_phys), intent(out) :: gdir
3503 real (kind=kind_phys), dimension(1:2), intent(out) :: frev
3504 real (kind=kind_phys), dimension(1:2), intent(out) :: freg
3505
3506! local
3507 real (kind=kind_phys) :: omega !fraction of intercepted radiation that is scattered
3508 real (kind=kind_phys) :: omegal !omega for leaves
3509 real (kind=kind_phys) :: betai !upscatter parameter for diffuse radiation
3510 real (kind=kind_phys) :: betail !betai for leaves
3511 real (kind=kind_phys) :: betad !upscatter parameter for direct beam radiation
3512 real (kind=kind_phys) :: betadl !betad for leaves
3513 real (kind=kind_phys) :: ext !optical depth of direct beam per unit leaf area
3514 real (kind=kind_phys) :: avmu !average diffuse optical depth
3515
3516 real (kind=kind_phys) :: coszi !0.001 <= cosz <= 1.000
3517 real (kind=kind_phys) :: asu !single scattering albedo
3518 real (kind=kind_phys) :: chil ! -0.4 <= xl <= 0.6
3519
3520 real (kind=kind_phys) :: tmp0,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,tmp7,tmp8,tmp9
3521 real (kind=kind_phys) :: p1,p2,p3,p4,s1,s2,u1,u2,u3
3522 real (kind=kind_phys) :: b,c,d,d1,d2,f,h,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10
3523 real (kind=kind_phys) :: phi1,phi2,sigma
3524 real (kind=kind_phys) :: ftds,ftis,fres
3525 real (kind=kind_phys) :: denfveg
3526 real (kind=kind_phys) :: vai_spread
3527!jref:start
3528 real (kind=kind_phys) :: freveg,frebar,ftdveg,ftiveg,ftdbar,ftibar
3529 real (kind=kind_phys) :: thetaz
3530!jref:end
3531
3532! variables for the modified two-stream scheme
3533! niu and yang (2004), jgr
3534
3535 real (kind=kind_phys), parameter :: pai = 3.14159265
3536 real (kind=kind_phys) :: hd !crown depth (m)
3537 real (kind=kind_phys) :: bb !vertical crown radius (m)
3538 real (kind=kind_phys) :: thetap !angle conversion from sza
3539 real (kind=kind_phys) :: fa !foliage volume density (m-1)
3540 real (kind=kind_phys) :: newvai !effective lsai (-)
3541
3542 real (kind=kind_phys),intent(inout) :: bgap !between canopy gap fraction for beam (-)
3543 real (kind=kind_phys),intent(inout) :: wgap !within canopy gap fraction for beam (-)
3544
3545 real (kind=kind_phys) :: kopen !gap fraction for diffue light (-)
3546 real (kind=kind_phys) :: gap !total gap fraction for beam ( <=1-shafac )
3547
3548! -----------------------------------------------------------------
3549! compute within and between gaps
3550 vai_spread = vai
3551 if(vai == 0.0) then
3552 gap = 1.0
3553 kopen = 1.0
3554 else
3555 if(opt_rad == 1) then
3556 denfveg = -log(max(1.0-fveg,0.01))/(pai*parameters%rc**2)
3557 hd = parameters%hvt - parameters%hvb
3558 bb = 0.5 * hd
3559 thetap = atan(bb/parameters%rc * tan(acos(max(0.01,cosz))) )
3560 ! bgap = exp(-parameters%den * pai * parameters%rc**2/cos(thetap) )
3561 bgap = exp(-denfveg * pai * parameters%rc**2/cos(thetap) )
3562 fa = vai/(1.33 * pai * parameters%rc**3.0 *(bb/parameters%rc)*denfveg)
3563 newvai = hd*fa
3564 wgap = (1.0-bgap) * exp(-0.5*newvai/cosz)
3565 gap = min(1.0-fveg, bgap+wgap)
3566
3567 kopen = 0.05
3568 end if
3569
3570 if(opt_rad == 2) then
3571 gap = 0.0
3572 kopen = 0.0
3573 end if
3574
3575 if(opt_rad == 3) then
3576 gap = 1.0-fveg
3577 kopen = 1.0-fveg
3578 end if
3579 end if
3580
3581! calculate two-stream parameters omega, betad, betai, avmu, gdir, ext.
3582! omega, betad, betai are adjusted for snow. values for omega*betad
3583! and omega*betai are calculated and then divided by the new omega
3584! because the product omega*betai, omega*betad is used in solution.
3585! also, the transmittances and reflectances (tau, rho) are linear
3586! weights of leaf and stem values.
3587
3588 coszi = max(0.001, cosz)
3589 chil = min( max(parameters%xl, -0.4), 0.6)
3590 if (abs(chil) .le. 0.01) chil = 0.01
3591 phi1 = 0.5 - 0.633*chil - 0.330*chil*chil
3592 phi2 = 0.877 * (1.-2.*phi1)
3593 gdir = phi1 + phi2*coszi
3594 ext = gdir/coszi
3595 avmu = ( 1. - phi1/phi2 * log((phi1+phi2)/phi1) ) / phi2
3596 omegal = rho(ib) + tau(ib)
3597 tmp0 = gdir + phi2*coszi
3598 tmp1 = phi1*coszi
3599 asu = 0.5*omegal*gdir/tmp0 * ( 1.-tmp1/tmp0*log((tmp1+tmp0)/tmp1) )
3600 betadl = (1.+avmu*ext)/(omegal*avmu*ext)*asu
3601 betail = 0.5 * ( rho(ib)+tau(ib) + (rho(ib)-tau(ib)) &
3602 * ((1.+chil)/2.)**2 ) / omegal
3603
3604! adjust omega, betad, and betai for intercepted snow
3605
3606 if (t .gt. tfrz) then !no snow
3607 tmp0 = omegal
3608 tmp1 = betadl
3609 tmp2 = betail
3610 else
3611 tmp0 = (1.-fwet)*omegal + fwet*parameters%omegas(ib)
3612 tmp1 = ( (1.-fwet)*omegal*betadl + fwet*parameters%omegas(ib)*parameters%betads ) / tmp0
3613 tmp2 = ( (1.-fwet)*omegal*betail + fwet*parameters%omegas(ib)*parameters%betais ) / tmp0
3614 end if
3615
3616 omega = tmp0
3617 betad = tmp1
3618 betai = tmp2
3619
3620! absorbed, reflected, transmitted fluxes per unit incoming radiation
3621
3622 b = 1. - omega + omega*betai
3623 c = omega*betai
3624 tmp0 = avmu*ext
3625 d = tmp0 * omega*betad
3626 f = tmp0 * omega*(1.-betad)
3627 tmp1 = b*b - c*c
3628 h = sqrt(tmp1) / avmu
3629 sigma = tmp0*tmp0 - tmp1
3630 if ( abs(sigma) < 1.e-6 ) sigma = sign(1.e-6_kind_phys,sigma)
3631 p1 = b + avmu*h
3632 p2 = b - avmu*h
3633 p3 = b + tmp0
3634 p4 = b - tmp0
3635 s1 = exp(-h*vai)
3636 s2 = exp(-ext*vai)
3637 if (ic .eq. 0) then
3638 u1 = b - c/albgrd(ib)
3639 u2 = b - c*albgrd(ib)
3640 u3 = f + c*albgrd(ib)
3641 else
3642 u1 = b - c/albgri(ib)
3643 u2 = b - c*albgri(ib)
3644 u3 = f + c*albgri(ib)
3645 end if
3646 tmp2 = u1 - avmu*h
3647 tmp3 = u1 + avmu*h
3648 d1 = p1*tmp2/s1 - p2*tmp3*s1
3649 tmp4 = u2 + avmu*h
3650 tmp5 = u2 - avmu*h
3651 d2 = tmp4/s1 - tmp5*s1
3652 h1 = -d*p4 - c*f
3653 tmp6 = d - h1*p3/sigma
3654 tmp7 = ( d - c - h1/sigma*(u1+tmp0) ) * s2
3655 h2 = ( tmp6*tmp2/s1 - p2*tmp7 ) / d1
3656 h3 = - ( tmp6*tmp3*s1 - p1*tmp7 ) / d1
3657 h4 = -f*p3 - c*d
3658 tmp8 = h4/sigma
3659 tmp9 = ( u3 - tmp8*(u2-tmp0) ) * s2
3660 h5 = - ( tmp8*tmp4/s1 + tmp9 ) / d2
3661 h6 = ( tmp8*tmp5*s1 + tmp9 ) / d2
3662 h7 = (c*tmp2) / (d1*s1)
3663 h8 = (-c*tmp3*s1) / d1
3664 h9 = tmp4 / (d2*s1)
3665 h10 = (-tmp5*s1) / d2
3666
3667! downward direct and diffuse fluxes below vegetation
3668! niu and yang (2004), jgr.
3669
3670 if (ic .eq. 0) then
3671 ftds = s2 *(1.0-gap) + gap
3672 ftis = (h4*s2/sigma + h5*s1 + h6/s1)*(1.0-gap)
3673 else
3674 ftds = 0.
3675 ftis = (h9*s1 + h10/s1)*(1.0-kopen) + kopen
3676 end if
3677 ftd(ib) = ftds
3678 fti(ib) = ftis
3679
3680! flux reflected by the surface (veg. and ground)
3681
3682 if (ic .eq. 0) then
3683 fres = (h1/sigma + h2 + h3)*(1.0-gap ) + albgrd(ib)*gap
3684 freveg = (h1/sigma + h2 + h3)*(1.0-gap )
3685 frebar = albgrd(ib)*gap !jref - separate veg. and ground reflection
3686 else
3687 fres = (h7 + h8) *(1.0-kopen) + albgri(ib)*kopen
3688 freveg = (h7 + h8) *(1.0-kopen) + albgri(ib)*kopen
3689 frebar = 0 !jref - separate veg. and ground reflection
3690 end if
3691 fre(ib) = fres
3692
3693 frev(ib) = freveg
3694 freg(ib) = frebar
3695! flux absorbed by vegetation
3696
3697 fab(ib) = 1. - fre(ib) - (1.-albgrd(ib))*ftd(ib) &
3698 - (1.-albgri(ib))*fti(ib)
3699
3700!if(iloc == 1.and.jloc == 2) then
3701! write(*,'(a7,2i2,5(a6,f8.4),2(a9,f8.4))') "ib,ic: ",ib,ic," gap: ",gap," ftd: ",ftd(ib)," fti: ",fti(ib)," fre: ", &
3702! fre(ib)," fab: ",fab(ib)," albgrd: ",albgrd(ib)," albgri: ",albgri(ib)
3703!end if
3704
3705 end subroutine twostream
3706
3707!== begin vege_flux ================================================================================
3708
3712 subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & !in
3713 dt ,sav ,sag ,lwdn ,ur , & !in
3714 uu ,vv ,sfctmp ,thair ,qair , & !in
3715 eair ,rhoair ,snowh ,vai ,gammav ,gammag, & !in
3716 fwet ,laisun ,laisha ,cwp ,dzsnso , & !in
3717 zlvl ,zpd ,z0m ,fveg ,shdfac, & !in
3718 z0mg ,emv ,emg ,canliq ,fsno, & !in
3719 canice ,stc ,df ,rssun ,rssha , & !in
3720 rsurf ,latheav ,latheag ,parsun ,parsha ,igs , & !in
3721 foln ,co2air ,o2air ,btran ,sfcprs , & !in
3722 rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in
3723 thsfc_loc, prslkix,prsik1x,prslk1x, garea1, & !in
3724 pblhx ,iz0tlnd ,itime ,psi_opt ,ep_1, ep_2, epsm1, cp, &
3725 eah ,tah ,tv ,tg ,cm,ustarx,& !inout
3726#ifdef CCPP
3727 ch ,dx ,dz8w ,errmsg ,errflg , & !inout
3728#else
3729 ch ,dx ,dz8w , & !inout
3730#endif
3731 tauxv ,tauyv ,irg ,irc ,shg , & !out
3732 shc ,evg ,evc ,tr ,gh , & !out
3733 t2mv ,psnsun ,psnsha ,canhs , & !out
3734 csigmaf1, & !out
3735 qc ,qsfc ,psfc , & !in
3736 q2v ,cah2 ,chleaf ,chuc , & !inout
3737 rb) !out
3738
3739! --------------------------------------------------------------------------------------------------
3740! use newton-raphson iteration to solve for vegetation (tv) and
3741! ground (tg) temperatures that balance the surface energy budgets
3742
3743! vegetated:
3744! -sav + irc[tv] + shc[tv] + evc[tv] + tr[tv] + canhs[tv] = 0
3745! -sag + irg[tg] + shg[tg] + evg[tg] + gh[tg] = 0
3746! --------------------------------------------------------------------------------------------------
3747 use funcphys, only : fpvs
3748 implicit none
3749! --------------------------------------------------------------------------------------------------
3750! input
3751 type (noahmp_parameters), intent(in) :: parameters
3752 integer, intent(in) :: iloc
3753 integer, intent(in) :: jloc
3754 logical, intent(in) :: veg
3755 integer, intent(in) :: nsnow
3756 integer, intent(in) :: nsoil
3757 integer, intent(in) :: isnow
3758 integer, intent(in) :: vegtyp
3759 real (kind=kind_phys), intent(in) :: fveg
3760 real (kind=kind_phys), intent(in) :: sav
3761 real (kind=kind_phys), intent(in) :: sag
3762 real (kind=kind_phys), intent(in) :: lwdn
3763 real (kind=kind_phys), intent(in) :: ur
3764 real (kind=kind_phys), intent(in) :: uu
3765 real (kind=kind_phys), intent(in) :: vv
3766 real (kind=kind_phys), intent(in) :: sfctmp
3767 real (kind=kind_phys), intent(in) :: thair
3768 real (kind=kind_phys), intent(in) :: eair
3769 real (kind=kind_phys), intent(in) :: qair
3770 real (kind=kind_phys), intent(in) :: rhoair
3771 real (kind=kind_phys), intent(in) :: dt
3772 real (kind=kind_phys), intent(in) :: fsno
3773
3774 real (kind=kind_phys) , intent(in) :: pblhx
3775 real (kind=kind_phys) , intent(in) :: ep_1
3776 real (kind=kind_phys) , intent(in) :: ep_2
3777 real (kind=kind_phys) , intent(in) :: epsm1
3778 real (kind=kind_phys) , intent(in) :: cp
3779 integer , intent(in) :: iz0tlnd
3780 integer , intent(in) :: itime
3781 integer , intent(in) :: psi_opt
3782
3783
3784 real (kind=kind_phys), intent(in) :: snowh
3785 real (kind=kind_phys), intent(in) :: fwet
3786 real (kind=kind_phys), intent(in) :: cwp
3787
3788 real (kind=kind_phys), intent(in) :: vai
3789 real (kind=kind_phys), intent(in) :: laisun
3790 real (kind=kind_phys), intent(in) :: laisha
3791 real (kind=kind_phys), intent(in) :: zlvl
3792 real (kind=kind_phys), intent(in) :: zpd
3793 real (kind=kind_phys), intent(in) :: z0m
3794 real (kind=kind_phys), intent(in) :: z0mg
3795 real (kind=kind_phys), intent(in) :: emv
3796 real (kind=kind_phys), intent(in) :: emg
3797
3798 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc
3799 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: df
3800 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
3801 real (kind=kind_phys), intent(in) :: canliq
3802 real (kind=kind_phys), intent(in) :: canice
3803 real (kind=kind_phys), intent(in) :: rsurf
3804! real (kind=kind_phys), intent(in) :: gamma !< psychrometric constant (pa/k)
3805! real (kind=kind_phys), intent(in) :: lathea !< latent heat of vaporization/subli (j/kg)
3806 real (kind=kind_phys), intent(in) :: gammav
3807 real (kind=kind_phys), intent(in) :: latheav
3808 real (kind=kind_phys), intent(in) :: gammag
3809 real (kind=kind_phys), intent(in) :: latheag
3810 real (kind=kind_phys), intent(in) :: parsun
3811 real (kind=kind_phys), intent(in) :: parsha
3812 real (kind=kind_phys), intent(in) :: foln
3813 real (kind=kind_phys), intent(in) :: co2air
3814 real (kind=kind_phys), intent(in) :: o2air
3815 real (kind=kind_phys), intent(in) :: igs
3816 real (kind=kind_phys), intent(in) :: sfcprs
3817 real (kind=kind_phys), intent(in) :: btran
3818 real (kind=kind_phys), intent(in) :: rhsur
3819
3820 real (kind=kind_phys) , intent(in) :: qc
3821 real (kind=kind_phys) , intent(in) :: psfc
3822 real (kind=kind_phys) , intent(in) :: dx
3823 real (kind=kind_phys) , intent(in) :: q2
3824 real (kind=kind_phys) , intent(in) :: dz8w
3825 real (kind=kind_phys) , intent(inout) :: qsfc
3826 real (kind=kind_phys), intent(in) :: pahv
3827 real (kind=kind_phys), intent(in) :: pahg
3828
3829! input/output
3830 real (kind=kind_phys), intent(inout) :: eah
3831 real (kind=kind_phys), intent(inout) :: tah
3832 real (kind=kind_phys), intent(inout) :: tv
3833 real (kind=kind_phys), intent(inout) :: tg
3834 real (kind=kind_phys), intent(inout) :: cm
3835 real (kind=kind_phys), intent(inout) :: ch
3836
3837#ifdef CCPP
3838 character(len=*), intent(inout) :: errmsg
3839 integer, intent(inout) :: errflg
3840#endif
3841
3842! output
3843! -fsa + fira + fsh + (fcev + fctr + fgev) + fcst + ssoil + canhs = 0
3844 real (kind=kind_phys), intent(out) :: tauxv
3845 real (kind=kind_phys), intent(out) :: tauyv
3846 real (kind=kind_phys), intent(out) :: irc
3847 real (kind=kind_phys), intent(out) :: shc
3848 real (kind=kind_phys), intent(out) :: evc
3849 real (kind=kind_phys), intent(out) :: irg
3850 real (kind=kind_phys), intent(out) :: shg
3851 real (kind=kind_phys), intent(out) :: evg
3852 real (kind=kind_phys), intent(out) :: tr
3853 real (kind=kind_phys), intent(out) :: gh
3854 real (kind=kind_phys), intent(out) :: t2mv
3855 real (kind=kind_phys), intent(out) :: psnsun
3856 real (kind=kind_phys), intent(out) :: psnsha
3857 real (kind=kind_phys), intent(out) :: chleaf
3858 real (kind=kind_phys), intent(out) :: chuc
3859 real (kind=kind_phys), intent(out) :: canhs
3860 real (kind=kind_phys), intent(out) :: q2v
3861 real (kind=kind_phys), intent(out) :: rb
3862 real (kind=kind_phys) :: cah
3863 real (kind=kind_phys) :: u10v
3864 real (kind=kind_phys) :: v10v
3865 real (kind=kind_phys) :: wspd
3866
3867! ------------------------ local variables ----------------------------------------------------
3868 real (kind=kind_phys) :: gdx !grid dx
3869 real (kind=kind_phys) :: snwd ! snowdepth in mm
3870 integer :: mnice ! MYNN ice flag
3871
3872 real (kind=kind_phys) :: cw !water vapor exchange coefficient
3873 real (kind=kind_phys) :: fv !friction velocity (m/s)
3874 real (kind=kind_phys) :: wstar !friction velocity n vertical direction (m/s) (only for sfcdif2)
3875 real (kind=kind_phys) :: z0mo !roughness length for intermediate output only (m)
3876 real (kind=kind_phys) :: z0h !roughness length, sensible heat (m)
3877 real (kind=kind_phys) :: z0hg !roughness length, sensible heat (m)
3878 real (kind=kind_phys) :: ramc !aerodynamic resistance for momentum (s/m)
3879 real (kind=kind_phys) :: rahc !aerodynamic resistance for sensible heat (s/m)
3880 real (kind=kind_phys) :: rawc !aerodynamic resistance for water vapor (s/m)
3881 real (kind=kind_phys) :: ramg !aerodynamic resistance for momentum (s/m)
3882 real (kind=kind_phys) :: rahg !aerodynamic resistance for sensible heat (s/m)
3883 real (kind=kind_phys) :: rawg !aerodynamic resistance for water vapor (s/m)
3884
3885 real (kind=kind_phys), intent(out) :: rssun !sunlit leaf stomatal resistance (s/m)
3886 real (kind=kind_phys), intent(out) :: rssha !shaded leaf stomatal resistance (s/m)
3887
3888 real (kind=kind_phys) :: mol !monin-obukhov length (m)
3889 real (kind=kind_phys) :: dtv !change in tv, last iteration (k)
3890 real (kind=kind_phys) :: dtg !change in tg, last iteration (k)
3891
3892 real (kind=kind_phys) :: air,cir !coefficients for ir as function of ts**4
3893 real (kind=kind_phys) :: csh !coefficients for sh as function of ts
3894 real (kind=kind_phys) :: cev !coefficients for ev as function of esat[ts]
3895 real (kind=kind_phys) :: cgh !coefficients for st as function of ts
3896 real (kind=kind_phys) :: atr,ctr !coefficients for tr as function of esat[ts]
3897 real (kind=kind_phys) :: ata,bta !coefficients for tah as function of ts
3898 real (kind=kind_phys) :: aea,bea !coefficients for eah as function of esat[ts]
3899
3900 real (kind=kind_phys) :: estv !saturation vapor pressure at tv (pa)
3901 real (kind=kind_phys) :: estg !saturation vapor pressure at tg (pa)
3902 real (kind=kind_phys) :: destv !d(es)/dt at ts (pa/k)
3903 real (kind=kind_phys) :: destg !d(es)/dt at tg (pa/k)
3904 real (kind=kind_phys) :: esatw !es for water
3905 real (kind=kind_phys) :: esati !es for ice
3906 real (kind=kind_phys) :: dsatw !d(es)/dt at tg (pa/k) for water
3907 real (kind=kind_phys) :: dsati !d(es)/dt at tg (pa/k) for ice
3908
3909 real (kind=kind_phys) :: fm !momentum stability correction, weighted by prior iters
3910 real (kind=kind_phys) :: fh !sen heat stability correction, weighted by prior iters
3911 real (kind=kind_phys) :: fhg !sen heat stability correction, ground
3912 real (kind=kind_phys) :: fhgh !sen heat stability correction, canopy
3913 real (kind=kind_phys) :: hcan !canopy height (m) [note: hcan >= z0mg]
3914
3915 real (kind=kind_phys) :: a !temporary calculation
3916 real (kind=kind_phys) :: b !temporary calculation
3917 real (kind=kind_phys) :: cvh !sensible heat conductance, leaf surface to canopy air (m/s)
3918 real (kind=kind_phys) :: caw !latent heat conductance, canopy air zlvl air (m/s)
3919 real (kind=kind_phys) :: ctw !transpiration conductance, leaf to canopy air (m/s)
3920 real (kind=kind_phys) :: cew !evaporation conductance, leaf to canopy air (m/s)
3921 real (kind=kind_phys) :: cgw !latent heat conductance, ground to canopy air (m/s)
3922 real (kind=kind_phys) :: cond !sum of conductances (s/m)
3923 real (kind=kind_phys) :: uc !wind speed at top of canopy (m/s)
3924 real (kind=kind_phys) :: kh !turbulent transfer coefficient, sensible heat, (m2/s)
3925 real (kind=kind_phys) :: h !temporary sensible heat flux (w/m2)
3926 real (kind=kind_phys) :: hg !temporary sensible heat flux (w/m2)
3927 real (kind=kind_phys) :: moz !monin-obukhov stability parameter
3928 real (kind=kind_phys) :: mozg !monin-obukhov stability parameter
3929 real (kind=kind_phys) :: mozold !monin-obukhov stability parameter from prior iteration
3930 real (kind=kind_phys) :: fm2 !monin-obukhov momentum adjustment at 2m
3931 real (kind=kind_phys) :: fh2 !monin-obukhov heat adjustment at 2m
3932 real (kind=kind_phys) :: ch2 !surface exchange at 2m
3933 real (kind=kind_phys) :: thstar !surface exchange at 2m
3934
3935 real (kind=kind_phys) :: fm10
3936 real (kind=kind_phys) :: rb1v
3937 real (kind=kind_phys) :: stress1v
3938
3939
3940 real (kind=kind_phys) :: flhcv ! for MYNN
3941 real (kind=kind_phys) :: flqcv ! for MYNN
3942 real (kind=kind_phys) :: wspdv ! for MYNN
3943
3944 real (kind=kind_phys) :: thvair
3945 real (kind=kind_phys) :: thah
3946 real (kind=kind_phys) :: rahc2 !aerodynamic resistance for sensible heat (s/m)
3947 real (kind=kind_phys) :: rawc2 !aerodynamic resistance for water vapor (s/m)
3948 real (kind=kind_phys), intent(out):: cah2 !sensible heat conductance for diagnostics
3949 real (kind=kind_phys) :: ch2v !exchange coefficient for 2m over vegetation.
3950 real (kind=kind_phys) :: cq2v !exchange coefficient for 2m over vegetation.
3951 real (kind=kind_phys) :: eah2 !2m vapor pressure over canopy
3952 real (kind=kind_phys) :: qfx !moisture flux
3953 real (kind=kind_phys) :: e1
3954 real (kind=kind_phys) :: hcv !canopy heat capacity j/m2/k, C.He added
3955
3956 real (kind=kind_phys) :: vaie !total leaf area index + stem area index,effective
3957 real (kind=kind_phys) :: laisune !sunlit leaf area index, one-sided (m2/m2),effective
3958 real (kind=kind_phys) :: laishae !shaded leaf area index, one-sided (m2/m2),effective
3959
3960 integer :: k !index
3961 integer :: iter !iteration index
3962
3963!jref - niterc test from 5 to 20
3964 integer, parameter :: niterc = 20 !number of iterations for surface temperature
3965!jref - niterg test from 3-5
3966 integer, parameter :: niterg = 5 !number of iterations for ground temperature
3967 integer :: mozsgn !number of times moz changes sign
3968 real (kind=kind_phys) :: mpe !prevents overflow error if division by zero
3969
3970 integer :: liter !last iteration
3971
3972! New variables for sfcdif3
3973
3974 logical , intent(in ) :: thsfc_loc
3975 real (kind=kind_phys), intent(in ) :: prslkix ! in exner function
3976 real (kind=kind_phys), intent(in ) :: prsik1x ! in exner function
3977 real (kind=kind_phys), intent(in ) :: prslk1x ! in exner function
3978 real (kind=kind_phys), intent(in ) :: garea1
3979 real (kind=kind_phys), intent(in ) :: shdfac ! greeness vegetation fraction (-)
3980 real (kind=kind_phys), intent(inout) :: ustarx ! friction velocity
3981 real (kind=kind_phys), intent( out) :: csigmaf1 !
3982 real (kind=kind_phys) :: csigmaf0 !
3983! dummy for thermal roughness scheme
3984 real (kind=kind_phys) :: temptrs
3985
3986
3987 real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50
3988
3989 real(kind=kind_phys) :: evpot
3990 real(kind=kind_phys) :: fhi, qss, wrk
3991 real(kind=kind_phys), parameter :: qmin=1.0e-8
3992
3993 character(len=80) :: message
3994
3995 tdc(t) = min( 50., max(-50.,(t-tfrz)) )
3996! ---------------------------------------------------------------------------------------------
3997
3998 mpe = 1e-6
3999 liter = 0
4000 temptrs = 1.
4001
4002 fv = ustarx
4003! ---------------------------------------------------------------------------------------------
4004! initialization variables that do not depend on stability iteration
4005! ---------------------------------------------------------------------------------------------
4006 dtv = 0.
4007 dtg = 0.
4008 moz = 0.
4009 mozsgn = 0
4010 mozold = 0.
4011 fh2 = 0.
4012 hg = 0.
4013 h = 0.
4014 qfx = 0.
4015
4016! limit lai
4017
4018 vaie = min(6.,vai )
4019 laisune = min(6.,laisun)
4020 laishae = min(6.,laisha)
4021
4022! saturation vapor pressure at ground temperature
4023
4024 t = tdc(tg)
4025 call esat(t, esatw, esati, dsatw, dsati)
4026 if (t .gt. 0.) then
4027 estg = esatw
4028 else
4029 estg = esati
4030 end if
4031
4032!jref - consistent surface specific humidity for sfcdif3 and sfcdif4
4033
4034 qsfc = ep_2*eair/(psfc+epsm1*eair)
4035
4036! canopy height
4037 hcan = parameters%hvt
4038 uc = ur*log(hcan/z0m)/log(zlvl/z0m)
4039 uc = ur*log((hcan-zpd+z0m)/z0m)/log(zlvl/z0m) ! mb: add zpd v3.7
4040 if((hcan-zpd) <= 0.) then
4041 write(message,*) "critical problem: hcan <= zpd"
4042#ifdef CCPP
4043 errmsg = trim(message)
4044#else
4045 call wrf_message ( message )
4046#endif
4047 write(message,*) 'i,j point=',iloc, jloc
4048#ifdef CCPP
4049 errmsg = trim(errmsg)//new_line('A')//trim(message)
4050#else
4051 call wrf_message ( message )
4052#endif
4053 write(message,*) 'hcan =',hcan
4054#ifdef CCPP
4055 errmsg = trim(errmsg)//new_line('A')//trim(message)
4056#else
4057 call wrf_message ( message )
4058#endif
4059 write(message,*) 'zpd =',zpd
4060#ifdef CCPP
4061 errmsg = trim(errmsg)//new_line('A')//trim(message)
4062#else
4063 call wrf_message ( message )
4064#endif
4065 write (message, *) 'snowh =',snowh
4066#ifdef CCPP
4067 errflg = 1
4068 errmsg = trim(errmsg)//new_line('A')//trim(message)//new_line('A')//"critical problem in module_sf_noahmplsm:vegeflux"
4069 return
4070#else
4071 call wrf_message ( message )
4072 call wrf_error_fatal ( "critical problem in module_sf_noahmplsm:vegeflux" )
4073#endif
4074
4075 end if
4076
4077 if(opt_sfc == 4) then
4078
4079 gdx = sqrt(garea1)
4080 snwd = snowh * 1000.0
4081 fv = ustarx !inout in sfcdif4
4082
4083 if (snowh .gt. 0.1) then
4084 mnice = 1
4085 else
4086 mnice = 0
4087 endif
4088
4089 endif
4090
4091! ---------------------------------------------------------------------------------------------
4092 loop1: do iter = 1, niterc ! begin stability iteration
4093
4094! if(iter == 1) then
4095! z0hg = z0mg
4096! else
4097! z0hg = z0mg !* exp(-czil*0.4*258.2*sqrt(fv*z0mg))
4098! end if
4099
4100
4101 call thermalz0(parameters,fveg,z0m,z0mg,zlvl,zpd,zpd,ustarx, & !in
4102 vegtyp,vaie,ur,csigmaf0,csigmaf1,temptrs,temptrs,temptrs,0, & !in
4103 z0mo,z0hg)
4104
4105 call thermalz0(parameters,fveg,z0m,z0mg,zlvl,zpd,zpd,ustarx, & !in
4106 vegtyp,vaie,ur,csigmaf0,csigmaf1,temptrs,temptrs,temptrs,1, & !in
4107 z0mo,z0h)
4108
4109! aerodyn resistances between heights zlvl and d+z0v
4110
4111 if(opt_sfc == 1) then
4112 call sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in
4113 zlvl ,zpd ,z0m ,z0h ,ur , & !in
4114 mpe ,iloc ,jloc , & !in
4115#ifdef CCPP
4116 moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,fv, errmsg ,errflg ,& !inout
4117#else
4118 moz ,mozsgn ,fm ,fh ,fm2,fh2, fv, & !inout
4119#endif
4120 cm ,ch ,ch2 ) !out
4121#ifdef CCPP
4122 if (errflg /= 0) return
4123#endif
4124 endif
4125
4126 if(opt_sfc == 2) then
4127 call sfcdif2(parameters,iter ,z0m ,tah ,thair ,ur , & !in
4128 zlvl ,iloc ,jloc , & !in
4129 cm ,ch ,moz ,wstar , & !in
4130 fv ) !out
4131 ! undo the multiplication by windspeed that sfcdif2
4132 ! applies to exchange coefficients ch and cm:
4133 ch = ch / ur
4134 cm = cm / ur
4135 endif
4136
4137 if(opt_sfc == 3) then
4138 call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in
4139 zlvl ,tah ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in
4140 z0h, zpd ,snowh ,shdfac ,garea1 , & !in
4141 ustarx ,fm ,fh ,fm2 ,fh2 , & !inout
4142 fv ,cm ,ch ) !out
4143
4144 endif
4145
4146 if(opt_sfc == 4) then
4147
4148 call sfcdif4(iloc ,jloc ,uu ,vv ,sfctmp , &
4149 sfcprs ,psfc ,pblhx ,gdx ,z0m , &
4150 ep_1, ep_2, cp, &
4151 itime ,snwd ,mnice ,psi_opt, &
4152 tah ,qair ,zlvl ,iz0tlnd,qsfc , &
4153 h ,qfx ,cm ,ch ,ch2v , &
4154 cq2v ,moz ,fv ,rb1v, fm, fh, &
4155 stress1v,fm10 ,fh2 ,wspdv ,flhcv ,flqcv)
4156
4157
4158 ! Undo the multiplication by windspeed that SFCDIF4
4159 ! applies to exchange coefficients CH and CM
4160
4161 ch = ch / wspdv
4162 cm = cm / wspdv
4163 ch2v = ch2v / wspdv
4164
4165 endif
4166
4167
4168 if(opt_sfc == 1 .or. opt_sfc == 2 .or. opt_sfc == 3) then
4169 ramc = max(1.,1./(cm*ur))
4170 rahc = max(1.,1./(ch*ur))
4171 elseif(opt_sfc == 4) then
4172 ramc = max(1.,1./(cm*wspdv) )
4173 rahc = max(1.,1./(ch*wspdv) )
4174 endif
4175
4176 rawc = rahc
4177
4178! aerodyn resistance between heights z0g and d+z0v, rag, and leaf
4179! boundary layer resistance, rb
4180
4181 call ragrb(parameters,iter ,vaie ,rhoair ,hg ,tah , & !in
4182 zpd ,z0mg ,z0hg ,hcan ,uc , & !in
4183 z0h ,fv ,cwp ,vegtyp ,mpe , & !in
4184 tv ,mozg ,fhg ,fhgh ,iloc ,jloc , & !inout
4185 ramg ,rahg ,rawg ,rb ) !out
4186
4187! es and d(es)/dt evaluated at tv
4188
4189 t = tdc(tv)
4190 call esat(t, esatw, esati, dsatw, dsati)
4191 if (t .gt. 0.) then
4192 estv = esatw
4193 destv = dsatw
4194 else
4195 estv = esati
4196 destv = dsati
4197 end if
4198
4199! stomatal resistance
4200
4201 if(iter == 1) then
4202 if (opt_crs == 1) then ! ball-berry
4203 call stomata (parameters,vegtyp,mpe ,parsun ,foln ,iloc , jloc , & !in
4204 tv ,estv ,eah ,sfctmp,sfcprs, & !in
4205 o2air ,co2air,igs ,btran ,rb , & !in
4206 rssun ,psnsun) !out
4207
4208 call stomata (parameters,vegtyp,mpe ,parsha ,foln ,iloc , jloc , & !in
4209 tv ,estv ,eah ,sfctmp,sfcprs, & !in
4210 o2air ,co2air,igs ,btran ,rb , & !in
4211 rssha ,psnsha) !out
4212 end if
4213
4214 if (opt_crs == 2) then ! jarvis
4215 call canres (parameters,ep_2, epsm1,parsun,tv ,btran ,eah ,sfcprs, & !in
4216 rssun ,psnsun,iloc ,jloc ) !out
4217
4218 call canres (parameters,ep_2, epsm1,parsha,tv ,btran ,eah ,sfcprs, & !in
4219 rssha ,psnsha,iloc ,jloc ) !out
4220 end if
4221 end if
4222
4223! prepare for longwave rad.
4224
4225 air = -emv*(1.+(1.-emv)*(1.-emg))*lwdn - emv*emg*sb*tg**4
4226 cir = (2.-emv*(1.-emg))*emv*sb
4227
4228! prepare for sensible heat flux above veg.
4229
4230 cah = 1./rahc
4231 cvh = 2.*vaie/rb
4232 cgh = 1./rahg
4233 cond = cah + cvh + cgh
4234 ata = (sfctmp*cah + tg*cgh) / cond
4235 bta = cvh/cond
4236 csh = (1.-bta)*rhoair*cpair*cvh
4237
4238! prepare for latent heat flux above veg.
4239
4240 evpot= fveg*rhoair*cpair*vaie/rb * (estv-eah) / gammav
4241 caw = 1./rawc
4242 if(evpot > 0. .and. fwet > 0.) then
4243 if (tv > tfrz) then
4244 cew = min(fwet,canliq*latheav/dt/evpot) * vaie/rb
4245 else
4246 cew = min(fwet,canice*latheav/dt/evpot) * vaie/rb
4247 endif
4248 else
4249 cew= fwet * vaie/rb
4250 endif
4251 ctw = (1.-fwet)*(laisune/(rb+rssun) + laishae/(rb+rssha))
4252 cgw = 1./(rawg+rsurf)
4253 cond = caw + cew + ctw + cgw
4254 aea = (eair*caw + estg*cgw) / cond
4255 bea = (cew+ctw)/cond
4256 cev = (1.-bea)*cew*rhoair*cpair/gammav ! barlage: change to vegetation v3.6
4257 ctr = (1.-bea)*ctw*rhoair*cpair/gammav
4258
4259! evaluate surface fluxes with current temperature and solve for dts
4260
4261 tah = ata + bta*tv ! canopy air t.
4262 eah = aea + bea*estv ! canopy air e
4263
4264 irc = fveg*(air + cir*tv**4)
4265 shc = fveg*rhoair*cpair*cvh * ( tv-tah)
4266 evc = fveg*rhoair*cpair*cew * (estv-eah) / gammav ! barlage: change to v in v3.6
4267 tr = fveg*rhoair*cpair*ctw * (estv-eah) / gammav
4268 if (tv > tfrz) then
4269 evc = min(canliq*latheav/dt,evc) ! barlage: add if block for canice in v3.6
4270 else
4271 evc = min(canice*latheav/dt,evc)
4272 end if
4273
4274! canopy heat capacity
4275 hcv = fveg*(parameters%cbiom*vaie*cwat + canliq*cwat/denh2o + canice*cice/denice) !j/m2/k
4276
4277 b = sav-irc-shc-evc-tr+pahv !additional w/m2
4278! a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) !volumetric heat capacity
4279 a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) + hcv/dt !volumetric heat capacity
4280 dtv = b/a
4281
4282 irc = irc + fveg*4.*cir*tv**3*dtv
4283 shc = shc + fveg*csh*dtv
4284 evc = evc + fveg*cev*destv*dtv
4285 tr = tr + fveg*ctr*destv*dtv
4286 canhs = dtv*hcv/dt
4287
4288! update vegetation surface temperature
4289 tv = tv + dtv
4290 tah = ata + bta*tv ! canopy air t; update here for consistency
4291
4292! for computing m-o length in the next iteration
4293 h = rhoair*cpair*(tah - sfctmp) /rahc
4294 hg = rhoair*cpair*(tg - tah) /rahg
4295
4296! consistent specific humidity from canopy air vapor pressure
4297 qsfc = (ep_2*eah)/(sfcprs+epsm1*eah)
4298
4299 if ( opt_sfc == 4 ) then
4300 qfx = (qsfc-qair)*rhoair*caw
4301 endif
4302
4303! after canopy balance, do the under-canopy ground balance
4304
4305! under-canopy fluxes and tg
4306
4307 air = - emg*(1.-emv)*lwdn - emg*emv*sb*tv**4
4308 cir = emg*sb
4309 csh = rhoair*cpair/rahg
4310 cev = rhoair*cpair / (gammag*(rawg+rsurf)) ! barlage: change to ground v3.6
4311 cgh = 2.*df(isnow+1)/dzsnso(isnow+1)
4312
4313 t = tdc(tg)
4314 call esat(t, esatw, esati, dsatw, dsati)
4315 if (t .gt. 0.) then
4316 estg = esatw
4317 destg = dsatw
4318 else
4319 estg = esati
4320 destg = dsati
4321 end if
4322
4323 irg = cir*tg**4 + air
4324 shg = csh * (tg - tah )
4325 evg = cev * (estg*rhsur - eah )
4326 gh = cgh * (tg - stc(isnow+1))
4327
4328 b = sag-irg-shg-evg-gh+pahg
4329 a = 4.*cir*tg**3+csh+cev*destg+cgh
4330 dtg = b/a
4331
4332 irg = irg + 4.*cir*tg**3*dtg
4333 shg = shg + csh*dtg
4334 evg = evg + cev*destg*dtg
4335 gh = gh + cgh*dtg
4336 tg = tg + dtg
4337
4338 if (liter == 1) then
4339 exit loop1
4340 endif
4341 if (iter >= 5 .and. abs(dtv) <= 0.01 .and. abs(dtg) <= 0.01 .and. liter == 0) then
4342 liter = 1 ! if conditions are met, then do one final loop
4343 endif
4344
4345 end do loop1
4346
4347! tah = (cah*sfctmp + cvh*tv + cgh*tg)/(cah + cvh + cgh)
4348
4349! if snow on ground and tg > tfrz: reset tg = tfrz. reevaluate ground fluxes.
4350
4351 if(opt_stc == 1 .or. opt_stc == 3) then
4352 if (snowh > 0.05 .and. tg > tfrz) then
4353 if(opt_stc == 1) tg = tfrz
4354 if(opt_stc == 3) tg = (1.-fsno)*tg + fsno*tfrz ! mb: allow tg>0c during melt v3.7
4355 irg = cir*tg**4 - emg*(1.-emv)*lwdn - emg*emv*sb*tv**4
4356 shg = csh * (tg - tah)
4357 evg = cev * (estg*rhsur - eah)
4358 gh = sag+pahg - (irg+shg+evg)
4359 end if
4360 end if
4361
4362! wind stresses
4363
4364 tauxv = -rhoair*cm*ur*uu
4365 tauyv = -rhoair*cm*ur*vv
4366
4367! consistent vegetation air temperature and vapor pressure since tg is not consistent with the tah/eah
4368! calculation.
4369! tah = sfctmp + (shg+shc)/(rhoair*cpair*cah)
4370! tah = sfctmp + (shg*fveg+shc)/(rhoair*cpair*cah) ! ground flux need fveg
4371! eah = eair + (evc+fveg*(tr+evg))/(rhoair*caw*cpair/gammag )
4372! qfx = (qsfc-qair)*rhoair*caw !*cpair/gammag
4373
4374! 2m temperature over vegetation ( corrected for low cq2v values )
4375 if (opt_sfc == 1 .or. opt_sfc == 2 ) then
4376! cah2 = fv*1./vkc*log((2.+z0h)/z0h)
4377 cah2 = fv*vkc/log((2.+z0h)/z0h)
4378 cah2 = fv*vkc/(log((2.+z0h)/z0h)-fh2)
4379 cq2v = cah2
4380 endif
4381
4382! opt_sfc 3: fh2 is the stability
4383 if (opt_sfc ==3) then
4384 cah2 = fv*vkc/fh2
4385 cq2v = cah2
4386 endif
4387
4388 if (opt_sfc == 4 ) then
4389 rahc2 = max(1.,1./(ch2v*wspdv))
4390 rawc2 = rahc2
4391 cah2 = 1./rahc2
4392 cq2v = 1./max(1.,1./(cq2v*wspdv))
4393 endif
4394
4395 if (cah2 .lt. 1.e-5 ) then
4396 t2mv = tah
4397! q2v = (eah*0.622/(sfcprs - 0.378*eah))
4398 q2v = qsfc
4399 else
4400 t2mv = tah - (shg+shc/fveg)/(rhoair*cpair) * 1./cah2
4401! q2v = (eah*0.622/(sfcprs - 0.378*eah))- qfx/(rhoair*fv)* 1./vkc * log((2.+z0h)/z0h)
4402 q2v = qsfc - ((evc+tr)/fveg+evg)/(latheav*rhoair) * 1./cq2v
4403 endif
4404
4405! use sfc_diag to calculate t2mv and q2v for opt_sfc=1&3
4406 if(opt_diag ==3) then
4407 if(opt_sfc == 1 .or. opt_sfc == 3) then
4408
4409 fhi = fh2/fh
4410 wrk = 1.0 - fhi
4411 if(thsfc_loc) then ! Use local potential temperature
4412 t2mv = tah*wrk + sfctmp*prslkix*fhi - (grav+grav)/cp
4413 else ! Use potential temperature referenced to 1000 hPa
4414 t2mv = tah*wrk + sfctmp*fhi - (grav+grav)/cp
4415 endif
4416
4417 if((evc+tr)/fveg+evg >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2v
4418 q2v = qsfc*wrk + max(qmin,qair)*fhi
4419 else ! for dew formation, use saturated q at tskin
4420 qss = fpvs(tah)
4421 qss = ep_2 * qss / (psfc + epsm1 * qss)
4422 q2v= qss*wrk + max(qmin,qair)*fhi
4423 endif
4424 qss = fpvs(t2mv)
4425 qss = ep_2 * qss / (psfc + epsm1 * qss)
4426 q2v = min(q2v,qss)
4427 else
4428 errmsg = 'Problem :opt_diag=3 is only applied for opt_sfc=1&3'
4429 errflg = 1
4430 return
4431 endif
4432 endif
4433! update ch for output
4434 ch = cah
4435 chleaf = cvh
4436 chuc = 1./rahg
4437
4438 end subroutine vege_flux
4439
4440!== begin bare_flux ================================================================================
4441
4445 subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & !in
4446 lwdn ,ur ,uu ,vv ,sfctmp , & !in
4447 thair ,qair ,eair ,rhoair ,snowh , & !in
4448 dzsnso ,zlvl ,zpd ,z0m ,fsno , & !in
4449 emg ,stc ,df ,rsurf ,lathea , & !in
4450 gamma ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in
4451 thsfc_loc, prslkix,prsik1x,prslk1x,vegtyp,fveg,shdfac,garea1, & !in
4452 pblhx , iz0tlnd , itime ,psi_opt,ep_1,ep_2,epsm1,cp ,&
4453#ifdef CCPP
4454 tgb ,cm ,ch,ustarx,errmsg ,errflg , & !inout
4455#else
4456 tgb ,cm ,ch,ustarx, & !inout
4457#endif
4458 tauxb ,tauyb ,irb ,shb ,evb , & !out
4459 csigmaf0, & !out
4460 ghb ,t2mb ,dx ,dz8w , & !out
4461 qc ,qsfc ,psfc , & !in
4462 sfcprs ,q2b ,ehb2 ) !in
4463
4464! --------------------------------------------------------------------------------------------------
4465! use newton-raphson iteration to solve ground (tg) temperature
4466! that balances the surface energy budgets for bare soil fraction.
4467
4468! bare soil:
4469! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0
4470! ----------------------------------------------------------------------
4471 use funcphys, only : fpvs
4472 implicit none
4473! ----------------------------------------------------------------------
4474! input
4475 type (noahmp_parameters), intent(in) :: parameters
4476 integer , intent(in) :: iloc
4477 integer , intent(in) :: jloc
4478 integer, intent(in) :: nsnow
4479 integer, intent(in) :: nsoil
4480 integer, intent(in) :: isnow
4481 real (kind=kind_phys), intent(in) :: dt
4482 real (kind=kind_phys), intent(in) :: sag
4483 real (kind=kind_phys), intent(in) :: lwdn
4484 real (kind=kind_phys), intent(in) :: ur
4485 real (kind=kind_phys), intent(in) :: uu
4486 real (kind=kind_phys), intent(in) :: vv
4487 real (kind=kind_phys), intent(in) :: sfctmp
4488 real (kind=kind_phys), intent(in) :: thair
4489 real (kind=kind_phys), intent(in) :: qair
4490 real (kind=kind_phys), intent(in) :: eair
4491 real (kind=kind_phys), intent(in) :: rhoair
4492 real (kind=kind_phys), intent(in) :: snowh
4493 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
4494 real (kind=kind_phys), intent(in) :: zlvl
4495 real (kind=kind_phys), intent(in) :: zpd
4496 real (kind=kind_phys), intent(in) :: z0m
4497 real (kind=kind_phys), intent(in) :: emg
4498 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc
4499 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: df
4500 real (kind=kind_phys), intent(in) :: rsurf
4501 real (kind=kind_phys), intent(in) :: lathea
4502 real (kind=kind_phys), intent(in) :: gamma
4503 real (kind=kind_phys), intent(in) :: rhsur
4504 real (kind=kind_phys), intent(in) :: fsno
4505
4506 real (kind=kind_phys), intent(in) :: pblhx
4507 real (kind=kind_phys), intent(in) :: ep_1
4508 real (kind=kind_phys), intent(in) :: ep_2
4509 real (kind=kind_phys), intent(in) :: epsm1
4510 real (kind=kind_phys), intent(in) :: cp
4511 integer, intent(in) :: iz0tlnd
4512 integer, intent(in) :: itime
4513 integer, intent(in) :: psi_opt
4514
4515
4516!jref:start; in
4517 real (kind=kind_phys) , intent(in) :: qc
4518 real (kind=kind_phys) , intent(inout) :: qsfc
4519 real (kind=kind_phys) , intent(in) :: psfc
4520 real (kind=kind_phys) , intent(in) :: sfcprs
4521 real (kind=kind_phys) , intent(in) :: dx
4522 real (kind=kind_phys) , intent(in) :: q2
4523 real (kind=kind_phys) , intent(in) :: dz8w
4524!jref:end
4525 real (kind=kind_phys), intent(in) :: pahb
4526
4527! input/output
4528 real (kind=kind_phys), intent(inout) :: tgb
4529 real (kind=kind_phys), intent(inout) :: cm
4530 real (kind=kind_phys), intent(inout) :: ch
4531#ifdef CCPP
4532 character(len=*), intent(inout) :: errmsg
4533 integer, intent(inout) :: errflg
4534#endif
4535
4536! output
4537! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0
4538
4539 real (kind=kind_phys), intent(out) :: tauxb
4540 real (kind=kind_phys), intent(out) :: tauyb
4541 real (kind=kind_phys), intent(out) :: irb
4542 real (kind=kind_phys), intent(out) :: shb
4543 real (kind=kind_phys), intent(out) :: evb
4544 real (kind=kind_phys), intent(out) :: ghb
4545 real (kind=kind_phys), intent(out) :: t2mb
4546!jref:start
4547 real (kind=kind_phys), intent(out) :: q2b
4548 real (kind=kind_phys) :: ehb !bare ground heat conductance
4549 real (kind=kind_phys) :: u10b !10 m wind speed in eastward dir (m/s)
4550 real (kind=kind_phys) :: v10b !10 m wind speed in eastward dir (m/s)
4551 real (kind=kind_phys) :: wspd
4552!jref:end
4553
4554! local variables
4555
4556 real (kind=kind_phys) :: gdx !grid dx
4557 real (kind=kind_phys) :: snwd ! snowdepth in mm
4558 integer :: mnice ! MYNN ice flag
4559
4560 real (kind=kind_phys) :: fm10
4561 real (kind=kind_phys) :: rb1b
4562 real (kind=kind_phys) :: stress1b
4563
4564 real (kind=kind_phys) :: wspdb
4565 real (kind=kind_phys) :: flhcb
4566 real (kind=kind_phys) :: flqcb
4567!
4568
4569 real (kind=kind_phys) :: taux !wind stress: e-w (n/m2)
4570 real (kind=kind_phys) :: tauy !wind stress: n-s (n/m2)
4571 real (kind=kind_phys) :: fira !total net longwave rad (w/m2) [+ to atm]
4572 real (kind=kind_phys) :: fsh !total sensible heat flux (w/m2) [+ to atm]
4573 real (kind=kind_phys) :: fgev !ground evaporation heat flux (w/m2)[+ to atm]
4574 real (kind=kind_phys) :: ssoil !soil heat flux (w/m2) [+ to soil]
4575 real (kind=kind_phys) :: fire !emitted ir (w/m2)
4576 real (kind=kind_phys) :: trad !radiative temperature (k)
4577 real (kind=kind_phys) :: tah !"surface" temperature at height z0h+zpd (k)
4578
4579 real (kind=kind_phys) :: cw !water vapor exchange coefficient
4580 real (kind=kind_phys) :: fv !friction velocity (m/s)
4581 real (kind=kind_phys) :: wstar !friction velocity n vertical direction (m/s) (only for sfcdif2)
4582 real (kind=kind_phys) :: z0mo !roughness length for intermediate output only (m)
4583 real (kind=kind_phys) :: z0h !roughness length, sensible heat, ground (m)
4584 real (kind=kind_phys) :: rb !bulk leaf boundary layer resistance (s/m)
4585 real (kind=kind_phys) :: ramb !aerodynamic resistance for momentum (s/m)
4586 real (kind=kind_phys) :: rahb !aerodynamic resistance for sensible heat (s/m)
4587 real (kind=kind_phys) :: rawb !aerodynamic resistance for water vapor (s/m)
4588 real (kind=kind_phys) :: mol !monin-obukhov length (m)
4589 real (kind=kind_phys) :: dtg !change in tg, last iteration (k)
4590
4591 real (kind=kind_phys) :: cir !coefficients for ir as function of ts**4
4592 real (kind=kind_phys) :: csh !coefficients for sh as function of ts
4593 real (kind=kind_phys) :: cev !coefficients for ev as function of esat[ts]
4594 real (kind=kind_phys) :: cgh !coefficients for st as function of ts
4595
4596 real(kind=kind_phys) :: kbsigmaf0
4597 real(kind=kind_phys) :: reynb
4598
4599
4600!jref:start
4601 real (kind=kind_phys) :: rahb2 !aerodynamic resistance for sensible heat 2m (s/m)
4602 real (kind=kind_phys) :: rawb2 !aerodynamic resistance for water vapor 2m (s/m)
4603 real (kind=kind_phys),intent(out) :: ehb2 !sensible heat conductance for diagnostics
4604 real (kind=kind_phys) :: ch2b !exchange coefficient for 2m temp.
4605 real (kind=kind_phys) :: cq2b !exchange coefficient for 2m temp.
4606 real (kind=kind_phys) :: thvair !virtual potential air temp
4607 real (kind=kind_phys) :: thgh !potential ground temp
4608 real (kind=kind_phys) :: emb !momentum conductance
4609 real (kind=kind_phys) :: qfx !moisture flux
4610 real (kind=kind_phys) :: estg2 !saturation vapor pressure at 2m (pa)
4611 real (kind=kind_phys) :: e1
4612!jref:end
4613
4614 real (kind=kind_phys) :: estg !saturation vapor pressure at tg (pa)
4615 real (kind=kind_phys) :: destg !d(es)/dt at tg (pa/k)
4616 real (kind=kind_phys) :: esatw !es for water
4617 real (kind=kind_phys) :: esati !es for ice
4618 real (kind=kind_phys) :: dsatw !d(es)/dt at tg (pa/k) for water
4619 real (kind=kind_phys) :: dsati !d(es)/dt at tg (pa/k) for ice
4620
4621 real (kind=kind_phys) :: a !temporary calculation
4622 real (kind=kind_phys) :: b !temporary calculation
4623 real (kind=kind_phys) :: h !temporary sensible heat flux (w/m2)
4624 real (kind=kind_phys) :: moz !monin-obukhov stability parameter
4625 real (kind=kind_phys) :: mozold !monin-obukhov stability parameter from prior iteration
4626 real (kind=kind_phys) :: fm !momentum stability correction, weighted by prior iters
4627 real (kind=kind_phys) :: fh !sen heat stability correction, weighted by prior iters
4628 integer :: mozsgn !number of times moz changes sign
4629 real (kind=kind_phys) :: fm2 !monin-obukhov momentum adjustment at 2m
4630 real (kind=kind_phys) :: fh2 !monin-obukhov heat adjustment at 2m
4631 real (kind=kind_phys) :: ch2 !surface exchange at 2m
4632
4633 integer :: iter !iteration index
4634 integer :: niterb !number of iterations for surface temperature
4635 real (kind=kind_phys) :: mpe !prevents overflow error if division by zero
4636!jref:start
4637! data niterb /3/
4638 data niterb /5/
4639 save niterb
4640
4641! New variables for sfcdif3
4642
4643 logical , intent(in ) :: thsfc_loc
4644 real (kind=kind_phys), intent(in ) :: prslkix ! in exner function
4645 real (kind=kind_phys), intent(in ) :: prsik1x ! in exner function
4646 real (kind=kind_phys), intent(in ) :: prslk1x ! in exner function
4647 integer , intent(in ) :: vegtyp
4648 real (kind=kind_phys), intent(in ) :: fveg
4649 real (kind=kind_phys), intent(in ) :: shdfac
4650 real (kind=kind_phys), intent(in ) :: garea1
4651 real (kind=kind_phys), intent(inout) :: ustarx !friction velocity
4652 real (kind=kind_phys), intent( out) :: csigmaf0 !
4653 real (kind=kind_phys) :: csigmaf1 !
4654! dummy for thermal roughness scheme
4655 real (kind=kind_phys) :: temptrs
4656
4657 real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50
4658
4659 real(kind=kind_phys) :: fhi, qss, wrk
4660 real(kind=kind_phys), parameter :: qmin=1.0e-8
4661
4662 tdc(t) = min( 50., max(-50.,(t-tfrz)) )
4663
4664! -----------------------------------------------------------------
4665! initialization variables that do not depend on stability iteration
4666! -----------------------------------------------------------------
4667 temptrs = 1.
4668 mpe = 1e-6
4669 dtg = 0.
4670 moz = 0.
4671 mozsgn = 0
4672 mozold = 0.
4673 fh2 = 0.
4674 h = 0.
4675 qfx = 0.
4676
4677 cir = emg*sb
4678 cgh = 2.*df(isnow+1)/dzsnso(isnow+1)
4679
4680 reynb = ustarx*z0m/(1.5e-05)
4681
4682 if (reynb .gt. 2.0) then
4683 kbsigmaf0 = 2.46*reynb**0.25 - log(7.4)
4684 else
4685 kbsigmaf0 = - log(0.397)
4686 endif
4687
4688 z0h = max(z0m/exp(kbsigmaf0),1.0e-6)
4689
4690 if (opt_sfc == 4) then
4691 fv = ustarx
4692 gdx = sqrt(garea1)
4693 snwd = snowh * 1000.0
4694
4695 if (snowh .gt. 0.1) then
4696 mnice = 1
4697 else
4698 mnice = 0
4699 endif
4700 endif
4701
4702! -----------------------------------------------------------------
4703 loop3: do iter = 1, niterb ! begin stability iteration
4704
4705! if(iter == 1) then
4706! z0h = z0m
4707! else
4708! z0h = z0m !* exp(-czil*0.4*258.2*sqrt(fv*z0m))
4709! end if
4710 call thermalz0(parameters,fveg,z0m,z0m,zlvl,zpd,zpd,ustarx, & !in
4711 vegtyp,0._kind_phys,ur,csigmaf0,csigmaf1,temptrs,temptrs,temptrs,0, & !in
4712 z0mo,z0h)
4713
4714 if(opt_sfc == 1) then
4715 call sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in
4716 zlvl ,zpd ,z0m ,z0h ,ur , & !in
4717 mpe ,iloc ,jloc , & !in
4718#ifdef CCPP
4719 moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,fv,errmsg ,errflg ,& !inout
4720#else
4721 moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,fv, & !inout
4722#endif
4723 cm ,ch ,ch2 ) !out
4724#ifdef CCPP
4725 if (errflg /= 0) return
4726#endif
4727 endif
4728
4729 if(opt_sfc == 2) then
4730 call sfcdif2(parameters,iter ,z0m ,tgb ,thair ,ur , & !in
4731 zlvl ,iloc ,jloc , & !in
4732 cm ,ch ,moz ,wstar , & !in
4733 fv ) !out
4734 ! undo the multiplication by windspeed that sfcdif2
4735 ! applies to exchange coefficients ch and cm:
4736 ch = ch / ur
4737 cm = cm / ur
4738 if(snowh > 0.) then
4739 cm = min(0.01,cm) ! cm & ch are too large, causing
4740 ch = min(0.01,ch) ! computational instability
4741 end if
4742
4743 endif
4744
4745 if(opt_sfc == 3) then
4746 call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in
4747 zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in
4748 z0h, zpd,snowh ,shdfac ,garea1 , & !in
4749 ustarx ,fm ,fh ,fm2 ,fh2 , & !inout
4750 fv ,cm ,ch ) !out
4751
4752 endif
4753
4754 if(opt_sfc == 4) then
4755
4756 call sfcdif4(iloc ,jloc ,uu ,vv ,sfctmp , &
4757 sfcprs ,psfc ,pblhx ,gdx ,z0m , &
4758 ep_1, ep_2, cp, &
4759 itime ,snwd ,mnice ,psi_opt , &
4760 tgb ,qair ,zlvl ,iz0tlnd,qsfc , &
4761 h ,qfx ,cm ,ch ,ch2b , &
4762 cq2b ,moz ,fv ,rb1b, fm, fh , &
4763 stress1b,fm10 ,fh2 , wspdb ,flhcb ,flqcb)
4764
4765 ! Undo the multiplication by windspeed that SFCDIF4
4766 ! applies to exchange coefficients CH and CM:
4767
4768 ch = ch / wspdb
4769 cm = cm / wspdb
4770 ch2b = ch2b / wspdb
4771 cq2b = cq2b / wspdb
4772
4773 if(snwd > 0.) then
4774 cm = min(0.01,cm)
4775 ch = min(0.01,ch)
4776 ch2b = min(0.01,ch2b)
4777 cq2b = min(0.01,cq2b)
4778 end if
4779
4780 endif ! 4
4781
4782 if(opt_sfc == 1 .or. opt_sfc == 2 .or. opt_sfc == 3) then
4783 ramb = max(1.,1./(cm*ur))
4784 rahb = max(1.,1./(ch*ur))
4785 elseif(opt_sfc == 4) then
4786 ramb = max(1.,1./(cm*wspdb) )
4787 rahb = max(1.,1./(ch*wspdb) )
4788 endif
4789
4790 rawb = rahb
4791
4792!jref - variables for diagnostics
4793 emb = 1./ramb
4794 ehb = 1./rahb
4795
4796! es and d(es)/dt evaluated at tg
4797
4798 t = tdc(tgb)
4799 call esat(t, esatw, esati, dsatw, dsati)
4800 if (t .gt. 0.) then
4801 estg = esatw
4802 destg = dsatw
4803 else
4804 estg = esati
4805 destg = dsati
4806 end if
4807
4808 csh = rhoair*cpair/rahb
4809 cev = rhoair*cpair/gamma/(rsurf+rawb)
4810
4811! surface fluxes and dtg
4812
4813 irb = cir * tgb**4 - emg*lwdn
4814 shb = csh * (tgb - sfctmp )
4815 evb = cev * (estg*rhsur - eair )
4816 ghb = cgh * (tgb - stc(isnow+1))
4817
4818 b = sag-irb-shb-evb-ghb+pahb
4819 a = 4.*cir*tgb**3 + csh + cev*destg + cgh
4820 dtg = b/a
4821
4822 irb = irb + 4.*cir*tgb**3*dtg
4823 shb = shb + csh*dtg
4824 evb = evb + cev*destg*dtg
4825 ghb = ghb + cgh*dtg
4826
4827! update ground surface temperature
4828 tgb = tgb + dtg
4829
4830! for m-o length
4831 h = csh * (tgb - sfctmp)
4832
4833 t = tdc(tgb)
4834 call esat(t, esatw, esati, dsatw, dsati)
4835 if (t .gt. 0.) then
4836 estg = esatw
4837 else
4838 estg = esati
4839 end if
4840 qsfc = ep_2*(estg*rhsur)/(psfc+epsm1*(estg*rhsur))
4841
4842 qfx = (qsfc-qair)*cev*gamma/cpair
4843
4844 end do loop3 ! end stability iteration
4845! -----------------------------------------------------------------
4846
4847! if snow on ground and tg > tfrz: reset tg = tfrz. reevaluate ground fluxes.
4848
4849 if(opt_stc == 1 .or. opt_stc == 3) then
4850 if (snowh > 0.05 .and. tgb > tfrz) then
4851 if(opt_stc == 1) tgb = tfrz
4852 if(opt_stc == 3) tgb = (1.-fsno)*tgb + fsno*tfrz ! mb: allow tg>0c during melt v3.7
4853 irb = cir * tgb**4 - emg*lwdn
4854 shb = csh * (tgb - sfctmp)
4855 evb = cev * (estg*rhsur - eair ) !estg reevaluate ?
4856 ghb = sag+pahb - (irb+shb+evb)
4857 end if
4858 end if
4859
4860! wind stresses
4861
4862 tauxb = -rhoair*cm*ur*uu
4863 tauyb = -rhoair*cm*ur*vv
4864
4865!jref:start; errors in original equation corrected.
4866! 2m air temperature
4867
4868 if(opt_sfc == 1 .or. opt_sfc ==2 ) then
4869 ehb2 = fv*vkc/log((2.+z0h)/z0h)
4870 ehb2 = fv*vkc/(log((2.+z0h)/z0h)-fh2)
4871 cq2b = ehb2
4872 if (ehb2.lt.1.e-5 ) then
4873 t2mb = tgb
4874 q2b = qsfc
4875 else
4876 t2mb = tgb - shb/(rhoair*cpair) * 1./ehb2
4877 q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf)
4878 endif
4879 if (parameters%urban_flag) q2b = qsfc
4880 end if
4881
4882! opt_sfc 3: fh2 is the stability
4883 if(opt_sfc == 3 ) then
4884 ehb2 = fv*vkc/fh2
4885 cq2b = ehb2
4886 if (ehb2.lt.1.e-5 ) then
4887 t2mb = tgb
4888 q2b = qsfc
4889 else
4890 t2mb = tgb - shb/(rhoair*cpair) * 1./ehb2
4891 q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf)
4892 endif
4893 if (parameters%urban_flag) q2b = qsfc
4894 end if
4895
4896 if(opt_sfc == 4) then ! consistent with veg
4897
4898 rahb2 = max(1.,1./(ch2b*wspdb))
4899 ehb2 = 1./rahb2
4900 cq2b = 1./max(1.,1./(cq2b*wspdb)) !
4901
4902 if (ehb2.lt.1.e-5 ) then
4903 t2mb = tgb
4904 q2b = qsfc
4905 else
4906 t2mb = tgb - shb/(rhoair*cpair*ehb2)
4907! q2b = qsfc - qfx/(rhoair*cq2b)
4908 q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf)
4909 end if
4910 endif ! 4
4911
4912! use sfc_diag to calculate t2mb and q2b for opt_sfc=1&3
4913 if(opt_diag ==3) then
4914 if(opt_sfc == 1 .or. opt_sfc == 3) then
4915
4916 fhi = fh2/fh
4917 wrk = 1.0 - fhi
4918 if(thsfc_loc) then ! Use local potential temperature
4919 t2mb = tgb*wrk + sfctmp*prslkix*fhi - (grav+grav)/cp
4920 else ! Use potential temperature referenced to 1000 hPa
4921 t2mb = tgb*wrk + sfctmp*fhi - (grav+grav)/cp
4922 endif
4923
4924 if(evb >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2v
4925 q2b = qsfc*wrk + max(qmin,qair)*fhi
4926 else ! for dew formation, use saturated q at tskin
4927 qss = fpvs(tgb)
4928 qss = ep_2 * qss / (psfc + epsm1 * qss)
4929 q2b= qss*wrk + max(qmin,qair)*fhi
4930 endif
4931 qss = fpvs(t2mb)
4932 qss = ep_2 * qss / (psfc + epsm1 * qss)
4933 q2b = min(q2b,qss)
4934 else
4935 errmsg = 'Problem :opt_diag=3 is only applied for opt_sfc=1&3'
4936 errflg = 1
4937 return
4938 endif
4939 endif
4940 if (parameters%urban_flag) q2b = qsfc
4941
4942! update ch
4943 ch = ehb
4944
4945 end subroutine bare_flux
4946
4947!== begin ragrb ====================================================================================
4948
4952 subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in
4953 zpd ,z0mg ,z0hg ,hcan ,uc , & !in
4954 z0h ,fv ,cwp ,vegtyp ,mpe , & !in
4955 tv ,mozg ,fhg ,fhgh ,iloc ,jloc , & !inout
4956 ramg ,rahg ,rawg ,rb ) !out
4957! --------------------------------------------------------------------------------------------------
4958! compute under-canopy aerodynamic resistance rag and leaf boundary layer
4959! resistance rb
4960! --------------------------------------------------------------------------------------------------
4961 implicit none
4962! --------------------------------------------------------------------------------------------------
4963! inputs
4964
4965 type (noahmp_parameters), intent(in) :: parameters
4966 integer, intent(in) :: iloc
4967 integer, intent(in) :: jloc
4968 integer, intent(in) :: iter
4969 integer, intent(in) :: vegtyp
4970 real (kind=kind_phys), intent(in) :: vai
4971 real (kind=kind_phys), intent(in) :: rhoair
4972 real (kind=kind_phys), intent(in) :: hg
4973 real (kind=kind_phys), intent(in) :: tv
4974 real (kind=kind_phys), intent(in) :: tah
4975 real (kind=kind_phys), intent(in) :: zpd
4976 real (kind=kind_phys), intent(in) :: z0mg
4977 real (kind=kind_phys), intent(in) :: hcan
4978 real (kind=kind_phys), intent(in) :: uc
4979 real (kind=kind_phys), intent(in) :: z0h
4980 real (kind=kind_phys), intent(in) :: z0hg
4981 real (kind=kind_phys), intent(in) :: fv
4982 real (kind=kind_phys), intent(in) :: cwp
4983 real (kind=kind_phys), intent(in) :: mpe
4984
4985! in & out
4986
4987 real (kind=kind_phys), intent(inout) :: mozg
4988 real (kind=kind_phys), intent(inout) :: fhg
4989 real (kind=kind_phys), intent(inout) :: fhgh
4990
4991! outputs
4992 real (kind=kind_phys) :: ramg
4993 real (kind=kind_phys) :: rahg
4994 real (kind=kind_phys) :: rawg
4995 real (kind=kind_phys) :: rb
4996
4997
4998 real (kind=kind_phys) :: kh !turbulent transfer coefficient, sensible heat, (m2/s)
4999 real (kind=kind_phys) :: tmp1 !temporary calculation
5000 real (kind=kind_phys) :: tmp2 !temporary calculation
5001 real (kind=kind_phys) :: tmprah2 !temporary calculation for aerodynamic resistances
5002 real (kind=kind_phys) :: tmprb !temporary calculation for rb
5003 real (kind=kind_phys) :: molg,fhgnew,cwpc
5004 real (kind=kind_phys) :: mozgh, fhgnewh
5005! --------------------------------------------------------------------------------------------------
5006! stability correction to below canopy resistance
5007
5008 mozg = 0.
5009 molg = 0.
5010 mozgh = 0.
5011
5012 if(iter > 1) then
5013 tmp1 = vkc * (grav/tah) * hg/(rhoair*cpair)
5014 if (abs(tmp1) .le. mpe) tmp1 = mpe
5015 molg = -1. * fv**3 / tmp1
5016 mozg = min( (zpd-z0mg)/molg, 1.)
5017 mozgh = min( (hcan - zpd)/molg, 1.)
5018 end if
5019
5020 if (mozg < 0.) then
5021 fhgnew = (1. - 15.*mozg)**(-0.25)
5022 fhgnewh = 0.74 * (1. - 9.*mozg)**(-0.5) ! PHIh
5023 else
5024 fhgnew = 1.+ 4.7*mozg
5025 fhgnewh = 0.74 + 4.7*mozgh ! PHIh
5026 endif
5027
5028 if (iter == 1) then
5029 fhg = fhgnew
5030 fhgh = fhgnewh
5031 else
5032 fhg = 0.5 * (fhg+fhgnew)
5033 fhgh = 0.5 * (fhgh+fhgnewh)
5034 endif
5035
5036 cwpc = (cwp * vai * hcan * fhg)**0.5
5037! cwpc = (cwp*fhg)**0.5
5038 cwpc = max(min(cwpc,5.0),1.0)
5039
5040 tmp1 = exp( -cwpc*z0hg/hcan )
5041 tmp2 = exp( -cwpc*(z0h+zpd)/hcan )
5042 tmprah2 = hcan*exp(cwpc) / cwpc * (tmp1-tmp2)
5043
5044! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg.
5045
5046 kh = max( vkc*fv*(hcan-zpd)/(max(fhgh,0.1)), mpe )
5047 ramg = 0.
5048 rahg = tmprah2 / kh
5049 rawg = rahg
5050
5051! leaf boundary layer resistance
5052
5053 tmprb = cwpc*50. / (1. - exp(-cwpc/2.))
5054 rb = tmprb * sqrt(parameters%dleaf/uc)
5055 rb = min(max(rb, 5.0),50.0) ! limit rb to 5-50, typically rb<50
5056
5057 end subroutine ragrb
5058
5059!== begin sfcdif1 ==================================================================================
5060
5063 subroutine sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in
5064 & zlvl ,zpd ,z0m ,z0h ,ur , & !in
5065 & mpe ,iloc ,jloc , & !in
5066#ifdef CCPP
5067 & moz ,mozsgn ,fm ,fh ,fm2,fh2,fv,errmsg,errflg, & !inout
5068#else
5069 & moz ,mozsgn ,fm ,fh ,fm2,fh2, fv, & !inout
5070#endif
5071 & cm ,ch ,ch2 ) !out
5072! -------------------------------------------------------------------------------------------------
5073! computing surface drag coefficient cm for momentum and ch for heat
5074! -------------------------------------------------------------------------------------------------
5075 implicit none
5076! -------------------------------------------------------------------------------------------------
5077! inputs
5078
5079 type (noahmp_parameters), intent(in) :: parameters
5080 integer, intent(in) :: iloc
5081 integer, intent(in) :: jloc
5082 integer, intent(in) :: iter
5083 real (kind=kind_phys), intent(in) :: sfctmp
5084 real (kind=kind_phys), intent(in) :: rhoair
5085 real (kind=kind_phys), intent(in) :: h
5086 real (kind=kind_phys), intent(in) :: qair
5087 real (kind=kind_phys), intent(in) :: zlvl
5088 real (kind=kind_phys), intent(in) :: zpd
5089 real (kind=kind_phys), intent(in) :: z0h
5090 real (kind=kind_phys), intent(in) :: z0m
5091 real (kind=kind_phys), intent(in) :: ur
5092 real (kind=kind_phys), intent(in) :: mpe
5093! in & out
5094
5095 integer, intent(inout) :: mozsgn
5096 real (kind=kind_phys), intent(inout) :: moz
5097 real (kind=kind_phys), intent(inout) :: fm
5098 real (kind=kind_phys), intent(inout) :: fh
5099 real (kind=kind_phys), intent(inout) :: fm2
5100 real (kind=kind_phys), intent(inout) :: fh2
5101 real (kind=kind_phys), intent(inout) :: fv
5102#ifdef CCPP
5103 character(len=*), intent(inout) :: errmsg
5104 integer, intent(inout) :: errflg
5105#endif
5106
5107! outputs
5108
5109 real (kind=kind_phys), intent(out) :: cm
5110 real (kind=kind_phys), intent(out) :: ch
5111 real (kind=kind_phys), intent(out) :: ch2
5112
5113! locals
5114 real (kind=kind_phys) :: mol !monin-obukhov length (m)
5115 real (kind=kind_phys) :: tmpcm !temporary calculation for cm
5116 real (kind=kind_phys) :: tmpch !temporary calculation for ch
5117 real (kind=kind_phys) :: fmnew !stability correction factor, momentum, for current moz
5118 real (kind=kind_phys) :: fhnew !stability correction factor, sen heat, for current moz
5119 real (kind=kind_phys) :: mozold !monin-obukhov stability parameter from prior iteration
5120 real (kind=kind_phys) :: tmp1,tmp2,tmp3,tmp4,tmp5 !temporary calculation
5121 real (kind=kind_phys) :: tvir !temporary virtual temperature (k)
5122 real (kind=kind_phys) :: moz2 !2/l
5123 real (kind=kind_phys) :: tmpcm2 !temporary calculation for cm2
5124 real (kind=kind_phys) :: tmpch2 !temporary calculation for ch2
5125 real (kind=kind_phys) :: fm2new !stability correction factor, momentum, for current moz
5126 real (kind=kind_phys) :: fh2new !stability correction factor, sen heat, for current moz
5127 real (kind=kind_phys) :: tmp12,tmp22,tmp32 !temporary calculation
5128
5129 real (kind=kind_phys) :: cmfm, chfh, cm2fm2, ch2fh2
5130! -------------------------------------------------------------------------------------------------
5131! monin-obukhov stability parameter moz for next iteration
5132
5133 mozold = moz
5134
5135 if(zlvl <= zpd) then
5136 write(*,*) 'critical problem: zlvl <= zpd; model stops'
5137#ifdef CCPP
5138 errflg = 1
5139 errmsg = "stop in noah-mp"
5140 return
5141#else
5142 call wrf_error_fatal("stop in noah-mp")
5143#endif
5144 endif
5145
5146 tmpcm = log((zlvl-zpd) / z0m)
5147 tmpch = log((zlvl-zpd) / z0h)
5148 tmpcm2 = log((2.0 + z0m) / z0m)
5149 tmpch2 = log((2.0 + z0h) / z0h)
5150
5151 if(iter == 1) then
5152 fv = 0.1
5153 moz = 0.0
5154 mol = 0.0
5155 moz2 = 0.0
5156 else
5157 tvir = (1. + 0.61*qair) * sfctmp
5158 tmp1 = vkc * (grav/tvir) * h/(rhoair*cpair)
5159 if (abs(tmp1) .le. mpe) tmp1 = mpe
5160 mol = -1. * fv**3 / tmp1
5161 moz = min( (zlvl-zpd)/mol, 1.)
5162 moz2 = min( (2.0 + z0h)/mol, 1.)
5163 endif
5164
5165! accumulate number of times moz changes sign.
5166
5167 if (mozold*moz .lt. 0.) mozsgn = mozsgn+1
5168 if (mozsgn .ge. 2) then
5169 moz = 0.
5170 fm = 0.
5171 fh = 0.
5172 moz2 = 0.
5173 fm2 = 0.
5174 fh2 = 0.
5175 endif
5176
5177! evaluate stability-dependent variables using moz from prior iteration
5178 if (moz .lt. 0.) then
5179 tmp1 = (1. - 16.*moz)**0.25
5180 tmp2 = log((1.+tmp1*tmp1)/2.)
5181 tmp3 = log((1.+tmp1)/2.)
5182 fmnew = 2.*tmp3 + tmp2 - 2.*atan(tmp1) + 1.5707963
5183 fhnew = 2*tmp2
5184
5185! 2-meter
5186 tmp12 = (1. - 16.*moz2)**0.25
5187 tmp22 = log((1.+tmp12*tmp12)/2.)
5188 tmp32 = log((1.+tmp12)/2.)
5189 fm2new = 2.*tmp32 + tmp22 - 2.*atan(tmp12) + 1.5707963
5190 fh2new = 2*tmp22
5191 else
5192 fmnew = -5.*moz
5193 fhnew = fmnew
5194 fm2new = -5.*moz2
5195 fh2new = fm2new
5196 endif
5197
5198! except for first iteration, weight stability factors for previous
5199! iteration to help avoid flip-flops from one iteration to the next
5200
5201 if (iter == 1) then
5202 fm = fmnew
5203 fh = fhnew
5204 fm2 = fm2new
5205 fh2 = fh2new
5206 else
5207 fm = 0.5 * (fm+fmnew)
5208 fh = 0.5 * (fh+fhnew)
5209 fm2 = 0.5 * (fm2+fm2new)
5210 fh2 = 0.5 * (fh2+fh2new)
5211 endif
5212
5213! exchange coefficients
5214
5215 fh = min(fh,0.9*tmpch)
5216 fm = min(fm,0.9*tmpcm)
5217 fh2 = min(fh2,0.9*tmpch2)
5218 fm2 = min(fm2,0.9*tmpcm2)
5219
5220 cmfm = tmpcm-fm
5221 chfh = tmpch-fh
5222 cm2fm2 = tmpcm2-fm2
5223 ch2fh2 = tmpch2-fh2
5224 if(abs(cmfm) <= mpe) cmfm = mpe
5225 if(abs(chfh) <= mpe) chfh = mpe
5226 if(abs(cm2fm2) <= mpe) cm2fm2 = mpe
5227 if(abs(ch2fh2) <= mpe) ch2fh2 = mpe
5228 cm = vkc*vkc/(cmfm*cmfm)
5229 ch = vkc*vkc/(cmfm*chfh)
5230 ch2 = vkc*vkc/(cm2fm2*ch2fh2)
5231
5232! friction velocity
5233
5234 fv = ur * sqrt(cm)
5235 ch2 = vkc*fv/ch2fh2
5236
5237 end subroutine sfcdif1
5238
5239!== begin sfcdif2 ==================================================================================
5240
5244 subroutine sfcdif2(parameters,iter ,z0 ,thz0 ,thlm ,sfcspd , & !in
5245 zlm ,iloc ,jloc , & !in
5246 akms ,akhs ,rlmo ,wstar2 , & !in
5247 ustar ) !out
5248
5249! -------------------------------------------------------------------------------------------------
5250! subroutine sfcdif (renamed sfcdif_off to avoid clash with eta pbl)
5251! -------------------------------------------------------------------------------------------------
5252! calculate surface layer exchange coefficients via iterative process.
5253! see chen et al (1997, blm)
5254! -------------------------------------------------------------------------------------------------
5255 implicit none
5256 type (noahmp_parameters), intent(in) :: parameters
5257 integer, intent(in) :: iloc
5258 integer, intent(in) :: jloc
5259 integer, intent(in) :: iter
5260 real (kind=kind_phys), intent(in) :: zlm, z0, thz0, thlm, sfcspd
5261 real (kind=kind_phys), intent(inout) :: akms
5262 real (kind=kind_phys), intent(inout) :: akhs
5263 real (kind=kind_phys), intent(inout) :: rlmo
5264 real (kind=kind_phys), intent(inout) :: wstar2
5265 real (kind=kind_phys), intent(inout) :: ustar
5266
5267 real (kind=kind_phys) zz, pslmu, pslms, pslhu, pslhs
5268 real (kind=kind_phys) xx, pspmu, yy, pspms, psphu, psphs
5269 real (kind=kind_phys) zilfc, zu, zt, rdz, cxch
5270 real (kind=kind_phys) dthv, du2, btgh, zslu, zslt, rlogu, rlogt
5271 real (kind=kind_phys) zetalt, zetalu, zetau, zetat, xlu4, xlt4, xu4, xt4
5272
5273 real (kind=kind_phys) xlu, xlt, xu, xt, psmz, simm, pshz, simh, ustark, rlmn, &
5274 & rlma
5275
5276 integer ilech, itr
5277
5278 integer, parameter :: itrmx = 5
5279 real (kind=kind_phys), parameter :: wwst = 1.2
5280 real (kind=kind_phys), parameter :: wwst2 = wwst * wwst
5281 real (kind=kind_phys), parameter :: vkrm = 0.40
5282 real (kind=kind_phys), parameter :: excm = 0.001
5283 real (kind=kind_phys), parameter :: beta = 1.0 / 270.0
5284 real (kind=kind_phys), parameter :: btg = beta * grav
5285 real (kind=kind_phys), parameter :: elfc = vkrm * btg
5286 real (kind=kind_phys), parameter :: wold = 0.15
5287 real (kind=kind_phys), parameter :: wnew = 1.0 - wold
5288 real (kind=kind_phys), parameter :: pihf = 3.14159265 / 2.
5289 real (kind=kind_phys), parameter :: epsu2 = 1.e-4
5290 real (kind=kind_phys), parameter :: epsust = 0.07
5291 real (kind=kind_phys), parameter :: epsit = 1.e-4
5292 real (kind=kind_phys), parameter :: epsa = 1.e-8
5293 real (kind=kind_phys), parameter :: ztmin = -5.0
5294 real (kind=kind_phys), parameter :: ztmax = 1.0
5295 real (kind=kind_phys), parameter :: hpbl = 1000.0
5296 real (kind=kind_phys), parameter :: sqvisc = 258.2
5297 real (kind=kind_phys), parameter :: ric = 0.183
5298 real (kind=kind_phys), parameter :: rric = 1.0 / ric
5299 real (kind=kind_phys), parameter :: fhneu = 0.8
5300 real (kind=kind_phys), parameter :: rfc = 0.191
5301 real (kind=kind_phys), parameter :: rfac = ric / ( fhneu * rfc * rfc )
5302
5303! ----------------------------------------------------------------------
5304! note: the two code blocks below define functions
5305! ----------------------------------------------------------------------
5306! lech's surface functions
5307 pslmu(zz)= -0.96* log(1.0-4.5* zz)
5308 pslms(zz)= zz * rric -2.076* (1. -1./ (zz +1.))
5309 pslhu(zz)= -0.96* log(1.0-4.5* zz)
5310 pslhs(zz)= zz * rfac -2.076* (1. -1./ (zz +1.))
5311! paulson's surface functions
5312 pspmu(xx)= -2.* log( (xx +1.)*0.5) - log( (xx * xx +1.)*0.5) &
5313 & +2.* atan(xx) &
5314 &- pihf
5315 pspms(yy)= 5.* yy
5316 psphu(xx)= -2.* log( (xx * xx +1.)*0.5)
5317 psphs(yy)= 5.* yy
5318
5319! this routine sfcdif can handle both over open water (sea, ocean) and
5320! over solid surface (land, sea-ice).
5321! ----------------------------------------------------------------------
5322! ztfc: ratio of zoh/zom less or equal than 1
5323! c......ztfc=0.1
5324! czil: constant c in zilitinkevich, s. s.1995,:note about zt
5325! ----------------------------------------------------------------------
5326 ilech = 0
5327
5328! ----------------------------------------------------------------------
5329 zilfc = - parameters%czil * vkrm * sqvisc
5330 zu = z0
5331 rdz = 1./ zlm
5332 cxch = excm * rdz
5333 dthv = thlm - thz0
5334
5335! beljars correction of ustar
5336 du2 = max(sfcspd * sfcspd,epsu2)
5337 btgh = btg * hpbl
5338
5339 if(iter == 1) then
5340 if (btgh * akhs * dthv .ne. 0.0) then
5341 wstar2 = wwst2* abs(btgh * akhs * dthv)** (2./3.)
5342 else
5343 wstar2 = 0.0
5344 end if
5345 ustar = max(sqrt(akms * sqrt(du2+ wstar2)),epsust)
5346 rlmo = elfc * akhs * dthv / ustar **3
5347 end if
5348
5349! zilitinkevitch approach for zt
5350 zt = max(1.e-6,exp(zilfc * sqrt(ustar * z0))* z0)
5351 zslu = zlm + zu
5352 zslt = zlm + zt
5353 rlogu = log(zslu / zu)
5354 rlogt = log(zslt / zt)
5355
5356! ----------------------------------------------------------------------
5357! 1./monin-obukkhov length-scale
5358! ----------------------------------------------------------------------
5359 zetalt = max(zslt * rlmo,ztmin)
5360 rlmo = zetalt / zslt
5361 zetalu = zslu * rlmo
5362 zetau = zu * rlmo
5363 zetat = zt * rlmo
5364
5365 if (ilech .eq. 0) then
5366 if (rlmo .lt. 0.)then
5367 xlu4 = 1. -16.* zetalu
5368 xlt4 = 1. -16.* zetalt
5369 xu4 = 1. -16.* zetau
5370 xt4 = 1. -16.* zetat
5371 xlu = sqrt(sqrt(xlu4))
5372 xlt = sqrt(sqrt(xlt4))
5373 xu = sqrt(sqrt(xu4))
5374
5375 xt = sqrt(sqrt(xt4))
5376 psmz = pspmu(xu)
5377 simm = pspmu(xlu) - psmz + rlogu
5378 pshz = psphu(xt)
5379 simh = psphu(xlt) - pshz + rlogt
5380 else
5381 zetalu = min(zetalu,ztmax)
5382 zetalt = min(zetalt,ztmax)
5383 zetau = min(zetau,ztmax/(zslu/zu)) ! barlage: add limit on zetau/zetat
5384 zetat = min(zetat,ztmax/(zslt/zt)) ! barlage: prevent simm/simh < 0
5385 psmz = pspms(zetau)
5386 simm = pspms(zetalu) - psmz + rlogu
5387 pshz = psphs(zetat)
5388 simh = psphs(zetalt) - pshz + rlogt
5389 end if
5390! ----------------------------------------------------------------------
5391! lech's functions
5392! ----------------------------------------------------------------------
5393 else
5394 if (rlmo .lt. 0.)then
5395 psmz = pslmu(zetau)
5396 simm = pslmu(zetalu) - psmz + rlogu
5397 pshz = pslhu(zetat)
5398 simh = pslhu(zetalt) - pshz + rlogt
5399 else
5400 zetalu = min(zetalu,ztmax)
5401 zetalt = min(zetalt,ztmax)
5402 psmz = pslms(zetau)
5403 simm = pslms(zetalu) - psmz + rlogu
5404 pshz = pslhs(zetat)
5405 simh = pslhs(zetalt) - pshz + rlogt
5406 end if
5407! ----------------------------------------------------------------------
5408 end if
5409
5410! ----------------------------------------------------------------------
5411! beljaars correction for ustar
5412! ----------------------------------------------------------------------
5413 ustar = max(sqrt(akms * sqrt(du2+ wstar2)),epsust)
5414
5415! zilitinkevitch fix for zt
5416 zt = max(1.e-6,exp(zilfc * sqrt(ustar * z0))* z0)
5417 zslt = zlm + zt
5418!-----------------------------------------------------------------------
5419 rlogt = log(zslt / zt)
5420 ustark = ustar * vkrm
5421 if(simm < 1.e-6) simm = 1.e-6 ! limit stability function
5422 akms = max(ustark / simm,cxch)
5423!-----------------------------------------------------------------------
5424! if statements to avoid tangent linear problems near zero
5425!-----------------------------------------------------------------------
5426 if(simh < 1.e-6) simh = 1.e-6 ! limit stability function
5427 akhs = max(ustark / simh,cxch)
5428
5429 if (btgh * akhs * dthv .ne. 0.0) then
5430 wstar2 = wwst2* abs(btgh * akhs * dthv)** (2./3.)
5431 else
5432 wstar2 = 0.0
5433 end if
5434!-----------------------------------------------------------------------
5435 rlmn = elfc * akhs * dthv / ustar **3
5436!-----------------------------------------------------------------------
5437! if(abs((rlmn-rlmo)/rlma).lt.epsit) go to 110
5438!-----------------------------------------------------------------------
5439 rlma = rlmo * wold+ rlmn * wnew
5440!-----------------------------------------------------------------------
5441 rlmo = rlma
5442
5443! write(*,'(a20,10f15.6)')'sfcdif: rlmo=',rlmo,rlmn,elfc , akhs , dthv , ustar
5444! end do
5445! ----------------------------------------------------------------------
5446 end subroutine sfcdif2
5447
5448!== begin sfcdif3 ==================================================================================
5449
5452 subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in
5453 zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in
5454 z0h,zpd ,snowh ,fveg ,garea1 , & !in
5455 ustarx ,fm ,fh ,fm2 ,fh2 , & !inout
5456 fv ,cm ,ch ) !out
5457
5458! -------------------------------------------------------------------------------------------------
5459! computing surface drag coefficient cm for momentum and ch for heat
5460! -------------------------------------------------------------------------------------------------
5461 implicit none
5462! -------------------------------------------------------------------------------------------------
5463! inputs
5464
5465 type (noahmp_parameters), intent(in) :: parameters
5466 integer, intent(in ) :: iloc
5467 integer, intent(in ) :: jloc
5468 integer, intent(in ) :: iter
5469 real (kind=kind_phys), intent(in ) :: sfctmp
5470 real (kind=kind_phys), intent(in ) :: qair
5471 real (kind=kind_phys), intent(in ) :: ur
5472 real (kind=kind_phys), intent(in ) :: zlvl
5473 real (kind=kind_phys), intent(in ) :: tgb
5474 logical, intent(in ) :: thsfc_loc
5475 real (kind=kind_phys), intent(in ) :: prslkix
5476 real (kind=kind_phys), intent(in ) :: prsik1x
5477 real (kind=kind_phys), intent(in ) :: prslk1x
5478 real (kind=kind_phys), intent(in ) :: z0m
5479 real (kind=kind_phys), intent(in ) :: z0h
5480 real (kind=kind_phys), intent(in ) :: zpd
5481 real (kind=kind_phys), intent(in ) :: snowh
5482 real (kind=kind_phys), intent(in ) :: fveg
5483 real (kind=kind_phys), intent(in ) :: garea1
5484 real (kind=kind_phys), intent(inout) :: ustarx
5485 real (kind=kind_phys), intent(inout) :: fm
5486 real (kind=kind_phys), intent(inout) :: fh
5487 real (kind=kind_phys), intent(inout) :: fm2
5488 real (kind=kind_phys), intent(inout) :: fh2
5489 real (kind=kind_phys), intent( out) :: fv
5490 real (kind=kind_phys), intent( out) :: cm
5491 real (kind=kind_phys), intent( out) :: ch
5492
5493 real (kind=kind_phys) :: snwd ! snow depth [mm]
5494 real (kind=kind_phys) :: zlvlb ! reference height - zpd [m]
5495 real (kind=kind_phys) :: virtfac ! virtual temperature factor [-]
5496 real (kind=kind_phys) :: tv1 ! virtual temperature at reference [K]
5497 real (kind=kind_phys) :: thv1 ! virtual theta at reference [K]
5498 real (kind=kind_phys) :: tvs ! virtural surface temperature [K]
5499 real (kind=kind_phys) :: rb1 ! bulk Richardson - stability output
5500 real (kind=kind_phys) :: stress1 ! stress - stability output
5501 real (kind=kind_phys) :: fm10 ! 10-m stability adjustment - stability output
5502 real (kind=kind_phys) :: tem1,tem2,zvfun1,gdx
5503 real (kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0
5504
5505! -------------------------------------------------------------------------------------------------
5506
5507 fv = ustarx
5508! fv = ur*vkc/log((zlvl-zpd)/z0m)
5509
5510 snwd = snowh*1000.0
5511 zlvlb = zlvl - zpd
5512
5513 virtfac = 1.0 + 0.61 * max(qair, 1.0e-8)
5514 tv1 = sfctmp * virtfac
5515
5516 if(thsfc_loc) then ! Use local potential temperature
5517 thv1 = sfctmp * prslkix * virtfac
5518 else ! Use potential temperature reference to 1000 hPa
5519 thv1 = sfctmp / prslk1x * virtfac
5520 endif
5521
5522 tem1 = (z0m - z0lo) / (z0up - z0lo)
5523 tem1 = min(max(tem1, 0.0_kind_phys), 1.0_kind_phys)
5524 tem2 = max(fveg, 0.1_kind_phys)
5525 zvfun1 = sqrt(tem1 * tem2)
5526 gdx = sqrt(garea1)
5527
5528 gdx = 3000.0 ! this will remove gdx effect
5529 zvfun1 = 1.0 ! this will remove zvfun effect
5530
5531 if(thsfc_loc) then ! Use local potential temperature
5532 tvs = tgb * virtfac
5533 else ! Use potential temperature referenced to 1000 hPa
5534 tvs = tgb/prsik1x * virtfac
5535 endif
5536
5537 call gfs_stability (zlvlb, zvfun1, gdx, tv1, thv1, ur, z0m, z0h, tvs, grav, thsfc_loc, &
5538 rb1, fm,fh,fm10,fh2,cm,ch,stress1,fv)
5539
5540 end subroutine sfcdif3
5541
5542!== begin gfs_stability ==================================================================================
5543
5544subroutine gfs_stability &
5545! --- inputs:
5546 ( z1, zvfun, gdx, tv1, thv1, wind, z0max, ztmax, tvs, grav, &
5547 thsfc_loc, &
5548! --- outputs:
5549 rb, fm, fh, fm10, fh2, cm, ch, stress, ustar)
5550
5551! Documentation below refers to UTN and STN which are:
5552! UTN (Unstable Tech Note) : NCEP Office Note 356
5553! STN (Stable Tech Note) : NCEP Office Note 321
5554
5555real(kind=kind_phys), parameter :: ca=0.4_kind_phys ! ca - von karman constant
5556
5557real(kind=kind_phys), intent(in) :: z1 ! height model level
5558real(kind=kind_phys), intent(in) :: zvfun ! vegetation adjustment factor
5559real(kind=kind_phys), intent(in) :: gdx ! grid spatial dimension
5560real(kind=kind_phys), intent(in) :: tv1 ! virtual temperature at model level
5561real(kind=kind_phys), intent(in) :: thv1 ! virtual potential temperature at model level
5562real(kind=kind_phys), intent(in) :: wind ! wind speed at model level
5563real(kind=kind_phys), intent(in) :: z0max ! momentum roughness length
5564real(kind=kind_phys), intent(in) :: ztmax ! thermal roughness length
5565real(kind=kind_phys), intent(in) :: tvs ! surface virtual temperature
5566real(kind=kind_phys), intent(in) :: grav ! local gravity
5567logical, intent(in) :: thsfc_loc ! use local theta reference flag
5568
5569real(kind=kind_phys), intent(out) :: rb ! bulk richardson number [-]
5570real(kind=kind_phys), intent(out) :: fm ! phi momentum function (UTN 1.1) [-]
5571real(kind=kind_phys), intent(out) :: fh ! phi heat function (UTN 1.2) [-]
5572real(kind=kind_phys), intent(out) :: fm10 ! 10-meter phi momentum function [-]
5573real(kind=kind_phys), intent(out) :: fh2 ! 2-meter phi heat function [-]
5574real(kind=kind_phys), intent(out) :: cm ! momentum exchange coeficient [-]
5575real(kind=kind_phys), intent(out) :: ch ! heat exchange coeficient [-]
5576real(kind=kind_phys), intent(out) :: stress ! surface stress [m2/s2]
5577real(kind=kind_phys), intent(out) :: ustar ! friction velocity [m/s]
5578
5579! --- locals:
5580real(kind=kind_phys), parameter :: a0 = -3.975 ! UTN 2.37
5581real(kind=kind_phys), parameter :: a1 = 12.32 ! UTN 2.37
5582real(kind=kind_phys), parameter :: b1 = -7.755 ! UTN 2.37
5583real(kind=kind_phys), parameter :: b2 = 6.041 ! UTN 2.37
5584real(kind=kind_phys), parameter :: a0p = -7.941 ! UTN 2.38
5585real(kind=kind_phys), parameter :: a1p = 24.75 ! UTN 2.38
5586real(kind=kind_phys), parameter :: b1p = -8.705 ! UTN 2.38
5587real(kind=kind_phys), parameter :: b2p = 7.899 ! UTN 2.38
5588
5589real(kind=kind_phys), parameter :: alpha = 5.0 ! alpha in e.g., STN 1.10
5590real(kind=kind_phys), parameter :: alpha4 = 4.0 * alpha ! term in aa
5591real(kind=kind_phys), parameter :: xkrefsqr = 0.3 ! baseline maximum z/L
5592real(kind=kind_phys), parameter :: xkmin = 0.05 ! min multiplier for grid size and vegetation
5593real(kind=kind_phys), parameter :: xkgdx = 3000.0 ! critical grid scale for diffusivity[m^0.5]
5594real(kind=kind_phys), parameter :: zolmin = -10.0 ! minimum z/L
5595real(kind=kind_phys), parameter :: zero = 0.0
5596real(kind=kind_phys), parameter :: one = 1.0
5597
5598real(kind=kind_phys) :: aa
5599real(kind=kind_phys) :: aa0
5600real(kind=kind_phys) :: bb
5601real(kind=kind_phys) :: bb0
5602real(kind=kind_phys) :: dtv
5603real(kind=kind_phys) :: adtv
5604real(kind=kind_phys) :: hl1
5605real(kind=kind_phys) :: hl12
5606real(kind=kind_phys) :: pm
5607real(kind=kind_phys) :: ph
5608real(kind=kind_phys) :: pm10
5609real(kind=kind_phys) :: ph2
5610real(kind=kind_phys) :: z1i
5611real(kind=kind_phys) :: fms
5612real(kind=kind_phys) :: fhs
5613real(kind=kind_phys) :: hl0
5614real(kind=kind_phys) :: hl0inf
5615real(kind=kind_phys) :: hlinf
5616real(kind=kind_phys) :: hl110
5617real(kind=kind_phys) :: hlt
5618real(kind=kind_phys) :: hltinf
5619real(kind=kind_phys) :: olinf
5620real(kind=kind_phys) :: tem1
5621real(kind=kind_phys) :: tem2
5622real(kind=kind_phys) :: zolmax
5623
5624real(kind=kind_phys) xkzo
5625
5626z1i = one / z1 ! inverse of model height
5627
5628!
5629! set background diffusivities with one for gdx >= xkgdx and
5630! as a function of horizontal grid size for gdx < xkgdx
5631! (i.e., gdx/xkgdx for gdx < xkgdx)
5632!
5633
5634if(gdx >= xkgdx) then
5635 xkzo = one
5636else
5637 xkzo = gdx / xkgdx
5638endif
5639
5640tem1 = tv1 - tvs
5641if(tem1 > zero) then ! for stable case, adjust for vegetation cover
5642 tem2 = xkzo * zvfun
5643 xkzo = min(max(tem2, xkmin), xkzo)
5644endif
5645
5646zolmax = xkrefsqr / sqrt(xkzo) ! maximum z/L
5647
5648! compute stability indices (rb and hlinf)
5649
5650 dtv = thv1 - tvs
5651 adtv = max(abs(dtv),0.001_kind_phys)
5652 dtv = sign(1.0_kind_phys,dtv) * adtv
5653
5654 if(thsfc_loc) then ! Use local potential temperature
5655 rb = max(-5000.0_kind_phys, (grav+grav) * dtv * z1 &
5656 / ((thv1 + tvs) * wind * wind))
5657 else ! Use potential temperature referenced to 1000 hPa
5658 rb = max(-5000.0_kind_phys, grav * dtv * z1 &
5659 / (tv1 * wind * wind))
5660 endif
5661
5662 tem1 = one / z0max ! 1/z0m
5663 tem2 = one / ztmax ! 1/z0t
5664 fm = log((z0max+z1) * tem1) ! neutral phi_m
5665 fh = log((ztmax+z1) * tem2) ! neutral phi_h
5666 fm10 = log((z0max+10.0_kind_phys) * tem1) ! neutral phi_m at 10 meters
5667 fh2 = log((ztmax+2.0_kind_phys) * tem2) ! neutral phi_h at 2 meters
5668 hlinf = rb * fm * fm / fh ! z/L STN 2.7
5669 hlinf = min(max(hlinf,zolmin),zolmax) ! z/L, xi in STN/UTN
5670!
5671! stable case
5672!
5673 if (dtv >= zero) then
5674 hl1 = hlinf ! z/L, xi in STN
5675 if(hlinf > 0.25_kind_phys) then ! z/L > 0.25, do two iterations
5676 tem1 = hlinf * z1i ! 1/L
5677 hl0inf = z0max * tem1 ! z0m/z1, zi_0 in STN
5678 hltinf = ztmax * tem1 ! z0t/z1, zi_0 in STN
5679 aa = sqrt(one + alpha4 * hlinf) ! sqrt term of STN 2.16 with z
5680 aa0 = sqrt(one + alpha4 * hl0inf) ! sqrt term of STN 2.16 with z0m
5681 bb = aa ! sqrt term of STN 2.16 with z
5682 bb0 = sqrt(one + alpha4 * hltinf) ! sqrt term of STN 2.16 with z0t
5683 pm = aa0 - aa + log( (aa + one)/(aa0 + one) ) ! psi_m STN 3.11
5684 ph = bb0 - bb + log( (bb + one)/(bb0 + one) ) ! psi_h STN 3.11
5685 fms = fm - pm ! phi_m STN 3.10
5686 fhs = fh - ph ! phi_h STN 3.10
5687 hl1 = fms * fms * rb / fhs ! z/L iteration STN 3.8
5688 hl1 = min(hl1, zolmax) ! z/L iteration
5689 endif
5690!
5691! second iteration
5692!
5693 tem1 = hl1 * z1i ! 1/L
5694 hl0 = z0max * tem1 ! z0m/z1
5695 hlt = ztmax * tem1 ! z0t/z1
5696 aa = sqrt(one + alpha4 * hl1) ! sqrt term of STN 2.16 with z
5697 aa0 = sqrt(one + alpha4 * hl0) ! sqrt term of STN 2.16 with z0m
5698 bb = aa ! sqrt term of STN 2.16 with z
5699 bb0 = sqrt(one + alpha4 * hlt) ! sqrt term of STN 2.16 with z0t
5700 pm = aa0 - aa + log( (one+aa)/(one+aa0) ) ! psi_m STN 3.11
5701 ph = bb0 - bb + log( (one+bb)/(one+bb0) ) ! psi_h STN 3.11
5702 hl110 = hl1 * 10.0_kind_phys * z1i ! 10/L
5703 aa = sqrt(one + alpha4 * hl110) ! sqrt term of STN 2.16 with z=10m
5704 pm10 = aa0 - aa + log( (one+aa)/(one+aa0) ) ! psi_m STN 3.11 with z=10m
5705 hl12 = (hl1+hl1) * z1i ! 2/L
5706! aa = sqrt(one + alpha4 * hl12)
5707 bb = sqrt(one + alpha4 * hl12) ! sqrt term of STN 2.16 with z=2m
5708 ph2 = bb0 - bb + log( (one+bb)/(one+bb0) ) ! psi_m STN 3.11 with z=2m
5709!
5710! unstable case - check for unphysical obukhov length
5711! see steps in UTN Sec. D
5712!
5713 else ! dtv < 0 case
5714
5715 olinf = z1 / hlinf ! z/L, xi in UTN
5716 tem1 = 50.0_kind_phys * z0max ! 50 * z0m, z/L limit for calc methods, see UTN Sec. E
5717 if(abs(olinf) <= tem1) then !
5718 hlinf = -z1 / tem1 !
5719 hlinf = max(hlinf, zolmin)
5720 endif
5721!
5722! get pm and ph
5723!
5724 if (hlinf >= -0.5_kind_phys) then
5725 hl1 = hlinf
5726 pm = (a0 + a1*hl1) * hl1 / (one+ (b1+b2*hl1) *hl1) ! psi_m UTN 2.37
5727 ph = (a0p + a1p*hl1) * hl1 / (one+ (b1p+b2p*hl1)*hl1) ! psi_h UTN 2.38
5728 hl110 = hl1 * 10.0_kind_phys * z1i ! 10/L
5729 pm10 = (a0 + a1*hl110) * hl110/(one+(b1+b2*hl110)*hl110) ! psi_m UTN 2.37 with z=10m
5730 hl12 = (hl1+hl1) * z1i ! 2/L
5731 ph2 = (a0p + a1p*hl12) * hl12/(one+(b1p+b2p*hl12)*hl12) ! psi_h UTN 2.38 with z=2m
5732 else ! z/L < -0.5
5733 hl1 = -hlinf ! -z/L
5734 tem1 = one / sqrt(hl1) ! sqrt(-z/L)
5735 pm = log(hl1) + 2.0_kind_phys * sqrt(tem1) - 0.8776_kind_phys ! UTN 2.64, first three terms
5736 ph = log(hl1) + 0.5_kind_phys * tem1 + 1.386_kind_phys ! UTN 2.65, first three terms
5737 hl110 = hl1 * 10.0_kind_phys * z1i ! 10/L
5738 pm10 = log(hl110) + 2.0_kind_phys/sqrt(sqrt(hl110)) - 0.8776_kind_phys ! psi_m UTN 2.64 with z=10m
5739 hl12 = (hl1+hl1) * z1i ! 2/L
5740 ph2 = log(hl12) + 0.5_kind_phys / sqrt(hl12) + 1.386_kind_phys ! psi_h UTN 2.65 with z=2m
5741 endif
5742
5743 endif ! end of if (dtv >= 0 ) then loop
5744!
5745! finish the exchange coefficient computation to provide fm and fh
5746!
5747 fm = fm - pm ! phi_m
5748 fh = fh - ph ! phi_h
5749 fm10 = fm10 - pm10 ! phi_m at 10m
5750 fh2 = fh2 - ph2 ! phi_h at 2m
5751 cm = ca * ca / (fm * fm) ! momentum exchange coef = k^2/phi_m^2
5752 ch = ca * ca / (fm * fh) ! heat exchange coef = k^2/phi_m/phi_h
5753 tem1 = 0.00001_kind_phys/z1 ! minimum exhange coef (?)
5754 cm = max(cm, tem1)
5755 ch = max(ch, tem1)
5756 stress = cm * wind * wind ! surface stress = Cm*U*U
5757 ustar = sqrt(stress) ! friction velocity
5758
5759 return
5760!.................................
5761 end subroutine gfs_stability
5762!---------------------------------
5763
5764!== begin thermalz0
5765!==================================================================================
5766
5768! compute thermal roughness length based on option opt_trs.
5769
5770 subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl, zpd, ezpd, & !in
5771 ustarx, vegtyp, vaie, ur, c_sigma_f0, c_sigma_f1, a1, & !in
5772 cdmn_v, cdmn_g, surface_flag, & !in
5773 z0m_out, z0h_out ) !out
5774
5775! compute thermal roughness length based on option opt_trs.
5776! -------------------------------------------------------------------------------------------------
5777 implicit none
5778! -------------------------------------------------------------------------------------------------
5779! inputs
5780
5781 type (noahmp_parameters),intent(in ) :: parameters ! parameters data structure
5782 integer , intent(in ) :: vegtyp ! vegetation type
5783 integer , intent(in ) :: surface_flag ! 0=bare 1=vegetation 2=composite
5784 real (kind=kind_phys), intent(in ) :: fveg ! vegetation fraction [0.0-1.0]
5785 real (kind=kind_phys), intent(in ) :: z0m ! z0 momentum [m]
5786 real (kind=kind_phys), intent(in ) :: z0mg ! z0 momentum, ground [m]
5787 real (kind=kind_phys), intent(in ) :: zlvl ! reference height [m]
5788 real (kind=kind_phys), intent(in ) :: zpd ! zero plane displacement [m]
5789 real (kind=kind_phys), intent(in ) :: ezpd ! grid zero plane displacement [m]
5790 real (kind=kind_phys), intent(in ) :: ustarx ! friction velocity [m/s]
5791 real (kind=kind_phys), intent(in ) :: vaie ! exposed LAI + SAI [m2/m2]
5792 real (kind=kind_phys), intent(in ) :: ur ! wind speed [m/s]
5793 real (kind=kind_phys), intent(in ) :: a1 ! Blumel 99 eqn 43
5794 real (kind=kind_phys), intent(in ) :: cdmn_v ! neutral momentum drag coefficient for vegetation
5795 real (kind=kind_phys), intent(in ) :: cdmn_g ! neutral momentum drag coefficient for bare ground
5796 real (kind=kind_phys), intent(inout) :: c_sigma_f0 ! C factor for no vegetation Blumel99 eqn 35
5797 real (kind=kind_phys), intent(inout) :: c_sigma_f1 ! C factor for full vegetation Blumel99 eqn 39
5798 real (kind=kind_phys), intent(out ) :: z0m_out ! output z0 momentum [m]
5799 real (kind=kind_phys), intent(out ) :: z0h_out ! output z0 heat [m]
5800
5801! local
5802 real (kind=kind_phys) :: czil ! Zilitinkevich factor
5803 real (kind=kind_phys) :: coeff_a ! slope of Blumel99 eqn 40 Blumel99 eqn 41
5804 real (kind=kind_phys) :: coeff_b ! intercept of Blumel99 eqn 40 Blumel99 eqn 42
5805 real (kind=kind_phys) :: c_sigma_fveg ! estimated C factor Blumel99 eqn 40
5806 real (kind=kind_phys) :: g_sigma ! weighting function Blumel99 eqn 22
5807 real (kind=kind_phys) :: sigma_a ! momentum partition factor Blumel99 eqn 8
5808 real (kind=kind_phys) :: cdmn ! grid neutral momentum drag coefficient Blumel99 eqn 21
5809 real (kind=kind_phys) :: reyn ! roughness Reynolds number Blumel99 eqn 36c
5810 real (kind=kind_phys) :: kb_sigma_f0 ! bare ground kb^-1 Blumel99 eqn 36ab
5811 real (kind=kind_phys) :: kb_sigma_f1 ! vegetated kb^-1 Blumel99 eqn 38
5812 real (kind=kind_phys) :: kb_sigma_fveg! grid estimated kb^-1 Blumel99 eqn 34
5813
5814 integer, parameter :: bare_flag = 0, vegetated_flag = 1, composite_flag = 2
5815 integer, parameter :: z0heqz0m = 1, &
5816 chen09 = 2, &
5817 tessel = 3, &
5818 blumel99 = 4
5819 real (kind=kind_phys), parameter :: blumel_gamma = 0.5, &
5820 blumel_zeta = 1.0, &
5821 viscosity = 1.5e-5
5822
5823! -------------------------------------------------------------------------------------------------
5824 czil = 0.5
5825 coeff_a = 0.0
5826 coeff_b = 0.0
5827 c_sigma_fveg = 0.0
5828 g_sigma = 0.0
5829 cdmn = 0.0
5830 reyn = 0.0
5831 sigma_a = 0.0
5832 kb_sigma_fveg = 0.0
5833 kb_sigma_f0 = 0.0
5834 kb_sigma_f1 = 0.0
5835
5836 surface_flag_select : select case(surface_flag)
5837
5838 case (composite_flag) ! calculate grid based z0m and z0h
5839
5840 if (opt_trs == z0heqz0m) then
5841
5842! z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg))
5843 z0m_out = fveg * z0m + (1.0 - fveg) * z0mg
5844 z0h_out = z0m_out
5845
5846 elseif (opt_trs == chen09) then
5847
5848! z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg))
5849 z0m_out = fveg * z0m + (1.0 - fveg) * z0mg
5850 czil = 10.0 ** (- 0.4 * parameters%hvt)
5851
5852 reyn = ustarx*z0m_out/viscosity ! Blumel99 eqn 36c
5853 if (reyn > 2.0) then
5854 kb_sigma_f0 = 2.46*reyn**0.25 - log(7.4) ! Blumel99 eqn 36a
5855 else
5856 kb_sigma_f0 = - log(0.397) ! Blumel99 eqn 36b
5857 endif
5858
5859 z0h_out = exp( fveg * log(z0m * exp(-czil*0.4*258.2*sqrt(ustarx*z0m))) + &
5860 (1.0 - fveg) * log(max(z0mg/exp(kb_sigma_f0),1.0e-6)) )
5861
5862 elseif (opt_trs == tessel) then
5863
5864 z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg))
5865 if (vegtyp <= 5) then
5866 z0h_out = fveg * log(z0m) + (1.0 - fveg) * log(z0mg * 0.1)
5867 else
5868 z0h_out = fveg * log(z0m * 0.01) + (1.0 - fveg) * log(z0mg * 0.1)
5869 endif
5870
5871 elseif (opt_trs == blumel99) then
5872
5873 coeff_a = (c_sigma_f0 - c_sigma_f1)/(1.0 - exp(-1.0*a1)) ! Blumel99 eqn 41
5874 coeff_b = c_sigma_f0 - coeff_a ! Blumel99 eqn 42
5875 c_sigma_fveg = coeff_a * exp(-1.0*a1*fveg) + coeff_b ! Blumel99 eqn 40
5876
5877! blumel_gamma = 0.5 ~ 1.0 and blumel_zeta = 0 ~ 1.0, adjustable empirical
5878! canopy roughness geometry parameter; currently fveg = 0.78 has the largest
5879! momentum flux; can test the fveg-based average by setting 0.5 to 1.0 and 1.0
5880! to 0.0 ! see Blumel; JAM,1999
5881
5882 g_sigma = fveg**blumel_gamma + fveg*(1.0-fveg)*blumel_zeta ! Blumel99 eqn 22
5883 cdmn = g_sigma*cdmn_v + (1.0-g_sigma)*cdmn_g ! Blumel99 eqn 21
5884 z0m_out = (zlvl - ezpd)*exp(-0.4/sqrt(cdmn)) ! Blumel99 eqn 24
5885 kb_sigma_fveg = c_sigma_fveg/log((zlvl-ezpd)/z0m_out) - &
5886 log((zlvl-ezpd)/z0m_out) ! Blumel99 eqn 34
5887 z0h_out = z0m_out/exp(kb_sigma_fveg)
5888
5889 endif
5890
5891 case (bare_flag) ! calculate z0m and z0h over bare tile
5892
5893 z0m_out = z0mg
5894
5895 if (opt_trs == z0heqz0m) then
5896
5897 z0h_out = z0m_out
5898
5899 elseif (opt_trs == tessel) then
5900
5901 if (vegtyp <= 5) then
5902 z0h_out = z0m_out
5903 else
5904 z0h_out = z0m_out * 0.01
5905 endif
5906
5907 elseif (opt_trs == chen09 .or. opt_trs == blumel99) then
5908
5909 reyn = ustarx*z0m_out/viscosity ! Blumel99 eqn 36c
5910 if (reyn > 2.0) then
5911 kb_sigma_f0 = 2.46*reyn**0.25 - log(7.4) ! Blumel99 eqn 36a
5912 else
5913 kb_sigma_f0 = - log(0.397) ! Blumel99 eqn 36b
5914 endif
5915
5916 z0h_out = max(z0m_out/exp(kb_sigma_f0),1.0e-6)
5917 c_sigma_f0 = log((zlvl-zpd)/z0m_out) * &
5918 (log((zlvl-zpd)/z0m_out) + kb_sigma_f0) ! Blumel99 eqn 35
5919
5920 endif
5921
5922 case (vegetated_flag) ! calculate z0m and z0h over vegetated tile
5923
5924 z0m_out = z0m
5925
5926 if (opt_trs == z0heqz0m) then
5927
5928 z0h_out = z0m_out
5929
5930 elseif (opt_trs == chen09) then
5931
5932 czil = 10.0 ** (- 0.4 * parameters%hvt)
5933 z0h_out = z0m_out * exp(-czil*0.4*258.2*sqrt(ustarx*z0m_out))
5934
5935 elseif (opt_trs == tessel) then
5936
5937 if (vegtyp <= 5) then
5938 z0h_out = z0m_out
5939 else
5940 z0h_out = z0m_out*0.01
5941 endif
5942
5943 elseif (opt_trs == blumel99) then
5944
5945 sigma_a = 1.0 - (0.5/(0.5+vaie)) * exp(-vaie**2/8.0) ! Blumel99 eqn 8
5946 kb_sigma_f1 = 16.4 * (sigma_a*vaie**3)**(-0.25) * & ! Blumel99 eqn 38
5947 sqrt(parameters%dleaf*ur/log((zlvl-zpd)/z0m_out))
5948 z0h_out = z0m_out/exp(kb_sigma_f1)
5949 c_sigma_f1 = log((zlvl-zpd)/z0m_out)*(log((zlvl-zpd)/z0m_out)+kb_sigma_f1) ! Blumel99 eqn 39
5950
5951 endif
5952
5953 end select surface_flag_select
5954
5955 end subroutine thermalz0
5956
5957!== begin esat =====================================================================================
5958
5962 subroutine esat(t, esw, esi, desw, desi)
5963!---------------------------------------------------------------------------------------------------
5964! use polynomials to calculate saturation vapor pressure and derivative with
5965! respect to temperature: over water when t > 0 c and over ice when t <= 0 c
5966 implicit none
5967!---------------------------------------------------------------------------------------------------
5968! in
5969
5970 real (kind=kind_phys), intent(in) :: t
5971
5972!out
5973
5974 real (kind=kind_phys), intent(out) :: esw
5975 real (kind=kind_phys), intent(out) :: esi
5976 real (kind=kind_phys), intent(out) :: desw
5977 real (kind=kind_phys), intent(out) :: desi
5978
5979! local
5980
5981 real (kind=kind_phys) :: a0,a1,a2,a3,a4,a5,a6 !coefficients for esat over water
5982 real (kind=kind_phys) :: b0,b1,b2,b3,b4,b5,b6 !coefficients for esat over ice
5983 real (kind=kind_phys) :: c0,c1,c2,c3,c4,c5,c6 !coefficients for dsat over water
5984 real (kind=kind_phys) :: d0,d1,d2,d3,d4,d5,d6 !coefficients for dsat over ice
5985
5986 parameter(a0=6.107799961 , a1=4.436518521e-01, &
5987 a2=1.428945805e-02, a3=2.650648471e-04, &
5988 a4=3.031240396e-06, a5=2.034080948e-08, &
5989 a6=6.136820929e-11)
5990
5991 parameter(b0=6.109177956 , b1=5.034698970e-01, &
5992 b2=1.886013408e-02, b3=4.176223716e-04, &
5993 b4=5.824720280e-06, b5=4.838803174e-08, &
5994 b6=1.838826904e-10)
5995
5996 parameter(c0= 4.438099984e-01, c1=2.857002636e-02, &
5997 c2= 7.938054040e-04, c3=1.215215065e-05, &
5998 c4= 1.036561403e-07, c5=3.532421810e-10, &
5999 c6=-7.090244804e-13)
6000
6001 parameter(d0=5.030305237e-01, d1=3.773255020e-02, &
6002 d2=1.267995369e-03, d3=2.477563108e-05, &
6003 d4=3.005693132e-07, d5=2.158542548e-09, &
6004 d6=7.131097725e-12)
6005
6006 esw = 100.*(a0+t*(a1+t*(a2+t*(a3+t*(a4+t*(a5+t*a6))))))
6007 esi = 100.*(b0+t*(b1+t*(b2+t*(b3+t*(b4+t*(b5+t*b6))))))
6008 desw = 100.*(c0+t*(c1+t*(c2+t*(c3+t*(c4+t*(c5+t*c6))))))
6009 desi = 100.*(d0+t*(d1+t*(d2+t*(d3+t*(d4+t*(d5+t*d6))))))
6010
6011 end subroutine esat
6012
6013!== begin stomata ==================================================================================
6014
6017 subroutine stomata (parameters,vegtyp ,mpe ,apar ,foln ,iloc , jloc, & !in
6018 tv ,ei ,ea ,sfctmp ,sfcprs , & !in
6019 o2 ,co2 ,igs ,btran ,rb , & !in
6020 rs ,psn ) !out
6021! --------------------------------------------------------------------------------------------------
6022 implicit none
6023! --------------------------------------------------------------------------------------------------
6024! input
6025 type (noahmp_parameters), intent(in) :: parameters
6026 integer,intent(in) :: iloc
6027 integer,intent(in) :: jloc
6028 integer,intent(in) :: vegtyp
6029
6030 real (kind=kind_phys), intent(in) :: igs
6031 real (kind=kind_phys), intent(in) :: mpe
6032
6033 real (kind=kind_phys), intent(in) :: tv
6034 real (kind=kind_phys), intent(in) :: ei
6035 real (kind=kind_phys), intent(in) :: ea
6036 real (kind=kind_phys), intent(in) :: apar
6037 real (kind=kind_phys), intent(in) :: o2
6038 real (kind=kind_phys), intent(in) :: co2
6039 real (kind=kind_phys), intent(in) :: sfcprs
6040 real (kind=kind_phys), intent(in) :: sfctmp
6041 real (kind=kind_phys), intent(in) :: btran
6042 real (kind=kind_phys), intent(in) :: foln
6043 real (kind=kind_phys), intent(in) :: rb
6044
6045! output
6046 real (kind=kind_phys), intent(out) :: rs
6047 real (kind=kind_phys), intent(out) :: psn
6048
6049! in&out
6050 real (kind=kind_phys) :: rlb !boundary layer resistance (s m2 / umol)
6051! ---------------------------------------------------------------------------------------------
6052
6053! ------------------------ local variables ----------------------------------------------------
6054 integer :: iter !iteration index
6055 integer :: niter !number of iterations
6056
6057 data niter /3/
6058 save niter
6059
6060 real (kind=kind_phys) :: ab !used in statement functions
6061 real (kind=kind_phys) :: bc !used in statement functions
6062 real (kind=kind_phys) :: f1 !generic temperature response (statement function)
6063 real (kind=kind_phys) :: f2 !generic temperature inhibition (statement function)
6064 real (kind=kind_phys) :: tc !foliage temperature (degree celsius)
6065 real (kind=kind_phys) :: cs !co2 concentration at leaf surface (pa)
6066 real (kind=kind_phys) :: kc !co2 michaelis-menten constant (pa)
6067 real (kind=kind_phys) :: ko !o2 michaelis-menten constant (pa)
6068 real (kind=kind_phys) :: a,b,c,q !intermediate calculations for rs
6069 real (kind=kind_phys) :: r1,r2 !roots for rs
6070 real (kind=kind_phys) :: fnf !foliage nitrogen adjustment factor (0 to 1)
6071 real (kind=kind_phys) :: ppf !absorb photosynthetic photon flux (umol photons/m2/s)
6072 real (kind=kind_phys) :: wc !rubisco limited photosynthesis (umol co2/m2/s)
6073 real (kind=kind_phys) :: wj !light limited photosynthesis (umol co2/m2/s)
6074 real (kind=kind_phys) :: we !export limited photosynthesis (umol co2/m2/s)
6075 real (kind=kind_phys) :: cp !co2 compensation point (pa)
6076 real (kind=kind_phys) :: ci !internal co2 (pa)
6077 real (kind=kind_phys) :: awc !intermediate calculation for wc
6078 real (kind=kind_phys) :: vcmx !maximum rate of carbonylation (umol co2/m2/s)
6079 real (kind=kind_phys) :: j !electron transport (umol co2/m2/s)
6080 real (kind=kind_phys) :: cea !constrain ea or else model blows up
6081 real (kind=kind_phys) :: cf !s m2/umol -> s/m
6082
6083 f1(ab,bc) = ab**((bc-25.)/10.)
6084 f2(ab) = 1. + exp((-2.2e05+710.*(ab+273.16))/(8.314*(ab+273.16)))
6085 real (kind=kind_phys) :: t
6086! ---------------------------------------------------------------------------------------------
6087
6088! initialize rs=rsmax and psn=0 because will only do calculations
6089! for apar > 0, in which case rs <= rsmax and psn >= 0
6090
6091 cf = sfcprs/(8.314*sfctmp)*1.e06
6092 rs = 1./parameters%bp * cf
6093 psn = 0.
6094
6095 if (apar .le. 0.) return
6096
6097 fnf = min( foln/max(mpe,parameters%folnmx), 1.0 )
6098 tc = tv-tfrz
6099 ppf = 4.6*apar
6100 j = ppf*parameters%qe25
6101 kc = parameters%kc25 * f1(parameters%akc,tc)
6102 ko = parameters%ko25 * f1(parameters%ako,tc)
6103 awc = kc * (1.+o2/ko)
6104 cp = 0.5*kc/ko*o2*0.21
6105 vcmx = parameters%vcmx25 / f2(tc) * fnf * btran * f1(parameters%avcmx,tc)
6106
6107! first guess ci
6108
6109 ci = 0.7*co2*parameters%c3psn + 0.4*co2*(1.-parameters%c3psn)
6110
6111! rb: s/m -> s m**2 / umol
6112
6113 rlb = rb/cf
6114
6115! constrain ea
6116
6117 cea = max(0.25*ei*parameters%c3psn+0.40*ei*(1.-parameters%c3psn), min(ea,ei) )
6118
6119! ci iteration
6120!jref: c3psn is equal to 1 for all veg types.
6121 do iter = 1, niter
6122 wj = max(ci-cp,0.)*j/(ci+2.*cp)*parameters%c3psn + j*(1.-parameters%c3psn)
6123 wc = max(ci-cp,0.)*vcmx/(ci+awc)*parameters%c3psn + vcmx*(1.-parameters%c3psn)
6124 we = 0.5*vcmx*parameters%c3psn + 4000.*vcmx*ci/sfcprs*(1.-parameters%c3psn)
6125 psn = min(wj,wc,we) * igs
6126
6127 cs = max( co2-1.37*rlb*sfcprs*psn, mpe )
6128 a = parameters%mp*psn*sfcprs*cea / (cs*ei) + parameters%bp
6129 b = ( parameters%mp*psn*sfcprs/cs + parameters%bp ) * rlb - 1.
6130 c = -rlb
6131 if (b .ge. 0.) then
6132 q = -0.5*( b + sqrt(b*b-4.*a*c) )
6133 else
6134 q = -0.5*( b - sqrt(b*b-4.*a*c) )
6135 end if
6136 r1 = q/a
6137 r2 = c/q
6138 rs = max(r1,r2)
6139 ci = max( cs-psn*sfcprs*1.65*rs, 0. )
6140 end do
6141
6142! rs, rb: s m**2 / umol -> s/m
6143
6144 rs = rs*cf
6145
6146 end subroutine stomata
6147
6148!== begin canres ===================================================================================
6149
6155 subroutine canres (parameters,ep_2,epsm1,par ,sfctmp,rcsoil ,eah ,sfcprs , & !in
6156 rc ,psn ,iloc ,jloc ) !out
6157
6158! --------------------------------------------------------------------------------------------------
6159! calculate canopy resistance which depends on incoming solar radiation,
6160! air temperature, atmospheric water vapor pressure deficit at the
6161! lowest model level, and soil moisture (preferably unfrozen soil
6162! moisture rather than total)
6163! --------------------------------------------------------------------------------------------------
6164! source: jarvis (1976), noilhan and planton (1989, mwr), jacquemin and
6165! noilhan (1990, blm). chen et al (1996, jgr, vol 101(d3), 7251-7268),
6166! eqns 12-14 and table 2 of sec. 3.1.2
6167! --------------------------------------------------------------------------------------------------
6168!niu use module_noahlsm_utility
6169! --------------------------------------------------------------------------------------------------
6170 implicit none
6171! --------------------------------------------------------------------------------------------------
6172! inputs
6173
6174 type (noahmp_parameters), intent(in) :: parameters
6175 integer, intent(in) :: iloc
6176 integer, intent(in) :: jloc
6177 real (kind=kind_phys), intent(in) :: ep_2
6178 real (kind=kind_phys), intent(in) :: epsm1
6179 real (kind=kind_phys), intent(in) :: par
6180 real (kind=kind_phys), intent(in) :: sfctmp
6181 real (kind=kind_phys), intent(in) :: sfcprs
6182 real (kind=kind_phys), intent(in) :: eah
6183 real (kind=kind_phys), intent(in) :: rcsoil
6184
6185!outputs
6186
6187 real (kind=kind_phys), intent(out) :: rc
6188 real (kind=kind_phys), intent(out) :: psn
6189
6190!local
6191
6192 real (kind=kind_phys) :: rcq
6193 real (kind=kind_phys) :: rcs
6194 real (kind=kind_phys) :: rct
6195 real (kind=kind_phys) :: ff
6196 real (kind=kind_phys) :: q2 !water vapor mixing ratio (kg/kg)
6197 real (kind=kind_phys) :: q2sat !saturation q2
6198 real (kind=kind_phys) :: dqsdt2 !d(q2sat)/d(t)
6199
6200! rsmin, rsmax, topt, rgl, hs are canopy stress parameters set in redprm
6201! ----------------------------------------------------------------------
6202! initialize canopy resistance multiplier terms.
6203! ----------------------------------------------------------------------
6204 rc = 0.0
6205 rcs = 0.0
6206 rct = 0.0
6207 rcq = 0.0
6208
6209! compute q2 and q2sat
6210
6211 q2 = ep_2 * eah / (sfcprs + epsm1 * eah) !specific humidity [kg/kg]
6212 q2 = q2 / (1.0 - q2) !mixing ratio [kg/kg]
6213
6214 call calhum(parameters,sfctmp, sfcprs, q2sat, dqsdt2)
6215
6216! contribution due to incoming solar radiation
6217
6218 ff = 2.0 * par / parameters%rgl
6219 rcs = (ff + parameters%rsmin / parameters%rsmax) / (1.0+ ff)
6220 rcs = max(rcs,0.0001)
6221
6222! contribution due to air temperature
6223
6224 rct = 1.0- 0.0016* ( (parameters%topt - sfctmp)**2.0)
6225 rct = max(rct,0.0001)
6226
6227! contribution due to vapor pressure deficit
6228
6229 rcq = 1.0/ (1.0+ parameters%hs * max(0.,q2sat-q2))
6230 rcq = max(rcq,0.01)
6231
6232! determine canopy resistance due to all factors
6233
6234 rc = parameters%rsmin / (rcs * rct * rcq * rcsoil)
6235 psn = -999.99 ! psn not applied for dynamic carbon
6236
6237 end subroutine canres
6238
6239!== begin calhum ===================================================================================
6240
6243 subroutine calhum(parameters,sfctmp, sfcprs, q2sat, dqsdt2)
6244
6245 implicit none
6246
6247 type (noahmp_parameters), intent(in) :: parameters
6248 real (kind=kind_phys), intent(in) :: sfctmp, sfcprs
6249 real (kind=kind_phys), intent(out) :: q2sat, dqsdt2
6250 real (kind=kind_phys), parameter :: a2=17.67,a3=273.15,a4=29.65, elwv=2.501e6, &
6251 a23m4=a2*(a3-a4), e0=0.611, rv=461.0, &
6252 epsilon=0.622
6253 real (kind=kind_phys) :: es, sfcprsx
6254
6255! q2sat: saturated mixing ratio
6256 es = e0 * exp( elwv/rv*(1./a3 - 1./sfctmp) )
6257! convert sfcprs from pa to kpa
6258 sfcprsx = sfcprs*1.e-3
6259 q2sat = epsilon * es / (sfcprsx-es)
6260! convert from g/g to g/kg
6261 q2sat = q2sat * 1.e3
6262! q2sat is currently a 'mixing ratio'
6263
6264! dqsdt2 is calculated assuming q2sat is a specific humidity
6265 dqsdt2=(q2sat/(1+q2sat))*a23m4/(sfctmp-a4)**2
6266
6267! dg q2sat needs to be in g/g when returned for sflx
6268 q2sat = q2sat / 1.e3
6269
6270 end subroutine calhum
6271
6272!== begin tsnosoi ==================================================================================
6273
6279 subroutine tsnosoi (parameters,ice ,nsoil ,nsnow ,isnow ,ist , & !in
6280 tbot ,zsnso ,ssoil ,df ,hcpct , & !in
6281 sag ,dt ,snowh ,dzsnso , & !in
6282 tg ,iloc ,jloc , & !in
6283#ifdef CCPP
6284 stc ,errmsg ,errflg) !inout
6285#else
6286 stc ) !inout
6287#endif
6288! --------------------------------------------------------------------------------------------------
6289! compute snow (up to 3l) and soil (4l) temperature. note that snow temperatures
6290! during melting season may exceed melting point (tfrz) but later in phasechange
6291! subroutine the snow temperatures are reset to tfrz for melting snow.
6292! --------------------------------------------------------------------------------------------------
6293 implicit none
6294! --------------------------------------------------------------------------------------------------
6295!input
6296
6297 type (noahmp_parameters), intent(in) :: parameters
6298 integer, intent(in) :: iloc
6299 integer, intent(in) :: jloc
6300 integer, intent(in) :: ice
6301 integer, intent(in) :: nsoil
6302 integer, intent(in) :: nsnow
6303 integer, intent(in) :: isnow
6304 integer, intent(in) :: ist
6305
6306 real (kind=kind_phys), intent(in) :: dt
6307 real (kind=kind_phys), intent(in) :: tbot
6308 real (kind=kind_phys), intent(in) :: ssoil
6309 real (kind=kind_phys), intent(in) :: sag
6310 real (kind=kind_phys), intent(in) :: snowh
6311 real (kind=kind_phys), intent(in) :: tg
6312 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: zsnso
6313 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
6314 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: df
6315 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: hcpct
6316
6317!input and output
6318
6319 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
6320#ifdef CCPP
6321 character(len=*) , intent(inout) :: errmsg
6322 integer , intent(inout) :: errflg
6323#endif
6324
6325!local
6326
6327 integer :: iz
6328 real (kind=kind_phys) :: zbotsno !zbot from snow surface
6329 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: ai, bi, ci, rhsts
6330 real (kind=kind_phys) :: eflxb !energy influx from soil bottom (w/m2)
6331 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: phi !light through water (w/m2)
6332
6333 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: tbeg
6334 real (kind=kind_phys) :: err_est !heat storage error (w/m2)
6335 real (kind=kind_phys) :: ssoil2 !ground heat flux (w/m2) (for energy check)
6336 real (kind=kind_phys) :: eflxb2 !heat flux from the bottom (w/m2) (for energy check)
6337 character(len=256) :: message
6338! ----------------------------------------------------------------------
6339! compute solar penetration through water, needs more work
6340
6341 phi(isnow+1:nsoil) = 0.
6342
6343! adjust zbot from soil surface to zbotsno from snow surface
6344
6345 zbotsno = parameters%zbot - snowh !from snow surface
6346
6347! snow/soil heat storage for energy balance check
6348
6349 do iz = isnow+1, nsoil
6350 tbeg(iz) = stc(iz)
6351 enddo
6352
6353! compute soil temperatures
6354
6355 call hrt (parameters,nsnow ,nsoil ,isnow ,zsnso , &
6356 stc ,tbot ,zbotsno ,dt , &
6357 df ,hcpct ,ssoil ,phi , &
6358 ai ,bi ,ci ,rhsts , &
6359 eflxb )
6360
6361 call hstep (parameters,nsnow ,nsoil ,isnow ,dt , &
6362 ai ,bi ,ci ,rhsts , &
6363 stc )
6364
6365! update ground heat flux just for energy check, but not for final output
6366! otherwise, it would break the surface energy balance
6367
6368 if(opt_tbot == 1) then
6369 eflxb2 = 0.
6370 else if(opt_tbot == 2) then
6371 eflxb2 = df(nsoil)*(tbot-stc(nsoil)) / &
6372 (0.5*(zsnso(nsoil-1)+zsnso(nsoil)) - zbotsno)
6373 end if
6374
6375 ! skip the energy balance check for now, until we can make it work
6376 ! right for small time steps.
6377 return
6378
6379! energy balance check
6380
6381 err_est = 0.0
6382 do iz = isnow+1, nsoil
6383 err_est = err_est + (stc(iz)-tbeg(iz)) * dzsnso(iz) * hcpct(iz) / dt
6384 enddo
6385
6386 if (opt_stc == 1 .or. opt_stc == 3) then ! semi-implicit
6387 err_est = err_est - (ssoil +eflxb)
6388 else ! full-implicit
6389 ssoil2 = df(isnow+1)*(tg-stc(isnow+1))/(0.5*dzsnso(isnow+1)) !m. barlage
6390 err_est = err_est - (ssoil2+eflxb2)
6391 endif
6392
6393 if (abs(err_est) > 1.) then ! w/m2
6394 write(message,*) 'tsnosoi is losing(-)/gaining(+) false energy',err_est,' w/m2'
6395#ifdef CCPP
6396 errmsg = trim(message)
6397#else
6398 call wrf_message(trim(message))
6399#endif
6400 write(message,'(i6,1x,i6,1x,i3,f18.13,5f20.12)') &
6401 iloc, jloc, ist,err_est,ssoil,snowh,tg,stc(isnow+1),eflxb
6402#ifdef CCPP
6403 errmsg = trim(errmsg)//new_line('A')//trim(message)
6404#else
6405 call wrf_message(trim(message))
6406#endif
6407 !niu stop
6408 end if
6409
6410 end subroutine tsnosoi
6411
6412!== begin hrt ======================================================================================
6413
6418 subroutine hrt (parameters,nsnow ,nsoil ,isnow ,zsnso , &
6419 stc ,tbot ,zbot ,dt , &
6420 df ,hcpct ,ssoil ,phi , &
6421 ai ,bi ,ci ,rhsts , &
6422 botflx )
6423! ----------------------------------------------------------------------
6424! ----------------------------------------------------------------------
6425! calculate the right hand side of the time tendency term of the soil
6426! thermal diffusion equation. also to compute ( prepare ) the matrix
6427! coefficients for the tri-diagonal matrix of the implicit time scheme.
6428! ----------------------------------------------------------------------
6429 implicit none
6430! ----------------------------------------------------------------------
6431! input
6432
6433 type (noahmp_parameters), intent(in) :: parameters
6434 integer, intent(in) :: nsoil
6435 integer, intent(in) :: nsnow
6436 integer, intent(in) :: isnow !, actual no of snow layers
6437 real (kind=kind_phys), intent(in) :: tbot
6438 real (kind=kind_phys), intent(in) :: zbot
6440 real (kind=kind_phys), intent(in) :: dt
6441 real (kind=kind_phys), intent(in) :: ssoil
6442 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: zsnso
6443 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc
6444 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: df
6445 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: hcpct
6446 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: phi
6447
6448! output
6449
6450 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: rhsts
6451 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: ai
6452 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: bi
6453 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(out) :: ci
6454 real (kind=kind_phys), intent(out) :: botflx
6455
6456! local
6457
6458 integer :: k
6459 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: ddz
6460 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: dz
6461 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: denom
6462 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: dtsdz
6463 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: eflux
6464 real (kind=kind_phys) :: temp1
6465! ----------------------------------------------------------------------
6466
6467 do k = isnow+1, nsoil
6468 if (k == isnow+1) then
6469 denom(k) = - zsnso(k) * hcpct(k)
6470 temp1 = - zsnso(k+1)
6471 ddz(k) = 2.0 / temp1
6472 dtsdz(k) = 2.0 * (stc(k) - stc(k+1)) / temp1
6473 eflux(k) = df(k) * dtsdz(k) - ssoil - phi(k)
6474 else if (k < nsoil) then
6475 denom(k) = (zsnso(k-1) - zsnso(k)) * hcpct(k)
6476 temp1 = zsnso(k-1) - zsnso(k+1)
6477 ddz(k) = 2.0 / temp1
6478 dtsdz(k) = 2.0 * (stc(k) - stc(k+1)) / temp1
6479 eflux(k) = (df(k)*dtsdz(k) - df(k-1)*dtsdz(k-1)) - phi(k)
6480 else if (k == nsoil) then
6481 denom(k) = (zsnso(k-1) - zsnso(k)) * hcpct(k)
6482 temp1 = zsnso(k-1) - zsnso(k)
6483 if(opt_tbot == 1) then
6484 botflx = 0.
6485 end if
6486 if(opt_tbot == 2) then
6487 dtsdz(k) = (stc(k) - tbot) / ( 0.5*(zsnso(k-1)+zsnso(k)) - zbot)
6488 botflx = -df(k) * dtsdz(k)
6489 end if
6490 eflux(k) = (-botflx - df(k-1)*dtsdz(k-1) ) - phi(k)
6491 end if
6492 end do
6493
6494 do k = isnow+1, nsoil
6495 if (k == isnow+1) then
6496 ai(k) = 0.0
6497 ci(k) = - df(k) * ddz(k) / denom(k)
6498 if (opt_stc == 1 .or. opt_stc == 3 ) then
6499 bi(k) = - ci(k)
6500 end if
6501 if (opt_stc == 2) then
6502 bi(k) = - ci(k) + df(k)/(0.5*zsnso(k)*zsnso(k)*hcpct(k))
6503 end if
6504 else if (k < nsoil) then
6505 ai(k) = - df(k-1) * ddz(k-1) / denom(k)
6506 ci(k) = - df(k ) * ddz(k ) / denom(k)
6507 bi(k) = - (ai(k) + ci(k))
6508 else if (k == nsoil) then
6509 ai(k) = - df(k-1) * ddz(k-1) / denom(k)
6510 ci(k) = 0.0
6511 bi(k) = - (ai(k) + ci(k))
6512 end if
6513 rhsts(k) = eflux(k)/ (-denom(k))
6514 end do
6515
6516 end subroutine hrt
6517
6518!== begin hstep ====================================================================================
6519
6522 subroutine hstep (parameters,nsnow ,nsoil ,isnow ,dt , &
6523 ai ,bi ,ci ,rhsts , &
6524 stc )
6525! ----------------------------------------------------------------------
6526! calculate/update the soil temperature field.
6527! ----------------------------------------------------------------------
6528 implicit none
6529! ----------------------------------------------------------------------
6530! input
6531
6532 type (noahmp_parameters), intent(in) :: parameters
6533 integer, intent(in) :: nsoil
6534 integer, intent(in) :: nsnow
6535 integer, intent(in) :: isnow
6536 real (kind=kind_phys), intent(in) :: dt
6537
6538! output & input
6539 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: rhsts
6540 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: ai
6541 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: bi
6542 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: ci
6543 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
6544
6545! local
6546 integer :: k
6547 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: rhstsin
6548 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: ciin
6549! ----------------------------------------------------------------------
6550
6551 do k = isnow+1,nsoil
6552 rhsts(k) = rhsts(k) * dt
6553 ai(k) = ai(k) * dt
6554 bi(k) = 1. + bi(k) * dt
6555 ci(k) = ci(k) * dt
6556 end do
6557
6558! copy values for input variables before call to rosr12
6559
6560 do k = isnow+1,nsoil
6561 rhstsin(k) = rhsts(k)
6562 ciin(k) = ci(k)
6563 end do
6564
6565! solve the tri-diagonal matrix equation
6566
6567 call rosr12 (ci,ai,bi,ciin,rhstsin,rhsts,isnow+1,nsoil,nsnow)
6568
6569! update snow & soil temperature
6570
6571 do k = isnow+1,nsoil
6572 stc(k) = stc(k) + ci(k)
6573 end do
6574
6575 end subroutine hstep
6576
6577!== begin rosr12 ===================================================================================
6578
6581 subroutine rosr12 (p,a,b,c,d,delta,ntop,nsoil,nsnow)
6582! ----------------------------------------------------------------------
6583! subroutine rosr12
6584! ----------------------------------------------------------------------
6585! invert (solve) the tri-diagonal matrix problem shown below:
6586! ### ### ### ### ### ###
6587! #b(1), c(1), 0 , 0 , 0 , . . . , 0 # # # # #
6588! #a(2), b(2), c(2), 0 , 0 , . . . , 0 # # # # #
6589! # 0 , a(3), b(3), c(3), 0 , . . . , 0 # # # # d(3) #
6590! # 0 , 0 , a(4), b(4), c(4), . . . , 0 # # p(4) # # d(4) #
6591! # 0 , 0 , 0 , a(5), b(5), . . . , 0 # # p(5) # # d(5) #
6592! # . . # # . # = # . #
6593! # . . # # . # # . #
6594! # . . # # . # # . #
6595! # 0 , . . . , 0 , a(m-2), b(m-2), c(m-2), 0 # #p(m-2)# #d(m-2)#
6596! # 0 , . . . , 0 , 0 , a(m-1), b(m-1), c(m-1)# #p(m-1)# #d(m-1)#
6597! # 0 , . . . , 0 , 0 , 0 , a(m) , b(m) # # p(m) # # d(m) #
6598! ### ### ### ### ### ###
6599! ----------------------------------------------------------------------
6600 implicit none
6601
6602 integer, intent(in) :: ntop
6603 integer, intent(in) :: nsoil,nsnow
6604 integer :: k, kk
6605
6606 real (kind=kind_phys), dimension(-nsnow+1:nsoil),intent(in):: a, b, d
6607 real (kind=kind_phys), dimension(-nsnow+1:nsoil),intent(inout):: c,p,delta
6608
6609! ----------------------------------------------------------------------
6610! initialize eqn coef c for the lowest soil layer
6611! ----------------------------------------------------------------------
6612 c(nsoil) = 0.0
6613 p(ntop) = - c(ntop) / b(ntop)
6614! ----------------------------------------------------------------------
6615! solve the coefs for the 1st soil layer
6616! ----------------------------------------------------------------------
6617 delta(ntop) = d(ntop) / b(ntop)
6618! ----------------------------------------------------------------------
6619! solve the coefs for soil layers 2 thru nsoil
6620! ----------------------------------------------------------------------
6621 do k = ntop+1,nsoil
6622 p(k) = - c(k) * ( 1.0 / (b(k) + a(k) * p(k -1)) )
6623 delta(k) = (d(k) - a(k)* delta(k -1))* (1.0/ (b(k) + a(k)&
6624 * p(k -1)))
6625 end do
6626! ----------------------------------------------------------------------
6627! set p to delta for lowest soil layer
6628! ----------------------------------------------------------------------
6629 p(nsoil) = delta(nsoil)
6630! ----------------------------------------------------------------------
6631! adjust p for soil layers 2 thru nsoil
6632! ----------------------------------------------------------------------
6633 do k = ntop+1,nsoil
6634 kk = nsoil - k + (ntop-1) + 1
6635 p(kk) = p(kk) * p(kk +1) + delta(kk)
6636 end do
6637! ----------------------------------------------------------------------
6638 end subroutine rosr12
6639
6640!== begin phasechange ==============================================================================
6641
6644 subroutine phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , & !in
6645 dzsnso ,hcpct ,ist ,iloc ,jloc , & !in
6646 stc ,snice ,snliq ,sneqv ,snowh , & !inout
6647#ifdef CCPP
6648 smc ,sh2o ,errmsg ,errflg , & !inout
6649#else
6650 smc ,sh2o , & !inout
6651#endif
6652 qmelt ,imelt ,ponding ) !out
6653! ----------------------------------------------------------------------
6654! melting/freezing of snow water and soil water
6655! ----------------------------------------------------------------------
6656 implicit none
6657! ----------------------------------------------------------------------
6658! inputs
6659
6660 type (noahmp_parameters), intent(in) :: parameters
6661 integer, intent(in) :: iloc
6662 integer, intent(in) :: jloc
6663 integer, intent(in) :: nsnow
6664 integer, intent(in) :: nsoil
6665 integer, intent(in) :: isnow
6666 integer, intent(in) :: ist
6667 real (kind=kind_phys), intent(in) :: dt
6668 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: fact
6669 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
6670 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: hcpct
6671
6672! outputs
6673 integer, dimension(-nsnow+1:nsoil), intent(out) :: imelt !phase change index
6674 real (kind=kind_phys), intent(out) :: qmelt
6675 real (kind=kind_phys), intent(out) :: ponding
6676
6677! inputs and outputs
6678
6679 real (kind=kind_phys), intent(inout) :: sneqv
6680 real (kind=kind_phys), intent(inout) :: snowh
6681 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
6682 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sh2o
6683 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: smc
6684 real (kind=kind_phys), dimension(-nsnow+1:0) , intent(inout) :: snice
6685 real (kind=kind_phys), dimension(-nsnow+1:0) , intent(inout) :: snliq
6686#ifdef CCPP
6687 character(len=*) , intent(inout) :: errmsg
6688 integer , intent(inout) :: errflg
6689#endif
6690
6691! local
6692
6693 integer :: j !do loop index
6694 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: hm !energy residual [w/m2]
6695 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: xm !melting or freezing water [kg/m2]
6696 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: wmass0
6697 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: wice0
6698 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: wliq0
6699 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: mice !soil/snow ice mass [mm]
6700 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: mliq !soil/snow liquid water mass [mm]
6701 real (kind=kind_phys), dimension(-nsnow+1:nsoil) :: supercool !supercooled water in soil (kg/m2)
6702 real (kind=kind_phys) :: heatr !energy residual or loss after melting/freezing
6703 real (kind=kind_phys) :: temp1 !temporary variables [kg/m2]
6704 real (kind=kind_phys) :: propor
6705 real (kind=kind_phys) :: smp !frozen water potential (mm)
6706 real (kind=kind_phys) :: xmf !total latent heat of phase change
6707
6708! ----------------------------------------------------------------------
6709! initialization
6710
6711 qmelt = 0.
6712 ponding = 0.
6713 xmf = 0.
6714
6715 do j = -nsnow+1, nsoil
6716 supercool(j) = 0.0
6717 end do
6718
6719 do j = isnow+1,0 ! all layers
6720 mice(j) = snice(j)
6721 mliq(j) = snliq(j)
6722 end do
6723
6724 do j = 1, nsoil ! soil
6725 mliq(j) = sh2o(j) * dzsnso(j) * 1000.
6726 mice(j) = (smc(j) - sh2o(j)) * dzsnso(j) * 1000.
6727 end do
6728
6729 do j = isnow+1,nsoil ! all layers
6730 imelt(j) = 0
6731 hm(j) = 0.
6732 xm(j) = 0.
6733 wice0(j) = mice(j)
6734 wliq0(j) = mliq(j)
6735 wmass0(j) = mice(j) + mliq(j)
6736 enddo
6737
6738 if(ist == 1) then
6739 do j = 1,nsoil
6740 if (opt_frz == 1) then
6741 if(stc(j) < tfrz) then
6742 smp = hfus*(tfrz-stc(j))/(grav*stc(j)) !(m)
6743 supercool(j) = parameters%smcmax(j)*(smp/parameters%psisat(j))**(-1./parameters%bexp(j))
6744 supercool(j) = supercool(j)*dzsnso(j)*1000. !(mm)
6745 end if
6746 end if
6747 if (opt_frz == 2) then
6748#ifdef CCPP
6749 call frh2o (parameters,j,supercool(j),stc(j),smc(j),sh2o(j),errmsg,errflg)
6750 if (errflg /=0) return
6751#else
6752 call frh2o (parameters,j,supercool(j),stc(j),smc(j),sh2o(j))
6753#endif
6754 supercool(j) = supercool(j)*dzsnso(j)*1000. !(mm)
6755 end if
6756 enddo
6757 end if
6758
6759 do j = isnow+1,nsoil
6760 if (mice(j) > 0. .and. stc(j) >= tfrz) then !melting
6761 imelt(j) = 1
6762 endif
6763 if (mliq(j) > supercool(j) .and. stc(j) < tfrz) then
6764 imelt(j) = 2
6765 endif
6766
6767 ! if snow exists, but its thickness is not enough to create a layer
6768 if (isnow == 0 .and. sneqv > 0. .and. j == 1) then
6769 if (stc(j) >= tfrz) then
6770 imelt(j) = 1
6771 endif
6772 endif
6773 enddo
6774
6775! calculate the energy surplus and loss for melting and freezing
6776
6777 do j = isnow+1,nsoil
6778 if (imelt(j) > 0) then
6779 hm(j) = (stc(j)-tfrz)/fact(j)
6780 stc(j) = tfrz
6781 endif
6782
6783 if (imelt(j) == 1 .and. hm(j) < 0.) then
6784 hm(j) = 0.
6785 imelt(j) = 0
6786 endif
6787 if (imelt(j) == 2 .and. hm(j) > 0.) then
6788 hm(j) = 0.
6789 imelt(j) = 0
6790 endif
6791 xm(j) = hm(j)*dt/hfus
6792 enddo
6793
6794! the rate of melting and freezing for snow without a layer, needs more work.
6795
6796 if (isnow == 0 .and. sneqv > 0. .and. xm(1) > 0.) then
6797 temp1 = sneqv
6798 sneqv = max(0.,temp1-xm(1))
6799 propor = sneqv/temp1
6800 snowh = max(0.,propor * snowh)
6801 snowh = min(max(snowh,sneqv/500.0),sneqv/50.0) ! limit adjustment to a reasonable density
6802 heatr = hm(1) - hfus*(temp1-sneqv)/dt
6803 if (heatr > 0.) then
6804 xm(1) = heatr*dt/hfus
6805 hm(1) = heatr
6806 else
6807 xm(1) = 0.
6808 hm(1) = 0.
6809 endif
6810 qmelt = max(0.,(temp1-sneqv))/dt
6811 xmf = hfus*qmelt
6812 ponding = temp1-sneqv
6813 endif
6814
6815! the rate of melting and freezing for snow and soil
6816
6817 do j = isnow+1,nsoil
6818 if (imelt(j) > 0 .and. abs(hm(j)) > 0.) then
6819
6820 heatr = 0.
6821 if (xm(j) > 0.) then
6822 mice(j) = max(0., wice0(j)-xm(j))
6823 heatr = hm(j) - hfus*(wice0(j)-mice(j))/dt
6824 else if (xm(j) < 0.) then
6825 if (j <= 0) then ! snow
6826 mice(j) = min(wmass0(j), wice0(j)-xm(j))
6827 else ! soil
6828 if (wmass0(j) < supercool(j)) then
6829 mice(j) = 0.
6830 else
6831 mice(j) = min(wmass0(j) - supercool(j),wice0(j)-xm(j))
6832 mice(j) = max(mice(j),0.0)
6833 endif
6834 endif
6835 heatr = hm(j) - hfus*(wice0(j)-mice(j))/dt
6836 endif
6837
6838 mliq(j) = max(0.,wmass0(j)-mice(j))
6839
6840 if (abs(heatr) > 0.) then
6841 stc(j) = stc(j) + fact(j)*heatr
6842 if (j <= 0) then ! snow
6843 if (mliq(j)*mice(j)>0.) stc(j) = tfrz
6844 if (mice(j) == 0.) then ! barlage
6845 stc(j) = tfrz ! barlage
6846 hm(j+1) = hm(j+1) + heatr ! barlage
6847 xm(j+1) = hm(j+1)*dt/hfus ! barlage
6848 endif
6849 end if
6850 endif
6851
6852 xmf = xmf + hfus * (wice0(j)-mice(j))/dt
6853
6854 if (j < 1) then
6855 qmelt = qmelt + max(0.,(wice0(j)-mice(j)))/dt
6856 endif
6857 endif
6858 enddo
6859
6860 do j = isnow+1,0 ! snow
6861 snliq(j) = mliq(j)
6862 snice(j) = mice(j)
6863 end do
6864
6865 do j = 1, nsoil ! soil
6866 sh2o(j) = mliq(j) / (1000. * dzsnso(j))
6867 smc(j) = (mliq(j) + mice(j)) / (1000. * dzsnso(j))
6868 end do
6869
6870 end subroutine phasechange
6871
6872!== begin frh2o ====================================================================================
6873
6879 subroutine frh2o (parameters,isoil,free,tkelv,smc,sh2o,&
6880#ifdef CCPP
6881 errmsg,errflg)
6882#else
6883 )
6884#endif
6885
6886! ----------------------------------------------------------------------
6887! subroutine frh2o
6888! ----------------------------------------------------------------------
6889! calculate amount of supercooled liquid soil water content if
6890! temperature is below 273.15k (tfrz). requires newton-type iteration
6891! to solve the nonlinear implicit equation given in eqn 17 of koren et al
6892! (1999, jgr, vol 104(d16), 19569-19585).
6893! ----------------------------------------------------------------------
6894! new version (june 2001): much faster and more accurate newton
6895! iteration achieved by first taking log of eqn cited above -- less than
6896! 4 (typically 1 or 2) iterations achieves convergence. also, explicit
6897! 1-step solution option for special case of parameter ck=0, which
6898! reduces the original implicit equation to a simpler explicit form,
6899! known as the "flerchinger eqn". improved handling of solution in the
6900! limit of freezing point temperature tfrz.
6901! ----------------------------------------------------------------------
6902! input:
6903
6904! tkelv.........temperature (kelvin)
6905! smc...........total soil moisture content (volumetric)
6906! sh2o..........liquid soil moisture content (volumetric)
6907! b.............soil type "b" parameter (from redprm)
6908! psisat........saturated soil matric potential (from redprm)
6909
6910! output:
6911! free..........supercooled liquid water content [m3/m3]
6912! ----------------------------------------------------------------------
6913 implicit none
6914 type (noahmp_parameters), intent(in) :: parameters
6915 integer,intent(in) :: isoil
6916 real (kind=kind_phys), intent(in) :: sh2o,smc,tkelv
6917 real (kind=kind_phys), intent(out) :: free
6918#ifdef CCPP
6919 character(len=*), intent(inout) :: errmsg
6920 integer, intent(inout) :: errflg
6921#endif
6922 real (kind=kind_phys) :: bx,denom,df,dswl,fk,swl,swlk
6923 integer :: nlog,kcount
6924! parameter(ck = 0.0)
6925 real (kind=kind_phys), parameter :: ck = 8.0, blim = 5.5, error = 0.005, &
6926 dice = 920.0
6927 character(len=80) :: message
6928
6929! ----------------------------------------------------------------------
6930! limits on parameter b: b < 5.5 (use parameter blim)
6931! simulations showed if b > 5.5 unfrozen water content is
6932! non-realistically high at very low temperatures.
6933! ----------------------------------------------------------------------
6934 bx = parameters%bexp(isoil)
6935! ----------------------------------------------------------------------
6936! initializing iterations counter and iterative solution flag.
6937! ----------------------------------------------------------------------
6938
6939 if (parameters%bexp(isoil) > blim) bx = blim
6940 nlog = 0
6941
6942! ----------------------------------------------------------------------
6943! if temperature not significantly below freezing (tfrz), sh2o = smc
6944! ----------------------------------------------------------------------
6945 kcount = 0
6946 if (tkelv > (tfrz- 1.e-3)) then
6947 free = smc
6948 else
6949
6950! ----------------------------------------------------------------------
6951! option 1: iterated solution in koren et al, jgr, 1999, eqn 17
6952! ----------------------------------------------------------------------
6953! initial guess for swl (frozen content)
6954! ----------------------------------------------------------------------
6955 if (ck /= 0.0) then
6956 swl = smc - sh2o
6957! ----------------------------------------------------------------------
6958! keep within bounds.
6959! ----------------------------------------------------------------------
6960 if (swl > (smc -0.02)) swl = smc -0.02
6961! ----------------------------------------------------------------------
6962! start of iterations
6963! ----------------------------------------------------------------------
6964 if (swl < 0.) swl = 0.
69651001 continue
6966 if (.not.( (nlog < 10) .and. (kcount == 0))) goto 1002
6967 nlog = nlog +1
6968 df = log( ( parameters%psisat(isoil) * grav / hfus ) * ( ( 1. + ck * swl )**2.) * &
6969 ( parameters%smcmax(isoil) / (smc - swl) )** bx) - log( - ( &
6970 tkelv - tfrz)/ tkelv)
6971 denom = 2. * ck / ( 1. + ck * swl ) + bx / ( smc - swl )
6972 swlk = swl - df / denom
6973! ----------------------------------------------------------------------
6974! bounds useful for mathematical solution.
6975! ----------------------------------------------------------------------
6976 if (swlk > (smc -0.02)) swlk = smc - 0.02
6977 if (swlk < 0.) swlk = 0.
6978
6979! ----------------------------------------------------------------------
6980! mathematical solution bounds applied.
6981! ----------------------------------------------------------------------
6982 dswl = abs(swlk - swl)
6983! if more than 10 iterations, use explicit method (ck=0 approx.)
6984! when dswl less or eq. error, no more iterations required.
6985! ----------------------------------------------------------------------
6986 swl = swlk
6987 if ( dswl <= error ) then
6988 kcount = kcount +1
6989 end if
6990! ----------------------------------------------------------------------
6991! end of iterations
6992! ----------------------------------------------------------------------
6993! bounds applied within do-block are valid for physical solution.
6994! ----------------------------------------------------------------------
6995 goto 1001
69961002 continue
6997 free = smc - swl
6998 end if
6999! ----------------------------------------------------------------------
7000! end option 1
7001! ----------------------------------------------------------------------
7002! ----------------------------------------------------------------------
7003! option 2: explicit solution for flerchinger eq. i.e. ck=0
7004! in koren et al., jgr, 1999, eqn 17
7005! apply physical bounds to flerchinger solution
7006! ----------------------------------------------------------------------
7007 if (kcount == 0) then
7008 write(message, '("flerchinger used in new version. iterations=", i6)') nlog
7009#ifdef CCPP
7010 errmsg = trim(message)
7011#else
7012 call wrf_message(trim(message))
7013#endif
7014 fk = ( ( (hfus / (grav * ( - parameters%psisat(isoil))))* &
7015 ( (tkelv - tfrz)/ tkelv))** ( -1/ bx))* parameters%smcmax(isoil)
7016 if (fk < 0.02) fk = 0.02
7017 free = min(fk, smc)
7018! ----------------------------------------------------------------------
7019! end option 2
7020! ----------------------------------------------------------------------
7021 end if
7022 end if
7023! ----------------------------------------------------------------------
7024 end subroutine frh2o
7025! ----------------------------------------------------------------------
7026! ==================================================================================================
7027! **********************end of energy subroutines***********************
7028! ==================================================================================================
7029
7030!== begin water ====================================================================================
7031
7034 subroutine water (parameters,vegtyp ,nsnow ,nsoil ,imelt ,dt ,uu , & !in
7035 vv ,fcev ,fctr ,qprecc ,qprecl ,elai , & !in
7036 esai ,sfctmp ,qvap ,qdew ,zsoil ,btrani , & !in
7037 ficeold,ponding,tg ,ist ,fveg ,iloc ,jloc ,smceq , & !in
7038 bdfall ,fp ,rain ,snow, & !in mb/an: v3.7
7039 qsnow ,qrain ,snowhin,latheav,latheag,frozen_canopy,frozen_ground, & !in mb
7040 isnow ,canliq ,canice ,tv ,snowh ,sneqv , & !inout
7041 snice ,snliq ,stc ,zsnso ,sh2o ,smc , & !inout
7042 sice ,zwt ,wa ,wt ,dzsnso ,wslake , & !inout
7043 smcwtd ,deeprech,rech , & !inout
7044 cmc ,ecan ,etran ,fwet ,runsrf ,runsub , & !out
7045 qin ,qdis ,ponding1 ,ponding2, &
7046 qsnbot ,esnow)
7047! ----------------------------------------------------------------------
7048! code history:
7049! initial code: guo-yue niu, oct. 2007
7050! ----------------------------------------------------------------------
7051 implicit none
7052! ----------------------------------------------------------------------
7053! input
7054 type (noahmp_parameters), intent(in) :: parameters
7055 integer, intent(in) :: iloc
7056 integer, intent(in) :: jloc
7057 integer, intent(in) :: vegtyp
7058 integer, intent(in) :: nsnow
7059 integer , intent(in) :: ist
7060 integer, intent(in) :: nsoil
7061 integer, dimension(-nsnow+1:0) , intent(in) :: imelt
7062 real (kind=kind_phys), intent(in) :: dt
7063 real (kind=kind_phys), intent(in) :: uu
7064 real (kind=kind_phys), intent(in) :: vv
7065 real (kind=kind_phys), intent(in) :: fcev
7066 real (kind=kind_phys), intent(in) :: fctr
7067 real (kind=kind_phys), intent(in) :: qprecc
7068 real (kind=kind_phys), intent(in) :: qprecl
7069 real (kind=kind_phys), intent(in) :: elai
7070 real (kind=kind_phys), intent(in) :: esai
7071 real (kind=kind_phys), intent(in) :: sfctmp
7072 real (kind=kind_phys), intent(in) :: qvap
7073 real (kind=kind_phys), intent(in) :: qdew
7074 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil
7075 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: btrani
7076 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: ficeold
7077! real (kind=kind_phys) , intent(in) :: ponding !< [mm]
7078 real (kind=kind_phys) , intent(in) :: tg
7079 real (kind=kind_phys) , intent(in) :: fveg
7080 real (kind=kind_phys) , intent(in) :: bdfall
7081 real (kind=kind_phys) , intent(in) :: fp
7082 real (kind=kind_phys) , intent(in) :: rain
7083 real (kind=kind_phys) , intent(in) :: snow
7084 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smceq
7085 real (kind=kind_phys) , intent(in) :: qsnow
7086 real (kind=kind_phys) , intent(in) :: qrain
7087 real (kind=kind_phys) , intent(in) :: snowhin
7088
7089! input/output
7090 integer, intent(inout) :: isnow
7091 real (kind=kind_phys), intent(inout) :: canliq
7092 real (kind=kind_phys), intent(inout) :: canice
7093 real (kind=kind_phys), intent(inout) :: tv
7094 real (kind=kind_phys), intent(inout) :: snowh
7095 real (kind=kind_phys), intent(inout) :: sneqv
7096 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snice
7097 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snliq
7098 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
7099 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: zsnso
7100 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
7101 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sh2o
7102 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sice
7103 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: smc
7104 real (kind=kind_phys), intent(inout) :: zwt
7105 real (kind=kind_phys), intent(inout) :: wa
7106 real (kind=kind_phys), intent(inout) :: wt
7108 real (kind=kind_phys), intent(inout) :: wslake
7109 real (kind=kind_phys) , intent(inout) :: ponding
7110 real (kind=kind_phys), intent(inout) :: smcwtd
7111 real (kind=kind_phys), intent(inout) :: deeprech
7112 real (kind=kind_phys), intent(inout) :: rech
7113
7114! output
7115 real (kind=kind_phys), intent(out) :: cmc
7116 real (kind=kind_phys), intent(out) :: ecan
7117 real (kind=kind_phys), intent(out) :: etran
7118 real (kind=kind_phys), intent(out) :: fwet
7119 real (kind=kind_phys), intent(out) :: runsrf
7120 real (kind=kind_phys), intent(out) :: runsub
7121 real (kind=kind_phys), intent(out) :: qin
7122 real (kind=kind_phys), intent(out) :: qdis
7123 real (kind=kind_phys), intent(out) :: ponding1
7124 real (kind=kind_phys), intent(out) :: ponding2
7125 real (kind=kind_phys), intent(out) :: esnow
7126 real (kind=kind_phys), intent(out) :: qsnbot
7127 real (kind=kind_phys) , intent(in) :: latheav
7128 real (kind=kind_phys) , intent(in) :: latheag
7129 logical , intent(in) :: frozen_ground
7130 logical , intent(in) :: frozen_canopy
7131
7132
7133! local
7134 integer :: iz
7135 real (kind=kind_phys) :: qinsur !water input on soil surface [m/s]
7136 real (kind=kind_phys) :: qseva !soil surface evap rate [mm/s]
7137 real (kind=kind_phys) :: qsdew !soil surface dew rate [mm/s]
7138 real (kind=kind_phys) :: qsnfro !snow surface frost rate[mm/s]
7139 real (kind=kind_phys) :: qsnsub !snow surface sublimation rate [mm/s]
7140 real (kind=kind_phys), dimension( 1:nsoil) :: etrani !transpiration rate (mm/s) [+]
7141 real (kind=kind_phys), dimension( 1:nsoil) :: wcnd !hydraulic conductivity (m/s)
7142 real (kind=kind_phys) :: qdrain !soil-bottom free drainage [mm/s]
7143 real (kind=kind_phys) :: snoflow !glacier flow [mm/s]
7144 real (kind=kind_phys) :: fcrmax !maximum of fcr (-)
7145
7146 real (kind=kind_phys), parameter :: wslmax = 5000. !maximum lake water storage (mm)
7147
7148
7149! ----------------------------------------------------------------------
7150! initialize
7151
7152 etrani(1:nsoil) = 0.
7153 snoflow = 0.
7154 runsub = 0.
7155 qinsur = 0.
7156
7157! canopy-intercepted snowfall/rainfall, drips, and throughfall
7158
7159 call canwater (parameters,vegtyp ,dt , & !in
7160 fcev ,fctr ,elai , & !in
7161 esai ,tg ,fveg ,iloc , jloc, & !in
7162 bdfall ,frozen_canopy , & !in
7163 canliq ,canice ,tv , & !inout
7164 cmc ,ecan ,etran , & !out
7165 fwet ) !out
7166
7167! sublimation, frost, evaporation, and dew
7168
7169 qsnsub = 0.
7170 if (sneqv > 0.) then
7171 qsnsub = min(qvap, sneqv/dt)
7172 endif
7173 qseva = qvap-qsnsub
7174 esnow = qsnsub*hsub
7175
7176 qsnfro = 0.
7177 if (sneqv > 0.) then
7178 qsnfro = qdew
7179 endif
7180 qsdew = qdew - qsnfro
7181
7182 call snowwater (parameters,nsnow ,nsoil ,imelt ,dt ,zsoil , & !in
7183 & sfctmp ,snowhin,qsnow ,qsnfro ,qsnsub , & !in
7184 & qrain ,ficeold,iloc ,jloc , & !in
7185 & isnow ,snowh ,sneqv ,snice ,snliq , & !inout
7186 & sh2o ,sice ,stc ,zsnso ,dzsnso , & !inout
7187 & qsnbot ,snoflow,ponding1 ,ponding2) !out
7188
7189 if(frozen_ground) then
7190 sice(1) = sice(1) + (qsdew-qseva)*dt/(dzsnso(1)*1000.)
7191 qsdew = 0.0
7192 qseva = 0.0
7193 if(sice(1) < 0.) then
7194 sh2o(1) = sh2o(1) + sice(1)
7195 sice(1) = 0.
7196 end if
7197 end if
7198
7199! convert units (mm/s -> m/s)
7200
7201 !ponding: melting water from snow when there is no layer
7202 qinsur = (ponding+ponding1+ponding2)/dt * 0.001
7203! qinsur = ponding/dt * 0.001
7204
7205 if(isnow == 0) then
7206 qinsur = qinsur+(qsnbot + qsdew + qrain) * 0.001
7207 else
7208 qinsur = qinsur+(qsnbot + qsdew) * 0.001
7209 endif
7210
7211 qseva = qseva * 0.001
7212
7213 do iz = 1, parameters%nroot
7214 etrani(iz) = etran * btrani(iz) * 0.001
7215 enddo
7216
7217
7218! lake/soil water balances
7219
7220 if (ist == 2) then ! lake
7221 runsrf = 0.
7222 if(wslake >= wslmax) runsrf = qinsur*1000. !mm/s
7223 wslake = wslake + (qinsur-qseva)*1000.*dt -runsrf*dt !mm
7224 else ! soil
7225 call soilwater (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in
7226 qinsur ,qseva ,etrani ,sice ,iloc , jloc , & !in
7227 sh2o ,smc ,zwt ,vegtyp , & !inout
7228 smcwtd, deeprech , & !inout
7229 runsrf ,qdrain ,runsub ,wcnd ,fcrmax ) !out
7230
7231 if(opt_run == 1) then
7232 call groundwater (parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in
7233 stc ,wcnd ,fcrmax ,iloc ,jloc , & !in
7234 sh2o ,zwt ,wa ,wt , & !inout
7235 qin ,qdis ) !out
7236 runsub = qdis !mm/s
7237 end if
7238
7239 if(opt_run == 3 .or. opt_run == 4) then
7240 runsub = runsub + qdrain !mm/s
7241 end if
7242
7243 do iz = 1,nsoil
7244 smc(iz) = sh2o(iz) + sice(iz)
7245 enddo
7246
7247 if(opt_run == 5) then
7248 call shallowwatertable (parameters,nsnow ,nsoil, zsoil, dt , & !in
7249 dzsnso ,smceq ,iloc , jloc , & !in
7250 smc ,zwt ,smcwtd ,rech, qdrain ) !inout
7251
7252 sh2o(nsoil) = smc(nsoil) - sice(nsoil)
7253 runsub = runsub + qdrain !it really comes from subroutine watertable, which is not called with the same frequency as the soil routines here
7254 wa = 0.
7255 endif
7256
7257 endif
7258
7259 runsub = runsub + snoflow !mm/s
7260
7261 end subroutine water
7262
7263!== begin canwater =================================================================================
7264
7267 subroutine canwater (parameters,vegtyp ,dt , & !in
7268 fcev ,fctr ,elai , & !in
7269 esai ,tg ,fveg ,iloc , jloc , & !in
7270 bdfall ,frozen_canopy , & !in
7271 canliq ,canice ,tv , & !inout
7272 cmc ,ecan ,etran , & !out
7273 fwet ) !out
7274
7275! ------------------------ code history ------------------------------
7276! canopy hydrology
7277! --------------------------------------------------------------------
7278 implicit none
7279! ------------------------ input/output variables --------------------
7280! input
7281 type (noahmp_parameters), intent(in) :: parameters
7282 integer,intent(in) :: iloc
7283 integer,intent(in) :: jloc
7284 integer,intent(in) :: vegtyp
7285 real (kind=kind_phys), intent(in) :: dt
7286 real (kind=kind_phys), intent(in) :: fcev
7287 real (kind=kind_phys), intent(in) :: fctr
7288 real (kind=kind_phys), intent(in) :: elai
7289 real (kind=kind_phys), intent(in) :: esai
7290 real (kind=kind_phys), intent(in) :: tg
7291 real (kind=kind_phys), intent(in) :: fveg
7292 logical , intent(in) :: frozen_canopy
7293 real (kind=kind_phys), intent(in) :: bdfall
7294
7295! input & output
7296 real (kind=kind_phys), intent(inout) :: canliq
7297 real (kind=kind_phys), intent(inout) :: canice
7298 real (kind=kind_phys), intent(inout) :: tv
7299
7300! output
7301 real (kind=kind_phys), intent(out) :: cmc
7302 real (kind=kind_phys), intent(out) :: ecan
7303 real (kind=kind_phys), intent(out) :: etran
7304 real (kind=kind_phys), intent(out) :: fwet
7305! --------------------------------------------------------------------
7306
7307! ------------------------ local variables ---------------------------
7308 real (kind=kind_phys) :: maxsno !canopy capacity for snow interception (mm)
7309 real (kind=kind_phys) :: maxliq !canopy capacity for rain interception (mm)
7310 real (kind=kind_phys) :: qevac !evaporation rate (mm/s)
7311 real (kind=kind_phys) :: qdewc !dew rate (mm/s)
7312 real (kind=kind_phys) :: qfroc !frost rate (mm/s)
7313 real (kind=kind_phys) :: qsubc !sublimation rate (mm/s)
7314 real (kind=kind_phys) :: qmeltc !melting rate of canopy snow (mm/s)
7315 real (kind=kind_phys) :: qfrzc !refreezing rate of canopy liquid water (mm/s)
7316 real (kind=kind_phys) :: canmas !total canopy mass (kg/m2)
7317! --------------------------------------------------------------------
7318! initialization
7319
7320 ecan = 0.0
7321
7322! --------------------------- liquid water ------------------------------
7323! maximum canopy water
7324
7325 maxliq = parameters%ch2op * (elai+ esai)
7326
7327! evaporation, transpiration, and dew
7328
7329 if (.not.frozen_canopy) then ! barlage: change to frozen_canopy
7330 etran = max( fctr/hvap, 0. )
7331 qevac = max( fcev/hvap, 0. )
7332 qdewc = abs( min( fcev/hvap, 0. ) )
7333 qsubc = 0.
7334 qfroc = 0.
7335 else
7336 etran = max( fctr/hsub, 0. )
7337 qevac = 0.
7338 qdewc = 0.
7339 qsubc = max( fcev/hsub, 0. )
7340 qfroc = abs( min( fcev/hsub, 0. ) )
7341 endif
7342
7343! canopy water balance. for convenience allow dew to bring canliq above
7344! maxh2o or else would have to re-adjust drip
7345
7346 qevac = min(canliq/dt,qevac)
7347 canliq=max(0.,canliq+(qdewc-qevac)*dt)
7348 if(canliq <= 1.e-06) canliq = 0.0
7349
7350! --------------------------- canopy ice ------------------------------
7351! for canopy ice
7352
7353 maxsno = 6.6*(0.27+46./bdfall) * (elai+ esai)
7354
7355 qsubc = min(canice/dt,qsubc)
7356 canice= max(0.,canice + (qfroc-qsubc)*dt)
7357 if(canice.le.1.e-6) canice = 0.
7358
7359! wetted fraction of canopy
7360
7361 if(canice.gt.0.) then
7362 fwet = max(0.,canice) / max(maxsno,1.e-06)
7363 else
7364 fwet = max(0.,canliq) / max(maxliq,1.e-06)
7365 endif
7366 fwet = min(fwet, 1.) ** 0.667
7367
7368! phase change
7369
7370 qmeltc = 0.
7371 qfrzc = 0.
7372
7373 if(canice.gt.1.e-6.and.tv.gt.tfrz) then
7374 qmeltc = min(canice/dt,(tv-tfrz)*cice*canice/denice/(dt*hfus))
7375 canice = max(0.,canice - qmeltc*dt)
7376 canliq = max(0.,canliq + qmeltc*dt)
7377 tv = fwet*tfrz + (1.-fwet)*tv
7378 endif
7379
7380 if(canliq.gt.1.e-6.and.tv.lt.tfrz) then
7381 qfrzc = min(canliq/dt,(tfrz-tv)*cwat*canliq/denh2o/(dt*hfus))
7382 canliq = max(0.,canliq - qfrzc*dt)
7383 canice = max(0.,canice + qfrzc*dt)
7384 tv = fwet*tfrz + (1.-fwet)*tv
7385 endif
7386
7387! total canopy water
7388
7389 cmc = canliq + canice
7390
7391! total canopy evaporation
7392
7393 ecan = qevac + qsubc - qdewc - qfroc
7394
7395 end subroutine canwater
7396
7397!== begin snowwater ================================================================================
7398
7401 subroutine snowwater (parameters,nsnow ,nsoil ,imelt ,dt ,zsoil , & !in
7402 sfctmp ,snowhin,qsnow ,qsnfro ,qsnsub , & !in
7403 qrain ,ficeold,iloc ,jloc , & !in
7404 isnow ,snowh ,sneqv ,snice ,snliq , & !inout
7405 sh2o ,sice ,stc ,zsnso ,dzsnso , & !inout
7406 qsnbot ,snoflow,ponding1 ,ponding2) !out
7407! ----------------------------------------------------------------------
7408 implicit none
7409! ----------------------------------------------------------------------
7410! input
7411 type (noahmp_parameters), intent(in) :: parameters
7412 integer, intent(in) :: iloc
7413 integer, intent(in) :: jloc
7414 integer, intent(in) :: nsnow
7415 integer, intent(in) :: nsoil
7416 integer, dimension(-nsnow+1:0) , intent(in) :: imelt
7417 real (kind=kind_phys), intent(in) :: dt
7418 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil
7419 real (kind=kind_phys), intent(in) :: sfctmp
7420 real (kind=kind_phys), intent(in) :: snowhin
7421 real (kind=kind_phys), intent(in) :: qsnow
7422 real (kind=kind_phys), intent(in) :: qsnfro
7423 real (kind=kind_phys), intent(in) :: qsnsub
7424 real (kind=kind_phys), intent(in) :: qrain
7425 real (kind=kind_phys), dimension(-nsnow+1:0) , intent(in) :: ficeold
7426
7427! input & output
7428 integer, intent(inout) :: isnow
7429 real (kind=kind_phys), intent(inout) :: snowh
7430 real (kind=kind_phys), intent(inout) :: sneqv
7431 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snice
7432 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snliq
7433 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sh2o
7434 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sice
7435 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
7436 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: zsnso
7437 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
7438
7439! output
7440 real (kind=kind_phys), intent(out) :: qsnbot
7441 real (kind=kind_phys), intent(out) :: snoflow
7442 real (kind=kind_phys), intent(out) :: ponding1
7443 real (kind=kind_phys), intent(out) :: ponding2
7444
7445! local
7446 integer :: iz,i
7447 real (kind=kind_phys) :: bdsnow !bulk density of snow (kg/m3)
7448! ----------------------------------------------------------------------
7449 snoflow = 0.0
7450 ponding1 = 0.0
7451 ponding2 = 0.0
7452
7453 call snowfall (parameters,nsoil ,nsnow ,dt ,qsnow ,snowhin, & !in
7454 sfctmp ,iloc ,jloc , & !in
7455 isnow ,snowh ,dzsnso ,stc ,snice , & !inout
7456 snliq ,sneqv ) !inout
7457
7458! mb: do each if block separately
7459
7460 if(isnow < 0) & ! when multi-layer
7461 call compact (parameters,nsnow ,nsoil ,dt ,stc ,snice , & !in
7462 snliq ,zsoil ,imelt ,ficeold,iloc , jloc ,& !in
7463 isnow ,dzsnso ,zsnso ) !inout
7464
7465 if(isnow < 0) & !when multi-layer
7466 call combine (parameters,nsnow ,nsoil ,iloc ,jloc , & !in
7467 isnow ,sh2o ,stc ,snice ,snliq , & !inout
7468 dzsnso ,sice ,snowh ,sneqv , & !inout
7469 ponding1 ,ponding2) !out
7470
7471 if(isnow < 0) & !when multi-layer
7472 call divide (parameters,nsnow ,nsoil , & !in
7473 isnow ,stc ,snice ,snliq ,dzsnso ) !inout
7474
7475 call snowh2o (parameters,nsnow ,nsoil ,dt ,qsnfro ,qsnsub , & !in
7476 qrain ,iloc ,jloc , & !in
7477 isnow ,dzsnso ,snowh ,sneqv ,snice , & !inout
7478 snliq ,sh2o ,sice ,stc , & !inout
7479 qsnbot ,ponding1 ,ponding2) !out
7480
7481!set empty snow layers to zero
7482
7483 do iz = -nsnow+1, isnow
7484 snice(iz) = 0.
7485 snliq(iz) = 0.
7486 stc(iz) = 0.
7487 dzsnso(iz)= 0.
7488 zsnso(iz) = 0.
7489 enddo
7490
7491!to obtain equilibrium state of snow in glacier region
7492
7493 if(sneqv > 5000.) then ! 5000 mm -> maximum water depth
7494 bdsnow = snice(0) / dzsnso(0)
7495 snoflow = (sneqv - 5000.)
7496 snice(0) = snice(0) - snoflow
7497 dzsnso(0) = dzsnso(0) - snoflow/bdsnow
7498 snoflow = snoflow / dt
7499 end if
7500
7501! sum up snow mass for layered snow
7502
7503 if(isnow < 0) then ! mb: only do for multi-layer
7504 sneqv = 0.
7505 snowh = 0.
7506 do iz = isnow+1,0
7507 sneqv = sneqv + snice(iz) + snliq(iz)
7508 snowh = snowh + dzsnso(iz)
7509 enddo
7510 end if
7511
7512! reset zsnso and layer thinkness dzsnso
7513
7514 do iz = isnow+1, 0
7515 dzsnso(iz) = -dzsnso(iz)
7516 end do
7517
7518 dzsnso(1) = zsoil(1)
7519 do iz = 2,nsoil
7520 dzsnso(iz) = (zsoil(iz) - zsoil(iz-1))
7521 end do
7522
7523 zsnso(isnow+1) = dzsnso(isnow+1)
7524 do iz = isnow+2 ,nsoil
7525 zsnso(iz) = zsnso(iz-1) + dzsnso(iz)
7526 enddo
7527
7528 do iz = isnow+1 ,nsoil
7529 dzsnso(iz) = -dzsnso(iz)
7530 end do
7531
7532 end subroutine snowwater
7533
7534!== begin snowfall =================================================================================
7535
7539 subroutine snowfall (parameters,nsoil ,nsnow ,dt ,qsnow ,snowhin , & !in
7540 sfctmp ,iloc ,jloc , & !in
7541 isnow ,snowh ,dzsnso ,stc ,snice , & !inout
7542 snliq ,sneqv ) !inout
7543! ----------------------------------------------------------------------
7544! snow depth and density to account for the new snowfall.
7545! new values of snow depth & density returned.
7546! ----------------------------------------------------------------------
7547 implicit none
7548! ----------------------------------------------------------------------
7549! input
7550
7551 type (noahmp_parameters), intent(in) :: parameters
7552 integer, intent(in) :: iloc
7553 integer, intent(in) :: jloc
7554 integer, intent(in) :: nsoil
7555 integer, intent(in) :: nsnow
7556 real (kind=kind_phys), intent(in) :: dt
7557 real (kind=kind_phys), intent(in) :: qsnow
7558 real (kind=kind_phys), intent(in) :: snowhin
7559 real (kind=kind_phys), intent(in) :: sfctmp
7560
7561! input and output
7562
7563 integer, intent(inout) :: isnow
7564 real (kind=kind_phys), intent(inout) :: snowh
7565 real (kind=kind_phys), intent(inout) :: sneqv
7566 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
7567 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
7568 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snice
7569 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snliq
7570
7571! local
7572
7573 integer :: newnode ! 0-no new layers, 1-creating new layers
7574! ----------------------------------------------------------------------
7575 newnode = 0
7576
7577! shallow snow / no layer
7578
7579 if(isnow == 0 .and. qsnow > 0.) then
7580 snowh = snowh + snowhin * dt
7581 sneqv = sneqv + qsnow * dt
7582 end if
7583
7584! creating a new layer
7585
7586 if(isnow == 0 .and. qsnow>0. .and. snowh >= 0.025) then !mb: change limit
7587! if(isnow == 0 .and. qsnow>0. .and. snowh >= 0.05) then
7588 isnow = -1
7589 newnode = 1
7590 dzsnso(0)= snowh
7591 snowh = 0.
7592 stc(0) = min(273.16, sfctmp) ! temporary setup
7593 snice(0) = sneqv
7594 snliq(0) = 0.
7595 end if
7596
7597! snow with layers
7598
7599 if(isnow < 0 .and. newnode == 0 .and. qsnow > 0.) then
7600 snice(isnow+1) = snice(isnow+1) + qsnow * dt
7601 dzsnso(isnow+1) = dzsnso(isnow+1) + snowhin * dt
7602 endif
7603
7604! ----------------------------------------------------------------------
7605 end subroutine snowfall
7606
7607!== begin combine ==================================================================================
7608
7611 subroutine combine (parameters,nsnow ,nsoil ,iloc ,jloc , & !in
7612 isnow ,sh2o ,stc ,snice ,snliq , & !inout
7613 dzsnso ,sice ,snowh ,sneqv , & !inout
7614 ponding1 ,ponding2) !out
7615! ----------------------------------------------------------------------
7616 implicit none
7617! ----------------------------------------------------------------------
7618! input
7619
7620 type (noahmp_parameters), intent(in) :: parameters
7621 integer, intent(in) :: iloc
7622 integer, intent(in) :: jloc
7623 integer, intent(in) :: nsnow
7624 integer, intent(in) :: nsoil
7625
7626! input and output
7627
7628 integer, intent(inout) :: isnow
7629 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sh2o
7630 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sice
7631 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
7632 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snice
7633 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snliq
7634 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
7635 real (kind=kind_phys), intent(inout) :: sneqv
7636 real (kind=kind_phys), intent(inout) :: snowh
7637 real (kind=kind_phys), intent(out) :: ponding1
7638 real (kind=kind_phys), intent(out) :: ponding2
7639
7640! local variables:
7641
7642 integer :: i,j,k,l ! node indices
7643 integer :: isnow_old ! number of top snow layer
7644 integer :: mssi ! node index
7645 integer :: neibor ! adjacent node selected for combination
7646 real (kind=kind_phys) :: zwice ! total ice mass in snow
7647 real (kind=kind_phys) :: zwliq ! total liquid water in snow
7648
7649 real (kind=kind_phys) :: dzmin(3) ! minimum of top snow layer
7650! data dzmin /0.045, 0.05, 0.2/
7651 data dzmin /0.025, 0.025, 0.1/ ! mb: change limit
7652!-----------------------------------------------------------------------
7653
7654 isnow_old = isnow
7655
7656 do j = isnow_old+1,0
7657 if (snice(j) <= .1) then
7658 if(j /= 0) then
7659 snliq(j+1) = snliq(j+1) + snliq(j)
7660 snice(j+1) = snice(j+1) + snice(j)
7661 dzsnso(j+1) = dzsnso(j+1) + dzsnso(j)
7662 else
7663 if (isnow_old < -1) then ! mb/km: change to isnow
7664 snliq(j-1) = snliq(j-1) + snliq(j)
7665 snice(j-1) = snice(j-1) + snice(j)
7666 dzsnso(j-1) = dzsnso(j-1) + dzsnso(j)
7667 else
7668 if(snice(j) >= 0.) then
7669 ponding1 = snliq(j) ! isnow will get set to zero below; ponding1 will get
7670 sneqv = snice(j) ! added to ponding from phasechange ponding should be
7671 snowh = dzsnso(j) ! zero here because it was calculated for thin snow
7672 else ! snice over-sublimated earlier
7673 ponding1 = snliq(j) + snice(j)
7674 if(ponding1 < 0.) then ! if snice and snliq sublimates remove from soil
7675 sice(1) = max(0.0,sice(1)+ponding1/(dzsnso(1)*1000.))
7676 ponding1 = 0.0
7677 end if
7678 sneqv = 0.0
7679 snowh = 0.0
7680 end if
7681 snliq(j) = 0.0
7682 snice(j) = 0.0
7683 dzsnso(j) = 0.0
7684 endif
7685! sh2o(1) = sh2o(1)+snliq(j)/(dzsnso(1)*1000.)
7686! sice(1) = sice(1)+snice(j)/(dzsnso(1)*1000.)
7687 endif
7688
7689 ! shift all elements above this down by one.
7690 if (j > isnow+1 .and. isnow < -1) then
7691 do i = j, isnow+2, -1
7692 stc(i) = stc(i-1)
7693 snliq(i) = snliq(i-1)
7694 snice(i) = snice(i-1)
7695 dzsnso(i)= dzsnso(i-1)
7696 end do
7697 end if
7698 isnow = isnow + 1
7699 end if
7700 end do
7701
7702! to conserve water in case of too large surface sublimation
7703
7704 if(sice(1) < 0.) then
7705 sh2o(1) = sh2o(1) + sice(1)
7706 sice(1) = 0.
7707 end if
7708
7709 if(isnow ==0) return ! mb: get out if no longer multi-layer
7710
7711 sneqv = 0.
7712 snowh = 0.
7713 zwice = 0.
7714 zwliq = 0.
7715
7716 do j = isnow+1,0
7717 sneqv = sneqv + snice(j) + snliq(j)
7718 snowh = snowh + dzsnso(j)
7719 zwice = zwice + snice(j)
7720 zwliq = zwliq + snliq(j)
7721 end do
7722
7723! check the snow depth - all snow gone
7724! the liquid water assumes ponding on soil surface.
7725
7726 if (snowh < 0.025 .and. isnow < 0 ) then ! mb: change limit
7727! if (snowh < 0.05 .and. isnow < 0 ) then
7728 isnow = 0
7729 sneqv = zwice
7730 ponding2 = zwliq ! limit of isnow < 0 means input ponding
7731 if(sneqv <= 0.) snowh = 0. ! should be zero; see above
7732 end if
7733
7734! if (snowh < 0.05 ) then
7735! isnow = 0
7736! sneqv = zwice
7737! sh2o(1) = sh2o(1) + zwliq / (dzsnso(1) * 1000.)
7738! if(sneqv <= 0.) snowh = 0.
7739! end if
7740
7741! check the snow depth - snow layers combined
7742
7743 if (isnow < -1) then
7744
7745 isnow_old = isnow
7746 mssi = 1
7747
7748 do i = isnow_old+1,0
7749 if (dzsnso(i) < dzmin(mssi)) then
7750
7751 if (i == isnow+1) then
7752 neibor = i + 1
7753 else if (i == 0) then
7754 neibor = i - 1
7755 else
7756 neibor = i + 1
7757 if ((dzsnso(i-1)+dzsnso(i)) < (dzsnso(i+1)+dzsnso(i))) neibor = i-1
7758 end if
7759
7760 ! node l and j are combined and stored as node j.
7761 if (neibor > i) then
7762 j = neibor
7763 l = i
7764 else
7765 j = i
7766 l = neibor
7767 end if
7768
7769 call combo (parameters,dzsnso(j), snliq(j), snice(j), &
7770 stc(j), dzsnso(l), snliq(l), snice(l), stc(l) )
7771
7772 ! now shift all elements above this down one.
7773 if (j-1 > isnow+1) then
7774 do k = j-1, isnow+2, -1
7775 stc(k) = stc(k-1)
7776 snice(k) = snice(k-1)
7777 snliq(k) = snliq(k-1)
7778 dzsnso(k) = dzsnso(k-1)
7779 end do
7780 end if
7781
7782 ! decrease the number of snow layers
7783 isnow = isnow + 1
7784 if (isnow >= -1) exit
7785 else
7786
7787 ! the layer thickness is greater than the prescribed minimum value
7788 mssi = mssi + 1
7789
7790 end if
7791 end do
7792
7793 end if
7794
7795 end subroutine combine
7796
7797!== begin divide ===================================================================================
7798
7801 subroutine divide (parameters,nsnow ,nsoil , & !in
7802 isnow ,stc ,snice ,snliq ,dzsnso ) !inout
7803! ----------------------------------------------------------------------
7804 implicit none
7805! ----------------------------------------------------------------------
7806! input
7807
7808 type (noahmp_parameters), intent(in) :: parameters
7809 integer, intent(in) :: nsnow
7810 integer, intent(in) :: nsoil
7811
7812! input and output
7813
7814 integer , intent(inout) :: isnow
7815 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
7816 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snice
7817 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snliq
7818 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
7819
7820! local variables:
7821
7822 integer :: j !indices
7823 integer :: msno !number of layer (top) to msno (bot)
7824 real (kind=kind_phys) :: drr !thickness of the combined [m]
7825 real (kind=kind_phys), dimension( 1:nsnow) :: dz !snow layer thickness [m]
7826 real (kind=kind_phys), dimension( 1:nsnow) :: swice !partial volume of ice [m3/m3]
7827 real (kind=kind_phys), dimension( 1:nsnow) :: swliq !partial volume of liquid water [m3/m3]
7828 real (kind=kind_phys), dimension( 1:nsnow) :: tsno !node temperature [k]
7829 real (kind=kind_phys) :: zwice !temporary
7830 real (kind=kind_phys) :: zwliq !temporary
7831 real (kind=kind_phys) :: propor!temporary
7832 real (kind=kind_phys) :: dtdz !temporary
7833! ----------------------------------------------------------------------
7834
7835 do j = 1,nsnow
7836 if (j <= abs(isnow)) then
7837 dz(j) = dzsnso(j+isnow)
7838 swice(j) = snice(j+isnow)
7839 swliq(j) = snliq(j+isnow)
7840 tsno(j) = stc(j+isnow)
7841 end if
7842 end do
7843
7844 msno = abs(isnow)
7845
7846 if (msno == 1) then
7847 ! specify a new snow layer
7848 if (dz(1) > 0.05) then
7849 msno = 2
7850 dz(1) = dz(1)/2.
7851 swice(1) = swice(1)/2.
7852 swliq(1) = swliq(1)/2.
7853 dz(2) = dz(1)
7854 swice(2) = swice(1)
7855 swliq(2) = swliq(1)
7856 tsno(2) = tsno(1)
7857 end if
7858 end if
7859
7860 if (msno > 1) then
7861 if (dz(1) > 0.05) then
7862 drr = dz(1) - 0.05
7863 propor = drr/dz(1)
7864 zwice = propor*swice(1)
7865 zwliq = propor*swliq(1)
7866 propor = 0.05/dz(1)
7867 swice(1) = propor*swice(1)
7868 swliq(1) = propor*swliq(1)
7869 dz(1) = 0.05
7870
7871 call combo (parameters,dz(2), swliq(2), swice(2), tsno(2), drr, &
7872 zwliq, zwice, tsno(1))
7873
7874 ! subdivide a new layer
7875 if (msno <= 2 .and. dz(2) > 0.20) then ! mb: change limit
7876! if (msno <= 2 .and. dz(2) > 0.10) then
7877 msno = 3
7878 dtdz = (tsno(1) - tsno(2))/((dz(1)+dz(2))/2.)
7879 dz(2) = dz(2)/2.
7880 swice(2) = swice(2)/2.
7881 swliq(2) = swliq(2)/2.
7882 dz(3) = dz(2)
7883 swice(3) = swice(2)
7884 swliq(3) = swliq(2)
7885 tsno(3) = tsno(2) - dtdz*dz(2)/2.
7886 if (tsno(3) >= tfrz) then
7887 tsno(3) = tsno(2)
7888 else
7889 tsno(2) = tsno(2) + dtdz*dz(2)/2.
7890 endif
7891
7892 end if
7893 end if
7894 end if
7895
7896 if (msno > 2) then
7897 if (dz(2) > 0.2) then
7898 drr = dz(2) - 0.2
7899 propor = drr/dz(2)
7900 zwice = propor*swice(2)
7901 zwliq = propor*swliq(2)
7902 propor = 0.2/dz(2)
7903 swice(2) = propor*swice(2)
7904 swliq(2) = propor*swliq(2)
7905 dz(2) = 0.2
7906 call combo (parameters,dz(3), swliq(3), swice(3), tsno(3), drr, &
7907 zwliq, zwice, tsno(2))
7908 end if
7909 end if
7910
7911 isnow = -msno
7912
7913 do j = isnow+1,0
7914 dzsnso(j) = dz(j-isnow)
7915 snice(j) = swice(j-isnow)
7916 snliq(j) = swliq(j-isnow)
7917 stc(j) = tsno(j-isnow)
7918 end do
7919
7920
7921! do j = isnow+1,nsoil
7922! write(*,'(i5,7f10.3)') j, dzsnso(j), snice(j), snliq(j),stc(j)
7923! end do
7924
7925 end subroutine divide
7926
7927!== begin combo ====================================================================================
7928
7931 subroutine combo(parameters,dz, wliq, wice, t, dz2, wliq2, wice2, t2)
7932! ----------------------------------------------------------------------
7933 implicit none
7934! ----------------------------------------------------------------------
7935
7936! ----------------------------------------------------------------------s
7937! input
7938
7939 type (noahmp_parameters), intent(in) :: parameters
7940 real (kind=kind_phys), intent(in) :: dz2
7941 real (kind=kind_phys), intent(in) :: wliq2
7942 real (kind=kind_phys), intent(in) :: wice2
7943 real (kind=kind_phys), intent(in) :: t2
7944 real (kind=kind_phys), intent(inout) :: dz
7945 real (kind=kind_phys), intent(inout) :: wliq
7946 real (kind=kind_phys), intent(inout) :: wice
7947 real (kind=kind_phys), intent(inout) :: t
7948
7949! local
7950
7951 real (kind=kind_phys) :: dzc !total thickness of nodes 1 and 2 (dzc=dz+dz2).
7952 real (kind=kind_phys) :: wliqc !combined liquid water [kg/m2]
7953 real (kind=kind_phys) :: wicec !combined ice [kg/m2]
7954 real (kind=kind_phys) :: tc !combined node temperature [k]
7955 real (kind=kind_phys) :: h !enthalpy of element 1 [j/m2]
7956 real (kind=kind_phys) :: h2 !enthalpy of element 2 [j/m2]
7957 real (kind=kind_phys) :: hc !temporary
7958
7959!-----------------------------------------------------------------------
7960
7961 dzc = dz+dz2
7962 wicec = (wice+wice2)
7963 wliqc = (wliq+wliq2)
7964 h = (cice*wice+cwat*wliq) * (t-tfrz)+hfus*wliq
7965 h2= (cice*wice2+cwat*wliq2) * (t2-tfrz)+hfus*wliq2
7966
7967 hc = h + h2
7968 if(hc < 0.)then
7969 tc = tfrz + hc/(cice*wicec + cwat*wliqc)
7970 else if (hc.le.hfus*wliqc) then
7971 tc = tfrz
7972 else
7973 tc = tfrz + (hc - hfus*wliqc) / (cice*wicec + cwat*wliqc)
7974 end if
7975
7976 dz = dzc
7977 wice = wicec
7978 wliq = wliqc
7979 t = tc
7980
7981 end subroutine combo
7982
7983!== begin compact ==================================================================================
7984
7987 subroutine compact (parameters,nsnow ,nsoil ,dt ,stc ,snice , & !in
7988 snliq ,zsoil ,imelt ,ficeold,iloc , jloc , & !in
7989 isnow ,dzsnso ,zsnso ) !inout
7990! ----------------------------------------------------------------------
7991 implicit none
7992! ----------------------------------------------------------------------
7993! input
7994 type (noahmp_parameters), intent(in) :: parameters
7995 integer, intent(in) :: iloc
7996 integer, intent(in) :: jloc
7997 integer, intent(in) :: nsoil
7998 integer, intent(in) :: nsnow
7999 integer, dimension(-nsnow+1:0) , intent(in) :: imelt
8000 real (kind=kind_phys), intent(in) :: dt
8001 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc
8002 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snice
8003 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snliq
8004 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil
8005 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: ficeold
8006
8007! input and output
8008 integer, intent(inout) :: isnow
8009 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
8010 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: zsnso
8011
8012! local
8013 real (kind=kind_phys), parameter :: c2 = 21.e-3 ![m3/kg] ! default 21.e-3
8014 real (kind=kind_phys), parameter :: c3 = 2.5e-6 ![1/s]
8015 real (kind=kind_phys), parameter :: c4 = 0.04 ![1/k]
8016 real (kind=kind_phys), parameter :: c5 = 2.0 !
8017 real (kind=kind_phys), parameter :: dm = 100.0 !upper limit on destructive metamorphism compaction [kg/m3]
8018 real (kind=kind_phys), parameter :: eta0 = 1.8e+6 !viscosity coefficient [kg-s/m2]
8019 !according to anderson, it is between 0.52e6~1.38e6
8020 real (kind=kind_phys) :: burden !pressure of overlying snow [kg/m2]
8021 real (kind=kind_phys) :: ddz1 !rate of settling of snow pack due to destructive metamorphism.
8022 real (kind=kind_phys) :: ddz2 !rate of compaction of snow pack due to overburden.
8023 real (kind=kind_phys) :: ddz3 !rate of compaction of snow pack due to melt [1/s]
8024 real (kind=kind_phys) :: dexpf !expf=exp(-c4*(273.15-stc)).
8025 real (kind=kind_phys) :: td !stc - tfrz [k]
8026 real (kind=kind_phys) :: pdzdtc !nodal rate of change in fractional-thickness due to compaction [fraction/s]
8027 real (kind=kind_phys) :: void !void (1 - snice - snliq)
8028 real (kind=kind_phys) :: wx !water mass (ice + liquid) [kg/m2]
8029 real (kind=kind_phys) :: bi !partial density of ice [kg/m3]
8030 real (kind=kind_phys), dimension(-nsnow+1:0) :: fice !fraction of ice at current time step
8031
8032 integer :: j
8033
8034! ----------------------------------------------------------------------
8035 burden = 0.0
8036
8037 do j = isnow+1, 0
8038
8039 wx = snice(j) + snliq(j)
8040 fice(j) = snice(j) / wx
8041 void = 1. - (snice(j)/denice + snliq(j)/denh2o) / dzsnso(j)
8042
8043 ! allow compaction only for non-saturated node and higher ice lens node.
8044 if (void > 0.001 .and. snice(j) > 0.1) then
8045 bi = snice(j) / dzsnso(j)
8046 td = max(0.,tfrz-stc(j))
8047 dexpf = exp(-c4*td)
8048
8049 ! settling as a result of destructive metamorphism
8050
8051 ddz1 = -c3*dexpf
8052
8053 if (bi > dm) ddz1 = ddz1*exp(-46.0e-3*(bi-dm))
8054
8055 ! liquid water term
8056
8057 if (snliq(j) > 0.01*dzsnso(j)) ddz1=ddz1*c5
8058
8059 ! compaction due to overburden
8060
8061 ddz2 = -(burden+0.5*wx)*exp(-0.08*td-c2*bi)/eta0 ! 0.5*wx -> self-burden
8062
8063 ! compaction occurring during melt
8064
8065 if (imelt(j) == 1) then
8066 ddz3 = max(0.,(ficeold(j) - fice(j))/max(1.e-6,ficeold(j)))
8067 ddz3 = - ddz3/dt ! sometimes too large
8068 else
8069 ddz3 = 0.
8070 end if
8071
8072 ! time rate of fractional change in dz (units of s-1)
8073
8074 pdzdtc = (ddz1 + ddz2 + ddz3)*dt
8075 pdzdtc = max(-0.5,pdzdtc)
8076
8077 ! the change in dz due to compaction
8078
8079 dzsnso(j) = dzsnso(j)*(1.+pdzdtc)
8080 dzsnso(j) = min(max(dzsnso(j),(snliq(j)+snice(j))/500.0),(snliq(j)+snice(j))/50.0) ! limit adjustment to a reasonable density
8081 end if
8082
8083 ! pressure of overlying snow
8084
8085 burden = burden + wx
8086
8087 end do
8088
8089 end subroutine compact
8090
8091!== begin snowh2o ==================================================================================
8092
8096 subroutine snowh2o (parameters,nsnow ,nsoil ,dt ,qsnfro ,qsnsub , & !in
8097 qrain ,iloc ,jloc , & !in
8098 isnow ,dzsnso ,snowh ,sneqv ,snice , & !inout
8099 snliq ,sh2o ,sice ,stc , & !inout
8100 qsnbot ,ponding1 ,ponding2) !out
8101! ----------------------------------------------------------------------
8102! renew the mass of ice lens (snice) and liquid (snliq) of the
8103! surface snow layer resulting from sublimation (frost) / evaporation (dew)
8104! ----------------------------------------------------------------------
8105 implicit none
8106! ----------------------------------------------------------------------
8107! input
8108
8109 type (noahmp_parameters), intent(in) :: parameters
8110 integer, intent(in) :: iloc
8111 integer, intent(in) :: jloc
8112 integer, intent(in) :: nsnow
8113 integer, intent(in) :: nsoil
8114 real (kind=kind_phys), intent(in) :: dt
8115 real (kind=kind_phys), intent(in) :: qsnfro
8116 real (kind=kind_phys), intent(in) :: qsnsub
8117 real (kind=kind_phys), intent(in) :: qrain
8118
8119! output
8120
8121 real (kind=kind_phys), intent(out) :: qsnbot
8122
8123! input and output
8124
8125 integer, intent(inout) :: isnow
8126 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
8127 real (kind=kind_phys), intent(inout) :: snowh
8128 real (kind=kind_phys), intent(inout) :: sneqv
8129 real (kind=kind_phys), dimension(-nsnow+1:0), intent(inout) :: snice
8130 real (kind=kind_phys), dimension(-nsnow+1:0), intent(inout) :: snliq
8131 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sh2o
8132 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sice
8133 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
8134
8135! local variables:
8136
8137 integer :: j !do loop/array indices
8138 real (kind=kind_phys) :: qin !water flow into the element (mm/s)
8139 real (kind=kind_phys) :: qout !water flow out of the element (mm/s)
8140 real (kind=kind_phys) :: wgdif !ice mass after minus sublimation
8141 real (kind=kind_phys), dimension(-nsnow+1:0) :: vol_liq !partial volume of liquid water in layer
8142 real (kind=kind_phys), dimension(-nsnow+1:0) :: vol_ice !partial volume of ice lens in layer
8143 real (kind=kind_phys), dimension(-nsnow+1:0) :: epore !effective porosity = porosity - vol_ice
8144 real (kind=kind_phys) :: propor, temp
8145 real (kind=kind_phys) :: ponding1, ponding2
8146 real (kind=kind_phys), parameter :: max_liq_mass_fraction = 0.4
8147! ----------------------------------------------------------------------
8148
8149!for the case when sneqv becomes '0' after 'combine'
8150
8151 if(sneqv == 0.) then
8152 sice(1) = sice(1) + (qsnfro-qsnsub)*dt/(dzsnso(1)*1000.) ! barlage: sh2o->sice v3.6
8153 if(sice(1) < 0.) then
8154 sh2o(1) = sh2o(1) + sice(1)
8155 sice(1) = 0.
8156 end if
8157 end if
8158
8159! for shallow snow without a layer
8160! snow surface sublimation may be larger than existing snow mass. to conserve water,
8161! excessive sublimation is used to reduce soil water. smaller time steps would tend
8162! to aviod this problem.
8163
8164 if(isnow == 0 .and. sneqv > 0.) then
8165 temp = sneqv
8166 sneqv = sneqv - qsnsub*dt + qsnfro*dt
8167 propor = sneqv/temp
8168 snowh = max(0.,propor * snowh)
8169 snowh = min(max(snowh,sneqv/500.0),sneqv/50.0) ! limit adjustment to a reasonable density
8170
8171 if(sneqv < 0.) then
8172 sice(1) = sice(1) + sneqv/(dzsnso(1)*1000.)
8173 sneqv = 0.
8174 snowh = 0.
8175 end if
8176 if(sice(1) < 0.) then
8177 sh2o(1) = sh2o(1) + sice(1)
8178 sice(1) = 0.
8179 end if
8180 end if
8181
8182 if(snowh <= 1.e-6 .or. sneqv <= 1.e-3) then
8183 snowh = 0.0
8184 sneqv = 0.0
8185 end if
8186
8187! for deep snow
8188
8189 if ( isnow < 0 ) then !kwm added this if statement to prevent out-of-bounds array references
8190
8191 wgdif = snice(isnow+1) - qsnsub*dt + qsnfro*dt
8192 snice(isnow+1) = wgdif
8193 if (wgdif < 1.e-6 .and. isnow <0) then
8194 call combine (parameters,nsnow ,nsoil ,iloc, jloc , & !in
8195 isnow ,sh2o ,stc ,snice ,snliq , & !inout
8196 dzsnso ,sice ,snowh ,sneqv , & !inout
8197 ponding1, ponding2 ) !out
8198 endif
8199 !kwm: subroutine combine can change isnow to make it 0 again?
8200 if ( isnow < 0 ) then !kwm added this if statement to prevent out-of-bounds array references
8201 snliq(isnow+1) = snliq(isnow+1) + qrain * dt
8202 snliq(isnow+1) = max(0., snliq(isnow+1))
8203 endif
8204
8205 endif !kwm -- can the endif be moved toward the end of the subroutine (just set qsnbot=0)?
8206
8207! porosity and partial volume
8208
8209 do j = isnow+1, 0
8210 vol_ice(j) = min(1., snice(j)/(dzsnso(j)*denice))
8211 epore(j) = 1. - vol_ice(j)
8212 end do
8213
8214 qin = 0.
8215 qout = 0.
8216
8217 do j = isnow+1, 0
8218 snliq(j) = snliq(j) + qin
8219 vol_liq(j) = snliq(j)/(dzsnso(j)*denh2o)
8220 qout = max(0.,(vol_liq(j)-parameters%ssi*epore(j))*dzsnso(j))
8221 if(j == 0) then
8222 qout = max((vol_liq(j)- epore(j))*dzsnso(j) , parameters%snow_ret_fac*dt*qout)
8223 end if
8224 qout = qout*denh2o
8225 snliq(j) = snliq(j) - qout
8226 if((snliq(j)/(snice(j)+snliq(j))) > max_liq_mass_fraction) then
8227 qout = qout + (snliq(j) - max_liq_mass_fraction/(1.0 - max_liq_mass_fraction)*snice(j))
8228 snliq(j) = max_liq_mass_fraction/(1.0 - max_liq_mass_fraction)*snice(j)
8229 endif
8230 qin = qout
8231 end do
8232
8233 do j = isnow+1, 0
8234 dzsnso(j) = min(max(dzsnso(j),(snliq(j)+snice(j))/500.0),(snliq(j)+snice(j))/50.0) ! limit adjustment to a reasonable density
8235 end do
8236
8237! liquid water from snow bottom to soil
8238
8239 qsnbot = qout / dt ! mm/s
8240
8241 end subroutine snowh2o
8242
8243!== begin soilwater ================================================================================
8244
8247 subroutine soilwater (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in
8248 qinsur ,qseva ,etrani ,sice ,iloc , jloc, & !in
8249 sh2o ,smc ,zwt ,vegtyp ,& !inout
8250 smcwtd, deeprech ,& !inout
8251 runsrf ,qdrain ,runsub ,wcnd ,fcrmax ) !out
8252
8253! ----------------------------------------------------------------------
8254! calculate surface runoff and soil moisture.
8255! ----------------------------------------------------------------------
8256! ----------------------------------------------------------------------
8257 implicit none
8258! ----------------------------------------------------------------------
8259! input
8260 type (noahmp_parameters), intent(in) :: parameters
8261 integer, intent(in) :: iloc
8262 integer, intent(in) :: jloc
8263 integer, intent(in) :: nsoil
8264 integer, intent(in) :: nsnow
8265 real (kind=kind_phys), intent(in) :: dt
8266 real (kind=kind_phys), intent(in) :: qinsur
8267 real (kind=kind_phys), intent(in) :: qseva
8268 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: zsoil
8269 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: etrani
8270 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
8271 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: sice
8272
8273 integer, intent(in) :: vegtyp
8274
8275! input & output
8276 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: sh2o
8277 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: smc
8278 real (kind=kind_phys), intent(inout) :: zwt
8279 real (kind=kind_phys), intent(inout) :: smcwtd
8280 real (kind=kind_phys) , intent(inout) :: deeprech
8281
8282! output
8283 real (kind=kind_phys), intent(out) :: qdrain
8284 real (kind=kind_phys), intent(out) :: runsrf
8285 real (kind=kind_phys), intent(out) :: runsub
8286 real (kind=kind_phys), intent(out) :: fcrmax
8287 real (kind=kind_phys), dimension(1:nsoil), intent(out) :: wcnd
8288
8289! local
8290 integer :: k,iz !do-loop index
8291 integer :: iter !iteration index
8292 real (kind=kind_phys) :: dtfine !fine time step (s)
8293 real (kind=kind_phys), dimension(1:nsoil) :: rhstt !right-hand side term of the matrix
8294 real (kind=kind_phys), dimension(1:nsoil) :: ai !left-hand side term
8295 real (kind=kind_phys), dimension(1:nsoil) :: bi !left-hand side term
8296 real (kind=kind_phys), dimension(1:nsoil) :: ci !left-hand side term
8297
8298 real (kind=kind_phys) :: fff !runoff decay factor (m-1)
8299 real (kind=kind_phys) :: rsbmx !baseflow coefficient [mm/s]
8300 real (kind=kind_phys) :: pddum !infiltration rate at surface (m/s)
8301 real (kind=kind_phys) :: fice !ice fraction in frozen soil
8302 real (kind=kind_phys) :: wplus !saturation excess of the total soil [m]
8303 real (kind=kind_phys) :: rsat !accumulation of wplus (saturation excess) [m]
8304 real (kind=kind_phys) :: sicemax!maximum soil ice content (m3/m3)
8305 real (kind=kind_phys) :: sh2omin!minimum soil liquid water content (m3/m3)
8306 real (kind=kind_phys) :: wtsub !sum of wcnd(k)*dzsnso(k)
8307 real (kind=kind_phys) :: mh2o !water mass removal (mm)
8308 real (kind=kind_phys) :: fsat !fractional saturated area (-)
8309 real (kind=kind_phys), dimension(1:nsoil) :: mliq !
8310 real (kind=kind_phys) :: xs !
8311 real (kind=kind_phys) :: watmin !
8312 real (kind=kind_phys) :: qdrain_save !
8313 real (kind=kind_phys) :: runsrf_save !
8314 real (kind=kind_phys) :: epore !effective porosity [m3/m3]
8315 real (kind=kind_phys), dimension(1:nsoil) :: fcr !impermeable fraction due to frozen soil
8316 integer :: niter !iteration times soil moisture (-)
8317 real (kind=kind_phys) :: smctot !2-m averaged soil moisture (m3/m3)
8318 real (kind=kind_phys) :: dztot !2-m soil depth (m)
8319 real (kind=kind_phys), parameter :: a = 4.0
8320! ----------------------------------------------------------------------
8321 runsrf = 0.0
8322 pddum = 0.0
8323 rsat = 0.0
8324
8325! for the case when snowmelt water is too large
8326
8327 do k = 1,nsoil
8328 epore = max( 1.e-4 , ( parameters%smcmax(k) - sice(k) ) )
8329 rsat = rsat + max(0.,sh2o(k)-epore)*dzsnso(k)
8330 sh2o(k) = min(epore,sh2o(k))
8331 end do
8332
8333!impermeable fraction due to frozen soil
8334
8335 do k = 1,nsoil
8336 fice = min(1.0,sice(k)/parameters%smcmax(k))
8337 fcr(k) = max(0.0,exp(-a*(1.-fice))- exp(-a)) / &
8338 (1.0 - exp(-a))
8339 end do
8340
8341! maximum soil ice content and minimum liquid water of all layers
8342
8343 sicemax = 0.0
8344 fcrmax = 0.0
8345 sh2omin = parameters%smcmax(1)
8346 do k = 1,nsoil
8347 if (sice(k) > sicemax) sicemax = sice(k)
8348 if (fcr(k) > fcrmax) fcrmax = fcr(k)
8349 if (sh2o(k) < sh2omin) sh2omin = sh2o(k)
8350 end do
8351
8352!subsurface runoff for runoff scheme option 2
8353
8354 if(opt_run == 2) then
8355 fff = 2.0
8356 rsbmx = 4.0
8357 call zwteq (parameters,nsoil ,nsnow ,zsoil ,dzsnso ,sh2o ,zwt)
8358 runsub = (1.0-fcrmax) * rsbmx * exp(-parameters%timean) * exp(-fff*zwt) ! mm/s
8359 end if
8360
8361!surface runoff and infiltration rate using different schemes
8362
8363!jref impermable surface at urban
8364 if ( parameters%urban_flag ) fcr(1)= 0.95
8365
8366 if(opt_run == 1) then
8367! fff = 6.0
8368 fff = parameters%bexp(1) / 3.0 ! calibratable, c.he changed based on gy niu's update
8369! fsat = parameters%fsatmx*exp(-0.5*fff*(zwt-2.0))
8370 fsat = parameters%fsatmx*exp(-0.5*fff*zwt) ! c.he changed based on gy niu's update
8371 if(qinsur > 0.) then
8372 runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) )
8373 pddum = qinsur - runsrf ! m/s
8374 end if
8375 end if
8376
8377 if(opt_run == 5) then
8378 fff = 6.0
8379 fsat = parameters%fsatmx*exp(-0.5*fff*max(-2.0-zwt,0.))
8380 if(qinsur > 0.) then
8381 runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) )
8382 pddum = qinsur - runsrf ! m/s
8383 end if
8384 end if
8385
8386 if(opt_run == 2) then
8387 fff = 2.0
8388 fsat = parameters%fsatmx*exp(-0.5*fff*zwt)
8389 if(qinsur > 0.) then
8390 runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) )
8391 pddum = qinsur - runsrf ! m/s
8392 end if
8393 end if
8394
8395 if(opt_run == 3) then
8396 call infil (parameters,nsoil ,dt ,zsoil ,sh2o ,sice , & !in
8397 sicemax,qinsur , & !in
8398 pddum ,runsrf ) !out
8399 end if
8400
8401 if(opt_run == 4) then
8402 smctot = 0.
8403 dztot = 0.
8404 do k = 1,nsoil
8405 dztot = dztot + dzsnso(k)
8406 smctot = smctot + smc(k)/parameters%smcmax(k)*dzsnso(k)
8407 if(dztot >= 2.0) exit
8408 end do
8409 smctot = smctot/dztot
8410 fsat = max(0.01,smctot) ** 4. !bats
8411
8412 if(qinsur > 0.) then
8413 runsrf = qinsur * ((1.0-fcr(1))*fsat+fcr(1))
8414 pddum = qinsur - runsrf ! m/s
8415 end if
8416 end if
8417
8418! determine iteration times and finer time step
8419
8420 niter = 1
8421
8422! if(opt_inf == 1) then !opt_inf =2 may cause water imbalance
8423 niter = 3
8424 if (pddum*dt>dzsnso(1)*parameters%smcmax(1) ) then
8425 niter = niter*2
8426 end if
8427! end if
8428
8429 dtfine = dt / niter
8430
8431! solve soil moisture
8432
8433 qdrain_save = 0.0
8434 runsrf_save = 0.0
8435 do iter = 1, niter
8436 if(qinsur > 0. .and. opt_run == 3) then
8437 call infil (parameters,nsoil ,dtfine ,zsoil ,sh2o ,sice , & !in
8438 sicemax,qinsur , & !in
8439 pddum ,runsrf ) !out
8440 end if
8441
8442 call srt (parameters,nsoil ,zsoil ,dtfine ,pddum ,etrani , & !in
8443 qseva ,sh2o ,smc ,zwt ,fcr , & !in
8444 sicemax,fcrmax ,iloc ,jloc ,smcwtd , & !in
8445 rhstt ,ai ,bi ,ci ,qdrain , & !out
8446 wcnd ) !out
8447
8448 call sstep (parameters,nsoil ,nsnow ,dtfine ,zsoil ,dzsnso , & !in
8449 sice ,iloc ,jloc ,zwt , & !in
8450 sh2o ,smc ,ai ,bi ,ci , & !inout
8451 rhstt ,smcwtd ,qdrain ,deeprech, & !inout
8452 wplus) !out
8453 rsat = rsat + wplus
8454 qdrain_save = qdrain_save + qdrain
8455 runsrf_save = runsrf_save + runsrf
8456 end do
8457
8458 qdrain = qdrain_save/niter
8459 runsrf = runsrf_save/niter
8460
8461 runsrf = runsrf * 1000. + rsat * 1000./dt ! m/s -> mm/s
8462 qdrain = qdrain * 1000.
8463
8464!wrf_hydro_djg...
8465!yw infxsrt = runsrf * dt !mm/s -> mm
8466
8467! removal of soil water due to groundwater flow (option 2)
8468
8469 if(opt_run == 2) then
8470 wtsub = 0.
8471 do k = 1, nsoil
8472 wtsub = wtsub + wcnd(k)*dzsnso(k)
8473 end do
8474
8475 do k = 1, nsoil
8476 mh2o = runsub*dt*(wcnd(k)*dzsnso(k))/wtsub ! mm
8477 sh2o(k) = sh2o(k) - mh2o/(dzsnso(k)*1000.)
8478 end do
8479 end if
8480
8481! limit mliq to be greater than or equal to watmin.
8482! get water needed to bring mliq equal watmin from lower layer.
8483
8484 if(opt_run /= 1) then
8485 do iz = 1, nsoil
8486 mliq(iz) = sh2o(iz)*dzsnso(iz)*1000.
8487 end do
8488
8489 watmin = 0.01 ! mm
8490 do iz = 1, nsoil-1
8491 if (mliq(iz) .lt. 0.) then
8492 xs = watmin-mliq(iz)
8493 else
8494 xs = 0.
8495 end if
8496 mliq(iz ) = mliq(iz ) + xs
8497 mliq(iz+1) = mliq(iz+1) - xs
8498 end do
8499
8500 iz = nsoil
8501 if (mliq(iz) .lt. watmin) then
8502 xs = watmin-mliq(iz)
8503 else
8504 xs = 0.
8505 end if
8506 mliq(iz) = mliq(iz) + xs
8507 runsub = runsub - xs/dt
8508 if(opt_run == 5)deeprech = deeprech - xs*1.e-3
8509
8510 do iz = 1, nsoil
8511 sh2o(iz) = mliq(iz) / (dzsnso(iz)*1000.)
8512 end do
8513 end if
8514
8515 end subroutine soilwater
8516
8517!== begin zwteq ====================================================================================
8518
8521 subroutine zwteq (parameters,nsoil ,nsnow ,zsoil ,dzsnso ,sh2o ,zwt)
8522! ----------------------------------------------------------------------
8523! calculate equilibrium water table depth (niu et al., 2005)
8524! ----------------------------------------------------------------------
8525 implicit none
8526! ----------------------------------------------------------------------
8527! input
8528
8529 type (noahmp_parameters), intent(in) :: parameters
8530 integer, intent(in) :: nsoil
8531 integer, intent(in) :: nsnow
8532 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: zsoil
8533 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
8534 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: sh2o
8535
8536! output
8537
8538 real (kind=kind_phys), intent(out) :: zwt
8539
8540! locals
8541
8542 integer :: k !do-loop index
8543 integer, parameter :: nfine = 100 !no. of fine soil layers of 6m soil
8544 real (kind=kind_phys) :: wd1 !water deficit from coarse (4-l) soil moisture profile
8545 real (kind=kind_phys) :: wd2 !water deficit from fine (100-l) soil moisture profile
8546 real (kind=kind_phys) :: dzfine !layer thickness of the 100-l soil layers to 6.0 m
8547 real (kind=kind_phys) :: temp !temporary variable
8548 real (kind=kind_phys), dimension(1:nfine) :: zfine !layer-bottom depth of the 100-l soil layers to 6.0 m
8549! ----------------------------------------------------------------------
8550
8551 wd1 = 0.
8552 do k = 1,nsoil
8553 wd1 = wd1 + (parameters%smcmax(1)-sh2o(k)) * dzsnso(k) ! [m]
8554 enddo
8555
8556 dzfine = 3.0 * (-zsoil(nsoil)) / nfine
8557 do k =1,nfine
8558 zfine(k) = float(k) * dzfine
8559 enddo
8560
8561 zwt = -3.*zsoil(nsoil) - 0.001 ! initial value [m]
8562
8563 wd2 = 0.
8564 do k = 1,nfine
8565 temp = 1. + (zwt-zfine(k))/parameters%psisat(1)
8566 wd2 = wd2 + parameters%smcmax(1)*(1.-temp**(-1./parameters%bexp(1)))*dzfine
8567 if(abs(wd2-wd1).le.0.01) then
8568 zwt = zfine(k)
8569 exit
8570 endif
8571 enddo
8572
8573 end subroutine zwteq
8574
8575!== begin infil ====================================================================================
8576
8579 subroutine infil (parameters,nsoil ,dt ,zsoil ,sh2o ,sice , & !in
8580 sicemax,qinsur , & !in
8581 pddum ,runsrf ) !out
8582! --------------------------------------------------------------------------------
8583! compute inflitration rate at soil surface and surface runoff
8584! --------------------------------------------------------------------------------
8585 implicit none
8586! --------------------------------------------------------------------------------
8587! inputs
8588 type (noahmp_parameters), intent(in) :: parameters
8589 integer, intent(in) :: nsoil
8590 real (kind=kind_phys), intent(in) :: dt
8591 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: zsoil
8592 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: sh2o
8593 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: sice
8594 real (kind=kind_phys), intent(in) :: qinsur
8595 real (kind=kind_phys), intent(in) :: sicemax
8596
8597! outputs
8598 real (kind=kind_phys), intent(out) :: runsrf
8599 real (kind=kind_phys), intent(out) :: pddum
8600
8601! locals
8602 integer :: ialp1, j, jj, k
8603 real (kind=kind_phys) :: val
8604 real (kind=kind_phys) :: ddt
8605 real (kind=kind_phys) :: px
8606 real (kind=kind_phys) :: dt1, dd, dice
8607 real (kind=kind_phys) :: fcr
8608 real (kind=kind_phys) :: sum
8609 real (kind=kind_phys) :: acrt
8610 real (kind=kind_phys) :: wdf
8611 real (kind=kind_phys) :: wcnd
8612 real (kind=kind_phys) :: smcav
8613 real (kind=kind_phys) :: infmax
8614 real (kind=kind_phys), dimension(1:nsoil) :: dmax
8615 integer, parameter :: cvfrz = 3
8616! --------------------------------------------------------------------------------
8617
8618 if (qinsur > 0.0) then
8619 dt1 = dt /86400.
8620 smcav = parameters%smcmax(1) - parameters%smcwlt(1)
8621
8622! maximum infiltration rate
8623
8624 dmax(1)= -zsoil(1) * smcav
8625 dice = -zsoil(1) * sice(1)
8626 dmax(1)= dmax(1)* (1.0-(sh2o(1) + sice(1) - parameters%smcwlt(1))/smcav)
8627
8628 dd = dmax(1)
8629
8630 do k = 2,nsoil
8631 dice = dice + (zsoil(k-1) - zsoil(k) ) * sice(k)
8632 dmax(k) = (zsoil(k-1) - zsoil(k)) * smcav
8633 dmax(k) = dmax(k) * (1.0-(sh2o(k) + sice(k) - parameters%smcwlt(k))/smcav)
8634 dd = dd + dmax(k)
8635 end do
8636
8637 val = (1. - exp( - parameters%kdt * dt1))
8638 ddt = dd * val
8639 px = max(0.,qinsur * dt)
8640 infmax = (px * (ddt / (px + ddt)))/ dt
8641
8642! impermeable fraction due to frozen soil
8643
8644 fcr = 1.
8645 if (dice > 1.e-2) then
8646 acrt = cvfrz * parameters%frzx / dice
8647 sum = 1.
8648 ialp1 = cvfrz - 1
8649 do j = 1,ialp1
8650 k = 1
8651 do jj = j +1,ialp1
8652 k = k * jj
8653 end do
8654 sum = sum + (acrt ** (cvfrz - j)) / float(k)
8655 end do
8656 fcr = 1. - exp(-acrt) * sum
8657 end if
8658
8659! correction of infiltration limitation
8660
8661 infmax = infmax * fcr
8662
8663! jref for urban areas
8664! if ( parameters%urban_flag ) infmax == infmax * 0.05
8665
8666 call wdfcnd2 (parameters,wdf,wcnd,sh2o(1),sicemax,1)
8667 infmax = max(infmax,wcnd)
8668 infmax = min(infmax,px/dt)
8669
8670 runsrf= max(0., qinsur - infmax)
8671 pddum = qinsur - runsrf
8672
8673 end if
8674
8675 end subroutine infil
8676
8677!== begin srt ======================================================================================
8678
8683 subroutine srt (parameters,nsoil ,zsoil ,dt ,pddum ,etrani , & !in
8684 qseva ,sh2o ,smc ,zwt ,fcr , & !in
8685 sicemax,fcrmax ,iloc ,jloc ,smcwtd , & !in
8686 rhstt ,ai ,bi ,ci ,qdrain , & !out
8687 wcnd ) !out
8688! ----------------------------------------------------------------------
8689! calculate the right hand side of the time tendency term of the soil
8690! water diffusion equation. also to compute ( prepare ) the matrix
8691! coefficients for the tri-diagonal matrix of the implicit time scheme.
8692! ----------------------------------------------------------------------
8693 implicit none
8694! ----------------------------------------------------------------------
8695!input
8696
8697 type (noahmp_parameters), intent(in) :: parameters
8698 integer, intent(in) :: iloc !grid index
8699 integer, intent(in) :: jloc !grid index
8700 integer, intent(in) :: nsoil
8701 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: zsoil
8702 real (kind=kind_phys), intent(in) :: dt
8703 real (kind=kind_phys), intent(in) :: pddum
8704 real (kind=kind_phys), intent(in) :: qseva
8705 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: etrani
8706 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: sh2o
8707 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: smc
8708 real (kind=kind_phys), intent(in) :: zwt ! water table depth [m]
8709 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: fcr
8710 real (kind=kind_phys), intent(in) :: fcrmax !maximum of fcr (-)
8711 real (kind=kind_phys), intent(in) :: sicemax!maximum soil ice content (m3/m3)
8712 real (kind=kind_phys), intent(in) :: smcwtd !soil moisture between bottom of the soil and the water table
8713
8714! output
8715
8716 real (kind=kind_phys), dimension(1:nsoil), intent(out) :: rhstt
8717 real (kind=kind_phys), dimension(1:nsoil), intent(out) :: ai
8718 real (kind=kind_phys), dimension(1:nsoil), intent(out) :: bi
8719 real (kind=kind_phys), dimension(1:nsoil), intent(out) :: ci
8720 real (kind=kind_phys), dimension(1:nsoil), intent(out) :: wcnd !hydraulic conductivity (m/s)
8721 real (kind=kind_phys), intent(out) :: qdrain !bottom drainage (m/s)
8722
8723! local
8724 integer :: k
8725 real (kind=kind_phys), dimension(1:nsoil) :: ddz
8726 real (kind=kind_phys), dimension(1:nsoil) :: denom
8727 real (kind=kind_phys), dimension(1:nsoil) :: dsmdz
8728 real (kind=kind_phys), dimension(1:nsoil) :: wflux
8729 real (kind=kind_phys), dimension(1:nsoil) :: wdf
8730 real (kind=kind_phys), dimension(1:nsoil) :: smx
8731 real (kind=kind_phys) :: temp1
8732 real (kind=kind_phys) :: smxwtd !soil moisture between bottom of the soil and water table
8733 real (kind=kind_phys) :: smxbot !soil moisture below bottom to calculate flux
8734
8735! niu and yang (2006), j. of hydrometeorology
8736! ----------------------------------------------------------------------
8737
8738 if(opt_inf == 1) then
8739 do k = 1, nsoil
8740 call wdfcnd1 (parameters,wdf(k),wcnd(k),smc(k),fcr(k),k)
8741 smx(k) = smc(k)
8742 end do
8743 if(opt_run == 5)smxwtd=smcwtd
8744 end if
8745
8746 if(opt_inf == 2) then
8747 do k = 1, nsoil
8748 call wdfcnd2 (parameters,wdf(k),wcnd(k),sh2o(k),sicemax,k)
8749 smx(k) = sh2o(k)
8750 end do
8751 if(opt_run == 5)smxwtd=smcwtd*sh2o(nsoil)/smc(nsoil) !same liquid fraction as in the bottom layer
8752 end if
8753
8754 do k = 1, nsoil
8755 if(k == 1) then
8756 denom(k) = - zsoil(k)
8757 temp1 = - zsoil(k+1)
8758 ddz(k) = 2.0 / temp1
8759 dsmdz(k) = 2.0 * (smx(k) - smx(k+1)) / temp1
8760 wflux(k) = wdf(k) * dsmdz(k) + wcnd(k) - pddum + etrani(k) + qseva
8761 else if (k < nsoil) then
8762 denom(k) = (zsoil(k-1) - zsoil(k))
8763 temp1 = (zsoil(k-1) - zsoil(k+1))
8764 ddz(k) = 2.0 / temp1
8765 dsmdz(k) = 2.0 * (smx(k) - smx(k+1)) / temp1
8766 wflux(k) = wdf(k ) * dsmdz(k ) + wcnd(k ) &
8767 - wdf(k-1) * dsmdz(k-1) - wcnd(k-1) + etrani(k)
8768 else
8769 denom(k) = (zsoil(k-1) - zsoil(k))
8770 if(opt_run == 1 .or. opt_run == 2) then
8771 qdrain = 0.
8772 end if
8773 if(opt_run == 3) then
8774 qdrain = parameters%slope*wcnd(k)
8775 end if
8776 if(opt_run == 4) then
8777 qdrain = (1.0-fcrmax)*wcnd(k)
8778 end if
8779 if(opt_run == 5) then !gmm new m-m&f water table dynamics formulation
8780 temp1 = 2.0 * denom(k)
8781 if(zwt < zsoil(nsoil)-denom(nsoil))then
8782!gmm interpolate from below, midway to the water table, to the middle of the auxiliary layer below the soil bottom
8783 smxbot = smx(k) - (smx(k)-smxwtd) * denom(k) * 2./ (denom(k) + zsoil(k) - zwt)
8784 else
8785 smxbot = smxwtd
8786 endif
8787 dsmdz(k) = 2.0 * (smx(k) - smxbot) / temp1
8788 qdrain = wdf(k ) * dsmdz(k ) + wcnd(k )
8789 end if
8790 wflux(k) = -(wdf(k-1)*dsmdz(k-1))-wcnd(k-1)+etrani(k) + qdrain
8791 end if
8792 end do
8793
8794 do k = 1, nsoil
8795 if(k == 1) then
8796 ai(k) = 0.0
8797 bi(k) = wdf(k ) * ddz(k ) / denom(k)
8798 ci(k) = - bi(k)
8799 else if (k < nsoil) then
8800 ai(k) = - wdf(k-1) * ddz(k-1) / denom(k)
8801 ci(k) = - wdf(k ) * ddz(k ) / denom(k)
8802 bi(k) = - ( ai(k) + ci(k) )
8803 else
8804 ai(k) = - wdf(k-1) * ddz(k-1) / denom(k)
8805 ci(k) = 0.0
8806 bi(k) = - ( ai(k) + ci(k) )
8807 end if
8808 rhstt(k) = wflux(k) / (-denom(k))
8809 end do
8810
8811! ----------------------------------------------------------------------
8812 end subroutine srt
8813
8814!== begin sstep ====================================================================================
8815
8818 subroutine sstep (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in
8819 sice ,iloc ,jloc ,zwt , & !in
8820 sh2o ,smc ,ai ,bi ,ci , & !inout
8821 rhstt ,smcwtd ,qdrain ,deeprech, & !inout
8822 wplus ) !out
8823
8824! ----------------------------------------------------------------------
8825! calculate/update soil moisture content values
8826! ----------------------------------------------------------------------
8827 implicit none
8828! ----------------------------------------------------------------------
8829!input
8830
8831 type (noahmp_parameters), intent(in) :: parameters
8832 integer, intent(in) :: iloc !grid index
8833 integer, intent(in) :: jloc !grid index
8834 integer, intent(in) :: nsoil !
8835 integer, intent(in) :: nsnow !
8836 real (kind=kind_phys), intent(in) :: dt
8837 real (kind=kind_phys), intent(in) :: zwt
8838 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil
8839 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: sice
8840 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso ! snow/soil layer thickness [m]
8841
8842!input and output
8843 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: sh2o
8844 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: smc
8845 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: ai
8846 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: bi
8847 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: ci
8848 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: rhstt
8849 real (kind=kind_phys) , intent(inout) :: smcwtd
8850 real (kind=kind_phys) , intent(inout) :: qdrain
8851 real (kind=kind_phys) , intent(inout) :: deeprech
8852
8853!output
8854 real (kind=kind_phys), intent(out) :: wplus !saturation excess water (m)
8855
8856!local
8857 integer :: k
8858 real (kind=kind_phys), dimension(1:nsoil) :: rhsttin
8859 real (kind=kind_phys), dimension(1:nsoil) :: ciin
8860 real (kind=kind_phys) :: stot
8861 real (kind=kind_phys) :: epore
8862 real (kind=kind_phys) :: wminus
8863! ----------------------------------------------------------------------
8864 wplus = 0.0
8865
8866 do k = 1,nsoil
8867 rhstt(k) = rhstt(k) * dt
8868 ai(k) = ai(k) * dt
8869 bi(k) = 1. + bi(k) * dt
8870 ci(k) = ci(k) * dt
8871 end do
8872
8873! copy values for input variables before calling rosr12
8874
8875 do k = 1,nsoil
8876 rhsttin(k) = rhstt(k)
8877 ciin(k) = ci(k)
8878 end do
8879
8880! call rosr12 to solve the tri-diagonal matrix
8881
8882 call rosr12 (ci,ai,bi,ciin,rhsttin,rhstt,1,nsoil,0)
8883
8884 do k = 1,nsoil
8885 sh2o(k) = sh2o(k) + ci(k)
8886 enddo
8887
8888! excessive water above saturation in a layer is moved to
8889! its unsaturated layer like in a bucket
8890
8891!gmmwith opt_run=5 there is soil moisture below nsoil, to the water table
8892 if(opt_run == 5) then
8893
8894!update smcwtd
8895
8896 if(zwt < zsoil(nsoil)-dzsnso(nsoil))then
8897!accumulate qdrain to update deep water table and soil moisture later
8898 deeprech = deeprech + dt * qdrain
8899 else
8900 smcwtd = smcwtd + dt * qdrain / dzsnso(nsoil)
8901 wplus = max((smcwtd-parameters%smcmax(nsoil)), 0.0) * dzsnso(nsoil)
8902 wminus = max((1.e-4-smcwtd), 0.0) * dzsnso(nsoil)
8903
8904 smcwtd = max( min(smcwtd,parameters%smcmax(nsoil)) , 1.e-4)
8905 sh2o(nsoil) = sh2o(nsoil) + wplus/dzsnso(nsoil)
8906
8907!reduce fluxes at the bottom boundaries accordingly
8908 qdrain = qdrain - wplus/dt
8909 deeprech = deeprech - wminus
8910 endif
8911
8912 endif
8913
8914 do k = nsoil,2,-1
8915 epore = max( 1.e-4 , ( parameters%smcmax(k) - sice(k) ) )
8916 wplus = max((sh2o(k)-epore), 0.0) * dzsnso(k)
8917 sh2o(k) = min(epore,sh2o(k))
8918 sh2o(k-1) = sh2o(k-1) + wplus/dzsnso(k-1)
8919 end do
8920
8921 epore = max( 1.e-4 , ( parameters%smcmax(1) - sice(1) ) )
8922 wplus = max((sh2o(1)-epore), 0.0) * dzsnso(1)
8923 sh2o(1) = min(epore,sh2o(1))
8924
8925 if(wplus > 0.0) then
8926 sh2o(2) = sh2o(2) + wplus/dzsnso(2)
8927 do k = 2,nsoil-1
8928 epore = max( 1.e-4 , ( parameters%smcmax(k) - sice(k) ) )
8929 wplus = max((sh2o(k)-epore), 0.0) * dzsnso(k)
8930 sh2o(k) = min(epore,sh2o(k))
8931 sh2o(k+1) = sh2o(k+1) + wplus/dzsnso(k+1)
8932 end do
8933
8934 epore = max( 1.e-4 , ( parameters%smcmax(nsoil) - sice(nsoil) ) )
8935 wplus = max((sh2o(nsoil)-epore), 0.0) * dzsnso(nsoil)
8936 sh2o(nsoil) = min(epore,sh2o(nsoil))
8937 end if
8938
8939 smc = sh2o + sice
8940
8941 end subroutine sstep
8942
8943!== begin wdfcnd1 ==================================================================================
8944
8947 subroutine wdfcnd1 (parameters,wdf,wcnd,smc,fcr,isoil)
8948! ----------------------------------------------------------------------
8949! calculate soil water diffusivity and soil hydraulic conductivity.
8950! ----------------------------------------------------------------------
8951 implicit none
8952! ----------------------------------------------------------------------
8953! input
8954 type (noahmp_parameters), intent(in) :: parameters
8955 real (kind=kind_phys),intent(in) :: smc
8956 real (kind=kind_phys),intent(in) :: fcr
8957 integer,intent(in) :: isoil
8958
8959! output
8960 real (kind=kind_phys),intent(out) :: wcnd
8961 real (kind=kind_phys),intent(out) :: wdf
8962
8963! local
8964 real (kind=kind_phys) :: expon
8965 real (kind=kind_phys) :: factr
8966 real (kind=kind_phys) :: vkwgt
8967! ----------------------------------------------------------------------
8968
8969! soil water diffusivity
8970
8971 factr = max(0.01, smc/parameters%smcmax(isoil))
8972 expon = parameters%bexp(isoil) + 2.0
8973 wdf = parameters%dwsat(isoil) * factr ** expon
8974 wdf = wdf * (1.0 - fcr)
8975
8976! hydraulic conductivity
8977
8978 expon = 2.0*parameters%bexp(isoil) + 3.0
8979 wcnd = parameters%dksat(isoil) * factr ** expon
8980 wcnd = wcnd * (1.0 - fcr)
8981
8982 end subroutine wdfcnd1
8983
8984!== begin wdfcnd2 ==================================================================================
8985
8988 subroutine wdfcnd2 (parameters,wdf,wcnd,smc,sice,isoil)
8989! ----------------------------------------------------------------------
8990! calculate soil water diffusivity and soil hydraulic conductivity.
8991! ----------------------------------------------------------------------
8992 implicit none
8993! ----------------------------------------------------------------------
8994! input
8995 type (noahmp_parameters), intent(in) :: parameters
8996 real (kind=kind_phys),intent(in) :: smc
8997 real (kind=kind_phys),intent(in) :: sice
8998 integer,intent(in) :: isoil
8999
9000! output
9001 real (kind=kind_phys),intent(out) :: wcnd
9002 real (kind=kind_phys),intent(out) :: wdf
9003
9004! local
9005 real (kind=kind_phys) :: expon
9006 real (kind=kind_phys) :: factr1,factr2
9007 real (kind=kind_phys) :: vkwgt
9008! ----------------------------------------------------------------------
9009
9010! soil water diffusivity
9011
9012 factr1 = 0.05/parameters%smcmax(isoil)
9013 factr2 = max(0.01, smc/parameters%smcmax(isoil))
9014 factr1 = min(factr1,factr2)
9015 expon = parameters%bexp(isoil) + 2.0
9016 wdf = parameters%dwsat(isoil) * factr2 ** expon
9017
9018 if (sice > 0.0) then
9019 vkwgt = 1./ (1. + (500.* sice)**3.)
9020 wdf = vkwgt * wdf + (1.-vkwgt)*parameters%dwsat(isoil)*(factr1)**expon
9021 end if
9022
9023! hydraulic conductivity
9024
9025 expon = 2.0*parameters%bexp(isoil) + 3.0
9026 wcnd = parameters%dksat(isoil) * factr2 ** expon
9027
9028 end subroutine wdfcnd2
9029
9030!== begin groundwater ==============================================================================
9031
9034 subroutine groundwater(parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in
9035 stc ,wcnd ,fcrmax ,iloc ,jloc , & !in
9036 sh2o ,zwt ,wa ,wt , & !inout
9037 qin ,qdis ) !out
9038! ----------------------------------------------------------------------
9039 implicit none
9040! ----------------------------------------------------------------------
9041! input
9042 type (noahmp_parameters), intent(in) :: parameters
9043 integer, intent(in) :: iloc !grid index
9044 integer, intent(in) :: jloc !grid index
9045 integer, intent(in) :: nsnow !maximum no. of snow layers
9046 integer, intent(in) :: nsoil !no. of soil layers
9047 real (kind=kind_phys), intent(in) :: dt !timestep [sec]
9048 real (kind=kind_phys), intent(in) :: fcrmax!maximum fcr (-)
9049 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: sice !soil ice content [m3/m3]
9050 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m]
9051 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: wcnd !hydraulic conductivity (m/s)
9052 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature (k)
9053
9054! input and output
9055 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sh2o !liquid soil water [m3/m3]
9056 real (kind=kind_phys), intent(inout) :: zwt !the depth to water table [m]
9057 real (kind=kind_phys), intent(inout) :: wa !water storage in aquifer [mm]
9058 real (kind=kind_phys), intent(inout) :: wt !water storage in aquifer
9059 !+ saturated soil [mm]
9060! output
9061 real (kind=kind_phys), intent(out) :: qin !groundwater recharge [mm/s]
9062 real (kind=kind_phys), intent(out) :: qdis !groundwater discharge [mm/s]
9063
9064! local
9065 real (kind=kind_phys) :: fff !runoff decay factor (m-1)
9066 real (kind=kind_phys) :: rsbmx !baseflow coefficient [mm/s]
9067 integer :: iz !do-loop index
9068 integer :: iwt !layer index above water table layer
9069 real (kind=kind_phys), dimension( 1:nsoil) :: dzmm !layer thickness [mm]
9070 real (kind=kind_phys), dimension( 1:nsoil) :: znode !node depth [m]
9071 real (kind=kind_phys), dimension( 1:nsoil) :: mliq !liquid water mass [kg/m2 or mm]
9072 real (kind=kind_phys), dimension( 1:nsoil) :: epore !effective porosity [-]
9073 real (kind=kind_phys), dimension( 1:nsoil) :: hk !hydraulic conductivity [mm/s]
9074 real (kind=kind_phys), dimension( 1:nsoil) :: smc !total soil water content [m3/m3]
9075 real (kind=kind_phys) :: s_node!degree of saturation of iwt layer
9076 real (kind=kind_phys) :: dzsum !cumulative depth above water table [m]
9077 real (kind=kind_phys) :: smpfz !matric potential (frozen effects) [mm]
9078 real (kind=kind_phys) :: ka !aquifer hydraulic conductivity [mm/s]
9079 real (kind=kind_phys) :: wh_zwt!water head at water table [mm]
9080 real (kind=kind_phys) :: wh !water head at layer above zwt [mm]
9081 real (kind=kind_phys) :: ws !water used to fill air pore [mm]
9082 real (kind=kind_phys) :: wtsub !sum of hk*dzmm
9083 real (kind=kind_phys) :: watmin!minimum soil vol soil moisture [m3/m3]
9084 real (kind=kind_phys) :: xs !excessive water above saturation [mm]
9085 real (kind=kind_phys), parameter :: rous = 0.2 !specific yield [-]
9086! real (kind=kind_phys), parameter :: cmic = 0.20 !microprore content (0.0-1.0)
9087 !0.0-close to free drainage
9088 real (kind=kind_phys), parameter :: cmic = 0.80 ! calibratable, c.he changed based on gy niu's update
9089! -------------------------------------------------------------
9090 qdis = 0.0
9091 qin = 0.0
9092
9093! derive layer-bottom depth in [mm]
9094!kwm: derive layer thickness in mm
9095
9096 dzmm(1) = -zsoil(1)*1.e3
9097 do iz = 2, nsoil
9098 dzmm(iz) = 1.e3 * (zsoil(iz - 1) - zsoil(iz))
9099 enddo
9100
9101! derive node (middle) depth in [m]
9102!kwm: positive number, depth below ground surface in m
9103 znode(1) = -zsoil(1) / 2.
9104 do iz = 2, nsoil
9105 znode(iz) = -zsoil(iz-1) + 0.5 * (zsoil(iz-1) - zsoil(iz))
9106 enddo
9107
9108! convert volumetric soil moisture "sh2o" to mass
9109
9110 do iz = 1, nsoil
9111 smc(iz) = sh2o(iz) + sice(iz)
9112 mliq(iz) = sh2o(iz) * dzmm(iz)
9113 epore(iz) = max(0.01,parameters%smcmax(iz) - sice(iz))
9114 hk(iz) = 1.e3*wcnd(iz)
9115 enddo
9116
9117! the layer index of the first unsaturated layer,
9118! i.e., the layer right above the water table
9119
9120 iwt = nsoil
9121 do iz = 2,nsoil
9122 if(zwt .le. -zsoil(iz) ) then
9123 iwt = iz-1
9124 exit
9125 end if
9126 enddo
9127
9128! groundwater discharge [mm/s]
9129
9130! fff = 6.0
9131! rsbmx = 5.0
9132 fff = parameters%bexp(iwt) / 3.0 ! calibratable, c.he changed based on gy niu's update
9133 rsbmx = hk(iwt) * 1.0e3 * exp(3.0) ! mm/s, calibratable, c.he changed based on gy niu's update
9134
9135! qdis = (1.0-fcrmax)*rsbmx*exp(-parameters%timean)*exp(-fff*(zwt-2.0))
9136 qdis = (1.0-fcrmax)*rsbmx*exp(-parameters%timean)*exp(-fff*zwt) ! c.he changed based on gy niu's update
9137
9138! matric potential at the layer above the water table
9139
9140 s_node = min(1.0,smc(iwt)/parameters%smcmax(iwt) )
9141 s_node = max(s_node,real(0.01,kind=8))
9142 smpfz = -parameters%psisat(iwt)*1000.*s_node**(-parameters%bexp(iwt)) ! m --> mm
9143 smpfz = max(-120000.0,cmic*smpfz)
9144
9145! recharge rate qin to groundwater
9146
9147 ka = 0.5*(hk(iwt)+parameters%dksat(iwt)*1.0e3)
9148
9149 wh_zwt = - zwt * 1.e3 !(mm)
9150 wh = smpfz - znode(iwt)*1.e3 !(mm)
9151 qin = - ka * (wh_zwt-wh) /((zwt-znode(iwt))*1.e3)
9152 qin = max(-10.0/dt,min(10./dt,qin))
9153
9154! water storage in the aquifer + saturated soil
9155
9156 wt = wt + (qin - qdis) * dt !(mm)
9157
9158 if(iwt.eq.nsoil) then
9159 wa = wa + (qin - qdis) * dt !(mm)
9160 wt = wa
9161 zwt = (-zsoil(nsoil) + 25.) - wa/1000./rous !(m)
9162 mliq(nsoil) = mliq(nsoil) - qin * dt ! [mm]
9163
9164 mliq(nsoil) = mliq(nsoil) + max(0.,(wa - 5000.))
9165 wa = min(wa, 5000.)
9166 else
9167
9168 if (iwt.eq.nsoil-1) then
9169 zwt = -zsoil(nsoil) &
9170 - (wt-rous*1000*25.) / (epore(nsoil))/1000.
9171 else
9172 ws = 0. ! water used to fill soil air pores
9173 do iz = iwt+2,nsoil
9174 ws = ws + epore(iz) * dzmm(iz)
9175 enddo
9176 zwt = -zsoil(iwt+1) &
9177 - (wt-rous*1000.*25.-ws) /(epore(iwt+1))/1000.
9178 endif
9179
9180 wtsub = 0.
9181 do iz = 1, nsoil
9182 wtsub = wtsub + hk(iz)*dzmm(iz)
9183 end do
9184
9185 do iz = 1, nsoil ! removing subsurface runoff
9186 mliq(iz) = mliq(iz) - qdis*dt*hk(iz)*dzmm(iz)/wtsub
9187 end do
9188 end if
9189
9190 zwt = max(1.5,zwt)
9191
9192!
9193! limit mliq to be greater than or equal to watmin.
9194! get water needed to bring mliq equal watmin from lower layer.
9195!
9196 watmin = 0.01
9197 do iz = 1, nsoil-1
9198 if (mliq(iz) .lt. 0.) then
9199 xs = watmin-mliq(iz)
9200 else
9201 xs = 0.
9202 end if
9203 mliq(iz ) = mliq(iz ) + xs
9204 mliq(iz+1) = mliq(iz+1) - xs
9205 end do
9206
9207 iz = nsoil
9208 if (mliq(iz) .lt. watmin) then
9209 xs = watmin-mliq(iz)
9210 else
9211 xs = 0.
9212 end if
9213 mliq(iz) = mliq(iz) + xs
9214 wa = wa - xs
9215 wt = wt - xs
9216
9217 do iz = 1, nsoil
9218 sh2o(iz) = mliq(iz) / dzmm(iz)
9219 end do
9220
9221 end subroutine groundwater
9222
9223!== begin shallowwatertable ========================================================================
9224
9228 subroutine shallowwatertable (parameters,nsnow ,nsoil ,zsoil, dt , & !in
9229 dzsnso ,smceq ,iloc ,jloc , & !in
9230 smc ,wtd ,smcwtd ,rech, qdrain ) !inout
9231! ----------------------------------------------------------------------
9232!diagnoses water table depth and computes recharge when the water table is within the resolved soil layers,
9233!according to the miguez-macho&fan scheme
9234! ----------------------------------------------------------------------
9235 implicit none
9236! ----------------------------------------------------------------------
9237! input
9238 type (noahmp_parameters), intent(in) :: parameters
9239 integer, intent(in) :: nsnow !maximum no. of snow layers
9240 integer, intent(in) :: nsoil !no. of soil layers
9241 integer, intent(in) :: iloc,jloc
9242 real (kind=kind_phys), intent(in) :: dt
9243 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m]
9244 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso ! snow/soil layer thickness [m]
9245 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smceq !equilibrium soil water content [m3/m3]
9246
9247! input and output
9248 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: smc !total soil water content [m3/m3]
9249 real (kind=kind_phys), intent(inout) :: wtd !the depth to water table [m]
9250 real (kind=kind_phys), intent(inout) :: smcwtd !soil moisture between bottom of the soil and the water table [m3/m3]
9251 real (kind=kind_phys), intent(out) :: rech ! groundwater recharge (net vertical flux across the water table), positive up
9252 real (kind=kind_phys), intent(inout) :: qdrain
9253
9254! local
9255 integer :: iz !do-loop index
9256 integer :: iwtd !layer index above water table layer
9257 integer :: kwtd !layer index where the water table layer is
9258 real (kind=kind_phys) :: wtdold
9259 real (kind=kind_phys) :: dzup
9260 real (kind=kind_phys) :: smceqdeep
9261 real (kind=kind_phys), dimension( 0:nsoil) :: zsoil0
9262! -------------------------------------------------------------
9263
9264
9265zsoil0(1:nsoil) = zsoil(1:nsoil)
9266zsoil0(0) = 0.
9267
9268!find the layer where the water table is
9269 do iz=nsoil,1,-1
9270 if(wtd + 1.e-6 < zsoil0(iz)) exit
9271 enddo
9272 iwtd=iz
9273
9274
9275 kwtd=iwtd+1 !layer where the water table is
9276 if(kwtd.le.nsoil)then !wtd in the resolved layers
9277 wtdold=wtd
9278 if(smc(kwtd).gt.smceq(kwtd))then
9279
9280 if(smc(kwtd).eq.parameters%smcmax(kwtd))then !wtd went to the layer above
9281 wtd=zsoil0(iwtd)
9282 rech=-(wtdold-wtd) * (parameters%smcmax(kwtd)-smceq(kwtd))
9283 iwtd=iwtd-1
9284 kwtd=kwtd-1
9285 if(kwtd.ge.1)then
9286 if(smc(kwtd).gt.smceq(kwtd))then
9287 wtdold=wtd
9288 wtd = min( ( smc(kwtd)*dzsnso(kwtd) &
9289 - smceq(kwtd)*zsoil0(iwtd) + parameters%smcmax(kwtd)*zsoil0(kwtd) ) / &
9290 ( parameters%smcmax(kwtd)-smceq(kwtd) ), zsoil0(iwtd))
9291 rech=rech-(wtdold-wtd) * (parameters%smcmax(kwtd)-smceq(kwtd))
9292 endif
9293 endif
9294 else !wtd stays in the layer
9295 wtd = min( ( smc(kwtd)*dzsnso(kwtd) &
9296 - smceq(kwtd)*zsoil0(iwtd) + parameters%smcmax(kwtd)*zsoil0(kwtd) ) / &
9297 ( parameters%smcmax(kwtd)-smceq(kwtd) ), zsoil0(iwtd))
9298 rech=-(wtdold-wtd) * (parameters%smcmax(kwtd)-smceq(kwtd))
9299 endif
9300
9301 else !wtd has gone down to the layer below
9302 wtd=zsoil0(kwtd)
9303 rech=-(wtdold-wtd) * (parameters%smcmax(kwtd)-smceq(kwtd))
9304 kwtd=kwtd+1
9305 iwtd=iwtd+1
9306!wtd crossed to the layer below. now adjust it there
9307 if(kwtd.le.nsoil)then
9308 wtdold=wtd
9309 if(smc(kwtd).gt.smceq(kwtd))then
9310 wtd = min( ( smc(kwtd)*dzsnso(kwtd) &
9311 - smceq(kwtd)*zsoil0(iwtd) + parameters%smcmax(kwtd)*zsoil0(kwtd) ) / &
9312 ( parameters%smcmax(kwtd)-smceq(kwtd) ) , zsoil0(iwtd) )
9313 else
9314 wtd=zsoil0(kwtd)
9315 endif
9316 rech = rech - (wtdold-wtd) * &
9317 (parameters%smcmax(kwtd)-smceq(kwtd))
9318
9319 else
9320 wtdold=wtd
9321!restore smoi to equilibrium value with water from the ficticious layer below
9322! smcwtd=smcwtd-(smceq(nsoil)-smc(nsoil))
9323! qdrain = qdrain - 1000 * (smceq(nsoil)-smc(nsoil)) * dzsnso(nsoil) / dt
9324! smc(nsoil)=smceq(nsoil)
9325!adjust wtd in the ficticious layer below
9326 smceqdeep = parameters%smcmax(nsoil) * ( -parameters%psisat(nsoil) / ( -parameters%psisat(nsoil) - dzsnso(nsoil) ) ) ** (1./parameters%bexp(nsoil))
9327 wtd = min( ( smcwtd*dzsnso(nsoil) &
9328 - smceqdeep*zsoil0(nsoil) + parameters%smcmax(nsoil)*(zsoil0(nsoil)-dzsnso(nsoil)) ) / &
9329 ( parameters%smcmax(nsoil)-smceqdeep ) , zsoil0(nsoil) )
9330 rech = rech - (wtdold-wtd) * &
9331 (parameters%smcmax(nsoil)-smceqdeep)
9332 endif
9333
9334 endif
9335 elseif(wtd.ge.zsoil0(nsoil)-dzsnso(nsoil))then
9336!if wtd was already below the bottom of the resolved soil crust
9337 wtdold=wtd
9338 smceqdeep = parameters%smcmax(nsoil) * ( -parameters%psisat(nsoil) / ( -parameters%psisat(nsoil) - dzsnso(nsoil) ) ) ** (1./parameters%bexp(nsoil))
9339 if(smcwtd.gt.smceqdeep)then
9340 wtd = min( ( smcwtd*dzsnso(nsoil) &
9341 - smceqdeep*zsoil0(nsoil) + parameters%smcmax(nsoil)*(zsoil0(nsoil)-dzsnso(nsoil)) ) / &
9342 ( parameters%smcmax(nsoil)-smceqdeep ) , zsoil0(nsoil) )
9343 rech = -(wtdold-wtd) * (parameters%smcmax(nsoil)-smceqdeep)
9344 else
9345 rech = -(wtdold-(zsoil0(nsoil)-dzsnso(nsoil))) * (parameters%smcmax(nsoil)-smceqdeep)
9346 wtdold=zsoil0(nsoil)-dzsnso(nsoil)
9347!and now even further down
9348 dzup=(smceqdeep-smcwtd)*dzsnso(nsoil)/(parameters%smcmax(nsoil)-smceqdeep)
9349 wtd=wtdold-dzup
9350 rech = rech - (parameters%smcmax(nsoil)-smceqdeep)*dzup
9351 smcwtd=smceqdeep
9352 endif
9353
9354
9355 endif
9356
9357if(iwtd.lt.nsoil .and. iwtd.gt.0) then
9358 smcwtd=parameters%smcmax(iwtd)
9359elseif(iwtd.lt.nsoil .and. iwtd.le.0) then
9360 smcwtd=parameters%smcmax(1)
9361end if
9362
9363end subroutine shallowwatertable
9364
9365! ==================================================================================================
9366! ********************* end of water subroutines ******************************************
9367! ==================================================================================================
9368
9369!== begin carbon ===================================================================================
9370
9373 subroutine carbon (parameters,nsnow ,nsoil ,vegtyp ,dt ,zsoil , & !in
9374 dzsnso ,stc ,smc ,tv ,tg ,psn , & !in
9375 foln ,btran ,apar ,fveg ,igs , & !in
9376 troot ,ist ,lat ,iloc ,jloc , & !in
9377 lfmass ,rtmass ,stmass ,wood ,stblcp ,fastcp , & !inout
9378 gpp ,npp ,nee ,autors ,heters ,totsc , & !out
9379 totlb ,xlai ,xsai ) !out
9380! ------------------------------------------------------------------------------------------
9381 implicit none
9382! ------------------------------------------------------------------------------------------
9383! inputs (carbon)
9384
9385 type (noahmp_parameters), intent(in) :: parameters
9386 integer , intent(in) :: iloc !grid index
9387 integer , intent(in) :: jloc !grid index
9388 integer , intent(in) :: vegtyp !vegetation type
9389 integer , intent(in) :: nsnow !number of snow layers
9390 integer , intent(in) :: nsoil !number of soil layers
9391 real (kind=kind_phys) , intent(in) :: lat !latitude (radians)
9392 real (kind=kind_phys) , intent(in) :: dt !time step (s)
9393 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil !depth of layer-bottom from soil surface
9394 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m]
9395 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature [k]
9396 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smc !soil moisture (ice + liq.) [m3/m3]
9397 real (kind=kind_phys) , intent(in) :: tv !vegetation temperature (k)
9398 real (kind=kind_phys) , intent(in) :: tg !ground temperature (k)
9399 real (kind=kind_phys) , intent(in) :: foln !foliage nitrogen (%)
9400 real (kind=kind_phys) , intent(in) :: btran !soil water transpiration factor (0 to 1)
9401 real (kind=kind_phys) , intent(in) :: psn !total leaf photosyn (umolco2/m2/s) [+]
9402 real (kind=kind_phys) , intent(in) :: apar !par by canopy (w/m2)
9403 real (kind=kind_phys) , intent(in) :: igs !growing season index (0=off, 1=on)
9404 real (kind=kind_phys) , intent(in) :: fveg !vegetation greenness fraction
9405 real (kind=kind_phys) , intent(in) :: troot !root-zone averaged temperature (k)
9406 integer , intent(in) :: ist !surface type 1->soil; 2->lake
9407
9408! input & output (carbon)
9409
9410 real (kind=kind_phys) , intent(inout) :: lfmass !leaf mass [g/m2]
9411 real (kind=kind_phys) , intent(inout) :: rtmass !mass of fine roots [g/m2]
9412 real (kind=kind_phys) , intent(inout) :: stmass !stem mass [g/m2]
9413 real (kind=kind_phys) , intent(inout) :: wood !mass of wood (incl. woody roots) [g/m2]
9414 real (kind=kind_phys) , intent(inout) :: stblcp !stable carbon in deep soil [g/m2]
9415 real (kind=kind_phys) , intent(inout) :: fastcp !short-lived carbon in shallow soil [g/m2]
9416
9417! outputs: (carbon)
9418
9419 real (kind=kind_phys) , intent(out) :: gpp !net instantaneous assimilation [g/m2/s c]
9420 real (kind=kind_phys) , intent(out) :: npp !net primary productivity [g/m2/s c]
9421 real (kind=kind_phys) , intent(out) :: nee !net ecosystem exchange [g/m2/s co2]
9422 real (kind=kind_phys) , intent(out) :: autors !net ecosystem respiration [g/m2/s c]
9423 real (kind=kind_phys) , intent(out) :: heters !organic respiration [g/m2/s c]
9424 real (kind=kind_phys) , intent(out) :: totsc !total soil carbon [g/m2 c]
9425 real (kind=kind_phys) , intent(out) :: totlb !total living carbon ([g/m2 c]
9426 real (kind=kind_phys) , intent(out) :: xlai !leaf area index [-]
9427 real (kind=kind_phys) , intent(out) :: xsai !stem area index [-]
9428! real (kind=kind_phys) , intent(out) :: vocflx(5) ! voc fluxes [ug c m-2 h-1]
9429
9430! local variables
9431
9432 integer :: j !do-loop index
9433 real (kind=kind_phys) :: wroot !root zone soil water [-]
9434 real (kind=kind_phys) :: wstres !water stress coeficient [-] (1. for wilting )
9435 real (kind=kind_phys) :: lapm !leaf area per unit mass [m2/g]
9436! ------------------------------------------------------------------------------------------
9437
9438 if ( ( vegtyp == parameters%iswater ) .or. ( vegtyp == parameters%isbarren ) .or. &
9439 ( vegtyp == parameters%isice ) .or. (parameters%urban_flag) ) then
9440 xlai = 0.
9441 xsai = 0.
9442 gpp = 0.
9443 npp = 0.
9444 nee = 0.
9445 autors = 0.
9446 heters = 0.
9447 totsc = 0.
9448 totlb = 0.
9449 lfmass = 0.
9450 rtmass = 0.
9451 stmass = 0.
9452 wood = 0.
9453 stblcp = 0.
9454 fastcp = 0.
9455
9456 return
9457 end if
9458
9459 lapm = parameters%sla / 1000. ! m2/kg -> m2/g
9460
9461! water stress
9462
9463 wstres = 1.- btran
9464
9465 wroot = 0.
9466 do j=1,parameters%nroot
9467 wroot = wroot + smc(j)/parameters%smcmax(j) * dzsnso(j) / (-zsoil(parameters%nroot))
9468 enddo
9469
9470 call co2flux (parameters,nsnow ,nsoil ,vegtyp ,igs ,dt , & !in
9471 dzsnso ,stc ,psn ,troot ,tv , & !in
9472 wroot ,wstres ,foln ,lapm , & !in
9473 lat ,iloc ,jloc ,fveg , & !in
9474 xlai ,xsai ,lfmass ,rtmass ,stmass , & !inout
9475 fastcp ,stblcp ,wood , & !inout
9476 gpp ,npp ,nee ,autors ,heters , & !out
9477 totsc ,totlb ) !out
9478
9479! call bvoc (parameters,vocflx, vegtyp, vegfac, apar, tv)
9480! call ch4
9481
9482 end subroutine carbon
9483
9484!== begin co2flux ==================================================================================
9485
9489 subroutine co2flux (parameters,nsnow ,nsoil ,vegtyp ,igs ,dt , & !in
9490 dzsnso ,stc ,psn ,troot ,tv , & !in
9491 wroot ,wstres ,foln ,lapm , & !in
9492 lat ,iloc ,jloc ,fveg , & !in
9493 xlai ,xsai ,lfmass ,rtmass ,stmass , & !inout
9494 fastcp ,stblcp ,wood , & !inout
9495 gpp ,npp ,nee ,autors ,heters , & !out
9496 totsc ,totlb ) !out
9497! -----------------------------------------------------------------------------------------
9498! the original code is from re dickinson et al.(1998), modifed by guo-yue niu, 2004
9499! -----------------------------------------------------------------------------------------
9500 implicit none
9501! -----------------------------------------------------------------------------------------
9502
9503! input
9504
9505 type (noahmp_parameters), intent(in) :: parameters
9506 integer , intent(in) :: iloc !grid index
9507 integer , intent(in) :: jloc !grid index
9508 integer , intent(in) :: vegtyp !vegetation physiology type
9509 integer , intent(in) :: nsnow !number of snow layers
9510 integer , intent(in) :: nsoil !number of soil layers
9511 real (kind=kind_phys) , intent(in) :: dt !time step (s)
9512 real (kind=kind_phys) , intent(in) :: lat !latitude (radians)
9513 real (kind=kind_phys) , intent(in) :: igs !growing season index (0=off, 1=on)
9514 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m]
9515 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature [k]
9516 real (kind=kind_phys) , intent(in) :: psn !total leaf photosynthesis (umolco2/m2/s)
9517 real (kind=kind_phys) , intent(in) :: troot !root-zone averaged temperature (k)
9518 real (kind=kind_phys) , intent(in) :: tv !leaf temperature (k)
9519 real (kind=kind_phys) , intent(in) :: wroot !root zone soil water
9520 real (kind=kind_phys) , intent(in) :: wstres !soil water stress
9521 real (kind=kind_phys) , intent(in) :: foln !foliage nitrogen (%)
9522 real (kind=kind_phys) , intent(in) :: lapm !leaf area per unit mass [m2/g]
9523 real (kind=kind_phys) , intent(in) :: fveg !vegetation greenness fraction
9524
9525! input and output
9526
9527 real (kind=kind_phys) , intent(inout) :: xlai !leaf area index from leaf carbon [-]
9528 real (kind=kind_phys) , intent(inout) :: xsai !stem area index from leaf carbon [-]
9529 real (kind=kind_phys) , intent(inout) :: lfmass !leaf mass [g/m2]
9530 real (kind=kind_phys) , intent(inout) :: rtmass !mass of fine roots [g/m2]
9531 real (kind=kind_phys) , intent(inout) :: stmass !stem mass [g/m2]
9532 real (kind=kind_phys) , intent(inout) :: fastcp !short lived carbon [g/m2]
9533 real (kind=kind_phys) , intent(inout) :: stblcp !stable carbon pool [g/m2]
9534 real (kind=kind_phys) , intent(inout) :: wood !mass of wood (incl. woody roots) [g/m2]
9535
9536! output
9537
9538 real (kind=kind_phys) , intent(out) :: gpp !net instantaneous assimilation [g/m2/s]
9539 real (kind=kind_phys) , intent(out) :: npp !net primary productivity [g/m2]
9540 real (kind=kind_phys) , intent(out) :: nee !net ecosystem exchange (autors+heters-gpp)
9541 real (kind=kind_phys) , intent(out) :: autors !net ecosystem resp. (maintance and growth)
9542 real (kind=kind_phys) , intent(out) :: heters !organic respiration
9543 real (kind=kind_phys) , intent(out) :: totsc !total soil carbon (g/m2)
9544 real (kind=kind_phys) , intent(out) :: totlb !total living carbon (g/m2)
9545
9546! local
9547
9548 real (kind=kind_phys) :: cflux !carbon flux to atmosphere [g/m2/s]
9549 real (kind=kind_phys) :: lfmsmn !minimum leaf mass [g/m2]
9550 real (kind=kind_phys) :: rswood !wood respiration [g/m2]
9551 real (kind=kind_phys) :: rsleaf !leaf maintenance respiration per timestep [g/m2]
9552 real (kind=kind_phys) :: rsroot !fine root respiration per time step [g/m2]
9553 real (kind=kind_phys) :: nppl !leaf net primary productivity [g/m2/s]
9554 real (kind=kind_phys) :: nppr !root net primary productivity [g/m2/s]
9555 real (kind=kind_phys) :: nppw !wood net primary productivity [g/m2/s]
9556 real (kind=kind_phys) :: npps !wood net primary productivity [g/m2/s]
9557 real (kind=kind_phys) :: dielf !death of leaf mass per time step [g/m2]
9558
9559 real (kind=kind_phys) :: addnpplf !leaf assimil after resp. losses removed [g/m2]
9560 real (kind=kind_phys) :: addnppst !stem assimil after resp. losses removed [g/m2]
9561 real (kind=kind_phys) :: carbfx !carbon assimilated per model step [g/m2]
9562 real (kind=kind_phys) :: grleaf !growth respiration rate for leaf [g/m2/s]
9563 real (kind=kind_phys) :: grroot !growth respiration rate for root [g/m2/s]
9564 real (kind=kind_phys) :: grwood !growth respiration rate for wood [g/m2/s]
9565 real (kind=kind_phys) :: grstem !growth respiration rate for stem [g/m2/s]
9566 real (kind=kind_phys) :: leafpt !fraction of carbon allocated to leaves [-]
9567 real (kind=kind_phys) :: lfdel !maximum leaf mass available to change [g/m2/s]
9568 real (kind=kind_phys) :: lftovr !stem turnover per time step [g/m2]
9569 real (kind=kind_phys) :: sttovr !stem turnover per time step [g/m2]
9570 real (kind=kind_phys) :: wdtovr !wood turnover per time step [g/m2]
9571 real (kind=kind_phys) :: rssoil !soil respiration per time step [g/m2]
9572 real (kind=kind_phys) :: rttovr !root carbon loss per time step by turnover [g/m2]
9573 real (kind=kind_phys) :: stablc !decay rate of fast carbon to slow carbon [g/m2/s]
9574 real (kind=kind_phys) :: woodf !calculated wood to root ratio [-]
9575 real (kind=kind_phys) :: nonlef !fraction of carbon to root and wood [-]
9576 real (kind=kind_phys) :: rootpt !fraction of carbon flux to roots [-]
9577 real (kind=kind_phys) :: woodpt !fraction of carbon flux to wood [-]
9578 real (kind=kind_phys) :: stempt !fraction of carbon flux to stem [-]
9579 real (kind=kind_phys) :: resp !leaf respiration [umol/m2/s]
9580 real (kind=kind_phys) :: rsstem !stem respiration [g/m2/s]
9581
9582 real (kind=kind_phys) :: fsw !soil water factor for microbial respiration
9583 real (kind=kind_phys) :: fst !soil temperature factor for microbial respiration
9584 real (kind=kind_phys) :: fnf !foliage nitrogen adjustemt to respiration (<= 1)
9585 real (kind=kind_phys) :: tf !temperature factor
9586 real (kind=kind_phys) :: rf !respiration reduction factor (<= 1)
9587 real (kind=kind_phys) :: stdel
9588 real (kind=kind_phys) :: stmsmn
9589 real (kind=kind_phys) :: sapm !stem area per unit mass (m2/g)
9590 real (kind=kind_phys) :: diest
9591! -------------------------- constants -------------------------------
9592 real (kind=kind_phys) :: bf !parameter for present wood allocation [-]
9593 real (kind=kind_phys) :: rswoodc !wood respiration coeficient [1/s]
9594 real (kind=kind_phys) :: stovrc !stem turnover coefficient [1/s]
9595 real (kind=kind_phys) :: rsdryc !degree of drying that reduces soil respiration [-]
9596 real (kind=kind_phys) :: rtovrc !root turnover coefficient [1/s]
9597 real (kind=kind_phys) :: wstrc !water stress coeficient [-]
9598 real (kind=kind_phys) :: laimin !minimum leaf area index [m2/m2]
9599 real (kind=kind_phys) :: xsamin !minimum leaf area index [m2/m2]
9600 real (kind=kind_phys) :: sc
9601 real (kind=kind_phys) :: sd
9602 real (kind=kind_phys) :: vegfrac
9603
9604! respiration as a function of temperature
9605
9606 real (kind=kind_phys) :: r,x
9607 r(x) = exp(0.08*(x-298.16))
9608! ---------------------------------------------------------------------------------
9609
9610! constants
9611 rtovrc = 2.0e-8 !original was 2.0e-8
9612 rsdryc = 40.0 !original was 40.0
9613 rswoodc = 3.0e-10 !
9614 bf = 0.90 !original was 0.90 ! carbon to roots
9615 wstrc = 100.0
9616 laimin = 0.05
9617 xsamin = 0.05 ! mb: change to prevent vegetation from not growing back in spring
9618
9619 sapm = 3.*0.001 ! m2/kg -->m2/g
9620 lfmsmn = laimin/lapm
9621 stmsmn = xsamin/sapm
9622! ---------------------------------------------------------------------------------
9623
9624! respiration
9625
9626 if(igs .eq. 0.) then
9627 rf = 0.5
9628 else
9629 rf = 1.0
9630 endif
9631
9632 fnf = min( foln/max(1.e-06,parameters%folnmx), 1.0 )
9633 tf = parameters%arm**( (tv-298.16)/10. )
9634 resp = parameters%rmf25 * tf * fnf * xlai * rf * (1.-wstres) ! umol/m2/s
9635 rsleaf = min((lfmass-lfmsmn)/dt,resp*12.e-6) ! g/m2/s
9636
9637 rsroot = parameters%rmr25*(rtmass*1e-3)*tf *rf* 12.e-6 ! g/m2/s
9638 rsstem = parameters%rms25*((stmass-stmsmn)*1e-3)*tf *rf* 12.e-6 ! g/m2/s
9639 rswood = rswoodc * r(tv) * wood*parameters%wdpool
9640
9641! carbon assimilation
9642! 1 mole -> 12 g carbon or 44 g co2; 1 umol -> 12.e-6 g carbon;
9643
9644 carbfx = psn * 12.e-6 ! umol co2 /m2/ s -> g/m2/s carbon
9645
9646! fraction of carbon into leaf versus nonleaf
9647
9648 leafpt = exp(0.01*(1.-exp(0.75*xlai))*xlai)
9649 if(vegtyp == parameters%eblforest) leafpt = exp(0.01*(1.-exp(0.50*xlai))*xlai)
9650
9651 nonlef = 1.0 - leafpt
9652 stempt = xlai/10.0*leafpt
9653 leafpt = leafpt - stempt
9654
9655! fraction of carbon into wood versus root
9656
9657 if(wood > 1.e-6) then
9658 woodf = (1.-exp(-bf*(parameters%wrrat*rtmass/wood))/bf)*parameters%wdpool
9659 else
9660 woodf = parameters%wdpool
9661 endif
9662
9663 rootpt = nonlef*(1.-woodf)
9664 woodpt = nonlef*woodf
9665
9666! leaf and root turnover per time step
9667
9668 lftovr = parameters%ltovrc*5.e-7*lfmass
9669 sttovr = parameters%ltovrc*5.e-7*stmass
9670 rttovr = rtovrc*rtmass
9671 wdtovr = 9.5e-10*wood
9672
9673! seasonal leaf die rate dependent on temp and water stress
9674! water stress is set to 1 at permanent wilting point
9675
9676 sc = exp(-0.3*max(0.,tv-parameters%tdlef)) * (lfmass/120.)
9677 sd = exp((wstres-1.)*wstrc)
9678 dielf = lfmass*1.e-6*(parameters%dilefw * sd + parameters%dilefc*sc)
9679 diest = stmass*1.e-6*(parameters%dilefw * sd + parameters%dilefc*sc)
9680
9681! calculate growth respiration for leaf, rtmass and wood
9682
9683 grleaf = max(0.0,parameters%fragr*(leafpt*carbfx - rsleaf))
9684 grstem = max(0.0,parameters%fragr*(stempt*carbfx - rsstem))
9685 grroot = max(0.0,parameters%fragr*(rootpt*carbfx - rsroot))
9686 grwood = max(0.0,parameters%fragr*(woodpt*carbfx - rswood))
9687
9688! impose lower t limit for photosynthesis
9689
9690 addnpplf = max(0.,leafpt*carbfx - grleaf-rsleaf)
9691 addnppst = max(0.,stempt*carbfx - grstem-rsstem)
9692! addnpplf = leafpt*carbfx - grleaf-rsleaf ! mb: test kjetil
9693! addnppst = stempt*carbfx - grstem-rsstem ! mb: test kjetil
9694 if(tv.lt.parameters%tmin) addnpplf =0.
9695 if(tv.lt.parameters%tmin) addnppst =0.
9696
9697! update leaf, root, and wood carbon
9698! avoid reducing leaf mass below its minimum value but conserve mass
9699
9700 lfdel = (lfmass - lfmsmn)/dt
9701 stdel = (stmass - stmsmn)/dt
9702 dielf = min(dielf,lfdel+addnpplf-lftovr)
9703 diest = min(diest,stdel+addnppst-sttovr)
9704
9705! net primary productivities
9706
9707 nppl = max(addnpplf,-lfdel)
9708 npps = max(addnppst,-stdel)
9709 nppr = rootpt*carbfx - rsroot - grroot
9710 nppw = woodpt*carbfx - rswood - grwood
9711
9712! masses of plant components
9713
9714 lfmass = lfmass + (nppl-lftovr-dielf)*dt
9715 stmass = stmass + (npps-sttovr-diest)*dt ! g/m2
9716 rtmass = rtmass + (nppr-rttovr) *dt
9717
9718 if(rtmass.lt.0.0) then
9719 rttovr = nppr
9720 rtmass = 0.0
9721 endif
9722 wood = (wood+(nppw-wdtovr)*dt)*parameters%wdpool
9723
9724! soil carbon budgets
9725
9726 fastcp = fastcp + (rttovr+lftovr+sttovr+wdtovr+dielf+diest)*dt ! mb: add diest v3.7
9727
9728 fst = 2.0**( (stc(1)-283.16)/10. )
9729 fsw = wroot / (0.20+wroot) * 0.23 / (0.23+wroot)
9730 rssoil = fsw * fst * parameters%mrp* max(0.,fastcp*1.e-3)*12.e-6
9731
9732 stablc = 0.1*rssoil
9733 fastcp = fastcp - (rssoil + stablc)*dt
9734 stblcp = stblcp + stablc*dt
9735
9736! total carbon flux
9737
9738 cflux = - carbfx + rsleaf + rsroot + rswood + rsstem & ! mb: add rsstem,grstem,0.9*rssoil v3.7
9739 + 0.9*rssoil + grleaf + grroot + grwood + grstem ! g/m2/s
9740
9741! for outputs
9742
9743 gpp = carbfx !g/m2/s c
9744 npp = nppl + nppw + nppr +npps !g/m2/s c
9745 autors = rsroot + rswood + rsleaf + rsstem + & !g/m2/s c mb: add rsstem, grstem v3.7
9746 grleaf + grroot + grwood + grstem !g/m2/s c mb: add 0.9* v3.7
9747 heters = 0.9*rssoil !g/m2/s c
9748 nee = (autors + heters - gpp)*44./12. !g/m2/s co2
9749 totsc = fastcp + stblcp !g/m2 c
9750 totlb = lfmass + rtmass +stmass + wood !g/m2 c mb: add stmass v3.7
9751
9752! leaf area index and stem area index
9753
9754 xlai = max(lfmass*lapm,laimin)
9755 xsai = max(stmass*sapm,xsamin)
9756
9757 end subroutine co2flux
9758
9759!== begin carbon_crop ==============================================================================
9763 subroutine carbon_crop (parameters,nsnow ,nsoil ,vegtyp ,dt ,zsoil ,julian , & !in
9764 dzsnso ,stc ,smc ,tv ,psn ,foln ,btran , & !in
9765 soldn ,t2m , & !in
9766 lfmass ,rtmass ,stmass ,wood ,stblcp ,fastcp ,grain , & !inout
9767 xlai ,xsai ,gdd , & !inout
9768 gpp ,npp ,nee ,autors ,heters ,totsc ,totlb, pgs ) !out
9769! ------------------------------------------------------------------------------------------
9770! initial crop version created by xing liu
9771! initial crop version added by barlage v3.8
9772
9773! ------------------------------------------------------------------------------------------
9774 implicit none
9775! ------------------------------------------------------------------------------------------
9776! inputs (carbon)
9777
9778 type (noahmp_parameters), intent(in) :: parameters
9779 integer , intent(in) :: nsnow !number of snow layers
9780 integer , intent(in) :: nsoil !number of soil layers
9781 integer , intent(in) :: vegtyp !vegetation type
9782 real (kind=kind_phys) , intent(in) :: dt !time step (s)
9783 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil !depth of layer-bottomfrom soil surface
9784 real (kind=kind_phys) , intent(in) :: julian !julian day of year(fractional) ( 0 <= julian < yearlen )
9785 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layerthickness [m]
9786 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature[k]
9787 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smc !soil moisture (ice +liq.) [m3/m3]
9788 real (kind=kind_phys) , intent(in) :: tv !vegetation temperature(k)
9789 real (kind=kind_phys) , intent(in) :: psn !total leaf photosyn(umolco2/m2/s) [+]
9790 real (kind=kind_phys) , intent(in) :: foln !foliage nitrogen (%)
9791 real (kind=kind_phys) , intent(in) :: btran !soil watertranspiration factor (0 to 1)
9792 real (kind=kind_phys) , intent(in) :: soldn !downward solar radiation
9793 real (kind=kind_phys) , intent(in) :: t2m !air temperature
9794
9795! input & output (carbon)
9796
9797 real (kind=kind_phys) , intent(inout) :: lfmass !leaf mass [g/m2]
9798 real (kind=kind_phys) , intent(inout) :: rtmass !mass of fine roots[g/m2]
9799 real (kind=kind_phys) , intent(inout) :: stmass !stem mass [g/m2]
9800 real (kind=kind_phys) , intent(inout) :: wood !mass of wood (incl.woody roots) [g/m2]
9801 real (kind=kind_phys) , intent(inout) :: stblcp !stable carbon in deepsoil [g/m2]
9802 real (kind=kind_phys) , intent(inout) :: fastcp !short-lived carbon inshallow soil [g/m2]
9803 real (kind=kind_phys) , intent(inout) :: grain !mass of grain [g/m2]
9804 real (kind=kind_phys) , intent(inout) :: xlai !leaf area index [-]
9805 real (kind=kind_phys) , intent(inout) :: xsai !stem area index [-]
9806 real (kind=kind_phys) , intent(inout) :: gdd !growing degree days
9807
9808! outout
9809 real (kind=kind_phys) , intent(out) :: gpp !net instantaneous assimilation [g/m2/s c]
9810 real (kind=kind_phys) , intent(out) :: npp !net primary productivity [g/m2/s c]
9811 real (kind=kind_phys) , intent(out) :: nee !net ecosystem exchange[g/m2/s co2]
9812 real (kind=kind_phys) , intent(out) :: autors !net ecosystem respiration [g/m2/s c]
9813 real (kind=kind_phys) , intent(out) :: heters !organic respiration[g/m2/s c]
9814 real (kind=kind_phys) , intent(out) :: totsc !total soil carbon [g/m2c]
9815 real (kind=kind_phys) , intent(out) :: totlb !total living carbon ([g/m2 c]
9816
9817! local variables
9818
9819 integer :: j !do-loop index
9820 real (kind=kind_phys) :: wroot !root zone soil water [-]
9821 real (kind=kind_phys) :: wstres !water stress coeficient [-] (1. for wilting )
9822 integer :: ipa !planting index
9823 integer :: iha !havestindex(0=on,1=off)
9824 integer, intent(out) :: pgs !plant growth stage
9825
9826 real (kind=kind_phys) :: psncrop
9827
9828! ------------------------------------------------------------------------------------------
9829 if ( ( vegtyp == parameters%iswater ) .or. ( vegtyp == parameters%isbarren ) .or. &
9830 ( vegtyp == parameters%isice ) .or. (parameters%urban_flag) ) then
9831 xlai = 0.
9832 xsai = 0.
9833 gpp = 0.
9834 npp = 0.
9835 nee = 0.
9836 autors = 0.
9837 heters = 0.
9838 totsc = 0.
9839 totlb = 0.
9840 lfmass = 0.
9841 rtmass = 0.
9842 stmass = 0.
9843 wood = 0.
9844 stblcp = 0.
9845 fastcp = 0.
9846 grain = 0.
9847 return
9848 end if
9849
9850! water stress
9851
9852
9853 wstres = 1.- btran
9854
9855 wroot = 0.
9856 do j=1,parameters%nroot
9857 wroot = wroot + smc(j)/parameters%smcmax(j) * dzsnso(j) / (-zsoil(parameters%nroot))
9858 enddo
9859
9860 call psn_crop ( parameters, & !in
9861 soldn, xlai, t2m, & !in
9862 psncrop ) !out
9863
9864 call growing_gdd (parameters, & !in
9865 t2m , dt, julian, & !in
9866 gdd , & !inout
9867 ipa , iha, pgs) !out
9868
9869 call co2flux_crop (parameters, & !in
9870 dt ,stc(1) ,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 end subroutine carbon_crop
9878
9879!== begin co2flux_crop =============================================================================
9883 subroutine co2flux_crop (parameters, & !in
9884 dt ,stc ,psn ,tv ,wroot ,wstres ,foln , & !in
9885 ipa ,iha ,pgs , & !in xing
9886 xlai ,xsai ,lfmass ,rtmass ,stmass , & !inout
9887 fastcp ,stblcp ,wood ,grain ,gdd, & !inout
9888 gpp ,npp ,nee ,autors ,heters , & !out
9889 totsc ,totlb ) !out
9890! -----------------------------------------------------------------------------------------
9891! the original code from re dickinson et al.(1998) and guo-yue niu(2004),
9892! modified by xing liu, 2014.
9893!
9894! -----------------------------------------------------------------------------------------
9895 implicit none
9896! -----------------------------------------------------------------------------------------
9897
9898! input
9899
9900 type (noahmp_parameters), intent(in) :: parameters
9901 real (kind=kind_phys) , intent(in) :: dt !time step (s)
9902 real (kind=kind_phys) , intent(in) :: stc !soil temperature[k]
9903 real (kind=kind_phys) , intent(in) :: psn !total leaf photosynthesis (umolco2/m2/s)
9904 real (kind=kind_phys) , intent(in) :: tv !leaf temperature (k)
9905 real (kind=kind_phys) , intent(in) :: wroot !root zone soil water
9906 real (kind=kind_phys) , intent(in) :: wstres !soil water stress
9907 real (kind=kind_phys) , intent(in) :: foln !foliage nitrogen (%)
9908 integer , intent(in) :: ipa
9909 integer , intent(in) :: iha
9910 integer , intent(in) :: pgs
9911
9912! input and output
9913
9914 real (kind=kind_phys) , intent(inout) :: xlai !leaf area index from leaf carbon [-]
9915 real (kind=kind_phys) , intent(inout) :: xsai !stem area index from leaf carbon [-]
9916 real (kind=kind_phys) , intent(inout) :: lfmass !leaf mass [g/m2]
9917 real (kind=kind_phys) , intent(inout) :: rtmass !mass of fine roots [g/m2]
9918 real (kind=kind_phys) , intent(inout) :: stmass !stem mass [g/m2]
9919 real (kind=kind_phys) , intent(inout) :: fastcp !short lived carbon [g/m2]
9920 real (kind=kind_phys) , intent(inout) :: stblcp !stable carbon pool [g/m2]
9921 real (kind=kind_phys) , intent(inout) :: wood !mass of wood (incl. woody roots) [g/m2]
9922 real (kind=kind_phys) , intent(inout) :: grain !mass of grain (xing) [g/m2]
9923 real (kind=kind_phys) , intent(inout) :: gdd !growing degree days (xing)
9924
9925! output
9926
9927 real (kind=kind_phys) , intent(out) :: gpp !net instantaneous assimilation [g/m2/s]
9928 real (kind=kind_phys) , intent(out) :: npp !net primary productivity [g/m2]
9929 real (kind=kind_phys) , intent(out) :: nee !net ecosystem exchange (autors+heters-gpp)
9930 real (kind=kind_phys) , intent(out) :: autors !net ecosystem resp. (maintance and growth)
9931 real (kind=kind_phys) , intent(out) :: heters !organic respiration
9932 real (kind=kind_phys) , intent(out) :: totsc !total soil carbon (g/m2)
9933 real (kind=kind_phys) , intent(out) :: totlb !total living carbon (g/m2)
9934
9935! local
9936
9937 real (kind=kind_phys) :: cflux !carbon flux to atmosphere [g/m2/s]
9938 real (kind=kind_phys) :: lfmsmn !minimum leaf mass [g/m2]
9939 real (kind=kind_phys) :: rswood !wood respiration [g/m2]
9940 real (kind=kind_phys) :: rsleaf !leaf maintenance respiration per timestep[g/m2]
9941 real (kind=kind_phys) :: rsroot !fine root respiration per time step [g/m2]
9942 real (kind=kind_phys) :: rsgrain !grain respiration [g/m2]
9943 real (kind=kind_phys) :: nppl !leaf net primary productivity [g/m2/s]
9944 real (kind=kind_phys) :: nppr !root net primary productivity [g/m2/s]
9945 real (kind=kind_phys) :: nppw !wood net primary productivity [g/m2/s]
9946 real (kind=kind_phys) :: npps !wood net primary productivity [g/m2/s]
9947 real (kind=kind_phys) :: nppg !grain net primary productivity [g/m2/s]
9948 real (kind=kind_phys) :: dielf !death of leaf mass per time step [g/m2]
9949
9950 real (kind=kind_phys) :: addnpplf !leaf assimil after resp. losses removed[g/m2]
9951 real (kind=kind_phys) :: addnppst !stem assimil after resp. losses removed[g/m2]
9952 real (kind=kind_phys) :: carbfx !carbon assimilated per model step [g/m2]
9953 real (kind=kind_phys) :: cbhydrafx!carbonhydrate assimilated per model step [g/m2]
9954 real (kind=kind_phys) :: grleaf !growth respiration rate for leaf [g/m2/s]
9955 real (kind=kind_phys) :: grroot !growth respiration rate for root [g/m2/s]
9956 real (kind=kind_phys) :: grwood !growth respiration rate for wood [g/m2/s]
9957 real (kind=kind_phys) :: grstem !growth respiration rate for stem [g/m2/s]
9958 real (kind=kind_phys) :: grgrain !growth respiration rate for stem [g/m2/s]
9959 real (kind=kind_phys) :: leafpt !fraction of carbon allocated to leaves [-]
9960 real (kind=kind_phys) :: lfdel !maximum leaf mass available to change[g/m2/s]
9961 real (kind=kind_phys) :: lftovr !stem turnover per time step [g/m2]
9962 real (kind=kind_phys) :: sttovr !stem turnover per time step [g/m2]
9963 real (kind=kind_phys) :: wdtovr !wood turnover per time step [g/m2]
9964 real (kind=kind_phys) :: grtovr !grainturnover per time step [g/m2]
9965 real (kind=kind_phys) :: rssoil !soil respiration per time step [g/m2]
9966 real (kind=kind_phys) :: rttovr !root carbon loss per time step by turnover[g/m2]
9967 real (kind=kind_phys) :: stablc !decay rate of fast carbon to slow carbon[g/m2/s]
9968 real (kind=kind_phys) :: woodf !calculated wood to root ratio [-]
9969 real (kind=kind_phys) :: nonlef !fraction of carbon to root and wood [-]
9970 real (kind=kind_phys) :: resp !leaf respiration [umol/m2/s]
9971 real (kind=kind_phys) :: rsstem !stem respiration [g/m2/s]
9972
9973 real (kind=kind_phys) :: fsw !soil water factor for microbial respiration
9974 real (kind=kind_phys) :: fst !soil temperature factor for microbialrespiration
9975 real (kind=kind_phys) :: fnf !foliage nitrogen adjustemt to respiration(<= 1)
9976 real (kind=kind_phys) :: tf !temperature factor
9977 real (kind=kind_phys) :: stdel
9978 real (kind=kind_phys) :: stmsmn
9979 real (kind=kind_phys) :: sapm !stem area per unit mass (m2/g)
9980 real (kind=kind_phys) :: diest
9981 real (kind=kind_phys) :: stconvert !stem to grain conversion [g/m2/s]
9982 real (kind=kind_phys) :: rtconvert !root to grain conversion [g/m2/s]
9983! -------------------------- constants -------------------------------
9984 real (kind=kind_phys) :: bf !parameter for present wood allocation [-]
9985 real (kind=kind_phys) :: rswoodc !wood respiration coeficient [1/s]
9986 real (kind=kind_phys) :: stovrc !stem turnover coefficient [1/s]
9987 real (kind=kind_phys) :: rsdryc !degree of drying that reduces soilrespiration [-]
9988 real (kind=kind_phys) :: rtovrc !root turnover coefficient [1/s]
9989 real (kind=kind_phys) :: wstrc !water stress coeficient [-]
9990 real (kind=kind_phys) :: laimin !minimum leaf area index [m2/m2]
9991 real (kind=kind_phys) :: xsamin !minimum leaf area index [m2/m2]
9992 real (kind=kind_phys) :: sc
9993 real (kind=kind_phys) :: sd
9994 real (kind=kind_phys) :: vegfrac
9995 real (kind=kind_phys) :: temp
9996
9997! respiration as a function of temperature
9998
9999 real (kind=kind_phys) :: r,x
10000 r(x) = exp(0.08*(x-298.16))
10001! ---------------------------------------------------------------------------------
10002
10003! constants
10004 rsdryc = 40.0 !original was 40.0
10005 rswoodc = 3.0e-10 !
10006 bf = 0.90 !original was 0.90 ! carbon to roots
10007 wstrc = 100.0
10008 laimin = 0.05
10009 xsamin = 0.05
10010
10011 sapm = 3.*0.001 ! m2/kg -->m2/g
10012 lfmsmn = laimin/0.035
10013 stmsmn = xsamin/sapm
10014! ---------------------------------------------------------------------------------
10015
10016! carbon assimilation
10017! 1 mole -> 12 g carbon or 44 g co2 or 30 g ch20
10018
10019 carbfx = psn*12.e-6!*ipa !umol co2 /m2/ s -> g/m2/s c
10020 cbhydrafx = psn*30.e-6!*ipa
10021
10022! mainteinance respiration
10023 fnf = min( foln/max(1.e-06,parameters%foln_mx), 1.0 )
10024 tf = parameters%q10mr**( (tv-298.16)/10. )
10025 resp = parameters%lfmr25 * tf * fnf * xlai * (1.-wstres) ! umol/m2/s
10026 rsleaf = min((lfmass-lfmsmn)/dt,resp*30.e-6) ! g/m2/s
10027 rsroot = parameters%rtmr25*(rtmass*1e-3)*tf * 30.e-6 ! g/m2/s
10028 rsstem = parameters%stmr25*(stmass*1e-3)*tf * 30.e-6 ! g/m2/s
10029 rsgrain = parameters%grainmr25*(grain*1e-3)*tf * 30.e-6 ! g/m2/s
10030
10031! calculate growth respiration for leaf, rtmass and grain
10032
10033 grleaf = max(0.0,parameters%fra_gr*(parameters%lfpt(pgs)*cbhydrafx - rsleaf))
10034 grstem = max(0.0,parameters%fra_gr*(parameters%stpt(pgs)*cbhydrafx - rsstem))
10035 grroot = max(0.0,parameters%fra_gr*(parameters%rtpt(pgs)*cbhydrafx - rsroot))
10036 grgrain = max(0.0,parameters%fra_gr*(parameters%grainpt(pgs)*cbhydrafx - rsgrain))
10037
10038! leaf turnover, stem turnover, root turnover and leaf death caused by soil
10039! water and soil temperature stress
10040
10041 lftovr = parameters%lf_ovrc(pgs)*1.e-6*lfmass
10042 rttovr = parameters%rt_ovrc(pgs)*1.e-6*rtmass
10043 sttovr = parameters%st_ovrc(pgs)*1.e-6*stmass
10044 sc = exp(-0.3*max(0.,tv-parameters%lefreez)) * (lfmass/120.)
10045 sd = exp((wstres-1.)*wstrc)
10046 dielf = lfmass*1.e-6*(parameters%dile_fw(pgs) * sd + parameters%dile_fc(pgs)*sc)
10047
10048! allocation of cbhydrafx to leaf, stem, root and grain at each growth stage
10049
10050
10051 addnpplf = max(0.,parameters%lfpt(pgs)*cbhydrafx - grleaf-rsleaf)
10052 addnpplf = parameters%lfpt(pgs)*cbhydrafx - grleaf-rsleaf
10053 addnppst = max(0.,parameters%stpt(pgs)*cbhydrafx - grstem-rsstem)
10054 addnppst = parameters%stpt(pgs)*cbhydrafx - grstem-rsstem
10055
10056
10057! avoid reducing leaf mass below its minimum value but conserve mass
10058
10059 lfdel = (lfmass - lfmsmn)/dt
10060 stdel = (stmass - stmsmn)/dt
10061 lftovr = min(lftovr,lfdel+addnpplf)
10062 sttovr = min(sttovr,stdel+addnppst)
10063 dielf = min(dielf,lfdel+addnpplf-lftovr)
10064
10065! net primary productivities
10066
10067 nppl = max(addnpplf,-lfdel)
10068 nppl = addnpplf
10069 npps = max(addnppst,-stdel)
10070 npps = addnppst
10071 nppr = parameters%rtpt(pgs)*cbhydrafx - rsroot - grroot
10072 nppg = parameters%grainpt(pgs)*cbhydrafx - rsgrain - grgrain
10073
10074! masses of plant components
10075
10076 lfmass = lfmass + (nppl-lftovr-dielf)*dt
10077 stmass = stmass + (npps-sttovr)*dt ! g/m2
10078 rtmass = rtmass + (nppr-rttovr)*dt
10079 grain = grain + nppg*dt
10080
10081 gpp = cbhydrafx* 0.4 !!g/m2/s c 0.4=12/30, ch20 to c
10082
10083 stconvert = 0.0
10084 rtconvert = 0.0
10085 if(pgs==6) then
10086 stconvert = stmass*(0.00005*dt/3600.0)
10087 stmass = stmass - stconvert
10088 rtconvert = rtmass*(0.0005*dt/3600.0)
10089 rtmass = rtmass - rtconvert
10090 grain = grain + stconvert + rtconvert
10091 end if
10092
10093 if(rtmass.lt.0.0) then
10094 rttovr = nppr
10095 rtmass = 0.0
10096 endif
10097
10098 if(grain.lt.0.0) then
10099 grain = 0.0
10100 endif
10101
10102 ! soil carbon budgets
10103
10104! if(pgs == 1 .or. pgs == 2 .or. pgs == 8) then
10105! fastcp=1000
10106! else
10107 fastcp = fastcp + (rttovr+lftovr+sttovr+dielf)*dt
10108! end if
10109 fst = 2.0**( (stc-283.16)/10. )
10110 fsw = wroot / (0.20+wroot) * 0.23 / (0.23+wroot)
10111 rssoil = fsw * fst * parameters%mrp* max(0.,fastcp*1.e-3)*12.e-6
10112
10113 stablc = 0.1*rssoil
10114 fastcp = fastcp - (rssoil + stablc)*dt
10115 stblcp = stblcp + stablc*dt
10116
10117! total carbon flux
10118
10119 cflux = - carbfx + rsleaf + rsroot + rsstem &
10120 + rssoil + grleaf + grroot ! g/m2/s 0.4=12/30, ch20 to c
10121
10122! for outputs
10123 !g/m2/s c
10124
10125 npp = (nppl + npps+ nppr +nppg)*0.4 !!g/m2/s c 0.4=12/30, ch20 to c
10126
10127
10128 autors = rsroot + rsgrain + rsleaf + & !g/m2/s c
10129 grleaf + grroot + grgrain !g/m2/s c
10130
10131 heters = rssoil !g/m2/s c
10132 nee = (autors + heters - gpp)*44./30. !g/m2/s co2
10133 totsc = fastcp + stblcp !g/m2 c
10134
10135 totlb = lfmass + rtmass + grain
10136
10137! leaf area index and stem area index
10138
10139 xlai = max(lfmass*parameters%bio2lai,laimin)
10140 xsai = max(stmass*sapm,xsamin)
10141
10142
10143!after harversting
10144! if(pgs == 8 ) then
10145! lfmass = 0.62
10146! stmass = 0
10147! grain = 0
10148! end if
10149
10150! if(pgs == 1 .or. pgs == 2 .or. pgs == 8) then
10151 if(pgs == 8 .and. (grain > 0. .or. lfmass > 0 .or. stmass > 0 .or. rtmass > 0)) then
10152 xlai = 0.05
10153 xsai = 0.05
10154 lfmass = lfmsmn
10155 stmass = stmsmn
10156 rtmass = 0
10157 grain = 0
10158 end if
10159
10160end subroutine co2flux_crop
10161
10162!== begin growing_gdd ==============================================================================
10165 subroutine growing_gdd (parameters, & !in
10166 t2m , dt, julian, & !in
10167 gdd , & !inout
10168 ipa, iha, pgs) !out
10169!===================================================================================================
10170
10171! input
10172
10173 type (noahmp_parameters), intent(in) :: parameters
10174 real (kind=kind_phys) , intent(in) :: t2m
10175 real (kind=kind_phys) , intent(in) :: dt
10176 real (kind=kind_phys) , intent(in) :: julian
10177
10178! input and output
10179
10180 real (kind=kind_phys) , intent(inout) :: gdd
10181
10182! output
10183
10184 integer , intent(out) :: ipa
10185 integer , intent(out) :: iha
10186 integer , intent(out) :: pgs
10187
10188!local
10189
10190 real (kind=kind_phys) :: gddday !gap bewtween gdd and gdd8
10191 real (kind=kind_phys) :: dayofs2 !days in stage2
10192 real (kind=kind_phys) :: tdiff !temperature difference for growing degree days calculation
10193 real (kind=kind_phys) :: tc
10194
10195 tc = t2m - 273.15
10196
10197!havestindex(0=on,1=off)
10198
10199 ipa = 1
10200 iha = 1
10201
10202!turn on/off the planting
10203
10204 if(julian < parameters%pltday) ipa = 0
10205
10206!turn on/off the harvesting
10207 if(julian >= parameters%hsday) iha = 0
10208
10209!calculate the growing degree days
10210
10211 if(tc < parameters%gddtbase) then
10212 tdiff = 0.0
10213 elseif(tc >= parameters%gddtcut) then
10214 tdiff = parameters%gddtcut - parameters%gddtbase
10215 else
10216 tdiff = tc - parameters%gddtbase
10217 end if
10218
10219 gdd = (gdd + tdiff * dt / 86400.0) * ipa * iha
10220
10221 gddday = gdd
10222
10223 ! decide corn growth stage, based on hybrid-maize
10224 ! pgs = 1 : before planting
10225 ! pgs = 2 : from tassel initiation to silking
10226 ! pgs = 3 : from silking to effective grain filling
10227 ! pgs = 4 : from effective grain filling to pysiological maturity
10228 ! pgs = 5 : gddm=1389
10229 ! pgs = 6 :
10230 ! pgs = 7 :
10231 ! pgs = 8 :
10232 ! gddm = 1389
10233 ! gddm = 1555
10234 ! gddsk = 0.41*gddm +145.4+150 !from hybrid-maize
10235 ! gdds1 = ((gddsk-96)/38.9-4)*21
10236 ! gdds1 = 0.77*gddsk
10237 ! gdds3 = gddsk+170
10238 ! gdds3 = 170
10239
10240 pgs = 1 ! mb: set pgs = 1 (for initialization during growing season when no gdd)
10241
10242 if(gddday > 0.0) pgs = 2
10243
10244 if(gddday >= parameters%gdds1) pgs = 3
10245
10246 if(gddday >= parameters%gdds2) pgs = 4
10247
10248 if(gddday >= parameters%gdds3) pgs = 5
10249
10250 if(gddday >= parameters%gdds4) pgs = 6
10251
10252 if(gddday >= parameters%gdds5) pgs = 7
10253
10254 if(julian >= parameters%hsday) pgs = 8
10255
10256 if(julian < parameters%pltday) pgs = 1
10257
10258end subroutine growing_gdd
10259
10260!== begin psn_crop =================================================================================
10263subroutine psn_crop ( parameters, & !in
10264 soldn, xlai,t2m, & !in
10265 psncrop ) !out
10266!===================================================================================================
10267
10268! input
10269
10270 type (noahmp_parameters), intent(in) :: parameters
10271 real (kind=kind_phys) , intent(in) :: soldn
10272 real (kind=kind_phys) , intent(in) :: xlai
10273 real (kind=kind_phys) , intent(in) :: t2m
10274 real (kind=kind_phys) , intent(out) :: psncrop
10275
10276!local
10277
10278 real (kind=kind_phys) :: par ! photosynthetically active radiation (w/m2) 1 w m-2 = 0.0864 mj m-2 day-1
10279 real (kind=kind_phys) :: amax ! maximum co2 assimulation rate g/co2/s
10280 real (kind=kind_phys) :: l1 ! three gaussian method
10281 real (kind=kind_phys) :: l2 ! three gaussian method
10282 real (kind=kind_phys) :: l3 ! three gaussian method
10283 real (kind=kind_phys) :: i1 ! three gaussian method
10284 real (kind=kind_phys) :: i2 ! three gaussian method
10285 real (kind=kind_phys) :: i3 ! three gaussian method
10286 real (kind=kind_phys) :: a1 ! three gaussian method
10287 real (kind=kind_phys) :: a2 ! three gaussian method
10288 real (kind=kind_phys) :: a3 ! three gaussian method
10289 real (kind=kind_phys) :: a ! co2 assimulation
10290 real (kind=kind_phys) :: tc
10291
10292 tc = t2m - 273.15
10293
10294 par = parameters%i2par * soldn * 0.0036 !w to mj m-2
10295
10296 if(tc < parameters%tassim0) then
10297 amax = 1e-10
10298 elseif(tc >= parameters%tassim0 .and. tc < parameters%tassim1) then
10299 amax = (tc - parameters%tassim0) * parameters%aref / (parameters%tassim1 - parameters%tassim0)
10300 elseif(tc >= parameters%tassim1 .and. tc < parameters%tassim2) then
10301 amax = parameters%aref
10302 else
10303 amax= parameters%aref - 0.2 * (t2m - parameters%tassim2)
10304 endif
10305
10306 amax = max(amax,0.01)
10307
10308 if(xlai <= 0.05) then
10309 l1 = 0.1127 * 0.05 !use initial lai(0.05), avoid error
10310 l2 = 0.5 * 0.05
10311 l3 = 0.8873 * 0.05
10312 else
10313 l1 = 0.1127 * xlai
10314 l2 = 0.5 * xlai
10315 l3 = 0.8873 * xlai
10316 end if
10317
10318 i1 = parameters%k * par * exp(-parameters%k * l1)
10319 i2 = parameters%k * par * exp(-parameters%k * l2)
10320 i3 = parameters%k * par * exp(-parameters%k * l3)
10321
10322 i1 = max(i1,1e-10)
10323 i2 = max(i2,1e-10)
10324 i3 = max(i3,1e-10)
10325
10326 a1 = amax * (1 - exp(-parameters%epsi * i1 / amax))
10327 a2 = amax * (1 - exp(-parameters%epsi * i2 / amax)) * 1.6
10328 a3 = amax * (1 - exp(-parameters%epsi * i3 / amax))
10329
10330 if (xlai <= 0.05) then
10331 a = (a1+a2+a3) / 3.6 * 0.05
10332 elseif (xlai > 0.05 .and. xlai <= 4.0) then
10333 a = (a1+a2+a3) / 3.6 * xlai
10334 else
10335 a = (a1+a2+a3) / 3.6 * 4
10336 end if
10337
10338 a = a * parameters%psnrf ! attainable
10339
10340 psncrop = 6.313 * a ! (1/44) * 1000000)/3600 = 6.313
10341
10342end subroutine psn_crop
10343
10344!== begin bvocflux =================================================================================
10345
10346! subroutine bvocflux(parameters,vocflx, vegtyp, vegfrac, apar, tv )
10347!
10348! ------------------------------------------------------------------------------------------
10349! implicit none
10350! ------------------------------------------------------------------------------------------
10351!
10352! ------------------------ code history ---------------------------
10353! source file: bvoc
10354! purpose: bvoc emissions
10355! description:
10356! volatile organic compound emission
10357! this code simulates volatile organic compound emissions
10358! following the algorithm presented in guenther, a., 1999: modeling
10359! biogenic volatile organic compound emissions to the atmosphere. in
10360! reactive hydrocarbons in the atmosphere, ch. 3
10361! this model relies on the assumption that 90% of isoprene and monoterpene
10362! emissions originate from canopy foliage:
10363! e = epsilon * gamma * density * delta
10364! the factor delta (longterm activity factor) applies to isoprene emission
10365! from deciduous plants only. we neglect this factor at the present time.
10366! this factor is discussed in guenther (1997).
10367! subroutine written to operate at the patch level.
10368! in final implementation, remember:
10369! 1. may wish to call this routine only as freq. as rad. calculations
10370! 2. may wish to place epsilon values directly in pft-physiology file
10371! ------------------------ input/output variables -----------------
10372! input
10373! integer ,intent(in) :: vegtyp !vegetation type
10374! real (kind=kind_phys) ,intent(in) :: vegfrac !green vegetation fraction [0.0-1.0]
10375! real (kind=kind_phys) ,intent(in) :: apar !photosynthesis active energy by canopy (w/m2)
10376! real (kind=kind_phys) ,intent(in) :: tv !vegetation canopy temperature (k)
10377!
10378! output
10379! real (kind=kind_phys) ,intent(out) :: vocflx(5) ! voc fluxes [ug c m-2 h-1]
10380!
10381! local variables
10382!
10383! real (kind=kind_phys), parameter :: r = 8.314 ! univ. gas constant [j k-1 mol-1]
10384! real (kind=kind_phys), parameter :: alpha = 0.0027 ! empirical coefficient
10385! real (kind=kind_phys), parameter :: cl1 = 1.066 ! empirical coefficient
10386! real (kind=kind_phys), parameter :: ct1 = 95000.0 ! empirical coefficient [j mol-1]
10387! real (kind=kind_phys), parameter :: ct2 = 230000.0 ! empirical coefficient [j mol-1]
10388! real (kind=kind_phys), parameter :: ct3 = 0.961 ! empirical coefficient
10389! real (kind=kind_phys), parameter :: tm = 314.0 ! empirical coefficient [k]
10390! real (kind=kind_phys), parameter :: tstd = 303.0 ! std temperature [k]
10391! real (kind=kind_phys), parameter :: bet = 0.09 ! beta empirical coefficient [k-1]
10392!
10393! integer ivoc ! do-loop index
10394! integer ityp ! do-loop index
10395! real (kind=kind_phys) epsilon(5)
10396! real (kind=kind_phys) gamma(5)
10397! real (kind=kind_phys) density
10398! real (kind=kind_phys) elai
10399! real (kind=kind_phys) par,cl,reciprod,ct
10400!
10401! epsilon :
10402!
10403! do ivoc = 1, 5
10404! epsilon(ivoc) = parameters%eps(vegtyp,ivoc)
10405! end do
10406!
10407! gamma : activity factor. units [dimensionless]
10408!
10409! reciprod = 1. / (r * tv * tstd)
10410! ct = exp(ct1 * (tv - tstd) * reciprod) / &
10411! (ct3 + exp(ct2 * (tv - tm) * reciprod))
10412!
10413! par = apar * 4.6 ! (multiply w/m2 by 4.6 to get umol/m2/s)
10414! cl = alpha * cl1 * par * (1. + alpha * alpha * par * par)**(-0.5)
10415!
10416! gamma(1) = cl * ct ! for isoprenes
10417!
10418! do ivoc = 2, 5
10419! gamma(ivoc) = exp(bet * (tv - tstd))
10420! end do
10421!
10422! foliage density
10423!
10424! transform vegfrac to lai
10425!
10426! elai = max(0.0,-6.5/2.5*alog((1.-vegfrac)))
10427! density = elai / (parameters%slarea(vegtyp) * 0.5)
10428!
10429! calculate the voc flux
10430!
10431! do ivoc = 1, 5
10432! vocflx(ivoc) = epsilon(ivoc) * gamma(ivoc) * density
10433! end do
10434!
10435! end subroutine bvocflux
10436! ==================================================================================================
10437! ********************************* end of carbon subroutines *****************************
10438! ==================================================================================================
10439
10440!== begin noahmp_options ===========================================================================
10441
10444 subroutine noahmp_options(idveg , iopt_crs , iopt_btr , iopt_run , iopt_sfc , iopt_frz , &
10445 iopt_inf, iopt_rad , iopt_alb , iopt_snf , iopt_tbot, iopt_stc , &
10446 iopt_rsf, iopt_soil, iopt_pedo, iopt_crop, iopt_trs , iopt_diag, &
10447 iopt_z0m )
10448
10449 implicit none
10450
10451 integer, intent(in) :: idveg
10452 integer, intent(in) :: iopt_crs
10453 integer, intent(in) :: iopt_btr
10454 integer, intent(in) :: iopt_run
10455 integer, intent(in) :: iopt_sfc
10456 integer, intent(in) :: iopt_frz
10457 integer, intent(in) :: iopt_inf
10458 integer, intent(in) :: iopt_rad
10459 integer, intent(in) :: iopt_alb
10460 integer, intent(in) :: iopt_snf
10461 integer, intent(in) :: iopt_tbot
10462
10463 integer, intent(in) :: iopt_stc
10465 integer, intent(in) :: iopt_rsf
10466 integer, intent(in) :: iopt_soil
10467 integer, intent(in) :: iopt_pedo
10468 integer, intent(in) :: iopt_crop
10469 integer, intent(in) :: iopt_trs
10470 integer, intent(in) :: iopt_diag
10471 integer, intent(in) :: iopt_z0m
10472
10473! -------------------------------------------------------------------------------------------------
10474
10475 dveg = idveg
10476
10477 opt_crs = iopt_crs
10478 opt_btr = iopt_btr
10479 opt_run = iopt_run
10480 opt_sfc = iopt_sfc
10481 opt_frz = iopt_frz
10482 opt_inf = iopt_inf
10483 opt_rad = iopt_rad
10484 opt_alb = iopt_alb
10485 opt_snf = iopt_snf
10486 opt_tbot = iopt_tbot
10487 opt_stc = iopt_stc
10488 opt_rsf = iopt_rsf
10489 opt_soil = iopt_soil
10490 opt_pedo = iopt_pedo
10491 opt_crop = iopt_crop
10492 opt_trs = iopt_trs
10493 opt_diag = iopt_diag
10494 opt_z0m = iopt_z0m
10495
10496 end subroutine noahmp_options
10497
10500 subroutine sfcdif4(iloc ,jloc ,ux ,vx ,t1d , &
10501 p1d ,psfcpa,pblhx ,dx ,znt , &
10502 ep_1, ep_2, cp, &
10503 itime ,snwh ,isice ,psi_opt, &
10504 tsk ,qx ,zlvl ,iz0tlnd,qsfc , &
10505 hfx ,qfx ,cm ,chs ,chs2 , &
10506 cqs2 , &
10507 rmolx ,ust , rbx, fmx, fhx,stressx,&
10508 fm10x, fh2x, wspdx,flhcx,flqcx)
10509
10510
10511
10512!-------------------------------------------------------------------
10513 implicit none
10514!-------------------------------------------------------------------
10515
10516! input
10517
10518 integer,intent(in ) :: iloc
10519 integer,intent(in ) :: jloc
10520 integer, intent(in) :: itime
10521
10522 integer, intent(in) :: psi_opt
10523
10524 integer, intent(in) :: isice
10525
10526 real(kind=kind_phys), intent(in ) :: pblhx
10527 real(kind=kind_phys), intent(in ) :: tsk
10528 real(kind=kind_phys), intent(in ) :: psfcpa
10529 real(kind=kind_phys), intent(in ) :: p1d
10530 real(kind=kind_phys), intent(in ) :: t1d
10531 real(kind=kind_phys), intent(in ) :: qx
10532 real(kind=kind_phys), intent(in ) :: zlvl
10533 real(kind=kind_phys), intent(in ) :: hfx
10534 real(kind=kind_phys), intent(in ) :: qfx
10535 real(kind=kind_phys), intent(in ) :: dx
10536 real(kind=kind_phys), intent(in ) :: ux
10537 real(kind=kind_phys), intent(in ) :: vx
10538 real(kind=kind_phys), intent(in ) :: znt
10539 real(kind=kind_phys), intent(in ) :: snwh
10540 real(kind=kind_phys), intent(in ) :: ep_1
10541 real(kind=kind_phys), intent(in ) :: ep_2
10542 real(kind=kind_phys), intent(in ) :: cp
10543
10544! optional vars
10545
10546 integer,optional,intent(in ) :: iz0tlnd
10547
10548 real(kind=kind_phys), intent(inout) :: qsfc
10549 real(kind=kind_phys), intent(inout) :: ust
10550 real(kind=kind_phys), intent(inout) :: chs
10551 real(kind=kind_phys), intent(inout) :: chs2
10552 real(kind=kind_phys), intent(inout) :: cqs2
10553 real(kind=kind_phys), intent(inout) :: cm
10554
10555 real(kind=kind_phys), intent(inout) :: rmolx
10556 real(kind=kind_phys), intent(inout) :: rbx
10557 real(kind=kind_phys), intent(inout) :: fmx
10558 real(kind=kind_phys), intent(inout) :: fhx
10559 real(kind=kind_phys), intent(inout) :: stressx
10560 real(kind=kind_phys), intent(inout) :: fm10x
10561 real(kind=kind_phys), intent(inout) :: fh2x
10562
10563 real(kind=kind_phys), intent(inout) :: wspdx
10564 real(kind=kind_phys), intent(inout) :: flhcx
10565 real(kind=kind_phys), intent(inout) :: flqcx
10566
10567 real(kind=kind_phys) :: zolx
10568 real(kind=kind_phys) :: molx
10569
10570! diagnostics out
10571! real, intent(out) :: u10
10572! real, intent(out) :: v10
10573! real, intent(out) :: th2
10574! real, intent(out) :: t2
10575! real, intent(out) :: q2
10576! real, intent(out) :: qsfc
10577
10578
10579! local
10580
10581 real(kind=kind_phys) :: za ! height of full-sigma level
10582 real(kind=kind_phys) :: thvx ! virtual potential temperature
10583 real(kind=kind_phys) :: zqkl ! height of upper half level
10584 real(kind=kind_phys) :: zqklp1 ! height of lower half level (surface)
10585 real(kind=kind_phys) :: thx ! potential temperature
10586 real(kind=kind_phys) :: psih ! similarity function for heat
10587 real(kind=kind_phys) :: psih2 ! similarity function for heat 2m
10588 real(kind=kind_phys) :: psih10 ! similarity function for heat 10m
10589 real(kind=kind_phys) :: psim ! similarity function for momentum
10590 real(kind=kind_phys) :: psim2 ! similarity function for momentum 2m
10591 real(kind=kind_phys) :: psim10 ! similarity function for momentum 10m
10592
10593 real(kind=kind_phys) :: gz1oz0 ! log(za/z0)
10594 real(kind=kind_phys) :: gz2oz0 ! log(z2/z0)
10595 real(kind=kind_phys) :: gz10oz0 ! log(z10/z0)
10596
10597 real(kind=kind_phys) :: rhox ! density
10598 real(kind=kind_phys) :: govrth ! g/theta for stability l
10599 real(kind=kind_phys) :: tgdsa ! tsk
10600 real(kind=kind_phys) :: tvir ! temporal variable src4 -> tvir
10601 real(kind=kind_phys) :: thgb ! potential temperature ground
10602 real(kind=kind_phys) :: psfcx ! surface pressure
10603 real(kind=kind_phys) :: cpm
10604 real(kind=kind_phys) :: qgh
10605
10606 integer :: n,i,k,kk,l,nzol,nk,nzol2,nzol10
10607
10608 real(kind=kind_phys) :: zolzt, zolz0, zolza
10609 real(kind=kind_phys) :: gz1ozt,gz2ozt,gz10ozt
10610
10611
10612 real(kind=kind_phys) :: pl,thcon,tvcon,e1
10613 real(kind=kind_phys) :: zl,tskv,dthvdz,dthvm,vconv,rzol,rzol2,rzol10,zol2,zol10
10614 real(kind=kind_phys) :: dtg,psix,dtthx,psix10,psit,psit2,psiq,psiq2,psiq10
10615 real(kind=kind_phys) :: fluxc,vsgd,z0q,visc,restar,czil,restar2
10616
10617 real(kind=kind_phys) :: dqg
10618 real(kind=kind_phys) :: tabs
10619 real(kind=kind_phys) :: qsfcmr
10620 real(kind=kind_phys) :: t1dc
10621 real(kind=kind_phys) :: zt
10622 real(kind=kind_phys) :: zq
10623 real(kind=kind_phys) :: zratio
10624 real(kind=kind_phys) :: qstar
10625 real(kind=kind_phys) :: ep2
10626 real(kind=kind_phys) :: ep_3
10627!-------------------------------------------------------------------
10628
10629 psfcx=psfcpa/1000. ! to kPa for saturation check
10630 ep2=ep_2
10631 ep_3=1.-ep_2
10632
10633 if (itime == 1) then !init SP, MR
10634 if (isice == 0) then
10635 tabs = 0.5*(tsk + t1d)
10636 if (tabs .lt. 273.15) then
10637 !saturation vapor pressure wrt ice (svp1=.6112; 10*mb)
10638 e1=svp1*exp(4648*(1./273.15 - 1./tabs) - &
10639 & 11.64*log(273.15/tabs) + 0.02265*(273.15 - tabs))
10640 else
10641 !saturation vapor pressure wrt water (bolton 1980)
10642 e1=svp1*exp(svp2*(tabs-svpt0)/(tabs-svp3))
10643 endif
10644
10645 qsfc =ep2*e1/(psfcx-ep_3*e1) !avg with the input?
10646 qsfcmr =qsfc/(1.-qsfc) !to mixing ratio
10647 endif
10648
10649 if (isice == 1) then
10650 if (tsk .lt. 273.15) then
10651 !saturation vapor pressure wrt ice (svp1=.6112; 10*mb)
10652 e1=svp1*exp(4648*(1./273.15 - 1./tsk) - &
10653 & 11.64*log(273.15/tsk) + 0.02265*(273.15 - tsk))
10654 else
10655 !saturation vapor pressure wrt water (bolton 1980)
10656 e1=svp1*exp(svp2*(tsk-svpt0)/(tsk-svp3))
10657 endif
10658
10659 qsfc=ep2*e1/(psfcx-ep_3*e1) !specific humidity
10660 qsfcmr=ep2*e1/(psfcx-e1) !mixing ratio
10661
10662 endif
10663
10664 else
10665 ! use what comes out of the lsm
10666 if (isice == 0) then
10667 tabs = 0.5*(tsk + t1d)
10668 if (tabs .lt. 273.15) then
10669 !saturation vapor pressure wrt ice (svp1=.6112; 10*mb)
10670 e1=svp1*exp(4648*(1./273.15 - 1./tabs) - &
10671 & 11.64*log(273.15/tabs) + 0.02265*(273.15 - tabs))
10672 else
10673 !saturation vapor pressure wrt water (bolton 1980)
10674 e1=svp1*exp(svp2*(tabs-svpt0)/(tabs-svp3))
10675 endif
10676
10677 qsfc =ep2*e1/(psfcx-ep_3*e1) ! avg with previous qsfc?
10678 qsfcmr=qsfc/(1.-qsfc)
10679
10680 endif
10681
10682 if (isice == 1) then
10683 if (tsk .lt. 273.15) then
10684 !saturation vapor pressure wrt ice (svp1=.6112; 10*mb)
10685 e1=svp1*exp(4648*(1./273.15 - 1./tsk) - &
10686 & 11.64*log(273.15/tsk) + 0.02265*(273.15 - tsk))
10687 else
10688 !saturation vapor pressure wrt water (bolton 1980)
10689 e1=svp1*exp(svp2*(tsk-svpt0)/(tsk-svp3))
10690 endif
10691
10692 qsfc=ep2*e1/(psfcx-ep_3*e1) !specific humidity
10693 qsfcmr=qsfc/(1.-qsfc)
10694
10695 endif
10696
10697 endif !done INIT if itime=1
10698! convert (tah or tgb = tsk) temperature to potential temperature.
10699 tgdsa = tsk
10700 thgb = tsk*(p1000mb/psfcpa)**(rair/cpair) !psfcpa is pa
10701
10702! store virtual, virtual potential and potential temperature
10703
10704 pl = p1d/1000.
10705 thx = t1d*(p1000mb*0.001/pl)**(rair/cpair)
10706 t1dc = t1d - 273.15
10707
10708 thvx = thx*(1.+ep_1*qx) !qx is SH from input
10709 tvir = t1d*(1.+ep_1*qx)
10710
10711 rhox=psfcx*1000./(rair*tvir)
10712 govrth=grav/thx
10713 za = zlvl
10714
10715 !za=0.5*dz8w
10716
10717
10718! directly from input; check units
10719
10720! qfx = qflx * rhox
10721! hfx = hflx * rhox * cp
10722
10723
10724
10725! q2sat = qgh in lsm
10726!jref: canres and esat is calculated in the loop so should that be changed??
10727! qgh=ep_2*e1/(pl-e1)
10728! cpm=cp*(1.+0.8*qx)
10729
10730
10731! qgh changed to use lowest-level air temp
10732
10733 if (t1d .lt. 273.15) then
10734 !saturation vapor pressure wrt ice
10735 e1=svp1*exp(4648.*(1./273.15 - 1./t1d) - &
10736 & 11.64*log(273.15/t1d) + 0.02265*(273.15 - t1d))
10737 else
10738 !saturation vapor pressure wrt water (bolton 1980)
10739 e1=svp1*exp(svp2*(t1d-svpt0)/(t1d-svp3))
10740 endif
10741
10742
10743 !qgh=ep2*e1/(pl-ep_3*e1) !specific humidity
10744
10745 qgh=ep2*e1/(pl-e1) !sat. mixing ratio ?
10746
10747! cpm=cp*(1.+0.84*qx) ! qx is SH
10748 cpm=cp*(1.+0.84*qx/(1.0-qx) )
10749
10750 wspdx=sqrt(ux*ux+vx*vx)
10751
10752 tskv=thgb*(1.+ep_1*qsfc) !avg with tsurf not used
10753 dthvdz=(thvx-tskv)
10754
10755 fluxc = max(hfx/rhox/cp + ep_1*tskv*qfx/rhox,0.) !hfx + qfx are fluxes units: wm^-2 and kg m^-2 s^-1
10756! vconv = vconvc*(g/tgdsa*pblh*fluxc)**.33
10757
10758 vconv = vconvc*(grav/tgdsa*min(1.5*pblhx,4000.0)*fluxc)**.33 !wstar
10759! vsgd = 0.32 * (max(dx/5000.-1.,0.))**.33
10760
10761 vsgd = min(0.32 * (max(dx/5000.-1.,0.))**.33,0.5)
10762 wspdx=sqrt(wspdx*wspdx+vconv*vconv+vsgd*vsgd)
10763 wspdx=max(wspdx,0.1) !0.1 is wmin
10764 rbx=govrth*za*dthvdz/(wspdx*wspdx) !buld rich #
10765
10766 if (itime == 1) then
10767 rbx=max(rbx,-2.0)
10768 rbx=min(rbx, 2.0)
10769 else
10770 rbx=max(rbx,-4.0)
10771 rbx=min(rbx, 4.0)
10772 endif
10773
10774
10775! visc=(1.32+0.009*(t1d-273.15))*1.e-5
10776! kinematic viscosity
10777
10778
10779 visc=1.326e-5*(1. + 6.542e-3*t1dc + 8.301e-6*t1dc*t1dc &
10780 - 4.84e-9*t1dc*t1dc*t1dc)
10781
10782!compute roughness reynolds number (restar) using default znt
10783!the GFS option has been removed
10784
10785 restar=max(ust*znt/visc,0.1)
10786
10787! get zt, zq based on the input
10788! the GFS roughness option and spp_pbl have been removed
10789
10790 if (snwh > 50. .or. isice == 1) then ! (mm) treat as snow cover - use andreas cover isice =1
10791 call andreas_2002(znt,visc,ust,zt,zq)
10792 else
10793 if ( present(iz0tlnd) ) then
10794 if ( iz0tlnd .le. 1 ) then
10795 call zilitinkevich_1995(znt,zt,zq,restar,&
10796 ust,vkc,1.0_kind_phys,iz0tlnd,0,0.0_kind_phys)
10797 elseif ( iz0tlnd .eq. 2 ) then
10798 call yang_2008(znt,zt,zq,ust,molx,&
10799 qstar,restar,visc)
10800 elseif ( iz0tlnd .eq. 3 ) then
10801 !original mynn in wrf-arw used this form:
10802 call garratt_1992(zt,zq,znt,restar,1.0_kind_phys)
10803 endif
10804
10805! the GFS option is removed along with gfs_z0_lnd
10806
10807 else
10808
10809 !default to zilitinkevich
10810 call zilitinkevich_1995(znt,zt,zq,restar,&
10811 ust,vkc,1.0_kind_phys,0,0,0.0_kind_phys)
10812 endif
10813 endif
10814
10815
10816! ---------
10817! calculate bulk richardson no. of surface layer,
10818! according to akb(1976), eq(12).
10819
10820
10821 gz1oz0= log((za+znt)/znt)
10822 gz1ozt= log((za+znt)/zt)
10823 gz2oz0= log((2.0+znt)/znt)
10824 gz2ozt= log((2.0+znt)/zt)
10825 gz10oz0=log((10.+znt)/znt)
10826! gz10ozt=log((10.+znt)/zt)
10827
10828 zratio=znt/zt !need estimate for li et al.
10829
10830
10831! vconv = 0.25*sqrt(g/tskv*pblh(i)*dthvm)
10832! if(mol.lt.0.) br=amin1(br,0.0) -> check the input mol later
10833! rmol=-govrth*dthvdz*za*vkc
10834
10835 if (rbx .gt. 0.0) then
10836
10837 !compute z/l first guess:
10838 call li_etal_2010(zolx,rbx,za/znt,zratio)
10839 !zol=za*vkc*grav*mol/(thx*max(ust*ust,0.0001))
10840 zolx=max(zolx,0.0)
10841 zolx=min(zolx,20.)
10842
10843
10844 !use pedros iterative function to find z/l
10845 !zol=zolri(rb_lnd,za,zntstoch_lnd,zt_lnd,zol,psi_opt)
10846 !use brute-force method
10847
10848 zolx=zolrib(rbx,za,znt,zt,gz1oz0,gz1ozt,zolx,psi_opt)
10849 zolx=max(zolx,0.0)
10850 zolx=min(zolx,20.)
10851
10852 zolzt = zolx*zt/za ! zt/l
10853 zolz0 = zolx*znt/za ! z0/l
10854 zolza = zolx*(za+znt)/za ! (z+z0/l
10855 zol10 = zolx*(10.+znt)/za ! (10+z0)/l
10856 zol2 = zolx*(2.+znt)/za ! (2+z0)/l
10857
10858 !compute psim and psih
10859 !call psi_beljaars_holtslag_1991(psim,psih,zol)
10860 !call psi_businger_1971(psim,psih,zol)
10861 !call psi_zilitinkevich_esau_2007(psim,psih,zol)
10862 !call psi_dyerhicks(psim,psih,zol,zt_lnd,zntstoch_lnd,za)
10863 !call psi_cb2005(psim,psih,zolza,zolz0)
10864
10865 psim=psim_stable(zolza,psi_opt)-psim_stable(zolz0,psi_opt)
10866 psih=psih_stable(zolza,psi_opt)-psih_stable(zolzt,psi_opt)
10867 psim10=psim_stable(zol10,psi_opt)-psim_stable(zolz0,psi_opt)
10868! psih10=psih_stable(zol10,psi_opt)-psih_stable(zolz0,psi_opt)
10869 psih2=psih_stable(zol2,psi_opt)-psih_stable(zolzt,psi_opt)
10870
10871 ! 1.0 over monin-obukhov length
10872
10873 rmolx= zolx/za
10874
10875 elseif(rbx .eq. 0.) then
10876 !=========================================================
10877 !-----class 3; forced convection/neutral:
10878 !=========================================================
10879
10880 psim=0.0
10881 psih=psim
10882 psim10=0.
10883! psih10=0.
10884 psih2=0.
10885
10886 zolx =0.
10887 rmolx =0.
10888
10889 elseif(rbx .lt. 0.)then
10890 !==========================================================
10891 !-----class 4; free convection:
10892 !==========================================================
10893
10894 !compute z/l first guess:
10895
10896 call li_etal_2010(zolx,rbx,za/znt,zratio)
10897
10898 !zol=za*vkc*grav*mol/(th1d*max(ust_lnd*ust_lnd,0.001))
10899
10900 zolx=max(zolx,-20.0)
10901 zolx=min(zolx,0.0)
10902
10903
10904 !use pedros iterative function to find z/l
10905 !zol=zolri(rb_lnd,za,zntstoch_lnd,zt_lnd,zol,psi_opt)
10906 !use brute-force method
10907
10908 zolx=zolrib(rbx,za,znt,zt,gz1oz0,gz1ozt,zolx,psi_opt)
10909 zolx=max(zolx,-20.0)
10910 zolx=min(zolx,0.0)
10911
10912 zolzt = zolx*zt/za ! zt/l
10913 zolz0 = zolx*znt/za ! z0/l
10914 zolza = zolx*(za+znt)/za ! (z+z0/l
10915 zol10 = zolx*(10.+znt)/za ! (10+z0)/l
10916 zol2 = zolx*(2.+znt)/za ! (2+z0)/l
10917
10918 !compute psim and psih
10919 !call psi_hogstrom_1996(psim,psih,zol, zt_lnd, zntstoch_lnd, za)
10920 !call psi_businger_1971(psim,psih,zol)
10921 !call psi_dyerhicks(psim,psih,zol,zt_lnd,zntstoch_lnd,za)
10922 ! use tables
10923
10924 psim=psim_unstable(zolza,psi_opt)-psim_unstable(zolz0,psi_opt)
10925 psih=psih_unstable(zolza,psi_opt)-psih_unstable(zolzt,psi_opt)
10926 psim10=psim_unstable(zol10,psi_opt)-psim_unstable(zolz0,psi_opt)
10927! psih10=psih_unstable(zol10,psi_opt)-psih_unstable(zolz0,psi_opt)
10928 psih2=psih_unstable(zol2,psi_opt)-psih_unstable(zolzt,psi_opt)
10929
10930 !---limit psih and psim in the case of thin layers and
10931 !---high roughness. this prevents denominator in fluxes
10932 !---from getting too small
10933
10934 psih=min(psih,0.9*gz1ozt)
10935 psim=min(psim,0.9*gz1oz0)
10936 psih2=min(psih2,0.9*gz2ozt)
10937 psim10=min(psim10,0.9*gz10oz0)
10938! psih10=min(psih10,0.9*gz10ozt)
10939
10940 rmolx = zolx/za
10941
10942 endif
10943
10944 ! calculate the resistance:
10945
10946 psix =max(gz1oz0-psim, 1.0)
10947 psix10=max(gz10oz0-psim10, 1.0)
10948 psit =max(gz1ozt-psih , 1.0)
10949 psit2 =max(gz2ozt-psih2, 1.0)
10950 psiq =max(log((za+zq)/zq)-psih ,1.0)
10951 psiq2 =max(log((2.0+zq)/zq)-psih2 ,1.0)
10952
10953 !------------------------------------------------------------
10954 !-----compute the frictional velocity:
10955 !------------------------------------------------------------
10956
10957
10958 ! to prevent oscillations average with old value
10959
10960! oldust = ust
10961
10962 ust=0.5*ust+0.5*vkc*wspdx/psix
10963 ust=max(ust,0.005)
10964
10965! stress=ust**2
10966
10967 !set ustm = ust over land.
10968
10969! ustmx=ust
10970
10971
10972 !----------------------------------------------------
10973 !----compute the temperature scale (a.k.a. friction temperature, t*, or mol)
10974 !----and compute the moisture scale (or q*)
10975 !----------------------------------------------------
10976
10977 dtg=thvx-tskv
10978
10979! oldtst=mol
10980
10981 molx=vkc*dtg/psit/prt !T*
10982
10983 !t_star = -hfx/(ust*cpm*rho1d)
10984 !t_star = mol
10985 !----------------------------------------------------
10986 ! dqg=(qvsh-qsfc)*1000. !(kg/kg -> g/kg)
10987
10988 dqg=(qx-qsfc)*1000. !(kg/kg -> g/kg)
10989 qstar=vkc*dqg/psiq/prt
10990
10991 cm = (vkc/psix)*(vkc/psix)*wspdx
10992
10993! cm = (vkc/psix)*(vkc/psix)
10994! ch = (vkc/psix)*(vkc/psit)
10995
10996 chs=ust*vkc/psit
10997 cqs2=ust*vkc/psiq2
10998 chs2=ust*vkc/psit2
10999
11000! u10=ux*psix10/psix
11001! v10=vx*psix10/psix
11002
11003 flhcx = rhox*cpm*ust*vkc/psit
11004 flqcx = rhox*1.0*ust*vkc/psiq
11005
11006! ch = flhcx/(cpm*rhox) !same chs
11007
11008 fmx = psix
11009 fhx = psit
11010 fm10x = psix10
11011 fh2x =psit2
11012
11013! ustmx = ust
11014
11015 stressx = ust**2 ! or cm*wind*wind
11016
11017 end subroutine sfcdif4
11018
11021 subroutine zilitinkevich_1995(z_0,zt,zq,restar,ustar,vkc,&
11022 & landsea,iz0tlnd2,spp_pbl,rstoch)
11023
11024 implicit none
11025 real (kind=kind_phys), intent(in) :: z_0,restar,ustar,vkc,landsea
11026 integer, optional, intent(in):: iz0tlnd2
11027 real (kind=kind_phys), intent(out) :: zt,zq
11028 real (kind=kind_phys) :: czil !=0.100 in chen et al. (1997)
11029 !=0.075 in zilitinkevich (1995)
11030 !=0.500 in lemone et al. (2008)
11031 integer, intent(in) :: spp_pbl
11032 real (kind=kind_phys), intent(in) :: rstoch
11033
11034
11035 if (landsea-1.5 .gt. 0) then !water
11036
11037 !this is based on zilitinkevich, grachev, and fairall (2001;
11038 !their equations 15 and 16).
11039 if (restar .lt. 0.1) then
11040 zt = z_0*exp(vkc*2.0)
11041 zt = min( zt, 6.0e-5)
11042 zt = max( zt, 2.0e-9)
11043 zq = z_0*exp(vkc*3.0)
11044 zq = min( zq, 6.0e-5)
11045 zq = max( zq, 2.0e-9)
11046 else
11047 zt = z_0*exp(-vkc*(4.0*sqrt(restar)-3.2))
11048 zt = min( zt, 6.0e-5)
11049 zt = max( zt, 2.0e-9)
11050 zq = z_0*exp(-vkc*(4.0*sqrt(restar)-4.2))
11051 zq = min( zt, 6.0e-5)
11052 zq = max( zt, 2.0e-9)
11053 endif
11054
11055 else !land
11056
11057 !option to modify czil according to chen & zhang, 2009
11058 if ( iz0tlnd2 .eq. 1 ) then
11059 czil = 10.0 ** ( -0.40 * ( z_0 / 0.07 ) )
11060 else
11061 czil = 0.085 !0.075 !0.10
11062 end if
11063
11064 zt = z_0*exp(-vkc*czil*sqrt(restar))
11065 zt = min( zt, 0.75*z_0)
11066
11067 zq = z_0*exp(-vkc*czil*sqrt(restar))
11068 zq = min( zq, 0.75*z_0)
11069
11070
11071! stochastically perturb thermal and moisture roughness length.
11072! currently set to half the amplitude:
11073 if (spp_pbl==1) then
11074 zt = zt + zt * 0.5 * rstoch
11075 zt = max(zt, 0.0001)
11076 zq = zt
11077 endif
11078
11079 endif
11080
11081 return
11082
11083 end subroutine zilitinkevich_1995
11084
11088 subroutine garratt_1992(zt,zq,z_0,ren,landsea)
11089
11090 implicit none
11091 real (kind=kind_phys), intent(in) :: ren, z_0,landsea
11092 real (kind=kind_phys), intent(out) :: zt,zq
11093 real (kind=kind_phys) :: rq
11094 real (kind=kind_phys), parameter :: e=2.71828183
11095
11096 if (landsea-1.5 .gt. 0) then !water
11097
11098 zt = z_0*exp(2.0 - (2.48*(ren**0.25)))
11099 zq = z_0*exp(2.0 - (2.28*(ren**0.25)))
11100
11101 zq = min( zq, 5.5e-5)
11102 zq = max( zq, 2.0e-9)
11103 zt = min( zt, 5.5e-5)
11104 zt = max( zt, 2.0e-9) !same lower limit as ecmwf
11105 else !land
11106 zq = z_0/(e**2.) !taken from garratt (1980,1992)
11107 zt = zq
11108 endif
11109
11110 return
11111
11112 end subroutine garratt_1992
11113!--------------------------------------------------------------------
11138 subroutine yang_2008(z_0,zt,zq,ustar,tstar,qst,ren,visc)
11139
11140 implicit none
11141 real (kind=kind_phys), intent(in) :: z_0, ren, ustar, tstar, qst, visc
11142 real (kind=kind_phys) :: ht, &! roughness height at critical reynolds number
11143 tstar2, &! bounded t*, forced to be non-positive
11144 qstar2, &! bounded q*, forced to be non-positive
11145 z_02, &! bounded z_0 for variable renc2 calc
11146 renc2 ! variable renc, function of z_0
11147 real (kind=kind_phys), intent(out) :: zt,zq
11148 real (kind=kind_phys), parameter :: renc=300., & !old constant renc
11149 beta=1.5, & !important for diurnal variation
11150 m=170., & !slope for renc2 function
11151 b=691. !y-intercept for renc2 function
11152
11153 z_02 = min(z_0,0.5)
11154 z_02 = max(z_02,0.04)
11155 renc2= b + m*log(z_02)
11156 ht = renc2*visc/max(ustar,0.01)
11157 tstar2 = min(tstar, 0.0)
11158 qstar2 = min(qst,0.0)
11159
11160 zt = ht * exp(-beta*(ustar**0.5)*(abs(tstar2)**1.0))
11161 zq = ht * exp(-beta*(ustar**0.5)*(abs(qstar2)**1.0))
11162 !zq = zt
11163
11164 zt = min(zt, z_0/2.0)
11165 zq = min(zq, z_0/2.0)
11166
11167 return
11168
11169 end subroutine yang_2008
11170
11176 subroutine andreas_2002(z_0,bvisc,ustar,zt,zq)
11177
11178 implicit none
11179 real (kind=kind_phys), intent(in) :: z_0, bvisc, ustar
11180 real (kind=kind_phys), intent(out) :: zt, zq
11181 real (kind=kind_phys):: ren2, zntsno
11182
11183 real (kind=kind_phys), parameter :: bt0_s=1.25, bt0_t=0.149, bt0_r=0.317, &
11184 bt1_s=0.0, bt1_t=-0.55, bt1_r=-0.565, &
11185 bt2_s=0.0, bt2_t=0.0, bt2_r=-0.183
11186
11187 real (kind=kind_phys), parameter :: bq0_s=1.61, bq0_t=0.351, bq0_r=0.396, &
11188 bq1_s=0.0, bq1_t=-0.628, bq1_r=-0.512, &
11189 bq2_s=0.0, bq2_t=0.0, bq2_r=-0.180
11190
11191 !calculate zo for snow (andreas et al. 2005, blm)
11192 zntsno = 0.135*bvisc/ustar + &
11193 (0.035*(ustar*ustar)/9.8) * &
11194 (5.*exp(-1.*(((ustar - 0.18)/0.1)*((ustar - 0.18)/0.1))) + 1.)
11195 ren2 = ustar*zntsno/bvisc
11196
11197 ! make sure that re is not outside of the range of validity
11198 ! for using their equations
11199 if (ren2 .gt. 1000.) ren2 = 1000.
11200
11201 if (ren2 .le. 0.135) then
11202
11203 zt = zntsno*exp(bt0_s + bt1_s*log(ren2) + bt2_s*log(ren2)**2)
11204 zq = zntsno*exp(bq0_s + bq1_s*log(ren2) + bq2_s*log(ren2)**2)
11205
11206 else if (ren2 .gt. 0.135 .and. ren2 .lt. 2.5) then
11207
11208 zt = zntsno*exp(bt0_t + bt1_t*log(ren2) + bt2_t*log(ren2)**2)
11209 zq = zntsno*exp(bq0_t + bq1_t*log(ren2) + bq2_t*log(ren2)**2)
11210
11211 else
11212
11213 zt = zntsno*exp(bt0_r + bt1_r*log(ren2) + bt2_r*log(ren2)**2)
11214 zq = zntsno*exp(bq0_r + bq1_r*log(ren2) + bq2_r*log(ren2)**2)
11215
11216 endif
11217
11218 return
11219
11220 end subroutine andreas_2002
11221!--------------------------------------------------------------------
11226 subroutine li_etal_2010(zl, rib, zaz0, z0zt)
11227
11228 implicit none
11229 real (kind=kind_phys), intent(out) :: zl
11230 real (kind=kind_phys), intent(in) :: rib, zaz0, z0zt
11231 real (kind=kind_phys) :: alfa, beta, zaz02, z0zt2
11232 real (kind=kind_phys), parameter :: au11=0.045, bu11=0.003, bu12=0.0059, &
11233 &bu21=-0.0828, bu22=0.8845, bu31=0.1739, &
11234 &bu32=-0.9213, bu33=-0.1057
11235 real (kind=kind_phys), parameter :: aw11=0.5738, aw12=-0.4399, aw21=-4.901,&
11236 &aw22=52.50, bw11=-0.0539, bw12=1.540, &
11237 &bw21=-0.669, bw22=-3.282
11238 real (kind=kind_phys), parameter :: as11=0.7529, as21=14.94, bs11=0.1569,&
11239 &bs21=-0.3091, bs22=-1.303
11240
11241 !set limits according to li et al (2010), p 157.
11242 zaz02=zaz0
11243 if (zaz0 .lt. 100.0) zaz02=100.
11244 if (zaz0 .gt. 100000.0) zaz02=100000.
11245
11246 !set more limits according to li et al (2010)
11247 z0zt2=z0zt
11248 if (z0zt .lt. 0.5) z0zt2=0.5
11249 if (z0zt .gt. 100.0) z0zt2=100.
11250
11251 alfa = log(zaz02)
11252 beta = log(z0zt2)
11253
11254 if (rib .le. 0.0) then
11255 zl = au11*alfa*rib**2 + ( &
11256 & (bu11*beta + bu12)*alfa**2 + &
11257 & (bu21*beta + bu22)*alfa + &
11258 & (bu31*beta**2 + bu32*beta + bu33))*rib
11259 !if(zl .lt. -15 .or. zl .gt. 0.)print*,"violation rib<0:",zl
11260 zl = max(zl,-15.) !limits set according to li et al (2010)
11261 zl = min(zl,0.) !figure 1.
11262 elseif (rib .gt. 0.0 .and. rib .le. 0.2) then
11263 zl = ((aw11*beta + aw12)*alfa + &
11264 & (aw21*beta + aw22))*rib**2 + &
11265 & ((bw11*beta + bw12)*alfa + &
11266 & (bw21*beta + bw22))*rib
11267 !if(zl .lt. 0 .or. zl .gt. 4)print*,"violation 0<rib<0.2:",zl
11268 zl = min(zl,4.) !limits approx set according to li et al (2010)
11269 zl = max(zl,0.) !their figure 1b.
11270 else
11271 zl = (as11*alfa + as21)*rib + bs11*alfa + &
11272 & bs21*beta + bs22
11273 !if(zl .le. 1 .or. zl .gt. 23)print*,"violation rib>0.2:",zl
11274 zl = min(zl,20.) !limits according to li et al (2010), thier
11275 !figue 1c.
11276 zl = max(zl,1.)
11277 endif
11278
11279 return
11280
11281 end subroutine li_etal_2010
11282!-------------------------------------------------------------------
11285 real*8 function zolri(ri,za,z0,zt,zol1,psi_opt)
11286
11292
11293 implicit none
11294 real (kind=kind_phys), intent(in) :: ri,za,z0,zt,zol1
11295 integer, intent(in) :: psi_opt
11296 real (kind=kind_phys) :: x1,x2,fx1,fx2
11297 integer :: n
11298 integer, parameter :: nmax = 20
11299 real(kind=kind_phys) zolri_iteration
11300 !real, dimension(nmax):: zlhux
11301! real :: zolri2
11302
11303 if (ri.lt.0.)then
11304 x1=zol1 - 0.02 !-5.
11305 x2=0.
11306 else
11307 x1=0.
11308 x2=zol1 + 0.02 !5.
11309 endif
11310
11311 n=1
11312 fx1=zolri2(x1,ri,za,z0,zt,psi_opt)
11313 fx2=zolri2(x2,ri,za,z0,zt,psi_opt)
11314
11315 do while (abs(x1 - x2) > 0.01 .and. n < nmax)
11316 if(abs(fx2).lt.abs(fx1))then
11317 x1=x1-fx1/(fx2-fx1)*(x2-x1)
11318 fx1=zolri2(x1,ri,za,z0,zt,psi_opt)
11319 zolri=x1
11320 else
11321 x2=x2-fx2/(fx2-fx1)*(x2-x1)
11322 fx2=zolri2(x2,ri,za,z0,zt,psi_opt)
11323 zolri=x2
11324 endif
11325 n=n+1
11326 !print*," n=",n," x1=",x1," x2=",x2
11327 !zlhux(n)=zolri
11328 enddo
11329
11330 if (n==nmax .and. abs(x1 - x2) >= 0.01) then
11331 !if convergence fails, use approximate values:
11332 zolri_iteration= zolri
11333 call li_etal_2010(zolri_iteration, ri, za/z0, z0/zt)
11334 zolri = zolri_iteration
11335 !zlhux(n)=zolri
11336 !print*,"iter fail, n=",n," ri=",ri," z0=",z0
11337 else
11338 !print*,"success,n=",n," ri=",ri," z0=",z0
11339 endif
11340
11341 return
11342 end function
11343!-------------------------------------------------------------------
11344 real*8 function zolri2(zol2,ri2,za,z0,zt,psi_opt)
11345
11346 ! input: =================================
11347 ! zol2 - estimated z/l
11348 ! ri2 - calculated bulk richardson number
11349 ! za - 1/2 depth of first model layer
11350 ! z0 - aerodynamic roughness length
11351 ! zt - thermal roughness length
11352 ! output: ================================
11353 ! zolri2 - delta ri
11354
11355 implicit none
11356 integer, intent(in) :: psi_opt
11357 real (kind=kind_phys), intent(in) :: ri2,za,z0,zt
11358 real (kind=kind_phys), intent(inout) :: zol2
11359 real (kind=kind_phys) :: zol20,zol3,psim1,psih1,psix2,psit2,zolt
11360
11361! real :: psih_unstable,psim_unstable,psih_stable, psim_stable
11362
11363 if(zol2*ri2 .lt. 0.)zol2=0. ! limit zol2 - must be same sign as ri2
11364
11365 zol20=zol2*z0/za ! z0/l
11366 zol3=zol2+zol20 ! (z+z0)/l
11367 zolt=zol2*zt/za ! zt/l
11368
11369 if (ri2.lt.0) then
11370 !psix2=log((za+z0)/z0)-(psim_unstable(zol3)-psim_unstable(zol20))
11371 !psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20))
11372 psit2=max(log((za+z0)/zt)-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0)
11373 psix2=max(log((za+z0)/z0)-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)),1.0)
11374 else
11375 !psix2=log((za+z0)/z0)-(psim_stable(zol3)-psim_stable(zol20))
11376 !psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20))
11377 psit2=max(log((za+z0)/zt)-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0)
11378 psix2=max(log((za+z0)/z0)-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)),1.0)
11379 endif
11380
11381 zolri2=zol2*psit2/psix2**2 - ri2
11382 !print*," target ri=",ri2," est ri=",zol2*psit2/psix2**2
11383
11384 return
11385 end function
11386!====================================================================
11387
11388 real*8 function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt)
11389
11390 ! this iterative algorithm to compute z/l from bulk-ri
11391
11392 implicit none
11393 real (kind=kind_phys), intent(in) :: ri,za,z0,zt,logz0,logzt
11394 integer, intent(in) :: psi_opt
11395 real (kind=kind_phys), intent(inout) :: zol1
11396 real (kind=kind_phys) :: zol20,zol3,zolt,zolold
11397 integer :: n
11398 integer, parameter :: nmax = 20
11399 real (kind=kind_phys), dimension(nmax):: zlhux
11400 real (kind=kind_phys) :: psit2,psix2,zolrib_iteration
11401
11402! real :: psim_unstable, psim_stable
11403! real :: psih_unstable, psih_stable
11404
11405 !print*,"+++++++incoming: z/l=",zol1," ri=",ri
11406 if (zol1*ri .lt. 0.) then
11407 !print*,"begin: wrong quadrants: z/l=",zol1," ri=",ri
11408 zol1=0.
11409 endif
11410
11411 if (ri .lt. 0.) then
11412 zolold=-99999.
11413 zolrib=-66666.
11414 else
11415 zolold=99999.
11416 zolrib=66666.
11417 endif
11418 n=1
11419
11420 do while (abs(zolold - zolrib) > 0.01 .and. n < nmax)
11421
11422 if(n==1)then
11423 zolold=zol1
11424 else
11425 zolold=zolrib
11426 endif
11427 zol20=zolold*z0/za ! z0/l
11428 zol3=zolold+zol20 ! (z+z0)/l
11429 zolt=zolold*zt/za ! zt/l
11430 !print*,"z0/l=",zol20," (z+z0)/l=",zol3," zt/l=",zolt
11431 if (ri.lt.0) then
11432 !psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20))
11433 !psit2=log((za+z0)/zt)-(psih_unstable(zol3)-psih_unstable(zol20))
11434 psit2=max(logzt-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0)
11435 psix2=max(logz0-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)), 1.0)
11436 else
11437 !psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20))
11438 !psit2=log((za+z0)/zt)-(psih_stable(zol3)-psih_stable(zol20))
11439 psit2=max(logzt-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0)
11440 psix2=max(logz0-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)), 1.0)
11441 endif
11442 !print*,"n=",n," psit2=",psit2," psix2=",psix2
11443 zolrib=ri*psix2**2/psit2
11444 zlhux(n)=zolrib
11445 n=n+1
11446 enddo
11447
11448 if (n==nmax .and. abs(zolold - zolrib) > 0.01 ) then
11449 !print*,"iter fail, n=",n," ri=",ri," z/l=",zolri
11450 !if convergence fails, use approximate values:
11451 zolrib_iteration = zolrib
11452 call li_etal_2010(zolrib_iteration, ri, za/z0, z0/zt)
11453 zolrib = zolrib_iteration
11454 zlhux(n)=zolrib
11455 !print*,"failed, n=",n," ri=",ri," z0=",z0
11456 !print*,"z/l=",zlhux(1:nmax)
11457 else
11458 !if(zolrib*ri .lt. 0.) then
11459 ! !print*,"end: wrong quadrants: z/l=",zolrib," ri=",ri
11460 ! !phys_temp = zolrib
11461 ! !call li_etal_2010(zolrib, ri, za/z0, z0/zt)
11462 ! !zolrib = phys_temp
11463 !endif
11464 !print*,"success,n=",n," ri=",ri," z0=",z0
11465 endif
11466
11467 return
11468 end function
11469!====================================================================
11470
11473 subroutine psi_init(psi_opt,errmsg,errflg)
11474
11475 integer :: n,psi_opt
11476 real (kind=kind_phys) :: zolf
11477 character(len=*), intent(out) :: errmsg
11478 integer, intent(out) :: errflg
11479
11480 if (psi_opt == 0) then
11481 do n=0,1000
11482 ! stable function tables
11483 zolf = float(n)*0.01
11484 psim_stab(n)=psim_stable_full(zolf)
11485 psih_stab(n)=psih_stable_full(zolf)
11486
11487 ! unstable function tables
11488 zolf = -float(n)*0.01
11489 psim_unstab(n)=psim_unstable_full(zolf)
11490 psih_unstab(n)=psih_unstable_full(zolf)
11491 enddo
11492 else
11493 do n=0,1000
11494 ! stable function tables
11495 zolf = float(n)*0.01
11496 psim_stab(n)=psim_stable_full_gfs(zolf)
11497 psih_stab(n)=psih_stable_full_gfs(zolf)
11498
11499 ! unstable function tables
11500 zolf = -float(n)*0.01
11501 psim_unstab(n)=psim_unstable_full_gfs(zolf)
11502 psih_unstab(n)=psih_unstable_full_gfs(zolf)
11503 enddo
11504 endif
11505
11506 !simple test to see if initialization worked:
11507 if (psim_stab(1) < 0. .and. psih_stab(1) < 0. .and. &
11508 psim_unstab(1) > 0. .and. psih_unstab(1) > 0.) then
11509 errmsg = 'in mynn sfc, psi tables have been initialized'
11510 errflg = 0
11511 else
11512 errmsg = 'error in mynn sfc: problem initializing psi tables'
11513 errflg = 1
11514 endif
11515
11516 end subroutine psi_init
11517! ==================================================================
11518! ... integrated similarity functions from mynn...
11519!
11521 real*8 function psim_stable_full(zolf)
11522 real (kind=kind_phys) :: zolf
11523
11524 !psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5))
11525 psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**0.4)
11526
11527 return
11528 end function
11529
11531 real*8 function psih_stable_full(zolf)
11532 real (kind=kind_phys) :: zolf
11533
11534 !psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1))
11535 psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**0.9090909090909090909)
11536
11537 return
11538 end function
11539
11541 real*8 function psim_unstable_full(zolf)
11542 real (kind=kind_phys) :: zolf,x,ym,psimc,psimk
11543
11544 x=(1.-16.*zolf)**.25
11545 !psimk=2*alog(0.5*(1+x))+alog(0.5*(1+x*x))-2.*atan(x)+2.*atan(1.)
11546 psimk=2.*log(0.5*(1+x))+log(0.5*(1+x*x))-2.*atan(x)+2.*atan1
11547
11548 ym=(1.-10.*zolf)**onethird
11549 !psimc=(3./2.)*log((ym**2.+ym+1.)/3.)-sqrt(3.)*atan((2.*ym+1)/sqrt(3.))+4.*atan(1.)/sqrt(3.)
11550 psimc=1.5*log((ym**2 + ym+1.)*onethird)-sqrt3*atan((2.*ym+1)/sqrt3)+4.*atan1/sqrt3
11551
11552 psim_unstable_full=(psimk+zolf**2*(psimc))/(1+zolf**2.)
11553
11554 return
11555 end function
11556
11558 real*8 function psih_unstable_full(zolf)
11559 real (kind=kind_phys) :: zolf,y,yh,psihc,psihk
11560
11561 y=(1.-16.*zolf)**.5
11562 !psihk=2.*log((1+y)/2.)
11563 psihk=2.*log((1+y)*0.5)
11564
11565 yh=(1.-34.*zolf)**onethird
11566 !psihc=(3./2.)*log((yh**2.+yh+1.)/3.)-sqrt(3.)*atan((2.*yh+1)/sqrt(3.))+4.*atan(1.)/sqrt(3.)
11567 psihc=1.5*log((yh**2.+yh+1.)*onethird)-sqrt3*atan((2.*yh+1)/sqrt3)+4.*atan1/sqrt3
11568
11569 psih_unstable_full=(psihk+zolf**2*(psihc))/(1+zolf**2)
11570
11571 return
11572 end function
11573
11574! ==================================================================
11575! ... integrated similarity functions from gfs...
11576!
11577 real*8 function psim_stable_full_gfs(zolf)
11578 real (kind=kind_phys) :: zolf
11579 real (kind=kind_phys), parameter :: alpha4 = 20.
11580 real (kind=kind_phys) :: aa
11581
11582 aa = sqrt(1. + alpha4 * zolf)
11583 psim_stable_full_gfs = -1.*aa + log(aa + 1.)
11584
11585 return
11586 end function
11587
11588 real*8 function psih_stable_full_gfs(zolf)
11589 real (kind=kind_phys) :: zolf
11590 real (kind=kind_phys), parameter :: alpha4 = 20.
11591 real (kind=kind_phys) :: bb
11592
11593 bb = sqrt(1. + alpha4 * zolf)
11594 psih_stable_full_gfs = -1.*bb + log(bb + 1.)
11595
11596 return
11597 end function
11598
11599 real*8 function psim_unstable_full_gfs(zolf)
11600 real (kind=kind_phys) :: zolf
11601 real (kind=kind_phys) :: hl1,tem1
11602 real (kind=kind_phys), parameter :: a0=-3.975, a1=12.32, &
11603 b1=-7.755, b2=6.041
11604
11605 if (zolf .ge. -0.5) then
11606 hl1 = zolf
11607 psim_unstable_full_gfs = (a0 + a1*hl1) * hl1 / (1.+ (b1+b2*hl1) *hl1)
11608 else
11609 hl1 = -zolf
11610 tem1 = 1.0 / sqrt(hl1)
11611 psim_unstable_full_gfs = log(hl1) + 2. * sqrt(tem1) - .8776
11612 end if
11613
11614 return
11615 end function
11616
11617 real*8 function psih_unstable_full_gfs(zolf)
11618 real (kind=kind_phys) :: zolf
11619 real (kind=kind_phys) :: hl1,tem1
11620 real (kind=kind_phys), parameter :: a0p=-7.941, a1p=24.75, &
11621 b1p=-8.705, b2p=7.899
11622
11623 if (zolf .ge. -0.5) then
11624 hl1 = zolf
11625 psih_unstable_full_gfs = (a0p + a1p*hl1) * hl1 / (1.+ (b1p+b2p*hl1)*hl1)
11626 else
11627 hl1 = -zolf
11628 tem1 = 1.0 / sqrt(hl1)
11629 psih_unstable_full_gfs = log(hl1) + .5 * tem1 + 1.386
11630 end if
11631
11632 return
11633 end function
11634
11635!=================================================================
11636! look-up table functions - or, if beyond -10 < z/l < 10, recalculate
11637!=================================================================
11638 real*8 function psim_stable(zolf,psi_opt)
11639 integer :: nzol,psi_opt
11640 real (kind=kind_phys) :: rzol,zolf
11641
11642 nzol = int(zolf*100.)
11643 rzol = zolf*100. - nzol
11644 if(nzol+1 .lt. 1000)then
11645 psim_stable = psim_stab(nzol) + rzol*(psim_stab(nzol+1)-psim_stab(nzol))
11646 else
11647 if (psi_opt == 0) then
11648 psim_stable = psim_stable_full(zolf)
11649 else
11650 psim_stable = psim_stable_full_gfs(zolf)
11651 endif
11652 endif
11653
11654 return
11655 end function
11656
11657 real*8 function psih_stable(zolf,psi_opt)
11658 integer :: nzol,psi_opt
11659 real (kind=kind_phys) :: rzol,zolf
11660
11661 nzol = int(zolf*100.)
11662 rzol = zolf*100. - nzol
11663 if(nzol+1 .lt. 1000)then
11664 psih_stable = psih_stab(nzol) + rzol*(psih_stab(nzol+1)-psih_stab(nzol))
11665 else
11666 if (psi_opt == 0) then
11667 psih_stable = psih_stable_full(zolf)
11668 else
11669 psih_stable = psih_stable_full_gfs(zolf)
11670 endif
11671 endif
11672
11673 return
11674 end function
11675
11676 real*8 function psim_unstable(zolf,psi_opt)
11677 integer :: nzol,psi_opt
11678 real (kind=kind_phys) :: rzol,zolf
11679
11680 nzol = int(-zolf*100.)
11681 rzol = -zolf*100. - nzol
11682 if(nzol+1 .lt. 1000)then
11683 psim_unstable = psim_unstab(nzol) + rzol*(psim_unstab(nzol+1)-psim_unstab(nzol))
11684 else
11685 if (psi_opt == 0) then
11686 psim_unstable = psim_unstable_full(zolf)
11687 else
11688 psim_unstable = psim_unstable_full_gfs(zolf)
11689 endif
11690 endif
11691
11692 return
11693 end function
11694
11695 real*8 function psih_unstable(zolf,psi_opt)
11696 integer :: nzol,psi_opt
11697 real (kind=kind_phys) :: rzol,zolf
11698
11699 nzol = int(-zolf*100.)
11700 rzol = -zolf*100. - nzol
11701 if(nzol+1 .lt. 1000)then
11702 psih_unstable = psih_unstab(nzol) + rzol*(psih_unstab(nzol+1)-psih_unstab(nzol))
11703 else
11704 if (psi_opt == 0) then
11705 psih_unstable = psih_unstable_full(zolf)
11706 else
11707 psih_unstable = psih_unstable_full_gfs(zolf)
11708 endif
11709 endif
11710
11711 return
11712 end function
11713!========================================================================
11714end module module_sf_noahmplsm
11715
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:5275
rosr12
subroutine rosr12(nsoil, a, b, d, c, p, delta)
This subroutine inverts (solve) the tri-diagonal matrix problem.
Definition sflx.f:4723
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:3924
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:3005
snowz0
subroutine snowz0
This subroutine calculates total roughness length over snow.
Definition sflx.f:2948
canres
subroutine canres
This subroutine calculates canopy resistance which depends on incoming solar radiation,...
Definition sflx.f:1075
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:4082
hstep
subroutine hstep(nsoil, stcin, dt, rhsts, ai, bi, ci, stcout)
This subroutine calculates/updates the soil temperature field.
Definition sflx.f:4624
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:4963
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:9231
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:3105
combine
subroutine combine(parameters, nsnow, nsoil, iloc, jloc, isnow, sh2o, stc, snice, snliq, dzsnso, sice, snowh, sneqv, ponding1, ponding2)
Definition module_sf_noahmplsm.F90:7615
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:7274
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:9769
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:6648
snowalb_bats
subroutine snowalb_bats(parameters, nband, fsno, cosz, fage, albsnd, albsni)
bats snow surface albedo
Definition module_sf_noahmplsm.F90:3279
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:1693
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:7543
growing_gdd
subroutine growing_gdd(parameters, t2m, dt, julian, gdd, ipa, iha, pgs)
Definition module_sf_noahmplsm.F90:10169
divide
subroutine divide(parameters, nsnow, nsoil, isnow, stc, snice, snliq, dzsnso)
Definition module_sf_noahmplsm.F90:7803
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:10448
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:7047
snowalb_class
subroutine snowalb_class(parameters, nband, qsnow, dt, alb, albold, albsnd, albsni, iloc, jloc)
class snow surface albedo
Definition module_sf_noahmplsm.F90:3336
psi_init
subroutine psi_init(psi_opt, errmsg, errflg)
Definition module_sf_noahmplsm.F90:11474
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:8582
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:9380
combo
subroutine combo(parameters, dz, wliq, wice, t, dz2, wliq2, wice2, t2)
Definition module_sf_noahmplsm.F90:7932
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:3394
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:10509
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:5067
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:5457
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:1119
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:9038
snow_age
subroutine snow_age(parameters, dt, tg, sneqvo, sneqv, tauss, fage)
Definition module_sf_noahmplsm.F90:3225
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:6284
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:7407
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:11089
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:5248
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:2918
calhum
subroutine calhum(parameters, sfctmp, sfcprs, q2sat, dqsdt2)
Definition module_sf_noahmplsm.F90:6244
zilitinkevich_1995
subroutine zilitinkevich_1995(z_0, zt, zq, restar, ustar, vkc, landsea, iz0tlnd2, spp_pbl, rstoch)
Definition module_sf_noahmplsm.F90:11023
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:3465
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:970
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:2787
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:9497
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:2476
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:456
compact
subroutine compact(parameters, nsnow, nsoil, dt, stc, snice, snliq, zsoil, imelt, ficeold, iloc, jloc, isnow, dzsnso, zsnso)
Definition module_sf_noahmplsm.F90:7990
wdfcnd2
subroutine wdfcnd2(parameters, wdf, wcnd, smc, sice, isoil)
calculate soil water diffusivity and soil hydraulic conductivity.
Definition module_sf_noahmplsm.F90:8989
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:4957
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:1471
psn_crop
subroutine psn_crop(parameters, soldn, xlai, t2m, psncrop)
Definition module_sf_noahmplsm.F90:10266
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:8101
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:1240
zwteq
subroutine zwteq(parameters, nsoil, nsnow, zsoil, dzsnso, sh2o, zwt)
calculate equilibrium water table depth (niu et al., 2005)
Definition module_sf_noahmplsm.F90:8522
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:8252
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:9890
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:3727
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:5774
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:4454
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:6021
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:5963
zolri
real *8 function zolri(ri, za, z0, zt, zol1, psi_opt)
Definition module_sf_noahmplsm.F90:11286
wdfcnd1
subroutine wdfcnd1(parameters, wdf, wcnd, smc, fcr, isoil)
calculate soil water diffusivity and soil hydraulic conductivity.
Definition module_sf_noahmplsm.F90:8948
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:11139
psih_stable_full
real *8 function psih_stable_full(zolf)
Definition module_sf_noahmplsm.F90:11532
psim_unstable_full
real *8 function psim_unstable_full(zolf)
Definition module_sf_noahmplsm.F90:11542
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:11227
psim_stable_full
real *8 function psim_stable_full(zolf)
Definition module_sf_noahmplsm.F90:11522
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:11177
psih_unstable_full
real *8 function psih_unstable_full(zolf)
Definition module_sf_noahmplsm.F90:11559
noahmp_parameters
Definition module_sf_noahmplsm.F90:206