source: codes/icosagcm/trunk/src/field.f90 @ 29

Last change on this file since 29 was 29, checked in by ymipsl, 12 years ago

Bug fixe for output tracer

YM
File size: 9.8 KB
Line 
1MODULE field_mod
2  USE genmod
3 
4  INTEGER,PARAMETER :: field_T=1
5  INTEGER,PARAMETER :: field_U=2
6  INTEGER,PARAMETER :: field_Z=3
7
8  INTEGER,PARAMETER :: type_integer=1
9  INTEGER,PARAMETER :: type_real=2
10  INTEGER,PARAMETER :: type_logical=3
11   
12  TYPE t_field
13    REAL(rstd),POINTER :: rval2d(:)
14    REAL(rstd),POINTER :: rval3d(:,:)
15    REAL(rstd),POINTER :: rval4d(:,:,:)
16
17    INTEGER,POINTER :: ival2d(:)
18    INTEGER,POINTER :: ival3d(:,:)
19    INTEGER,POINTER :: ival4d(:,:,:)
20   
21    LOGICAL,POINTER :: lval2d(:)
22    LOGICAL,POINTER :: lval3d(:,:)
23    LOGICAL,POINTER :: lval4d(:,:,:)
24
25    INTEGER :: ndim
26    INTEGER :: field_type
27    INTEGER :: data_type 
28    INTEGER :: dim3
29    INTEGER :: dim4
30  END TYPE t_field   
31
32  INTERFACE get_val
33    MODULE PROCEDURE getval_r2d,getval_r3d,getval_r4d, &
34                     getval_i2d,getval_i3d,getval_i4d, &
35                     getval_l2d,getval_l3d,getval_l4d
36  END INTERFACE
37                   
38  INTERFACE ASSIGNMENT(=)
39    MODULE PROCEDURE getval_r2d,getval_r3d,getval_r4d, &
40                     getval_i2d,getval_i3d,getval_i4d, &
41                     getval_l2d,getval_l3d,getval_l4d 
42  END INTERFACE
43
44
45CONTAINS
46
47  SUBROUTINE allocate_field(field,field_type,data_type,dim1,dim2)
48  USE domain_mod
49  IMPLICIT NONE
50    TYPE(t_field),POINTER :: field(:)
51    INTEGER,INTENT(IN) :: field_type
52    INTEGER,INTENT(IN) :: data_type
53    INTEGER,OPTIONAL :: dim1,dim2
54    INTEGER :: ind
55    INTEGER :: ii_size,jj_size
56
57    ALLOCATE(field(ndomain))   
58
59    DO ind=1,ndomain
60 
61      IF (PRESENT(dim2)) THEN
62        field(ind)%ndim=4 
63        field(ind)%dim4=dim2 
64        field(ind)%dim3=dim1
65      ELSE IF (PRESENT(dim1)) THEN
66        field(ind)%ndim=3
67        field(ind)%dim3=dim1
68      ELSE
69        field(ind)%ndim=2
70      ENDIF
71   
72   
73      field(ind)%data_type=data_type
74      field(ind)%field_type=field_type
75   
76      IF (field_type==field_T) THEN
77        jj_size=domain(ind)%jjm
78      ELSE IF (field_type==field_U) THEN
79        jj_size=3*domain(ind)%jjm
80      ELSE IF (field_type==field_Z) THEN
81        jj_size=2*domain(ind)%jjm
82      ENDIF
83     
84      ii_size=domain(ind)%iim
85       
86      IF (field(ind)%ndim==4) THEN
87        IF (data_type==type_integer) ALLOCATE(field(ind)%ival4d(ii_size*jj_size,dim1,dim2))
88        IF (data_type==type_real)    ALLOCATE(field(ind)%rval4d(ii_size*jj_size,dim1,dim2))
89        IF (data_type==type_logical) ALLOCATE(field(ind)%lval4d(ii_size*jj_size,dim1,dim2))
90      ELSE IF (field(ind)%ndim==3) THEN
91        IF (data_type==type_integer) ALLOCATE(field(ind)%ival3d(ii_size*jj_size,dim1))
92        IF (data_type==type_real)    ALLOCATE(field(ind)%rval3d(ii_size*jj_size,dim1))
93        IF (data_type==type_logical) ALLOCATE(field(ind)%lval3d(ii_size*jj_size,dim1))
94      ELSE IF (field(ind)%ndim==2) THEN
95        IF (data_type==type_integer) ALLOCATE(field(ind)%ival2d(ii_size*jj_size))
96        IF (data_type==type_real)    ALLOCATE(field(ind)%rval2d(ii_size*jj_size))
97        IF (data_type==type_logical) ALLOCATE(field(ind)%lval2d(ii_size*jj_size))
98      ENDIF
99     
100   ENDDO
101   
102  END SUBROUTINE allocate_field
103
104  SUBROUTINE allocate_field_glo(field,field_type,data_type,dim1,dim2)
105  USE domain_mod
106  IMPLICIT NONE
107    TYPE(t_field),POINTER :: field(:)
108    INTEGER,INTENT(IN) :: field_type
109    INTEGER,INTENT(IN) :: data_type
110    INTEGER,OPTIONAL :: dim1,dim2
111    INTEGER :: ind
112    INTEGER :: ii_size,jj_size
113
114    ALLOCATE(field(ndomain_glo))   
115
116    DO ind=1,ndomain_glo
117 
118      IF (PRESENT(dim2)) THEN
119        field(ind)%ndim=4 
120        field(ind)%dim4=dim2 
121        field(ind)%dim3=dim1 
122      ELSE IF (PRESENT(dim1)) THEN
123        field(ind)%ndim=3
124        field(ind)%dim3=dim1 
125      ELSE
126        field(ind)%ndim=2
127      ENDIF
128   
129   
130      field(ind)%data_type=data_type
131      field(ind)%field_type=field_type
132   
133      IF (field_type==field_T) THEN
134        jj_size=domain_glo(ind)%jjm
135      ELSE IF (field_type==field_U) THEN
136        jj_size=3*domain_glo(ind)%jjm
137      ELSE IF (field_type==field_Z) THEN
138        jj_size=2*domain_glo(ind)%jjm
139      ENDIF
140     
141      ii_size=domain_glo(ind)%iim
142       
143      IF (field(ind)%ndim==4) THEN
144        IF (data_type==type_integer) ALLOCATE(field(ind)%ival4d(ii_size*jj_size,dim1,dim2))
145        IF (data_type==type_real)    ALLOCATE(field(ind)%rval4d(ii_size*jj_size,dim1,dim2))
146        IF (data_type==type_logical) ALLOCATE(field(ind)%lval4d(ii_size*jj_size,dim1,dim2))
147      ELSE IF (field(ind)%ndim==3) THEN
148        IF (data_type==type_integer) ALLOCATE(field(ind)%ival3d(ii_size*jj_size,dim1))
149        IF (data_type==type_real)    ALLOCATE(field(ind)%rval3d(ii_size*jj_size,dim1))
150        IF (data_type==type_logical) ALLOCATE(field(ind)%lval3d(ii_size*jj_size,dim1))
151      ELSE IF (field(ind)%ndim==2) THEN
152        IF (data_type==type_integer) ALLOCATE(field(ind)%ival2d(ii_size*jj_size))
153        IF (data_type==type_real)    ALLOCATE(field(ind)%rval2d(ii_size*jj_size))
154        IF (data_type==type_logical) ALLOCATE(field(ind)%lval2d(ii_size*jj_size))
155      ENDIF
156     
157   ENDDO
158 
159  END SUBROUTINE allocate_field_glo
160
161  SUBROUTINE deallocate_field(field)
162  USE domain_mod
163  IMPLICIT NONE
164    TYPE(t_field),POINTER :: field(:)
165    INTEGER :: data_type
166    INTEGER :: ind
167
168    DO ind=1,ndomain
169
170      data_type=field(ind)%data_type
171       
172      IF (field(ind)%ndim==4) THEN
173        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival4d)
174        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval4d)
175        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval4d)
176      ELSE IF (field(ind)%ndim==3) THEN
177        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival3d)
178        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval3d)
179        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval3d)
180      ELSE IF (field(ind)%ndim==2) THEN
181        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival2d)
182        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval2d)
183        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval2d)
184      ENDIF
185     
186   ENDDO
187   DEALLOCATE(field)
188       
189  END SUBROUTINE deallocate_field
190
191  SUBROUTINE deallocate_field_glo(field)
192  USE domain_mod
193  IMPLICIT NONE
194    TYPE(t_field),POINTER :: field(:)
195    INTEGER :: data_type
196    INTEGER :: ind
197
198    DO ind=1,ndomain_glo
199
200      data_type=field(ind)%data_type
201       
202      IF (field(ind)%ndim==4) THEN
203        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival4d)
204        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval4d)
205        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval4d)
206      ELSE IF (field(ind)%ndim==3) THEN
207        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival3d)
208        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval3d)
209        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval3d)
210      ELSE IF (field(ind)%ndim==2) THEN
211        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival2d)
212        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval2d)
213        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval2d)
214      ENDIF
215     
216   ENDDO
217   DEALLOCATE(field)
218       
219  END SUBROUTINE deallocate_field_glo
220   
221  SUBROUTINE getval_r2d(field_pt,field)
222  IMPLICIT NONE 
223    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:)
224    TYPE(t_field),INTENT(IN) :: field
225   
226    IF (field%ndim/=2 .OR. field%data_type/=type_real) STOP 'get_val_r2d : bad pointer assignation'       
227    field_pt=>field%rval2d
228  END SUBROUTINE  getval_r2d
229
230  SUBROUTINE getval_r3d(field_pt,field)
231  IMPLICIT NONE 
232    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:)
233    TYPE(t_field),INTENT(IN) :: field
234   
235    IF (field%ndim/=3 .OR. field%data_type/=type_real) STOP 'get_val_r3d : bad pointer assignation'       
236    field_pt=>field%rval3d
237  END SUBROUTINE  getval_r3d
238
239  SUBROUTINE getval_r4d(field_pt,field)
240  IMPLICIT NONE 
241    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:,:)
242    TYPE(t_field),INTENT(IN) :: field
243   
244    IF (field%ndim/=4 .OR. field%data_type/=type_real) STOP 'get_val_r4d : bad pointer assignation'       
245    field_pt=>field%rval4d
246  END SUBROUTINE  getval_r4d
247 
248
249 
250  SUBROUTINE getval_i2d(field_pt,field)
251  IMPLICIT NONE 
252    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:)
253    TYPE(t_field),INTENT(IN) :: field
254   
255    IF (field%ndim/=2 .OR. field%data_type/=type_integer) STOP 'get_val_i2d : bad pointer assignation'       
256    field_pt=>field%ival2d
257  END SUBROUTINE  getval_i2d
258
259  SUBROUTINE getval_i3d(field_pt,field)
260  IMPLICIT NONE 
261    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:)
262    TYPE(t_field),INTENT(IN) :: field
263   
264    IF (field%ndim/=3 .OR. field%data_type/=type_integer) STOP 'get_val_i3d : bad pointer assignation'       
265    field_pt=>field%ival3d
266  END SUBROUTINE  getval_i3d
267
268  SUBROUTINE getval_i4d(field_pt,field)
269  IMPLICIT NONE 
270    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
271    TYPE(t_field),INTENT(IN) :: field
272   
273    IF (field%ndim/=4 .OR. field%data_type/=type_integer) STOP 'get_val_i4d : bad pointer assignation'       
274    field_pt=>field%ival4d
275  END SUBROUTINE  getval_i4d
276
277  SUBROUTINE getval_l2d(field_pt,field)
278  IMPLICIT NONE 
279    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:)
280    TYPE(t_field),INTENT(IN) :: field
281   
282    IF (field%ndim/=2 .OR. field%data_type/=type_logical) STOP 'get_val_l2d : bad pointer assignation'       
283    field_pt=>field%lval2d
284  END SUBROUTINE  getval_l2d
285
286  SUBROUTINE getval_l3d(field_pt,field)
287  IMPLICIT NONE 
288    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:)
289    TYPE(t_field),INTENT(IN) :: field
290   
291    IF (field%ndim/=3 .OR. field%data_type/=type_logical) STOP 'get_val_l3d : bad pointer assignation'       
292    field_pt=>field%lval3d
293  END SUBROUTINE  getval_l3d
294
295  SUBROUTINE getval_l4d(field_pt,field)
296  IMPLICIT NONE 
297    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
298    TYPE(t_field),INTENT(IN) :: field
299   
300    IF (field%ndim/=4 .OR. field%data_type/=type_logical) STOP 'get_val_l4d : bad pointer assignation'       
301    field_pt=>field%lval4d
302  END SUBROUTINE  getval_l4d   
303
304END MODULE field_mod   
Note: See TracBrowser for help on using the repository browser.