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

Last change on this file since 288 was 266, checked in by ymipsl, 10 years ago

Synchronize trunk and Saturn branch.
Merge modification from Saturn branch to trunk

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