Context Navigation

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

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

Synchronize trunk and Saturn branch.
Merge modification from Saturn branch to trunk

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: