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

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

trunk : GPU implementation with OpenACC ( merge from glcp.idris.fr )
File size: 21.8 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 :: rval2d(:) => null()
16    REAL(rstd),POINTER :: rval3d(:,:) => null()
17    REAL(rstd),POINTER :: 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             DEALLOCATE(field(ind)%ival4d)
277             IF (field(ind)%ondevice) THEN
278                !$acc exit data delete(field(ind)%ival4d)
279                CONTINUE
280             END IF
281          END IF
282
283          IF (data_type==type_real) THEN
284             DEALLOCATE(field(ind)%rval4d)
285             IF (field(ind)%ondevice) THEN
286                !$acc exit data delete(field(ind)%rval4d)
287                CONTINUE
288             END IF
289          END IF
290
291          IF (data_type==type_logical) THEN
292             DEALLOCATE(field(ind)%lval4d)
293             IF (field(ind)%ondevice) THEN
294                !$acc exit data delete(field(ind)%lval4d)
295                CONTINUE
296             END IF
297          END IF
298
299       ELSE IF (field(ind)%ndim==3) THEN
300          IF (data_type==type_integer) THEN
301             DEALLOCATE(field(ind)%ival3d)
302             IF (field(ind)%ondevice) THEN
303                !$acc exit data delete(field(ind)%ival3d)
304                CONTINUE
305             END IF
306          END IF
307
308          IF (data_type==type_real) THEN
309             DEALLOCATE(field(ind)%rval3d)
310             IF (field(ind)%ondevice) THEN
311                !$acc exit data delete(field(ind)%rval3d)
312                CONTINUE
313             END IF
314          END IF
315
316          IF (data_type==type_logical) THEN
317             DEALLOCATE(field(ind)%lval3d)
318             IF (field(ind)%ondevice) THEN
319                !$acc exit data delete(field(ind)%lval3d)
320                CONTINUE
321             END IF
322          END IF
323
324       ELSE IF (field(ind)%ndim==2) THEN
325          IF (data_type==type_integer) THEN
326             DEALLOCATE(field(ind)%ival2d)
327             IF (field(ind)%ondevice) THEN
328                !$acc exit data delete(field(ind)%ival2d)
329                CONTINUE
330             END IF
331          END IF
332
333          IF (data_type==type_real) THEN
334             DEALLOCATE(field(ind)%rval2d)
335             IF (field(ind)%ondevice) THEN
336                !$acc exit data delete(field(ind)%rval2d)
337                CONTINUE
338             END IF
339          END IF
340
341          IF (data_type==type_logical) THEN
342             DEALLOCATE(field(ind)%lval2d)
343             IF (field(ind)%ondevice) THEN
344                !$acc exit data delete(field(ind)%lval2d)
345                CONTINUE
346             END IF
347          END IF
348
349       ENDIF
350
351    ENDDO
352  END SUBROUTINE deallocate_field_
353
354  SUBROUTINE deallocate_field_glo(field)
355  USE domain_mod
356  IMPLICIT NONE
357    TYPE(t_field),POINTER :: field(:)
358    INTEGER :: data_type
359    INTEGER :: ind
360
361    DO ind=1,ndomain_glo
362
363      data_type=field(ind)%data_type
364       
365      IF (field(ind)%ndim==4) THEN
366        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival4d)
367        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval4d)
368        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval4d)
369      ELSE IF (field(ind)%ndim==3) THEN
370        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival3d)
371        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval3d)
372        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval3d)
373      ELSE IF (field(ind)%ndim==2) THEN
374        IF (data_type==type_integer) DEALLOCATE(field(ind)%ival2d)
375        IF (data_type==type_real)    DEALLOCATE(field(ind)%rval2d)
376        IF (data_type==type_logical) DEALLOCATE(field(ind)%lval2d)
377      ENDIF
378     
379   ENDDO
380   DEALLOCATE(field)
381       
382  END SUBROUTINE deallocate_field_glo
383   
384  SUBROUTINE extract_slice(field_in, field_out, l) 
385  USE domain_mod
386  USE omp_para
387  IMPLICIT NONE 
388    TYPE(t_field) :: field_in(:)
389    TYPE(t_field) :: field_out(:)
390    INTEGER,INTENT(IN) :: l
391   
392    INTEGER :: ind
393    INTEGER :: data_type
394
395!$OMP BARRIER
396    DO ind=1,ndomain
397      data_type=field_in(ind)%data_type
398      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
399     
400      IF (field_in(ind)%ndim==3 .AND. field_out(ind)%ndim==2) THEN 
401        IF (data_type==type_integer)  field_out(ind)%ival2d=field_in(ind)%ival3d(:,l)
402        IF (data_type==type_real)     field_out(ind)%rval2d=field_in(ind)%rval3d(:,l)
403        IF (data_type==type_logical)  field_out(ind)%lval2d=field_in(ind)%lval3d(:,l)
404      ELSE IF  (field_in(ind)%ndim==4 .AND. field_out(ind)%ndim==3) THEN
405        IF (data_type==type_integer)  field_out(ind)%ival3d=field_in(ind)%ival4d(:,:,l)
406        IF (data_type==type_real)     field_out(ind)%rval3d=field_in(ind)%rval4d(:,:,l)
407        IF (data_type==type_logical)  field_out(ind)%lval3d=field_in(ind)%lval4d(:,:,l)
408      ELSE
409        PRINT *, 'extract_slice : cannot extract slice, dimension incompatible'
410        STOP       
411      ENDIF
412   ENDDO 
413!$OMP BARRIER   
414  END  SUBROUTINE extract_slice 
415 
416 
417  SUBROUTINE insert_slice(field_in, field_out, l) 
418  USE domain_mod
419  USE omp_para
420  IMPLICIT NONE 
421    TYPE(t_field) :: field_in(:)
422    TYPE(t_field) :: field_out(:)
423    INTEGER,INTENT(IN) :: l
424   
425    INTEGER :: ind
426    INTEGER :: data_type
427
428!$OMP BARRIER
429    DO ind=1,ndomain
430      data_type=field_in(ind)%data_type
431      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
432     
433      IF (field_in(ind)%ndim==2 .AND. field_out(ind)%ndim==3) THEN 
434        IF (data_type==type_integer)  field_out(ind)%ival3d(:,l)=field_in(ind)%ival2d(:)
435        IF (data_type==type_real)     field_out(ind)%rval3d(:,l)=field_in(ind)%rval2d(:)
436        IF (data_type==type_logical)  field_out(ind)%lval3d(:,l)=field_in(ind)%lval2d(:)
437      ELSE IF  (field_in(ind)%ndim==4 .AND. field_out(ind)%ndim==3) THEN
438        IF (data_type==type_integer)  field_out(ind)%ival4d(:,:,l)=field_out(ind)%ival3d(:,:)
439        IF (data_type==type_real)     field_out(ind)%rval4d(:,:,l)=field_out(ind)%rval3d(:,:)
440        IF (data_type==type_logical)  field_out(ind)%lval4d(:,:,l)=field_out(ind)%lval3d(:,:)
441      ELSE
442        PRINT *, 'extract_slice : cannot insert slice, dimension incompatible'
443        STOP       
444      ENDIF
445   ENDDO 
446!$OMP BARRIER   
447 
448  END SUBROUTINE insert_slice
449   
450  SUBROUTINE getval_r2d(field_pt,field)
451  IMPLICIT NONE 
452    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:)
453    TYPE(t_field),INTENT(IN) :: field
454   
455    IF (field%ndim/=2 .OR. field%data_type/=type_real) THEN
456       PRINT *, 'get_val_r2d : bad pointer assignment with ' // TRIM(field%name) 
457       STOP
458    END IF
459    field_pt=>field%rval2d
460  END SUBROUTINE  getval_r2d
461
462  SUBROUTINE getval_r3d(field_pt,field)
463  IMPLICIT NONE 
464    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:)
465    TYPE(t_field),INTENT(IN) :: field
466   
467    IF (field%ndim/=3 .OR. field%data_type/=type_real) THEN
468       PRINT *, 'get_val_r3d : bad pointer assignment with ' // TRIM(field%name) 
469       STOP
470!       CALL ABORT
471    END IF
472    field_pt=>field%rval3d
473  END SUBROUTINE  getval_r3d
474
475  SUBROUTINE getval_r4d(field_pt,field)
476  IMPLICIT NONE 
477    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:,:)
478    TYPE(t_field),INTENT(IN) :: field
479   
480    IF (field%ndim/=4 .OR. field%data_type/=type_real) THEN
481       PRINT *, 'get_val_r4d : bad pointer assignment with ' // TRIM(field%name)
482       STOP
483    END IF
484    field_pt=>field%rval4d
485  END SUBROUTINE  getval_r4d 
486
487 
488  SUBROUTINE getval_i2d(field_pt,field)
489  IMPLICIT NONE 
490    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:)
491    TYPE(t_field),INTENT(IN) :: field
492   
493    IF (field%ndim/=2 .OR. field%data_type/=type_integer) STOP 'get_val_i2d : bad pointer assignment'       
494    field_pt=>field%ival2d
495  END SUBROUTINE  getval_i2d
496
497  SUBROUTINE getval_i3d(field_pt,field)
498  IMPLICIT NONE 
499    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:)
500    TYPE(t_field),INTENT(IN) :: field
501   
502    IF (field%ndim/=3 .OR. field%data_type/=type_integer) STOP 'get_val_i3d : bad pointer assignment'       
503    field_pt=>field%ival3d
504  END SUBROUTINE  getval_i3d
505
506  SUBROUTINE getval_i4d(field_pt,field)
507  IMPLICIT NONE 
508    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
509    TYPE(t_field),INTENT(IN) :: field
510   
511    IF (field%ndim/=4 .OR. field%data_type/=type_integer) STOP 'get_val_i4d : bad pointer assignment'       
512    field_pt=>field%ival4d
513  END SUBROUTINE  getval_i4d
514
515  SUBROUTINE getval_l2d(field_pt,field)
516  IMPLICIT NONE 
517    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:)
518    TYPE(t_field),INTENT(IN) :: field
519   
520    IF (field%ndim/=2 .OR. field%data_type/=type_logical) STOP 'get_val_l2d : bad pointer assignment'       
521    field_pt=>field%lval2d
522  END SUBROUTINE  getval_l2d
523
524  SUBROUTINE getval_l3d(field_pt,field)
525  IMPLICIT NONE 
526    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:)
527    TYPE(t_field),INTENT(IN) :: field
528   
529    IF (field%ndim/=3 .OR. field%data_type/=type_logical) STOP 'get_val_l3d : bad pointer assignment'       
530    field_pt=>field%lval3d
531  END SUBROUTINE  getval_l3d
532
533  SUBROUTINE getval_l4d(field_pt,field)
534  IMPLICIT NONE 
535    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
536    TYPE(t_field),INTENT(IN) :: field
537   
538    IF (field%ndim/=4 .OR. field%data_type/=type_logical) STOP 'get_val_l4d : bad pointer assignment'       
539    field_pt=>field%lval4d
540  END SUBROUTINE  getval_l4d   
541
542
543  SUBROUTINE update_device_field(field)
544  USE domain_mod
545  USE omp_para
546  IMPLICIT NONE
547    TYPE(t_field) :: field(:)
548    INTEGER :: ind
549
550    DO ind=1,ndomain
551      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
552
553      IF (.NOT. field(ind)%ondevice) CALL create_device_field(field(ind))
554
555      IF (field(ind)%ndim==4) THEN
556         IF (field(ind)%data_type==type_integer) THEN
557            !$acc update device(field(ind)%ival4d(:,:,:))
558            CONTINUE
559         END IF
560
561         IF (field(ind)%data_type==type_real) THEN
562            !$acc update device(field(ind)%rval4d(:,:,:))
563            CONTINUE
564         END IF
565
566         IF (field(ind)%data_type==type_logical) THEN
567            !$acc update device(field(ind)%lval4d(:,:,:))
568            CONTINUE
569         END IF
570
571      ELSE IF (field(ind)%ndim==3) THEN
572         IF (field(ind)%data_type==type_integer) THEN
573            !$acc update device(field(ind)%ival3d(:,:))
574            CONTINUE
575         END IF
576
577         IF (field(ind)%data_type==type_real) THEN
578            !$acc update device(field(ind)%rval3d(:,:))
579            CONTINUE
580         END IF
581
582         IF (field(ind)%data_type==type_logical) THEN
583            !$acc update device(field(ind)%lval3d(:,:))
584            CONTINUE
585         END IF
586
587      ELSE IF (field(ind)%ndim==2) THEN
588         IF (field(ind)%data_type==type_integer) THEN
589            !$acc update device(field(ind)%ival2d(:))
590            CONTINUE
591         END IF
592
593         IF (field(ind)%data_type==type_real) THEN
594            !$acc update device(field(ind)%rval2d(:))
595            CONTINUE
596         END IF
597
598         IF (field(ind)%data_type==type_logical) THEN
599            !$acc update device(field(ind)%lval2d(:))
600            CONTINUE
601         END IF
602      ENDIF
603   ENDDO
604   !$OMP BARRIER
605 END SUBROUTINE update_device_field
606 
607  SUBROUTINE update_host_field(field)
608  USE domain_mod
609  USE omp_para
610  IMPLICIT NONE
611    TYPE(t_field) :: field(:)
612    INTEGER :: ind
613
614    DO ind=1,ndomain
615      IF (.NOT. assigned_domain(ind)  .OR. .NOT. is_omp_level_master) CYCLE
616
617      IF (field(ind)%ondevice) THEN
618       
619         IF (field(ind)%ndim==4) THEN
620            IF (field(ind)%data_type==type_integer) THEN
621               !$acc update host(field(ind)%ival4d(:,:,:)) wait
622               CONTINUE
623            END IF
624
625            IF (field(ind)%data_type==type_real) THEN
626               !$acc update host(field(ind)%rval4d(:,:,:)) wait
627               CONTINUE
628            END IF
629
630            IF (field(ind)%data_type==type_logical) THEN
631               !$acc update host(field(ind)%lval4d(:,:,:)) wait
632               CONTINUE
633            END IF
634         
635         ELSE IF (field(ind)%ndim==3) THEN
636            IF (field(ind)%data_type==type_integer) THEN
637               !$acc update host(field(ind)%ival3d(:,:)) wait
638               CONTINUE
639            END IF
640
641            IF (field(ind)%data_type==type_real) THEN
642               !$acc update host(field(ind)%rval3d(:,:)) wait
643               CONTINUE
644            END IF
645
646            IF (field(ind)%data_type==type_logical) THEN
647               !$acc update host(field(ind)%lval3d(:,:)) wait
648               CONTINUE
649            END IF
650
651         ELSE IF (field(ind)%ndim==2) THEN
652            IF (field(ind)%data_type==type_integer) THEN
653               !$acc update host(field(ind)%ival2d(:)) wait
654               CONTINUE
655            END IF
656
657            IF (field(ind)%data_type==type_real) THEN
658               !$acc update host(field(ind)%rval2d(:)) wait
659               CONTINUE
660            END IF
661
662            IF (field(ind)%data_type==type_logical) THEN
663               !$acc update host(field(ind)%lval2d(:)) wait
664               CONTINUE
665            END IF
666         ENDIF
667      END IF
668   ENDDO
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(:,:,:))
682       END IF
683
684       IF (field%data_type==type_real) THEN
685          !$acc enter data create(field%rval4d(:,:,:))
686       END IF
687
688       IF (field%data_type==type_logical) THEN
689          !$acc enter data create(field%lval4d(:,:,:))
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(:,:))
695       END IF
696
697       IF (field%data_type==type_real) THEN
698          !$acc enter data create(field%rval3d(:,:))
699       END IF
700
701       IF (field%data_type==type_logical) THEN
702          !$acc enter data create(field%lval3d(:,:))
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(:))
708       END IF
709
710       IF (field%data_type==type_real) THEN
711          !$acc enter data create(field%rval2d(:))
712       END IF
713
714       IF (field%data_type==type_logical) THEN
715          !$acc enter data create(field%lval2d(:))
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.