Context Navigation

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

Last change on this file since 363 was 358, checked in by llfita, 9 years ago

Modifying code to be 'gfortran' compatible:

Change WRITE(' ',)... by PRINT *,
Shorten some code lines

File size: 57.8 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
78	INTERFACE bcast_mpi
79	MODULE PROCEDURE bcast_mpi_c, &
80	bcast_mpi_i,bcast_mpi_i1,bcast_mpi_i2,bcast_mpi_i3,bcast_mpi_i4, &
81	bcast_mpi_r,bcast_mpi_r1,bcast_mpi_r2,bcast_mpi_r3,bcast_mpi_r4, &
82	bcast_mpi_l,bcast_mpi_l1,bcast_mpi_l2,bcast_mpi_l3,bcast_mpi_l4
83	END INTERFACE
84
85
86
87	CONTAINS
88
89
90	SUBROUTINE init_transfert
91	USE domain_mod
92	USE dimensions
93	USE field_mod
94	USE metric
95	USE mpipara
96	USE mpi_mod
97	IMPLICIT NONE
98	INTEGER :: ind,i,j
99	LOGICAL ::ok
100
101	CALL create_request(field_t,req_i1)
102
103	DO ind=1,ndomain
104	CALL swap_dimensions(ind)
105	DO i=ii_begin,ii_end+1
106	CALL request_add_point(ind,i,jj_begin-1,req_i1)
107	ENDDO
108
109	DO j=jj_begin,jj_end
110	CALL request_add_point(ind,ii_end+1,j,req_i1)
111	ENDDO
112	DO i=ii_begin,ii_end
113	CALL request_add_point(ind,i,jj_end+1,req_i1)
114	ENDDO
115
116	DO j=jj_begin,jj_end+1
117	CALL request_add_point(ind,ii_begin-1,j,req_i1)
118	ENDDO
119
120	ENDDO
121
122	CALL finalize_request(req_i1)
123
124
125	CALL create_request(field_t,req_i0)
126
127	DO ind=1,ndomain
128	CALL swap_dimensions(ind)
129
130	DO i=ii_begin,ii_end
131	CALL request_add_point(ind,i,jj_begin,req_i0)
132	ENDDO
133
134	DO j=jj_begin,jj_end
135	CALL request_add_point(ind,ii_end,j,req_i0)
136	ENDDO
137
138	DO i=ii_begin,ii_end
139	CALL request_add_point(ind,i,jj_end,req_i0)
140	ENDDO
141
142	DO j=jj_begin,jj_end
143	CALL request_add_point(ind,ii_begin,j,req_i0)
144	ENDDO
145
146	ENDDO
147
148	CALL finalize_request(req_i0)
149
150
151	CALL create_request(field_u,req_e1_scal)
152	DO ind=1,ndomain
153	CALL swap_dimensions(ind)
154	DO i=ii_begin,ii_end
155	CALL request_add_point(ind,i,jj_begin-1,req_e1_scal,rup)
156	CALL request_add_point(ind,i+1,jj_begin-1,req_e1_scal,lup)
157	ENDDO
158
159	DO j=jj_begin,jj_end
160	CALL request_add_point(ind,ii_end+1,j,req_e1_scal,left)
161	ENDDO
162	DO j=jj_begin,jj_end
163	CALL request_add_point(ind,ii_end+1,j-1,req_e1_scal,lup)
164	ENDDO
165
166	DO i=ii_begin,ii_end
167	CALL request_add_point(ind,i,jj_end+1,req_e1_scal,ldown)
168	CALL request_add_point(ind,i-1,jj_end+1,req_e1_scal,rdown)
169	ENDDO
170
171	DO j=jj_begin,jj_end
172	CALL request_add_point(ind,ii_begin-1,j,req_e1_scal,right)
173	ENDDO
174	DO j=jj_begin,jj_end
175	CALL request_add_point(ind,ii_begin-1,j+1,req_e1_scal,rdown)
176	ENDDO
177
178	ENDDO
179
180	CALL finalize_request(req_e1_scal)
181
182
183	CALL create_request(field_u,req_e0_scal)
184	DO ind=1,ndomain
185	CALL swap_dimensions(ind)
186
187
188	DO i=ii_begin+1,ii_end-1
189	CALL request_add_point(ind,i,jj_begin,req_e0_scal,right)
190	CALL request_add_point(ind,i,jj_end,req_e0_scal,right)
191	ENDDO
192
193	DO j=jj_begin+1,jj_end-1
194	CALL request_add_point(ind,ii_begin,j,req_e0_scal,rup)
195	CALL request_add_point(ind,ii_end,j,req_e0_scal,rup)
196	ENDDO
197
198	CALL request_add_point(ind,ii_begin+1,jj_begin,req_e0_scal,left)
199	CALL request_add_point(ind,ii_begin,jj_begin+1,req_e0_scal,ldown)
200	CALL request_add_point(ind,ii_begin+1,jj_end,req_e0_scal,left)
201	CALL request_add_point(ind,ii_end,jj_begin+1,req_e0_scal,ldown)
202
203	ENDDO
204
205	CALL finalize_request(req_e0_scal)
206
207
208
209	CALL create_request(field_u,req_e1_vect,.TRUE.)
210	DO ind=1,ndomain
211	CALL swap_dimensions(ind)
212	DO i=ii_begin,ii_end
213	CALL request_add_point(ind,i,jj_begin-1,req_e1_vect,rup)
214	CALL request_add_point(ind,i+1,jj_begin-1,req_e1_vect,lup)
215	ENDDO
216
217	DO j=jj_begin,jj_end
218	CALL request_add_point(ind,ii_end+1,j,req_e1_vect,left)
219	ENDDO
220	DO j=jj_begin,jj_end
221	CALL request_add_point(ind,ii_end+1,j-1,req_e1_vect,lup)
222	ENDDO
223
224	DO i=ii_begin,ii_end
225	CALL request_add_point(ind,i,jj_end+1,req_e1_vect,ldown)
226	CALL request_add_point(ind,i-1,jj_end+1,req_e1_vect,rdown)
227	ENDDO
228
229	DO j=jj_begin,jj_end
230	CALL request_add_point(ind,ii_begin-1,j,req_e1_vect,right)
231	ENDDO
232	DO j=jj_begin,jj_end
233	CALL request_add_point(ind,ii_begin-1,j+1,req_e1_vect,rdown)
234	ENDDO
235
236
237	ENDDO
238
239	CALL finalize_request(req_e1_vect)
240
241
242	CALL create_request(field_u,req_e0_vect,.TRUE.)
243	DO ind=1,ndomain
244	CALL swap_dimensions(ind)
245
246	DO i=ii_begin+1,ii_end-1
247	CALL request_add_point(ind,i,jj_begin,req_e0_vect,right)
248	CALL request_add_point(ind,i,jj_end,req_e0_vect,right)
249	ENDDO
250
251	DO j=jj_begin+1,jj_end-1
252	CALL request_add_point(ind,ii_begin,j,req_e0_vect,rup)
253	CALL request_add_point(ind,ii_end,j,req_e0_vect,rup)
254	ENDDO
255
256	CALL request_add_point(ind,ii_begin+1,jj_begin,req_e0_vect,left)
257	CALL request_add_point(ind,ii_begin,jj_begin+1,req_e0_vect,ldown)
258	CALL request_add_point(ind,ii_begin+1,jj_end,req_e0_vect,left)
259	CALL request_add_point(ind,ii_end,jj_begin+1,req_e0_vect,ldown)
260
261	ENDDO
262
263	CALL finalize_request(req_e0_vect)
264
265
266	END SUBROUTINE init_transfert
267
268	SUBROUTINE create_request(type_field,request,vector)
269	USE domain_mod
270	USE field_mod
271	IMPLICIT NONE
272	INTEGER :: type_field
273	TYPE(t_request),POINTER :: request(:)
274	LOGICAL,OPTIONAL :: vector
275
276	TYPE(t_request),POINTER :: req
277	TYPE(t_domain),POINTER :: d
278	INTEGER :: ind
279	INTEGER :: max_size
280
281	ALLOCATE(request(ndomain))
282
283	DO ind=1,ndomain
284	req=>request(ind)
285	d=>domain(ind)
286	IF (type_field==field_t) THEN
287	Max_size=2(d%iim+2)+2(d%jjm+2)
288	ELSE IF (type_field==field_u) THEN
289	Max_size=3(2(d%iim+2)+2*(d%jjm+2))
290	ELSE IF (type_field==field_z) THEN
291	Max_size=2(2(d%iim+2)+2*(d%jjm+2))
292	ENDIF
293
294	req%type_field=type_field
295	req%max_size=max_size*2
296	req%size=0
297	req%vector=.FALSE.
298	IF (PRESENT(vector)) req%vector=vector
299	ALLOCATE(req%src_domain(req%max_size))
300	ALLOCATE(req%src_ind(req%max_size))
301	ALLOCATE(req%target_ind(req%max_size))
302	ALLOCATE(req%src_i(req%max_size))
303	ALLOCATE(req%src_j(req%max_size))
304	ALLOCATE(req%target_i(req%max_size))
305	ALLOCATE(req%target_j(req%max_size))
306	ALLOCATE(req%target_sign(req%max_size))
307	ENDDO
308
309	END SUBROUTINE create_request
310
311	SUBROUTINE reallocate_request(req)
312	IMPLICIT NONE
313	TYPE(t_request),POINTER :: req
314
315	INTEGER,POINTER :: src_domain(:)
316	INTEGER,POINTER :: src_ind(:)
317	INTEGER,POINTER :: target_ind(:)
318	INTEGER,POINTER :: src_i(:)
319	INTEGER,POINTER :: src_j(:)
320	INTEGER,POINTER :: target_i(:)
321	INTEGER,POINTER :: target_j(:)
322	INTEGER,POINTER :: target_sign(:)
323
324	PRINT *,"REALLOCATE_REQUEST"
325	src_domain=>req%src_domain
326	src_ind=>req%src_ind
327	target_ind=>req%target_ind
328	src_i=>req%src_i
329	src_j=>req%src_j
330	target_i=>req%target_i
331	target_j=>req%target_j
332	target_sign=>req%target_sign
333
334	ALLOCATE(req%src_domain(req%max_size*2))
335	ALLOCATE(req%src_ind(req%max_size*2))
336	ALLOCATE(req%target_ind(req%max_size*2))
337	ALLOCATE(req%src_i(req%max_size*2))
338	ALLOCATE(req%src_j(req%max_size*2))
339	ALLOCATE(req%target_i(req%max_size*2))
340	ALLOCATE(req%target_j(req%max_size*2))
341	ALLOCATE(req%target_sign(req%max_size*2))
342
343	req%src_domain(1:req%max_size)=src_domain(:)
344	req%src_ind(1:req%max_size)=src_ind(:)
345	req%target_ind(1:req%max_size)=target_ind(:)
346	req%src_i(1:req%max_size)=src_i(:)
347	req%src_j(1:req%max_size)=src_j(:)
348	req%target_i(1:req%max_size)=target_i(:)
349	req%target_j(1:req%max_size)=target_j(:)
350	req%target_sign(1:req%max_size)=target_sign(:)
351
352	req%max_size=req%max_size*2
353
354	DEALLOCATE(src_domain)
355	DEALLOCATE(src_ind)
356	DEALLOCATE(target_ind)
357	DEALLOCATE(src_i)
358	DEALLOCATE(src_j)
359	DEALLOCATE(target_i)
360	DEALLOCATE(target_j)
361	DEALLOCATE(target_sign)
362
363	END SUBROUTINE reallocate_request
364
365
366	SUBROUTINE request_add_point(ind,i,j,request,pos)
367	USE domain_mod
368	USE field_mod
369	IMPLICIT NONE
370	INTEGER,INTENT(IN) :: ind
371	INTEGER,INTENT(IN) :: i
372	INTEGER,INTENT(IN) :: j
373	TYPE(t_request),POINTER :: request(:)
374	INTEGER,INTENT(IN),OPTIONAL :: pos
375
376	INTEGER :: src_domain
377	INTEGER :: src_iim,src_i,src_j,src_n,src_pos,src_delta
378	TYPE(t_request),POINTER :: req
379	TYPE(t_domain),POINTER :: d
380
381	req=>request(ind)
382	d=>domain(ind)
383
384	IF (req%max_size==req%size) CALL reallocate_request(req)
385	req%size=req%size+1
386	IF (req%type_field==field_t) THEN
387	src_domain=domain(ind)%assign_domain(i,j)
388	src_iim=domain_glo(src_domain)%iim
389	src_i=domain(ind)%assign_i(i,j)
390	src_j=domain(ind)%assign_j(i,j)
391
392	req%target_ind(req%size)=(j-1)*d%iim+i
393	req%target_sign(req%size)=1
394	req%src_domain(req%size)=src_domain
395	req%src_ind(req%size)=(src_j-1)*src_iim+src_i
396	ELSE IF (req%type_field==field_u) THEN
397	IF (.NOT. PRESENT(pos)) STOP 'argument request_add_point non conforme'
398
399	src_domain=domain(ind)%edge_assign_domain(pos-1,i,j)
400	src_iim=domain_glo(src_domain)%iim
401	src_i=domain(ind)%edge_assign_i(pos-1,i,j)
402	src_j=domain(ind)%edge_assign_j(pos-1,i,j)
403	src_n=(src_j-1)*src_iim+src_i
404	src_delta=domain(ind)%delta(i,j)
405	src_pos=domain(ind)%edge_assign_pos(pos-1,i,j)+1
406
407	req%target_ind(req%size)=(j-1)*d%iim+i+d%u_pos(pos)
408
409	req%target_sign(req%size)= 1
410	IF (req%vector) req%target_sign(req%size)= domain(ind)%edge_assign_sign(pos-1,i,j)
411
412	req%src_domain(req%size)=src_domain
413	req%src_ind(req%size)=src_n+domain_glo(src_domain)%u_pos(src_pos)
414
415	ELSE IF (req%type_field==field_z) THEN
416	IF (.NOT. PRESENT(pos)) STOP 'argument request_add_point non conforme'
417
418	src_domain=domain(ind)%assign_domain(i,j)
419	src_iim=domain_glo(src_domain)%iim
420	src_i=domain(ind)%assign_i(i,j)
421	src_j=domain(ind)%assign_j(i,j)
422	src_n=(src_j-1)*src_iim+src_i
423	src_delta=domain(ind)%delta(i,j)
424
425	src_pos=MOD(pos-1+src_delta+6,6)+1
426
427	req%target_ind(req%size)=(j-1)*d%iim+i+d%z_pos(pos)
428	req%target_sign(req%size)=1
429	req%src_domain(req%size)=src_domain
430	req%src_ind(req%size)=src_n+domain_glo(src_domain)%z_pos(src_pos)
431	ENDIF
432	END SUBROUTINE request_add_point
433
434
435	SUBROUTINE Finalize_request(request)
436	USE mpipara
437	USE domain_mod
438	USE mpi_mod
439	IMPLICIT NONE
440	TYPE(t_request),POINTER :: request(:)
441	TYPE(t_request),POINTER :: req, req_src
442	INTEGER :: nb_domain_recv(0:mpi_size-1)
443	INTEGER :: nb_domain_send(0:mpi_size-1)
444	INTEGER :: tag_rank(0:mpi_size-1)
445	INTEGER :: nb_data_domain_recv(ndomain_glo)
446	INTEGER :: list_domain_recv(ndomain_glo)
447	INTEGER,ALLOCATABLE :: list_domain_send(:)
448	INTEGER :: list_domain(ndomain)
449
450	INTEGER :: rank,i,j,pos
451	INTEGER :: size_,ind_glo,ind_loc, ind_src
452	INTEGER :: isend, irecv, ireq, nreq, nsend, nrecv
453	INTEGER, ALLOCATABLE :: mpi_req(:)
454	INTEGER, ALLOCATABLE :: status(:,:)
455	INTEGER, ALLOCATABLE :: rank_list(:)
456	INTEGER, ALLOCATABLE :: offset(:)
457	LOGICAL,PARAMETER :: debug = .FALSE.
458
459
460	IF (.NOT. using_mpi) RETURN
461
462	DO ind_loc=1,ndomain
463	req=>request(ind_loc)
464
465	nb_data_domain_recv(:) = 0
466	nb_domain_recv(:) = 0
467	tag_rank(:)=0
468
469	DO i=1,req%size
470	ind_glo=req%src_domain(i)
471	nb_data_domain_recv(ind_glo)=nb_data_domain_recv(ind_glo)+1
472	ENDDO
473
474	DO ind_glo=1,ndomain_glo
475	IF ( nb_data_domain_recv(ind_glo) > 0 ) nb_domain_recv(domglo_rank(ind_glo))=nb_domain_recv(domglo_rank(ind_glo))+1
476	ENDDO
477
478	req%nrecv=sum(nb_domain_recv(:))
479	ALLOCATE(req%recv(req%nrecv))
480
481	irecv=0
482	DO ind_glo=1,ndomain_glo
483	IF (nb_data_domain_recv(ind_glo)>0) THEN
484	irecv=irecv+1
485	list_domain_recv(ind_glo)=irecv
486	req%recv(irecv)%rank=domglo_rank(ind_glo)
487	req%recv(irecv)%size=nb_data_domain_recv(ind_glo)
488	req%recv(irecv)%domain=domglo_loc_ind(ind_glo)
489	ALLOCATE(req%recv(irecv)%value(req%recv(irecv)%size))
490	ALLOCATE(req%recv(irecv)%sign(req%recv(irecv)%size))
491	ALLOCATE(req%recv(irecv)%buffer(req%recv(irecv)%size))
492	ENDIF
493	ENDDO
494
495	req%recv(:)%size=0
496	irecv=0
497	DO i=1,req%size
498	irecv=list_domain_recv(req%src_domain(i))
499	req%recv(irecv)%size=req%recv(irecv)%size+1
500	size_=req%recv(irecv)%size
501	req%recv(irecv)%value(size_)=req%src_ind(i)
502	req%recv(irecv)%buffer(size_)=req%target_ind(i)
503	req%recv(irecv)%sign(size_)=req%target_sign(i)
504	ENDDO
505	ENDDO
506
507	nb_domain_recv(:) = 0
508	DO ind_loc=1,ndomain
509	req=>request(ind_loc)
510
511	DO irecv=1,req%nrecv
512	rank=req%recv(irecv)%rank
513	nb_domain_recv(rank)=nb_domain_recv(rank)+1
514	ENDDO
515	ENDDO
516
517	CALL MPI_Alltoall(nb_domain_recv,1,MPI_INTEGER,nb_domain_send,1,MPI_INTEGER,comm_icosa,ierr)
518
519
520	ALLOCATE(list_domain_send(sum(nb_domain_send)))
521
522	nreq=sum(nb_domain_recv(:))+sum(nb_domain_send(:))
523	ALLOCATE(mpi_req(nreq))
524	ALLOCATE(status(MPI_STATUS_SIZE,nreq))
525
526
527	ireq=0
528	DO ind_loc=1,ndomain
529	req=>request(ind_loc)
530	DO irecv=1,req%nrecv
531	ireq=ireq+1
532	CALL MPI_ISEND(req%recv(irecv)%domain,1,MPI_INTEGER,req%recv(irecv)%rank,0,comm_icosa, mpi_req(ireq),ierr)
533	IF (debug) PRINT *,"Isend ",req%recv(irecv)%domain, "from ", mpi_rank, "to ",req%recv(irecv)%rank, "tag ",0
534	ENDDO
535	ENDDO
536
537	IF (debug) PRINT *,"------------"
538	j=0
539	DO rank=0,mpi_size-1
540	DO i=1,nb_domain_send(rank)
541	j=j+1
542	ireq=ireq+1
543	CALL MPI_IRECV(list_domain_send(j),1,MPI_INTEGER,rank,0,comm_icosa, mpi_req(ireq),ierr)
544	IF (debug) PRINT *,"IRecv ",list_domain_send(j), "from ", rank, "to ",mpi_rank, "tag ",0
545	ENDDO
546	ENDDO
547	IF (debug) PRINT *,"------------"
548
549	CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
550
551	list_domain(:)=0
552	DO i=1,sum(nb_domain_send)
553	ind_loc=list_domain_send(i)
554	list_domain(ind_loc)=list_domain(ind_loc)+1
555	ENDDO
556
557	DO ind_loc=1,ndomain
558	req=>request(ind_loc)
559	req%nsend=list_domain(ind_loc)
560	ALLOCATE(req%send(req%nsend))
561	ENDDO
562
563	IF (debug) PRINT *,"------------"
564
565	ireq=0
566	DO ind_loc=1,ndomain
567	req=>request(ind_loc)
568
569	DO irecv=1,req%nrecv
570	ireq=ireq+1
571	CALL MPI_ISEND(mpi_rank,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr)
572	IF (debug) PRINT *,"Isend ",mpi_rank, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain
573	ENDDO
574	IF (debug) PRINT *,"------------"
575
576	DO isend=1,req%nsend
577	ireq=ireq+1
578	CALL MPI_IRECV(req%send(isend)%rank,1,MPI_INTEGER,MPI_ANY_SOURCE,ind_loc,comm_icosa, mpi_req(ireq),ierr)
579	IF (debug) PRINT *,"IRecv ",req%send(isend)%rank, "from ", "xxx", "to ",mpi_rank, "tag ",ind_loc
580	ENDDO
581	ENDDO
582
583	IF (debug) PRINT *,"------------"
584
585	CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
586	CALL MPI_BARRIER(comm_icosa,ierr)
587
588	IF (debug) PRINT *,"------------"
589
590	ireq=0
591	DO ind_loc=1,ndomain
592	req=>request(ind_loc)
593
594	DO irecv=1,req%nrecv
595	ireq=ireq+1
596	CALL MPI_ISEND(ind_loc,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr)
597	IF (debug) PRINT *,"Isend ",ind_loc, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain
598	ENDDO
599
600	IF (debug) PRINT *,"------------"
601
602	DO isend=1,req%nsend
603	ireq=ireq+1
604	CALL MPI_IRECV(req%send(isend)%domain,1,MPI_INTEGER,req%send(isend)%rank,ind_loc,comm_icosa, mpi_req(ireq),ierr)
605	IF (debug) PRINT *,"IRecv ",req%send(isend)%domain, "from ", req%send(isend)%rank, "to ",mpi_rank, "tag ",ind_loc
606	ENDDO
607	ENDDO
608	IF (debug) PRINT *,"------------"
609
610	CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
611	CALL MPI_BARRIER(comm_icosa,ierr)
612	IF (debug) PRINT *,"------------"
613
614	ireq=0
615	DO ind_loc=1,ndomain
616	req=>request(ind_loc)
617
618	DO irecv=1,req%nrecv
619	ireq=ireq+1
620	req%recv(irecv)%tag=tag_rank(req%recv(irecv)%rank)
621	tag_rank(req%recv(irecv)%rank)=tag_rank(req%recv(irecv)%rank)+1
622	CALL MPI_ISEND(req%recv(irecv)%tag,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%domain,comm_icosa, mpi_req(ireq),ierr)
623	IF (debug) PRINT *,"Isend ",req%recv(irecv)%tag, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain
624	ENDDO
625	IF (debug) PRINT *,"------------"
626
627	DO isend=1,req%nsend
628	ireq=ireq+1
629	CALL MPI_IRECV(req%send(isend)%tag,1,MPI_INTEGER,req%send(isend)%rank,ind_loc,comm_icosa, mpi_req(ireq),ierr)
630	IF (debug) PRINT *,"IRecv ",req%send(isend)%tag, "from ", req%send(isend)%rank, "to ",mpi_rank, "tag ",ind_loc
631	ENDDO
632	ENDDO
633	IF (debug) PRINT *,"------------"
634
635	CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
636	CALL MPI_BARRIER(comm_icosa,ierr)
637
638
639	IF (debug) PRINT *,"------------"
640
641	ireq=0
642	DO ind_loc=1,ndomain
643	req=>request(ind_loc)
644
645	DO irecv=1,req%nrecv
646	ireq=ireq+1
647	CALL MPI_ISEND(req%recv(irecv)%size,1,MPI_INTEGER,req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr)
648	IF (debug) PRINT *,"Isend ",req%recv(irecv)%size, "from ", mpi_rank, "to ",req%recv(irecv)%rank,"tag ",req%recv(irecv)%domain
649	ENDDO
650	IF (debug) PRINT *,"------------"
651
652	DO isend=1,req%nsend
653	ireq=ireq+1
654	CALL MPI_IRECV(req%send(isend)%size,1,MPI_INTEGER,req%send(isend)%rank,req%send(isend)%tag,comm_icosa, mpi_req(ireq),ierr)
655	IF (debug) PRINT *,"IRecv ",req%send(isend)%size, "from ", req%send(isend)%rank, "to ",mpi_rank, "tag ",ind_loc
656	ENDDO
657	ENDDO
658
659	CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
660
661	ireq=0
662	DO ind_loc=1,ndomain
663	req=>request(ind_loc)
664
665	DO irecv=1,req%nrecv
666	ireq=ireq+1
667	CALL MPI_ISEND(req%recv(irecv)%value,req%recv(irecv)%size,MPI_INTEGER,&
668	req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr)
669	ENDDO
670
671	DO isend=1,req%nsend
672	ireq=ireq+1
673	ALLOCATE(req%send(isend)%value(req%send(isend)%size))
674	CALL MPI_IRECV(req%send(isend)%value,req%send(isend)%size,MPI_INTEGER,&
675	req%send(isend)%rank,req%send(isend)%tag,comm_icosa, mpi_req(ireq),ierr)
676	ENDDO
677	ENDDO
678
679	CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
680
681	DO ind_loc=1,ndomain
682	req=>request(ind_loc)
683
684	DO irecv=1,req%nrecv
685	req%recv(irecv)%value(:)=req%recv(irecv)%buffer(:)
686	req%recv(irecv)%sign(:) =req%recv(irecv)%sign(:)
687	DEALLOCATE(req%recv(irecv)%buffer)
688	ENDDO
689	ENDDO
690
691
692	! domain is on the same mpi process => copie memory to memory
693
694	DO ind_loc=1,ndomain
695	req=>request(ind_loc)
696
697	DO irecv=1,req%nrecv
698
699	IF (req%recv(irecv)%rank==mpi_rank) THEN
700	req_src=>request(req%recv(irecv)%domain)
701	DO isend=1,req_src%nsend
702	IF (req_src%send(isend)%rank==mpi_rank .AND. req_src%send(isend)%tag==req%recv(irecv)%tag) THEN
703	req%recv(irecv)%src_value => req_src%send(isend)%value
704	IF ( size(req%recv(irecv)%value) /= size(req_src%send(isend)%value)) THEN
705	PRINT *,ind_loc, irecv, isend, size(req%recv(irecv)%value), size(req_src%send(isend)%value)
706	STOP "size(req%recv(irecv)%value) /= size(req_src%send(isend)%value"
707	ENDIF
708	ENDIF
709	ENDDO
710	ENDIF
711
712	ENDDO
713	ENDDO
714
715	! true number of mpi request
716
717	request(:)%nreq_mpi=0
718	request(:)%nreq_send=0
719	request(:)%nreq_recv=0
720	ALLOCATE(rank_list(sum(request(:)%nsend)))
721	ALLOCATE(offset(sum(request(:)%nsend)))
722	offset(:)=0
723
724	nsend=0
725	DO ind_loc=1,ndomain
726	req=>request(ind_loc)
727
728	DO isend=1,req%nsend
729	IF (req%send(isend)%rank/=mpi_rank) THEN
730	pos=0
731	DO i=1,nsend
732	IF (req%send(isend)%rank==rank_list(i)) EXIT
733	pos=pos+1
734	ENDDO
735
736	IF (pos==nsend) THEN
737	nsend=nsend+1
738	req%nreq_mpi=req%nreq_mpi+1
739	req%nreq_send=req%nreq_send+1
740	IF (mpi_threading_mode==MPI_THREAD_FUNNELED .OR. mpi_threading_mode==MPI_THREAD_SINGLE) THEN
741	rank_list(nsend)=req%send(isend)%rank
742	ELSE
743	rank_list(nsend)=-1
744	ENDIF
745	ENDIF
746
747	pos=pos+1
748	req%send(isend)%ireq=pos
749	req%send(isend)%offset=offset(pos)
750	offset(pos)=offset(pos)+req%send(isend)%size
751	ENDIF
752	ENDDO
753	ENDDO
754
755	DEALLOCATE(rank_list)
756	DEALLOCATE(offset)
757
758	ALLOCATE(rank_list(sum(request(:)%nrecv)))
759	ALLOCATE(offset(sum(request(:)%nrecv)))
760	offset(:)=0
761
762	nrecv=0
763	DO ind_loc=1,ndomain
764	req=>request(ind_loc)
765
766	DO irecv=1,req%nrecv
767	IF (req%recv(irecv)%rank/=mpi_rank) THEN
768	pos=0
769	DO i=1,nrecv
770	IF (req%recv(irecv)%rank==rank_list(i)) EXIT
771	pos=pos+1
772	ENDDO
773
774	IF (pos==nrecv) THEN
775	nrecv=nrecv+1
776	req%nreq_mpi=req%nreq_mpi+1
777	req%nreq_recv=req%nreq_recv+1
778	IF (mpi_threading_mode==MPI_THREAD_FUNNELED .OR. mpi_threading_mode==MPI_THREAD_SINGLE) THEN
779	rank_list(nrecv)=req%recv(irecv)%rank
780	ELSE
781	rank_list(nrecv)=-1
782	ENDIF
783	ENDIF
784
785	pos=pos+1
786	req%recv(irecv)%ireq=nsend+pos
787	req%recv(irecv)%offset=offset(pos)
788	offset(pos)=offset(pos)+req%recv(irecv)%size
789	ENDIF
790	ENDDO
791	ENDDO
792
793	! get the offsets
794
795	ireq=0
796	DO ind_loc=1,ndomain
797	req=>request(ind_loc)
798
799	DO irecv=1,req%nrecv
800	ireq=ireq+1
801	CALL MPI_ISEND(req%recv(irecv)%offset,1,MPI_INTEGER,&
802	req%recv(irecv)%rank,req%recv(irecv)%tag,comm_icosa, mpi_req(ireq),ierr)
803	ENDDO
804
805	DO isend=1,req%nsend
806	ireq=ireq+1
807	CALL MPI_IRECV(req%send(isend)%offset,1,MPI_INTEGER,&
808	req%send(isend)%rank,req%send(isend)%tag,comm_icosa, mpi_req(ireq),ierr)
809	ENDDO
810	ENDDO
811
812	CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
813
814
815	END SUBROUTINE Finalize_request
816
817
818	SUBROUTINE init_message_seq(field, request, message)
819	USE field_mod
820	USE domain_mod
821	USE mpi_mod
822	USE mpipara
823	USE mpi_mod
824	IMPLICIT NONE
825	TYPE(t_field),POINTER :: field(:)
826	TYPE(t_request),POINTER :: request(:)
827	TYPE(t_message) :: message
828
829	!$OMP MASTER
830	message%request=>request
831	!$OMP END MASTER
832	!$OMP BARRIER
833
834	END SUBROUTINE init_message_seq
835
836	SUBROUTINE send_message_seq(field,message)
837	USE field_mod
838	USE domain_mod
839	USE mpi_mod
840	USE mpipara
841	USE omp_para
842	USE trace
843	IMPLICIT NONE
844	TYPE(t_field),POINTER :: field(:)
845	TYPE(t_message) :: message
846
847	CALL transfert_request_seq(field,message%request)
848
849	END SUBROUTINE send_message_seq
850
851	SUBROUTINE test_message_seq(message)
852	IMPLICIT NONE
853	TYPE(t_message) :: message
854	END SUBROUTINE test_message_seq
855
856
857	SUBROUTINE wait_message_seq(message)
858	IMPLICIT NONE
859	TYPE(t_message) :: message
860
861	END SUBROUTINE wait_message_seq
862
863	SUBROUTINE transfert_message_seq(field,message)
864	USE field_mod
865	USE domain_mod
866	USE mpi_mod
867	USE mpipara
868	USE omp_para
869	USE trace
870	IMPLICIT NONE
871	TYPE(t_field),POINTER :: field(:)
872	TYPE(t_message) :: message
873
874	CALL send_message_seq(field,message)
875
876	END SUBROUTINE transfert_message_seq
877
878
879
880
881	SUBROUTINE init_message_mpi(field,request, message)
882	USE field_mod
883	USE domain_mod
884	USE mpi_mod
885	USE mpipara
886	USE mpi_mod
887	IMPLICIT NONE
888
889	TYPE(t_field),POINTER :: field(:)
890	TYPE(t_request),POINTER :: request(:)
891	TYPE(t_message) :: message
892
893	TYPE(ARRAY),POINTER :: recv,send
894	TYPE(t_request),POINTER :: req
895	INTEGER :: irecv,isend
896	INTEGER :: ireq,nreq, nreq_send
897	INTEGER :: ind
898	INTEGER :: dim3,dim4
899	INTEGER :: i,j
900	INTEGER,SAVE :: message_number=0
901	! TYPE(t_reorder),POINTER :: reorder(:)
902	! TYPE(t_reorder) :: reorder_swap
903
904	!$OMP BARRIER
905	!$OMP MASTER
906	message%number=message_number
907	message_number=message_number+1
908	IF (message_number==100) message_number=0
909
910
911	message%request=>request
912	message%nreq=sum(message%request(:)%nreq_mpi)
913	message%nreq_send=sum(message%request(:)%nreq_send)
914	message%nreq_recv=sum(message%request(:)%nreq_recv)
915	nreq=message%nreq
916
917	ALLOCATE(message%mpi_req(nreq))
918	ALLOCATE(message%buffers(nreq))
919	ALLOCATE(message%status(MPI_STATUS_SIZE,nreq))
920	message%buffers(:)%size=0
921	message%pending=.FALSE.
922	message%completed=.FALSE.
923
924	DO ind=1,ndomain
925	req=>request(ind)
926	DO isend=1,req%nsend
927	IF (req%send(isend)%rank/=mpi_rank) THEN
928	ireq=req%send(isend)%ireq
929	message%buffers(ireq)%size=message%buffers(ireq)%size+req%send(isend)%size
930	message%buffers(ireq)%rank=req%send(isend)%rank
931	ENDIF
932	ENDDO
933	DO irecv=1,req%nrecv
934	IF (req%recv(irecv)%rank/=mpi_rank) THEN
935	ireq=req%recv(irecv)%ireq
936	message%buffers(ireq)%size=message%buffers(ireq)%size+req%recv(irecv)%size
937	message%buffers(ireq)%rank=req%recv(irecv)%rank
938	ENDIF
939	ENDDO
940	ENDDO
941
942
943	IF (field(1)%data_type==type_real) THEN
944
945	IF (field(1)%ndim==2) THEN
946
947	DO ireq=1,message%nreq
948	CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size)
949	ENDDO
950
951	ELSE IF (field(1)%ndim==3) THEN
952
953	dim3=size(field(1)%rval3d,2)
954	DO ireq=1,message%nreq
955	message%buffers(ireq)%size=message%buffers(ireq)%size*dim3
956	CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size)
957	ENDDO
958
959	ELSE IF (field(1)%ndim==4) THEN
960	dim3=size(field(1)%rval4d,2)
961	dim4=size(field(1)%rval4d,3)
962	DO ireq=1,message%nreq
963	message%buffers(ireq)%size=message%buffers(ireq)%sizedim3dim4
964	CALL allocate_mpi_buffer(message%buffers(ireq)%r,message%buffers(ireq)%size)
965	ENDDO
966	ENDIF
967	ENDIF
968
969
970
971	! ! Reorder the request, so recv request are done in the same order than send request
972
973	! nreq_send=sum(request(:)%nsend)
974	! message%nreq_send=nreq_send
975	! ALLOCATE(message%reorder(nreq_send))
976	! reorder=>message%reorder
977	! ireq=0
978	! DO ind=1,ndomain
979	! req=>request(ind)
980	! DO isend=1,req%nsend
981	! ireq=ireq+1
982	! reorder(ireq)%ind=ind
983	! reorder(ireq)%isend=isend
984	! reorder(ireq)%tag=req%send(isend)%tag
985	! ENDDO
986	! ENDDO
987
988	! ! do a very very bad sort
989	! DO i=1,nreq_send-1
990	! DO j=i+1,nreq_send
991	! IF (reorder(i)%tag > reorder(j)%tag) THEN
992	! reorder_swap=reorder(i)
993	! reorder(i)=reorder(j)
994	! reorder(j)=reorder_swap
995	! ENDIF
996	! ENDDO
997	! ENDDO
998	! PRINT *,"reorder ",reorder(:)%tag
999
1000
1001	!$OMP END MASTER
1002	!$OMP BARRIER
1003
1004	END SUBROUTINE init_message_mpi
1005
1006	SUBROUTINE Finalize_message_mpi(field,message)
1007	USE field_mod
1008	USE domain_mod
1009	USE mpi_mod
1010	USE mpipara
1011	USE mpi_mod
1012	IMPLICIT NONE
1013	TYPE(t_field),POINTER :: field(:)
1014	TYPE(t_message) :: message
1015
1016	TYPE(t_request),POINTER :: req
1017	INTEGER :: irecv,isend
1018	INTEGER :: ireq,nreq
1019	INTEGER :: ind
1020
1021	!$OMP BARRIER
1022	!$OMP MASTER
1023
1024
1025	IF (field(1)%data_type==type_real) THEN
1026
1027	IF (field(1)%ndim==2) THEN
1028
1029	DO ireq=1,message%nreq
1030	CALL free_mpi_buffer(message%buffers(ireq)%r)
1031	ENDDO
1032
1033	ELSE IF (field(1)%ndim==3) THEN
1034
1035	DO ireq=1,message%nreq
1036	CALL free_mpi_buffer(message%buffers(ireq)%r)
1037	ENDDO
1038
1039	ELSE IF (field(1)%ndim==4) THEN
1040
1041	DO ireq=1,message%nreq
1042	CALL free_mpi_buffer(message%buffers(ireq)%r)
1043	ENDDO
1044
1045	ENDIF
1046	ENDIF
1047
1048
1049
1050	!$OMP END MASTER
1051	!$OMP BARRIER
1052
1053
1054	END SUBROUTINE Finalize_message_mpi
1055
1056
1057
1058	SUBROUTINE barrier
1059	USE mpi_mod
1060	USE mpipara
1061	IMPLICIT NONE
1062
1063	CALL MPI_BARRIER(comm_icosa,ierr)
1064
1065	END SUBROUTINE barrier
1066
1067	SUBROUTINE transfert_message_mpi(field,message)
1068	USE field_mod
1069	IMPLICIT NONE
1070	TYPE(t_field),POINTER :: field(:)
1071	TYPE(t_message) :: message
1072
1073	CALL send_message_mpi(field,message)
1074	CALL wait_message_mpi(message)
1075
1076	END SUBROUTINE transfert_message_mpi
1077
1078
1079	SUBROUTINE send_message_mpi(field,message)
1080	USE field_mod
1081	USE domain_mod
1082	USE mpi_mod
1083	USE mpipara
1084	USE omp_para
1085	USE trace
1086	IMPLICIT NONE
1087	TYPE(t_field),POINTER :: field(:)
1088	TYPE(t_message) :: message
1089	REAL(rstd),POINTER :: rval2d(:), src_rval2d(:)
1090	REAL(rstd),POINTER :: rval3d(:,:), src_rval3d(:,:)
1091	REAL(rstd),POINTER :: rval4d(:,:,:), src_rval4d(:,:,:)
1092	REAL(rstd),POINTER :: buffer_r(:)
1093	INTEGER,POINTER :: value(:)
1094	INTEGER,POINTER :: sgn(:)
1095	TYPE(ARRAY),POINTER :: recv,send
1096	TYPE(t_request),POINTER :: req
1097	INTEGER, ALLOCATABLE :: mpi_req(:)
1098	INTEGER, ALLOCATABLE :: status(:,:)
1099	INTEGER :: irecv,isend
1100	INTEGER :: ireq,nreq
1101	INTEGER :: ind,i,n,l,m
1102	INTEGER :: dim3,dim4,d3,d4
1103	INTEGER,POINTER :: src_value(:)
1104	INTEGER,POINTER :: sign(:)
1105	INTEGER :: offset,msize,rank
1106	INTEGER :: lbegin, lend
1107
1108	! CALL trace_start("send_message_mpi")
1109
1110	!$OMP BARRIER
1111
1112
1113	!$OMP MASTER
1114	message%field=>field
1115
1116	IF (message%nreq>0) THEN
1117	message%completed=.FALSE.
1118	message%pending=.TRUE.
1119	ELSE
1120	message%completed=.TRUE.
1121	message%pending=.FALSE.
1122	ENDIF
1123	!$OMP END MASTER
1124	!$OMP BARRIER
1125
1126	IF (field(1)%data_type==type_real) THEN
1127	IF (field(1)%ndim==2) THEN
1128
1129	DO ind=1,ndomain
1130	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
1131
1132	rval2d=>field(ind)%rval2d
1133
1134	req=>message%request(ind)
1135	DO isend=1,req%nsend
1136	send=>req%send(isend)
1137	value=>send%value
1138
1139
1140	IF (send%rank/=mpi_rank) THEN
1141	ireq=send%ireq
1142
1143	buffer_r=>message%buffers(ireq)%r
1144	offset=send%offset
1145
1146	DO n=1,send%size
1147	buffer_r(offset+n)=rval2d(value(n))
1148	ENDDO
1149
1150	IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN
1151	!$OMP CRITICAL
1152	CALL MPI_ISEND(buffer_r,send%size,MPI_REAL8,send%rank, &
1153	send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
1154	!$OMP END CRITICAL
1155	ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN
1156	CALL MPI_ISEND(buffer_r,send%size,MPI_REAL8,send%rank, &
1157	send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
1158	ENDIF
1159
1160	ENDIF
1161	ENDDO
1162	ENDDO
1163
1164	DO ind=1,ndomain
1165	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
1166	rval2d=>field(ind)%rval2d
1167	req=>message%request(ind)
1168
1169	DO irecv=1,req%nrecv
1170	recv=>req%recv(irecv)
1171
1172	IF (recv%rank==mpi_rank) THEN
1173
1174	value=>recv%value
1175	src_value => recv%src_value
1176	src_rval2d=>field(recv%domain)%rval2d
1177	sgn=>recv%sign
1178
1179	DO n=1,recv%size
1180	rval2d(value(n))=src_rval2d(src_value(n))*sgn(n)
1181	ENDDO
1182
1183
1184	ELSE
1185
1186	ireq=recv%ireq
1187	buffer_r=>message%buffers(ireq)%r
1188	IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN
1189	!$OMP CRITICAL
1190	CALL MPI_IRECV(buffer_r,recv%size,MPI_REAL8,recv%rank, &
1191	recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
1192	!$OMP END CRITICAL
1193	ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN
1194	CALL MPI_IRECV(buffer_r,recv%size,MPI_REAL8,recv%rank, &
1195	recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
1196	ENDIF
1197
1198	ENDIF
1199	ENDDO
1200
1201	ENDDO
1202
1203
1204	ELSE IF (field(1)%ndim==3) THEN
1205
1206	DO ind=1,ndomain
1207	IF (.NOT. assigned_domain(ind) ) CYCLE
1208
1209	dim3=size(field(ind)%rval3d,2)
1210	CALL distrib_level(dim3,lbegin,lend)
1211
1212	rval3d=>field(ind)%rval3d
1213	req=>message%request(ind)
1214
1215	DO isend=1,req%nsend
1216	send=>req%send(isend)
1217	value=>send%value
1218
1219	IF (send%rank/=mpi_rank) THEN
1220	ireq=send%ireq
1221	buffer_r=>message%buffers(ireq)%r
1222
1223	offset=send%offsetdim3 + (lbegin-1)send%size
1224
1225	CALL trace_start("copy_to_buffer")
1226
1227	DO d3=lbegin,lend
1228	DO n=1,send%size
1229	buffer_r(n+offset)=rval3d(value(n),d3)
1230	ENDDO
1231	offset=offset+send%size
1232	ENDDO
1233	CALL trace_end("copy_to_buffer")
1234
1235	IF (is_omp_level_master) THEN
1236	IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN
1237	!$OMP CRITICAL
1238	CALL MPI_ISEND(buffer_r,send%size*dim3,MPI_REAL8,send%rank, &
1239	send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
1240	!$OMP END CRITICAL
1241	ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN
1242	CALL MPI_ISEND(buffer_r,send%size*dim3,MPI_REAL8,send%rank, &
1243	send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
1244	ENDIF
1245	ENDIF
1246	ENDIF
1247	ENDDO
1248	ENDDO
1249
1250	DO ind=1,ndomain
1251	IF (.NOT. assigned_domain(ind) ) CYCLE
1252	dim3=size(field(ind)%rval3d,2)
1253	CALL distrib_level(dim3,lbegin,lend)
1254	rval3d=>field(ind)%rval3d
1255	req=>message%request(ind)
1256
1257	DO irecv=1,req%nrecv
1258	recv=>req%recv(irecv)
1259
1260	IF (recv%rank==mpi_rank) THEN
1261	value=>recv%value
1262	src_value => recv%src_value
1263	src_rval3d=>field(recv%domain)%rval3d
1264	sgn=>recv%sign
1265
1266	CALL trace_start("copy_data")
1267
1268	DO d3=lbegin,lend
1269	DO n=1,recv%size
1270	rval3d(value(n),d3)=src_rval3d(src_value(n),d3)*sgn(n)
1271	ENDDO
1272	ENDDO
1273	CALL trace_end("copy_data")
1274
1275	ELSE
1276	ireq=recv%ireq
1277	buffer_r=>message%buffers(ireq)%r
1278
1279	IF (is_omp_level_master) THEN
1280	IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN
1281	!$OMP CRITICAL
1282	CALL MPI_IRECV(buffer_r,recv%size*dim3,MPI_REAL8,recv%rank, &
1283	recv%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_IRECV(buffer_r,recv%size*dim3,MPI_REAL8,recv%rank, &
1287	recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
1288	ENDIF
1289	ENDIF
1290	ENDIF
1291	ENDDO
1292
1293	ENDDO
1294
1295	ELSE IF (field(1)%ndim==4) THEN
1296
1297	DO ind=1,ndomain
1298	IF (.NOT. assigned_domain(ind) ) CYCLE
1299
1300	dim3=size(field(ind)%rval4d,2)
1301	CALL distrib_level(dim3,lbegin,lend)
1302	dim4=size(field(ind)%rval4d,3)
1303	rval4d=>field(ind)%rval4d
1304	req=>message%request(ind)
1305
1306	DO isend=1,req%nsend
1307	send=>req%send(isend)
1308	value=>send%value
1309
1310	IF (send%rank/=mpi_rank) THEN
1311
1312	ireq=send%ireq
1313	buffer_r=>message%buffers(ireq)%r
1314
1315	CALL trace_start("copy_to_buffer")
1316	DO d4=1,dim4
1317	offset=send%offsetdim3dim4 + dim3send%size(d4-1) + &
1318	(lbegin-1)*send%size
1319
1320	DO d3=lbegin,lend
1321	DO n=1,send%size
1322	buffer_r(n+offset)=rval4d(value(n),d3,d4)
1323	ENDDO
1324	offset=offset+send%size
1325	ENDDO
1326	ENDDO
1327	CALL trace_end("copy_to_buffer")
1328
1329	IF (is_omp_level_master) THEN
1330	IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN
1331	!$OMP CRITICAL
1332	CALL MPI_ISEND(buffer_r,send%sizedim3dim4,MPI_REAL8,send%rank, &
1333	send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
1334	!$OMP END CRITICAL
1335	ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN
1336	CALL MPI_ISEND(buffer_r,send%sizedim3dim4,MPI_REAL8,send%rank, &
1337	send%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
1338	ENDIF
1339	ENDIF
1340
1341	ENDIF
1342	ENDDO
1343	ENDDO
1344
1345	DO ind=1,ndomain
1346	IF (.NOT. assigned_domain(ind) ) CYCLE
1347
1348	dim3=size(field(ind)%rval4d,2)
1349	CALL distrib_level(dim3,lbegin,lend)
1350	dim4=size(field(ind)%rval4d,3)
1351	rval4d=>field(ind)%rval4d
1352	req=>message%request(ind)
1353
1354	DO irecv=1,req%nrecv
1355	recv=>req%recv(irecv)
1356	IF (recv%rank==mpi_rank) THEN
1357	value=>recv%value
1358	src_value => recv%src_value
1359	src_rval4d=>field(recv%domain)%rval4d
1360	sgn=>recv%sign
1361
1362	CALL trace_start("copy_data")
1363	DO d4=1,dim4
1364	DO d3=lbegin,lend
1365	DO n=1,recv%size
1366	rval4d(value(n),d3,d4)=src_rval4d(src_value(n),d3,d4)*sgn(n)
1367	ENDDO
1368	ENDDO
1369	ENDDO
1370
1371	CALL trace_end("copy_data")
1372
1373	ELSE
1374
1375	ireq=recv%ireq
1376	buffer_r=>message%buffers(ireq)%r
1377	IF (is_omp_level_master) THEN
1378	IF (mpi_threading_mode==MPI_THREAD_SERIALIZED) THEN
1379	!$OMP CRITICAL
1380	CALL MPI_IRECV(buffer_r,recv%sizedim3dim4,MPI_REAL8,recv%rank, &
1381	recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
1382	!$OMP END CRITICAL
1383	ELSE IF (mpi_threading_mode==MPI_THREAD_MULTIPLE) THEN
1384	CALL MPI_IRECV(buffer_r,recv%sizedim3dim4,MPI_REAL8,recv%rank, &
1385	recv%tag+1000*message%number,comm_icosa, message%mpi_req(ireq),ierr)
1386	ENDIF
1387	ENDIF
1388	ENDIF
1389	ENDDO
1390	ENDDO
1391
1392	ENDIF
1393
1394	IF (mpi_threading_mode==MPI_THREAD_FUNNELED .OR. mpi_threading_mode==MPI_THREAD_SINGLE) THEN
1395	!$OMP BARRIER
1396	!$OMP MASTER
1397
1398	DO ireq=1,message%nreq_send
1399	buffer_r=>message%buffers(ireq)%r
1400	msize=message%buffers(ireq)%size
1401	rank=message%buffers(ireq)%rank
1402	CALL MPI_ISEND(buffer_r,msize,MPI_REAL8,rank,1000*message%number, &
1403	comm_icosa, message%mpi_req(ireq),ierr)
1404	ENDDO
1405
1406	DO ireq=message%nreq_send+1,message%nreq_send+message%nreq_recv
1407	buffer_r=>message%buffers(ireq)%r
1408	msize=message%buffers(ireq)%size
1409	rank=message%buffers(ireq)%rank
1410	CALL MPI_IRECV(buffer_r,msize,MPI_REAL8,rank,1000*message%number, &
1411	comm_icosa, message%mpi_req(ireq),ierr)
1412	ENDDO
1413
1414	!$OMP END MASTER
1415	ENDIF
1416	ENDIF
1417
1418	!$OMP BARRIER
1419	! CALL trace_end("send_message_mpi")
1420
1421	END SUBROUTINE send_message_mpi
1422
1423	SUBROUTINE test_message_mpi(message)
1424	IMPLICIT NONE
1425	TYPE(t_message) :: message
1426
1427	INTEGER :: ierr
1428
1429	!$OMP MASTER
1430	IF (message%pending .AND. .NOT. message%completed) CALL MPI_TESTALL(message%nreq,&
1431	message%mpi_req,message%completed,message%status,ierr)
1432	!$OMP END MASTER
1433	END SUBROUTINE test_message_mpi
1434
1435
1436	SUBROUTINE wait_message_mpi(message)
1437	USE field_mod
1438	USE domain_mod
1439	USE mpi_mod
1440	USE mpipara
1441	USE omp_para
1442	USE trace
1443	IMPLICIT NONE
1444	TYPE(t_message) :: message
1445
1446	TYPE(t_field),POINTER :: field(:)
1447	REAL(rstd),POINTER :: rval2d(:)
1448	REAL(rstd),POINTER :: rval3d(:,:)
1449	REAL(rstd),POINTER :: rval4d(:,:,:)
1450	REAL(rstd),POINTER :: buffer_r(:)
1451	INTEGER,POINTER :: value(:)
1452	INTEGER,POINTER :: sgn(:)
1453	TYPE(ARRAY),POINTER :: recv,send
1454	TYPE(t_request),POINTER :: req
1455	INTEGER, ALLOCATABLE :: mpi_req(:)
1456	INTEGER, ALLOCATABLE :: status(:,:)
1457	INTEGER :: irecv,isend
1458	INTEGER :: ireq,nreq
1459	INTEGER :: ind,n,l,m,i
1460	INTEGER :: dim3,dim4,d3,d4,lbegin,lend
1461	INTEGER :: offset
1462
1463	IF (.NOT. message%pending) RETURN
1464
1465	! CALL trace_start("wait_message_mpi")
1466
1467	field=>message%field
1468	nreq=message%nreq
1469
1470	IF (field(1)%data_type==type_real) THEN
1471	IF (field(1)%ndim==2) THEN
1472
1473	!$OMP MASTER
1474	IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req, &
1475	message%status,ierr)
1476	!$OMP END MASTER
1477	!$OMP BARRIER
1478
1479	DO ind=1,ndomain
1480	IF (.NOT. assigned_domain(ind) .OR. .NOT. is_omp_level_master) CYCLE
1481
1482	rval2d=>field(ind)%rval2d
1483	req=>message%request(ind)
1484	DO irecv=1,req%nrecv
1485	recv=>req%recv(irecv)
1486	IF (recv%rank/=mpi_rank) THEN
1487	ireq=recv%ireq
1488	buffer_r=>message%buffers(ireq)%r
1489	value=>recv%value
1490	sgn=>recv%sign
1491	offset=recv%offset
1492	DO n=1,recv%size
1493	rval2d(value(n))=buffer_r(n+offset)*sgn(n)
1494	ENDDO
1495
1496	ENDIF
1497	ENDDO
1498
1499	ENDDO
1500
1501
1502	ELSE IF (field(1)%ndim==3) THEN
1503
1504	!$OMP MASTER
1505	IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req, &
1506	message%status,ierr)
1507	!$OMP END MASTER
1508	!$OMP BARRIER
1509
1510
1511	DO ind=1,ndomain
1512	IF (.NOT. assigned_domain(ind) ) CYCLE
1513
1514	rval3d=>field(ind)%rval3d
1515	req=>message%request(ind)
1516	DO irecv=1,req%nrecv
1517	recv=>req%recv(irecv)
1518	IF (recv%rank/=mpi_rank) THEN
1519	ireq=recv%ireq
1520	buffer_r=>message%buffers(ireq)%r
1521	value=>recv%value
1522	sgn=>recv%sign
1523
1524	dim3=size(rval3d,2)
1525
1526	CALL distrib_level(dim3,lbegin,lend)
1527	offset=recv%offsetdim3 + (lbegin-1)recv%size
1528	CALL trace_start("copy_from_buffer")
1529
1530	IF (req%vector) THEN
1531	DO d3=lbegin,lend
1532	DO n=1,recv%size
1533	rval3d(value(n),d3)=buffer_r(n+offset)*sgn(n)
1534	ENDDO
1535	offset=offset+recv%size
1536	ENDDO
1537	ELSE
1538	DO d3=lbegin,lend
1539	DO n=1,recv%size
1540	rval3d(value(n),d3)=buffer_r(n+offset)
1541	ENDDO
1542	offset=offset+recv%size
1543	ENDDO
1544	ENDIF
1545
1546	CALL trace_end("copy_from_buffer")
1547	ENDIF
1548	ENDDO
1549
1550	ENDDO
1551
1552	ELSE IF (field(1)%ndim==4) THEN
1553	!$OMP MASTER
1554	IF (.NOT. message%completed) CALL MPI_WAITALL(nreq,message%mpi_req, &
1555	message%status,ierr)
1556	!$OMP END MASTER
1557	!$OMP BARRIER
1558
1559
1560	DO ind=1,ndomain
1561	IF (.NOT. assigned_domain(ind) ) CYCLE
1562
1563	rval4d=>field(ind)%rval4d
1564	req=>message%request(ind)
1565	DO irecv=1,req%nrecv
1566	recv=>req%recv(irecv)
1567	IF (recv%rank/=mpi_rank) THEN
1568	ireq=recv%ireq
1569	buffer_r=>message%buffers(ireq)%r
1570	value=>recv%value
1571	sgn=>recv%sign
1572
1573	dim3=size(rval4d,2)
1574	CALL distrib_level(dim3,lbegin,lend)
1575	dim4=size(rval4d,3)
1576	CALL trace_start("copy_from_buffer")
1577	DO d4=1,dim4
1578	offset=recv%offsetdim3dim4 + dim3recv%size(d4-1) + &
1579	(lbegin-1)*recv%size
1580	DO d3=lbegin,lend
1581	DO n=1,recv%size
1582	rval4d(value(n),d3,d4)=buffer_r(n+offset)*sgn(n)
1583	ENDDO
1584	offset=offset+recv%size
1585	ENDDO
1586	ENDDO
1587	CALL trace_end("copy_from_buffer")
1588	ENDIF
1589	ENDDO
1590
1591	ENDDO
1592
1593	ENDIF
1594
1595	ENDIF
1596
1597	!$OMP MASTER
1598	message%pending=.FALSE.
1599	!$OMP END MASTER
1600
1601	! CALL trace_end("wait_message_mpi")
1602	!$OMP BARRIER
1603
1604	END SUBROUTINE wait_message_mpi
1605
1606	SUBROUTINE transfert_request_mpi(field,request)
1607	USE field_mod
1608	IMPLICIT NONE
1609	TYPE(t_field),POINTER :: field(:)
1610	TYPE(t_request),POINTER :: request(:)
1611
1612	TYPE(t_message),SAVE :: message
1613
1614
1615	CALL init_message_mpi(field,request, message)
1616	CALL transfert_message_mpi(field,message)
1617	CALL finalize_message_mpi(field,message)
1618
1619	END SUBROUTINE transfert_request_mpi
1620
1621
1622
1623	SUBROUTINE transfert_request_seq(field,request)
1624	USE field_mod
1625	USE domain_mod
1626	IMPLICIT NONE
1627	TYPE(t_field),POINTER :: field(:)
1628	TYPE(t_request),POINTER :: request(:)
1629	REAL(rstd),POINTER :: rval2d(:)
1630	REAL(rstd),POINTER :: rval3d(:,:)
1631	REAL(rstd),POINTER :: rval4d(:,:,:)
1632	INTEGER :: ind
1633	TYPE(t_request),POINTER :: req
1634	INTEGER :: n
1635	REAL(rstd) :: var1,var2
1636
1637	DO ind=1,ndomain
1638	req=>request(ind)
1639	rval2d=>field(ind)%rval2d
1640	rval3d=>field(ind)%rval3d
1641	rval4d=>field(ind)%rval4d
1642
1643	IF (field(ind)%data_type==type_real) THEN
1644	IF (field(ind)%ndim==2) THEN
1645	DO n=1,req%size
1646	rval2d(req%target_ind(n))=field(req%src_domain(n))%rval2d(req%src_ind(n))*&
1647	req%target_sign(n)
1648	ENDDO
1649	ELSE IF (field(ind)%ndim==3) THEN
1650	DO n=1,req%size
1651	rval3d(req%target_ind(n),:)=field(req%src_domain(n))%rval3d(req%src_ind(n),:)*&
1652	req%target_sign(n)
1653	ENDDO
1654	ELSE IF (field(ind)%ndim==4) THEN
1655	DO n=1,req%size
1656	rval4d(req%target_ind(n),:,:)=field(req%src_domain(n))%rval4d(req%src_ind(n),:,:)*&
1657	req%target_sign(n)
1658	ENDDO
1659	ENDIF
1660	ENDIF
1661
1662	ENDDO
1663
1664	END SUBROUTINE transfert_request_seq
1665
1666
1667	SUBROUTINE gather_field(field_loc,field_glo)
1668	USE field_mod
1669	USE domain_mod
1670	USE mpi_mod
1671	USE mpipara
1672	IMPLICIT NONE
1673	TYPE(t_field),POINTER :: field_loc(:)
1674	TYPE(t_field),POINTER :: field_glo(:)
1675	INTEGER, ALLOCATABLE :: mpi_req(:)
1676	INTEGER, ALLOCATABLE :: status(:,:)
1677	INTEGER :: ireq,nreq
1678	INTEGER :: ind_glo,ind_loc
1679
1680	IF (.NOT. using_mpi) THEN
1681
1682	DO ind_loc=1,ndomain
1683	IF (field_loc(ind_loc)%ndim==2) field_glo(ind_loc)%rval2d=field_loc(ind_loc)%rval2d
1684	IF (field_loc(ind_loc)%ndim==3) field_glo(ind_loc)%rval3d=field_loc(ind_loc)%rval3d
1685	IF (field_loc(ind_loc)%ndim==4) field_glo(ind_loc)%rval4d=field_loc(ind_loc)%rval4d
1686	ENDDO
1687
1688	ELSE
1689
1690	nreq=ndomain
1691	IF (mpi_rank==0) nreq=nreq+ndomain_glo
1692	ALLOCATE(mpi_req(nreq))
1693	ALLOCATE(status(MPI_STATUS_SIZE,nreq))
1694
1695
1696	ireq=0
1697	IF (mpi_rank==0) THEN
1698	DO ind_glo=1,ndomain_glo
1699	ireq=ireq+1
1700
1701	IF (field_glo(ind_glo)%ndim==2) THEN
1702	CALL MPI_IRECV(field_glo(ind_glo)%rval2d,size(field_glo(ind_glo)%rval2d) , MPI_REAL8 , &
1703	domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
1704
1705	ELSE IF (field_glo(ind_glo)%ndim==3) THEN
1706	CALL MPI_IRECV(field_glo(ind_glo)%rval3d,size(field_glo(ind_glo)%rval3d) , MPI_REAL8 , &
1707	domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
1708
1709	ELSE IF (field_glo(ind_glo)%ndim==4) THEN
1710	CALL MPI_IRECV(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 , &
1711	domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
1712	ENDIF
1713
1714	ENDDO
1715	ENDIF
1716
1717	DO ind_loc=1,ndomain
1718	ireq=ireq+1
1719
1720	IF (field_loc(ind_loc)%ndim==2) THEN
1721	CALL MPI_ISEND(field_loc(ind_loc)%rval2d,size(field_loc(ind_loc)%rval2d) , MPI_REAL8 , &
1722	0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
1723	ELSE IF (field_loc(ind_loc)%ndim==3) THEN
1724	CALL MPI_ISEND(field_loc(ind_loc)%rval3d,size(field_loc(ind_loc)%rval3d) , MPI_REAL8 , &
1725	0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
1726	ELSE IF (field_loc(ind_loc)%ndim==4) THEN
1727	CALL MPI_ISEND(field_loc(ind_loc)%rval4d,size(field_loc(ind_loc)%rval4d) , MPI_REAL8 , &
1728	0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
1729	ENDIF
1730
1731	ENDDO
1732
1733	CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
1734
1735	ENDIF
1736
1737	END SUBROUTINE gather_field
1738
1739
1740	SUBROUTINE scatter_field(field_glo,field_loc)
1741	USE field_mod
1742	USE domain_mod
1743	USE mpi_mod
1744	USE mpipara
1745	IMPLICIT NONE
1746	TYPE(t_field),POINTER :: field_glo(:)
1747	TYPE(t_field),POINTER :: field_loc(:)
1748	INTEGER, ALLOCATABLE :: mpi_req(:)
1749	INTEGER, ALLOCATABLE :: status(:,:)
1750	INTEGER :: ireq,nreq
1751	INTEGER :: ind_glo,ind_loc
1752
1753	IF (.NOT. using_mpi) THEN
1754
1755	DO ind_loc=1,ndomain
1756	IF (field_loc(ind_loc)%ndim==2) field_loc(ind_loc)%rval2d=field_glo(ind_loc)%rval2d
1757	IF (field_loc(ind_loc)%ndim==3) field_loc(ind_loc)%rval3d=field_glo(ind_loc)%rval3d
1758	IF (field_loc(ind_loc)%ndim==4) field_loc(ind_loc)%rval4d=field_glo(ind_loc)%rval4d
1759	ENDDO
1760
1761	ELSE
1762
1763	nreq=ndomain
1764	IF (mpi_rank==0) nreq=nreq+ndomain_glo
1765	ALLOCATE(mpi_req(nreq))
1766	ALLOCATE(status(MPI_STATUS_SIZE,nreq))
1767
1768
1769	ireq=0
1770	IF (mpi_rank==0) THEN
1771	DO ind_glo=1,ndomain_glo
1772	ireq=ireq+1
1773
1774	IF (field_glo(ind_glo)%ndim==2) THEN
1775	CALL MPI_ISEND(field_glo(ind_glo)%rval2d,size(field_glo(ind_glo)%rval2d) , MPI_REAL8 , &
1776	domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
1777
1778	ELSE IF (field_glo(ind_glo)%ndim==3) THEN
1779	CALL MPI_ISEND(field_glo(ind_glo)%rval3d,size(field_glo(ind_glo)%rval3d) , MPI_REAL8 , &
1780	domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
1781
1782	ELSE IF (field_glo(ind_glo)%ndim==4) THEN
1783	CALL MPI_ISEND(field_glo(ind_glo)%rval4d,size(field_glo(ind_glo)%rval4d) , MPI_REAL8 , &
1784	domglo_rank(ind_glo),domglo_loc_ind(ind_glo), comm_icosa, mpi_req(ireq), ierr)
1785	ENDIF
1786
1787	ENDDO
1788	ENDIF
1789
1790	DO ind_loc=1,ndomain
1791	ireq=ireq+1
1792
1793	IF (field_loc(ind_loc)%ndim==2) THEN
1794	CALL MPI_IRECV(field_loc(ind_loc)%rval2d,size(field_loc(ind_loc)%rval2d) , MPI_REAL8 , &
1795	0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
1796	ELSE IF (field_loc(ind_loc)%ndim==3) THEN
1797	CALL MPI_IRECV(field_loc(ind_loc)%rval3d,size(field_loc(ind_loc)%rval3d) , MPI_REAL8 , &
1798	0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
1799	ELSE IF (field_loc(ind_loc)%ndim==4) THEN
1800	CALL MPI_IRECV(field_loc(ind_loc)%rval4d,size(field_loc(ind_loc)%rval4d) , MPI_REAL8 , &
1801	0, ind_loc, comm_icosa, mpi_req(ireq), ierr)
1802	ENDIF
1803
1804	ENDDO
1805
1806	CALL MPI_WAITALL(nreq,mpi_req,status,ierr)
1807
1808	ENDIF
1809
1810	END SUBROUTINE scatter_field
1811
1812	SUBROUTINE trace_in
1813	USE trace
1814	IMPLICIT NONE
1815
1816	CALL trace_start("transfert_buffer")
1817	END SUBROUTINE trace_in
1818
1819	SUBROUTINE trace_out
1820	USE trace
1821	IMPLICIT NONE
1822
1823	CALL trace_end("transfert_buffer")
1824	END SUBROUTINE trace_out
1825
1826
1827
1828
1829	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1830	!! Definition des Broadcast --> 4D !!
1831	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1832
1833	!! -- Les chaine de charactï¿œre -- !!
1834
1835	SUBROUTINE bcast_mpi_c(var1)
1836	IMPLICIT NONE
1837	CHARACTER(LEN=*),INTENT(INOUT) :: Var1
1838
1839	CALL bcast_mpi_cgen(Var1,len(Var1))
1840
1841	END SUBROUTINE bcast_mpi_c
1842
1843	!! -- Les entiers -- !!
1844
1845	SUBROUTINE bcast_mpi_i(var)
1846	USE mpipara
1847	IMPLICIT NONE
1848	INTEGER,INTENT(INOUT) :: Var
1849
1850	INTEGER :: var_tmp(1)
1851
1852	IF (is_mpi_master) var_tmp(1)=var
1853	CALL bcast_mpi_igen(Var_tmp,1)
1854	var=var_tmp(1)
1855
1856	END SUBROUTINE bcast_mpi_i
1857
1858	SUBROUTINE bcast_mpi_i1(var)
1859	IMPLICIT NONE
1860	INTEGER,INTENT(INOUT) :: Var(:)
1861
1862	CALL bcast_mpi_igen(Var,size(Var))
1863
1864	END SUBROUTINE bcast_mpi_i1
1865
1866	SUBROUTINE bcast_mpi_i2(var)
1867	IMPLICIT NONE
1868	INTEGER,INTENT(INOUT) :: Var(:,:)
1869
1870	CALL bcast_mpi_igen(Var,size(Var))
1871
1872	END SUBROUTINE bcast_mpi_i2
1873
1874	SUBROUTINE bcast_mpi_i3(var)
1875	IMPLICIT NONE
1876	INTEGER,INTENT(INOUT) :: Var(:,:,:)
1877
1878	CALL bcast_mpi_igen(Var,size(Var))
1879
1880	END SUBROUTINE bcast_mpi_i3
1881
1882	SUBROUTINE bcast_mpi_i4(var)
1883	IMPLICIT NONE
1884	INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
1885
1886	CALL bcast_mpi_igen(Var,size(Var))
1887
1888	END SUBROUTINE bcast_mpi_i4
1889
1890
1891	!! -- Les reels -- !!
1892
1893	SUBROUTINE bcast_mpi_r(var)
1894	USE mpipara
1895	IMPLICIT NONE
1896	REAL,INTENT(INOUT) :: Var
1897	REAL :: var_tmp(1)
1898
1899	IF (is_mpi_master) var_tmp(1)=var
1900	CALL bcast_mpi_rgen(Var_tmp,1)
1901	var=var_tmp(1)
1902
1903	END SUBROUTINE bcast_mpi_r
1904
1905	SUBROUTINE bcast_mpi_r1(var)
1906	IMPLICIT NONE
1907	REAL,INTENT(INOUT) :: Var(:)
1908
1909	CALL bcast_mpi_rgen(Var,size(Var))
1910
1911	END SUBROUTINE bcast_mpi_r1
1912
1913	SUBROUTINE bcast_mpi_r2(var)
1914	IMPLICIT NONE
1915	REAL,INTENT(INOUT) :: Var(:,:)
1916
1917	CALL bcast_mpi_rgen(Var,size(Var))
1918
1919	END SUBROUTINE bcast_mpi_r2
1920
1921	SUBROUTINE bcast_mpi_r3(var)
1922	IMPLICIT NONE
1923	REAL,INTENT(INOUT) :: Var(:,:,:)
1924
1925	CALL bcast_mpi_rgen(Var,size(Var))
1926
1927	END SUBROUTINE bcast_mpi_r3
1928
1929	SUBROUTINE bcast_mpi_r4(var)
1930	IMPLICIT NONE
1931	REAL,INTENT(INOUT) :: Var(:,:,:,:)
1932
1933	CALL bcast_mpi_rgen(Var,size(Var))
1934
1935	END SUBROUTINE bcast_mpi_r4
1936
1937	!! -- Les booleans -- !!
1938
1939	SUBROUTINE bcast_mpi_l(var)
1940	USE mpipara
1941	IMPLICIT NONE
1942	LOGICAL,INTENT(INOUT) :: Var
1943	LOGICAL :: var_tmp(1)
1944
1945	IF (is_mpi_master) var_tmp(1)=var
1946	CALL bcast_mpi_lgen(Var_tmp,1)
1947	var=var_tmp(1)
1948
1949	END SUBROUTINE bcast_mpi_l
1950
1951	SUBROUTINE bcast_mpi_l1(var)
1952	IMPLICIT NONE
1953	LOGICAL,INTENT(INOUT) :: Var(:)
1954
1955	CALL bcast_mpi_lgen(Var,size(Var))
1956
1957	END SUBROUTINE bcast_mpi_l1
1958
1959	SUBROUTINE bcast_mpi_l2(var)
1960	IMPLICIT NONE
1961	LOGICAL,INTENT(INOUT) :: Var(:,:)
1962
1963	CALL bcast_mpi_lgen(Var,size(Var))
1964
1965	END SUBROUTINE bcast_mpi_l2
1966
1967	SUBROUTINE bcast_mpi_l3(var)
1968	IMPLICIT NONE
1969	LOGICAL,INTENT(INOUT) :: Var(:,:,:)
1970
1971	CALL bcast_mpi_lgen(Var,size(Var))
1972
1973	END SUBROUTINE bcast_mpi_l3
1974
1975	SUBROUTINE bcast_mpi_l4(var)
1976	IMPLICIT NONE
1977	LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
1978
1979	CALL bcast_mpi_lgen(Var,size(Var))
1980
1981	END SUBROUTINE bcast_mpi_l4
1982
1983	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1984	!! DEFINITION DES FONCTIONS DE TRANSFERT GENERIQUES !
1985	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1986
1987	SUBROUTINE bcast_mpi_cgen(var,nb)
1988	USE mpi_mod
1989	USE mpipara
1990	IMPLICIT NONE
1991
1992	CHARACTER(LEN=*),INTENT(INOUT) :: Var
1993	INTEGER,INTENT(IN) :: nb
1994
1995	IF (.NOT. using_mpi) RETURN
1996
1997	CALL MPI_BCAST(Var,nb,MPI_CHARACTER,mpi_master,comm_icosa,ierr)
1998
1999	END SUBROUTINE bcast_mpi_cgen
2000
2001
2002
2003	SUBROUTINE bcast_mpi_igen(var,nb)
2004	USE mpi_mod
2005	USE mpipara
2006	IMPLICIT NONE
2007
2008	INTEGER,DIMENSION(nb),INTENT(INOUT) :: Var
2009	INTEGER,INTENT(IN) :: nb
2010
2011	IF (.NOT. using_mpi) RETURN
2012
2013	CALL MPI_BCAST(Var,nb,MPI_INTEGER,mpi_master,comm_icosa,ierr)
2014
2015	END SUBROUTINE bcast_mpi_igen
2016
2017
2018
2019
2020	SUBROUTINE bcast_mpi_rgen(var,nb)
2021	USE mpi_mod
2022	USE mpipara
2023	IMPLICIT NONE
2024
2025	REAL,DIMENSION(nb),INTENT(INOUT) :: Var
2026	INTEGER,INTENT(IN) :: nb
2027
2028	IF (.NOT. using_mpi) RETURN
2029
2030	CALL MPI_BCAST(Var,nb,MPI_REAL8,mpi_master,comm_icosa,ierr)
2031
2032	END SUBROUTINE bcast_mpi_rgen
2033
2034
2035
2036
2037	SUBROUTINE bcast_mpi_lgen(var,nb)
2038	USE mpi_mod
2039	USE mpipara
2040	IMPLICIT NONE
2041
2042	LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var
2043	INTEGER,INTENT(IN) :: nb
2044
2045	IF (.NOT. using_mpi) RETURN
2046
2047	CALL MPI_BCAST(Var,nb,MPI_LOGICAL,mpi_master,comm_icosa,ierr)
2048
2049	END SUBROUTINE bcast_mpi_lgen
2050
2051
2052	END MODULE transfert_mpi_mod
2053
2054
2055
2056
2057

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

Download in other formats: