Context Navigation

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

Last change on this file since 199 was 193, checked in by ymipsl, 10 years ago

bug fix : MPI_THREAD_SINGLE was not managed, so for not multithreaded mpi stack environment, crash may occur.

YM

File size: 47.7 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: