Context Navigation

mod_hallo.F90 @ 1423

Last change on this file since 1423 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: 21.3 KB

Rev	Line
[630]	1	module mod_Hallo
	2	USE parallel
	3	implicit none
[985]	4	logical,save :: use_mpi_alloc
[764]	5	integer, parameter :: MaxRequest=200
[630]	6	integer, parameter :: MaxProc=80
	7	integer, parameter :: MaxBufferSize=1024102416
	8	integer, parameter :: ListSize=1000
	9
	10	integer,save :: MaxBufferSize_Used
[985]	11	!$OMP THREADPRIVATE( MaxBufferSize_Used)
[807]	12
[985]	13	real,save,pointer,dimension(:) :: Buffer
	14	!$OMP THREADPRIVATE(Buffer)
	15
	16	integer,save,dimension(Listsize) :: Buffer_Pos
	17	integer,save :: Index_Pos
	18	!$OMP THREADPRIVATE(Buffer_Pos,Index_pos)
[630]	19
	20	type Hallo
	21	real, dimension(:,:),pointer :: Field
	22	integer :: offset
	23	integer :: size
	24	integer :: NbLevel
	25	integer :: Stride
	26	end type Hallo
	27
	28	type request_SR
	29	integer :: NbRequest=0
	30	integer :: Pos
	31	integer :: Index
	32	type(Hallo),dimension(MaxRequest) :: Hallo
	33	integer :: MSG_Request
	34	end type request_SR
	35
	36	type request
	37	type(request_SR),dimension(0:MaxProc-1) :: RequestSend
	38	type(request_SR),dimension(0:MaxProc-1) :: RequestRecv
	39	integer :: tag=1
	40	end type request
	41
	42
	43	contains
	44
[807]	45	subroutine Init_mod_hallo
[630]	46	implicit none
[807]	47
[630]	48	Index_Pos=1
	49	Buffer_Pos(Index_Pos)=1
[807]	50	MaxBufferSize_Used=0
	51
[1000]	52	IF (use_mpi_alloc .AND. using_mpi) THEN
[985]	53	CALL create_global_mpi_buffer
	54	ELSE
	55	CALL create_standard_mpi_buffer
	56	ENDIF
	57
[630]	58	end subroutine init_mod_hallo
[807]	59
	60	SUBROUTINE create_standard_mpi_buffer
	61	IMPLICIT NONE
	62
	63	ALLOCATE(Buffer(MaxBufferSize))
	64
	65	END SUBROUTINE create_standard_mpi_buffer
	66
	67	SUBROUTINE create_global_mpi_buffer
	68	IMPLICIT NONE
[1000]	69	#ifdef CPP_MPI
	70	INCLUDE 'mpif.h'
	71	#endif
[807]	72	POINTER (Pbuffer,MPI_Buffer(MaxBufferSize))
	73	REAL :: MPI_Buffer
[1000]	74	#ifdef CPP_MPI
[807]	75	INTEGER(KIND=MPI_ADDRESS_KIND) :: BS
[1000]	76	#else
	77	INTEGER(KIND=8) :: BS
	78	#endif
[807]	79	INTEGER :: i,ierr
	80
[985]	81	! Allocation du buffer MPI
[807]	82	Bs=8*MaxBufferSize
[985]	83	!$OMP CRITICAL (MPI)
[1000]	84	#ifdef CPP_MPI
[807]	85	CALL MPI_ALLOC_MEM(BS,MPI_INFO_NULL,Pbuffer,ierr)
[1000]	86	#endif
[985]	87	!$OMP END CRITICAL (MPI)
[807]	88	DO i=1,MaxBufferSize
	89	MPI_Buffer(i)=i
	90	ENDDO
	91
	92	CALL Associate_buffer(MPI_Buffer)
[630]	93
[807]	94	CONTAINS
	95
	96	SUBROUTINE Associate_buffer(MPI_Buffer)
	97	IMPLICIT NONE
	98	REAL,DIMENSION(:),target :: MPI_Buffer
	99
	100	Buffer=>MPI_Buffer
	101
	102	END SUBROUTINE Associate_buffer
	103
	104	END SUBROUTINE create_global_mpi_buffer
