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

Last change on this file since 155 was 138, checked in by dubos, 11 years ago

Transport now working again - tested with dcmip4.1.0
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 = '(unkown)'
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 assignation 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 assignation with ' // TRIM(field%name) 
247       STOP
248    END IF
249    field_pt=>field%rval3d
250  END SUBROUTINE  getval_r3d
251
252  SUBROUTINE getval_r4d(field_pt,field)
253  IMPLICIT NONE 
254    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:,:)
255    TYPE(t_field),INTENT(IN) :: field
256   
257    IF (field%ndim/=4 .OR. field%data_type/=type_real) THEN
258       PRINT *, 'get_val_r4d : bad pointer assignation with ' // TRIM(field%name)
259       STOP
260    END IF
261    field_pt=>field%rval4d
262  END SUBROUTINE  getval_r4d 
263
264 
265  SUBROUTINE getval_i2d(field_pt,field)
266  IMPLICIT NONE 
267    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:)
268    TYPE(t_field),INTENT(IN) :: field
269   
270    IF (field%ndim/=2 .OR. field%data_type/=type_integer) STOP 'get_val_i2d : bad pointer assignation'       
271    field_pt=>field%ival2d
272  END SUBROUTINE  getval_i2d
273
274  SUBROUTINE getval_i3d(field_pt,field)
275  IMPLICIT NONE 
276    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:)
277    TYPE(t_field),INTENT(IN) :: field
278   
279    IF (field%ndim/=3 .OR. field%data_type/=type_integer) STOP 'get_val_i3d : bad pointer assignation'       
280    field_pt=>field%ival3d
281  END SUBROUTINE  getval_i3d
282
283  SUBROUTINE getval_i4d(field_pt,field)
284  IMPLICIT NONE 
285    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
286    TYPE(t_field),INTENT(IN) :: field
287   
288    IF (field%ndim/=4 .OR. field%data_type/=type_integer) STOP 'get_val_i4d : bad pointer assignation'       
289    field_pt=>field%ival4d
290  END SUBROUTINE  getval_i4d
291
292  SUBROUTINE getval_l2d(field_pt,field)
293  IMPLICIT NONE 
294    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:)
295    TYPE(t_field),INTENT(IN) :: field
296   
297    IF (field%ndim/=2 .OR. field%data_type/=type_logical) STOP 'get_val_l2d : bad pointer assignation'       
298    field_pt=>field%lval2d
299  END SUBROUTINE  getval_l2d
300
301  SUBROUTINE getval_l3d(field_pt,field)
302  IMPLICIT NONE 
303    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:)
304    TYPE(t_field),INTENT(IN) :: field
305   
306    IF (field%ndim/=3 .OR. field%data_type/=type_logical) STOP 'get_val_l3d : bad pointer assignation'       
307    field_pt=>field%lval3d
308  END SUBROUTINE  getval_l3d
309
310  SUBROUTINE getval_l4d(field_pt,field)
311  IMPLICIT NONE 
312    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
313    TYPE(t_field),INTENT(IN) :: field
314   
315    IF (field%ndim/=4 .OR. field%data_type/=type_logical) STOP 'get_val_l4d : bad pointer assignation'       
316    field_pt=>field%lval4d
317  END SUBROUTINE  getval_l4d   
318
319END MODULE field_mod   
Note: See TracBrowser for help on using the repository browser.