Context Navigation

parallel_lmdz.F90 @ 1950

Last change on this file since 1950 was 1907, checked in by lguez, 11 years ago

Added a copyright property to every file of the distribution, except
for the fcm files (which have their own copyright). Use svn propget on
a file to see the copyright. For instance:

$ svn propget copyright libf/phylmd/physiq.F90
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

Also added the files defining the CeCILL version 2 license, in French
and English, at the top of the LMDZ tree.

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

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

Download in other formats:

Original Format