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

Last change on this file since 200 was 186, checked in by ymipsl, 10 years ago

Add new openMP parallelism based on distribution of domains on threads. There is no more limitation of number of threads by MPI process.

YM
File size: 10.3 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)
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    INTEGER :: ind
126    INTEGER :: ii_size,jj_size
127
128    ALLOCATE(field(ndomain_glo))   
129
130    DO ind=1,ndomain_glo
131 
132      IF (PRESENT(dim2)) THEN
133        field(ind)%ndim=4 
134        field(ind)%dim4=dim2 
135        field(ind)%dim3=dim1 
136      ELSE IF (PRESENT(dim1)) THEN
137        field(ind)%ndim=3
138        field(ind)%dim3=dim1 
139      ELSE
140        field(ind)%ndim=2
141      ENDIF
142   
143   
144      field(ind)%data_type=data_type
145      field(ind)%field_type=field_type
146   
147      IF (field_type==field_T) THEN
148        jj_size=domain_glo(ind)%jjm
149      ELSE IF (field_type==field_U) THEN
150        jj_size=3*domain_glo(ind)%jjm
151      ELSE IF (field_type==field_Z) THEN
152        jj_size=2*domain_glo(ind)%jjm
153      ENDIF
154     
155      ii_size=domain_glo(ind)%iim
156       
157      IF (field(ind)%ndim==4) THEN
158        IF (data_type==type_integer) ALLOCATE(field(ind)%ival4d(ii_size*jj_size,dim1,dim2))
159        IF (data_type==type_real)    ALLOCATE(field(ind)%rval4d(ii_size*jj_size,dim1,dim2))
160        IF (data_type==type_logical) ALLOCATE(field(ind)%lval4d(ii_size*jj_size,dim1,dim2))
161      ELSE IF (field(ind)%ndim==3) THEN
162        IF (data_type==type_integer) ALLOCATE(field(ind)%ival3d(ii_size*jj_size,dim1))
163        IF (data_type==type_real)    ALLOCATE(field(ind)%rval3d(ii_size*jj_size,dim1))
164        IF (data_type==type_logical) ALLOCATE(field(ind)%lval3d(ii_size*jj_size,dim1))
165      ELSE IF (field(ind)%ndim==2) THEN
166        IF (data_type==type_integer) ALLOCATE(field(ind)%ival2d(ii_size*jj_size))
167        IF (data_type==type_real)    ALLOCATE(field(ind)%rval2d(ii_size*jj_size))
168        IF (data_type==type_logical) ALLOCATE(field(ind)%lval2d(ii_size*jj_size))
169      ENDIF
170     
171   ENDDO
172 
173  END SUBROUTINE allocate_field_glo
174
175  SUBROUTINE deallocate_field(field)
176  USE domain_mod
177  IMPLICIT NONE
178    TYPE(t_field),POINTER :: field(:)
179    INTEGER :: data_type
180    INTEGER :: ind
181
182    DO ind=1,ndomain
183
184      data_type=field(ind)%data_type
185       
186      IF (field(ind)%ndim==4) THEN
187        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival4d)
188        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval4d)
189        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval4d)
190      ELSE IF (field(ind)%ndim==3) THEN
191        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival3d)
192        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval3d)
193        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval3d)
194      ELSE IF (field(ind)%ndim==2) THEN
195        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival2d)
196        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval2d)
197        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval2d)
198      ENDIF
199     
200   ENDDO
201   DEALLOCATE(field)
202       
203  END SUBROUTINE deallocate_field
204
205  SUBROUTINE deallocate_field_glo(field)
206  USE domain_mod
207  IMPLICIT NONE
208    TYPE(t_field),POINTER :: field(:)
209    INTEGER :: data_type
210    INTEGER :: ind
211
212    DO ind=1,ndomain_glo
213
214      data_type=field(ind)%data_type
215       
216      IF (field(ind)%ndim==4) THEN
217        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival4d)
218        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval4d)
219        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval4d)
220      ELSE IF (field(ind)%ndim==3) THEN
221        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival3d)
222        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval3d)
223        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval3d)
224      ELSE IF (field(ind)%ndim==2) THEN
225        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival2d)
226        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval2d)
227        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval2d)
228      ENDIF
229     
230   ENDDO
231   DEALLOCATE(field)
232       
233  END SUBROUTINE deallocate_field_glo
234   
235  SUBROUTINE getval_r2d(field_pt,field)
236  IMPLICIT NONE 
237    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:)
238    TYPE(t_field),INTENT(IN) :: field
239   
240    IF (field%ndim/=2 .OR. field%data_type/=type_real) THEN
241       PRINT *, 'get_val_r2d : bad pointer assignment with ' // TRIM(field%name) 
242       STOP
243    END IF
244    field_pt=>field%rval2d
245  END SUBROUTINE  getval_r2d
246
247  SUBROUTINE getval_r3d(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/=3 .OR. field%data_type/=type_real) THEN
253       PRINT *, 'get_val_r3d : bad pointer assignment with ' // TRIM(field%name) 
254       STOP
255!       CALL ABORT
256    END IF
257    field_pt=>field%rval3d
258  END SUBROUTINE  getval_r3d
259
260  SUBROUTINE getval_r4d(field_pt,field)
261  IMPLICIT NONE 
262    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:,:)
263    TYPE(t_field),INTENT(IN) :: field
264   
265    IF (field%ndim/=4 .OR. field%data_type/=type_real) THEN
266       PRINT *, 'get_val_r4d : bad pointer assignment with ' // TRIM(field%name)
267       STOP
268    END IF
269    field_pt=>field%rval4d
270  END SUBROUTINE  getval_r4d 
271
272 
273  SUBROUTINE getval_i2d(field_pt,field)
274  IMPLICIT NONE 
275    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:)
276    TYPE(t_field),INTENT(IN) :: field
277   
278    IF (field%ndim/=2 .OR. field%data_type/=type_integer) STOP 'get_val_i2d : bad pointer assignment'       
279    field_pt=>field%ival2d
280  END SUBROUTINE  getval_i2d
281
282  SUBROUTINE getval_i3d(field_pt,field)
283  IMPLICIT NONE 
284    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:)
285    TYPE(t_field),INTENT(IN) :: field
286   
287    IF (field%ndim/=3 .OR. field%data_type/=type_integer) STOP 'get_val_i3d : bad pointer assignment'       
288    field_pt=>field%ival3d
289  END SUBROUTINE  getval_i3d
290
291  SUBROUTINE getval_i4d(field_pt,field)
292  IMPLICIT NONE 
293    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
294    TYPE(t_field),INTENT(IN) :: field
295   
296    IF (field%ndim/=4 .OR. field%data_type/=type_integer) STOP 'get_val_i4d : bad pointer assignment'       
297    field_pt=>field%ival4d
298  END SUBROUTINE  getval_i4d
299
300  SUBROUTINE getval_l2d(field_pt,field)
301  IMPLICIT NONE 
302    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:)
303    TYPE(t_field),INTENT(IN) :: field
304   
305    IF (field%ndim/=2 .OR. field%data_type/=type_logical) STOP 'get_val_l2d : bad pointer assignment'       
306    field_pt=>field%lval2d
307  END SUBROUTINE  getval_l2d
308
309  SUBROUTINE getval_l3d(field_pt,field)
310  IMPLICIT NONE 
311    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:)
312    TYPE(t_field),INTENT(IN) :: field
313   
314    IF (field%ndim/=3 .OR. field%data_type/=type_logical) STOP 'get_val_l3d : bad pointer assignment'       
315    field_pt=>field%lval3d
316  END SUBROUTINE  getval_l3d
317
318  SUBROUTINE getval_l4d(field_pt,field)
319  IMPLICIT NONE 
320    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
321    TYPE(t_field),INTENT(IN) :: field
322   
323    IF (field%ndim/=4 .OR. field%data_type/=type_logical) STOP 'get_val_l4d : bad pointer assignment'       
324    field_pt=>field%lval4d
325  END SUBROUTINE  getval_l4d   
326
327END MODULE field_mod   
Note: See TracBrowser for help on using the repository browser.