Ignore:
Timestamp:
09/30/20 23:22:33 (4 years ago)
Author:
dubos
Message:

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:
1 edited

Legend:

Unmodified
Added
Removed

  • codes/icosagcm/trunk/src/base/field.f90

    r1053 r1055  
    22  USE genmod 
    33  IMPLICIT NONE 
    4    
     4 
    55  INTEGER,PARAMETER :: field_T=1 
    66  INTEGER,PARAMETER :: field_U=2 
    … …  
    1010  INTEGER,PARAMETER :: type_real=2 
    1111  INTEGER,PARAMETER :: type_logical=3 
    12      
     12 
    1313  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    
     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 
    3631 
    3732  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 
     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 
    4142  END INTERFACE 
    42                     
     43 
    4344  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  
     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 
    4754  END INTERFACE 
    4855 
    49   PRIVATE :: allocate_field_ 
     56  PRIVATE :: allocate_field_, deallocate_field_ 
    5057 
    5158CONTAINS 
    5259 
    53   SUBROUTINE allocate_field(field,field_type,data_type,dim1,dim2,name,ondevice) 
    54   USE domain_mod 
    55   USE omp_para 
     60  !====================================== allocate_field =================================== 
     61 
     62  SUBROUTINE allocate_field_glo(field,field_type,data_type,dim1,dim2,name) 
     63    USE domain_mod 
    5664    TYPE(t_field),POINTER :: field(:) 
    5765    INTEGER,INTENT(IN) :: field_type 
    … …  
    5967    INTEGER,OPTIONAL :: dim1,dim2 
    6068    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 
     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 
    8085    CHARACTER(*), OPTIONAL :: name 
    8186    LOGICAL, INTENT(IN), OPTIONAL :: ondevice 
    82     INTEGER :: i 
    83 !$OMP BARRIER 
    84 !$OMP MASTER 
     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 
    85115    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) 
     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 
    90123    END DO 
     124    !$OMP BARRIER 
     125 
    91126  END SUBROUTINE allocate_fields 
    92127 
    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 
     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 
    101136    CHARACTER(*), OPTIONAL :: name 
    102137    LOGICAL, INTENT(IN), OPTIONAL :: ondevice 
    103     INTEGER :: ind 
     138 
    104139    INTEGER :: ij_size 
    105140 
    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 
     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 
    170200    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  
     201    INTEGER :: ind 
    180202    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 
     203       CALL deallocate_field_(field(ind)) 
     204    END DO 
     205    DEALLOCATE(field) 
     206  END SUBROUTINE deallocate_field_glo 
    231207 
    232208  SUBROUTINE deallocate_field(field) 
    233209    USE domain_mod 
    234210    USE omp_para 
    235     IMPLICIT NONE 
    236211    TYPE(t_field),POINTER :: field(:) 
    237     !$OMP BARRIER 
    238     CALL deallocate_field_(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 
    239218    !$OMP BARRIER 
    240219    !$OMP MASTER 
    … …  
    243222    !$OMP BARRIER 
    244223  END SUBROUTINE deallocate_field 
    245    
     224 
    246225  SUBROUTINE deallocate_fields(field) 
    247226    USE domain_mod 
    248227    USE omp_para 
    249     IMPLICIT NONE 
    250228    TYPE(t_field),POINTER :: field(:,:) 
    251     INTEGER :: i 
    252     !$OMP BARRIER 
    253     DO i=1,SIZE(field,2) 
    254        CALL deallocate_field_(field(:,i)) 
     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 
    255236    END DO 
    256237    !$OMP BARRIER 
    … …  
    262243 
    263244  SUBROUTINE deallocate_field_(field) 
    264   USE domain_mod 
    265   USE omp_para 
    266   IMPLICIT NONE 
     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 
    267380    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(:,:,:)) 
     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 
    278416             CONTINUE 
    279417          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(:,:,:)) 
     418          IF (field(ind)%data_type==type_integer) THEN 
     419             !$acc update host(field(ind)%ival4d(:,:,:)) async 
    286420             CONTINUE 
    287421          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(:,:,:)) 
     422          IF (field(ind)%data_type==type_logical) THEN 
     423             !$acc update host(field(ind)%lval4d(:,:,:)) async 
    294424             CONTINUE 
    295425          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) 
     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) 
    622434    TYPE(t_field) :: field 
    623435 
    … …  
    626438       STOP 1 
    627439    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 
     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 
    667450    field%ondevice = .TRUE. 
    668451  END SUBROUTINE create_device_field 
    669   
    670 END MODULE field_mod    
     452 
     453END MODULE field_mod 
Note: See TracChangeset for help on using the changeset viewer.