source: codes/icosagcm/trunk/src/transfert_mpi.f90 @ 187

Last change on this file since 187 was 186, checked in by ymipsl, 10 years ago

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 size: 47.5 KB
Line 
1MODULE transfert_mpi_mod
2USE genmod
3USE field_mod
4 
5  TYPE array
6    INTEGER,POINTER :: value(:)
7    INTEGER,POINTER :: sign(:)
8    INTEGER         :: domain
9    INTEGER         :: rank
10    INTEGER         :: tag
11    INTEGER         :: size
12    INTEGER         :: offset
13    INTEGER         :: ireq
14    INTEGER,POINTER :: buffer(:)
15    REAL,POINTER    :: buffer_r(:)
16    INTEGER,POINTER :: src_value(:)
17  END TYPE array
18 
19  TYPE t_buffer
20    REAL,POINTER    :: r(:)
21    INTEGER         :: size
22    INTEGER         :: rank
23  END TYPE t_buffer   
24   
25  TYPE t_request
26    INTEGER :: type_field
27    INTEGER :: max_size
28    INTEGER :: size
29    LOGICAL :: vector
30    INTEGER,POINTER :: src_domain(:)
31    INTEGER,POINTER :: src_i(:)
32    INTEGER,POINTER :: src_j(:)
33    INTEGER,POINTER :: src_ind(:)
34    INTEGER,POINTER :: target_ind(:)
35    INTEGER,POINTER :: target_i(:)
36    INTEGER,POINTER :: target_j(:)
37    INTEGER,POINTER :: target_sign(:)
38    INTEGER :: nrecv
39    TYPE(ARRAY),POINTER :: recv(:)
40    INTEGER :: nsend
41    INTEGER :: nreq_mpi
42    INTEGER :: nreq_send
43    INTEGER :: nreq_recv
44    TYPE(ARRAY),POINTER :: send(:)
45  END TYPE t_request
46 
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 
61 
62  TYPE t_message
63    TYPE(t_request), POINTER :: request(:)
64    INTEGER :: nreq
65    INTEGER :: nreq_send
66    INTEGER :: nreq_recv
67    TYPE(t_reorder), POINTER :: reorder(:)
68    INTEGER, POINTER :: mpi_req(:)
69    INTEGER, POINTER :: status(:,:)
70    TYPE(t_buffer),POINTER :: buffers(:) 
71    TYPE(t_field),POINTER :: field(:)
72    LOGICAL :: completed
73    LOGICAL :: pending
74    INTEGER :: number
75  END TYPE t_message
76 
77CONTAINS
78       
79     
80  SUBROUTINE init_transfert
81  USE domain_mod
82  USE dimensions
83  USE field_mod
84  USE metric
85  USE mpipara
86  USE mpi_mod
87  IMPLICIT NONE
88  INTEGER :: ind,i,j
89  LOGICAL ::ok
90 
91    CALL create_request(field_t,req_i1)
92
93    DO ind=1,ndomain
94      CALL swap_dimensions(ind)
95      DO i=ii_begin,ii_end+1
96        CALL request_add_point(ind,i,jj_begin-1,req_i1)
97      ENDDO
98
99      DO j=jj_begin,jj_end
100        CALL request_add_point(ind,ii_end+1,j,req_i1)
101      ENDDO   
102      DO i=ii_begin,ii_end
103        CALL request_add_point(ind,i,jj_end+1,req_i1)
104      ENDDO   
105
106      DO j=jj_begin,jj_end+1
107        CALL request_add_point(ind,ii_begin-1,j,req_i1)
108      ENDDO   
109   
110    ENDDO
111 
112    CALL finalize_request(req_i1)
113
114
115    CALL create_request(field_t,req_i0)
116
117    DO ind=1,ndomain
118      CALL swap_dimensions(ind)
119   
120      DO i=ii_begin,ii_end
121        CALL request_add_point(ind,i,jj_begin,req_i0)
122      ENDDO
123
124      DO j=jj_begin,jj_end
125        CALL request_add_point(ind,ii_end,j,req_i0)
126      ENDDO   
127   
128      DO i=ii_begin,ii_end
129        CALL request_add_point(ind,i,jj_end,req_i0)
130      ENDDO   
131
132      DO j=jj_begin,jj_end
133        CALL request_add_point(ind,ii_begin,j,req_i0)
134      ENDDO   
135   
136    ENDDO
137 
138    CALL finalize_request(req_i0) 
139
140
141    CALL create_request(field_u,req_e1_scal)
142    DO ind=1,ndomain
143      CALL swap_dimensions(ind)
144      DO i=ii_begin,ii_end
145        CALL request_add_point(ind,i,jj_begin-1,req_e1_scal,rup)
146        CALL request_add_point(ind,i+1,jj_begin-1,req_e1_scal,lup)
147      ENDDO
148
149      DO j=jj_begin,jj_end
150        CALL request_add_point(ind,ii_end+1,j,req_e1_scal,left)
151        CALL request_add_point(ind,ii_end+1,j-1,req_e1_scal,lup)
152      ENDDO   
153   
154      DO i=ii_begin,ii_end
155        CALL request_add_point(ind,i,jj_end+1,req_e1_scal,ldown)
156        CALL request_add_point(ind,i-1,jj_end+1,req_e1_scal,rdown)
157      ENDDO   
158
159      DO j=jj_begin,jj_end
160        CALL request_add_point(ind,ii_begin-1,j,req_e1_scal,right)
161        CALL request_add_point(ind,ii_begin-1,j+1,req_e1_scal,rdown)
162      ENDDO   
163
164    ENDDO
165
166    CALL finalize_request(req_e1_scal)
167
168
169    CALL create_request(field_u,req_e0_scal)
170    DO ind=1,ndomain
171      CALL swap_dimensions(ind)
172
173
174      DO i=ii_begin+1,ii_end-1
175        CALL request_add_point(ind,i,jj_begin,req_e0_scal,right)
176        CALL request_add_point(ind,i,jj_end,req_e0_scal,right)
177      ENDDO
178   
179      DO j=jj_begin+1,jj_end-1
180        CALL request_add_point(ind,ii_begin,j,req_e0_scal,rup)
181        CALL request_add_point(ind,ii_end,j,req_e0_scal,rup)
182      ENDDO   
183
184      CALL request_add_point(ind,ii_begin+1,jj_begin,req_e0_scal,left)
185      CALL request_add_point(ind,ii_begin,jj_begin+1,req_e0_scal,ldown)
186      CALL request_add_point(ind,ii_begin+1,jj_end,req_e0_scal,left)
187      CALL request_add_point(ind,ii_end,jj_begin+1,req_e0_scal,ldown)
188
189    ENDDO
190
191    CALL finalize_request(req_e0_scal)
192
193
194   
195    CALL create_request(field_u,req_e1_vect,.TRUE.)
196    DO ind=1,ndomain
197      CALL swap_dimensions(ind)
198      DO i=ii_begin,ii_end
199        CALL request_add_point(ind,i,jj_begin-1,req_e1_vect,rup)
200        CALL request_add_point(ind,i+1,jj_begin-1,req_e1_vect,lup)
201      ENDDO
202
203      DO j=jj_begin,jj_end
204        CALL request_add_point(ind,ii_end+1,j,req_e1_vect,left)
205        CALL request_add_point(ind,ii_end+1,j-1,req_e1_vect,lup)
206      ENDDO   
207   
208      DO i=ii_begin,ii_end
209        CALL request_add_point(ind,i,jj_end+1,req_e1_vect,ldown)
210        CALL request_add_point(ind,i-1,jj_end+1,req_e1_vect,rdown)
211      ENDDO   
212
213      DO j=jj_begin,jj_end
214        CALL request_add_point(ind,ii_begin-1,j,req_e1_vect,right)
215        CALL request_add_point(ind,ii_begin-1,j+1,req_e1_vect,rdown)
216      ENDDO   
217
218 
219    ENDDO 
220
221    CALL finalize_request(req_e1_vect)
222   
223   
224    CALL create_request(field_u,req_e0_vect,.TRUE.)
225    DO ind=1,ndomain
226      CALL swap_dimensions(ind)
227 
228      DO i=ii_begin+1,ii_end-1
229        CALL request_add_point(ind,i,jj_begin,req_e0_vect,right)
230        CALL request_add_point(ind,i,jj_end,req_e0_vect,right)
231      ENDDO
232   
233      DO j=jj_begin+1,jj_end-1
234        CALL request_add_point(ind,ii_begin,j,req_e0_vect,rup)
235        CALL request_add_point(ind,ii_end,j,req_e0_vect,rup)
236      ENDDO   
237
238      CALL request_add_point(ind,ii_begin+1,jj_begin,req_e0_vect,left)
239      CALL request_add_point(ind,ii_begin,jj_begin+1,req_e0_vect,ldown)
240      CALL request_add_point(ind,ii_begin+1,jj_end,req_e0_vect,left)
241      CALL request_add_point(ind,ii_end,jj_begin+1,req_e0_vect,ldown)
242 
243    ENDDO 
244
245    CALL finalize_request(req_e0_vect)
246
247
248  END SUBROUTINE init_transfert
249 
250  SUBROUTINE create_request(type_field,request,vector)
251  USE domain_mod
252  USE field_mod
253  IMPLICIT NONE
254    INTEGER :: type_field
255    TYPE(t_request),POINTER :: request(:)
256    LOGICAL,OPTIONAL :: vector
257   
258    TYPE(t_request),POINTER :: req
259    TYPE(t_domain),POINTER :: d
260    INTEGER :: ind
261    INTEGER :: max_size
262       
263    ALLOCATE(request(ndomain))
264
265    DO ind=1,ndomain
266      req=>request(ind)
267      d=>domain(ind)
268      IF (type_field==field_t) THEN
269        Max_size=2*(d%iim+2)+2*(d%jjm+2)
270      ELSE IF (type_field==field_u) THEN
271        Max_size=3*(2*(d%iim+2)+2*(d%jjm+2))
272      ELSE IF (type_field==field_z) THEN
273        Max_size=2*(2*(d%iim+2)+2*(d%jjm+2))
274      ENDIF
275
276      req%type_field=type_field
277      req%max_size=max_size*2
278      req%size=0
279      req%vector=.FALSE.
280      IF (PRESENT(vector)) req%vector=vector
281      ALLOCATE(req%src_domain(req%max_size))
282      ALLOCATE(req%src_ind(req%max_size))
283      ALLOCATE(req%target_ind(req%max_size))
284      ALLOCATE(req%src_i(req%max_size))
285      ALLOCATE(req%src_j(req%max_size))
286      ALLOCATE(req%target_i(req%max_size))
287      ALLOCATE(req%target_j(req%max_size))
288      ALLOCATE(req%target_sign(req%max_size))
289    ENDDO
290 
291  END SUBROUTINE create_request
292
293  SUBROUTINE reallocate_request(req)
294  IMPLICIT NONE
295    TYPE(t_request),POINTER :: req
296     
297    INTEGER,POINTER :: src_domain(:)
298    INTEGER,POINTER :: src_ind(:)
299    INTEGER,POINTER :: target_ind(:)
300    INTEGER,POINTER :: src_i(:)
301    INTEGER,POINTER :: src_j(:)
302    INTEGER,POINTER :: target_i(:)
303    INTEGER,POINTER :: target_j(:)
304    INTEGER,POINTER :: target_sign(:)
305
306    PRINT *,"REALLOCATE_REQUEST"
307    src_domain=>req%src_domain
308    src_ind=>req%src_ind
309    target_ind=>req%target_ind
310    src_i=>req%src_i
311    src_j=>req%src_j
312    target_i=>req%target_i
313    target_j=>req%target_j
314    target_sign=>req%target_sign
315
316    ALLOCATE(req%src_domain(req%max_size*2))
317    ALLOCATE(req%src_ind(req%max_size*2))
318    ALLOCATE(req%target_ind(req%max_size*2))
319    ALLOCATE(req%src_i(req%max_size*2))
320    ALLOCATE(req%src_j(req%max_size*2))
321    ALLOCATE(req%target_i(req%max_size*2))
322    ALLOCATE(req%target_j(req%max_size*2))
323    ALLOCATE(req%target_sign(req%max_size*2))
324   
325    req%src_domain(1:req%max_size)=src_domain(:)
326    req%src_ind(1:req%max_size)=src_ind(:)
327    req%target_ind(1:req%max_size)=target_ind(:)
328    req%src_i(1:req%max_size)=src_i(:)
329    req%src_j(1:req%max_size)=src_j(:)
330    req%target_i(1:req%max_size)=target_i(:)
331    req%target_j(1:req%max_size)=target_j(:)
332    req%target_sign(1:req%max_size)=target_sign(:)
333   
334    req%max_size=req%max_size*2
335         
336    DEALLOCATE(src_domain)
337    DEALLOCATE(src_ind)
338    DEALLOCATE(target_ind)
339    DEALLOCATE(src_i)
340    DEALLOCATE(src_j)
341    DEALLOCATE(target_i)
342    DEALLOCATE(target_j)
343    DEALLOCATE(target_sign)
344
345  END SUBROUTINE reallocate_request
346
347     
348    SUBROUTINE request_add_point(ind,i,j,request,pos)
349    USE domain_mod
350    USE field_mod
351    IMPLICIT NONE
352      INTEGER,INTENT(IN)            ::  ind
353      INTEGER,INTENT(IN)            :: i
354      INTEGER,INTENT(IN)            :: j
355      TYPE(t_request),POINTER :: request(:)
356      INTEGER,INTENT(IN),OPTIONAL  :: pos
357     
358      INTEGER :: src_domain
359      INTEGER :: src_iim,src_i,src_j,src_n,src_pos,src_delta
360      TYPE(t_request),POINTER :: req
361      TYPE(t_domain),POINTER :: d
362     
363      req=>request(ind)
364      d=>domain(ind)
365     
366      IF (req%max_size==req%size) CALL reallocate_request(req)
367      req%size=req%size+1
368      IF (req%type_field==field_t) THEN
369        src_domain=domain(ind)%assign_domain(i,j)
370        src_iim=domain_glo(src_domain)%iim
371        src_i=domain(ind)%assign_i(i,j)
372        src_j=domain(ind)%assign_j(i,j)
373
374        req%target_ind(req%size)=(j-1)*d%iim+i
375        req%target_sign(req%size)=1
376        req%src_domain(req%size)=src_domain
377        req%src_ind(req%size)=(src_j-1)*src_iim+src_i
378      ELSE IF (req%type_field==field_u) THEN
379        IF (.NOT. PRESENT(pos)) STOP 'argument request_add_point non conforme'
380
381        src_domain=domain(ind)%edge_assign_domain(pos-1,i,j)
382        src_iim=domain_glo(src_domain)%iim
383        src_i=domain(ind)%edge_assign_i(pos-1,i,j)
384        src_j=domain(ind)%edge_assign_j(pos-1,i,j)
385        src_n=(src_j-1)*src_iim+src_i
386        src_delta=domain(ind)%delta(i,j)
387        src_pos=domain(ind)%edge_assign_pos(pos-1,i,j)+1
388               
389        req%target_ind(req%size)=(j-1)*d%iim+i+d%u_pos(pos)
390
391        req%target_sign(req%size)= 1
392        IF (req%vector) req%target_sign(req%size)= domain(ind)%edge_assign_sign(pos-1,i,j)
393
394        req%src_domain(req%size)=src_domain
395        req%src_ind(req%size)=src_n+domain_glo(src_domain)%u_pos(src_pos)
396
397      ELSE IF (req%type_field==field_z) THEN
398        IF (.NOT. PRESENT(pos)) STOP 'argument request_add_point non conforme'
399
400        src_domain=domain(ind)%assign_domain(i,j)
401        src_iim=domain_glo(src_domain)%iim
402        src_i=domain(ind)%assign_i(i,j)
403        src_j=domain(ind)%assign_j(i,j)
404        src_n=(src_j-1)*src_iim+src_i
405        src_delta=domain(ind)%delta(i,j)
406       
407        src_pos=MOD(pos-1+src_delta+6,6)+1
408       
409        req%target_ind(req%size)=(j-1)*d%iim+i+d%z_pos(pos)
410        req%target_sign(req%size)=1
411        req%src_domain(req%size)=src_domain
412        req%src_ind(req%size)=src_n+domain_glo(src_domain)%z_pos(src_pos)
413      ENDIF
414  END SUBROUTINE request_add_point
415 
416 
417  SUBROUTINE Finalize_request(request)
418  USE mpipara
419  USE domain_mod
420  USE mpi_mod
421  IMPLICIT NONE
422    TYPE(t_request),POINTER :: request(:)
423    TYPE(t_request),POINTER :: req, req_src
424    INTEGER :: nb_domain_recv(0:mpi_size-1)
425    INTEGER :: nb_domain_send(0:mpi_size-1)
426    INTEGER :: tag_rank(0:mpi_size-1)
427    INTEGER :: nb_data_domain_recv(ndomain_glo)
428    INTEGER :: list_domain_recv(ndomain_glo)
429    INTEGER,ALLOCATABLE :: list_domain_send(:)
430    INTEGER             :: list_domain(ndomain)
431
432    INTEGER :: rank,i,j,pos
433    INTEGER :: size_,ind_glo,ind_loc, ind_src
434    INTEGER :: isend, irecv, ireq, nreq, nsend, nrecv
435    INTEGER, ALLOCATABLE :: mpi_req(:)
436    INTEGER, ALLOCATABLE :: status(:,:)
437    INTEGER, ALLOCATABLE :: rank_list(:)
438    INTEGER, ALLOCATABLE :: offset(:)
439    LOGICAL,PARAMETER :: debug = .FALSE.
440
441 
442    IF (.NOT. using_mpi) RETURN
443   
444    DO ind_loc=1,ndomain
445      req=>request(ind_loc)
446     
447      nb_data_domain_recv(:) = 0
448      nb_domain_recv(:) = 0
449      tag_rank(:)=0
450     
451      DO i=1,req%size
452        ind_glo=req%src_domain(i)
453        nb_data_domain_recv(ind_glo)=nb_data_domain_recv(ind_glo)+1
454      ENDDO
455 
456      DO ind_glo=1,ndomain_glo
457        IF ( nb_data_domain_recv(ind_glo) > 0 )  nb_domain_recv(domglo_rank(ind_glo))=nb_domain_recv(domglo_rank(ind_glo))+1
458      ENDDO
459
460      req%nrecv=sum(nb_domain_recv(:))
461      ALLOCATE(req%recv(req%nrecv))
462
463      irecv=0
464      DO ind_glo=1,ndomain_glo
465        IF (nb_data_domain_recv(ind_glo)>0) THEN
466          irecv=irecv+1
467          list_domain_recv(ind_glo)=irecv
468          req%recv(irecv)%rank=domglo_rank(ind_glo)
469          req%recv(irecv)%size=nb_data_domain_recv(ind_glo)
470          req%recv(irecv)%domain=domglo_loc_ind(ind_glo)
471          ALLOCATE(req%recv(irecv)%value(req%recv(irecv)%size))
472          ALLOCATE(req%recv(irecv)%sign(req%recv(irecv)%size))
473          ALLOCATE(req%recv(irecv)%buffer(req%recv(irecv)%size))
474        ENDIF
475      ENDDO
476     
477      req%recv(:)%size=0
478      irecv=0
479      DO i=1,req%size
480        irecv=list_domain_recv(req%src_domain(i))
481        req%recv(irecv)%size=req%recv(irecv)%size+1
482        size_=req%recv(irecv)%size
483        req%recv(irecv)%value(size_)=req%src_ind(i)
484        req%recv(irecv)%buffer(size_)=req%target_ind(i)
485        req%recv(irecv)%sign(size_)=req%target_sign(i)
486      ENDDO
487    ENDDO
488
489    nb_domain_recv(:) = 0   
490    DO ind_loc=1,ndomain
491      req=>request(ind_loc)
492     
493      DO irecv=1,req%nrecv
494        rank=req%recv(irecv)%rank
495        nb_domain_recv(rank)=nb_domain_recv(rank)+1
496      ENDDO
497    ENDDO
498   
499    CALL MPI_Alltoall(nb_domain_recv,1,MPI_INTEGER,nb_domain_send,1,MPI_INTEGER,comm_icosa,ierr)     
500   
501
502    ALLOCATE(list_domain_send(sum(nb_domain_send)))
503   
504    nreq=sum(nb_domain_recv(:))+sum(nb_domain_send(:))
505    ALLOCATE(mpi_req(nreq))
506    ALLOCATE(status(MPI_STATUS_SIZE,nreq))
507   
508
509    ireq=0
510    DO ind_loc=1,ndomain
511      req=>request(ind_loc)
512      DO irecv=1,req%nrecv
513        ireq=ireq+1
514        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
516      ENDDO
517    ENDDO
518
519    IF (debug) PRINT *,"------------"   
520    j=0
521    DO rank=0,mpi_size-1
522      DO i=1,nb_domain_send(rank)
523        j=j+1
524        ireq=ireq+1
525        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
527      ENDDO
528    ENDDO
529    IF (debug) PRINT *,"------------"   
530   
531    CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
532   
533    list_domain(:)=0
534    DO i=1,sum(nb_domain_send)
535      ind_loc=list_domain_send(i)
536      list_domain(ind_loc)=list_domain(ind_loc)+1
537    ENDDO
538   
539    DO ind_loc=1,ndomain
540      req=>request(ind_loc)
541      req%nsend=list_domain(ind_loc)
542      ALLOCATE(req%send(req%nsend))
543    ENDDO
544
545    IF (debug) PRINT *,"------------"   
546   
547   ireq=0 
548   DO ind_loc=1,ndomain
549     req=>request(ind_loc)
550     
551     DO irecv=1,req%nrecv
552       ireq=ireq+1
553       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
555     ENDDO
556    IF (debug) PRINT *,"------------"   
557     
558     DO isend=1,req%nsend
559       ireq=ireq+1
560       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
562     ENDDO
563   ENDDO
564
565   IF (debug) PRINT *,"------------"   
566
567   CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
568   CALL MPI_BARRIER(comm_icosa,ierr)
569
570   IF (debug) PRINT *,"------------"   
571
572   ireq=0 
573   DO ind_loc=1,ndomain
574     req=>request(ind_loc)
575     
576     DO irecv=1,req%nrecv
577       ireq=ireq+1
578       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
580     ENDDO
581
582     IF (debug) PRINT *,"------------"   
583     
584     DO isend=1,req%nsend
585       ireq=ireq+1
586       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
588     ENDDO
589   ENDDO
590   IF (debug) PRINT *,"------------"   
591   
592   CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
593   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 *,"------------"   
622
623   ireq=0 
624   DO ind_loc=1,ndomain
625     req=>request(ind_loc)
626     
627     DO irecv=1,req%nrecv
628       ireq=ireq+1
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
631     ENDDO
632     IF (debug) PRINT *,"------------"   
633     
634     DO isend=1,req%nsend
635       ireq=ireq+1
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
638     ENDDO
639   ENDDO
640
641   CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
642
643   ireq=0 
644   DO ind_loc=1,ndomain
645     req=>request(ind_loc)
646     
647     DO irecv=1,req%nrecv
648       ireq=ireq+1
649       CALL MPI_ISEND(req%recv(irecv)%value,req%recv(irecv)%size,MPI_INTEGER,&
650            req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr)
651     ENDDO
652     
653     DO isend=1,req%nsend
654       ireq=ireq+1
655       ALLOCATE(req%send(isend)%value(req%send(isend)%size))
656       CALL MPI_IRECV(req%send(isend)%value,req%send(isend)%size,MPI_INTEGER,&
657            req%send(isend)%rank,req%send(isend)%tag,comm_icosa, mpi_req(ireq),ierr)
658     ENDDO
659   ENDDO
660
661   CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
662
663   DO ind_loc=1,ndomain
664     req=>request(ind_loc)
665     
666     DO irecv=1,req%nrecv
667       req%recv(irecv)%value(:)=req%recv(irecv)%buffer(:)
668       req%recv(irecv)%sign(:) =req%recv(irecv)%sign(:)
669       DEALLOCATE(req%recv(irecv)%buffer)
670     ENDDO
671   ENDDO 
672   
673
674! domain is on the same mpi process => copie memory to memory
675   
676   DO ind_loc=1,ndomain
677     req=>request(ind_loc)
678     
679     DO irecv=1,req%nrecv
680   
681       IF (req%recv(irecv)%rank==mpi_rank) THEN
682           req_src=>request(req%recv(irecv)%domain)
683           DO isend=1,req_src%nsend
684             IF (req_src%send(isend)%rank==mpi_rank .AND. req_src%send(isend)%tag==req%recv(irecv)%tag) THEN
685               req%recv(irecv)%src_value => req_src%send(isend)%value
686               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)
688                 STOP "size(req%recv(irecv)%value) /= size(req_src%send(isend)%value"
689               ENDIF
690             ENDIF
691           ENDDO
692       ENDIF
693     
694     ENDDO
695   ENDDO
696   
697! 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
707   DO ind_loc=1,ndomain
708     req=>request(ind_loc)
709
710     DO isend=1,req%nsend
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
734     ENDDO
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
748     DO irecv=1,req%nrecv
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
772     ENDDO
773   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     
796       
797  END SUBROUTINE Finalize_request 
798
799
800  SUBROUTINE init_message_seq(field, request, message)
801  USE field_mod
802  USE domain_mod
803  USE mpi_mod
804  USE mpipara
805  USE mpi_mod
806  IMPLICIT NONE
807    TYPE(t_field),POINTER :: field(:)
808    TYPE(t_request),POINTER :: request(:)
809    TYPE(t_message) :: message
810
811!$OMP MASTER   
812    message%request=>request
813!$OMP END MASTER   
814!$OMP BARRIER   
815
816  END SUBROUTINE init_message_seq
817
818  SUBROUTINE send_message_seq(field,message)
819  USE field_mod
820  USE domain_mod
821  USE mpi_mod
822  USE mpipara
823  USE omp_para
824  USE trace
825  IMPLICIT NONE
826    TYPE(t_field),POINTER :: field(:)
827    TYPE(t_message) :: message
828
829    CALL transfert_request_seq(field,message%request)
830   
831  END SUBROUTINE send_message_seq
832 
833  SUBROUTINE test_message_seq(message)
834  IMPLICIT NONE
835    TYPE(t_message) :: message
836  END SUBROUTINE  test_message_seq
837 
838   
839  SUBROUTINE wait_message_seq(message)
840  IMPLICIT NONE
841    TYPE(t_message) :: message
842   
843  END SUBROUTINE wait_message_seq   
844
845  SUBROUTINE transfert_message_seq(field,message)
846  USE field_mod
847  USE domain_mod
848  USE mpi_mod
849  USE mpipara
850  USE omp_para
851  USE trace
852  IMPLICIT NONE
853    TYPE(t_field),POINTER :: field(:)
854    TYPE(t_message) :: message
855
856   CALL send_message_seq(field,message)
857   
858  END SUBROUTINE transfert_message_seq   
859   
860
861
862   
863  SUBROUTINE init_message_mpi(field,request, message)
864  USE field_mod
865  USE domain_mod
866  USE mpi_mod
867  USE mpipara
868  USE mpi_mod
869  IMPLICIT NONE
870 
871    TYPE(t_field),POINTER :: field(:)
872    TYPE(t_request),POINTER :: request(:)
873    TYPE(t_message) :: message
874
875    TYPE(ARRAY),POINTER :: recv,send 
876    TYPE(t_request),POINTER :: req
877    INTEGER :: irecv,isend
878    INTEGER :: ireq,nreq, nreq_send
879    INTEGER :: ind
880    INTEGER :: dim3,dim4
881    INTEGER :: i,j
882    INTEGER :: message_number
883!    TYPE(t_reorder),POINTER :: reorder(:)
884!    TYPE(t_reorder) :: reorder_swap
885
886!$OMP BARRIER
887!$OMP MASTER
888    message%number=message_number
889    message_number=message_number+1
890    IF (message_number==100) message_number=0
891
892 
893    message%request=>request
894    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
899    ALLOCATE(message%mpi_req(nreq))
900    ALLOCATE(message%buffers(nreq))
901    ALLOCATE(message%status(MPI_STATUS_SIZE,nreq))
902    message%buffers(:)%size=0
903    message%pending=.FALSE.
904    message%completed=.FALSE.
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
925    IF (field(1)%data_type==type_real) THEN
926
927      IF (field(1)%ndim==2) THEN
928     
929        DO ireq=1,message%nreq
930          CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size)
931        ENDDO
932     
933      ELSE  IF (field(1)%ndim==3) THEN
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     
941      ELSE  IF (field(1)%ndim==4) THEN
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
948      ENDIF     
949    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 
983!$OMP END MASTER
984!$OMP BARRIER   
985
986  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
1039 
1040  SUBROUTINE barrier
1041  USE mpi_mod
1042  USE mpipara
1043  IMPLICIT NONE
1044   
1045    CALL MPI_BARRIER(comm_icosa,ierr)
1046   
1047  END SUBROUTINE barrier 
1048   
1049  SUBROUTINE transfert_message_mpi(field,message)
1050  USE field_mod
1051  IMPLICIT NONE
1052    TYPE(t_field),POINTER :: field(:)
1053    TYPE(t_message) :: message
1054   
1055    CALL send_message_mpi(field,message)
1056    CALL wait_message_mpi(message)
1057   
1058  END SUBROUTINE transfert_message_mpi
1059
1060
1061  SUBROUTINE send_message_mpi(field,message)
1062  USE field_mod
1063  USE domain_mod
1064  USE mpi_mod
1065  USE mpipara
1066  USE omp_para
1067  USE trace
1068  IMPLICIT NONE
1069    TYPE(t_field),POINTER :: field(:)
1070    TYPE(t_message) :: message
1071    REAL(rstd),POINTER :: rval2d(:), src_rval2d(:) 
1072    REAL(rstd),POINTER :: rval3d(:,:), src_rval3d(:,:) 
1073    REAL(rstd),POINTER :: rval4d(:,:,:), src_rval4d(:,:,:) 
1074    REAL(rstd),POINTER :: buffer_r(:) 
1075    INTEGER,POINTER :: value(:) 
1076    INTEGER,POINTER :: sgn(:) 
1077    TYPE(ARRAY),POINTER :: recv,send 
1078    TYPE(t_request),POINTER :: req
1079    INTEGER, ALLOCATABLE :: mpi_req(:)
1080    INTEGER, ALLOCATABLE :: status(:,:)
1081    INTEGER :: irecv,isend
1082    INTEGER :: ireq,nreq
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")
1090
1091!$OMP BARRIER
1092
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     
1107    IF (field(1)%data_type==type_real) THEN
1108      IF (field(1)%ndim==2) THEN
1109
1110        DO ind=1,ndomain
1111          IF (.NOT. assigned_domain(ind)) CYCLE
1112         
1113          rval2d=>field(ind)%rval2d
1114       
1115          req=>message%request(ind)
1116          DO isend=1,req%nsend
1117            send=>req%send(isend)
1118            value=>send%value
1119
1120           
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             
1139            ENDIF
1140          ENDDO
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       
1180     
1181      ELSE  IF (field(1)%ndim==3) THEN
1182     
1183        DO ind=1,ndomain
1184          IF (.NOT. assigned_domain(ind)) CYCLE
1185
1186          dim3=size(field(ind)%rval3d,2)
1187          rval3d=>field(ind)%rval3d
1188          req=>message%request(ind)
1189 
1190          DO isend=1,req%nsend
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
1213            ENDIF
1214          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
1249       
1250        ENDDO
1251
1252      ELSE  IF (field(1)%ndim==4) THEN
1253   
1254        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)
1259          rval4d=>field(ind)%rval4d
1260          req=>message%request(ind)
1261
1262          DO isend=1,req%nsend
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
1279              ENDDO
1280
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
1289            ENDIF
1290          ENDDO
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
1329      ENDIF     
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             
1351    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
1363
1364!$OMP MASTER
1365    IF (message%pending .AND. .NOT. message%completed) CALL MPI_TESTALL(message%nreq,message%mpi_req,message%completed,message%status,ierr)
1366!$OMP END MASTER
1367  END SUBROUTINE  test_message_mpi
1368 
1369   
1370  SUBROUTINE wait_message_mpi(message)
1371  USE field_mod
1372  USE domain_mod
1373  USE mpi_mod
1374  USE mpipara
1375  USE omp_para
1376  USE trace
1377  IMPLICIT NONE
1378    TYPE(t_message) :: message
1379
1380    TYPE(t_field),POINTER :: field(:)
1381    REAL(rstd),POINTER :: rval2d(:) 
1382    REAL(rstd),POINTER :: rval3d(:,:) 
1383    REAL(rstd),POINTER :: rval4d(:,:,:) 
1384    REAL(rstd),POINTER :: buffer_r(:) 
1385    INTEGER,POINTER :: value(:) 
1386    INTEGER,POINTER :: sgn(:) 
1387    TYPE(ARRAY),POINTER :: recv,send 
1388    TYPE(t_request),POINTER :: req
1389    INTEGER, ALLOCATABLE :: mpi_req(:)
1390    INTEGER, ALLOCATABLE :: status(:,:)
1391    INTEGER :: irecv,isend
1392    INTEGER :: ireq,nreq
1393    INTEGER :: ind,n,l,m,i
1394    INTEGER :: dim3,dim4,d3,d4
1395    INTEGER :: offset
1396
1397    IF (.NOT. message%pending) RETURN
1398
1399    CALL trace_start("transfert_mpi")
1400
1401    field=>message%field
1402    nreq=message%nreq
1403   
1404    IF (field(1)%data_type==type_real) THEN
1405      IF (field(1)%ndim==2) THEN
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       
1412        DO ind=1,ndomain
1413          IF (.NOT. assigned_domain(ind)) CYCLE
1414         
1415          rval2d=>field(ind)%rval2d
1416          req=>message%request(ind)
1417          DO irecv=1,req%nrecv
1418            recv=>req%recv(irecv)
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
1430          ENDDO
1431       
1432        ENDDO
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
1442       
1443        DO ind=1,ndomain
1444          IF (.NOT. assigned_domain(ind)) CYCLE
1445
1446          rval3d=>field(ind)%rval3d
1447          req=>message%request(ind)
1448          DO irecv=1,req%nrecv
1449            recv=>req%recv(irecv)
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
1465          ENDDO
1466       
1467        ENDDO
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               
1476        DO ind=1,ndomain
1477          IF (.NOT. assigned_domain(ind)) CYCLE
1478
1479          rval4d=>field(ind)%rval4d
1480          req=>message%request(ind)
1481          DO irecv=1,req%nrecv
1482            recv=>req%recv(irecv)
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
1501          ENDDO
1502       
1503        ENDDO
1504     
1505      ENDIF     
1506     
1507    ENDIF
1508
1509!$OMP MASTER
1510    message%pending=.FALSE.
1511!$OMP END MASTER
1512
1513    CALL trace_end("transfert_mpi")
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   
1531  END SUBROUTINE transfert_request_mpi
1532 
1533   
1534   
1535  SUBROUTINE transfert_request_seq(field,request)
1536  USE field_mod
1537  USE domain_mod
1538  IMPLICIT NONE
1539    TYPE(t_field),POINTER :: field(:)
1540    TYPE(t_request),POINTER :: request(:)
1541    REAL(rstd),POINTER :: rval2d(:) 
1542    REAL(rstd),POINTER :: rval3d(:,:) 
1543    REAL(rstd),POINTER :: rval4d(:,:,:) 
1544    INTEGER :: ind
1545    TYPE(t_request),POINTER :: req
1546    INTEGER :: n
1547    REAL(rstd) :: var1,var2
1548   
1549    DO ind=1,ndomain
1550      req=>request(ind)
1551      rval2d=>field(ind)%rval2d
1552      rval3d=>field(ind)%rval3d
1553      rval4d=>field(ind)%rval4d
1554     
1555      IF (field(ind)%data_type==type_real) THEN
1556        IF (field(ind)%ndim==2) THEN
1557          DO n=1,req%size
1558            rval2d(req%target_ind(n))=field(req%src_domain(n))%rval2d(req%src_ind(n))*req%target_sign(n)
1559          ENDDO
1560        ELSE IF (field(ind)%ndim==3) THEN
1561          DO n=1,req%size
1562            rval3d(req%target_ind(n),:)=field(req%src_domain(n))%rval3d(req%src_ind(n),:)*req%target_sign(n)
1563          ENDDO
1564        ELSE IF (field(ind)%ndim==4) THEN
1565          DO n=1,req%size
1566            rval4d(req%target_ind(n),:,:)=field(req%src_domain(n))%rval4d(req%src_ind(n),:,:)*req%target_sign(n)
1567          ENDDO
1568        ENDIF
1569      ENDIF       
1570
1571    ENDDO
1572   
1573  END SUBROUTINE transfert_request_seq
1574 
1575 
1576  SUBROUTINE gather_field(field_loc,field_glo)
1577  USE field_mod
1578  USE domain_mod
1579  USE mpi_mod
1580  USE mpipara
1581  IMPLICIT NONE
1582    TYPE(t_field),POINTER :: field_loc(:)
1583    TYPE(t_field),POINTER :: field_glo(:)
1584    INTEGER, ALLOCATABLE :: mpi_req(:)
1585    INTEGER, ALLOCATABLE :: status(:,:)
1586    INTEGER :: ireq,nreq
1587    INTEGER :: ind_glo,ind_loc   
1588 
1589    IF (.NOT. using_mpi) THEN
1590   
1591      DO ind_loc=1,ndomain
1592        IF (field_loc(ind_loc)%ndim==2) field_glo(ind_loc)%rval2d=field_loc(ind_loc)%rval2d
1593        IF (field_loc(ind_loc)%ndim==3) field_glo(ind_loc)%rval3d=field_loc(ind_loc)%rval3d
1594        IF (field_loc(ind_loc)%ndim==4) field_glo(ind_loc)%rval4d=field_loc(ind_loc)%rval4d
1595      ENDDO
1596   
1597    ELSE
1598         
1599      nreq=ndomain
1600      IF (mpi_rank==0) nreq=nreq+ndomain_glo 
1601      ALLOCATE(mpi_req(nreq))
1602      ALLOCATE(status(MPI_STATUS_SIZE,nreq))
1603   
1604   
1605      ireq=0
1606      IF (mpi_rank==0) THEN
1607        DO ind_glo=1,ndomain_glo
1608          ireq=ireq+1
1609
1610          IF (field_glo(ind_glo)%ndim==2) THEN
1611            CALL MPI_IRECV(field_glo(ind_glo)%rval2d,size(field_glo(ind_glo)%rval2d) , MPI_REAL8 ,   &
1612                         domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
1613   
1614          ELSE IF (field_glo(ind_glo)%ndim==3) THEN
1615            CALL MPI_IRECV(field_glo(ind_glo)%rval3d,size(field_glo(ind_glo)%rval3d) , MPI_REAL8 ,   &
1616                         domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
1617
1618          ELSE IF (field_glo(ind_glo)%ndim==4) THEN
1619            CALL MPI_IRECV(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 ,   &
1620                         domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
1621          ENDIF
1622         
1623        ENDDO
1624      ENDIF
1625 
1626      DO ind_loc=1,ndomain
1627        ireq=ireq+1
1628
1629        IF (field_loc(ind_loc)%ndim==2) THEN
1630          CALL MPI_ISEND(field_loc(ind_loc)%rval2d,size(field_loc(ind_loc)%rval2d) , MPI_REAL8 ,   &
1631                         0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
1632        ELSE IF (field_loc(ind_loc)%ndim==3) THEN
1633          CALL MPI_ISEND(field_loc(ind_loc)%rval3d,size(field_loc(ind_loc)%rval3d) , MPI_REAL8 ,   &
1634                         0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
1635        ELSE IF (field_loc(ind_loc)%ndim==4) THEN
1636          CALL MPI_ISEND(field_loc(ind_loc)%rval4d,size(field_loc(ind_loc)%rval4d) , MPI_REAL8 ,   &
1637                         0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
1638        ENDIF
1639     
1640      ENDDO
1641   
1642      CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
1643
1644    ENDIF
1645       
1646  END SUBROUTINE gather_field
1647
1648   
1649  SUBROUTINE trace_in
1650  USE trace
1651  IMPLICIT NONE
1652 
1653    CALL trace_start("transfert_buffer")
1654  END SUBROUTINE trace_in             
1655
1656  SUBROUTINE trace_out
1657  USE trace
1658  IMPLICIT NONE
1659 
1660    CALL trace_end("transfert_buffer")
1661  END SUBROUTINE trace_out             
1662
1663END MODULE transfert_mpi_mod
1664     
1665       
1666       
1667       
1668     
Note: See TracBrowser for help on using the repository browser.