Context Navigation

parallel.F90 @ 1117

Last change on this file since 1117 was 1000, checked in by Laurent Fairhead, 16 years ago

Modifs sur le parallelisme: masquage dans la physique
Inclusion strato
mise en coherence etat0
le mode offline fonctionne maintenant en parallele,
les fichiers de la dynamiques sont correctement sortis et peuvent etre reconstruit avec rebuild
la version parallele de la dynamique peut s'executer sans MPI (sur 1 proc)
L'OPENMP fonctionne maintenant sans la parallelisation MPI.

YM
LF

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

File size: 13.1 KB

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

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

Download in other formats:

Original Format