Context Navigation

parallel_lmdz.F90 @ 1907

Last change on this file since 1907 was 1907, checked in by lguez, 10 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: 15.2 KB

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

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

Download in other formats:

Original Format