Skip to content

Commit

Permalink
Merge pull request #52 from lanl/reshuffle
Browse files Browse the repository at this point in the history 
Reshuffle
  • Loading branch information
@nicolasbock
nicolasbock authored Apr 17, 2017
2 parents f985ef6 + af35426 commit de6b9c3
Showing 1 changed file with 100 additions and 10 deletions.
110 changes: 100 additions & 10 deletions examples/gpmdcov/gpmdcov.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -75,12 +75,13 @@ program gpmd
character(2) :: auxchar
integer :: mdstep, Nr_SCF_It, i, icount, ierr
integer :: j, nel, norb, pp(100), nnodes, iii
integer :: nparts, niter=500, npat, ipt
integer :: nparts, niter=500, npat, ipt, iptt
integer :: ii, jj, iscf, norb_core
integer :: mdim
integer, allocatable :: hindex(:,:), hnode(:), vectorint(:)
integer, allocatable :: xadj(:), adjncy(:), CH_count(:)
integer, allocatable :: part(:), core_count(:), Halo_count(:,:)
integer, allocatable :: PartsInRankI(:), reshuffle(:,:)
real(dp) :: C0, C1, C2, C3
real(dp) :: C4, C5, ECoul, EKIN
real(dp) :: EPOT, ERep, Energy, Etot
Expand All @@ -90,7 +91,7 @@ program gpmd
real(dp) :: dx, egap, ehomo, elumo
real(dp) :: kappa, scferror, traceMult, vv(100)
real(dp) :: sumCubes, maxCH, Ef, smooth_maxCH, pnorm=6
real(dp) :: dvdw, d, mls_i, Efstep
real(dp) :: dvdw, d, mls_i, Efstep, costperrank, costperrankmax, costperrankmin
real(dp), allocatable :: FPUL(:,:), FSCOUL(:,:), FTOT(:,:), PairForces(:,:)
real(dp), allocatable :: SKForce(:,:), VX(:), VY(:), VZ(:), collectedforce(:,:)
real(dp), allocatable :: charges_old(:), coul_forces(:,:), coul_forces_k(:,:), coul_forces_r(:,:)
Expand Down Expand Up @@ -132,7 +133,6 @@ program gpmd
integer :: vsize(2)
integer :: nparts_cov, myRank


!!!!!!!!!!!!!!!!!!!!!!!!
!> Main program driver
!!!!!!!!!!!!!!!!!!!!!!!!
Expand Down Expand Up @@ -312,10 +312,14 @@ subroutine gpmd_Part
if(lt%verbose >= 1 .and. myRank == 1) write(*,*) "Time for prg_get_covgraph_h "//to_string(mls()-mls_ii)//" ms"

#ifdef DO_MPI
do ipt = gpat%localPartMin(myRank), gpat%localPartMax(myRank)
!do ipt= gpat%localPartMin(myRank), gpat%localPartMax(myRank)
do iptt=1,PartsInRankI(myRank)
ipt= reshuffle(iptt,myRank)
write(*,*)"rank=",myRank,ipt
#else
do ipt = 1,gpat%TotalParts
#endif

call prg_collect_graph_p(syprt(ipt)%estr%orho,gpat%sgraph(ipt)%llsize,sy%nats,syprt(ipt)%estr%hindex,&
gpat%sgraph(ipt)%core_halo_index,graph_p,gsp2%gthreshold,gsp2%mdim,lt%verbose)

Expand All @@ -324,6 +328,7 @@ subroutine gpmd_Part

mls_i = mls()


#ifdef DO_MPI
if (getNRanks() > 1) then
call prg_sumIntReduceN(graph_p, mdim*sy%nats)
Expand Down Expand Up @@ -389,8 +394,13 @@ subroutine gpmd_Part
gpat%sgraph(i)%lsize = vsize(1)
gpat%sgraph(i)%llsize = vsize(2)
enddo

if(lt%verbose >= 1 .and. myRank == 1)write(*,*)"Time for bml_matrix2submatrix_index "//to_string(mls()-mls_ii)//" ms"


call gpmd_reshuffle()


if(allocated(syprt))deallocate(syprt)
allocate(syprt(gpat%TotalParts))

Expand All @@ -401,11 +411,15 @@ subroutine gpmd_Part

if(lt%verbose >= 1 .and. myRank == 1)call prg_get_mem("gpmdcov","Before prg_get_subsystem")
mls_ii = mls()

#ifdef DO_MPI
do ipt= gpat%localPartMin(myRank), gpat%localPartMax(myRank)
!do ipt= gpat%localPartMin(myRank), gpat%localPartMax(myRank)
do iptt=1,PartsInRankI(myRank)
ipt= reshuffle(iptt,myRank)
#else
do ipt = 1,gpat%TotalParts
#endif

call prg_get_subsystem(sy,gpat%sgraph(ipt)%lsize,gpat%sgraph(ipt)%core_halo_index,syprt(ipt))
enddo
if(lt%verbose >= 1 .and. myRank == 1)write(*,*)"Time for prg_get_subsystem "//to_string(mls()-mls_ii)//" ms"
Expand All @@ -427,7 +441,9 @@ subroutine gpmd_InitParts

