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

Last change on this file since 963 was 963, checked in by adurocher, 5 years ago

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