[985]	105
[807]	106
[630]	107	subroutine allocate_buffer(Size,Index,Pos)
	108	implicit none
	109	integer :: Size
	110	integer :: Index
	111	integer :: Pos
	112
	113	if (Buffer_pos(Index_pos)+Size>MaxBufferSize_Used) MaxBufferSize_Used=Buffer_pos(Index_pos)+Size
	114	if (Buffer_pos(Index_pos)+Size>MaxBufferSize) then
	115	print *,'STOP :: La taille de MaxBufferSize dans mod_hallo.F90 est trop petite !!!!'
	116	stop
	117	endif
	118
	119	if (Index_pos>=ListSize) then
	120	print *,'STOP :: La taille de ListSize dans mod_hallo.F90 est trop petite !!!!'
	121	stop
	122	endif
	123
	124	Pos=Buffer_Pos(Index_Pos)
	125	Buffer_Pos(Index_pos+1)=Buffer_Pos(Index_Pos)+Size
	126	Index_Pos=Index_Pos+1
	127	Index=Index_Pos
	128
	129	end subroutine allocate_buffer
	130
	131	subroutine deallocate_buffer(Index)
	132	implicit none
	133	integer :: Index
	134
	135	Buffer_Pos(Index)=-1
	136
	137	do while (Buffer_Pos(Index_Pos)==-1 .and. Index_Pos>1)
	138	Index_Pos=Index_Pos-1
	139	end do
	140
	141	end subroutine deallocate_buffer
	142
	143	subroutine SetTag(a_request,tag)
	144	implicit none
	145	type(request):: a_request
	146	integer :: tag
	147
	148	a_request%tag=tag
	149	end subroutine SetTag
	150
	151
	152	subroutine Init_Hallo(Field,Stride,NbLevel,offset,size,NewHallo)
	153	integer :: Stride
	154	integer :: NbLevel
	155	integer :: size
	156	integer :: offset
	157	real, dimension(Stride,NbLevel),target :: Field
	158	type(Hallo) :: NewHallo
	159
	160	NewHallo%Field=>Field
	161	NewHallo%Stride=Stride
	162	NewHallo%NbLevel=NbLevel
	163	NewHallo%size=size
	164	NewHallo%offset=offset
	165
	166
	167	end subroutine Init_Hallo
	168
	169	subroutine Register_SendField(Field,ij,ll,offset,size,target,a_request)
	170	implicit none
	171
[792]	172	#include "dimensions.h"
	173	#include "paramet.h"
[630]	174
	175	INTEGER :: ij,ll,offset,size,target
	176	REAL, dimension(ij,ll) :: Field
	177	type(request),target :: a_request
	178	type(request_SR),pointer :: Ptr_request
	179
	180	Ptr_Request=>a_request%RequestSend(target)
	181	Ptr_Request%NbRequest=Ptr_Request%NbRequest+1
	182	if (Ptr_Request%NbRequest>=MaxRequest) then
	183	print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!'
	184	stop
	185	endif
	186	call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest))
	187
	188	end subroutine Register_SendField
	189
	190	subroutine Register_RecvField(Field,ij,ll,offset,size,target,a_request)
	191	implicit none
	192
[792]	193	#include "dimensions.h"
	194	#include "paramet.h"
[630]	195
	196	INTEGER :: ij,ll,offset,size,target
	197	REAL, dimension(ij,ll) :: Field
	198	type(request),target :: a_request
	199	type(request_SR),pointer :: Ptr_request
	200
	201	Ptr_Request=>a_request%RequestRecv(target)
	202	Ptr_Request%NbRequest=Ptr_Request%NbRequest+1
	203
	204	if (Ptr_Request%NbRequest>=MaxRequest) then
	205	print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!'
	206	stop
	207	endif
	208
	209	call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest))
	210
	211
	212	end subroutine Register_RecvField
	213
	214	subroutine Register_SwapField(FieldS,FieldR,ij,ll,jj_Nb_New,a_request)
	215
	216	implicit none
[792]	217	#include "dimensions.h"
	218	#include "paramet.h"
[630]	219
	220	INTEGER :: ij,ll
	221	REAL, dimension(ij,ll) :: FieldS
	222	REAL, dimension(ij,ll) :: FieldR
	223	type(request) :: a_request
	224	integer,dimension(0:MPI_Size-1) :: jj_Nb_New
	225	integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
	226
	227	integer ::i,jje,jjb
	228
	229	jj_begin_New(0)=1
	230	jj_End_New(0)=jj_Nb_New(0)
	231	do i=1,MPI_Size-1
	232	jj_begin_New(i)=jj_end_New(i-1)+1
	233	jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
	234	enddo
	235
	236	do i=0,MPI_Size-1
	237	if (i /= MPI_Rank) then
	238	jjb=max(jj_begin_new(i),jj_begin)
	239	jje=min(jj_end_new(i),jj_end)
	240
	241	if (ij==ip1jm .and. jje==jjp1) jje=jjm
	242
	243	if (jje >= jjb) then
	244	call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request)
	245	endif
	246
	247	jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
	248	jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
	249
	250	if (ij==ip1jm .and. jje==jjp1) jje=jjm
	251
	252	if (jje >= jjb) then
	253	call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request)
	254	endif
	255
	256	endif
	257	enddo
	258
	259	end subroutine Register_SwapField
	260
	261
	262	subroutine Register_SwapFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down,a_request)
	263
	264	implicit none
[792]	265	#include "dimensions.h"
	266	#include "paramet.h"
[630]	267
	268	INTEGER :: ij,ll,Up,Down
	269	REAL, dimension(ij,ll) :: FieldS
	270	REAL, dimension(ij,ll) :: FieldR
	271	type(request) :: a_request
	272	integer,dimension(0:MPI_Size-1) :: jj_Nb_New
	273	integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
	274
	275	integer ::i,jje,jjb
	276
	277	jj_begin_New(0)=1
	278	jj_End_New(0)=jj_Nb_New(0)
	279	do i=1,MPI_Size-1
	280	jj_begin_New(i)=jj_end_New(i-1)+1
	281	jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
	282	enddo
	283
	284	do i=0,MPI_Size-1
	285	jj_begin_New(i)=max(1,jj_begin_New(i)-Up)
	286	jj_end_New(i)=min(jjp1,jj_end_new(i)+Down)
	287	enddo
	288
	289	do i=0,MPI_Size-1
	290	if (i /= MPI_Rank) then
	291	jjb=max(jj_begin_new(i),jj_begin)
	292	jje=min(jj_end_new(i),jj_end)
	293
	294	if (ij==ip1jm .and. jje==jjp1) jje=jjm
	295
	296	if (jje >= jjb) then
	297	call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request)
	298	endif
	299
	300	jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
	301	jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
	302
	303	if (ij==ip1jm .and. jje==jjp1) jje=jjm
	304
	305	if (jje >= jjb) then
	306	call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request)
	307	endif
	308
	309	endif
	310	enddo
	311
	312	end subroutine Register_SwapFieldHallo
	313
	314	subroutine Register_Hallo(Field,ij,ll,RUp,Rdown,SUp,SDown,a_request)
	315
	316	implicit none
[792]	317	#include "dimensions.h"
	318	#include "paramet.h"
[1000]	319	#ifdef CPP_MPI
[630]	320	include 'mpif.h'
[1000]	321	#endif
[630]	322	INTEGER :: ij,ll
	323	REAL, dimension(ij,ll) :: Field
	324	INTEGER :: Sup,Sdown,rup,rdown
	325	type(request) :: a_request
	326	type(Hallo),pointer :: PtrHallo
	327	LOGICAL :: SendUp,SendDown
	328	LOGICAL :: RecvUp,RecvDown
	329
	330
	331	SendUp=.TRUE.
	332	SendDown=.TRUE.
	333	RecvUp=.TRUE.
	334	RecvDown=.TRUE.
	335
	336	IF (pole_nord) THEN
	337	SendUp=.FALSE.
	338	RecvUp=.FALSE.
	339	ENDIF
	340
	341	IF (pole_sud) THEN
	342	SendDown=.FALSE.
	343	RecvDown=.FALSE.
	344	ENDIF
	345
	346	if (Sup.eq.0) then
	347	SendUp=.FALSE.
	348	endif
	349
	350	if (Sdown.eq.0) then
	351	SendDown=.FALSE.
	352	endif
	353
	354	if (Rup.eq.0) then
	355	RecvUp=.FALSE.
	356	endif
	357
	358	if (Rdown.eq.0) then
	359	RecvDown=.FALSE.
	360	endif
	361
	362	IF (SendUp) THEN
	363	call Register_SendField(Field,ij,ll,jj_begin,SUp,MPI_Rank-1,a_request)
	364	ENDIF
	365
	366	IF (SendDown) THEN
	367	call Register_SendField(Field,ij,ll,jj_end-SDown+1,SDown,MPI_Rank+1,a_request)
	368	ENDIF
	369
	370
	371	IF (RecvUp) THEN
	372	call Register_RecvField(Field,ij,ll,jj_begin-Rup,RUp,MPI_Rank-1,a_request)
	373	ENDIF
	374
	375	IF (RecvDown) THEN
	376	call Register_RecvField(Field,ij,ll,jj_end+1,RDown,MPI_Rank+1,a_request)
	377	ENDIF
	378
	379	end subroutine Register_Hallo
	380
	381	subroutine SendRequest(a_Request)
	382	implicit none
	383
[792]	384	#include "dimensions.h"
	385	#include "paramet.h"
[1000]	386	#ifdef CPP_MPI
[630]	387	include 'mpif.h'
[1000]	388	#endif
[630]	389
	390	type(request),target :: a_request
	391	type(request_SR),pointer :: Req
	392	type(Hallo),pointer :: PtrHallo
	393	integer :: SizeBuffer
	394	integer :: i,rank,l,ij,Pos,ierr
	395	integer :: offset
	396	real,dimension(:,:),pointer :: Field
	397	integer :: Nb
	398
	399	do rank=0,MPI_SIZE-1
	400
	401	Req=>a_Request%RequestSend(rank)
	402
	403	SizeBuffer=0
	404	do i=1,Req%NbRequest
	405	PtrHallo=>Req%Hallo(i)
[985]	406	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	407	DO l=1,PtrHallo%NbLevel
	408	SizeBuffer=SizeBuffer+PtrHallo%size*iip1
	409	ENDDO
	410	!$OMP ENDDO NOWAIT
[630]	411	enddo
	412
	413	if (SizeBuffer>0) then
	414
	415	call allocate_buffer(SizeBuffer,Req%Index,Req%pos)
	416
	417	Pos=Req%Pos
	418	do i=1,Req%NbRequest
	419	PtrHallo=>Req%Hallo(i)
	420	offset=(PtrHallo%offset-1)*iip1+1
	421	Nb=iip1*PtrHallo%size-1
	422	Field=>PtrHallo%Field
[985]	423
	424	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]	425	do l=1,PtrHallo%NbLevel
	426	!cdir NODEP
	427	do ij=0,Nb
	428	Buffer(Pos+ij)=Field(Offset+ij,l)
	429	enddo
	430
	431	Pos=Pos+Nb+1
	432	enddo
[985]	433	!$OMP END DO NOWAIT
[630]	434	enddo
	435
[985]	436	!$OMP CRITICAL (MPI)
[1000]	437
	438	#ifdef CPP_MPI
	439	call MPI_ISSEND(Buffer(req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank, &
[764]	440	COMM_LMDZ,Req%MSG_Request,ierr)
[1000]	441	#endif
	442	IF (.NOT.using_mpi) THEN
	443	PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
	444	STOP
	445	ENDIF
[985]	446	! PRINT *,"-------------------------------------------------------------------"
	447	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
	448	! PRINT ,"Requete envoye au proc :",rank,"tag :",a_request%tag+1000omp_rank
	449	! PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
	450	! PRINT *,"-------------------------------------------------------------------"
	451	!$OMP END CRITICAL (MPI)
[630]	452	endif
	453
	454	enddo
	455
	456
	457	do rank=0,MPI_SIZE-1
	458
	459	Req=>a_Request%RequestRecv(rank)
	460	SizeBuffer=0
	461
	462	do i=1,Req%NbRequest
	463	PtrHallo=>Req%Hallo(i)
[985]	464
	465	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	466	DO l=1,PtrHallo%NbLevel
	467	SizeBuffer=SizeBuffer+PtrHallo%size*iip1
	468	ENDDO
	469	!$OMP ENDDO NOWAIT
[630]	470	enddo
	471
	472	if (SizeBuffer>0) then
[985]	473
[630]	474	call allocate_buffer(SizeBuffer,Req%Index,Req%Pos)
[985]	475	!$OMP CRITICAL (MPI)
[1000]	476
	477	#ifdef CPP_MPI
	478	call MPI_IRECV(Buffer(Req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank, &
[764]	479	COMM_LMDZ,Req%MSG_Request,ierr)
[1000]	480	#endif
	481	IF (.NOT.using_mpi) THEN
	482	PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
	483	STOP
	484	ENDIF
	485
[985]	486	! PRINT *,"-------------------------------------------------------------------"
	487	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
	488	! PRINT ,"Requete en attente du proc :",rank,"tag :",a_request%tag+1000omp_rank
	489	! PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
	490	! PRINT *,"-------------------------------------------------------------------"
[630]	491
[985]	492	!$OMP END CRITICAL (MPI)
[630]	493	endif
	494
	495	enddo
	496
	497	end subroutine SendRequest
	498
	499	subroutine WaitRequest(a_Request)
	500	implicit none
	501
[792]	502	#include "dimensions.h"
	503	#include "paramet.h"
[1000]	504	#ifdef CPP_MPI
[630]	505	include 'mpif.h'
[1000]	506	#endif
[630]	507
	508	type(request),target :: a_request
	509	type(request_SR),pointer :: Req
	510	type(Hallo),pointer :: PtrHallo
[764]	511	integer, dimension(2*mpi_size) :: TabRequest
[1000]	512	#ifdef CPP_MPI
[764]	513	integer, dimension(MPI_STATUS_SIZE,2*mpi_size) :: TabStatus
[1000]	514	#else
	515	integer, dimension(1,2*mpi_size) :: TabStatus
	516	#endif
[630]	517	integer :: NbRequest
	518	integer :: i,rank,pos,ij,l,ierr
	519	integer :: offset
	520	integer :: Nb
	521
	522
	523	NbRequest=0
	524	do rank=0,MPI_SIZE-1
	525	Req=>a_request%RequestSend(rank)
	526	if (Req%NbRequest>0) then
	527	NbRequest=NbRequest+1
	528	TabRequest(NbRequest)=Req%MSG_Request
	529	endif
	530	enddo
	531
	532	do rank=0,MPI_SIZE-1
	533	Req=>a_request%RequestRecv(rank)
	534	if (Req%NbRequest>0) then
	535	NbRequest=NbRequest+1
	536	TabRequest(NbRequest)=Req%MSG_Request
	537	endif
	538	enddo
	539
[985]	540	if (NbRequest>0) then
	541	!$OMP CRITICAL (MPI)
	542	! PRINT *,"-------------------------------------------------------------------"
	543	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
	544	! PRINT *,"No des requetes :",TabRequest(1:NbRequest)
[1000]	545	#ifdef CPP_MPI
[985]	546	call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
[1000]	547	#endif
[985]	548	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
	549	! PRINT *,"-------------------------------------------------------------------"
	550	!$OMP END CRITICAL (MPI)
	551	endif
[630]	552	do rank=0,MPI_Size-1
	553	Req=>a_request%RequestRecv(rank)
	554	if (Req%NbRequest>0) then
	555	Pos=Req%Pos
	556	do i=1,Req%NbRequest
	557	PtrHallo=>Req%Hallo(i)
	558	offset=(PtrHallo%offset-1)*iip1+1
	559	Nb=iip1*PtrHallo%size-1
[985]	560
	561	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]	562	do l=1,PtrHallo%NbLevel
	563	!cdir NODEP
	564	do ij=0,Nb
	565	PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
	566	enddo
[985]	567
[630]	568	Pos=Pos+Nb+1
	569	enddo
[985]	570	!$OMP ENDDO NOWAIT
[630]	571	enddo
	572	endif
	573	enddo
	574
	575	do rank=0,MPI_SIZE-1
	576	Req=>a_request%RequestSend(rank)
	577	if (Req%NbRequest>0) then
	578	call deallocate_buffer(Req%Index)
	579	Req%NbRequest=0
	580	endif
	581	enddo
	582
	583	do rank=0,MPI_SIZE-1
	584	Req=>a_request%RequestRecv(rank)
	585	if (Req%NbRequest>0) then
	586	call deallocate_buffer(Req%Index)
	587	Req%NbRequest=0
	588	endif
	589	enddo
	590
	591	a_request%tag=1
	592	end subroutine WaitRequest
	593
	594	subroutine WaitSendRequest(a_Request)
	595	implicit none
	596
[792]	597	#include "dimensions.h"
	598	#include "paramet.h"
[1000]	599	#ifdef CPP_MPI
[630]	600	include 'mpif.h'
[1000]	601	#endif
[630]	602	type(request),target :: a_request
	603	type(request_SR),pointer :: Req
	604	type(Hallo),pointer :: PtrHallo
[764]	605	integer, dimension(mpi_size) :: TabRequest
[1000]	606	#ifdef CPP_MPI
[764]	607	integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
[1000]	608	#else
	609	integer, dimension(1,mpi_size) :: TabStatus
	610	#endif
[630]	611	integer :: NbRequest
	612	integer :: i,rank,pos,ij,l,ierr
	613	integer :: offset
	614
	615
	616	NbRequest=0
	617	do rank=0,MPI_SIZE-1
	618	Req=>a_request%RequestSend(rank)
	619	if (Req%NbRequest>0) then
	620	NbRequest=NbRequest+1
	621	TabRequest(NbRequest)=Req%MSG_Request
	622	endif
	623	enddo
	624
	625
[985]	626	if (NbRequest>0) THEN
	627	!$OMP CRITICAL (MPI)
	628	! PRINT *,"-------------------------------------------------------------------"
	629	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
	630	! PRINT *,"No des requetes :",TabRequest(1:NbRequest)
[1000]	631	#ifdef CPP_MPI
[985]	632	call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
[1000]	633	#endif
[985]	634	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
	635	! PRINT *,"-------------------------------------------------------------------"
	636
	637	!$OMP END CRITICAL (MPI)
	638	endif
[630]	639
	640	do rank=0,MPI_SIZE-1
	641	Req=>a_request%RequestSend(rank)
	642	if (Req%NbRequest>0) then
	643	call deallocate_buffer(Req%Index)
	644	Req%NbRequest=0
	645	endif
	646	enddo
	647
	648	a_request%tag=1
	649	end subroutine WaitSendRequest
	650
	651	subroutine WaitRecvRequest(a_Request)
	652	implicit none
	653
[792]	654	#include "dimensions.h"
	655	#include "paramet.h"
[1000]	656	#ifdef CPP_MPI
[630]	657	include 'mpif.h'
[1000]	658	#endif
[630]	659
	660	type(request),target :: a_request
	661	type(request_SR),pointer :: Req
	662	type(Hallo),pointer :: PtrHallo
[764]	663	integer, dimension(mpi_size) :: TabRequest
[1000]	664	#ifdef CPP_MPI
[764]	665	integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
[1000]	666	#else
	667	integer, dimension(1,mpi_size) :: TabStatus
	668	#endif
[630]	669	integer :: NbRequest
	670	integer :: i,rank,pos,ij,l,ierr
	671	integer :: offset,Nb
	672
	673
	674	NbRequest=0
	675
	676	do rank=0,MPI_SIZE-1
	677	Req=>a_request%RequestRecv(rank)
	678	if (Req%NbRequest>0) then
	679	NbRequest=NbRequest+1
	680	TabRequest(NbRequest)=Req%MSG_Request
	681	endif
	682	enddo
	683
	684
[985]	685	if (NbRequest>0) then
	686	!$OMP CRITICAL (MPI)
	687	! PRINT *,"-------------------------------------------------------------------"
	688	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
	689	! PRINT *,"No des requetes :",TabRequest(1:NbRequest)
[1000]	690	#ifdef CPP_MPI
[985]	691	call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
[1000]	692	#endif
[985]	693	! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
	694	! PRINT *,"-------------------------------------------------------------------"
	695	!$OMP END CRITICAL (MPI)
	696	endif
[630]	697
	698	do rank=0,MPI_Size-1
	699	Req=>a_request%RequestRecv(rank)
	700	if (Req%NbRequest>0) then
	701	Pos=Req%Pos
	702	do i=1,Req%NbRequest
	703	PtrHallo=>Req%Hallo(i)
	704	offset=(PtrHallo%offset-1)*iip1+1
	705	Nb=iip1*PtrHallo%size-1
[985]	706	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]	707	do l=1,PtrHallo%NbLevel
	708	!cdir NODEP
	709	do ij=0,Nb
	710	PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
	711	enddo
	712	Pos=Pos+Nb+1
	713	enddo
