Context Navigation

mod_hallo.F90 @ 5411

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

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

Download in other formats:

Original Format