Context Navigation

parallel_lmdz.F90 @ 4048

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

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

Download in other formats:

Original Format