if(lt%verbose >= 1 .and. myRank == 1)call prg_get_mem("gpmdcov","Before gpmd_InitParts")
#ifdef DO_MPI
do ipt= gpat%localPartMin(myRank), gpat%localPartMax(myRank)
!do ipt= gpat%localPartMin(myRank), gpat%localPartMax(myRank)
do iptt=1,PartsInRankI(myRank)
ipt= reshuffle(iptt,myRank)
#else
do ipt = 1,gpat%TotalParts
#endif
Expand Down Expand Up @@ -505,7 +521,9 @@ subroutine gpmd_FirstCharges()
sy%net_charge = 0.0_dp

#ifdef DO_MPI
do ipt= gpat%localPartMin(myRank), gpat%localPartMax(myRank)
!do ipt= gpat%localPartMin(myRank), gpat%localPartMax(myRank)
do iptt=1,PartsInRankI(myRank)
ipt= reshuffle(iptt,myRank)
#else
do ipt = 1,gpat%TotalParts
#endif
Expand Down Expand Up @@ -647,7 +665,9 @@ subroutine gpmd_DM_Min(Nr_SCF,nguess,mix)
auxcharge = 0.0_dp
mls_i = mls()
#ifdef DO_MPI
do ipt= gpat%localPartMin(myRank), gpat%localPartMax(myRank)
!do ipt= gpat%localPartMin(myRank), gpat%localPartMax(myRank)
do iptt=1,PartsInRankI(myRank)
ipt= reshuffle(iptt,myRank)
#else
do ipt = 1,gpat%TotalParts
#endif
Expand Down Expand Up @@ -832,7 +852,9 @@ subroutine gpmd_EnergAndForces(charges)
!> Loop over all the parts
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
#ifdef DO_MPI
do ipt= gpat%localPartMin(myRank), gpat%localPartMax(myRank)
!do ipt= gpat%localPartMin(myRank), gpat%localPartMax(myRank)
do iptt=1,PartsInRankI(myRank)
ipt= reshuffle(iptt,myRank)
#else
do ipt = 1,gpat%TotalParts
#endif
Expand Down Expand Up @@ -1392,7 +1414,9 @@ subroutine gpmd_writeout()
sy%resindex(sy%nats)=-100

#ifdef DO_MPI
do ipt= gpat%localPartMin(myRank), gpat%localPartMax(myRank)
!do ipt= gpat%localPartMin(myRank), gpat%localPartMax(myRank)
do iptt=1,PartsInRankI(myRank)
ipt= reshuffle(iptt,myRank)
#else
do ipt = 1,gpat%TotalParts
#endif
Expand Down Expand Up @@ -1548,4 +1572,70 @@ subroutine gpmd_restart()

end subroutine gpmd_restart

!> Reshuffle the parts
!! PartsInRankI(getNRanks()) stores the number of partitions assigned to rank i
!! reshuffle(j,i) assigns partition reshuffle(j,i) to rank i for j=1,PartsInRankI(getNRanks())
!!
subroutine gpmd_reshuffle()
integer :: maxnparts, np

maxnparts = 0
do i=1,getNRanks()
np = gpat%localPartMax(i)-gpat%localPartMin(i)+1
maxnparts = max(maxnparts,np)
enddo

if(allocated(reshuffle))then
deallocate(reshuffle)
deallocate(PartsInRankI)
endif

allocate(reshuffle(maxnparts,getNRanks()))
allocate(PartsInRankI(getNRanks()))

reshuffle = 0
icount = 0
PartsInRankI = 0

do j=1,maxnparts
do i=1,getNRanks()
np = gpat%localPartMax(i)-gpat%localPartMin(i)+1
if(np > PartsInRankI(i))then
icount = icount + 1
PartsInRankI(i) = PartsInRankI(i) + 1
reshuffle(PartsInRankI(i),i) = icount
if(icount == nparts) exit
endif
enddo
if(icount == nparts) exit
do i=getNRanks(),1,-1
np = gpat%localPartMax(i)-gpat%localPartMin(i)+1
if(np > PartsInRankI(i))then
icount = icount + 1
PartsInRankI(i) = PartsInRankI(i) + 1
reshuffle(PartsInRankI(i),i) = icount
if(icount == nparts) exit
endif
enddo
if(icount == nparts) exit
enddo

costperrankmax = 0.0d0
costperrankmin = 1.0d+10

do i=1,getNRanks()
costperrank = 0.0d0
do j=1,maxnparts
if(reshuffle(j,i)>0)write(*,*)i,j,reshuffle(j,i),gpat%sgraph(reshuffle(j,i))%lsize
costperrank = costperrank + real((gpat%sgraph(reshuffle(j,i))%lsize)**3)
enddo
write(*,*)"Cost per rank =", costperrank
costperrankmax = max(costperrank,costperrankmax)
costperrankmin = min(costperrank,costperrankmin)
enddo
write(*,*)"The following is a measure of the asymmetry"
write(*,*)"DeltaCostPerrank/CostPerrankMin =", (costperrankmax - costperrankmin)/costperrankmin

end subroutine gpmd_reshuffle

end program gpmd

0 comments on commit de6b9c3

Please sign in to comment.