Context Navigation

parallel.F90 @ 5017

Last change on this file since 5017 was 1717, checked in by Ehouarn Millour, 12 years ago
Added "arch" files for Ada (using dynamic libraries for NetCDF, you must have export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:/smplocal/pub/NetCDF/4.1.3/lib:/smplocal/pub/HDF5/1.8.9/seq/lib in your .bashrc or .bash_login or in your job to run). Also updated some sources so that gcm bench runs in "debug" mode (note that all these changes are minor and have already been implemented in LMDZ5 trunk). EM
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 13.9 KB

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

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

Download in other formats:

Original Format