Changeset 963


Ignore:
Timestamp:
07/25/19 11:36:36 (5 years ago)
Author:
adurocher
Message:

Merge 'mpi_rewrite' into trunk

Location:
codes/icosagcm/trunk/src
Files:
2 added
8 edited
1 copied

Legend:

Unmodified
Added
Removed

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

    r953 r963  
    1313  TYPE t_field 
    1414    CHARACTER(30)      :: name 
    15     REAL(rstd),POINTER :: rval2d(:) => null() 
    16     REAL(rstd),POINTER :: rval3d(:,:) => null() 
    17     REAL(rstd),POINTER :: rval4d(:,:,:) => null() 
     15    REAL(rstd),POINTER, CONTIGUOUS :: rval2d(:) => null() 
     16    REAL(rstd),POINTER, CONTIGUOUS :: rval3d(:,:) => null() 
     17    REAL(rstd),POINTER, CONTIGUOUS :: rval4d(:,:,:) => null() 
    1818 
    1919    INTEGER,POINTER :: ival2d(:) 
    … …  
    274274       IF (field(ind)%ndim==4) THEN 
    275275          IF (data_type==type_integer) THEN 
     276             IF (field(ind)%ondevice) THEN 
     277                !$acc exit data delete(field(ind)%ival4d(:,:,:)) 
     278                CONTINUE 
     279             END IF 
    276280             DEALLOCATE(field(ind)%ival4d) 
    277              IF (field(ind)%ondevice) THEN 
    278                 !$acc exit data delete(field(ind)%ival4d) 
    279                 CONTINUE 
    280              END IF 
    281281          END IF 
    282282 
    283283          IF (data_type==type_real) THEN 
     284             IF (field(ind)%ondevice) THEN 
     285                !$acc exit data delete(field(ind)%rval4d(:,:,:)) 
     286                CONTINUE 
     287             END IF 
    284288             DEALLOCATE(field(ind)%rval4d) 
    285              IF (field(ind)%ondevice) THEN 
    286                 !$acc exit data delete(field(ind)%rval4d) 
    287                 CONTINUE 
    288              END IF 
    289289          END IF 
    290290 
    291291          IF (data_type==type_logical) THEN 
     292             IF (field(ind)%ondevice) THEN 
     293                !$acc exit data delete(field(ind)%lval4d(:,:,:)) 
     294                CONTINUE 
     295             END IF 
    292296             DEALLOCATE(field(ind)%lval4d) 
    293              IF (field(ind)%ondevice) THEN 
    294                 !$acc exit data delete(field(ind)%lval4d) 
    295                 CONTINUE 
    296              END IF 
    297297          END IF 
    298298 
    299299       ELSE IF (field(ind)%ndim==3) THEN 
    300300          IF (data_type==type_integer) THEN 
     301             IF (field(ind)%ondevice) THEN 
     302                !$acc exit data delete(field(ind)%ival3d(:,:)) 
     303                CONTINUE 
     304             END IF 
    301305             DEALLOCATE(field(ind)%ival3d) 
    302              IF (field(ind)%ondevice) THEN 
    303                 !$acc exit data delete(field(ind)%ival3d) 
    304                 CONTINUE 
    305              END IF 
    306306          END IF 
    307307 
    308308          IF (data_type==type_real) THEN 
     309             IF (field(ind)%ondevice) THEN 
     310                !$acc exit data delete(field(ind)%rval3d(:,:)) 
     311                CONTINUE 
     312             END IF 
    309313             DEALLOCATE(field(ind)%rval3d) 
    310              IF (field(ind)%ondevice) THEN 
    311                 !$acc exit data delete(field(ind)%rval3d) 
    312                 CONTINUE 
    313              END IF 
    314314          END IF 
    315315 
    316316          IF (data_type==type_logical) THEN 
     317             IF (field(ind)%ondevice) THEN 
     318                !$acc exit data delete(field(ind)%lval3d(:,:)) 
     319                CONTINUE 
     320             END IF 
    317321             DEALLOCATE(field(ind)%lval3d) 
    318              IF (field(ind)%ondevice) THEN 
    319                 !$acc exit data delete(field(ind)%lval3d) 
    320                 CONTINUE 
    321              END IF 
    322322          END IF 
    323323 
    324324       ELSE IF (field(ind)%ndim==2) THEN 
    325325          IF (data_type==type_integer) THEN 
     326             IF (field(ind)%ondevice) THEN 
     327                !$acc exit data delete(field(ind)%ival2d(:)) 
     328                CONTINUE 
     329             END IF 
    326330             DEALLOCATE(field(ind)%ival2d) 
    327              IF (field(ind)%ondevice) THEN 
    328                 !$acc exit data delete(field(ind)%ival2d) 
    329                 CONTINUE 
    330              END IF 
    331331          END IF 
    332332 
    333333          IF (data_type==type_real) THEN 
     334             IF (field(ind)%ondevice) THEN 
     335                !$acc exit data delete(field(ind)%rval2d(:)) 
     336                CONTINUE 
     337             END IF 
    334338             DEALLOCATE(field(ind)%rval2d) 
    335              IF (field(ind)%ondevice) THEN 
    336                 !$acc exit data delete(field(ind)%rval2d) 
    337                 CONTINUE 
    338              END IF 
    339339          END IF 
    340340 
    341341          IF (data_type==type_logical) THEN 
     342             IF (field(ind)%ondevice) THEN 
     343                !$acc exit data delete(field(ind)%lval2d(:)) 
     344                CONTINUE 
     345             END IF 
    342346             DEALLOCATE(field(ind)%lval2d) 
    343              IF (field(ind)%ondevice) THEN 
    344                 !$acc exit data delete(field(ind)%lval2d) 
    345                 CONTINUE 
    346              END IF 
    347347          END IF 
    348348 
    349349       ENDIF 
    350  
    351350    ENDDO 
    352351  END SUBROUTINE deallocate_field_ 
    … …  
    555554      IF (field(ind)%ndim==4) THEN 
    556555         IF (field(ind)%data_type==type_integer) THEN 
    557             !$acc update device(field(ind)%ival4d(:,:,:)) 
     556            !$acc update device(field(ind)%ival4d(:,:,:)) async 
    558557            CONTINUE 
    559558         END IF 
    560559 
    561560         IF (field(ind)%data_type==type_real) THEN 
    562             !$acc update device(field(ind)%rval4d(:,:,:)) 
     561            !$acc update device(field(ind)%rval4d(:,:,:)) async 
    563562            CONTINUE 
    564563         END IF 
    565564 
    566565         IF (field(ind)%data_type==type_logical) THEN 
    567             !$acc update device(field(ind)%lval4d(:,:,:)) 
     566            !$acc update device(field(ind)%lval4d(:,:,:)) async 
    568567            CONTINUE 
    569568         END IF 
    … …  
    571570      ELSE IF (field(ind)%ndim==3) THEN 
    572571         IF (field(ind)%data_type==type_integer) THEN 
    573             !$acc update device(field(ind)%ival3d(:,:)) 
     572            !$acc update device(field(ind)%ival3d(:,:)) async 
    574573            CONTINUE 
    575574         END IF 
    576575 
    577576         IF (field(ind)%data_type==type_real) THEN 
    578             !$acc update device(field(ind)%rval3d(:,:)) 
     577            !$acc update device(field(ind)%rval3d(:,:)) async 
    579578            CONTINUE 
    580579         END IF 
    581580 
    582581         IF (field(ind)%data_type==type_logical) THEN 
    583             !$acc update device(field(ind)%lval3d(:,:)) 
     582            !$acc update device(field(ind)%lval3d(:,:)) async 
    584583            CONTINUE 
    585584         END IF 
    … …  
    587586      ELSE IF (field(ind)%ndim==2) THEN 
    588587         IF (field(ind)%data_type==type_integer) THEN 
    589             !$acc update device(field(ind)%ival2d(:)) 
     588            !$acc update device(field(ind)%ival2d(:)) async 
    590589            CONTINUE 
    591590         END IF 
    592591 
    593592         IF (field(ind)%data_type==type_real) THEN 
    594             !$acc update device(field(ind)%rval2d(:)) 
     593            !$acc update device(field(ind)%rval2d(:)) async 
    595594            CONTINUE 
    596595         END IF 
    597596 
    598597         IF (field(ind)%data_type==type_logical) THEN 
    599             !$acc update device(field(ind)%lval2d(:)) 
     598            !$acc update device(field(ind)%lval2d(:)) async 
    600599            CONTINUE 
    601600         END IF 
    … …  
    616615 
    617616      IF (field(ind)%ondevice) THEN 
    618          
     617 
    619618         IF (field(ind)%ndim==4) THEN 
    620619            IF (field(ind)%data_type==type_integer) THEN 
    621                !$acc update host(field(ind)%ival4d(:,:,:)) wait 
     620               !$acc update host(field(ind)%ival4d(:,:,:)) async 
    622621               CONTINUE 
    623622            END IF 
    624623 
    625624            IF (field(ind)%data_type==type_real) THEN 
    626                !$acc update host(field(ind)%rval4d(:,:,:)) wait 
     625               !$acc update host(field(ind)%rval4d(:,:,:)) async 
    627626               CONTINUE 
    628627            END IF 
    629628 
    630629            IF (field(ind)%data_type==type_logical) THEN 
    631                !$acc update host(field(ind)%lval4d(:,:,:)) wait 
    632                CONTINUE 
    633             END IF 
    634           
     630               !$acc update host(field(ind)%lval4d(:,:,:)) async 
     631               CONTINUE 
     632            END IF 
     633 
    635634         ELSE IF (field(ind)%ndim==3) THEN 
    636635            IF (field(ind)%data_type==type_integer) THEN 
    637                !$acc update host(field(ind)%ival3d(:,:)) wait 
     636               !$acc update host(field(ind)%ival3d(:,:)) async 
    638637               CONTINUE 
    639638            END IF 
    640639 
    641640            IF (field(ind)%data_type==type_real) THEN 
    642                !$acc update host(field(ind)%rval3d(:,:)) wait 
     641               !$acc update host(field(ind)%rval3d(:,:)) async 
    643642               CONTINUE 
    644643            END IF 
    645644 
    646645            IF (field(ind)%data_type==type_logical) THEN 
    647                !$acc update host(field(ind)%lval3d(:,:)) wait 
     646               !$acc update host(field(ind)%lval3d(:,:)) async 
    648647               CONTINUE 
    649648            END IF 
    … …  
    651650         ELSE IF (field(ind)%ndim==2) THEN 
    652651            IF (field(ind)%data_type==type_integer) THEN 
    653                !$acc update host(field(ind)%ival2d(:)) wait 
     652               !$acc update host(field(ind)%ival2d(:)) async 
    654653               CONTINUE 
    655654            END IF 
    656655 
    657656            IF (field(ind)%data_type==type_real) THEN 
    658                !$acc update host(field(ind)%rval2d(:)) wait 
     657               !$acc update host(field(ind)%rval2d(:)) async 
    659658               CONTINUE 
    660659            END IF 
    661660 
    662661            IF (field(ind)%data_type==type_logical) THEN 
    663                !$acc update host(field(ind)%lval2d(:)) wait 
     662               !$acc update host(field(ind)%lval2d(:)) async 
    664663               CONTINUE 
    665664            END IF 
    … …  
    667666      END IF 
    668667   ENDDO 
     668   !$acc wait 
    669669   !$OMP BARRIER 
    670670 END SUBROUTINE update_host_field 
    … …  
    679679    IF (field%ndim==4) THEN 
    680680       IF (field%data_type==type_integer) THEN 
    681           !$acc enter data create(field%ival4d(:,:,:)) 
     681          !$acc enter data create(field%ival4d(:,:,:)) async 
    682682       END IF 
    683683 
    684684       IF (field%data_type==type_real) THEN 
    685           !$acc enter data create(field%rval4d(:,:,:)) 
     685          !$acc enter data create(field%rval4d(:,:,:)) async 
    686686       END IF 
    687687 
    688688       IF (field%data_type==type_logical) THEN 
    689           !$acc enter data create(field%lval4d(:,:,:)) 
     689          !$acc enter data create(field%lval4d(:,:,:)) async 
    690690       END IF 
    691691 
    692692    ELSE IF (field%ndim==3) THEN 
    693693       IF (field%data_type==type_integer) THEN 
    694           !$acc enter data create(field%ival3d(:,:)) 
     694          !$acc enter data create(field%ival3d(:,:)) async 
    695695       END IF 
    696696 
    697697       IF (field%data_type==type_real) THEN 
    698           !$acc enter data create(field%rval3d(:,:)) 
     698          !$acc enter data create(field%rval3d(:,:)) async 
    699699       END IF 
    700700 
    701701       IF (field%data_type==type_logical) THEN 
    702           !$acc enter data create(field%lval3d(:,:)) 
     702          !$acc enter data create(field%lval3d(:,:)) async 
    703703       END IF 
    704704 
    705705    ELSE IF (field%ndim==2) THEN 
    706706       IF (field%data_type==type_integer) THEN 
    707           !$acc enter data create(field%ival2d(:)) 
     707          !$acc enter data create(field%ival2d(:)) async 
    708708       END IF 
    709709 
    710710       IF (field%data_type==type_real) THEN 
    711           !$acc enter data create(field%rval2d(:)) 
     711          !$acc enter data create(field%rval2d(:)) async 
    712712       END IF 
    713713 
    714714       IF (field%data_type==type_logical) THEN 
    715           !$acc enter data create(field%lval2d(:)) 
     715          !$acc enter data create(field%lval2d(:)) async 
    716716       END IF 
    717717    ENDIF 

  • codes/icosagcm/trunk/src/dissip/dissip_gcm.F90

    r954 r963  
    44  PRIVATE 
    55 
    6   TYPE(t_field),POINTER,SAVE :: f_due_diss1(:) 
    7   TYPE(t_field),POINTER,SAVE :: f_due_diss2(:) 
     6  TYPE(t_field),POINTER,SAVE :: f_due_diss_gradiv(:) 
     7  TYPE(t_field),POINTER,SAVE :: f_due_diss_gradrot(:) 
    88 
    99  TYPE(t_field),POINTER,SAVE :: f_dtheta_diss(:) 
    1010  TYPE(t_field),POINTER,SAVE :: f_dtheta_rhodz_diss(:) 
    11   TYPE(t_message),SAVE :: req_due, req_dtheta  
     11  TYPE(t_message),SAVE :: req_due_gradiv, req_due_gradrot, req_dtheta  
    1212  
    1313  INTEGER,SAVE :: nitergdiv=1 
    … …  
    4747  SUBROUTINE allocate_dissip 
    4848  USE icosa 
    49   IMPLICIT NONE   
    50     CALL allocate_field(f_due_diss1,field_u,type_real,llm,ondevice=.TRUE.) 
    51     CALL allocate_field(f_due_diss2,field_u,type_real,llm,ondevice=.TRUE.) 
     49  IMPLICIT NONE 
     50    CALL allocate_field(f_due_diss_gradiv,field_u,type_real,llm,ondevice=.TRUE.) 
     51    CALL allocate_field(f_due_diss_gradrot,field_u,type_real,llm,ondevice=.TRUE.) 
    5252    CALL allocate_field(f_dtheta_diss,field_t,type_real,llm) 
    5353    CALL allocate_field(f_dtheta_rhodz_diss,field_t,type_real,llm,ondevice=.TRUE.) 
    … …  
    140140    CALL allocate_field(f_dtheta,field_t,type_real,ondevice=.TRUE.) 
    141141     
    142     CALL init_message(f_due_diss1,req_e1_vect,req_due) 
    143     CALL init_message(f_dtheta_diss,req_i1,req_dtheta) 
     142    CALL init_message(f_due_diss_gradiv,req_e1_vect,req_due_gradiv) 
     143    CALL init_message(f_due_diss_gradrot,req_e1_vect,req_due_gradrot) 
     144    CALL init_message(f_dtheta_rhodz_diss,req_i1,req_dtheta) 
    144145 
    145146    tau_graddiv(:)=5000 
    … …  
    548549     
    549550    CALL trace_start("dissip") 
    550     CALL gradiv(f_ue,f_due_diss1) 
    551     CALL gradrot(f_ue,f_due_diss2) 
     551    CALL gradiv(f_ue,f_due_diss_gradiv) 
     552    CALL gradrot(f_ue,f_due_diss_gradrot) 
    552553 
    553554    CALL divgrad_theta_rhodz(f_mass,f_theta_rhodz,f_dtheta_rhodz_diss) 
    … …  
    558559      CALL swap_geometry(ind) 
    559560      due=f_due(ind)  
    560       due_diss1=f_due_diss1(ind) 
    561       due_diss2=f_due_diss2(ind) 
     561      due_diss1=f_due_diss_gradiv(ind) 
     562      due_diss2=f_due_diss_gradrot(ind) 
    562563      dtheta_rhodz=f_dtheta_rhodz(ind) 
    563564      dtheta_rhodz_diss=f_dtheta_rhodz_diss(ind) 
    … …  
    653654         USE output_field_mod 
    654655 
    655          CALL transfert_request(f_due_diss1,req_e1_vect) 
    656          CALL un2ulonlat(f_due_diss1, f_buf_ulon, f_buf_ulat, (1./(tau_graddiv(1)))) 
     656         CALL transfert_request(f_due_diss_gradiv,req_e1_vect) 
     657         CALL un2ulonlat(f_due_diss_gradiv, f_buf_ulon, f_buf_ulat, (1./(tau_graddiv(1)))) 
    657658         CALL output_field("dulon_diss1",f_buf_ulon) 
    658659         CALL output_field("dulat_diss1",f_buf_ulat) 
    659660! 
    660          CALL transfert_request(f_due_diss2,req_e1_vect) 
    661          CALL un2ulonlat(f_due_diss2, f_buf_ulon, f_buf_ulat, (1./(tau_graddiv(1)))) 
     661         CALL transfert_request(f_due_diss_gradrot,req_e1_vect) 
     662         CALL un2ulonlat(f_due_diss_gradrot, f_buf_ulon, f_buf_ulat, (1./(tau_graddiv(1)))) 
    662663         CALL output_field("dulon_diss2",f_buf_ulon) 
    663664         CALL output_field("dulat_diss2",f_buf_ulat) 
    … …  
    699700 
    700701    DO it=1,nitergdiv 
    701       CALL send_message(f_due,req_due) 
    702       CALL wait_message(req_due) 
    703  
     702      CALL send_message(f_due,req_due_gradiv) 
     703      CALL wait_message(req_due_gradiv) 
    704704      DO ind=1,ndomain 
    705705        IF (.NOT. assigned_domain(ind)) CYCLE 
    … …  
    749749 
    750750    DO it=1,nitergrot 
    751       CALL send_message(f_due,req_due) 
    752       CALL wait_message(req_due) 
     751      CALL send_message(f_due,req_due_gradrot) 
     752      CALL wait_message(req_due_gradrot) 
    753753         
    754754      DO ind=1,ndomain 

  • codes/icosagcm/trunk/src/output/write_field.f90

    r899 r963  
    6666    USE domain_mod 
    6767    USE field_mod 
    68     USE transfert_mpi_mod 
     68    USE transfert_mod 
    6969    USE dimensions 
    7070    USE mpipara 

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

    r899 r963  
    694694     
    695695    ENDDO 
     696 
     697    !$acc enter data copyin(assigned_domain(:)) 
    696698     
    697699  END SUBROUTINE assign_domain_omp 

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

    r711 r963  
    1 MODULE transfert_mod 
    2  
     1module transfert_mod 
    32#ifdef CPP_USING_MPI 
    4   USE transfert_mpi_mod, ONLY : init_transfert, transfert_request=>transfert_request_mpi, req_i1,req_e1_vect, & 
    5                                 req_e1_scal, req_z1_scal, req_i0, req_e0_vect, req_e0_scal, request_add_point,             & 
    6                                 create_request, gather_field, scatter_field,         & 
    7                                 t_message, init_message=>init_message_mpi,           & 
    8                                 transfert_message=>transfert_message_mpi,            & 
    9                                 send_message=>send_message_mpi,                      & 
    10                                 test_message=>test_message_mpi,                      & 
    11                                 wait_message=>wait_message_mpi,barrier,bcast_mpi 
    12 #else  
    13   USE transfert_mpi_mod, ONLY : init_transfert, transfert_request=>transfert_request_seq, req_i1,req_e1_vect, & 
    14                                 req_e1_scal, req_z1_scal, req_i0, req_e0_vect, req_e0_scal,        & 
    15                                 request_add_point, create_request, gather_field,     & 
    16                                 scatter_field, t_message,                            & 
    17                                 init_message=>init_message_seq,                      & 
    18                                 transfert_message=>transfert_message_seq,            & 
    19                                 send_message=>send_message_seq,                      & 
    20                                 test_message=>test_message_seq,                      & 
    21                                 wait_message=>wait_message_seq,barrier, bcast_mpi 
     3 
     4#if defined(CPP_USING_MPI_LEGACY) 
     5#warning("Using legacy transfert_mpi (not default)") 
     6  use transfert_mpi_legacy_mod, only :  t_message, t_request, & 
     7                                        req_i1, req_e1_scal, req_e1_vect, & 
     8                                        req_i0, req_e0_scal, req_e0_vect, & 
     9                                        req_z1_scal, & 
     10                                        init_transfert, & 
     11                                        init_message => init_message_mpi, & 
     12                                        finalize_message => finalize_message_mpi, & 
     13                                        send_message => send_message_mpi, & 
     14                                        wait_message => wait_message_mpi, & 
     15                                        test_message => test_message_mpi 
     16#else 
     17  ! transfert_mpi using manual pack/unpack (default) 
     18  use transfert_mpi_mod, only : t_message, t_request, & 
     19                                req_i1, req_e1_scal, req_e1_vect, & 
     20                                req_i0, req_e0_scal, req_e0_vect, & 
     21                                req_z1_scal, & 
     22                                init_transfert, & 
     23                                init_message, & 
     24                                finalize_message, & 
     25                                send_message, & 
     26                                wait_message, & 
     27                                test_message 
    2228#endif 
    23  
    24   USE transfert_omp_mod 
    25    
    26   INTERFACE bcast 
    27     MODULE PROCEDURE bcast_c,                                     & 
    28                      bcast_i,bcast_i1,bcast_i2,bcast_i3,bcast_i4, & 
    29                      bcast_r,bcast_r1,bcast_r2,bcast_r3,bcast_r4, & 
    30                      bcast_l,bcast_l1,bcast_l2,bcast_l3,bcast_l4 
    31  
    32   END INTERFACE 
    33  
    34  
    35 CONTAINS 
    36  
     29#else 
     30#warning("Using transfert_seq (unmaintained)") 
     31  use transfert_mpi_legacy_mod, only :  t_message, t_request, & 
     32                                        req_i1, req_e1_scal, req_e1_vect, & 
     33                                        req_i0, req_e0_scal, req_e0_vect, & 
     34                                        req_z1_scal, & 
     35                                        init_transfert, & 
     36                                        init_message=>init_message_seq, & 
     37                                        finalize_message => finalize_message_seq, & 
     38                                        send_message => send_message_seq, & 
     39                                        wait_message => wait_message_seq, & 
     40                                        test_message => test_message_seq 
     41#endif 
     42  use transfert_mpi_collectives_mod, only : gather_field, scatter_field, bcast_field, bcast_mpi 
     43  use transfert_omp_mod, only : bcast_omp 
     44 
     45  implicit none 
     46  private 
     47  public :: t_message, t_request, & 
     48          req_i1, req_e1_scal, req_e1_vect, & 
     49          req_i0, req_e0_scal, req_e0_vect, & 
     50          !req_z1_scal, & 
     51          init_transfert, & 
     52          init_message, & 
     53          finalize_message, & 
     54          send_message, & 
     55          wait_message, & 
     56          test_message, & 
     57          transfert_request, & 
     58          transfert_message, & 
     59          gather_field, scatter_field, bcast_field, bcast, bcast_omp 
     60 
     61  interface bcast 
     62    module procedure  bcast_c,                                     & 
     63                      bcast_i,bcast_i1,bcast_i2,bcast_i3,bcast_i4, & 
     64                      bcast_r,bcast_r1,bcast_r2,bcast_r3,bcast_r4, & 
     65                      bcast_l,bcast_l1,bcast_l2,bcast_l3,bcast_l4 
     66  end interface 
     67 
     68contains 
     69  subroutine transfert_message(field, message) 
     70    use field_mod, only : t_field 
     71    type(t_field), pointer :: field(:) 
     72    type(t_message) :: message 
     73 
     74    call send_message(field, message) 
     75    call wait_message(message) 
     76  end subroutine 
     77 
     78  subroutine transfert_request(field, request) 
     79    use field_mod, only : t_field 
     80    type(t_field),pointer :: field(:) 
     81    type(t_request),pointer :: request(:) 
     82    type(t_message), save :: message ! Save because shared between threads 
     83 
     84    call init_message(field, request, message) 
     85    call transfert_message(field, message) 
     86    call finalize_message(message) 
     87  end subroutine 
    3788 
    3889!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    … …  
    4091!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    4192 
    42 !! -- Les chaine de charactère -- !! 
     93!! -- Les chaine de charactï¿œre -- !! 
    4394 
    4495  SUBROUTINE bcast_c(var) 

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

    r962 r963  
    1 MODULE transfert_mpi_mod 
    2 USE genmod 
    3 USE field_mod 
    4 IMPLICIT NONE 
    5    
    6   TYPE array 
    7     INTEGER,POINTER :: value(:)=>null() 
    8     INTEGER,POINTER :: sign(:)=>null() 
    9     INTEGER         :: domain 
    10     INTEGER         :: rank 
    11     INTEGER         :: tag 
    12     INTEGER         :: size 
    13     INTEGER         :: offset 
    14     INTEGER         :: ireq 
    15     INTEGER,POINTER :: buffer(:)=>null() 
    16     REAL,POINTER    :: buffer_r(:)=>null() 
    17     INTEGER,POINTER :: src_value(:)=>null() 
    18   END TYPE array 
    19    
    20   TYPE t_buffer 
    21     REAL,POINTER    :: r(:) 
    22     INTEGER         :: size 
    23     INTEGER         :: rank 
    24   END TYPE t_buffer     
    25      
    26   TYPE t_request 
    27     INTEGER :: type_field 
    28     INTEGER :: max_size 
    29     INTEGER :: size 
    30     LOGICAL :: vector 
    31     INTEGER,POINTER :: src_domain(:) 
    32     INTEGER,POINTER :: src_i(:) 
    33     INTEGER,POINTER :: src_j(:) 
    34     INTEGER,POINTER :: src_ind(:) 
    35     INTEGER,POINTER :: target_ind(:) 
    36     INTEGER,POINTER :: target_i(:) 
    37     INTEGER,POINTER :: target_j(:) 
    38     INTEGER,POINTER :: target_sign(:) 
    39     INTEGER :: nrecv 
    40     TYPE(ARRAY),POINTER :: recv(:) 
    41     INTEGER :: nsend 
    42     INTEGER :: nreq_mpi 
    43     INTEGER :: nreq_send 
    44     INTEGER :: nreq_recv 
    45     TYPE(ARRAY),POINTER :: send(:) 
    46   END TYPE t_request 
    47    
    48   TYPE(t_request),SAVE,POINTER :: req_i1(:) 
    49   TYPE(t_request),SAVE,POINTER :: req_e1_scal(:) 
    50   TYPE(t_request),SAVE,POINTER :: req_e1_vect(:) 
    51   TYPE(t_request),SAVE,POINTER :: req_z1_scal(:) 
    52    
    53   TYPE(t_request),SAVE,POINTER :: req_i0(:) 
    54   TYPE(t_request),SAVE,POINTER :: req_e0_scal(:) 
    55   TYPE(t_request),SAVE,POINTER :: req_e0_vect(:) 
    56  
    57   TYPE t_reorder 
    58     INTEGER :: ind 
    59     INTEGER :: rank 
    60     INTEGER :: tag 
    61     INTEGER :: isend 
    62   END TYPE t_reorder   
    63    
    64   TYPE t_message 
    65     CHARACTER(LEN=100) :: name ! for debug 
    66     TYPE(t_request), POINTER :: request(:) 
    67     INTEGER :: nreq 
    68     INTEGER :: nreq_send 
    69     INTEGER :: nreq_recv 
    70     TYPE(t_reorder), POINTER :: reorder(:) 
    71     INTEGER, POINTER :: mpi_req(:) 
    72     INTEGER, POINTER :: status(:,:) 
    73     TYPE(t_buffer),POINTER :: buffers(:)  
    74     TYPE(t_field),POINTER :: field(:) 
    75     LOGICAL :: completed 
    76     LOGICAL :: pending 
    77     LOGICAL :: open      ! for debug 
    78     INTEGER :: number 
    79     LOGICAL :: ondevice=.false. !<Ready to transfer ondevice field 
    80   END TYPE t_message 
    81  
    82  
    83   INTERFACE bcast_mpi 
    84     MODULE PROCEDURE bcast_mpi_c,                                                     & 
    85                      bcast_mpi_i,bcast_mpi_i1,bcast_mpi_i2,bcast_mpi_i3,bcast_mpi_i4, & 
    86                      bcast_mpi_r,bcast_mpi_r1,bcast_mpi_r2,bcast_mpi_r3,bcast_mpi_r4, & 
    87                      bcast_mpi_l,bcast_mpi_l1,bcast_mpi_l2,bcast_mpi_l3,bcast_mpi_l4 
    88   END INTERFACE 
    89  
    90   integer :: profile_mpi_copies, profile_mpi_waitall, profile_mpi_omp_barrier 
    91  
    92 CONTAINS 
    93         
    94        
    95   SUBROUTINE init_transfert 
    96   USE profiling_mod 
    97   USE domain_mod 
    98   USE dimensions 
    99   USE field_mod 
    100   USE metric 
    101   USE mpipara 
    102   USE mpi_mod 
    103   IMPLICIT NONE 
    104   INTEGER :: ind,i,j 
    105  
    106     CALL register_id('MPI', id_mpi) 
    107     CALL register_id('MPI_copies', profile_mpi_copies) 
    108     CALL register_id('MPI_waitall', profile_mpi_waitall) 
    109     CALL register_id('MPI_omp_barrier', profile_mpi_omp_barrier) 
    110  
    111     CALL create_request(field_t,req_i1) 
    112  
    113     DO ind=1,ndomain 
    114       CALL swap_dimensions(ind) 
    115       DO i=ii_begin,ii_end+1 
    116         CALL request_add_point(ind,i,jj_begin-1,req_i1) 
    117       ENDDO 
    118  
    119       DO j=jj_begin,jj_end 
    120         CALL request_add_point(ind,ii_end+1,j,req_i1) 
    121       ENDDO     
    122       DO i=ii_begin,ii_end 
    123         CALL request_add_point(ind,i,jj_end+1,req_i1) 
    124       ENDDO     
    125  
    126       DO j=jj_begin,jj_end+1 
    127         CALL request_add_point(ind,ii_begin-1,j,req_i1) 
    128       ENDDO     
    129      
    130     ENDDO 
    131    
    132     CALL finalize_request(req_i1) 
    133  
    134  
    135     CALL create_request(field_t,req_i0) 
    136  
    137     DO ind=1,ndomain 
    138       CALL swap_dimensions(ind) 
    139      
    140       DO i=ii_begin,ii_end 
    141         CALL request_add_point(ind,i,jj_begin,req_i0) 
    142       ENDDO 
    143  
    144       DO j=jj_begin,jj_end 
    145         CALL request_add_point(ind,ii_end,j,req_i0) 
    146       ENDDO     
    147      
    148       DO i=ii_begin,ii_end 
    149         CALL request_add_point(ind,i,jj_end,req_i0) 
    150       ENDDO     
    151  
    152       DO j=jj_begin,jj_end 
    153         CALL request_add_point(ind,ii_begin,j,req_i0) 
    154       ENDDO     
    155      
    156     ENDDO 
    157   
    158     CALL finalize_request(req_i0)   
    159  
    160  
    161     CALL create_request(field_u,req_e1_scal) 
    162     DO ind=1,ndomain 
    163       CALL swap_dimensions(ind) 
    164       DO i=ii_begin,ii_end 
    165         CALL request_add_point(ind,i,jj_begin-1,req_e1_scal,rup) 
    166         CALL request_add_point(ind,i+1,jj_begin-1,req_e1_scal,lup) 
    167       ENDDO 
    168  
    169       DO j=jj_begin,jj_end 
    170         CALL request_add_point(ind,ii_end+1,j,req_e1_scal,left) 
    171       ENDDO     
    172       DO j=jj_begin,jj_end 
    173         CALL request_add_point(ind,ii_end+1,j-1,req_e1_scal,lup) 
    174       ENDDO     
    175      
    176       DO i=ii_begin,ii_end 
    177         CALL request_add_point(ind,i,jj_end+1,req_e1_scal,ldown) 
    178         CALL request_add_point(ind,i-1,jj_end+1,req_e1_scal,rdown) 
    179       ENDDO     
    180  
    181       DO j=jj_begin,jj_end 
    182         CALL request_add_point(ind,ii_begin-1,j,req_e1_scal,right) 
    183       ENDDO    
    184       DO j=jj_begin,jj_end 
    185         CALL request_add_point(ind,ii_begin-1,j+1,req_e1_scal,rdown) 
    186       ENDDO    
    187  
    188     ENDDO 
    189  
    190     CALL finalize_request(req_e1_scal) 
    191  
    192  
    193     CALL create_request(field_u,req_e0_scal) 
    194     DO ind=1,ndomain 
    195       CALL swap_dimensions(ind) 
    196  
    197  
    198       DO i=ii_begin+1,ii_end-1 
    199         CALL request_add_point(ind,i,jj_begin,req_e0_scal,right) 
    200         CALL request_add_point(ind,i,jj_end,req_e0_scal,right) 
    201       ENDDO 
    202      
    203       DO j=jj_begin+1,jj_end-1 
    204         CALL request_add_point(ind,ii_begin,j,req_e0_scal,rup) 
    205         CALL request_add_point(ind,ii_end,j,req_e0_scal,rup) 
    206       ENDDO    
    207  
    208       CALL request_add_point(ind,ii_begin+1,jj_begin,req_e0_scal,left) 
    209       CALL request_add_point(ind,ii_begin,jj_begin+1,req_e0_scal,ldown) 
    210       CALL request_add_point(ind,ii_begin+1,jj_end,req_e0_scal,left) 
    211       CALL request_add_point(ind,ii_end,jj_begin+1,req_e0_scal,ldown) 
    212  
    213     ENDDO 
    214  
    215     CALL finalize_request(req_e0_scal) 
    216  
    217  
    218      
    219     CALL create_request(field_u,req_e1_vect,.TRUE.) 
    220     DO ind=1,ndomain 
    221       CALL swap_dimensions(ind) 
    222       DO i=ii_begin,ii_end 
    223         CALL request_add_point(ind,i,jj_begin-1,req_e1_vect,rup) 
    224         CALL request_add_point(ind,i+1,jj_begin-1,req_e1_vect,lup) 
    225       ENDDO 
    226  
    227       DO j=jj_begin,jj_end 
    228         CALL request_add_point(ind,ii_end+1,j,req_e1_vect,left) 
    229       ENDDO     
    230       DO j=jj_begin,jj_end 
    231         CALL request_add_point(ind,ii_end+1,j-1,req_e1_vect,lup) 
    232       ENDDO     
    233      
    234       DO i=ii_begin,ii_end 
    235         CALL request_add_point(ind,i,jj_end+1,req_e1_vect,ldown) 
    236         CALL request_add_point(ind,i-1,jj_end+1,req_e1_vect,rdown) 
    237       ENDDO     
    238  
    239       DO j=jj_begin,jj_end 
    240         CALL request_add_point(ind,ii_begin-1,j,req_e1_vect,right) 
    241       ENDDO    
    242       DO j=jj_begin,jj_end 
    243         CALL request_add_point(ind,ii_begin-1,j+1,req_e1_vect,rdown) 
    244       ENDDO    
    245  
    246    
    247     ENDDO   
    248  
    249     CALL finalize_request(req_e1_vect) 
    250      
    251      
    252     CALL create_request(field_u,req_e0_vect,.TRUE.) 
    253     DO ind=1,ndomain 
    254       CALL swap_dimensions(ind) 
    255   
    256       DO i=ii_begin+1,ii_end-1 
    257         CALL request_add_point(ind,i,jj_begin,req_e0_vect,right) 
    258         CALL request_add_point(ind,i,jj_end,req_e0_vect,right) 
    259       ENDDO 
    260      
    261       DO j=jj_begin+1,jj_end-1 
    262         CALL request_add_point(ind,ii_begin,j,req_e0_vect,rup) 
    263         CALL request_add_point(ind,ii_end,j,req_e0_vect,rup) 
    264       ENDDO    
    265  
    266       CALL request_add_point(ind,ii_begin+1,jj_begin,req_e0_vect,left) 
    267       CALL request_add_point(ind,ii_begin,jj_begin+1,req_e0_vect,ldown) 
    268       CALL request_add_point(ind,ii_begin+1,jj_end,req_e0_vect,left) 
    269       CALL request_add_point(ind,ii_end,jj_begin+1,req_e0_vect,ldown) 
    270    
    271     ENDDO   
    272  
    273     CALL finalize_request(req_e0_vect) 
    274  
    275     CALL create_request(field_z,req_z1_scal) 
    276     DO ind=1,ndomain 
    277       CALL swap_dimensions(ind) 
    278       DO i=ii_begin,ii_end 
    279         CALL request_add_point(ind,i,jj_begin-1,req_z1_scal,vrup) 
    280         CALL request_add_point(ind,i+1,jj_begin-1,req_z1_scal,vup) 
    281       ENDDO 
    282  
    283       DO j=jj_begin,jj_end 
    284         CALL request_add_point(ind,ii_end+1,j,req_z1_scal,vlup) 
    285       ENDDO     
    286       DO j=jj_begin,jj_end 
    287         CALL request_add_point(ind,ii_end+1,j-1,req_z1_scal,vup) 
    288       ENDDO     
    289      
    290       DO i=ii_begin,ii_end 
    291         CALL request_add_point(ind,i,jj_end+1,req_z1_scal,vdown) 
    292         CALL request_add_point(ind,i-1,jj_end+1,req_z1_scal,vrdown) 
    293       ENDDO     
    294  
    295       DO j=jj_begin,jj_end 
    296         CALL request_add_point(ind,ii_begin-1,j,req_z1_scal,vrup) 
    297       ENDDO    
    298       DO j=jj_begin,jj_end 
    299         CALL request_add_point(ind,ii_begin-1,j,req_z1_scal,vrdown) 
    300       ENDDO    
    301  
    302     ENDDO 
    303  
    304     CALL finalize_request(req_z1_scal) 
    305  
    306   END SUBROUTINE init_transfert 
    307    
    308   SUBROUTINE create_request(type_field,request,vector) 
    309   USE domain_mod 
    310   USE field_mod 
    311   IMPLICIT NONE 
    312     INTEGER :: type_field 
    313     TYPE(t_request),POINTER :: request(:) 
    314     LOGICAL,OPTIONAL :: vector 
    315      
    316     TYPE(t_request),POINTER :: req 
    317     TYPE(t_domain),POINTER :: d 
    318     INTEGER :: ind 
    319     INTEGER :: max_size 
    320         
    321     ALLOCATE(request(ndomain)) 
    322  
    323     DO ind=1,ndomain 
    324       req=>request(ind) 
    325       d=>domain(ind) 
    326       IF (type_field==field_t) THEN 
    327         Max_size=2*(d%iim+2)+2*(d%jjm+2) 
    328       ELSE IF (type_field==field_u) THEN 
    329         Max_size=3*(2*(d%iim+2)+2*(d%jjm+2)) 
    330       ELSE IF (type_field==field_z) THEN 
    331         Max_size=2*(2*(d%iim+2)+2*(d%jjm+2)) 
    332       ENDIF 
    333  
    334       req%type_field=type_field 
    335       req%max_size=max_size*2 
    336       req%size=0 
    337       req%vector=.FALSE. 
    338       IF (PRESENT(vector)) req%vector=vector 
    339       ALLOCATE(req%src_domain(req%max_size)) 
    340       ALLOCATE(req%src_ind(req%max_size)) 
    341       ALLOCATE(req%target_ind(req%max_size)) 
    342       ALLOCATE(req%src_i(req%max_size)) 
    343       ALLOCATE(req%src_j(req%max_size)) 
    344       ALLOCATE(req%target_i(req%max_size)) 
    345       ALLOCATE(req%target_j(req%max_size)) 
    346       ALLOCATE(req%target_sign(req%max_size)) 
    347     ENDDO 
    348    
    349   END SUBROUTINE create_request 
    350  
    351   SUBROUTINE reallocate_request(req) 
    352   IMPLICIT NONE 
    353     TYPE(t_request),POINTER :: req 
    354        
    355     INTEGER,POINTER :: src_domain(:) 
    356     INTEGER,POINTER :: src_ind(:) 
    357     INTEGER,POINTER :: target_ind(:) 
    358     INTEGER,POINTER :: src_i(:) 
    359     INTEGER,POINTER :: src_j(:) 
    360     INTEGER,POINTER :: target_i(:) 
    361     INTEGER,POINTER :: target_j(:) 
    362     INTEGER,POINTER :: target_sign(:) 
    363  
    364     PRINT *,"REALLOCATE_REQUEST" 
    365     src_domain=>req%src_domain 
    366     src_ind=>req%src_ind 
    367     target_ind=>req%target_ind 
    368     src_i=>req%src_i 
    369     src_j=>req%src_j 
    370     target_i=>req%target_i 
    371     target_j=>req%target_j 
    372     target_sign=>req%target_sign 
    373  
    374     ALLOCATE(req%src_domain(req%max_size*2)) 
    375     ALLOCATE(req%src_ind(req%max_size*2)) 
    376     ALLOCATE(req%target_ind(req%max_size*2)) 
    377     ALLOCATE(req%src_i(req%max_size*2)) 
    378     ALLOCATE(req%src_j(req%max_size*2)) 
    379     ALLOCATE(req%target_i(req%max_size*2)) 
    380     ALLOCATE(req%target_j(req%max_size*2)) 
    381     ALLOCATE(req%target_sign(req%max_size*2)) 
    382      
    383     req%src_domain(1:req%max_size)=src_domain(:) 
    384     req%src_ind(1:req%max_size)=src_ind(:) 
    385     req%target_ind(1:req%max_size)=target_ind(:) 
    386     req%src_i(1:req%max_size)=src_i(:) 
    387     req%src_j(1:req%max_size)=src_j(:) 
    388     req%target_i(1:req%max_size)=target_i(:) 
    389     req%target_j(1:req%max_size)=target_j(:) 
    390     req%target_sign(1:req%max_size)=target_sign(:) 
    391      
    392     req%max_size=req%max_size*2 
    393           
    394     DEALLOCATE(src_domain) 
    395     DEALLOCATE(src_ind) 
    396     DEALLOCATE(target_ind) 
    397     DEALLOCATE(src_i) 
    398     DEALLOCATE(src_j) 
    399     DEALLOCATE(target_i) 
    400     DEALLOCATE(target_j) 
    401     DEALLOCATE(target_sign) 
    402  
    403   END SUBROUTINE reallocate_request 
    404  
    405        
    406     SUBROUTINE request_add_point(ind,i,j,request,pos) 
    407     USE domain_mod 
    408     USE field_mod 
    409     IMPLICIT NONE 
    410       INTEGER,INTENT(IN)            ::  ind 
    411       INTEGER,INTENT(IN)            :: i 
    412       INTEGER,INTENT(IN)            :: j 
    413       TYPE(t_request),POINTER :: request(:) 
    414       INTEGER,INTENT(IN),OPTIONAL  :: pos 
    415        
    416       INTEGER :: src_domain 
    417       INTEGER :: src_iim,src_i,src_j,src_n,src_pos,src_delta 
    418       TYPE(t_request),POINTER :: req 
    419       TYPE(t_domain),POINTER :: d 
    420        
    421       req=>request(ind) 
    422       d=>domain(ind) 
    423        
    424       IF (req%max_size==req%size) CALL reallocate_request(req) 
    425       req%size=req%size+1 
    426       IF (req%type_field==field_t) THEN 
    427         src_domain=domain(ind)%assign_domain(i,j) 
    428         src_iim=domain_glo(src_domain)%iim 
    429         src_i=domain(ind)%assign_i(i,j) 
    430         src_j=domain(ind)%assign_j(i,j) 
    431  
    432         req%target_ind(req%size)=(j-1)*d%iim+i 
    433         req%target_sign(req%size)=1 
    434         req%src_domain(req%size)=src_domain 
    435         req%src_ind(req%size)=(src_j-1)*src_iim+src_i 
    436       ELSE IF (req%type_field==field_u) THEN 
    437         IF (.NOT. PRESENT(pos)) STOP 'argument request_add_point non conforme' 
    438  
    439         src_domain=domain(ind)%edge_assign_domain(pos-1,i,j) 
    440         src_iim=domain_glo(src_domain)%iim 
    441         src_i=domain(ind)%edge_assign_i(pos-1,i,j) 
    442         src_j=domain(ind)%edge_assign_j(pos-1,i,j) 
    443         src_n=(src_j-1)*src_iim+src_i 
    444         src_delta=domain(ind)%delta(i,j) 
    445         src_pos=domain(ind)%edge_assign_pos(pos-1,i,j)+1 
    446                  
    447         req%target_ind(req%size)=(j-1)*d%iim+i+d%u_pos(pos) 
    448  
    449         req%target_sign(req%size)= 1 
    450         IF (req%vector) req%target_sign(req%size)= domain(ind)%edge_assign_sign(pos-1,i,j) 
    451  
    452         req%src_domain(req%size)=src_domain 
    453         req%src_ind(req%size)=src_n+domain_glo(src_domain)%u_pos(src_pos) 
    454  
    455       ELSE IF (req%type_field==field_z) THEN 
    456         IF (.NOT. PRESENT(pos)) STOP 'argument request_add_point non conforme' 
    457  
    458         src_domain=domain(ind)%vertex_assign_domain(pos-1,i,j) 
    459         src_iim=domain_glo(src_domain)%iim 
    460         src_i=domain(ind)%vertex_assign_i(pos-1,i,j) 
    461         src_j=domain(ind)%vertex_assign_j(pos-1,i,j) 
    462         src_n=(src_j-1)*src_iim+src_i 
    463         src_delta=domain(ind)%delta(i,j) 
    464         src_pos=domain(ind)%vertex_assign_pos(pos-1,i,j)+1 
    465  
    466          
    467         req%target_ind(req%size)=(j-1)*d%iim+i+d%z_pos(pos) 
    468         req%target_sign(req%size)=1 
    469         req%src_domain(req%size)=src_domain 
    470         req%src_ind(req%size)=src_n+domain_glo(src_domain)%z_pos(src_pos) 
    471       ENDIF 
    472   END SUBROUTINE request_add_point 
    473    
    474    
    475   SUBROUTINE Finalize_request(request) 
    476   USE mpipara 
    477   USE domain_mod 
    478   USE mpi_mod 
    479   IMPLICIT NONE 
    480     TYPE(t_request),POINTER :: request(:) 
    481     TYPE(t_request),POINTER :: req, req_src 
    482     INTEGER :: nb_domain_recv(0:mpi_size-1) 
    483     INTEGER :: nb_domain_send(0:mpi_size-1) 
    484     INTEGER :: tag_rank(0:mpi_size-1) 
    485     INTEGER :: nb_data_domain_recv(ndomain_glo) 
    486     INTEGER :: list_domain_recv(ndomain_glo) 
    487     INTEGER,ALLOCATABLE :: list_domain_send(:) 
    488     INTEGER             :: list_domain(ndomain) 
    489  
    490     INTEGER :: rank,i,j,pos 
    491     INTEGER :: size_,ind_glo,ind_loc 
    492     INTEGER :: isend, irecv, ireq, nreq, nsend, nrecv 
    493     INTEGER, ALLOCATABLE :: mpi_req(:) 
    494     INTEGER, ALLOCATABLE :: status(:,:) 
    495     INTEGER, ALLOCATABLE :: rank_list(:) 
    496     INTEGER, ALLOCATABLE :: offset(:) 
    497     LOGICAL,PARAMETER :: debug = .FALSE. 
    498  
    499   
    500     IF (.NOT. using_mpi) RETURN 
    501      
    502     DO ind_loc=1,ndomain 
    503       req=>request(ind_loc) 
    504        
    505       nb_data_domain_recv(:) = 0 
    506       nb_domain_recv(:) = 0 
    507       tag_rank(:)=0 
    508        
    509       DO i=1,req%size 
    510         ind_glo=req%src_domain(i) 
    511         nb_data_domain_recv(ind_glo)=nb_data_domain_recv(ind_glo)+1 
    512       ENDDO 
    513   
    514       DO ind_glo=1,ndomain_glo 
    515         IF ( nb_data_domain_recv(ind_glo) > 0 )  nb_domain_recv(domglo_rank(ind_glo))=nb_domain_recv(domglo_rank(ind_glo))+1 
    516       ENDDO 
    517  
    518       req%nrecv=sum(nb_domain_recv(:)) 
    519       ALLOCATE(req%recv(req%nrecv)) 
    520  
    521       irecv=0 
    522       DO ind_glo=1,ndomain_glo 
    523         IF (nb_data_domain_recv(ind_glo)>0) THEN 
    524           irecv=irecv+1 
    525           list_domain_recv(ind_glo)=irecv 
    526           req%recv(irecv)%rank=domglo_rank(ind_glo) 
    527           req%recv(irecv)%size=nb_data_domain_recv(ind_glo) 
    528           req%recv(irecv)%domain=domglo_loc_ind(ind_glo) 
    529           ALLOCATE(req%recv(irecv)%value(req%recv(irecv)%size)) 
    530           ALLOCATE(req%recv(irecv)%sign(req%recv(irecv)%size)) 
    531           ALLOCATE(req%recv(irecv)%buffer(req%recv(irecv)%size)) 
    532         ENDIF 
    533       ENDDO 
    534        
    535       req%recv(:)%size=0 
    536       irecv=0 
    537       DO i=1,req%size 
    538         irecv=list_domain_recv(req%src_domain(i)) 
    539         req%recv(irecv)%size=req%recv(irecv)%size+1 
    540         size_=req%recv(irecv)%size 
    541         req%recv(irecv)%value(size_)=req%src_ind(i) 
    542         req%recv(irecv)%buffer(size_)=req%target_ind(i) 
    543         req%recv(irecv)%sign(size_)=req%target_sign(i) 
    544       ENDDO 
    545     ENDDO 
    546  
    547     nb_domain_recv(:) = 0     
    548     DO ind_loc=1,ndomain 
    549       req=>request(ind_loc) 
    550        
    551       DO irecv=1,req%nrecv 
    552         rank=req%recv(irecv)%rank 
    553         nb_domain_recv(rank)=nb_domain_recv(rank)+1 
    554       ENDDO 
    555     ENDDO 
    556      
    557     CALL MPI_Alltoall(nb_domain_recv,1,MPI_INTEGER,nb_domain_send,1,MPI_INTEGER,comm_icosa,ierr)      
    558      
    559  
    560     ALLOCATE(list_domain_send(sum(nb_domain_send))) 
    561      
    562     nreq=sum(nb_domain_recv(:))+sum(nb_domain_send(:)) 
    563     ALLOCATE(mpi_req(nreq)) 
    564     ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 
    565      
    566  
    567     ireq=0 
    568     DO ind_loc=1,ndomain 
    569       req=>request(ind_loc) 
    570       DO irecv=1,req%nrecv 
    571         ireq=ireq+1 
    572         CALL MPI_ISEND(req%recv(irecv)%domain,1,MPI_INTEGER,req%recv(irecv)%rank,0,comm_icosa, mpi_req(ireq),ierr) 
    573         IF (debug) PRINT *,"Isend ",req%recv(irecv)%domain, "from ", mpi_rank, "to ",req%recv(irecv)%rank, "tag ",0 
    574       ENDDO 
    575     ENDDO 
    576  
    577     IF (debug) PRINT *,"------------"     
    578     j=0 
    579     DO rank=0,mpi_size-1 
    580       DO i=1,nb_domain_send(rank) 
    581         j=j+1 
    582         ireq=ireq+1 
    583         CALL MPI_IRECV(list_domain_send(j),1,MPI_INTEGER,rank,0,comm_icosa, mpi_req(ireq),ierr) 
    584         IF (debug) PRINT *,"IRecv ",list_domain_send(j), "from ", rank, "to ",mpi_rank, "tag ",0 
    585       ENDDO 
    586     ENDDO 
    587     IF (debug) PRINT *,"------------"     
    588      
    589     CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    590      
    591     list_domain(:)=0 
    592     DO i=1,sum(nb_domain_send) 
    593       ind_loc=list_domain_send(i) 
    594       list_domain(ind_loc)=list_domain(ind_loc)+1 
    595     ENDDO 
    596      
    597     DO ind_loc=1,ndomain 
    598       req=>request(ind_loc) 
    599       req%nsend=list_domain(ind_loc) 
    600       ALLOCATE(req%send(req%nsend)) 
    601     ENDDO 
    602  
    603     IF (debug) PRINT *,"------------"     
    604     
    605    ireq=0  
    606    DO ind_loc=1,ndomain 
    607      req=>request(ind_loc) 
    608       
    609      DO irecv=1,req%nrecv 
    610        ireq=ireq+1 
    611        CALL MPI_ISEND(mpi_rank,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr) 
    612        IF (debug) PRINT *,"Isend ",mpi_rank, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain 
    613      ENDDO 
    614     IF (debug) PRINT *,"------------"     
    615       
    616      DO isend=1,req%nsend 
    617        ireq=ireq+1 
    618        CALL MPI_IRECV(req%send(isend)%rank,1,MPI_INTEGER,MPI_ANY_SOURCE,ind_loc,comm_icosa, mpi_req(ireq),ierr) 
    619        IF (debug) PRINT *,"IRecv ",req%send(isend)%rank, "from ", "xxx", "to ",mpi_rank, "tag ",ind_loc 
    620      ENDDO 
    621    ENDDO 
    622  
    623    IF (debug) PRINT *,"------------"     
    624  
    625    CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    626    CALL MPI_BARRIER(comm_icosa,ierr) 
    627  
    628    IF (debug) PRINT *,"------------"     
    629  
    630    ireq=0  
    631    DO ind_loc=1,ndomain 
    632      req=>request(ind_loc) 
    633       
    634      DO irecv=1,req%nrecv 
    635        ireq=ireq+1 
    636        CALL MPI_ISEND(ind_loc,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr) 
    637        IF (debug) PRINT *,"Isend ",ind_loc, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain 
    638      ENDDO 
    639  
    640      IF (debug) PRINT *,"------------"     
    641       
    642      DO isend=1,req%nsend 
    643        ireq=ireq+1 
    644        CALL MPI_IRECV(req%send(isend)%domain,1,MPI_INTEGER,req%send(isend)%rank,ind_loc,comm_icosa, mpi_req(ireq),ierr) 
    645        IF (debug) PRINT *,"IRecv ",req%send(isend)%domain, "from ", req%send(isend)%rank, "to ",mpi_rank, "tag ",ind_loc 
    646      ENDDO 
    647    ENDDO 
    648    IF (debug) PRINT *,"------------"     
    649     
    650    CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    651    CALL MPI_BARRIER(comm_icosa,ierr) 
    652    IF (debug) PRINT *,"------------"     
    653  
    654    ireq=0 
    655    DO ind_loc=1,ndomain 
    656      req=>request(ind_loc) 
    657       
    658      DO irecv=1,req%nrecv 
    659        ireq=ireq+1 
    660        req%recv(irecv)%tag=tag_rank(req%recv(irecv)%rank) 
    661        tag_rank(req%recv(irecv)%rank)=tag_rank(req%recv(irecv)%rank)+1 
    662        CALL MPI_ISEND(req%recv(irecv)%tag,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr) 
    663        IF (debug) PRINT *,"Isend ",req%recv(irecv)%tag, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain 
    664      ENDDO 
    665    IF (debug) PRINT *,"------------"     
    666       
    667      DO isend=1,req%nsend 
    668        ireq=ireq+1 
    669        CALL MPI_IRECV(req%send(isend)%tag,1,MPI_INTEGER,req%send(isend)%rank,ind_loc,comm_icosa, mpi_req(ireq),ierr) 
    670        IF (debug) PRINT *,"IRecv ",req%send(isend)%tag, "from ", req%send(isend)%rank, "to ",mpi_rank, "tag ",ind_loc 
    671      ENDDO 
    672    ENDDO 
    673    IF (debug) PRINT *,"------------"     
    674     
    675    CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    676    CALL MPI_BARRIER(comm_icosa,ierr) 
    677  
    678  
    679    IF (debug) PRINT *,"------------"     
    680  
    681    ireq=0  
    682    DO ind_loc=1,ndomain 
    683      req=>request(ind_loc) 
    684       
    685      DO irecv=1,req%nrecv 
    686        ireq=ireq+1 
    687        CALL MPI_ISEND(req%recv(irecv)%size,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr) 
    688        IF (debug) PRINT *,"Isend ",req%recv(irecv)%size, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain 
    689      ENDDO 
    690      IF (debug) PRINT *,"------------"     
    691       
    692      DO isend=1,req%nsend 
    693        ireq=ireq+1 
    694        CALL MPI_IRECV(req%send(isend)%size,1,MPI_INTEGER,req%send(isend)%rank,req%send(isend)%tag,comm_icosa, mpi_req(ireq),ierr) 
    695        IF (debug) PRINT *,"IRecv ",req%send(isend)%size, "from ", req%send(isend)%rank, "to ",mpi_rank, "tag ",ind_loc 
    696      ENDDO 
    697    ENDDO 
    698  
    699    CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    700  
    701    ireq=0  
    702    DO ind_loc=1,ndomain 
    703      req=>request(ind_loc) 
    704       
    705      DO irecv=1,req%nrecv 
    706        ireq=ireq+1 
    707        CALL MPI_ISEND(req%recv(irecv)%value,req%recv(irecv)%size,MPI_INTEGER,& 
    708             req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr) 
    709      ENDDO 
    710       
    711      DO isend=1,req%nsend 
    712        ireq=ireq+1 
    713        ALLOCATE(req%send(isend)%value(req%send(isend)%size)) 
    714        CALL MPI_IRECV(req%send(isend)%value,req%send(isend)%size,MPI_INTEGER,& 
    715             req%send(isend)%rank,req%send(isend)%tag,comm_icosa, mpi_req(ireq),ierr) 
    716      ENDDO 
    717    ENDDO 
    718  
    719    CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    720  
    721    DO ind_loc=1,ndomain 
    722      req=>request(ind_loc) 
    723       
    724      DO irecv=1,req%nrecv 
    725        req%recv(irecv)%value(:)=req%recv(irecv)%buffer(:) 
    726        req%recv(irecv)%sign(:) =req%recv(irecv)%sign(:) 
    727        DEALLOCATE(req%recv(irecv)%buffer) 
    728      ENDDO 
    729    ENDDO   
    730     
    731  
    732 ! domain is on the same mpi process => copie memory to memory 
    733     
    734    DO ind_loc=1,ndomain 
    735      req=>request(ind_loc) 
    736       
    737      DO irecv=1,req%nrecv 
    738     
    739        IF (req%recv(irecv)%rank==mpi_rank) THEN 
    740            req_src=>request(req%recv(irecv)%domain) 
    741            DO isend=1,req_src%nsend 
    742              IF (req_src%send(isend)%rank==mpi_rank .AND. req_src%send(isend)%tag==req%recv(irecv)%tag) THEN 
    743                req%recv(irecv)%src_value => req_src%send(isend)%value 
    744                IF ( size(req%recv(irecv)%value) /= size(req_src%send(isend)%value)) THEN 
    745                  PRINT *,ind_loc, irecv, isend, size(req%recv(irecv)%value), size(req_src%send(isend)%value) 
    746                  STOP "size(req%recv(irecv)%value) /= size(req_src%send(isend)%value" 
    747                ENDIF 
    748              ENDIF 
    749            ENDDO 
    750        ENDIF 
    751       
    752      ENDDO 
    753    ENDDO 
    754     
    755 ! true number of mpi request 
    756  
    757    request(:)%nreq_mpi=0 
    758    request(:)%nreq_send=0 
    759    request(:)%nreq_recv=0 
    760    ALLOCATE(rank_list(sum(request(:)%nsend))) 
    761    ALLOCATE(offset(sum(request(:)%nsend))) 
    762    offset(:)=0 
    763     
    764    nsend=0 
    765    DO ind_loc=1,ndomain 
    766      req=>request(ind_loc) 
    767  
    768      DO isend=1,req%nsend 
    769        IF (req%send(isend)%rank/=mpi_rank) THEN 
    770          pos=0 
    771          DO i=1,nsend 
    772            IF (req%send(isend)%rank==rank_list(i)) EXIT 
    773            pos=pos+1 
    774          ENDDO 
    775          
    776          IF (pos==nsend) THEN 
    777            nsend=nsend+1 
    778            req%nreq_mpi=req%nreq_mpi+1 
    779            req%nreq_send=req%nreq_send+1 
    780            IF (mpi_threading_mode==MPI_THREAD_FUNNELED .OR. mpi_threading_mode==MPI_THREAD_SINGLE) THEN 
    781              rank_list(nsend)=req%send(isend)%rank 
    782            ELSE 
    783              rank_list(nsend)=-1 
    784            ENDIF 
    785          ENDIF 
    786           
    787          pos=pos+1 
    788          req%send(isend)%ireq=pos 
    789          req%send(isend)%offset=offset(pos) 
    790          offset(pos)=offset(pos)+req%send(isend)%size 
    791        ENDIF 
    792      ENDDO 
    793    ENDDO 
    794  
    795    DEALLOCATE(rank_list) 
    796    DEALLOCATE(offset) 
    797       
    798    ALLOCATE(rank_list(sum(request(:)%nrecv))) 
    799    ALLOCATE(offset(sum(request(:)%nrecv))) 
    800    offset(:)=0 
    801     
    802    nrecv=0 
    803    DO ind_loc=1,ndomain 
    804      req=>request(ind_loc) 
    805  
    806      DO irecv=1,req%nrecv 
    807        IF (req%recv(irecv)%rank/=mpi_rank) THEN 
    808          pos=0 
    809          DO i=1,nrecv 
    810            IF (req%recv(irecv)%rank==rank_list(i)) EXIT 
    811            pos=pos+1 
    812          ENDDO 
    813          
    814          IF (pos==nrecv) THEN 
    815            nrecv=nrecv+1 
    816            req%nreq_mpi=req%nreq_mpi+1 
    817            req%nreq_recv=req%nreq_recv+1 
    818            IF (mpi_threading_mode==MPI_THREAD_FUNNELED .OR. mpi_threading_mode==MPI_THREAD_SINGLE) THEN 
    819              rank_list(nrecv)=req%recv(irecv)%rank 
    820            ELSE 
    821              rank_list(nrecv)=-1 
    822            ENDIF 
    823          ENDIF 
    824          
    825          pos=pos+1 
    826          req%recv(irecv)%ireq=nsend+pos 
    827          req%recv(irecv)%offset=offset(pos) 
    828          offset(pos)=offset(pos)+req%recv(irecv)%size 
    829        ENDIF 
    830      ENDDO 
    831    ENDDO  
    832  
    833 ! get the offsets    
    834  
    835    ireq=0  
    836    DO ind_loc=1,ndomain 
    837      req=>request(ind_loc) 
    838       
    839      DO irecv=1,req%nrecv 
    840        ireq=ireq+1 
    841        CALL MPI_ISEND(req%recv(irecv)%offset,1,MPI_INTEGER,& 
    842             req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr) 
    843      ENDDO 
    844       
    845      DO isend=1,req%nsend 
    846        ireq=ireq+1 
    847        CALL MPI_IRECV(req%send(isend)%offset,1,MPI_INTEGER,& 
    848             req%send(isend)%rank,req%send(isend)%tag,comm_icosa, mpi_req(ireq),ierr) 
    849      ENDDO 
    850    ENDDO 
    851  
    852    CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    853        
    854         
    855   END SUBROUTINE Finalize_request  
    856  
    857  
    858   SUBROUTINE init_message_seq(field, request, message, name) 
    859   USE field_mod 
    860   USE domain_mod 
    861   USE mpi_mod 
    862   USE mpipara 
    863   USE mpi_mod 
    864   IMPLICIT NONE 
    865     TYPE(t_field),POINTER :: field(:) 
    866     TYPE(t_request),POINTER :: request(:) 
    867     TYPE(t_message) :: message 
    868     CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: name 
    869 !$OMP MASTER     
    870     message%request=>request 
    871     IF(PRESENT(name)) THEN 
    872        message%name = TRIM(name) 
    873     ELSE 
    874        message%name = 'unknown' 
    875     END IF 
    876 !$OMP END MASTER     
    877 !$OMP BARRIER     
    878  
    879   END SUBROUTINE init_message_seq 
    880  
    881   SUBROUTINE send_message_seq(field,message) 
    882   USE field_mod 
    883   USE domain_mod 
    884   USE mpi_mod 
    885   USE mpipara 
    886   USE omp_para 
    887   USE trace 
    888   IMPLICIT NONE 
    889     TYPE(t_field),POINTER :: field(:) 
    890     TYPE(t_message) :: message 
    891  
    892     CALL transfert_request_seq(field,message%request) 
    893      
    894   END SUBROUTINE send_message_seq 
    895    
    896   SUBROUTINE test_message_seq(message) 
    897   IMPLICIT NONE 
    898     TYPE(t_message) :: message 
    899   END SUBROUTINE  test_message_seq 
    900    
    901     
    902   SUBROUTINE wait_message_seq(message) 
    903   IMPLICIT NONE 
    904     TYPE(t_message) :: message 
    905      
    906   END SUBROUTINE wait_message_seq     
    907  
    908   SUBROUTINE transfert_message_seq(field,message) 
    909   USE field_mod 
    910   USE domain_mod 
    911   USE mpi_mod 
    912   USE mpipara 
    913   USE omp_para 
    914   USE trace 
    915   IMPLICIT NONE 
    916     TYPE(t_field),POINTER :: field(:) 
    917     TYPE(t_message) :: message 
    918  
    919    CALL send_message_seq(field,message) 
    920      
    921   END SUBROUTINE transfert_message_seq     
    922      
    923  
    924  
    925      
    926   SUBROUTINE init_message_mpi(field,request, message, name) 
    927   USE field_mod 
    928   USE domain_mod 
    929   USE mpi_mod 
    930   USE mpipara 
    931   USE mpi_mod 
    932   IMPLICIT NONE 
    933    
    934     TYPE(t_field),POINTER :: field(:) 
    935     TYPE(t_request),POINTER :: request(:) 
    936     TYPE(t_message) :: message 
    937     CHARACTER(LEN=*), INTENT(IN),OPTIONAL :: name 
    938  
    939     TYPE(t_request),POINTER :: req 
    940     INTEGER :: irecv,isend 
    941     INTEGER :: ireq,nreq 
    942     INTEGER :: ind 
    943     INTEGER :: dim3,dim4 
    944     INTEGER,SAVE :: message_number=0 
    945 !    TYPE(t_reorder),POINTER :: reorder(:) 
    946 !    TYPE(t_reorder) :: reorder_swap 
    947  
    948 !$OMP BARRIER 
    949 !$OMP MASTER 
     1! Module for MPI communication of field halos 
     2! This module uses Fortran 2003 features : move_alloc intrinsic, pointer bounds remapping, allocatable type fields 
     3module transfert_mpi_mod 
     4  use abort_mod, only : dynamico_abort, abort_acc 
     5  use profiling_mod, only : enter_profile, exit_profile, register_id 
     6  use domain_mod, only : ndomain, ndomain_glo, domain, domain_glo, domloc_glo_ind, domglo_rank, domglo_loc_ind 
     7  use field_mod, only : t_field, field_T, field_U 
     8  use transfert_request_mod 
     9  implicit none 
     10  private 
     11 
     12  ! Describes how to pack/unpack a message from a local domain to another 
     13  type t_local_submessage 
     14    integer :: src_ind_loc, dest_ind_loc ! index of local and remote domain 
     15    integer, allocatable :: displ_src(:) ! List of indexes to copy from domain src_ind_loc 
     16    integer, allocatable :: displ_dest(:) ! List of indexes to copy to domain dest_ind_loc 
     17    integer, allocatable :: sign(:) ! Sign change to be applied for vector requests 
     18  end type 
     19 
     20  ! Describes how to pack/unpack a message from a domain to another, and contains MPI buffer 
     21  type t_submessage 
     22    integer :: ind_loc, remote_ind_glo ! index of local and remote domain 
     23    integer, allocatable :: displs(:) ! List of indexes to copy from field to buffer for each level 
     24    integer, allocatable :: sign(:) ! Sign change to be applied for vector requests 
     25    real, allocatable :: buff(:,:,:) ! MPI buffer buff(iim*jjm[*3],dim3,dim4) 
     26  end type 
     27 
     28  ! Describes how to exchange data for a field. 
     29  type t_message 
     30    type (t_field), pointer :: field(:) => null() ! Field to exchange 
     31    type (t_request), pointer :: request(:) => null() ! Type of message to send 
     32    type (t_local_submessage), pointer :: message_local(:) ! Local halo copies 
     33    type (t_submessage), pointer :: message_in(:) ! Messages to recieve from remote ranks and to copy back to the field 
     34    type (t_submessage), pointer :: message_out(:) ! Halos to copy to MPI buffer and to send to remote ranks 
     35    integer, pointer :: mpi_requests_in(:) ! MPI requests used for message_in. 
     36    integer, pointer :: mpi_requests_out(:) ! MPI requests used for message_out. 
     37    ! NOTE : requests are persistant requests initialized in init_message. MPI_Start and MPI_Wait are then used to initiate and complete communications. 
     38    ! ex : Give mpi_requests_in(i) to MPI_Start to send the buffer contained in message_in(i) 
     39    integer :: send_seq ! Sequence number : send_seq is incremented each time send_message is called 
     40    integer :: wait_seq ! Sequence number : wait_seq is incremented each time wait_message is called 
     41    logical :: ondevice ! Ready to transfer ondevice field 
     42  end type t_message 
     43 
     44  public :: t_message, t_request, & 
     45    req_i1, req_e1_scal, req_e1_vect, & 
     46    req_i0, req_e0_scal, req_e0_vect, & 
     47    req_z1_scal, & 
     48    init_transfert, & 
     49    init_message, & 
     50    finalize_message, & 
     51    send_message, & 
     52    wait_message, & 
     53    test_message 
     54 
     55  ! ---- Private variables ---- 
     56  ! Profiling id for mpi 
     57  integer :: profile_mpi, profile_mpi_copies, profile_mpi_waitall, profile_mpi_barrier 
     58contains 
     59  ! Initialize transfert : must be called before any other transfert_mpi routines 
     60  subroutine init_transfert 
     61    use mpi_mod, only : MPI_THREAD_SINGLE, MPI_THREAD_FUNNELED 
     62    use mpipara, only : mpi_threading_mode 
     63    use profiling_mod, only : register_id 
     64    logical, parameter :: profile_mpi_detail = .true. 
     65 
     66    !$omp master 
     67    ! Check requested threads support 
     68    if( mpi_threading_mode /= MPI_THREAD_SINGLE .and. mpi_threading_mode /= MPI_THREAD_FUNNELED ) call dynamico_abort("Only single and funneled threading mode are supported.") 
     69 
     70    ! Register profiling ids 
     71    call register_id("MPI", profile_mpi) 
     72    if( profile_mpi_detail ) then 
     73      call register_id("MPI_copies", profile_mpi_copies) 
     74      call register_id("MPI_waitall", profile_mpi_waitall) 
     75      call register_id("MPI_omp_barrier", profile_mpi_barrier) 
     76    else 
     77      profile_mpi_copies = profile_mpi 
     78      profile_mpi_waitall = profile_mpi 
     79      profile_mpi_barrier = profile_mpi 
     80    endif 
     81 
     82    ! Initialize requests 
     83    call init_all_requests() 
     84    !$omp end master 
     85    !$omp barrier 
     86  end subroutine 
     87 
     88  subroutine init_message(field, request, message, name) 
     89    use mpi_mod 
     90    use mpipara 
     91    type(t_field), pointer, intent(in) :: field(:) 
     92    type(t_request),pointer, intent(in) :: request(:) 
     93    type(t_message), target, intent(out) :: message ! Needs intent out for call to finalize_message 
     94    character(len=*), intent(in),optional :: name 
     95    integer, parameter :: INITIAL_ALLOC_SIZE = 10, GROW_FACTOR = 2 
     96 
     97    type(t_submessage) :: submessage_in, submessage_out 
     98    type(t_local_submessage) :: submessage_local 
     99    integer :: dim3, dim4 
     100    integer :: ind, ind_loc, remote_ind_glo, i 
     101    integer :: message_in_size, message_out_size, message_local_size 
     102    type(t_local_submessage), allocatable :: message_local_tmp(:) 
     103    type(t_submessage), allocatable :: message_in_tmp(:), message_out_tmp(:) 
     104    type(t_submessage), pointer :: submessage 
     105 
     106    !$omp barrier 
     107    !$omp master 
    950108    !init off-device 
    951109    message%ondevice=.false. 
    952  
    953     IF(PRESENT(name)) THEN 
    954        message%name = TRIM(name) 
    955     ELSE 
    956        message%name = 'unknown' 
    957     END IF 
    958     message%number=message_number 
    959     message_number=message_number+1 
    960     IF (message_number==100) message_number=0 
    961  
    962    
    963     message%request=>request 
    964     message%nreq=sum(message%request(:)%nreq_mpi) 
    965     message%nreq_send=sum(message%request(:)%nreq_send) 
    966     message%nreq_recv=sum(message%request(:)%nreq_recv) 
    967     nreq=message%nreq 
    968  
    969     ALLOCATE(message%mpi_req(nreq)) 
    970     ALLOCATE(message%buffers(nreq)) 
    971     ALLOCATE(message%status(MPI_STATUS_SIZE,nreq)) 
    972     message%buffers(:)%size=0 
    973     message%pending=.FALSE. 
    974     message%completed=.FALSE. 
    975     message%open=.FALSE. 
    976  
    977     DO ind=1,ndomain 
    978       req=>request(ind) 
    979       DO isend=1,req%nsend 
    980         IF (req%send(isend)%rank/=mpi_rank) THEN 
    981           ireq=req%send(isend)%ireq  
    982           message%buffers(ireq)%size=message%buffers(ireq)%size+req%send(isend)%size 
    983           message%buffers(ireq)%rank=req%send(isend)%rank 
    984         ENDIF 
    985       ENDDO 
    986       DO irecv=1,req%nrecv 
    987         IF (req%recv(irecv)%rank/=mpi_rank) THEN 
    988           ireq=req%recv(irecv)%ireq  
    989           message%buffers(ireq)%size=message%buffers(ireq)%size+req%recv(irecv)%size 
    990           message%buffers(ireq)%rank=req%recv(irecv)%rank 
    991         ENDIF 
    992       ENDDO 
    993     ENDDO 
    994  
    995  
    996     IF (field(1)%data_type==type_real) THEN 
    997  
    998       IF (field(1)%ndim==2) THEN 
    999       
    1000         DO ireq=1,message%nreq 
    1001           CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size) 
    1002         ENDDO 
    1003        
    1004       ELSE  IF (field(1)%ndim==3) THEN 
    1005        
    1006         dim3=size(field(1)%rval3d,2) 
    1007         DO ireq=1,message%nreq 
    1008           message%buffers(ireq)%size=message%buffers(ireq)%size*dim3 
    1009           CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size) 
    1010         ENDDO 
    1011        
    1012       ELSE  IF (field(1)%ndim==4) THEN 
    1013         dim3=size(field(1)%rval4d,2) 
    1014         dim4=size(field(1)%rval4d,3) 
    1015         DO ireq=1,message%nreq 
    1016           message%buffers(ireq)%size=message%buffers(ireq)%size*dim3*dim4 
    1017           CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size) 
    1018         ENDDO 
    1019       ENDIF       
    1020     ENDIF 
    1021        
    1022           
     110    message%send_seq = 0 
     111    message%wait_seq = 0 
     112    ! Set field%rval4d pointer to always use 4d array 
     113    do ind = 1, ndomain 
     114      if( field(ind)%ndim == 2 ) field(ind)%rval4d(1:size(field(ind)%rval2d,1),1:1,1:1) => field(ind)%rval2d 
     115      ! This is Fortran 2008 : can be avoided by using a subroutine with rval3d as a 1D dummy argument 
     116      ! (/!\ : using a subroutine might generate a temporary contiguous array) 
     117      if( field(ind)%ndim == 3 ) field(ind)%rval4d(1:size(field(ind)%rval3d,1), & 
     118        1:size(field(ind)%rval3d,2), 1:1) => field(ind)%rval3d 
     119    end do 
     120    dim3 = size(field(1)%rval4d,2) 
     121    dim4 = size(field(1)%rval4d,3) 
     122    message%field => field 
     123    message%request => request 
     124    ! Create list of inbound/outbound/local messages 
     125    allocate(message_in_tmp(INITIAL_ALLOC_SIZE)) 
     126    message_in_size=0 
     127    allocate(message_out_tmp(INITIAL_ALLOC_SIZE)) 
     128    message_out_size=0 
     129    allocate(message_local_tmp(INITIAL_ALLOC_SIZE)) 
     130    message_local_size=0 
     131    do ind_loc = 1, ndomain 
     132      do remote_ind_glo = 1, ndomain_glo 
     133        if( domglo_rank(remote_ind_glo) == mpi_rank ) then ! If sending to local domain 
     134          if(request(ind_loc)%points_HtoB(remote_ind_glo)%npoints > 0 ) then ! Add only non-empty messages 
     135            ! Add local message ind_loc -> remote_ind_glo, aggregarting submessage_in and submessage_out into submessage_local 
     136            submessage_out = make_submessage( request(ind_loc)%points_HtoB(remote_ind_glo), & 
     137                                              ind_loc, remote_ind_glo, dim3, dim4, request(1)%vector ) 
     138            submessage_in = make_submessage(request(domglo_loc_ind(remote_ind_glo))%points_BtoH(domloc_glo_ind(ind_loc)), & 
     139                                            domglo_loc_ind(remote_ind_glo), domloc_glo_ind(ind_loc), dim3, dim4, request(1)%vector) 
     140            submessage_local%src_ind_loc = ind_loc 
     141            submessage_local%dest_ind_loc = domglo_loc_ind(remote_ind_glo) 
     142            submessage_local%displ_src = submessage_out%displs 
     143            submessage_local%displ_dest = submessage_in%displs 
     144            submessage_local%sign = submessage_in%sign 
     145            ! Add to local message list 
     146            call array_append_local_submessage( message_local_tmp, message_local_size, submessage_local) 
     147          endif 
     148        else ! If remote domain 
     149          ! When data to send to remote_domain, add submessage in message%message_out 
     150          if( request(ind_loc)%points_HtoB(remote_ind_glo)%npoints > 0 ) then 
     151            submessage_out = make_submessage( request(ind_loc)%points_HtoB(remote_ind_glo), & 
     152                                              ind_loc, remote_ind_glo, dim3, dim4, request(1)%vector ) 
     153            call array_append_submessage( message_out_tmp, message_out_size, submessage_out ) 
     154          end if 
     155          if( request(ind_loc)%points_BtoH(remote_ind_glo)%npoints > 0 ) then 
     156            submessage_in = make_submessage( request(ind_loc)%points_BtoH(remote_ind_glo), & 
     157                                             ind_loc, remote_ind_glo, dim3, dim4, request(1)%vector ) 
     158            call array_append_submessage( message_in_tmp, message_in_size, submessage_in ) 
     159          end if 
     160        end if 
     161      end do 
     162    end do 
     163    ! Trim message_xx_tmp and put it in message%message_xx 
     164    allocate(message%message_in(message_in_size)); message%message_in(:) = message_in_tmp(:message_in_size) 
     165    allocate(message%message_out(message_out_size)); message%message_out(:) = message_out_tmp(:message_out_size) 
     166    allocate(message%message_local(message_local_size)); message%message_local(:) = message_local_tmp(:message_local_size) 
     167 
     168    ! Create MPI Persistant Send/Recv requests 
     169    allocate( message%mpi_requests_in(size(message%message_in)) ) 
     170    allocate( message%mpi_requests_out(size(message%message_out)) ) 
     171    do i=1, size(message%message_out) 
     172      submessage => message%message_out(i) 
     173      call MPI_Send_init( submessage%buff, size(submessage%buff), MPI_DOUBLE, domglo_rank(submessage%remote_ind_glo), & 
     174        submessage%remote_ind_glo+ndomain_glo*domloc_glo_ind(submessage%ind_loc), & 
     175        comm_icosa, message%mpi_requests_out(i), ierr ) 
     176    end do 
     177    do i=1, size(message%message_in) 
     178      submessage => message%message_in(i) 
     179      call MPI_Recv_init( submessage%buff, size(submessage%buff), MPI_DOUBLE, domglo_rank(submessage%remote_ind_glo), & 
     180        domloc_glo_ind(submessage%ind_loc)+ndomain_glo*submessage%remote_ind_glo, & 
     181        comm_icosa,  message%mpi_requests_in(i), ierr ) 
     182    end do 
     183    !$omp end master 
     184    !$omp barrier 
     185  contains 
     186    ! Generate submessage from points 
     187    function make_submessage(points, ind_loc, remote_ind_glo, dim3, dim4, vector) result(submessage) 
     188      use dimensions, only : swap_dimensions, iim, u_pos 
     189      type(t_points), intent(in) :: points 
     190      integer, intent(in) :: ind_loc, remote_ind_glo, dim3, dim4 
     191      logical, intent(in) :: vector 
     192      integer :: k 
     193      type(t_submessage) :: submessage 
     194 
     195      call swap_dimensions(ind_loc) 
     196      submessage%ind_loc = ind_loc 
     197      submessage%remote_ind_glo = remote_ind_glo 
     198      allocate( submessage%buff( points%npoints, dim3, dim4 ) ) 
     199      allocate( submessage%displs( points%npoints ) ) 
     200      submessage%displs(:) = points%i + (points%j-1)*iim 
     201      if(allocated(points%edge)) submessage%displs = submessage%displs + u_pos( points%edge ) 
     202      allocate(submessage%sign( points%npoints )) 
     203      if( vector ) then 
     204        submessage%sign(:) = (/( domain(ind_loc)%edge_assign_sign(points%edge(k)-1, points%i(k), points%j(k)) ,k=1,points%npoints)/) 
     205      else 
     206        submessage%sign(:) = 1 
     207      endif 
     208    end function 
     209 
     210    ! Add element to array, and reallocate if necessary 
     211    subroutine array_append_submessage( a, a_size, elt ) 
     212      type(t_submessage), allocatable, intent(inout) :: a(:) 
     213      integer, intent(inout) :: a_size 
     214      type(t_submessage), intent(in) :: elt 
     215      type(t_submessage), allocatable :: a_tmp(:) 
     216      integer, parameter :: GROW_FACTOR = 2 
     217 
     218      if( size( a ) <= a_size ) then 
     219        allocate( a_tmp ( a_size * GROW_FACTOR ) ) 
     220        a_tmp(1:a_size) = a(1:a_size) 
     221        call move_alloc(a_tmp, a) 
     222      end if 
     223      a_size = a_size + 1 
     224      a(a_size) = elt; 
     225    end subroutine 
     226    ! Add element to array, and reallocate if necessary 
     227    subroutine array_append_local_submessage( a, a_size, elt ) 
     228      type(t_local_submessage), allocatable, intent(inout) :: a(:) 
     229      integer, intent(inout) :: a_size 
     230      type(t_local_submessage), intent(in) :: elt 
     231      type(t_local_submessage), allocatable :: a_tmp(:) 
     232      integer, parameter :: GROW_FACTOR = 2 
     233 
     234      if( size( a ) <= a_size ) then 
     235        allocate( a_tmp ( a_size * GROW_FACTOR ) ) 
     236        a_tmp(1:a_size) = a(1:a_size) 
     237        call move_alloc(a_tmp, a) 
     238      end if 
     239      a_size = a_size + 1 
     240      a(a_size) = elt; 
     241    end subroutine 
     242    ! Je demande pardon au dieu du copier-coller car j'ai péché 
     243  end subroutine 
     244 
     245  subroutine message_create_ondevice(message) 
     246    use mpi_mod 
     247    use mpipara, only : comm_icosa 
     248    type(t_message), intent(inout) :: message 
     249    type(t_submessage), pointer :: submessage 
     250    integer :: i, ierr 
     251 
     252    if( message%ondevice ) call dynamico_abort("Message already on device") 
     253 
     254    !$acc enter data copyin(message) async 
     255    !$acc enter data copyin(message%message_in(:)) async 
     256    do i = 1, size( message%message_in ) 
     257      !$acc enter data copyin(message%message_in(i)%buff(:,:,:)) async 
     258      !$acc enter data copyin(message%message_in(i)%displs(:)) async 
     259      !$acc enter data copyin(message%message_in(i)%sign(:)) async 
     260    end do 
     261    !$acc enter data copyin(message%message_out(:)) async 
     262    do i = 1, size( message%message_out ) 
     263      !$acc enter data copyin(message%message_out(i)%buff(:,:,:)) async 
     264      !$acc enter data copyin(message%message_out(i)%displs(:)) async 
     265      !!$acc enter data copyin(message%message_out(i)%sign(:)) async 
     266    end do 
     267    !$acc enter data copyin(message%message_local(:)) async 
     268    do i = 1, size( message%message_local ) 
     269      !$acc enter data copyin(message%message_local(i)%displ_src(:)) async 
     270      !$acc enter data copyin(message%message_local(i)%displ_dest(:)) async 
     271      !$acc enter data copyin(message%message_local(i)%sign(:)) async 
     272    end do 
     273    !$acc enter data copyin(message%field(:)) async 
     274    do i = 1, ndomain 
     275      !$acc enter data copyin(message%field(i)%rval4d(:,:,:)) async 
     276    end do 
     277 
     278    do i=1, size(message%message_out) 
     279      submessage => message%message_out(i) 
     280      call MPI_Request_free(message%mpi_requests_out(i), ierr) 
     281      !$acc host_data use_device(submessage%buff) 
     282      call MPI_Send_init( submessage%buff, size(submessage%buff), MPI_DOUBLE, domglo_rank(submessage%remote_ind_glo), & 
     283        submessage%remote_ind_glo+ndomain_glo*domloc_glo_ind(submessage%ind_loc), & 
     284        comm_icosa, message%mpi_requests_out(i), ierr ) 
     285      !$acc end host_data 
     286    end do 
     287    do i=1, size(message%message_in) 
     288      submessage => message%message_in(i) 
     289      call MPI_Request_free(message%mpi_requests_in(i), ierr) 
     290      !$acc host_data use_device(submessage%buff) 
     291      call MPI_Recv_init( submessage%buff, size(submessage%buff), MPI_DOUBLE, domglo_rank(submessage%remote_ind_glo), & 
     292        domloc_glo_ind(submessage%ind_loc)+ndomain_glo*submessage%remote_ind_glo, & 
     293        comm_icosa,  message%mpi_requests_in(i), ierr ) 
     294      !$acc end host_data 
     295    end do 
     296 
     297    message%ondevice=.true. 
     298    !!$acc update device(message%ondevice) 
     299  end subroutine 
     300 
     301  subroutine message_delete_ondevice(message) 
     302    type(t_message), intent(inout) :: message 
     303    integer :: i 
     304 
     305    if( .not. message%ondevice ) call dynamico_abort("Message not on device") 
     306 
     307    do i = 1, size( message%message_in ) 
     308      !$acc exit data delete(message%message_in(i)%buff(:,:,:)) async 
     309      !$acc exit data delete(message%message_in(i)%displs(:)) async 
     310      !$acc exit data delete(message%message_in(i)%sign(:)) async 
     311    end do 
     312    !$acc exit data delete(message%message_in(:)) async 
     313    do i = 1, size( message%message_out ) 
     314      !$acc exit data delete(message%message_out(i)%buff(:,:,:)) async 
     315      !$acc exit data delete(message%message_out(i)%displs(:)) async 
     316      !!$acc exit data delete(message%message_out(i)%sign(:)) async 
     317    end do 
     318    !$acc exit data delete(message%message_out(:)) async 
     319    do i = 1, size( message%message_local ) 
     320      !$acc exit data delete(message%message_local(i)%displ_src(:)) async 
     321      !$acc exit data delete(message%message_local(i)%displ_dest(:)) async 
     322      !$acc exit data delete(message%message_local(i)%sign(:)) async 
     323    end do 
     324    !$acc exit data delete(message%message_local(:)) async 
     325 
     326    do i = 1, ndomain 
     327      !$acc exit data delete(message%field(i)%rval4d(:,:,:)) async 
     328    end do 
     329    !$acc exit data delete(message%field(:)) async 
     330    !$acc exit data delete(message) async 
     331    message%ondevice=.false. 
     332  end subroutine 
     333 
     334  subroutine finalize_message(message) 
     335    type(t_message), intent(inout) :: message 
     336    integer :: i, ierr 
     337 
     338    !$omp barrier 
     339    !$omp master 
     340    if(message%send_seq /= message%wait_seq) call dynamico_abort("No matching wait_message before finalization") 
     341 
     342    if(message%ondevice) call message_delete_ondevice(message) 
     343    deallocate(message%message_in) 
     344    deallocate(message%message_out) 
     345    deallocate(message%message_local) 
     346    do i=1, size(message%mpi_requests_in) 
     347      call MPI_Request_free(message%mpi_requests_in(i), ierr) 
     348    end do 
     349    deallocate(message%mpi_requests_in) 
     350    do i=1, size(message%mpi_requests_out) 
     351      call MPI_Request_free(message%mpi_requests_out(i), ierr) 
     352    end do 
     353    deallocate(message%mpi_requests_out) 
     354    !$omp end master 
     355    !$omp barrier 
     356  end subroutine 
     357 
     358  subroutine send_message(field, message) 
     359    use mpi_mod 
     360    use domain_mod, only : assigned_domain 
     361    use omp_para, only : distrib_level 
     362    type(t_field),pointer :: field(:) 
     363    type(t_message), target :: message 
     364    integer :: i, k, d3, d4 
     365    integer :: ierr, d3_begin, d3_end, dim4 
     366 
     367    call enter_profile(profile_mpi) 
     368 
     369    ! Needed because rval4d is set in init_message 
     370    if( .not. associated( message%field, field ) ) & 
     371      call dynamico_abort("send_message must be called with the same field used in init_message") 
     372 
     373    !Prepare 'message' for on-device copies if field is on device 
     374    !$omp master 
     375    if( field(1)%ondevice .and. .not. message%ondevice ) call message_create_ondevice(message) 
     376    if( field(1)%ondevice .neqv. message%ondevice ) call dynamico_abort("send_message : internal device/host memory synchronization error") 
     377    ! Check if previous message has been waited 
     378    if(message%send_seq /= message%wait_seq) & 
     379      call dynamico_abort("No matching wait_message before new send_message") 
     380    message%send_seq = message%send_seq + 1 
     381    !$omp end master 
    1023382     
    1024 ! ! Reorder the request, so recv request are done in the same order than send request 
    1025  
    1026 !    nreq_send=sum(request(:)%nsend)   
    1027 !    message%nreq_send=nreq_send 
    1028 !    ALLOCATE(message%reorder(nreq_send)) 
    1029 !    reorder=>message%reorder 
    1030 !    ireq=0 
    1031 !    DO ind=1,ndomain 
    1032 !      req=>request(ind) 
    1033 !      DO isend=1,req%nsend 
    1034 !        ireq=ireq+1 
    1035 !        reorder(ireq)%ind=ind 
    1036 !        reorder(ireq)%isend=isend 
    1037 !        reorder(ireq)%tag=req%send(isend)%tag 
    1038 !      ENDDO 
    1039 !    ENDDO 
    1040  
    1041 ! ! do a very very bad sort 
    1042 !    DO i=1,nreq_send-1 
    1043 !      DO j=i+1,nreq_send 
    1044 !        IF (reorder(i)%tag > reorder(j)%tag) THEN 
    1045 !          reorder_swap=reorder(i) 
    1046 !          reorder(i)=reorder(j) 
    1047 !          reorder(j)=reorder_swap 
    1048 !        ENDIF 
    1049 !      ENDDO 
    1050 !    ENDDO 
    1051 !    PRINT *,"reorder ",reorder(:)%tag 
    1052      
    1053   
    1054 !$OMP END MASTER 
    1055 !$OMP BARRIER     
    1056  
    1057   END SUBROUTINE init_message_mpi 
    1058    
    1059   SUBROUTINE Finalize_message_mpi(field,message) 
    1060   USE field_mod 
    1061   USE domain_mod 
    1062   USE mpi_mod 
    1063   USE mpipara 
    1064   USE mpi_mod 
    1065   IMPLICIT NONE 
    1066     TYPE(t_field),POINTER :: field(:) 
    1067     TYPE(t_message) :: message 
    1068  
    1069     INTEGER :: ireq, ibuff 
    1070  
    1071 !$OMP BARRIER 
    1072 !$OMP MASTER 
    1073  
    1074  
    1075     IF (message%field(1)%data_type==type_real) THEN 
    1076       DO ireq=1,message%nreq 
    1077         CALL free_mpi_buffer(message%buffers(ireq)%r) 
    1078       ENDDO     
    1079     ENDIF 
    1080  
    1081     !deallocate device data if ondevice 
    1082     if(message%ondevice) then 
    1083       do ireq=1, ndomain 
    1084         do ibuff=1,message%request(ireq)%nsend 
    1085           !$acc exit data delete(message%request(ireq)%send(ibuff)%buffer(:)) 
    1086           !$acc exit data delete(message%request(ireq)%send(ibuff)%buffer_r(:)) 
    1087           !$acc exit data delete(message%request(ireq)%send(ibuff)%sign(:)) 
    1088           !$acc exit data delete(message%request(ireq)%send(ibuff)%src_value(:)) 
    1089           !$acc exit data delete(message%request(ireq)%send(ibuff)%value(:)) 
     383    call enter_profile(profile_mpi_barrier) 
     384    !$omp barrier 
     385    call exit_profile(profile_mpi_barrier) 
     386 
     387    dim4 = size(message%field(1)%rval4d, 3) 
     388    CALL distrib_level( 1, size(message%field(1)%rval4d, 2), d3_begin, d3_end ) 
     389 
     390    call enter_profile(profile_mpi_copies) 
     391    !$acc data present(message) async if(message%ondevice) 
     392 
     393    ! Halo to Buffer : copy outbound message to MPI buffers 
     394    !$acc parallel loop default(none) present(message, assigned_domain) async if(message%ondevice) 
     395    do i = 1, size( message%message_out ) 
     396      if( assigned_domain( message%message_out(i)%ind_loc ) ) then 
     397        !$acc loop collapse(2) 
     398        do d4 = 1, dim4 
     399          do d3 = d3_begin, d3_end 
     400            !$acc loop 
     401             do k = 1, size(message%message_out(i)%displs) 
     402              message%message_out(i)%buff(k,d3,d4) = message%field(message%message_out(i)%ind_loc)%rval4d(message%message_out(i)%displs(k),d3, d4) 
     403            end do 
     404          end do 
    1090405        end do 
    1091         do ibuff=1,message%request(ireq)%nrecv 
    1092           !$acc exit data delete(message%request(ireq)%recv(ibuff)%buffer(:)) 
    1093           !$acc exit data delete(message%request(ireq)%recv(ibuff)%buffer_r(:)) 
    1094           !$acc exit data delete(message%request(ireq)%recv(ibuff)%sign(:)) 
    1095           !$acc exit data delete(message%request(ireq)%recv(ibuff)%src_value(:)) 
    1096           !$acc exit data delete(message%request(ireq)%recv(ibuff)%value(:)) 
     406      endif 
     407    end do 
     408 
     409    ! Halo to Halo : copy local messages from source field to destination field 
     410    !$acc parallel loop default(none) present(message, assigned_domain) async if(message%ondevice) 
     411    do i = 1, size( message%message_local ) 
     412      if( assigned_domain( message%message_local(i)%dest_ind_loc ) ) then 
     413        !$acc loop collapse(2)  
     414        do d4 = 1, dim4 
     415          do d3 = d3_begin, d3_end 
     416            ! Cannot collapse because size(displ_dest) varies with i 
     417            !$acc loop vector 
     418            do k = 1, size(message%message_local(i)%displ_dest) 
     419              message%field(message%message_local(i)%dest_ind_loc)%rval4d(message%message_local(i)%displ_dest(k),d3,d4) = & 
     420                message%message_local(i)%sign(k)*message%field(message%message_local(i)%src_ind_loc)%rval4d(message%message_local(i)%displ_src(k),d3,d4) 
     421            end do 
     422          end do 
    1097423        end do 
    1098       end do 
    1099       DO ireq=1,message%nreq 
    1100         !$acc exit data delete(message%buffers(ireq)%r) 
    1101       ENDDO 
    1102       message%ondevice=.false. 
     424      endif 
     425    end do 
     426 
     427    !$acc end data 
     428    call exit_profile(profile_mpi_copies) 
     429 
     430 
     431    call enter_profile(profile_mpi_barrier) 
     432    !$acc wait 
     433    !$omp barrier 
     434    call exit_profile(profile_mpi_barrier) 
     435 
     436    !$omp master 
     437    call MPI_Startall( size(message%mpi_requests_out), message%mpi_requests_out, ierr ) 
     438    call MPI_Startall( size(message%mpi_requests_in), message%mpi_requests_in, ierr ) 
     439    !$omp end master 
     440 
     441    call exit_profile(profile_mpi) 
     442  end subroutine 
     443 
     444  subroutine test_message(message) 
     445    use mpi_mod 
     446    type(t_message) :: message 
     447    integer :: ierr 
     448    logical :: completed 
     449 
     450    !$omp master 
     451    call MPI_Testall( size(message%mpi_requests_out), message%mpi_requests_out, completed, MPI_STATUSES_IGNORE, ierr ) 
     452    call MPI_Testall( size(message%mpi_requests_in), message%mpi_requests_in, completed, MPI_STATUSES_IGNORE, ierr ) 
     453    !$omp end master 
     454  end subroutine 
     455 
     456  subroutine wait_message(message) 
     457    use mpi_mod 
     458    use domain_mod, only : assigned_domain 
     459    use omp_para, only : distrib_level 
     460    type(t_message), target :: message 
     461    integer :: d3_begin, d3_end, dim4 
     462    integer :: i, ierr, k, d3, d4 
     463 
     464    ! Check if message has been sent and not recieved yet 
     465    ! note : barrier needed between this and send_seq increment, and this and wait_seq increment 
     466    ! note : watch out for integer overflow a = b+1 doesn't imply a>b 
     467    if(message%send_seq /= message%wait_seq+1) then 
     468      print*, "WARNING : wait_message called multiple times for one send_message, skipping" 
     469      return ! Don't recieve message if already recieved 
    1103470    end if 
    1104471 
    1105     DEALLOCATE(message%mpi_req) 
    1106     DEALLOCATE(message%buffers) 
    1107     DEALLOCATE(message%status) 
    1108  
    1109 !$OMP END MASTER 
    1110 !$OMP BARRIER 
    1111  
    1112        
    1113   END SUBROUTINE Finalize_message_mpi 
    1114  
    1115  
    1116    
    1117   SUBROUTINE barrier 
    1118   USE mpi_mod 
    1119   USE mpipara 
    1120   IMPLICIT NONE 
    1121      
    1122     CALL MPI_BARRIER(comm_icosa,ierr) 
    1123      
    1124   END SUBROUTINE barrier   
    1125      
    1126   SUBROUTINE transfert_message_mpi(field,message) 
    1127   USE field_mod 
    1128   IMPLICIT NONE 
    1129     TYPE(t_field),POINTER :: field(:) 
    1130     TYPE(t_message) :: message 
    1131      
    1132     CALL send_message_mpi(field,message) 
    1133     CALL wait_message_mpi(message) 
    1134      
    1135   END SUBROUTINE transfert_message_mpi 
    1136  
    1137  
    1138   !!!Update buffers on device for 'message' 
    1139   !!! does create_device_message when not already ondevice 
    1140   SUBROUTINE update_device_message_mpi(message) 
    1141     USE domain_mod 
    1142     IMPLICIT NONE 
    1143     TYPE(t_message), intent(inout) :: message 
    1144     INTEGER :: ireq, ibuff 
    1145  
    1146     !if(.not. message%ondevice) call create_device_message_mpi(message) 
    1147  
    1148     do ireq=1, ndomain 
    1149       do ibuff=1,message%request(ireq)%nsend 
    1150         !device buffers updated even if pointers not attached : 
    1151         !non allocated buffers in 'message' must be set to NULL() 
    1152         !$acc enter data copyin(message%request(ireq)%send(ibuff)%buffer(:)) async 
    1153         !$acc enter data copyin(message%request(ireq)%send(ibuff)%buffer_r(:)) async 
    1154         !$acc enter data copyin(message%request(ireq)%send(ibuff)%sign(:)) async 
    1155         !$acc enter data copyin(message%request(ireq)%send(ibuff)%src_value(:)) async 
    1156         !$acc enter data copyin(message%request(ireq)%send(ibuff)%value(:)) async 
    1157       end do 
    1158       do ibuff=1,message%request(ireq)%nrecv 
    1159         !$acc enter data copyin(message%request(ireq)%recv(ibuff)%buffer(:)) async 
    1160         !$acc enter data copyin(message%request(ireq)%recv(ibuff)%buffer_r(:)) async 
    1161         !$acc enter data copyin(message%request(ireq)%recv(ibuff)%sign(:)) async 
    1162         !$acc enter data copyin(message%request(ireq)%recv(ibuff)%src_value(:)) async 
    1163         !$acc enter data copyin(message%request(ireq)%recv(ibuff)%value(:)) async 
    1164       end do 
    1165     end do 
    1166     DO ireq=1,message%nreq 
    1167       !$acc enter data copyin(message%buffers(ireq)%r) async 
    1168     ENDDO 
    1169     message%ondevice=.true. 
    1170   END SUBROUTINE 
    1171  
    1172   !TODO : add openacc with multiple process 
    1173   SUBROUTINE send_message_mpi(field,message) 
    1174   USE abort_mod 
    1175   USE profiling_mod 
    1176   USE field_mod 
    1177   USE domain_mod 
    1178   USE mpi_mod 
    1179   USE mpipara 
    1180   USE omp_para 
    1181   USE trace 
    1182   USE abort_mod 
    1183   IMPLICIT NONE 
    1184     TYPE(t_field),POINTER :: field(:) 
    1185     TYPE(t_message) :: message 
    1186     REAL(rstd),POINTER :: rval2d(:), src_rval2d(:)  
    1187     REAL(rstd),POINTER :: rval3d(:,:), src_rval3d(:,:)  
    1188     REAL(rstd),POINTER :: rval4d(:,:,:), src_rval4d(:,:,:)  
    1189     REAL(rstd),POINTER :: buffer_r(:)  
    1190     INTEGER,POINTER :: value(:)  
    1191     INTEGER,POINTER :: sgn(:)  
    1192     TYPE(ARRAY),POINTER :: recv,send  
    1193     TYPE(t_request),POINTER :: req 
    1194     INTEGER :: irecv,isend 
    1195     INTEGER :: ireq 
    1196     INTEGER :: ind,n 
    1197     INTEGER :: dim3,dim4,d3,d4 
    1198     INTEGER,POINTER :: src_value(:) 
    1199     INTEGER :: offset,msize,moffset,rank 
    1200     INTEGER :: lbegin, lend 
    1201     INTEGER :: max_req 
    1202  
    1203 !    CALL trace_start("send_message_mpi") 
    1204  
    1205     CALL enter_profile(id_mpi) 
    1206  
    1207     !Prepare 'message' for on-device copies if field is on device 
    1208     if( field(1)%ondevice .AND. .NOT. message%ondevice ) call update_device_message_mpi(message) 
    1209  
    1210 CALL enter_profile(profile_mpi_omp_barrier) 
    1211 !$OMP BARRIER 
    1212 CALL exit_profile(profile_mpi_omp_barrier) 
    1213  
    1214  
    1215 !$OMP MASTER 
    1216     IF(message%open) THEN 
    1217        PRINT *, 'send_message_mpi : message ' // TRIM(message%name) // & 
    1218             ' is still open, no call to wait_message_mpi after last send_message_mpi' 
    1219        CALL dynamico_abort( "send_message_mpi : message still open" ) 
    1220     END IF 
    1221     message%open=.TRUE. ! will be set to .FALSE. by wait_message_mpi 
    1222  
    1223     message%field=>field 
    1224  
    1225     IF (message%nreq>0) THEN 
    1226       message%completed=.FALSE. 
    1227       message%pending=.TRUE. 
    1228     ELSE 
    1229       message%completed=.TRUE. 
    1230       message%pending=.FALSE. 
    1231     ENDIF 
    1232 !$OMP END MASTER 
    1233 CALL enter_profile(profile_mpi_omp_barrier) 
    1234 !$OMP BARRIER 
    1235 CALL exit_profile(profile_mpi_omp_barrier) 
    1236       
    1237     IF (field(1)%data_type==type_real) THEN 
    1238       IF (field(1)%ndim==2) THEN 
    1239  
    1240         DO ind=1,ndomain 
    1241           IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 
    1242            
    1243           rval2d=>field(ind)%rval2d 
    1244          
    1245           req=>message%request(ind) 
    1246           DO isend=1,req%nsend 
    1247             send=>req%send(isend) 
    1248             value=>send%value 
    1249  
    1250              
    1251             IF (send%rank/=mpi_rank) THEN 
    1252               ireq=send%ireq 
    1253  
    1254               buffer_r=>message%buffers(ireq)%r 
    1255               offset=send%offset 
    1256               msize=send%size 
    1257               call enter_profile(profile_mpi_copies) 
    1258               !$acc parallel loop default(present) async if (field(ind)%ondevice) 
    1259               DO n=1,msize 
    1260                 buffer_r(offset+n)=rval2d(value(n)) 
    1261               ENDDO 
    1262               call exit_profile(profile_mpi_copies) 
    1263  
    1264               IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 
    1265                 CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 
    1266                 !$OMP CRITICAL             
    1267                 CALL MPI_ISEND(buffer_r,send%size,MPI_REAL8,send%rank,               & 
    1268                   send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
    1269                 !$OMP END CRITICAL 
    1270               ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 
    1271                 CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE") 
    1272                 CALL MPI_ISEND(buffer_r,send%size,MPI_REAL8,send%rank,               & 
    1273                   send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
    1274               ENDIF 
    1275               
    1276             ENDIF 
    1277           ENDDO 
    1278         ENDDO 
    1279          
    1280         DO ind=1,ndomain 
    1281           IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 
    1282           rval2d=>field(ind)%rval2d 
    1283           req=>message%request(ind)         
    1284  
    1285           DO irecv=1,req%nrecv 
    1286             recv=>req%recv(irecv) 
    1287  
    1288             IF (recv%rank==mpi_rank) THEN 
    1289  
    1290               value=>recv%value 
    1291               src_value => recv%src_value 
    1292               src_rval2d=>field(recv%domain)%rval2d 
    1293               sgn=>recv%sign 
    1294               msize=recv%size 
    1295               call enter_profile(profile_mpi_copies) 
    1296               !$acc parallel loop default(present) async if (field(ind)%ondevice) 
    1297               DO n=1,msize 
    1298                 rval2d(value(n))=src_rval2d(src_value(n))*sgn(n) 
    1299               ENDDO 
    1300               call exit_profile(profile_mpi_copies) 
    1301                      
    1302             ELSE 
    1303              
    1304               ireq=recv%ireq 
    1305               buffer_r=>message%buffers(ireq)%r 
    1306               IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 
    1307                 CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 
    1308                !$OMP CRITICAL             
    1309                 CALL MPI_IRECV(buffer_r,recv%size,MPI_REAL8,recv%rank,               & 
    1310                   recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
    1311                !$OMP END CRITICAL 
    1312               ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 
    1313                  CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE") 
    1314                  CALL MPI_IRECV(buffer_r,recv%size,MPI_REAL8,recv%rank,              & 
    1315                    recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
    1316               ENDIF 
    1317              
    1318             ENDIF 
    1319           ENDDO 
    1320          
    1321         ENDDO 
    1322          
    1323        
    1324       ELSE  IF (field(1)%ndim==3) THEN 
    1325         max_req=0 
    1326         DO ind=1,ndomain 
    1327           req=>message%request(ind) 
    1328           IF (req%nsend>max_req) max_req=req%nsend 
    1329         ENDDO 
    1330                
    1331         DO ind=1,ndomain 
    1332           IF (.NOT. assigned_domain(ind) ) CYCLE 
    1333  
    1334           dim3=size(field(ind)%rval3d,2) 
    1335           CALL distrib_level(1,dim3, lbegin,lend) 
    1336  
    1337           rval3d=>field(ind)%rval3d 
    1338           req=>message%request(ind) 
    1339   
    1340           DO isend=1,req%nsend 
    1341             send=>req%send(isend) 
    1342             value=>send%value 
    1343  
    1344             IF (send%rank/=mpi_rank) THEN 
    1345               ireq=send%ireq 
    1346               buffer_r=>message%buffers(ireq)%r 
    1347  
    1348               msize=send%size 
    1349               moffset=send%offset 
    1350               call enter_profile(profile_mpi_copies) 
    1351  
    1352               !$acc parallel loop default(present) async if (field(ind)%ondevice) 
    1353               DO d3=lbegin,lend 
    1354                 offset=moffset*dim3 + (d3-1)*msize 
    1355                 !$acc loop 
    1356                 DO n=1,msize 
    1357                   buffer_r(n+offset)=rval3d(value(n),d3) 
    1358                 ENDDO 
    1359               ENDDO 
    1360               call exit_profile(profile_mpi_copies) 
    1361  
    1362               IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN 
    1363 CALL enter_profile(profile_mpi_omp_barrier) 
    1364 !$OMP BARRIER 
    1365 CALL exit_profile(profile_mpi_omp_barrier) 
    1366  
    1367               ENDIF 
    1368                
    1369               IF (is_omp_level_master) THEN 
    1370                 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 
    1371                   CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 
    1372                   !$OMP CRITICAL    
    1373                   CALL MPI_ISEND(buffer_r,send%size*dim3,MPI_REAL8,send%rank,        & 
    1374                     send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
    1375                   !$OMP END CRITICAL 
    1376                 ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 
    1377                   CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE") 
    1378                   CALL MPI_ISEND(buffer_r,send%size*dim3,MPI_REAL8,send%rank,        & 
    1379                     send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
    1380                 ENDIF 
    1381               ENDIF 
    1382             ELSE 
    1383               IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN 
    1384 CALL enter_profile(profile_mpi_omp_barrier) 
    1385 !$OMP BARRIER 
    1386 CALL exit_profile(profile_mpi_omp_barrier) 
    1387  
    1388               ENDIF 
    1389             ENDIF 
    1390           ENDDO 
    1391  
    1392           IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN 
    1393             DO isend=req%nsend+1,max_req 
    1394 CALL enter_profile(profile_mpi_omp_barrier) 
    1395 !$OMP BARRIER 
    1396 CALL exit_profile(profile_mpi_omp_barrier) 
    1397  
    1398             ENDDO 
    1399           ENDIF 
    1400  
    1401         ENDDO 
    1402           
    1403         DO ind=1,ndomain 
    1404           IF (.NOT. assigned_domain(ind) ) CYCLE 
    1405           dim3=size(field(ind)%rval3d,2) 
    1406           CALL distrib_level(1,dim3, lbegin,lend) 
    1407           rval3d=>field(ind)%rval3d 
    1408           req=>message%request(ind) 
    1409  
    1410           DO irecv=1,req%nrecv 
    1411             recv=>req%recv(irecv) 
    1412  
    1413             IF (recv%rank==mpi_rank) THEN 
    1414               value=>recv%value 
    1415               src_value => recv%src_value 
    1416               src_rval3d=>field(recv%domain)%rval3d 
    1417               sgn=>recv%sign 
    1418               msize=recv%size 
    1419  
    1420               call enter_profile(profile_mpi_copies) 
    1421               CALL trace_start("copy_data") 
    1422               !$acc parallel loop collapse(2) default(present) async if (field(ind)%ondevice) 
    1423               DO d3=lbegin,lend 
    1424                 DO n=1,msize 
    1425                   rval3d(value(n),d3)=src_rval3d(src_value(n),d3)*sgn(n) 
    1426                 ENDDO 
    1427               ENDDO 
    1428               call exit_profile(profile_mpi_copies) 
    1429               CALL trace_end("copy_data") 
    1430  
    1431             ELSE 
    1432               ireq=recv%ireq 
    1433               buffer_r=>message%buffers(ireq)%r 
    1434   
    1435               IF (is_omp_level_master) THEN 
    1436                 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 
    1437                   CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 
    1438                   !$OMP CRITICAL 
    1439                   CALL MPI_IRECV(buffer_r,recv%size*dim3,MPI_REAL8,recv%rank,        & 
    1440                     recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
    1441                   !$OMP END CRITICAL 
    1442                 ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 
    1443                   CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE") 
    1444                   CALL MPI_IRECV(buffer_r,recv%size*dim3,MPI_REAL8,recv%rank,        & 
    1445                     recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
    1446                 ENDIF 
    1447               ENDIF 
    1448             ENDIF   
    1449           ENDDO 
    1450          
    1451         ENDDO 
    1452  
    1453       ELSE  IF (field(1)%ndim==4) THEN 
    1454  
    1455         max_req=0 
    1456         DO ind=1,ndomain 
    1457           req=>message%request(ind) 
    1458           IF (req%nsend>max_req) max_req=req%nsend 
    1459         ENDDO 
    1460      
    1461         DO ind=1,ndomain 
    1462           IF (.NOT. assigned_domain(ind) ) CYCLE 
    1463  
    1464           dim3=size(field(ind)%rval4d,2) 
    1465           CALL distrib_level(1,dim3, lbegin,lend) 
    1466           dim4=size(field(ind)%rval4d,3) 
    1467           rval4d=>field(ind)%rval4d 
    1468           req=>message%request(ind) 
    1469  
    1470           DO isend=1,req%nsend 
    1471             send=>req%send(isend) 
    1472             value=>send%value 
    1473  
    1474             IF (send%rank/=mpi_rank) THEN 
    1475  
    1476               ireq=send%ireq 
    1477               buffer_r=>message%buffers(ireq)%r 
    1478               msize=send%size 
    1479               moffset=send%offset 
    1480  
    1481               call enter_profile(profile_mpi_copies) 
    1482               CALL trace_start("copy_to_buffer") 
    1483               !$acc parallel loop default(present) collapse(2) async if (field(ind)%ondevice) 
    1484               DO d4=1,dim4 
    1485                 DO d3=lbegin,lend 
    1486                   offset=moffset*dim3*dim4 + dim3*msize*(d4-1) +               & 
    1487                     (d3-1)*msize 
    1488                   !$acc loop 
    1489                   DO n=1,msize 
    1490                     buffer_r(n+offset)=rval4d(value(n),d3,d4) 
    1491                   ENDDO 
    1492                 ENDDO 
    1493               ENDDO 
    1494               CALL trace_end("copy_to_buffer") 
    1495               call exit_profile(profile_mpi_copies) 
    1496  
    1497               IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN 
    1498 CALL enter_profile(profile_mpi_omp_barrier) 
    1499 !$OMP BARRIER 
    1500 CALL exit_profile(profile_mpi_omp_barrier) 
    1501  
    1502               ENDIF 
    1503  
    1504               IF (is_omp_level_master) THEN 
    1505                 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 
    1506                   CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 
    1507                   !$OMP CRITICAL 
    1508                   CALL MPI_ISEND(buffer_r,send%size*dim3*dim4,MPI_REAL8,send%rank,   & 
    1509                     send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
    1510                   !$OMP END CRITICAL 
    1511                 ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 
    1512                   CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE") 
    1513                   CALL MPI_ISEND(buffer_r,send%size*dim3*dim4,MPI_REAL8,send%rank,   & 
    1514                     send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
    1515                 ENDIF 
    1516               ENDIF 
    1517             ELSE 
    1518               IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN 
    1519 CALL enter_profile(profile_mpi_omp_barrier) 
    1520 !$OMP BARRIER 
    1521 CALL exit_profile(profile_mpi_omp_barrier) 
    1522  
    1523               ENDIF 
    1524             ENDIF 
    1525           ENDDO 
    1526            
    1527           IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN 
    1528             DO isend=req%nsend+1,max_req 
    1529 CALL enter_profile(profile_mpi_omp_barrier) 
    1530 !$OMP BARRIER 
    1531 CALL exit_profile(profile_mpi_omp_barrier) 
    1532  
    1533             ENDDO 
    1534           ENDIF 
    1535  
    1536         ENDDO 
    1537          
    1538         DO ind=1,ndomain 
    1539           IF (.NOT. assigned_domain(ind) ) CYCLE 
    1540            
    1541           dim3=size(field(ind)%rval4d,2) 
    1542           CALL distrib_level(1,dim3, lbegin,lend) 
    1543           dim4=size(field(ind)%rval4d,3) 
    1544           rval4d=>field(ind)%rval4d 
    1545           req=>message%request(ind) 
    1546            
    1547           DO irecv=1,req%nrecv 
    1548             recv=>req%recv(irecv) 
    1549             IF (recv%rank==mpi_rank) THEN 
    1550               value=>recv%value 
    1551               src_value => recv%src_value 
    1552               src_rval4d=>field(recv%domain)%rval4d 
    1553               sgn=>recv%sign 
    1554               msize=recv%size 
    1555               call enter_profile(profile_mpi_copies) 
    1556               CALL trace_start("copy_data") 
    1557               !$acc parallel loop collapse(3) default(present) async if (field(ind)%ondevice) 
    1558               DO d4=1,dim4 
    1559                 DO d3=lbegin,lend 
    1560                   DO n=1,msize 
    1561                     rval4d(value(n),d3,d4)=src_rval4d(src_value(n),d3,d4)*sgn(n) 
    1562                   ENDDO 
    1563                 ENDDO 
    1564               ENDDO 
    1565               call exit_profile(profile_mpi_copies) 
    1566               CALL trace_end("copy_data") 
    1567                     
    1568             ELSE 
    1569  
    1570               ireq=recv%ireq 
    1571               buffer_r=>message%buffers(ireq)%r 
    1572               IF (is_omp_level_master) THEN 
    1573                 IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 
    1574                   CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 
    1575                  !$OMP CRITICAL            
    1576                   CALL MPI_IRECV(buffer_r,recv%size*dim3*dim4,MPI_REAL8,recv%rank,   & 
    1577                     recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)  
    1578                   !$OMP END CRITICAL 
    1579                 ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 
    1580                   CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE") 
    1581                   CALL MPI_IRECV(buffer_r,recv%size*dim3*dim4,MPI_REAL8,recv%rank,   & 
    1582                     recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)  
    1583                 ENDIF 
    1584               ENDIF 
    1585             ENDIF 
    1586           ENDDO 
    1587         ENDDO 
    1588  
    1589       ENDIF       
    1590  
    1591       IF (mpi_threading_mode==MPI_THREAD_FUNNELED .OR. mpi_threading_mode==MPI_THREAD_SINGLE) THEN 
    1592 CALL enter_profile(profile_mpi_omp_barrier) 
    1593 !$acc wait 
    1594 !$OMP BARRIER 
    1595 CALL exit_profile(profile_mpi_omp_barrier) 
    1596 !$OMP MASTER         
    1597  
    1598         DO ireq=1,message%nreq_send 
    1599           buffer_r=>message%buffers(ireq)%r 
    1600           msize=message%buffers(ireq)%size 
    1601           rank=message%buffers(ireq)%rank 
    1602           ! Using the "if" clause on the "host_data" directive seems to cause a crash at compilation 
    1603           IF (message%ondevice) THEN 
    1604             !$acc host_data use_device(buffer_r) ! if (message%ondevice) 
    1605             CALL MPI_ISEND(buffer_r,msize,MPI_REAL8,rank,1000*message%number,          & 
    1606               comm_icosa, message%mpi_req(ireq),ierr) 
    1607             !$acc end host_data 
    1608           ELSE 
    1609             CALL MPI_ISEND(buffer_r,msize,MPI_REAL8,rank,1000*message%number,          & 
    1610               comm_icosa, message%mpi_req(ireq),ierr) 
    1611           ENDIF 
    1612         ENDDO 
    1613  
    1614         DO ireq=message%nreq_send+1,message%nreq_send+message%nreq_recv 
    1615           buffer_r=>message%buffers(ireq)%r 
    1616           msize=message%buffers(ireq)%size 
    1617           rank=message%buffers(ireq)%rank 
    1618           ! Using the "if" clause on the "host_data" directive seems to cause a crash at compilation 
    1619           IF (message%ondevice) THEN 
    1620             !$acc host_data use_device(buffer_r) ! if (message%ondevice) 
    1621             CALL MPI_IRECV(buffer_r,msize,MPI_REAL8,rank,1000*message%number,          & 
    1622               comm_icosa, message%mpi_req(ireq),ierr) 
    1623             !$acc end host_data 
    1624           ELSE 
    1625             CALL MPI_IRECV(buffer_r,msize,MPI_REAL8,rank,1000*message%number,          & 
    1626               comm_icosa, message%mpi_req(ireq),ierr) 
    1627           ENDIF 
    1628         ENDDO 
    1629  
    1630 !$OMP END MASTER 
    1631       ENDIF               
    1632     ENDIF 
    1633 CALL enter_profile(profile_mpi_omp_barrier) 
    1634 !$OMP BARRIER 
    1635 CALL exit_profile(profile_mpi_omp_barrier) 
    1636   
    1637 !    CALL trace_end("send_message_mpi") 
    1638  
    1639     CALL exit_profile(id_mpi) 
    1640      
    1641   END SUBROUTINE send_message_mpi 
    1642    
    1643   SUBROUTINE test_message_mpi(message) 
    1644   IMPLICIT NONE 
    1645     TYPE(t_message) :: message 
    1646      
    1647     INTEGER :: ierr 
    1648  
    1649 !$OMP MASTER 
    1650     IF (message%pending .AND. .NOT. message%completed) CALL MPI_TESTALL(message%nreq,& 
    1651       message%mpi_req,message%completed,message%status,ierr) 
    1652 !$OMP END MASTER 
    1653   END SUBROUTINE  test_message_mpi 
    1654    
    1655     
    1656   SUBROUTINE wait_message_mpi(message) 
    1657   USE profiling_mod 
    1658   USE field_mod 
    1659   USE domain_mod 
    1660   USE mpi_mod 
    1661   USE mpipara 
    1662   USE omp_para 
    1663   USE trace 
    1664   IMPLICIT NONE 
    1665     TYPE(t_message) :: message 
    1666  
    1667     TYPE(t_field),POINTER :: field(:) 
    1668     REAL(rstd),POINTER :: rval2d(:)  
    1669     REAL(rstd),POINTER :: rval3d(:,:)  
    1670     REAL(rstd),POINTER :: rval4d(:,:,:)  
    1671     REAL(rstd),POINTER :: buffer_r(:)  
    1672     INTEGER,POINTER :: value(:)  
    1673     INTEGER,POINTER :: sgn(:)  
    1674     TYPE(ARRAY),POINTER :: recv  
    1675     TYPE(t_request),POINTER :: req 
    1676     INTEGER :: irecv 
    1677     INTEGER :: ireq,nreq 
    1678     INTEGER :: ind,n 
    1679     INTEGER :: dim3,dim4,d3,d4,lbegin,lend 
    1680     INTEGER :: offset, msize, moffset 
    1681  
    1682     message%open=.FALSE. 
    1683     IF (.NOT. message%pending) RETURN 
    1684  
    1685     CALL enter_profile(id_mpi) 
    1686  
    1687 !    CALL trace_start("wait_message_mpi") 
    1688  
    1689     field=>message%field 
    1690     nreq=message%nreq 
    1691      
    1692     IF (field(1)%data_type==type_real) THEN 
    1693       IF (field(1)%ndim==2) THEN 
    1694  
    1695 call enter_profile(profile_mpi_waitall) 
    1696 !$OMP MASTER          
    1697          IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req,          & 
    1698           message%status,ierr) 
    1699 !$OMP END MASTER 
    1700 !$OMP BARRIER 
    1701 call exit_profile(profile_mpi_waitall) 
    1702         call enter_profile(profile_mpi_copies) 
    1703         DO ind=1,ndomain 
    1704           IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 
    1705            
    1706           rval2d=>field(ind)%rval2d 
    1707           req=>message%request(ind) 
    1708           DO irecv=1,req%nrecv 
    1709             recv=>req%recv(irecv) 
    1710             IF (recv%rank/=mpi_rank) THEN 
    1711               ireq=recv%ireq 
    1712               buffer_r=>message%buffers(ireq)%r 
    1713               value=>recv%value 
    1714               sgn=>recv%sign 
    1715               offset=recv%offset 
    1716               msize=recv%size 
    1717               !$acc parallel loop default(present) async if (field(ind)%ondevice) 
    1718               DO n=1,msize 
    1719                 rval2d(value(n))=buffer_r(n+offset)*sgn(n)   
    1720               ENDDO 
    1721  
    1722             ENDIF 
    1723           ENDDO 
    1724          
    1725         ENDDO 
    1726         call exit_profile(profile_mpi_copies) 
    1727        
    1728        
    1729       ELSE  IF (field(1)%ndim==3) THEN 
    1730          call enter_profile(profile_mpi_waitall) 
    1731 !$OMP MASTER 
    1732          IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req,          & 
    1733               message%status,ierr) 
    1734 !$OMP END MASTER 
    1735 !$OMP BARRIER 
    1736         call exit_profile(profile_mpi_waitall) 
    1737  
    1738          
    1739         DO ind=1,ndomain 
    1740           IF (.NOT. assigned_domain(ind) ) CYCLE 
    1741  
    1742           rval3d=>field(ind)%rval3d 
    1743           req=>message%request(ind) 
    1744           DO irecv=1,req%nrecv 
    1745             recv=>req%recv(irecv) 
    1746             IF (recv%rank/=mpi_rank) THEN 
    1747               ireq=recv%ireq 
    1748               buffer_r=>message%buffers(ireq)%r 
    1749               value=>recv%value 
    1750               sgn=>recv%sign 
    1751                
    1752               dim3=size(rval3d,2) 
    1753      
    1754               CALL distrib_level(1,dim3, lbegin,lend) 
    1755               msize=recv%size 
    1756               moffset=recv%offset 
    1757               call enter_profile(profile_mpi_copies) 
    1758               CALL trace_start("copy_from_buffer") 
    1759                
    1760               IF (req%vector) THEN 
    1761                 !$acc parallel loop default(present) async if (field(ind)%ondevice) 
    1762                 DO d3=lbegin,lend 
    1763                   offset=moffset*dim3 + (d3-1)*msize 
    1764                   !$acc loop 
    1765                   DO n=1,msize 
    1766                     rval3d(value(n),d3)=buffer_r(n+offset)*sgn(n)   
    1767                   ENDDO 
    1768                 ENDDO 
    1769               ELSE 
    1770                 !$acc parallel loop default(present) async if (field(ind)%ondevice) 
    1771                 DO d3=lbegin,lend 
    1772                   offset=moffset*dim3 + (d3-1)*msize 
    1773                   !$acc loop 
    1774                   DO n=1,msize 
    1775                     rval3d(value(n),d3)=buffer_r(n+offset)   
    1776                   ENDDO 
    1777                 ENDDO 
    1778               ENDIF 
    1779                  
    1780               CALL trace_end("copy_from_buffer") 
    1781               call exit_profile(profile_mpi_copies) 
    1782             ENDIF 
    1783           ENDDO 
    1784          
    1785         ENDDO 
    1786  
    1787       ELSE  IF (field(1)%ndim==4) THEN 
    1788 call enter_profile(profile_mpi_waitall) 
    1789 !$OMP MASTER 
    1790         IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req,          & 
    1791           message%status,ierr) 
    1792 !$OMP END MASTER 
    1793 !$OMP BARRIER 
    1794         call exit_profile(profile_mpi_waitall) 
    1795  
    1796                  
    1797         DO ind=1,ndomain 
    1798           IF (.NOT. assigned_domain(ind) ) CYCLE 
    1799  
    1800           rval4d=>field(ind)%rval4d 
    1801           req=>message%request(ind) 
    1802           DO irecv=1,req%nrecv 
    1803             recv=>req%recv(irecv) 
    1804             IF (recv%rank/=mpi_rank) THEN 
    1805               ireq=recv%ireq 
    1806               buffer_r=>message%buffers(ireq)%r 
    1807               value=>recv%value 
    1808               sgn=>recv%sign 
    1809  
    1810               dim3=size(rval4d,2) 
    1811               CALL distrib_level(1,dim3, lbegin,lend) 
    1812               dim4=size(rval4d,3) 
    1813               msize=recv%size 
    1814               moffset=recv%offset 
    1815               call enter_profile(profile_mpi_copies) 
    1816               CALL trace_start("copy_from_buffer") 
    1817               !$acc parallel loop default(present) collapse(2) async if (field(ind)%ondevice) 
    1818               DO d4=1,dim4 
    1819                 DO d3=lbegin,lend 
    1820                   offset=moffset*dim3*dim4 + dim3*msize*(d4-1) +               & 
    1821                     (d3-1)*msize 
    1822                   !$acc loop 
    1823                   DO n=1,msize 
    1824                     rval4d(value(n),d3,d4)=buffer_r(n+offset)*sgn(n)  
    1825                   ENDDO 
    1826                 ENDDO 
    1827               ENDDO 
    1828               CALL trace_end("copy_from_buffer") 
    1829               call exit_profile(profile_mpi_copies) 
    1830             ENDIF 
    1831           ENDDO 
    1832          
    1833         ENDDO 
    1834        
    1835       ENDIF       
    1836        
    1837     ENDIF 
    1838  
    1839 !$OMP MASTER 
    1840     message%pending=.FALSE. 
    1841 !$OMP END MASTER 
    1842  
    1843 !    CALL trace_end("wait_message_mpi") 
    1844 !$OMP BARRIER 
    1845    
    1846     CALL exit_profile(id_mpi) 
    1847  
    1848   END SUBROUTINE wait_message_mpi 
    1849  
    1850   SUBROUTINE transfert_request_mpi(field,request) 
    1851   USE field_mod 
    1852   IMPLICIT NONE 
    1853     TYPE(t_field),POINTER :: field(:) 
    1854     TYPE(t_request),POINTER :: request(:) 
    1855  
    1856     TYPE(t_message),SAVE :: message 
    1857     
    1858     
    1859     CALL init_message_mpi(field,request, message) 
    1860     CALL transfert_message_mpi(field,message) 
    1861     CALL finalize_message_mpi(field,message) 
    1862     
    1863   END SUBROUTINE transfert_request_mpi 
    1864   
    1865     
    1866     
    1867   SUBROUTINE transfert_request_seq(field,request) 
    1868   USE field_mod 
    1869   USE domain_mod 
    1870   IMPLICIT NONE 
    1871     TYPE(t_field),POINTER :: field(:) 
    1872     TYPE(t_request),POINTER :: request(:) 
    1873     REAL(rstd),POINTER :: rval2d(:)  
    1874     REAL(rstd),POINTER :: rval3d(:,:)  
    1875     REAL(rstd),POINTER :: rval4d(:,:,:)  
    1876     INTEGER :: ind 
    1877     TYPE(t_request),POINTER :: req 
    1878     INTEGER :: n 
    1879      
    1880     DO ind=1,ndomain 
    1881       req=>request(ind) 
    1882       rval2d=>field(ind)%rval2d 
    1883       rval3d=>field(ind)%rval3d 
    1884       rval4d=>field(ind)%rval4d 
    1885        
    1886       IF (field(ind)%data_type==type_real) THEN 
    1887         IF (field(ind)%ndim==2) THEN 
    1888           DO n=1,req%size 
    1889             rval2d(req%target_ind(n))=field(req%src_domain(n))%rval2d(req%src_ind(n))*& 
    1890               req%target_sign(n) 
    1891           ENDDO 
    1892         ELSE IF (field(ind)%ndim==3) THEN 
    1893           DO n=1,req%size 
    1894             rval3d(req%target_ind(n),:)=field(req%src_domain(n))%rval3d(req%src_ind(n),:)*& 
    1895               req%target_sign(n) 
    1896           ENDDO 
    1897         ELSE IF (field(ind)%ndim==4) THEN 
    1898           DO n=1,req%size 
    1899             rval4d(req%target_ind(n),:,:)=field(req%src_domain(n))%rval4d(req%src_ind(n),:,:)*& 
    1900               req%target_sign(n) 
    1901           ENDDO 
    1902         ENDIF 
    1903       ENDIF         
    1904  
    1905     ENDDO 
    1906      
    1907   END SUBROUTINE transfert_request_seq 
    1908    
    1909    
    1910   SUBROUTINE gather_field(field_loc,field_glo) 
    1911   USE field_mod 
    1912   USE domain_mod 
    1913   USE mpi_mod 
    1914   USE mpipara 
    1915   IMPLICIT NONE 
    1916     TYPE(t_field),POINTER :: field_loc(:) 
    1917     TYPE(t_field),POINTER :: field_glo(:) 
    1918     INTEGER, ALLOCATABLE :: mpi_req(:) 
    1919     INTEGER, ALLOCATABLE :: status(:,:) 
    1920     INTEGER :: ireq,nreq 
    1921     INTEGER :: ind_glo,ind_loc     
    1922    
    1923     IF (.NOT. using_mpi) THEN 
    1924      
    1925       DO ind_loc=1,ndomain 
    1926         IF (field_loc(ind_loc)%ndim==2) field_glo(ind_loc)%rval2d=field_loc(ind_loc)%rval2d 
    1927         IF (field_loc(ind_loc)%ndim==3) field_glo(ind_loc)%rval3d=field_loc(ind_loc)%rval3d 
    1928         IF (field_loc(ind_loc)%ndim==4) field_glo(ind_loc)%rval4d=field_loc(ind_loc)%rval4d 
    1929       ENDDO 
    1930      
    1931     ELSE 
    1932            
    1933       nreq=ndomain 
    1934       IF (mpi_rank==0) nreq=nreq+ndomain_glo  
    1935       ALLOCATE(mpi_req(nreq)) 
    1936       ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 
    1937      
    1938      
    1939       ireq=0 
    1940       IF (mpi_rank==0) THEN 
    1941         DO ind_glo=1,ndomain_glo 
    1942           ireq=ireq+1 
    1943  
    1944           IF (field_glo(ind_glo)%ndim==2) THEN 
    1945             CALL MPI_IRECV(field_glo(ind_glo)%rval2d,size(field_glo(ind_glo)%rval2d) , MPI_REAL8 ,   & 
    1946                          domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
    1947     
    1948           ELSE IF (field_glo(ind_glo)%ndim==3) THEN 
    1949             CALL MPI_IRECV(field_glo(ind_glo)%rval3d,size(field_glo(ind_glo)%rval3d) , MPI_REAL8 ,   & 
    1950                          domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
    1951  
    1952           ELSE IF (field_glo(ind_glo)%ndim==4) THEN 
    1953             CALL MPI_IRECV(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 ,   & 
    1954                          domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
    1955           ENDIF 
    1956           
    1957         ENDDO 
    1958       ENDIF 
    1959    
    1960       DO ind_loc=1,ndomain 
    1961         ireq=ireq+1 
    1962  
    1963         IF (field_loc(ind_loc)%ndim==2) THEN 
    1964           CALL MPI_ISEND(field_loc(ind_loc)%rval2d,size(field_loc(ind_loc)%rval2d) , MPI_REAL8 ,   & 
    1965                          0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
    1966         ELSE IF (field_loc(ind_loc)%ndim==3) THEN 
    1967           CALL MPI_ISEND(field_loc(ind_loc)%rval3d,size(field_loc(ind_loc)%rval3d) , MPI_REAL8 ,   & 
    1968                          0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
    1969         ELSE IF (field_loc(ind_loc)%ndim==4) THEN 
    1970           CALL MPI_ISEND(field_loc(ind_loc)%rval4d,size(field_loc(ind_loc)%rval4d) , MPI_REAL8 ,   & 
    1971                          0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
    1972         ENDIF 
    1973        
    1974       ENDDO 
    1975     
    1976       CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    1977  
    1978     ENDIF 
    1979          
    1980   END SUBROUTINE gather_field 
    1981  
    1982   SUBROUTINE bcast_field(field_glo) 
    1983   USE field_mod 
    1984   USE domain_mod 
    1985   USE mpi_mod 
    1986   USE mpipara 
    1987   IMPLICIT NONE 
    1988     TYPE(t_field),POINTER :: field_glo(:) 
    1989     INTEGER :: ind_glo     
    1990    
    1991     IF (.NOT. using_mpi) THEN 
    1992      
    1993 ! nothing to do 
    1994      
    1995     ELSE 
    1996            
    1997       DO ind_glo=1,ndomain_glo 
    1998  
    1999           IF (field_glo(ind_glo)%ndim==2) THEN 
    2000             CALL MPI_BCAST(field_glo(ind_glo)%rval2d, size(field_glo(ind_glo)%rval2d) , MPI_REAL8, 0, comm_icosa, ierr) 
    2001           ELSE IF (field_glo(ind_glo)%ndim==3) THEN 
    2002             CALL MPI_BCAST(field_glo(ind_glo)%rval3d, size(field_glo(ind_glo)%rval3d) , MPI_REAL8, 0, comm_icosa, ierr) 
    2003           ELSE IF (field_glo(ind_glo)%ndim==4) THEN 
    2004             CALL MPI_BCAST(field_glo(ind_glo)%rval4d, size(field_glo(ind_glo)%rval4d) , MPI_REAL8, 0, comm_icosa, ierr) 
    2005           ENDIF 
    2006           
    2007         ENDDO 
    2008       ENDIF 
    2009          
    2010   END SUBROUTINE bcast_field 
    2011  
    2012   SUBROUTINE scatter_field(field_glo,field_loc) 
    2013   USE field_mod 
    2014   USE domain_mod 
    2015   USE mpi_mod 
    2016   USE mpipara 
    2017   IMPLICIT NONE 
    2018     TYPE(t_field),POINTER :: field_glo(:) 
    2019     TYPE(t_field),POINTER :: field_loc(:) 
    2020     INTEGER, ALLOCATABLE :: mpi_req(:) 
    2021     INTEGER, ALLOCATABLE :: status(:,:) 
    2022     INTEGER :: ireq,nreq 
    2023     INTEGER :: ind_glo,ind_loc     
    2024    
    2025     IF (.NOT. using_mpi) THEN 
    2026      
    2027       DO ind_loc=1,ndomain 
    2028         IF (field_loc(ind_loc)%ndim==2) field_loc(ind_loc)%rval2d=field_glo(ind_loc)%rval2d 
    2029         IF (field_loc(ind_loc)%ndim==3) field_loc(ind_loc)%rval3d=field_glo(ind_loc)%rval3d 
    2030         IF (field_loc(ind_loc)%ndim==4) field_loc(ind_loc)%rval4d=field_glo(ind_loc)%rval4d 
    2031       ENDDO 
    2032      
    2033     ELSE 
    2034            
    2035       nreq=ndomain 
    2036       IF (mpi_rank==0) nreq=nreq+ndomain_glo  
    2037       ALLOCATE(mpi_req(nreq)) 
    2038       ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 
    2039      
    2040      
    2041       ireq=0 
    2042       IF (mpi_rank==0) THEN 
    2043         DO ind_glo=1,ndomain_glo 
    2044           ireq=ireq+1 
    2045  
    2046           IF (field_glo(ind_glo)%ndim==2) THEN 
    2047             CALL MPI_ISEND(field_glo(ind_glo)%rval2d,size(field_glo(ind_glo)%rval2d) , MPI_REAL8 ,   & 
    2048                          domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
    2049     
    2050           ELSE IF (field_glo(ind_glo)%ndim==3) THEN 
    2051             CALL MPI_ISEND(field_glo(ind_glo)%rval3d,size(field_glo(ind_glo)%rval3d) , MPI_REAL8 ,   & 
    2052                          domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
    2053  
    2054           ELSE IF (field_glo(ind_glo)%ndim==4) THEN 
    2055             CALL MPI_ISEND(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 ,   & 
    2056                          domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
    2057           ENDIF 
    2058           
    2059         ENDDO 
    2060       ENDIF 
    2061    
    2062       DO ind_loc=1,ndomain 
    2063         ireq=ireq+1 
    2064  
    2065         IF (field_loc(ind_loc)%ndim==2) THEN 
    2066           CALL MPI_IRECV(field_loc(ind_loc)%rval2d,size(field_loc(ind_loc)%rval2d) , MPI_REAL8 ,   & 
    2067                          0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
    2068         ELSE IF (field_loc(ind_loc)%ndim==3) THEN 
    2069           CALL MPI_IRECV(field_loc(ind_loc)%rval3d,size(field_loc(ind_loc)%rval3d) , MPI_REAL8 ,   & 
    2070                          0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
    2071         ELSE IF (field_loc(ind_loc)%ndim==4) THEN 
    2072           CALL MPI_IRECV(field_loc(ind_loc)%rval4d,size(field_loc(ind_loc)%rval4d) , MPI_REAL8 ,   & 
    2073                          0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
    2074         ENDIF 
    2075        
    2076       ENDDO 
    2077     
    2078       CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    2079  
    2080     ENDIF 
    2081          
    2082   END SUBROUTINE scatter_field 
    2083    
    2084   SUBROUTINE trace_in 
    2085   USE trace 
    2086   IMPLICIT NONE 
    2087    
    2088     CALL trace_start("transfert_buffer") 
    2089   END SUBROUTINE trace_in               
    2090  
    2091   SUBROUTINE trace_out 
    2092   USE trace 
    2093   IMPLICIT NONE 
    2094    
    2095     CALL trace_end("transfert_buffer") 
    2096   END SUBROUTINE trace_out               
    2097  
    2098  
    2099  
    2100  
    2101 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    2102 !! Definition des Broadcast --> 4D   !! 
    2103 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    2104  
    2105 !! -- Les chaine de charactï¿œre -- !! 
    2106  
    2107   SUBROUTINE bcast_mpi_c(var1) 
    2108   IMPLICIT NONE 
    2109     CHARACTER(LEN=*),INTENT(INOUT) :: Var1 
    2110     
    2111     CALL bcast_mpi_cgen(Var1,len(Var1)) 
    2112  
    2113   END SUBROUTINE bcast_mpi_c 
    2114  
    2115 !! -- Les entiers -- !! 
    2116    
    2117   SUBROUTINE bcast_mpi_i(var) 
    2118   USE mpipara 
    2119   IMPLICIT NONE 
    2120     INTEGER,INTENT(INOUT) :: Var 
    2121      
    2122     INTEGER               :: var_tmp(1) 
    2123      
    2124     IF (is_mpi_master) var_tmp(1)=var 
    2125     CALL bcast_mpi_igen(Var_tmp,1) 
    2126     var=var_tmp(1) 
    2127      
    2128   END SUBROUTINE bcast_mpi_i 
    2129  
    2130   SUBROUTINE bcast_mpi_i1(var) 
    2131   IMPLICIT NONE 
    2132     INTEGER,INTENT(INOUT) :: Var(:) 
    2133  
    2134     CALL bcast_mpi_igen(Var,size(Var)) 
    2135      
    2136   END SUBROUTINE bcast_mpi_i1 
    2137  
    2138   SUBROUTINE bcast_mpi_i2(var) 
    2139   IMPLICIT NONE 
    2140     INTEGER,INTENT(INOUT) :: Var(:,:) 
    2141     
    2142     CALL bcast_mpi_igen(Var,size(Var)) 
    2143    
    2144   END SUBROUTINE bcast_mpi_i2 
    2145  
    2146   SUBROUTINE bcast_mpi_i3(var) 
    2147   IMPLICIT NONE 
    2148     INTEGER,INTENT(INOUT) :: Var(:,:,:) 
    2149     
    2150     CALL bcast_mpi_igen(Var,size(Var)) 
    2151  
    2152   END SUBROUTINE bcast_mpi_i3 
    2153  
    2154   SUBROUTINE bcast_mpi_i4(var) 
    2155   IMPLICIT NONE 
    2156     INTEGER,INTENT(INOUT) :: Var(:,:,:,:) 
    2157     
    2158     CALL bcast_mpi_igen(Var,size(Var)) 
    2159  
    2160   END SUBROUTINE bcast_mpi_i4 
    2161  
    2162  
    2163 !! -- Les reels -- !! 
    2164  
    2165   SUBROUTINE bcast_mpi_r(var) 
    2166   USE mpipara 
    2167   IMPLICIT NONE 
    2168     REAL,INTENT(INOUT) :: Var 
    2169     REAL               :: var_tmp(1) 
    2170      
    2171     IF (is_mpi_master) var_tmp(1)=var 
    2172     CALL bcast_mpi_rgen(Var_tmp,1) 
    2173     var=var_tmp(1)    
    2174  
    2175   END SUBROUTINE bcast_mpi_r 
    2176  
    2177   SUBROUTINE bcast_mpi_r1(var) 
    2178   IMPLICIT NONE 
    2179     REAL,INTENT(INOUT) :: Var(:) 
    2180     
    2181     CALL bcast_mpi_rgen(Var,size(Var)) 
    2182  
    2183   END SUBROUTINE bcast_mpi_r1 
    2184  
    2185   SUBROUTINE bcast_mpi_r2(var) 
    2186   IMPLICIT NONE 
    2187     REAL,INTENT(INOUT) :: Var(:,:) 
    2188     
    2189     CALL bcast_mpi_rgen(Var,size(Var)) 
    2190  
    2191   END SUBROUTINE bcast_mpi_r2 
    2192  
    2193   SUBROUTINE bcast_mpi_r3(var) 
    2194   IMPLICIT NONE 
    2195     REAL,INTENT(INOUT) :: Var(:,:,:) 
    2196     
    2197     CALL bcast_mpi_rgen(Var,size(Var)) 
    2198  
    2199   END SUBROUTINE bcast_mpi_r3 
    2200  
    2201   SUBROUTINE bcast_mpi_r4(var) 
    2202   IMPLICIT NONE 
    2203     REAL,INTENT(INOUT) :: Var(:,:,:,:) 
    2204     
    2205     CALL bcast_mpi_rgen(Var,size(Var)) 
    2206  
    2207   END SUBROUTINE bcast_mpi_r4 
    2208    
    2209 !! -- Les booleans -- !! 
    2210  
    2211   SUBROUTINE bcast_mpi_l(var) 
    2212   USE mpipara 
    2213   IMPLICIT NONE 
    2214     LOGICAL,INTENT(INOUT) :: Var 
    2215     LOGICAL               :: var_tmp(1) 
    2216      
    2217     IF (is_mpi_master) var_tmp(1)=var 
    2218     CALL bcast_mpi_lgen(Var_tmp,1) 
    2219     var=var_tmp(1)    
    2220  
    2221   END SUBROUTINE bcast_mpi_l 
    2222  
    2223   SUBROUTINE bcast_mpi_l1(var) 
    2224   IMPLICIT NONE 
    2225     LOGICAL,INTENT(INOUT) :: Var(:) 
    2226     
    2227     CALL bcast_mpi_lgen(Var,size(Var)) 
    2228  
    2229   END SUBROUTINE bcast_mpi_l1 
    2230  
    2231   SUBROUTINE bcast_mpi_l2(var) 
    2232   IMPLICIT NONE 
    2233     LOGICAL,INTENT(INOUT) :: Var(:,:) 
    2234     
    2235     CALL bcast_mpi_lgen(Var,size(Var)) 
    2236  
    2237   END SUBROUTINE bcast_mpi_l2 
    2238  
    2239   SUBROUTINE bcast_mpi_l3(var) 
    2240   IMPLICIT NONE 
    2241     LOGICAL,INTENT(INOUT) :: Var(:,:,:) 
    2242     
    2243     CALL bcast_mpi_lgen(Var,size(Var)) 
    2244  
    2245   END SUBROUTINE bcast_mpi_l3 
    2246  
    2247   SUBROUTINE bcast_mpi_l4(var) 
    2248   IMPLICIT NONE 
    2249     LOGICAL,INTENT(INOUT) :: Var(:,:,:,:) 
    2250     
    2251     CALL bcast_mpi_lgen(Var,size(Var)) 
    2252  
    2253   END SUBROUTINE bcast_mpi_l4 
    2254    
    2255 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    2256 !! DEFINITION DES FONCTIONS DE TRANSFERT GENERIQUES ! 
    2257 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    2258  
    2259   SUBROUTINE bcast_mpi_cgen(var,nb) 
    2260     USE mpi_mod 
    2261     USE mpipara 
    2262     IMPLICIT NONE 
    2263      
    2264     CHARACTER(LEN=*),INTENT(INOUT) :: Var 
    2265     INTEGER,INTENT(IN) :: nb 
    2266  
    2267     IF (.NOT. using_mpi) RETURN 
    2268      
    2269     CALL MPI_BCAST(Var,nb,MPI_CHARACTER,mpi_master,comm_icosa,ierr) 
    2270          
    2271   END SUBROUTINE bcast_mpi_cgen 
    2272  
    2273  
    2274        
    2275   SUBROUTINE bcast_mpi_igen(var,nb) 
    2276     USE mpi_mod 
    2277     USE mpipara 
    2278     IMPLICIT NONE 
    2279     INTEGER,INTENT(IN) :: nb 
    2280     INTEGER,DIMENSION(nb),INTENT(INOUT) :: Var 
    2281      
    2282     IF (.NOT. using_mpi) RETURN 
    2283  
    2284     CALL MPI_BCAST(Var,nb,MPI_INTEGER,mpi_master,comm_icosa,ierr) 
    2285          
    2286   END SUBROUTINE bcast_mpi_igen 
    2287  
    2288  
    2289  
    2290    
    2291   SUBROUTINE bcast_mpi_rgen(var,nb) 
    2292     USE mpi_mod 
    2293     USE mpipara 
    2294     IMPLICIT NONE 
    2295     INTEGER,INTENT(IN) :: nb 
    2296     REAL,DIMENSION(nb),INTENT(INOUT) :: Var 
    2297  
    2298     IF (.NOT. using_mpi) RETURN 
    2299  
    2300     CALL MPI_BCAST(Var,nb,MPI_REAL8,mpi_master,comm_icosa,ierr) 
    2301      
    2302   END SUBROUTINE bcast_mpi_rgen 
    2303    
    2304  
    2305  
    2306  
    2307   SUBROUTINE bcast_mpi_lgen(var,nb) 
    2308     USE mpi_mod 
    2309     USE mpipara 
    2310     IMPLICIT NONE 
    2311     INTEGER,INTENT(IN) :: nb 
    2312     LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var 
    2313  
    2314     IF (.NOT. using_mpi) RETURN 
    2315  
    2316     CALL MPI_BCAST(Var,nb,MPI_LOGICAL,mpi_master,comm_icosa,ierr) 
    2317  
    2318   END SUBROUTINE bcast_mpi_lgen 
    2319    
    2320     
    2321 END MODULE transfert_mpi_mod 
    2322        
    2323          
    2324          
    2325          
    2326        
     472    call enter_profile(profile_mpi) 
     473 
     474    CALL distrib_level( 1, size(message%field(1)%rval4d, 2), d3_begin, d3_end ) 
     475 
     476    call enter_profile(profile_mpi_waitall) 
     477    !$omp master 
     478    call MPI_Waitall( size(message%mpi_requests_out), message%mpi_requests_out, MPI_STATUSES_IGNORE, ierr ) 
     479    call MPI_Waitall( size(message%mpi_requests_in), message%mpi_requests_in, MPI_STATUSES_IGNORE, ierr ) 
     480    !$omp end master 
     481    call exit_profile(profile_mpi_waitall) 
     482 
     483    call enter_profile(profile_mpi_barrier) 
     484    !$omp barrier 
     485    call exit_profile(profile_mpi_barrier) 
     486 
     487    call enter_profile(profile_mpi_copies) 
     488    !$acc data present(message) async if(message%ondevice) 
     489 
     490    dim4 = size(message%field(1)%rval4d, 3) 
     491    ! Buffer to Halo : copy inbound message to field 
     492    !$acc parallel loop default(none) present(message, assigned_domain) async if(message%ondevice) 
     493    do i = 1, size( message%message_in ) 
     494      if( assigned_domain( message%message_in(i)%ind_loc ) ) then 
     495        !$acc loop collapse(2) 
     496        do d4 = 1, dim4 
     497          do d3 = d3_begin, d3_end 
     498            !$acc loop 
     499            do k = 1, size(message%message_in(i)%displs) 
     500              message%field(message%message_in(i)%ind_loc)%rval4d(message%message_in(i)%displs(k),d3,d4) = message%message_in(i)%sign(k)*message%message_in(i)%buff(k,d3,d4) 
     501            end do 
     502          end do 
     503        end do 
     504      endif 
     505    end do 
     506 
     507    !$acc end data 
     508    call exit_profile(profile_mpi_copies) 
     509 
     510    !$omp master 
     511    message%wait_seq = message%wait_seq + 1 
     512    !$omp end master 
     513 
     514    call enter_profile(profile_mpi_barrier) 
     515    !$omp barrier 
     516    call exit_profile(profile_mpi_barrier) 
     517    call exit_profile(profile_mpi) 
     518  end subroutine 
     519end module 

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

    r962 r963  
    1 MODULE transfert_mpi_mod 
     1MODULE transfert_mpi_legacy_mod 
    22USE genmod 
    33USE field_mod 
    44IMPLICIT NONE 
    5    
     5 
    66  TYPE array 
    77    INTEGER,POINTER :: value(:)=>null() 
    … …  
    1717    INTEGER,POINTER :: src_value(:)=>null() 
    1818  END TYPE array 
    19    
     19 
    2020  TYPE t_buffer 
    2121    REAL,POINTER    :: r(:) 
    2222    INTEGER         :: size 
    2323    INTEGER         :: rank 
    24   END TYPE t_buffer     
    25      
     24  END TYPE t_buffer 
     25 
    2626  TYPE t_request 
    2727    INTEGER :: type_field 
    … …  
    4545    TYPE(ARRAY),POINTER :: send(:) 
    4646  END TYPE t_request 
    47    
     47 
    4848  TYPE(t_request),SAVE,POINTER :: req_i1(:) 
    4949  TYPE(t_request),SAVE,POINTER :: req_e1_scal(:) 
    5050  TYPE(t_request),SAVE,POINTER :: req_e1_vect(:) 
    5151  TYPE(t_request),SAVE,POINTER :: req_z1_scal(:) 
    52    
     52 
    5353  TYPE(t_request),SAVE,POINTER :: req_i0(:) 
    5454  TYPE(t_request),SAVE,POINTER :: req_e0_scal(:) 
    … …  
    6060    INTEGER :: tag 
    6161    INTEGER :: isend 
    62   END TYPE t_reorder   
    63    
     62  END TYPE t_reorder 
     63 
    6464  TYPE t_message 
    6565    CHARACTER(LEN=100) :: name ! for debug 
    … …  
    7171    INTEGER, POINTER :: mpi_req(:) 
    7272    INTEGER, POINTER :: status(:,:) 
    73     TYPE(t_buffer),POINTER :: buffers(:)  
     73    TYPE(t_buffer),POINTER :: buffers(:) 
    7474    TYPE(t_field),POINTER :: field(:) 
    7575    LOGICAL :: completed 
    … …  
    8080  END TYPE t_message 
    8181 
    82  
    83   INTERFACE bcast_mpi 
    84     MODULE PROCEDURE bcast_mpi_c,                                                     & 
    85                      bcast_mpi_i,bcast_mpi_i1,bcast_mpi_i2,bcast_mpi_i3,bcast_mpi_i4, & 
    86                      bcast_mpi_r,bcast_mpi_r1,bcast_mpi_r2,bcast_mpi_r3,bcast_mpi_r4, & 
    87                      bcast_mpi_l,bcast_mpi_l1,bcast_mpi_l2,bcast_mpi_l3,bcast_mpi_l4 
    88   END INTERFACE 
    89  
    9082  integer :: profile_mpi_copies, profile_mpi_waitall, profile_mpi_omp_barrier 
    9183 
    9284CONTAINS 
    93         
    94        
     85 
     86 
    9587  SUBROUTINE init_transfert 
    9688  USE profiling_mod 
    … …  
    119111      DO j=jj_begin,jj_end 
    120112        CALL request_add_point(ind,ii_end+1,j,req_i1) 
    121       ENDDO     
     113      ENDDO 
    122114      DO i=ii_begin,ii_end 
    123115        CALL request_add_point(ind,i,jj_end+1,req_i1) 
    124       ENDDO     
     116      ENDDO 
    125117 
    126118      DO j=jj_begin,jj_end+1 
    127119        CALL request_add_point(ind,ii_begin-1,j,req_i1) 
    128       ENDDO     
    129      
     120      ENDDO 
     121 
    130122    ENDDO 
    131    
     123 
    132124    CALL finalize_request(req_i1) 
    133125 
    … …  
    137129    DO ind=1,ndomain 
    138130      CALL swap_dimensions(ind) 
    139      
     131 
    140132      DO i=ii_begin,ii_end 
    141133        CALL request_add_point(ind,i,jj_begin,req_i0) 
    … …  
    144136      DO j=jj_begin,jj_end 
    145137        CALL request_add_point(ind,ii_end,j,req_i0) 
    146       ENDDO     
    147      
     138      ENDDO 
     139 
    148140      DO i=ii_begin,ii_end 
    149141        CALL request_add_point(ind,i,jj_end,req_i0) 
    150       ENDDO     
     142      ENDDO 
    151143 
    152144      DO j=jj_begin,jj_end 
    153145        CALL request_add_point(ind,ii_begin,j,req_i0) 
    154       ENDDO     
    155      
     146      ENDDO 
     147 
    156148    ENDDO 
    157   
    158     CALL finalize_request(req_i0)   
     149 
     150    CALL finalize_request(req_i0) 
    159151 
    160152 
    … …  
    169161      DO j=jj_begin,jj_end 
    170162        CALL request_add_point(ind,ii_end+1,j,req_e1_scal,left) 
    171       ENDDO     
     163      ENDDO 
    172164      DO j=jj_begin,jj_end 
    173165        CALL request_add_point(ind,ii_end+1,j-1,req_e1_scal,lup) 
    174       ENDDO     
    175      
     166      ENDDO 
     167 
    176168      DO i=ii_begin,ii_end 
    177169        CALL request_add_point(ind,i,jj_end+1,req_e1_scal,ldown) 
    178170        CALL request_add_point(ind,i-1,jj_end+1,req_e1_scal,rdown) 
    179       ENDDO     
     171      ENDDO 
    180172 
    181173      DO j=jj_begin,jj_end 
    182174        CALL request_add_point(ind,ii_begin-1,j,req_e1_scal,right) 
    183       ENDDO    
     175      ENDDO 
    184176      DO j=jj_begin,jj_end 
    185177        CALL request_add_point(ind,ii_begin-1,j+1,req_e1_scal,rdown) 
    186       ENDDO    
     178      ENDDO 
    187179 
    188180    ENDDO 
    … …  
    200192        CALL request_add_point(ind,i,jj_end,req_e0_scal,right) 
    201193      ENDDO 
    202      
     194 
    203195      DO j=jj_begin+1,jj_end-1 
    204196        CALL request_add_point(ind,ii_begin,j,req_e0_scal,rup) 
    205197        CALL request_add_point(ind,ii_end,j,req_e0_scal,rup) 
    206       ENDDO    
     198      ENDDO 
    207199 
    208200      CALL request_add_point(ind,ii_begin+1,jj_begin,req_e0_scal,left) 
    … …  
    216208 
    217209 
    218      
     210 
    219211    CALL create_request(field_u,req_e1_vect,.TRUE.) 
    220212    DO ind=1,ndomain 
    … …  
    227219      DO j=jj_begin,jj_end 
    228220        CALL request_add_point(ind,ii_end+1,j,req_e1_vect,left) 
    229       ENDDO     
     221      ENDDO 
    230222      DO j=jj_begin,jj_end 
    231223        CALL request_add_point(ind,ii_end+1,j-1,req_e1_vect,lup) 
    232       ENDDO     
    233      
     224      ENDDO 
     225 
    234226      DO i=ii_begin,ii_end 
    235227        CALL request_add_point(ind,i,jj_end+1,req_e1_vect,ldown) 
    236228        CALL request_add_point(ind,i-1,jj_end+1,req_e1_vect,rdown) 
    237       ENDDO     
     229      ENDDO 
    238230 
    239231      DO j=jj_begin,jj_end 
    240232        CALL request_add_point(ind,ii_begin-1,j,req_e1_vect,right) 
    241       ENDDO    
     233      ENDDO 
    242234      DO j=jj_begin,jj_end 
    243235        CALL request_add_point(ind,ii_begin-1,j+1,req_e1_vect,rdown) 
    244       ENDDO    
    245  
    246    
    247     ENDDO   
     236      ENDDO 
     237 
     238 
     239    ENDDO 
    248240 
    249241    CALL finalize_request(req_e1_vect) 
    250      
    251      
     242 
     243 
    252244    CALL create_request(field_u,req_e0_vect,.TRUE.) 
    253245    DO ind=1,ndomain 
    254246      CALL swap_dimensions(ind) 
    255   
     247 
    256248      DO i=ii_begin+1,ii_end-1 
    257249        CALL request_add_point(ind,i,jj_begin,req_e0_vect,right) 
    258250        CALL request_add_point(ind,i,jj_end,req_e0_vect,right) 
    259251      ENDDO 
    260      
     252 
    261253      DO j=jj_begin+1,jj_end-1 
    262254        CALL request_add_point(ind,ii_begin,j,req_e0_vect,rup) 
    263255        CALL request_add_point(ind,ii_end,j,req_e0_vect,rup) 
    264       ENDDO    
     256      ENDDO 
    265257 
    266258      CALL request_add_point(ind,ii_begin+1,jj_begin,req_e0_vect,left) 
    … …  
    268260      CALL request_add_point(ind,ii_begin+1,jj_end,req_e0_vect,left) 
    269261      CALL request_add_point(ind,ii_end,jj_begin+1,req_e0_vect,ldown) 
    270    
    271     ENDDO   
     262 
     263    ENDDO 
    272264 
    273265    CALL finalize_request(req_e0_vect) 
    … …  
    283275      DO j=jj_begin,jj_end 
    284276        CALL request_add_point(ind,ii_end+1,j,req_z1_scal,vlup) 
    285       ENDDO     
     277      ENDDO 
    286278      DO j=jj_begin,jj_end 
    287279        CALL request_add_point(ind,ii_end+1,j-1,req_z1_scal,vup) 
    288       ENDDO     
    289      
     280      ENDDO 
     281 
    290282      DO i=ii_begin,ii_end 
    291283        CALL request_add_point(ind,i,jj_end+1,req_z1_scal,vdown) 
    292284        CALL request_add_point(ind,i-1,jj_end+1,req_z1_scal,vrdown) 
    293       ENDDO     
     285      ENDDO 
    294286 
    295287      DO j=jj_begin,jj_end 
    296288        CALL request_add_point(ind,ii_begin-1,j,req_z1_scal,vrup) 
    297       ENDDO    
     289      ENDDO 
    298290      DO j=jj_begin,jj_end 
    299291        CALL request_add_point(ind,ii_begin-1,j,req_z1_scal,vrdown) 
    300       ENDDO    
     292      ENDDO 
    301293 
    302294    ENDDO 
    … …  
    305297 
    306298  END SUBROUTINE init_transfert 
    307    
     299 
    308300  SUBROUTINE create_request(type_field,request,vector) 
    309301  USE domain_mod 
    … …  
    313305    TYPE(t_request),POINTER :: request(:) 
    314306    LOGICAL,OPTIONAL :: vector 
    315      
     307 
    316308    TYPE(t_request),POINTER :: req 
    317309    TYPE(t_domain),POINTER :: d 
    318310    INTEGER :: ind 
    319311    INTEGER :: max_size 
    320         
     312 
    321313    ALLOCATE(request(ndomain)) 
    322314 
    … …  
    346338      ALLOCATE(req%target_sign(req%max_size)) 
    347339    ENDDO 
    348    
     340 
    349341  END SUBROUTINE create_request 
    350342 
    … …  
    352344  IMPLICIT NONE 
    353345    TYPE(t_request),POINTER :: req 
    354        
     346 
    355347    INTEGER,POINTER :: src_domain(:) 
    356348    INTEGER,POINTER :: src_ind(:) 
    … …  
    380372    ALLOCATE(req%target_j(req%max_size*2)) 
    381373    ALLOCATE(req%target_sign(req%max_size*2)) 
    382      
     374 
    383375    req%src_domain(1:req%max_size)=src_domain(:) 
    384376    req%src_ind(1:req%max_size)=src_ind(:) 
    … …  
    389381    req%target_j(1:req%max_size)=target_j(:) 
    390382    req%target_sign(1:req%max_size)=target_sign(:) 
    391      
     383 
    392384    req%max_size=req%max_size*2 
    393           
     385 
    394386    DEALLOCATE(src_domain) 
    395387    DEALLOCATE(src_ind) 
    … …  
    403395  END SUBROUTINE reallocate_request 
    404396 
    405        
     397 
    406398    SUBROUTINE request_add_point(ind,i,j,request,pos) 
    407399    USE domain_mod 
    … …  
    413405      TYPE(t_request),POINTER :: request(:) 
    414406      INTEGER,INTENT(IN),OPTIONAL  :: pos 
    415        
     407 
    416408      INTEGER :: src_domain 
    417409      INTEGER :: src_iim,src_i,src_j,src_n,src_pos,src_delta 
    418410      TYPE(t_request),POINTER :: req 
    419411      TYPE(t_domain),POINTER :: d 
    420        
     412 
    421413      req=>request(ind) 
    422414      d=>domain(ind) 
    423        
     415 
    424416      IF (req%max_size==req%size) CALL reallocate_request(req) 
    425417      req%size=req%size+1 
    … …  
    444436        src_delta=domain(ind)%delta(i,j) 
    445437        src_pos=domain(ind)%edge_assign_pos(pos-1,i,j)+1 
    446                  
     438 
    447439        req%target_ind(req%size)=(j-1)*d%iim+i+d%u_pos(pos) 
    448440 
    … …  
    464456        src_pos=domain(ind)%vertex_assign_pos(pos-1,i,j)+1 
    465457 
    466          
     458 
    467459        req%target_ind(req%size)=(j-1)*d%iim+i+d%z_pos(pos) 
    468460        req%target_sign(req%size)=1 
    … …  
    471463      ENDIF 
    472464  END SUBROUTINE request_add_point 
    473    
    474    
     465 
     466 
    475467  SUBROUTINE Finalize_request(request) 
    476468  USE mpipara 
    … …  
    497489    LOGICAL,PARAMETER :: debug = .FALSE. 
    498490 
    499   
     491 
    500492    IF (.NOT. using_mpi) RETURN 
    501      
     493 
    502494    DO ind_loc=1,ndomain 
    503495      req=>request(ind_loc) 
    504        
     496 
    505497      nb_data_domain_recv(:) = 0 
    506498      nb_domain_recv(:) = 0 
    507499      tag_rank(:)=0 
    508        
     500 
    509501      DO i=1,req%size 
    510502        ind_glo=req%src_domain(i) 
    511503        nb_data_domain_recv(ind_glo)=nb_data_domain_recv(ind_glo)+1 
    512504      ENDDO 
    513   
     505 
    514506      DO ind_glo=1,ndomain_glo 
    515507        IF ( nb_data_domain_recv(ind_glo) > 0 )  nb_domain_recv(domglo_rank(ind_glo))=nb_domain_recv(domglo_rank(ind_glo))+1 
    … …  
    532524        ENDIF 
    533525      ENDDO 
    534        
     526 
    535527      req%recv(:)%size=0 
    536528      irecv=0 
    … …  
    545537    ENDDO 
    546538 
    547     nb_domain_recv(:) = 0     
     539    nb_domain_recv(:) = 0 
    548540    DO ind_loc=1,ndomain 
    549541      req=>request(ind_loc) 
    550        
     542 
    551543      DO irecv=1,req%nrecv 
    552544        rank=req%recv(irecv)%rank 
    … …  
    554546      ENDDO 
    555547    ENDDO 
    556      
    557     CALL MPI_Alltoall(nb_domain_recv,1,MPI_INTEGER,nb_domain_send,1,MPI_INTEGER,comm_icosa,ierr)      
    558      
     548 
     549    CALL MPI_Alltoall(nb_domain_recv,1,MPI_INTEGER,nb_domain_send,1,MPI_INTEGER,comm_icosa,ierr) 
     550 
    559551 
    560552    ALLOCATE(list_domain_send(sum(nb_domain_send))) 
    561      
     553 
    562554    nreq=sum(nb_domain_recv(:))+sum(nb_domain_send(:)) 
    563555    ALLOCATE(mpi_req(nreq)) 
    564556    ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 
    565      
     557 
    566558 
    567559    ireq=0 
    … …  
    575567    ENDDO 
    576568 
    577     IF (debug) PRINT *,"------------"     
     569    IF (debug) PRINT *,"------------" 
    578570    j=0 
    579571    DO rank=0,mpi_size-1 
    … …  
    585577      ENDDO 
    586578    ENDDO 
    587     IF (debug) PRINT *,"------------"     
    588      
     579    IF (debug) PRINT *,"------------" 
     580 
    589581    CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    590      
     582 
    591583    list_domain(:)=0 
    592584    DO i=1,sum(nb_domain_send) 
    … …  
    594586      list_domain(ind_loc)=list_domain(ind_loc)+1 
    595587    ENDDO 
    596      
     588 
    597589    DO ind_loc=1,ndomain 
    598590      req=>request(ind_loc) 
    … …  
    601593    ENDDO 
    602594 
    603     IF (debug) PRINT *,"------------"     
    604     
    605    ireq=0  
     595    IF (debug) PRINT *,"------------" 
     596 
     597   ireq=0 
    606598   DO ind_loc=1,ndomain 
    607599     req=>request(ind_loc) 
    608       
     600 
    609601     DO irecv=1,req%nrecv 
    610602       ireq=ireq+1 
    … …  
    612604       IF (debug) PRINT *,"Isend ",mpi_rank, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain 
    613605     ENDDO 
    614     IF (debug) PRINT *,"------------"     
    615       
     606    IF (debug) PRINT *,"------------" 
     607 
    616608     DO isend=1,req%nsend 
    617609       ireq=ireq+1 
    … …  
    621613   ENDDO 
    622614 
    623    IF (debug) PRINT *,"------------"     
     615   IF (debug) PRINT *,"------------" 
    624616 
    625617   CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    626618   CALL MPI_BARRIER(comm_icosa,ierr) 
    627619 
    628    IF (debug) PRINT *,"------------"     
    629  
    630    ireq=0  
     620   IF (debug) PRINT *,"------------" 
     621 
     622   ireq=0 
    631623   DO ind_loc=1,ndomain 
    632624     req=>request(ind_loc) 
    633       
     625 
    634626     DO irecv=1,req%nrecv 
    635627       ireq=ireq+1 
    … …  
    638630     ENDDO 
    639631 
    640      IF (debug) PRINT *,"------------"     
    641       
     632     IF (debug) PRINT *,"------------" 
     633 
    642634     DO isend=1,req%nsend 
    643635       ireq=ireq+1 
    … …  
    646638     ENDDO 
    647639   ENDDO 
    648    IF (debug) PRINT *,"------------"     
    649     
     640   IF (debug) PRINT *,"------------" 
     641 
    650642   CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    651643   CALL MPI_BARRIER(comm_icosa,ierr) 
    652    IF (debug) PRINT *,"------------"     
     644   IF (debug) PRINT *,"------------" 
    653645 
    654646   ireq=0 
    655647   DO ind_loc=1,ndomain 
    656648     req=>request(ind_loc) 
    657       
     649 
    658650     DO irecv=1,req%nrecv 
    659651       ireq=ireq+1 
    … …  
    663655       IF (debug) PRINT *,"Isend ",req%recv(irecv)%tag, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain 
    664656     ENDDO 
    665    IF (debug) PRINT *,"------------"     
    666       
     657   IF (debug) PRINT *,"------------" 
     658 
    667659     DO isend=1,req%nsend 
    668660       ireq=ireq+1 
    … …  
    671663     ENDDO 
    672664   ENDDO 
    673    IF (debug) PRINT *,"------------"     
    674     
     665   IF (debug) PRINT *,"------------" 
     666 
    675667   CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    676668   CALL MPI_BARRIER(comm_icosa,ierr) 
    677669 
    678670 
    679    IF (debug) PRINT *,"------------"     
    680  
    681    ireq=0  
     671   IF (debug) PRINT *,"------------" 
     672 
     673   ireq=0 
    682674   DO ind_loc=1,ndomain 
    683675     req=>request(ind_loc) 
    684       
     676 
    685677     DO irecv=1,req%nrecv 
    686678       ireq=ireq+1 
    … …  
    688680       IF (debug) PRINT *,"Isend ",req%recv(irecv)%size, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain 
    689681     ENDDO 
    690      IF (debug) PRINT *,"------------"     
    691       
     682     IF (debug) PRINT *,"------------" 
     683 
    692684     DO isend=1,req%nsend 
    693685       ireq=ireq+1 
    … …  
    699691   CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    700692 
    701    ireq=0  
     693   ireq=0 
    702694   DO ind_loc=1,ndomain 
    703695     req=>request(ind_loc) 
    704       
     696 
    705697     DO irecv=1,req%nrecv 
    706698       ireq=ireq+1 
    … …  
    708700            req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr) 
    709701     ENDDO 
    710       
     702 
    711703     DO isend=1,req%nsend 
    712704       ireq=ireq+1 
    … …  
    721713   DO ind_loc=1,ndomain 
    722714     req=>request(ind_loc) 
    723       
     715 
    724716     DO irecv=1,req%nrecv 
    725717       req%recv(irecv)%value(:)=req%recv(irecv)%buffer(:) 
    … …  
    727719       DEALLOCATE(req%recv(irecv)%buffer) 
    728720     ENDDO 
    729    ENDDO   
    730     
     721   ENDDO 
     722 
    731723 
    732724! domain is on the same mpi process => copie memory to memory 
    733     
     725 
    734726   DO ind_loc=1,ndomain 
    735727     req=>request(ind_loc) 
    736       
     728 
    737729     DO irecv=1,req%nrecv 
    738     
     730 
    739731       IF (req%recv(irecv)%rank==mpi_rank) THEN 
    740732           req_src=>request(req%recv(irecv)%domain) 
    … …  
    749741           ENDDO 
    750742       ENDIF 
    751       
     743 
    752744     ENDDO 
    753745   ENDDO 
    754     
     746 
    755747! true number of mpi request 
    756748 
    … …  
    761753   ALLOCATE(offset(sum(request(:)%nsend))) 
    762754   offset(:)=0 
    763     
     755 
    764756   nsend=0 
    765757   DO ind_loc=1,ndomain 
    … …  
    773765           pos=pos+1 
    774766         ENDDO 
    775          
     767 
    776768         IF (pos==nsend) THEN 
    777769           nsend=nsend+1 
    … …  
    784776           ENDIF 
    785777         ENDIF 
    786           
     778 
    787779         pos=pos+1 
    788780         req%send(isend)%ireq=pos 
    … …  
    795787   DEALLOCATE(rank_list) 
    796788   DEALLOCATE(offset) 
    797       
     789 
    798790   ALLOCATE(rank_list(sum(request(:)%nrecv))) 
    799791   ALLOCATE(offset(sum(request(:)%nrecv))) 
    800792   offset(:)=0 
    801     
     793 
    802794   nrecv=0 
    803795   DO ind_loc=1,ndomain 
    … …  
    811803           pos=pos+1 
    812804         ENDDO 
    813          
     805 
    814806         IF (pos==nrecv) THEN 
    815807           nrecv=nrecv+1 
    … …  
    822814           ENDIF 
    823815         ENDIF 
    824          
     816 
    825817         pos=pos+1 
    826818         req%recv(irecv)%ireq=nsend+pos 
    … …  
    829821       ENDIF 
    830822     ENDDO 
    831    ENDDO  
    832  
    833 ! get the offsets    
    834  
    835    ireq=0  
     823   ENDDO 
     824 
     825! get the offsets 
     826 
     827   ireq=0 
    836828   DO ind_loc=1,ndomain 
    837829     req=>request(ind_loc) 
    838       
     830 
    839831     DO irecv=1,req%nrecv 
    840832       ireq=ireq+1 
    … …  
    842834            req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr) 
    843835     ENDDO 
    844       
     836 
    845837     DO isend=1,req%nsend 
    846838       ireq=ireq+1 
    … …  
    851843 
    852844   CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    853        
    854         
    855   END SUBROUTINE Finalize_request  
     845 
     846 
     847  END SUBROUTINE Finalize_request 
    856848 
    857849 
    … …  
    867859    TYPE(t_message) :: message 
    868860    CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: name 
    869 !$OMP MASTER     
     861!$OMP MASTER 
    870862    message%request=>request 
    871863    IF(PRESENT(name)) THEN 
    … …  
    874866       message%name = 'unknown' 
    875867    END IF 
    876 !$OMP END MASTER     
    877 !$OMP BARRIER     
     868!$OMP END MASTER 
     869!$OMP BARRIER 
    878870 
    879871  END SUBROUTINE init_message_seq 
    … …  
    891883 
    892884    CALL transfert_request_seq(field,message%request) 
    893      
     885 
    894886  END SUBROUTINE send_message_seq 
    895    
     887 
    896888  SUBROUTINE test_message_seq(message) 
    897889  IMPLICIT NONE 
    898890    TYPE(t_message) :: message 
    899891  END SUBROUTINE  test_message_seq 
    900    
    901     
     892 
     893 
    902894  SUBROUTINE wait_message_seq(message) 
    903895  IMPLICIT NONE 
    904896    TYPE(t_message) :: message 
    905      
    906   END SUBROUTINE wait_message_seq     
    907  
    908   SUBROUTINE transfert_message_seq(field,message) 
    909   USE field_mod 
    910   USE domain_mod 
    911   USE mpi_mod 
    912   USE mpipara 
    913   USE omp_para 
    914   USE trace 
    915   IMPLICIT NONE 
    916     TYPE(t_field),POINTER :: field(:) 
    917     TYPE(t_message) :: message 
    918  
    919    CALL send_message_seq(field,message) 
    920      
    921   END SUBROUTINE transfert_message_seq     
    922      
    923  
    924  
    925      
     897 
     898  END SUBROUTINE wait_message_seq 
     899 
    926900  SUBROUTINE init_message_mpi(field,request, message, name) 
    927901  USE field_mod 
    … …  
    931905  USE mpi_mod 
    932906  IMPLICIT NONE 
    933    
     907 
    934908    TYPE(t_field),POINTER :: field(:) 
    935909    TYPE(t_request),POINTER :: request(:) 
    … …  
    960934    IF (message_number==100) message_number=0 
    961935 
    962    
     936 
    963937    message%request=>request 
    964938    message%nreq=sum(message%request(:)%nreq_mpi) 
    … …  
    979953      DO isend=1,req%nsend 
    980954        IF (req%send(isend)%rank/=mpi_rank) THEN 
    981           ireq=req%send(isend)%ireq  
     955          ireq=req%send(isend)%ireq 
    982956          message%buffers(ireq)%size=message%buffers(ireq)%size+req%send(isend)%size 
    983957          message%buffers(ireq)%rank=req%send(isend)%rank 
    … …  
    986960      DO irecv=1,req%nrecv 
    987961        IF (req%recv(irecv)%rank/=mpi_rank) THEN 
    988           ireq=req%recv(irecv)%ireq  
     962          ireq=req%recv(irecv)%ireq 
    989963          message%buffers(ireq)%size=message%buffers(ireq)%size+req%recv(irecv)%size 
    990964          message%buffers(ireq)%rank=req%recv(irecv)%rank 
    … …  
    997971 
    998972      IF (field(1)%ndim==2) THEN 
    999       
     973 
    1000974        DO ireq=1,message%nreq 
    1001975          CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size) 
    1002976        ENDDO 
    1003        
     977 
    1004978      ELSE  IF (field(1)%ndim==3) THEN 
    1005        
     979 
    1006980        dim3=size(field(1)%rval3d,2) 
    1007981        DO ireq=1,message%nreq 
    … …  
    1009983          CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size) 
    1010984        ENDDO 
    1011        
     985 
    1012986      ELSE  IF (field(1)%ndim==4) THEN 
    1013987        dim3=size(field(1)%rval4d,2) 
    … …  
    1017991          CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size) 
    1018992        ENDDO 
    1019       ENDIF       
     993      ENDIF 
    1020994    ENDIF 
    1021        
    1022           
    1023      
     995 
     996 
     997 
    1024998! ! Reorder the request, so recv request are done in the same order than send request 
    1025999 
    1026 !    nreq_send=sum(request(:)%nsend)   
     1000!    nreq_send=sum(request(:)%nsend) 
    10271001!    message%nreq_send=nreq_send 
    10281002!    ALLOCATE(message%reorder(nreq_send)) 
    … …  
    10501024!    ENDDO 
    10511025!    PRINT *,"reorder ",reorder(:)%tag 
    1052      
    1053   
     1026 
     1027 
    10541028!$OMP END MASTER 
    1055 !$OMP BARRIER     
     1029!$OMP BARRIER 
    10561030 
    10571031  END SUBROUTINE init_message_mpi 
    1058    
    1059   SUBROUTINE Finalize_message_mpi(field,message) 
     1032 
     1033  SUBROUTINE Finalize_message_mpi(message) 
    10601034  USE field_mod 
    10611035  USE domain_mod 
    … …  
    10641038  USE mpi_mod 
    10651039  IMPLICIT NONE 
    1066     TYPE(t_field),POINTER :: field(:) 
    10671040    TYPE(t_message) :: message 
    10681041 
    … …  
    10761049      DO ireq=1,message%nreq 
    10771050        CALL free_mpi_buffer(message%buffers(ireq)%r) 
    1078       ENDDO     
     1051      ENDDO 
    10791052    ENDIF 
    10801053 
    … …  
    11101083!$OMP BARRIER 
    11111084 
    1112        
     1085 
    11131086  END SUBROUTINE Finalize_message_mpi 
    1114  
    1115  
    1116    
    1117   SUBROUTINE barrier 
    1118   USE mpi_mod 
    1119   USE mpipara 
    1120   IMPLICIT NONE 
    1121      
    1122     CALL MPI_BARRIER(comm_icosa,ierr) 
    1123      
    1124   END SUBROUTINE barrier   
    1125      
    1126   SUBROUTINE transfert_message_mpi(field,message) 
    1127   USE field_mod 
    1128   IMPLICIT NONE 
    1129     TYPE(t_field),POINTER :: field(:) 
    1130     TYPE(t_message) :: message 
    1131      
    1132     CALL send_message_mpi(field,message) 
    1133     CALL wait_message_mpi(message) 
    1134      
    1135   END SUBROUTINE transfert_message_mpi 
    11361087 
    11371088 
    … …  
    11841135    TYPE(t_field),POINTER :: field(:) 
    11851136    TYPE(t_message) :: message 
    1186     REAL(rstd),POINTER :: rval2d(:), src_rval2d(:)  
    1187     REAL(rstd),POINTER :: rval3d(:,:), src_rval3d(:,:)  
    1188     REAL(rstd),POINTER :: rval4d(:,:,:), src_rval4d(:,:,:)  
    1189     REAL(rstd),POINTER :: buffer_r(:)  
    1190     INTEGER,POINTER :: value(:)  
    1191     INTEGER,POINTER :: sgn(:)  
    1192     TYPE(ARRAY),POINTER :: recv,send  
     1137    REAL(rstd),POINTER :: rval2d(:), src_rval2d(:) 
     1138    REAL(rstd),POINTER :: rval3d(:,:), src_rval3d(:,:) 
     1139    REAL(rstd),POINTER :: rval4d(:,:,:), src_rval4d(:,:,:) 
     1140    REAL(rstd),POINTER :: buffer_r(:) 
     1141    INTEGER,POINTER :: value(:) 
     1142    INTEGER,POINTER :: sgn(:) 
     1143    TYPE(ARRAY),POINTER :: recv,send 
    11931144    TYPE(t_request),POINTER :: req 
    11941145    INTEGER :: irecv,isend 
    … …  
    12401191        DO ind=1,ndomain 
    12411192          IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 
    1242            
     1193 
    12431194          rval2d=>field(ind)%rval2d 
    1244          
     1195 
    12451196          req=>message%request(ind) 
    12461197          DO isend=1,req%nsend 
    … …  
    12481199            value=>send%value 
    12491200 
    1250              
     1201 
    12511202            IF (send%rank/=mpi_rank) THEN 
    12521203              ireq=send%ireq 
    … …  
    12641215              IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 
    12651216                CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 
    1266                 !$OMP CRITICAL             
     1217                !$OMP CRITICAL 
    12671218                CALL MPI_ISEND(buffer_r,send%size,MPI_REAL8,send%rank,               & 
    12681219                  send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
    … …  
    12731224                  send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
    12741225              ENDIF 
    1275               
     1226 
    12761227            ENDIF 
    12771228          ENDDO 
    12781229        ENDDO 
    1279          
     1230 
    12801231        DO ind=1,ndomain 
    12811232          IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 
    12821233          rval2d=>field(ind)%rval2d 
    1283           req=>message%request(ind)         
     1234          req=>message%request(ind) 
    12841235 
    12851236          DO irecv=1,req%nrecv 
    … …  
    13011252                     
    13021253            ELSE 
    1303              
     1254 
    13041255              ireq=recv%ireq 
    13051256              buffer_r=>message%buffers(ireq)%r 
    13061257              IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 
    13071258                CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 
    1308                !$OMP CRITICAL             
     1259               !$OMP CRITICAL 
    13091260                CALL MPI_IRECV(buffer_r,recv%size,MPI_REAL8,recv%rank,               & 
    13101261                  recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
    … …  
    13151266                   recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
    13161267              ENDIF 
    1317              
     1268 
    13181269            ENDIF 
    13191270          ENDDO 
    1320          
     1271 
    13211272        ENDDO 
    1322          
    1323        
     1273 
     1274 
    13241275      ELSE  IF (field(1)%ndim==3) THEN 
    13251276        max_req=0 
    … …  
    13281279          IF (req%nsend>max_req) max_req=req%nsend 
    13291280        ENDDO 
    1330                
     1281 
    13311282        DO ind=1,ndomain 
    13321283          IF (.NOT. assigned_domain(ind) ) CYCLE 
    … …  
    13371288          rval3d=>field(ind)%rval3d 
    13381289          req=>message%request(ind) 
    1339   
     1290 
    13401291          DO isend=1,req%nsend 
    13411292            send=>req%send(isend) 
    … …  
    13661317 
    13671318              ENDIF 
    1368                
     1319 
    13691320              IF (is_omp_level_master) THEN 
    13701321                IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 
    13711322                  CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 
    1372                   !$OMP CRITICAL    
     1323                  !$OMP CRITICAL 
    13731324                  CALL MPI_ISEND(buffer_r,send%size*dim3,MPI_REAL8,send%rank,        & 
    13741325                    send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
    … …  
    14001351 
    14011352        ENDDO 
    1402           
     1353 
    14031354        DO ind=1,ndomain 
    14041355          IF (.NOT. assigned_domain(ind) ) CYCLE 
    … …  
    14321383              ireq=recv%ireq 
    14331384              buffer_r=>message%buffers(ireq)%r 
    1434   
     1385 
    14351386              IF (is_omp_level_master) THEN 
    14361387                IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 
    … …  
    14461397                ENDIF 
    14471398              ENDIF 
    1448             ENDIF   
     1399            ENDIF 
    14491400          ENDDO 
    1450          
     1401 
    14511402        ENDDO 
    14521403 
    … …  
    14581409          IF (req%nsend>max_req) max_req=req%nsend 
    14591410        ENDDO 
    1460      
     1411 
    14611412        DO ind=1,ndomain 
    14621413          IF (.NOT. assigned_domain(ind) ) CYCLE 
    … …  
    15241475            ENDIF 
    15251476          ENDDO 
    1526            
     1477 
    15271478          IF (mpi_threading_mode==MPI_THREAD_SERIALIZED.OR.mpi_threading_mode==MPI_THREAD_MULTIPLE .AND. omp_level_size>1) THEN 
    15281479            DO isend=req%nsend+1,max_req 
    … …  
    15351486 
    15361487        ENDDO 
    1537          
     1488 
    15381489        DO ind=1,ndomain 
    15391490          IF (.NOT. assigned_domain(ind) ) CYCLE 
    1540            
     1491 
    15411492          dim3=size(field(ind)%rval4d,2) 
    15421493          CALL distrib_level(1,dim3, lbegin,lend) 
    … …  
    15651516              call exit_profile(profile_mpi_copies) 
    15661517              CALL trace_end("copy_data") 
    1567                     
     1518 
    15681519            ELSE 
    15691520 
    … …  
    15731524                IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 
    15741525                  CALL abort_acc("mpi_threading_mode==MPI_THREAD_SERIALIZED") 
    1575                  !$OMP CRITICAL            
     1526                 !$OMP CRITICAL 
    15761527                  CALL MPI_IRECV(buffer_r,recv%size*dim3*dim4,MPI_REAL8,recv%rank,   & 
    1577                     recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)  
     1528                    recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
    15781529                  !$OMP END CRITICAL 
    15791530                ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 
    15801531                  CALL abort_acc("mpi_threading_mode==MPI_THREAD_MULTIPLE") 
    15811532                  CALL MPI_IRECV(buffer_r,recv%size*dim3*dim4,MPI_REAL8,recv%rank,   & 
    1582                     recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)  
     1533                    recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
    15831534                ENDIF 
    15841535              ENDIF 
    … …  
    15871538        ENDDO 
    15881539 
    1589       ENDIF       
     1540      ENDIF 
    15901541 
    15911542      IF (mpi_threading_mode==MPI_THREAD_FUNNELED .OR. mpi_threading_mode==MPI_THREAD_SINGLE) THEN 
    … …  
    16291580 
    16301581!$OMP END MASTER 
    1631       ENDIF               
     1582      ENDIF 
    16321583    ENDIF 
    16331584CALL enter_profile(profile_mpi_omp_barrier) 
    … …  
    16381589 
    16391590    CALL exit_profile(id_mpi) 
    1640      
     1591 
    16411592  END SUBROUTINE send_message_mpi 
    1642    
     1593 
    16431594  SUBROUTINE test_message_mpi(message) 
    16441595  IMPLICIT NONE 
    16451596    TYPE(t_message) :: message 
    1646      
     1597 
    16471598    INTEGER :: ierr 
    16481599 
    … …  
    16521603!$OMP END MASTER 
    16531604  END SUBROUTINE  test_message_mpi 
    1654    
    1655     
     1605 
     1606 
    16561607  SUBROUTINE wait_message_mpi(message) 
    16571608  USE profiling_mod 
    … …  
    16661617 
    16671618    TYPE(t_field),POINTER :: field(:) 
    1668     REAL(rstd),POINTER :: rval2d(:)  
    1669     REAL(rstd),POINTER :: rval3d(:,:)  
    1670     REAL(rstd),POINTER :: rval4d(:,:,:)  
    1671     REAL(rstd),POINTER :: buffer_r(:)  
    1672     INTEGER,POINTER :: value(:)  
    1673     INTEGER,POINTER :: sgn(:)  
    1674     TYPE(ARRAY),POINTER :: recv  
     1619    REAL(rstd),POINTER :: rval2d(:) 
     1620    REAL(rstd),POINTER :: rval3d(:,:) 
     1621    REAL(rstd),POINTER :: rval4d(:,:,:) 
     1622    REAL(rstd),POINTER :: buffer_r(:) 
     1623    INTEGER,POINTER :: value(:) 
     1624    INTEGER,POINTER :: sgn(:) 
     1625    TYPE(ARRAY),POINTER :: recv 
    16751626    TYPE(t_request),POINTER :: req 
    16761627    INTEGER :: irecv 
    … …  
    16891640    field=>message%field 
    16901641    nreq=message%nreq 
    1691      
     1642 
    16921643    IF (field(1)%data_type==type_real) THEN 
    16931644      IF (field(1)%ndim==2) THEN 
    … …  
    17031654        DO ind=1,ndomain 
    17041655          IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE 
    1705            
     1656 
    17061657          rval2d=>field(ind)%rval2d 
    17071658          req=>message%request(ind) 
    … …  
    17171668              !$acc parallel loop default(present) async if (field(ind)%ondevice) 
    17181669              DO n=1,msize 
    1719                 rval2d(value(n))=buffer_r(n+offset)*sgn(n)   
     1670                rval2d(value(n))=buffer_r(n+offset)*sgn(n) 
    17201671              ENDDO 
    17211672 
    17221673            ENDIF 
    17231674          ENDDO 
    1724          
     1675 
    17251676        ENDDO 
    17261677        call exit_profile(profile_mpi_copies) 
    … …  
    17361687        call exit_profile(profile_mpi_waitall) 
    17371688 
    1738          
     1689 
    17391690        DO ind=1,ndomain 
    17401691          IF (.NOT. assigned_domain(ind) ) CYCLE 
    … …  
    17491700              value=>recv%value 
    17501701              sgn=>recv%sign 
    1751                
     1702 
    17521703              dim3=size(rval3d,2) 
    1753      
     1704 
    17541705              CALL distrib_level(1,dim3, lbegin,lend) 
    17551706              msize=recv%size 
    … …  
    17571708              call enter_profile(profile_mpi_copies) 
    17581709              CALL trace_start("copy_from_buffer") 
    1759                
     1710 
    17601711              IF (req%vector) THEN 
    17611712                !$acc parallel loop default(present) async if (field(ind)%ondevice) 
    … …  
    17641715                  !$acc loop 
    17651716                  DO n=1,msize 
    1766                     rval3d(value(n),d3)=buffer_r(n+offset)*sgn(n)   
     1717                    rval3d(value(n),d3)=buffer_r(n+offset)*sgn(n) 
    17671718                  ENDDO 
    17681719                ENDDO 
    … …  
    17731724                  !$acc loop 
    17741725                  DO n=1,msize 
    1775                     rval3d(value(n),d3)=buffer_r(n+offset)   
     1726                    rval3d(value(n),d3)=buffer_r(n+offset) 
    17761727                  ENDDO 
    17771728                ENDDO 
    17781729              ENDIF 
    1779                  
     1730 
    17801731              CALL trace_end("copy_from_buffer") 
    17811732              call exit_profile(profile_mpi_copies) 
    17821733            ENDIF 
    17831734          ENDDO 
    1784          
     1735 
    17851736        ENDDO 
    17861737 
    … …  
    17941745        call exit_profile(profile_mpi_waitall) 
    17951746 
    1796                  
     1747 
    17971748        DO ind=1,ndomain 
    17981749          IF (.NOT. assigned_domain(ind) ) CYCLE 
    … …  
    18221773                  !$acc loop 
    18231774                  DO n=1,msize 
    1824                     rval4d(value(n),d3,d4)=buffer_r(n+offset)*sgn(n)  
     1775                    rval4d(value(n),d3,d4)=buffer_r(n+offset)*sgn(n) 
    18251776                  ENDDO 
    18261777                ENDDO 
    … …  
    18301781            ENDIF 
    18311782          ENDDO 
    1832          
     1783 
    18331784        ENDDO 
    1834        
    1835       ENDIF       
    1836        
     1785 
     1786      ENDIF 
     1787 
    18371788    ENDIF 
    18381789 
    … …  
    18431794!    CALL trace_end("wait_message_mpi") 
    18441795!$OMP BARRIER 
    1845    
     1796 
    18461797    CALL exit_profile(id_mpi) 
    18471798 
    18481799  END SUBROUTINE wait_message_mpi 
    18491800 
    1850   SUBROUTINE transfert_request_mpi(field,request) 
    1851   USE field_mod 
    1852   IMPLICIT NONE 
    1853     TYPE(t_field),POINTER :: field(:) 
    1854     TYPE(t_request),POINTER :: request(:) 
    1855  
    1856     TYPE(t_message),SAVE :: message 
    1857     
    1858     
    1859     CALL init_message_mpi(field,request, message) 
    1860     CALL transfert_message_mpi(field,message) 
    1861     CALL finalize_message_mpi(field,message) 
    1862     
    1863   END SUBROUTINE transfert_request_mpi 
    1864   
    1865     
    1866     
     1801 
    18671802  SUBROUTINE transfert_request_seq(field,request) 
    18681803  USE field_mod 
    … …  
    18711806    TYPE(t_field),POINTER :: field(:) 
    18721807    TYPE(t_request),POINTER :: request(:) 
    1873     REAL(rstd),POINTER :: rval2d(:)  
    1874     REAL(rstd),POINTER :: rval3d(:,:)  
    1875     REAL(rstd),POINTER :: rval4d(:,:,:)  
     1808    REAL(rstd),POINTER :: rval2d(:) 
     1809    REAL(rstd),POINTER :: rval3d(:,:) 
     1810    REAL(rstd),POINTER :: rval4d(:,:,:) 
    18761811    INTEGER :: ind 
    18771812    TYPE(t_request),POINTER :: req 
    18781813    INTEGER :: n 
    1879      
     1814 
    18801815    DO ind=1,ndomain 
    18811816      req=>request(ind) 
    … …  
    18831818      rval3d=>field(ind)%rval3d 
    18841819      rval4d=>field(ind)%rval4d 
    1885        
     1820 
    18861821      IF (field(ind)%data_type==type_real) THEN 
    18871822        IF (field(ind)%ndim==2) THEN 
    … …  
    19011836          ENDDO 
    19021837        ENDIF 
    1903       ENDIF         
     1838      ENDIF 
    19041839 
    19051840    ENDDO 
    1906      
     1841 
    19071842  END SUBROUTINE transfert_request_seq 
    1908    
    1909    
    1910   SUBROUTINE gather_field(field_loc,field_glo) 
    1911   USE field_mod 
    1912   USE domain_mod 
    1913   USE mpi_mod 
    1914   USE mpipara 
    1915   IMPLICIT NONE 
    1916     TYPE(t_field),POINTER :: field_loc(:) 
    1917     TYPE(t_field),POINTER :: field_glo(:) 
    1918     INTEGER, ALLOCATABLE :: mpi_req(:) 
    1919     INTEGER, ALLOCATABLE :: status(:,:) 
    1920     INTEGER :: ireq,nreq 
    1921     INTEGER :: ind_glo,ind_loc     
    1922    
    1923     IF (.NOT. using_mpi) THEN 
    1924      
    1925       DO ind_loc=1,ndomain 
    1926         IF (field_loc(ind_loc)%ndim==2) field_glo(ind_loc)%rval2d=field_loc(ind_loc)%rval2d 
    1927         IF (field_loc(ind_loc)%ndim==3) field_glo(ind_loc)%rval3d=field_loc(ind_loc)%rval3d 
    1928         IF (field_loc(ind_loc)%ndim==4) field_glo(ind_loc)%rval4d=field_loc(ind_loc)%rval4d 
    1929       ENDDO 
    1930      
    1931     ELSE 
    1932            
    1933       nreq=ndomain 
    1934       IF (mpi_rank==0) nreq=nreq+ndomain_glo  
    1935       ALLOCATE(mpi_req(nreq)) 
    1936       ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 
    1937      
    1938      
    1939       ireq=0 
    1940       IF (mpi_rank==0) THEN 
    1941         DO ind_glo=1,ndomain_glo 
    1942           ireq=ireq+1 
    1943  
    1944           IF (field_glo(ind_glo)%ndim==2) THEN 
    1945             CALL MPI_IRECV(field_glo(ind_glo)%rval2d,size(field_glo(ind_glo)%rval2d) , MPI_REAL8 ,   & 
    1946                          domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
    1947     
    1948           ELSE IF (field_glo(ind_glo)%ndim==3) THEN 
    1949             CALL MPI_IRECV(field_glo(ind_glo)%rval3d,size(field_glo(ind_glo)%rval3d) , MPI_REAL8 ,   & 
    1950                          domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
    1951  
    1952           ELSE IF (field_glo(ind_glo)%ndim==4) THEN 
    1953             CALL MPI_IRECV(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 ,   & 
    1954                          domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
    1955           ENDIF 
    1956           
    1957         ENDDO 
    1958       ENDIF 
    1959    
    1960       DO ind_loc=1,ndomain 
    1961         ireq=ireq+1 
    1962  
    1963         IF (field_loc(ind_loc)%ndim==2) THEN 
    1964           CALL MPI_ISEND(field_loc(ind_loc)%rval2d,size(field_loc(ind_loc)%rval2d) , MPI_REAL8 ,   & 
    1965                          0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
    1966         ELSE IF (field_loc(ind_loc)%ndim==3) THEN 
    1967           CALL MPI_ISEND(field_loc(ind_loc)%rval3d,size(field_loc(ind_loc)%rval3d) , MPI_REAL8 ,   & 
    1968                          0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
    1969         ELSE IF (field_loc(ind_loc)%ndim==4) THEN 
    1970           CALL MPI_ISEND(field_loc(ind_loc)%rval4d,size(field_loc(ind_loc)%rval4d) , MPI_REAL8 ,   & 
    1971                          0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
    1972         ENDIF 
    1973        
    1974       ENDDO 
    1975     
    1976       CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    1977  
    1978     ENDIF 
    1979          
    1980   END SUBROUTINE gather_field 
    1981  
    1982   SUBROUTINE bcast_field(field_glo) 
    1983   USE field_mod 
    1984   USE domain_mod 
    1985   USE mpi_mod 
    1986   USE mpipara 
    1987   IMPLICIT NONE 
    1988     TYPE(t_field),POINTER :: field_glo(:) 
    1989     INTEGER :: ind_glo     
    1990    
    1991     IF (.NOT. using_mpi) THEN 
    1992      
    1993 ! nothing to do 
    1994      
    1995     ELSE 
    1996            
    1997       DO ind_glo=1,ndomain_glo 
    1998  
    1999           IF (field_glo(ind_glo)%ndim==2) THEN 
    2000             CALL MPI_BCAST(field_glo(ind_glo)%rval2d, size(field_glo(ind_glo)%rval2d) , MPI_REAL8, 0, comm_icosa, ierr) 
    2001           ELSE IF (field_glo(ind_glo)%ndim==3) THEN 
    2002             CALL MPI_BCAST(field_glo(ind_glo)%rval3d, size(field_glo(ind_glo)%rval3d) , MPI_REAL8, 0, comm_icosa, ierr) 
    2003           ELSE IF (field_glo(ind_glo)%ndim==4) THEN 
    2004             CALL MPI_BCAST(field_glo(ind_glo)%rval4d, size(field_glo(ind_glo)%rval4d) , MPI_REAL8, 0, comm_icosa, ierr) 
    2005           ENDIF 
    2006           
    2007         ENDDO 
    2008       ENDIF 
    2009          
    2010   END SUBROUTINE bcast_field 
    2011  
    2012   SUBROUTINE scatter_field(field_glo,field_loc) 
    2013   USE field_mod 
    2014   USE domain_mod 
    2015   USE mpi_mod 
    2016   USE mpipara 
    2017   IMPLICIT NONE 
    2018     TYPE(t_field),POINTER :: field_glo(:) 
    2019     TYPE(t_field),POINTER :: field_loc(:) 
    2020     INTEGER, ALLOCATABLE :: mpi_req(:) 
    2021     INTEGER, ALLOCATABLE :: status(:,:) 
    2022     INTEGER :: ireq,nreq 
    2023     INTEGER :: ind_glo,ind_loc     
    2024    
    2025     IF (.NOT. using_mpi) THEN 
    2026      
    2027       DO ind_loc=1,ndomain 
    2028         IF (field_loc(ind_loc)%ndim==2) field_loc(ind_loc)%rval2d=field_glo(ind_loc)%rval2d 
    2029         IF (field_loc(ind_loc)%ndim==3) field_loc(ind_loc)%rval3d=field_glo(ind_loc)%rval3d 
    2030         IF (field_loc(ind_loc)%ndim==4) field_loc(ind_loc)%rval4d=field_glo(ind_loc)%rval4d 
    2031       ENDDO 
    2032      
    2033     ELSE 
    2034            
    2035       nreq=ndomain 
    2036       IF (mpi_rank==0) nreq=nreq+ndomain_glo  
    2037       ALLOCATE(mpi_req(nreq)) 
    2038       ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 
    2039      
    2040      
    2041       ireq=0 
    2042       IF (mpi_rank==0) THEN 
    2043         DO ind_glo=1,ndomain_glo 
    2044           ireq=ireq+1 
    2045  
    2046           IF (field_glo(ind_glo)%ndim==2) THEN 
    2047             CALL MPI_ISEND(field_glo(ind_glo)%rval2d,size(field_glo(ind_glo)%rval2d) , MPI_REAL8 ,   & 
    2048                          domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
    2049     
    2050           ELSE IF (field_glo(ind_glo)%ndim==3) THEN 
    2051             CALL MPI_ISEND(field_glo(ind_glo)%rval3d,size(field_glo(ind_glo)%rval3d) , MPI_REAL8 ,   & 
    2052                          domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
    2053  
    2054           ELSE IF (field_glo(ind_glo)%ndim==4) THEN 
    2055             CALL MPI_ISEND(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 ,   & 
    2056                          domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr) 
    2057           ENDIF 
    2058           
    2059         ENDDO 
    2060       ENDIF 
    2061    
    2062       DO ind_loc=1,ndomain 
    2063         ireq=ireq+1 
    2064  
    2065         IF (field_loc(ind_loc)%ndim==2) THEN 
    2066           CALL MPI_IRECV(field_loc(ind_loc)%rval2d,size(field_loc(ind_loc)%rval2d) , MPI_REAL8 ,   & 
    2067                          0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
    2068         ELSE IF (field_loc(ind_loc)%ndim==3) THEN 
    2069           CALL MPI_IRECV(field_loc(ind_loc)%rval3d,size(field_loc(ind_loc)%rval3d) , MPI_REAL8 ,   & 
    2070                          0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
    2071         ELSE IF (field_loc(ind_loc)%ndim==4) THEN 
    2072           CALL MPI_IRECV(field_loc(ind_loc)%rval4d,size(field_loc(ind_loc)%rval4d) , MPI_REAL8 ,   & 
    2073                          0, ind_loc, comm_icosa, mpi_req(ireq), ierr) 
    2074         ENDIF 
    2075        
    2076       ENDDO 
    2077     
    2078       CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    2079  
    2080     ENDIF 
    2081          
    2082   END SUBROUTINE scatter_field 
    2083    
    2084   SUBROUTINE trace_in 
    2085   USE trace 
    2086   IMPLICIT NONE 
    2087    
    2088     CALL trace_start("transfert_buffer") 
    2089   END SUBROUTINE trace_in               
    2090  
    2091   SUBROUTINE trace_out 
    2092   USE trace 
    2093   IMPLICIT NONE 
    2094    
    2095     CALL trace_end("transfert_buffer") 
    2096   END SUBROUTINE trace_out               
    2097  
    2098  
    2099  
    2100  
    2101 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    2102 !! Definition des Broadcast --> 4D   !! 
    2103 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    2104  
    2105 !! -- Les chaine de charactï¿œre -- !! 
    2106  
    2107   SUBROUTINE bcast_mpi_c(var1) 
    2108   IMPLICIT NONE 
    2109     CHARACTER(LEN=*),INTENT(INOUT) :: Var1 
    2110     
    2111     CALL bcast_mpi_cgen(Var1,len(Var1)) 
    2112  
    2113   END SUBROUTINE bcast_mpi_c 
    2114  
    2115 !! -- Les entiers -- !! 
    2116    
    2117   SUBROUTINE bcast_mpi_i(var) 
    2118   USE mpipara 
    2119   IMPLICIT NONE 
    2120     INTEGER,INTENT(INOUT) :: Var 
    2121      
    2122     INTEGER               :: var_tmp(1) 
    2123      
    2124     IF (is_mpi_master) var_tmp(1)=var 
    2125     CALL bcast_mpi_igen(Var_tmp,1) 
    2126     var=var_tmp(1) 
    2127      
    2128   END SUBROUTINE bcast_mpi_i 
    2129  
    2130   SUBROUTINE bcast_mpi_i1(var) 
    2131   IMPLICIT NONE 
    2132     INTEGER,INTENT(INOUT) :: Var(:) 
    2133  
    2134     CALL bcast_mpi_igen(Var,size(Var)) 
    2135      
    2136   END SUBROUTINE bcast_mpi_i1 
    2137  
    2138   SUBROUTINE bcast_mpi_i2(var) 
    2139   IMPLICIT NONE 
    2140     INTEGER,INTENT(INOUT) :: Var(:,:) 
    2141     
    2142     CALL bcast_mpi_igen(Var,size(Var)) 
    2143    
    2144   END SUBROUTINE bcast_mpi_i2 
    2145  
    2146   SUBROUTINE bcast_mpi_i3(var) 
    2147   IMPLICIT NONE 
    2148     INTEGER,INTENT(INOUT) :: Var(:,:,:) 
    2149     
    2150     CALL bcast_mpi_igen(Var,size(Var)) 
    2151  
    2152   END SUBROUTINE bcast_mpi_i3 
    2153  
    2154   SUBROUTINE bcast_mpi_i4(var) 
    2155   IMPLICIT NONE 
    2156     INTEGER,INTENT(INOUT) :: Var(:,:,:,:) 
    2157     
    2158     CALL bcast_mpi_igen(Var,size(Var)) 
    2159  
    2160   END SUBROUTINE bcast_mpi_i4 
    2161  
    2162  
    2163 !! -- Les reels -- !! 
    2164  
    2165   SUBROUTINE bcast_mpi_r(var) 
    2166   USE mpipara 
    2167   IMPLICIT NONE 
    2168     REAL,INTENT(INOUT) :: Var 
    2169     REAL               :: var_tmp(1) 
    2170      
    2171     IF (is_mpi_master) var_tmp(1)=var 
    2172     CALL bcast_mpi_rgen(Var_tmp,1) 
    2173     var=var_tmp(1)    
    2174  
    2175   END SUBROUTINE bcast_mpi_r 
    2176  
    2177   SUBROUTINE bcast_mpi_r1(var) 
    2178   IMPLICIT NONE 
    2179     REAL,INTENT(INOUT) :: Var(:) 
    2180     
    2181     CALL bcast_mpi_rgen(Var,size(Var)) 
    2182  
    2183   END SUBROUTINE bcast_mpi_r1 
    2184  
    2185   SUBROUTINE bcast_mpi_r2(var) 
    2186   IMPLICIT NONE 
    2187     REAL,INTENT(INOUT) :: Var(:,:) 
    2188     
    2189     CALL bcast_mpi_rgen(Var,size(Var)) 
    2190  
    2191   END SUBROUTINE bcast_mpi_r2 
    2192  
    2193   SUBROUTINE bcast_mpi_r3(var) 
    2194   IMPLICIT NONE 
    2195     REAL,INTENT(INOUT) :: Var(:,:,:) 
    2196     
    2197     CALL bcast_mpi_rgen(Var,size(Var)) 
    2198  
    2199   END SUBROUTINE bcast_mpi_r3 
    2200  
    2201   SUBROUTINE bcast_mpi_r4(var) 
    2202   IMPLICIT NONE 
    2203     REAL,INTENT(INOUT) :: Var(:,:,:,:) 
    2204     
    2205     CALL bcast_mpi_rgen(Var,size(Var)) 
    2206  
    2207   END SUBROUTINE bcast_mpi_r4 
    2208    
    2209 !! -- Les booleans -- !! 
    2210  
    2211   SUBROUTINE bcast_mpi_l(var) 
    2212   USE mpipara 
    2213   IMPLICIT NONE 
    2214     LOGICAL,INTENT(INOUT) :: Var 
    2215     LOGICAL               :: var_tmp(1) 
    2216      
    2217     IF (is_mpi_master) var_tmp(1)=var 
    2218     CALL bcast_mpi_lgen(Var_tmp,1) 
    2219     var=var_tmp(1)    
    2220  
    2221   END SUBROUTINE bcast_mpi_l 
    2222  
    2223   SUBROUTINE bcast_mpi_l1(var) 
    2224   IMPLICIT NONE 
    2225     LOGICAL,INTENT(INOUT) :: Var(:) 
    2226     
    2227     CALL bcast_mpi_lgen(Var,size(Var)) 
    2228  
    2229   END SUBROUTINE bcast_mpi_l1 
    2230  
    2231   SUBROUTINE bcast_mpi_l2(var) 
    2232   IMPLICIT NONE 
    2233     LOGICAL,INTENT(INOUT) :: Var(:,:) 
    2234     
    2235     CALL bcast_mpi_lgen(Var,size(Var)) 
    2236  
    2237   END SUBROUTINE bcast_mpi_l2 
    2238  
    2239   SUBROUTINE bcast_mpi_l3(var) 
    2240   IMPLICIT NONE 
    2241     LOGICAL,INTENT(INOUT) :: Var(:,:,:) 
    2242     
    2243     CALL bcast_mpi_lgen(Var,size(Var)) 
    2244  
    2245   END SUBROUTINE bcast_mpi_l3 
    2246  
    2247   SUBROUTINE bcast_mpi_l4(var) 
    2248   IMPLICIT NONE 
    2249     LOGICAL,INTENT(INOUT) :: Var(:,:,:,:) 
    2250     
    2251     CALL bcast_mpi_lgen(Var,size(Var)) 
    2252  
    2253   END SUBROUTINE bcast_mpi_l4 
    2254    
    2255 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    2256 !! DEFINITION DES FONCTIONS DE TRANSFERT GENERIQUES ! 
    2257 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    2258  
    2259   SUBROUTINE bcast_mpi_cgen(var,nb) 
    2260     USE mpi_mod 
    2261     USE mpipara 
    2262     IMPLICIT NONE 
    2263      
    2264     CHARACTER(LEN=*),INTENT(INOUT) :: Var 
    2265     INTEGER,INTENT(IN) :: nb 
    2266  
    2267     IF (.NOT. using_mpi) RETURN 
    2268      
    2269     CALL MPI_BCAST(Var,nb,MPI_CHARACTER,mpi_master,comm_icosa,ierr) 
    2270          
    2271   END SUBROUTINE bcast_mpi_cgen 
    2272  
    2273  
    2274        
    2275   SUBROUTINE bcast_mpi_igen(var,nb) 
    2276     USE mpi_mod 
    2277     USE mpipara 
    2278     IMPLICIT NONE 
    2279     INTEGER,INTENT(IN) :: nb 
    2280     INTEGER,DIMENSION(nb),INTENT(INOUT) :: Var 
    2281      
    2282     IF (.NOT. using_mpi) RETURN 
    2283  
    2284     CALL MPI_BCAST(Var,nb,MPI_INTEGER,mpi_master,comm_icosa,ierr) 
    2285          
    2286   END SUBROUTINE bcast_mpi_igen 
    2287  
    2288  
    2289  
    2290    
    2291   SUBROUTINE bcast_mpi_rgen(var,nb) 
    2292     USE mpi_mod 
    2293     USE mpipara 
    2294     IMPLICIT NONE 
    2295     INTEGER,INTENT(IN) :: nb 
    2296     REAL,DIMENSION(nb),INTENT(INOUT) :: Var 
    2297  
    2298     IF (.NOT. using_mpi) RETURN 
    2299  
    2300     CALL MPI_BCAST(Var,nb,MPI_REAL8,mpi_master,comm_icosa,ierr) 
    2301      
    2302   END SUBROUTINE bcast_mpi_rgen 
    2303    
    2304  
    2305  
    2306  
    2307   SUBROUTINE bcast_mpi_lgen(var,nb) 
    2308     USE mpi_mod 
    2309     USE mpipara 
    2310     IMPLICIT NONE 
    2311     INTEGER,INTENT(IN) :: nb 
    2312     LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var 
    2313  
    2314     IF (.NOT. using_mpi) RETURN 
    2315  
    2316     CALL MPI_BCAST(Var,nb,MPI_LOGICAL,mpi_master,comm_icosa,ierr) 
    2317  
    2318   END SUBROUTINE bcast_mpi_lgen 
    2319    
    2320     
    2321 END MODULE transfert_mpi_mod 
    2322        
    2323          
    2324          
    2325          
    2326        
     1843 
     1844 
     1845END MODULE transfert_mpi_legacy_mod 
     1846 
     1847 
     1848 
     1849 
     1850 

  • codes/icosagcm/trunk/src/sphere/geometry.f90

    r953 r963  
    360360    USE dimensions 
    361361    USE domain_mod  
    362     USE transfert_mpi_mod 
     362    USE transfert_mod 
    363363 
    364364    INTEGER :: ind,i,j,k,n 
    … …  
    384384    CALL allocate_field_glo(xyz_glo, field_t, type_real, 3) 
    385385    CALL allocate_field_glo(vertex_glo, field_z, type_real, 3) 
     386 
    386387 
    387388    CALL gather_field(xyz_loc, xyz_glo) 

  • codes/icosagcm/trunk/src/transport/advect_tracer.F90

    r954 r963  
    148148 
    149149    CALL send_message(f_cc,req_cc) 
     150    CALL wait_message(req_cc) 
    150151 
    151152    ! horizontal transport - split in two to place transfer of gradq3d 
    … …  
    164165 
    165166        CALL send_message(f_gradq3d,req_gradq3d) 
    166         CALL wait_message(req_cc) 
    167167        CALL wait_message(req_gradq3d) 
    168168 
Note: See TracChangeset for help on using the changeset viewer.