source: codes/icosagcm/branches/SATURN_DYNAMICO/ICOSAGCM/src/field.f90 @ 314

Last change on this file since 314 was 260, checked in by ymipsl, 10 years ago

Implement restartability for dynamico

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.