SURFEX v8.1
General documentation of Surfex
mode_av_pgd.F90
Go to the documentation of this file.
1 !SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
2 !SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
3 !SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
4 !SFX_LIC for details. version 1.
5 MODULE mode_av_pgd
6 !
7 USE modd_surf_par, ONLY : nundef
8 !
9 USE yomhook ,ONLY : lhook, dr_hook
10 USE parkind1 ,ONLY : jprb
11 !
12 IMPLICIT NONE
13 !
14 CONTAINS
15 !
16 SUBROUTINE date2doy(TPDATA, OCOVER, KDOY)
17 USE modd_type_date_surf
18 USE modd_data_cover_par, ONLY : nvegtype
19 !
20 type(date_time), DIMENSION(:,:), INTENT(IN) :: tpdata
21 LOGICAL, DIMENSION(:), INTENT(IN) :: OCOVER
22 INTEGER, DIMENSION(:,:), INTENT(OUT) :: KDOY
23 INTEGER, DIMENSION(SIZE(OCOVER),NVEGTYPE) :: IMONTH, IDAY
24 INTEGER, PARAMETER, DIMENSION(12) :: TAB=(/1,32,60,91,121,152,182,213,244,274,305,335/)
25 INTEGER :: JCOV, JJ, JVEG
26 REAL(KIND=JPRB) :: ZHOOK_HANDLE
27 
28 IF (lhook) CALL dr_hook('MODE_AV_PGD:DATE2DOY',0,zhook_handle)
29 !
30 imonth(:,:) = tpdata(:,:)%TDATE%MONTH
31 iday(:,:) = tpdata(:,:)%TDATE%DAY
32 !
33 kdoy(:,:) = nundef
34 !
35 jcov = 0
36 DO jj = 1, SIZE(ocover)
37  IF (.NOT.ocover(jj)) cycle
38  jcov = jcov + 1
39  DO jveg = 1, nvegtype
40  IF (imonth(jj,jveg)/=nundef .AND. iday(jj,jveg) /= nundef) THEN
41  kdoy(jcov,jveg) = tab(imonth(jj,jveg)) + iday(jj,jveg) - 1
42  ENDIF
43  END DO
44 END DO
45 IF (lhook) CALL dr_hook('MODE_AV_PGD:DATE2DOY',1,zhook_handle)
46 
47 END SUBROUTINE date2doy
48 !
49 SUBROUTINE doy2date(KDOY,KMONTH,KDAY)
50 !
51 INTEGER, INTENT(IN) :: KDOY
52 INTEGER, INTENT(OUT) :: KMONTH, KDAY
53 REAL :: ZWORK(12)
54 INTEGER, PARAMETER, DIMENSION(12) :: ZTAB=(/31.,59.,90.,120.,151.,181.,212.,243.,273.,304.,334.,365./)
55 INTEGER :: J
56 REAL(KIND=JPRB) :: ZHOOK_HANDLE
57 
58 IF (lhook) CALL dr_hook('MODE_AV_PGD:DOY2DATE',0,zhook_handle)
59 !
60 kmonth = nundef
61 kday = nundef
62 !
63 zwork(1) = REAL(KDOY) / ZTAB(1)
64 IF ( int(zwork(1))==0 .AND. zwork(1)/=0.) THEN
65  kmonth = 1
66  kday = kdoy
67 ENDIF
68 !
69 DO j = 2, 12
70  zwork(j) = REAL(KDOY) / ZTAB(j)
71  IF ( int(zwork(j))==0 .AND. int(zwork(j-1))==1 ) THEN
72  kmonth = j
73  kday = kdoy - int(ztab(j-1))
74  ENDIF
75 END DO
76 IF (lhook) CALL dr_hook('MODE_AV_PGD:DOY2DATE',1,zhook_handle)
77 
78 END SUBROUTINE doy2date
79 !
80 SUBROUTINE get_weight(DTCO,KCOVER,KMASK,HSFTYPE,PWEIGHT)
81 !
82 USE modd_data_cover_n, ONLY : data_cover_t
83 !
84 USE modd_data_cover, ONLY : xdata_bld_height
85 USE modd_data_cover_par, ONLY : nvt_tebd, nvt_bone, nvt_trbe, nvt_trbd, &
86  nvt_tebe, nvt_tene, nvt_bobd, nvt_bond, nvt_shrb
87 !
88 USE modi_abor1_sfx
89 !
90 IMPLICIT NONE
91 !
92 TYPE(data_cover_t), INTENT(INOUT) :: DTCO
93 INTEGER, INTENT(IN) :: KCOVER
94 INTEGER, DIMENSION(:), INTENT(IN) :: KMASK
95  CHARACTER(LEN=3), INTENT(IN) :: HSFTYPE
96 REAL, DIMENSION(:), INTENT(OUT) :: PWEIGHT
97 !
98 INTEGER :: JCOV,JJ
99 REAL(KIND=JPRB) :: ZHOOK_HANDLE
100 !
101 IF (lhook) CALL dr_hook('MODE_AV_PGD:GET_WEIGHT',0,zhook_handle)
102 !
103 DO jcov=1,kcover
104  !
105  jj = kmask(jcov)
106  !
107  !-------------------------------------------------------------------------------
108  !
109  !* 2. Selection of the weighting function
110  ! -----------------------------------
111  !
112  SELECT CASE (hsftype)
113  CASE('ALL')
114  pweight(jcov)=1.
115 
116  CASE('NAT')
117  pweight(jcov)=dtco%XDATA_NATURE(jj)
118 
119  CASE('GRD')
120  pweight(jcov)=dtco%XDATA_TOWN (jj) * dtco%XDATA_GARDEN(jj)
121 
122  CASE('TWN')
123  pweight(jcov)=dtco%XDATA_TOWN (jj)
124 
125  CASE('WAT')
126  pweight(jcov)=dtco%XDATA_WATER (jj)
127 
128  CASE('SEA')
129  pweight(jcov)=dtco%XDATA_SEA (jj)
130 
131  CASE('BLD')
132  pweight(jcov)=dtco%XDATA_TOWN (jj) * dtco%XDATA_BLD(jj)
133 
134  CASE('BLV') !* building Volume
135  pweight(jcov)=dtco%XDATA_TOWN (jj) * dtco%XDATA_BLD(jj) &
136  * xdata_bld_height(jj)
137 
138  CASE('STR')
139  pweight(jcov)=dtco%XDATA_TOWN (jj) * ( 1. - dtco%XDATA_BLD(jj) )
140 
141  CASE('TRE')
142  pweight(jcov)=dtco%XDATA_NATURE(jj) * ( dtco%XDATA_VEGTYPE(jj,nvt_tebd) &
143  + dtco%XDATA_VEGTYPE(jj,nvt_trbe) &
144  + dtco%XDATA_VEGTYPE(jj,nvt_trbd) &
145  + dtco%XDATA_VEGTYPE(jj,nvt_tebe) &
146  + dtco%XDATA_VEGTYPE(jj,nvt_tene) &
147  + dtco%XDATA_VEGTYPE(jj,nvt_bobd) &
148  + dtco%XDATA_VEGTYPE(jj,nvt_bond) &
149  + dtco%XDATA_VEGTYPE(jj,nvt_shrb) &
150  + dtco%XDATA_VEGTYPE(jj,nvt_bone) )
151 
152  CASE('GRT')
153  pweight(jcov)=dtco%XDATA_TOWN(jj) * dtco%XDATA_GARDEN(jj) &
154  * ( dtco%XDATA_VEGTYPE(jj,nvt_tebd) &
155  + dtco%XDATA_VEGTYPE(jj,nvt_trbe) &
156  + dtco%XDATA_VEGTYPE(jj,nvt_trbd) &
157  + dtco%XDATA_VEGTYPE(jj,nvt_tebe) &
158  + dtco%XDATA_VEGTYPE(jj,nvt_tene) &
159  + dtco%XDATA_VEGTYPE(jj,nvt_bobd) &
160  + dtco%XDATA_VEGTYPE(jj,nvt_bond) &
161  + dtco%XDATA_VEGTYPE(jj,nvt_shrb) &
162  + dtco%XDATA_VEGTYPE(jj,nvt_bone) )
163 
164  CASE DEFAULT
165  CALL abor1_sfx('AV_1PGD_1D: WEIGHTING FUNCTION NOT ALLOWED '//hsftype)
166  END SELECT
167 !
168 ENDDO
169 !
170 IF (lhook) CALL dr_hook('MODE_AV_PGD:GET_WEIGHT',1,zhook_handle)
171 !
172 END SUBROUTINE get_weight
173 !
174 SUBROUTINE get_weight_patch(DTCO,KCOVER,KMASK,KDECADE,HSFTYPE,PWEIGHT)
175 !
176 USE modd_data_cover_n, ONLY : data_cover_t
177 !
178 USE modd_data_cover, ONLY : xdata_veg, xdata_lai
179 USE modd_data_cover_par, ONLY : nvt_tebd, nvt_bone, nvt_trbe, nvt_trbd, &
180  nvt_tebe, nvt_tene, nvt_bobd, nvt_bond, nvt_shrb, &
181  nvegtype
182 !
183 USE yomhook ,ONLY : lhook, dr_hook
184 USE parkind1 ,ONLY : jprb
185 !
186 USE modi_abor1_sfx
187 !
188 IMPLICIT NONE
189 !
190 TYPE(data_cover_t), INTENT(INOUT) :: DTCO
191 INTEGER, INTENT(IN) :: KCOVER
192 INTEGER, DIMENSION(:), INTENT(IN) :: KMASK
193 INTEGER, INTEnt(IN) :: KDECADE
194  CHARACTER(LEN=3), INTENT(IN) :: HSFTYPE
195 REAL, DIMENSION(:,:), INTENT(OUT) :: PWEIGHT
196 !
197 INTEGER :: JCOV,JJ, JVEG
198 REAL(KIND=JPRB) :: ZHOOK_HANDLE
199 !
200 IF (lhook) CALL dr_hook('MODE_AV_PGD:GET_WEIGHT_PATCH',0,zhook_handle)
201 !
202 IF (.NOT.ASSOCIATED(dtco%XDATA_WEIGHT)) THEN
203  !
204  ALLOCATE(dtco%XDATA_WEIGHT(kcover,nvegtype,12))
205  dtco%XDATA_WEIGHT(:,:,:) = 0.
206  !
207  DO jcov=1,kcover
208  !
209  jj = kmask(jcov)
210  !
211  DO jveg=1,nvegtype
212  ! CASE('NAT')
213  IF (dtco%XDATA_VEGTYPE(jj,jveg)==0.) cycle
214  !
215  dtco%XDATA_WEIGHT(jcov,jveg,1)= dtco%XDATA_NATURE(jj) * dtco%XDATA_VEGTYPE(jj,jveg)
216  !CASE('GRD')
217  dtco%XDATA_WEIGHT(jcov,jveg,2)= dtco%XDATA_TOWN(jj)*dtco%XDATA_GARDEN(jj) * dtco%XDATA_VEGTYPE(jj,jveg)
218  !CASE('VEG')
219  dtco%XDATA_WEIGHT(jcov,jveg,3)= dtco%XDATA_WEIGHT(jcov,jveg,1) * xdata_veg(jj,kdecade,jveg)
220  !CASE('BAR')
221  dtco%XDATA_WEIGHT(jcov,jveg,4)= dtco%XDATA_WEIGHT(jcov,jveg,1) * (1.-xdata_veg(jj,kdecade,jveg))
222  !CASE('GRV')
223  dtco%XDATA_WEIGHT(jcov,jveg,5)= dtco%XDATA_WEIGHT(jcov,jveg,2) * xdata_veg(jj,kdecade,jveg)
224  !CASE('GRB')
225  dtco%XDATA_WEIGHT(jcov,jveg,6)= dtco%XDATA_WEIGHT(jcov,jveg,2) * (1.-xdata_veg(jj,kdecade,jveg))
226  IF ( sum(xdata_lai(jj,:,jveg)) .GT. 0.0) THEN
227  !CASE('DVG') ! for diffusion scheme only
228  dtco%XDATA_WEIGHT(jcov,jveg,7)= dtco%XDATA_WEIGHT(jcov,jveg,1)
229  !CASE('GDV') ! for diffusion scheme only
230  dtco%XDATA_WEIGHT(jcov,jveg,8)= dtco%XDATA_WEIGHT(jcov,jveg,2)
231  ENDIF
232  !CASE('LAI')
233  dtco%XDATA_WEIGHT(jcov,jveg,9)= dtco%XDATA_WEIGHT(jcov,jveg,1) * xdata_lai(jj,kdecade,jveg)
234  !CASE('GRL')
235  dtco%XDATA_WEIGHT(jcov,jveg,10)= dtco%XDATA_WEIGHT(jcov,jveg,2) * xdata_lai(jj,kdecade,jveg)
236  !
237  !Tree vegtype
238  !
239  !CASE('TRE')
240  !CASE('GRT')
241  IF (jveg==nvt_tebd) THEN
242  dtco%XDATA_WEIGHT(jcov,nvt_tebd,11)= dtco%XDATA_WEIGHT(jcov,nvt_tebd,1)
243  dtco%XDATA_WEIGHT(jcov,nvt_tebd,12)= dtco%XDATA_WEIGHT(jcov,nvt_tebd,2)
244  ENDIF
245  IF (jveg==nvt_bone) THEN
246  dtco%XDATA_WEIGHT(jcov,nvt_bone,11)= dtco%XDATA_WEIGHT(jcov,nvt_bone,1)
247  dtco%XDATA_WEIGHT(jcov,nvt_bone,12)= dtco%XDATA_WEIGHT(jcov,nvt_bone,2)
248  ENDIF
249  IF (jveg==nvt_trbe) THEN
250  dtco%XDATA_WEIGHT(jcov,nvt_trbe,11)= dtco%XDATA_WEIGHT(jcov,nvt_trbe,1)
251  dtco%XDATA_WEIGHT(jcov,nvt_trbe,12)= dtco%XDATA_WEIGHT(jcov,nvt_trbe,2)
252  ENDIF
253  IF (jveg==nvt_trbd) THEN
254  dtco%XDATA_WEIGHT(jcov,nvt_trbd,11)= dtco%XDATA_WEIGHT(jcov,nvt_trbd,1)
255  dtco%XDATA_WEIGHT(jcov,nvt_trbd,12)= dtco%XDATA_WEIGHT(jcov,nvt_trbd,2)
256  ENDIF
257  IF (jveg==nvt_tebe) THEN
258  dtco%XDATA_WEIGHT(jcov,nvt_tebe,11)= dtco%XDATA_WEIGHT(jcov,nvt_tebe,1)
259  dtco%XDATA_WEIGHT(jcov,nvt_tebe,12)= dtco%XDATA_WEIGHT(jcov,nvt_tebe,2)
260  ENDIF
261  IF (jveg==nvt_tene) THEN
262  dtco%XDATA_WEIGHT(jcov,nvt_tene,11)= dtco%XDATA_WEIGHT(jcov,nvt_tene,1)
263  dtco%XDATA_WEIGHT(jcov,nvt_tene,12)= dtco%XDATA_WEIGHT(jcov,nvt_tene,2)
264  ENDIF
265  IF (jveg==nvt_bobd) THEN
266  dtco%XDATA_WEIGHT(jcov,nvt_bobd,11)= dtco%XDATA_WEIGHT(jcov,nvt_bobd,1)
267  dtco%XDATA_WEIGHT(jcov,nvt_bobd,12)= dtco%XDATA_WEIGHT(jcov,nvt_bobd,2)
268  ENDIF
269  IF (jveg==nvt_bond) THEN
270  dtco%XDATA_WEIGHT(jcov,nvt_bond,11)= dtco%XDATA_WEIGHT(jcov,nvt_bond,1)
271  dtco%XDATA_WEIGHT(jcov,nvt_bond,12)= dtco%XDATA_WEIGHT(jcov,nvt_bond,2)
272  ENDIF
273  IF (jveg==nvt_shrb) THEN
274  dtco%XDATA_WEIGHT(jcov,nvt_shrb,11)= dtco%XDATA_WEIGHT(jcov,nvt_shrb,1)
275  dtco%XDATA_WEIGHT(jcov,nvt_shrb,12)= dtco%XDATA_WEIGHT(jcov,nvt_shrb,2)
276  ENDIF
277  !
278  ENDDO
279  !
280  ENDDO
281  !
282 ENDIF
283 !
284 SELECT CASE (hsftype)
285  CASE('NAT')
286  pweight(:,:) = dtco%XDATA_WEIGHT(:,:,1)
287  CASE('GRD')
288  pweight(:,:) = dtco%XDATA_WEIGHT(:,:,2)
289  CASE('VEG')
290  pweight(:,:) = dtco%XDATA_WEIGHT(:,:,3)
291  CASE('BAR')
292  pweight(:,:) = dtco%XDATA_WEIGHT(:,:,4)
293  CASE('GRV')
294  pweight(:,:) = dtco%XDATA_WEIGHT(:,:,5)
295  CASE('GRB')
296  pweight(:,:) = dtco%XDATA_WEIGHT(:,:,6)
297  CASE('DVG')
298  pweight(:,:) = dtco%XDATA_WEIGHT(:,:,7)
299  CASE('GDV')
300  pweight(:,:) = dtco%XDATA_WEIGHT(:,:,8)
301  CASE('LAI')
302  pweight(:,:) = dtco%XDATA_WEIGHT(:,:,9)
303  CASE('GRL')
304  pweight(:,:) = dtco%XDATA_WEIGHT(:,:,10)
305  CASE('TRE')
306  pweight(:,:) = dtco%XDATA_WEIGHT(:,:,11)
307  CASE('GRT')
308  pweight(:,:) = dtco%XDATA_WEIGHT(:,:,12)
309  CASE DEFAULT
310  CALL abor1_sfx('AV_1PATCH_PGD_1D: WEIGHTING FUNCTION FOR VEGTYPE NOT ALLOWED')
311 END SELECT
312 !
313 IF (lhook) CALL dr_hook('MODE_AV_PGD:GET_WEIGHT_PATCH',1,zhook_handle)
314 !
315 END SUBROUTINE get_weight_patch
316 !
317  END MODULE mode_av_pgd
mode_av_pgd::get_weight_patch
subroutine get_weight_patch(DTCO, KCOVER, KMASK, KDECADE, HSFTYPE, PWEIGHT)
Definition: mode_av_pgd.F90:175
modd_data_cover
Definition: modd_data_cover.F90:6
modd_surf_par
Definition: modd_surf_par.F90:6
yomhook::dr_hook
Definition: yomhook.F90:20
abor1_sfx
subroutine abor1_sfx(YTEXT)
Definition: abor1_sfx.F90:7
parkind1::jprb
integer, parameter jprb
Definition: parkind1.F90:32
modd_surf_par::nundef
integer, parameter nundef
Definition: modd_surf_par.F90:51
mode_av_pgd::get_weight
subroutine get_weight(DTCO, KCOVER, KMASK, HSFTYPE, PWEIGHT)
Definition: mode_av_pgd.F90:81
modd_data_cover_n
Definition: modd_data_covern.F90:6
mode_av_pgd
Definition: mode_av_pgd.F90:5
modd_data_cover::xdata_veg
real, dimension(:,:,:), allocatable xdata_veg
Definition: modd_data_cover.F90:87
modd_type_date_surf::date_time
Definition: modd_type_date_surf.F90:46
sum
intent(out) overrides sub arrays one Sort by the least significant key first sum(iindex(1:n))
mode_av_pgd::date2doy
subroutine date2doy(TPDATA, OCOVER, KDOY)
Definition: mode_av_pgd.F90:17
yomhook::lhook
logical lhook
Definition: yomhook.F90:15
modd_data_cover::xdata_lai
real, dimension(:,:,:), allocatable xdata_lai
Definition: modd_data_cover.F90:149
modd_data_cover_n::data_cover_t
Definition: modd_data_covern.F90:43
modd_data_cover::xdata_bld_height
real, dimension(:), allocatable xdata_bld_height
Definition: modd_data_cover.F90:174
modd_type_date_surf
Definition: modd_type_date_surf.F90:6
mode_av_pgd::doy2date
subroutine doy2date(KDOY, KMONTH, KDAY)
Definition: mode_av_pgd.F90:50
Generated on Tue Jan 16 2018 16:23:29 for SURFEX v8.1 by   doxygen 1.8.13