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

Last change on this file since 347 was 295, checked in by ymipsl, 10 years ago

Merging OpenMP parallisme mode : by subdomain and on vertical level.
This feature is actually experimental but may be retro-compatible with the last method based only on subdomain

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