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

Merge 'mpi_rewrite' into trunk

File:
1 copied

Legend:

Unmodified
Added
Removed

  • 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 
Note: See TracChangeset for help on using the changeset viewer.