Context Navigation

parallel.F90 @ 1148

Last change on this file since 1148 was 1146, checked in by Laurent Fairhead, 16 years ago
Réintegration dans le tronc des modifications issues de la branche LMDZ-dev comprises entre la révision 1074 et 1145 Validation: une simulation de 1 jour en séquentiel sur PC donne les mêmes résultats entre la trunk et la dev LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 13.2 KB

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

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

Download in other formats:

Original Format