Changeset 1055


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

Location:
codes/icosagcm/trunk
Files:
7 added
3 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 

  • codes/icosagcm/trunk/src/parallel/openacc_mod.F90

    r1019 r1055  
    3131    ELSE IF (slurm_local_id_ierr == 0) then 
    3232       READ(slurm_local_id_value,*) local_id 
    33        PRINT *, "setDevice : found env variable SLURM_LOCAL_ID =", local_id  
     33       PRINT *, "setDevice : found env variable SLURM_LOCALID =", local_id  
    3434    ELSE 
    3535     RETURN 

  • codes/icosagcm/trunk/src/parallel/transfert_mpi_collectives.f90

    r963 r1055  
    11MODULE transfert_mpi_collectives_mod 
    2 IMPLICIT NONE 
     2  IMPLICIT NONE 
    33 
    44  INTERFACE bcast_mpi 
    5     MODULE PROCEDURE bcast_mpi_c,                                                     & 
    6                      bcast_mpi_i,bcast_mpi_i1,bcast_mpi_i2,bcast_mpi_i3,bcast_mpi_i4, & 
    7                      bcast_mpi_r,bcast_mpi_r1,bcast_mpi_r2,bcast_mpi_r3,bcast_mpi_r4, & 
    8                      bcast_mpi_l,bcast_mpi_l1,bcast_mpi_l2,bcast_mpi_l3,bcast_mpi_l4 
     5     MODULE PROCEDURE bcast_mpi_c 
     6     MODULE PROCEDURE bcast_mpi_i, bcast_mpi_i1, bcast_mpi_i2, bcast_mpi_i3, bcast_mpi_i4 
     7     MODULE PROCEDURE bcast_mpi_r, bcast_mpi_r1, bcast_mpi_r2, bcast_mpi_r3, bcast_mpi_r4 
     8     MODULE PROCEDURE bcast_mpi_l, bcast_mpi_l1, bcast_mpi_l2, bcast_mpi_l3, bcast_mpi_l4 
    99  END INTERFACE 
    1010 
    … …  
    1212 
    1313  SUBROUTINE gather_field(field_loc,field_glo) 
    14   USE field_mod 
    15   USE domain_mod 
    16   USE mpi_mod 
    17   USE mpipara 
    18   IMPLICIT NONE 
     14    USE field_mod 
     15    USE domain_mod 
     16    USE mpi_mod 
     17    USE mpipara 
    1918    TYPE(t_field),POINTER :: field_loc(:) 
    2019    TYPE(t_field),POINTER :: field_glo(:) 
    … …  
    2524 
    2625    IF (.NOT. using_mpi) THEN 
    27  
    28       DO ind_loc=1,ndomain 
    29         IF (field_loc(ind_loc)%ndim==2) field_glo(ind_loc)%rval2d=field_loc(ind_loc)%rval2d 
    30         IF (field_loc(ind_loc)%ndim==3) field_glo(ind_loc)%rval3d=field_loc(ind_loc)%rval3d 
    31         IF (field_loc(ind_loc)%ndim==4) field_glo(ind_loc)%rval4d=field_loc(ind_loc)%rval4d 
    32       ENDDO 
     26       DO ind_loc=1,ndomain 
     27          field_glo(ind_loc)%rval4d=field_loc(ind_loc)%rval4d 
     28       ENDDO 
    3329 
    3430    ELSE 
    35  
    36       nreq=ndomain 
    37       IF (mpi_rank==0) nreq=nreq+ndomain_glo 
    38       ALLOCATE(mpi_req(nreq)) 
    39       ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 
    40  
    41  
    42       ireq=0 
    43       IF (mpi_rank==0) THEN 
    44         DO ind_glo=1,ndomain_glo 
     31       nreq=ndomain 
     32       IF (mpi_rank==0) nreq=nreq+ndomain_glo 
     33       ALLOCATE(mpi_req(nreq)) 
     34       ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 
     35 
     36       ireq=0 
     37       IF (mpi_rank==0) THEN 
     38          DO ind_glo=1,ndomain_glo 
     39             ireq=ireq+1 
     40             CALL MPI_IRECV(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 ,   & 
     41                  domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
     42          ENDDO 
     43       ENDIF 
     44 
     45       DO ind_loc=1,ndomain 
    4546          ireq=ireq+1 
    46  
    47           IF (field_glo(ind_glo)%ndim==2) THEN 
    48             CALL MPI_IRECV(field_glo(ind_glo)%rval2d,size(field_glo(ind_glo)%rval2d) , MPI_REAL8 ,   & 
    49                          domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
    50  
    51           ELSE IF (field_glo(ind_glo)%ndim==3) THEN 
    52             CALL MPI_IRECV(field_glo(ind_glo)%rval3d,size(field_glo(ind_glo)%rval3d) , MPI_REAL8 ,   & 
    53                          domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
    54  
    55           ELSE IF (field_glo(ind_glo)%ndim==4) THEN 
    56             CALL MPI_IRECV(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 ,   & 
    57                          domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
    58           ENDIF 
    59  
    60         ENDDO 
    61       ENDIF 
    62  
    63       DO ind_loc=1,ndomain 
    64         ireq=ireq+1 
    65  
    66         IF (field_loc(ind_loc)%ndim==2) THEN 
    67           CALL MPI_ISEND(field_loc(ind_loc)%rval2d,size(field_loc(ind_loc)%rval2d) , MPI_REAL8 ,   & 
    68                          0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
    69         ELSE IF (field_loc(ind_loc)%ndim==3) THEN 
    70           CALL MPI_ISEND(field_loc(ind_loc)%rval3d,size(field_loc(ind_loc)%rval3d) , MPI_REAL8 ,   & 
    71                          0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
    72         ELSE IF (field_loc(ind_loc)%ndim==4) THEN 
    7347          CALL MPI_ISEND(field_loc(ind_loc)%rval4d,size(field_loc(ind_loc)%rval4d) , MPI_REAL8 ,   & 
    74                          0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
    75         ENDIF 
    76  
    77       ENDDO 
    78  
    79       CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
     48               0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
     49       ENDDO 
     50 
     51       CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    8052 
    8153    ENDIF 
    … …  
    8456 
    8557  SUBROUTINE bcast_field(field_glo) 
    86   USE field_mod 
    87   USE domain_mod 
    88   USE mpi_mod 
    89   USE mpipara 
    90   IMPLICIT NONE 
     58    USE field_mod 
     59    USE domain_mod 
     60    USE mpi_mod 
     61    USE mpipara 
    9162    TYPE(t_field),POINTER :: field_glo(:) 
    9263    INTEGER :: ind_glo 
    9364 
    94     IF (.NOT. using_mpi) THEN 
    95  
    96 ! nothing to do 
    97  
    98     ELSE 
    99  
    100       DO ind_glo=1,ndomain_glo 
    101  
    102           IF (field_glo(ind_glo)%ndim==2) THEN 
    103             CALL MPI_BCAST(field_glo(ind_glo)%rval2d, size(field_glo(ind_glo)%rval2d) , MPI_REAL8, 0, comm_icosa, ierr) 
    104           ELSE IF (field_glo(ind_glo)%ndim==3) THEN 
    105             CALL MPI_BCAST(field_glo(ind_glo)%rval3d, size(field_glo(ind_glo)%rval3d) , MPI_REAL8, 0, comm_icosa, ierr) 
    106           ELSE IF (field_glo(ind_glo)%ndim==4) THEN 
    107             CALL MPI_BCAST(field_glo(ind_glo)%rval4d, size(field_glo(ind_glo)%rval4d) , MPI_REAL8, 0, comm_icosa, ierr) 
    108           ENDIF 
    109  
    110         ENDDO 
    111       ENDIF 
     65    IF (using_mpi) THEN 
     66       DO ind_glo=1,ndomain_glo 
     67          CALL MPI_BCAST(field_glo(ind_glo)%rval4d, size(field_glo(ind_glo)%rval4d) , MPI_REAL8, 0, comm_icosa, ierr) 
     68       ENDDO 
     69    ENDIF 
    11270 
    11371  END SUBROUTINE bcast_field 
    11472 
    11573  SUBROUTINE scatter_field(field_glo,field_loc) 
    116   USE field_mod 
    117   USE domain_mod 
    118   USE mpi_mod 
    119   USE mpipara 
    120   IMPLICIT NONE 
     74    USE field_mod 
     75    USE domain_mod 
     76    USE mpi_mod 
     77    USE mpipara 
    12178    TYPE(t_field),POINTER :: field_glo(:) 
    12279    TYPE(t_field),POINTER :: field_loc(:) 
    … …  
    12784 
    12885    IF (.NOT. using_mpi) THEN 
    129  
    130       DO ind_loc=1,ndomain 
    131         IF (field_loc(ind_loc)%ndim==2) field_loc(ind_loc)%rval2d=field_glo(ind_loc)%rval2d 
    132         IF (field_loc(ind_loc)%ndim==3) field_loc(ind_loc)%rval3d=field_glo(ind_loc)%rval3d 
    133         IF (field_loc(ind_loc)%ndim==4) field_loc(ind_loc)%rval4d=field_glo(ind_loc)%rval4d 
    134       ENDDO 
     86       DO ind_loc=1,ndomain 
     87          field_loc(ind_loc)%rval4d=field_glo(ind_loc)%rval4d 
     88       ENDDO 
    13589 
    13690    ELSE 
    137  
    138       nreq=ndomain 
    139       IF (mpi_rank==0) nreq=nreq+ndomain_glo 
    140       ALLOCATE(mpi_req(nreq)) 
    141       ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 
    142  
    143  
    144       ireq=0 
    145       IF (mpi_rank==0) THEN 
    146         DO ind_glo=1,ndomain_glo 
     91       nreq=ndomain 
     92       IF (mpi_rank==0) nreq=nreq+ndomain_glo 
     93       ALLOCATE(mpi_req(nreq)) 
     94       ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 
     95 
     96       ireq=0 
     97       IF (mpi_rank==0) THEN 
     98          DO ind_glo=1,ndomain_glo 
     99             ireq=ireq+1 
     100             CALL MPI_ISEND(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 ,   & 
     101                  domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
     102          ENDDO 
     103       ENDIF 
     104 
     105       DO ind_loc=1,ndomain 
    147106          ireq=ireq+1 
    148  
    149           IF (field_glo(ind_glo)%ndim==2) THEN 
    150             CALL MPI_ISEND(field_glo(ind_glo)%rval2d,size(field_glo(ind_glo)%rval2d) , MPI_REAL8 ,   & 
    151                          domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
    152  
    153           ELSE IF (field_glo(ind_glo)%ndim==3) THEN 
    154             CALL MPI_ISEND(field_glo(ind_glo)%rval3d,size(field_glo(ind_glo)%rval3d) , MPI_REAL8 ,   & 
    155                          domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
    156  
    157           ELSE IF (field_glo(ind_glo)%ndim==4) THEN 
    158             CALL MPI_ISEND(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 ,   & 
    159                          domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
    160           ENDIF 
    161  
    162         ENDDO 
    163       ENDIF 
    164  
    165       DO ind_loc=1,ndomain 
    166         ireq=ireq+1 
    167  
    168         IF (field_loc(ind_loc)%ndim==2) THEN 
    169           CALL MPI_IRECV(field_loc(ind_loc)%rval2d,size(field_loc(ind_loc)%rval2d) , MPI_REAL8 ,   & 
    170                          0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
    171         ELSE IF (field_loc(ind_loc)%ndim==3) THEN 
    172           CALL MPI_IRECV(field_loc(ind_loc)%rval3d,size(field_loc(ind_loc)%rval3d) , MPI_REAL8 ,   & 
    173                          0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
    174         ELSE IF (field_loc(ind_loc)%ndim==4) THEN 
    175107          CALL MPI_IRECV(field_loc(ind_loc)%rval4d,size(field_loc(ind_loc)%rval4d) , MPI_REAL8 ,   & 
    176                          0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
    177         ENDIF 
    178  
    179       ENDDO 
    180  
    181       CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
     108               0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
     109       ENDDO 
     110 
     111       CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    182112 
    183113    ENDIF 
    … …  
    185115  END SUBROUTINE scatter_field 
    186116 
    187 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    188 !! Definition des Broadcast --> 4D   !! 
    189 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    190  
    191 !! -- Les chaine de charactï¿œre -- !! 
    192  
    193   SUBROUTINE bcast_mpi_c(var1) 
    194   IMPLICIT NONE 
    195     CHARACTER(LEN=*),INTENT(INOUT) :: Var1 
    196  
    197     CALL bcast_mpi_cgen(Var1,len(Var1)) 
    198  
    199   END SUBROUTINE bcast_mpi_c 
    200  
    201 !! -- Les entiers -- !! 
    202  
    203   SUBROUTINE bcast_mpi_i(var) 
    204   USE mpipara 
    205   IMPLICIT NONE 
    206     INTEGER,INTENT(INOUT) :: Var 
    207  
    208     INTEGER               :: var_tmp(1) 
    209  
    210     IF (is_mpi_master) var_tmp(1)=var 
    211     CALL bcast_mpi_igen(Var_tmp,1) 
    212     var=var_tmp(1) 
    213  
    214   END SUBROUTINE bcast_mpi_i 
    215  
    216   SUBROUTINE bcast_mpi_i1(var) 
    217   IMPLICIT NONE 
    218     INTEGER,INTENT(INOUT) :: Var(:) 
    219  
    220     CALL bcast_mpi_igen(Var,size(Var)) 
    221  
    222   END SUBROUTINE bcast_mpi_i1 
    223  
    224   SUBROUTINE bcast_mpi_i2(var) 
    225   IMPLICIT NONE 
    226     INTEGER,INTENT(INOUT) :: Var(:,:) 
    227  
    228     CALL bcast_mpi_igen(Var,size(Var)) 
    229  
    230   END SUBROUTINE bcast_mpi_i2 
    231  
    232   SUBROUTINE bcast_mpi_i3(var) 
    233   IMPLICIT NONE 
    234     INTEGER,INTENT(INOUT) :: Var(:,:,:) 
    235  
    236     CALL bcast_mpi_igen(Var,size(Var)) 
    237  
    238   END SUBROUTINE bcast_mpi_i3 
    239  
    240   SUBROUTINE bcast_mpi_i4(var) 
    241   IMPLICIT NONE 
    242     INTEGER,INTENT(INOUT) :: Var(:,:,:,:) 
    243  
    244     CALL bcast_mpi_igen(Var,size(Var)) 
    245  
    246   END SUBROUTINE bcast_mpi_i4 
    247  
    248  
    249 !! -- Les reels -- !! 
    250  
    251   SUBROUTINE bcast_mpi_r(var) 
    252   USE mpipara 
    253   IMPLICIT NONE 
    254     REAL,INTENT(INOUT) :: Var 
    255     REAL               :: var_tmp(1) 
    256  
    257     IF (is_mpi_master) var_tmp(1)=var 
    258     CALL bcast_mpi_rgen(Var_tmp,1) 
    259     var=var_tmp(1) 
    260  
    261   END SUBROUTINE bcast_mpi_r 
    262  
    263   SUBROUTINE bcast_mpi_r1(var) 
    264   IMPLICIT NONE 
    265     REAL,INTENT(INOUT) :: Var(:) 
    266  
    267     CALL bcast_mpi_rgen(Var,size(Var)) 
    268  
    269   END SUBROUTINE bcast_mpi_r1 
    270  
    271   SUBROUTINE bcast_mpi_r2(var) 
    272   IMPLICIT NONE 
    273     REAL,INTENT(INOUT) :: Var(:,:) 
    274  
    275     CALL bcast_mpi_rgen(Var,size(Var)) 
    276  
    277   END SUBROUTINE bcast_mpi_r2 
    278  
    279   SUBROUTINE bcast_mpi_r3(var) 
    280   IMPLICIT NONE 
    281     REAL,INTENT(INOUT) :: Var(:,:,:) 
    282  
    283     CALL bcast_mpi_rgen(Var,size(Var)) 
    284  
    285   END SUBROUTINE bcast_mpi_r3 
    286  
    287   SUBROUTINE bcast_mpi_r4(var) 
    288   IMPLICIT NONE 
    289     REAL,INTENT(INOUT) :: Var(:,:,:,:) 
    290  
    291     CALL bcast_mpi_rgen(Var,size(Var)) 
    292  
    293   END SUBROUTINE bcast_mpi_r4 
    294  
    295 !! -- Les booleans -- !! 
    296  
    297   SUBROUTINE bcast_mpi_l(var) 
    298   USE mpipara 
    299   IMPLICIT NONE 
    300     LOGICAL,INTENT(INOUT) :: Var 
    301     LOGICAL               :: var_tmp(1) 
    302  
    303     IF (is_mpi_master) var_tmp(1)=var 
    304     CALL bcast_mpi_lgen(Var_tmp,1) 
    305     var=var_tmp(1) 
    306  
    307   END SUBROUTINE bcast_mpi_l 
    308  
    309   SUBROUTINE bcast_mpi_l1(var) 
    310   IMPLICIT NONE 
    311     LOGICAL,INTENT(INOUT) :: Var(:) 
    312  
    313     CALL bcast_mpi_lgen(Var,size(Var)) 
    314  
    315   END SUBROUTINE bcast_mpi_l1 
    316  
    317   SUBROUTINE bcast_mpi_l2(var) 
    318   IMPLICIT NONE 
    319     LOGICAL,INTENT(INOUT) :: Var(:,:) 
    320  
    321     CALL bcast_mpi_lgen(Var,size(Var)) 
    322  
    323   END SUBROUTINE bcast_mpi_l2 
    324  
    325   SUBROUTINE bcast_mpi_l3(var) 
    326   IMPLICIT NONE 
    327     LOGICAL,INTENT(INOUT) :: Var(:,:,:) 
    328  
    329     CALL bcast_mpi_lgen(Var,size(Var)) 
    330  
    331   END SUBROUTINE bcast_mpi_l3 
    332  
    333   SUBROUTINE bcast_mpi_l4(var) 
    334   IMPLICIT NONE 
    335     LOGICAL,INTENT(INOUT) :: Var(:,:,:,:) 
    336  
    337     CALL bcast_mpi_lgen(Var,size(Var)) 
    338  
    339   END SUBROUTINE bcast_mpi_l4 
    340  
    341 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    342 !! DEFINITION DES FONCTIONS DE TRANSFERT GENERIQUES ! 
    343 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     117  !===================  Broadcast routines for strings ==================! 
    344118 
    345119  SUBROUTINE bcast_mpi_cgen(var,nb) 
    346120    USE mpi_mod 
    347121    USE mpipara 
    348     IMPLICIT NONE 
    349  
    350122    CHARACTER(LEN=*),INTENT(INOUT) :: Var 
    351123    INTEGER,INTENT(IN) :: nb 
    352  
    353124    IF (.NOT. using_mpi) RETURN 
    354  
    355125    CALL MPI_BCAST(Var,nb,MPI_CHARACTER,mpi_master,comm_icosa,ierr) 
    356  
    357126  END SUBROUTINE bcast_mpi_cgen 
    358127 
    359  
     128  SUBROUTINE bcast_mpi_c(var1) 
     129    CHARACTER(LEN=*),INTENT(INOUT) :: Var1 
     130    CALL bcast_mpi_cgen(Var1,len(Var1)) 
     131  END SUBROUTINE bcast_mpi_c 
     132 
     133  !============= Broadcast routines for INTEGER scalars and arrays ============! 
    360134 
    361135  SUBROUTINE bcast_mpi_igen(var,nb) 
    362136    USE mpi_mod 
    363137    USE mpipara 
    364     IMPLICIT NONE 
    365     INTEGER,INTENT(IN) :: nb 
    366     INTEGER,DIMENSION(nb),INTENT(INOUT) :: Var 
    367  
    368     IF (.NOT. using_mpi) RETURN 
    369  
    370     CALL MPI_BCAST(Var,nb,MPI_INTEGER,mpi_master,comm_icosa,ierr) 
    371  
     138    INTEGER, INTENT(IN) :: nb 
     139    INTEGER, DIMENSION(nb), INTENT(INOUT) :: var 
     140    IF (using_mpi) CALL MPI_BCAST(Var, nb, MPI_INTEGER, mpi_master, comm_icosa, ierr) 
    372141  END SUBROUTINE bcast_mpi_igen 
    373142 
    374  
    375  
     143  SUBROUTINE bcast_mpi_i(var) 
     144    USE mpipara 
     145    INTEGER, INTENT(INOUT) :: var 
     146    INTEGER                :: var_tmp(1) 
     147    IF (is_mpi_master) var_tmp(1)=var 
     148    CALL bcast_mpi_igen(var_tmp,1) 
     149    var=var_tmp(1) 
     150  END SUBROUTINE bcast_mpi_i 
     151 
     152  SUBROUTINE bcast_mpi_i1(var) 
     153    INTEGER, INTENT(INOUT) :: var(:) 
     154    CALL bcast_mpi_igen(var,size(var)) 
     155  END SUBROUTINE bcast_mpi_i1 
     156 
     157  SUBROUTINE bcast_mpi_i2(var) 
     158    INTEGER, INTENT(INOUT) :: var(:,:) 
     159    CALL bcast_mpi_igen(var,size(var)) 
     160  END SUBROUTINE bcast_mpi_i2 
     161 
     162  SUBROUTINE bcast_mpi_i3(var) 
     163    INTEGER, INTENT(INOUT) :: var(:,:,:) 
     164    CALL bcast_mpi_igen(var,size(var)) 
     165  END SUBROUTINE bcast_mpi_i3 
     166 
     167  SUBROUTINE bcast_mpi_i4(var) 
     168    INTEGER, INTENT(INOUT) :: var(:,:,:,:) 
     169    CALL bcast_mpi_igen(var,size(var)) 
     170  END SUBROUTINE bcast_mpi_i4 
     171 
     172  !============= Broadcast routines for REAL scalars and arrays ============! 
    376173 
    377174  SUBROUTINE bcast_mpi_rgen(var,nb) 
    378175    USE mpi_mod 
    379176    USE mpipara 
    380     IMPLICIT NONE 
    381     INTEGER,INTENT(IN) :: nb 
    382     REAL,DIMENSION(nb),INTENT(INOUT) :: Var 
    383  
    384     IF (.NOT. using_mpi) RETURN 
    385  
    386     CALL MPI_BCAST(Var,nb,MPI_REAL8,mpi_master,comm_icosa,ierr) 
    387  
     177    INTEGER, INTENT(IN) :: nb 
     178    REAL, DIMENSION(nb), INTENT(INOUT) :: var 
     179    IF (using_mpi) CALL MPI_BCAST(Var, nb, MPI_REAL8, mpi_master, comm_icosa, ierr) 
    388180  END SUBROUTINE bcast_mpi_rgen 
    389181 
    390  
    391  
     182  SUBROUTINE bcast_mpi_r(var) 
     183    USE mpipara 
     184    REAL, INTENT(INOUT) :: var 
     185    REAL                :: var_tmp(1) 
     186    IF (is_mpi_master) var_tmp(1)=var 
     187    CALL bcast_mpi_rgen(var_tmp,1) 
     188    var=var_tmp(1) 
     189  END SUBROUTINE bcast_mpi_r 
     190 
     191  SUBROUTINE bcast_mpi_r1(var) 
     192    REAL, INTENT(INOUT) :: var(:) 
     193    CALL bcast_mpi_rgen(var,size(var)) 
     194  END SUBROUTINE bcast_mpi_r1 
     195 
     196  SUBROUTINE bcast_mpi_r2(var) 
     197    REAL, INTENT(INOUT) :: var(:,:) 
     198    CALL bcast_mpi_rgen(var,size(var)) 
     199  END SUBROUTINE bcast_mpi_r2 
     200 
     201  SUBROUTINE bcast_mpi_r3(var) 
     202    REAL, INTENT(INOUT) :: var(:,:,:) 
     203    CALL bcast_mpi_rgen(var,size(var)) 
     204  END SUBROUTINE bcast_mpi_r3 
     205 
     206  SUBROUTINE bcast_mpi_r4(var) 
     207    REAL, INTENT(INOUT) :: var(:,:,:,:) 
     208    CALL bcast_mpi_rgen(var,size(var)) 
     209  END SUBROUTINE bcast_mpi_r4 
     210 
     211  !============= Broadcast routines for LOGICAL scalars and arrays ============! 
    392212 
    393213  SUBROUTINE bcast_mpi_lgen(var,nb) 
    394214    USE mpi_mod 
    395215    USE mpipara 
    396     IMPLICIT NONE 
    397     INTEGER,INTENT(IN) :: nb 
    398     LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var 
    399  
    400     IF (.NOT. using_mpi) RETURN 
    401  
    402     CALL MPI_BCAST(Var,nb,MPI_LOGICAL,mpi_master,comm_icosa,ierr) 
    403  
     216    INTEGER, INTENT(IN) :: nb 
     217    LOGICAL, DIMENSION(nb), INTENT(INOUT) :: var 
     218    IF (using_mpi) CALL MPI_BCAST(Var, nb, MPI_LOGICAL, mpi_master, comm_icosa, ierr) 
    404219  END SUBROUTINE bcast_mpi_lgen 
    405220 
     221  SUBROUTINE bcast_mpi_l(var) 
     222    USE mpipara 
     223    LOGICAL, INTENT(INOUT) :: var 
     224    LOGICAL                :: var_tmp(1) 
     225    IF (is_mpi_master) var_tmp(1)=var 
     226    CALL bcast_mpi_lgen(var_tmp,1) 
     227    var=var_tmp(1) 
     228  END SUBROUTINE bcast_mpi_l 
     229 
     230  SUBROUTINE bcast_mpi_l1(var) 
     231    LOGICAL, INTENT(INOUT) :: var(:) 
     232    CALL bcast_mpi_lgen(var,size(var)) 
     233  END SUBROUTINE bcast_mpi_l1 
     234 
     235  SUBROUTINE bcast_mpi_l2(var) 
     236    LOGICAL, INTENT(INOUT) :: var(:,:) 
     237    CALL bcast_mpi_lgen(var,size(var)) 
     238  END SUBROUTINE bcast_mpi_l2 
     239 
     240  SUBROUTINE bcast_mpi_l3(var) 
     241    LOGICAL, INTENT(INOUT) :: var(:,:,:) 
     242    CALL bcast_mpi_lgen(var,size(var)) 
     243  END SUBROUTINE bcast_mpi_l3 
     244 
     245  SUBROUTINE bcast_mpi_l4(var) 
     246    LOGICAL, INTENT(INOUT) :: var(:,:,:,:) 
     247    CALL bcast_mpi_lgen(var,size(var)) 
     248  END SUBROUTINE bcast_mpi_l4 
    406249 
    407250END MODULE transfert_mpi_collectives_mod 
    408  
    409  
    410  
    411  
    412  
Note: See TracChangeset for help on using the changeset viewer.