Context Navigation

source: codes/icosagcm/trunk/src/parallel/transfert_mpi.f90 @ 899

Last change on this file since 899 was 899, checked in by adurocher, 5 years ago

trunk : Fixed GCC warnings

Fixed iso c bindings
fixed warnings with -Wall -Wno-aliasing -Wno-unused -Wno-unused-dummy-argument -Wno-maybe-uninitialized -Wno-tabs warnings
Removed all unused variables (-Wunused-variable)
vector%dot_product is now dot_product_3d to avoid compilation warning "dot_product shadows intrinsic" with GCC

File size: 61.8 KB

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

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

Download in other formats: