Context Navigation

source: codes/icosagcm/branches/SATURN_DYNAMICO/ICOSAGCM/src/transfert_mpi.f90 @ 261

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

Add bcast functionnalities for MPI

YM

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

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

Download in other formats: