source: branches/publications/ORCHIDEE-GMv3.2/ORCHIDEE/src_stomate/stomate_gluc_constants.f90 @ 7481

Last change on this file since 7481 was 6940, checked in by jinfeng.chang, 4 years ago

add missing files for ORCHIDEE-GMv3.2
File size: 13.1 KB
Line 
1! =================================================================================================================================
2! MODULE       : stomate_gluc_common
3!
4! CONTACT      : orchidee-help _at_ ipsl.jussieu.fr
5!
6! LICENCE      : IPSL (2006)
7! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
8!
9!>\BRIEF       This module contains common fuctions and subroutines used by
10!              gross land use change and forestry harvest modules.
11!!
12!!\n DESCRIPTION: None
13!!
14!! RECENT CHANGE(S):
15!!
16!! REFERENCE(S) : None
17!!
18!! SVN          :
19!! $HeadURL: svn://forge.ipsl.jussieu.fr/orchidee/perso/albert.jornet/ORCHIDEE-MICT/src_stomate/stomate_lcchange.f90 $
20!! $Date: 2015-07-30 15:38:45 +0200 (Thu, 30 Jul 2015) $
21!! $Revision: 2847 $
22!! \n
23!_ ================================================================================================================================
24
25
26MODULE stomate_gluc_constants
27
28  ! modules used:
29 
30  USE pft_parameters
31  USE constantes
32  USE constantes_soil_var
33 
34  IMPLICIT NONE
35 
36  PUBLIC
37 
38  INTEGER, ALLOCATABLE, SAVE                  :: indall_tree(:)       !! Indices for all tree PFTs
39  INTEGER, ALLOCATABLE, SAVE                  :: indold_tree(:)       !! Indices for old tree cohort only
40  INTEGER, ALLOCATABLE, SAVE                  :: indagec_tree(:,:)    !! Indices for secondary tree cohorts,
41                                                                      !! note the sequence is old->young.
42  INTEGER, ALLOCATABLE, SAVE                  :: indall_grass(:)      !! Indices for all grass PFTs
43  INTEGER, ALLOCATABLE, SAVE                  :: indold_grass(:)      !! Indices for old grasses only
44  INTEGER, ALLOCATABLE, SAVE                  :: indagec_grass(:,:)   !! Indices for secondary grass cohorts
45                                                                      !! note the sequence is old->young.
46  INTEGER, ALLOCATABLE, SAVE                  :: indall_pasture(:)    !! Indices for all pasture PFTs
47  INTEGER, ALLOCATABLE, SAVE                  :: indold_pasture(:)    !! Indices for old pasture only
48  INTEGER, ALLOCATABLE, SAVE                  :: indagec_pasture(:,:) !! Indices for secondary pasture cohorts
49                                                                      !! note the sequence is old->young.
50  INTEGER, ALLOCATABLE, SAVE                  :: indall_crop(:)       !! Indices for all crop PFTs
51  INTEGER, ALLOCATABLE, SAVE                  :: indold_crop(:)       !! Indices for old crops only
52  INTEGER, ALLOCATABLE, SAVE                  :: indagec_crop(:,:)    !! Indices for secondary crop cohorts
53
54  INTEGER, ALLOCATABLE, SAVE                  :: indall_bioe1(:)       !! Indices for all bioe1 PFTs
55  INTEGER, ALLOCATABLE, SAVE                  :: indold_bioe1(:)       !! Indices for old bioe1 only
56  INTEGER, ALLOCATABLE, SAVE                  :: indagec_bioe1(:,:)    !! Indices for secondary bioe1 cohorts
57
58  INTEGER, SAVE :: num_tree_mulagec,num_grass_mulagec,     &
59                   num_pasture_mulagec,num_crop_mulagec,   &
60                   num_bioe1_mulagec
61 
62CONTAINS
63
64! ================================================================================================================================
65!! SUBROUTINE   : stomate_gluc_constants_init
66!!
67!>\BRIEF        Calculate coverage fraction for different age classes of forest,
68!!              grass, pasture and crops and also for each metaclass. Note baresoil is excluded.
69!!             
70!! DESCRIPTION :
71!! Note:
72!! 1. "calc_cover" subroutine does not depend on how many age classes
73!! there are in each MTC.
74!! 2. Fraction of baresoil is excluded here. This means transformation
75!! of baresoil to a vegetated PFT is excluded in gross land cover change.
76!! 
77!!
78!! MAIN OUTPUT VARIABLE(S) : 
79!!
80!! \n
81!_ ================================================================================================================================
82
83  SUBROUTINE stomate_gluc_constants_init()
84
85    INTEGER(i_std) :: itree,itree2,igrass,igrass2,ipasture,ipasture2,icrop,icrop2, &
86                      ibioe1, ibioe12
87    INTEGER(i_std) :: i,j,ivma,staind,endind,ivm
88    INTEGER(i_std) :: ier               !! Check errors in netcdf call
89
90
91    !! 1. We first build all different indices that we are going to use
92    !!    in handling the PFT exchanges, three types of indices are built:
93    !!     - for all age classes
94    !!     - include only oldest age classes
95    !!     - include all age classes excpet the oldest ones
96    ! We have to build these indices because we would like to extract from
97    ! donating PFTs in the sequnce of old->young age classes or the revserse,
98    ! and add in the receving PFTs only in the youngest-age-class PFTs. These
99    ! indicies allow us to know where the different age classes are.
100
101    ! calculate the total number of MTCs for each vegetation type.
102    num_tree_mulagec=0         
103    num_grass_mulagec=0
104    num_pasture_mulagec=0
105    num_crop_mulagec=0
106    num_bioe1_mulagec=0
107   
108    !! 1.1 Calculate the number of PFTs for different MTCs and allocate
109    !! the old and all indices arrays.
110
111    ! [Note here the sequence to identify tree,pasture,grass,crop] is
112    ! critical. The similar sequence is used in the subroutine "calc_cover".
113    ! Do not forget to change the sequence there if you modify here.
114    DO ivma =2,nvmap
115      staind=start_index(ivma)
116      IF (nagec_pft(ivma)==1) THEN
117        WRITE(numout,*) "Error: metaclass has only a single age group: ",ivma
118        WRITE(numout,*) "stomate_gluc_constants_init"
119        STOP
120      ELSE
121        IF (is_tree(staind)) THEN
122          num_tree_mulagec = num_tree_mulagec+1
123        ELSE IF (is_grassland_manag(staind)) THEN
124          num_pasture_mulagec = num_pasture_mulagec+1
125        ELSE IF (is_bioe1(staind)) THEN
126          num_bioe1_mulagec = num_bioe1_mulagec+1
127        ELSE IF (natural(staind)) THEN
128          num_grass_mulagec = num_grass_mulagec+1
129        ELSE
130          num_crop_mulagec = num_crop_mulagec+1
131        ENDIF
132      ENDIF
133    ENDDO
134   
135    !! Allocate index array
136    ! allocate all index
137
138    ALLOCATE(indall_tree(num_tree_mulagec*nagec_tree),stat=ier)
139    IF (ier .NE. 0) THEN
140       WRITE(numout,*) 'Memory allocation error for indall_tree'
141       STOP 'stomate_gluc_constants_init'
142    ENDIF
143
144    ALLOCATE(indall_grass(num_grass_mulagec*nagec_herb),stat=ier)
145    IF (ier .NE. 0) THEN
146       WRITE(numout,*) 'Memory allocation error for indall_grass'
147       STOP 'stomate_gluc_constants_init'
148    ENDIF
149
150    ALLOCATE(indall_pasture(num_pasture_mulagec*nagec_herb),stat=ier)
151    IF (ier .NE. 0) THEN
152       WRITE(numout,*) 'Memory allocation error for indall_pasture'
153       STOP 'stomate_gluc_constants_init'
154    ENDIF
155
156    ALLOCATE(indall_crop(num_crop_mulagec*nagec_herb),stat=ier)
157    IF (ier .NE. 0) THEN
158       WRITE(numout,*) 'Memory allocation error for indall_crop'
159       STOP 'stomate_gluc_constants_init'
160    ENDIF
161
162    ! allocate old-ageclass index
163    ALLOCATE(indold_tree(num_tree_mulagec),stat=ier)
164    IF (ier .NE. 0) THEN
165       WRITE(numout,*) 'Memory allocation error for indold_tree'
166       STOP 'stomate_gluc_constants_init'
167    ENDIF
168
169    ALLOCATE(indold_grass(num_grass_mulagec),stat=ier)
170    IF (ier .NE. 0) THEN
171       WRITE(numout,*) 'Memory allocation error for indold_grass'
172       STOP 'stomate_gluc_constants_init'
173    ENDIF
174
175    ALLOCATE(indold_pasture(num_pasture_mulagec),stat=ier)
176    IF (ier .NE. 0) THEN
177       WRITE(numout,*) 'Memory allocation error for indold_pasture'
178       STOP 'stomate_gluc_constants_init'
179    ENDIF
180
181    ALLOCATE(indold_crop(num_crop_mulagec),stat=ier)
182    IF (ier .NE. 0) THEN
183       WRITE(numout,*) 'Memory allocation error for indold_crop'
184       STOP 'stomate_gluc_constants_init'
185    ENDIF
186
187    ! To to be able to go through the following code, when there are no bio1
188    ! meta-calsses, we set num_bioe1_mulagec as 1.
189    IF (num_bioe1_mulagec .EQ. 0) num_bioe1_mulagec = 1
190
191    ALLOCATE(indall_bioe1(num_bioe1_mulagec*nagec_bioe1),stat=ier)
192    IF (ier .NE. 0) THEN
193       WRITE(numout,*) 'Memory allocation error for indall_crop'
194       STOP 'stomate_gluc_constants_init'
195    ENDIF
196    indall_bioe1(:) = 0
197
198    ALLOCATE(indold_bioe1(num_bioe1_mulagec),stat=ier)
199    IF (ier .NE. 0) THEN
200       WRITE(numout,*) 'Memory allocation error for indold_crop'
201       STOP 'stomate_gluc_constants_init'
202    ENDIF
203    indold_bioe1(:) = 0
204
205    ALLOCATE(indagec_bioe1(num_bioe1_mulagec,nagec_bioe1-1))
206    IF (ier .NE. 0) THEN
207       WRITE(numout,*) 'Memory allocation error for indagec_crop'
208       STOP 'stomate_gluc_constants_init'
209    ENDIF
210    indagec_bioe1(:,:) = 0
211
212    !! 1.2 Fill the oldest-age-class and all index arrays
213    itree=0
214    igrass=0
215    ipasture=0
216    icrop=0
217    ibioe1=0
218    itree2=1
219    igrass2=1
220    ipasture2=1
221    icrop2=1
222    ibioe12=1
223    DO ivma =2,nvmap
224      staind=start_index(ivma)
225      IF (is_tree(staind)) THEN
226        itree=itree+1
227        indold_tree(itree) = staind+nagec_pft(ivma)-1
228        DO j = 0,nagec_pft(ivma)-1
229          indall_tree(itree2+j) = staind+j
230        ENDDO
231        itree2=itree2+nagec_pft(ivma)
232      ELSE IF (is_bioe1(staind)) THEN
233        ibioe1 = ibioe1+1
234        indold_bioe1(ipasture) = staind+nagec_pft(ivma)-1
235        DO j = 0,nagec_pft(ivma)-1
236          indall_bioe1(ibioe12+j) = staind+j
237        ENDDO
238        ibioe12=ibioe12+nagec_pft(ivma)
239      ELSE IF (natural(staind) .AND. .NOT. is_grassland_manag(staind)) THEN
240        igrass=igrass+1
241        indold_grass(igrass) = staind+nagec_pft(ivma)-1
242        DO j = 0,nagec_pft(ivma)-1
243          indall_grass(igrass2+j) = staind+j
244        ENDDO
245        igrass2=igrass2+nagec_pft(ivma)
246      ELSE IF (is_grassland_manag(staind)) THEN
247        ipasture = ipasture+1
248        indold_pasture(ipasture) = staind+nagec_pft(ivma)-1
249        DO j = 0,nagec_pft(ivma)-1
250          indall_pasture(ipasture2+j) = staind+j
251        ENDDO
252        ipasture2=ipasture2+nagec_pft(ivma)
253      ELSE
254        icrop = icrop+1
255        indold_crop(icrop) = staind+nagec_pft(ivma)-1
256        DO j = 0,nagec_pft(ivma)-1
257          indall_crop(icrop2+j) = staind+j
258        ENDDO
259        icrop2=icrop2+nagec_pft(ivma)
260      ENDIF
261    ENDDO
262   
263    !! 1.3 Allocate and fill other age class index
264
265    ! allocate old-ageclass index
266    ALLOCATE(indagec_tree(num_tree_mulagec,nagec_tree-1),stat=ier)     
267    IF (ier .NE. 0) THEN
268       WRITE(numout,*) 'Memory allocation error for indagec_tree'
269       STOP 'stomate_gluc_constants_init'
270    ENDIF
271
272    ALLOCATE(indagec_grass(num_grass_mulagec,nagec_herb-1),stat=ier)     
273    IF (ier .NE. 0) THEN
274       WRITE(numout,*) 'Memory allocation error for indagec_grass'
275       STOP 'stomate_gluc_constants_init'
276    ENDIF
277
278    ALLOCATE(indagec_pasture(num_pasture_mulagec,nagec_herb-1),stat=ier)
279    IF (ier .NE. 0) THEN
280       WRITE(numout,*) 'Memory allocation error for indagec_pasture'
281       STOP 'stomate_gluc_constants_init'
282    ENDIF
283
284    ALLOCATE(indagec_crop(num_crop_mulagec,nagec_herb-1),stat=ier)
285    IF (ier .NE. 0) THEN
286       WRITE(numout,*) 'Memory allocation error for indagec_crop'
287       STOP 'stomate_gluc_constants_init'
288    ENDIF
289
290    ! fill the non-oldest age class index arrays when number of age classes
291    ! is more than 1.
292    itree=0
293    igrass=0
294    ipasture=0
295    icrop=0
296    ibioe1=0
297    DO ivma = 2,nvmap
298      staind=start_index(ivma)
299      IF (nagec_pft(ivma) > 1) THEN
300        IF (is_tree(staind)) THEN
301          itree=itree+1
302          DO j = 1,nagec_tree-1
303            indagec_tree(itree,j) = staind+nagec_tree-j-1
304          ENDDO
305        ELSE IF (is_bioe1(staind)) THEN
306          ibioe1=ibioe1+1
307          DO j = 1,nagec_bioe1-1
308            indagec_bioe1(ibioe1,j) = staind+nagec_bioe1-j-1
309          ENDDO
310        ELSE IF (natural(staind) .AND. .NOT. is_grassland_manag(staind)) THEN
311          igrass=igrass+1
312          DO j = 1,nagec_herb-1
313            indagec_grass(igrass,j) = staind+nagec_herb-j-1
314          ENDDO
315        ELSE IF (is_grassland_manag(staind)) THEN
316          ipasture=ipasture+1
317          DO j = 1,nagec_herb-1
318            indagec_pasture(ipasture,j) = staind+nagec_herb-j-1
319          ENDDO
320        ELSE
321          icrop=icrop+1
322          DO j = 1,nagec_herb-1
323            indagec_crop(icrop,j) = staind+nagec_herb-j-1
324          ENDDO
325        ENDIF
326      ENDIF
327    ENDDO
328
329    write (numout,*) "indices calculated"
330  END SUBROUTINE stomate_gluc_constants_init
331
332  SUBROUTINE stomate_gluc_constants_init_clear()
333
334    IF (ALLOCATED(indall_tree)) DEALLOCATE(indall_tree)
335    IF (ALLOCATED(indall_grass)) DEALLOCATE(indall_grass)
336    IF (ALLOCATED(indall_pasture)) DEALLOCATE(indall_pasture)
337    IF (ALLOCATED(indall_crop)) DEALLOCATE(indall_crop)
338
339    IF (ALLOCATED(indold_tree)) DEALLOCATE(indold_tree)
340    IF (ALLOCATED(indold_grass)) DEALLOCATE(indold_grass)
341    IF (ALLOCATED(indold_pasture)) DEALLOCATE(indold_pasture)
342    IF (ALLOCATED(indold_crop)) DEALLOCATE(indold_crop)
343
344    IF (ALLOCATED(indagec_tree)) DEALLOCATE(indagec_tree)
345    IF (ALLOCATED(indagec_grass)) DEALLOCATE(indagec_grass)
346    IF (ALLOCATED(indagec_pasture)) DEALLOCATE(indagec_pasture)
347    IF (ALLOCATED(indagec_crop)) DEALLOCATE(indagec_crop)
348
349    IF (ALLOCATED(indall_bioe1)) DEALLOCATE(indall_bioe1)
350    IF (ALLOCATED(indold_bioe1)) DEALLOCATE(indold_bioe1)
351    IF (ALLOCATED(indagec_bioe1)) DEALLOCATE(indagec_bioe1)
352
353  END SUBROUTINE stomate_gluc_constants_init_clear
354
355END MODULE stomate_gluc_constants
Note: See TracBrowser for help on using the repository browser.