Context Navigation

parallel.F90 @ 5080

Last change on this file since 5080 was 1492, checked in by Laurent Fairhead, 14 years ago

Merge of development branch LMDZ5V2.0-dev r1455:r1491 into the trunk.
Validation made locally: restart files are strictly equal between the HEAD of the trunk
and r1491 of LMDZ5V2.0-dev

Synchro de la branche de développement LMDZ5V2.0-dev r1455:r1491 et de la trunk
Validation faite en local: les fichiers restart sont équivalents entre la HEAD de la trunk
et la révision r1491 de LMDZ5V2.0-dev

Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

File size: 13.7 KB

Line
1	!
2	! $Id: parallel.F90 1492 2011-03-08 08:10:25Z abarral $
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	endif
479
480	!$OMP CRITICAL (MPI)
481	#ifdef CPP_MPI
482	call MPI_GATHERV(Buffer_send,(min(ij_end,ij)-ij_begin+1)*ll,MPI_REAL8, &
483	Buffer_Recv,Recv_count,displ,MPI_REAL8,rank,COMM_LMDZ,ierr)
484	#endif
485	!$OMP END CRITICAL (MPI)
486
487	if (MPI_Rank==rank) then
488
489	if (ij==ip1jmp1) then
490	do i=0,MPI_Size-1
491	call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll, &
492	jj_end_para(i)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
493	enddo
494	else if (ij==ip1jm) then
495	do i=0,MPI_Size-1
496	call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll, &
497	min(jj_end_para(i),jjm)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
498	enddo
499	endif
500	endif
501	ENDIF ! using_mpi
502
503	end subroutine Gather_Field
504
505
506	subroutine AllGather_Field(Field,ij,ll)
507	implicit none
508	#include "dimensions.h"
509	#include "paramet.h"
510	#ifdef CPP_MPI
511	include 'mpif.h'
512	#endif
513	INTEGER :: ij,ll
514	REAL, dimension(ij,ll) :: Field
515	INTEGER :: ierr
516
517	IF (using_mpi) THEN
518	call Gather_Field(Field,ij,ll,0)
519	!$OMP CRITICAL (MPI)
520	#ifdef CPP_MPI
521	call MPI_BCAST(Field,ij*ll,MPI_REAL8,0,COMM_LMDZ,ierr)
522	#endif
523	!$OMP END CRITICAL (MPI)
524	ENDIF
525
526	end subroutine AllGather_Field
527
528	subroutine Broadcast_Field(Field,ij,ll,rank)
529	implicit none
530	#include "dimensions.h"
531	#include "paramet.h"
532	#ifdef CPP_MPI
533	include 'mpif.h'
534	#endif
535	INTEGER :: ij,ll
536	REAL, dimension(ij,ll) :: Field
537	INTEGER :: rank
538	INTEGER :: ierr
539
540	IF (using_mpi) THEN
541
542	!$OMP CRITICAL (MPI)
543	#ifdef CPP_MPI
544	call MPI_BCAST(Field,ij*ll,MPI_REAL8,rank,COMM_LMDZ,ierr)
545	#endif
546	!$OMP END CRITICAL (MPI)
547
548	ENDIF
549	end subroutine Broadcast_Field
550
551
552	! Subroutine verif_hallo(Field,ij,ll,up,down)
553	! implicit none
554	!#include "dimensions.h"
555	!#include "paramet.h"
556	! include 'mpif.h'
557	!
558	! INTEGER :: ij,ll
559	! REAL, dimension(ij,ll) :: Field
560	! INTEGER :: up,down
561	!
562	! REAL,dimension(ij,ll): NewField
563	!
564	! NewField=0
565	!
566	! ijb=ij_begin
567	! ije=ij_end
568	! if (pole_nord)
569	! NewField(ij_be
570
571	end module parallel

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

Download in other formats:

Original Format