Context Navigation

parallel_lmdz.F90 @ 5127

Last change on this file since 5127 was 5119, checked in by abarral, 11 months ago
enforce PRIVATE by default in several modules, expose PUBLIC as needed move eigen.f90 to obsolete/ (lint) aslong the way
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: 18.7 KB

Line
1	! $Id$
2
3	MODULE parallel_lmdz
4	USE mod_const_mpi
5	USE lmdz_mpi, ONLY: using_mpi
6	USE IOIPSL
7	INTEGER, PARAMETER :: halo_max = 3
8
9	LOGICAL, SAVE :: using_omp ! .TRUE. if using OpenMP
10	LOGICAL, SAVE :: is_master ! .TRUE. if the core is both MPI & OpenMP master
11	!$OMP THREADPRIVATE(is_master)
12
13	INTEGER, save :: mpi_size
14	INTEGER, save :: mpi_rank
15	INTEGER, save :: jj_begin
16	INTEGER, save :: jj_end
17	INTEGER, save :: jj_nb
18	INTEGER, save :: ij_begin
19	INTEGER, save :: ij_end
20	logical, save :: pole_nord
21	logical, save :: pole_sud
22
23	INTEGER, save :: jjb_u
24	INTEGER, save :: jje_u
25	INTEGER, save :: jjnb_u
26	INTEGER, save :: jjb_v
27	INTEGER, save :: jje_v
28	INTEGER, save :: jjnb_v
29
30	INTEGER, save :: ijb_u
31	INTEGER, save :: ije_u
32	INTEGER, save :: ijnb_u
33
34	INTEGER, save :: ijb_v
35	INTEGER, save :: ije_v
36	INTEGER, save :: ijnb_v
37
38	INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: jj_begin_para
39	INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: jj_end_para
40	INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: jj_nb_para
41	INTEGER, save :: OMP_CHUNK
42	INTEGER, save :: omp_rank
43	INTEGER, save :: omp_size
44	!$OMP THREADPRIVATE(omp_rank)
45
46	TYPE distrib
47	INTEGER :: jj_begin
48	INTEGER :: jj_end
49	INTEGER :: jj_nb
50	INTEGER :: ij_begin
51	INTEGER :: ij_end
52
53	INTEGER :: jjb_u
54	INTEGER :: jje_u
55	INTEGER :: jjnb_u
56	INTEGER :: jjb_v
57	INTEGER :: jje_v
58	INTEGER :: jjnb_v
59
60	INTEGER :: ijb_u
61	INTEGER :: ije_u
62	INTEGER :: ijnb_u
63
64	INTEGER :: ijb_v
65	INTEGER :: ije_v
66	INTEGER :: ijnb_v
67
68	INTEGER, pointer :: jj_begin_para(:) => NULL()
69	INTEGER, pointer :: jj_end_para(:) => NULL()
70	INTEGER, pointer :: jj_nb_para(:) => NULL()
71	END TYPE distrib
72
73	INTERFACE ASSIGNMENT (=)
74	MODULE PROCEDURE copy_distrib
75	END INTERFACE
76	TYPE(distrib), SAVE :: current_dist
77
78	CONTAINS
79
80	SUBROUTINE init_parallel
81	USE lmdz_vampir
82	USE lmdz_mpi
83	USE lmdz_iniprint, ONLY: lunout, prt_level
84	IMPLICIT NONE
85	INCLUDE "dimensions.h"
86	INCLUDE "paramet.h"
87
88	INTEGER :: ierr
89	INTEGER :: i, j
90	INTEGER :: type_size
91	INTEGER, DIMENSION(3) :: blocklen, type
92	INTEGER :: comp_id
93	CHARACTER(LEN = 4) :: num
94	CHARACTER(LEN = 20) :: filename
95
96	#ifdef CPP_OMP
97	INTEGER :: OMP_GET_NUM_THREADS
98	EXTERNAL OMP_GET_NUM_THREADS
99	INTEGER :: OMP_GET_THREAD_NUM
100	EXTERNAL OMP_GET_THREAD_NUM
101	#endif
102
103	#ifdef CPP_OMP
104	using_OMP=.TRUE.
105	#else
106	using_OMP = .FALSE.
107	#endif
108
109	CALL InitVampir
110
111	IF (using_mpi) THEN
112	CALL MPI_COMM_SIZE(COMM_LMDZ, mpi_size, ierr)
113	CALL MPI_COMM_RANK(COMM_LMDZ, mpi_rank, ierr)
114	ELSE
115	mpi_size = 1
116	mpi_rank = 0
117	ENDIF
118
119
120	! Open text output file with mpi_rank in suffix of file name
121	IF (lunout /= 5 .AND. lunout /= 6) THEN
122	WRITE(num, '(I4.4)') mpi_rank
123	filename = 'lmdz.out_' // num
124	IF (mpi_rank /= 0) THEN
125	OPEN(UNIT = lunout, FILE = TRIM(filename), ACTION = 'write', &
126	STATUS = 'unknown', FORM = 'formatted', IOSTAT = ierr)
127	ENDIF
128	ENDIF
129
130	allocate(jj_begin_para(0:mpi_size - 1))
131	allocate(jj_end_para(0:mpi_size - 1))
132	allocate(jj_nb_para(0:mpi_size - 1))
133
134	do i = 0, mpi_size - 1
135	jj_nb_para(i) = (jjm + 1) / mpi_size
136	IF (i < MOD((jjm + 1), mpi_size)) jj_nb_para(i) = jj_nb_para(i) + 1
137
138	IF (jj_nb_para(i) <= 1) THEN
139	WRITE(lunout, *)"Arret : le nombre de bande de lattitude par process est trop faible (<2)."
140	WRITE(lunout, *)" ---> diminuez le nombre de CPU ou augmentez la taille en lattitude"
141
142	IF (using_mpi) CALL MPI_ABORT(COMM_LMDZ, -1, ierr)
143
144	endif
145
146	enddo
147
148	! jj_nb_para(0)=11
149	! jj_nb_para(1)=25
150	! jj_nb_para(2)=25
151	! jj_nb_para(3)=12
152
153	j = 1
154
155	do i = 0, mpi_size - 1
156
157	jj_begin_para(i) = j
158	jj_end_para(i) = j + jj_Nb_para(i) - 1
159	j = j + jj_Nb_para(i)
160
161	enddo
162
163	jj_begin = jj_begin_para(mpi_rank)
164	jj_end = jj_end_para(mpi_rank)
165	jj_nb = jj_nb_para(mpi_rank)
166
167	ij_begin = (jj_begin - 1) * iip1 + 1
168	ij_end = jj_end * iip1
169
170	IF (mpi_rank==0) THEN
171	pole_nord = .TRUE.
172	else
173	pole_nord = .FALSE.
174	endif
175
176	IF (mpi_rank==mpi_size - 1) THEN
177	pole_sud = .TRUE.
178	else
179	pole_sud = .FALSE.
180	endif
181
182	WRITE(lunout, *)"init_parallel: jj_begin", jj_begin
183	WRITE(lunout, *)"init_parallel: jj_end", jj_end
184	WRITE(lunout, *)"init_parallel: ij_begin", ij_begin
185	WRITE(lunout, *)"init_parallel: ij_end", ij_end
186	jjb_u = MAX(jj_begin - halo_max, 1)
187	jje_u = MIN(jj_end + halo_max, jjp1)
188	jjnb_u = jje_u - jjb_u + 1
189
190	jjb_v = MAX(jj_begin - halo_max, 1)
191	jje_v = MIN(jj_end + halo_max, jjm)
192	jjnb_v = jje_v - jjb_v + 1
193
194	ijb_u = MAX(ij_begin - halo_max * iip1, 1)
195	ije_u = MIN(ij_end + halo_max * iip1, ip1jmp1)
196	ijnb_u = ije_u - ijb_u + 1
197
198	ijb_v = MAX(ij_begin - halo_max * iip1, 1)
199	ije_v = MIN(ij_end + halo_max * iip1, ip1jm)
200	ijnb_v = ije_v - ijb_v + 1
201
202	!$OMP PARALLEL
203
204	#ifdef CPP_OMP
205	!$OMP MASTER
206	omp_size=OMP_GET_NUM_THREADS()
207	!$OMP END MASTER
208	!$OMP BARRIER
209	omp_rank=OMP_GET_THREAD_NUM()
210
211	!Config Key = omp_chunk
212	!Config Desc = taille des blocs openmp
213	!Config Def = 1
214	!Config Help = defini la taille des packets d'itération openmp
215	!Config distribue a chaque tache lors de l'entree dans une
216	!Config boucle parallelisee
217
218	!$OMP MASTER
219	omp_chunk=(llm+1)/omp_size
220	IF (MOD(llm+1,omp_size)/=0) omp_chunk=omp_chunk+1
221	CALL getin('omp_chunk',omp_chunk)
222	!$OMP END MASTER
223	!$OMP BARRIER
224	#else
225	omp_size = 1
226	omp_rank = 0
227	#endif
228	!$OMP END PARALLEL
229	CALL create_distrib(jj_nb_para, current_dist)
230
231	IF ((mpi_rank==0).AND.(omp_rank==0)) THEN
232	is_master = .TRUE.
233	ELSE
234	is_master = .FALSE.
235	ENDIF
236
237	END SUBROUTINE init_parallel
238
239	SUBROUTINE create_distrib(jj_nb_new, d)
240	IMPLICIT NONE
241	INCLUDE "dimensions.h"
242	INCLUDE "paramet.h"
243
244	INTEGER, INTENT(IN) :: jj_Nb_New(0:MPI_Size - 1)
245	TYPE(distrib), INTENT(INOUT) :: d
246	INTEGER :: i
247
248	IF (.NOT. ASSOCIATED(d%jj_nb_para)) ALLOCATE(d%jj_nb_para(0:MPI_Size - 1))
249	IF (.NOT. ASSOCIATED(d%jj_begin_para)) ALLOCATE(d%jj_begin_para(0:MPI_Size - 1))
250	IF (.NOT. ASSOCIATED(d%jj_end_para)) ALLOCATE(d%jj_end_para(0:MPI_Size - 1))
251
252	d%jj_Nb_Para = jj_Nb_New
253
254	d%jj_begin_para(0) = 1
255	d%jj_end_para(0) = d%jj_Nb_Para(0)
256
257	do i = 1, mpi_size - 1
258
259	d%jj_begin_para(i) = d%jj_end_para(i - 1) + 1
260	d%jj_end_para(i) = d%jj_begin_para(i) + d%jj_Nb_para(i) - 1
261
262	enddo
263
264	d%jj_begin = d%jj_begin_para(mpi_rank)
265	d%jj_end = d%jj_end_para(mpi_rank)
266	d%jj_nb = d%jj_nb_para(mpi_rank)
267
268	d%ij_begin = (d%jj_begin - 1) * iip1 + 1
269	d%ij_end = d%jj_end * iip1
270
271	d%jjb_u = MAX(d%jj_begin - halo_max, 1)
272	d%jje_u = MIN(d%jj_end + halo_max, jjp1)
273	d%jjnb_u = d%jje_u - d%jjb_u + 1
274
275	d%jjb_v = MAX(d%jj_begin - halo_max, 1)
276	d%jje_v = MIN(d%jj_end + halo_max, jjm)
277	d%jjnb_v = d%jje_v - d%jjb_v + 1
278
279	d%ijb_u = MAX(d%ij_begin - halo_max * iip1, 1)
280	d%ije_u = MIN(d%ij_end + halo_max * iip1, ip1jmp1)
281	d%ijnb_u = d%ije_u - d%ijb_u + 1
282
283	d%ijb_v = MAX(d%ij_begin - halo_max * iip1, 1)
284	d%ije_v = MIN(d%ij_end + halo_max * iip1, ip1jm)
285	d%ijnb_v = d%ije_v - d%ijb_v + 1
286
287	END SUBROUTINE create_distrib
288
289
290	SUBROUTINE Set_Distrib(d)
291	IMPLICIT NONE
292
293	INCLUDE "dimensions.h"
294	INCLUDE "paramet.h"
295	TYPE(distrib), INTENT(IN) :: d
296
297	jj_begin = d%jj_begin
298	jj_end = d%jj_end
299	jj_nb = d%jj_nb
300	ij_begin = d%ij_begin
301	ij_end = d%ij_end
302
303	jjb_u = d%jjb_u
304	jje_u = d%jje_u
305	jjnb_u = d%jjnb_u
306	jjb_v = d%jjb_v
307	jje_v = d%jje_v
308	jjnb_v = d%jjnb_v
309
310	ijb_u = d%ijb_u
311	ije_u = d%ije_u
312	ijnb_u = d%ijnb_u
313
314	ijb_v = d%ijb_v
315	ije_v = d%ije_v
316	ijnb_v = d%ijnb_v
317
318	jj_begin_para(:) = d%jj_begin_para(:)
319	jj_end_para(:) = d%jj_end_para(:)
320	jj_nb_para(:) = d%jj_nb_para(:)
321	current_dist = d
322
323	END SUBROUTINE Set_Distrib
324
325	SUBROUTINE copy_distrib(dist, new_dist)
326	IMPLICIT NONE
327
328	INCLUDE "dimensions.h"
329	INCLUDE "paramet.h"
330	TYPE(distrib), INTENT(INOUT) :: dist
331	TYPE(distrib), INTENT(IN) :: new_dist
332
333	dist%jj_begin = new_dist%jj_begin
334	dist%jj_end = new_dist%jj_end
335	dist%jj_nb = new_dist%jj_nb
336	dist%ij_begin = new_dist%ij_begin
337	dist%ij_end = new_dist%ij_end
338
339	dist%jjb_u = new_dist%jjb_u
340	dist%jje_u = new_dist%jje_u
341	dist%jjnb_u = new_dist%jjnb_u
342	dist%jjb_v = new_dist%jjb_v
343	dist%jje_v = new_dist%jje_v
344	dist%jjnb_v = new_dist%jjnb_v
345
346	dist%ijb_u = new_dist%ijb_u
347	dist%ije_u = new_dist%ije_u
348	dist%ijnb_u = new_dist%ijnb_u
349
350	dist%ijb_v = new_dist%ijb_v
351	dist%ije_v = new_dist%ije_v
352	dist%ijnb_v = new_dist%ijnb_v
353
354	dist%jj_begin_para(:) = new_dist%jj_begin_para(:)
355	dist%jj_end_para(:) = new_dist%jj_end_para(:)
356	dist%jj_nb_para(:) = new_dist%jj_nb_para(:)
357
358	END SUBROUTINE copy_distrib
359
360
361	SUBROUTINE get_current_distrib(d)
362	IMPLICIT NONE
363
364	INCLUDE "dimensions.h"
365	INCLUDE "paramet.h"
366	TYPE(distrib), INTENT(OUT) :: d
367
368	d = current_dist
369
370	END SUBROUTINE get_current_distrib
371
372	SUBROUTINE Finalize_parallel
373	USE lmdz_mpi
374	! ug Pour les sorties XIOS
375	USE lmdz_wxios
376
377	#ifdef CPP_COUPLE
378	! Use of Oasis-MCT coupler
379	#if defined CPP_OMCT
380	USE mod_prism
381	#else
382	USE mod_prism_proto
383	#endif
384	! Ehouarn: surface_data module is in 'phylmd' ...
385	USE surface_data, ONLY: type_ocean
386	IMPLICIT NONE
387	#else
388	IMPLICIT NONE
389	! without the surface_data module, we declare (and set) a dummy 'type_ocean'
390	CHARACTER(LEN = 6), parameter :: type_ocean = "dummy"
391	#endif
392
393	include "dimensions.h"
394	include "paramet.h"
395
396	INTEGER :: ierr
397	INTEGER :: i
398
399	IF (allocated(jj_begin_para)) deallocate(jj_begin_para)
400	IF (allocated(jj_end_para)) deallocate(jj_end_para)
401	IF (allocated(jj_nb_para)) deallocate(jj_nb_para)
402
403	IF (type_ocean == 'couple') THEN
404	#ifdef CPP_COUPLE
405	IF (using_xios) THEN
406	!Fermeture propre de XIOS
407	CALL wxios_close()
408	CALL prism_terminate_proto(ierr)
409	IF (ierr .NE. PRISM_Ok) THEN
410	CALL abort_gcm('Finalize_parallel',' Probleme dans prism_terminate_proto ',1)
411	ENDIF
412	ELSE
413	CALL prism_terminate_proto(ierr)
414	IF (ierr .NE. PRISM_Ok) THEN
415	CALL abort_gcm('Finalize_parallel',' Probleme dans prism_terminate_proto ',1)
416	endif
417	ENDIF
418	#else
419	CALL abort_gcm('Finalize_parallel', 'type_ocean = couple but CPP_COUPLE not defined', 1)
420	#endif
421	else
422	IF (using_xios) THEN
423	!Fermeture propre de XIOS
424	CALL wxios_close()
425	ENDIF
426	IF (using_mpi) CALL MPI_FINALIZE(ierr)
427	end if
428
429	END SUBROUTINE Finalize_parallel
430
431	SUBROUTINE Pack_Data(Field, ij, ll, row, Buffer)
432	IMPLICIT NONE
433
434	INCLUDE "dimensions.h"
435	INCLUDE "paramet.h"
436
437	INTEGER, INTENT(IN) :: ij, ll, row
438	REAL, DIMENSION(ij, ll), INTENT(IN) :: Field
439	REAL, DIMENSION(ll * iip1 * row), INTENT(OUT) :: Buffer
440
441	INTEGER :: Pos
442	INTEGER :: i, l
443
444	Pos = 0
445	do l = 1, ll
446	do i = 1, row * iip1
447	Pos = Pos + 1
448	Buffer(Pos) = Field(i, l)
449	enddo
450	enddo
451
452	END SUBROUTINE Pack_data
453
454	SUBROUTINE Unpack_Data(Field, ij, ll, row, Buffer)
455	IMPLICIT NONE
456
457	INCLUDE "dimensions.h"
458	INCLUDE "paramet.h"
459
460	INTEGER, INTENT(IN) :: ij, ll, row
461	REAL, DIMENSION(ij, ll), INTENT(OUT) :: Field
462	REAL, DIMENSION(ll * iip1 * row), INTENT(IN) :: Buffer
463
464	INTEGER :: Pos
465	INTEGER :: i, l
466
467	Pos = 0
468
469	do l = 1, ll
470	do i = 1, row * iip1
471	Pos = Pos + 1
472	Field(i, l) = Buffer(Pos)
473	enddo
474	enddo
475
476	END SUBROUTINE UnPack_data
477
478
479	SUBROUTINE barrier
480	USE lmdz_mpi
481	IMPLICIT NONE
482	INTEGER :: ierr
483
484	!$OMP CRITICAL (MPI)
485	IF (using_mpi) CALL MPI_Barrier(COMM_LMDZ, ierr)
486	!$OMP END CRITICAL (MPI)
487
488	END SUBROUTINE barrier
489
490
491	SUBROUTINE exchange_hallo(Field, ij, ll, up, down)
492	USE lmdz_mpi
493	USE lmdz_vampir
494	IMPLICIT NONE
495	INCLUDE "dimensions.h"
496	INCLUDE "paramet.h"
497	INTEGER :: ij, ll
498	REAL, DIMENSION(ij, ll) :: Field
499	INTEGER :: up, down
500
501	INTEGER :: ierr
502	LOGICAL :: SendUp, SendDown
503	LOGICAL :: RecvUp, RecvDown
504	INTEGER, DIMENSION(4) :: Request
505	INTEGER, DIMENSION(MPI_STATUS_SIZE, 4) :: Status
506
507	INTEGER :: NbRequest
508	REAL, DIMENSION(:), ALLOCATABLE :: Buffer_Send_up, Buffer_Send_down
509	REAL, DIMENSION(:), ALLOCATABLE :: Buffer_Recv_up, Buffer_Recv_down
510	INTEGER :: Buffer_size
511
512	IF (using_mpi) THEN
513
514	CALL barrier
515
516	CALL VTb(VThallo)
517
518	SendUp = .TRUE.
519	SendDown = .TRUE.
520	RecvUp = .TRUE.
521	RecvDown = .TRUE.
522
523	IF (pole_nord) THEN
524	SendUp = .FALSE.
525	RecvUp = .FALSE.
526	ENDIF
527
528	IF (pole_sud) THEN
529	SendDown = .FALSE.
530	RecvDown = .FALSE.
531	ENDIF
532
533	IF (up==0) THEN
534	SendDown = .FALSE.
535	RecvUp = .FALSE.
536	endif
537
538	IF (down==0) THEN
539	SendUp = .FALSE.
540	RecvDown = .FALSE.
541	endif
542
543	NbRequest = 0
544
545	IF (SendUp) THEN
546	NbRequest = NbRequest + 1
547	buffer_size = down * iip1 * ll
548	allocate(Buffer_Send_up(Buffer_size))
549	CALL PACK_Data(Field(ij_begin, 1), ij, ll, down, Buffer_Send_up)
550	!$OMP CRITICAL (MPI)
551	CALL MPI_ISEND(Buffer_send_up, Buffer_Size, MPI_REAL8, MPI_Rank - 1, 1, &
552	COMM_LMDZ, Request(NbRequest), ierr)
553	!$OMP END CRITICAL (MPI)
554	ENDIF
555
556	IF (SendDown) THEN
557	NbRequest = NbRequest + 1
558
559	buffer_size = up * iip1 * ll
560	allocate(Buffer_Send_down(Buffer_size))
561	CALL PACK_Data(Field(ij_end + 1 - up * iip1, 1), ij, ll, up, Buffer_send_down)
562
563	!$OMP CRITICAL (MPI)
564	CALL MPI_ISEND(Buffer_send_down, Buffer_Size, MPI_REAL8, MPI_Rank + 1, 1, &
565	COMM_LMDZ, Request(NbRequest), ierr)
566	!$OMP END CRITICAL (MPI)
567	ENDIF
568
569	IF (RecvUp) THEN
570	NbRequest = NbRequest + 1
571	buffer_size = up * iip1 * ll
572	allocate(Buffer_recv_up(Buffer_size))
573
574	!$OMP CRITICAL (MPI)
575	CALL MPI_IRECV(Buffer_recv_up, Buffer_size, MPI_REAL8, MPI_Rank - 1, 1, &
576	COMM_LMDZ, Request(NbRequest), ierr)
577	!$OMP END CRITICAL (MPI)
578
579	ENDIF
580
581	IF (RecvDown) THEN
582	NbRequest = NbRequest + 1
583	buffer_size = down * iip1 * ll
584	allocate(Buffer_recv_down(Buffer_size))
585
586	!$OMP CRITICAL (MPI)
587	CALL MPI_IRECV(Buffer_recv_down, Buffer_size, MPI_REAL8, MPI_Rank + 1, 1, &
588	COMM_LMDZ, Request(NbRequest), ierr)
589	!$OMP END CRITICAL (MPI)
590
591	ENDIF
592
593	IF (NbRequest > 0) CALL MPI_WAITALL(NbRequest, Request, Status, ierr)
594	IF (RecvUp) CALL Unpack_Data(Field(ij_begin - up * iip1, 1), ij, ll, up, Buffer_Recv_up)
595	IF (RecvDown) CALL Unpack_Data(Field(ij_end + 1, 1), ij, ll, down, Buffer_Recv_down)
596
597	CALL VTe(VThallo)
598	CALL barrier
599
600	ENDIF ! using_mpi
601
602	END SUBROUTINE exchange_Hallo
603
604
605	SUBROUTINE Gather_Field(Field, ij, ll, rank)
606	USE lmdz_mpi
607	USE lmdz_iniprint, ONLY: lunout, prt_level
608	IMPLICIT NONE
609	INCLUDE "dimensions.h"
610	INCLUDE "paramet.h"
611	INTEGER :: ij, ll, rank
612	REAL, DIMENSION(ij, ll) :: Field
613	REAL, DIMENSION(:), ALLOCATABLE :: Buffer_send
614	REAL, DIMENSION(:), ALLOCATABLE :: Buffer_Recv
615	INTEGER, DIMENSION(0:MPI_Size - 1) :: Recv_count, displ
616	INTEGER :: ierr
617	INTEGER :: i
618
619	IF (using_mpi) THEN
620
621	IF (ij==ip1jmp1) THEN
622	allocate(Buffer_send(iip1 * ll * (jj_end - jj_begin + 1)))
623	CALL Pack_Data(Field(ij_begin, 1), ij, ll, jj_end - jj_begin + 1, Buffer_send)
624	ELSE IF (ij==ip1jm) THEN
625	allocate(Buffer_send(iip1 * ll * (min(jj_end, jjm) - jj_begin + 1)))
626	CALL Pack_Data(Field(ij_begin, 1), ij, ll, min(jj_end, jjm) - jj_begin + 1, Buffer_send)
627	else
628	WRITE(lunout, *)ij
629	CALL abort_gcm("parallel_lmdz", "erreur dans Gather_Field", 1)
630	endif
631
632	IF (MPI_Rank==rank) THEN
633	allocate(Buffer_Recv(ij * ll))
634
635	!CDIR NOVECTOR
636	do i = 0, MPI_Size - 1
637
638	IF (ij==ip1jmp1) THEN
639	Recv_count(i) = (jj_end_para(i) - jj_begin_para(i) + 1) * ll * iip1
640	ELSE IF (ij==ip1jm) THEN
641	Recv_count(i) = (min(jj_end_para(i), jjm) - jj_begin_para(i) + 1) * ll * iip1
642	else
643	CALL abort_gcm("parallel_lmdz", "erreur dans Gather_Field", 1)
644	endif
645
646	IF (i==0) THEN
647	displ(i) = 0
648	else
649	displ(i) = displ(i - 1) + Recv_count(i - 1)
650	endif
651
652	enddo
653
654	else
655	! Ehouarn: When in debug mode, ifort complains (for CALL MPI_GATHERV
656	! below) about Buffer_Recv() being not allocated.
657	! So make a dummy allocation.
658	allocate(Buffer_Recv(1))
659	endif ! of if (MPI_Rank==rank)
660
661	!$OMP CRITICAL (MPI)
662	CALL MPI_GATHERV(Buffer_send, (min(ij_end, ij) - ij_begin + 1) * ll, MPI_REAL8, &
663	Buffer_Recv, Recv_count, displ, MPI_REAL8, rank, COMM_LMDZ, ierr)
664	!$OMP END CRITICAL (MPI)
665
666	IF (MPI_Rank==rank) THEN
667	IF (ij==ip1jmp1) THEN
668	do i = 0, MPI_Size - 1
669	CALL Unpack_Data(Field((jj_begin_para(i) - 1) * iip1 + 1, 1), ij, ll, &
670	jj_end_para(i) - jj_begin_para(i) + 1, Buffer_Recv(displ(i) + 1))
671	enddo
672	ELSE IF (ij==ip1jm) THEN
673	do i = 0, MPI_Size - 1
674	CALL Unpack_Data(Field((jj_begin_para(i) - 1) * iip1 + 1, 1), ij, ll, &
675	min(jj_end_para(i), jjm) - jj_begin_para(i) + 1, Buffer_Recv(displ(i) + 1))
676	enddo
677	endif
678	endif
679	ENDIF ! using_mpi
680
681	END SUBROUTINE Gather_Field
682
683
684	SUBROUTINE AllGather_Field(Field, ij, ll)
685	USE lmdz_mpi
686	IMPLICIT NONE
687	INCLUDE "dimensions.h"
688	INCLUDE "paramet.h"
689	INTEGER :: ij, ll
690	REAL, DIMENSION(ij, ll) :: Field
691	INTEGER :: ierr
692
693	IF (using_mpi) THEN
694	CALL Gather_Field(Field, ij, ll, 0)
695	!$OMP CRITICAL (MPI)
696	CALL MPI_BCAST(Field, ij * ll, MPI_REAL8, 0, COMM_LMDZ, ierr)
697	!$OMP END CRITICAL (MPI)
698	ENDIF
699
700	END SUBROUTINE AllGather_Field
701
702	SUBROUTINE Broadcast_Field(Field, ij, ll, rank)
703	USE lmdz_mpi
704	IMPLICIT NONE
705	INCLUDE "dimensions.h"
706	INCLUDE "paramet.h"
707	INTEGER :: ij, ll
708	REAL, DIMENSION(ij, ll) :: Field
709	INTEGER :: rank
710	INTEGER :: ierr
711
712	IF (using_mpi) THEN
713
714	!$OMP CRITICAL (MPI)
715	CALL MPI_BCAST(Field, ij * ll, MPI_REAL8, rank, COMM_LMDZ, ierr)
716	!$OMP END CRITICAL (MPI)
717
718	ENDIF
719	END SUBROUTINE Broadcast_Field
720
721
722	! Subroutine verif_hallo(Field,ij,ll,up,down)
723	! USE lmdz_mpi
724	! IMPLICIT NONE
725	! INCLUDE "dimensions.h"
726	! INCLUDE "paramet.h"
727
728	! INTEGER :: ij,ll
729	! REAL, DIMENSION(ij,ll) :: Field
730	! INTEGER :: up,down
731
732	! REAL,DIMENSION(ij,ll): NewField
733
734	! NewField=0
735
736	! ijb=ij_begin
737	! ije=ij_end
738	! if (pole_nord)
739	! NewField(ij_be
740
741	end MODULE parallel_lmdz

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

Download in other formats:

Original Format