Index: LMDZ4/trunk/libf/dyn3d/parallel.F90 =================================================================== --- LMDZ4/trunk/libf/dyn3d/parallel.F90 (revision 643) +++ LMDZ4/trunk/libf/dyn3d/parallel.F90 (revision 643) @@ -0,0 +1,463 @@ + module parallel + + integer, save :: mpi_size + integer, save :: mpi_rank + integer, save :: jj_begin + integer, save :: jj_end + integer, save :: jj_nb + integer, save :: ij_begin + integer, save :: ij_end + logical, save :: pole_nord + logical, save :: pole_sud + + integer, allocatable, save, dimension(:) :: jj_begin_para + integer, allocatable, save, dimension(:) :: jj_end_para + integer, allocatable, save, dimension(:) :: jj_nb_para + + contains + + subroutine init_parallel + +#ifdef CPP_PARALLEL + + USE vampir + implicit none + + integer :: ierr + integer :: i,j + integer :: type_size + integer, dimension(3) :: blocklen,type + + + include 'mpif.h' +#include "dimensions90.h" +#include "paramet90.h" + + call MPI_INIT(ierr) + call InitVampir + call MPI_COMM_SIZE(MPI_COMM_WORLD,mpi_size,ierr) + call MPI_COMM_RANK(MPI_COMM_WORLD,mpi_rank,ierr) + + + allocate(jj_begin_para(0:mpi_size-1)) + allocate(jj_end_para(0:mpi_size-1)) + allocate(jj_nb_para(0:mpi_size-1)) + + do i=0,mpi_size-1 + jj_nb_para(i)=(jjm+1)/mpi_size + if ( i < MOD((jjm+1),mpi_size) ) jj_nb_para(i)=jj_nb_para(i)+1 + + if (jj_nb_para(i) <= 2 ) then + + print *,"Arret : le nombre de bande de lattitude par process est trop faible (<2)." + print *," ---> diminuez le nombre de CPU ou augmentez la taille en lattitude" + + call MPI_ABORT(MPI_COMM_WORLD,-1, ierr) + + endif + + enddo + +! jj_nb_para(0)=11 +! jj_nb_para(1)=25 +! jj_nb_para(2)=25 +! jj_nb_para(3)=12 + + j=1 + + do i=0,mpi_size-1 + + jj_begin_para(i)=j + jj_end_para(i)=j+jj_Nb_para(i)-1 + j=j+jj_Nb_para(i) + + enddo + + jj_begin = jj_begin_para(mpi_rank) + jj_end = jj_end_para(mpi_rank) + jj_nb = jj_nb_para(mpi_rank) + + ij_begin=(jj_begin-1)*iip1+1 + ij_end=jj_end*iip1 + + if (mpi_rank.eq.0) then + pole_nord=.TRUE. + else + pole_nord=.FALSE. + endif + + if (mpi_rank.eq.mpi_size-1) then + pole_sud=.TRUE. + else + pole_sud=.FALSE. + endif + + print *,"jj_begin",jj_begin + print *,"jj_end",jj_end + print *,"ij_begin",ij_begin + print *,"ij_end",ij_end + +#endif + + end subroutine init_parallel + + + subroutine SetDistrib(jj_Nb_New) + +#ifdef CPP_PARALLEL + + implicit none + +#include "dimensions90.h" +#include "paramet90.h" + + INTEGER,dimension(0:MPI_Size-1) :: jj_Nb_New + INTEGER :: i + + jj_Nb_Para=jj_Nb_New + + jj_begin_para(0)=1 + jj_end_para(0)=jj_Nb_Para(0) + + do i=1,mpi_size-1 + + jj_begin_para(i)=jj_end_para(i-1)+1 + jj_end_para(i)=jj_begin_para(i)+jj_Nb_para(i)-1 + + enddo + + jj_begin = jj_begin_para(mpi_rank) + jj_end = jj_end_para(mpi_rank) + jj_nb = jj_nb_para(mpi_rank) + + ij_begin=(jj_begin-1)*iip1+1 + ij_end=jj_end*iip1 + +#endif + + end subroutine SetDistrib + + subroutine Finalize_parallel + +#ifdef CPP_PARALLEL + + implicit none + +#include "dimensions90.h" +#include "paramet90.h" + integer :: ierr + integer :: i + include 'mpif.h' + + deallocate(jj_begin_para) + deallocate(jj_end_para) + deallocate(jj_nb_para) + + call MPI_FINALIZE(ierr) + +#endif + + end subroutine Finalize_parallel + + subroutine Pack_Data(Field,ij,ll,row,Buffer) + implicit none + +#include "dimensions90.h" +#include "paramet90.h" + + integer, intent(in) :: ij,ll,row + real,dimension(ij,ll),intent(in) ::Field + real,dimension(ll*iip1*row), intent(out) :: Buffer + + integer :: Pos + integer :: i,l + + Pos=0 + do l=1,ll + do i=1,row*iip1 + Pos=Pos+1 + Buffer(Pos)=Field(i,l) + enddo + enddo + + end subroutine Pack_data + + subroutine Unpack_Data(Field,ij,ll,row,Buffer) + implicit none + +#include "dimensions90.h" +#include "paramet90.h" + + integer, intent(in) :: ij,ll,row + real,dimension(ij,ll),intent(out) ::Field + real,dimension(ll*iip1*row), intent(in) :: Buffer + + integer :: Pos + integer :: i,l + + Pos=0 + + do l=1,ll + do i=1,row*iip1 + Pos=Pos+1 + Field(i,l)=Buffer(Pos) + enddo + enddo + + end subroutine UnPack_data + + subroutine exchange_hallo(Field,ij,ll,up,down) + +#ifdef CPP_PARALLEL + + USE Vampir + implicit none +#include "dimensions90.h" +#include "paramet90.h" + include 'mpif.h' + + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: Field + INTEGER :: up,down + + INTEGER :: ierr + LOGICAL :: SendUp,SendDown + LOGICAL :: RecvUp,RecvDown + INTEGER, DIMENSION(4) :: Request + INTEGER, DIMENSION(MPI_STATUS_SIZE,4) :: Status + INTEGER :: NbRequest + REAL, dimension(:),allocatable :: Buffer_Send_up,Buffer_Send_down + REAL, dimension(:),allocatable :: Buffer_Recv_up,Buffer_Recv_down + INTEGER :: Buffer_size + + call MPI_Barrier(MPI_COMM_WORLD,ierr) + call VTb(VThallo) + + SendUp=.TRUE. + SendDown=.TRUE. + RecvUp=.TRUE. + RecvDown=.TRUE. + + IF (pole_nord) THEN + SendUp=.FALSE. + RecvUp=.FALSE. + ENDIF + + IF (pole_sud) THEN + SendDown=.FALSE. + RecvDown=.FALSE. + ENDIF + + if (up.eq.0) then + SendDown=.FALSE. + RecvUp=.FALSE. + endif + + if (down.eq.0) then + SendUp=.FALSE. + RecvDown=.FALSE. + endif + + NbRequest=0 + + IF (SendUp) THEN + NbRequest=NbRequest+1 + buffer_size=down*iip1*ll + allocate(Buffer_Send_up(Buffer_size)) + call PACK_Data(Field(ij_begin,1),ij,ll,down,Buffer_Send_up) + call MPI_ISSEND(Buffer_send_up,Buffer_Size,MPI_REAL8,MPI_Rank-1,1, & + MPI_COMM_WORLD,Request(NbRequest),ierr) + ENDIF + + IF (SendDown) THEN + NbRequest=NbRequest+1 + + buffer_size=up*iip1*ll + allocate(Buffer_Send_down(Buffer_size)) + call PACK_Data(Field(ij_end+1-up*iip1,1),ij,ll,up,Buffer_send_down) + + call MPI_ISSEND(Buffer_send_down,Buffer_Size,MPI_REAL8,MPI_Rank+1,1, & + MPI_COMM_WORLD,Request(NbRequest),ierr) + ENDIF + + + IF (RecvUp) THEN + NbRequest=NbRequest+1 + buffer_size=up*iip1*ll + allocate(Buffer_recv_up(Buffer_size)) + + call MPI_IRECV(Buffer_recv_up,Buffer_size,MPI_REAL8,MPI_Rank-1,1, & + MPI_COMM_WORLD,Request(NbRequest),ierr) + + + ENDIF + + IF (RecvDown) THEN + NbRequest=NbRequest+1 + buffer_size=down*iip1*ll + allocate(Buffer_recv_down(Buffer_size)) + + call MPI_IRECV(Buffer_recv_down,Buffer_size,MPI_REAL8,MPI_Rank+1,1, & + MPI_COMM_WORLD,Request(NbRequest),ierr) + + + ENDIF + + if (NbRequest > 0) call MPI_WAITALL(NbRequest,Request,Status,ierr) + IF (RecvUp) call Unpack_Data(Field(ij_begin-up*iip1,1),ij,ll,up,Buffer_Recv_up) + IF (RecvDown) call Unpack_Data(Field(ij_end+1,1),ij,ll,down,Buffer_Recv_down) + + call VTe(VThallo) + call MPI_Barrier(MPI_COMM_WORLD,ierr) + RETURN + +#endif + + end subroutine exchange_Hallo + + + subroutine Gather_Field(Field,ij,ll,rank) + + + + implicit none +#include "dimensions90.h" +#include "paramet90.h" + +#ifdef CPP_PARALLEL + include 'mpif.h' +#endif + + INTEGER :: ij,ll,rank + REAL, dimension(ij,ll) :: Field +#ifdef CPP_PARALLEL + REAL, dimension(:),allocatable :: Buffer_send + REAL, dimension(:),allocatable :: Buffer_Recv + INTEGER, dimension(0:MPI_Size-1) :: Recv_count, displ + INTEGER :: ierr + INTEGER ::i + + if (ij==ip1jmp1) then + allocate(Buffer_send(iip1*ll*(jj_end-jj_begin+1))) + call Pack_Data(Field(ij_begin,1),ij,ll,jj_end-jj_begin+1,Buffer_send) + else if (ij==ip1jm) then + allocate(Buffer_send(iip1*ll*(min(jj_end,jjm)-jj_begin+1))) + call Pack_Data(Field(ij_begin,1),ij,ll,min(jj_end,jjm)-jj_begin+1,Buffer_send) + else + print *,ij + stop 'erreur dans Gather_Field' + endif + + if (MPI_Rank==rank) then + allocate(Buffer_Recv(ij*ll)) + do i=0,MPI_Size-1 + + if (ij==ip1jmp1) then + Recv_count(i)=(jj_end_para(i)-jj_begin_para(i)+1)*ll*iip1 + else if (ij==ip1jm) then + Recv_count(i)=(min(jj_end_para(i),jjm)-jj_begin_para(i)+1)*ll*iip1 + else + stop 'erreur dans Gather_Field' + endif + + if (i==0) then + displ(i)=0 + else + displ(i)=displ(i-1)+Recv_count(i-1) + endif + + enddo + + endif + + call MPI_GATHERV(Buffer_send,(min(ij_end,ij)-ij_begin+1)*ll,MPI_REAL8, & + Buffer_Recv,Recv_count,displ,MPI_REAL8,rank,MPI_COMM_WORLD,ierr) + + if (MPI_Rank==rank) then + + if (ij==ip1jmp1) then + do i=0,MPI_Size-1 + call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll, & + jj_end_para(i)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1)) + enddo + else if (ij==ip1jm) then + do i=0,MPI_Size-1 + call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll, & + min(jj_end_para(i),jjm)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1)) + enddo + endif + + endif + +#endif + + end subroutine Gather_Field + + subroutine AllGather_Field(Field,ij,ll) + +#ifdef CPP_PARALLEL + + implicit none +#include "dimensions90.h" +#include "paramet90.h" + include 'mpif.h' + + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: Field + INTEGER :: ierr + + call Gather_Field(Field,ij,ll,0) + call MPI_BCAST(Field,ij*ll,MPI_REAL8,0,MPI_COMM_WORLD) + +#endif + + end subroutine AllGather_Field + + subroutine Broadcast_Field(Field,ij,ll,rank) + +#ifdef CPP_PARALLEL + + implicit none +#include "dimensions90.h" +#include "paramet90.h" + include 'mpif.h' + + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: Field + INTEGER :: rank + INTEGER :: ierr + + call MPI_BCAST(Field,ij*ll,MPI_REAL8,rank,MPI_COMM_WORLD) + +#endif + + end subroutine Broadcast_Field + + + /* + Subroutine verif_hallo(Field,ij,ll,up,down) + +#ifdef CPP_PARALLEL + + implicit none +#include "dimensions90.h" +#include "paramet90.h" + include 'mpif.h' + + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: Field + INTEGER :: up,down + + REAL,dimension(ij,ll): NewField + + NewField=0 + + ijb=ij_begin + ije=ij_end + if (pole_nord) + NewField(ij_be + +#endif + +*/ + end module parallel