86 USE parkind1, ONLY: jpim, jprb
87 USE radsurf_interface, ONLY: radsurf
88 USE radsurf_config, ONLY: config_type
89
90 USE radsurf_canopy_properties, ONLY: canopy_properties_type
91 USE radsurf_sw_spectral_properties, ONLY: sw_spectral_properties_type
92 USE radsurf_lw_spectral_properties, ONLY: lw_spectral_properties_type
93 USE radsurf_boundary_conds_out, ONLY: boundary_conds_out_type
94 USE radsurf_canopy_flux, ONLY: canopy_flux_type
95 USE radsurf_simple_spectrum, ONLY: calc_simple_spectrum_lw
96
98
99 IMPLICIT NONE
100
101
102
103
104 REAL(KIND(1D0)), INTENT(IN) :: zenith_deg
105 INTEGER, INTENT(IN) :: DiagQN
106 INTEGER, INTENT(IN) :: nlayer
107
108
109 REAL(KIND(1D0)), DIMENSION(nlayer), INTENT(IN) :: tsfc_roof, tsfc_wall
110 REAL(KIND(1D0)), INTENT(IN) :: Tair_C
111
112 REAL(KIND(1D0)), INTENT(IN) :: kdown
113 REAL(KIND(1D0)), INTENT(IN) :: ldown
114 REAL(KIND(1D0)), DIMENSION(NSURF), INTENT(IN) :: tsfc_surf
115
116 REAL(KIND(1D0)), DIMENSION(NSURF), INTENT(IN) :: sfr_surf, alb_surf
117 REAL(KIND(1D0)), DIMENSION(NVegSurf), INTENT(IN) :: LAI_id
118
119
120 INTEGER, INTENT(IN) :: n_vegetation_region_urban, &
122 REAL(KIND(1D0)), INTENT(IN) :: sw_dn_direct_frac, air_ext_sw, air_ssa_sw
123
126
127
128 INTEGER(kind=jpim), ALLOCATABLE :: i_representation(:)
129 INTEGER(kind=jpim), ALLOCATABLE :: nlay(:)
130 INTEGER :: istartcol, iendcol
131 INTEGER :: jrepeat, ilay, jlay, jcol
132
133
134
135
136
137 REAL(KIND(1D0)), INTENT(OUT) :: qn, kup, lup
138 REAL(KIND(1D0)), DIMENSION(nlayer), INTENT(OUT) :: qn_roof
139 REAL(KIND(1D0)), DIMENSION(nlayer), INTENT(OUT) :: qn_wall
140 REAL(KIND(1D0)), DIMENSION(nsurf), INTENT(OUT) :: qn_surf
141 REAL(KIND(1D0)) :: sw_net_grnd
142 REAL(KIND(1D0)) :: lw_net_grnd
143 REAL(KIND(1D0)) :: sw_dn_grnd
144 REAL(KIND(1D0)) :: lw_dn_grnd
145 REAL(KIND(1D0)) :: lw_up_grnd
146 REAL(KIND(1D0)), DIMENSION(NSURF - 1) :: qn_grnd_ind
147 REAL(KIND(1D0)), DIMENSION(NSURF - 1) :: alb_grnd_ind
148 REAL(KIND(1D0)), DIMENSION(NSURF - 1) :: emis_grnd_ind
149 REAL(KIND(1D0)), DIMENSION(NSURF - 1) :: sfr_grnd_ind
150 REAL(KIND(1D0)), DIMENSION(nsurf - 1) :: sw_net_grnd_ind
151 REAL(KIND(1D0)), DIMENSION(nsurf - 1) :: lw_net_grnd_ind
152 REAL(KIND(1D0)), DIMENSION(NSURF - 1) :: tsfc_grnd_ind_K
153
154
155 REAL(KIND(1D0)) :: alb_spc, emis_spc, lw_emission_spc, lw_up_spc, sw_up_spc
156 REAL(KIND(1D0)) :: top_net_lw_spc
157 REAL(KIND(1D0)) :: grnd_net_lw_spc
158 REAL(KIND(1D0)) :: top_dn_lw_spc
159 REAL(KIND(1D0)) :: top_dn_dir_sw_spc
160 REAL(KIND(1D0)) :: top_net_sw_spc
161 REAL(KIND(1D0)) :: grnd_dn_dir_sw_spc
162 REAL(KIND(1D0)) :: grnd_net_sw_spc
163 REAL(KIND(1D0)) :: grnd_vertical_diff
164 REAL(KIND(1D0)), DIMENSION(15) :: clear_air_abs_lw_spc
165 REAL(KIND(1D0)), DIMENSION(15) :: clear_air_abs_sw_spc
166 REAL(KIND(1D0)), DIMENSION(15) :: roof_in_sw_spc
167 REAL(KIND(1D0)), DIMENSION(15) :: roof_in_lw_spc
168 REAL(KIND(1D0)), DIMENSION(15) :: roof_net_sw_spc
169 REAL(KIND(1D0)), DIMENSION(15) :: roof_net_lw_spc
170 REAL(KIND(1D0)), DIMENSION(15) :: wall_in_sw_spc
171 REAL(KIND(1D0)), DIMENSION(15) :: wall_in_lw_spc
172 REAL(KIND(1D0)), DIMENSION(15) :: wall_net_sw_spc
173 REAL(KIND(1D0)), DIMENSION(15) :: wall_net_lw_spc
174 REAL(KIND(1D0)), DIMENSION(15) :: sfr_roof_spc
175 REAL(KIND(1D0)), DIMENSION(15) :: sfr_wall_spc
176
177
178 REAL(KIND(1D0)), DIMENSION(ncolumnsDataOutSPARTACUS - 5), INTENT(OUT)
179
180
181 TYPE(config_type) :: config
182 TYPE(canopy_properties_type) :: canopy_props
183 TYPE(sw_spectral_properties_type) :: sw_spectral_props
184 TYPE(lw_spectral_properties_type) :: lw_spectral_props
185 TYPE(boundary_conds_out_type) :: bc_out
186 TYPE(canopy_flux_type) :: sw_norm_dir
187 TYPE(canopy_flux_type) :: sw_norm_diff
188 TYPE(canopy_flux_type) :: lw_internal
189 TYPE(canopy_flux_type) :: lw_norm
190 TYPE(canopy_flux_type) :: lw_flux
191 TYPE(canopy_flux_type) :: sw_flux
192
193
194 REAL(KIND(1D0)), ALLOCATABLE :: top_flux_dn_sw(:, :)
195 REAL(KIND(1D0)), ALLOCATABLE :: top_flux_dn_direct_sw(:, :)
196 REAL(KIND(1D0)), ALLOCATABLE :: top_flux_dn_lw(:, :)
197
198
199 REAL(KIND(1D0)), DIMENSION(nlayer) :: tsfc_roof_K, tsfc_wall_K
200 REAL(KIND(1D0)), DIMENSION(nsurf) :: tsfc_surf_K
201 REAL(KIND(1D0)) :: tair_K
202
203 REAL(KIND(1D0)) :: top_flux_dn_diffuse_sw
204
205 REAL(KIND(1D0)) :: alb_no_tree_bldg, emis_no_tree_bldg
206
207
208
209 REAL(KIND(1D0)), ALLOCATABLE :: LAI_av(:)
210
211 REAL(KIND(1D0)), ALLOCATABLE :: LAI_av_z(:)
212 REAL(KIND(1D0)), ALLOCATABLE :: veg_ext(:)
213
214 REAL(KIND(1D0)), ALLOCATABLE :: veg_depth(:)
215
216 LOGICAL, INTENT(IN) :: use_sw_direct_albedo
217
218 REAL(KIND(1D0)), DIMENSION(nlayer + 1), INTENT(IN) :: height
219 REAL(KIND(1D0)), DIMENSION(nlayer), INTENT(IN) :: building_frac
220 REAL(KIND(1D0)), DIMENSION(nlayer), INTENT(IN) :: veg_frac
221 REAL(KIND(1D0)), DIMENSION(nlayer), INTENT(IN) :: sfr_roof
222 REAL(KIND(1D0)), DIMENSION(nlayer), INTENT(IN) :: sfr_wall
223 REAL(KIND(1D0)), DIMENSION(nlayer), INTENT(IN) :: building_scale
224 REAL(KIND(1D0)), DIMENSION(nlayer), INTENT(IN) :: veg_scale
225 REAL(KIND(1D0)), DIMENSION(nlayer), INTENT(IN) :: alb_roof
226 REAL(KIND(1D0)), DIMENSION(nlayer), INTENT(IN) :: emis_roof
227 REAL(KIND(1D0)), DIMENSION(nlayer), INTENT(IN) :: alb_wall
228 REAL(KIND(1D0)), DIMENSION(nlayer), INTENT(IN) :: emis_wall
229 REAL(KIND(1D0)), DIMENSION(nspec, nlayer), INTENT(IN) :: roof_albedo_dir_mult_fact
230 REAL(KIND(1D0)), DIMENSION(nspec, nlayer), INTENT(IN) :: wall_specular_frac
231
232
233 REAL(KIND(1D0)), DIMENSION(nspec, nlayer) :: roof_albedo
234 REAL(KIND(1D0)), DIMENSION(nspec, nlayer) :: wall_albedo
235 REAL(KIND(1D0)), DIMENSION(nspec, nlayer) :: roof_emissivity
236 REAL(KIND(1D0)), DIMENSION(nspec, nlayer) :: wall_emissivity
237 REAL(KIND(1D0)), DIMENSION(nlayer) :: veg_fsd, veg_contact_fraction
238
239
240
241 IF (diagqn == 1) print *, 'in SPARTACUS, starting ...'
242
244
245 sfr_roof_spc = -999.
247 sfr_wall_spc = -999.
249
250 ALLOCATE (nlay(
ncol))
251
254
255
256
259
260
265
266
267
268
269 IF (diagqn == 1) print *, 'in SPARTACUS, setting up model ...'
270
271 config%do_sw = .true.
272 config%do_lw = .true.
274 ALLOCATE (i_representation(
ncol))
276 config%do_vegetation = .true.
277 i_representation = [3]
278 config%do_urban = .true.
280 config%do_vegetation = .false.
281 i_representation = [2]
282 config%do_urban = .true.
284 config%do_vegetation = .true.
285 i_representation = [1]
286 config%do_urban = .false.
287 ELSE
288 config%do_vegetation = .false.
289 i_representation = [0]
290 config%do_urban = .false.
291 END IF
292 config%iverbose = 3
301 CALL config%consolidate()
302
303
304
305
306 CALL canopy_props%DEALLOCATE()
307 CALL canopy_props%ALLOCATE(config,
ncol,
nlayer, i_representation)
308
309
310 canopy_props%cos_sza = cos(zenith_deg*3.1415927/180)
311 canopy_props%nlay = nlay
312 canopy_props%ncol =
ncol
313 canopy_props%ntotlay =
nlayer
314
315 IF (diagqn == 1) print *, 'in SPARTACUS, calculating dz array ...'
316
317 ilay = 1
319 canopy_props%dz(ilay:ilay + canopy_props%nlay(jcol) - 1) &
320 & =
height(ilay + 1:ilay + canopy_props%nlay(jcol)) &
321 & -
height(ilay:ilay + canopy_props%nlay(jcol) - 1)
322 canopy_props%istartlay(jcol) = ilay
323 ilay = ilay + canopy_props%nlay(jcol)
324 END DO
325
326 ALLOCATE (lai_av(
ncol))
327 ALLOCATE (veg_depth(
ncol))
328 ALLOCATE (lai_av_z(
nlayer))
329
331
332 lai_av(jcol) = &
335 END DO
336
337
338
339
340
341
343 ilay = canopy_props%istartlay(jcol)
344 veg_depth(jcol) = 0.
345 DO jlay = 0, nlay(jcol) - 1
346 IF (
veg_frac(ilay + jlay) > 0.)
THEN
347 veg_depth(jcol) = veg_depth(jcol) + canopy_props%dz(ilay
348 END IF
349 END DO
350 END DO
351
353 ilay = canopy_props%istartlay(jcol)
354
355
356 DO jlay = 0, nlay(jcol) - 1
357
358
359
360
361 IF (
veg_frac(ilay + jlay) > 0.)
THEN
362 lai_av_z(ilay + jlay) = lai_av(jcol)*canopy_props%dz(ilay
363 veg_ext(ilay + jlay) = lai_av_z(ilay + jlay)/(2*canopy_props%dz
364 END IF
365 END DO
366 END DO
367
368
372 tair_k = tair_c + 273.15
373
374
375 canopy_props%ground_temperature = (dot_product(tsfc_surf_k,
sfr_surf
377
378 canopy_props%roof_temperature = tsfc_roof_k
379 canopy_props%wall_temperature = tsfc_wall_k
380 canopy_props%clear_air_temperature = tair_k
382 canopy_props%veg_temperature = dot_product(tsfc_surf_k(
conifsurf
383 canopy_props%veg_air_temperature = tair_k
384 END IF
385
386
387 canopy_props%i_representation = i_representation
391 canopy_props%veg_fraction =
veg_frac(:)
393 canopy_props%veg_ext =
veg_ext(:)
394 canopy_props%veg_fsd =
veg_fsd(:)
396 END IF
397
398
399 IF (diagqn == 1) print *, 'in SPARTACUS, setting canopy top forcing ...'
401 ALLOCATE (top_flux_dn_direct_sw(
nspec,
ncol))
403 top_flux_dn_sw = kdown
405 top_flux_dn_diffuse_sw = top_flux_dn_sw(
nspec,
ncol) - top_flux_dn_direct_sw
406 top_flux_dn_lw = ldown
407
408
409
410 CALL sw_spectral_props%DEALLOCATE()
411 CALL sw_spectral_props%ALLOCATE(config,
ncol,
nlayer,
nspec, canopy_props%i_representation
412
413
421 END IF
422 sw_spectral_props%ground_albedo = alb_no_tree_bldg
423 sw_spectral_props%roof_albedo = roof_albedo(
nspec,
ncol)
424 sw_spectral_props%wall_albedo = wall_albedo(
nspec,
ncol)
426 IF (config%use_sw_direct_albedo) THEN
429 END IF
430
431
432
433 CALL lw_spectral_props%DEALLOCATE()
434 CALL lw_spectral_props%ALLOCATE(config,
nspec,
ncol,
nlayer, canopy_props%i_representation
435
443 END IF
444 lw_spectral_props%ground_emissivity = emis_no_tree_bldg
445 lw_spectral_props%roof_emissivity = roof_emissivity(
nspec,
ncol)
446 lw_spectral_props%wall_emissivity = wall_emissivity(
nspec,
ncol)
447
448
449
450
451
452
453
454
455 IF (config%do_sw) THEN
456 CALL sw_norm_dir%ALLOCATE(config,
ncol,
nlayer, config%nsw, use_direct
457 CALL sw_norm_diff%ALLOCATE(config,
ncol,
nlayer, config%nsw, use_direct
458
459 CALL sw_norm_dir%zero_all()
460 CALL sw_norm_diff%zero_all()
461
462 CALL sw_flux%ALLOCATE(config,
ncol,
nlayer, config%nsw, use_direct
463 END IF
464
465
466
467 IF (config%do_lw) THEN
468 CALL lw_internal%ALLOCATE(config,
ncol,
nlayer, config%nlw, use_direct
469 CALL lw_norm%ALLOCATE(config,
ncol,
nlayer, config%nlw, use_direct
470
471 CALL lw_internal%zero_all()
472 CALL lw_norm%zero_all()
473
474 CALL lw_flux%ALLOCATE(config,
ncol,
nlayer, config%nlw, use_direct
475 END IF
476
477
478
479 CALL bc_out%ALLOCATE(
ncol, config%nsw, config%nlw)
480
481
482
483 CALL lw_spectral_props%calc_monochromatic_emission(canopy_props)
484
485
486
487 istartcol = 1
488 iendcol = 1
489
490 DO jrepeat = 1, 3
491 IF (config%do_lw) THEN
492
493 CALL calc_simple_spectrum_lw(config, canopy_props, lw_spectral_props
494 & istartcol, iendcol)
495 END IF
496
497 CALL radsurf(config, canopy_props, &
498 & sw_spectral_props, lw_spectral_props, &
499 & bc_out, &
500 & istartcol, iendcol, &
501 & sw_norm_dir, sw_norm_diff, &
502 & lw_internal, lw_norm)
503 IF (config%do_sw) THEN
504
505 CALL sw_norm_dir%SCALE(canopy_props%nlay, &
506 & top_flux_dn_direct_sw)
507 CALL sw_norm_diff%SCALE(canopy_props%nlay, &
508 & top_flux_dn_sw - top_flux_dn_direct_sw)
509 CALL sw_flux%SUM(sw_norm_dir, sw_norm_diff)
510 END IF
511 IF (config%do_lw) THEN
512 CALL lw_norm%SCALE(canopy_props%nlay, top_flux_dn_lw)
513 CALL lw_flux%SUM(lw_internal, lw_norm)
514 END IF
515 END DO
516
517
518 IF (top_flux_dn_diffuse_sw + top_flux_dn_direct_sw(
nspec,
ncol) >
THEN
519 alb_spc = ((top_flux_dn_diffuse_sw + 10.**(-10))*(bc_out%sw_albedo
520 + (top_flux_dn_direct_sw(
nspec,
ncol) + 10.**(-10))*
521 /(top_flux_dn_diffuse_sw + top_flux_dn_direct_sw(
nspec
522 IF (alb_spc < 0.0) alb_spc = 0
523 ELSE
524 alb_spc = 0.0
525 END IF
526
527
528
529
530 emis_spc = bc_out%lw_emissivity(
nspec,
ncol)
531
532 lw_emission_spc = bc_out%lw_emission(
nspec,
ncol)
533
534 lw_up_spc = lw_emission_spc + (1 - emis_spc)*ldown
535
536 sw_up_spc = 0.0
537 sw_up_spc = kdown*alb_spc
538
540
541
542 clear_air_abs_lw_spc = -999
544 wall_net_lw_spc = -999
546 wall_in_lw_spc = -999
548
549 roof_net_lw_spc = -999
551
552 roof_in_lw_spc = -999
554 top_net_lw_spc = lw_flux%top_net(
nspec,
ncol)
555 grnd_net_lw_spc = lw_flux%ground_net(
nspec,
ncol)
556 top_dn_lw_spc = lw_flux%top_dn(
nspec,
ncol)
557
558
559 clear_air_abs_sw_spc = -999
561 wall_net_sw_spc = -999
563 wall_in_sw_spc = -999
565
566 roof_net_sw_spc = -999
568
569
570 roof_in_sw_spc = -999
572
573
574
575 top_dn_dir_sw_spc = sw_flux%top_dn_dir(
nspec,
ncol)
576 top_net_sw_spc = sw_flux%top_net(
nspec,
ncol)
577 grnd_dn_dir_sw_spc = sw_flux%ground_dn_dir(
nspec,
ncol)
578 grnd_net_sw_spc = sw_flux%ground_net(
nspec,
ncol)
579 grnd_vertical_diff = sw_flux%ground_vertical_diff(
nspec,
ncol)
580
581
582
583 lup = lw_up_spc
584
585 kup = sw_up_spc
586
587
588 qn = max(qn_spc, -600d0)
589
590
591
592
593
594 qn_roof = roof_net_lw_spc(:
nlayer) + roof_net_sw_spc(:
nlayer)
595 qn_wall = wall_net_lw_spc(:
nlayer) + wall_net_sw_spc(:
nlayer)
596
597
598
599
601
603
604
605
606
611
612
613
616
617
618 sw_dn_grnd = sw_net_grnd/dot_product(alb_grnd_ind, sfr_grnd_ind)/sum
620
621
622 lw_up_grnd = sbconst*dot_product(emis_grnd_ind*tsfc_grnd_ind_k**4,
623
624
625 lw_dn_grnd = lw_up_grnd + lw_net_grnd
626 lw_net_grnd_ind = lw_dn_grnd - sbconst*emis_grnd_ind*tsfc_grnd_ind_k
627
628
629 qn_grnd_ind = lw_net_grnd_ind + sw_net_grnd_ind
630
631
633
634
635
636 qn_surf(
bldgsurf) = (qn_spc - dot_product(qn_grnd_ind, sfr_grnd_ind
637
639 [alb_spc, emis_spc, &
640 top_dn_dir_sw_spc, &
641 sw_up_spc, &
642 top_dn_lw_spc, &
643 lw_up_spc, &
644 qn_spc, &
645 top_net_sw_spc, &
646 top_net_lw_spc, &
647 lw_emission_spc, &
648 grnd_dn_dir_sw_spc, &
649 grnd_vertical_diff, &
650 grnd_net_sw_spc, &
651 grnd_net_lw_spc, &
652 roof_in_sw_spc, &
653 roof_net_sw_spc, &
654 wall_in_sw_spc, &
655 wall_net_sw_spc, &
656 clear_air_abs_sw_spc, &
657 roof_in_lw_spc, &
658 roof_net_lw_spc, &
659 wall_in_lw_spc, &
660 wall_net_lw_spc, &
661 sfr_roof_spc, &
662 sfr_wall_spc, &
663 clear_air_abs_lw_spc &
664 ]
665
666
667
668 CALL canopy_props%DEALLOCATE()
669 CALL sw_spectral_props%DEALLOCATE()
670 CALL lw_spectral_props%DEALLOCATE()
671 CALL bc_out%DEALLOCATE()
672 CALL sw_norm_dir%DEALLOCATE()
673 CALL sw_norm_diff%DEALLOCATE()
674 CALL lw_internal%DEALLOCATE()
675 CALL lw_norm%DEALLOCATE()
676 CALL sw_flux%DEALLOCATE()
677 CALL lw_flux%DEALLOCATE()
678
679
680 DEALLOCATE (top_flux_dn_sw)
681 DEALLOCATE (top_flux_dn_direct_sw)
682 DEALLOCATE (top_flux_dn_lw)
683
684
685
686
687 DEALLOCATE (veg_depth)
689 DEALLOCATE (lai_av)
690 DEALLOCATE (lai_av_z)
691
692
693
694
695
696
697
698
699
integer n_stream_sw_urban
integer, parameter bldgsurf
integer, parameter conifsurf
real(kind(1d0)) ground_albedo_dir_mult_fact
real(kind(1d0)), dimension(:), allocatable tsfc_roof
real(kind(1d0)), dimension(:), allocatable alb_roof
integer n_vegetation_region_urban
real(kind(1d0)), dimension(nvegsurf) lai_id
real(kind(1d0)) veg_ssa_lw
real(kind(1d0)) air_ext_sw
real(kind(1d0)), dimension(nsurf) sfr_surf
real(kind(1d0)), dimension(:), allocatable sfr_roof
real(kind(1d0)), dimension(:), allocatable veg_ext
real(kind(1d0)), dimension(:), allocatable building_scale
real(kind(1d0)), dimension(:), allocatable veg_contact_fraction
real(kind(1d0)) air_ssa_sw
logical use_sw_direct_albedo
real(kind(1d0)), dimension(:), allocatable height
real(kind(1d0)) veg_ssa_sw
real(kind(1d0)) air_ssa_lw
real(kind(1d0)), dimension(:), allocatable emis_roof
real(kind(1d0)), dimension(:), allocatable tsfc_surf
integer, parameter ncolumnsdataoutspartacus
real(kind(1d0)), dimension(:), allocatable veg_frac
integer n_stream_lw_urban
real(kind(1d0)), dimension(ncolumnsdataoutspartacus) dataoutlinespartacus
real(kind(1d0)), dimension(:, :), allocatable roof_albedo_dir_mult_fact
integer, parameter watersurf
integer, parameter grasssurf
real(kind(1d0)), dimension(:), allocatable alb_wall
real(kind(1d0)), dimension(:, :), allocatable wall_specular_frac
real(kind(1d0)) veg_fsd_const
integer, parameter bsoilsurf
real(kind(1d0)), dimension(:), allocatable emis_wall
integer, parameter pavsurf
real(kind(1d0)), dimension(:), allocatable building_frac
real(kind(1d0)) air_ext_lw
real(kind(1d0)), dimension(:), allocatable sfr_wall
real(kind(1d0)), dimension(:), allocatable veg_scale
real(kind(1d0)) sw_dn_direct_frac
integer, parameter decidsurf
real(kind(1d0)), dimension(:), allocatable veg_fsd
real(kind(1d0)), dimension(:), allocatable tsfc_wall
real(kind(1d0)) veg_contact_fraction_const