Context Navigation

parallel_lmdz.F90 @ 5206

Last change on this file since 5206 was 5206, checked in by Laurent Fairhead, 10 months ago
Corrections to properly close XIOS contexts in LMDZ (either with DYNAMICO or lonlat) Anne Cozic
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: 19.9 KB

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

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

Download in other formats:

Original Format