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

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

Implementation of mixte parallelism MPI/OpenMP into src directory

YM
File size: 39.1 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  END TYPE array
16 
17  TYPE t_buffer
18    REAL,POINTER    :: r2(:)
19    REAL,POINTER    :: r3(:,:)
20    REAL,POINTER    :: r4(:,:,:)
21  END TYPE t_buffer   
22   
23  TYPE t_request
24    INTEGER :: type_field
25    INTEGER :: max_size
26    INTEGER :: size
27    LOGICAL :: vector
28    INTEGER,POINTER :: src_domain(:)
29    INTEGER,POINTER :: src_i(:)
30    INTEGER,POINTER :: src_j(:)
31    INTEGER,POINTER :: src_ind(:)
32    INTEGER,POINTER :: target_ind(:)
33    INTEGER,POINTER :: target_i(:)
34    INTEGER,POINTER :: target_j(:)
35    INTEGER,POINTER :: target_sign(:)
36    INTEGER :: nrecv
37    TYPE(ARRAY),POINTER :: recv(:)
38    INTEGER :: nsend
39    TYPE(ARRAY),POINTER :: send(:)
40  END TYPE t_request
41 
42  TYPE(t_request),POINTER :: req_i1(:)
43  TYPE(t_request),POINTER :: req_e1_scal(:)
44  TYPE(t_request),POINTER :: req_e1_vect(:)
45 
46  TYPE(t_request),POINTER :: req_i0(:)
47  TYPE(t_request),POINTER :: req_e0_scal(:)
48  TYPE(t_request),POINTER :: req_e0_vect(:)
49 
50  TYPE t_message
51    TYPE(t_request), POINTER :: request(:)
52    INTEGER :: nreq
53    INTEGER, POINTER :: mpi_req(:)
54    INTEGER, POINTER :: status(:,:)
55    TYPE(t_buffer),POINTER :: buffers(:) 
56    TYPE(t_field),POINTER :: field(:)
57    LOGICAL :: completed
58    LOGICAL :: pending
59  END TYPE t_message
60 
61CONTAINS
62 
63  SUBROUTINE init_transfert
64  USE domain_mod
65  USE dimensions
66  USE field_mod
67  USE metric
68  USE mpipara
69  IMPLICIT NONE
70  INTEGER :: ind,i,j
71 
72    CALL create_request(field_t,req_i1)
73
74    DO ind=1,ndomain
75      CALL swap_dimensions(ind)
76      DO i=ii_begin,ii_end+1
77        CALL request_add_point(ind,i,jj_begin-1,req_i1)
78      ENDDO
79
80      DO j=jj_begin,jj_end
81        CALL request_add_point(ind,ii_end+1,j,req_i1)
82      ENDDO   
83      DO i=ii_begin,ii_end
84        CALL request_add_point(ind,i,jj_end+1,req_i1)
85      ENDDO   
86
87      DO j=jj_begin,jj_end+1
88        CALL request_add_point(ind,ii_begin-1,j,req_i1)
89      ENDDO   
90   
91    ENDDO
92 
93    CALL finalize_request(req_i1)
94
95
96    CALL create_request(field_t,req_i0)
97
98    DO ind=1,ndomain
99      CALL swap_dimensions(ind)
100   
101      DO i=ii_begin,ii_end
102        CALL request_add_point(ind,i,jj_begin,req_i0)
103      ENDDO
104
105      DO j=jj_begin,jj_end
106        CALL request_add_point(ind,ii_end,j,req_i0)
107      ENDDO   
108   
109      DO i=ii_begin,ii_end
110        CALL request_add_point(ind,i,jj_end,req_i0)
111      ENDDO   
112
113      DO j=jj_begin,jj_end
114        CALL request_add_point(ind,ii_begin,j,req_i0)
115      ENDDO   
116   
117    ENDDO
118 
119    CALL finalize_request(req_i0) 
120
121
122    CALL create_request(field_u,req_e1_scal)
123    DO ind=1,ndomain
124      CALL swap_dimensions(ind)
125      DO i=ii_begin,ii_end
126        CALL request_add_point(ind,i,jj_begin-1,req_e1_scal,rup)
127        CALL request_add_point(ind,i+1,jj_begin-1,req_e1_scal,lup)
128      ENDDO
129
130      DO j=jj_begin,jj_end
131        CALL request_add_point(ind,ii_end+1,j,req_e1_scal,left)
132        CALL request_add_point(ind,ii_end+1,j-1,req_e1_scal,lup)
133      ENDDO   
134   
135      DO i=ii_begin,ii_end
136        CALL request_add_point(ind,i,jj_end+1,req_e1_scal,ldown)
137        CALL request_add_point(ind,i-1,jj_end+1,req_e1_scal,rdown)
138      ENDDO   
139
140      DO j=jj_begin,jj_end
141        CALL request_add_point(ind,ii_begin-1,j,req_e1_scal,right)
142        CALL request_add_point(ind,ii_begin-1,j+1,req_e1_scal,rdown)
143      ENDDO   
144
145    ENDDO
146
147    CALL finalize_request(req_e1_scal)
148
149
150    CALL create_request(field_u,req_e0_scal)
151    DO ind=1,ndomain
152      CALL swap_dimensions(ind)
153
154
155      DO i=ii_begin+1,ii_end-1
156        CALL request_add_point(ind,i,jj_begin,req_e0_scal,right)
157        CALL request_add_point(ind,i,jj_end,req_e0_scal,right)
158      ENDDO
159   
160      DO j=jj_begin+1,jj_end-1
161        CALL request_add_point(ind,ii_begin,j,req_e0_scal,rup)
162        CALL request_add_point(ind,ii_end,j,req_e0_scal,rup)
163      ENDDO   
164
165      CALL request_add_point(ind,ii_begin+1,jj_begin,req_e0_scal,left)
166      CALL request_add_point(ind,ii_begin,jj_begin+1,req_e0_scal,ldown)
167      CALL request_add_point(ind,ii_begin+1,jj_end,req_e0_scal,left)
168      CALL request_add_point(ind,ii_end,jj_begin+1,req_e0_scal,ldown)
169
170    ENDDO
171
172    CALL finalize_request(req_e0_scal)
173
174
175   
176    CALL create_request(field_u,req_e1_vect,.TRUE.)
177    DO ind=1,ndomain
178      CALL swap_dimensions(ind)
179      DO i=ii_begin,ii_end
180        CALL request_add_point(ind,i,jj_begin-1,req_e1_vect,rup)
181        CALL request_add_point(ind,i+1,jj_begin-1,req_e1_vect,lup)
182      ENDDO
183
184      DO j=jj_begin,jj_end
185        CALL request_add_point(ind,ii_end+1,j,req_e1_vect,left)
186        CALL request_add_point(ind,ii_end+1,j-1,req_e1_vect,lup)
187      ENDDO   
188   
189      DO i=ii_begin,ii_end
190        CALL request_add_point(ind,i,jj_end+1,req_e1_vect,ldown)
191        CALL request_add_point(ind,i-1,jj_end+1,req_e1_vect,rdown)
192      ENDDO   
193
194      DO j=jj_begin,jj_end
195        CALL request_add_point(ind,ii_begin-1,j,req_e1_vect,right)
196        CALL request_add_point(ind,ii_begin-1,j+1,req_e1_vect,rdown)
197      ENDDO   
198
199 
200    ENDDO 
201
202    CALL finalize_request(req_e1_vect)
203   
204   
205    CALL create_request(field_u,req_e0_vect,.TRUE.)
206    DO ind=1,ndomain
207      CALL swap_dimensions(ind)
208 
209      DO i=ii_begin+1,ii_end-1
210        CALL request_add_point(ind,i,jj_begin,req_e0_vect,right)
211        CALL request_add_point(ind,i,jj_end,req_e0_vect,right)
212      ENDDO
213   
214      DO j=jj_begin+1,jj_end-1
215        CALL request_add_point(ind,ii_begin,j,req_e0_vect,rup)
216        CALL request_add_point(ind,ii_end,j,req_e0_vect,rup)
217      ENDDO   
218
219      CALL request_add_point(ind,ii_begin+1,jj_begin,req_e0_vect,left)
220      CALL request_add_point(ind,ii_begin,jj_begin+1,req_e0_vect,ldown)
221      CALL request_add_point(ind,ii_begin+1,jj_end,req_e0_vect,left)
222      CALL request_add_point(ind,ii_end,jj_begin+1,req_e0_vect,ldown)
223 
224    ENDDO 
225
226    CALL finalize_request(req_e0_vect)
227
228
229  END SUBROUTINE init_transfert
230 
231  SUBROUTINE create_request(type_field,request,vector)
232  USE domain_mod
233  USE field_mod
234  IMPLICIT NONE
235    INTEGER :: type_field
236    TYPE(t_request),POINTER :: request(:)
237    LOGICAL,OPTIONAL :: vector
238   
239    TYPE(t_request),POINTER :: req
240    TYPE(t_domain),POINTER :: d
241    INTEGER :: ind
242    INTEGER :: max_size
243       
244    ALLOCATE(request(ndomain))
245
246    DO ind=1,ndomain
247      req=>request(ind)
248      d=>domain(ind)
249      IF (type_field==field_t) THEN
250        Max_size=2*(d%iim+2)+2*(d%jjm+2)
251      ELSE IF (type_field==field_u) THEN
252        Max_size=3*(2*(d%iim+2)+2*(d%jjm+2))
253      ELSE IF (type_field==field_z) THEN
254        Max_size=2*(2*(d%iim+2)+2*(d%jjm+2))
255      ENDIF
256
257      req%type_field=type_field
258      req%max_size=max_size*2
259      req%size=0
260      req%vector=.FALSE.
261      IF (PRESENT(vector)) req%vector=vector
262      ALLOCATE(req%src_domain(req%max_size))
263      ALLOCATE(req%src_ind(req%max_size))
264      ALLOCATE(req%target_ind(req%max_size))
265      ALLOCATE(req%src_i(req%max_size))
266      ALLOCATE(req%src_j(req%max_size))
267      ALLOCATE(req%target_i(req%max_size))
268      ALLOCATE(req%target_j(req%max_size))
269      ALLOCATE(req%target_sign(req%max_size))
270    ENDDO
271 
272  END SUBROUTINE create_request
273
274  SUBROUTINE reallocate_request(req)
275  IMPLICIT NONE
276    TYPE(t_request),POINTER :: req
277     
278    INTEGER,POINTER :: src_domain(:)
279    INTEGER,POINTER :: src_ind(:)
280    INTEGER,POINTER :: target_ind(:)
281    INTEGER,POINTER :: src_i(:)
282    INTEGER,POINTER :: src_j(:)
283    INTEGER,POINTER :: target_i(:)
284    INTEGER,POINTER :: target_j(:)
285    INTEGER,POINTER :: target_sign(:)
286
287    PRINT *,"REALLOCATE_REQUEST"
288    src_domain=>req%src_domain
289    src_ind=>req%src_ind
290    target_ind=>req%target_ind
291    src_i=>req%src_i
292    src_j=>req%src_j
293    target_i=>req%target_i
294    target_j=>req%target_j
295    target_sign=>req%target_sign
296
297    ALLOCATE(req%src_domain(req%max_size*2))
298    ALLOCATE(req%src_ind(req%max_size*2))
299    ALLOCATE(req%target_ind(req%max_size*2))
300    ALLOCATE(req%src_i(req%max_size*2))
301    ALLOCATE(req%src_j(req%max_size*2))
302    ALLOCATE(req%target_i(req%max_size*2))
303    ALLOCATE(req%target_j(req%max_size*2))
304    ALLOCATE(req%target_sign(req%max_size*2))
305   
306    req%src_domain(1:req%max_size)=src_domain(:)
307    req%src_ind(1:req%max_size)=src_ind(:)
308    req%target_ind(1:req%max_size)=target_ind(:)
309    req%src_i(1:req%max_size)=src_i(:)
310    req%src_j(1:req%max_size)=src_j(:)
311    req%target_i(1:req%max_size)=target_i(:)
312    req%target_j(1:req%max_size)=target_j(:)
313    req%target_sign(1:req%max_size)=target_sign(:)
314   
315    req%max_size=req%max_size*2
316         
317    DEALLOCATE(src_domain)
318    DEALLOCATE(src_ind)
319    DEALLOCATE(target_ind)
320    DEALLOCATE(src_i)
321    DEALLOCATE(src_j)
322    DEALLOCATE(target_i)
323    DEALLOCATE(target_j)
324    DEALLOCATE(target_sign)
325
326  END SUBROUTINE reallocate_request
327
328     
329    SUBROUTINE request_add_point(ind,i,j,request,pos)
330    USE domain_mod
331    USE field_mod
332    IMPLICIT NONE
333      INTEGER,INTENT(IN)            ::  ind
334      INTEGER,INTENT(IN)            :: i
335      INTEGER,INTENT(IN)            :: j
336      TYPE(t_request),POINTER :: request(:)
337      INTEGER,INTENT(IN),OPTIONAL  :: pos
338     
339      INTEGER :: src_domain
340      INTEGER :: src_iim,src_i,src_j,src_n,src_pos,src_delta
341      TYPE(t_request),POINTER :: req
342      TYPE(t_domain),POINTER :: d
343     
344      req=>request(ind)
345      d=>domain(ind)
346     
347      IF (req%max_size==req%size) CALL reallocate_request(req)
348      req%size=req%size+1
349      IF (req%type_field==field_t) THEN
350        src_domain=domain(ind)%assign_domain(i,j)
351        src_iim=domain_glo(src_domain)%iim
352        src_i=domain(ind)%assign_i(i,j)
353        src_j=domain(ind)%assign_j(i,j)
354
355        req%target_ind(req%size)=(j-1)*d%iim+i
356        req%target_sign(req%size)=1
357        req%src_domain(req%size)=src_domain
358        req%src_ind(req%size)=(src_j-1)*src_iim+src_i
359      ELSE IF (req%type_field==field_u) THEN
360        IF (.NOT. PRESENT(pos)) STOP 'argument request_add_point non conforme'
361
362        src_domain=domain(ind)%edge_assign_domain(pos-1,i,j)
363        src_iim=domain_glo(src_domain)%iim
364        src_i=domain(ind)%edge_assign_i(pos-1,i,j)
365        src_j=domain(ind)%edge_assign_j(pos-1,i,j)
366        src_n=(src_j-1)*src_iim+src_i
367        src_delta=domain(ind)%delta(i,j)
368        src_pos=domain(ind)%edge_assign_pos(pos-1,i,j)+1
369               
370        req%target_ind(req%size)=(j-1)*d%iim+i+d%u_pos(pos)
371
372        req%target_sign(req%size)= 1
373        IF (req%vector) req%target_sign(req%size)= domain(ind)%edge_assign_sign(pos-1,i,j)
374
375        req%src_domain(req%size)=src_domain
376        req%src_ind(req%size)=src_n+domain_glo(src_domain)%u_pos(src_pos)
377
378      ELSE IF (req%type_field==field_z) THEN
379        IF (.NOT. PRESENT(pos)) STOP 'argument request_add_point non conforme'
380
381        src_domain=domain(ind)%assign_domain(i,j)
382        src_iim=domain_glo(src_domain)%iim
383        src_i=domain(ind)%assign_i(i,j)
384        src_j=domain(ind)%assign_j(i,j)
385        src_n=(src_j-1)*src_iim+src_i
386        src_delta=domain(ind)%delta(i,j)
387       
388        src_pos=MOD(pos-1+src_delta+6,6)+1
389       
390        req%target_ind(req%size)=(j-1)*d%iim+i+d%z_pos(pos)
391        req%target_sign(req%size)=1
392        req%src_domain(req%size)=src_domain
393        req%src_ind(req%size)=src_n+domain_glo(src_domain)%z_pos(src_pos)
394      ENDIF
395  END SUBROUTINE request_add_point
396 
397 
398  SUBROUTINE Finalize_request(request)
399  USE mpipara
400  USE domain_mod
401  USE mpi_mod
402  IMPLICIT NONE
403    TYPE(t_request),POINTER :: request(:)
404    TYPE(t_request),POINTER :: req
405    INTEGER :: nb_domain_recv(0:mpi_size-1)
406    INTEGER :: nb_domain_send(0:mpi_size-1)
407    INTEGER :: nb_data_domain_recv(ndomain_glo)
408    INTEGER :: list_domain_recv(ndomain_glo)
409    INTEGER,ALLOCATABLE :: list_domain_send(:)
410    INTEGER             :: list_domain(ndomain)
411
412    INTEGER :: rank,i,j
413    INTEGER :: size,ind_glo,ind_loc
414    INTEGER :: isend, irecv, ireq, nreq
415    INTEGER, ALLOCATABLE :: mpi_req(:)
416    INTEGER, ALLOCATABLE :: status(:,:)
417   
418    IF (.NOT. using_mpi) RETURN
419   
420    DO ind_loc=1,ndomain
421      req=>request(ind_loc)
422     
423      nb_data_domain_recv(:) = 0
424      nb_domain_recv(:) = 0
425     
426      DO i=1,req%size
427        ind_glo=req%src_domain(i)
428        nb_data_domain_recv(ind_glo)=nb_data_domain_recv(ind_glo)+1
429      ENDDO
430 
431      DO ind_glo=1,ndomain_glo
432        IF ( nb_data_domain_recv(ind_glo) > 0 )  nb_domain_recv(domglo_rank(ind_glo))=nb_domain_recv(domglo_rank(ind_glo))+1
433      ENDDO
434
435      req%nrecv=sum(nb_domain_recv(:))
436      ALLOCATE(req%recv(req%nrecv))
437
438      irecv=0
439      DO ind_glo=1,ndomain_glo
440        IF (nb_data_domain_recv(ind_glo)>0) THEN
441          irecv=irecv+1
442          list_domain_recv(ind_glo)=irecv
443          req%recv(irecv)%rank=domglo_rank(ind_glo)
444          req%recv(irecv)%size=nb_data_domain_recv(ind_glo)
445          req%recv(irecv)%domain=domglo_loc_ind(ind_glo)
446          ALLOCATE(req%recv(irecv)%value(req%recv(irecv)%size))
447          ALLOCATE(req%recv(irecv)%sign(req%recv(irecv)%size))
448          ALLOCATE(req%recv(irecv)%buffer(req%recv(irecv)%size))
449        ENDIF
450      ENDDO
451     
452      req%recv(:)%size=0
453      irecv=0
454      DO i=1,req%size
455        irecv=list_domain_recv(req%src_domain(i))
456        req%recv(irecv)%size=req%recv(irecv)%size+1
457        size=req%recv(irecv)%size
458        req%recv(irecv)%value(size)=req%src_ind(i)
459        req%recv(irecv)%buffer(size)=req%target_ind(i)
460        req%recv(irecv)%sign(size)=req%target_sign(i)
461      ENDDO
462    ENDDO
463
464    nb_domain_recv(:) = 0   
465    DO ind_loc=1,ndomain
466      req=>request(ind_loc)
467     
468      DO irecv=1,req%nrecv
469        rank=req%recv(irecv)%rank
470        nb_domain_recv(rank)=nb_domain_recv(rank)+1
471      ENDDO
472    ENDDO
473   
474    CALL MPI_Alltoall(nb_domain_recv,1,MPI_INTEGER,nb_domain_send,1,MPI_INTEGER,comm_icosa,ierr)     
475   
476
477    ALLOCATE(list_domain_send(sum(nb_domain_send)))
478   
479    nreq=sum(nb_domain_recv(:))+sum(nb_domain_send(:))
480    ALLOCATE(mpi_req(nreq))
481    ALLOCATE(status(MPI_STATUS_SIZE,nreq))
482   
483    ireq=0
484    DO ind_loc=1,ndomain
485      req=>request(ind_loc)
486      DO irecv=1,req%nrecv
487        ireq=ireq+1
488        CALL MPI_ISEND(req%recv(irecv)%domain,1,MPI_INTEGER,req%recv(irecv)%rank,0,comm_icosa, mpi_req(ireq),ierr)
489      ENDDO
490    ENDDO
491   
492    j=0
493    DO rank=0,mpi_size-1
494      DO i=1,nb_domain_send(rank)
495        j=j+1
496        ireq=ireq+1
497        CALL MPI_IRECV(list_domain_send(j),1,MPI_INTEGER,rank,0,comm_icosa, mpi_req(ireq),ierr)
498      ENDDO
499    ENDDO
500   
501    CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
502   
503    list_domain(:)=0
504    DO i=1,sum(nb_domain_send)
505      ind_loc=list_domain_send(i)
506      list_domain(ind_loc)=list_domain(ind_loc)+1
507    ENDDO
508   
509    DO ind_loc=1,ndomain
510      req=>request(ind_loc)
511      req%nsend=list_domain(ind_loc)
512      ALLOCATE(req%send(req%nsend))
513    ENDDO
514   
515   ireq=0 
516   DO ind_loc=1,ndomain
517     req=>request(ind_loc)
518     
519     DO irecv=1,req%nrecv
520       ireq=ireq+1
521       CALL MPI_ISEND(mpi_rank,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr)
522     ENDDO
523     
524     DO isend=1,req%nsend
525       ireq=ireq+1
526       CALL MPI_IRECV(req%send(isend)%rank,1,MPI_INTEGER,MPI_ANY_SOURCE,ind_loc,comm_icosa, mpi_req(ireq),ierr)
527     ENDDO
528   ENDDO
529
530   CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
531   CALL MPI_BARRIER(comm_icosa,ierr)
532
533   ireq=0 
534   DO ind_loc=1,ndomain
535     req=>request(ind_loc)
536     
537     DO irecv=1,req%nrecv
538       ireq=ireq+1
539       CALL MPI_ISEND(req%recv(irecv)%size,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr)
540     ENDDO
541     
542     DO isend=1,req%nsend
543       ireq=ireq+1
544       CALL MPI_IRECV(req%send(isend)%size,1,MPI_INTEGER,req%send(isend)%rank,ind_loc,comm_icosa, mpi_req(ireq),ierr)
545     ENDDO
546   ENDDO
547
548   CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
549
550   ireq=0 
551   DO ind_loc=1,ndomain
552     req=>request(ind_loc)
553     
554     DO irecv=1,req%nrecv
555       ireq=ireq+1
556       CALL MPI_ISEND(req%recv(irecv)%value,req%recv(irecv)%size,MPI_INTEGER,&
557            req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr)
558     ENDDO
559     
560     DO isend=1,req%nsend
561       ireq=ireq+1
562       ALLOCATE(req%send(isend)%value(req%send(isend)%size))
563       CALL MPI_IRECV(req%send(isend)%value,req%send(isend)%size,MPI_INTEGER,&
564            req%send(isend)%rank,ind_loc,comm_icosa, mpi_req(ireq),ierr)
565     ENDDO
566   ENDDO
567
568   CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
569
570   DO ind_loc=1,ndomain
571     req=>request(ind_loc)
572     
573     DO irecv=1,req%nrecv
574       req%recv(irecv)%value(:)=req%recv(irecv)%buffer(:)
575       req%recv(irecv)%sign(:) =req%recv(irecv)%sign(:)
576       DEALLOCATE(req%recv(irecv)%buffer)
577     ENDDO
578   ENDDO 
579   
580   
581  END SUBROUTINE Finalize_request 
582
583
584  SUBROUTINE init_message_seq(field, request, message)
585  USE field_mod
586  USE domain_mod
587  USE mpi_mod
588  USE mpipara
589  USE mpi_mod
590  IMPLICIT NONE
591    TYPE(t_field),POINTER :: field(:)
592    TYPE(t_request),POINTER :: request(:)
593    TYPE(t_message) :: message
594
595!$OMP MASTER   
596    message%request=>request
597!$OMP END MASTER   
598!$OMP BARRIER   
599
600  END SUBROUTINE init_message_seq
601
602  SUBROUTINE send_message_seq(field,message)
603  USE field_mod
604  USE domain_mod
605  USE mpi_mod
606  USE mpipara
607  USE omp_para
608  USE trace
609  IMPLICIT NONE
610    TYPE(t_field),POINTER :: field(:)
611    TYPE(t_message) :: message
612
613    CALL transfert_request_seq(field,message%request)
614   
615  END SUBROUTINE send_message_seq
616 
617  SUBROUTINE test_message_seq(message)
618  IMPLICIT NONE
619    TYPE(t_message) :: message
620  END SUBROUTINE  test_message_seq
621 
622   
623  SUBROUTINE wait_message_seq(message)
624  IMPLICIT NONE
625    TYPE(t_message) :: message
626   
627  END SUBROUTINE wait_message_seq   
628
629  SUBROUTINE transfert_message_seq(field,message)
630  USE field_mod
631  USE domain_mod
632  USE mpi_mod
633  USE mpipara
634  USE omp_para
635  USE trace
636  IMPLICIT NONE
637    TYPE(t_field),POINTER :: field(:)
638    TYPE(t_message) :: message
639
640   CALL send_message_seq(field,message)
641   
642  END SUBROUTINE transfert_message_seq   
643   
644   
645  SUBROUTINE init_message_mpi(field,request, message)
646  USE field_mod
647  USE domain_mod
648  USE mpi_mod
649  USE mpipara
650  USE mpi_mod
651  IMPLICIT NONE
652 
653    TYPE(t_field),POINTER :: field(:)
654    TYPE(t_request),POINTER :: request(:)
655    TYPE(t_message) :: message
656
657    TYPE(ARRAY),POINTER :: recv,send 
658    TYPE(t_request),POINTER :: req
659    INTEGER :: irecv,isend
660    INTEGER :: ireq,nreq
661    INTEGER :: ind
662    INTEGER :: dim3,dim4
663
664!$OMP MASTER
665    message%request=>request
666    nreq=sum(request(:)%nsend)+sum(request(:)%nrecv)
667    message%nreq=nreq
668    ALLOCATE(message%mpi_req(nreq))
669    ALLOCATE(message%buffers(nreq))
670    ALLOCATE(message%status(MPI_STATUS_SIZE,nreq))
671   
672    message%pending=.FALSE.
673    message%completed=.FALSE.
674   
675    IF (field(1)%data_type==type_real) THEN
676
677      IF (field(1)%ndim==2) THEN
678     
679        ireq=0
680        DO ind=1,ndomain
681          req=>request(ind)
682     
683          DO isend=1,req%nsend
684            ireq=ireq+1
685            send=>req%send(isend)
686            CALL allocate_mpi_buffer(message%buffers(ireq)%r2,send%size)
687          ENDDO
688       
689          DO irecv=1,req%nrecv
690            ireq=ireq+1
691            recv=>req%recv(irecv)
692            CALL allocate_mpi_buffer(message%buffers(ireq)%r2,recv%size)
693          ENDDO
694       
695        ENDDO
696     
697     
698      ELSE  IF (field(1)%ndim==3) THEN
699   
700        ireq=0
701        DO ind=1,ndomain
702          dim3=size(field(ind)%rval3d,2)
703          req=>request(ind)
704 
705          DO isend=1,req%nsend
706            ireq=ireq+1
707            send=>req%send(isend)
708            CALL allocate_mpi_buffer(message%buffers(ireq)%r3,send%size,dim3)
709          ENDDO
710       
711          DO irecv=1,req%nrecv
712            ireq=ireq+1
713            recv=>req%recv(irecv)
714            CALL allocate_mpi_buffer(message%buffers(ireq)%r3,recv%size,dim3)
715
716          ENDDO
717       
718        ENDDO
719
720
721      ELSE  IF (field(1)%ndim==4) THEN
722   
723        ireq=0
724        DO ind=1,ndomain
725          dim3=size(field(ind)%rval4d,2)
726          dim4=size(field(ind)%rval4d,3)
727          req=>request(ind)
728
729          DO isend=1,req%nsend
730            ireq=ireq+1
731            send=>req%send(isend)
732            CALL allocate_mpi_buffer(message%buffers(ireq)%r4,send%size,dim3,dim4)
733          ENDDO
734       
735          DO irecv=1,req%nrecv
736            ireq=ireq+1
737            recv=>req%recv(irecv)
738            CALL allocate_mpi_buffer(message%buffers(ireq)%r4,recv%size,dim3,dim4)
739          ENDDO
740       
741        ENDDO
742     
743      ENDIF     
744    ENDIF
745!$OMP END MASTER
746!$OMP BARRIER   
747  END SUBROUTINE init_message_mpi
748 
749  SUBROUTINE barrier
750  USE mpi_mod
751  USE mpipara
752  IMPLICIT NONE
753   
754    CALL MPI_BARRIER(comm_icosa,ierr)
755   
756  END SUBROUTINE barrier 
757   
758  SUBROUTINE transfert_message_mpi(field,message)
759  USE field_mod
760  IMPLICIT NONE
761    TYPE(t_field),POINTER :: field(:)
762    TYPE(t_message) :: message
763   
764    CALL send_message_mpi(field,message)
765    CALL wait_message_mpi(message)
766   
767  END SUBROUTINE transfert_message_mpi
768
769
770  SUBROUTINE send_message_mpi(field,message)
771  USE field_mod
772  USE domain_mod
773  USE mpi_mod
774  USE mpipara
775  USE omp_para
776  USE trace
777  IMPLICIT NONE
778    TYPE(t_field),POINTER :: field(:)
779    TYPE(t_message) :: message
780    REAL(rstd),POINTER :: rval2d(:) 
781    REAL(rstd),POINTER :: rval3d(:,:) 
782    REAL(rstd),POINTER :: rval4d(:,:,:) 
783    REAL(rstd),POINTER :: buffer_r2(:) 
784    REAL(rstd),POINTER :: buffer_r3(:,:) 
785    REAL(rstd),POINTER :: buffer_r4(:,:,:) 
786    INTEGER,POINTER :: value(:) 
787    INTEGER,POINTER :: sgn(:) 
788    TYPE(ARRAY),POINTER :: recv,send 
789    TYPE(t_request),POINTER :: req
790    INTEGER, ALLOCATABLE :: mpi_req(:)
791    INTEGER, ALLOCATABLE :: status(:,:)
792    INTEGER :: irecv,isend
793    INTEGER :: ireq,nreq
794    INTEGER :: ind,n,l,m
795    INTEGER :: dim3,dim4
796
797!$OMP BARRIER
798
799    CALL trace_start("transfert_mpi")
800
801    nreq=message%nreq
802    message%field=>field
803
804!$OMP MASTER
805    message%completed=.FALSE.
806    message%pending=.TRUE.
807!$OMP END MASTER
808   
809    IF (field(1)%data_type==type_real) THEN
810      IF (field(1)%ndim==2) THEN
811
812        ireq=0
813        DO ind=1,ndomain
814          rval2d=>field(ind)%rval2d
815       
816          req=>message%request(ind)
817          DO isend=1,req%nsend
818            ireq=ireq+1
819            send=>req%send(isend)
820            buffer_r2=>message%buffers(ireq)%r2
821            value=>send%value
822
823            CALL trace_in
824
825!$OMP DO SCHEDULE(STATIC)
826            DO n=1,send%size
827              buffer_r2(n)=rval2d(value(n))
828            ENDDO
829           
830            CALL trace_out
831
832!$OMP MASTER
833            CALL MPI_ISSEND(buffer_r2,send%size,MPI_REAL8,send%rank,ind,comm_icosa, message%mpi_req(ireq),ierr)
834!$OMP END MASTER
835          ENDDO
836       
837          DO irecv=1,req%nrecv
838            ireq=ireq+1
839            recv=>req%recv(irecv)
840            buffer_r2=>message%buffers(ireq)%r2
841!$OMP MASTER
842            CALL MPI_IRECV(buffer_r2,recv%size,MPI_REAL8,recv%rank,recv%domain,comm_icosa, message%mpi_req(ireq),ierr)
843!$OMP END MASTER
844          ENDDO
845       
846        ENDDO
847     
848      ELSE  IF (field(1)%ndim==3) THEN
849     
850        ireq=0
851        DO ind=1,ndomain
852          dim3=size(field(ind)%rval3d,2)
853          rval3d=>field(ind)%rval3d
854          req=>message%request(ind)
855 
856          DO isend=1,req%nsend
857            ireq=ireq+1
858            send=>req%send(isend)
859            buffer_r3=>message%buffers(ireq)%r3
860            value=>send%value
861
862            CALL trace_in
863           
864!$OMP DO SCHEDULE(STATIC)
865              DO n=1,send%size
866                buffer_r3(n,:)=rval3d(value(n),:)
867              ENDDO
868
869             CALL trace_out
870
871!$OMP MASTER
872            CALL MPI_ISSEND(buffer_r3,send%size*dim3,MPI_REAL8,send%rank,ind,comm_icosa, message%mpi_req(ireq),ierr)
873!$OMP END MASTER
874          ENDDO
875       
876          DO irecv=1,req%nrecv
877            ireq=ireq+1
878            recv=>req%recv(irecv)
879            buffer_r3=>message%buffers(ireq)%r3
880!$OMP MASTER           
881            CALL MPI_IRECV(buffer_r3,recv%size*dim3,MPI_REAL8,recv%rank,recv%domain,comm_icosa, message%mpi_req(ireq),ierr)
882!$OMP END MASTER
883
884          ENDDO
885       
886        ENDDO
887
888      ELSE  IF (field(1)%ndim==4) THEN
889   
890        ireq=0
891        DO ind=1,ndomain
892          dim3=size(field(ind)%rval4d,2)
893          dim4=size(field(ind)%rval4d,3)
894          rval4d=>field(ind)%rval4d
895          req=>message%request(ind)
896
897          DO isend=1,req%nsend
898            ireq=ireq+1
899            send=>req%send(isend)
900            buffer_r4=>message%buffers(ireq)%r4
901            value=>send%value
902
903            CALL trace_in
904
905!$OMP DO SCHEDULE(STATIC)
906            DO n=1,send%size
907               buffer_r4(n,:,:)=rval4d(value(n),:,:)
908            ENDDO
909
910           CALL trace_out
911
912!$OMP MASTER
913            CALL MPI_ISSEND(buffer_r4,send%size*dim3*dim4,MPI_REAL8,send%rank,ind,comm_icosa, message%mpi_req(ireq),ierr)
914!$OMP END MASTER
915          ENDDO
916       
917          DO irecv=1,req%nrecv
918            ireq=ireq+1
919            recv=>req%recv(irecv)
920            buffer_r4=>message%buffers(ireq)%r4
921!$OMP MASTER           
922            CALL MPI_IRECV(buffer_r4,recv%size*dim3*dim4,MPI_REAL8,recv%rank,recv%domain,comm_icosa, message%mpi_req(ireq),ierr)
923!$OMP END MASTER
924          ENDDO
925       
926        ENDDO
927     
928      ENDIF     
929     
930    ENDIF
931
932    CALL trace_end("transfert_mpi")
933!$OMP BARRIER
934   
935  END SUBROUTINE send_message_mpi
936 
937  SUBROUTINE test_message_mpi(message)
938  IMPLICIT NONE
939    TYPE(t_message) :: message
940   
941    INTEGER :: ierr
942!$OMP MASTER
943     IF (.NOT. message%pending) RETURN
944!$OMP END MASTER
945
946!$OMP MASTER
947     IF (.NOT. message%completed) CALL MPI_TESTALL(message%nreq,message%mpi_req,message%completed,message%status,ierr)
948!$OMP END MASTER
949  END SUBROUTINE  test_message_mpi
950 
951   
952  SUBROUTINE wait_message_mpi(message)
953  USE field_mod
954  USE domain_mod
955  USE mpi_mod
956  USE mpipara
957  USE omp_para
958  USE trace
959  IMPLICIT NONE
960    TYPE(t_message) :: message
961
962    TYPE(t_field),POINTER :: field(:)
963    REAL(rstd),POINTER :: rval2d(:) 
964    REAL(rstd),POINTER :: rval3d(:,:) 
965    REAL(rstd),POINTER :: rval4d(:,:,:) 
966    REAL(rstd),POINTER :: buffer_r2(:) 
967    REAL(rstd),POINTER :: buffer_r3(:,:) 
968    REAL(rstd),POINTER :: buffer_r4(:,:,:) 
969    INTEGER,POINTER :: value(:) 
970    INTEGER,POINTER :: sgn(:) 
971    TYPE(ARRAY),POINTER :: recv,send 
972    TYPE(t_request),POINTER :: req
973    INTEGER, ALLOCATABLE :: mpi_req(:)
974    INTEGER, ALLOCATABLE :: status(:,:)
975    INTEGER :: irecv,isend
976    INTEGER :: ireq,nreq
977    INTEGER :: ind,n,l,m
978    INTEGER :: dim3,dim4
979
980!$OMP BARRIER
981
982    CALL trace_start("transfert_mpi")
983
984    IF (.NOT. message%pending) RETURN
985   
986    field=>message%field
987    nreq=message%nreq
988   
989    IF (field(1)%data_type==type_real) THEN
990      IF (field(1)%ndim==2) THEN
991
992!$OMP MASTER
993        IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req,message%status,ierr)
994!$OMP END MASTER
995!$OMP BARRIER
996
997        ireq=0       
998        DO ind=1,ndomain
999          rval2d=>field(ind)%rval2d
1000          req=>message%request(ind)
1001
1002          DO isend=1,req%nsend
1003            ireq=ireq+1
1004          ENDDO
1005     
1006          DO irecv=1,req%nrecv
1007            ireq=ireq+1
1008            recv=>req%recv(irecv)
1009            buffer_r2=>message%buffers(ireq)%r2
1010            value=>recv%value
1011            sgn=>recv%sign
1012
1013            CALL trace_in
1014           
1015!$OMP DO SCHEDULE(STATIC)
1016            DO n=1,recv%size
1017              rval2d(value(n))=buffer_r2(n)*sgn(n) 
1018            ENDDO       
1019
1020            CALL trace_out
1021
1022          ENDDO
1023       
1024        ENDDO
1025     
1026     
1027      ELSE  IF (field(1)%ndim==3) THEN
1028
1029!$OMP MASTER
1030        IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req,message%status,ierr)
1031!$OMP END MASTER
1032!$OMP BARRIER
1033
1034        ireq=0       
1035        DO ind=1,ndomain
1036          rval3d=>field(ind)%rval3d
1037          req=>message%request(ind)
1038
1039          DO isend=1,req%nsend
1040            ireq=ireq+1
1041          ENDDO
1042       
1043          DO irecv=1,req%nrecv
1044            ireq=ireq+1
1045            recv=>req%recv(irecv)
1046            buffer_r3=>message%buffers(ireq)%r3
1047            value=>recv%value
1048            sgn=>recv%sign
1049
1050            CALL trace_in
1051           
1052!$OMP DO SCHEDULE(STATIC)
1053            DO n=1,recv%size
1054              rval3d(value(n),:)=buffer_r3(n,:)*sgn(n) 
1055            ENDDO 
1056
1057            CALL trace_out
1058
1059          ENDDO
1060       
1061        ENDDO
1062
1063      ELSE  IF (field(1)%ndim==4) THEN
1064!$OMP MASTER
1065        IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req,message%status,ierr)
1066!$OMP END MASTER
1067!$OMP BARRIER
1068
1069        ireq=0       
1070        DO ind=1,ndomain
1071          rval4d=>field(ind)%rval4d
1072          req=>message%request(ind)
1073
1074          DO isend=1,req%nsend
1075            ireq=ireq+1
1076          ENDDO
1077       
1078          DO irecv=1,req%nrecv
1079            ireq=ireq+1
1080            recv=>req%recv(irecv)
1081            buffer_r4=>message%buffers(ireq)%r4
1082            value=>recv%value
1083            sgn=>recv%sign
1084
1085            CALL trace_in
1086
1087!$OMP DO SCHEDULE(STATIC)
1088            DO n=1,recv%size
1089              rval4d(value(n),:,:)=buffer_r4(n,:,:)*sgn(n) 
1090            ENDDO
1091
1092            CALL trace_out
1093
1094          ENDDO
1095       
1096        ENDDO
1097     
1098      ENDIF     
1099     
1100    ENDIF
1101
1102!$OMP MASTER
1103    message%pending=.FALSE.
1104!$OMP END MASTER
1105
1106    CALL trace_end("transfert_mpi")
1107!$OMP BARRIER
1108   
1109  END SUBROUTINE wait_message_mpi
1110
1111
1112  SUBROUTINE transfert_request_mpi(field,request)
1113  USE field_mod
1114  USE domain_mod
1115  USE mpi_mod
1116  USE mpipara
1117  USE trace
1118  IMPLICIT NONE
1119    TYPE(t_field),POINTER :: field(:)
1120    TYPE(t_request),POINTER :: request(:)
1121    REAL(rstd),POINTER :: rval2d(:) 
1122    REAL(rstd),POINTER :: rval3d(:,:) 
1123    REAL(rstd),POINTER :: rval4d(:,:,:) 
1124    REAL(rstd),POINTER :: buffer_r2(:) 
1125    REAL(rstd),POINTER :: buffer_r3(:,:) 
1126    REAL(rstd),POINTER :: buffer_r4(:,:,:) 
1127    INTEGER,POINTER :: value(:) 
1128    INTEGER,POINTER :: sgn(:) 
1129    TYPE(ARRAY),POINTER :: recv,send 
1130    TYPE(t_request),POINTER :: req
1131    INTEGER, ALLOCATABLE :: mpi_req(:)
1132    INTEGER, ALLOCATABLE :: status(:,:)
1133    INTEGER :: irecv,isend
1134    INTEGER :: ireq,nreq
1135    INTEGER :: ind,n
1136    INTEGER :: dim3,dim4
1137
1138    CALL trace_start("transfert_mpi")
1139
1140    IF (field(1)%data_type==type_real) THEN
1141      IF (field(1)%ndim==2) THEN
1142     
1143        nreq=sum(request(:)%nsend)+sum(request(:)%nrecv)
1144        ALLOCATE(mpi_req(nreq))
1145        ALLOCATE(status(MPI_STATUS_SIZE,nreq))
1146   
1147        ireq=0
1148        DO ind=1,ndomain
1149          rval2d=>field(ind)%rval2d
1150       
1151          req=>request(ind)
1152          DO isend=1,req%nsend
1153            send=>req%send(isend)
1154
1155            ALLOCATE(send%buffer_r2(send%size))
1156            buffer_r2=>send%buffer_r2
1157            value=>send%value
1158            DO n=1,send%size
1159              buffer_r2(n)=rval2d(value(n))
1160            ENDDO
1161
1162            ireq=ireq+1
1163            CALL MPI_ISEND(buffer_r2,send%size,MPI_REAL8,send%rank,ind,comm_icosa, mpi_req(ireq),ierr)
1164          ENDDO
1165       
1166          DO irecv=1,req%nrecv
1167            recv=>req%recv(irecv)
1168            ALLOCATE(recv%buffer_r2(recv%size))
1169           
1170            ireq=ireq+1
1171            CALL MPI_IRECV(recv%buffer_r2,recv%size,MPI_REAL8,recv%rank,recv%domain,comm_icosa, mpi_req(ireq),ierr)
1172          ENDDO
1173       
1174        ENDDO
1175       
1176        CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
1177       
1178        DO ind=1,ndomain
1179          rval2d=>field(ind)%rval2d
1180       
1181          req=>request(ind)
1182          DO isend=1,req%nsend
1183            send=>req%send(isend)
1184            DEALLOCATE(send%buffer_r2)
1185          ENDDO
1186       
1187          DO irecv=1,req%nrecv
1188            recv=>req%recv(irecv)
1189            buffer_r2=>recv%buffer_r2
1190            value=>recv%value
1191            sgn=>recv%sign
1192            DO n=1,recv%size
1193              rval2d(value(n))=buffer_r2(n)*sgn(n) 
1194            ENDDO       
1195            DEALLOCATE(recv%buffer_r2)
1196          ENDDO
1197       
1198        ENDDO
1199     
1200     
1201      ELSE  IF (field(1)%ndim==3) THEN
1202     
1203        nreq=sum(request(:)%nsend)+sum(request(:)%nrecv)
1204        ALLOCATE(mpi_req(nreq))
1205        ALLOCATE(status(MPI_STATUS_SIZE,nreq))
1206   
1207        ireq=0
1208        DO ind=1,ndomain
1209          dim3=size(field(ind)%rval3d,2)
1210          rval3d=>field(ind)%rval3d
1211       
1212          req=>request(ind)
1213          DO isend=1,req%nsend
1214            send=>req%send(isend)
1215
1216            ALLOCATE(send%buffer_r3(send%size,dim3))
1217            buffer_r3=>send%buffer_r3
1218            value=>send%value
1219            DO n=1,send%size
1220              buffer_r3(n,:)=rval3d(value(n),:)
1221            ENDDO
1222
1223            ireq=ireq+1
1224            CALL MPI_ISEND(buffer_r3,send%size*dim3,MPI_REAL8,send%rank,ind,comm_icosa, mpi_req(ireq),ierr)
1225          ENDDO
1226       
1227          DO irecv=1,req%nrecv
1228            recv=>req%recv(irecv)
1229            ALLOCATE(recv%buffer_r3(recv%size,dim3))
1230           
1231            ireq=ireq+1
1232            CALL MPI_IRECV(recv%buffer_r3,recv%size*dim3,MPI_REAL8,recv%rank,recv%domain,comm_icosa, mpi_req(ireq),ierr)
1233          ENDDO
1234       
1235        ENDDO
1236       
1237        CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
1238       
1239        DO ind=1,ndomain
1240          rval3d=>field(ind)%rval3d
1241       
1242          req=>request(ind)
1243          DO isend=1,req%nsend
1244            send=>req%send(isend)
1245            DEALLOCATE(send%buffer_r3)
1246          ENDDO
1247       
1248          DO irecv=1,req%nrecv
1249            recv=>req%recv(irecv)
1250            buffer_r3=>recv%buffer_r3
1251            value=>recv%value
1252            sgn=>recv%sign
1253            DO n=1,recv%size
1254              rval3d(value(n),:)=buffer_r3(n,:)*sgn(n) 
1255            ENDDO       
1256            DEALLOCATE(recv%buffer_r3)
1257          ENDDO
1258       
1259        ENDDO
1260
1261      ELSE  IF (field(1)%ndim==4) THEN
1262     
1263        nreq=sum(request(:)%nsend)+sum(request(:)%nrecv)
1264        ALLOCATE(mpi_req(nreq))
1265        ALLOCATE(status(MPI_STATUS_SIZE,nreq))
1266   
1267        ireq=0
1268        DO ind=1,ndomain
1269          dim3=size(field(ind)%rval4d,2)
1270          dim4=size(field(ind)%rval4d,3)
1271          rval4d=>field(ind)%rval4d
1272       
1273          req=>request(ind)
1274          DO isend=1,req%nsend
1275            send=>req%send(isend)
1276
1277            ALLOCATE(send%buffer_r4(send%size,dim3,dim4))
1278            buffer_r4=>send%buffer_r4
1279            value=>send%value
1280            DO n=1,send%size
1281              buffer_r4(n,:,:)=rval4d(value(n),:,:)
1282            ENDDO
1283
1284            ireq=ireq+1
1285            CALL MPI_ISEND(buffer_r4,send%size*dim3*dim4,MPI_REAL8,send%rank,ind,comm_icosa, mpi_req(ireq),ierr)
1286          ENDDO
1287       
1288          DO irecv=1,req%nrecv
1289            recv=>req%recv(irecv)
1290            ALLOCATE(recv%buffer_r4(recv%size,dim3,dim4))
1291           
1292            ireq=ireq+1
1293            CALL MPI_IRECV(recv%buffer_r4,recv%size*dim3*dim4,MPI_REAL8,recv%rank,recv%domain,comm_icosa, mpi_req(ireq),ierr)
1294          ENDDO
1295       
1296        ENDDO
1297       
1298        CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
1299       
1300        DO ind=1,ndomain
1301          rval4d=>field(ind)%rval4d
1302       
1303          req=>request(ind)
1304          DO isend=1,req%nsend
1305            send=>req%send(isend)
1306            DEALLOCATE(send%buffer_r4)
1307          ENDDO
1308       
1309          DO irecv=1,req%nrecv
1310            recv=>req%recv(irecv)
1311            buffer_r4=>recv%buffer_r4
1312            value=>recv%value
1313            sgn=>recv%sign
1314            DO n=1,recv%size
1315              rval4d(value(n),:,:)=buffer_r4(n,:,:)*sgn(n) 
1316            ENDDO       
1317            DEALLOCATE(recv%buffer_r4)
1318          ENDDO
1319       
1320        ENDDO
1321     
1322      ENDIF     
1323     
1324    ENDIF
1325
1326    CALL trace_end("transfert_mpi")
1327   
1328  END SUBROUTINE transfert_request_mpi
1329   
1330  SUBROUTINE transfert_request_seq(field,request)
1331  USE field_mod
1332  USE domain_mod
1333  IMPLICIT NONE
1334    TYPE(t_field),POINTER :: field(:)
1335    TYPE(t_request),POINTER :: request(:)
1336    REAL(rstd),POINTER :: rval2d(:) 
1337    REAL(rstd),POINTER :: rval3d(:,:) 
1338    REAL(rstd),POINTER :: rval4d(:,:,:) 
1339    INTEGER :: ind
1340    TYPE(t_request),POINTER :: req
1341    INTEGER :: n
1342    REAL(rstd) :: var1,var2
1343   
1344    DO ind=1,ndomain
1345      req=>request(ind)
1346      rval2d=>field(ind)%rval2d
1347      rval3d=>field(ind)%rval3d
1348      rval4d=>field(ind)%rval4d
1349     
1350      IF (field(ind)%data_type==type_real) THEN
1351        IF (field(ind)%ndim==2) THEN
1352          DO n=1,req%size
1353            rval2d(req%target_ind(n))=field(req%src_domain(n))%rval2d(req%src_ind(n))*req%target_sign(n)
1354          ENDDO
1355        ELSE IF (field(ind)%ndim==3) THEN
1356          DO n=1,req%size
1357            rval3d(req%target_ind(n),:)=field(req%src_domain(n))%rval3d(req%src_ind(n),:)*req%target_sign(n)
1358          ENDDO
1359        ELSE IF (field(ind)%ndim==4) THEN
1360          DO n=1,req%size
1361            rval4d(req%target_ind(n),:,:)=field(req%src_domain(n))%rval4d(req%src_ind(n),:,:)*req%target_sign(n)
1362          ENDDO
1363        ENDIF
1364      ENDIF       
1365
1366    ENDDO
1367   
1368  END SUBROUTINE transfert_request_seq
1369 
1370 
1371  SUBROUTINE gather_field(field_loc,field_glo)
1372  USE field_mod
1373  USE domain_mod
1374  USE mpi_mod
1375  USE mpipara
1376  IMPLICIT NONE
1377    TYPE(t_field),POINTER :: field_loc(:)
1378    TYPE(t_field),POINTER :: field_glo(:)
1379    INTEGER, ALLOCATABLE :: mpi_req(:)
1380    INTEGER, ALLOCATABLE :: status(:,:)
1381    INTEGER :: ireq,nreq
1382    INTEGER :: ind_glo,ind_loc   
1383 
1384    IF (.NOT. using_mpi) THEN
1385   
1386      DO ind_loc=1,ndomain
1387        IF (field_loc(ind_loc)%ndim==2) field_glo(ind_loc)%rval2d=field_loc(ind_loc)%rval2d
1388        IF (field_loc(ind_loc)%ndim==3) field_glo(ind_loc)%rval3d=field_loc(ind_loc)%rval3d
1389        IF (field_loc(ind_loc)%ndim==4) field_glo(ind_loc)%rval4d=field_loc(ind_loc)%rval4d
1390      ENDDO
1391   
1392    ELSE
1393         
1394      nreq=ndomain
1395      IF (mpi_rank==0) nreq=nreq+ndomain_glo 
1396      ALLOCATE(mpi_req(nreq))
1397      ALLOCATE(status(MPI_STATUS_SIZE,nreq))
1398   
1399   
1400      ireq=0
1401      IF (mpi_rank==0) THEN
1402        DO ind_glo=1,ndomain_glo
1403          ireq=ireq+1
1404
1405          IF (field_glo(ind_glo)%ndim==2) THEN
1406            CALL MPI_IRECV(field_glo(ind_glo)%rval2d,size(field_glo(ind_glo)%rval2d) , MPI_REAL8 ,   &
1407                         domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
1408   
1409          ELSE IF (field_glo(ind_glo)%ndim==3) THEN
1410            CALL MPI_IRECV(field_glo(ind_glo)%rval3d,size(field_glo(ind_glo)%rval3d) , MPI_REAL8 ,   &
1411                         domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
1412
1413          ELSE IF (field_glo(ind_glo)%ndim==4) THEN
1414            CALL MPI_IRECV(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 ,   &
1415                         domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
1416          ENDIF
1417         
1418        ENDDO
1419      ENDIF
1420 
1421      DO ind_loc=1,ndomain
1422        ireq=ireq+1
1423
1424        IF (field_loc(ind_loc)%ndim==2) THEN
1425          CALL MPI_ISEND(field_loc(ind_loc)%rval2d,size(field_loc(ind_loc)%rval2d) , MPI_REAL8 ,   &
1426                         0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
1427        ELSE IF (field_loc(ind_loc)%ndim==3) THEN
1428          CALL MPI_ISEND(field_loc(ind_loc)%rval3d,size(field_loc(ind_loc)%rval3d) , MPI_REAL8 ,   &
1429                         0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
1430        ELSE IF (field_loc(ind_loc)%ndim==4) THEN
1431          CALL MPI_ISEND(field_loc(ind_loc)%rval4d,size(field_loc(ind_loc)%rval4d) , MPI_REAL8 ,   &
1432                         0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
1433        ENDIF
1434     
1435      ENDDO
1436   
1437      CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
1438
1439    ENDIF
1440       
1441  END SUBROUTINE gather_field
1442
1443   
1444  SUBROUTINE trace_in
1445  USE trace
1446  IMPLICIT NONE
1447 
1448    CALL trace_start("transfert_buffer")
1449  END SUBROUTINE trace_in             
1450
1451  SUBROUTINE trace_out
1452  USE trace
1453  IMPLICIT NONE
1454 
1455    CALL trace_end("transfert_buffer")
1456  END SUBROUTINE trace_out             
1457
1458END MODULE transfert_mpi_mod
1459     
1460       
1461       
1462       
1463     
Note: See TracBrowser for help on using the repository browser.