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

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

trunk : simplify allocate_field -- tested on 4 GPUs (TBC)
File size: 20.4 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
16    REAL(rstd),POINTER, CONTIGUOUS :: rval2d(:) => null()
17    REAL(rstd),POINTER, CONTIGUOUS :: rval3d(:,:) => null()
18    REAL(rstd),POINTER, CONTIGUOUS :: rval4d(:,:,:) => null()
19
20    INTEGER,POINTER :: ival2d(:)
21    INTEGER,POINTER :: ival3d(:,:)
22    INTEGER,POINTER :: ival4d(:,:,:)
23   
24    LOGICAL,POINTER :: lval2d(:)
25    LOGICAL,POINTER :: lval3d(:,:)
26    LOGICAL,POINTER :: lval4d(:,:,:)
27
28    INTEGER :: ndim
29    INTEGER :: field_type
30    INTEGER :: data_type 
31    INTEGER :: dim3
32    INTEGER :: dim4
33   
34    LOGICAL :: ondevice !< flag if field is allocated on device as well
35  END TYPE t_field   
36
37  INTERFACE get_val
38    MODULE PROCEDURE getval_r2d,getval_r3d,getval_r4d, &
39                     getval_i2d,getval_i3d,getval_i4d, &
40                     getval_l2d,getval_l3d,getval_l4d
41  END INTERFACE
42                   
43  INTERFACE ASSIGNMENT(=)
44    MODULE PROCEDURE getval_r2d,getval_r3d,getval_r4d, &
45                     getval_i2d,getval_i3d,getval_i4d, &
46                     getval_l2d,getval_l3d,getval_l4d 
47  END INTERFACE
48
49  PRIVATE :: allocate_field_
50
51CONTAINS
52
53  SUBROUTINE allocate_field(field,field_type,data_type,dim1,dim2,name,ondevice)
54  USE domain_mod
55  USE omp_para
56    TYPE(t_field),POINTER :: field(:)
57    INTEGER,INTENT(IN) :: field_type
58    INTEGER,INTENT(IN) :: data_type
59    INTEGER,OPTIONAL :: dim1,dim2
60    CHARACTER(*), OPTIONAL :: name
61    LOGICAL, INTENT(IN), OPTIONAL :: ondevice 
62!$OMP BARRIER
63!$OMP MASTER
64    ALLOCATE(field(ndomain))   
65!$OMP END MASTER
66!$OMP BARRIER
67
68    CALL allocate_field_(field,field_type,data_type,dim1,dim2,name,ondevice)
69   
70  END SUBROUTINE allocate_field
71
72  SUBROUTINE allocate_fields(nfield,field,field_type,data_type,dim1,dim2,name, ondevice)
73  USE domain_mod
74  USE omp_para
75    INTEGER,INTENT(IN) :: nfield
76    TYPE(t_field),POINTER :: field(:,:)
77    INTEGER,INTENT(IN) :: field_type
78    INTEGER,INTENT(IN) :: data_type
79    INTEGER,OPTIONAL :: dim1,dim2
80    CHARACTER(*), OPTIONAL :: name
81    LOGICAL, INTENT(IN), OPTIONAL :: ondevice
82    INTEGER :: i
83!$OMP BARRIER
84!$OMP MASTER
85    ALLOCATE(field(ndomain,nfield))
86!$OMP END MASTER
87!$OMP BARRIER
88    DO i=1,nfield
89       CALL allocate_field_(field(:,i),field_type,data_type,dim1,dim2,name,ondevice)
90    END DO
91  END SUBROUTINE allocate_fields
92
93  SUBROUTINE allocate_field_(field,field_type,data_type,dim3,dim4,name,ondevice)
94  USE domain_mod
95  USE omp_para
96  IMPLICIT NONE
97    TYPE(t_field) :: field(:)
98    INTEGER,INTENT(IN) :: field_type
99    INTEGER,INTENT(IN) :: data_type
100    INTEGER,OPTIONAL :: dim3,dim4
101    CHARACTER(*), OPTIONAL :: name
102    LOGICAL, INTENT(IN), OPTIONAL :: ondevice
103    INTEGER :: ind
104    INTEGER :: ij_size
105
106    DO ind=1,ndomain
107      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
108
109      IF(PRESENT(name)) THEN
110         field(ind)%name = name
111      ELSE
112         field(ind)%name = '(undefined)'
113      END IF
114
115      IF (PRESENT(dim4)) THEN
116        field(ind)%ndim=4 
117        field(ind)%dim4=dim4 
118        field(ind)%dim3=dim3
119      ELSE IF (PRESENT(dim3)) THEN
120        field(ind)%ndim=3
121        field(ind)%dim3=dim3
122        field(ind)%dim4=1
123      ELSE
124        field(ind)%ndim=2
125        field(ind)%dim3=1
126        field(ind)%dim4=1
127      ENDIF
128   
129   
130      field(ind)%data_type=data_type
131      field(ind)%field_type=field_type
132
133      IF (field_type==field_T) THEN
134         ij_size=domain(ind)%iim*domain(ind)%jjm
135      ELSE IF (field_type==field_U) THEN
136         ij_size=3*domain(ind)%iim*domain(ind)%jjm
137      ELSE IF (field_type==field_Z) THEN
138         ij_size=2*domain(ind)%iim*domain(ind)%jjm
139      ENDIF
140     
141      IF (data_type==type_integer) ALLOCATE(field(ind)%ival4d(ij_size, field(ind)%dim3, field(ind)%dim4))
142      IF (data_type==type_real)    ALLOCATE(field(ind)%rval4d(ij_size, field(ind)%dim3, field(ind)%dim4))
143      IF (data_type==type_logical) ALLOCATE(field(ind)%lval4d(ij_size, field(ind)%dim3, field(ind)%dim4))
144
145      IF (field(ind)%ndim==3) THEN
146         IF (data_type==type_integer) field(ind)%ival3d => field(ind)%ival4d(:,:,1)
147         IF (data_type==type_real)    field(ind)%rval3d => field(ind)%rval4d(:,:,1)
148         IF (data_type==type_logical) field(ind)%lval3d => field(ind)%lval4d(:,:,1)
149
150      ELSE IF (field(ind)%ndim==2) THEN
151         IF (data_type==type_integer) field(ind)%ival2d => field(ind)%ival4d(:,1,1)
152         IF (data_type==type_real)    field(ind)%rval2d => field(ind)%rval4d(:,1,1)
153         IF (data_type==type_logical) field(ind)%lval2d => field(ind)%lval4d(:,1,1)
154
155      ENDIF
156
157      field(ind)%ondevice = .FALSE.
158      IF (PRESENT(ondevice)) THEN
159         IF (ondevice) CALL create_device_field(field(ind))
160      END IF
161   
162   ENDDO
163!$OMP BARRIER
164   
165 END SUBROUTINE allocate_field_
166
167  SUBROUTINE allocate_field_glo(field,field_type,data_type,dim1,dim2,name)
168  USE domain_mod
169  IMPLICIT NONE
170    TYPE(t_field),POINTER :: field(:)
171    INTEGER,INTENT(IN) :: field_type
172    INTEGER,INTENT(IN) :: data_type
173    INTEGER,OPTIONAL :: dim1,dim2
174    CHARACTER(*), OPTIONAL :: name
175    INTEGER :: ind
176    INTEGER :: ii_size,jj_size
177
178    ALLOCATE(field(ndomain_glo)) 
179
180    DO ind=1,ndomain_glo
181 
182      IF (PRESENT(dim2)) THEN
183        field(ind)%ndim=4 
184        field(ind)%dim4=dim2 
185        field(ind)%dim3=dim1 
186      ELSE IF (PRESENT(dim1)) THEN
187        field(ind)%ndim=3
188        field(ind)%dim3=dim1 
189      ELSE
190        field(ind)%ndim=2
191      ENDIF
192   
193      IF(PRESENT(name)) THEN
194         field(ind)%name = name
195      ELSE
196         field(ind)%name = '(undefined)'
197      END IF
198   
199      field(ind)%data_type=data_type
200      field(ind)%field_type=field_type
201   
202      field(ind)%ondevice = .FALSE.
203
204      IF (field_type==field_T) THEN
205        jj_size=domain_glo(ind)%jjm
206      ELSE IF (field_type==field_U) THEN
207        jj_size=3*domain_glo(ind)%jjm
208      ELSE IF (field_type==field_Z) THEN
209        jj_size=2*domain_glo(ind)%jjm
210      ENDIF
211     
212      ii_size=domain_glo(ind)%iim
213       
214      IF (field(ind)%ndim==4) THEN
215        IF (data_type==type_integer) ALLOCATE(field(ind)%ival4d(ii_size*jj_size,dim1,dim2))
216        IF (data_type==type_real)    ALLOCATE(field(ind)%rval4d(ii_size*jj_size,dim1,dim2))
217        IF (data_type==type_logical) ALLOCATE(field(ind)%lval4d(ii_size*jj_size,dim1,dim2))
218      ELSE IF (field(ind)%ndim==3) THEN
219        IF (data_type==type_integer) ALLOCATE(field(ind)%ival3d(ii_size*jj_size,dim1))
220        IF (data_type==type_real)    ALLOCATE(field(ind)%rval3d(ii_size*jj_size,dim1))
221        IF (data_type==type_logical) ALLOCATE(field(ind)%lval3d(ii_size*jj_size,dim1))
222      ELSE IF (field(ind)%ndim==2) THEN
223        IF (data_type==type_integer) ALLOCATE(field(ind)%ival2d(ii_size*jj_size))
224        IF (data_type==type_real)    ALLOCATE(field(ind)%rval2d(ii_size*jj_size))
225        IF (data_type==type_logical) ALLOCATE(field(ind)%lval2d(ii_size*jj_size))
226      ENDIF
227     
228   ENDDO
229 
230  END SUBROUTINE allocate_field_glo
231
232  SUBROUTINE deallocate_field(field)
233    USE domain_mod
234    USE omp_para
235    IMPLICIT NONE
236    TYPE(t_field),POINTER :: field(:)
237    !$OMP BARRIER
238    CALL deallocate_field_(field)
239    !$OMP BARRIER
240    !$OMP MASTER
241    DEALLOCATE(field)
242    !$OMP END MASTER
243    !$OMP BARRIER
244  END SUBROUTINE deallocate_field
245 
246  SUBROUTINE deallocate_fields(field)
247    USE domain_mod
248    USE omp_para
249    IMPLICIT NONE
250    TYPE(t_field),POINTER :: field(:,:)
251    INTEGER :: i
252    !$OMP BARRIER
253    DO i=1,SIZE(field,2)
254       CALL deallocate_field_(field(:,i))
255    END DO
256    !$OMP BARRIER
257    !$OMP MASTER
258    DEALLOCATE(field)
259    !$OMP END MASTER
260    !$OMP BARRIER
261  END SUBROUTINE deallocate_fields
262
263  SUBROUTINE deallocate_field_(field)
264  USE domain_mod
265  USE omp_para
266  IMPLICIT NONE
267    TYPE(t_field) :: field(:)
268    INTEGER :: data_type
269    INTEGER :: ind
270    DO ind=1,ndomain
271       IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
272
273       data_type=field(ind)%data_type
274
275       IF (data_type==type_integer) THEN
276          IF (field(ind)%ondevice) THEN
277             !$acc exit data delete(field(ind)%ival4d(:,:,:))
278             CONTINUE
279          END IF
280          DEALLOCATE(field(ind)%ival4d)
281       END IF
282
283       IF (data_type==type_real) THEN
284          IF (field(ind)%ondevice) THEN
285             !$acc exit data delete(field(ind)%rval4d(:,:,:))
286             CONTINUE
287          END IF
288          DEALLOCATE(field(ind)%rval4d)
289       END IF
290
291       IF (data_type==type_logical) THEN
292          IF (field(ind)%ondevice) THEN
293             !$acc exit data delete(field(ind)%lval4d(:,:,:))
294             CONTINUE
295          END IF
296          DEALLOCATE(field(ind)%lval4d)
297       END IF
298    END DO
299
300  END SUBROUTINE deallocate_field_
301
302  SUBROUTINE deallocate_field_glo(field)
303  USE domain_mod
304  IMPLICIT NONE
305    TYPE(t_field),POINTER :: field(:)
306    INTEGER :: data_type
307    INTEGER :: ind
308
309    DO ind=1,ndomain_glo
310
311      data_type=field(ind)%data_type
312       
313      IF (field(ind)%ndim==4) THEN
314        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival4d)
315        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval4d)
316        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval4d)
317      ELSE IF (field(ind)%ndim==3) THEN
318        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival3d)
319        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval3d)
320        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval3d)
321      ELSE IF (field(ind)%ndim==2) THEN
322        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival2d)
323        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval2d)
324        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval2d)
325      ENDIF
326     
327   ENDDO
328   DEALLOCATE(field)
329       
330  END SUBROUTINE deallocate_field_glo
331   
332  SUBROUTINE extract_slice(field_in, field_out, l) 
333  USE domain_mod
334  USE omp_para
335  IMPLICIT NONE 
336    TYPE(t_field) :: field_in(:)
337    TYPE(t_field) :: field_out(:)
338    INTEGER,INTENT(IN) :: l
339   
340    INTEGER :: ind
341    INTEGER :: data_type
342
343!$OMP BARRIER
344    DO ind=1,ndomain
345      data_type=field_in(ind)%data_type
346      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
347     
348      IF (field_in(ind)%ndim==3 .AND. field_out(ind)%ndim==2) THEN 
349        IF (data_type==type_integer)  field_out(ind)%ival2d=field_in(ind)%ival3d(:,l)
350        IF (data_type==type_real)     field_out(ind)%rval2d=field_in(ind)%rval3d(:,l)
351        IF (data_type==type_logical)  field_out(ind)%lval2d=field_in(ind)%lval3d(:,l)
352      ELSE IF  (field_in(ind)%ndim==4 .AND. field_out(ind)%ndim==3) THEN
353        IF (data_type==type_integer)  field_out(ind)%ival3d=field_in(ind)%ival4d(:,:,l)
354        IF (data_type==type_real)     field_out(ind)%rval3d=field_in(ind)%rval4d(:,:,l)
355        IF (data_type==type_logical)  field_out(ind)%lval3d=field_in(ind)%lval4d(:,:,l)
356      ELSE
357        PRINT *, 'extract_slice : cannot extract slice, dimension incompatible'
358        STOP       
359      ENDIF
360   ENDDO 
361!$OMP BARRIER   
362  END  SUBROUTINE extract_slice 
363 
364 
365  SUBROUTINE insert_slice(field_in, field_out, l) 
366  USE domain_mod
367  USE omp_para
368  IMPLICIT NONE 
369    TYPE(t_field) :: field_in(:)
370    TYPE(t_field) :: field_out(:)
371    INTEGER,INTENT(IN) :: l
372   
373    INTEGER :: ind
374    INTEGER :: data_type
375
376!$OMP BARRIER
377    DO ind=1,ndomain
378      data_type=field_in(ind)%data_type
379      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
380     
381      IF (field_in(ind)%ndim==2 .AND. field_out(ind)%ndim==3) THEN 
382        IF (data_type==type_integer)  field_out(ind)%ival3d(:,l)=field_in(ind)%ival2d(:)
383        IF (data_type==type_real)     field_out(ind)%rval3d(:,l)=field_in(ind)%rval2d(:)
384        IF (data_type==type_logical)  field_out(ind)%lval3d(:,l)=field_in(ind)%lval2d(:)
385      ELSE IF  (field_in(ind)%ndim==4 .AND. field_out(ind)%ndim==3) THEN
386        IF (data_type==type_integer)  field_out(ind)%ival4d(:,:,l)=field_out(ind)%ival3d(:,:)
387        IF (data_type==type_real)     field_out(ind)%rval4d(:,:,l)=field_out(ind)%rval3d(:,:)
388        IF (data_type==type_logical)  field_out(ind)%lval4d(:,:,l)=field_out(ind)%lval3d(:,:)
389      ELSE
390        PRINT *, 'extract_slice : cannot insert slice, dimension incompatible'
391        STOP       
392      ENDIF
393   ENDDO 
394!$OMP BARRIER   
395 
396  END SUBROUTINE insert_slice
397   
398  SUBROUTINE getval_r2d(field_pt,field)
399  IMPLICIT NONE 
400    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:)
401    TYPE(t_field),INTENT(IN) :: field
402   
403    IF (field%ndim/=2 .OR. field%data_type/=type_real) THEN
404       PRINT *, 'get_val_r2d : bad pointer assignment with ' // TRIM(field%name) 
405       STOP
406    END IF
407    field_pt=>field%rval2d
408  END SUBROUTINE  getval_r2d
409
410  SUBROUTINE getval_r3d(field_pt,field)
411  IMPLICIT NONE 
412    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:)
413    TYPE(t_field),INTENT(IN) :: field
414   
415    IF (field%ndim/=3 .OR. field%data_type/=type_real) THEN
416       PRINT *, 'get_val_r3d : bad pointer assignment with ' // TRIM(field%name) 
417       STOP
418!       CALL ABORT
419    END IF
420    field_pt=>field%rval3d
421  END SUBROUTINE  getval_r3d
422
423  SUBROUTINE getval_r4d(field_pt,field)
424  IMPLICIT NONE 
425    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:,:)
426    TYPE(t_field),INTENT(IN) :: field
427   
428    IF (field%ndim/=4 .OR. field%data_type/=type_real) THEN
429       PRINT *, 'get_val_r4d : bad pointer assignment with ' // TRIM(field%name)
430       STOP
431    END IF
432    field_pt=>field%rval4d
433  END SUBROUTINE  getval_r4d 
434
435 
436  SUBROUTINE getval_i2d(field_pt,field)
437  IMPLICIT NONE 
438    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:)
439    TYPE(t_field),INTENT(IN) :: field
440   
441    IF (field%ndim/=2 .OR. field%data_type/=type_integer) STOP 'get_val_i2d : bad pointer assignment'       
442    field_pt=>field%ival2d
443  END SUBROUTINE  getval_i2d
444
445  SUBROUTINE getval_i3d(field_pt,field)
446  IMPLICIT NONE 
447    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:)
448    TYPE(t_field),INTENT(IN) :: field
449   
450    IF (field%ndim/=3 .OR. field%data_type/=type_integer) STOP 'get_val_i3d : bad pointer assignment'       
451    field_pt=>field%ival3d
452  END SUBROUTINE  getval_i3d
453
454  SUBROUTINE getval_i4d(field_pt,field)
455  IMPLICIT NONE 
456    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
457    TYPE(t_field),INTENT(IN) :: field
458   
459    IF (field%ndim/=4 .OR. field%data_type/=type_integer) STOP 'get_val_i4d : bad pointer assignment'       
460    field_pt=>field%ival4d
461  END SUBROUTINE  getval_i4d
462
463  SUBROUTINE getval_l2d(field_pt,field)
464  IMPLICIT NONE 
465    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:)
466    TYPE(t_field),INTENT(IN) :: field
467   
468    IF (field%ndim/=2 .OR. field%data_type/=type_logical) STOP 'get_val_l2d : bad pointer assignment'       
469    field_pt=>field%lval2d
470  END SUBROUTINE  getval_l2d
471
472  SUBROUTINE getval_l3d(field_pt,field)
473  IMPLICIT NONE 
474    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:)
475    TYPE(t_field),INTENT(IN) :: field
476   
477    IF (field%ndim/=3 .OR. field%data_type/=type_logical) STOP 'get_val_l3d : bad pointer assignment'       
478    field_pt=>field%lval3d
479  END SUBROUTINE  getval_l3d
480
481  SUBROUTINE getval_l4d(field_pt,field)
482  IMPLICIT NONE 
483    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
484    TYPE(t_field),INTENT(IN) :: field
485   
486    IF (field%ndim/=4 .OR. field%data_type/=type_logical) STOP 'get_val_l4d : bad pointer assignment'       
487    field_pt=>field%lval4d
488  END SUBROUTINE  getval_l4d   
489
490
491  SUBROUTINE update_device_field(field)
492  USE domain_mod
493  USE omp_para
494  IMPLICIT NONE
495    TYPE(t_field) :: field(:)
496    INTEGER :: ind
497
498    DO ind=1,ndomain
499      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
500
501      IF (.NOT. field(ind)%ondevice) CALL create_device_field(field(ind))
502
503      IF (field(ind)%ndim==4) THEN
504         IF (field(ind)%data_type==type_integer) THEN
505            !$acc update device(field(ind)%ival4d(:,:,:)) async
506            CONTINUE
507         END IF
508
509         IF (field(ind)%data_type==type_real) THEN
510            !$acc update device(field(ind)%rval4d(:,:,:)) async
511            CONTINUE
512         END IF
513
514         IF (field(ind)%data_type==type_logical) THEN
515            !$acc update device(field(ind)%lval4d(:,:,:)) async
516            CONTINUE
517         END IF
518
519      ELSE IF (field(ind)%ndim==3) THEN
520         IF (field(ind)%data_type==type_integer) THEN
521            !$acc update device(field(ind)%ival3d(:,:)) async
522            CONTINUE
523         END IF
524
525         IF (field(ind)%data_type==type_real) THEN
526            !$acc update device(field(ind)%rval3d(:,:)) async
527            CONTINUE
528         END IF
529
530         IF (field(ind)%data_type==type_logical) THEN
531            !$acc update device(field(ind)%lval3d(:,:)) async
532            CONTINUE
533         END IF
534
535      ELSE IF (field(ind)%ndim==2) THEN
536         IF (field(ind)%data_type==type_integer) THEN
537            !$acc update device(field(ind)%ival2d(:)) async
538            CONTINUE
539         END IF
540
541         IF (field(ind)%data_type==type_real) THEN
542            !$acc update device(field(ind)%rval2d(:)) async
543            CONTINUE
544         END IF
545
546         IF (field(ind)%data_type==type_logical) THEN
547            !$acc update device(field(ind)%lval2d(:)) async
548            CONTINUE
549         END IF
550      ENDIF
551   ENDDO
552   !$OMP BARRIER
553 END SUBROUTINE update_device_field
554 
555  SUBROUTINE update_host_field(field)
556  USE domain_mod
557  USE omp_para
558  IMPLICIT NONE
559    TYPE(t_field) :: field(:)
560    INTEGER :: ind
561
562    DO ind=1,ndomain
563      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
564
565      IF (field(ind)%ondevice) THEN
566
567         IF (field(ind)%ndim==4) THEN
568            IF (field(ind)%data_type==type_integer) THEN
569               !$acc update host(field(ind)%ival4d(:,:,:)) async
570               CONTINUE
571            END IF
572
573            IF (field(ind)%data_type==type_real) THEN
574               !$acc update host(field(ind)%rval4d(:,:,:)) async
575               CONTINUE
576            END IF
577
578            IF (field(ind)%data_type==type_logical) THEN
579               !$acc update host(field(ind)%lval4d(:,:,:)) async
580               CONTINUE
581            END IF
582
583         ELSE IF (field(ind)%ndim==3) THEN
584            IF (field(ind)%data_type==type_integer) THEN
585               !$acc update host(field(ind)%ival3d(:,:)) async
586               CONTINUE
587            END IF
588
589            IF (field(ind)%data_type==type_real) THEN
590               !$acc update host(field(ind)%rval3d(:,:)) async
591               CONTINUE
592            END IF
593
594            IF (field(ind)%data_type==type_logical) THEN
595               !$acc update host(field(ind)%lval3d(:,:)) async
596               CONTINUE
597            END IF
598
599         ELSE IF (field(ind)%ndim==2) THEN
600            IF (field(ind)%data_type==type_integer) THEN
601               !$acc update host(field(ind)%ival2d(:)) async
602               CONTINUE
603            END IF
604
605            IF (field(ind)%data_type==type_real) THEN
606               !$acc update host(field(ind)%rval2d(:)) async
607               CONTINUE
608            END IF
609
610            IF (field(ind)%data_type==type_logical) THEN
611               !$acc update host(field(ind)%lval2d(:)) async
612               CONTINUE
613            END IF
614         ENDIF
615      END IF
616   ENDDO
617   !$acc wait
618   !$OMP BARRIER
619 END SUBROUTINE update_host_field
620
621 SUBROUTINE create_device_field(field)
622    TYPE(t_field) :: field
623
624    IF (field%ondevice) THEN
625       PRINT *, "Field is already on device !"
626       STOP 1
627    END IF
628    IF (field%ndim==4) THEN
629       IF (field%data_type==type_integer) THEN
630          !$acc enter data create(field%ival4d(:,:,:)) async
631       END IF
632
633       IF (field%data_type==type_real) THEN
634          !$acc enter data create(field%rval4d(:,:,:)) async
635       END IF
636
637       IF (field%data_type==type_logical) THEN
638          !$acc enter data create(field%lval4d(:,:,:)) async
639       END IF
640
641    ELSE IF (field%ndim==3) THEN
642       IF (field%data_type==type_integer) THEN
643          !$acc enter data create(field%ival3d(:,:)) async
644       END IF
645
646       IF (field%data_type==type_real) THEN
647          !$acc enter data create(field%rval3d(:,:)) async
648       END IF
649
650       IF (field%data_type==type_logical) THEN
651          !$acc enter data create(field%lval3d(:,:)) async
652       END IF
653
654    ELSE IF (field%ndim==2) THEN
655       IF (field%data_type==type_integer) THEN
656          !$acc enter data create(field%ival2d(:)) async
657       END IF
658
659       IF (field%data_type==type_real) THEN
660          !$acc enter data create(field%rval2d(:)) async
661       END IF
662
663       IF (field%data_type==type_logical) THEN
664          !$acc enter data create(field%lval2d(:)) async
665       END IF
666    ENDIF
667    field%ondevice = .TRUE.
668  END SUBROUTINE create_device_field
669 
670END MODULE field_mod   
Note: See TracBrowser for help on using the repository browser.