[985]	714	!$OMP END DO NOWAIT
[630]	715	enddo
	716	endif
	717	enddo
	718
	719
	720	do rank=0,MPI_SIZE-1
	721	Req=>a_request%RequestRecv(rank)
	722	if (Req%NbRequest>0) then
	723	call deallocate_buffer(Req%Index)
	724	Req%NbRequest=0
	725	endif
	726	enddo
	727
	728	a_request%tag=1
	729	end subroutine WaitRecvRequest
	730
	731
	732
	733	subroutine CopyField(FieldS,FieldR,ij,ll,jj_Nb_New)
	734
	735	implicit none
[792]	736	#include "dimensions.h"
	737	#include "paramet.h"
[630]	738
[985]	739	INTEGER :: ij,ll,l
[630]	740	REAL, dimension(ij,ll) :: FieldS
	741	REAL, dimension(ij,ll) :: FieldR
	742	integer,dimension(0:MPI_Size-1) :: jj_Nb_New
	743	integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
	744
	745	integer ::i,jje,jjb,ijb,ije
	746
	747	jj_begin_New(0)=1
	748	jj_End_New(0)=jj_Nb_New(0)
	749	do i=1,MPI_Size-1
	750	jj_begin_New(i)=jj_end_New(i-1)+1
	751	jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
	752	enddo
	753
	754	jjb=max(jj_begin,jj_begin_new(MPI_Rank))
	755	jje=min(jj_end,jj_end_new(MPI_Rank))
	756	if (ij==ip1jm) jje=min(jje,jjm)
	757
	758	if (jje >= jjb) then
	759	ijb=(jjb-1)*iip1+1
	760	ije=jje*iip1
