Context Navigation

parallel.F90 @ 790

Last change on this file since 790 was 785, checked in by Laurent Fairhead, 17 years ago
Quelques caracteres en trop pour le premier et elimination de la cle CPP_PSMILE JG LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 11.1 KB

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

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

Download in other formats:

Original Format