source: codes/icosagcm/trunk/src/base/field.f90

Last change on this file was 1055, checked in by dubos, 4 years ago

Simplify base/field.f90 to reduce repetitive code
Generate remaining repetitive code in base/field.f90 and parallel/transfert_mpi_collectives from a template
File size: 13.3 KB
Line 
1MODULE field_mod
2  USE genmod
3  IMPLICIT NONE
4
5  INTEGER,PARAMETER :: field_T=1
6  INTEGER,PARAMETER :: field_U=2
7  INTEGER,PARAMETER :: field_Z=3
8
9  INTEGER,PARAMETER :: type_integer=1
10  INTEGER,PARAMETER :: type_real=2
11  INTEGER,PARAMETER :: type_logical=3
12
13  TYPE t_field
14     CHARACTER(30)      :: name
15     LOGICAL :: ondevice !< flag if field is allocated on device as well
16     INTEGER :: ndim
17     INTEGER :: field_type
18     INTEGER :: data_type
19     INTEGER :: dim3
20     INTEGER :: dim4
21     REAL(rstd), POINTER, CONTIGUOUS :: rval2d(:) => NULL()
22     REAL(rstd), POINTER, CONTIGUOUS :: rval3d(:,:) => NULL()
23     REAL(rstd), POINTER, CONTIGUOUS :: rval4d(:,:,:) => NULL()
24     INTEGER, POINTER, CONTIGUOUS :: ival2d(:) => NULL()
25     INTEGER, POINTER, CONTIGUOUS :: ival3d(:,:) => NULL()
26     INTEGER, POINTER, CONTIGUOUS :: ival4d(:,:,:) => NULL()
27     LOGICAL, POINTER, CONTIGUOUS :: lval2d(:) => NULL()
28     LOGICAL, POINTER, CONTIGUOUS :: lval3d(:,:) => NULL()
29     LOGICAL, POINTER, CONTIGUOUS :: lval4d(:,:,:) => NULL()
30  END TYPE t_field
31
32  INTERFACE get_val
33     MODULE PROCEDURE getval_r2d
34     MODULE PROCEDURE getval_r3d
35     MODULE PROCEDURE getval_r4d
36     MODULE PROCEDURE getval_i2d
37     MODULE PROCEDURE getval_i3d
38     MODULE PROCEDURE getval_i4d
39     MODULE PROCEDURE getval_l2d
40     MODULE PROCEDURE getval_l3d
41     MODULE PROCEDURE getval_l4d
42  END INTERFACE
43
44  INTERFACE ASSIGNMENT(=)
45     MODULE PROCEDURE getval_r2d
46     MODULE PROCEDURE getval_r3d
47     MODULE PROCEDURE getval_r4d
48     MODULE PROCEDURE getval_i2d
49     MODULE PROCEDURE getval_i3d
50     MODULE PROCEDURE getval_i4d
51     MODULE PROCEDURE getval_l2d
52     MODULE PROCEDURE getval_l3d
53     MODULE PROCEDURE getval_l4d
54  END INTERFACE
55
56  PRIVATE :: allocate_field_, deallocate_field_
57
58CONTAINS
59
60  !====================================== allocate_field ===================================
61
62  SUBROUTINE allocate_field_glo(field,field_type,data_type,dim1,dim2,name)
63    USE domain_mod
64    TYPE(t_field),POINTER :: field(:)
65    INTEGER,INTENT(IN) :: field_type
66    INTEGER,INTENT(IN) :: data_type
67    INTEGER,OPTIONAL :: dim1,dim2
68    CHARACTER(*), OPTIONAL :: name
69    INTEGER :: ind
70
71    ALLOCATE(field(ndomain_glo))
72    DO ind=1,ndomain_glo
73       CALL allocate_field_(domain_glo(ind), field(ind), field_type, data_type, dim1, dim2, name)
74    ENDDO
75
76  END SUBROUTINE allocate_field_glo
77
78  SUBROUTINE allocate_field(field, field_type, data_type, dim3, dim4, name, ondevice)
79    USE domain_mod
80    USE omp_para
81    TYPE(t_field), POINTER :: field(:)
82    INTEGER, INTENT(IN)    :: field_type
83    INTEGER, INTENT(IN)    :: data_type
84    INTEGER, OPTIONAL      :: dim3,dim4
85    CHARACTER(*), OPTIONAL :: name
86    LOGICAL, INTENT(IN), OPTIONAL :: ondevice
87    INTEGER :: ind
88    !$OMP BARRIER
89    !$OMP MASTER
90    ALLOCATE(field(ndomain))
91    !$OMP END MASTER
92    !$OMP BARRIER
93
94    DO ind=1,ndomain
95       IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
96       CALL allocate_field_(domain(ind), field(ind), field_type, data_type, dim3, dim4, name, ondevice)
97    END DO
98    !$OMP BARRIER
99
100  END SUBROUTINE allocate_field
101
102  SUBROUTINE allocate_fields(nfield,field,field_type,data_type,dim3,dim4,name, ondevice)
103    USE domain_mod
104    USE omp_para
105    INTEGER, INTENT(IN)     :: nfield
106    TYPE(t_field), POINTER  :: field(:,:)
107    INTEGER, INTENT(IN)     :: field_type
108    INTEGER, INTENT(IN)     :: data_type
109    INTEGER, OPTIONAL       :: dim3,dim4
110    CHARACTER(*), OPTIONAL  :: name
111    LOGICAL, INTENT(IN), OPTIONAL :: ondevice
112    INTEGER :: i, ind
113    !$OMP BARRIER
114    !$OMP MASTER
115    ALLOCATE(field(ndomain,nfield))
116    !$OMP END MASTER
117    !$OMP BARRIER
118    DO ind=1,ndomain
119       IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
120       DO i=1,nfield
121          CALL allocate_field_(domain(ind), field(ind,i),field_type, data_type, dim3, dim4, name, ondevice)
122       END DO
123    END DO
124    !$OMP BARRIER
125
126  END SUBROUTINE allocate_fields
127
128  SUBROUTINE allocate_field_(dom, field, field_type, data_type, dim3, dim4, name, ondevice)
129    USE domain_mod
130    USE omp_para
131    TYPE(t_domain)         :: dom
132    TYPE(t_field)          :: field
133    INTEGER, INTENT(IN)    :: field_type
134    INTEGER, INTENT(IN)    :: data_type
135    INTEGER, OPTIONAL      :: dim3,dim4
136    CHARACTER(*), OPTIONAL :: name
137    LOGICAL, INTENT(IN), OPTIONAL :: ondevice
138
139    INTEGER :: ij_size
140
141    IF(PRESENT(name)) THEN
142       field%name = name
143    ELSE
144       field%name = '(undefined)'
145    END IF
146
147    IF (PRESENT(dim4)) THEN
148       field%ndim=4
149       field%dim4=dim4
150       field%dim3=dim3
151    ELSE IF (PRESENT(dim3)) THEN
152       field%ndim=3
153       field%dim3=dim3
154       field%dim4=1
155    ELSE
156       field%ndim=2
157       field%dim3=1
158       field%dim4=1
159    ENDIF
160
161
162    field%data_type=data_type
163    field%field_type=field_type
164
165    IF (field_type==field_T) THEN
166       ij_size=dom%iim*dom%jjm
167    ELSE IF (field_type==field_U) THEN
168       ij_size=3*dom%iim*dom%jjm
169    ELSE IF (field_type==field_Z) THEN
170       ij_size=2*dom%iim*dom%jjm
171    ENDIF
172
173    IF (data_type==type_integer) ALLOCATE(field%ival4d(ij_size, field%dim3, field%dim4))
174    IF (data_type==type_real)    ALLOCATE(field%rval4d(ij_size, field%dim3, field%dim4))
175    IF (data_type==type_logical) ALLOCATE(field%lval4d(ij_size, field%dim3, field%dim4))
176
177    IF (field%ndim==3) THEN
178       IF (data_type==type_integer) field%ival3d => field%ival4d(:,:,1)
179       IF (data_type==type_real)    field%rval3d => field%rval4d(:,:,1)
180       IF (data_type==type_logical) field%lval3d => field%lval4d(:,:,1)
181
182    ELSE IF (field%ndim==2) THEN
183       IF (data_type==type_integer) field%ival2d => field%ival4d(:,1,1)
184       IF (data_type==type_real)    field%rval2d => field%rval4d(:,1,1)
185       IF (data_type==type_logical) field%lval2d => field%lval4d(:,1,1)
186
187    ENDIF
188
189    field%ondevice = .FALSE.
190    IF (PRESENT(ondevice)) THEN
191       IF (ondevice) CALL create_device_field(field)
192    END IF
193
194  END SUBROUTINE allocate_field_
195
196  !==================================== deallocate_field ===================================
197
198  SUBROUTINE deallocate_field_glo(field)
199    USE domain_mod
200    TYPE(t_field),POINTER :: field(:)
201    INTEGER :: ind
202    DO ind=1,ndomain_glo
203       CALL deallocate_field_(field(ind))
204    END DO
205    DEALLOCATE(field)
206  END SUBROUTINE deallocate_field_glo
207
208  SUBROUTINE deallocate_field(field)
209    USE domain_mod
210    USE omp_para
211    TYPE(t_field),POINTER :: field(:)
212    INTEGER :: ind
213    !$OMP BARRIER
214    DO ind=1,ndomain
215       IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
216       CALL deallocate_field_(field(ind))
217    END DO
218    !$OMP BARRIER
219    !$OMP MASTER
220    DEALLOCATE(field)
221    !$OMP END MASTER
222    !$OMP BARRIER
223  END SUBROUTINE deallocate_field
224
225  SUBROUTINE deallocate_fields(field)
226    USE domain_mod
227    USE omp_para
228    TYPE(t_field),POINTER :: field(:,:)
229    INTEGER :: i, ind
230    !$OMP BARRIER
231    DO ind=1,ndomain
232       IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
233       DO i=1,SIZE(field,2)
234          CALL deallocate_field_(field(ind,i))
235       END DO
236    END DO
237    !$OMP BARRIER
238    !$OMP MASTER
239    DEALLOCATE(field)
240    !$OMP END MASTER
241    !$OMP BARRIER
242  END SUBROUTINE deallocate_fields
243
244  SUBROUTINE deallocate_field_(field)
245    USE domain_mod
246    USE omp_para
247    TYPE(t_field) :: field
248    INTEGER :: data_type
249    data_type=field%data_type
250    IF (data_type==type_real) THEN
251       IF (field%ondevice) THEN
252          !$acc exit data delete(field%rval4d(:,:,:))
253          CONTINUE
254       END IF
255       DEALLOCATE(field%rval4d)
256    END IF
257    IF (data_type==type_integer) THEN
258       IF (field%ondevice) THEN
259          !$acc exit data delete(field%ival4d(:,:,:))
260          CONTINUE
261       END IF
262       DEALLOCATE(field%ival4d)
263    END IF
264    IF (data_type==type_logical) THEN
265       IF (field%ondevice) THEN
266          !$acc exit data delete(field%lval4d(:,:,:))
267          CONTINUE
268       END IF
269       DEALLOCATE(field%lval4d)
270    END IF
271
272  END SUBROUTINE deallocate_field_
273
274  !====================================== getval ===================================
275
276  SUBROUTINE getval_r2d(field_pt,field)
277    REAL(rstd), POINTER, INTENT(INOUT) :: field_pt(:)
278    TYPE(t_field),INTENT(IN) :: field
279
280    IF (field%ndim/=2 .OR. field%data_type/=type_real) THEN
281       PRINT *, 'getval_r2d : bad pointer assignment with ' // TRIM(field%name)
282       STOP
283    END IF
284    field_pt=>field%rval2d
285  END SUBROUTINE getval_r2d
286
287  SUBROUTINE getval_r3d(field_pt,field)
288    REAL(rstd), POINTER, INTENT(INOUT) :: field_pt(:,:)
289    TYPE(t_field),INTENT(IN) :: field
290
291    IF (field%ndim/=3 .OR. field%data_type/=type_real) THEN
292       PRINT *, 'getval_r3d : bad pointer assignment with ' // TRIM(field%name)
293       STOP
294    END IF
295    field_pt=>field%rval3d
296  END SUBROUTINE getval_r3d
297
298  SUBROUTINE getval_r4d(field_pt,field)
299    REAL(rstd), POINTER, INTENT(INOUT) :: field_pt(:,:,:)
300    TYPE(t_field),INTENT(IN) :: field
301
302    IF (field%ndim/=4 .OR. field%data_type/=type_real) THEN
303       PRINT *, 'getval_r4d : bad pointer assignment with ' // TRIM(field%name)
304       STOP
305    END IF
306    field_pt=>field%rval4d
307  END SUBROUTINE getval_r4d
308
309  SUBROUTINE getval_i2d(field_pt,field)
310    INTEGER, POINTER, INTENT(INOUT) :: field_pt(:)
311    TYPE(t_field),INTENT(IN) :: field
312
313    IF (field%ndim/=2 .OR. field%data_type/=type_integer) THEN
314       PRINT *, 'getval_i2d : bad pointer assignment with ' // TRIM(field%name)
315       STOP
316    END IF
317    field_pt=>field%ival2d
318  END SUBROUTINE getval_i2d
319
320  SUBROUTINE getval_i3d(field_pt,field)
321    INTEGER, POINTER, INTENT(INOUT) :: field_pt(:,:)
322    TYPE(t_field),INTENT(IN) :: field
323
324    IF (field%ndim/=3 .OR. field%data_type/=type_integer) THEN
325       PRINT *, 'getval_i3d : bad pointer assignment with ' // TRIM(field%name)
326       STOP
327    END IF
328    field_pt=>field%ival3d
329  END SUBROUTINE getval_i3d
330
331  SUBROUTINE getval_i4d(field_pt,field)
332    INTEGER, POINTER, INTENT(INOUT) :: field_pt(:,:,:)
333    TYPE(t_field),INTENT(IN) :: field
334
335    IF (field%ndim/=4 .OR. field%data_type/=type_integer) THEN
336       PRINT *, 'getval_i4d : bad pointer assignment with ' // TRIM(field%name)
337       STOP
338    END IF
339    field_pt=>field%ival4d
340  END SUBROUTINE getval_i4d
341
342  SUBROUTINE getval_l2d(field_pt,field)
343    LOGICAL, POINTER, INTENT(INOUT) :: field_pt(:)
344    TYPE(t_field),INTENT(IN) :: field
345
346    IF (field%ndim/=2 .OR. field%data_type/=type_logical) THEN
347       PRINT *, 'getval_l2d : bad pointer assignment with ' // TRIM(field%name)
348       STOP
349    END IF
350    field_pt=>field%lval2d
351  END SUBROUTINE getval_l2d
352
353  SUBROUTINE getval_l3d(field_pt,field)
354    LOGICAL, POINTER, INTENT(INOUT) :: field_pt(:,:)
355    TYPE(t_field),INTENT(IN) :: field
356
357    IF (field%ndim/=3 .OR. field%data_type/=type_logical) THEN
358       PRINT *, 'getval_l3d : bad pointer assignment with ' // TRIM(field%name)
359       STOP
360    END IF
361    field_pt=>field%lval3d
362  END SUBROUTINE getval_l3d
363
364  SUBROUTINE getval_l4d(field_pt,field)
365    LOGICAL, POINTER, INTENT(INOUT) :: field_pt(:,:,:)
366    TYPE(t_field),INTENT(IN) :: field
367
368    IF (field%ndim/=4 .OR. field%data_type/=type_logical) THEN
369       PRINT *, 'getval_l4d : bad pointer assignment with ' // TRIM(field%name)
370       STOP
371    END IF
372    field_pt=>field%lval4d
373  END SUBROUTINE getval_l4d
374
375  !===================== Data transfer between host (CPU) and device (GPU) =========================
376
377  SUBROUTINE update_device_field(field)
378    USE domain_mod
379    USE omp_para
380    TYPE(t_field) :: field(:)
381    INTEGER :: ind
382
383    DO ind=1,ndomain
384       IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
385
386       IF (.NOT. field(ind)%ondevice) CALL create_device_field(field(ind))
387       IF (field(ind)%data_type==type_real) THEN
388          !$acc update device(field(ind)%rval4d(:,:,:)) async
389          CONTINUE
390       END IF
391       IF (field(ind)%data_type==type_integer) THEN
392          !$acc update device(field(ind)%ival4d(:,:,:)) async
393          CONTINUE
394       END IF
395       IF (field(ind)%data_type==type_logical) THEN
396          !$acc update device(field(ind)%lval4d(:,:,:)) async
397          CONTINUE
398       END IF
399
400    ENDDO
401    !$OMP BARRIER
402  END SUBROUTINE update_device_field
403
404  SUBROUTINE update_host_field(field)
405    USE domain_mod
406    USE omp_para
407    TYPE(t_field) :: field(:)
408    INTEGER :: ind
409
410    DO ind=1,ndomain
411       IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
412
413       IF (field(ind)%ondevice) THEN
414          IF (field(ind)%data_type==type_real) THEN
415             !$acc update host(field(ind)%rval4d(:,:,:)) async
416             CONTINUE
417          END IF
418          IF (field(ind)%data_type==type_integer) THEN
419             !$acc update host(field(ind)%ival4d(:,:,:)) async
420             CONTINUE
421          END IF
422          IF (field(ind)%data_type==type_logical) THEN
423             !$acc update host(field(ind)%lval4d(:,:,:)) async
424             CONTINUE
425          END IF
426
427       END IF
428    ENDDO
429    !$acc wait
430    !$OMP BARRIER
431  END SUBROUTINE update_host_field
432
433  SUBROUTINE create_device_field(field)
434    TYPE(t_field) :: field
435
436    IF (field%ondevice) THEN
437       PRINT *, "Field is already on device !"
438       STOP 1
439    END IF
440    IF (field%data_type==type_real) THEN
441       !$acc enter data create(field%rval4d(:,:,:)) async
442    END IF
443    IF (field%data_type==type_integer) THEN
444       !$acc enter data create(field%ival4d(:,:,:)) async
445    END IF
446    IF (field%data_type==type_logical) THEN
447       !$acc enter data create(field%lval4d(:,:,:)) async
448    END IF
449
450    field%ondevice = .TRUE.
451  END SUBROUTINE create_device_field
452
453END MODULE field_mod
Note: See TracBrowser for help on using the repository browser.