Context Navigation

mod_hallo.F90_orig @ 1630

Last change on this file since 1630 was 1630, checked in by Laurent Fairhead, 12 years ago

Importation initiale du rÃ©pertoire dyn3dmem

Initial import of dyn3dmem directory

File size: 44.4 KB

Line
1	module mod_Hallo
2	USE parallel
3	implicit none
4	logical,save :: use_mpi_alloc
5	integer, parameter :: MaxRequest=200
6	integer, parameter :: MaxProc=512
7	integer, parameter :: MaxBufferSize=10241024100
8	integer, parameter :: ListSize=1000
9
10	integer,save :: MaxBufferSize_Used
11	!$OMP THREADPRIVATE( MaxBufferSize_Used)
12
13	real,save,pointer,dimension(:) :: Buffer
14	!$OMP THREADPRIVATE(Buffer)
15
16	integer,save,dimension(Listsize) :: Buffer_Pos
17	integer,save :: Index_Pos
18	!$OMP THREADPRIVATE(Buffer_Pos,Index_pos)
19
20	type Hallo
21	real, dimension(:,:),pointer :: Field
22	integer :: offset
23	integer :: size
24	integer :: NbLevel
25	integer :: Stride
26	end type Hallo
27
28	type request_SR
29	integer :: NbRequest=0
30	integer :: BufferSize
31	integer :: Pos
32	integer :: Index
33	type(Hallo),dimension(MaxRequest) :: Hallo
34	integer :: MSG_Request
35	end type request_SR
36
37	type request
38	type(request_SR),dimension(0:MaxProc-1) :: RequestSend
39	type(request_SR),dimension(0:MaxProc-1) :: RequestRecv
40	integer :: tag=1
41	end type request
42
43	TYPE(distrib),SAVE :: distrib_gather
44
45
46	INTERFACE Register_SwapField_u
47	MODULE PROCEDURE Register_SwapField1d_u,Register_SwapField2d_u,Register_SwapField3d_u
48	END INTERFACE Register_SwapField_u
49
50	INTERFACE Register_SwapField_v
51	MODULE PROCEDURE Register_SwapField1d_v,Register_SwapField2d_v,Register_SwapField3d_v
52	END INTERFACE Register_SwapField_v
53
54	INTERFACE Register_SwapField2d_u
55	MODULE PROCEDURE Register_SwapField1d_u2d,Register_SwapField2d_u2d,Register_SwapField3d_u2d
56	END INTERFACE Register_SwapField2d_u
57
58	INTERFACE Register_SwapField2d_v
59	MODULE PROCEDURE Register_SwapField1d_v2d,Register_SwapField2d_v2d,Register_SwapField3d_v2d
60	END INTERFACE Register_SwapField2d_v
61
62	contains
63
64	subroutine Init_mod_hallo
65	USE dimensions
66	implicit none
67	integer :: jj_nb_gather(0:mpi_size-1)
68
69	Index_Pos=1
70	Buffer_Pos(Index_Pos)=1
71	MaxBufferSize_Used=0
72
73	IF (use_mpi_alloc .AND. using_mpi) THEN
74	CALL create_global_mpi_buffer
75	ELSE
76	CALL create_standard_mpi_buffer
77	ENDIF
78
79	jj_nb_gather(:)=0
80	jj_nb_gather(0)=jjp1
81
82	CALL create_distrib(jj_nb_gather,distrib_gather)
83
84	end subroutine init_mod_hallo
85
86	SUBROUTINE create_standard_mpi_buffer
87	IMPLICIT NONE
88
89	ALLOCATE(Buffer(MaxBufferSize))
90
91	END SUBROUTINE create_standard_mpi_buffer
92
93	SUBROUTINE create_global_mpi_buffer
94	IMPLICIT NONE
95	#ifdef CPP_MPI
96	INCLUDE 'mpif.h'
97	#endif
98	POINTER (Pbuffer,MPI_Buffer(MaxBufferSize))
99	REAL :: MPI_Buffer
100	#ifdef CPP_MPI
101	INTEGER(KIND=MPI_ADDRESS_KIND) :: BS
102	#else
103	INTEGER(KIND=8) :: BS
104	#endif
105	INTEGER :: i,ierr
106
107	! Allocation du buffer MPI
108	Bs=8*MaxBufferSize
109	!$OMP CRITICAL (MPI)
110	#ifdef CPP_MPI
111	CALL MPI_ALLOC_MEM(BS,MPI_INFO_NULL,Pbuffer,ierr)
112	#endif
113	!$OMP END CRITICAL (MPI)
114	DO i=1,MaxBufferSize
115	MPI_Buffer(i)=i
116	ENDDO
117
118	CALL Associate_buffer(MPI_Buffer)
119
120	CONTAINS
121
122	SUBROUTINE Associate_buffer(MPI_Buffer)
123	IMPLICIT NONE
124	REAL,DIMENSION(:),target :: MPI_Buffer
125
126	Buffer=>MPI_Buffer
127
128	END SUBROUTINE Associate_buffer
129
130	END SUBROUTINE create_global_mpi_buffer
131
132
133	subroutine allocate_buffer(Size,Index,Pos)
134	implicit none
135	integer :: Size
136	integer :: Index
137	integer :: Pos
138
139	if (Buffer_pos(Index_pos)+Size>MaxBufferSize_Used) MaxBufferSize_Used=Buffer_pos(Index_pos)+Size
140	if (Buffer_pos(Index_pos)+Size>MaxBufferSize) then
141	print *,'STOP :: La taille de MaxBufferSize dans mod_hallo.F90 est trop petite !!!!'
142	stop
143	endif
144
145	if (Index_pos>=ListSize) then
146	print *,'STOP :: La taille de ListSize dans mod_hallo.F90 est trop petite !!!!'
147	stop
148	endif
149
150	Pos=Buffer_Pos(Index_Pos)
151	Buffer_Pos(Index_pos+1)=Buffer_Pos(Index_Pos)+Size
152	Index_Pos=Index_Pos+1
153	Index=Index_Pos
154
155	end subroutine allocate_buffer
156
157	subroutine deallocate_buffer(Index)
158	implicit none
159	integer :: Index
160
161	Buffer_Pos(Index)=-1
162
163	do while (Buffer_Pos(Index_Pos)==-1 .and. Index_Pos>1)
164	Index_Pos=Index_Pos-1
165	end do
166
167	end subroutine deallocate_buffer
168
169	subroutine SetTag(a_request,tag)
170	implicit none
171	type(request):: a_request
172	integer :: tag
173
174	a_request%tag=tag
175	end subroutine SetTag
176
177
178	subroutine Init_Hallo(Field,Stride,NbLevel,offset,size,NewHallo)
179	integer :: Stride
180	integer :: NbLevel
181	integer :: size
182	integer :: offset
183	real, dimension(Stride,NbLevel),target :: Field
184	type(Hallo) :: NewHallo
185
186	NewHallo%Field=>Field
187	NewHallo%Stride=Stride
188	NewHallo%NbLevel=NbLevel
189	NewHallo%size=size
190	NewHallo%offset=offset
191
192
193	end subroutine Init_Hallo
194
195	subroutine Register_SendField(Field,ij,ll,offset,size,target,a_request)
196	USE dimensions
197	implicit none
198
199
200	INTEGER :: ij,ll,offset,size,target
201	REAL, dimension(ij,ll) :: Field
202	type(request),target :: a_request
203	type(request_SR),pointer :: Ptr_request
204
205	Ptr_Request=>a_request%RequestSend(target)
206	Ptr_Request%NbRequest=Ptr_Request%NbRequest+1
207	if (Ptr_Request%NbRequest>=MaxRequest) then
208	print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!'
209	stop
210	endif
211	call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest))
212
213	end subroutine Register_SendField
214
215	subroutine Register_RecvField(Field,ij,ll,offset,size,target,a_request)
216	USE dimensions
217	implicit none
218
219
220	INTEGER :: ij,ll,offset,size,target
221	REAL, dimension(ij,ll) :: Field
222	type(request),target :: a_request
223	type(request_SR),pointer :: Ptr_request
224
225	Ptr_Request=>a_request%RequestRecv(target)
226	Ptr_Request%NbRequest=Ptr_Request%NbRequest+1
227
228	if (Ptr_Request%NbRequest>=MaxRequest) then
229	print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!'
230	stop
231	endif
232
233	call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest))
234
235
236	end subroutine Register_RecvField
237
238	subroutine Register_SwapField(FieldS,FieldR,ij,ll,jj_Nb_New,a_request)
239	USE dimensions
240	implicit none
241
242
243	INTEGER :: ij,ll
244	REAL, dimension(ij,ll) :: FieldS
245	REAL, dimension(ij,ll) :: FieldR
246	type(request) :: a_request
247	integer,dimension(0:MPI_Size-1) :: jj_Nb_New
248	integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
249
250	integer ::i,jje,jjb
251
252	jj_begin_New(0)=1
253	jj_End_New(0)=jj_Nb_New(0)
254	do i=1,MPI_Size-1
255	jj_begin_New(i)=jj_end_New(i-1)+1
256	jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
257	enddo
258
259	do i=0,MPI_Size-1
260	if (i /= MPI_Rank) then
261	jjb=max(jj_begin_new(i),jj_begin)
262	jje=min(jj_end_new(i),jj_end)
263
264	if (ij==ip1jm .and. jje==jjp1) jje=jjm
265
266	if (jje >= jjb) then
267	call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request)
268	endif
269
270	jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
271	jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
272
273	if (ij==ip1jm .and. jje==jjp1) jje=jjm
274
275	if (jje >= jjb) then
276	call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request)
277	endif
278
279	endif
280	enddo
281
282	end subroutine Register_SwapField
283
284
285
286	subroutine Register_SwapFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down,a_request)
287	USE dimensions
288
289	implicit none
290
291	INTEGER :: ij,ll,Up,Down
292	REAL, dimension(ij,ll) :: FieldS
293	REAL, dimension(ij,ll) :: FieldR
294	type(request) :: a_request
295	integer,dimension(0:MPI_Size-1) :: jj_Nb_New
296	integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
297
298	integer ::i,jje,jjb
299
300	jj_begin_New(0)=1
301	jj_End_New(0)=jj_Nb_New(0)
302	do i=1,MPI_Size-1
303	jj_begin_New(i)=jj_end_New(i-1)+1
304	jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
305	enddo
306
307	do i=0,MPI_Size-1
308	jj_begin_New(i)=max(1,jj_begin_New(i)-Up)
309	jj_end_New(i)=min(jjp1,jj_end_new(i)+Down)
310	enddo
311
312	do i=0,MPI_Size-1
313	if (i /= MPI_Rank) then
314	jjb=max(jj_begin_new(i),jj_begin)
315	jje=min(jj_end_new(i),jj_end)
316
317	if (ij==ip1jm .and. jje==jjp1) jje=jjm
318
319	if (jje >= jjb) then
320	call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request)
321	endif
322
323	jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
324	jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
325
326	if (ij==ip1jm .and. jje==jjp1) jje=jjm
327
328	if (jje >= jjb) then
329	call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request)
330	endif
331
332	endif
333	enddo
334
335	end subroutine Register_SwapFieldHallo
336
337
338
339	SUBROUTINE Register_SwapField1d_u(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
340	USE parallel
341	USE dimensions
342	IMPLICIT NONE
343
344	REAL, DIMENSION(:),INTENT(IN) :: FieldS
345	REAL, DIMENSION(:),INTENT(OUT) :: FieldR
346	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
347	TYPE(distrib),INTENT(IN) :: new_dist
348	INTEGER,OPTIONAL,INTENT(IN) :: up
349	INTEGER,OPTIONAL,INTENT(IN) :: down
350	TYPE(request),INTENT(INOUT) :: a_request
351
352	INTEGER :: halo_up
353	INTEGER :: halo_down
354
355
356	halo_up=0
357	halo_down=0
358	IF (PRESENT(up)) halo_up=up
359	IF (PRESENT(down)) halo_down=down
360
361	IF (PRESENT(old_dist)) THEN
362	CALL Register_SwapField_gen_u(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
363	ELSE
364	CALL Register_SwapField_gen_u(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
365	ENDIF
366
367	END SUBROUTINE Register_SwapField1d_u
368
369
370	!! SUBROUTINE Register_SwapField2d_u(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
371	!! USE parallel
372	!! USE dimensions
373	!! IMPLICIT NONE
374	!!
375	!! REAL, DIMENSION(:,:),INTENT(IN) :: FieldS
376	!! REAL, DIMENSION(:,:),INTENT(OUT) :: FieldR
377	!! TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
378	!! TYPE(distrib),INTENT(IN) :: new_dist
379	!! INTEGER,OPTIONAL,INTENT(IN) :: up
380	!! INTEGER,OPTIONAL,INTENT(IN) :: down
381	!! TYPE(request),INTENT(INOUT) :: a_request
382	!!
383	!! INTEGER :: halo_up
384	!! INTEGER :: halo_down
385	!! INTEGER :: ll
386	!!
387	!!
388	!! halo_up=0
389	!! halo_down=0
390	!! IF (PRESENT(up)) halo_up=up
391	!! IF (PRESENT(down)) halo_down=down
392	!!
393	!! ll=size(FieldS,2)
394	!!
395	!! IF (PRESENT(old_dist)) THEN
396	!! CALL Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
397	!! ELSE
398	!! CALL Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
399	!! ENDIF
400	!!
401	!! END SUBROUTINE Register_SwapField2d_u
402
403
404	SUBROUTINE Register_SwapField3d_u(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
405	USE parallel
406	USE dimensions
407	IMPLICIT NONE
408
409	REAL, DIMENSION(:,:,:),INTENT(IN) :: FieldS
410	REAL, DIMENSION(:,:,:),INTENT(OUT) :: FieldR
411	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
412	TYPE(distrib),INTENT(IN) :: new_dist
413	INTEGER,OPTIONAL,INTENT(IN) :: up
414	INTEGER,OPTIONAL,INTENT(IN) :: down
415	TYPE(request),INTENT(INOUT) :: a_request
416
417	INTEGER :: halo_up
418	INTEGER :: halo_down
419	INTEGER :: ll
420
421
422	halo_up=0
423	halo_down=0
424	IF (PRESENT(up)) halo_up=up
425	IF (PRESENT(down)) halo_down=down
426
427	ll=size(FieldS,2)*size(FieldS,3)
428
429	IF (PRESENT(old_dist)) THEN
430	CALL Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
431	ELSE
432	CALL Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
433	ENDIF
434
435	END SUBROUTINE Register_SwapField3d_u
436
437
438
439	SUBROUTINE Register_SwapField1d_u2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
440	USE parallel
441	USE dimensions
442
443	IMPLICIT NONE
444
445	REAL, DIMENSION(:,:),INTENT(IN) :: FieldS
446	REAL, DIMENSION(:,:),INTENT(OUT) :: FieldR
447	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
448	TYPE(distrib),OPTIONAL,INTENT(IN) :: new_dist !LF
449	INTEGER,OPTIONAL,INTENT(IN) :: up
450	INTEGER,OPTIONAL,INTENT(IN) :: down
451	TYPE(request),INTENT(INOUT) :: a_request
452
453	INTEGER :: halo_up
454	INTEGER :: halo_down
455
456
457	halo_up=0
458	halo_down=0
459	IF (PRESENT(up)) halo_up=up
460	IF (PRESENT(down)) halo_down=down
461
462	IF (PRESENT(old_dist)) THEN
463	CALL Register_SwapField_gen_u(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
464	ELSE
465	CALL Register_SwapField_gen_u(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
466	ENDIF
467
468	END SUBROUTINE Register_SwapField1d_u2d
469
470
471	SUBROUTINE Register_SwapField2d_u2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
472	USE parallel
473	USE dimensions
474
475	IMPLICIT NONE
476
477	REAL, DIMENSION(:,:,:),INTENT(IN) :: FieldS
478	REAL, DIMENSION(:,:,:),INTENT(OUT) :: FieldR
479	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
480	TYPE(distrib),INTENT(IN) :: new_dist
481	INTEGER,OPTIONAL,INTENT(IN) :: up
482	INTEGER,OPTIONAL,INTENT(IN) :: down
483	TYPE(request),INTENT(INOUT) :: a_request
484
485	INTEGER :: halo_up
486	INTEGER :: halo_down
487	INTEGER :: ll
488
489
490	halo_up=0
491	halo_down=0
492	IF (PRESENT(up)) halo_up=up
493	IF (PRESENT(down)) halo_down=down
494
495	ll=size(FieldS,3)
496
497	IF (PRESENT(old_dist)) THEN
498	CALL Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
499	ELSE
500	CALL Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
501	ENDIF
502
503	END SUBROUTINE Register_SwapField2d_u2d
504
505
506	SUBROUTINE Register_SwapField3d_u2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
507	USE parallel
508	USE dimensions
509	IMPLICIT NONE
510
511	REAL, DIMENSION(:,:,:,:),INTENT(IN) :: FieldS
512	REAL, DIMENSION(:,:,:,:),INTENT(OUT) :: FieldR
513	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
514	TYPE(distrib),INTENT(IN) :: new_dist
515	INTEGER,OPTIONAL,INTENT(IN) :: up
516	INTEGER,OPTIONAL,INTENT(IN) :: down
517	TYPE(request),INTENT(INOUT) :: a_request
518
519	INTEGER :: halo_up
520	INTEGER :: halo_down
521	INTEGER :: ll
522
523
524	halo_up=0
525	halo_down=0
526	IF (PRESENT(up)) halo_up=up
527	IF (PRESENT(down)) halo_down=down
528
529	ll=size(FieldS,3)*size(FieldS,4)
530
531	IF (PRESENT(old_dist)) THEN
532	CALL Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
533	ELSE
534	CALL Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
535	ENDIF
536
537	END SUBROUTINE Register_SwapField3d_u2d
538
539
540
541
542
543
544
545	SUBROUTINE Register_SwapField1d_v(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
546	USE parallel
547	USE dimensions
548	IMPLICIT NONE
549
550	REAL, DIMENSION(:),INTENT(IN) :: FieldS
551	REAL, DIMENSION(:),INTENT(OUT) :: FieldR
552	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
553	TYPE(distrib),INTENT(IN) :: new_dist
554	INTEGER,OPTIONAL,INTENT(IN) :: up
555	INTEGER,OPTIONAL,INTENT(IN) :: down
556	TYPE(request),INTENT(INOUT) :: a_request
557
558	INTEGER :: halo_up
559	INTEGER :: halo_down
560
561
562	halo_up=0
563	halo_down=0
564	IF (PRESENT(up)) halo_up=up
565	IF (PRESENT(down)) halo_down=down
566
567	IF (PRESENT(old_dist)) THEN
568	CALL Register_SwapField_gen_v(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
569	ELSE
570	CALL Register_SwapField_gen_v(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
571	ENDIF
572
573	END SUBROUTINE Register_SwapField1d_v
574
575
576	!! SUBROUTINE Register_SwapField2d_v(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
577	!! USE parallel
578	!! USE dimensions
579	!! IMPLICIT NONE
580
581	!! REAL, DIMENSION(:,:),INTENT(IN) :: FieldS
582	!! REAL, DIMENSION(:,:),INTENT(OUT) :: FieldR
583	!! TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
584	!! TYPE(distrib),INTENT(IN) :: new_dist
585	!! INTEGER,OPTIONAL,INTENT(IN) :: up
586	!! INTEGER,OPTIONAL,INTENT(IN) :: down
587	!! TYPE(request),INTENT(INOUT) :: a_request
588	!!
589	!! INTEGER :: halo_up
590	!! INTEGER :: halo_down
591	!! INTEGER :: ll
592	!!
593	!!
594	!! halo_up=0
595	!! halo_down=0
596	!! IF (PRESENT(up)) halo_up=up
597	!! IF (PRESENT(down)) halo_down=down
598	!!
599	!! ll=size(FieldS,2)
600	!!
601	!! IF (PRESENT(old_dist)) THEN
602	!! CALL Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
603	!! ELSE
604	!! CALL Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
605	!! ENDIF
606	!!
607	!! END SUBROUTINE Register_SwapField2d_v
608
609
610	SUBROUTINE Register_SwapField3d_v(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
611	USE parallel
612	USE dimensions
613	IMPLICIT NONE
614
615	REAL, DIMENSION(:,:,:),INTENT(IN) :: FieldS
616	REAL, DIMENSION(:,:,:),INTENT(OUT) :: FieldR
617	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
618	TYPE(distrib),INTENT(IN) :: new_dist
619	INTEGER,OPTIONAL,INTENT(IN) :: up
620	INTEGER,OPTIONAL,INTENT(IN) :: down
621	TYPE(request),INTENT(INOUT) :: a_request
622
623	INTEGER :: halo_up
624	INTEGER :: halo_down
625	INTEGER :: ll
626
627
628	halo_up=0
629	halo_down=0
630	IF (PRESENT(up)) halo_up=up
631	IF (PRESENT(down)) halo_down=down
632
633	ll=size(FieldS,2)*size(FieldS,3)
634
635	IF (PRESENT(old_dist)) THEN
636	CALL Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
637	ELSE
638	CALL Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
639	ENDIF
640
641	END SUBROUTINE Register_SwapField3d_v
642
643
644
645
646	SUBROUTINE Register_SwapField1d_v2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
647	USE parallel
648	USE dimensions
649	IMPLICIT NONE
650
651	REAL, DIMENSION(:,:),INTENT(IN) :: FieldS
652	REAL, DIMENSION(:,:),INTENT(OUT) :: FieldR
653	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
654	TYPE(distrib),OPTIONAL,INTENT(IN) :: new_dist !LF
655	INTEGER,OPTIONAL,INTENT(IN) :: up
656	INTEGER,OPTIONAL,INTENT(IN) :: down
657	TYPE(request),INTENT(INOUT) :: a_request
658
659	INTEGER :: halo_up
660	INTEGER :: halo_down
661
662
663	halo_up=0
664	halo_down=0
665	IF (PRESENT(up)) halo_up=up
666	IF (PRESENT(down)) halo_down=down
667
668	IF (PRESENT(old_dist)) THEN
669	CALL Register_SwapField_gen_v(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
670	ELSE
671	CALL Register_SwapField_gen_v(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
672	ENDIF
673
674	END SUBROUTINE Register_SwapField1d_v2d
675
676
677	SUBROUTINE Register_SwapField2d_v2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
678	USE parallel
679	USE dimensions
680	IMPLICIT NONE
681
682	REAL, DIMENSION(:,:,:),INTENT(IN) :: FieldS
683	REAL, DIMENSION(:,:,:),INTENT(OUT) :: FieldR
684	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
685	TYPE(distrib),INTENT(IN) :: new_dist
686	INTEGER,OPTIONAL,INTENT(IN) :: up
687	INTEGER,OPTIONAL,INTENT(IN) :: down
688	TYPE(request),INTENT(INOUT) :: a_request
689
690	INTEGER :: halo_up
691	INTEGER :: halo_down
692	INTEGER :: ll
693
694
695	halo_up=0
696	halo_down=0
697	IF (PRESENT(up)) halo_up=up
698	IF (PRESENT(down)) halo_down=down
699
700	ll=size(FieldS,3)
701
702	IF (PRESENT(old_dist)) THEN
703	CALL Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
704	ELSE
705	CALL Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
706	ENDIF
707
708	END SUBROUTINE Register_SwapField2d_v2d
709
710
711	SUBROUTINE Register_SwapField3d_v2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
712	USE parallel
713	USE dimensions
714	IMPLICIT NONE
715
716	REAL, DIMENSION(:,:,:,:),INTENT(IN) :: FieldS
717	REAL, DIMENSION(:,:,:,:),INTENT(OUT) :: FieldR
718	TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist
719	TYPE(distrib),INTENT(IN) :: new_dist
720	INTEGER,OPTIONAL,INTENT(IN) :: up
721	INTEGER,OPTIONAL,INTENT(IN) :: down
722	TYPE(request),INTENT(INOUT) :: a_request
723
724	INTEGER :: halo_up
725	INTEGER :: halo_down
726	INTEGER :: ll
727
728
729	halo_up=0
730	halo_down=0
731	IF (PRESENT(up)) halo_up=up
732	IF (PRESENT(down)) halo_down=down
733
734	ll=size(FieldS,3)*size(FieldS,4)
735
736	IF (PRESENT(old_dist)) THEN
737	CALL Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
738	ELSE
739	CALL Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
740	ENDIF
741
742	END SUBROUTINE Register_SwapField3d_v2d
743
744
745
746	SUBROUTINE Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,Up,Down,a_request)
747	USE parallel
748	USE dimensions
749	IMPLICIT NONE
750
751	INTEGER :: ll,Up,Down
752	TYPE(distrib) :: old_dist
753	TYPE(distrib) :: new_dist
754	REAL, DIMENSION(old_dist%ijb_u:old_dist%ije_u,ll) :: FieldS
755	REAL, DIMENSION(new_dist%ijb_u:new_dist%ije_u,ll) :: FieldR
756	TYPE(request) :: a_request
757	INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New
758	INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
759
760	INTEGER ::i,l,jje,jjb,ijb,ije
761
762	DO i=0,MPI_Size-1
763	jj_begin_New(i)=max(1,new_dist%jj_begin_para(i)-Up)
764	jj_end_New(i)=min(jjp1,new_dist%jj_end_para(i)+Down)
765	ENDDO
766
767	DO i=0,MPI_Size-1
768	IF (i /= MPI_Rank) THEN
769	jjb=max(jj_begin_new(i),old_dist%jj_begin)
770	jje=min(jj_end_new(i),old_dist%jj_end)
771
772	IF (jje >= jjb) THEN
773	CALL Register_SendField(FieldS,old_dist%ijnb_u,ll,jjb-old_dist%jjb_u+1,jje-jjb+1,i,a_request)
774	ENDIF
775
776	jjb=max(jj_begin_new(MPI_Rank),old_dist%jj_begin_Para(i))
777	jje=min(jj_end_new(MPI_Rank),old_dist%jj_end_Para(i))
778
779	IF (jje >= jjb) THEN
780	CALL Register_RecvField(FieldR,new_dist%ijnb_u,ll,jjb-new_dist%jjb_u+1,jje-jjb+1,i,a_request)
781	ENDIF
782	ELSE
783	jjb=max(jj_begin_new(i),old_dist%jj_begin)
784	jje=min(jj_end_new(i),old_dist%jj_end)
785	ijb=(jjb-1)*iip1+1
786	ije=jje*iip1
787	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
788	DO l=1,ll
789	FieldR(ijb:ije,:)=FieldS(ijb:ije,:)
790	ENDDO
791	!$OMP END DO NOWAIT
792	ENDIF
793	ENDDO
794
795	END SUBROUTINE Register_SwapField_gen_u
796
797
798
799	SUBROUTINE Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,Up,Down,a_request)
800	USE parallel
801	USE dimensions
802	IMPLICIT NONE
803
804	INTEGER :: ll,Up,Down
805	TYPE(distrib) :: old_dist
806	TYPE(distrib) :: new_dist
807	REAL, DIMENSION(old_dist%ijb_v:old_dist%ije_v,ll) :: FieldS
808	REAL, DIMENSION(new_dist%ijb_v:new_dist%ije_v,ll) :: FieldR
809	TYPE(request) :: a_request
810	INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New
811	INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
812
813	INTEGER ::i,l,jje,jjb,ijb,ije
814
815	DO i=0,MPI_Size-1
816	jj_begin_New(i)=max(1,new_dist%jj_begin_para(i)-Up)
817	jj_end_New(i)=min(jjp1,new_dist%jj_end_para(i)+Down)
818	ENDDO
819
820	DO i=0,MPI_Size-1
821	IF (i /= MPI_Rank) THEN
822	jjb=max(jj_begin_new(i),old_dist%jj_begin)
823	jje=min(jj_end_new(i),old_dist%jj_end)
824
825	IF (jje==jjp1) jje=jjm
826
827	IF (jje >= jjb) THEN
828	CALL Register_SendField(FieldS,old_dist%ijnb_v,ll,jjb-old_dist%jjb_v+1,jje-jjb+1,i,a_request)
829	ENDIF
830
831	jjb=max(jj_begin_new(MPI_Rank),old_dist%jj_begin_Para(i))
832	jje=min(jj_end_new(MPI_Rank),old_dist%jj_end_Para(i))
833
834	IF (jje==jjp1) jje=jjm
835
836	IF (jje >= jjb) THEN
837	CALL Register_RecvField(FieldR,new_dist%ijnb_v,ll,jjb-new_dist%jjb_v+1,jje-jjb+1,i,a_request)
838	ENDIF
839	ELSE
840	jjb=max(jj_begin_new(i),old_dist%jj_begin)
841	jje=min(jj_end_new(i),old_dist%jj_end)
842	IF (jje==jjp1) jje=jjm
843	ijb=(jjb-1)*iip1+1
844	ije=jje*iip1
845	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
846	DO l=1,ll
847	FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
848	ENDDO
849	!$OMP END DO NOWAIT
850	ENDIF
851	ENDDO
852
853	END SUBROUTINE Register_SwapField_gen_v
854
855
856
857
858
859	subroutine Register_Hallo(Field,ij,ll,RUp,Rdown,SUp,SDown,a_request)
860	USE dimensions
861	implicit none
862
863	#ifdef CPP_MPI
864	include 'mpif.h'
865	#endif
866	INTEGER :: ij,ll
867	REAL, dimension(ij,ll) :: Field
868	INTEGER :: Sup,Sdown,rup,rdown
869	type(request) :: a_request
870	type(Hallo),pointer :: PtrHallo
871	LOGICAL :: SendUp,SendDown
872	LOGICAL :: RecvUp,RecvDown
873
874
875	SendUp=.TRUE.
876	SendDown=.TRUE.
877	RecvUp=.TRUE.
878	RecvDown=.TRUE.
879
880	IF (pole_nord) THEN
881	SendUp=.FALSE.
882	RecvUp=.FALSE.
883	ENDIF
884
885	IF (pole_sud) THEN
886	SendDown=.FALSE.
887	RecvDown=.FALSE.
888	ENDIF
889
890	if (Sup.eq.0) then
891	SendUp=.FALSE.
892	endif
893
894	if (Sdown.eq.0) then
895	SendDown=.FALSE.
896	endif
897
898	if (Rup.eq.0) then
899	RecvUp=.FALSE.
900	endif
901
902	if (Rdown.eq.0) then
903	RecvDown=.FALSE.
904	endif
905
906	IF (SendUp) THEN
907	call Register_SendField(Field,ij,ll,jj_begin,SUp,MPI_Rank-1,a_request)
908	ENDIF
909
910	IF (SendDown) THEN
911	call Register_SendField(Field,ij,ll,jj_end-SDown+1,SDown,MPI_Rank+1,a_request)
912	ENDIF
913
914
915	IF (RecvUp) THEN
916	call Register_RecvField(Field,ij,ll,jj_begin-Rup,RUp,MPI_Rank-1,a_request)
917	ENDIF
918
919	IF (RecvDown) THEN
920	call Register_RecvField(Field,ij,ll,jj_end+1,RDown,MPI_Rank+1,a_request)
921	ENDIF
922
923	end subroutine Register_Hallo
924
925
926	subroutine Register_Hallo_u(Field,ll,RUp,Rdown,SUp,SDown,a_request)
927	USE dimensions
928	implicit none
929	#ifdef CPP_MPI
930	include 'mpif.h'
931	#endif
932	INTEGER :: ll
933	REAL, dimension(ijb_u:ije_u,ll) :: Field
934	INTEGER :: Sup,Sdown,rup,rdown
935	type(request) :: a_request
936	type(Hallo),pointer :: PtrHallo
937	LOGICAL :: SendUp,SendDown
938	LOGICAL :: RecvUp,RecvDown
939
940
941	SendUp=.TRUE.
942	SendDown=.TRUE.
943	RecvUp=.TRUE.
944	RecvDown=.TRUE.
945
946	IF (pole_nord) THEN
947	SendUp=.FALSE.
948	RecvUp=.FALSE.
949	ENDIF
950
951	IF (pole_sud) THEN
952	SendDown=.FALSE.
953	RecvDown=.FALSE.
954	ENDIF
955
956	if (Sup.eq.0) then
957	SendUp=.FALSE.
958	endif
959
960	if (Sdown.eq.0) then
961	SendDown=.FALSE.
962	endif
963
964	if (Rup.eq.0) then
965	RecvUp=.FALSE.
966	endif
967
968	if (Rdown.eq.0) then
969	RecvDown=.FALSE.
970	endif
971
972	IF (SendUp) THEN
973	call Register_SendField(Field,ijnb_u,ll,jj_begin-jjb_u+1,SUp,MPI_Rank-1,a_request)
974	ENDIF
975
976	IF (SendDown) THEN
977	call Register_SendField(Field,ijnb_u,ll,jj_end-SDown+1-jjb_u+1,SDown,MPI_Rank+1,a_request)
978	ENDIF
979
980
981	IF (RecvUp) THEN
982	call Register_RecvField(Field,ijnb_u,ll,jj_begin-Rup-jjb_u+1,RUp,MPI_Rank-1,a_request)
983	ENDIF
984
985	IF (RecvDown) THEN
986	call Register_RecvField(Field,ijnb_u,ll,jj_end+1-jjb_u+1,RDown,MPI_Rank+1,a_request)
987	ENDIF
988
989	end subroutine Register_Hallo_u
990
991	subroutine Register_Hallo_v(Field,ll,RUp,Rdown,SUp,SDown,a_request)
992	USE dimensions
993	implicit none
994	#ifdef CPP_MPI
995	include 'mpif.h'
996	#endif
997	INTEGER :: ll
998	REAL, dimension(ijb_v:ije_v,ll) :: Field
999	INTEGER :: Sup,Sdown,rup,rdown
1000	type(request) :: a_request
1001	type(Hallo),pointer :: PtrHallo
1002	LOGICAL :: SendUp,SendDown
1003	LOGICAL :: RecvUp,RecvDown
1004
1005
1006	SendUp=.TRUE.
1007	SendDown=.TRUE.
1008	RecvUp=.TRUE.
1009	RecvDown=.TRUE.
1010
1011	IF (pole_nord) THEN
1012	SendUp=.FALSE.
1013	RecvUp=.FALSE.
1014	ENDIF
1015
1016	IF (pole_sud) THEN
1017	SendDown=.FALSE.
1018	RecvDown=.FALSE.
1019	ENDIF
1020
1021	if (Sup.eq.0) then
1022	SendUp=.FALSE.
1023	endif
1024
1025	if (Sdown.eq.0) then
1026	SendDown=.FALSE.
1027	endif
1028
1029	if (Rup.eq.0) then
1030	RecvUp=.FALSE.
1031	endif
1032
1033	if (Rdown.eq.0) then
1034	RecvDown=.FALSE.
1035	endif
1036
1037	IF (SendUp) THEN
1038	call Register_SendField(Field,ijnb_v,ll,jj_begin-jjb_v+1,SUp,MPI_Rank-1,a_request)
1039	ENDIF
1040
1041	IF (SendDown) THEN
1042	call Register_SendField(Field,ijnb_v,ll,jj_end-SDown+1-jjb_v+1,SDown,MPI_Rank+1,a_request)
1043	ENDIF
1044
1045
1046	IF (RecvUp) THEN
1047	call Register_RecvField(Field,ijnb_v,ll,jj_begin-Rup-jjb_v+1,RUp,MPI_Rank-1,a_request)
1048	ENDIF
1049
1050	IF (RecvDown) THEN
1051	call Register_RecvField(Field,ijnb_v,ll,jj_end+1-jjb_v+1,RDown,MPI_Rank+1,a_request)
1052	ENDIF
1053
1054	end subroutine Register_Hallo_v
1055
1056	subroutine SendRequest(a_Request)
1057	USE dimensions
1058	implicit none
1059
1060	#ifdef CPP_MPI
1061	include 'mpif.h'
1062	#endif
1063
1064	type(request),target :: a_request
1065	type(request_SR),pointer :: Req
1066	type(Hallo),pointer :: PtrHallo
1067	integer :: SizeBuffer
1068	integer :: i,rank,l,ij,Pos,ierr
1069	integer :: offset
1070	real,dimension(:,:),pointer :: Field
1071	integer :: Nb
1072
1073	do rank=0,MPI_SIZE-1
1074
1075	Req=>a_Request%RequestSend(rank)
1076
1077	SizeBuffer=0
1078	do i=1,Req%NbRequest
1079	PtrHallo=>Req%Hallo(i)
1080	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1081	DO l=1,PtrHallo%NbLevel
1082	SizeBuffer=SizeBuffer+PtrHallo%size*iip1
1083	ENDDO
1084	!$OMP ENDDO NOWAIT
1085	enddo
1086
1087	Req%BufferSize=SizeBuffer
1088	if (Req%NbRequest>0) then
1089
1090	call allocate_buffer(SizeBuffer,Req%Index,Req%pos)
1091
1092	Pos=Req%Pos
1093	do i=1,Req%NbRequest
1094	PtrHallo=>Req%Hallo(i)
1095	offset=(PtrHallo%offset-1)*iip1+1
1096	Nb=iip1*PtrHallo%size-1
1097	Field=>PtrHallo%Field
1098
1099	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1100	do l=1,PtrHallo%NbLevel
1101	!cdir NODEP
1102	do ij=0,Nb
1103	Buffer(Pos+ij)=Field(Offset+ij,l)
1104	enddo
1105
1106	Pos=Pos+Nb+1
1107	enddo
1108	!$OMP END DO NOWAIT
1109	enddo
1110
1111	if (SizeBuffer>0) then
1112	!$OMP CRITICAL (MPI)
1113
1114	#ifdef CPP_MPI
1115	call MPI_ISSEND(Buffer(req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank, &
1116	COMM_LMDZ,Req%MSG_Request,ierr)
1117	#endif
1118	IF (.NOT.using_mpi) THEN
1119	PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
1120	STOP
1121	ENDIF
1122	! PRINT *,"-------------------------------------------------------------------"
1123	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
1124	! PRINT ,"Requete envoye au proc :",rank,"tag :",a_request%tag+1000omp_rank
1125	! PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
1126	! PRINT *,"-------------------------------------------------------------------"
1127	!$OMP END CRITICAL (MPI)
1128	endif
1129	endif
1130	enddo
1131
1132
1133	do rank=0,MPI_SIZE-1
1134
1135	Req=>a_Request%RequestRecv(rank)
1136	SizeBuffer=0
1137
1138	do i=1,Req%NbRequest
1139	PtrHallo=>Req%Hallo(i)
1140
1141	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1142	DO l=1,PtrHallo%NbLevel
1143	SizeBuffer=SizeBuffer+PtrHallo%size*iip1
1144	ENDDO
1145	!$OMP ENDDO NOWAIT
1146	enddo
1147
1148	Req%BufferSize=SizeBuffer
1149
1150	if (Req%NbRequest>0) then
1151	call allocate_buffer(SizeBuffer,Req%Index,Req%Pos)
1152
1153	if (SizeBuffer>0) then
1154
1155	!$OMP CRITICAL (MPI)
1156
1157	#ifdef CPP_MPI
1158	call MPI_IRECV(Buffer(Req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank, &
1159	COMM_LMDZ,Req%MSG_Request,ierr)
1160	#endif
1161	IF (.NOT.using_mpi) THEN
1162	PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
1163	STOP
1164	ENDIF
1165
1166	! PRINT *,"-------------------------------------------------------------------"
1167	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
1168	! PRINT ,"Requete en attente du proc :",rank,"tag :",a_request%tag+1000omp_rank
1169	! PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
1170	! PRINT *,"-------------------------------------------------------------------"
1171
1172	!$OMP END CRITICAL (MPI)
1173	endif
1174	endif
1175
1176	enddo
1177
1178	end subroutine SendRequest
1179
1180	subroutine WaitRequest(a_Request)
1181	USE dimensions
1182	implicit none
1183
1184	#ifdef CPP_MPI
1185	include 'mpif.h'
1186	#endif
1187
1188	type(request),target :: a_request
1189	type(request_SR),pointer :: Req
1190	type(Hallo),pointer :: PtrHallo
1191	integer, dimension(2*mpi_size) :: TabRequest
1192	#ifdef CPP_MPI
1193	integer, dimension(MPI_STATUS_SIZE,2*mpi_size) :: TabStatus
1194	#else
1195	integer, dimension(1,2*mpi_size) :: TabStatus
1196	#endif
1197	integer :: NbRequest
1198	integer :: i,rank,pos,ij,l,ierr
1199	integer :: offset
1200	integer :: Nb
1201
1202
1203	NbRequest=0
1204	do rank=0,MPI_SIZE-1
1205	Req=>a_request%RequestSend(rank)
1206	if (Req%NbRequest>0 .AND. Req%BufferSize > 0) then
1207	NbRequest=NbRequest+1
1208	TabRequest(NbRequest)=Req%MSG_Request
1209	endif
1210	enddo
1211
1212	do rank=0,MPI_SIZE-1
1213	Req=>a_request%RequestRecv(rank)
1214	if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) then
1215	NbRequest=NbRequest+1
1216	TabRequest(NbRequest)=Req%MSG_Request
1217	endif
1218	enddo
1219
1220	if (NbRequest>0) then
1221	!$OMP CRITICAL (MPI)
1222	! PRINT *,"-------------------------------------------------------------------"
1223	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
1224	! PRINT *,"No des requetes :",TabRequest(1:NbRequest)
1225	#ifdef CPP_MPI
1226	call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
1227	#endif
1228	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
1229	! PRINT *,"-------------------------------------------------------------------"
1230	!$OMP END CRITICAL (MPI)
1231	endif
1232	do rank=0,MPI_Size-1
1233	Req=>a_request%RequestRecv(rank)
1234	if (Req%NbRequest>0) then
1235	Pos=Req%Pos
1236	do i=1,Req%NbRequest
1237	PtrHallo=>Req%Hallo(i)
1238	offset=(PtrHallo%offset-1)*iip1+1
1239	Nb=iip1*PtrHallo%size-1
1240
1241	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1242	do l=1,PtrHallo%NbLevel
1243	!cdir NODEP
1244	do ij=0,Nb
1245	PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
1246	enddo
1247
1248	Pos=Pos+Nb+1
1249	enddo
1250	!$OMP ENDDO NOWAIT
1251	enddo
1252	endif
1253	enddo
1254
1255	do rank=0,MPI_SIZE-1
1256	Req=>a_request%RequestSend(rank)
1257	if (Req%NbRequest>0) then
1258	call deallocate_buffer(Req%Index)
1259	Req%NbRequest=0
1260	endif
1261	enddo
1262
1263	do rank=0,MPI_SIZE-1
1264	Req=>a_request%RequestRecv(rank)
1265	if (Req%NbRequest>0) then
1266	call deallocate_buffer(Req%Index)
1267	Req%NbRequest=0
1268	endif
1269	enddo
1270
1271	a_request%tag=1
1272	end subroutine WaitRequest
1273
1274	subroutine WaitSendRequest(a_Request)
1275	USE dimensions
1276	implicit none
1277
1278	#ifdef CPP_MPI
1279	include 'mpif.h'
1280	#endif
1281	type(request),target :: a_request
1282	type(request_SR),pointer :: Req
1283	type(Hallo),pointer :: PtrHallo
1284	integer, dimension(mpi_size) :: TabRequest
1285	#ifdef CPP_MPI
1286	integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
1287	#else
1288	integer, dimension(1,mpi_size) :: TabStatus
1289	#endif
1290	integer :: NbRequest
1291	integer :: i,rank,pos,ij,l,ierr
1292	integer :: offset
1293
1294
1295	NbRequest=0
1296	do rank=0,MPI_SIZE-1
1297	Req=>a_request%RequestSend(rank)
1298	if (Req%NbRequest>0) then
1299	NbRequest=NbRequest+1
1300	TabRequest(NbRequest)=Req%MSG_Request
1301	endif
1302	enddo
1303
1304
1305	if (NbRequest>0 .AND. Req%BufferSize > 0 ) THEN
1306	!$OMP CRITICAL (MPI)
1307	! PRINT *,"-------------------------------------------------------------------"
1308	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
1309	! PRINT *,"No des requetes :",TabRequest(1:NbRequest)
1310	#ifdef CPP_MPI
1311	call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
1312	#endif
1313	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
1314	! PRINT *,"-------------------------------------------------------------------"
1315
1316	!$OMP END CRITICAL (MPI)
1317	endif
1318
1319	do rank=0,MPI_SIZE-1
1320	Req=>a_request%RequestSend(rank)
1321	if (Req%NbRequest>0) then
1322	call deallocate_buffer(Req%Index)
1323	Req%NbRequest=0
1324	endif
1325	enddo
1326
1327	a_request%tag=1
1328	end subroutine WaitSendRequest
1329
1330	subroutine WaitRecvRequest(a_Request)
1331	USE dimensions
1332	implicit none
1333
1334	#ifdef CPP_MPI
1335	include 'mpif.h'
1336	#endif
1337
1338	type(request),target :: a_request
1339	type(request_SR),pointer :: Req
1340	type(Hallo),pointer :: PtrHallo
1341	integer, dimension(mpi_size) :: TabRequest
1342	#ifdef CPP_MPI
1343	integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
1344	#else
1345	integer, dimension(1,mpi_size) :: TabStatus
1346	#endif
1347	integer :: NbRequest
1348	integer :: i,rank,pos,ij,l,ierr
1349	integer :: offset,Nb
1350
1351
1352	NbRequest=0
1353
1354	do rank=0,MPI_SIZE-1
1355	Req=>a_request%RequestRecv(rank)
1356	if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) then
1357	NbRequest=NbRequest+1
1358	TabRequest(NbRequest)=Req%MSG_Request
1359	endif
1360	enddo
1361
1362
1363	if (NbRequest>0) then
1364	!$OMP CRITICAL (MPI)
1365	! PRINT *,"-------------------------------------------------------------------"
1366	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
1367	! PRINT *,"No des requetes :",TabRequest(1:NbRequest)
1368	#ifdef CPP_MPI
1369	call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
1370	#endif
1371	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
1372	! PRINT *,"-------------------------------------------------------------------"
1373	!$OMP END CRITICAL (MPI)
1374	endif
1375
1376	do rank=0,MPI_Size-1
1377	Req=>a_request%RequestRecv(rank)
1378	if (Req%NbRequest>0) then
1379	Pos=Req%Pos
1380	do i=1,Req%NbRequest
1381	PtrHallo=>Req%Hallo(i)
1382	offset=(PtrHallo%offset-1)*iip1+1
1383	Nb=iip1*PtrHallo%size-1
1384	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1385	do l=1,PtrHallo%NbLevel
1386	!cdir NODEP
1387	do ij=0,Nb
1388	PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
1389	enddo
1390	Pos=Pos+Nb+1
1391	enddo
1392	!$OMP END DO NOWAIT
1393	enddo
1394	endif
1395	enddo
1396
1397
1398	do rank=0,MPI_SIZE-1
1399	Req=>a_request%RequestRecv(rank)
1400	if (Req%NbRequest>0) then
1401	call deallocate_buffer(Req%Index)
1402	Req%NbRequest=0
1403	endif
1404	enddo
1405
1406	a_request%tag=1
1407	end subroutine WaitRecvRequest
1408
1409
1410
1411	subroutine CopyField(FieldS,FieldR,ij,ll,jj_Nb_New)
1412	USE dimensions
1413
1414	implicit none
1415
1416	INTEGER :: ij,ll,l
1417	REAL, dimension(ij,ll) :: FieldS
1418	REAL, dimension(ij,ll) :: FieldR
1419	integer,dimension(0:MPI_Size-1) :: jj_Nb_New
1420	integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
1421
1422	integer ::i,jje,jjb,ijb,ije
1423
1424	jj_begin_New(0)=1
1425	jj_End_New(0)=jj_Nb_New(0)
1426	do i=1,MPI_Size-1
1427	jj_begin_New(i)=jj_end_New(i-1)+1
1428	jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
1429	enddo
1430
1431	jjb=max(jj_begin,jj_begin_new(MPI_Rank))
1432	jje=min(jj_end,jj_end_new(MPI_Rank))
1433	if (ij==ip1jm) jje=min(jje,jjm)
1434
1435	if (jje >= jjb) then
1436	ijb=(jjb-1)*iip1+1
1437	ije=jje*iip1
1438
1439	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1440	do l=1,ll
1441	FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
1442	enddo
1443	!$OMP ENDDO NOWAIT
1444	endif
1445
1446
1447	end subroutine CopyField
1448
1449	subroutine CopyFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down)
1450	USE dimensions
1451
1452	implicit none
1453
1454	INTEGER :: ij,ll,Up,Down
1455	REAL, dimension(ij,ll) :: FieldS
1456	REAL, dimension(ij,ll) :: FieldR
1457	integer,dimension(0:MPI_Size-1) :: jj_Nb_New
1458	integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
1459
1460	integer ::i,jje,jjb,ijb,ije,l
1461
1462
1463	jj_begin_New(0)=1
1464	jj_End_New(0)=jj_Nb_New(0)
1465	do i=1,MPI_Size-1
1466	jj_begin_New(i)=jj_end_New(i-1)+1
1467	jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
1468	enddo
1469
1470
1471	jjb=max(jj_begin,jj_begin_new(MPI_Rank)-Up)
1472	jje=min(jj_end,jj_end_new(MPI_Rank)+Down)
1473	if (ij==ip1jm) jje=min(jje,jjm)
1474
1475
1476	if (jje >= jjb) then
1477	ijb=(jjb-1)*iip1+1
1478	ije=jje*iip1
1479
1480	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1481	do l=1,ll
1482	FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
1483	enddo
1484	!$OMP ENDDO NOWAIT
1485
1486	endif
1487	end subroutine CopyFieldHallo
1488
1489	subroutine Gather_field_u(field_loc,field_glo,ll)
1490	USE dimensions
1491	implicit none
1492	integer :: ll
1493	real :: field_loc(ijb_u:ije_u,ll)
1494	real :: field_glo(ip1jmp1,ll)
1495	type(request) :: request_gather
1496	integer :: l
1497
1498
1499	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1500	DO l=1,ll
1501	field_glo(ij_begin:ij_end,l)=field_loc(ij_begin:ij_end,l)
1502	ENDDO
1503
1504	call register_SwapField(field_glo,field_glo,ip1jmp1,ll,distrib_gather%jj_nb_para,request_gather)
1505	call SendRequest(request_gather)
1506	!$OMP BARRIER
1507	call WaitRequest(request_gather)
1508	!$OMP BARRIER
1509
1510	end subroutine Gather_field_u
1511
1512	subroutine Gather_field_v(field_loc,field_glo,ll)
1513	USE dimensions
1514	implicit none
1515	integer :: ll
1516	real :: field_loc(ijb_v:ije_v,ll)
1517	real :: field_glo(ip1jm,ll)
1518	type(request) :: request_gather
1519	integer :: ijb,ije
1520	integer :: l
1521
1522
1523	ijb=ij_begin
1524	ije=ij_end
1525	if (pole_sud) ije=ij_end-iip1
1526
1527	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1528	DO l=1,ll
1529	field_glo(ijb:ije,l)=field_loc(ijb:ije,l)
1530	ENDDO
1531
1532	call register_SwapField(field_glo,field_glo,ip1jm,ll,distrib_gather%jj_nb_para,request_gather)
1533	call SendRequest(request_gather)
1534	!$OMP BARRIER
1535	call WaitRequest(request_gather)
1536	!$OMP BARRIER
1537
1538	end subroutine Gather_field_v
1539
1540	subroutine Scatter_field_u(field_glo,field_loc,ll)
1541	USE dimensions
1542	implicit none
1543	integer :: ll
1544	real :: field_glo(ip1jmp1,ll)
1545	real :: field_loc(ijb_u:ije_u,ll)
1546	type(request) :: request_gather
1547	TYPE(distrib) :: distrib_swap
1548	integer :: l
1549
1550	!$OMP BARRIER
1551	!$OMP MASTER
1552	call get_current_distrib(distrib_swap)
1553	call set_Distrib(distrib_gather)
1554	!$OMP END MASTER
1555	!$OMP BARRIER
1556
1557	call register_SwapField(field_glo,field_glo,ip1jmp1,ll,distrib_swap%jj_nb_para,request_gather)
1558	call SendRequest(request_gather)
1559	!$OMP BARRIER
1560	call WaitRequest(request_gather)
1561	!$OMP BARRIER
1562	!$OMP MASTER
1563	call set_Distrib(distrib_swap)
1564	!$OMP END MASTER
1565	!$OMP BARRIER
1566
1567	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1568	DO l=1,ll
1569	field_loc(ij_begin:ij_end,l)=field_glo(ij_begin:ij_end,l)
1570	ENDDO
1571
1572	end subroutine Scatter_field_u
1573
1574	subroutine Scatter_field_v(field_glo,field_loc,ll)
1575	USE dimensions
1576	implicit none
1577	integer :: ll
1578	real :: field_glo(ip1jmp1,ll)
1579	real :: field_loc(ijb_v:ije_v,ll)
1580	type(request) :: request_gather
1581	TYPE(distrib) :: distrib_swap
1582	integer :: ijb,ije,l
1583
1584
1585	!$OMP BARRIER
1586	!$OMP MASTER
1587	call get_current_distrib(distrib_swap)
1588	call set_Distrib(distrib_gather)
1589	!$OMP END MASTER
1590	!$OMP BARRIER
1591	call register_SwapField(field_glo,field_glo,ip1jm,ll,distrib_swap%jj_nb_para,request_gather)
1592	call SendRequest(request_gather)
1593	!$OMP BARRIER
1594	call WaitRequest(request_gather)
1595	!$OMP BARRIER
1596	!$OMP MASTER
1597	call set_Distrib(distrib_swap)
1598	!$OMP END MASTER
1599	!$OMP BARRIER
1600	ijb=ij_begin
1601	ije=ij_end
1602	if (pole_sud) ije=ij_end-iip1
1603
1604	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1605	DO l=1,ll
1606	field_loc(ijb:ije,l)=field_glo(ijb:ije,l)
1607	ENDDO
1608
1609	end subroutine Scatter_field_v
1610
1611	end module mod_Hallo
1612

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

Download in other formats:

Original Format