mirror of https://gitlab.com/QEF/q-e.git
115 lines
3.4 KiB
Fortran
115 lines
3.4 KiB
Fortran
!
|
|
! Copyright (C) 2001-2013 Quantum ESPRESSO group
|
|
! This file is distributed under the terms of the
|
|
! GNU General Public License. See the file `License'
|
|
! in the root directory of the present distribution,
|
|
! or http://www.gnu.org/copyleft/gpl.txt .
|
|
!
|
|
!
|
|
|
|
!this subroutine contains the routines dedicated to obtaining optimal basis sets
|
|
|
|
|
|
SUBROUTINE optimal_driver(num_in,wfcs,lda,options,num_out, info)
|
|
!this routine is a driver for performing the calculation of the optimal basis set
|
|
!using the appropriate method
|
|
|
|
USE kinds, ONLY : DP
|
|
USE wannier_gw, ONLY : optimal_options
|
|
USE io_global, ONLY : stdout
|
|
|
|
implicit none
|
|
|
|
INTEGER, INTENT(in) :: num_in!number of initial vectors
|
|
COMPLEX(kind=DP), INTENT(inout) :: wfcs(lda,num_in)!in input non-orthonormal in output optimal basis
|
|
INTEGER, INTENT(in) :: lda!leading dimension of wfcs, essentially npw or npwx
|
|
TYPE(optimal_options), INTENT(in) :: options!options to be used
|
|
INTEGER, INTENT(out) :: num_out!final number of orthonormal basis functions
|
|
INTEGER, INTENT(out) :: info!final outcome status 0== OK
|
|
|
|
REAL(kind=DP) :: tr
|
|
|
|
!select routine
|
|
select case (options%idiago)
|
|
|
|
case(0)
|
|
!Gram_Schmidt like
|
|
if(options%l_complete) then
|
|
tr=0.d0
|
|
else
|
|
tr=options%thres
|
|
endif
|
|
call optimal_gram_schmidt(num_in,wfcs,lda,options%ithres,tr,num_out)
|
|
|
|
case default
|
|
write(stdout,*) 'optimal driver: NOT IMPLEMENTED YET'
|
|
FLUSH(stdout)
|
|
stop
|
|
end select
|
|
|
|
info=0
|
|
return
|
|
END SUBROUTINE optimal_driver
|
|
|
|
|
|
|
|
|
|
|
|
|
|
SUBROUTINE optimal_gram_schmidt(num_in,wfcs,lda,ithres,thres,num_out)
|
|
!this subroutine performs a gram_schmidt orthonormalization and retains
|
|
!vectors which are above the give threshold
|
|
|
|
USE kinds, ONLY : DP
|
|
USE mp_world, ONLY : world_comm, mpime, nproc
|
|
USE mp, ONLY : mp_sum,mp_bcast
|
|
USE io_global, ONLY : stdout, ionode,ionode_id
|
|
USE wvfct, ONLY : npwx, npw
|
|
USE gvect, ONLY : gstart
|
|
|
|
implicit none
|
|
|
|
INTEGER, INTENT(in) :: num_in!number of initial vectors
|
|
COMPLEX(kind=DP), INTENT(inout) :: wfcs(lda,num_in)!in input non-orthonormal in output optimal basis
|
|
INTEGER, INTENT(in) :: lda!leading dimension of wfcs, essetally npw or npwx
|
|
INTEGER, INTENT(in) :: ithres!kind of threshold
|
|
REAL(kind=DP), INTENT(in) :: thres!thrshold for the optimal basis
|
|
INTEGER, INTENT(out) :: num_out!final number of orthonormal basis functions
|
|
|
|
|
|
|
|
INTEGER :: i,j
|
|
REAL(kind=DP), ALLOCATABLE :: prod(:)
|
|
REAL(kind=DP) :: sca
|
|
REAL(kind=DP), EXTERNAL :: ddot
|
|
|
|
|
|
allocate(prod(num_in))
|
|
num_out=0
|
|
|
|
do i=1,num_in
|
|
if(num_out >0) then
|
|
call dgemv('T',2*npw,num_out,2.d0, wfcs,2*lda,wfcs(:,i),1,0.d0,prod,1)
|
|
if(gstart==2) then
|
|
prod(1:num_out)=prod(1:num_out) - dble(wfcs(1,1:num_out)*conjg(wfcs(1,i)))
|
|
endif
|
|
call mp_sum(prod(1:num_out),world_comm)
|
|
call dgemm('N','N',2*npw,1,num_out,-1.d0,wfcs,2*lda,prod,num_in,1.d0,wfcs(:,i),2*lda)
|
|
endif
|
|
sca = 2.d0*ddot(2*npw,wfcs(:,i),1,wfcs(:,i),1)
|
|
if(gstart==2) then
|
|
sca=sca-dble((wfcs(1,i)*conjg(wfcs(1,i))))
|
|
endif
|
|
call mp_sum(sca,world_comm)
|
|
if(sca >= thres) then
|
|
num_out=num_out+1
|
|
sca=dsqrt(sca)
|
|
call dcopy(2*npw,wfcs(:,i),1,wfcs(:,num_out),1)
|
|
wfcs(1:npw,num_out)=wfcs(1:npw,num_out)/sca
|
|
endif
|
|
enddo
|
|
|
|
deallocate(prod)
|
|
return
|
|
END SUBROUTINE optimal_gram_schmidt
|