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

Last change on this file since 178 was 159, checked in by dubos, 11 years ago

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