mirror of
https://code.it4i.cz/sccs/easyconfigs-it4i.git
synced 2025-04-18 20:50:49 +01:00
264 lines
8.4 KiB
Fortran
264 lines
8.4 KiB
Fortran
!TODO: dgelss->dgesv
|
|
!********************************************************************************
|
|
subroutine general_subspace_solver(ndim,x,b,maxit,tol,lfirst_trial,vecfile, &
|
|
errfile,errfunc,multiply,precond,lprint)
|
|
!********************************************************************************
|
|
! Solves Ax=b with subspace method
|
|
!********************************************************************************
|
|
use common_mod, only: dcore,scrfile1,imem,iout
|
|
implicit none
|
|
integer ndim,maxit
|
|
double precision x(ndim),b(ndim),tol
|
|
double precision bvec(ndim),bvec_tr(ndim)
|
|
character*16 vecfile,errfile
|
|
character*8 error_type
|
|
logical lfirst_trial,lprint
|
|
|
|
integer step
|
|
integer iproj_mat,iproj_mat2 ! projected matrices
|
|
integer ibvec,ibvec_tr ! basis vector
|
|
integer ibvec_full ! all basis vectors
|
|
integer ierrvec ! error vector
|
|
integer imem_old
|
|
double precision error,norm
|
|
|
|
integer dblalloc
|
|
double precision dnrm2
|
|
|
|
interface
|
|
subroutine multiply(ndim,x,y)
|
|
integer ndim
|
|
double precision x(ndim),y(ndim)
|
|
end subroutine
|
|
|
|
subroutine precond(ndim,x,y)
|
|
integer ndim
|
|
double precision x(ndim),y(ndim)
|
|
end subroutine
|
|
|
|
double precision function errfunc(ndim,x)
|
|
integer ndim
|
|
double precision x(ndim)
|
|
end function
|
|
end interface
|
|
|
|
imem_old=imem
|
|
iproj_mat =dblalloc(maxit**2)
|
|
iproj_mat2=dblalloc(maxit**2)
|
|
ibvec=dblalloc(ndim)
|
|
ibvec_tr=dblalloc(ndim)
|
|
ierrvec=dblalloc(ndim)
|
|
|
|
if(lfirst_trial) then
|
|
call dcopy(ndim,x,1,dcore(ibvec),1)
|
|
else
|
|
call dcopy(ndim,b,1,dcore(ibvec_tr),1)
|
|
call precond(ndim,dcore(ibvec_tr),dcore(ibvec))
|
|
endif
|
|
|
|
norm=dnrm2(ndim,dcore(ibvec),1)
|
|
call dscal(ndim,1.0d0/norm,dcore(ibvec),1)
|
|
|
|
step=0
|
|
x=0.0d0
|
|
error=errfunc(ndim,b)
|
|
|
|
if(lprint) write(iout,'(1X,A)') 'Iteration Residual'
|
|
if(lprint) write(iout,'(1X,I4,8X,ES10.3E2)') step,error
|
|
do while(error>tol .and. step<maxit)
|
|
step=step+1
|
|
call save_vec(dcore(ibvec),ndim,vecfile)
|
|
call multiply(ndim,dcore(ibvec),dcore(ibvec_tr))
|
|
call save_vec(dcore(ibvec_tr),ndim,errfile)
|
|
ibvec_full=dblalloc(ndim*step)
|
|
call calc_red_matrix(ndim,dcore(ibvec),dcore(ibvec_full),dcore(ibvec_full),&
|
|
dcore(iproj_mat),maxit,step,'disk ',vecfile,errfile)
|
|
call solve(ndim,maxit,step,dcore(ibvec_full),dcore(iproj_mat),&
|
|
dcore(iproj_mat2),b,x,dcore(ierrvec),vecfile,errfile,iout,'disk ')
|
|
error=errfunc(ndim,dcore(ierrvec))
|
|
if(error>tol) then
|
|
call dcopy(ndim,dcore(ierrvec),1,dcore(ibvec_tr),1)
|
|
call precond(ndim,dcore(ibvec_tr),dcore(ibvec))
|
|
call read_vecs(dcore(ibvec_full),ndim,step,vecfile,scrfile1)
|
|
call gsch(dcore(ibvec_full),dcore(ibvec),dcore(ibvec_tr),ndim,ndim,step)
|
|
endif
|
|
call dbldealloc(ibvec_full)
|
|
if(lprint) write(iout,'(1X,I4,8X,ES10.3E2)') step,error
|
|
enddo
|
|
|
|
call dbldealloc(imem_old)
|
|
|
|
end subroutine
|
|
|
|
!********************************************************************************
|
|
subroutine save_vec(bvec,nn,diisfile)
|
|
!********************************************************************************
|
|
! Write trial vector to the end of a file
|
|
!********************************************************************************
|
|
use common_mod, only: scrfile1
|
|
implicit none
|
|
integer nn
|
|
double precision bvec(nn)
|
|
character*16 diisfile
|
|
|
|
open(scrfile1,file=trim(diisfile),form='unformatted',access='append')
|
|
write(scrfile1) bvec
|
|
close(scrfile1)
|
|
|
|
end subroutine
|
|
|
|
!********************************************************************************
|
|
subroutine solve(nn,maxstep,step,full_bvec,proj_mat,proj_mat2,y,z, &
|
|
errvec,vecfile,errfile,iout,route)
|
|
!********************************************************************************
|
|
! Solves the equation A*z=y in the subspace spanned by the vectors in bvec
|
|
! bvec_tr=A*bvec
|
|
! proj_mat=bvec'*A*bvec
|
|
! errvec stores the residual in the full space
|
|
!********************************************************************************
|
|
use common_mod, only: dcore,imem,scrfile1
|
|
implicit none
|
|
integer nn,maxstep,step,iout
|
|
double precision bvec(nn),full_bvec(nn,step),y(nn),z(nn)
|
|
double precision proj_mat(maxstep,maxstep),proj_mat2(step*step)
|
|
double precision errvec(nn)
|
|
character*8 route
|
|
character*16 errfile,vecfile
|
|
|
|
integer dblalloc,info,ipiv,isol,i,rank,lwork
|
|
|
|
isol=dblalloc(step)
|
|
ipiv=dblalloc(step)
|
|
|
|
if(route=='disk ') call read_vecs(full_bvec,nn,step,vecfile,scrfile1)
|
|
call dlacpy('f',step,step,proj_mat,maxstep,proj_mat2,step)
|
|
call dgemv('t',nn,step,1.0d0,full_bvec,nn,y,1,0.0d0,dcore(isol),1)
|
|
call dgesv(step,1,proj_mat2,step,dcore(ipiv),dcore(isol),step,info)
|
|
if(info/=0) then
|
|
write(iout,'(A)') ' Error at solution of the linear equation'
|
|
write(iout,'(A,I3)') ' Error code: ',info
|
|
call mrccend(1)
|
|
endif
|
|
|
|
! calculating approximate solution
|
|
call dgemv('n',nn,step,1.0d0,full_bvec,nn,dcore(isol),1,0.0d0,z,1)
|
|
! calculating the residual
|
|
if(route=='disk ') call read_vecs(full_bvec,nn,step,errfile,scrfile1)
|
|
call dgemv('n',nn,step,1.0d0,full_bvec,nn,dcore(isol),1,0.0d0,errvec,1)
|
|
call daxpy(nn,-1.0d0,y,1,errvec,1)
|
|
|
|
call dbldealloc(isol)
|
|
|
|
end subroutine
|
|
|
|
!********************************************************************************
|
|
subroutine calc_red_matrix(nn,bvec,full_bvec,full_bvec_tr,proj_mat,maxstep,step,&
|
|
route,vecfile,errfile)
|
|
!********************************************************************************
|
|
! Build reduced matrix: redmat_ij=b_i'*A*b_j
|
|
!********************************************************************************
|
|
implicit none
|
|
integer nn,maxstep,step
|
|
double precision proj_mat(maxstep,maxstep)
|
|
double precision bvec(nn),full_bvec(nn,step),full_bvec_tr(nn,step)
|
|
character*8 route
|
|
character*16 vecfile,errfile
|
|
|
|
if(route=='memory ') then
|
|
call red_matrix(full_bvec,full_bvec_tr,proj_mat,maxstep,step,&
|
|
nn,step==1)
|
|
elseif(route=='disk ') then
|
|
call red_matrix_disk(bvec,full_bvec,proj_mat,maxstep,step,nn,&
|
|
step==1,vecfile,errfile)
|
|
else
|
|
write(*,'(1X,A)') 'Unknown route type: '//route
|
|
call mrccend(1)
|
|
endif
|
|
|
|
end subroutine
|
|
|
|
!************************************************************************
|
|
subroutine red_matrix_disk(b,btr,a,lda,m,n,linit,vecfile,errfile)
|
|
!************************************************************************
|
|
! Building reduced matrix in case of small memory
|
|
!************************************************************************
|
|
use common_mod, only: scrfile1
|
|
implicit none
|
|
integer m,n,lda,i,j
|
|
double precision a(lda,*),btr(n,m),b(n),ddot
|
|
logical linit
|
|
character*16 vecfile,errfile
|
|
|
|
open(unit=scrfile1,file=trim(errfile),form='unformatted')
|
|
do i=1,m
|
|
read(scrfile1) btr(:,i)
|
|
enddo
|
|
close(scrfile1)
|
|
|
|
open(unit=scrfile1,file=trim(vecfile),form='unformatted')
|
|
if(linit) then
|
|
do i = 1, m
|
|
read(scrfile1) b
|
|
do j = 1, m
|
|
a(i, j) = ddot(n, btr(1, j), 1, b, 1)
|
|
enddo
|
|
enddo
|
|
else
|
|
do i = 1, m
|
|
read(scrfile1) b
|
|
a(i, m) = ddot(n, btr(1, m), 1, b, 1)
|
|
enddo
|
|
do i = 1, m
|
|
a(m, i) = ddot(n, btr(1, i), 1, b, 1)
|
|
enddo
|
|
endif
|
|
close(scrfile1)
|
|
|
|
end subroutine
|
|
|
|
!************************************************************************
|
|
subroutine red_matrix(b,btr,a,lda,m,n,linit)
|
|
!************************************************************************
|
|
!* Build reduced matrix for subspace solvers
|
|
!************************************************************************
|
|
implicit none
|
|
|
|
integer lda, n, m, i, j
|
|
double precision b(n,m),a(lda,*),btr(n,m)
|
|
double precision ddot
|
|
logical linit
|
|
|
|
if(linit) then
|
|
do i = 1, m
|
|
do j = i, m
|
|
a(i, j) = ddot(n, btr(1, j), 1, b(1, i), 1)
|
|
a(j, i) = ddot(n, btr(1, i), 1, b(1, j), 1)
|
|
enddo
|
|
enddo
|
|
else
|
|
do i = 1, m
|
|
a(i, m) = ddot(n, btr(1, m), 1, b(1, i), 1)
|
|
a(m, i) = ddot(n, btr(1, i), 1, b(1, m), 1)
|
|
enddo
|
|
endif
|
|
|
|
end subroutine
|
|
|
|
!********************************************************************************
|
|
subroutine read_vecs(bvec,nn,step,filename,scrfile)
|
|
!********************************************************************************
|
|
! Reads trial vectors form file
|
|
!********************************************************************************
|
|
implicit none
|
|
integer nn,step,scrfile,i
|
|
double precision bvec(nn,step)
|
|
character*16 filename
|
|
|
|
open(scrfile,file=trim(filename),form='unformatted')
|
|
do i=1,step
|
|
read(scrfile) bvec(1:nn,i)
|
|
enddo
|
|
close(scrfile)
|
|
end subroutine
|
|
|