Ignore:
Timestamp:
01/09/14 09:56:11 (10 years ago)
Author:
ymipsl
Message:

Add new openMP parallelism based on distribution of domains on threads. There is no more limitation of number of threads by MPI process.

YM

File:
1 edited

Legend:

Unmodified
Added
Removed

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

    r176 r186  
    88    INTEGER         :: domain 
    99    INTEGER         :: rank 
     10    INTEGER         :: tag 
    1011    INTEGER         :: size 
     12    INTEGER         :: offset 
     13    INTEGER         :: ireq 
    1114    INTEGER,POINTER :: buffer(:) 
    12     REAL,POINTER    :: buffer_r2(:) 
    13     REAL,POINTER    :: buffer_r3(:,:) 
    14     REAL,POINTER    :: buffer_r4(:,:,:) 
     15    REAL,POINTER    :: buffer_r(:) 
    1516    INTEGER,POINTER :: src_value(:) 
    1617  END TYPE array 
    1718   
    1819  TYPE t_buffer 
    19     REAL,POINTER    :: r2(:) 
    20     REAL,POINTER    :: r3(:,:) 
    21     REAL,POINTER    :: r4(:,:,:) 
     20    REAL,POINTER    :: r(:) 
     21    INTEGER         :: size 
     22    INTEGER         :: rank 
    2223  END TYPE t_buffer     
    2324     
    … …  
    3940    INTEGER :: nsend 
    4041    INTEGER :: nreq_mpi 
     42    INTEGER :: nreq_send 
     43    INTEGER :: nreq_recv 
    4144    TYPE(ARRAY),POINTER :: send(:) 
    4245  END TYPE t_request 
    4346   
    44   TYPE(t_request),POINTER :: req_i1(:) 
    45   TYPE(t_request),POINTER :: req_e1_scal(:) 
    46   TYPE(t_request),POINTER :: req_e1_vect(:) 
    47    
    48   TYPE(t_request),POINTER :: req_i0(:) 
    49   TYPE(t_request),POINTER :: req_e0_scal(:) 
    50   TYPE(t_request),POINTER :: req_e0_vect(:) 
     47  TYPE(t_request),SAVE,POINTER :: req_i1(:) 
     48  TYPE(t_request),SAVE,POINTER :: req_e1_scal(:) 
     49  TYPE(t_request),SAVE,POINTER :: req_e1_vect(:) 
     50   
     51  TYPE(t_request),SAVE,POINTER :: req_i0(:) 
     52  TYPE(t_request),SAVE,POINTER :: req_e0_scal(:) 
     53  TYPE(t_request),SAVE,POINTER :: req_e0_vect(:) 
     54 
     55  TYPE t_reorder 
     56    INTEGER :: ind 
     57    INTEGER :: rank 
     58    INTEGER :: tag 
     59    INTEGER :: isend 
     60  END TYPE t_reorder   
    5161   
    5262  TYPE t_message 
    5363    TYPE(t_request), POINTER :: request(:) 
    5464    INTEGER :: nreq 
     65    INTEGER :: nreq_send 
     66    INTEGER :: nreq_recv 
     67    TYPE(t_reorder), POINTER :: reorder(:) 
    5568    INTEGER, POINTER :: mpi_req(:) 
    5669    INTEGER, POINTER :: status(:,:) 
    … …  
    6275  END TYPE t_message 
    6376   
    64   INTEGER,SAVE :: message_number=0 ; 
    65    
    6677CONTAINS 
    67    
     78        
     79       
    6880  SUBROUTINE init_transfert 
    6981  USE domain_mod 
    … …  
    7284  USE metric 
    7385  USE mpipara 
     86  USE mpi_mod 
    7487  IMPLICIT NONE 
    7588  INTEGER :: ind,i,j 
     89  LOGICAL ::ok 
    7690  
    7791    CALL create_request(field_t,req_i1) 
    … …  
    410424    INTEGER :: nb_domain_recv(0:mpi_size-1) 
    411425    INTEGER :: nb_domain_send(0:mpi_size-1) 
     426    INTEGER :: tag_rank(0:mpi_size-1) 
    412427    INTEGER :: nb_data_domain_recv(ndomain_glo) 
    413428    INTEGER :: list_domain_recv(ndomain_glo) 
    … …  
    415430    INTEGER             :: list_domain(ndomain) 
    416431 
    417     INTEGER :: rank,i,j 
     432    INTEGER :: rank,i,j,pos 
    418433    INTEGER :: size_,ind_glo,ind_loc, ind_src 
    419     INTEGER :: isend, irecv, ireq, nreq 
     434    INTEGER :: isend, irecv, ireq, nreq, nsend, nrecv 
    420435    INTEGER, ALLOCATABLE :: mpi_req(:) 
    421436    INTEGER, ALLOCATABLE :: status(:,:) 
    422      
     437    INTEGER, ALLOCATABLE :: rank_list(:) 
     438    INTEGER, ALLOCATABLE :: offset(:) 
     439    LOGICAL,PARAMETER :: debug = .FALSE. 
     440 
     441  
    423442    IF (.NOT. using_mpi) RETURN 
    424443     
    … …  
    428447      nb_data_domain_recv(:) = 0 
    429448      nb_domain_recv(:) = 0 
     449      tag_rank(:)=0 
    430450       
    431451      DO i=1,req%size 
    … …  
    486506    ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 
    487507     
     508 
    488509    ireq=0 
    489510    DO ind_loc=1,ndomain 
    … …  
    492513        ireq=ireq+1 
    493514        CALL MPI_ISEND(req%recv(irecv)%domain,1,MPI_INTEGER,req%recv(irecv)%rank,0,comm_icosa, mpi_req(ireq),ierr) 
     515        IF (debug) PRINT *,"Isend ",req%recv(irecv)%domain, "from ", mpi_rank, "to ",req%recv(irecv)%rank, "tag ",0 
    494516      ENDDO 
    495517    ENDDO 
    496      
     518 
     519    IF (debug) PRINT *,"------------"     
    497520    j=0 
    498521    DO rank=0,mpi_size-1 
    … …  
    501524        ireq=ireq+1 
    502525        CALL MPI_IRECV(list_domain_send(j),1,MPI_INTEGER,rank,0,comm_icosa, mpi_req(ireq),ierr) 
     526        IF (debug) PRINT *,"IRecv ",list_domain_send(j), "from ", rank, "to ",mpi_rank, "tag ",0 
    503527      ENDDO 
    504528    ENDDO 
     529    IF (debug) PRINT *,"------------"     
    505530     
    506531    CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    … …  
    517542      ALLOCATE(req%send(req%nsend)) 
    518543    ENDDO 
     544 
     545    IF (debug) PRINT *,"------------"     
    519546    
    520547   ireq=0  
    … …  
    525552       ireq=ireq+1 
    526553       CALL MPI_ISEND(mpi_rank,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr) 
     554       IF (debug) PRINT *,"Isend ",mpi_rank, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain 
    527555     ENDDO 
     556    IF (debug) PRINT *,"------------"     
    528557      
    529558     DO isend=1,req%nsend 
    530559       ireq=ireq+1 
    531560       CALL MPI_IRECV(req%send(isend)%rank,1,MPI_INTEGER,MPI_ANY_SOURCE,ind_loc,comm_icosa, mpi_req(ireq),ierr) 
     561       IF (debug) PRINT *,"IRecv ",req%send(isend)%rank, "from ", "xxx", "to ",mpi_rank, "tag ",ind_loc 
    532562     ENDDO 
    533563   ENDDO 
    534564 
     565   IF (debug) PRINT *,"------------"     
     566 
    535567   CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    536568   CALL MPI_BARRIER(comm_icosa,ierr) 
     569 
     570   IF (debug) PRINT *,"------------"     
    537571 
    538572   ireq=0  
    … …  
    543577       ireq=ireq+1 
    544578       CALL MPI_ISEND(ind_loc,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr) 
     579       IF (debug) PRINT *,"Isend ",ind_loc, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain 
    545580     ENDDO 
     581 
     582     IF (debug) PRINT *,"------------"     
    546583      
    547584     DO isend=1,req%nsend 
    548585       ireq=ireq+1 
    549586       CALL MPI_IRECV(req%send(isend)%domain,1,MPI_INTEGER,req%send(isend)%rank,ind_loc,comm_icosa, mpi_req(ireq),ierr) 
     587       IF (debug) PRINT *,"IRecv ",req%send(isend)%domain, "from ", req%send(isend)%rank, "to ",mpi_rank, "tag ",ind_loc 
    550588     ENDDO 
    551589   ENDDO 
     590   IF (debug) PRINT *,"------------"     
    552591    
    553592   CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    554593   CALL MPI_BARRIER(comm_icosa,ierr) 
     594   IF (debug) PRINT *,"------------"     
     595 
     596   ireq=0 
     597   DO ind_loc=1,ndomain 
     598     req=>request(ind_loc) 
     599      
     600     DO irecv=1,req%nrecv 
     601       ireq=ireq+1 
     602       req%recv(irecv)%tag=tag_rank(req%recv(irecv)%rank) 
     603       tag_rank(req%recv(irecv)%rank)=tag_rank(req%recv(irecv)%rank)+1 
     604       CALL MPI_ISEND(req%recv(irecv)%tag,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr) 
     605       IF (debug) PRINT *,"Isend ",req%recv(irecv)%tag, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain 
     606     ENDDO 
     607   IF (debug) PRINT *,"------------"     
     608      
     609     DO isend=1,req%nsend 
     610       ireq=ireq+1 
     611       CALL MPI_IRECV(req%send(isend)%tag,1,MPI_INTEGER,req%send(isend)%rank,ind_loc,comm_icosa, mpi_req(ireq),ierr) 
     612       IF (debug) PRINT *,"IRecv ",req%send(isend)%tag, "from ", req%send(isend)%rank, "to ",mpi_rank, "tag ",ind_loc 
     613     ENDDO 
     614   ENDDO 
     615   IF (debug) PRINT *,"------------"     
     616    
     617   CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
     618   CALL MPI_BARRIER(comm_icosa,ierr) 
     619 
     620 
     621   IF (debug) PRINT *,"------------"     
    555622 
    556623   ireq=0  
    … …  
    560627     DO irecv=1,req%nrecv 
    561628       ireq=ireq+1 
    562        CALL MPI_ISEND(req%recv(irecv)%size,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr) 
     629       CALL MPI_ISEND(req%recv(irecv)%size,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr) 
     630       IF (debug) PRINT *,"Isend ",req%recv(irecv)%size, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain 
    563631     ENDDO 
     632     IF (debug) PRINT *,"------------"     
    564633      
    565634     DO isend=1,req%nsend 
    566635       ireq=ireq+1 
    567        CALL MPI_IRECV(req%send(isend)%size,1,MPI_INTEGER,req%send(isend)%rank,ind_loc,comm_icosa, mpi_req(ireq),ierr) 
     636       CALL MPI_IRECV(req%send(isend)%size,1,MPI_INTEGER,req%send(isend)%rank,req%send(isend)%tag,comm_icosa, mpi_req(ireq),ierr) 
     637       IF (debug) PRINT *,"IRecv ",req%send(isend)%size, "from ", req%send(isend)%rank, "to ",mpi_rank, "tag ",ind_loc 
    568638     ENDDO 
    569639   ENDDO 
    … …  
    578648       ireq=ireq+1 
    579649       CALL MPI_ISEND(req%recv(irecv)%value,req%recv(irecv)%size,MPI_INTEGER,& 
    580             req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr) 
     650            req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr) 
    581651     ENDDO 
    582652      
    … …  
    585655       ALLOCATE(req%send(isend)%value(req%send(isend)%size)) 
    586656       CALL MPI_IRECV(req%send(isend)%value,req%send(isend)%size,MPI_INTEGER,& 
    587             req%send(isend)%rank,ind_loc,comm_icosa, mpi_req(ireq),ierr) 
     657            req%send(isend)%rank,req%send(isend)%tag,comm_icosa, mpi_req(ireq),ierr) 
    588658     ENDDO 
    589659   ENDDO 
    … …  
    600670     ENDDO 
    601671   ENDDO   
    602  
    603 ! domain is on the same mpi process 
     672    
     673 
     674! domain is on the same mpi process => copie memory to memory 
    604675    
    605676   DO ind_loc=1,ndomain 
    … …  
    611682           req_src=>request(req%recv(irecv)%domain) 
    612683           DO isend=1,req_src%nsend 
    613              IF (req_src%send(isend)%rank==mpi_rank .AND. req_src%send(isend)%domain==ind_loc) THEN 
     684             IF (req_src%send(isend)%rank==mpi_rank .AND. req_src%send(isend)%tag==req%recv(irecv)%tag) THEN 
    614685               req%recv(irecv)%src_value => req_src%send(isend)%value 
    615686               IF ( size(req%recv(irecv)%value) /= size(req_src%send(isend)%value)) THEN 
     687                 PRINT *,ind_loc, irecv, isend, size(req%recv(irecv)%value), size(req_src%send(isend)%value) 
    616688                 STOP "size(req%recv(irecv)%value) /= size(req_src%send(isend)%value" 
    617689               ENDIF 
    … …  
    624696    
    625697! true number of mpi request 
     698 
     699   request(:)%nreq_mpi=0 
     700   request(:)%nreq_send=0 
     701   request(:)%nreq_recv=0 
     702   ALLOCATE(rank_list(sum(request(:)%nsend))) 
     703   ALLOCATE(offset(sum(request(:)%nsend))) 
     704   offset(:)=0 
     705    
     706   nsend=0 
    626707   DO ind_loc=1,ndomain 
    627708     req=>request(ind_loc) 
    628      req%nreq_mpi=0 
    629709 
    630710     DO isend=1,req%nsend 
    631       IF (req%send(isend)%rank/=mpi_rank .OR. .TRUE.) req%nreq_mpi=req%nreq_mpi+1   
     711       IF (req%send(isend)%rank/=mpi_rank) THEN 
     712         pos=0 
     713         DO i=1,nsend 
     714           IF (req%send(isend)%rank==rank_list(i)) EXIT 
     715           pos=pos+1 
     716         ENDDO 
     717         
     718         IF (pos==nsend) THEN 
     719           nsend=nsend+1 
     720           req%nreq_mpi=req%nreq_mpi+1 
     721           req%nreq_send=req%nreq_send+1 
     722           IF (mpi_threading_mode==MPI_THREAD_FUNNELED) THEN 
     723             rank_list(nsend)=req%send(isend)%rank 
     724           ELSE 
     725             rank_list(nsend)=-1 
     726           ENDIF 
     727         ENDIF 
     728          
     729         pos=pos+1 
     730         req%send(isend)%ireq=pos 
     731         req%send(isend)%offset=offset(pos) 
     732         offset(pos)=offset(pos)+req%send(isend)%size 
     733       ENDIF 
    632734     ENDDO 
    633       
     735   ENDDO 
     736 
     737   DEALLOCATE(rank_list) 
     738   DEALLOCATE(offset) 
     739      
     740   ALLOCATE(rank_list(sum(request(:)%nrecv))) 
     741   ALLOCATE(offset(sum(request(:)%nrecv))) 
     742   offset(:)=0 
     743    
     744   nrecv=0 
     745   DO ind_loc=1,ndomain 
     746     req=>request(ind_loc) 
     747 
    634748     DO irecv=1,req%nrecv 
    635       IF (req%recv(irecv)%rank/=mpi_rank .OR. .TRUE.) req%nreq_mpi=req%nreq_mpi+1   
     749       IF (req%recv(irecv)%rank/=mpi_rank) THEN 
     750         pos=0 
     751         DO i=1,nrecv 
     752           IF (req%recv(irecv)%rank==rank_list(i)) EXIT 
     753           pos=pos+1 
     754         ENDDO 
     755         
     756         IF (pos==nrecv) THEN 
     757           nrecv=nrecv+1 
     758           req%nreq_mpi=req%nreq_mpi+1 
     759           req%nreq_recv=req%nreq_recv+1 
     760           IF (mpi_threading_mode==MPI_THREAD_FUNNELED) THEN 
     761             rank_list(nrecv)=req%recv(irecv)%rank 
     762           ELSE 
     763             rank_list(nrecv)=-1 
     764           ENDIF 
     765         ENDIF 
     766         
     767         pos=pos+1 
     768         req%recv(irecv)%ireq=nsend+pos 
     769         req%recv(irecv)%offset=offset(pos) 
     770         offset(pos)=offset(pos)+req%recv(irecv)%size 
     771       ENDIF 
    636772     ENDDO 
    637    
    638773   ENDDO  
     774 
     775! get the offsets    
     776 
     777   ireq=0  
     778   DO ind_loc=1,ndomain 
     779     req=>request(ind_loc) 
     780      
     781     DO irecv=1,req%nrecv 
     782       ireq=ireq+1 
     783       CALL MPI_ISEND(req%recv(irecv)%offset,1,MPI_INTEGER,& 
     784            req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr) 
     785     ENDDO 
     786      
     787     DO isend=1,req%nsend 
     788       ireq=ireq+1 
     789       CALL MPI_IRECV(req%send(isend)%offset,1,MPI_INTEGER,& 
     790            req%send(isend)%rank,req%send(isend)%tag,comm_icosa, mpi_req(ireq),ierr) 
     791     ENDDO 
     792   ENDDO 
     793 
     794   CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
     795       
    639796        
    640797  END SUBROUTINE Finalize_request  
    … …  
    701858  END SUBROUTINE transfert_message_seq     
    702859     
     860 
     861 
    703862     
    704863  SUBROUTINE init_message_mpi(field,request, message) 
    … …  
    717876    TYPE(t_request),POINTER :: req 
    718877    INTEGER :: irecv,isend 
    719     INTEGER :: ireq,nreq 
     878    INTEGER :: ireq,nreq, nreq_send 
    720879    INTEGER :: ind 
    721880    INTEGER :: dim3,dim4 
    722  
     881    INTEGER :: i,j 
     882    INTEGER :: message_number 
     883!    TYPE(t_reorder),POINTER :: reorder(:) 
     884!    TYPE(t_reorder) :: reorder_swap 
     885 
     886!$OMP BARRIER 
    723887!$OMP MASTER 
    724888    message%number=message_number 
    725889    message_number=message_number+1 
    726890    IF (message_number==100) message_number=0 
    727      
     891 
     892   
    728893    message%request=>request 
    729     nreq=sum(request(:)%nsend)+sum(request(:)%nrecv) 
    730 !    message%nreq=nreq 
    731894    message%nreq=sum(message%request(:)%nreq_mpi) 
     895    message%nreq_send=sum(message%request(:)%nreq_send) 
     896    message%nreq_recv=sum(message%request(:)%nreq_recv) 
     897    nreq=message%nreq 
     898 
    732899    ALLOCATE(message%mpi_req(nreq)) 
    733900    ALLOCATE(message%buffers(nreq)) 
    734901    ALLOCATE(message%status(MPI_STATUS_SIZE,nreq)) 
    735      
     902    message%buffers(:)%size=0 
    736903    message%pending=.FALSE. 
    737904    message%completed=.FALSE. 
    738      
     905   
     906    DO ind=1,ndomain 
     907      req=>request(ind) 
     908      DO isend=1,req%nsend 
     909        IF (req%send(isend)%rank/=mpi_rank) THEN 
     910          ireq=req%send(isend)%ireq  
     911          message%buffers(ireq)%size=message%buffers(ireq)%size+req%send(isend)%size 
     912          message%buffers(ireq)%rank=req%send(isend)%rank 
     913        ENDIF 
     914      ENDDO 
     915      DO irecv=1,req%nrecv 
     916        IF (req%recv(irecv)%rank/=mpi_rank) THEN 
     917          ireq=req%recv(irecv)%ireq  
     918          message%buffers(ireq)%size=message%buffers(ireq)%size+req%recv(irecv)%size 
     919          message%buffers(ireq)%rank=req%recv(irecv)%rank 
     920        ENDIF 
     921      ENDDO 
     922    ENDDO 
     923 
     924 
    739925    IF (field(1)%data_type==type_real) THEN 
    740926 
    741927      IF (field(1)%ndim==2) THEN 
    742        
    743         ireq=0 
    744         DO ind=1,ndomain 
    745           req=>request(ind) 
    746        
    747           DO isend=1,req%nsend 
    748             ireq=ireq+1 
    749             send=>req%send(isend) 
    750             CALL allocate_mpi_buffer(message%buffers(ireq)%r2,send%size) 
    751           ENDDO 
    752          
    753           DO irecv=1,req%nrecv 
    754             ireq=ireq+1 
    755             recv=>req%recv(irecv) 
    756             CALL allocate_mpi_buffer(message%buffers(ireq)%r2,recv%size) 
    757           ENDDO 
    758          
    759         ENDDO 
    760        
     928      
     929        DO ireq=1,message%nreq 
     930          CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size) 
     931        ENDDO 
    761932       
    762933      ELSE  IF (field(1)%ndim==3) THEN 
    763      
    764         ireq=0 
    765         DO ind=1,ndomain 
    766           dim3=size(field(ind)%rval3d,2) 
    767           req=>request(ind) 
    768   
    769           DO isend=1,req%nsend 
    770             ireq=ireq+1 
    771             send=>req%send(isend) 
    772             CALL allocate_mpi_buffer(message%buffers(ireq)%r3,send%size,dim3) 
    773           ENDDO 
    774          
    775           DO irecv=1,req%nrecv 
    776             ireq=ireq+1 
    777             recv=>req%recv(irecv) 
    778             CALL allocate_mpi_buffer(message%buffers(ireq)%r3,recv%size,dim3) 
    779  
    780           ENDDO 
    781          
    782         ENDDO 
    783  
    784  
     934       
     935        dim3=size(field(1)%rval3d,2) 
     936        DO ireq=1,message%nreq 
     937          message%buffers(ireq)%size=message%buffers(ireq)%size*dim3 
     938          CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size) 
     939        ENDDO 
     940       
    785941      ELSE  IF (field(1)%ndim==4) THEN 
    786     
    787         ireq=0 
    788         DO ind=1,ndomain 
    789           dim3=size(field(ind)%rval4d,2) 
    790           dim4=size(field(ind)%rval4d,3) 
    791           req=>request(ind) 
    792  
    793           DO isend=1,req%nsend 
    794             ireq=ireq+1 
    795             send=>req%send(isend) 
    796             CALL allocate_mpi_buffer(message%buffers(ireq)%r4,send%size,dim3,dim4) 
    797           ENDDO 
    798          
    799           DO irecv=1,req%nrecv 
    800             ireq=ireq+1 
    801             recv=>req%recv(irecv) 
    802             CALL allocate_mpi_buffer(message%buffers(ireq)%r4,recv%size,dim3,dim4) 
    803           ENDDO 
    804          
    805         ENDDO 
    806        
     942        dim3=size(field(1)%rval4d,2) 
     943        dim4=size(field(1)%rval4d,3) 
     944        DO ireq=1,message%nreq 
     945          message%buffers(ireq)%size=message%buffers(ireq)%size*dim3*dim4 
     946          CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size) 
     947        ENDDO 
    807948      ENDIF       
    808949    ENDIF 
     950       
     951          
     952     
     953! ! Reorder the request, so recv request are done in the same order than send request 
     954 
     955!    nreq_send=sum(request(:)%nsend)   
     956!    message%nreq_send=nreq_send 
     957!    ALLOCATE(message%reorder(nreq_send)) 
     958!    reorder=>message%reorder 
     959!    ireq=0 
     960!    DO ind=1,ndomain 
     961!      req=>request(ind) 
     962!      DO isend=1,req%nsend 
     963!        ireq=ireq+1 
     964!        reorder(ireq)%ind=ind 
     965!        reorder(ireq)%isend=isend 
     966!        reorder(ireq)%tag=req%send(isend)%tag 
     967!      ENDDO 
     968!    ENDDO 
     969 
     970! ! do a very very bad sort 
     971!    DO i=1,nreq_send-1 
     972!      DO j=i+1,nreq_send 
     973!        IF (reorder(i)%tag > reorder(j)%tag) THEN 
     974!          reorder_swap=reorder(i) 
     975!          reorder(i)=reorder(j) 
     976!          reorder(j)=reorder_swap 
     977!        ENDIF 
     978!      ENDDO 
     979!    ENDDO 
     980!    PRINT *,"reorder ",reorder(:)%tag 
     981     
     982  
    809983!$OMP END MASTER 
    810984!$OMP BARRIER     
     985 
    811986  END SUBROUTINE init_message_mpi 
     987   
     988  SUBROUTINE Finalize_message_mpi(field,message) 
     989  USE field_mod 
     990  USE domain_mod 
     991  USE mpi_mod 
     992  USE mpipara 
     993  USE mpi_mod 
     994  IMPLICIT NONE 
     995    TYPE(t_field),POINTER :: field(:) 
     996    TYPE(t_message) :: message 
     997 
     998    TYPE(t_request),POINTER :: req 
     999    INTEGER :: irecv,isend 
     1000    INTEGER :: ireq,nreq 
     1001    INTEGER :: ind 
     1002 
     1003!$OMP BARRIER 
     1004!$OMP MASTER 
     1005 
     1006 
     1007    IF (field(1)%data_type==type_real) THEN 
     1008 
     1009      IF (field(1)%ndim==2) THEN 
     1010      
     1011        DO ireq=1,message%nreq 
     1012          CALL free_mpi_buffer(message%buffers(ireq)%r) 
     1013        ENDDO 
     1014       
     1015      ELSE  IF (field(1)%ndim==3) THEN 
     1016 
     1017        DO ireq=1,message%nreq 
     1018          CALL free_mpi_buffer(message%buffers(ireq)%r) 
     1019        ENDDO 
     1020       
     1021      ELSE  IF (field(1)%ndim==4) THEN 
     1022 
     1023        DO ireq=1,message%nreq 
     1024          CALL free_mpi_buffer(message%buffers(ireq)%r) 
     1025        ENDDO 
     1026 
     1027      ENDIF       
     1028    ENDIF 
     1029     
     1030 
     1031 
     1032!$OMP END MASTER 
     1033!$OMP BARRIER 
     1034 
     1035       
     1036  END SUBROUTINE Finalize_message_mpi 
     1037 
     1038 
    8121039   
    8131040  SUBROUTINE barrier 
    … …  
    8451072    REAL(rstd),POINTER :: rval3d(:,:), src_rval3d(:,:)  
    8461073    REAL(rstd),POINTER :: rval4d(:,:,:), src_rval4d(:,:,:)  
    847     REAL(rstd),POINTER :: buffer_r2(:)  
    848     REAL(rstd),POINTER :: buffer_r3(:,:)  
    849     REAL(rstd),POINTER :: buffer_r4(:,:,:)  
    850     INTEGER,POINTER :: value(:)  
    851     INTEGER,POINTER :: sgn(:)  
    852     TYPE(ARRAY),POINTER :: recv,send  
    853     TYPE(t_request),POINTER :: req 
    854     INTEGER, ALLOCATABLE :: mpi_req(:) 
    855     INTEGER, ALLOCATABLE :: status(:,:) 
    856     INTEGER :: irecv,isend 
    857     INTEGER :: ireq,ireq_mpi,nreq 
    858     INTEGER :: ind,n,l,m 
    859     INTEGER :: dim3,dim4 
    860     INTEGER,POINTER :: src_value(:) 
    861     INTEGER,POINTER :: sign(:) 
    862  
    863 !$OMP BARRIER 
    864  
    865     CALL trace_start("transfert_mpi") 
    866  
    867 !    nreq=message%nreq 
    868     message%field=>field 
    869  
    870 !$OMP MASTER 
    871     IF (message%nreq>0) THEN 
    872       message%completed=.FALSE. 
    873       message%pending=.TRUE. 
    874     ELSE 
    875       message%completed=.TRUE. 
    876       message%pending=.FALSE. 
    877     ENDIF 
    878      
    879 !$OMP END MASTER 
    880      
    881     IF (field(1)%data_type==type_real) THEN 
    882       IF (field(1)%ndim==2) THEN 
    883  
    884         ireq=0 
    885         ireq_mpi=0 
    886         DO ind=1,ndomain 
    887           rval2d=>field(ind)%rval2d 
    888          
    889           req=>message%request(ind) 
    890           DO isend=1,req%nsend 
    891             ireq=ireq+1 
    892             send=>req%send(isend) 
    893             value=>send%value 
    894  
    895              
    896             IF (send%rank/=mpi_rank .OR. .TRUE.) THEN 
    897               ireq_mpi=ireq_mpi+1 
    898               buffer_r2=>message%buffers(ireq)%r2 
    899               CALL trace_in 
    900  
    901               !$OMP DO SCHEDULE(STATIC) 
    902               DO n=1,send%size 
    903                 buffer_r2(n)=rval2d(value(n)) 
    904               ENDDO 
    905              
    906               CALL trace_out 
    907  
    908               !$OMP MASTER 
    909               CALL MPI_ISSEND(buffer_r2,send%size,MPI_REAL8,send%rank,ind+100*message%number,comm_icosa, message%mpi_req(ireq_mpi),ierr) 
    910               !$OMP END MASTER 
    911               
    912              ENDIF 
    913           ENDDO 
    914          
    915           DO irecv=1,req%nrecv 
    916             ireq=ireq+1 
    917             recv=>req%recv(irecv) 
    918  
    919             IF (recv%rank==mpi_rank .AND. .FALSE.) THEN 
    920               value=>recv%value 
    921               src_value => recv%src_value 
    922               src_rval2d=>field(recv%domain)%rval2d 
    923               sgn=>recv%sign 
    924               !$OMP DO SCHEDULE(STATIC) 
    925               DO n=1,recv%size 
    926                 rval2d(value(n))=src_rval2d(src_value(n))*sgn(n) 
    927               ENDDO 
    928              
    929             ELSE 
    930                ireq_mpi=ireq_mpi+1 
    931                buffer_r2=>message%buffers(ireq)%r2 
    932               !$OMP MASTER 
    933               CALL MPI_IRECV(buffer_r2,recv%size,MPI_REAL8,recv%rank,recv%domain+100*message%number,comm_icosa, message%mpi_req(ireq_mpi),ierr) 
    934               !$OMP END MASTER 
    935             ENDIF 
    936           ENDDO 
    937          
    938         ENDDO 
    939        
    940       ELSE  IF (field(1)%ndim==3) THEN 
    941        
    942         ireq=0 
    943         ireq_mpi=0 
    944         DO ind=1,ndomain 
    945           dim3=size(field(ind)%rval3d,2) 
    946           rval3d=>field(ind)%rval3d 
    947           req=>message%request(ind) 
    948   
    949           DO isend=1,req%nsend 
    950             ireq=ireq+1 
    951             send=>req%send(isend) 
    952             value=>send%value 
    953  
    954             IF (send%rank/=mpi_rank .OR. .TRUE.) THEN 
    955               ireq_mpi=ireq_mpi+1 
    956               buffer_r3=>message%buffers(ireq)%r3 
    957   
    958               CALL trace_in 
    959              
    960 !$OMP DO SCHEDULE(STATIC) 
    961                 DO n=1,send%size 
    962                   buffer_r3(n,:)=rval3d(value(n),:) 
    963                 ENDDO 
    964  
    965                CALL trace_out 
    966  
    967   !$OMP MASTER 
    968               CALL MPI_ISSEND(buffer_r3,send%size*dim3,MPI_REAL8,send%rank,ind+100*message%number,comm_icosa, message%mpi_req(ireq_mpi),ierr) 
    969   !$OMP END MASTER 
    970             ENDIF 
    971          ENDDO 
    972          
    973           DO irecv=1,req%nrecv 
    974             ireq=ireq+1 
    975             recv=>req%recv(irecv) 
    976  
    977             IF (recv%rank==mpi_rank .AND. .FALSE.) THEN 
    978               value=>recv%value 
    979               src_value => recv%src_value 
    980               src_rval3d=>field(recv%domain)%rval3d 
    981               sgn=>recv%sign 
    982               !$OMP DO SCHEDULE(STATIC) 
    983               DO n=1,recv%size 
    984                 rval3d(value(n),:)=src_rval3d(src_value(n),:)*sgn(n) 
    985               ENDDO 
    986              
    987             ELSE 
    988               ireq_mpi=ireq_mpi+1 
    989               buffer_r3=>message%buffers(ireq)%r3 
    990 !$OMP MASTER            
    991               CALL MPI_IRECV(buffer_r3,recv%size*dim3,MPI_REAL8,recv%rank,recv%domain+100*message%number,comm_icosa, message%mpi_req(ireq_mpi),ierr) 
    992 !$OMP END MASTER 
    993             ENDIF 
    994           ENDDO 
    995          
    996         ENDDO 
    997  
    998       ELSE  IF (field(1)%ndim==4) THEN 
    999      
    1000         ireq=0 
    1001         ireq_mpi=0 
    1002         DO ind=1,ndomain 
    1003           dim3=size(field(ind)%rval4d,2) 
    1004           dim4=size(field(ind)%rval4d,3) 
    1005           rval4d=>field(ind)%rval4d 
    1006           req=>message%request(ind) 
    1007  
    1008           DO isend=1,req%nsend 
    1009             ireq=ireq+1 
    1010             send=>req%send(isend) 
    1011             value=>send%value 
    1012  
    1013             IF (send%rank/=mpi_rank .OR. .TRUE.) THEN 
    1014               ireq_mpi=ireq_mpi+1 
    1015               buffer_r4=>message%buffers(ireq)%r4 
    1016               CALL trace_in 
    1017  
    1018 !$OMP DO SCHEDULE(STATIC) 
    1019               DO n=1,send%size 
    1020                  buffer_r4(n,:,:)=rval4d(value(n),:,:) 
    1021               ENDDO 
    1022  
    1023              CALL trace_out 
    1024  
    1025 !$OMP MASTER 
    1026               CALL MPI_ISSEND(buffer_r4,send%size*dim3*dim4,MPI_REAL8,send%rank,ind+100*message%number,comm_icosa, message%mpi_req(ireq_mpi),ierr) 
    1027 !$OMP END MASTER 
    1028             ENDIF 
    1029           ENDDO 
    1030          
    1031           DO irecv=1,req%nrecv 
    1032             ireq=ireq+1 
    1033             recv=>req%recv(irecv) 
    1034             IF (recv%rank==mpi_rank .AND. .FALSE.) THEN 
    1035               value=>recv%value 
    1036               src_value => recv%src_value 
    1037               src_rval4d=>field(recv%domain)%rval4d 
    1038               sgn=>recv%sign 
    1039  
    1040               !$OMP DO SCHEDULE(STATIC) 
    1041               DO n=1,recv%size 
    1042                 rval4d(value(n),:,:)=src_rval4d(src_value(n),:,:)*sgn(n) 
    1043               ENDDO 
    1044              
    1045             ELSE 
    1046               ireq_mpi=ireq_mpi+1 
    1047               buffer_r4=>message%buffers(ireq)%r4 
    1048 !$OMP MASTER            
    1049               CALL MPI_IRECV(buffer_r4,recv%size*dim3*dim4,MPI_REAL8,recv%rank,recv%domain+100*message%number,comm_icosa, message%mpi_req(ireq_mpi),ierr) 
    1050 !$OMP END MASTER 
    1051             ENDIF 
    1052           ENDDO 
    1053          
    1054         ENDDO 
    1055        
    1056       ENDIF       
    1057        
    1058     ENDIF 
    1059     IF (ireq_mpi /= message%nreq ) THEN 
    1060       STOP "ireq_mpi /= message%nreq" 
    1061     ENDIF 
    1062      
    1063     CALL trace_end("transfert_mpi") 
    1064 !$OMP BARRIER 
    1065      
    1066   END SUBROUTINE send_message_mpi 
    1067    
    1068   SUBROUTINE test_message_mpi(message) 
    1069   IMPLICIT NONE 
    1070     TYPE(t_message) :: message 
    1071      
    1072     INTEGER :: ierr 
    1073 !$OMP MASTER 
    1074      IF (.NOT. message%pending) RETURN 
    1075 !$OMP END MASTER 
    1076  
    1077 !$OMP MASTER 
    1078      IF (.NOT. message%completed) CALL MPI_TESTALL(message%nreq,message%mpi_req,message%completed,message%status,ierr) 
    1079 !$OMP END MASTER 
    1080   END SUBROUTINE  test_message_mpi 
    1081    
    1082     
    1083   SUBROUTINE wait_message_mpi(message) 
    1084   USE field_mod 
    1085   USE domain_mod 
    1086   USE mpi_mod 
    1087   USE mpipara 
    1088   USE omp_para 
    1089   USE trace 
    1090   IMPLICIT NONE 
    1091     TYPE(t_message) :: message 
    1092  
    1093     TYPE(t_field),POINTER :: field(:) 
    1094     REAL(rstd),POINTER :: rval2d(:)  
    1095     REAL(rstd),POINTER :: rval3d(:,:)  
    1096     REAL(rstd),POINTER :: rval4d(:,:,:)  
    1097     REAL(rstd),POINTER :: buffer_r2(:)  
    1098     REAL(rstd),POINTER :: buffer_r3(:,:)  
    1099     REAL(rstd),POINTER :: buffer_r4(:,:,:)  
     1074    REAL(rstd),POINTER :: buffer_r(:)  
    11001075    INTEGER,POINTER :: value(:)  
    11011076    INTEGER,POINTER :: sgn(:)  
    … …  
    11061081    INTEGER :: irecv,isend 
    11071082    INTEGER :: ireq,nreq 
    1108     INTEGER :: ind,n,l,m 
    1109     INTEGER :: dim3,dim4 
     1083    INTEGER :: ind,i,n,l,m 
     1084    INTEGER :: dim3,dim4,d3,d4 
     1085    INTEGER,POINTER :: src_value(:) 
     1086    INTEGER,POINTER :: sign(:) 
     1087    INTEGER :: offset,msize,rank 
     1088 
     1089    CALL trace_start("transfert_mpi") 
    11101090 
    11111091!$OMP BARRIER 
    11121092 
    1113     CALL trace_start("transfert_mpi") 
    1114  
    1115     IF (.NOT. message%pending) RETURN 
    1116      
    1117     field=>message%field 
    1118     nreq=message%nreq 
    1119      
     1093 
     1094!$OMP MASTER 
     1095    message%field=>field 
     1096 
     1097    IF (message%nreq>0) THEN 
     1098      message%completed=.FALSE. 
     1099      message%pending=.TRUE. 
     1100    ELSE 
     1101      message%completed=.TRUE. 
     1102      message%pending=.FALSE. 
     1103    ENDIF 
     1104!$OMP END MASTER 
     1105!$OMP BARRIER 
     1106      
    11201107    IF (field(1)%data_type==type_real) THEN 
    11211108      IF (field(1)%ndim==2) THEN 
    11221109 
    1123 !$OMP MASTER 
    1124         IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req,message%status,ierr) 
    1125 !$OMP END MASTER 
    1126 !$OMP BARRIER 
    1127  
    1128         ireq=0         
    11291110        DO ind=1,ndomain 
     1111          IF (.NOT. assigned_domain(ind)) CYCLE 
     1112           
    11301113          rval2d=>field(ind)%rval2d 
     1114         
    11311115          req=>message%request(ind) 
    1132  
    11331116          DO isend=1,req%nsend 
    1134             ireq=ireq+1 
    1135           ENDDO 
    1136       
    1137           DO irecv=1,req%nrecv 
    1138             ireq=ireq+1 
    1139             recv=>req%recv(irecv) 
    1140             IF (recv%rank/=mpi_rank .OR. .TRUE.) THEN 
    1141               buffer_r2=>message%buffers(ireq)%r2 
    1142               value=>recv%value 
    1143               sgn=>recv%sign 
    1144  
    1145               CALL trace_in 
     1117            send=>req%send(isend) 
     1118            value=>send%value 
     1119 
    11461120             
    1147 !$OMP DO SCHEDULE(STATIC) 
    1148               DO n=1,recv%size 
    1149                 rval2d(value(n))=buffer_r2(n)*sgn(n)   
    1150               ENDDO         
    1151  
    1152               CALL trace_out 
     1121            IF (send%rank/=mpi_rank) THEN 
     1122              ireq=send%ireq 
     1123 
     1124              buffer_r=>message%buffers(ireq)%r 
     1125              offset=send%offset 
     1126                                             
     1127              DO n=1,send%size 
     1128                buffer_r(offset+n)=rval2d(value(n)) 
     1129              ENDDO 
     1130 
     1131              IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 
     1132                !$OMP CRITICAL             
     1133                CALL MPI_ISEND(buffer_r,send%size,MPI_REAL8,send%rank,send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
     1134                !$OMP END CRITICAL 
     1135              ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 
     1136                CALL MPI_ISEND(buffer_r,send%size,MPI_REAL8,send%rank,send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
     1137              ENDIF 
     1138              
    11531139            ENDIF 
    11541140          ENDDO 
    1155          
    1156         ENDDO 
    1157        
     1141        ENDDO 
     1142         
     1143        DO ind=1,ndomain 
     1144          IF (.NOT. assigned_domain(ind)) CYCLE 
     1145          rval2d=>field(ind)%rval2d 
     1146          req=>message%request(ind)         
     1147 
     1148          DO irecv=1,req%nrecv 
     1149            recv=>req%recv(irecv) 
     1150 
     1151            IF (recv%rank==mpi_rank) THEN 
     1152 
     1153              value=>recv%value 
     1154              src_value => recv%src_value 
     1155              src_rval2d=>field(recv%domain)%rval2d 
     1156              sgn=>recv%sign 
     1157 
     1158              DO n=1,recv%size 
     1159                rval2d(value(n))=src_rval2d(src_value(n))*sgn(n) 
     1160              ENDDO 
     1161                 
     1162                     
     1163            ELSE 
     1164             
     1165              ireq=recv%ireq 
     1166              buffer_r=>message%buffers(ireq)%r 
     1167              IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 
     1168               !$OMP CRITICAL             
     1169                CALL MPI_IRECV(buffer_r,recv%size,MPI_REAL8,recv%rank,recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
     1170               !$OMP END CRITICAL 
     1171              ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 
     1172                 CALL MPI_IRECV(buffer_r,recv%size,MPI_REAL8,recv%rank,recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
     1173              ENDIF 
     1174             
     1175            ENDIF 
     1176          ENDDO 
     1177         
     1178        ENDDO 
     1179         
    11581180       
    11591181      ELSE  IF (field(1)%ndim==3) THEN 
    1160  
    1161 !$OMP MASTER 
    1162         IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req,message%status,ierr) 
    1163 !$OMP END MASTER 
    1164 !$OMP BARRIER 
    1165  
    1166         ireq=0         
     1182       
    11671183        DO ind=1,ndomain 
     1184          IF (.NOT. assigned_domain(ind)) CYCLE 
     1185 
     1186          dim3=size(field(ind)%rval3d,2) 
    11681187          rval3d=>field(ind)%rval3d 
    11691188          req=>message%request(ind) 
    1170  
     1189  
    11711190          DO isend=1,req%nsend 
    1172             ireq=ireq+1 
    1173           ENDDO 
    1174          
    1175           DO irecv=1,req%nrecv 
    1176             ireq=ireq+1 
    1177             recv=>req%recv(irecv) 
    1178             IF (recv%rank/=mpi_rank .OR. .TRUE.) THEN 
    1179               buffer_r3=>message%buffers(ireq)%r3 
    1180               value=>recv%value 
    1181               sgn=>recv%sign 
    1182  
    1183               CALL trace_in 
    1184              
    1185 !$OMP DO SCHEDULE(STATIC) 
    1186               DO n=1,recv%size 
    1187                 rval3d(value(n),:)=buffer_r3(n,:)*sgn(n)   
    1188               ENDDO   
    1189  
    1190               CALL trace_out 
     1191            send=>req%send(isend) 
     1192            value=>send%value 
     1193 
     1194            IF (send%rank/=mpi_rank) THEN 
     1195              ireq=send%ireq 
     1196              buffer_r=>message%buffers(ireq)%r 
     1197              offset=send%offset*dim3 
     1198 
     1199              DO d3=1,dim3 
     1200                DO n=1,send%size 
     1201                  buffer_r(n+offset)=rval3d(value(n),d3) 
     1202                ENDDO 
     1203                offset=offset+send%size 
     1204              ENDDO 
     1205 
     1206              IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 
     1207                !$OMP CRITICAL    
     1208                CALL MPI_ISEND(buffer_r,send%size*dim3,MPI_REAL8,send%rank,send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
     1209                !$OMP END CRITICAL 
     1210              ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 
     1211                CALL MPI_ISEND(buffer_r,send%size*dim3,MPI_REAL8,send%rank,send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
     1212              ENDIF 
    11911213            ENDIF 
    11921214          ENDDO 
     1215        ENDDO 
     1216          
     1217        DO ind=1,ndomain 
     1218          IF (.NOT. assigned_domain(ind)) CYCLE 
     1219          dim3=size(field(ind)%rval3d,2) 
     1220          rval3d=>field(ind)%rval3d 
     1221          req=>message%request(ind) 
     1222 
     1223          DO irecv=1,req%nrecv 
     1224            recv=>req%recv(irecv) 
     1225 
     1226            IF (recv%rank==mpi_rank) THEN 
     1227              value=>recv%value 
     1228              src_value => recv%src_value 
     1229              src_rval3d=>field(recv%domain)%rval3d 
     1230              sgn=>recv%sign 
     1231 
     1232              DO n=1,recv%size 
     1233                rval3d(value(n),:)=src_rval3d(src_value(n),:)*sgn(n) 
     1234              ENDDO 
     1235 
     1236            ELSE 
     1237              ireq=recv%ireq 
     1238              buffer_r=>message%buffers(ireq)%r 
     1239  
     1240              IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 
     1241                !$OMP CRITICAL 
     1242                CALL MPI_IRECV(buffer_r,recv%size*dim3,MPI_REAL8,recv%rank,recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
     1243                !$OMP END CRITICAL 
     1244              ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 
     1245                CALL MPI_IRECV(buffer_r,recv%size*dim3,MPI_REAL8,recv%rank,recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
     1246              ENDIF 
     1247            ENDIF 
     1248          ENDDO 
    11931249         
    11941250        ENDDO 
    11951251 
    11961252      ELSE  IF (field(1)%ndim==4) THEN 
    1197 !$OMP MASTER 
    1198         IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req,message%status,ierr) 
    1199 !$OMP END MASTER 
    1200 !$OMP BARRIER 
    1201  
    1202         ireq=0         
     1253     
    12031254        DO ind=1,ndomain 
     1255          IF (.NOT. assigned_domain(ind)) CYCLE 
     1256 
     1257          dim3=size(field(ind)%rval4d,2) 
     1258          dim4=size(field(ind)%rval4d,3) 
    12041259          rval4d=>field(ind)%rval4d 
    12051260          req=>message%request(ind) 
    12061261 
    12071262          DO isend=1,req%nsend 
    1208             ireq=ireq+1 
    1209           ENDDO 
    1210          
    1211           DO irecv=1,req%nrecv 
    1212             ireq=ireq+1 
    1213             recv=>req%recv(irecv) 
    1214             IF (recv%rank/=mpi_rank .OR. .TRUE.) THEN 
    1215               buffer_r4=>message%buffers(ireq)%r4 
    1216               value=>recv%value 
    1217               sgn=>recv%sign 
    1218  
    1219               CALL trace_in 
    1220  
    1221 !$OMP DO SCHEDULE(STATIC) 
    1222               DO n=1,recv%size 
    1223                 rval4d(value(n),:,:)=buffer_r4(n,:,:)*sgn(n)  
     1263            send=>req%send(isend) 
     1264            value=>send%value 
     1265 
     1266            IF (send%rank/=mpi_rank) THEN 
     1267 
     1268              ireq=send%ireq 
     1269              buffer_r=>message%buffers(ireq)%r 
     1270              offset=send%offset*dim3*dim4 
     1271 
     1272              DO d4=1,dim4 
     1273                DO d3=1,dim3 
     1274                  DO n=1,send%size 
     1275                    buffer_r(n+offset)=rval4d(value(n),d3,d4) 
     1276                  ENDDO 
     1277                  offset=offset+send%size 
     1278                ENDDO 
    12241279              ENDDO 
    12251280 
    1226               CALL trace_out 
     1281              IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 
     1282                !$OMP CRITICAL 
     1283                CALL MPI_ISEND(buffer_r,send%size*dim3*dim4,MPI_REAL8,send%rank,send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
     1284                !$OMP END CRITICAL 
     1285              ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 
     1286                CALL MPI_ISEND(buffer_r,send%size*dim3*dim4,MPI_REAL8,send%rank,send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
     1287              ENDIF 
     1288 
    12271289            ENDIF 
    12281290          ENDDO 
    1229          
    1230         ENDDO 
    1231        
     1291        ENDDO 
     1292         
     1293        DO ind=1,ndomain 
     1294          IF (.NOT. assigned_domain(ind)) CYCLE 
     1295           
     1296          dim3=size(field(ind)%rval4d,2) 
     1297          dim4=size(field(ind)%rval4d,3) 
     1298          rval4d=>field(ind)%rval4d 
     1299          req=>message%request(ind) 
     1300 
     1301          DO irecv=1,req%nrecv 
     1302            recv=>req%recv(irecv) 
     1303            IF (recv%rank==mpi_rank) THEN 
     1304              value=>recv%value 
     1305              src_value => recv%src_value 
     1306              src_rval4d=>field(recv%domain)%rval4d 
     1307              sgn=>recv%sign 
     1308 
     1309              DO n=1,recv%size 
     1310                rval4d(value(n),:,:)=src_rval4d(src_value(n),:,:)*sgn(n) 
     1311              ENDDO 
     1312                    
     1313            ELSE 
     1314 
     1315              ireq=recv%ireq 
     1316              buffer_r=>message%buffers(ireq)%r 
     1317              IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN 
     1318                !$OMP CRITICAL            
     1319                CALL MPI_IRECV(buffer_r,recv%size*dim3*dim4,MPI_REAL8,recv%rank,recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)  
     1320                !$OMP END CRITICAL 
     1321              ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN 
     1322                CALL MPI_IRECV(buffer_r,recv%size*dim3*dim4,MPI_REAL8,recv%rank,recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)  
     1323              ENDIF 
     1324     
     1325            ENDIF 
     1326          ENDDO 
     1327        ENDDO 
     1328 
    12321329      ENDIF       
    1233        
     1330 
     1331      IF (mpi_threading_mode==MPI_THREAD_FUNNELED) THEN 
     1332!$OMP BARRIER 
     1333!$OMP MASTER         
     1334 
     1335        DO ireq=1,message%nreq_send 
     1336          buffer_r=>message%buffers(ireq)%r 
     1337          msize=message%buffers(ireq)%size 
     1338          rank=message%buffers(ireq)%rank 
     1339          CALL MPI_ISEND(buffer_r,msize,MPI_REAL8,rank,1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
     1340        ENDDO 
     1341 
     1342        DO ireq=message%nreq_send+1,message%nreq_send+message%nreq_recv 
     1343          buffer_r=>message%buffers(ireq)%r 
     1344          msize=message%buffers(ireq)%size 
     1345          rank=message%buffers(ireq)%rank 
     1346          CALL MPI_IRECV(buffer_r,msize,MPI_REAL8,rank,1000*message%number,comm_icosa, message%mpi_req(ireq),ierr) 
     1347        ENDDO 
     1348 
     1349!$OMP END MASTER 
     1350      ENDIF               
    12341351    ENDIF 
     1352     
     1353!$OMP BARRIER 
     1354    CALL trace_end("transfert_mpi") 
     1355     
     1356  END SUBROUTINE send_message_mpi 
     1357   
     1358  SUBROUTINE test_message_mpi(message) 
     1359  IMPLICIT NONE 
     1360    TYPE(t_message) :: message 
     1361     
     1362    INTEGER :: ierr 
    12351363 
    12361364!$OMP MASTER 
    1237     message%pending=.FALSE. 
     1365    IF (message%pending .AND. .NOT. message%completed) CALL MPI_TESTALL(message%nreq,message%mpi_req,message%completed,message%status,ierr) 
    12381366!$OMP END MASTER 
    1239  
    1240     CALL trace_end("transfert_mpi") 
    1241 !$OMP BARRIER 
    1242      
    1243   END SUBROUTINE wait_message_mpi 
    1244  
    1245  
    1246   SUBROUTINE transfert_request_mpi(field,request) 
     1367  END SUBROUTINE  test_message_mpi 
     1368   
     1369    
     1370  SUBROUTINE wait_message_mpi(message) 
    12471371  USE field_mod 
    12481372  USE domain_mod 
    12491373  USE mpi_mod 
    12501374  USE mpipara 
     1375  USE omp_para 
    12511376  USE trace 
    12521377  IMPLICIT NONE 
     1378    TYPE(t_message) :: message 
     1379 
    12531380    TYPE(t_field),POINTER :: field(:) 
    1254     TYPE(t_request),POINTER :: request(:) 
    12551381    REAL(rstd),POINTER :: rval2d(:)  
    12561382    REAL(rstd),POINTER :: rval3d(:,:)  
    12571383    REAL(rstd),POINTER :: rval4d(:,:,:)  
    1258     REAL(rstd),POINTER :: buffer_r2(:)  
    1259     REAL(rstd),POINTER :: buffer_r3(:,:)  
    1260     REAL(rstd),POINTER :: buffer_r4(:,:,:)  
     1384    REAL(rstd),POINTER :: buffer_r(:)  
    12611385    INTEGER,POINTER :: value(:)  
    12621386    INTEGER,POINTER :: sgn(:)  
    … …  
    12671391    INTEGER :: irecv,isend 
    12681392    INTEGER :: ireq,nreq 
    1269     INTEGER :: ind,n 
    1270     INTEGER :: dim3,dim4 
     1393    INTEGER :: ind,n,l,m,i 
     1394    INTEGER :: dim3,dim4,d3,d4 
     1395    INTEGER :: offset 
     1396 
     1397    IF (.NOT. message%pending) RETURN 
    12711398 
    12721399    CALL trace_start("transfert_mpi") 
    12731400 
     1401    field=>message%field 
     1402    nreq=message%nreq 
     1403     
    12741404    IF (field(1)%data_type==type_real) THEN 
    12751405      IF (field(1)%ndim==2) THEN 
    1276        
    1277         nreq=sum(request(:)%nsend)+sum(request(:)%nrecv) 
    1278         ALLOCATE(mpi_req(nreq)) 
    1279         ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 
    1280      
    1281         ireq=0 
     1406 
     1407!$OMP MASTER 
     1408        IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req,message%status,ierr) 
     1409!$OMP END MASTER 
     1410!$OMP BARRIER 
     1411         
    12821412        DO ind=1,ndomain 
     1413          IF (.NOT. assigned_domain(ind)) CYCLE 
     1414           
    12831415          rval2d=>field(ind)%rval2d 
    1284          
    1285           req=>request(ind) 
    1286           DO isend=1,req%nsend 
    1287             send=>req%send(isend) 
    1288  
    1289             ALLOCATE(send%buffer_r2(send%size)) 
    1290             buffer_r2=>send%buffer_r2 
    1291             value=>send%value 
    1292             DO n=1,send%size 
    1293               buffer_r2(n)=rval2d(value(n)) 
    1294             ENDDO 
    1295  
    1296             ireq=ireq+1 
    1297             CALL MPI_ISEND(buffer_r2,send%size,MPI_REAL8,send%rank,ind,comm_icosa, mpi_req(ireq),ierr) 
    1298           ENDDO 
    1299          
     1416          req=>message%request(ind) 
    13001417          DO irecv=1,req%nrecv 
    13011418            recv=>req%recv(irecv) 
    1302             ALLOCATE(recv%buffer_r2(recv%size)) 
    1303             
    1304             ireq=ireq+1 
    1305             CALL MPI_IRECV(recv%buffer_r2,recv%size,MPI_REAL8,recv%rank,recv%domain,comm_icosa, mpi_req(ireq),ierr) 
     1419            IF (recv%rank/=mpi_rank) THEN 
     1420              ireq=recv%ireq 
     1421              buffer_r=>message%buffers(ireq)%r 
     1422              value=>recv%value 
     1423              sgn=>recv%sign 
     1424              offset=recv%offset 
     1425              DO n=1,recv%size 
     1426                rval2d(value(n))=buffer_r(n+offset)*sgn(n)   
     1427              ENDDO 
     1428 
     1429            ENDIF 
    13061430          ENDDO 
    13071431         
    13081432        ENDDO 
    1309          
    1310         CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
     1433       
     1434       
     1435      ELSE  IF (field(1)%ndim==3) THEN 
     1436 
     1437!$OMP MASTER 
     1438        IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req,message%status,ierr) 
     1439!$OMP END MASTER 
     1440!$OMP BARRIER 
     1441 
    13111442         
    13121443        DO ind=1,ndomain 
    1313           rval2d=>field(ind)%rval2d 
    1314          
    1315           req=>request(ind) 
    1316           DO isend=1,req%nsend 
    1317             send=>req%send(isend) 
    1318             DEALLOCATE(send%buffer_r2) 
    1319           ENDDO 
    1320          
     1444          IF (.NOT. assigned_domain(ind)) CYCLE 
     1445 
     1446          rval3d=>field(ind)%rval3d 
     1447          req=>message%request(ind) 
    13211448          DO irecv=1,req%nrecv 
    13221449            recv=>req%recv(irecv) 
    1323             buffer_r2=>recv%buffer_r2 
    1324             value=>recv%value 
    1325             sgn=>recv%sign 
    1326             DO n=1,recv%size 
    1327               rval2d(value(n))=buffer_r2(n)*sgn(n)   
    1328             ENDDO         
    1329             DEALLOCATE(recv%buffer_r2) 
     1450            IF (recv%rank/=mpi_rank) THEN 
     1451              ireq=recv%ireq 
     1452              buffer_r=>message%buffers(ireq)%r 
     1453              value=>recv%value 
     1454              sgn=>recv%sign 
     1455               
     1456              dim3=size(rval3d,2) 
     1457              offset=recv%offset*dim3 
     1458              DO d3=1,dim3 
     1459                DO n=1,recv%size 
     1460                  rval3d(value(n),d3)=buffer_r(n+offset)*sgn(n)   
     1461                ENDDO 
     1462                offset=offset+recv%size 
     1463              ENDDO   
     1464            ENDIF 
    13301465          ENDDO 
    13311466         
    13321467        ENDDO 
    1333        
    1334        
    1335       ELSE  IF (field(1)%ndim==3) THEN 
    1336        
    1337         nreq=sum(request(:)%nsend)+sum(request(:)%nrecv) 
    1338         ALLOCATE(mpi_req(nreq)) 
    1339         ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 
    1340      
    1341         ireq=0 
     1468 
     1469      ELSE  IF (field(1)%ndim==4) THEN 
     1470!$OMP MASTER 
     1471        IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req,message%status,ierr) 
     1472!$OMP END MASTER 
     1473!$OMP BARRIER 
     1474 
     1475                 
    13421476        DO ind=1,ndomain 
    1343           dim3=size(field(ind)%rval3d,2) 
    1344           rval3d=>field(ind)%rval3d 
    1345          
    1346           req=>request(ind) 
    1347           DO isend=1,req%nsend 
    1348             send=>req%send(isend) 
    1349  
    1350             ALLOCATE(send%buffer_r3(send%size,dim3)) 
    1351             buffer_r3=>send%buffer_r3 
    1352             value=>send%value 
    1353             DO n=1,send%size 
    1354               buffer_r3(n,:)=rval3d(value(n),:) 
    1355             ENDDO 
    1356  
    1357             ireq=ireq+1 
    1358             CALL MPI_ISEND(buffer_r3,send%size*dim3,MPI_REAL8,send%rank,ind,comm_icosa, mpi_req(ireq),ierr) 
    1359           ENDDO 
    1360          
     1477          IF (.NOT. assigned_domain(ind)) CYCLE 
     1478 
     1479          rval4d=>field(ind)%rval4d 
     1480          req=>message%request(ind) 
    13611481          DO irecv=1,req%nrecv 
    13621482            recv=>req%recv(irecv) 
    1363             ALLOCATE(recv%buffer_r3(recv%size,dim3)) 
    1364             
    1365             ireq=ireq+1 
    1366             CALL MPI_IRECV(recv%buffer_r3,recv%size*dim3,MPI_REAL8,recv%rank,recv%domain,comm_icosa, mpi_req(ireq),ierr) 
     1483            IF (recv%rank/=mpi_rank) THEN 
     1484              ireq=recv%ireq 
     1485              buffer_r=>message%buffers(ireq)%r 
     1486              value=>recv%value 
     1487              sgn=>recv%sign 
     1488 
     1489              dim3=size(rval4d,2) 
     1490              dim4=size(rval4d,3) 
     1491              offset=recv%offset*dim3*dim4 
     1492              DO d4=1,dim4 
     1493                DO d3=1,dim3 
     1494                  DO n=1,recv%size 
     1495                    rval4d(value(n),d3,d4)=buffer_r(n+offset)*sgn(n)  
     1496                  ENDDO 
     1497                  offset=offset+recv%size 
     1498                ENDDO 
     1499              ENDDO 
     1500            ENDIF 
    13671501          ENDDO 
    13681502         
    13691503        ENDDO 
    1370          
    1371         CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    1372          
    1373         DO ind=1,ndomain 
    1374           rval3d=>field(ind)%rval3d 
    1375          
    1376           req=>request(ind) 
    1377           DO isend=1,req%nsend 
    1378             send=>req%send(isend) 
    1379             DEALLOCATE(send%buffer_r3) 
    1380           ENDDO 
    1381          
    1382           DO irecv=1,req%nrecv 
    1383             recv=>req%recv(irecv) 
    1384             buffer_r3=>recv%buffer_r3 
    1385             value=>recv%value 
    1386             sgn=>recv%sign 
    1387             DO n=1,recv%size 
    1388               rval3d(value(n),:)=buffer_r3(n,:)*sgn(n)   
    1389             ENDDO         
    1390             DEALLOCATE(recv%buffer_r3) 
    1391           ENDDO 
    1392          
    1393         ENDDO 
    1394  
    1395       ELSE  IF (field(1)%ndim==4) THEN 
    1396        
    1397         nreq=sum(request(:)%nsend)+sum(request(:)%nrecv) 
    1398         ALLOCATE(mpi_req(nreq)) 
    1399         ALLOCATE(status(MPI_STATUS_SIZE,nreq)) 
    1400      
    1401         ireq=0 
    1402         DO ind=1,ndomain 
    1403           dim3=size(field(ind)%rval4d,2) 
    1404           dim4=size(field(ind)%rval4d,3) 
    1405           rval4d=>field(ind)%rval4d 
    1406          
    1407           req=>request(ind) 
    1408           DO isend=1,req%nsend 
    1409             send=>req%send(isend) 
    1410  
    1411             ALLOCATE(send%buffer_r4(send%size,dim3,dim4)) 
    1412             buffer_r4=>send%buffer_r4 
    1413             value=>send%value 
    1414             DO n=1,send%size 
    1415               buffer_r4(n,:,:)=rval4d(value(n),:,:) 
    1416             ENDDO 
    1417  
    1418             ireq=ireq+1 
    1419             CALL MPI_ISEND(buffer_r4,send%size*dim3*dim4,MPI_REAL8,send%rank,ind,comm_icosa, mpi_req(ireq),ierr) 
    1420           ENDDO 
    1421          
    1422           DO irecv=1,req%nrecv 
    1423             recv=>req%recv(irecv) 
    1424             ALLOCATE(recv%buffer_r4(recv%size,dim3,dim4)) 
    1425             
    1426             ireq=ireq+1 
    1427             CALL MPI_IRECV(recv%buffer_r4,recv%size*dim3*dim4,MPI_REAL8,recv%rank,recv%domain,comm_icosa, mpi_req(ireq),ierr) 
    1428           ENDDO 
    1429          
    1430         ENDDO 
    1431          
    1432         CALL MPI_WAITALL(nreq,mpi_req,status,ierr) 
    1433          
    1434         DO ind=1,ndomain 
    1435           rval4d=>field(ind)%rval4d 
    1436          
    1437           req=>request(ind) 
    1438           DO isend=1,req%nsend 
    1439             send=>req%send(isend) 
    1440             DEALLOCATE(send%buffer_r4) 
    1441           ENDDO 
    1442          
    1443           DO irecv=1,req%nrecv 
    1444             recv=>req%recv(irecv) 
    1445             buffer_r4=>recv%buffer_r4 
    1446             value=>recv%value 
    1447             sgn=>recv%sign 
    1448             DO n=1,recv%size 
    1449               rval4d(value(n),:,:)=buffer_r4(n,:,:)*sgn(n)  
    1450             ENDDO         
    1451             DEALLOCATE(recv%buffer_r4) 
    1452           ENDDO 
    1453          
    1454         ENDDO 
    14551504       
    14561505      ENDIF       
    … …  
    14581507    ENDIF 
    14591508 
     1509!$OMP MASTER 
     1510    message%pending=.FALSE. 
     1511!$OMP END MASTER 
     1512 
    14601513    CALL trace_end("transfert_mpi") 
    1461      
     1514!$OMP BARRIER 
     1515     
     1516  END SUBROUTINE wait_message_mpi 
     1517 
     1518  SUBROUTINE transfert_request_mpi(field,request) 
     1519  USE field_mod 
     1520  IMPLICIT NONE 
     1521    TYPE(t_field),POINTER :: field(:) 
     1522    TYPE(t_request),POINTER :: request(:) 
     1523 
     1524    TYPE(t_message),SAVE :: message 
     1525    
     1526    
     1527    CALL init_message_mpi(field,request, message) 
     1528    CALL transfert_message_mpi(field,message) 
     1529    CALL finalize_message_mpi(field,message) 
     1530    
    14621531  END SUBROUTINE transfert_request_mpi 
     1532  
     1533    
    14631534    
    14641535  SUBROUTINE transfert_request_seq(field,request) 
Note: See TracChangeset for help on using the changeset viewer.