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

Last change on this file since 176 was 176, checked in by ymipsl, 11 years ago

Transfering data between domain on the same processus are now done by memory copy without use MPI CALL
=> prepare then new openMP version

YM
File size: 43.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         :: size
11    INTEGER,POINTER :: buffer(:)
12    REAL,POINTER    :: buffer_r2(:)
13    REAL,POINTER    :: buffer_r3(:,:)
14    REAL,POINTER    :: buffer_r4(:,:,:)
15    INTEGER,POINTER :: src_value(:)
16  END TYPE array
17 
18  TYPE t_buffer
19    REAL,POINTER    :: r2(:)
20    REAL,POINTER    :: r3(:,:)
21    REAL,POINTER    :: r4(:,:,:)
22  END TYPE t_buffer   
23   
24  TYPE t_request
25    INTEGER :: type_field
26    INTEGER :: max_size
27    INTEGER :: size
28    LOGICAL :: vector
29    INTEGER,POINTER :: src_domain(:)
30    INTEGER,POINTER :: src_i(:)
31    INTEGER,POINTER :: src_j(:)
32    INTEGER,POINTER :: src_ind(:)
33    INTEGER,POINTER :: target_ind(:)
34    INTEGER,POINTER :: target_i(:)
35    INTEGER,POINTER :: target_j(:)
36    INTEGER,POINTER :: target_sign(:)
37    INTEGER :: nrecv
38    TYPE(ARRAY),POINTER :: recv(:)
39    INTEGER :: nsend
40    INTEGER :: nreq_mpi
41    TYPE(ARRAY),POINTER :: send(:)
42  END TYPE t_request
43 
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(:)
51 
52  TYPE t_message
53    TYPE(t_request), POINTER :: request(:)
54    INTEGER :: nreq
55    INTEGER, POINTER :: mpi_req(:)
56    INTEGER, POINTER :: status(:,:)
57    TYPE(t_buffer),POINTER :: buffers(:) 
58    TYPE(t_field),POINTER :: field(:)
59    LOGICAL :: completed
60    LOGICAL :: pending
61    INTEGER :: number
62  END TYPE t_message
63 
64  INTEGER,SAVE :: message_number=0 ;
65 
66CONTAINS
67 
68  SUBROUTINE init_transfert
69  USE domain_mod
70  USE dimensions
71  USE field_mod
72  USE metric
73  USE mpipara
74  IMPLICIT NONE
75  INTEGER :: ind,i,j
76 
77    CALL create_request(field_t,req_i1)
78
79    DO ind=1,ndomain
80      CALL swap_dimensions(ind)
81      DO i=ii_begin,ii_end+1
82        CALL request_add_point(ind,i,jj_begin-1,req_i1)
83      ENDDO
84
85      DO j=jj_begin,jj_end
86        CALL request_add_point(ind,ii_end+1,j,req_i1)
87      ENDDO   
88      DO i=ii_begin,ii_end
89        CALL request_add_point(ind,i,jj_end+1,req_i1)
90      ENDDO   
91
92      DO j=jj_begin,jj_end+1
93        CALL request_add_point(ind,ii_begin-1,j,req_i1)
94      ENDDO   
95   
96    ENDDO
97 
98    CALL finalize_request(req_i1)
99
100
101    CALL create_request(field_t,req_i0)
102
103    DO ind=1,ndomain
104      CALL swap_dimensions(ind)
105   
106      DO i=ii_begin,ii_end
107        CALL request_add_point(ind,i,jj_begin,req_i0)
108      ENDDO
109
110      DO j=jj_begin,jj_end
111        CALL request_add_point(ind,ii_end,j,req_i0)
112      ENDDO   
113   
114      DO i=ii_begin,ii_end
115        CALL request_add_point(ind,i,jj_end,req_i0)
116      ENDDO   
117
118      DO j=jj_begin,jj_end
119        CALL request_add_point(ind,ii_begin,j,req_i0)
120      ENDDO   
121   
122    ENDDO
123 
124    CALL finalize_request(req_i0) 
125
126
127    CALL create_request(field_u,req_e1_scal)
128    DO ind=1,ndomain
129      CALL swap_dimensions(ind)
130      DO i=ii_begin,ii_end
131        CALL request_add_point(ind,i,jj_begin-1,req_e1_scal,rup)
132        CALL request_add_point(ind,i+1,jj_begin-1,req_e1_scal,lup)
133      ENDDO
134
135      DO j=jj_begin,jj_end
136        CALL request_add_point(ind,ii_end+1,j,req_e1_scal,left)
137        CALL request_add_point(ind,ii_end+1,j-1,req_e1_scal,lup)
138      ENDDO   
139   
140      DO i=ii_begin,ii_end
141        CALL request_add_point(ind,i,jj_end+1,req_e1_scal,ldown)
142        CALL request_add_point(ind,i-1,jj_end+1,req_e1_scal,rdown)
143      ENDDO   
144
145      DO j=jj_begin,jj_end
146        CALL request_add_point(ind,ii_begin-1,j,req_e1_scal,right)
147        CALL request_add_point(ind,ii_begin-1,j+1,req_e1_scal,rdown)
148      ENDDO   
149
150    ENDDO
151
152    CALL finalize_request(req_e1_scal)
153
154
155    CALL create_request(field_u,req_e0_scal)
156    DO ind=1,ndomain
157      CALL swap_dimensions(ind)
158
159
160      DO i=ii_begin+1,ii_end-1
161        CALL request_add_point(ind,i,jj_begin,req_e0_scal,right)
162        CALL request_add_point(ind,i,jj_end,req_e0_scal,right)
163      ENDDO
164   
165      DO j=jj_begin+1,jj_end-1
166        CALL request_add_point(ind,ii_begin,j,req_e0_scal,rup)
167        CALL request_add_point(ind,ii_end,j,req_e0_scal,rup)
168      ENDDO   
169
170      CALL request_add_point(ind,ii_begin+1,jj_begin,req_e0_scal,left)
171      CALL request_add_point(ind,ii_begin,jj_begin+1,req_e0_scal,ldown)
172      CALL request_add_point(ind,ii_begin+1,jj_end,req_e0_scal,left)
173      CALL request_add_point(ind,ii_end,jj_begin+1,req_e0_scal,ldown)
174
175    ENDDO
176
177    CALL finalize_request(req_e0_scal)
178
179
180   
181    CALL create_request(field_u,req_e1_vect,.TRUE.)
182    DO ind=1,ndomain
183      CALL swap_dimensions(ind)
184      DO i=ii_begin,ii_end
185        CALL request_add_point(ind,i,jj_begin-1,req_e1_vect,rup)
186        CALL request_add_point(ind,i+1,jj_begin-1,req_e1_vect,lup)
187      ENDDO
188
189      DO j=jj_begin,jj_end
190        CALL request_add_point(ind,ii_end+1,j,req_e1_vect,left)
191        CALL request_add_point(ind,ii_end+1,j-1,req_e1_vect,lup)
192      ENDDO   
193   
194      DO i=ii_begin,ii_end
195        CALL request_add_point(ind,i,jj_end+1,req_e1_vect,ldown)
196        CALL request_add_point(ind,i-1,jj_end+1,req_e1_vect,rdown)
197      ENDDO   
198
199      DO j=jj_begin,jj_end
200        CALL request_add_point(ind,ii_begin-1,j,req_e1_vect,right)
201        CALL request_add_point(ind,ii_begin-1,j+1,req_e1_vect,rdown)
202      ENDDO   
203
204 
205    ENDDO 
206
207    CALL finalize_request(req_e1_vect)
208   
209   
210    CALL create_request(field_u,req_e0_vect,.TRUE.)
211    DO ind=1,ndomain
212      CALL swap_dimensions(ind)
213 
214      DO i=ii_begin+1,ii_end-1
215        CALL request_add_point(ind,i,jj_begin,req_e0_vect,right)
216        CALL request_add_point(ind,i,jj_end,req_e0_vect,right)
217      ENDDO
218   
219      DO j=jj_begin+1,jj_end-1
220        CALL request_add_point(ind,ii_begin,j,req_e0_vect,rup)
221        CALL request_add_point(ind,ii_end,j,req_e0_vect,rup)
222      ENDDO   
223
224      CALL request_add_point(ind,ii_begin+1,jj_begin,req_e0_vect,left)
225      CALL request_add_point(ind,ii_begin,jj_begin+1,req_e0_vect,ldown)
226      CALL request_add_point(ind,ii_begin+1,jj_end,req_e0_vect,left)
227      CALL request_add_point(ind,ii_end,jj_begin+1,req_e0_vect,ldown)
228 
229    ENDDO 
230
231    CALL finalize_request(req_e0_vect)
232
233
234  END SUBROUTINE init_transfert
235 
236  SUBROUTINE create_request(type_field,request,vector)
237  USE domain_mod
238  USE field_mod
239  IMPLICIT NONE
240    INTEGER :: type_field
241    TYPE(t_request),POINTER :: request(:)
242    LOGICAL,OPTIONAL :: vector
243   
244    TYPE(t_request),POINTER :: req
245    TYPE(t_domain),POINTER :: d
246    INTEGER :: ind
247    INTEGER :: max_size
248       
249    ALLOCATE(request(ndomain))
250
251    DO ind=1,ndomain
252      req=>request(ind)
253      d=>domain(ind)
254      IF (type_field==field_t) THEN
255        Max_size=2*(d%iim+2)+2*(d%jjm+2)
256      ELSE IF (type_field==field_u) THEN
257        Max_size=3*(2*(d%iim+2)+2*(d%jjm+2))
258      ELSE IF (type_field==field_z) THEN
259        Max_size=2*(2*(d%iim+2)+2*(d%jjm+2))
260      ENDIF
261
262      req%type_field=type_field
263      req%max_size=max_size*2
264      req%size=0
265      req%vector=.FALSE.
266      IF (PRESENT(vector)) req%vector=vector
267      ALLOCATE(req%src_domain(req%max_size))
268      ALLOCATE(req%src_ind(req%max_size))
269      ALLOCATE(req%target_ind(req%max_size))
270      ALLOCATE(req%src_i(req%max_size))
271      ALLOCATE(req%src_j(req%max_size))
272      ALLOCATE(req%target_i(req%max_size))
273      ALLOCATE(req%target_j(req%max_size))
274      ALLOCATE(req%target_sign(req%max_size))
275    ENDDO
276 
277  END SUBROUTINE create_request
278
279  SUBROUTINE reallocate_request(req)
280  IMPLICIT NONE
281    TYPE(t_request),POINTER :: req
282     
283    INTEGER,POINTER :: src_domain(:)
284    INTEGER,POINTER :: src_ind(:)
285    INTEGER,POINTER :: target_ind(:)
286    INTEGER,POINTER :: src_i(:)
287    INTEGER,POINTER :: src_j(:)
288    INTEGER,POINTER :: target_i(:)
289    INTEGER,POINTER :: target_j(:)
290    INTEGER,POINTER :: target_sign(:)
291
292    PRINT *,"REALLOCATE_REQUEST"
293    src_domain=>req%src_domain
294    src_ind=>req%src_ind
295    target_ind=>req%target_ind
296    src_i=>req%src_i
297    src_j=>req%src_j
298    target_i=>req%target_i
299    target_j=>req%target_j
300    target_sign=>req%target_sign
301
302    ALLOCATE(req%src_domain(req%max_size*2))
303    ALLOCATE(req%src_ind(req%max_size*2))
304    ALLOCATE(req%target_ind(req%max_size*2))
305    ALLOCATE(req%src_i(req%max_size*2))
306    ALLOCATE(req%src_j(req%max_size*2))
307    ALLOCATE(req%target_i(req%max_size*2))
308    ALLOCATE(req%target_j(req%max_size*2))
309    ALLOCATE(req%target_sign(req%max_size*2))
310   
311    req%src_domain(1:req%max_size)=src_domain(:)
312    req%src_ind(1:req%max_size)=src_ind(:)
313    req%target_ind(1:req%max_size)=target_ind(:)
314    req%src_i(1:req%max_size)=src_i(:)
315    req%src_j(1:req%max_size)=src_j(:)
316    req%target_i(1:req%max_size)=target_i(:)
317    req%target_j(1:req%max_size)=target_j(:)
318    req%target_sign(1:req%max_size)=target_sign(:)
319   
320    req%max_size=req%max_size*2
321         
322    DEALLOCATE(src_domain)
323    DEALLOCATE(src_ind)
324    DEALLOCATE(target_ind)
325    DEALLOCATE(src_i)
326    DEALLOCATE(src_j)
327    DEALLOCATE(target_i)
328    DEALLOCATE(target_j)
329    DEALLOCATE(target_sign)
330
331  END SUBROUTINE reallocate_request
332
333     
334    SUBROUTINE request_add_point(ind,i,j,request,pos)
335    USE domain_mod
336    USE field_mod
337    IMPLICIT NONE
338      INTEGER,INTENT(IN)            ::  ind
339      INTEGER,INTENT(IN)            :: i
340      INTEGER,INTENT(IN)            :: j
341      TYPE(t_request),POINTER :: request(:)
342      INTEGER,INTENT(IN),OPTIONAL  :: pos
343     
344      INTEGER :: src_domain
345      INTEGER :: src_iim,src_i,src_j,src_n,src_pos,src_delta
346      TYPE(t_request),POINTER :: req
347      TYPE(t_domain),POINTER :: d
348     
349      req=>request(ind)
350      d=>domain(ind)
351     
352      IF (req%max_size==req%size) CALL reallocate_request(req)
353      req%size=req%size+1
354      IF (req%type_field==field_t) THEN
355        src_domain=domain(ind)%assign_domain(i,j)
356        src_iim=domain_glo(src_domain)%iim
357        src_i=domain(ind)%assign_i(i,j)
358        src_j=domain(ind)%assign_j(i,j)
359
360        req%target_ind(req%size)=(j-1)*d%iim+i
361        req%target_sign(req%size)=1
362        req%src_domain(req%size)=src_domain
363        req%src_ind(req%size)=(src_j-1)*src_iim+src_i
364      ELSE IF (req%type_field==field_u) THEN
365        IF (.NOT. PRESENT(pos)) STOP 'argument request_add_point non conforme'
366
367        src_domain=domain(ind)%edge_assign_domain(pos-1,i,j)
368        src_iim=domain_glo(src_domain)%iim
369        src_i=domain(ind)%edge_assign_i(pos-1,i,j)
370        src_j=domain(ind)%edge_assign_j(pos-1,i,j)
371        src_n=(src_j-1)*src_iim+src_i
372        src_delta=domain(ind)%delta(i,j)
373        src_pos=domain(ind)%edge_assign_pos(pos-1,i,j)+1
374               
375        req%target_ind(req%size)=(j-1)*d%iim+i+d%u_pos(pos)
376
377        req%target_sign(req%size)= 1
378        IF (req%vector) req%target_sign(req%size)= domain(ind)%edge_assign_sign(pos-1,i,j)
379
380        req%src_domain(req%size)=src_domain
381        req%src_ind(req%size)=src_n+domain_glo(src_domain)%u_pos(src_pos)
382
383      ELSE IF (req%type_field==field_z) THEN
384        IF (.NOT. PRESENT(pos)) STOP 'argument request_add_point non conforme'
385
386        src_domain=domain(ind)%assign_domain(i,j)
387        src_iim=domain_glo(src_domain)%iim
388        src_i=domain(ind)%assign_i(i,j)
389        src_j=domain(ind)%assign_j(i,j)
390        src_n=(src_j-1)*src_iim+src_i
391        src_delta=domain(ind)%delta(i,j)
392       
393        src_pos=MOD(pos-1+src_delta+6,6)+1
394       
395        req%target_ind(req%size)=(j-1)*d%iim+i+d%z_pos(pos)
396        req%target_sign(req%size)=1
397        req%src_domain(req%size)=src_domain
398        req%src_ind(req%size)=src_n+domain_glo(src_domain)%z_pos(src_pos)
399      ENDIF
400  END SUBROUTINE request_add_point
401 
402 
403  SUBROUTINE Finalize_request(request)
404  USE mpipara
405  USE domain_mod
406  USE mpi_mod
407  IMPLICIT NONE
408    TYPE(t_request),POINTER :: request(:)
409    TYPE(t_request),POINTER :: req, req_src
410    INTEGER :: nb_domain_recv(0:mpi_size-1)
411    INTEGER :: nb_domain_send(0:mpi_size-1)
412    INTEGER :: nb_data_domain_recv(ndomain_glo)
413    INTEGER :: list_domain_recv(ndomain_glo)
414    INTEGER,ALLOCATABLE :: list_domain_send(:)
415    INTEGER             :: list_domain(ndomain)
416
417    INTEGER :: rank,i,j
418    INTEGER :: size_,ind_glo,ind_loc, ind_src
419    INTEGER :: isend, irecv, ireq, nreq
420    INTEGER, ALLOCATABLE :: mpi_req(:)
421    INTEGER, ALLOCATABLE :: status(:,:)
422   
423    IF (.NOT. using_mpi) RETURN
424   
425    DO ind_loc=1,ndomain
426      req=>request(ind_loc)
427     
428      nb_data_domain_recv(:) = 0
429      nb_domain_recv(:) = 0
430     
431      DO i=1,req%size
432        ind_glo=req%src_domain(i)
433        nb_data_domain_recv(ind_glo)=nb_data_domain_recv(ind_glo)+1
434      ENDDO
435 
436      DO ind_glo=1,ndomain_glo
437        IF ( nb_data_domain_recv(ind_glo) > 0 )  nb_domain_recv(domglo_rank(ind_glo))=nb_domain_recv(domglo_rank(ind_glo))+1
438      ENDDO
439
440      req%nrecv=sum(nb_domain_recv(:))
441      ALLOCATE(req%recv(req%nrecv))
442
443      irecv=0
444      DO ind_glo=1,ndomain_glo
445        IF (nb_data_domain_recv(ind_glo)>0) THEN
446          irecv=irecv+1
447          list_domain_recv(ind_glo)=irecv
448          req%recv(irecv)%rank=domglo_rank(ind_glo)
449          req%recv(irecv)%size=nb_data_domain_recv(ind_glo)
450          req%recv(irecv)%domain=domglo_loc_ind(ind_glo)
451          ALLOCATE(req%recv(irecv)%value(req%recv(irecv)%size))
452          ALLOCATE(req%recv(irecv)%sign(req%recv(irecv)%size))
453          ALLOCATE(req%recv(irecv)%buffer(req%recv(irecv)%size))
454        ENDIF
455      ENDDO
456     
457      req%recv(:)%size=0
458      irecv=0
459      DO i=1,req%size
460        irecv=list_domain_recv(req%src_domain(i))
461        req%recv(irecv)%size=req%recv(irecv)%size+1
462        size_=req%recv(irecv)%size
463        req%recv(irecv)%value(size_)=req%src_ind(i)
464        req%recv(irecv)%buffer(size_)=req%target_ind(i)
465        req%recv(irecv)%sign(size_)=req%target_sign(i)
466      ENDDO
467    ENDDO
468
469    nb_domain_recv(:) = 0   
470    DO ind_loc=1,ndomain
471      req=>request(ind_loc)
472     
473      DO irecv=1,req%nrecv
474        rank=req%recv(irecv)%rank
475        nb_domain_recv(rank)=nb_domain_recv(rank)+1
476      ENDDO
477    ENDDO
478   
479    CALL MPI_Alltoall(nb_domain_recv,1,MPI_INTEGER,nb_domain_send,1,MPI_INTEGER,comm_icosa,ierr)     
480   
481
482    ALLOCATE(list_domain_send(sum(nb_domain_send)))
483   
484    nreq=sum(nb_domain_recv(:))+sum(nb_domain_send(:))
485    ALLOCATE(mpi_req(nreq))
486    ALLOCATE(status(MPI_STATUS_SIZE,nreq))
487   
488    ireq=0
489    DO ind_loc=1,ndomain
490      req=>request(ind_loc)
491      DO irecv=1,req%nrecv
492        ireq=ireq+1
493        CALL MPI_ISEND(req%recv(irecv)%domain,1,MPI_INTEGER,req%recv(irecv)%rank,0,comm_icosa, mpi_req(ireq),ierr)
494      ENDDO
495    ENDDO
496   
497    j=0
498    DO rank=0,mpi_size-1
499      DO i=1,nb_domain_send(rank)
500        j=j+1
501        ireq=ireq+1
502        CALL MPI_IRECV(list_domain_send(j),1,MPI_INTEGER,rank,0,comm_icosa, mpi_req(ireq),ierr)
503      ENDDO
504    ENDDO
505   
506    CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
507   
508    list_domain(:)=0
509    DO i=1,sum(nb_domain_send)
510      ind_loc=list_domain_send(i)
511      list_domain(ind_loc)=list_domain(ind_loc)+1
512    ENDDO
513   
514    DO ind_loc=1,ndomain
515      req=>request(ind_loc)
516      req%nsend=list_domain(ind_loc)
517      ALLOCATE(req%send(req%nsend))
518    ENDDO
519   
520   ireq=0 
521   DO ind_loc=1,ndomain
522     req=>request(ind_loc)
523     
524     DO irecv=1,req%nrecv
525       ireq=ireq+1
526       CALL MPI_ISEND(mpi_rank,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr)
527     ENDDO
528     
529     DO isend=1,req%nsend
530       ireq=ireq+1
531       CALL MPI_IRECV(req%send(isend)%rank,1,MPI_INTEGER,MPI_ANY_SOURCE,ind_loc,comm_icosa, mpi_req(ireq),ierr)
532     ENDDO
533   ENDDO
534
535   CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
536   CALL MPI_BARRIER(comm_icosa,ierr)
537
538   ireq=0 
539   DO ind_loc=1,ndomain
540     req=>request(ind_loc)
541     
542     DO irecv=1,req%nrecv
543       ireq=ireq+1
544       CALL MPI_ISEND(ind_loc,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr)
545     ENDDO
546     
547     DO isend=1,req%nsend
548       ireq=ireq+1
549       CALL MPI_IRECV(req%send(isend)%domain,1,MPI_INTEGER,req%send(isend)%rank,ind_loc,comm_icosa, mpi_req(ireq),ierr)
550     ENDDO
551   ENDDO
552   
553   CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
554   CALL MPI_BARRIER(comm_icosa,ierr)
555
556   ireq=0 
557   DO ind_loc=1,ndomain
558     req=>request(ind_loc)
559     
560     DO irecv=1,req%nrecv
561       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)
563     ENDDO
564     
565     DO isend=1,req%nsend
566       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)
568     ENDDO
569   ENDDO
570
571   CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
572
573   ireq=0 
574   DO ind_loc=1,ndomain
575     req=>request(ind_loc)
576     
577     DO irecv=1,req%nrecv
578       ireq=ireq+1
579       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)
581     ENDDO
582     
583     DO isend=1,req%nsend
584       ireq=ireq+1
585       ALLOCATE(req%send(isend)%value(req%send(isend)%size))
586       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)
588     ENDDO
589   ENDDO
590
591   CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
592
593   DO ind_loc=1,ndomain
594     req=>request(ind_loc)
595     
596     DO irecv=1,req%nrecv
597       req%recv(irecv)%value(:)=req%recv(irecv)%buffer(:)
598       req%recv(irecv)%sign(:) =req%recv(irecv)%sign(:)
599       DEALLOCATE(req%recv(irecv)%buffer)
600     ENDDO
601   ENDDO 
602
603! domain is on the same mpi process
604   
605   DO ind_loc=1,ndomain
606     req=>request(ind_loc)
607     
608     DO irecv=1,req%nrecv
609   
610       IF (req%recv(irecv)%rank==mpi_rank) THEN
611           req_src=>request(req%recv(irecv)%domain)
612           DO isend=1,req_src%nsend
613             IF (req_src%send(isend)%rank==mpi_rank .AND. req_src%send(isend)%domain==ind_loc) THEN
614               req%recv(irecv)%src_value => req_src%send(isend)%value
615               IF ( size(req%recv(irecv)%value) /= size(req_src%send(isend)%value)) THEN
616                 STOP "size(req%recv(irecv)%value) /= size(req_src%send(isend)%value"
617               ENDIF
618             ENDIF
619           ENDDO
620       ENDIF
621     
622     ENDDO
623   ENDDO
624   
625! true number of mpi request
626   DO ind_loc=1,ndomain
627     req=>request(ind_loc)
628     req%nreq_mpi=0
629
630     DO isend=1,req%nsend
631      IF (req%send(isend)%rank/=mpi_rank .OR. .TRUE.) req%nreq_mpi=req%nreq_mpi+1 
632     ENDDO
633     
634     DO irecv=1,req%nrecv
635      IF (req%recv(irecv)%rank/=mpi_rank .OR. .TRUE.) req%nreq_mpi=req%nreq_mpi+1 
636     ENDDO
637 
638   ENDDO 
639       
640  END SUBROUTINE Finalize_request 
641
642
643  SUBROUTINE init_message_seq(field, request, message)
644  USE field_mod
645  USE domain_mod
646  USE mpi_mod
647  USE mpipara
648  USE mpi_mod
649  IMPLICIT NONE
650    TYPE(t_field),POINTER :: field(:)
651    TYPE(t_request),POINTER :: request(:)
652    TYPE(t_message) :: message
653
654!$OMP MASTER   
655    message%request=>request
656!$OMP END MASTER   
657!$OMP BARRIER   
658
659  END SUBROUTINE init_message_seq
660
661  SUBROUTINE send_message_seq(field,message)
662  USE field_mod
663  USE domain_mod
664  USE mpi_mod
665  USE mpipara
666  USE omp_para
667  USE trace
668  IMPLICIT NONE
669    TYPE(t_field),POINTER :: field(:)
670    TYPE(t_message) :: message
671
672    CALL transfert_request_seq(field,message%request)
673   
674  END SUBROUTINE send_message_seq
675 
676  SUBROUTINE test_message_seq(message)
677  IMPLICIT NONE
678    TYPE(t_message) :: message
679  END SUBROUTINE  test_message_seq
680 
681   
682  SUBROUTINE wait_message_seq(message)
683  IMPLICIT NONE
684    TYPE(t_message) :: message
685   
686  END SUBROUTINE wait_message_seq   
687
688  SUBROUTINE transfert_message_seq(field,message)
689  USE field_mod
690  USE domain_mod
691  USE mpi_mod
692  USE mpipara
693  USE omp_para
694  USE trace
695  IMPLICIT NONE
696    TYPE(t_field),POINTER :: field(:)
697    TYPE(t_message) :: message
698
699   CALL send_message_seq(field,message)
700   
701  END SUBROUTINE transfert_message_seq   
702   
703   
704  SUBROUTINE init_message_mpi(field,request, message)
705  USE field_mod
706  USE domain_mod
707  USE mpi_mod
708  USE mpipara
709  USE mpi_mod
710  IMPLICIT NONE
711 
712    TYPE(t_field),POINTER :: field(:)
713    TYPE(t_request),POINTER :: request(:)
714    TYPE(t_message) :: message
715
716    TYPE(ARRAY),POINTER :: recv,send 
717    TYPE(t_request),POINTER :: req
718    INTEGER :: irecv,isend
719    INTEGER :: ireq,nreq
720    INTEGER :: ind
721    INTEGER :: dim3,dim4
722
723!$OMP MASTER
724    message%number=message_number
725    message_number=message_number+1
726    IF (message_number==100) message_number=0
727   
728    message%request=>request
729    nreq=sum(request(:)%nsend)+sum(request(:)%nrecv)
730!    message%nreq=nreq
731    message%nreq=sum(message%request(:)%nreq_mpi)
732    ALLOCATE(message%mpi_req(nreq))
733    ALLOCATE(message%buffers(nreq))
734    ALLOCATE(message%status(MPI_STATUS_SIZE,nreq))
735   
736    message%pending=.FALSE.
737    message%completed=.FALSE.
738   
739    IF (field(1)%data_type==type_real) THEN
740
741      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     
761     
762      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
785      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     
807      ENDIF     
808    ENDIF
809!$OMP END MASTER
810!$OMP BARRIER   
811  END SUBROUTINE init_message_mpi
812 
813  SUBROUTINE barrier
814  USE mpi_mod
815  USE mpipara
816  IMPLICIT NONE
817   
818    CALL MPI_BARRIER(comm_icosa,ierr)
819   
820  END SUBROUTINE barrier 
821   
822  SUBROUTINE transfert_message_mpi(field,message)
823  USE field_mod
824  IMPLICIT NONE
825    TYPE(t_field),POINTER :: field(:)
826    TYPE(t_message) :: message
827   
828    CALL send_message_mpi(field,message)
829    CALL wait_message_mpi(message)
830   
831  END SUBROUTINE transfert_message_mpi
832
833
834  SUBROUTINE send_message_mpi(field,message)
835  USE field_mod
836  USE domain_mod
837  USE mpi_mod
838  USE mpipara
839  USE omp_para
840  USE trace
841  IMPLICIT NONE
842    TYPE(t_field),POINTER :: field(:)
843    TYPE(t_message) :: message
844    REAL(rstd),POINTER :: rval2d(:), src_rval2d(:) 
845    REAL(rstd),POINTER :: rval3d(:,:), src_rval3d(:,:) 
846    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(:,:,:) 
1100    INTEGER,POINTER :: value(:) 
1101    INTEGER,POINTER :: sgn(:) 
1102    TYPE(ARRAY),POINTER :: recv,send 
1103    TYPE(t_request),POINTER :: req
1104    INTEGER, ALLOCATABLE :: mpi_req(:)
1105    INTEGER, ALLOCATABLE :: status(:,:)
1106    INTEGER :: irecv,isend
1107    INTEGER :: ireq,nreq
1108    INTEGER :: ind,n,l,m
1109    INTEGER :: dim3,dim4
1110
1111!$OMP BARRIER
1112
1113    CALL trace_start("transfert_mpi")
1114
1115    IF (.NOT. message%pending) RETURN
1116   
1117    field=>message%field
1118    nreq=message%nreq
1119   
1120    IF (field(1)%data_type==type_real) THEN
1121      IF (field(1)%ndim==2) THEN
1122
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       
1129        DO ind=1,ndomain
1130          rval2d=>field(ind)%rval2d
1131          req=>message%request(ind)
1132
1133          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
1146           
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
1153            ENDIF
1154          ENDDO
1155       
1156        ENDDO
1157     
1158     
1159      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       
1167        DO ind=1,ndomain
1168          rval3d=>field(ind)%rval3d
1169          req=>message%request(ind)
1170
1171          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            ENDIF
1192          ENDDO
1193       
1194        ENDDO
1195
1196      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       
1203        DO ind=1,ndomain
1204          rval4d=>field(ind)%rval4d
1205          req=>message%request(ind)
1206
1207          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) 
1224              ENDDO
1225
1226              CALL trace_out
1227            ENDIF
1228          ENDDO
1229       
1230        ENDDO
1231     
1232      ENDIF     
1233     
1234    ENDIF
1235
1236!$OMP MASTER
1237    message%pending=.FALSE.
1238!$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)
1247  USE field_mod
1248  USE domain_mod
1249  USE mpi_mod
1250  USE mpipara
1251  USE trace
1252  IMPLICIT NONE
1253    TYPE(t_field),POINTER :: field(:)
1254    TYPE(t_request),POINTER :: request(:)
1255    REAL(rstd),POINTER :: rval2d(:) 
1256    REAL(rstd),POINTER :: rval3d(:,:) 
1257    REAL(rstd),POINTER :: rval4d(:,:,:) 
1258    REAL(rstd),POINTER :: buffer_r2(:) 
1259    REAL(rstd),POINTER :: buffer_r3(:,:) 
1260    REAL(rstd),POINTER :: buffer_r4(:,:,:) 
1261    INTEGER,POINTER :: value(:) 
1262    INTEGER,POINTER :: sgn(:) 
1263    TYPE(ARRAY),POINTER :: recv,send 
1264    TYPE(t_request),POINTER :: req
1265    INTEGER, ALLOCATABLE :: mpi_req(:)
1266    INTEGER, ALLOCATABLE :: status(:,:)
1267    INTEGER :: irecv,isend
1268    INTEGER :: ireq,nreq
1269    INTEGER :: ind,n
1270    INTEGER :: dim3,dim4
1271
1272    CALL trace_start("transfert_mpi")
1273
1274    IF (field(1)%data_type==type_real) THEN
1275      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
1282        DO ind=1,ndomain
1283          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       
1300          DO irecv=1,req%nrecv
1301            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)
1306          ENDDO
1307       
1308        ENDDO
1309       
1310        CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
1311       
1312        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       
1321          DO irecv=1,req%nrecv
1322            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)
1330          ENDDO
1331       
1332        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
1342        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       
1361          DO irecv=1,req%nrecv
1362            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)
1367          ENDDO
1368       
1369        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
1455     
1456      ENDIF     
1457     
1458    ENDIF
1459
1460    CALL trace_end("transfert_mpi")
1461   
1462  END SUBROUTINE transfert_request_mpi
1463   
1464  SUBROUTINE transfert_request_seq(field,request)
1465  USE field_mod
1466  USE domain_mod
1467  IMPLICIT NONE
1468    TYPE(t_field),POINTER :: field(:)
1469    TYPE(t_request),POINTER :: request(:)
1470    REAL(rstd),POINTER :: rval2d(:) 
1471    REAL(rstd),POINTER :: rval3d(:,:) 
1472    REAL(rstd),POINTER :: rval4d(:,:,:) 
1473    INTEGER :: ind
1474    TYPE(t_request),POINTER :: req
1475    INTEGER :: n
1476    REAL(rstd) :: var1,var2
1477   
1478    DO ind=1,ndomain
1479      req=>request(ind)
1480      rval2d=>field(ind)%rval2d
1481      rval3d=>field(ind)%rval3d
1482      rval4d=>field(ind)%rval4d
1483     
1484      IF (field(ind)%data_type==type_real) THEN
1485        IF (field(ind)%ndim==2) THEN
1486          DO n=1,req%size
1487            rval2d(req%target_ind(n))=field(req%src_domain(n))%rval2d(req%src_ind(n))*req%target_sign(n)
1488          ENDDO
1489        ELSE IF (field(ind)%ndim==3) THEN
1490          DO n=1,req%size
1491            rval3d(req%target_ind(n),:)=field(req%src_domain(n))%rval3d(req%src_ind(n),:)*req%target_sign(n)
1492          ENDDO
1493        ELSE IF (field(ind)%ndim==4) THEN
1494          DO n=1,req%size
1495            rval4d(req%target_ind(n),:,:)=field(req%src_domain(n))%rval4d(req%src_ind(n),:,:)*req%target_sign(n)
1496          ENDDO
1497        ENDIF
1498      ENDIF       
1499
1500    ENDDO
1501   
1502  END SUBROUTINE transfert_request_seq
1503 
1504 
1505  SUBROUTINE gather_field(field_loc,field_glo)
1506  USE field_mod
1507  USE domain_mod
1508  USE mpi_mod
1509  USE mpipara
1510  IMPLICIT NONE
1511    TYPE(t_field),POINTER :: field_loc(:)
1512    TYPE(t_field),POINTER :: field_glo(:)
1513    INTEGER, ALLOCATABLE :: mpi_req(:)
1514    INTEGER, ALLOCATABLE :: status(:,:)
1515    INTEGER :: ireq,nreq
1516    INTEGER :: ind_glo,ind_loc   
1517 
1518    IF (.NOT. using_mpi) THEN
1519   
1520      DO ind_loc=1,ndomain
1521        IF (field_loc(ind_loc)%ndim==2) field_glo(ind_loc)%rval2d=field_loc(ind_loc)%rval2d
1522        IF (field_loc(ind_loc)%ndim==3) field_glo(ind_loc)%rval3d=field_loc(ind_loc)%rval3d
1523        IF (field_loc(ind_loc)%ndim==4) field_glo(ind_loc)%rval4d=field_loc(ind_loc)%rval4d
1524      ENDDO
1525   
1526    ELSE
1527         
1528      nreq=ndomain
1529      IF (mpi_rank==0) nreq=nreq+ndomain_glo 
1530      ALLOCATE(mpi_req(nreq))
1531      ALLOCATE(status(MPI_STATUS_SIZE,nreq))
1532   
1533   
1534      ireq=0
1535      IF (mpi_rank==0) THEN
1536        DO ind_glo=1,ndomain_glo
1537          ireq=ireq+1
1538
1539          IF (field_glo(ind_glo)%ndim==2) THEN
1540            CALL MPI_IRECV(field_glo(ind_glo)%rval2d,size(field_glo(ind_glo)%rval2d) , MPI_REAL8 ,   &
1541                         domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
1542   
1543          ELSE IF (field_glo(ind_glo)%ndim==3) THEN
1544            CALL MPI_IRECV(field_glo(ind_glo)%rval3d,size(field_glo(ind_glo)%rval3d) , MPI_REAL8 ,   &
1545                         domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
1546
1547          ELSE IF (field_glo(ind_glo)%ndim==4) THEN
1548            CALL MPI_IRECV(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 ,   &
1549                         domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
1550          ENDIF
1551         
1552        ENDDO
1553      ENDIF
1554 
1555      DO ind_loc=1,ndomain
1556        ireq=ireq+1
1557
1558        IF (field_loc(ind_loc)%ndim==2) THEN
1559          CALL MPI_ISEND(field_loc(ind_loc)%rval2d,size(field_loc(ind_loc)%rval2d) , MPI_REAL8 ,   &
1560                         0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
1561        ELSE IF (field_loc(ind_loc)%ndim==3) THEN
1562          CALL MPI_ISEND(field_loc(ind_loc)%rval3d,size(field_loc(ind_loc)%rval3d) , MPI_REAL8 ,   &
1563                         0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
1564        ELSE IF (field_loc(ind_loc)%ndim==4) THEN
1565          CALL MPI_ISEND(field_loc(ind_loc)%rval4d,size(field_loc(ind_loc)%rval4d) , MPI_REAL8 ,   &
1566                         0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
1567        ENDIF
1568     
1569      ENDDO
1570   
1571      CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
1572
1573    ENDIF
1574       
1575  END SUBROUTINE gather_field
1576
1577   
1578  SUBROUTINE trace_in
1579  USE trace
1580  IMPLICIT NONE
1581 
1582    CALL trace_start("transfert_buffer")
1583  END SUBROUTINE trace_in             
1584
1585  SUBROUTINE trace_out
1586  USE trace
1587  IMPLICIT NONE
1588 
1589    CALL trace_end("transfert_buffer")
1590  END SUBROUTINE trace_out             
1591
1592END MODULE transfert_mpi_mod
1593     
1594       
1595       
1596       
1597     
Note: See TracBrowser for help on using the repository browser.