You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
289 lines
9.2 KiB
Fortran
289 lines
9.2 KiB
Fortran
program df_comm
|
|
use f90sparse
|
|
use mat_dist
|
|
use read_mat
|
|
use partgraph
|
|
use comminfo
|
|
implicit none
|
|
|
|
! input parameters
|
|
character(len=20) :: cmethd, prec
|
|
character(len=40) :: mtrx_file
|
|
character(len=20) :: mtrx_name, out_file, tmpstr
|
|
character(len=200) :: charbuf
|
|
integer :: inparms(20)
|
|
double precision ddot
|
|
external ddot
|
|
|
|
|
|
integer, parameter :: izero=0, ione=1
|
|
character, parameter :: order='r'
|
|
real(kind(1.d0)), pointer, save :: b_col(:), x_col(:), r_col(:), &
|
|
& b_col_glob(:), x_col_glob(:), r_col_glob(:), b_glob(:,:), &
|
|
&z(:), q(:),z1(:), xm(:,:), ym(:,:)
|
|
integer :: iargc, check_descr, convert_descr
|
|
real(kind(1.d0)), parameter :: dzero = 0.d0, one = 1.d0
|
|
real(kind(1.d0)) :: mpi_wtime, t1, t2, t3, tprec, tslv, ttot, &
|
|
&r_amax, b_amax,bb(1,1), lambda,scale,resmx,resmxp, omega
|
|
integer :: nrhs, nrow, nx1, nx2, n_row, n_col, dim,iread,ip,io,no,nmats,&
|
|
& imat,irenum, igsmth, matop
|
|
logical :: amroot
|
|
external iargc, mpi_wtime
|
|
integer bsze,overlap, nn, nprecs, novrs
|
|
common/part/bsze,overlap
|
|
integer, pointer :: work(:), precs(:), ovrs(:), comm_info(:,:)
|
|
! sparse matrices
|
|
type(d_spmat) :: a, aux_a, h
|
|
type(d_prec) :: pre
|
|
!!$ type(d_precn) :: aprc
|
|
! dense matrices
|
|
real(kind(1.d0)), pointer :: aux_b(:,:) , aux1(:), aux2(:), vdiag(:), &
|
|
& aux_g(:,:), aux_x(:,:), d(:)
|
|
|
|
! communications data structure
|
|
type(desc_type) :: desc_a, desc_a_out
|
|
|
|
! blacs parameters
|
|
integer :: nprow, npcol, ictxt, iam, np, myprow, mypcol
|
|
|
|
! solver paramters
|
|
integer :: iter, itmax, ierr, itrace, ircode, ipart,&
|
|
& methd, istopc, irst
|
|
integer, pointer :: ierrv(:), ivg(:)
|
|
character(len=5) :: afmt
|
|
real(kind(1.d0)) :: err, eps
|
|
integer iparm(20)
|
|
real(kind(1.d0)) rparm(20)
|
|
|
|
! other variables
|
|
integer :: i,info,j, ntryslv
|
|
integer :: internal, m,ii,nnzero, itryslv
|
|
integer, parameter :: ncsw=4, ntcs=4
|
|
real(kind(1.d0)), pointer :: tsthal(:,:)
|
|
real(kind(1.d0)) :: tswmpi(ntcs,ncsw),tswsyn(ntcs,ncsw),tswsdrv(ntcs,ncsw)
|
|
! common area
|
|
integer m_problem, nproc, nc
|
|
|
|
|
|
allocate(ierrv(6))
|
|
! initialize blacs
|
|
call blacs_pinfo(iam, np)
|
|
call blacs_get(izero, izero, ictxt)
|
|
|
|
! rectangular Grid, Np x 1
|
|
|
|
call blacs_gridinit(ictxt, order, np, ione)
|
|
call blacs_gridinfo(ictxt, nprow, npcol, myprow, mypcol)
|
|
amroot = (myprow==0).and.(mypcol==0)
|
|
afmt='CSR'
|
|
!
|
|
! Get parameters from file
|
|
!
|
|
if (amroot) then
|
|
read(*,*) ipart
|
|
call igebs2d(ictxt,'all',' ',1,1,ipart,1)
|
|
read(*,*) nmats
|
|
call igebs2d(ictxt,'all',' ',1,1,nmats,1)
|
|
|
|
|
|
else
|
|
call igebr2d(ictxt,'all',' ',1,1,ipart,1,0,0)
|
|
call igebr2d(ictxt,'all',' ',1,1,nmats,1,0,0)
|
|
endif
|
|
|
|
do imat=1,nmats
|
|
|
|
if (amroot) then
|
|
!!$ read(*,*) mtrx_file,rhs_file
|
|
read(*,'(a)') charbuf
|
|
charbuf=adjustl(charbuf)
|
|
i=index(charbuf," ")
|
|
mtrx_file=charbuf(1:i-1)
|
|
i=index(mtrx_file,"/",back=.true.)
|
|
mtrx_name=trim(mtrx_file(i+1:))
|
|
write(0,*) 'Read mtx rhs : "', mtrx_file
|
|
i=index(mtrx_file,'.mtx')
|
|
write(tmpstr,'("_",i1,"_",i2.2,".out")')ipart,np
|
|
out_file=mtrx_file(1:i-1)//trim(tmpstr)
|
|
write(0,*)' out file is ', out_file
|
|
open(2,file=out_file,action='write')
|
|
write(2,'("Matrix: ",a20)')mtrx_name
|
|
write(2,'("Number of processes: ",i2)')np
|
|
write(2,'("Partitioning: ",i1)')ipart
|
|
write(2,'(" ")')
|
|
write(2,'(" ")')
|
|
close(2)
|
|
endif
|
|
|
|
call blacs_barrier(ictxt,'A')
|
|
t1 = mpi_wtime()
|
|
! read the input matrix to be processed and (possibly) the RHS
|
|
nrhs = 1
|
|
nproc = nprow
|
|
|
|
if (amroot) then
|
|
nullify(aux_b)
|
|
call readmat(mtrx_file, aux_a, ictxt)
|
|
|
|
m_problem = aux_a%m
|
|
call igebs2d(ictxt,'a',' ',1,1,m_problem,1)
|
|
|
|
allocate(aux_b(m_problem,1), stat=ircode)
|
|
if (ircode /= 0) then
|
|
write(0,*) 'memory allocation failure in df_sample'
|
|
call blacs_abort(ictxt,-1)
|
|
stop
|
|
endif
|
|
b_col_glob =>aux_b(:,1)
|
|
do i=1, m_problem
|
|
b_col_glob(i) = 1.d0
|
|
enddo
|
|
|
|
call dgebs2d(ictxt,'a',' ',m_problem,1,b_col_glob,m_problem)
|
|
else
|
|
call igebr2d(ictxt,'a',' ',1,1,m_problem,1,0,0)
|
|
|
|
allocate(aux_b(m_problem,1), stat=ircode)
|
|
if (ircode /= 0) then
|
|
write(0,*) 'Memory allocation failure in DF_SAMPLE'
|
|
call blacs_abort(ictxt,-1)
|
|
stop
|
|
endif
|
|
b_col_glob =>aux_b(:,1)
|
|
call dgebr2d(ictxt,'A',' ',m_problem,1,b_col_glob,m_problem,0,0)
|
|
end if
|
|
|
|
|
|
! switch over different partition types
|
|
if (ipart.eq.0) then
|
|
call blacs_barrier(ictxt,'A')
|
|
write(0,*) 'Partition type: BLOCK'
|
|
allocate(ivg(m_problem))
|
|
call bld_partblock(m_problem,np,ivg)
|
|
call matdist(aux_a, a, ivg, ictxt, &
|
|
& desc_a,b_col_glob,b_col,fmt=afmt)
|
|
else if (ipart.eq.1) then
|
|
call blacs_barrier(ictxt,'A')
|
|
write(0,*) 'partition type: BLK2'
|
|
allocate(ivg(m_problem))
|
|
call bld_partblk2(m_problem,np,ivg)
|
|
call matdist(aux_a, a, ivg, ictxt, &
|
|
& desc_a,b_col_glob,b_col,fmt=afmt)
|
|
else if (ipart.eq.2) then
|
|
write(0,*) 'partition type: GRAPH'
|
|
if (amroot) then
|
|
call build_grppart(aux_a%m,aux_a%fida,aux_a%ia1,aux_a%ia2,np)
|
|
endif
|
|
call distr_grppart(0,0,ictxt)
|
|
if (.false.) then
|
|
call matdist(aux_a, a, part_graph, ictxt, &
|
|
& desc_a,b_col_glob,b_col,fmt=afmt)
|
|
else
|
|
call getv_grppart(ivg)
|
|
call matdist(aux_a, a, ivg, ictxt, &
|
|
& desc_a,b_col_glob,b_col,fmt=afmt)
|
|
endif
|
|
end if
|
|
|
|
if(amroot) then
|
|
allocate(comm_info(np,np))
|
|
comm_info(:,:)=0
|
|
end if
|
|
call blacs_barrier(ictxt,'all')
|
|
write(0,'("Getting communication info")')
|
|
call get_comminfo(ictxt,desc_a,comm_info)
|
|
if(amroot) then
|
|
open(2,file=out_file,action='write',position='append')
|
|
write(2,'("Exchange table:")')
|
|
do i=1,np
|
|
write(2,*)'Row ',i,' : ',comm_info(i,:)
|
|
end do
|
|
write(2,'(" ")')
|
|
write(2,'(" ")')
|
|
close(2)
|
|
end if
|
|
|
|
|
|
n_row = desc_a%matrix_data(n_row_)
|
|
n_col = desc_a%matrix_data(n_col_)
|
|
write(0,'("Allocating vectors")')
|
|
call f90_psdsall(m_problem,ncsw,tsthal,ierrv,desc_a)
|
|
forall (i=1:n_row)
|
|
forall (j=1:ncsw)
|
|
tsthal(i,j) = j * desc_a%loc_to_glob(i)
|
|
end forall
|
|
end forall
|
|
tsthal(n_row+1:,:) = -1.d0
|
|
|
|
tswmpi = 1.d200
|
|
tswsyn = 1.d200
|
|
tswsdrv = 1.d200
|
|
|
|
write(0,'("Cycling")')
|
|
do nc=1, ncsw
|
|
do i=1, ntcs
|
|
tsthal(n_row+1:,:) = -1.d0
|
|
t1=mpi_wtime()
|
|
call f90_pshalo(tsthal(:,1:nc),desc_a,trans='T',mode=SWAP_MPI)
|
|
t2=mpi_wtime()-t1
|
|
call dgamx2d(ictxt,'a',' ',ione, ione,t2,ione,t1,t1,-1,-1,-1)
|
|
tswmpi(i,nc) = t2
|
|
!! Add correctness check
|
|
tsthal(n_row+1:,:) = -1.d0
|
|
t1=mpi_wtime()
|
|
call f90_pshalo(tsthal(:,1:nc),desc_a,trans='T',mode=SWAP_SYNC)
|
|
t2=mpi_wtime()-t1
|
|
call dgamx2d(ictxt,'a',' ',ione, ione,t2,ione,t1,t1,-1,-1,-1)
|
|
tswsyn(i,nc) = t2
|
|
!! Add correctness check
|
|
tsthal(n_row+1:,:) = -1.d0
|
|
t1=mpi_wtime()
|
|
call f90_pshalo(tsthal(:,1:nc),desc_a,trans='T',mode=IOR(SWAP_SEND,SWAP_RECV))
|
|
t2=mpi_wtime()-t1
|
|
call dgamx2d(ictxt,'a',' ',ione, ione,t2,ione,t1,t1,-1,-1,-1)
|
|
tswsdrv(i,nc) = t2
|
|
!! Add correctness check
|
|
end do
|
|
end do
|
|
|
|
if (amroot) then
|
|
open(2,file=out_file,action='write',position='append')
|
|
do nc=1, ncsw
|
|
write(*,'(a18,1x,a4,1(1x,i2),1x,i5,5(1x,g9.4))') mtrx_name,'MPI',&
|
|
& nprow,nc,minval(tswmpi(:,nc)),maxval(tswmpi(:,nc)),&
|
|
& sum(tswmpi(:,nc))/ntcs
|
|
write(2,'(a18,1x,a4,1(1x,i2),1x,i5,5(1x,g9.4))') mtrx_name,'MPI',&
|
|
& nprow,nc,minval(tswmpi(:,nc)),maxval(tswmpi(:,nc)),&
|
|
& sum(tswmpi(:,nc))/ntcs
|
|
write(*,'(a18,1x,a4,1(1x,i2),1x,i5,5(1x,g9.4))') mtrx_name,'SYNC',&
|
|
& nprow,nc,minval(tswsyn(:,nc)),maxval(tswsyn(:,nc)),&
|
|
& sum(tswsyn(:,nc))/ntcs
|
|
write(2,'(a18,1x,a4,1(1x,i2),1x,i5,5(1x,g9.4))') mtrx_name,'SYNC',&
|
|
& nprow,nc,minval(tswsyn(:,nc)),maxval(tswsyn(:,nc)),&
|
|
& sum(tswsyn(:,nc))/ntcs
|
|
write(*,'(a18,1x,a4,1(1x,i2),1x,i5,5(1x,g9.4))') mtrx_name,'SDRV',&
|
|
& nprow,nc,minval(tswsdrv(:,nc)),maxval(tswsdrv(:,nc)),&
|
|
& sum(tswsdrv(:,nc))/ntcs
|
|
write(2,'(a18,1x,a4,1(1x,i2),1x,i5,5(1x,g9.4))') mtrx_name,'SDRV',&
|
|
& nprow,nc,minval(tswsdrv(:,nc)),maxval(tswsdrv(:,nc)),&
|
|
& sum(tswsdrv(:,nc))/ntcs
|
|
end do
|
|
close(2)
|
|
end if
|
|
call f90_psdsfree(tsthal, desc_a)
|
|
call f90_psdsfree(b_col, desc_a)
|
|
call f90_psspfree(a, desc_a)
|
|
call f90_psdscfree(desc_a,info)
|
|
|
|
end do
|
|
deallocate(ovrs,precs,ierrv, stat=info)
|
|
write(0,*) 'Info from deallocate ',info
|
|
call blacs_gridexit(ictxt)
|
|
call blacs_exit(0)
|
|
|
|
end program df_comm
|
|
|
|
|
|
|
|
|