[985]	761
	762	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	763	do l=1,ll
	764	FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
	765	enddo
	766	!$OMP ENDDO NOWAIT
[630]	767	endif
	768
[985]	769
[630]	770	end subroutine CopyField
	771
	772	subroutine CopyFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down)
	773
	774	implicit none
[792]	775	#include "dimensions.h"
	776	#include "paramet.h"
[630]	777
	778	INTEGER :: ij,ll,Up,Down
	779	REAL, dimension(ij,ll) :: FieldS
	780	REAL, dimension(ij,ll) :: FieldR
	781	integer,dimension(0:MPI_Size-1) :: jj_Nb_New
	782	integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
	783
[985]	784	integer ::i,jje,jjb,ijb,ije,l
[630]	785
	786
	787	jj_begin_New(0)=1
	788	jj_End_New(0)=jj_Nb_New(0)
	789	do i=1,MPI_Size-1
	790	jj_begin_New(i)=jj_end_New(i-1)+1
	791	jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
	792	enddo
	793
	794
	795	jjb=max(jj_begin,jj_begin_new(MPI_Rank)-Up)
	796	jje=min(jj_end,jj_end_new(MPI_Rank)+Down)
	797	if (ij==ip1jm) jje=min(jje,jjm)
	798
	799
	800	if (jje >= jjb) then
	801	ijb=(jjb-1)*iip1+1
	802	ije=jje*iip1
[985]	803
	804	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	805	do l=1,ll
	806	FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
	807	enddo
	808	!$OMP ENDDO NOWAIT
	809
[630]	810	endif
	811	end subroutine CopyFieldHallo
	812
	813	end module mod_Hallo
	814

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

Download in other formats:

Original Format