Context Navigation

mod_hallo.f90 @ 5418

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

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

Download in other formats:

Original Format