source: codes/icosagcm/trunk/jsrc/base/field.f90 @ 1055

Last change on this file since 1055 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: 9.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  {%- set ranks = ( (2,':'), (3,':,:'), (4,':,:,:') ) %}
14  {%- set types = ( ('r','real','REAL(rstd)'), ('i','integer','INTEGER'), ('l','logical','LOGICAL') ) %}
15 
16  TYPE t_field
17     CHARACTER(30)      :: name
18     LOGICAL :: ondevice !< flag if field is allocated on device as well
19     INTEGER :: ndim
20     INTEGER :: field_type
21     INTEGER :: data_type
22     INTEGER :: dim3
23     INTEGER :: dim4
24
25     {%- for tn, tln, tp in types %} {%- for rk, shp in ranks %}     
26     {{tp}}, POINTER, CONTIGUOUS :: {{tn}}val{{rk}}d({{shp}}) => NULL()
27     {%- endfor %} {%- endfor %}
28  END TYPE t_field
29
30  INTERFACE get_val
31     {%- for tn, tln, tp in types %} {%- for rk, shp in ranks %}     
32     MODULE PROCEDURE getval_{{tn}}{{rk}}d
33     {%- endfor %} {%- endfor %}
34  END INTERFACE
35
36  INTERFACE ASSIGNMENT(=)
37     {%- for tn, tln, tp in types %} {%- for rk, shp in ranks %}     
38     MODULE PROCEDURE getval_{{tn}}{{rk}}d
39     {%- endfor %} {%- endfor %}
40  END INTERFACE
41 
42  PRIVATE :: allocate_field_, deallocate_field_
43
44CONTAINS
45
46  !====================================== allocate_field ===================================
47
48  SUBROUTINE allocate_field_glo(field,field_type,data_type,dim1,dim2,name)
49    USE domain_mod
50    TYPE(t_field),POINTER :: field(:)
51    INTEGER,INTENT(IN) :: field_type
52    INTEGER,INTENT(IN) :: data_type
53    INTEGER,OPTIONAL :: dim1,dim2
54    CHARACTER(*), OPTIONAL :: name
55    INTEGER :: ind
56
57    ALLOCATE(field(ndomain_glo))
58    DO ind=1,ndomain_glo
59       CALL allocate_field_(domain_glo(ind), field(ind), field_type, data_type, dim1, dim2, name)
60    ENDDO
61
62  END SUBROUTINE allocate_field_glo
63
64  SUBROUTINE allocate_field(field, field_type, data_type, dim3, dim4, name, ondevice)
65    USE domain_mod
66    USE omp_para
67    TYPE(t_field), POINTER :: field(:)
68    INTEGER, INTENT(IN)    :: field_type
69    INTEGER, INTENT(IN)    :: data_type
70    INTEGER, OPTIONAL      :: dim3,dim4
71    CHARACTER(*), OPTIONAL :: name
72    LOGICAL, INTENT(IN), OPTIONAL :: ondevice
73    INTEGER :: ind
74    !$OMP BARRIER
75    !$OMP MASTER
76    ALLOCATE(field(ndomain))
77    !$OMP END MASTER
78    !$OMP BARRIER
79
80    DO ind=1,ndomain
81       IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
82       CALL allocate_field_(domain(ind), field(ind), field_type, data_type, dim3, dim4, name, ondevice)
83    END DO
84    !$OMP BARRIER
85
86  END SUBROUTINE allocate_field
87
88  SUBROUTINE allocate_fields(nfield,field,field_type,data_type,dim3,dim4,name, ondevice)
89    USE domain_mod
90    USE omp_para
91    INTEGER, INTENT(IN)     :: nfield
92    TYPE(t_field), POINTER  :: field(:,:)
93    INTEGER, INTENT(IN)     :: field_type
94    INTEGER, INTENT(IN)     :: data_type
95    INTEGER, OPTIONAL       :: dim3,dim4
96    CHARACTER(*), OPTIONAL  :: name
97    LOGICAL, INTENT(IN), OPTIONAL :: ondevice
98    INTEGER :: i, ind
99    !$OMP BARRIER
100    !$OMP MASTER
101    ALLOCATE(field(ndomain,nfield))
102    !$OMP END MASTER
103    !$OMP BARRIER
104    DO ind=1,ndomain
105       IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
106       DO i=1,nfield
107          CALL allocate_field_(domain(ind), field(ind,i),field_type, data_type, dim3, dim4, name, ondevice)
108       END DO
109    END DO
110    !$OMP BARRIER
111
112  END SUBROUTINE allocate_fields
113
114  SUBROUTINE allocate_field_(dom, field, field_type, data_type, dim3, dim4, name, ondevice)
115    USE domain_mod
116    USE omp_para
117    TYPE(t_domain)         :: dom
118    TYPE(t_field)          :: field
119    INTEGER, INTENT(IN)    :: field_type
120    INTEGER, INTENT(IN)    :: data_type
121    INTEGER, OPTIONAL      :: dim3,dim4
122    CHARACTER(*), OPTIONAL :: name
123    LOGICAL, INTENT(IN), OPTIONAL :: ondevice
124
125    INTEGER :: ij_size
126
127    IF(PRESENT(name)) THEN
128       field%name = name
129    ELSE
130       field%name = '(undefined)'
131    END IF
132
133    IF (PRESENT(dim4)) THEN
134       field%ndim=4
135       field%dim4=dim4
136       field%dim3=dim3
137    ELSE IF (PRESENT(dim3)) THEN
138       field%ndim=3
139       field%dim3=dim3
140       field%dim4=1
141    ELSE
142       field%ndim=2
143       field%dim3=1
144       field%dim4=1
145    ENDIF
146
147
148    field%data_type=data_type
149    field%field_type=field_type
150
151    IF (field_type==field_T) THEN
152       ij_size=dom%iim*dom%jjm
153    ELSE IF (field_type==field_U) THEN
154       ij_size=3*dom%iim*dom%jjm
155    ELSE IF (field_type==field_Z) THEN
156       ij_size=2*dom%iim*dom%jjm
157    ENDIF
158
159    IF (data_type==type_integer) ALLOCATE(field%ival4d(ij_size, field%dim3, field%dim4))
160    IF (data_type==type_real)    ALLOCATE(field%rval4d(ij_size, field%dim3, field%dim4))
161    IF (data_type==type_logical) ALLOCATE(field%lval4d(ij_size, field%dim3, field%dim4))
162
163    IF (field%ndim==3) THEN
164       IF (data_type==type_integer) field%ival3d => field%ival4d(:,:,1)
165       IF (data_type==type_real)    field%rval3d => field%rval4d(:,:,1)
166       IF (data_type==type_logical) field%lval3d => field%lval4d(:,:,1)
167
168    ELSE IF (field%ndim==2) THEN
169       IF (data_type==type_integer) field%ival2d => field%ival4d(:,1,1)
170       IF (data_type==type_real)    field%rval2d => field%rval4d(:,1,1)
171       IF (data_type==type_logical) field%lval2d => field%lval4d(:,1,1)
172
173    ENDIF
174
175    field%ondevice = .FALSE.
176    IF (PRESENT(ondevice)) THEN
177       IF (ondevice) CALL create_device_field(field)
178    END IF
179
180  END SUBROUTINE allocate_field_
181
182  !==================================== deallocate_field ===================================
183
184  SUBROUTINE deallocate_field_glo(field)
185    USE domain_mod
186    TYPE(t_field),POINTER :: field(:)
187    INTEGER :: ind
188    DO ind=1,ndomain_glo
189       CALL deallocate_field_(field(ind))
190    END DO
191    DEALLOCATE(field)
192  END SUBROUTINE deallocate_field_glo
193
194  SUBROUTINE deallocate_field(field)
195    USE domain_mod
196    USE omp_para
197    TYPE(t_field),POINTER :: field(:)
198    INTEGER :: ind
199    !$OMP BARRIER
200    DO ind=1,ndomain
201       IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
202       CALL deallocate_field_(field(ind))
203    END DO
204    !$OMP BARRIER
205    !$OMP MASTER
206    DEALLOCATE(field)
207    !$OMP END MASTER
208    !$OMP BARRIER
209  END SUBROUTINE deallocate_field
210
211  SUBROUTINE deallocate_fields(field)
212    USE domain_mod
213    USE omp_para
214    TYPE(t_field),POINTER :: field(:,:)
215    INTEGER :: i, ind
216    !$OMP BARRIER
217    DO ind=1,ndomain
218       IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
219       DO i=1,SIZE(field,2)
220          CALL deallocate_field_(field(ind,i))
221       END DO
222    END DO
223    !$OMP BARRIER
224    !$OMP MASTER
225    DEALLOCATE(field)
226    !$OMP END MASTER
227    !$OMP BARRIER
228  END SUBROUTINE deallocate_fields
229
230  SUBROUTINE deallocate_field_(field)
231    USE domain_mod
232    USE omp_para
233    TYPE(t_field) :: field
234    INTEGER :: data_type
235    data_type=field%data_type
236
237    {%- for tn, tln, tp in types %}
238    IF (data_type==type_{{tln}}) THEN
239       IF (field%ondevice) THEN
240          !$acc exit data delete(field%{{tn}}val4d(:,:,:))
241          CONTINUE
242       END IF
243       DEALLOCATE(field%{{tn}}val4d)
244    END IF
245    {%- endfor %}
246
247  END SUBROUTINE deallocate_field_
248
249  !====================================== getval ===================================
250
251  {%- for tn, tln, tp in types %} {%- for rk, shp in ranks %}
252
253  SUBROUTINE getval_{{tn}}{{rk}}d(field_pt,field)
254    {{tp}}, POINTER, INTENT(INOUT) :: field_pt({{shp}})
255    TYPE(t_field),INTENT(IN) :: field
256
257    IF (field%ndim/={{rk}} .OR. field%data_type/=type_{{tln}}) THEN
258       PRINT *, 'getval_{{tn}}{{rk}}d : bad pointer assignment with ' // TRIM(field%name)
259       STOP
260    END IF
261    field_pt=>field%{{tn}}val{{rk}}d
262  END SUBROUTINE getval_{{tn}}{{rk}}d
263
264  {%- endfor %} {%- endfor %}
265
266  !===================== Data transfer between host (CPU) and device (GPU) =========================
267
268  SUBROUTINE update_device_field(field)
269    USE domain_mod
270    USE omp_para
271    TYPE(t_field) :: field(:)
272    INTEGER :: ind
273
274    DO ind=1,ndomain
275       IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
276
277       IF (.NOT. field(ind)%ondevice) CALL create_device_field(field(ind))
278
279       {%- for tn, tln, tp in types %}
280       IF (field(ind)%data_type==type_{{tln}}) THEN
281          !$acc update device(field(ind)%{{tn}}val4d(:,:,:)) async
282          CONTINUE
283       END IF
284       {%- endfor %}
285
286    ENDDO
287    !$OMP BARRIER
288  END SUBROUTINE update_device_field
289
290  SUBROUTINE update_host_field(field)
291    USE domain_mod
292    USE omp_para
293    TYPE(t_field) :: field(:)
294    INTEGER :: ind
295
296    DO ind=1,ndomain
297       IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
298
299       IF (field(ind)%ondevice) THEN
300         
301          {%- for tn, tln, tp in types %}
302          IF (field(ind)%data_type==type_{{tln}}) THEN
303             !$acc update host(field(ind)%{{tn}}val4d(:,:,:)) async
304             CONTINUE
305          END IF
306          {%- endfor %}
307         
308       END IF
309    ENDDO
310    !$acc wait
311    !$OMP BARRIER
312  END SUBROUTINE update_host_field
313
314  SUBROUTINE create_device_field(field)
315    TYPE(t_field) :: field
316
317    IF (field%ondevice) THEN
318       PRINT *, "Field is already on device !"
319       STOP 1
320    END IF
321   
322    {%- for tn, tln, tp in types %}
323    IF (field%data_type==type_{{tln}}) THEN
324       !$acc enter data create(field%{{tn}}val4d(:,:,:)) async
325    END IF
326    {%- endfor %}
327   
328    field%ondevice = .TRUE.
329  END SUBROUTINE create_device_field
330
331END MODULE field_mod
Note: See TracBrowser for help on using the repository browser.