← Back to Documentation Home
CCPP SciDoc v8.0.0  v8.0.0
Common Community Physics Package Developed at DTC
 
Loading...
Searching...
No Matches
module_sf_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.
6965 do while ((nlog < 10) .and. (kcount == 0))
6966 nlog = nlog +1
6967 df = log( ( parameters%psisat(isoil) * grav / hfus ) * ( ( 1. + ck * swl )**2.) * &
6968 ( parameters%smcmax(isoil) / (smc - swl) )** bx) - log( - ( &
6969 tkelv - tfrz)/ tkelv)
6970 denom = 2. * ck / ( 1. + ck * swl ) + bx / ( smc - swl )
6971 swlk = swl - df / denom
6972! ----------------------------------------------------------------------
6973! bounds useful for mathematical solution.
6974! ----------------------------------------------------------------------
6975 if (swlk > (smc -0.02)) swlk = smc - 0.02
6976 if (swlk < 0.) swlk = 0.
6977
6978! ----------------------------------------------------------------------
6979! mathematical solution bounds applied.
6980! ----------------------------------------------------------------------
6981 dswl = abs(swlk - swl)
6982! if more than 10 iterations, use explicit method (ck=0 approx.)
6983! when dswl less or eq. error, no more iterations required.
6984! ----------------------------------------------------------------------
6985 swl = swlk
6986 if ( dswl <= error ) then
6987 kcount = kcount +1
6988 end if
6989! ----------------------------------------------------------------------
6990! end of iterations
6991! ----------------------------------------------------------------------
6992! bounds applied within do-block are valid for physical solution.
6993! ----------------------------------------------------------------------
6994 end do
6995 free = smc - swl
6996 end if
6997! ----------------------------------------------------------------------
6998! end option 1
6999! ----------------------------------------------------------------------
7000! ----------------------------------------------------------------------
7001! option 2: explicit solution for flerchinger eq. i.e. ck=0
7002! in koren et al., jgr, 1999, eqn 17
7003! apply physical bounds to flerchinger solution
7004! ----------------------------------------------------------------------
7005 if (kcount == 0) then
7006 write(message, '("flerchinger used in new version. iterations=", i6)') nlog
7007#ifdef CCPP
7008 errmsg = trim(message)
7009#else
7010 call wrf_message(trim(message))
7011#endif
7012 fk = ( ( (hfus / (grav * ( - parameters%psisat(isoil))))* &
7013 ( (tkelv - tfrz)/ tkelv))** ( -1/ bx))* parameters%smcmax(isoil)
7014 if (fk < 0.02) fk = 0.02
7015 free = min(fk, smc)
7016! ----------------------------------------------------------------------
7017! end option 2
7018! ----------------------------------------------------------------------
7019 end if
7020 end if
7021! ----------------------------------------------------------------------
7022 end subroutine frh2o
7023! ----------------------------------------------------------------------
7024! ==================================================================================================
7025! **********************end of energy subroutines***********************
7026! ==================================================================================================
7027
7028!== begin water ====================================================================================
7029
7032 subroutine water (parameters,vegtyp ,nsnow ,nsoil ,imelt ,dt ,uu , & !in
7033 vv ,fcev ,fctr ,qprecc ,qprecl ,elai , & !in
7034 esai ,sfctmp ,qvap ,qdew ,zsoil ,btrani , & !in
7035 ficeold,ponding,tg ,ist ,fveg ,iloc ,jloc ,smceq , & !in
7036 bdfall ,fp ,rain ,snow, & !in mb/an: v3.7
7037 qsnow ,qrain ,snowhin,latheav,latheag,frozen_canopy,frozen_ground, & !in mb
7038 isnow ,canliq ,canice ,tv ,snowh ,sneqv , & !inout
7039 snice ,snliq ,stc ,zsnso ,sh2o ,smc , & !inout
7040 sice ,zwt ,wa ,wt ,dzsnso ,wslake , & !inout
7041 smcwtd ,deeprech,rech , & !inout
7042 cmc ,ecan ,etran ,fwet ,runsrf ,runsub , & !out
7043 qin ,qdis ,ponding1 ,ponding2, &
7044 qsnbot ,esnow)
7045! ----------------------------------------------------------------------
7046! code history:
7047! initial code: guo-yue niu, oct. 2007
7048! ----------------------------------------------------------------------
7049 implicit none
7050! ----------------------------------------------------------------------
7051! input
7052 type (noahmp_parameters), intent(in) :: parameters
7053 integer, intent(in) :: iloc
7054 integer, intent(in) :: jloc
7055 integer, intent(in) :: vegtyp
7056 integer, intent(in) :: nsnow
7057 integer , intent(in) :: ist
7058 integer, intent(in) :: nsoil
7059 integer, dimension(-nsnow+1:0) , intent(in) :: imelt
7060 real (kind=kind_phys), intent(in) :: dt
7061 real (kind=kind_phys), intent(in) :: uu
7062 real (kind=kind_phys), intent(in) :: vv
7063 real (kind=kind_phys), intent(in) :: fcev
7064 real (kind=kind_phys), intent(in) :: fctr
7065 real (kind=kind_phys), intent(in) :: qprecc
7066 real (kind=kind_phys), intent(in) :: qprecl
7067 real (kind=kind_phys), intent(in) :: elai
7068 real (kind=kind_phys), intent(in) :: esai
7069 real (kind=kind_phys), intent(in) :: sfctmp
7070 real (kind=kind_phys), intent(in) :: qvap
7071 real (kind=kind_phys), intent(in) :: qdew
7072 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil
7073 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: btrani
7074 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: ficeold
7075! real (kind=kind_phys) , intent(in) :: ponding !< [mm]
7076 real (kind=kind_phys) , intent(in) :: tg
7077 real (kind=kind_phys) , intent(in) :: fveg
7078 real (kind=kind_phys) , intent(in) :: bdfall
7079 real (kind=kind_phys) , intent(in) :: fp
7080 real (kind=kind_phys) , intent(in) :: rain
7081 real (kind=kind_phys) , intent(in) :: snow
7082 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smceq
7083 real (kind=kind_phys) , intent(in) :: qsnow
7084 real (kind=kind_phys) , intent(in) :: qrain
7085 real (kind=kind_phys) , intent(in) :: snowhin
7086
7087! input/output
7088 integer, intent(inout) :: isnow
7089 real (kind=kind_phys), intent(inout) :: canliq
7090 real (kind=kind_phys), intent(inout) :: canice
7091 real (kind=kind_phys), intent(inout) :: tv
7092 real (kind=kind_phys), intent(inout) :: snowh
7093 real (kind=kind_phys), intent(inout) :: sneqv
7094 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snice
7095 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snliq
7096 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
7097 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: zsnso
7098 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
7099 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sh2o
7100 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sice
7101 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: smc
7102 real (kind=kind_phys), intent(inout) :: zwt
7103 real (kind=kind_phys), intent(inout) :: wa
7104 real (kind=kind_phys), intent(inout) :: wt
7106 real (kind=kind_phys), intent(inout) :: wslake
7107 real (kind=kind_phys) , intent(inout) :: ponding
7108 real (kind=kind_phys), intent(inout) :: smcwtd
7109 real (kind=kind_phys), intent(inout) :: deeprech
7110 real (kind=kind_phys), intent(inout) :: rech
7111
7112! output
7113 real (kind=kind_phys), intent(out) :: cmc
7114 real (kind=kind_phys), intent(out) :: ecan
7115 real (kind=kind_phys), intent(out) :: etran
7116 real (kind=kind_phys), intent(out) :: fwet
7117 real (kind=kind_phys), intent(out) :: runsrf
7118 real (kind=kind_phys), intent(out) :: runsub
7119 real (kind=kind_phys), intent(out) :: qin
7120 real (kind=kind_phys), intent(out) :: qdis
7121 real (kind=kind_phys), intent(out) :: ponding1
7122 real (kind=kind_phys), intent(out) :: ponding2
7123 real (kind=kind_phys), intent(out) :: esnow
7124 real (kind=kind_phys), intent(out) :: qsnbot
7125 real (kind=kind_phys) , intent(in) :: latheav
7126 real (kind=kind_phys) , intent(in) :: latheag
7127 logical , intent(in) :: frozen_ground
7128 logical , intent(in) :: frozen_canopy
7129
7130
7131! local
7132 integer :: iz
7133 real (kind=kind_phys) :: qinsur !water input on soil surface [m/s]
7134 real (kind=kind_phys) :: qseva !soil surface evap rate [mm/s]
7135 real (kind=kind_phys) :: qsdew !soil surface dew rate [mm/s]
7136 real (kind=kind_phys) :: qsnfro !snow surface frost rate[mm/s]
7137 real (kind=kind_phys) :: qsnsub !snow surface sublimation rate [mm/s]
7138 real (kind=kind_phys), dimension( 1:nsoil) :: etrani !transpiration rate (mm/s) [+]
7139 real (kind=kind_phys), dimension( 1:nsoil) :: wcnd !hydraulic conductivity (m/s)
7140 real (kind=kind_phys) :: qdrain !soil-bottom free drainage [mm/s]
7141 real (kind=kind_phys) :: snoflow !glacier flow [mm/s]
7142 real (kind=kind_phys) :: fcrmax !maximum of fcr (-)
7143
7144 real (kind=kind_phys), parameter :: wslmax = 5000. !maximum lake water storage (mm)
7145
7146
7147! ----------------------------------------------------------------------
7148! initialize
7149
7150 etrani(1:nsoil) = 0.
7151 snoflow = 0.
7152 runsub = 0.
7153 qinsur = 0.
7154
7155! canopy-intercepted snowfall/rainfall, drips, and throughfall
7156
7157 call canwater (parameters,vegtyp ,dt , & !in
7158 fcev ,fctr ,elai , & !in
7159 esai ,tg ,fveg ,iloc , jloc, & !in
7160 bdfall ,frozen_canopy , & !in
7161 canliq ,canice ,tv , & !inout
7162 cmc ,ecan ,etran , & !out
7163 fwet ) !out
7164
7165! sublimation, frost, evaporation, and dew
7166
7167 qsnsub = 0.
7168 if (sneqv > 0.) then
7169 qsnsub = min(qvap, sneqv/dt)
7170 endif
7171 qseva = qvap-qsnsub
7172 esnow = qsnsub*hsub
7173
7174 qsnfro = 0.
7175 if (sneqv > 0.) then
7176 qsnfro = qdew
7177 endif
7178 qsdew = qdew - qsnfro
7179
7180 call snowwater (parameters,nsnow ,nsoil ,imelt ,dt ,zsoil , & !in
7181 & sfctmp ,snowhin,qsnow ,qsnfro ,qsnsub , & !in
7182 & qrain ,ficeold,iloc ,jloc , & !in
7183 & isnow ,snowh ,sneqv ,snice ,snliq , & !inout
7184 & sh2o ,sice ,stc ,zsnso ,dzsnso , & !inout
7185 & qsnbot ,snoflow,ponding1 ,ponding2) !out
7186
7187 if(frozen_ground) then
7188 sice(1) = sice(1) + (qsdew-qseva)*dt/(dzsnso(1)*1000.)
7189 qsdew = 0.0
7190 qseva = 0.0
7191 if(sice(1) < 0.) then
7192 sh2o(1) = sh2o(1) + sice(1)
7193 sice(1) = 0.
7194 end if
7195 end if
7196
7197! convert units (mm/s -> m/s)
7198
7199 !ponding: melting water from snow when there is no layer
7200 qinsur = (ponding+ponding1+ponding2)/dt * 0.001
7201! qinsur = ponding/dt * 0.001
7202
7203 if(isnow == 0) then
7204 qinsur = qinsur+(qsnbot + qsdew + qrain) * 0.001
7205 else
7206 qinsur = qinsur+(qsnbot + qsdew) * 0.001
7207 endif
7208
7209 qseva = qseva * 0.001
7210
7211 do iz = 1, parameters%nroot
7212 etrani(iz) = etran * btrani(iz) * 0.001
7213 enddo
7214
7215
7216! lake/soil water balances
7217
7218 if (ist == 2) then ! lake
7219 runsrf = 0.
7220 if(wslake >= wslmax) runsrf = qinsur*1000. !mm/s
7221 wslake = wslake + (qinsur-qseva)*1000.*dt -runsrf*dt !mm
7222 else ! soil
7223 call soilwater (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in
7224 qinsur ,qseva ,etrani ,sice ,iloc , jloc , & !in
7225 sh2o ,smc ,zwt ,vegtyp , & !inout
7226 smcwtd, deeprech , & !inout
7227 runsrf ,qdrain ,runsub ,wcnd ,fcrmax ) !out
7228
7229 if(opt_run == 1) then
7230 call groundwater (parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in
7231 stc ,wcnd ,fcrmax ,iloc ,jloc , & !in
7232 sh2o ,zwt ,wa ,wt , & !inout
7233 qin ,qdis ) !out
7234 runsub = qdis !mm/s
7235 end if
7236
7237 if(opt_run == 3 .or. opt_run == 4) then
7238 runsub = runsub + qdrain !mm/s
7239 end if
7240
7241 do iz = 1,nsoil
7242 smc(iz) = sh2o(iz) + sice(iz)
7243 enddo
7244
7245 if(opt_run == 5) then
7246 call shallowwatertable (parameters,nsnow ,nsoil, zsoil, dt , & !in
7247 dzsnso ,smceq ,iloc , jloc , & !in
7248 smc ,zwt ,smcwtd ,rech, qdrain ) !inout
7249
7250 sh2o(nsoil) = smc(nsoil) - sice(nsoil)
7251 runsub = runsub + qdrain !it really comes from subroutine watertable, which is not called with the same frequency as the soil routines here
7252 wa = 0.
7253 endif
7254
7255 endif
7256
7257 runsub = runsub + snoflow !mm/s
7258
7259 end subroutine water
7260
7261!== begin canwater =================================================================================
7262
7265 subroutine canwater (parameters,vegtyp ,dt , & !in
7266 fcev ,fctr ,elai , & !in
7267 esai ,tg ,fveg ,iloc , jloc , & !in
7268 bdfall ,frozen_canopy , & !in
7269 canliq ,canice ,tv , & !inout
7270 cmc ,ecan ,etran , & !out
7271 fwet ) !out
7272
7273! ------------------------ code history ------------------------------
7274! canopy hydrology
7275! --------------------------------------------------------------------
7276 implicit none
7277! ------------------------ input/output variables --------------------
7278! input
7279 type (noahmp_parameters), intent(in) :: parameters
7280 integer,intent(in) :: iloc
7281 integer,intent(in) :: jloc
7282 integer,intent(in) :: vegtyp
7283 real (kind=kind_phys), intent(in) :: dt
7284 real (kind=kind_phys), intent(in) :: fcev
7285 real (kind=kind_phys), intent(in) :: fctr
7286 real (kind=kind_phys), intent(in) :: elai
7287 real (kind=kind_phys), intent(in) :: esai
7288 real (kind=kind_phys), intent(in) :: tg
7289 real (kind=kind_phys), intent(in) :: fveg
7290 logical , intent(in) :: frozen_canopy
7291 real (kind=kind_phys), intent(in) :: bdfall
7292
7293! input & output
7294 real (kind=kind_phys), intent(inout) :: canliq
7295 real (kind=kind_phys), intent(inout) :: canice
7296 real (kind=kind_phys), intent(inout) :: tv
7297
7298! output
7299 real (kind=kind_phys), intent(out) :: cmc
7300 real (kind=kind_phys), intent(out) :: ecan
7301 real (kind=kind_phys), intent(out) :: etran
7302 real (kind=kind_phys), intent(out) :: fwet
7303! --------------------------------------------------------------------
7304
7305! ------------------------ local variables ---------------------------
7306 real (kind=kind_phys) :: maxsno !canopy capacity for snow interception (mm)
7307 real (kind=kind_phys) :: maxliq !canopy capacity for rain interception (mm)
7308 real (kind=kind_phys) :: qevac !evaporation rate (mm/s)
7309 real (kind=kind_phys) :: qdewc !dew rate (mm/s)
7310 real (kind=kind_phys) :: qfroc !frost rate (mm/s)
7311 real (kind=kind_phys) :: qsubc !sublimation rate (mm/s)
7312 real (kind=kind_phys) :: qmeltc !melting rate of canopy snow (mm/s)
7313 real (kind=kind_phys) :: qfrzc !refreezing rate of canopy liquid water (mm/s)
7314 real (kind=kind_phys) :: canmas !total canopy mass (kg/m2)
7315! --------------------------------------------------------------------
7316! initialization
7317
7318 ecan = 0.0
7319
7320! --------------------------- liquid water ------------------------------
7321! maximum canopy water
7322
7323 maxliq = parameters%ch2op * (elai+ esai)
7324
7325! evaporation, transpiration, and dew
7326
7327 if (.not.frozen_canopy) then ! barlage: change to frozen_canopy
7328 etran = max( fctr/hvap, 0. )
7329 qevac = max( fcev/hvap, 0. )
7330 qdewc = abs( min( fcev/hvap, 0. ) )
7331 qsubc = 0.
7332 qfroc = 0.
7333 else
7334 etran = max( fctr/hsub, 0. )
7335 qevac = 0.
7336 qdewc = 0.
7337 qsubc = max( fcev/hsub, 0. )
7338 qfroc = abs( min( fcev/hsub, 0. ) )
7339 endif
7340
7341! canopy water balance. for convenience allow dew to bring canliq above
7342! maxh2o or else would have to re-adjust drip
7343
7344 qevac = min(canliq/dt,qevac)
7345 canliq=max(0.,canliq+(qdewc-qevac)*dt)
7346 if(canliq <= 1.e-06) canliq = 0.0
7347
7348! --------------------------- canopy ice ------------------------------
7349! for canopy ice
7350
7351 maxsno = 6.6*(0.27+46./bdfall) * (elai+ esai)
7352
7353 qsubc = min(canice/dt,qsubc)
7354 canice= max(0.,canice + (qfroc-qsubc)*dt)
7355 if(canice.le.1.e-6) canice = 0.
7356
7357! wetted fraction of canopy
7358
7359 if(canice.gt.0.) then
7360 fwet = max(0.,canice) / max(maxsno,1.e-06)
7361 else
7362 fwet = max(0.,canliq) / max(maxliq,1.e-06)
7363 endif
7364 fwet = min(fwet, 1.) ** 0.667
7365
7366! phase change
7367
7368 qmeltc = 0.
7369 qfrzc = 0.
7370
7371 if(canice.gt.1.e-6.and.tv.gt.tfrz) then
7372 qmeltc = min(canice/dt,(tv-tfrz)*cice*canice/denice/(dt*hfus))
7373 canice = max(0.,canice - qmeltc*dt)
7374 canliq = max(0.,canliq + qmeltc*dt)
7375 tv = fwet*tfrz + (1.-fwet)*tv
7376 endif
7377
7378 if(canliq.gt.1.e-6.and.tv.lt.tfrz) then
7379 qfrzc = min(canliq/dt,(tfrz-tv)*cwat*canliq/denh2o/(dt*hfus))
7380 canliq = max(0.,canliq - qfrzc*dt)
7381 canice = max(0.,canice + qfrzc*dt)
7382 tv = fwet*tfrz + (1.-fwet)*tv
7383 endif
7384
7385! total canopy water
7386
7387 cmc = canliq + canice
7388
7389! total canopy evaporation
7390
7391 ecan = qevac + qsubc - qdewc - qfroc
7392
7393 end subroutine canwater
7394
7395!== begin snowwater ================================================================================
7396
7399 subroutine snowwater (parameters,nsnow ,nsoil ,imelt ,dt ,zsoil , & !in
7400 sfctmp ,snowhin,qsnow ,qsnfro ,qsnsub , & !in
7401 qrain ,ficeold,iloc ,jloc , & !in
7402 isnow ,snowh ,sneqv ,snice ,snliq , & !inout
7403 sh2o ,sice ,stc ,zsnso ,dzsnso , & !inout
7404 qsnbot ,snoflow,ponding1 ,ponding2) !out
7405! ----------------------------------------------------------------------
7406 implicit none
7407! ----------------------------------------------------------------------
7408! input
7409 type (noahmp_parameters), intent(in) :: parameters
7410 integer, intent(in) :: iloc
7411 integer, intent(in) :: jloc
7412 integer, intent(in) :: nsnow
7413 integer, intent(in) :: nsoil
7414 integer, dimension(-nsnow+1:0) , intent(in) :: imelt
7415 real (kind=kind_phys), intent(in) :: dt
7416 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil
7417 real (kind=kind_phys), intent(in) :: sfctmp
7418 real (kind=kind_phys), intent(in) :: snowhin
7419 real (kind=kind_phys), intent(in) :: qsnow
7420 real (kind=kind_phys), intent(in) :: qsnfro
7421 real (kind=kind_phys), intent(in) :: qsnsub
7422 real (kind=kind_phys), intent(in) :: qrain
7423 real (kind=kind_phys), dimension(-nsnow+1:0) , intent(in) :: ficeold
7424
7425! input & output
7426 integer, intent(inout) :: isnow
7427 real (kind=kind_phys), intent(inout) :: snowh
7428 real (kind=kind_phys), intent(inout) :: sneqv
7429 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snice
7430 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snliq
7431 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sh2o
7432 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sice
7433 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
7434 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: zsnso
7435 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
7436
7437! output
7438 real (kind=kind_phys), intent(out) :: qsnbot
7439 real (kind=kind_phys), intent(out) :: snoflow
7440 real (kind=kind_phys), intent(out) :: ponding1
7441 real (kind=kind_phys), intent(out) :: ponding2
7442
7443! local
7444 integer :: iz,i
7445 real (kind=kind_phys) :: bdsnow !bulk density of snow (kg/m3)
7446! ----------------------------------------------------------------------
7447 snoflow = 0.0
7448 ponding1 = 0.0
7449 ponding2 = 0.0
7450
7451 call snowfall (parameters,nsoil ,nsnow ,dt ,qsnow ,snowhin, & !in
7452 sfctmp ,iloc ,jloc , & !in
7453 isnow ,snowh ,dzsnso ,stc ,snice , & !inout
7454 snliq ,sneqv ) !inout
7455
7456! mb: do each if block separately
7457
7458 if(isnow < 0) & ! when multi-layer
7459 call compact (parameters,nsnow ,nsoil ,dt ,stc ,snice , & !in
7460 snliq ,zsoil ,imelt ,ficeold,iloc , jloc ,& !in
7461 isnow ,dzsnso ,zsnso ) !inout
7462
7463 if(isnow < 0) & !when multi-layer
7464 call combine (parameters,nsnow ,nsoil ,iloc ,jloc , & !in
7465 isnow ,sh2o ,stc ,snice ,snliq , & !inout
7466 dzsnso ,sice ,snowh ,sneqv , & !inout
7467 ponding1 ,ponding2) !out
7468
7469 if(isnow < 0) & !when multi-layer
7470 call divide (parameters,nsnow ,nsoil , & !in
7471 isnow ,stc ,snice ,snliq ,dzsnso ) !inout
7472
7473 call snowh2o (parameters,nsnow ,nsoil ,dt ,qsnfro ,qsnsub , & !in
7474 qrain ,iloc ,jloc , & !in
7475 isnow ,dzsnso ,snowh ,sneqv ,snice , & !inout
7476 snliq ,sh2o ,sice ,stc , & !inout
7477 qsnbot ,ponding1 ,ponding2) !out
7478
7479!set empty snow layers to zero
7480
7481 do iz = -nsnow+1, isnow
7482 snice(iz) = 0.
7483 snliq(iz) = 0.
7484 stc(iz) = 0.
7485 dzsnso(iz)= 0.
7486 zsnso(iz) = 0.
7487 enddo
7488
7489!to obtain equilibrium state of snow in glacier region
7490
7491 if(sneqv > 5000.) then ! 5000 mm -> maximum water depth
7492 bdsnow = snice(0) / dzsnso(0)
7493 snoflow = (sneqv - 5000.)
7494 snice(0) = snice(0) - snoflow
7495 dzsnso(0) = dzsnso(0) - snoflow/bdsnow
7496 snoflow = snoflow / dt
7497 end if
7498
7499! sum up snow mass for layered snow
7500
7501 if(isnow < 0) then ! mb: only do for multi-layer
7502 sneqv = 0.
7503 snowh = 0.
7504 do iz = isnow+1,0
7505 sneqv = sneqv + snice(iz) + snliq(iz)
7506 snowh = snowh + dzsnso(iz)
7507 enddo
7508 end if
7509
7510! reset zsnso and layer thinkness dzsnso
7511
7512 do iz = isnow+1, 0
7513 dzsnso(iz) = -dzsnso(iz)
7514 end do
7515
7516 dzsnso(1) = zsoil(1)
7517 do iz = 2,nsoil
7518 dzsnso(iz) = (zsoil(iz) - zsoil(iz-1))
7519 end do
7520
7521 zsnso(isnow+1) = dzsnso(isnow+1)
7522 do iz = isnow+2 ,nsoil
7523 zsnso(iz) = zsnso(iz-1) + dzsnso(iz)
7524 enddo
7525
7526 do iz = isnow+1 ,nsoil
7527 dzsnso(iz) = -dzsnso(iz)
7528 end do
7529
7530 end subroutine snowwater
7531
7532!== begin snowfall =================================================================================
7533
7537 subroutine snowfall (parameters,nsoil ,nsnow ,dt ,qsnow ,snowhin , & !in
7538 sfctmp ,iloc ,jloc , & !in
7539 isnow ,snowh ,dzsnso ,stc ,snice , & !inout
7540 snliq ,sneqv ) !inout
7541! ----------------------------------------------------------------------
7542! snow depth and density to account for the new snowfall.
7543! new values of snow depth & density returned.
7544! ----------------------------------------------------------------------
7545 implicit none
7546! ----------------------------------------------------------------------
7547! input
7548
7549 type (noahmp_parameters), intent(in) :: parameters
7550 integer, intent(in) :: iloc
7551 integer, intent(in) :: jloc
7552 integer, intent(in) :: nsoil
7553 integer, intent(in) :: nsnow
7554 real (kind=kind_phys), intent(in) :: dt
7555 real (kind=kind_phys), intent(in) :: qsnow
7556 real (kind=kind_phys), intent(in) :: snowhin
7557 real (kind=kind_phys), intent(in) :: sfctmp
7558
7559! input and output
7560
7561 integer, intent(inout) :: isnow
7562 real (kind=kind_phys), intent(inout) :: snowh
7563 real (kind=kind_phys), intent(inout) :: sneqv
7564 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
7565 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
7566 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snice
7567 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snliq
7568
7569! local
7570
7571 integer :: newnode ! 0-no new layers, 1-creating new layers
7572! ----------------------------------------------------------------------
7573 newnode = 0
7574
7575! shallow snow / no layer
7576
7577 if(isnow == 0 .and. qsnow > 0.) then
7578 snowh = snowh + snowhin * dt
7579 sneqv = sneqv + qsnow * dt
7580 end if
7581
7582! creating a new layer
7583
7584 if(isnow == 0 .and. qsnow>0. .and. snowh >= 0.025) then !mb: change limit
7585! if(isnow == 0 .and. qsnow>0. .and. snowh >= 0.05) then
7586 isnow = -1
7587 newnode = 1
7588 dzsnso(0)= snowh
7589 snowh = 0.
7590 stc(0) = min(273.16, sfctmp) ! temporary setup
7591 snice(0) = sneqv
7592 snliq(0) = 0.
7593 end if
7594
7595! snow with layers
7596
7597 if(isnow < 0 .and. newnode == 0 .and. qsnow > 0.) then
7598 snice(isnow+1) = snice(isnow+1) + qsnow * dt
7599 dzsnso(isnow+1) = dzsnso(isnow+1) + snowhin * dt
7600 endif
7601
7602! ----------------------------------------------------------------------
7603 end subroutine snowfall
7604
7605!== begin combine ==================================================================================
7606
7609 subroutine combine (parameters,nsnow ,nsoil ,iloc ,jloc , & !in
7610 isnow ,sh2o ,stc ,snice ,snliq , & !inout
7611 dzsnso ,sice ,snowh ,sneqv , & !inout
7612 ponding1 ,ponding2) !out
7613! ----------------------------------------------------------------------
7614 implicit none
7615! ----------------------------------------------------------------------
7616! input
7617
7618 type (noahmp_parameters), intent(in) :: parameters
7619 integer, intent(in) :: iloc
7620 integer, intent(in) :: jloc
7621 integer, intent(in) :: nsnow
7622 integer, intent(in) :: nsoil
7623
7624! input and output
7625
7626 integer, intent(inout) :: isnow
7627 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sh2o
7628 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sice
7629 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
7630 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snice
7631 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snliq
7632 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
7633 real (kind=kind_phys), intent(inout) :: sneqv
7634 real (kind=kind_phys), intent(inout) :: snowh
7635 real (kind=kind_phys), intent(out) :: ponding1
7636 real (kind=kind_phys), intent(out) :: ponding2
7637
7638! local variables:
7639
7640 integer :: i,j,k,l ! node indices
7641 integer :: isnow_old ! number of top snow layer
7642 integer :: mssi ! node index
7643 integer :: neibor ! adjacent node selected for combination
7644 real (kind=kind_phys) :: zwice ! total ice mass in snow
7645 real (kind=kind_phys) :: zwliq ! total liquid water in snow
7646
7647 real (kind=kind_phys) :: dzmin(3) ! minimum of top snow layer
7648! data dzmin /0.045, 0.05, 0.2/
7649 data dzmin /0.025, 0.025, 0.1/ ! mb: change limit
7650!-----------------------------------------------------------------------
7651
7652 isnow_old = isnow
7653
7654 do j = isnow_old+1,0
7655 if (snice(j) <= .1) then
7656 if(j /= 0) then
7657 snliq(j+1) = snliq(j+1) + snliq(j)
7658 snice(j+1) = snice(j+1) + snice(j)
7659 dzsnso(j+1) = dzsnso(j+1) + dzsnso(j)
7660 else
7661 if (isnow_old < -1) then ! mb/km: change to isnow
7662 snliq(j-1) = snliq(j-1) + snliq(j)
7663 snice(j-1) = snice(j-1) + snice(j)
7664 dzsnso(j-1) = dzsnso(j-1) + dzsnso(j)
7665 else
7666 if(snice(j) >= 0.) then
7667 ponding1 = snliq(j) ! isnow will get set to zero below; ponding1 will get
7668 sneqv = snice(j) ! added to ponding from phasechange ponding should be
7669 snowh = dzsnso(j) ! zero here because it was calculated for thin snow
7670 else ! snice over-sublimated earlier
7671 ponding1 = snliq(j) + snice(j)
7672 if(ponding1 < 0.) then ! if snice and snliq sublimates remove from soil
7673 sice(1) = max(0.0,sice(1)+ponding1/(dzsnso(1)*1000.))
7674 ponding1 = 0.0
7675 end if
7676 sneqv = 0.0
7677 snowh = 0.0
7678 end if
7679 snliq(j) = 0.0
7680 snice(j) = 0.0
7681 dzsnso(j) = 0.0
7682 endif
7683! sh2o(1) = sh2o(1)+snliq(j)/(dzsnso(1)*1000.)
7684! sice(1) = sice(1)+snice(j)/(dzsnso(1)*1000.)
7685 endif
7686
7687 ! shift all elements above this down by one.
7688 if (j > isnow+1 .and. isnow < -1) then
7689 do i = j, isnow+2, -1
7690 stc(i) = stc(i-1)
7691 snliq(i) = snliq(i-1)
7692 snice(i) = snice(i-1)
7693 dzsnso(i)= dzsnso(i-1)
7694 end do
7695 end if
7696 isnow = isnow + 1
7697 end if
7698 end do
7699
7700! to conserve water in case of too large surface sublimation
7701
7702 if(sice(1) < 0.) then
7703 sh2o(1) = sh2o(1) + sice(1)
7704 sice(1) = 0.
7705 end if
7706
7707 if(isnow ==0) return ! mb: get out if no longer multi-layer
7708
7709 sneqv = 0.
7710 snowh = 0.
7711 zwice = 0.
7712 zwliq = 0.
7713
7714 do j = isnow+1,0
7715 sneqv = sneqv + snice(j) + snliq(j)
7716 snowh = snowh + dzsnso(j)
7717 zwice = zwice + snice(j)
7718 zwliq = zwliq + snliq(j)
7719 end do
7720
7721! check the snow depth - all snow gone
7722! the liquid water assumes ponding on soil surface.
7723
7724 if (snowh < 0.025 .and. isnow < 0 ) then ! mb: change limit
7725! if (snowh < 0.05 .and. isnow < 0 ) then
7726 isnow = 0
7727 sneqv = zwice
7728 ponding2 = zwliq ! limit of isnow < 0 means input ponding
7729 if(sneqv <= 0.) snowh = 0. ! should be zero; see above
7730 end if
7731
7732! if (snowh < 0.05 ) then
7733! isnow = 0
7734! sneqv = zwice
7735! sh2o(1) = sh2o(1) + zwliq / (dzsnso(1) * 1000.)
7736! if(sneqv <= 0.) snowh = 0.
7737! end if
7738
7739! check the snow depth - snow layers combined
7740
7741 if (isnow < -1) then
7742
7743 isnow_old = isnow
7744 mssi = 1
7745
7746 do i = isnow_old+1,0
7747 if (dzsnso(i) < dzmin(mssi)) then
7748
7749 if (i == isnow+1) then
7750 neibor = i + 1
7751 else if (i == 0) then
7752 neibor = i - 1
7753 else
7754 neibor = i + 1
7755 if ((dzsnso(i-1)+dzsnso(i)) < (dzsnso(i+1)+dzsnso(i))) neibor = i-1
7756 end if
7757
7758 ! node l and j are combined and stored as node j.
7759 if (neibor > i) then
7760 j = neibor
7761 l = i
7762 else
7763 j = i
7764 l = neibor
7765 end if
7766
7767 call combo (parameters,dzsnso(j), snliq(j), snice(j), &
7768 stc(j), dzsnso(l), snliq(l), snice(l), stc(l) )
7769
7770 ! now shift all elements above this down one.
7771 if (j-1 > isnow+1) then
7772 do k = j-1, isnow+2, -1
7773 stc(k) = stc(k-1)
7774 snice(k) = snice(k-1)
7775 snliq(k) = snliq(k-1)
7776 dzsnso(k) = dzsnso(k-1)
7777 end do
7778 end if
7779
7780 ! decrease the number of snow layers
7781 isnow = isnow + 1
7782 if (isnow >= -1) exit
7783 else
7784
7785 ! the layer thickness is greater than the prescribed minimum value
7786 mssi = mssi + 1
7787
7788 end if
7789 end do
7790
7791 end if
7792
7793 end subroutine combine
7794
7795!== begin divide ===================================================================================
7796
7799 subroutine divide (parameters,nsnow ,nsoil , & !in
7800 isnow ,stc ,snice ,snliq ,dzsnso ) !inout
7801! ----------------------------------------------------------------------
7802 implicit none
7803! ----------------------------------------------------------------------
7804! input
7805
7806 type (noahmp_parameters), intent(in) :: parameters
7807 integer, intent(in) :: nsnow
7808 integer, intent(in) :: nsoil
7809
7810! input and output
7811
7812 integer , intent(inout) :: isnow
7813 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
7814 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snice
7815 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(inout) :: snliq
7816 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
7817
7818! local variables:
7819
7820 integer :: j !indices
7821 integer :: msno !number of layer (top) to msno (bot)
7822 real (kind=kind_phys) :: drr !thickness of the combined [m]
7823 real (kind=kind_phys), dimension( 1:nsnow) :: dz !snow layer thickness [m]
7824 real (kind=kind_phys), dimension( 1:nsnow) :: swice !partial volume of ice [m3/m3]
7825 real (kind=kind_phys), dimension( 1:nsnow) :: swliq !partial volume of liquid water [m3/m3]
7826 real (kind=kind_phys), dimension( 1:nsnow) :: tsno !node temperature [k]
7827 real (kind=kind_phys) :: zwice !temporary
7828 real (kind=kind_phys) :: zwliq !temporary
7829 real (kind=kind_phys) :: propor!temporary
7830 real (kind=kind_phys) :: dtdz !temporary
7831! ----------------------------------------------------------------------
7832
7833 do j = 1,nsnow
7834 if (j <= abs(isnow)) then
7835 dz(j) = dzsnso(j+isnow)
7836 swice(j) = snice(j+isnow)
7837 swliq(j) = snliq(j+isnow)
7838 tsno(j) = stc(j+isnow)
7839 end if
7840 end do
7841
7842 msno = abs(isnow)
7843
7844 if (msno == 1) then
7845 ! specify a new snow layer
7846 if (dz(1) > 0.05) then
7847 msno = 2
7848 dz(1) = dz(1)/2.
7849 swice(1) = swice(1)/2.
7850 swliq(1) = swliq(1)/2.
7851 dz(2) = dz(1)
7852 swice(2) = swice(1)
7853 swliq(2) = swliq(1)
7854 tsno(2) = tsno(1)
7855 end if
7856 end if
7857
7858 if (msno > 1) then
7859 if (dz(1) > 0.05) then
7860 drr = dz(1) - 0.05
7861 propor = drr/dz(1)
7862 zwice = propor*swice(1)
7863 zwliq = propor*swliq(1)
7864 propor = 0.05/dz(1)
7865 swice(1) = propor*swice(1)
7866 swliq(1) = propor*swliq(1)
7867 dz(1) = 0.05
7868
7869 call combo (parameters,dz(2), swliq(2), swice(2), tsno(2), drr, &
7870 zwliq, zwice, tsno(1))
7871
7872 ! subdivide a new layer
7873 if (msno <= 2 .and. dz(2) > 0.20) then ! mb: change limit
7874! if (msno <= 2 .and. dz(2) > 0.10) then
7875 msno = 3
7876 dtdz = (tsno(1) - tsno(2))/((dz(1)+dz(2))/2.)
7877 dz(2) = dz(2)/2.
7878 swice(2) = swice(2)/2.
7879 swliq(2) = swliq(2)/2.
7880 dz(3) = dz(2)
7881 swice(3) = swice(2)
7882 swliq(3) = swliq(2)
7883 tsno(3) = tsno(2) - dtdz*dz(2)/2.
7884 if (tsno(3) >= tfrz) then
7885 tsno(3) = tsno(2)
7886 else
7887 tsno(2) = tsno(2) + dtdz*dz(2)/2.
7888 endif
7889
7890 end if
7891 end if
7892 end if
7893
7894 if (msno > 2) then
7895 if (dz(2) > 0.2) then
7896 drr = dz(2) - 0.2
7897 propor = drr/dz(2)
7898 zwice = propor*swice(2)
7899 zwliq = propor*swliq(2)
7900 propor = 0.2/dz(2)
7901 swice(2) = propor*swice(2)
7902 swliq(2) = propor*swliq(2)
7903 dz(2) = 0.2
7904 call combo (parameters,dz(3), swliq(3), swice(3), tsno(3), drr, &
7905 zwliq, zwice, tsno(2))
7906 end if
7907 end if
7908
7909 isnow = -msno
7910
7911 do j = isnow+1,0
7912 dzsnso(j) = dz(j-isnow)
7913 snice(j) = swice(j-isnow)
7914 snliq(j) = swliq(j-isnow)
7915 stc(j) = tsno(j-isnow)
7916 end do
7917
7918
7919! do j = isnow+1,nsoil
7920! write(*,'(i5,7f10.3)') j, dzsnso(j), snice(j), snliq(j),stc(j)
7921! end do
7922
7923 end subroutine divide
7924
7925!== begin combo ====================================================================================
7926
7929 subroutine combo(parameters,dz, wliq, wice, t, dz2, wliq2, wice2, t2)
7930! ----------------------------------------------------------------------
7931 implicit none
7932! ----------------------------------------------------------------------
7933
7934! ----------------------------------------------------------------------s
7935! input
7936
7937 type (noahmp_parameters), intent(in) :: parameters
7938 real (kind=kind_phys), intent(in) :: dz2
7939 real (kind=kind_phys), intent(in) :: wliq2
7940 real (kind=kind_phys), intent(in) :: wice2
7941 real (kind=kind_phys), intent(in) :: t2
7942 real (kind=kind_phys), intent(inout) :: dz
7943 real (kind=kind_phys), intent(inout) :: wliq
7944 real (kind=kind_phys), intent(inout) :: wice
7945 real (kind=kind_phys), intent(inout) :: t
7946
7947! local
7948
7949 real (kind=kind_phys) :: dzc !total thickness of nodes 1 and 2 (dzc=dz+dz2).
7950 real (kind=kind_phys) :: wliqc !combined liquid water [kg/m2]
7951 real (kind=kind_phys) :: wicec !combined ice [kg/m2]
7952 real (kind=kind_phys) :: tc !combined node temperature [k]
7953 real (kind=kind_phys) :: h !enthalpy of element 1 [j/m2]
7954 real (kind=kind_phys) :: h2 !enthalpy of element 2 [j/m2]
7955 real (kind=kind_phys) :: hc !temporary
7956
7957!-----------------------------------------------------------------------
7958
7959 dzc = dz+dz2
7960 wicec = (wice+wice2)
7961 wliqc = (wliq+wliq2)
7962 h = (cice*wice+cwat*wliq) * (t-tfrz)+hfus*wliq
7963 h2= (cice*wice2+cwat*wliq2) * (t2-tfrz)+hfus*wliq2
7964
7965 hc = h + h2
7966 if(hc < 0.)then
7967 tc = tfrz + hc/(cice*wicec + cwat*wliqc)
7968 else if (hc.le.hfus*wliqc) then
7969 tc = tfrz
7970 else
7971 tc = tfrz + (hc - hfus*wliqc) / (cice*wicec + cwat*wliqc)
7972 end if
7973
7974 dz = dzc
7975 wice = wicec
7976 wliq = wliqc
7977 t = tc
7978
7979 end subroutine combo
7980
7981!== begin compact ==================================================================================
7982
7985 subroutine compact (parameters,nsnow ,nsoil ,dt ,stc ,snice , & !in
7986 snliq ,zsoil ,imelt ,ficeold,iloc , jloc , & !in
7987 isnow ,dzsnso ,zsnso ) !inout
7988! ----------------------------------------------------------------------
7989 implicit none
7990! ----------------------------------------------------------------------
7991! input
7992 type (noahmp_parameters), intent(in) :: parameters
7993 integer, intent(in) :: iloc
7994 integer, intent(in) :: jloc
7995 integer, intent(in) :: nsoil
7996 integer, intent(in) :: nsnow
7997 integer, dimension(-nsnow+1:0) , intent(in) :: imelt
7998 real (kind=kind_phys), intent(in) :: dt
7999 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc
8000 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snice
8001 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snliq
8002 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil
8003 real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: ficeold
8004
8005! input and output
8006 integer, intent(inout) :: isnow
8007 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
8008 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: zsnso
8009
8010! local
8011 real (kind=kind_phys), parameter :: c2 = 21.e-3 ![m3/kg] ! default 21.e-3
8012 real (kind=kind_phys), parameter :: c3 = 2.5e-6 ![1/s]
8013 real (kind=kind_phys), parameter :: c4 = 0.04 ![1/k]
8014 real (kind=kind_phys), parameter :: c5 = 2.0 !
8015 real (kind=kind_phys), parameter :: dm = 100.0 !upper limit on destructive metamorphism compaction [kg/m3]
8016 real (kind=kind_phys), parameter :: eta0 = 1.8e+6 !viscosity coefficient [kg-s/m2]
8017 !according to anderson, it is between 0.52e6~1.38e6
8018 real (kind=kind_phys) :: burden !pressure of overlying snow [kg/m2]
8019 real (kind=kind_phys) :: ddz1 !rate of settling of snow pack due to destructive metamorphism.
8020 real (kind=kind_phys) :: ddz2 !rate of compaction of snow pack due to overburden.
8021 real (kind=kind_phys) :: ddz3 !rate of compaction of snow pack due to melt [1/s]
8022 real (kind=kind_phys) :: dexpf !expf=exp(-c4*(273.15-stc)).
8023 real (kind=kind_phys) :: td !stc - tfrz [k]
8024 real (kind=kind_phys) :: pdzdtc !nodal rate of change in fractional-thickness due to compaction [fraction/s]
8025 real (kind=kind_phys) :: void !void (1 - snice - snliq)
8026 real (kind=kind_phys) :: wx !water mass (ice + liquid) [kg/m2]
8027 real (kind=kind_phys) :: bi !partial density of ice [kg/m3]
8028 real (kind=kind_phys), dimension(-nsnow+1:0) :: fice !fraction of ice at current time step
8029
8030 integer :: j
8031
8032! ----------------------------------------------------------------------
8033 burden = 0.0
8034
8035 do j = isnow+1, 0
8036
8037 wx = snice(j) + snliq(j)
8038 fice(j) = snice(j) / wx
8039 void = 1. - (snice(j)/denice + snliq(j)/denh2o) / dzsnso(j)
8040
8041 ! allow compaction only for non-saturated node and higher ice lens node.
8042 if (void > 0.001 .and. snice(j) > 0.1) then
8043 bi = snice(j) / dzsnso(j)
8044 td = max(0.,tfrz-stc(j))
8045 dexpf = exp(-c4*td)
8046
8047 ! settling as a result of destructive metamorphism
8048
8049 ddz1 = -c3*dexpf
8050
8051 if (bi > dm) ddz1 = ddz1*exp(-46.0e-3*(bi-dm))
8052
8053 ! liquid water term
8054
8055 if (snliq(j) > 0.01*dzsnso(j)) ddz1=ddz1*c5
8056
8057 ! compaction due to overburden
8058
8059 ddz2 = -(burden+0.5*wx)*exp(-0.08*td-c2*bi)/eta0 ! 0.5*wx -> self-burden
8060
8061 ! compaction occurring during melt
8062
8063 if (imelt(j) == 1) then
8064 ddz3 = max(0.,(ficeold(j) - fice(j))/max(1.e-6,ficeold(j)))
8065 ddz3 = - ddz3/dt ! sometimes too large
8066 else
8067 ddz3 = 0.
8068 end if
8069
8070 ! time rate of fractional change in dz (units of s-1)
8071
8072 pdzdtc = (ddz1 + ddz2 + ddz3)*dt
8073 pdzdtc = max(-0.5,pdzdtc)
8074
8075 ! the change in dz due to compaction
8076
8077 dzsnso(j) = dzsnso(j)*(1.+pdzdtc)
8078 dzsnso(j) = min(max(dzsnso(j),(snliq(j)+snice(j))/500.0),(snliq(j)+snice(j))/50.0) ! limit adjustment to a reasonable density
8079 end if
8080
8081 ! pressure of overlying snow
8082
8083 burden = burden + wx
8084
8085 end do
8086
8087 end subroutine compact
8088
8089!== begin snowh2o ==================================================================================
8090
8094 subroutine snowh2o (parameters,nsnow ,nsoil ,dt ,qsnfro ,qsnsub , & !in
8095 qrain ,iloc ,jloc , & !in
8096 isnow ,dzsnso ,snowh ,sneqv ,snice , & !inout
8097 snliq ,sh2o ,sice ,stc , & !inout
8098 qsnbot ,ponding1 ,ponding2) !out
8099! ----------------------------------------------------------------------
8100! renew the mass of ice lens (snice) and liquid (snliq) of the
8101! surface snow layer resulting from sublimation (frost) / evaporation (dew)
8102! ----------------------------------------------------------------------
8103 implicit none
8104! ----------------------------------------------------------------------
8105! input
8106
8107 type (noahmp_parameters), intent(in) :: parameters
8108 integer, intent(in) :: iloc
8109 integer, intent(in) :: jloc
8110 integer, intent(in) :: nsnow
8111 integer, intent(in) :: nsoil
8112 real (kind=kind_phys), intent(in) :: dt
8113 real (kind=kind_phys), intent(in) :: qsnfro
8114 real (kind=kind_phys), intent(in) :: qsnsub
8115 real (kind=kind_phys), intent(in) :: qrain
8116
8117! output
8118
8119 real (kind=kind_phys), intent(out) :: qsnbot
8120
8121! input and output
8122
8123 integer, intent(inout) :: isnow
8124 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso
8125 real (kind=kind_phys), intent(inout) :: snowh
8126 real (kind=kind_phys), intent(inout) :: sneqv
8127 real (kind=kind_phys), dimension(-nsnow+1:0), intent(inout) :: snice
8128 real (kind=kind_phys), dimension(-nsnow+1:0), intent(inout) :: snliq
8129 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sh2o
8130 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sice
8131 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(inout) :: stc
8132
8133! local variables:
8134
8135 integer :: j !do loop/array indices
8136 real (kind=kind_phys) :: qin !water flow into the element (mm/s)
8137 real (kind=kind_phys) :: qout !water flow out of the element (mm/s)
8138 real (kind=kind_phys) :: wgdif !ice mass after minus sublimation
8139 real (kind=kind_phys), dimension(-nsnow+1:0) :: vol_liq !partial volume of liquid water in layer
8140 real (kind=kind_phys), dimension(-nsnow+1:0) :: vol_ice !partial volume of ice lens in layer
8141 real (kind=kind_phys), dimension(-nsnow+1:0) :: epore !effective porosity = porosity - vol_ice
8142 real (kind=kind_phys) :: propor, temp
8143 real (kind=kind_phys) :: ponding1, ponding2
8144 real (kind=kind_phys), parameter :: max_liq_mass_fraction = 0.4
8145! ----------------------------------------------------------------------
8146
8147!for the case when sneqv becomes '0' after 'combine'
8148
8149 if(sneqv == 0.) then
8150 sice(1) = sice(1) + (qsnfro-qsnsub)*dt/(dzsnso(1)*1000.) ! barlage: sh2o->sice v3.6
8151 if(sice(1) < 0.) then
8152 sh2o(1) = sh2o(1) + sice(1)
8153 sice(1) = 0.
8154 end if
8155 end if
8156
8157! for shallow snow without a layer
8158! snow surface sublimation may be larger than existing snow mass. to conserve water,
8159! excessive sublimation is used to reduce soil water. smaller time steps would tend
8160! to aviod this problem.
8161
8162 if(isnow == 0 .and. sneqv > 0.) then
8163 temp = sneqv
8164 sneqv = sneqv - qsnsub*dt + qsnfro*dt
8165 propor = sneqv/temp
8166 snowh = max(0.,propor * snowh)
8167 snowh = min(max(snowh,sneqv/500.0),sneqv/50.0) ! limit adjustment to a reasonable density
8168
8169 if(sneqv < 0.) then
8170 sice(1) = sice(1) + sneqv/(dzsnso(1)*1000.)
8171 sneqv = 0.
8172 snowh = 0.
8173 end if
8174 if(sice(1) < 0.) then
8175 sh2o(1) = sh2o(1) + sice(1)
8176 sice(1) = 0.
8177 end if
8178 end if
8179
8180 if(snowh <= 1.e-6 .or. sneqv <= 1.e-3) then
8181 snowh = 0.0
8182 sneqv = 0.0
8183 end if
8184
8185! for deep snow
8186
8187 if ( isnow < 0 ) then !kwm added this if statement to prevent out-of-bounds array references
8188
8189 wgdif = snice(isnow+1) - qsnsub*dt + qsnfro*dt
8190 snice(isnow+1) = wgdif
8191 if (wgdif < 1.e-6 .and. isnow <0) then
8192 call combine (parameters,nsnow ,nsoil ,iloc, jloc , & !in
8193 isnow ,sh2o ,stc ,snice ,snliq , & !inout
8194 dzsnso ,sice ,snowh ,sneqv , & !inout
8195 ponding1, ponding2 ) !out
8196 endif
8197 !kwm: subroutine combine can change isnow to make it 0 again?
8198 if ( isnow < 0 ) then !kwm added this if statement to prevent out-of-bounds array references
8199 snliq(isnow+1) = snliq(isnow+1) + qrain * dt
8200 snliq(isnow+1) = max(0., snliq(isnow+1))
8201 endif
8202
8203 endif !kwm -- can the endif be moved toward the end of the subroutine (just set qsnbot=0)?
8204
8205! porosity and partial volume
8206
8207 do j = isnow+1, 0
8208 vol_ice(j) = min(1., snice(j)/(dzsnso(j)*denice))
8209 epore(j) = 1. - vol_ice(j)
8210 end do
8211
8212 qin = 0.
8213 qout = 0.
8214
8215 do j = isnow+1, 0
8216 snliq(j) = snliq(j) + qin
8217 vol_liq(j) = snliq(j)/(dzsnso(j)*denh2o)
8218 qout = max(0.,(vol_liq(j)-parameters%ssi*epore(j))*dzsnso(j))
8219 if(j == 0) then
8220 qout = max((vol_liq(j)- epore(j))*dzsnso(j) , parameters%snow_ret_fac*dt*qout)
8221 end if
8222 qout = qout*denh2o
8223 snliq(j) = snliq(j) - qout
8224 if((snliq(j)/(snice(j)+snliq(j))) > max_liq_mass_fraction) then
8225 qout = qout + (snliq(j) - max_liq_mass_fraction/(1.0 - max_liq_mass_fraction)*snice(j))
8226 snliq(j) = max_liq_mass_fraction/(1.0 - max_liq_mass_fraction)*snice(j)
8227 endif
8228 qin = qout
8229 end do
8230
8231 do j = isnow+1, 0
8232 dzsnso(j) = min(max(dzsnso(j),(snliq(j)+snice(j))/500.0),(snliq(j)+snice(j))/50.0) ! limit adjustment to a reasonable density
8233 end do
8234
8235! liquid water from snow bottom to soil
8236
8237 qsnbot = qout / dt ! mm/s
8238
8239 end subroutine snowh2o
8240
8241!== begin soilwater ================================================================================
8242
8245 subroutine soilwater (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in
8246 qinsur ,qseva ,etrani ,sice ,iloc , jloc, & !in
8247 sh2o ,smc ,zwt ,vegtyp ,& !inout
8248 smcwtd, deeprech ,& !inout
8249 runsrf ,qdrain ,runsub ,wcnd ,fcrmax ) !out
8250
8251! ----------------------------------------------------------------------
8252! calculate surface runoff and soil moisture.
8253! ----------------------------------------------------------------------
8254! ----------------------------------------------------------------------
8255 implicit none
8256! ----------------------------------------------------------------------
8257! input
8258 type (noahmp_parameters), intent(in) :: parameters
8259 integer, intent(in) :: iloc
8260 integer, intent(in) :: jloc
8261 integer, intent(in) :: nsoil
8262 integer, intent(in) :: nsnow
8263 real (kind=kind_phys), intent(in) :: dt
8264 real (kind=kind_phys), intent(in) :: qinsur
8265 real (kind=kind_phys), intent(in) :: qseva
8266 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: zsoil
8267 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: etrani
8268 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
8269 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: sice
8270
8271 integer, intent(in) :: vegtyp
8272
8273! input & output
8274 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: sh2o
8275 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: smc
8276 real (kind=kind_phys), intent(inout) :: zwt
8277 real (kind=kind_phys), intent(inout) :: smcwtd
8278 real (kind=kind_phys) , intent(inout) :: deeprech
8279
8280! output
8281 real (kind=kind_phys), intent(out) :: qdrain
8282 real (kind=kind_phys), intent(out) :: runsrf
8283 real (kind=kind_phys), intent(out) :: runsub
8284 real (kind=kind_phys), intent(out) :: fcrmax
8285 real (kind=kind_phys), dimension(1:nsoil), intent(out) :: wcnd
8286
8287! local
8288 integer :: k,iz !do-loop index
8289 integer :: iter !iteration index
8290 real (kind=kind_phys) :: dtfine !fine time step (s)
8291 real (kind=kind_phys), dimension(1:nsoil) :: rhstt !right-hand side term of the matrix
8292 real (kind=kind_phys), dimension(1:nsoil) :: ai !left-hand side term
8293 real (kind=kind_phys), dimension(1:nsoil) :: bi !left-hand side term
8294 real (kind=kind_phys), dimension(1:nsoil) :: ci !left-hand side term
8295
8296 real (kind=kind_phys) :: fff !runoff decay factor (m-1)
8297 real (kind=kind_phys) :: rsbmx !baseflow coefficient [mm/s]
8298 real (kind=kind_phys) :: pddum !infiltration rate at surface (m/s)
8299 real (kind=kind_phys) :: fice !ice fraction in frozen soil
8300 real (kind=kind_phys) :: wplus !saturation excess of the total soil [m]
8301 real (kind=kind_phys) :: rsat !accumulation of wplus (saturation excess) [m]
8302 real (kind=kind_phys) :: sicemax!maximum soil ice content (m3/m3)
8303 real (kind=kind_phys) :: sh2omin!minimum soil liquid water content (m3/m3)
8304 real (kind=kind_phys) :: wtsub !sum of wcnd(k)*dzsnso(k)
8305 real (kind=kind_phys) :: mh2o !water mass removal (mm)
8306 real (kind=kind_phys) :: fsat !fractional saturated area (-)
8307 real (kind=kind_phys), dimension(1:nsoil) :: mliq !
8308 real (kind=kind_phys) :: xs !
8309 real (kind=kind_phys) :: watmin !
8310 real (kind=kind_phys) :: qdrain_save !
8311 real (kind=kind_phys) :: runsrf_save !
8312 real (kind=kind_phys) :: epore !effective porosity [m3/m3]
8313 real (kind=kind_phys), dimension(1:nsoil) :: fcr !impermeable fraction due to frozen soil
8314 integer :: niter !iteration times soil moisture (-)
8315 real (kind=kind_phys) :: smctot !2-m averaged soil moisture (m3/m3)
8316 real (kind=kind_phys) :: dztot !2-m soil depth (m)
8317 real (kind=kind_phys), parameter :: a = 4.0
8318! ----------------------------------------------------------------------
8319 runsrf = 0.0
8320 pddum = 0.0
8321 rsat = 0.0
8322
8323! for the case when snowmelt water is too large
8324
8325 do k = 1,nsoil
8326 epore = max( 1.e-4 , ( parameters%smcmax(k) - sice(k) ) )
8327 rsat = rsat + max(0.,sh2o(k)-epore)*dzsnso(k)
8328 sh2o(k) = min(epore,sh2o(k))
8329 end do
8330
8331!impermeable fraction due to frozen soil
8332
8333 do k = 1,nsoil
8334 fice = min(1.0,sice(k)/parameters%smcmax(k))
8335 fcr(k) = max(0.0,exp(-a*(1.-fice))- exp(-a)) / &
8336 (1.0 - exp(-a))
8337 end do
8338
8339! maximum soil ice content and minimum liquid water of all layers
8340
8341 sicemax = 0.0
8342 fcrmax = 0.0
8343 sh2omin = parameters%smcmax(1)
8344 do k = 1,nsoil
8345 if (sice(k) > sicemax) sicemax = sice(k)
8346 if (fcr(k) > fcrmax) fcrmax = fcr(k)
8347 if (sh2o(k) < sh2omin) sh2omin = sh2o(k)
8348 end do
8349
8350!subsurface runoff for runoff scheme option 2
8351
8352 if(opt_run == 2) then
8353 fff = 2.0
8354 rsbmx = 4.0
8355 call zwteq (parameters,nsoil ,nsnow ,zsoil ,dzsnso ,sh2o ,zwt)
8356 runsub = (1.0-fcrmax) * rsbmx * exp(-parameters%timean) * exp(-fff*zwt) ! mm/s
8357 end if
8358
8359!surface runoff and infiltration rate using different schemes
8360
8361!jref impermable surface at urban
8362 if ( parameters%urban_flag ) fcr(1)= 0.95
8363
8364 if(opt_run == 1) then
8365! fff = 6.0
8366 fff = parameters%bexp(1) / 3.0 ! calibratable, c.he changed based on gy niu's update
8367! fsat = parameters%fsatmx*exp(-0.5*fff*(zwt-2.0))
8368 fsat = parameters%fsatmx*exp(-0.5*fff*zwt) ! c.he changed based on gy niu's update
8369 if(qinsur > 0.) then
8370 runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) )
8371 pddum = qinsur - runsrf ! m/s
8372 end if
8373 end if
8374
8375 if(opt_run == 5) then
8376 fff = 6.0
8377 fsat = parameters%fsatmx*exp(-0.5*fff*max(-2.0-zwt,0.))
8378 if(qinsur > 0.) then
8379 runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) )
8380 pddum = qinsur - runsrf ! m/s
8381 end if
8382 end if
8383
8384 if(opt_run == 2) then
8385 fff = 2.0
8386 fsat = parameters%fsatmx*exp(-0.5*fff*zwt)
8387 if(qinsur > 0.) then
8388 runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) )
8389 pddum = qinsur - runsrf ! m/s
8390 end if
8391 end if
8392
8393 if(opt_run == 3) then
8394 call infil (parameters,nsoil ,dt ,zsoil ,sh2o ,sice , & !in
8395 sicemax,qinsur , & !in
8396 pddum ,runsrf ) !out
8397 end if
8398
8399 if(opt_run == 4) then
8400 smctot = 0.
8401 dztot = 0.
8402 do k = 1,nsoil
8403 dztot = dztot + dzsnso(k)
8404 smctot = smctot + smc(k)/parameters%smcmax(k)*dzsnso(k)
8405 if(dztot >= 2.0) exit
8406 end do
8407 smctot = smctot/dztot
8408 fsat = max(0.01,smctot) ** 4. !bats
8409
8410 if(qinsur > 0.) then
8411 runsrf = qinsur * ((1.0-fcr(1))*fsat+fcr(1))
8412 pddum = qinsur - runsrf ! m/s
8413 end if
8414 end if
8415
8416! determine iteration times and finer time step
8417
8418 niter = 1
8419
8420! if(opt_inf == 1) then !opt_inf =2 may cause water imbalance
8421 niter = 3
8422 if (pddum*dt>dzsnso(1)*parameters%smcmax(1) ) then
8423 niter = niter*2
8424 end if
8425! end if
8426
8427 dtfine = dt / niter
8428
8429! solve soil moisture
8430
8431 qdrain_save = 0.0
8432 runsrf_save = 0.0
8433 do iter = 1, niter
8434 if(qinsur > 0. .and. opt_run == 3) then
8435 call infil (parameters,nsoil ,dtfine ,zsoil ,sh2o ,sice , & !in
8436 sicemax,qinsur , & !in
8437 pddum ,runsrf ) !out
8438 end if
8439
8440 call srt (parameters,nsoil ,zsoil ,dtfine ,pddum ,etrani , & !in
8441 qseva ,sh2o ,smc ,zwt ,fcr , & !in
8442 sicemax,fcrmax ,iloc ,jloc ,smcwtd , & !in
8443 rhstt ,ai ,bi ,ci ,qdrain , & !out
8444 wcnd ) !out
8445
8446 call sstep (parameters,nsoil ,nsnow ,dtfine ,zsoil ,dzsnso , & !in
8447 sice ,iloc ,jloc ,zwt , & !in
8448 sh2o ,smc ,ai ,bi ,ci , & !inout
8449 rhstt ,smcwtd ,qdrain ,deeprech, & !inout
8450 wplus) !out
8451 rsat = rsat + wplus
8452 qdrain_save = qdrain_save + qdrain
8453 runsrf_save = runsrf_save + runsrf
8454 end do
8455
8456 qdrain = qdrain_save/niter
8457 runsrf = runsrf_save/niter
8458
8459 runsrf = runsrf * 1000. + rsat * 1000./dt ! m/s -> mm/s
8460 qdrain = qdrain * 1000.
8461
8462!wrf_hydro_djg...
8463!yw infxsrt = runsrf * dt !mm/s -> mm
8464
8465! removal of soil water due to groundwater flow (option 2)
8466
8467 if(opt_run == 2) then
8468 wtsub = 0.
8469 do k = 1, nsoil
8470 wtsub = wtsub + wcnd(k)*dzsnso(k)
8471 end do
8472
8473 do k = 1, nsoil
8474 mh2o = runsub*dt*(wcnd(k)*dzsnso(k))/wtsub ! mm
8475 sh2o(k) = sh2o(k) - mh2o/(dzsnso(k)*1000.)
8476 end do
8477 end if
8478
8479! limit mliq to be greater than or equal to watmin.
8480! get water needed to bring mliq equal watmin from lower layer.
8481
8482 if(opt_run /= 1) then
8483 do iz = 1, nsoil
8484 mliq(iz) = sh2o(iz)*dzsnso(iz)*1000.
8485 end do
8486
8487 watmin = 0.01 ! mm
8488 do iz = 1, nsoil-1
8489 if (mliq(iz) .lt. 0.) then
8490 xs = watmin-mliq(iz)
8491 else
8492 xs = 0.
8493 end if
8494 mliq(iz ) = mliq(iz ) + xs
8495 mliq(iz+1) = mliq(iz+1) - xs
8496 end do
8497
8498 iz = nsoil
8499 if (mliq(iz) .lt. watmin) then
8500 xs = watmin-mliq(iz)
8501 else
8502 xs = 0.
8503 end if
8504 mliq(iz) = mliq(iz) + xs
8505 runsub = runsub - xs/dt
8506 if(opt_run == 5)deeprech = deeprech - xs*1.e-3
8507
8508 do iz = 1, nsoil
8509 sh2o(iz) = mliq(iz) / (dzsnso(iz)*1000.)
8510 end do
8511 end if
8512
8513 end subroutine soilwater
8514
8515!== begin zwteq ====================================================================================
8516
8519 subroutine zwteq (parameters,nsoil ,nsnow ,zsoil ,dzsnso ,sh2o ,zwt)
8520! ----------------------------------------------------------------------
8521! calculate equilibrium water table depth (niu et al., 2005)
8522! ----------------------------------------------------------------------
8523 implicit none
8524! ----------------------------------------------------------------------
8525! input
8526
8527 type (noahmp_parameters), intent(in) :: parameters
8528 integer, intent(in) :: nsoil
8529 integer, intent(in) :: nsnow
8530 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: zsoil
8531 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso
8532 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: sh2o
8533
8534! output
8535
8536 real (kind=kind_phys), intent(out) :: zwt
8537
8538! locals
8539
8540 integer :: k !do-loop index
8541 integer, parameter :: nfine = 100 !no. of fine soil layers of 6m soil
8542 real (kind=kind_phys) :: wd1 !water deficit from coarse (4-l) soil moisture profile
8543 real (kind=kind_phys) :: wd2 !water deficit from fine (100-l) soil moisture profile
8544 real (kind=kind_phys) :: dzfine !layer thickness of the 100-l soil layers to 6.0 m
8545 real (kind=kind_phys) :: temp !temporary variable
8546 real (kind=kind_phys), dimension(1:nfine) :: zfine !layer-bottom depth of the 100-l soil layers to 6.0 m
8547! ----------------------------------------------------------------------
8548
8549 wd1 = 0.
8550 do k = 1,nsoil
8551 wd1 = wd1 + (parameters%smcmax(1)-sh2o(k)) * dzsnso(k) ! [m]
8552 enddo
8553
8554 dzfine = 3.0 * (-zsoil(nsoil)) / nfine
8555 do k =1,nfine
8556 zfine(k) = float(k) * dzfine
8557 enddo
8558
8559 zwt = -3.*zsoil(nsoil) - 0.001 ! initial value [m]
8560
8561 wd2 = 0.
8562 do k = 1,nfine
8563 temp = 1. + (zwt-zfine(k))/parameters%psisat(1)
8564 wd2 = wd2 + parameters%smcmax(1)*(1.-temp**(-1./parameters%bexp(1)))*dzfine
8565 if(abs(wd2-wd1).le.0.01) then
8566 zwt = zfine(k)
8567 exit
8568 endif
8569 enddo
8570
8571 end subroutine zwteq
8572
8573!== begin infil ====================================================================================
8574
8577 subroutine infil (parameters,nsoil ,dt ,zsoil ,sh2o ,sice , & !in
8578 sicemax,qinsur , & !in
8579 pddum ,runsrf ) !out
8580! --------------------------------------------------------------------------------
8581! compute inflitration rate at soil surface and surface runoff
8582! --------------------------------------------------------------------------------
8583 implicit none
8584! --------------------------------------------------------------------------------
8585! inputs
8586 type (noahmp_parameters), intent(in) :: parameters
8587 integer, intent(in) :: nsoil
8588 real (kind=kind_phys), intent(in) :: dt
8589 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: zsoil
8590 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: sh2o
8591 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: sice
8592 real (kind=kind_phys), intent(in) :: qinsur
8593 real (kind=kind_phys), intent(in) :: sicemax
8594
8595! outputs
8596 real (kind=kind_phys), intent(out) :: runsrf
8597 real (kind=kind_phys), intent(out) :: pddum
8598
8599! locals
8600 integer :: ialp1, j, jj, k
8601 real (kind=kind_phys) :: val
8602 real (kind=kind_phys) :: ddt
8603 real (kind=kind_phys) :: px
8604 real (kind=kind_phys) :: dt1, dd, dice
8605 real (kind=kind_phys) :: fcr
8606 real (kind=kind_phys) :: sum
8607 real (kind=kind_phys) :: acrt
8608 real (kind=kind_phys) :: wdf
8609 real (kind=kind_phys) :: wcnd
8610 real (kind=kind_phys) :: smcav
8611 real (kind=kind_phys) :: infmax
8612 real (kind=kind_phys), dimension(1:nsoil) :: dmax
8613 integer, parameter :: cvfrz = 3
8614! --------------------------------------------------------------------------------
8615
8616 if (qinsur > 0.0) then
8617 dt1 = dt /86400.
8618 smcav = parameters%smcmax(1) - parameters%smcwlt(1)
8619
8620! maximum infiltration rate
8621
8622 dmax(1)= -zsoil(1) * smcav
8623 dice = -zsoil(1) * sice(1)
8624 dmax(1)= dmax(1)* (1.0-(sh2o(1) + sice(1) - parameters%smcwlt(1))/smcav)
8625
8626 dd = dmax(1)
8627
8628 do k = 2,nsoil
8629 dice = dice + (zsoil(k-1) - zsoil(k) ) * sice(k)
8630 dmax(k) = (zsoil(k-1) - zsoil(k)) * smcav
8631 dmax(k) = dmax(k) * (1.0-(sh2o(k) + sice(k) - parameters%smcwlt(k))/smcav)
8632 dd = dd + dmax(k)
8633 end do
8634
8635 val = (1. - exp( - parameters%kdt * dt1))
8636 ddt = dd * val
8637 px = max(0.,qinsur * dt)
8638 infmax = (px * (ddt / (px + ddt)))/ dt
8639
8640! impermeable fraction due to frozen soil
8641
8642 fcr = 1.
8643 if (dice > 1.e-2) then
8644 acrt = cvfrz * parameters%frzx / dice
8645 sum = 1.
8646 ialp1 = cvfrz - 1
8647 do j = 1,ialp1
8648 k = 1
8649 do jj = j +1,ialp1
8650 k = k * jj
8651 end do
8652 sum = sum + (acrt ** (cvfrz - j)) / float(k)
8653 end do
8654 fcr = 1. - exp(-acrt) * sum
8655 end if
8656
8657! correction of infiltration limitation
8658
8659 infmax = infmax * fcr
8660
8661! jref for urban areas
8662! if ( parameters%urban_flag ) infmax == infmax * 0.05
8663
8664 call wdfcnd2 (parameters,wdf,wcnd,sh2o(1),sicemax,1)
8665 infmax = max(infmax,wcnd)
8666 infmax = min(infmax,px/dt)
8667
8668 runsrf= max(0., qinsur - infmax)
8669 pddum = qinsur - runsrf
8670
8671 end if
8672
8673 end subroutine infil
8674
8675!== begin srt ======================================================================================
8676
8681 subroutine srt (parameters,nsoil ,zsoil ,dt ,pddum ,etrani , & !in
8682 qseva ,sh2o ,smc ,zwt ,fcr , & !in
8683 sicemax,fcrmax ,iloc ,jloc ,smcwtd , & !in
8684 rhstt ,ai ,bi ,ci ,qdrain , & !out
8685 wcnd ) !out
8686! ----------------------------------------------------------------------
8687! calculate the right hand side of the time tendency term of the soil
8688! water diffusion equation. also to compute ( prepare ) the matrix
8689! coefficients for the tri-diagonal matrix of the implicit time scheme.
8690! ----------------------------------------------------------------------
8691 implicit none
8692! ----------------------------------------------------------------------
8693!input
8694
8695 type (noahmp_parameters), intent(in) :: parameters
8696 integer, intent(in) :: iloc !grid index
8697 integer, intent(in) :: jloc !grid index
8698 integer, intent(in) :: nsoil
8699 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: zsoil
8700 real (kind=kind_phys), intent(in) :: dt
8701 real (kind=kind_phys), intent(in) :: pddum
8702 real (kind=kind_phys), intent(in) :: qseva
8703 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: etrani
8704 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: sh2o
8705 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: smc
8706 real (kind=kind_phys), intent(in) :: zwt ! water table depth [m]
8707 real (kind=kind_phys), dimension(1:nsoil), intent(in) :: fcr
8708 real (kind=kind_phys), intent(in) :: fcrmax !maximum of fcr (-)
8709 real (kind=kind_phys), intent(in) :: sicemax!maximum soil ice content (m3/m3)
8710 real (kind=kind_phys), intent(in) :: smcwtd !soil moisture between bottom of the soil and the water table
8711
8712! output
8713
8714 real (kind=kind_phys), dimension(1:nsoil), intent(out) :: rhstt
8715 real (kind=kind_phys), dimension(1:nsoil), intent(out) :: ai
8716 real (kind=kind_phys), dimension(1:nsoil), intent(out) :: bi
8717 real (kind=kind_phys), dimension(1:nsoil), intent(out) :: ci
8718 real (kind=kind_phys), dimension(1:nsoil), intent(out) :: wcnd !hydraulic conductivity (m/s)
8719 real (kind=kind_phys), intent(out) :: qdrain !bottom drainage (m/s)
8720
8721! local
8722 integer :: k
8723 real (kind=kind_phys), dimension(1:nsoil) :: ddz
8724 real (kind=kind_phys), dimension(1:nsoil) :: denom
8725 real (kind=kind_phys), dimension(1:nsoil) :: dsmdz
8726 real (kind=kind_phys), dimension(1:nsoil) :: wflux
8727 real (kind=kind_phys), dimension(1:nsoil) :: wdf
8728 real (kind=kind_phys), dimension(1:nsoil) :: smx
8729 real (kind=kind_phys) :: temp1
8730 real (kind=kind_phys) :: smxwtd !soil moisture between bottom of the soil and water table
8731 real (kind=kind_phys) :: smxbot !soil moisture below bottom to calculate flux
8732
8733! niu and yang (2006), j. of hydrometeorology
8734! ----------------------------------------------------------------------
8735
8736 if(opt_inf == 1) then
8737 do k = 1, nsoil
8738 call wdfcnd1 (parameters,wdf(k),wcnd(k),smc(k),fcr(k),k)
8739 smx(k) = smc(k)
8740 end do
8741 if(opt_run == 5)smxwtd=smcwtd
8742 end if
8743
8744 if(opt_inf == 2) then
8745 do k = 1, nsoil
8746 call wdfcnd2 (parameters,wdf(k),wcnd(k),sh2o(k),sicemax,k)
8747 smx(k) = sh2o(k)
8748 end do
8749 if(opt_run == 5)smxwtd=smcwtd*sh2o(nsoil)/smc(nsoil) !same liquid fraction as in the bottom layer
8750 end if
8751
8752 do k = 1, nsoil
8753 if(k == 1) then
8754 denom(k) = - zsoil(k)
8755 temp1 = - zsoil(k+1)
8756 ddz(k) = 2.0 / temp1
8757 dsmdz(k) = 2.0 * (smx(k) - smx(k+1)) / temp1
8758 wflux(k) = wdf(k) * dsmdz(k) + wcnd(k) - pddum + etrani(k) + qseva
8759 else if (k < nsoil) then
8760 denom(k) = (zsoil(k-1) - zsoil(k))
8761 temp1 = (zsoil(k-1) - zsoil(k+1))
8762 ddz(k) = 2.0 / temp1
8763 dsmdz(k) = 2.0 * (smx(k) - smx(k+1)) / temp1
8764 wflux(k) = wdf(k ) * dsmdz(k ) + wcnd(k ) &
8765 - wdf(k-1) * dsmdz(k-1) - wcnd(k-1) + etrani(k)
8766 else
8767 denom(k) = (zsoil(k-1) - zsoil(k))
8768 if(opt_run == 1 .or. opt_run == 2) then
8769 qdrain = 0.
8770 end if
8771 if(opt_run == 3) then
8772 qdrain = parameters%slope*wcnd(k)
8773 end if
8774 if(opt_run == 4) then
8775 qdrain = (1.0-fcrmax)*wcnd(k)
8776 end if
8777 if(opt_run == 5) then !gmm new m-m&f water table dynamics formulation
8778 temp1 = 2.0 * denom(k)
8779 if(zwt < zsoil(nsoil)-denom(nsoil))then
8780!gmm interpolate from below, midway to the water table, to the middle of the auxiliary layer below the soil bottom
8781 smxbot = smx(k) - (smx(k)-smxwtd) * denom(k) * 2./ (denom(k) + zsoil(k) - zwt)
8782 else
8783 smxbot = smxwtd
8784 endif
8785 dsmdz(k) = 2.0 * (smx(k) - smxbot) / temp1
8786 qdrain = wdf(k ) * dsmdz(k ) + wcnd(k )
8787 end if
8788 wflux(k) = -(wdf(k-1)*dsmdz(k-1))-wcnd(k-1)+etrani(k) + qdrain
8789 end if
8790 end do
8791
8792 do k = 1, nsoil
8793 if(k == 1) then
8794 ai(k) = 0.0
8795 bi(k) = wdf(k ) * ddz(k ) / denom(k)
8796 ci(k) = - bi(k)
8797 else if (k < nsoil) then
8798 ai(k) = - wdf(k-1) * ddz(k-1) / denom(k)
8799 ci(k) = - wdf(k ) * ddz(k ) / denom(k)
8800 bi(k) = - ( ai(k) + ci(k) )
8801 else
8802 ai(k) = - wdf(k-1) * ddz(k-1) / denom(k)
8803 ci(k) = 0.0
8804 bi(k) = - ( ai(k) + ci(k) )
8805 end if
8806 rhstt(k) = wflux(k) / (-denom(k))
8807 end do
8808
8809! ----------------------------------------------------------------------
8810 end subroutine srt
8811
8812!== begin sstep ====================================================================================
8813
8816 subroutine sstep (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in
8817 sice ,iloc ,jloc ,zwt , & !in
8818 sh2o ,smc ,ai ,bi ,ci , & !inout
8819 rhstt ,smcwtd ,qdrain ,deeprech, & !inout
8820 wplus ) !out
8821
8822! ----------------------------------------------------------------------
8823! calculate/update soil moisture content values
8824! ----------------------------------------------------------------------
8825 implicit none
8826! ----------------------------------------------------------------------
8827!input
8828
8829 type (noahmp_parameters), intent(in) :: parameters
8830 integer, intent(in) :: iloc !grid index
8831 integer, intent(in) :: jloc !grid index
8832 integer, intent(in) :: nsoil !
8833 integer, intent(in) :: nsnow !
8834 real (kind=kind_phys), intent(in) :: dt
8835 real (kind=kind_phys), intent(in) :: zwt
8836 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil
8837 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: sice
8838 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso ! snow/soil layer thickness [m]
8839
8840!input and output
8841 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: sh2o
8842 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: smc
8843 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: ai
8844 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: bi
8845 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: ci
8846 real (kind=kind_phys), dimension(1:nsoil), intent(inout) :: rhstt
8847 real (kind=kind_phys) , intent(inout) :: smcwtd
8848 real (kind=kind_phys) , intent(inout) :: qdrain
8849 real (kind=kind_phys) , intent(inout) :: deeprech
8850
8851!output
8852 real (kind=kind_phys), intent(out) :: wplus !saturation excess water (m)
8853
8854!local
8855 integer :: k
8856 real (kind=kind_phys), dimension(1:nsoil) :: rhsttin
8857 real (kind=kind_phys), dimension(1:nsoil) :: ciin
8858 real (kind=kind_phys) :: stot
8859 real (kind=kind_phys) :: epore
8860 real (kind=kind_phys) :: wminus
8861! ----------------------------------------------------------------------
8862 wplus = 0.0
8863
8864 do k = 1,nsoil
8865 rhstt(k) = rhstt(k) * dt
8866 ai(k) = ai(k) * dt
8867 bi(k) = 1. + bi(k) * dt
8868 ci(k) = ci(k) * dt
8869 end do
8870
8871! copy values for input variables before calling rosr12
8872
8873 do k = 1,nsoil
8874 rhsttin(k) = rhstt(k)
8875 ciin(k) = ci(k)
8876 end do
8877
8878! call rosr12 to solve the tri-diagonal matrix
8879
8880 call rosr12 (ci,ai,bi,ciin,rhsttin,rhstt,1,nsoil,0)
8881
8882 do k = 1,nsoil
8883 sh2o(k) = sh2o(k) + ci(k)
8884 enddo
8885
8886! excessive water above saturation in a layer is moved to
8887! its unsaturated layer like in a bucket
8888
8889!gmmwith opt_run=5 there is soil moisture below nsoil, to the water table
8890 if(opt_run == 5) then
8891
8892!update smcwtd
8893
8894 if(zwt < zsoil(nsoil)-dzsnso(nsoil))then
8895!accumulate qdrain to update deep water table and soil moisture later
8896 deeprech = deeprech + dt * qdrain
8897 else
8898 smcwtd = smcwtd + dt * qdrain / dzsnso(nsoil)
8899 wplus = max((smcwtd-parameters%smcmax(nsoil)), 0.0) * dzsnso(nsoil)
8900 wminus = max((1.e-4-smcwtd), 0.0) * dzsnso(nsoil)
8901
8902 smcwtd = max( min(smcwtd,parameters%smcmax(nsoil)) , 1.e-4)
8903 sh2o(nsoil) = sh2o(nsoil) + wplus/dzsnso(nsoil)
8904
8905!reduce fluxes at the bottom boundaries accordingly
8906 qdrain = qdrain - wplus/dt
8907 deeprech = deeprech - wminus
8908 endif
8909
8910 endif
8911
8912 do k = nsoil,2,-1
8913 epore = max( 1.e-4 , ( parameters%smcmax(k) - sice(k) ) )
8914 wplus = max((sh2o(k)-epore), 0.0) * dzsnso(k)
8915 sh2o(k) = min(epore,sh2o(k))
8916 sh2o(k-1) = sh2o(k-1) + wplus/dzsnso(k-1)
8917 end do
8918
8919 epore = max( 1.e-4 , ( parameters%smcmax(1) - sice(1) ) )
8920 wplus = max((sh2o(1)-epore), 0.0) * dzsnso(1)
8921 sh2o(1) = min(epore,sh2o(1))
8922
8923 if(wplus > 0.0) then
8924 sh2o(2) = sh2o(2) + wplus/dzsnso(2)
8925 do k = 2,nsoil-1
8926 epore = max( 1.e-4 , ( parameters%smcmax(k) - sice(k) ) )
8927 wplus = max((sh2o(k)-epore), 0.0) * dzsnso(k)
8928 sh2o(k) = min(epore,sh2o(k))
8929 sh2o(k+1) = sh2o(k+1) + wplus/dzsnso(k+1)
8930 end do
8931
8932 epore = max( 1.e-4 , ( parameters%smcmax(nsoil) - sice(nsoil) ) )
8933 wplus = max((sh2o(nsoil)-epore), 0.0) * dzsnso(nsoil)
8934 sh2o(nsoil) = min(epore,sh2o(nsoil))
8935 end if
8936
8937 smc = sh2o + sice
8938
8939 end subroutine sstep
8940
8941!== begin wdfcnd1 ==================================================================================
8942
8945 subroutine wdfcnd1 (parameters,wdf,wcnd,smc,fcr,isoil)
8946! ----------------------------------------------------------------------
8947! calculate soil water diffusivity and soil hydraulic conductivity.
8948! ----------------------------------------------------------------------
8949 implicit none
8950! ----------------------------------------------------------------------
8951! input
8952 type (noahmp_parameters), intent(in) :: parameters
8953 real (kind=kind_phys),intent(in) :: smc
8954 real (kind=kind_phys),intent(in) :: fcr
8955 integer,intent(in) :: isoil
8956
8957! output
8958 real (kind=kind_phys),intent(out) :: wcnd
8959 real (kind=kind_phys),intent(out) :: wdf
8960
8961! local
8962 real (kind=kind_phys) :: expon
8963 real (kind=kind_phys) :: factr
8964 real (kind=kind_phys) :: vkwgt
8965! ----------------------------------------------------------------------
8966
8967! soil water diffusivity
8968
8969 factr = max(0.01, smc/parameters%smcmax(isoil))
8970 expon = parameters%bexp(isoil) + 2.0
8971 wdf = parameters%dwsat(isoil) * factr ** expon
8972 wdf = wdf * (1.0 - fcr)
8973
8974! hydraulic conductivity
8975
8976 expon = 2.0*parameters%bexp(isoil) + 3.0
8977 wcnd = parameters%dksat(isoil) * factr ** expon
8978 wcnd = wcnd * (1.0 - fcr)
8979
8980 end subroutine wdfcnd1
8981
8982!== begin wdfcnd2 ==================================================================================
8983
8986 subroutine wdfcnd2 (parameters,wdf,wcnd,smc,sice,isoil)
8987! ----------------------------------------------------------------------
8988! calculate soil water diffusivity and soil hydraulic conductivity.
8989! ----------------------------------------------------------------------
8990 implicit none
8991! ----------------------------------------------------------------------
8992! input
8993 type (noahmp_parameters), intent(in) :: parameters
8994 real (kind=kind_phys),intent(in) :: smc
8995 real (kind=kind_phys),intent(in) :: sice
8996 integer,intent(in) :: isoil
8997
8998! output
8999 real (kind=kind_phys),intent(out) :: wcnd
9000 real (kind=kind_phys),intent(out) :: wdf
9001
9002! local
9003 real (kind=kind_phys) :: expon
9004 real (kind=kind_phys) :: factr1,factr2
9005 real (kind=kind_phys) :: vkwgt
9006! ----------------------------------------------------------------------
9007
9008! soil water diffusivity
9009
9010 factr1 = 0.05/parameters%smcmax(isoil)
9011 factr2 = max(0.01, smc/parameters%smcmax(isoil))
9012 factr1 = min(factr1,factr2)
9013 expon = parameters%bexp(isoil) + 2.0
9014 wdf = parameters%dwsat(isoil) * factr2 ** expon
9015
9016 if (sice > 0.0) then
9017 vkwgt = 1./ (1. + (500.* sice)**3.)
9018 wdf = vkwgt * wdf + (1.-vkwgt)*parameters%dwsat(isoil)*(factr1)**expon
9019 end if
9020
9021! hydraulic conductivity
9022
9023 expon = 2.0*parameters%bexp(isoil) + 3.0
9024 wcnd = parameters%dksat(isoil) * factr2 ** expon
9025
9026 end subroutine wdfcnd2
9027
9028!== begin groundwater ==============================================================================
9029
9032 subroutine groundwater(parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in
9033 stc ,wcnd ,fcrmax ,iloc ,jloc , & !in
9034 sh2o ,zwt ,wa ,wt , & !inout
9035 qin ,qdis ) !out
9036! ----------------------------------------------------------------------
9037 implicit none
9038! ----------------------------------------------------------------------
9039! input
9040 type (noahmp_parameters), intent(in) :: parameters
9041 integer, intent(in) :: iloc !grid index
9042 integer, intent(in) :: jloc !grid index
9043 integer, intent(in) :: nsnow !maximum no. of snow layers
9044 integer, intent(in) :: nsoil !no. of soil layers
9045 real (kind=kind_phys), intent(in) :: dt !timestep [sec]
9046 real (kind=kind_phys), intent(in) :: fcrmax!maximum fcr (-)
9047 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: sice !soil ice content [m3/m3]
9048 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m]
9049 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: wcnd !hydraulic conductivity (m/s)
9050 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature (k)
9051
9052! input and output
9053 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: sh2o !liquid soil water [m3/m3]
9054 real (kind=kind_phys), intent(inout) :: zwt !the depth to water table [m]
9055 real (kind=kind_phys), intent(inout) :: wa !water storage in aquifer [mm]
9056 real (kind=kind_phys), intent(inout) :: wt !water storage in aquifer
9057 !+ saturated soil [mm]
9058! output
9059 real (kind=kind_phys), intent(out) :: qin !groundwater recharge [mm/s]
9060 real (kind=kind_phys), intent(out) :: qdis !groundwater discharge [mm/s]
9061
9062! local
9063 real (kind=kind_phys) :: fff !runoff decay factor (m-1)
9064 real (kind=kind_phys) :: rsbmx !baseflow coefficient [mm/s]
9065 integer :: iz !do-loop index
9066 integer :: iwt !layer index above water table layer
9067 real (kind=kind_phys), dimension( 1:nsoil) :: dzmm !layer thickness [mm]
9068 real (kind=kind_phys), dimension( 1:nsoil) :: znode !node depth [m]
9069 real (kind=kind_phys), dimension( 1:nsoil) :: mliq !liquid water mass [kg/m2 or mm]
9070 real (kind=kind_phys), dimension( 1:nsoil) :: epore !effective porosity [-]
9071 real (kind=kind_phys), dimension( 1:nsoil) :: hk !hydraulic conductivity [mm/s]
9072 real (kind=kind_phys), dimension( 1:nsoil) :: smc !total soil water content [m3/m3]
9073 real (kind=kind_phys) :: s_node!degree of saturation of iwt layer
9074 real (kind=kind_phys) :: dzsum !cumulative depth above water table [m]
9075 real (kind=kind_phys) :: smpfz !matric potential (frozen effects) [mm]
9076 real (kind=kind_phys) :: ka !aquifer hydraulic conductivity [mm/s]
9077 real (kind=kind_phys) :: wh_zwt!water head at water table [mm]
9078 real (kind=kind_phys) :: wh !water head at layer above zwt [mm]
9079 real (kind=kind_phys) :: ws !water used to fill air pore [mm]
9080 real (kind=kind_phys) :: wtsub !sum of hk*dzmm
9081 real (kind=kind_phys) :: watmin!minimum soil vol soil moisture [m3/m3]
9082 real (kind=kind_phys) :: xs !excessive water above saturation [mm]
9083 real (kind=kind_phys), parameter :: rous = 0.2 !specific yield [-]
9084! real (kind=kind_phys), parameter :: cmic = 0.20 !microprore content (0.0-1.0)
9085 !0.0-close to free drainage
9086 real (kind=kind_phys), parameter :: cmic = 0.80 ! calibratable, c.he changed based on gy niu's update
9087! -------------------------------------------------------------
9088 qdis = 0.0
9089 qin = 0.0
9090
9091! derive layer-bottom depth in [mm]
9092!kwm: derive layer thickness in mm
9093
9094 dzmm(1) = -zsoil(1)*1.e3
9095 do iz = 2, nsoil
9096 dzmm(iz) = 1.e3 * (zsoil(iz - 1) - zsoil(iz))
9097 enddo
9098
9099! derive node (middle) depth in [m]
9100!kwm: positive number, depth below ground surface in m
9101 znode(1) = -zsoil(1) / 2.
9102 do iz = 2, nsoil
9103 znode(iz) = -zsoil(iz-1) + 0.5 * (zsoil(iz-1) - zsoil(iz))
9104 enddo
9105
9106! convert volumetric soil moisture "sh2o" to mass
9107
9108 do iz = 1, nsoil
9109 smc(iz) = sh2o(iz) + sice(iz)
9110 mliq(iz) = sh2o(iz) * dzmm(iz)
9111 epore(iz) = max(0.01,parameters%smcmax(iz) - sice(iz))
9112 hk(iz) = 1.e3*wcnd(iz)
9113 enddo
9114
9115! the layer index of the first unsaturated layer,
9116! i.e., the layer right above the water table
9117
9118 iwt = nsoil
9119 do iz = 2,nsoil
9120 if(zwt .le. -zsoil(iz) ) then
9121 iwt = iz-1
9122 exit
9123 end if
9124 enddo
9125
9126! groundwater discharge [mm/s]
9127
9128! fff = 6.0
9129! rsbmx = 5.0
9130 fff = parameters%bexp(iwt) / 3.0 ! calibratable, c.he changed based on gy niu's update
9131 rsbmx = hk(iwt) * 1.0e3 * exp(3.0) ! mm/s, calibratable, c.he changed based on gy niu's update
9132
9133! qdis = (1.0-fcrmax)*rsbmx*exp(-parameters%timean)*exp(-fff*(zwt-2.0))
9134 qdis = (1.0-fcrmax)*rsbmx*exp(-parameters%timean)*exp(-fff*zwt) ! c.he changed based on gy niu's update
9135
9136! matric potential at the layer above the water table
9137
9138 s_node = min(1.0,smc(iwt)/parameters%smcmax(iwt) )
9139 s_node = max(s_node,real(0.01,kind=8))
9140 smpfz = -parameters%psisat(iwt)*1000.*s_node**(-parameters%bexp(iwt)) ! m --> mm
9141 smpfz = max(-120000.0,cmic*smpfz)
9142
9143! recharge rate qin to groundwater
9144
9145 ka = 0.5*(hk(iwt)+parameters%dksat(iwt)*1.0e3)
9146
9147 wh_zwt = - zwt * 1.e3 !(mm)
9148 wh = smpfz - znode(iwt)*1.e3 !(mm)
9149 qin = - ka * (wh_zwt-wh) /((zwt-znode(iwt))*1.e3)
9150 qin = max(-10.0/dt,min(10./dt,qin))
9151
9152! water storage in the aquifer + saturated soil
9153
9154 wt = wt + (qin - qdis) * dt !(mm)
9155
9156 if(iwt.eq.nsoil) then
9157 wa = wa + (qin - qdis) * dt !(mm)
9158 wt = wa
9159 zwt = (-zsoil(nsoil) + 25.) - wa/1000./rous !(m)
9160 mliq(nsoil) = mliq(nsoil) - qin * dt ! [mm]
9161
9162 mliq(nsoil) = mliq(nsoil) + max(0.,(wa - 5000.))
9163 wa = min(wa, 5000.)
9164 else
9165
9166 if (iwt.eq.nsoil-1) then
9167 zwt = -zsoil(nsoil) &
9168 - (wt-rous*1000*25.) / (epore(nsoil))/1000.
9169 else
9170 ws = 0. ! water used to fill soil air pores
9171 do iz = iwt+2,nsoil
9172 ws = ws + epore(iz) * dzmm(iz)
9173 enddo
9174 zwt = -zsoil(iwt+1) &
9175 - (wt-rous*1000.*25.-ws) /(epore(iwt+1))/1000.
9176 endif
9177
9178 wtsub = 0.
9179 do iz = 1, nsoil
9180 wtsub = wtsub + hk(iz)*dzmm(iz)
9181 end do
9182
9183 do iz = 1, nsoil ! removing subsurface runoff
9184 mliq(iz) = mliq(iz) - qdis*dt*hk(iz)*dzmm(iz)/wtsub
9185 end do
9186 end if
9187
9188 zwt = max(1.5,zwt)
9189
9190!
9191! limit mliq to be greater than or equal to watmin.
9192! get water needed to bring mliq equal watmin from lower layer.
9193!
9194 watmin = 0.01
9195 do iz = 1, nsoil-1
9196 if (mliq(iz) .lt. 0.) then
9197 xs = watmin-mliq(iz)
9198 else
9199 xs = 0.
9200 end if
9201 mliq(iz ) = mliq(iz ) + xs
9202 mliq(iz+1) = mliq(iz+1) - xs
9203 end do
9204
9205 iz = nsoil
9206 if (mliq(iz) .lt. watmin) then
9207 xs = watmin-mliq(iz)
9208 else
9209 xs = 0.
9210 end if
9211 mliq(iz) = mliq(iz) + xs
9212 wa = wa - xs
9213 wt = wt - xs
9214
9215 do iz = 1, nsoil
9216 sh2o(iz) = mliq(iz) / dzmm(iz)
9217 end do
9218
9219 end subroutine groundwater
9220
9221!== begin shallowwatertable ========================================================================
9222
9226 subroutine shallowwatertable (parameters,nsnow ,nsoil ,zsoil, dt , & !in
9227 dzsnso ,smceq ,iloc ,jloc , & !in
9228 smc ,wtd ,smcwtd ,rech, qdrain ) !inout
9229! ----------------------------------------------------------------------
9230!diagnoses water table depth and computes recharge when the water table is within the resolved soil layers,
9231!according to the miguez-macho&fan scheme
9232! ----------------------------------------------------------------------
9233 implicit none
9234! ----------------------------------------------------------------------
9235! input
9236 type (noahmp_parameters), intent(in) :: parameters
9237 integer, intent(in) :: nsnow !maximum no. of snow layers
9238 integer, intent(in) :: nsoil !no. of soil layers
9239 integer, intent(in) :: iloc,jloc
9240 real (kind=kind_phys), intent(in) :: dt
9241 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m]
9242 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso ! snow/soil layer thickness [m]
9243 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smceq !equilibrium soil water content [m3/m3]
9244
9245! input and output
9246 real (kind=kind_phys), dimension( 1:nsoil), intent(inout) :: smc !total soil water content [m3/m3]
9247 real (kind=kind_phys), intent(inout) :: wtd !the depth to water table [m]
9248 real (kind=kind_phys), intent(inout) :: smcwtd !soil moisture between bottom of the soil and the water table [m3/m3]
9249 real (kind=kind_phys), intent(out) :: rech ! groundwater recharge (net vertical flux across the water table), positive up
9250 real (kind=kind_phys), intent(inout) :: qdrain
9251
9252! local
9253 integer :: iz !do-loop index
9254 integer :: iwtd !layer index above water table layer
9255 integer :: kwtd !layer index where the water table layer is
9256 real (kind=kind_phys) :: wtdold
9257 real (kind=kind_phys) :: dzup
9258 real (kind=kind_phys) :: smceqdeep
9259 real (kind=kind_phys), dimension( 0:nsoil) :: zsoil0
9260! -------------------------------------------------------------
9261
9262
9263zsoil0(1:nsoil) = zsoil(1:nsoil)
9264zsoil0(0) = 0.
9265
9266!find the layer where the water table is
9267 do iz=nsoil,1,-1
9268 if(wtd + 1.e-6 < zsoil0(iz)) exit
9269 enddo
9270 iwtd=iz
9271
9272
9273 kwtd=iwtd+1 !layer where the water table is
9274 if(kwtd.le.nsoil)then !wtd in the resolved layers
9275 wtdold=wtd
9276 if(smc(kwtd).gt.smceq(kwtd))then
9277
9278 if(smc(kwtd).eq.parameters%smcmax(kwtd))then !wtd went to the layer above
9279 wtd=zsoil0(iwtd)
9280 rech=-(wtdold-wtd) * (parameters%smcmax(kwtd)-smceq(kwtd))
9281 iwtd=iwtd-1
9282 kwtd=kwtd-1
9283 if(kwtd.ge.1)then
9284 if(smc(kwtd).gt.smceq(kwtd))then
9285 wtdold=wtd
9286 wtd = min( ( smc(kwtd)*dzsnso(kwtd) &
9287 - smceq(kwtd)*zsoil0(iwtd) + parameters%smcmax(kwtd)*zsoil0(kwtd) ) / &
9288 ( parameters%smcmax(kwtd)-smceq(kwtd) ), zsoil0(iwtd))
9289 rech=rech-(wtdold-wtd) * (parameters%smcmax(kwtd)-smceq(kwtd))
9290 endif
9291 endif
9292 else !wtd stays in the layer
9293 wtd = min( ( smc(kwtd)*dzsnso(kwtd) &
9294 - smceq(kwtd)*zsoil0(iwtd) + parameters%smcmax(kwtd)*zsoil0(kwtd) ) / &
9295 ( parameters%smcmax(kwtd)-smceq(kwtd) ), zsoil0(iwtd))
9296 rech=-(wtdold-wtd) * (parameters%smcmax(kwtd)-smceq(kwtd))
9297 endif
9298
9299 else !wtd has gone down to the layer below
9300 wtd=zsoil0(kwtd)
9301 rech=-(wtdold-wtd) * (parameters%smcmax(kwtd)-smceq(kwtd))
9302 kwtd=kwtd+1
9303 iwtd=iwtd+1
9304!wtd crossed to the layer below. now adjust it there
9305 if(kwtd.le.nsoil)then
9306 wtdold=wtd
9307 if(smc(kwtd).gt.smceq(kwtd))then
9308 wtd = min( ( smc(kwtd)*dzsnso(kwtd) &
9309 - smceq(kwtd)*zsoil0(iwtd) + parameters%smcmax(kwtd)*zsoil0(kwtd) ) / &
9310 ( parameters%smcmax(kwtd)-smceq(kwtd) ) , zsoil0(iwtd) )
9311 else
9312 wtd=zsoil0(kwtd)
9313 endif
9314 rech = rech - (wtdold-wtd) * &
9315 (parameters%smcmax(kwtd)-smceq(kwtd))
9316
9317 else
9318 wtdold=wtd
9319!restore smoi to equilibrium value with water from the ficticious layer below
9320! smcwtd=smcwtd-(smceq(nsoil)-smc(nsoil))
9321! qdrain = qdrain - 1000 * (smceq(nsoil)-smc(nsoil)) * dzsnso(nsoil) / dt
9322! smc(nsoil)=smceq(nsoil)
9323!adjust wtd in the ficticious layer below
9324 smceqdeep = parameters%smcmax(nsoil) * ( -parameters%psisat(nsoil) / ( -parameters%psisat(nsoil) - dzsnso(nsoil) ) ) ** (1./parameters%bexp(nsoil))
9325 wtd = min( ( smcwtd*dzsnso(nsoil) &
9326 - smceqdeep*zsoil0(nsoil) + parameters%smcmax(nsoil)*(zsoil0(nsoil)-dzsnso(nsoil)) ) / &
9327 ( parameters%smcmax(nsoil)-smceqdeep ) , zsoil0(nsoil) )
9328 rech = rech - (wtdold-wtd) * &
9329 (parameters%smcmax(nsoil)-smceqdeep)
9330 endif
9331
9332 endif
9333 elseif(wtd.ge.zsoil0(nsoil)-dzsnso(nsoil))then
9334!if wtd was already below the bottom of the resolved soil crust
9335 wtdold=wtd
9336 smceqdeep = parameters%smcmax(nsoil) * ( -parameters%psisat(nsoil) / ( -parameters%psisat(nsoil) - dzsnso(nsoil) ) ) ** (1./parameters%bexp(nsoil))
9337 if(smcwtd.gt.smceqdeep)then
9338 wtd = min( ( smcwtd*dzsnso(nsoil) &
9339 - smceqdeep*zsoil0(nsoil) + parameters%smcmax(nsoil)*(zsoil0(nsoil)-dzsnso(nsoil)) ) / &
9340 ( parameters%smcmax(nsoil)-smceqdeep ) , zsoil0(nsoil) )
9341 rech = -(wtdold-wtd) * (parameters%smcmax(nsoil)-smceqdeep)
9342 else
9343 rech = -(wtdold-(zsoil0(nsoil)-dzsnso(nsoil))) * (parameters%smcmax(nsoil)-smceqdeep)
9344 wtdold=zsoil0(nsoil)-dzsnso(nsoil)
9345!and now even further down
9346 dzup=(smceqdeep-smcwtd)*dzsnso(nsoil)/(parameters%smcmax(nsoil)-smceqdeep)
9347 wtd=wtdold-dzup
9348 rech = rech - (parameters%smcmax(nsoil)-smceqdeep)*dzup
9349 smcwtd=smceqdeep
9350 endif
9351
9352
9353 endif
9354
9355if(iwtd.lt.nsoil .and. iwtd.gt.0) then
9356 smcwtd=parameters%smcmax(iwtd)
9357elseif(iwtd.lt.nsoil .and. iwtd.le.0) then
9358 smcwtd=parameters%smcmax(1)
9359end if
9360
9361end subroutine shallowwatertable
9362
9363! ==================================================================================================
9364! ********************* end of water subroutines ******************************************
9365! ==================================================================================================
9366
9367!== begin carbon ===================================================================================
9368
9371 subroutine carbon (parameters,nsnow ,nsoil ,vegtyp ,dt ,zsoil , & !in
9372 dzsnso ,stc ,smc ,tv ,tg ,psn , & !in
9373 foln ,btran ,apar ,fveg ,igs , & !in
9374 troot ,ist ,lat ,iloc ,jloc , & !in
9375 lfmass ,rtmass ,stmass ,wood ,stblcp ,fastcp , & !inout
9376 gpp ,npp ,nee ,autors ,heters ,totsc , & !out
9377 totlb ,xlai ,xsai ) !out
9378! ------------------------------------------------------------------------------------------
9379 implicit none
9380! ------------------------------------------------------------------------------------------
9381! inputs (carbon)
9382
9383 type (noahmp_parameters), intent(in) :: parameters
9384 integer , intent(in) :: iloc !grid index
9385 integer , intent(in) :: jloc !grid index
9386 integer , intent(in) :: vegtyp !vegetation type
9387 integer , intent(in) :: nsnow !number of snow layers
9388 integer , intent(in) :: nsoil !number of soil layers
9389 real (kind=kind_phys) , intent(in) :: lat !latitude (radians)
9390 real (kind=kind_phys) , intent(in) :: dt !time step (s)
9391 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil !depth of layer-bottom from soil surface
9392 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m]
9393 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature [k]
9394 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smc !soil moisture (ice + liq.) [m3/m3]
9395 real (kind=kind_phys) , intent(in) :: tv !vegetation temperature (k)
9396 real (kind=kind_phys) , intent(in) :: tg !ground temperature (k)
9397 real (kind=kind_phys) , intent(in) :: foln !foliage nitrogen (%)
9398 real (kind=kind_phys) , intent(in) :: btran !soil water transpiration factor (0 to 1)
9399 real (kind=kind_phys) , intent(in) :: psn !total leaf photosyn (umolco2/m2/s) [+]
9400 real (kind=kind_phys) , intent(in) :: apar !par by canopy (w/m2)
9401 real (kind=kind_phys) , intent(in) :: igs !growing season index (0=off, 1=on)
9402 real (kind=kind_phys) , intent(in) :: fveg !vegetation greenness fraction
9403 real (kind=kind_phys) , intent(in) :: troot !root-zone averaged temperature (k)
9404 integer , intent(in) :: ist !surface type 1->soil; 2->lake
9405
9406! input & output (carbon)
9407
9408 real (kind=kind_phys) , intent(inout) :: lfmass !leaf mass [g/m2]
9409 real (kind=kind_phys) , intent(inout) :: rtmass !mass of fine roots [g/m2]
9410 real (kind=kind_phys) , intent(inout) :: stmass !stem mass [g/m2]
9411 real (kind=kind_phys) , intent(inout) :: wood !mass of wood (incl. woody roots) [g/m2]
9412 real (kind=kind_phys) , intent(inout) :: stblcp !stable carbon in deep soil [g/m2]
9413 real (kind=kind_phys) , intent(inout) :: fastcp !short-lived carbon in shallow soil [g/m2]
9414
9415! outputs: (carbon)
9416
9417 real (kind=kind_phys) , intent(out) :: gpp !net instantaneous assimilation [g/m2/s c]
9418 real (kind=kind_phys) , intent(out) :: npp !net primary productivity [g/m2/s c]
9419 real (kind=kind_phys) , intent(out) :: nee !net ecosystem exchange [g/m2/s co2]
9420 real (kind=kind_phys) , intent(out) :: autors !net ecosystem respiration [g/m2/s c]
9421 real (kind=kind_phys) , intent(out) :: heters !organic respiration [g/m2/s c]
9422 real (kind=kind_phys) , intent(out) :: totsc !total soil carbon [g/m2 c]
9423 real (kind=kind_phys) , intent(out) :: totlb !total living carbon ([g/m2 c]
9424 real (kind=kind_phys) , intent(out) :: xlai !leaf area index [-]
9425 real (kind=kind_phys) , intent(out) :: xsai !stem area index [-]
9426! real (kind=kind_phys) , intent(out) :: vocflx(5) ! voc fluxes [ug c m-2 h-1]
9427
9428! local variables
9429
9430 integer :: j !do-loop index
9431 real (kind=kind_phys) :: wroot !root zone soil water [-]
9432 real (kind=kind_phys) :: wstres !water stress coeficient [-] (1. for wilting )
9433 real (kind=kind_phys) :: lapm !leaf area per unit mass [m2/g]
9434! ------------------------------------------------------------------------------------------
9435
9436 if ( ( vegtyp == parameters%iswater ) .or. ( vegtyp == parameters%isbarren ) .or. &
9437 ( vegtyp == parameters%isice ) .or. (parameters%urban_flag) ) then
9438 xlai = 0.
9439 xsai = 0.
9440 gpp = 0.
9441 npp = 0.
9442 nee = 0.
9443 autors = 0.
9444 heters = 0.
9445 totsc = 0.
9446 totlb = 0.
9447 lfmass = 0.
9448 rtmass = 0.
9449 stmass = 0.
9450 wood = 0.
9451 stblcp = 0.
9452 fastcp = 0.
9453
9454 return
9455 end if
9456
9457 lapm = parameters%sla / 1000. ! m2/kg -> m2/g
9458
9459! water stress
9460
9461 wstres = 1.- btran
9462
9463 wroot = 0.
9464 do j=1,parameters%nroot
9465 wroot = wroot + smc(j)/parameters%smcmax(j) * dzsnso(j) / (-zsoil(parameters%nroot))
9466 enddo
9467
9468 call co2flux (parameters,nsnow ,nsoil ,vegtyp ,igs ,dt , & !in
9469 dzsnso ,stc ,psn ,troot ,tv , & !in
9470 wroot ,wstres ,foln ,lapm , & !in
9471 lat ,iloc ,jloc ,fveg , & !in
9472 xlai ,xsai ,lfmass ,rtmass ,stmass , & !inout
9473 fastcp ,stblcp ,wood , & !inout
9474 gpp ,npp ,nee ,autors ,heters , & !out
9475 totsc ,totlb ) !out
9476
9477! call bvoc (parameters,vocflx, vegtyp, vegfac, apar, tv)
9478! call ch4
9479
9480 end subroutine carbon
9481
9482!== begin co2flux ==================================================================================
9483
9487 subroutine co2flux (parameters,nsnow ,nsoil ,vegtyp ,igs ,dt , & !in
9488 dzsnso ,stc ,psn ,troot ,tv , & !in
9489 wroot ,wstres ,foln ,lapm , & !in
9490 lat ,iloc ,jloc ,fveg , & !in
9491 xlai ,xsai ,lfmass ,rtmass ,stmass , & !inout
9492 fastcp ,stblcp ,wood , & !inout
9493 gpp ,npp ,nee ,autors ,heters , & !out
9494 totsc ,totlb ) !out
9495! -----------------------------------------------------------------------------------------
9496! the original code is from re dickinson et al.(1998), modifed by guo-yue niu, 2004
9497! -----------------------------------------------------------------------------------------
9498 implicit none
9499! -----------------------------------------------------------------------------------------
9500
9501! input
9502
9503 type (noahmp_parameters), intent(in) :: parameters
9504 integer , intent(in) :: iloc !grid index
9505 integer , intent(in) :: jloc !grid index
9506 integer , intent(in) :: vegtyp !vegetation physiology type
9507 integer , intent(in) :: nsnow !number of snow layers
9508 integer , intent(in) :: nsoil !number of soil layers
9509 real (kind=kind_phys) , intent(in) :: dt !time step (s)
9510 real (kind=kind_phys) , intent(in) :: lat !latitude (radians)
9511 real (kind=kind_phys) , intent(in) :: igs !growing season index (0=off, 1=on)
9512 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m]
9513 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature [k]
9514 real (kind=kind_phys) , intent(in) :: psn !total leaf photosynthesis (umolco2/m2/s)
9515 real (kind=kind_phys) , intent(in) :: troot !root-zone averaged temperature (k)
9516 real (kind=kind_phys) , intent(in) :: tv !leaf temperature (k)
9517 real (kind=kind_phys) , intent(in) :: wroot !root zone soil water
9518 real (kind=kind_phys) , intent(in) :: wstres !soil water stress
9519 real (kind=kind_phys) , intent(in) :: foln !foliage nitrogen (%)
9520 real (kind=kind_phys) , intent(in) :: lapm !leaf area per unit mass [m2/g]
9521 real (kind=kind_phys) , intent(in) :: fveg !vegetation greenness fraction
9522
9523! input and output
9524
9525 real (kind=kind_phys) , intent(inout) :: xlai !leaf area index from leaf carbon [-]
9526 real (kind=kind_phys) , intent(inout) :: xsai !stem area index from leaf carbon [-]
9527 real (kind=kind_phys) , intent(inout) :: lfmass !leaf mass [g/m2]
9528 real (kind=kind_phys) , intent(inout) :: rtmass !mass of fine roots [g/m2]
9529 real (kind=kind_phys) , intent(inout) :: stmass !stem mass [g/m2]
9530 real (kind=kind_phys) , intent(inout) :: fastcp !short lived carbon [g/m2]
9531 real (kind=kind_phys) , intent(inout) :: stblcp !stable carbon pool [g/m2]
9532 real (kind=kind_phys) , intent(inout) :: wood !mass of wood (incl. woody roots) [g/m2]
9533
9534! output
9535
9536 real (kind=kind_phys) , intent(out) :: gpp !net instantaneous assimilation [g/m2/s]
9537 real (kind=kind_phys) , intent(out) :: npp !net primary productivity [g/m2]
9538 real (kind=kind_phys) , intent(out) :: nee !net ecosystem exchange (autors+heters-gpp)
9539 real (kind=kind_phys) , intent(out) :: autors !net ecosystem resp. (maintance and growth)
9540 real (kind=kind_phys) , intent(out) :: heters !organic respiration
9541 real (kind=kind_phys) , intent(out) :: totsc !total soil carbon (g/m2)
9542 real (kind=kind_phys) , intent(out) :: totlb !total living carbon (g/m2)
9543
9544! local
9545
9546 real (kind=kind_phys) :: cflux !carbon flux to atmosphere [g/m2/s]
9547 real (kind=kind_phys) :: lfmsmn !minimum leaf mass [g/m2]
9548 real (kind=kind_phys) :: rswood !wood respiration [g/m2]
9549 real (kind=kind_phys) :: rsleaf !leaf maintenance respiration per timestep [g/m2]
9550 real (kind=kind_phys) :: rsroot !fine root respiration per time step [g/m2]
9551 real (kind=kind_phys) :: nppl !leaf net primary productivity [g/m2/s]
9552 real (kind=kind_phys) :: nppr !root net primary productivity [g/m2/s]
9553 real (kind=kind_phys) :: nppw !wood net primary productivity [g/m2/s]
9554 real (kind=kind_phys) :: npps !wood net primary productivity [g/m2/s]
9555 real (kind=kind_phys) :: dielf !death of leaf mass per time step [g/m2]
9556
9557 real (kind=kind_phys) :: addnpplf !leaf assimil after resp. losses removed [g/m2]
9558 real (kind=kind_phys) :: addnppst !stem assimil after resp. losses removed [g/m2]
9559 real (kind=kind_phys) :: carbfx !carbon assimilated per model step [g/m2]
9560 real (kind=kind_phys) :: grleaf !growth respiration rate for leaf [g/m2/s]
9561 real (kind=kind_phys) :: grroot !growth respiration rate for root [g/m2/s]
9562 real (kind=kind_phys) :: grwood !growth respiration rate for wood [g/m2/s]
9563 real (kind=kind_phys) :: grstem !growth respiration rate for stem [g/m2/s]
9564 real (kind=kind_phys) :: leafpt !fraction of carbon allocated to leaves [-]
9565 real (kind=kind_phys) :: lfdel !maximum leaf mass available to change [g/m2/s]
9566 real (kind=kind_phys) :: lftovr !stem turnover per time step [g/m2]
9567 real (kind=kind_phys) :: sttovr !stem turnover per time step [g/m2]
9568 real (kind=kind_phys) :: wdtovr !wood turnover per time step [g/m2]
9569 real (kind=kind_phys) :: rssoil !soil respiration per time step [g/m2]
9570 real (kind=kind_phys) :: rttovr !root carbon loss per time step by turnover [g/m2]
9571 real (kind=kind_phys) :: stablc !decay rate of fast carbon to slow carbon [g/m2/s]
9572 real (kind=kind_phys) :: woodf !calculated wood to root ratio [-]
9573 real (kind=kind_phys) :: nonlef !fraction of carbon to root and wood [-]
9574 real (kind=kind_phys) :: rootpt !fraction of carbon flux to roots [-]
9575 real (kind=kind_phys) :: woodpt !fraction of carbon flux to wood [-]
9576 real (kind=kind_phys) :: stempt !fraction of carbon flux to stem [-]
9577 real (kind=kind_phys) :: resp !leaf respiration [umol/m2/s]
9578 real (kind=kind_phys) :: rsstem !stem respiration [g/m2/s]
9579
9580 real (kind=kind_phys) :: fsw !soil water factor for microbial respiration
9581 real (kind=kind_phys) :: fst !soil temperature factor for microbial respiration
9582 real (kind=kind_phys) :: fnf !foliage nitrogen adjustemt to respiration (<= 1)
9583 real (kind=kind_phys) :: tf !temperature factor
9584 real (kind=kind_phys) :: rf !respiration reduction factor (<= 1)
9585 real (kind=kind_phys) :: stdel
9586 real (kind=kind_phys) :: stmsmn
9587 real (kind=kind_phys) :: sapm !stem area per unit mass (m2/g)
9588 real (kind=kind_phys) :: diest
9589! -------------------------- constants -------------------------------
9590 real (kind=kind_phys) :: bf !parameter for present wood allocation [-]
9591 real (kind=kind_phys) :: rswoodc !wood respiration coeficient [1/s]
9592 real (kind=kind_phys) :: stovrc !stem turnover coefficient [1/s]
9593 real (kind=kind_phys) :: rsdryc !degree of drying that reduces soil respiration [-]
9594 real (kind=kind_phys) :: rtovrc !root turnover coefficient [1/s]
9595 real (kind=kind_phys) :: wstrc !water stress coeficient [-]
9596 real (kind=kind_phys) :: laimin !minimum leaf area index [m2/m2]
9597 real (kind=kind_phys) :: xsamin !minimum leaf area index [m2/m2]
9598 real (kind=kind_phys) :: sc
9599 real (kind=kind_phys) :: sd
9600 real (kind=kind_phys) :: vegfrac
9601
9602! respiration as a function of temperature
9603
9604 real (kind=kind_phys) :: r,x
9605 r(x) = exp(0.08*(x-298.16))
9606! ---------------------------------------------------------------------------------
9607
9608! constants
9609 rtovrc = 2.0e-8 !original was 2.0e-8
9610 rsdryc = 40.0 !original was 40.0
9611 rswoodc = 3.0e-10 !
9612 bf = 0.90 !original was 0.90 ! carbon to roots
9613 wstrc = 100.0
9614 laimin = 0.05
9615 xsamin = 0.05 ! mb: change to prevent vegetation from not growing back in spring
9616
9617 sapm = 3.*0.001 ! m2/kg -->m2/g
9618 lfmsmn = laimin/lapm
9619 stmsmn = xsamin/sapm
9620! ---------------------------------------------------------------------------------
9621
9622! respiration
9623
9624 if(igs .eq. 0.) then
9625 rf = 0.5
9626 else
9627 rf = 1.0
9628 endif
9629
9630 fnf = min( foln/max(1.e-06,parameters%folnmx), 1.0 )
9631 tf = parameters%arm**( (tv-298.16)/10. )
9632 resp = parameters%rmf25 * tf * fnf * xlai * rf * (1.-wstres) ! umol/m2/s
9633 rsleaf = min((lfmass-lfmsmn)/dt,resp*12.e-6) ! g/m2/s
9634
9635 rsroot = parameters%rmr25*(rtmass*1e-3)*tf *rf* 12.e-6 ! g/m2/s
9636 rsstem = parameters%rms25*((stmass-stmsmn)*1e-3)*tf *rf* 12.e-6 ! g/m2/s
9637 rswood = rswoodc * r(tv) * wood*parameters%wdpool
9638
9639! carbon assimilation
9640! 1 mole -> 12 g carbon or 44 g co2; 1 umol -> 12.e-6 g carbon;
9641
9642 carbfx = psn * 12.e-6 ! umol co2 /m2/ s -> g/m2/s carbon
9643
9644! fraction of carbon into leaf versus nonleaf
9645
9646 leafpt = exp(0.01*(1.-exp(0.75*xlai))*xlai)
9647 if(vegtyp == parameters%eblforest) leafpt = exp(0.01*(1.-exp(0.50*xlai))*xlai)
9648
9649 nonlef = 1.0 - leafpt
9650 stempt = xlai/10.0*leafpt
9651 leafpt = leafpt - stempt
9652
9653! fraction of carbon into wood versus root
9654
9655 if(wood > 1.e-6) then
9656 woodf = (1.-exp(-bf*(parameters%wrrat*rtmass/wood))/bf)*parameters%wdpool
9657 else
9658 woodf = parameters%wdpool
9659 endif
9660
9661 rootpt = nonlef*(1.-woodf)
9662 woodpt = nonlef*woodf
9663
9664! leaf and root turnover per time step
9665
9666 lftovr = parameters%ltovrc*5.e-7*lfmass
9667 sttovr = parameters%ltovrc*5.e-7*stmass
9668 rttovr = rtovrc*rtmass
9669 wdtovr = 9.5e-10*wood
9670
9671! seasonal leaf die rate dependent on temp and water stress
9672! water stress is set to 1 at permanent wilting point
9673
9674 sc = exp(-0.3*max(0.,tv-parameters%tdlef)) * (lfmass/120.)
9675 sd = exp((wstres-1.)*wstrc)
9676 dielf = lfmass*1.e-6*(parameters%dilefw * sd + parameters%dilefc*sc)
9677 diest = stmass*1.e-6*(parameters%dilefw * sd + parameters%dilefc*sc)
9678
9679! calculate growth respiration for leaf, rtmass and wood
9680
9681 grleaf = max(0.0,parameters%fragr*(leafpt*carbfx - rsleaf))
9682 grstem = max(0.0,parameters%fragr*(stempt*carbfx - rsstem))
9683 grroot = max(0.0,parameters%fragr*(rootpt*carbfx - rsroot))
9684 grwood = max(0.0,parameters%fragr*(woodpt*carbfx - rswood))
9685
9686! impose lower t limit for photosynthesis
9687
9688 addnpplf = max(0.,leafpt*carbfx - grleaf-rsleaf)
9689 addnppst = max(0.,stempt*carbfx - grstem-rsstem)
9690! addnpplf = leafpt*carbfx - grleaf-rsleaf ! mb: test kjetil
9691! addnppst = stempt*carbfx - grstem-rsstem ! mb: test kjetil
9692 if(tv.lt.parameters%tmin) addnpplf =0.
9693 if(tv.lt.parameters%tmin) addnppst =0.
9694
9695! update leaf, root, and wood carbon
9696! avoid reducing leaf mass below its minimum value but conserve mass
9697
9698 lfdel = (lfmass - lfmsmn)/dt
9699 stdel = (stmass - stmsmn)/dt
9700 dielf = min(dielf,lfdel+addnpplf-lftovr)
9701 diest = min(diest,stdel+addnppst-sttovr)
9702
9703! net primary productivities
9704
9705 nppl = max(addnpplf,-lfdel)
9706 npps = max(addnppst,-stdel)
9707 nppr = rootpt*carbfx - rsroot - grroot
9708 nppw = woodpt*carbfx - rswood - grwood
9709
9710! masses of plant components
9711
9712 lfmass = lfmass + (nppl-lftovr-dielf)*dt
9713 stmass = stmass + (npps-sttovr-diest)*dt ! g/m2
9714 rtmass = rtmass + (nppr-rttovr) *dt
9715
9716 if(rtmass.lt.0.0) then
9717 rttovr = nppr
9718 rtmass = 0.0
9719 endif
9720 wood = (wood+(nppw-wdtovr)*dt)*parameters%wdpool
9721
9722! soil carbon budgets
9723
9724 fastcp = fastcp + (rttovr+lftovr+sttovr+wdtovr+dielf+diest)*dt ! mb: add diest v3.7
9725
9726 fst = 2.0**( (stc(1)-283.16)/10. )
9727 fsw = wroot / (0.20+wroot) * 0.23 / (0.23+wroot)
9728 rssoil = fsw * fst * parameters%mrp* max(0.,fastcp*1.e-3)*12.e-6
9729
9730 stablc = 0.1*rssoil
9731 fastcp = fastcp - (rssoil + stablc)*dt
9732 stblcp = stblcp + stablc*dt
9733
9734! total carbon flux
9735
9736 cflux = - carbfx + rsleaf + rsroot + rswood + rsstem & ! mb: add rsstem,grstem,0.9*rssoil v3.7
9737 + 0.9*rssoil + grleaf + grroot + grwood + grstem ! g/m2/s
9738
9739! for outputs
9740
9741 gpp = carbfx !g/m2/s c
9742 npp = nppl + nppw + nppr +npps !g/m2/s c
9743 autors = rsroot + rswood + rsleaf + rsstem + & !g/m2/s c mb: add rsstem, grstem v3.7
9744 grleaf + grroot + grwood + grstem !g/m2/s c mb: add 0.9* v3.7
9745 heters = 0.9*rssoil !g/m2/s c
9746 nee = (autors + heters - gpp)*44./12. !g/m2/s co2
9747 totsc = fastcp + stblcp !g/m2 c
9748 totlb = lfmass + rtmass +stmass + wood !g/m2 c mb: add stmass v3.7
9749
9750! leaf area index and stem area index
9751
9752 xlai = max(lfmass*lapm,laimin)
9753 xsai = max(stmass*sapm,xsamin)
9754
9755 end subroutine co2flux
9756
9757!== begin carbon_crop ==============================================================================
9761 subroutine carbon_crop (parameters,nsnow ,nsoil ,vegtyp ,dt ,zsoil ,julian , & !in
9762 dzsnso ,stc ,smc ,tv ,psn ,foln ,btran , & !in
9763 soldn ,t2m , & !in
9764 lfmass ,rtmass ,stmass ,wood ,stblcp ,fastcp ,grain , & !inout
9765 xlai ,xsai ,gdd , & !inout
9766 gpp ,npp ,nee ,autors ,heters ,totsc ,totlb, pgs ) !out
9767! ------------------------------------------------------------------------------------------
9768! initial crop version created by xing liu
9769! initial crop version added by barlage v3.8
9770
9771! ------------------------------------------------------------------------------------------
9772 implicit none
9773! ------------------------------------------------------------------------------------------
9774! inputs (carbon)
9775
9776 type (noahmp_parameters), intent(in) :: parameters
9777 integer , intent(in) :: nsnow !number of snow layers
9778 integer , intent(in) :: nsoil !number of soil layers
9779 integer , intent(in) :: vegtyp !vegetation type
9780 real (kind=kind_phys) , intent(in) :: dt !time step (s)
9781 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil !depth of layer-bottomfrom soil surface
9782 real (kind=kind_phys) , intent(in) :: julian !julian day of year(fractional) ( 0 <= julian < yearlen )
9783 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layerthickness [m]
9784 real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature[k]
9785 real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smc !soil moisture (ice +liq.) [m3/m3]
9786 real (kind=kind_phys) , intent(in) :: tv !vegetation temperature(k)
9787 real (kind=kind_phys) , intent(in) :: psn !total leaf photosyn(umolco2/m2/s) [+]
9788 real (kind=kind_phys) , intent(in) :: foln !foliage nitrogen (%)
9789 real (kind=kind_phys) , intent(in) :: btran !soil watertranspiration factor (0 to 1)
9790 real (kind=kind_phys) , intent(in) :: soldn !downward solar radiation
9791 real (kind=kind_phys) , intent(in) :: t2m !air temperature
9792
9793! input & output (carbon)
9794
9795 real (kind=kind_phys) , intent(inout) :: lfmass !leaf mass [g/m2]
9796 real (kind=kind_phys) , intent(inout) :: rtmass !mass of fine roots[g/m2]
9797 real (kind=kind_phys) , intent(inout) :: stmass !stem mass [g/m2]
9798 real (kind=kind_phys) , intent(inout) :: wood !mass of wood (incl.woody roots) [g/m2]
9799 real (kind=kind_phys) , intent(inout) :: stblcp !stable carbon in deepsoil [g/m2]
9800 real (kind=kind_phys) , intent(inout) :: fastcp !short-lived carbon inshallow soil [g/m2]
9801 real (kind=kind_phys) , intent(inout) :: grain !mass of grain [g/m2]
9802 real (kind=kind_phys) , intent(inout) :: xlai !leaf area index [-]
9803 real (kind=kind_phys) , intent(inout) :: xsai !stem area index [-]
9804 real (kind=kind_phys) , intent(inout) :: gdd !growing degree days
9805
9806! outout
9807 real (kind=kind_phys) , intent(out) :: gpp !net instantaneous assimilation [g/m2/s c]
9808 real (kind=kind_phys) , intent(out) :: npp !net primary productivity [g/m2/s c]
9809 real (kind=kind_phys) , intent(out) :: nee !net ecosystem exchange[g/m2/s co2]
9810 real (kind=kind_phys) , intent(out) :: autors !net ecosystem respiration [g/m2/s c]
9811 real (kind=kind_phys) , intent(out) :: heters !organic respiration[g/m2/s c]
9812 real (kind=kind_phys) , intent(out) :: totsc !total soil carbon [g/m2c]
9813 real (kind=kind_phys) , intent(out) :: totlb !total living carbon ([g/m2 c]
9814
9815! local variables
9816
9817 integer :: j !do-loop index
9818 real (kind=kind_phys) :: wroot !root zone soil water [-]
9819 real (kind=kind_phys) :: wstres !water stress coeficient [-] (1. for wilting )
9820 integer :: ipa !planting index
9821 integer :: iha !havestindex(0=on,1=off)
9822 integer, intent(out) :: pgs !plant growth stage
9823
9824 real (kind=kind_phys) :: psncrop
9825
9826! ------------------------------------------------------------------------------------------
9827 if ( ( vegtyp == parameters%iswater ) .or. ( vegtyp == parameters%isbarren ) .or. &
9828 ( vegtyp == parameters%isice ) .or. (parameters%urban_flag) ) then
9829 xlai = 0.
9830 xsai = 0.
9831 gpp = 0.
9832 npp = 0.
9833 nee = 0.
9834 autors = 0.
9835 heters = 0.
9836 totsc = 0.
9837 totlb = 0.
9838 lfmass = 0.
9839 rtmass = 0.
9840 stmass = 0.
9841 wood = 0.
9842 stblcp = 0.
9843 fastcp = 0.
9844 grain = 0.
9845 return
9846 end if
9847
9848! water stress
9849
9850
9851 wstres = 1.- btran
9852
9853 wroot = 0.
9854 do j=1,parameters%nroot
9855 wroot = wroot + smc(j)/parameters%smcmax(j) * dzsnso(j) / (-zsoil(parameters%nroot))
9856 enddo
9857
9858 call psn_crop ( parameters, & !in
9859 soldn, xlai, t2m, & !in
9860 psncrop ) !out
9861
9862 call growing_gdd (parameters, & !in
9863 t2m , dt, julian, & !in
9864 gdd , & !inout
9865 ipa , iha, pgs) !out
9866
9867 call co2flux_crop (parameters, & !in
9868 dt ,stc(1) ,psn ,tv ,wroot ,wstres ,foln , & !in
9869 ipa ,iha ,pgs , & !in xing
9870 xlai ,xsai ,lfmass ,rtmass ,stmass , & !inout
9871 fastcp ,stblcp ,wood ,grain ,gdd , & !inout
9872 gpp ,npp ,nee ,autors ,heters , & !out
9873 totsc ,totlb ) !out
9874
9875 end subroutine carbon_crop
9876
9877!== begin co2flux_crop =============================================================================
9881 subroutine co2flux_crop (parameters, & !in
9882 dt ,stc ,psn ,tv ,wroot ,wstres ,foln , & !in
9883 ipa ,iha ,pgs , & !in xing
9884 xlai ,xsai ,lfmass ,rtmass ,stmass , & !inout
9885 fastcp ,stblcp ,wood ,grain ,gdd, & !inout
9886 gpp ,npp ,nee ,autors ,heters , & !out
9887 totsc ,totlb ) !out
9888! -----------------------------------------------------------------------------------------
9889! the original code from re dickinson et al.(1998) and guo-yue niu(2004),
9890! modified by xing liu, 2014.
9891!
9892! -----------------------------------------------------------------------------------------
9893 implicit none
9894! -----------------------------------------------------------------------------------------
9895
9896! input
9897
9898 type (noahmp_parameters), intent(in) :: parameters
9899 real (kind=kind_phys) , intent(in) :: dt !time step (s)
9900 real (kind=kind_phys) , intent(in) :: stc !soil temperature[k]
9901 real (kind=kind_phys) , intent(in) :: psn !total leaf photosynthesis (umolco2/m2/s)
9902 real (kind=kind_phys) , intent(in) :: tv !leaf temperature (k)
9903 real (kind=kind_phys) , intent(in) :: wroot !root zone soil water
9904 real (kind=kind_phys) , intent(in) :: wstres !soil water stress
9905 real (kind=kind_phys) , intent(in) :: foln !foliage nitrogen (%)
9906 integer , intent(in) :: ipa
9907 integer , intent(in) :: iha
9908 integer , intent(in) :: pgs
9909
9910! input and output
9911
9912 real (kind=kind_phys) , intent(inout) :: xlai !leaf area index from leaf carbon [-]
9913 real (kind=kind_phys) , intent(inout) :: xsai !stem area index from leaf carbon [-]
9914 real (kind=kind_phys) , intent(inout) :: lfmass !leaf mass [g/m2]
9915 real (kind=kind_phys) , intent(inout) :: rtmass !mass of fine roots [g/m2]
9916 real (kind=kind_phys) , intent(inout) :: stmass !stem mass [g/m2]
9917 real (kind=kind_phys) , intent(inout) :: fastcp !short lived carbon [g/m2]
9918 real (kind=kind_phys) , intent(inout) :: stblcp !stable carbon pool [g/m2]
9919 real (kind=kind_phys) , intent(inout) :: wood !mass of wood (incl. woody roots) [g/m2]
9920 real (kind=kind_phys) , intent(inout) :: grain !mass of grain (xing) [g/m2]
9921 real (kind=kind_phys) , intent(inout) :: gdd !growing degree days (xing)
9922
9923! output
9924
9925 real (kind=kind_phys) , intent(out) :: gpp !net instantaneous assimilation [g/m2/s]
9926 real (kind=kind_phys) , intent(out) :: npp !net primary productivity [g/m2]
9927 real (kind=kind_phys) , intent(out) :: nee !net ecosystem exchange (autors+heters-gpp)
9928 real (kind=kind_phys) , intent(out) :: autors !net ecosystem resp. (maintance and growth)
9929 real (kind=kind_phys) , intent(out) :: heters !organic respiration
9930 real (kind=kind_phys) , intent(out) :: totsc !total soil carbon (g/m2)
9931 real (kind=kind_phys) , intent(out) :: totlb !total living carbon (g/m2)
9932
9933! local
9934
9935 real (kind=kind_phys) :: cflux !carbon flux to atmosphere [g/m2/s]
9936 real (kind=kind_phys) :: lfmsmn !minimum leaf mass [g/m2]
9937 real (kind=kind_phys) :: rswood !wood respiration [g/m2]
9938 real (kind=kind_phys) :: rsleaf !leaf maintenance respiration per timestep[g/m2]
9939 real (kind=kind_phys) :: rsroot !fine root respiration per time step [g/m2]
9940 real (kind=kind_phys) :: rsgrain !grain respiration [g/m2]
9941 real (kind=kind_phys) :: nppl !leaf net primary productivity [g/m2/s]
9942 real (kind=kind_phys) :: nppr !root net primary productivity [g/m2/s]
9943 real (kind=kind_phys) :: nppw !wood net primary productivity [g/m2/s]
9944 real (kind=kind_phys) :: npps !wood net primary productivity [g/m2/s]
9945 real (kind=kind_phys) :: nppg !grain net primary productivity [g/m2/s]
9946 real (kind=kind_phys) :: dielf !death of leaf mass per time step [g/m2]
9947
9948 real (kind=kind_phys) :: addnpplf !leaf assimil after resp. losses removed[g/m2]
9949 real (kind=kind_phys) :: addnppst !stem assimil after resp. losses removed[g/m2]
9950 real (kind=kind_phys) :: carbfx !carbon assimilated per model step [g/m2]
9951 real (kind=kind_phys) :: cbhydrafx!carbonhydrate assimilated per model step [g/m2]
9952 real (kind=kind_phys) :: grleaf !growth respiration rate for leaf [g/m2/s]
9953 real (kind=kind_phys) :: grroot !growth respiration rate for root [g/m2/s]
9954 real (kind=kind_phys) :: grwood !growth respiration rate for wood [g/m2/s]
9955 real (kind=kind_phys) :: grstem !growth respiration rate for stem [g/m2/s]
9956 real (kind=kind_phys) :: grgrain !growth respiration rate for stem [g/m2/s]
9957 real (kind=kind_phys) :: leafpt !fraction of carbon allocated to leaves [-]
9958 real (kind=kind_phys) :: lfdel !maximum leaf mass available to change[g/m2/s]
9959 real (kind=kind_phys) :: lftovr !stem turnover per time step [g/m2]
9960 real (kind=kind_phys) :: sttovr !stem turnover per time step [g/m2]
9961 real (kind=kind_phys) :: wdtovr !wood turnover per time step [g/m2]
9962 real (kind=kind_phys) :: grtovr !grainturnover per time step [g/m2]
9963 real (kind=kind_phys) :: rssoil !soil respiration per time step [g/m2]
9964 real (kind=kind_phys) :: rttovr !root carbon loss per time step by turnover[g/m2]
9965 real (kind=kind_phys) :: stablc !decay rate of fast carbon to slow carbon[g/m2/s]
9966 real (kind=kind_phys) :: woodf !calculated wood to root ratio [-]
9967 real (kind=kind_phys) :: nonlef !fraction of carbon to root and wood [-]
9968 real (kind=kind_phys) :: resp !leaf respiration [umol/m2/s]
9969 real (kind=kind_phys) :: rsstem !stem respiration [g/m2/s]
9970
9971 real (kind=kind_phys) :: fsw !soil water factor for microbial respiration
9972 real (kind=kind_phys) :: fst !soil temperature factor for microbialrespiration
9973 real (kind=kind_phys) :: fnf !foliage nitrogen adjustemt to respiration(<= 1)
9974 real (kind=kind_phys) :: tf !temperature factor
9975 real (kind=kind_phys) :: stdel
9976 real (kind=kind_phys) :: stmsmn
9977 real (kind=kind_phys) :: sapm !stem area per unit mass (m2/g)
9978 real (kind=kind_phys) :: diest
9979 real (kind=kind_phys) :: stconvert !stem to grain conversion [g/m2/s]
9980 real (kind=kind_phys) :: rtconvert !root to grain conversion [g/m2/s]
9981! -------------------------- constants -------------------------------
9982 real (kind=kind_phys) :: bf !parameter for present wood allocation [-]
9983 real (kind=kind_phys) :: rswoodc !wood respiration coeficient [1/s]
9984 real (kind=kind_phys) :: stovrc !stem turnover coefficient [1/s]
9985 real (kind=kind_phys) :: rsdryc !degree of drying that reduces soilrespiration [-]
9986 real (kind=kind_phys) :: rtovrc !root turnover coefficient [1/s]
9987 real (kind=kind_phys) :: wstrc !water stress coeficient [-]
9988 real (kind=kind_phys) :: laimin !minimum leaf area index [m2/m2]
9989 real (kind=kind_phys) :: xsamin !minimum leaf area index [m2/m2]
9990 real (kind=kind_phys) :: sc
9991 real (kind=kind_phys) :: sd
9992 real (kind=kind_phys) :: vegfrac
9993 real (kind=kind_phys) :: temp
9994
9995! respiration as a function of temperature
9996
9997 real (kind=kind_phys) :: r,x
9998 r(x) = exp(0.08*(x-298.16))
9999! ---------------------------------------------------------------------------------
10000
10001! constants
10002 rsdryc = 40.0 !original was 40.0
10003 rswoodc = 3.0e-10 !
10004 bf = 0.90 !original was 0.90 ! carbon to roots
10005 wstrc = 100.0
10006 laimin = 0.05
10007 xsamin = 0.05
10008
10009 sapm = 3.*0.001 ! m2/kg -->m2/g
10010 lfmsmn = laimin/0.035
10011 stmsmn = xsamin/sapm
10012! ---------------------------------------------------------------------------------
10013
10014! carbon assimilation
10015! 1 mole -> 12 g carbon or 44 g co2 or 30 g ch20
10016
10017 carbfx = psn*12.e-6!*ipa !umol co2 /m2/ s -> g/m2/s c
10018 cbhydrafx = psn*30.e-6!*ipa
10019
10020! mainteinance respiration
10021 fnf = min( foln/max(1.e-06,parameters%foln_mx), 1.0 )
10022 tf = parameters%q10mr**( (tv-298.16)/10. )
10023 resp = parameters%lfmr25 * tf * fnf * xlai * (1.-wstres) ! umol/m2/s
10024 rsleaf = min((lfmass-lfmsmn)/dt,resp*30.e-6) ! g/m2/s
10025 rsroot = parameters%rtmr25*(rtmass*1e-3)*tf * 30.e-6 ! g/m2/s
10026 rsstem = parameters%stmr25*(stmass*1e-3)*tf * 30.e-6 ! g/m2/s
10027 rsgrain = parameters%grainmr25*(grain*1e-3)*tf * 30.e-6 ! g/m2/s
10028
10029! calculate growth respiration for leaf, rtmass and grain
10030
10031 grleaf = max(0.0,parameters%fra_gr*(parameters%lfpt(pgs)*cbhydrafx - rsleaf))
10032 grstem = max(0.0,parameters%fra_gr*(parameters%stpt(pgs)*cbhydrafx - rsstem))
10033 grroot = max(0.0,parameters%fra_gr*(parameters%rtpt(pgs)*cbhydrafx - rsroot))
10034 grgrain = max(0.0,parameters%fra_gr*(parameters%grainpt(pgs)*cbhydrafx - rsgrain))
10035
10036! leaf turnover, stem turnover, root turnover and leaf death caused by soil
10037! water and soil temperature stress
10038
10039 lftovr = parameters%lf_ovrc(pgs)*1.e-6*lfmass
10040 rttovr = parameters%rt_ovrc(pgs)*1.e-6*rtmass
10041 sttovr = parameters%st_ovrc(pgs)*1.e-6*stmass
10042 sc = exp(-0.3*max(0.,tv-parameters%lefreez)) * (lfmass/120.)
10043 sd = exp((wstres-1.)*wstrc)
10044 dielf = lfmass*1.e-6*(parameters%dile_fw(pgs) * sd + parameters%dile_fc(pgs)*sc)
10045
10046! allocation of cbhydrafx to leaf, stem, root and grain at each growth stage
10047
10048
10049 addnpplf = max(0.,parameters%lfpt(pgs)*cbhydrafx - grleaf-rsleaf)
10050 addnpplf = parameters%lfpt(pgs)*cbhydrafx - grleaf-rsleaf
10051 addnppst = max(0.,parameters%stpt(pgs)*cbhydrafx - grstem-rsstem)
10052 addnppst = parameters%stpt(pgs)*cbhydrafx - grstem-rsstem
10053
10054
10055! avoid reducing leaf mass below its minimum value but conserve mass
10056
10057 lfdel = (lfmass - lfmsmn)/dt
10058 stdel = (stmass - stmsmn)/dt
10059 lftovr = min(lftovr,lfdel+addnpplf)
10060 sttovr = min(sttovr,stdel+addnppst)
10061 dielf = min(dielf,lfdel+addnpplf-lftovr)
10062
10063! net primary productivities
10064
10065 nppl = max(addnpplf,-lfdel)
10066 nppl = addnpplf
10067 npps = max(addnppst,-stdel)
10068 npps = addnppst
10069 nppr = parameters%rtpt(pgs)*cbhydrafx - rsroot - grroot
10070 nppg = parameters%grainpt(pgs)*cbhydrafx - rsgrain - grgrain
10071
10072! masses of plant components
10073
10074 lfmass = lfmass + (nppl-lftovr-dielf)*dt
10075 stmass = stmass + (npps-sttovr)*dt ! g/m2
10076 rtmass = rtmass + (nppr-rttovr)*dt
10077 grain = grain + nppg*dt
10078
10079 gpp = cbhydrafx* 0.4 !!g/m2/s c 0.4=12/30, ch20 to c
10080
10081 stconvert = 0.0
10082 rtconvert = 0.0
10083 if(pgs==6) then
10084 stconvert = stmass*(0.00005*dt/3600.0)
10085 stmass = stmass - stconvert
10086 rtconvert = rtmass*(0.0005*dt/3600.0)
10087 rtmass = rtmass - rtconvert
10088 grain = grain + stconvert + rtconvert
10089 end if
10090
10091 if(rtmass.lt.0.0) then
10092 rttovr = nppr
10093 rtmass = 0.0
10094 endif
10095
10096 if(grain.lt.0.0) then
10097 grain = 0.0
10098 endif
10099
10100 ! soil carbon budgets
10101
10102! if(pgs == 1 .or. pgs == 2 .or. pgs == 8) then
10103! fastcp=1000
10104! else
10105 fastcp = fastcp + (rttovr+lftovr+sttovr+dielf)*dt
10106! end if
10107 fst = 2.0**( (stc-283.16)/10. )
10108 fsw = wroot / (0.20+wroot) * 0.23 / (0.23+wroot)
10109 rssoil = fsw * fst * parameters%mrp* max(0.,fastcp*1.e-3)*12.e-6
10110
10111 stablc = 0.1*rssoil
10112 fastcp = fastcp - (rssoil + stablc)*dt
10113 stblcp = stblcp + stablc*dt
10114
10115! total carbon flux
10116
10117 cflux = - carbfx + rsleaf + rsroot + rsstem &
10118 + rssoil + grleaf + grroot ! g/m2/s 0.4=12/30, ch20 to c
10119
10120! for outputs
10121 !g/m2/s c
10122
10123 npp = (nppl + npps+ nppr +nppg)*0.4 !!g/m2/s c 0.4=12/30, ch20 to c
10124
10125
10126 autors = rsroot + rsgrain + rsleaf + & !g/m2/s c
10127 grleaf + grroot + grgrain !g/m2/s c
10128
10129 heters = rssoil !g/m2/s c
10130 nee = (autors + heters - gpp)*44./30. !g/m2/s co2
10131 totsc = fastcp + stblcp !g/m2 c
10132
10133 totlb = lfmass + rtmass + grain
10134
10135! leaf area index and stem area index
10136
10137 xlai = max(lfmass*parameters%bio2lai,laimin)
10138 xsai = max(stmass*sapm,xsamin)
10139
10140
10141!after harversting
10142! if(pgs == 8 ) then
10143! lfmass = 0.62
10144! stmass = 0
10145! grain = 0
10146! end if
10147
10148! if(pgs == 1 .or. pgs == 2 .or. pgs == 8) then
10149 if(pgs == 8 .and. (grain > 0. .or. lfmass > 0 .or. stmass > 0 .or. rtmass > 0)) then
10150 xlai = 0.05
10151 xsai = 0.05
10152 lfmass = lfmsmn
10153 stmass = stmsmn
10154 rtmass = 0
10155 grain = 0
10156 end if
10157
10158end subroutine co2flux_crop
10159
10160!== begin growing_gdd ==============================================================================
10163 subroutine growing_gdd (parameters, & !in
10164 t2m , dt, julian, & !in
10165 gdd , & !inout
10166 ipa, iha, pgs) !out
10167!===================================================================================================
10168
10169! input
10170
10171 type (noahmp_parameters), intent(in) :: parameters
10172 real (kind=kind_phys) , intent(in) :: t2m
10173 real (kind=kind_phys) , intent(in) :: dt
10174 real (kind=kind_phys) , intent(in) :: julian
10175
10176! input and output
10177
10178 real (kind=kind_phys) , intent(inout) :: gdd
10179
10180! output
10181
10182 integer , intent(out) :: ipa
10183 integer , intent(out) :: iha
10184 integer , intent(out) :: pgs
10185
10186!local
10187
10188 real (kind=kind_phys) :: gddday !gap bewtween gdd and gdd8
10189 real (kind=kind_phys) :: dayofs2 !days in stage2
10190 real (kind=kind_phys) :: tdiff !temperature difference for growing degree days calculation
10191 real (kind=kind_phys) :: tc
10192
10193 tc = t2m - 273.15
10194
10195!havestindex(0=on,1=off)
10196
10197 ipa = 1
10198 iha = 1
10199
10200!turn on/off the planting
10201
10202 if(julian < parameters%pltday) ipa = 0
10203
10204!turn on/off the harvesting
10205 if(julian >= parameters%hsday) iha = 0
10206
10207!calculate the growing degree days
10208
10209 if(tc < parameters%gddtbase) then
10210 tdiff = 0.0
10211 elseif(tc >= parameters%gddtcut) then
10212 tdiff = parameters%gddtcut - parameters%gddtbase
10213 else
10214 tdiff = tc - parameters%gddtbase
10215 end if
10216
10217 gdd = (gdd + tdiff * dt / 86400.0) * ipa * iha
10218
10219 gddday = gdd
10220
10221 ! decide corn growth stage, based on hybrid-maize
10222 ! pgs = 1 : before planting
10223 ! pgs = 2 : from tassel initiation to silking
10224 ! pgs = 3 : from silking to effective grain filling
10225 ! pgs = 4 : from effective grain filling to pysiological maturity
10226 ! pgs = 5 : gddm=1389
10227 ! pgs = 6 :
10228 ! pgs = 7 :
10229 ! pgs = 8 :
10230 ! gddm = 1389
10231 ! gddm = 1555
10232 ! gddsk = 0.41*gddm +145.4+150 !from hybrid-maize
10233 ! gdds1 = ((gddsk-96)/38.9-4)*21
10234 ! gdds1 = 0.77*gddsk
10235 ! gdds3 = gddsk+170
10236 ! gdds3 = 170
10237
10238 pgs = 1 ! mb: set pgs = 1 (for initialization during growing season when no gdd)
10239
10240 if(gddday > 0.0) pgs = 2
10241
10242 if(gddday >= parameters%gdds1) pgs = 3
10243
10244 if(gddday >= parameters%gdds2) pgs = 4
10245
10246 if(gddday >= parameters%gdds3) pgs = 5
10247
10248 if(gddday >= parameters%gdds4) pgs = 6
10249
10250 if(gddday >= parameters%gdds5) pgs = 7
10251
10252 if(julian >= parameters%hsday) pgs = 8
10253
10254 if(julian < parameters%pltday) pgs = 1
10255
10256end subroutine growing_gdd
10257
10258!== begin psn_crop =================================================================================
10261subroutine psn_crop ( parameters, & !in
10262 soldn, xlai,t2m, & !in
10263 psncrop ) !out
10264!===================================================================================================
10265
10266! input
10267
10268 type (noahmp_parameters), intent(in) :: parameters
10269 real (kind=kind_phys) , intent(in) :: soldn
10270 real (kind=kind_phys) , intent(in) :: xlai
10271 real (kind=kind_phys) , intent(in) :: t2m
10272 real (kind=kind_phys) , intent(out) :: psncrop
10273
10274!local
10275
10276 real (kind=kind_phys) :: par ! photosynthetically active radiation (w/m2) 1 w m-2 = 0.0864 mj m-2 day-1
10277 real (kind=kind_phys) :: amax ! maximum co2 assimulation rate g/co2/s
10278 real (kind=kind_phys) :: l1 ! three gaussian method
10279 real (kind=kind_phys) :: l2 ! three gaussian method
10280 real (kind=kind_phys) :: l3 ! three gaussian method
10281 real (kind=kind_phys) :: i1 ! three gaussian method
10282 real (kind=kind_phys) :: i2 ! three gaussian method
10283 real (kind=kind_phys) :: i3 ! three gaussian method
10284 real (kind=kind_phys) :: a1 ! three gaussian method
10285 real (kind=kind_phys) :: a2 ! three gaussian method
10286 real (kind=kind_phys) :: a3 ! three gaussian method
10287 real (kind=kind_phys) :: a ! co2 assimulation
10288 real (kind=kind_phys) :: tc
10289
10290 tc = t2m - 273.15
10291
10292 par = parameters%i2par * soldn * 0.0036 !w to mj m-2
10293
10294 if(tc < parameters%tassim0) then
10295 amax = 1e-10
10296 elseif(tc >= parameters%tassim0 .and. tc < parameters%tassim1) then
10297 amax = (tc - parameters%tassim0) * parameters%aref / (parameters%tassim1 - parameters%tassim0)
10298 elseif(tc >= parameters%tassim1 .and. tc < parameters%tassim2) then
10299 amax = parameters%aref
10300 else
10301 amax= parameters%aref - 0.2 * (t2m - parameters%tassim2)
10302 endif
10303
10304 amax = max(amax,0.01)
10305
10306 if(xlai <= 0.05) then
10307 l1 = 0.1127 * 0.05 !use initial lai(0.05), avoid error
10308 l2 = 0.5 * 0.05
10309 l3 = 0.8873 * 0.05
10310 else
10311 l1 = 0.1127 * xlai
10312 l2 = 0.5 * xlai
10313 l3 = 0.8873 * xlai
10314 end if
10315
10316 i1 = parameters%k * par * exp(-parameters%k * l1)
10317 i2 = parameters%k * par * exp(-parameters%k * l2)
10318 i3 = parameters%k * par * exp(-parameters%k * l3)
10319
10320 i1 = max(i1,1e-10)
10321 i2 = max(i2,1e-10)
10322 i3 = max(i3,1e-10)
10323
10324 a1 = amax * (1 - exp(-parameters%epsi * i1 / amax))
10325 a2 = amax * (1 - exp(-parameters%epsi * i2 / amax)) * 1.6
10326 a3 = amax * (1 - exp(-parameters%epsi * i3 / amax))
10327
10328 if (xlai <= 0.05) then
10329 a = (a1+a2+a3) / 3.6 * 0.05
10330 elseif (xlai > 0.05 .and. xlai <= 4.0) then
10331 a = (a1+a2+a3) / 3.6 * xlai
10332 else
10333 a = (a1+a2+a3) / 3.6 * 4
10334 end if
10335
10336 a = a * parameters%psnrf ! attainable
10337
10338 psncrop = 6.313 * a ! (1/44) * 1000000)/3600 = 6.313
10339
10340end subroutine psn_crop
10341
10342!== begin bvocflux =================================================================================
10343
10344! subroutine bvocflux(parameters,vocflx, vegtyp, vegfrac, apar, tv )
10345!
10346! ------------------------------------------------------------------------------------------
10347! implicit none
10348! ------------------------------------------------------------------------------------------
10349!
10350! ------------------------ code history ---------------------------
10351! source file: bvoc
10352! purpose: bvoc emissions
10353! description:
10354! volatile organic compound emission
10355! this code simulates volatile organic compound emissions
10356! following the algorithm presented in guenther, a., 1999: modeling
10357! biogenic volatile organic compound emissions to the atmosphere. in
10358! reactive hydrocarbons in the atmosphere, ch. 3
10359! this model relies on the assumption that 90% of isoprene and monoterpene
10360! emissions originate from canopy foliage:
10361! e = epsilon * gamma * density * delta
10362! the factor delta (longterm activity factor) applies to isoprene emission
10363! from deciduous plants only. we neglect this factor at the present time.
10364! this factor is discussed in guenther (1997).
10365! subroutine written to operate at the patch level.
10366! in final implementation, remember:
10367! 1. may wish to call this routine only as freq. as rad. calculations
10368! 2. may wish to place epsilon values directly in pft-physiology file
10369! ------------------------ input/output variables -----------------
10370! input
10371! integer ,intent(in) :: vegtyp !vegetation type
10372! real (kind=kind_phys) ,intent(in) :: vegfrac !green vegetation fraction [0.0-1.0]
10373! real (kind=kind_phys) ,intent(in) :: apar !photosynthesis active energy by canopy (w/m2)
10374! real (kind=kind_phys) ,intent(in) :: tv !vegetation canopy temperature (k)
10375!
10376! output
10377! real (kind=kind_phys) ,intent(out) :: vocflx(5) ! voc fluxes [ug c m-2 h-1]
10378!
10379! local variables
10380!
10381! real (kind=kind_phys), parameter :: r = 8.314 ! univ. gas constant [j k-1 mol-1]
10382! real (kind=kind_phys), parameter :: alpha = 0.0027 ! empirical coefficient
10383! real (kind=kind_phys), parameter :: cl1 = 1.066 ! empirical coefficient
10384! real (kind=kind_phys), parameter :: ct1 = 95000.0 ! empirical coefficient [j mol-1]
10385! real (kind=kind_phys), parameter :: ct2 = 230000.0 ! empirical coefficient [j mol-1]
10386! real (kind=kind_phys), parameter :: ct3 = 0.961 ! empirical coefficient
10387! real (kind=kind_phys), parameter :: tm = 314.0 ! empirical coefficient [k]
10388! real (kind=kind_phys), parameter :: tstd = 303.0 ! std temperature [k]
10389! real (kind=kind_phys), parameter :: bet = 0.09 ! beta empirical coefficient [k-1]
10390!
10391! integer ivoc ! do-loop index
10392! integer ityp ! do-loop index
10393! real (kind=kind_phys) epsilon(5)
10394! real (kind=kind_phys) gamma(5)
10395! real (kind=kind_phys) density
10396! real (kind=kind_phys) elai
10397! real (kind=kind_phys) par,cl,reciprod,ct
10398!
10399! epsilon :
10400!
10401! do ivoc = 1, 5
10402! epsilon(ivoc) = parameters%eps(vegtyp,ivoc)
10403! end do
10404!
10405! gamma : activity factor. units [dimensionless]
10406!
10407! reciprod = 1. / (r * tv * tstd)
10408! ct = exp(ct1 * (tv - tstd) * reciprod) / &
10409! (ct3 + exp(ct2 * (tv - tm) * reciprod))
10410!
10411! par = apar * 4.6 ! (multiply w/m2 by 4.6 to get umol/m2/s)
10412! cl = alpha * cl1 * par * (1. + alpha * alpha * par * par)**(-0.5)
10413!
10414! gamma(1) = cl * ct ! for isoprenes
10415!
10416! do ivoc = 2, 5
10417! gamma(ivoc) = exp(bet * (tv - tstd))
10418! end do
10419!
10420! foliage density
10421!
10422! transform vegfrac to lai
10423!
10424! elai = max(0.0,-6.5/2.5*alog((1.-vegfrac)))
10425! density = elai / (parameters%slarea(vegtyp) * 0.5)
10426!
10427! calculate the voc flux
10428!
10429! do ivoc = 1, 5
10430! vocflx(ivoc) = epsilon(ivoc) * gamma(ivoc) * density
10431! end do
10432!
10433! end subroutine bvocflux
10434! ==================================================================================================
10435! ********************************* end of carbon subroutines *****************************
10436! ==================================================================================================
10437
10438!== begin noahmp_options ===========================================================================
10439
10442 subroutine noahmp_options(idveg , iopt_crs , iopt_btr , iopt_run , iopt_sfc , iopt_frz , &
10443 iopt_inf, iopt_rad , iopt_alb , iopt_snf , iopt_tbot, iopt_stc , &
10444 iopt_rsf, iopt_soil, iopt_pedo, iopt_crop, iopt_trs , iopt_diag, &
10445 iopt_z0m )
10446
10447 implicit none
10448
10449 integer, intent(in) :: idveg
10450 integer, intent(in) :: iopt_crs
10451 integer, intent(in) :: iopt_btr
10452 integer, intent(in) :: iopt_run
10453 integer, intent(in) :: iopt_sfc
10454 integer, intent(in) :: iopt_frz
10455 integer, intent(in) :: iopt_inf
10456 integer, intent(in) :: iopt_rad
10457 integer, intent(in) :: iopt_alb
10458 integer, intent(in) :: iopt_snf
10459 integer, intent(in) :: iopt_tbot
10460
10461 integer, intent(in) :: iopt_stc
10463 integer, intent(in) :: iopt_rsf
10464 integer, intent(in) :: iopt_soil
10465 integer, intent(in) :: iopt_pedo
10466 integer, intent(in) :: iopt_crop
10467 integer, intent(in) :: iopt_trs
10468 integer, intent(in) :: iopt_diag
10469 integer, intent(in) :: iopt_z0m
10470
10471! -------------------------------------------------------------------------------------------------
10472
10473 dveg = idveg
10474
10475 opt_crs = iopt_crs
10476 opt_btr = iopt_btr
10477 opt_run = iopt_run
10478 opt_sfc = iopt_sfc
10479 opt_frz = iopt_frz
10480 opt_inf = iopt_inf
10481 opt_rad = iopt_rad
10482 opt_alb = iopt_alb
10483 opt_snf = iopt_snf
10484 opt_tbot = iopt_tbot
10485 opt_stc = iopt_stc
10486 opt_rsf = iopt_rsf
10487 opt_soil = iopt_soil
10488 opt_pedo = iopt_pedo
10489 opt_crop = iopt_crop
10490 opt_trs = iopt_trs
10491 opt_diag = iopt_diag
10492 opt_z0m = iopt_z0m
10493
10494 end subroutine noahmp_options
10495
10498 subroutine sfcdif4(iloc ,jloc ,ux ,vx ,t1d , &
10499 p1d ,psfcpa,pblhx ,dx ,znt , &
10500 ep_1, ep_2, cp, &
10501 itime ,snwh ,isice ,psi_opt, &
10502 tsk ,qx ,zlvl ,iz0tlnd,qsfc , &
10503 hfx ,qfx ,cm ,chs ,chs2 , &
10504 cqs2 , &
10505 rmolx ,ust , rbx, fmx, fhx,stressx,&
10506 fm10x, fh2x, wspdx,flhcx,flqcx)
10507
10508
10509
10510!-------------------------------------------------------------------
10511 implicit none
10512!-------------------------------------------------------------------
10513
10514! input
10515
10516 integer,intent(in ) :: iloc
10517 integer,intent(in ) :: jloc
10518 integer, intent(in) :: itime
10519
10520 integer, intent(in) :: psi_opt
10521
10522 integer, intent(in) :: isice
10523
10524 real(kind=kind_phys), intent(in ) :: pblhx
10525 real(kind=kind_phys), intent(in ) :: tsk
10526 real(kind=kind_phys), intent(in ) :: psfcpa
10527 real(kind=kind_phys), intent(in ) :: p1d
10528 real(kind=kind_phys), intent(in ) :: t1d
10529 real(kind=kind_phys), intent(in ) :: qx
10530 real(kind=kind_phys), intent(in ) :: zlvl
10531 real(kind=kind_phys), intent(in ) :: hfx
10532 real(kind=kind_phys), intent(in ) :: qfx
10533 real(kind=kind_phys), intent(in ) :: dx
10534 real(kind=kind_phys), intent(in ) :: ux
10535 real(kind=kind_phys), intent(in ) :: vx
10536 real(kind=kind_phys), intent(in ) :: znt
10537 real(kind=kind_phys), intent(in ) :: snwh
10538 real(kind=kind_phys), intent(in ) :: ep_1
10539 real(kind=kind_phys), intent(in ) :: ep_2
10540 real(kind=kind_phys), intent(in ) :: cp
10541
10542! optional vars
10543
10544 integer,optional,intent(in ) :: iz0tlnd
10545
10546 real(kind=kind_phys), intent(inout) :: qsfc
10547 real(kind=kind_phys), intent(inout) :: ust
10548 real(kind=kind_phys), intent(inout) :: chs
10549 real(kind=kind_phys), intent(inout) :: chs2
10550 real(kind=kind_phys), intent(inout) :: cqs2
10551 real(kind=kind_phys), intent(inout) :: cm
10552
10553 real(kind=kind_phys), intent(inout) :: rmolx
10554 real(kind=kind_phys), intent(inout) :: rbx
10555 real(kind=kind_phys), intent(inout) :: fmx
10556 real(kind=kind_phys), intent(inout) :: fhx
10557 real(kind=kind_phys), intent(inout) :: stressx
10558 real(kind=kind_phys), intent(inout) :: fm10x
10559 real(kind=kind_phys), intent(inout) :: fh2x
10560
10561 real(kind=kind_phys), intent(inout) :: wspdx
10562 real(kind=kind_phys), intent(inout) :: flhcx
10563 real(kind=kind_phys), intent(inout) :: flqcx
10564
10565 real(kind=kind_phys) :: zolx
10566 real(kind=kind_phys) :: molx
10567
10568! diagnostics out
10569! real, intent(out) :: u10
10570! real, intent(out) :: v10
10571! real, intent(out) :: th2
10572! real, intent(out) :: t2
10573! real, intent(out) :: q2
10574! real, intent(out) :: qsfc
10575
10576
10577! local
10578
10579 real(kind=kind_phys) :: za ! height of full-sigma level
10580 real(kind=kind_phys) :: thvx ! virtual potential temperature
10581 real(kind=kind_phys) :: zqkl ! height of upper half level
10582 real(kind=kind_phys) :: zqklp1 ! height of lower half level (surface)
10583 real(kind=kind_phys) :: thx ! potential temperature
10584 real(kind=kind_phys) :: psih ! similarity function for heat
10585 real(kind=kind_phys) :: psih2 ! similarity function for heat 2m
10586 real(kind=kind_phys) :: psih10 ! similarity function for heat 10m
10587 real(kind=kind_phys) :: psim ! similarity function for momentum
10588 real(kind=kind_phys) :: psim2 ! similarity function for momentum 2m
10589 real(kind=kind_phys) :: psim10 ! similarity function for momentum 10m
10590
10591 real(kind=kind_phys) :: gz1oz0 ! log(za/z0)
10592 real(kind=kind_phys) :: gz2oz0 ! log(z2/z0)
10593 real(kind=kind_phys) :: gz10oz0 ! log(z10/z0)
10594
10595 real(kind=kind_phys) :: rhox ! density
10596 real(kind=kind_phys) :: govrth ! g/theta for stability l
10597 real(kind=kind_phys) :: tgdsa ! tsk
10598 real(kind=kind_phys) :: tvir ! temporal variable src4 -> tvir
10599 real(kind=kind_phys) :: thgb ! potential temperature ground
10600 real(kind=kind_phys) :: psfcx ! surface pressure
10601 real(kind=kind_phys) :: cpm
10602 real(kind=kind_phys) :: qgh
10603
10604 integer :: n,i,k,kk,l,nzol,nk,nzol2,nzol10
10605
10606 real(kind=kind_phys) :: zolzt, zolz0, zolza
10607 real(kind=kind_phys) :: gz1ozt,gz2ozt,gz10ozt
10608
10609
10610 real(kind=kind_phys) :: pl,thcon,tvcon,e1
10611 real(kind=kind_phys) :: zl,tskv,dthvdz,dthvm,vconv,rzol,rzol2,rzol10,zol2,zol10
10612 real(kind=kind_phys) :: dtg,psix,dtthx,psix10,psit,psit2,psiq,psiq2,psiq10
10613 real(kind=kind_phys) :: fluxc,vsgd,z0q,visc,restar,czil,restar2
10614
10615 real(kind=kind_phys) :: dqg
10616 real(kind=kind_phys) :: tabs
10617 real(kind=kind_phys) :: qsfcmr
10618 real(kind=kind_phys) :: t1dc
10619 real(kind=kind_phys) :: zt
10620 real(kind=kind_phys) :: zq
10621 real(kind=kind_phys) :: zratio
10622 real(kind=kind_phys) :: qstar
10623 real(kind=kind_phys) :: ep2
10624 real(kind=kind_phys) :: ep_3
10625!-------------------------------------------------------------------
10626
10627 psfcx=psfcpa/1000. ! to kPa for saturation check
10628 ep2=ep_2
10629 ep_3=1.-ep_2
10630
10631 if (itime == 1) then !init SP, MR
10632 if (isice == 0) then
10633 tabs = 0.5*(tsk + t1d)
10634 if (tabs .lt. 273.15) then
10635 !saturation vapor pressure wrt ice (svp1=.6112; 10*mb)
10636 e1=svp1*exp(4648*(1./273.15 - 1./tabs) - &
10637 & 11.64*log(273.15/tabs) + 0.02265*(273.15 - tabs))
10638 else
10639 !saturation vapor pressure wrt water (bolton 1980)
10640 e1=svp1*exp(svp2*(tabs-svpt0)/(tabs-svp3))
10641 endif
10642
10643 qsfc =ep2*e1/(psfcx-ep_3*e1) !avg with the input?
10644 qsfcmr =qsfc/(1.-qsfc) !to mixing ratio
10645 endif
10646
10647 if (isice == 1) then
10648 if (tsk .lt. 273.15) then
10649 !saturation vapor pressure wrt ice (svp1=.6112; 10*mb)
10650 e1=svp1*exp(4648*(1./273.15 - 1./tsk) - &
10651 & 11.64*log(273.15/tsk) + 0.02265*(273.15 - tsk))
10652 else
10653 !saturation vapor pressure wrt water (bolton 1980)
10654 e1=svp1*exp(svp2*(tsk-svpt0)/(tsk-svp3))
10655 endif
10656
10657 qsfc=ep2*e1/(psfcx-ep_3*e1) !specific humidity
10658 qsfcmr=ep2*e1/(psfcx-e1) !mixing ratio
10659
10660 endif
10661
10662 else
10663 ! use what comes out of the lsm
10664 if (isice == 0) then
10665 tabs = 0.5*(tsk + t1d)
10666 if (tabs .lt. 273.15) then
10667 !saturation vapor pressure wrt ice (svp1=.6112; 10*mb)
10668 e1=svp1*exp(4648*(1./273.15 - 1./tabs) - &
10669 & 11.64*log(273.15/tabs) + 0.02265*(273.15 - tabs))
10670 else
10671 !saturation vapor pressure wrt water (bolton 1980)
10672 e1=svp1*exp(svp2*(tabs-svpt0)/(tabs-svp3))
10673 endif
10674
10675 qsfc =ep2*e1/(psfcx-ep_3*e1) ! avg with previous qsfc?
10676 qsfcmr=qsfc/(1.-qsfc)
10677
10678 endif
10679
10680 if (isice == 1) then
10681 if (tsk .lt. 273.15) then
10682 !saturation vapor pressure wrt ice (svp1=.6112; 10*mb)
10683 e1=svp1*exp(4648*(1./273.15 - 1./tsk) - &
10684 & 11.64*log(273.15/tsk) + 0.02265*(273.15 - tsk))
10685 else
10686 !saturation vapor pressure wrt water (bolton 1980)
10687 e1=svp1*exp(svp2*(tsk-svpt0)/(tsk-svp3))
10688 endif
10689
10690 qsfc=ep2*e1/(psfcx-ep_3*e1) !specific humidity
10691 qsfcmr=qsfc/(1.-qsfc)
10692
10693 endif
10694
10695 endif !done INIT if itime=1
10696! convert (tah or tgb = tsk) temperature to potential temperature.
10697 tgdsa = tsk
10698 thgb = tsk*(p1000mb/psfcpa)**(rair/cpair) !psfcpa is pa
10699
10700! store virtual, virtual potential and potential temperature
10701
10702 pl = p1d/1000.
10703 thx = t1d*(p1000mb*0.001/pl)**(rair/cpair)
10704 t1dc = t1d - 273.15
10705
10706 thvx = thx*(1.+ep_1*qx) !qx is SH from input
10707 tvir = t1d*(1.+ep_1*qx)
10708
10709 rhox=psfcx*1000./(rair*tvir)
10710 govrth=grav/thx
10711 za = zlvl
10712
10713 !za=0.5*dz8w
10714
10715
10716! directly from input; check units
10717
10718! qfx = qflx * rhox
10719! hfx = hflx * rhox * cp
10720
10721
10722
10723! q2sat = qgh in lsm
10724!jref: canres and esat is calculated in the loop so should that be changed??
10725! qgh=ep_2*e1/(pl-e1)
10726! cpm=cp*(1.+0.8*qx)
10727
10728
10729! qgh changed to use lowest-level air temp
10730
10731 if (t1d .lt. 273.15) then
10732 !saturation vapor pressure wrt ice
10733 e1=svp1*exp(4648.*(1./273.15 - 1./t1d) - &
10734 & 11.64*log(273.15/t1d) + 0.02265*(273.15 - t1d))
10735 else
10736 !saturation vapor pressure wrt water (bolton 1980)
10737 e1=svp1*exp(svp2*(t1d-svpt0)/(t1d-svp3))
10738 endif
10739
10740
10741 !qgh=ep2*e1/(pl-ep_3*e1) !specific humidity
10742
10743 qgh=ep2*e1/(pl-e1) !sat. mixing ratio ?
10744
10745! cpm=cp*(1.+0.84*qx) ! qx is SH
10746 cpm=cp*(1.+0.84*qx/(1.0-qx) )
10747
10748 wspdx=sqrt(ux*ux+vx*vx)
10749
10750 tskv=thgb*(1.+ep_1*qsfc) !avg with tsurf not used
10751 dthvdz=(thvx-tskv)
10752
10753 fluxc = max(hfx/rhox/cp + ep_1*tskv*qfx/rhox,0.) !hfx + qfx are fluxes units: wm^-2 and kg m^-2 s^-1
10754! vconv = vconvc*(g/tgdsa*pblh*fluxc)**.33
10755
10756 vconv = vconvc*(grav/tgdsa*min(1.5*pblhx,4000.0)*fluxc)**.33 !wstar
10757! vsgd = 0.32 * (max(dx/5000.-1.,0.))**.33
10758
10759 vsgd = min(0.32 * (max(dx/5000.-1.,0.))**.33,0.5)
10760 wspdx=sqrt(wspdx*wspdx+vconv*vconv+vsgd*vsgd)
10761 wspdx=max(wspdx,0.1) !0.1 is wmin
10762 rbx=govrth*za*dthvdz/(wspdx*wspdx) !buld rich #
10763
10764 if (itime == 1) then
10765 rbx=max(rbx,-2.0)
10766 rbx=min(rbx, 2.0)
10767 else
10768 rbx=max(rbx,-4.0)
10769 rbx=min(rbx, 4.0)
10770 endif
10771
10772
10773! visc=(1.32+0.009*(t1d-273.15))*1.e-5
10774! kinematic viscosity
10775
10776
10777 visc=1.326e-5*(1. + 6.542e-3*t1dc + 8.301e-6*t1dc*t1dc &
10778 - 4.84e-9*t1dc*t1dc*t1dc)
10779
10780!compute roughness reynolds number (restar) using default znt
10781!the GFS option has been removed
10782
10783 restar=max(ust*znt/visc,0.1)
10784
10785! get zt, zq based on the input
10786! the GFS roughness option and spp_pbl have been removed
10787
10788 if (snwh > 50. .or. isice == 1) then ! (mm) treat as snow cover - use andreas cover isice =1
10789 call andreas_2002(znt,visc,ust,zt,zq)
10790 else
10791 if ( present(iz0tlnd) ) then
10792 if ( iz0tlnd .le. 1 ) then
10793 call zilitinkevich_1995(znt,zt,zq,restar,&
10794 ust,vkc,1.0_kind_phys,iz0tlnd,0,0.0_kind_phys)
10795 elseif ( iz0tlnd .eq. 2 ) then
10796 call yang_2008(znt,zt,zq,ust,molx,&
10797 qstar,restar,visc)
10798 elseif ( iz0tlnd .eq. 3 ) then
10799 !original mynn in wrf-arw used this form:
10800 call garratt_1992(zt,zq,znt,restar,1.0_kind_phys)
10801 endif
10802
10803! the GFS option is removed along with gfs_z0_lnd
10804
10805 else
10806
10807 !default to zilitinkevich
10808 call zilitinkevich_1995(znt,zt,zq,restar,&
10809 ust,vkc,1.0_kind_phys,0,0,0.0_kind_phys)
10810 endif
10811 endif
10812
10813
10814! ---------
10815! calculate bulk richardson no. of surface layer,
10816! according to akb(1976), eq(12).
10817
10818
10819 gz1oz0= log((za+znt)/znt)
10820 gz1ozt= log((za+znt)/zt)
10821 gz2oz0= log((2.0+znt)/znt)
10822 gz2ozt= log((2.0+znt)/zt)
10823 gz10oz0=log((10.+znt)/znt)
10824! gz10ozt=log((10.+znt)/zt)
10825
10826 zratio=znt/zt !need estimate for li et al.
10827
10828
10829! vconv = 0.25*sqrt(g/tskv*pblh(i)*dthvm)
10830! if(mol.lt.0.) br=amin1(br,0.0) -> check the input mol later
10831! rmol=-govrth*dthvdz*za*vkc
10832
10833 if (rbx .gt. 0.0) then
10834
10835 !compute z/l first guess:
10836 call li_etal_2010(zolx,rbx,za/znt,zratio)
10837 !zol=za*vkc*grav*mol/(thx*max(ust*ust,0.0001))
10838 zolx=max(zolx,0.0)
10839 zolx=min(zolx,20.)
10840
10841
10842 !use pedros iterative function to find z/l
10843 !zol=zolri(rb_lnd,za,zntstoch_lnd,zt_lnd,zol,psi_opt)
10844 !use brute-force method
10845
10846 zolx=zolrib(rbx,za,znt,zt,gz1oz0,gz1ozt,zolx,psi_opt)
10847 zolx=max(zolx,0.0)
10848 zolx=min(zolx,20.)
10849
10850 zolzt = zolx*zt/za ! zt/l
10851 zolz0 = zolx*znt/za ! z0/l
10852 zolza = zolx*(za+znt)/za ! (z+z0/l
10853 zol10 = zolx*(10.+znt)/za ! (10+z0)/l
10854 zol2 = zolx*(2.+znt)/za ! (2+z0)/l
10855
10856 !compute psim and psih
10857 !call psi_beljaars_holtslag_1991(psim,psih,zol)
10858 !call psi_businger_1971(psim,psih,zol)
10859 !call psi_zilitinkevich_esau_2007(psim,psih,zol)
10860 !call psi_dyerhicks(psim,psih,zol,zt_lnd,zntstoch_lnd,za)
10861 !call psi_cb2005(psim,psih,zolza,zolz0)
10862
10863 psim=psim_stable(zolza,psi_opt)-psim_stable(zolz0,psi_opt)
10864 psih=psih_stable(zolza,psi_opt)-psih_stable(zolzt,psi_opt)
10865 psim10=psim_stable(zol10,psi_opt)-psim_stable(zolz0,psi_opt)
10866! psih10=psih_stable(zol10,psi_opt)-psih_stable(zolz0,psi_opt)
10867 psih2=psih_stable(zol2,psi_opt)-psih_stable(zolzt,psi_opt)
10868
10869 ! 1.0 over monin-obukhov length
10870
10871 rmolx= zolx/za
10872
10873 elseif(rbx .eq. 0.) then
10874 !=========================================================
10875 !-----class 3; forced convection/neutral:
10876 !=========================================================
10877
10878 psim=0.0
10879 psih=psim
10880 psim10=0.
10881! psih10=0.
10882 psih2=0.
10883
10884 zolx =0.
10885 rmolx =0.
10886
10887 elseif(rbx .lt. 0.)then
10888 !==========================================================
10889 !-----class 4; free convection:
10890 !==========================================================
10891
10892 !compute z/l first guess:
10893
10894 call li_etal_2010(zolx,rbx,za/znt,zratio)
10895
10896 !zol=za*vkc*grav*mol/(th1d*max(ust_lnd*ust_lnd,0.001))
10897
10898 zolx=max(zolx,-20.0)
10899 zolx=min(zolx,0.0)
10900
10901
10902 !use pedros iterative function to find z/l
10903 !zol=zolri(rb_lnd,za,zntstoch_lnd,zt_lnd,zol,psi_opt)
10904 !use brute-force method
10905
10906 zolx=zolrib(rbx,za,znt,zt,gz1oz0,gz1ozt,zolx,psi_opt)
10907 zolx=max(zolx,-20.0)
10908 zolx=min(zolx,0.0)
10909
10910 zolzt = zolx*zt/za ! zt/l
10911 zolz0 = zolx*znt/za ! z0/l
10912 zolza = zolx*(za+znt)/za ! (z+z0/l
10913 zol10 = zolx*(10.+znt)/za ! (10+z0)/l
10914 zol2 = zolx*(2.+znt)/za ! (2+z0)/l
10915
10916 !compute psim and psih
10917 !call psi_hogstrom_1996(psim,psih,zol, zt_lnd, zntstoch_lnd, za)
10918 !call psi_businger_1971(psim,psih,zol)
10919 !call psi_dyerhicks(psim,psih,zol,zt_lnd,zntstoch_lnd,za)
10920 ! use tables
10921
10922 psim=psim_unstable(zolza,psi_opt)-psim_unstable(zolz0,psi_opt)
10923 psih=psih_unstable(zolza,psi_opt)-psih_unstable(zolzt,psi_opt)
10924 psim10=psim_unstable(zol10,psi_opt)-psim_unstable(zolz0,psi_opt)
10925! psih10=psih_unstable(zol10,psi_opt)-psih_unstable(zolz0,psi_opt)
10926 psih2=psih_unstable(zol2,psi_opt)-psih_unstable(zolzt,psi_opt)
10927
10928 !---limit psih and psim in the case of thin layers and
10929 !---high roughness. this prevents denominator in fluxes
10930 !---from getting too small
10931
10932 psih=min(psih,0.9*gz1ozt)
10933 psim=min(psim,0.9*gz1oz0)
10934 psih2=min(psih2,0.9*gz2ozt)
10935 psim10=min(psim10,0.9*gz10oz0)
10936! psih10=min(psih10,0.9*gz10ozt)
10937
10938 rmolx = zolx/za
10939
10940 endif
10941
10942 ! calculate the resistance:
10943
10944 psix =max(gz1oz0-psim, 1.0)
10945 psix10=max(gz10oz0-psim10, 1.0)
10946 psit =max(gz1ozt-psih , 1.0)
10947 psit2 =max(gz2ozt-psih2, 1.0)
10948 psiq =max(log((za+zq)/zq)-psih ,1.0)
10949 psiq2 =max(log((2.0+zq)/zq)-psih2 ,1.0)
10950
10951 !------------------------------------------------------------
10952 !-----compute the frictional velocity:
10953 !------------------------------------------------------------
10954
10955
10956 ! to prevent oscillations average with old value
10957
10958! oldust = ust
10959
10960 ust=0.5*ust+0.5*vkc*wspdx/psix
10961 ust=max(ust,0.005)
10962
10963! stress=ust**2
10964
10965 !set ustm = ust over land.
10966
10967! ustmx=ust
10968
10969
10970 !----------------------------------------------------
10971 !----compute the temperature scale (a.k.a. friction temperature, t*, or mol)
10972 !----and compute the moisture scale (or q*)
10973 !----------------------------------------------------
10974
10975 dtg=thvx-tskv
10976
10977! oldtst=mol
10978
10979 molx=vkc*dtg/psit/prt !T*
10980
10981 !t_star = -hfx/(ust*cpm*rho1d)
10982 !t_star = mol
10983 !----------------------------------------------------
10984 ! dqg=(qvsh-qsfc)*1000. !(kg/kg -> g/kg)
10985
10986 dqg=(qx-qsfc)*1000. !(kg/kg -> g/kg)
10987 qstar=vkc*dqg/psiq/prt
10988
10989 cm = (vkc/psix)*(vkc/psix)*wspdx
10990
10991! cm = (vkc/psix)*(vkc/psix)
10992! ch = (vkc/psix)*(vkc/psit)
10993
10994 chs=ust*vkc/psit
10995 cqs2=ust*vkc/psiq2
10996 chs2=ust*vkc/psit2
10997
10998! u10=ux*psix10/psix
10999! v10=vx*psix10/psix
11000
11001 flhcx = rhox*cpm*ust*vkc/psit
11002 flqcx = rhox*1.0*ust*vkc/psiq
11003
11004! ch = flhcx/(cpm*rhox) !same chs
11005
11006 fmx = psix
11007 fhx = psit
11008 fm10x = psix10
11009 fh2x =psit2
11010
11011! ustmx = ust
11012
11013 stressx = ust**2 ! or cm*wind*wind
11014
11015 end subroutine sfcdif4
11016
11019 subroutine zilitinkevich_1995(z_0,zt,zq,restar,ustar,vkc,&
11020 & landsea,iz0tlnd2,spp_pbl,rstoch)
11021
11022 implicit none
11023 real (kind=kind_phys), intent(in) :: z_0,restar,ustar,vkc,landsea
11024 integer, optional, intent(in):: iz0tlnd2
11025 real (kind=kind_phys), intent(out) :: zt,zq
11026 real (kind=kind_phys) :: czil !=0.100 in chen et al. (1997)
11027 !=0.075 in zilitinkevich (1995)
11028 !=0.500 in lemone et al. (2008)
11029 integer, intent(in) :: spp_pbl
11030 real (kind=kind_phys), intent(in) :: rstoch
11031
11032
11033 if (landsea-1.5 .gt. 0) then !water
11034
11035 !this is based on zilitinkevich, grachev, and fairall (2001;
11036 !their equations 15 and 16).
11037 if (restar .lt. 0.1) then
11038 zt = z_0*exp(vkc*2.0)
11039 zt = min( zt, 6.0e-5)
11040 zt = max( zt, 2.0e-9)
11041 zq = z_0*exp(vkc*3.0)
11042 zq = min( zq, 6.0e-5)
11043 zq = max( zq, 2.0e-9)
11044 else
11045 zt = z_0*exp(-vkc*(4.0*sqrt(restar)-3.2))
11046 zt = min( zt, 6.0e-5)
11047 zt = max( zt, 2.0e-9)
11048 zq = z_0*exp(-vkc*(4.0*sqrt(restar)-4.2))
11049 zq = min( zt, 6.0e-5)
11050 zq = max( zt, 2.0e-9)
11051 endif
11052
11053 else !land
11054
11055 !option to modify czil according to chen & zhang, 2009
11056 if ( iz0tlnd2 .eq. 1 ) then
11057 czil = 10.0 ** ( -0.40 * ( z_0 / 0.07 ) )
11058 else
11059 czil = 0.085 !0.075 !0.10
11060 end if
11061
11062 zt = z_0*exp(-vkc*czil*sqrt(restar))
11063 zt = min( zt, 0.75*z_0)
11064
11065 zq = z_0*exp(-vkc*czil*sqrt(restar))
11066 zq = min( zq, 0.75*z_0)
11067
11068
11069! stochastically perturb thermal and moisture roughness length.
11070! currently set to half the amplitude:
11071 if (spp_pbl==1) then
11072 zt = zt + zt * 0.5 * rstoch
11073 zt = max(zt, 0.0001)
11074 zq = zt
11075 endif
11076
11077 endif
11078
11079 return
11080
11081 end subroutine zilitinkevich_1995
11082
11086 subroutine garratt_1992(zt,zq,z_0,ren,landsea)
11087
11088 implicit none
11089 real (kind=kind_phys), intent(in) :: ren, z_0,landsea
11090 real (kind=kind_phys), intent(out) :: zt,zq
11091 real (kind=kind_phys) :: rq
11092 real (kind=kind_phys), parameter :: e=2.71828183
11093
11094 if (landsea-1.5 .gt. 0) then !water
11095
11096 zt = z_0*exp(2.0 - (2.48*(ren**0.25)))
11097 zq = z_0*exp(2.0 - (2.28*(ren**0.25)))
11098
11099 zq = min( zq, 5.5e-5)
11100 zq = max( zq, 2.0e-9)
11101 zt = min( zt, 5.5e-5)
11102 zt = max( zt, 2.0e-9) !same lower limit as ecmwf
11103 else !land
11104 zq = z_0/(e**2.) !taken from garratt (1980,1992)
11105 zt = zq
11106 endif
11107
11108 return
11109
11110 end subroutine garratt_1992
11111!--------------------------------------------------------------------
11136 subroutine yang_2008(z_0,zt,zq,ustar,tstar,qst,ren,visc)
11137
11138 implicit none
11139 real (kind=kind_phys), intent(in) :: z_0, ren, ustar, tstar, qst, visc
11140 real (kind=kind_phys) :: ht, &! roughness height at critical reynolds number
11141 tstar2, &! bounded t*, forced to be non-positive
11142 qstar2, &! bounded q*, forced to be non-positive
11143 z_02, &! bounded z_0 for variable renc2 calc
11144 renc2 ! variable renc, function of z_0
11145 real (kind=kind_phys), intent(out) :: zt,zq
11146 real (kind=kind_phys), parameter :: renc=300., & !old constant renc
11147 beta=1.5, & !important for diurnal variation
11148 m=170., & !slope for renc2 function
11149 b=691. !y-intercept for renc2 function
11150
11151 z_02 = min(z_0,0.5)
11152 z_02 = max(z_02,0.04)
11153 renc2= b + m*log(z_02)
11154 ht = renc2*visc/max(ustar,0.01)
11155 tstar2 = min(tstar, 0.0)
11156 qstar2 = min(qst,0.0)
11157
11158 zt = ht * exp(-beta*(ustar**0.5)*(abs(tstar2)**1.0))
11159 zq = ht * exp(-beta*(ustar**0.5)*(abs(qstar2)**1.0))
11160 !zq = zt
11161
11162 zt = min(zt, z_0/2.0)
11163 zq = min(zq, z_0/2.0)
11164
11165 return
11166
11167 end subroutine yang_2008
11168
11174 subroutine andreas_2002(z_0,bvisc,ustar,zt,zq)
11175
11176 implicit none
11177 real (kind=kind_phys), intent(in) :: z_0, bvisc, ustar
11178 real (kind=kind_phys), intent(out) :: zt, zq
11179 real (kind=kind_phys):: ren2, zntsno
11180
11181 real (kind=kind_phys), parameter :: bt0_s=1.25, bt0_t=0.149, bt0_r=0.317, &
11182 bt1_s=0.0, bt1_t=-0.55, bt1_r=-0.565, &
11183 bt2_s=0.0, bt2_t=0.0, bt2_r=-0.183
11184
11185 real (kind=kind_phys), parameter :: bq0_s=1.61, bq0_t=0.351, bq0_r=0.396, &
11186 bq1_s=0.0, bq1_t=-0.628, bq1_r=-0.512, &
11187 bq2_s=0.0, bq2_t=0.0, bq2_r=-0.180
11188
11189 !calculate zo for snow (andreas et al. 2005, blm)
11190 zntsno = 0.135*bvisc/ustar + &
11191 (0.035*(ustar*ustar)/9.8) * &
11192 (5.*exp(-1.*(((ustar - 0.18)/0.1)*((ustar - 0.18)/0.1))) + 1.)
11193 ren2 = ustar*zntsno/bvisc
11194
11195 ! make sure that re is not outside of the range of validity
11196 ! for using their equations
11197 if (ren2 .gt. 1000.) ren2 = 1000.
11198
11199 if (ren2 .le. 0.135) then
11200
11201 zt = zntsno*exp(bt0_s + bt1_s*log(ren2) + bt2_s*log(ren2)**2)
11202 zq = zntsno*exp(bq0_s + bq1_s*log(ren2) + bq2_s*log(ren2)**2)
11203
11204 else if (ren2 .gt. 0.135 .and. ren2 .lt. 2.5) then
11205
11206 zt = zntsno*exp(bt0_t + bt1_t*log(ren2) + bt2_t*log(ren2)**2)
11207 zq = zntsno*exp(bq0_t + bq1_t*log(ren2) + bq2_t*log(ren2)**2)
11208
11209 else
11210
11211 zt = zntsno*exp(bt0_r + bt1_r*log(ren2) + bt2_r*log(ren2)**2)
11212 zq = zntsno*exp(bq0_r + bq1_r*log(ren2) + bq2_r*log(ren2)**2)
11213
11214 endif
11215
11216 return
11217
11218 end subroutine andreas_2002
11219!--------------------------------------------------------------------
11224 subroutine li_etal_2010(zl, rib, zaz0, z0zt)
11225
11226 implicit none
11227 real (kind=kind_phys), intent(out) :: zl
11228 real (kind=kind_phys), intent(in) :: rib, zaz0, z0zt
11229 real (kind=kind_phys) :: alfa, beta, zaz02, z0zt2
11230 real (kind=kind_phys), parameter :: au11=0.045, bu11=0.003, bu12=0.0059, &
11231 &bu21=-0.0828, bu22=0.8845, bu31=0.1739, &
11232 &bu32=-0.9213, bu33=-0.1057
11233 real (kind=kind_phys), parameter :: aw11=0.5738, aw12=-0.4399, aw21=-4.901,&
11234 &aw22=52.50, bw11=-0.0539, bw12=1.540, &
11235 &bw21=-0.669, bw22=-3.282
11236 real (kind=kind_phys), parameter :: as11=0.7529, as21=14.94, bs11=0.1569,&
11237 &bs21=-0.3091, bs22=-1.303
11238
11239 !set limits according to li et al (2010), p 157.
11240 zaz02=zaz0
11241 if (zaz0 .lt. 100.0) zaz02=100.
11242 if (zaz0 .gt. 100000.0) zaz02=100000.
11243
11244 !set more limits according to li et al (2010)
11245 z0zt2=z0zt
11246 if (z0zt .lt. 0.5) z0zt2=0.5
11247 if (z0zt .gt. 100.0) z0zt2=100.
11248
11249 alfa = log(zaz02)
11250 beta = log(z0zt2)
11251
11252 if (rib .le. 0.0) then
11253 zl = au11*alfa*rib**2 + ( &
11254 & (bu11*beta + bu12)*alfa**2 + &
11255 & (bu21*beta + bu22)*alfa + &
11256 & (bu31*beta**2 + bu32*beta + bu33))*rib
11257 !if(zl .lt. -15 .or. zl .gt. 0.)print*,"violation rib<0:",zl
11258 zl = max(zl,-15.) !limits set according to li et al (2010)
11259 zl = min(zl,0.) !figure 1.
11260 elseif (rib .gt. 0.0 .and. rib .le. 0.2) then
11261 zl = ((aw11*beta + aw12)*alfa + &
11262 & (aw21*beta + aw22))*rib**2 + &
11263 & ((bw11*beta + bw12)*alfa + &
11264 & (bw21*beta + bw22))*rib
11265 !if(zl .lt. 0 .or. zl .gt. 4)print*,"violation 0<rib<0.2:",zl
11266 zl = min(zl,4.) !limits approx set according to li et al (2010)
11267 zl = max(zl,0.) !their figure 1b.
11268 else
11269 zl = (as11*alfa + as21)*rib + bs11*alfa + &
11270 & bs21*beta + bs22
11271 !if(zl .le. 1 .or. zl .gt. 23)print*,"violation rib>0.2:",zl
11272 zl = min(zl,20.) !limits according to li et al (2010), thier
11273 !figue 1c.
11274 zl = max(zl,1.)
11275 endif
11276
11277 return
11278
11279 end subroutine li_etal_2010
11280!-------------------------------------------------------------------
11283 real*8 function zolri(ri,za,z0,zt,zol1,psi_opt)
11284
11290
11291 implicit none
11292 real (kind=kind_phys), intent(in) :: ri,za,z0,zt,zol1
11293 integer, intent(in) :: psi_opt
11294 real (kind=kind_phys) :: x1,x2,fx1,fx2
11295 integer :: n
11296 integer, parameter :: nmax = 20
11297 real(kind=kind_phys) zolri_iteration
11298 !real, dimension(nmax):: zlhux
11299! real :: zolri2
11300
11301 if (ri.lt.0.)then
11302 x1=zol1 - 0.02 !-5.
11303 x2=0.
11304 else
11305 x1=0.
11306 x2=zol1 + 0.02 !5.
11307 endif
11308
11309 n=1
11310 fx1=zolri2(x1,ri,za,z0,zt,psi_opt)
11311 fx2=zolri2(x2,ri,za,z0,zt,psi_opt)
11312
11313 do while (abs(x1 - x2) > 0.01 .and. n < nmax)
11314 if(abs(fx2).lt.abs(fx1))then
11315 x1=x1-fx1/(fx2-fx1)*(x2-x1)
11316 fx1=zolri2(x1,ri,za,z0,zt,psi_opt)
11317 zolri=x1
11318 else
11319 x2=x2-fx2/(fx2-fx1)*(x2-x1)
11320 fx2=zolri2(x2,ri,za,z0,zt,psi_opt)
11321 zolri=x2
11322 endif
11323 n=n+1
11324 !print*," n=",n," x1=",x1," x2=",x2
11325 !zlhux(n)=zolri
11326 enddo
11327
11328 if (n==nmax .and. abs(x1 - x2) >= 0.01) then
11329 !if convergence fails, use approximate values:
11330 zolri_iteration= zolri
11331 call li_etal_2010(zolri_iteration, ri, za/z0, z0/zt)
11332 zolri = zolri_iteration
11333 !zlhux(n)=zolri
11334 !print*,"iter fail, n=",n," ri=",ri," z0=",z0
11335 else
11336 !print*,"success,n=",n," ri=",ri," z0=",z0
11337 endif
11338
11339 return
11340 end function
11341!-------------------------------------------------------------------
11342 real*8 function zolri2(zol2,ri2,za,z0,zt,psi_opt)
11343
11344 ! input: =================================
11345 ! zol2 - estimated z/l
11346 ! ri2 - calculated bulk richardson number
11347 ! za - 1/2 depth of first model layer
11348 ! z0 - aerodynamic roughness length
11349 ! zt - thermal roughness length
11350 ! output: ================================
11351 ! zolri2 - delta ri
11352
11353 implicit none
11354 integer, intent(in) :: psi_opt
11355 real (kind=kind_phys), intent(in) :: ri2,za,z0,zt
11356 real (kind=kind_phys), intent(inout) :: zol2
11357 real (kind=kind_phys) :: zol20,zol3,psim1,psih1,psix2,psit2,zolt
11358
11359! real :: psih_unstable,psim_unstable,psih_stable, psim_stable
11360
11361 if(zol2*ri2 .lt. 0.)zol2=0. ! limit zol2 - must be same sign as ri2
11362
11363 zol20=zol2*z0/za ! z0/l
11364 zol3=zol2+zol20 ! (z+z0)/l
11365 zolt=zol2*zt/za ! zt/l
11366
11367 if (ri2.lt.0) then
11368 !psix2=log((za+z0)/z0)-(psim_unstable(zol3)-psim_unstable(zol20))
11369 !psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20))
11370 psit2=max(log((za+z0)/zt)-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0)
11371 psix2=max(log((za+z0)/z0)-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)),1.0)
11372 else
11373 !psix2=log((za+z0)/z0)-(psim_stable(zol3)-psim_stable(zol20))
11374 !psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20))
11375 psit2=max(log((za+z0)/zt)-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0)
11376 psix2=max(log((za+z0)/z0)-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)),1.0)
11377 endif
11378
11379 zolri2=zol2*psit2/psix2**2 - ri2
11380 !print*," target ri=",ri2," est ri=",zol2*psit2/psix2**2
11381
11382 return
11383 end function
11384!====================================================================
11385
11386 real*8 function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt)
11387
11388 ! this iterative algorithm to compute z/l from bulk-ri
11389
11390 implicit none
11391 real (kind=kind_phys), intent(in) :: ri,za,z0,zt,logz0,logzt
11392 integer, intent(in) :: psi_opt
11393 real (kind=kind_phys), intent(inout) :: zol1
11394 real (kind=kind_phys) :: zol20,zol3,zolt,zolold
11395 integer :: n
11396 integer, parameter :: nmax = 20
11397 real (kind=kind_phys), dimension(nmax):: zlhux
11398 real (kind=kind_phys) :: psit2,psix2,zolrib_iteration
11399
11400! real :: psim_unstable, psim_stable
11401! real :: psih_unstable, psih_stable
11402
11403 !print*,"+++++++incoming: z/l=",zol1," ri=",ri
11404 if (zol1*ri .lt. 0.) then
11405 !print*,"begin: wrong quadrants: z/l=",zol1," ri=",ri
11406 zol1=0.
11407 endif
11408
11409 if (ri .lt. 0.) then
11410 zolold=-99999.
11411 zolrib=-66666.
11412 else
11413 zolold=99999.
11414 zolrib=66666.
11415 endif
11416 n=1
11417
11418 do while (abs(zolold - zolrib) > 0.01 .and. n < nmax)
11419
11420 if(n==1)then
11421 zolold=zol1
11422 else
11423 zolold=zolrib
11424 endif
11425 zol20=zolold*z0/za ! z0/l
11426 zol3=zolold+zol20 ! (z+z0)/l
11427 zolt=zolold*zt/za ! zt/l
11428 !print*,"z0/l=",zol20," (z+z0)/l=",zol3," zt/l=",zolt
11429 if (ri.lt.0) then
11430 !psit2=log((za+zt)/zt)-(psih_unstable(zol3)-psih_unstable(zol20))
11431 !psit2=log((za+z0)/zt)-(psih_unstable(zol3)-psih_unstable(zol20))
11432 psit2=max(logzt-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0)
11433 psix2=max(logz0-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)), 1.0)
11434 else
11435 !psit2=log((za+zt)/zt)-(psih_stable(zol3)-psih_stable(zol20))
11436 !psit2=log((za+z0)/zt)-(psih_stable(zol3)-psih_stable(zol20))
11437 psit2=max(logzt-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0)
11438 psix2=max(logz0-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)), 1.0)
11439 endif
11440 !print*,"n=",n," psit2=",psit2," psix2=",psix2
11441 zolrib=ri*psix2**2/psit2
11442 zlhux(n)=zolrib
11443 n=n+1
11444 enddo
11445
11446 if (n==nmax .and. abs(zolold - zolrib) > 0.01 ) then
11447 !print*,"iter fail, n=",n," ri=",ri," z/l=",zolri
11448 !if convergence fails, use approximate values:
11449 zolrib_iteration = zolrib
11450 call li_etal_2010(zolrib_iteration, ri, za/z0, z0/zt)
11451 zolrib = zolrib_iteration
11452 zlhux(n)=zolrib
11453 !print*,"failed, n=",n," ri=",ri," z0=",z0
11454 !print*,"z/l=",zlhux(1:nmax)
11455 else
11456 !if(zolrib*ri .lt. 0.) then
11457 ! !print*,"end: wrong quadrants: z/l=",zolrib," ri=",ri
11458 ! !phys_temp = zolrib
11459 ! !call li_etal_2010(zolrib, ri, za/z0, z0/zt)
11460 ! !zolrib = phys_temp
11461 !endif
11462 !print*,"success,n=",n," ri=",ri," z0=",z0
11463 endif
11464
11465 return
11466 end function
11467!====================================================================
11468
11471 subroutine psi_init(psi_opt,errmsg,errflg)
11472
11473 integer :: n,psi_opt
11474 real (kind=kind_phys) :: zolf
11475 character(len=*), intent(out) :: errmsg
11476 integer, intent(out) :: errflg
11477
11478 if (psi_opt == 0) then
11479 do n=0,1000
11480 ! stable function tables
11481 zolf = float(n)*0.01
11482 psim_stab(n)=psim_stable_full(zolf)
11483 psih_stab(n)=psih_stable_full(zolf)
11484
11485 ! unstable function tables
11486 zolf = -float(n)*0.01
11487 psim_unstab(n)=psim_unstable_full(zolf)
11488 psih_unstab(n)=psih_unstable_full(zolf)
11489 enddo
11490 else
11491 do n=0,1000
11492 ! stable function tables
11493 zolf = float(n)*0.01
11494 psim_stab(n)=psim_stable_full_gfs(zolf)
11495 psih_stab(n)=psih_stable_full_gfs(zolf)
11496
11497 ! unstable function tables
11498 zolf = -float(n)*0.01
11499 psim_unstab(n)=psim_unstable_full_gfs(zolf)
11500 psih_unstab(n)=psih_unstable_full_gfs(zolf)
11501 enddo
11502 endif
11503
11504 !simple test to see if initialization worked:
11505 if (psim_stab(1) < 0. .and. psih_stab(1) < 0. .and. &
11506 psim_unstab(1) > 0. .and. psih_unstab(1) > 0.) then
11507 errmsg = 'in mynn sfc, psi tables have been initialized'
11508 errflg = 0
11509 else
11510 errmsg = 'error in mynn sfc: problem initializing psi tables'
11511 errflg = 1
11512 endif
11513
11514 end subroutine psi_init
11515! ==================================================================
11516! ... integrated similarity functions from mynn...
11517!
11519 real*8 function psim_stable_full(zolf)
11520 real (kind=kind_phys) :: zolf
11521
11522 !psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5))
11523 psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**0.4)
11524
11525 return
11526 end function
11527
11529 real*8 function psih_stable_full(zolf)
11530 real (kind=kind_phys) :: zolf
11531
11532 !psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1))
11533 psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**0.9090909090909090909)
11534
11535 return
11536 end function
11537
11539 real*8 function psim_unstable_full(zolf)
11540 real (kind=kind_phys) :: zolf,x,ym,psimc,psimk
11541
11542 x=(1.-16.*zolf)**.25
11543 !psimk=2*alog(0.5*(1+x))+alog(0.5*(1+x*x))-2.*atan(x)+2.*atan(1.)
11544 psimk=2.*log(0.5*(1+x))+log(0.5*(1+x*x))-2.*atan(x)+2.*atan1
11545
11546 ym=(1.-10.*zolf)**onethird
11547 !psimc=(3./2.)*log((ym**2.+ym+1.)/3.)-sqrt(3.)*atan((2.*ym+1)/sqrt(3.))+4.*atan(1.)/sqrt(3.)
11548 psimc=1.5*log((ym**2 + ym+1.)*onethird)-sqrt3*atan((2.*ym+1)/sqrt3)+4.*atan1/sqrt3
11549
11550 psim_unstable_full=(psimk+zolf**2*(psimc))/(1+zolf**2.)
11551
11552 return
11553 end function
11554
11556 real*8 function psih_unstable_full(zolf)
11557 real (kind=kind_phys) :: zolf,y,yh,psihc,psihk
11558
11559 y=(1.-16.*zolf)**.5
11560 !psihk=2.*log((1+y)/2.)
11561 psihk=2.*log((1+y)*0.5)
11562
11563 yh=(1.-34.*zolf)**onethird
11564 !psihc=(3./2.)*log((yh**2.+yh+1.)/3.)-sqrt(3.)*atan((2.*yh+1)/sqrt(3.))+4.*atan(1.)/sqrt(3.)
11565 psihc=1.5*log((yh**2.+yh+1.)*onethird)-sqrt3*atan((2.*yh+1)/sqrt3)+4.*atan1/sqrt3
11566
11567 psih_unstable_full=(psihk+zolf**2*(psihc))/(1+zolf**2)
11568
11569 return
11570 end function
11571
11572! ==================================================================
11573! ... integrated similarity functions from gfs...
11574!
11575 real*8 function psim_stable_full_gfs(zolf)
11576 real (kind=kind_phys) :: zolf
11577 real (kind=kind_phys), parameter :: alpha4 = 20.
11578 real (kind=kind_phys) :: aa
11579
11580 aa = sqrt(1. + alpha4 * zolf)
11581 psim_stable_full_gfs = -1.*aa + log(aa + 1.)
11582
11583 return
11584 end function
11585
11586 real*8 function psih_stable_full_gfs(zolf)
11587 real (kind=kind_phys) :: zolf
11588 real (kind=kind_phys), parameter :: alpha4 = 20.
11589 real (kind=kind_phys) :: bb
11590
11591 bb = sqrt(1. + alpha4 * zolf)
11592 psih_stable_full_gfs = -1.*bb + log(bb + 1.)
11593
11594 return
11595 end function
11596
11597 real*8 function psim_unstable_full_gfs(zolf)
11598 real (kind=kind_phys) :: zolf
11599 real (kind=kind_phys) :: hl1,tem1
11600 real (kind=kind_phys), parameter :: a0=-3.975, a1=12.32, &
11601 b1=-7.755, b2=6.041
11602
11603 if (zolf .ge. -0.5) then
11604 hl1 = zolf
11605 psim_unstable_full_gfs = (a0 + a1*hl1) * hl1 / (1.+ (b1+b2*hl1) *hl1)
11606 else
11607 hl1 = -zolf
11608 tem1 = 1.0 / sqrt(hl1)
11609 psim_unstable_full_gfs = log(hl1) + 2. * sqrt(tem1) - .8776
11610 end if
11611
11612 return
11613 end function
11614
11615 real*8 function psih_unstable_full_gfs(zolf)
11616 real (kind=kind_phys) :: zolf
11617 real (kind=kind_phys) :: hl1,tem1
11618 real (kind=kind_phys), parameter :: a0p=-7.941, a1p=24.75, &
11619 b1p=-8.705, b2p=7.899
11620
11621 if (zolf .ge. -0.5) then
11622 hl1 = zolf
11623 psih_unstable_full_gfs = (a0p + a1p*hl1) * hl1 / (1.+ (b1p+b2p*hl1)*hl1)
11624 else
11625 hl1 = -zolf
11626 tem1 = 1.0 / sqrt(hl1)
11627 psih_unstable_full_gfs = log(hl1) + .5 * tem1 + 1.386
11628 end if
11629
11630 return
11631 end function
11632
11633!=================================================================
11634! look-up table functions - or, if beyond -10 < z/l < 10, recalculate
11635!=================================================================
11636 real*8 function psim_stable(zolf,psi_opt)
11637 integer :: nzol,psi_opt
11638 real (kind=kind_phys) :: rzol,zolf
11639
11640 nzol = int(zolf*100.)
11641 rzol = zolf*100. - nzol
11642 if(nzol+1 .lt. 1000)then
11643 psim_stable = psim_stab(nzol) + rzol*(psim_stab(nzol+1)-psim_stab(nzol))
11644 else
11645 if (psi_opt == 0) then
11646 psim_stable = psim_stable_full(zolf)
11647 else
11648 psim_stable = psim_stable_full_gfs(zolf)
11649 endif
11650 endif
11651
11652 return
11653 end function
11654
11655 real*8 function psih_stable(zolf,psi_opt)
11656 integer :: nzol,psi_opt
11657 real (kind=kind_phys) :: rzol,zolf
11658
11659 nzol = int(zolf*100.)
11660 rzol = zolf*100. - nzol
11661 if(nzol+1 .lt. 1000)then
11662 psih_stable = psih_stab(nzol) + rzol*(psih_stab(nzol+1)-psih_stab(nzol))
11663 else
11664 if (psi_opt == 0) then
11665 psih_stable = psih_stable_full(zolf)
11666 else
11667 psih_stable = psih_stable_full_gfs(zolf)
11668 endif
11669 endif
11670
11671 return
11672 end function
11673
11674 real*8 function psim_unstable(zolf,psi_opt)
11675 integer :: nzol,psi_opt
11676 real (kind=kind_phys) :: rzol,zolf
11677
11678 nzol = int(-zolf*100.)
11679 rzol = -zolf*100. - nzol
11680 if(nzol+1 .lt. 1000)then
11681 psim_unstable = psim_unstab(nzol) + rzol*(psim_unstab(nzol+1)-psim_unstab(nzol))
11682 else
11683 if (psi_opt == 0) then
11684 psim_unstable = psim_unstable_full(zolf)
11685 else
11686 psim_unstable = psim_unstable_full_gfs(zolf)
11687 endif
11688 endif
11689
11690 return
11691 end function
11692
11693 real*8 function psih_unstable(zolf,psi_opt)
11694 integer :: nzol,psi_opt
11695 real (kind=kind_phys) :: rzol,zolf
11696
11697 nzol = int(-zolf*100.)
11698 rzol = -zolf*100. - nzol
11699 if(nzol+1 .lt. 1000)then
11700 psih_unstable = psih_unstab(nzol) + rzol*(psih_unstab(nzol+1)-psih_unstab(nzol))
11701 else
11702 if (psi_opt == 0) then
11703 psih_unstable = psih_unstable_full(zolf)
11704 else
11705 psih_unstable = psih_unstable_full_gfs(zolf)
11706 endif
11707 endif
11708
11709 return
11710 end function
11711!========================================================================
11712end module module_sf_noahmplsm
11713
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
noahmp_parameters
Definition module_sf_noahmplsm.F90:206