Context Navigation

parallel.F90 @ 801

Last change on this file since 801 was 792, checked in by Laurent Fairhead, 17 years ago
Modifications suite a la transformation des fichiers include pour qu'ils soient compatibles a la fois au format fixe et au format libre Un bon nombre de fichier *.inc du coup disparaissent 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 "dimensions.h"
37	#include "paramet.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 "dimensions.h"
117	#include "paramet.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 "dimensions.h"
153	#include "paramet.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 "dimensions.h"
177	#include "paramet.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 "dimensions.h"
200	#include "paramet.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 "dimensions.h"
224	#include "paramet.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 "dimensions.h"
328	#include "paramet.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 "dimensions.h"
396	#include "paramet.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 "dimensions.h"
411	#include "paramet.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 "dimensions.h"
428	#include "paramet.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