Context Navigation

mod_hallo.F90 @ 4600

Last change on this file since 4600 was 4600, checked in by yann meurdesoif, 11 months ago

Suppress CPP_MPI key usage in source code. MPI wrappers is used to supress missing symbol if the mpi library is not linked

Property copyright set to
Name of program: LMDZ
Creation date: 1984
Version: LMDZ5
License: CeCILL version 2
Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
See the license file in the root directory

File size: 53.9 KB

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

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

Download in other formats:

Original Format