Context Navigation

parallel.F90 @ 3400

Last change on this file since 3400 was 885, checked in by Laurent Fairhead, 17 years ago
Modifs pour faire tourner le meme executable en force ou couple JG LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 10.9 KB

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

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

Download in other formats:

Original Format