Context Navigation

mod_hallo.f90 @ 5272

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

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

Download in other formats:

Original Format