Skip to content

fleur
fleur
Commit fdac2fb9 authored by Daniel Wortmann's avatar Daniel Wortmann
Browse files
Options

Deleted some old versions of subroutines in eigen

parent d86baa66
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 0 additions and 1575 deletions
eigen/hsint.F90 deleted 100644 → 0
View file @ d86baa66
!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------
MODULE m_hsint
CONTAINS
SUBROUTINE hsint(input,noco,jij,stars, vpw,lapw,jspin,&
n_size,n_rank,bkpt,cell,atoms,l_real,hamOvlp)
!*********************************************************************
! initializes and sets up the hamiltonian and overlap matrices
! for the interstitial. only the lower triangle of the hermitian
! matrices are stored in compact real mode such that if h(i,j),
! i.ge.j, is hermitian and a is real, then
! a(i,j)=real( h(i,j) ) and a(j,i)=aimag( h(i,j) )
! m. weinert 1986
!
! For the eigenvector parallelization each pe calculates an equal share
! of columns labeled nc. Then the starting element of a columns nc is
!
! ii = (nc-1)*( n_rank - n_size + 1 ) + n_size*(nc-1)*nc/2
!
! and, if a non-collinear matrix has to be set up, the starting column
! for the second spin-direction is
!
! nc = int( 1. + (nv - n_rank - 1)/n_size ) + 1 .
!
! For this direction, the outer loop starts at
!
! istart = n_rank + (nc - 1)*n_size - nv . gb99
!
! for a lo-calculation nv has to be replaced by nv+nlotot gb01
!
!*********************************************************************
USE m_types
IMPLICIT NONE
TYPE(t_input),INTENT(IN) :: input
TYPE(t_noco),INTENT(IN) :: noco
TYPE(t_jij),INTENT(IN) :: jij
TYPE(t_stars),INTENT(IN) :: stars
TYPE(t_cell),INTENT(IN) :: cell
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_lapw),INTENT(INOUT) :: lapw
TYPE(t_hamOvlp),INTENT(INOUT) :: hamOvlp
! ..
! .. Scalar Arguments ..
INTEGER, INTENT (IN) :: n_size,n_rank,jspin
! ..
! .. Array Arguments ..
COMPLEX, INTENT (INOUT) :: vpw(stars%ng3)
REAL, INTENT (IN) :: bkpt(3)
LOGICAL,INTENT(IN) :: l_real
! ..
! .. Local Scalars ..
COMPLEX th,ts,phase
REAL b1(3),b2(3),r2
INTEGER i,i1,i2,i3,ii,in,j,ig3,ispin,l,iloc
INTEGER istart,nc
COMPLEX ust1,vp1
COMPLEX, ALLOCATABLE :: vpw1(:) ! for J constants
! ..
! ..
!$OMP PARALLEL
if (l_real) THEN
!$OMP DO
do i = 1, size(hamOvlp%a_r)
hamOvlp%a_r(i)=0.0
end do
!OMP END DO
!$OMP DO
do i = 1, size(hamOvlp%b_r)
hamOvlp%b_r(i)=0.0
end do
!OMP END DO
ELSE
!$OMP DO
do i = 1, size(hamOvlp%a_c)
hamOvlp%a_c(i)=0.0
end do
!$OMP END DO
!$OMP DO
do i = 1, size(hamOvlp%b_c)
hamOvlp%b_c(i)=0.0
end do
!$OMP END DO
ENDIF
!$OMP END PARALLEL
ust1 = stars%ustep(1)
ispin = jspin
lapw%nmat = lapw%nv(ispin)
!---> pk non-collinear
IF (noco%l_noco) THEN
!---> determine spin-up spin-up part of Hamiltonian- and overlapp-matrix
!---> reload V_11
READ (25) (vpw(ig3),ig3=1,stars%ng3)
!--- J const
IF( jij%l_J) THEN
ALLOCATE ( vpw1(stars%ng3) )
READ (25) (vpw1(ig3),ig3=1,stars%ng3)
ENDIF
!--- J const
lapw%nmat = lapw%nv(1) + lapw%nv(2)
ispin = 1
!--- J const
IF (jij%l_J) THEN
DO i = 1,stars%ng3
vpw(i) = (vpw(i) + vpw1(i))/2.
END DO
ENDIF
!--- J const
vp1 = REAL(vpw(1))
ENDIF
!---> pk non-collinear
vp1 = vpw(1)
!---> loop over (k+g')
ii = 0
!$OMP PARALLEL DO SCHEDULE(dynamic) DEFAULT(none) &
!$OMP SHARED(n_rank,n_size,lapw,ispin,stars,input,bkpt,cell,vpw,ust1,vp1) &
!$OMP SHARED(l_real,hamOvlp)&
!$OMP PRIVATE(i,j,iloc,i1,i2,i3,in,phase,b1,b2,r2,th,ts)&
!$OMP FIRSTPRIVATE(ii)
DO i = n_rank+1, lapw%nv(ispin), n_size
!---> loop over (k+g)
DO j = 1,i - 1
ii = 0
DO iloc = n_rank+1,i-n_size,n_size
ii = ii + iloc
ENDDO
ii = ii + j
!--> determine index and phase factor
i1 = lapw%k1(i,ispin) - lapw%k1(j,ispin)
i2 = lapw%k2(i,ispin) - lapw%k2(j,ispin)
i3 = lapw%k3(i,ispin) - lapw%k3(j,ispin)
in = stars%ig(i1,i2,i3)
IF (in.EQ.0) CYCLE
phase = stars%rgphs(i1,i2,i3)
!+APW_LO
IF (input%l_useapw) THEN
b1(1) = bkpt(1)+lapw%k1(i,ispin) ; b2(1) = bkpt(1)+lapw%k1(j,ispin)
b1(2) = bkpt(2)+lapw%k2(i,ispin) ; b2(2) = bkpt(2)+lapw%k2(j,ispin)
b1(3) = bkpt(3)+lapw%k3(i,ispin) ; b2(3) = bkpt(3)+lapw%k3(j,ispin)
r2 = DOT_PRODUCT(MATMUL(b2,cell%bbmat),b1)
th = phase*(0.5*r2*stars%ustep(in)+vpw(in))
ELSE
th = phase* (0.25* (lapw%rk(i,ispin)**2+lapw%rk(j,ispin)**2)*stars%ustep(in) + vpw(in))
ENDIF
!-APW_LO
!---> determine matrix element and store
ts = phase*stars%ustep(in)
if (l_real) THEN
hamOvlp%a_r(ii) = REAL(th)
hamOvlp%b_r(ii) = REAL(ts)
else
hamOvlp%a_c(ii) = th
hamOvlp%b_c(ii) = ts
endif
ENDDO
!---> diagonal term (g-g'=0 always first star)
ii = ii + 1
if (l_real) THEN
hamOvlp%a_r(ii) = 0.5*lapw%rk(i,ispin)*lapw%rk(i,ispin)*REAL(ust1) + REAL(vp1)
hamOvlp%b_r(ii) = REAL(ust1)
else
hamOvlp%a_c(ii) = 0.5*lapw%rk(i,ispin)*lapw%rk(i,ispin)*ust1 + vp1
hamOvlp%b_c(ii) = ust1
endif
ENDDO
!$OMP END PARALLEL DO
!---> pk non-collinear
IF (noco%l_noco) THEN
!+gb99
nc = INT( 1. + (lapw%nv(1)+atoms%nlotot - n_rank - 1)/n_size )
istart = n_rank + nc*n_size - (lapw%nv(1)+atoms%nlotot)
! ii = (nv(1)+nlotot+1)*(nv(1)+nlotot+2)/2 - 1
ii = nc*(n_rank-n_size+1) + n_size*(nc+1)*nc/2 + lapw%nv(1)+atoms%nlotot
!-gb99
ispin = 2
!---> determine spin-down spin-down part of Hamiltonian- and ovlp-matrix
!---> reload V_22
!--- J constants
IF(.NOT.jij%l_J) THEN
READ (25) (vpw(ig3),ig3=1,stars%ng3)
vp1 = REAL(vpw(1))
ENDIF
!--- J constants
!---> loop over (k+g')
DO i = istart+1, lapw%nv(ispin), n_size
nc = nc + 1
!---> loop over (k+g)
DO j = 1,i - 1
!-gb99 ii = (nv(1)+i-1)*(nv(1)+i)/2 + nv(1) + j
ii = (nc-1)*( n_rank - n_size + 1 ) + n_size*(nc-1)*nc/2 + lapw%nv(1)+atoms%nlotot + j
!---> determine index and phase factor
i1 = lapw%k1(i,ispin) - lapw%k1(j,ispin)
i2 = lapw%k2(i,ispin) - lapw%k2(j,ispin)
i3 = lapw%k3(i,ispin) - lapw%k3(j,ispin)
in = stars%ig(i1,i2,i3)
IF (in.EQ.0) THEN
WRITE (*,*) 'HSINT: G-G'' not in star i,j= ',i,j
ELSE
phase = stars%rgphs(i1,i2,i3)
!+APW_LO
IF (input%l_useapw) THEN
b1(1) = bkpt(1)+lapw%k1(i,ispin) ; b2(1) = bkpt(1)+lapw%k1(j,ispin)
b1(2) = bkpt(2)+lapw%k2(i,ispin) ; b2(2) = bkpt(2)+lapw%k2(j,ispin)
b1(3) = bkpt(3)+lapw%k3(i,ispin) ; b2(3) = bkpt(3)+lapw%k3(j,ispin)
r2 = DOT_PRODUCT(MATMUL(b2,cell%bbmat),b1)
th = phase*( 0.5*r2*stars%ustep(in) + vpw(in) )
ELSE
th = phase* (0.25* (lapw%rk(i,ispin)**2+lapw%rk(j,ispin)**2)*stars%ustep(in) + vpw(in))
ENDIF
!-APW_LO
ts = phase*stars%ustep(in)
hamOvlp%a_c(ii) = th
hamOvlp%b_c(ii) = ts
ENDIF
ENDDO
!---> diagonal term (g-g'=0 always first star)
!-gb99 ii = (nv(1)+i)*(nv(1)+i+1)/2
ii = ii + 1
hamOvlp%a_c(ii) = 0.5*lapw%rk(i,ispin)*lapw%rk(i,ispin)*ust1 + vp1
hamOvlp%b_c(ii) = ust1
ENDDO
!---> determine spin-down spin-up part of Hamiltonian- and ovlp-matrix
!---> reload real part of V_21
READ (25) (vpw(ig3),ig3=1,stars%ng3)
nc = INT( 1. + (lapw%nv(1)+atoms%nlotot - n_rank - 1)/n_size )
!
!---> loop over (k+g')
!
DO i = istart+1, lapw%nv(2), n_size
nc = nc + 1
!---> loop over (k+g)
DO j = 1,lapw%nv(1)
!-gb99 ii = (nv(1)+i-1)*(nv(1)+i)/2 + j
ii = (nc-1)*( n_rank - n_size + 1 ) + n_size*(nc-1)*nc/2 + j
!---> determine index and phase factor
i1 = lapw%k1(i,2) - lapw%k1(j,1)
i2 = lapw%k2(i,2) - lapw%k2(j,1)
i3 = lapw%k3(i,2) - lapw%k3(j,1)
in = stars%ig(i1,i2,i3)
IF (in.EQ.0) THEN
WRITE (*,*) 'HSINT: G-G'' not in star i,j= ',i,j
ELSE
hamOvlp%a_c(ii) = stars%rgphs(i1,i2,i3)*vpw(in)
!--- J constants
IF(jij%l_J) THEN
hamOvlp%a_c(ii) = 0
ENDIF
!--- J constants
ENDIF
ENDDO
ENDDO
!---> pk non-collinear
ENDIF
IF (jij%l_J) DEALLOCATE (vpw1)
RETURN
END SUBROUTINE hsint
END MODULE m_hsint
eigen/hsmt_blas.F90 deleted 100644 → 0
View file @ d86baa66
!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------
MODULE m_hsmt_blas
use m_juDFT
implicit none
CONTAINS
SUBROUTINE hsmt_blas(sym,atoms,isp,noco,cell,lapw,td,ud,gk,vk,fj,gj,smat,hmat)
!Calculate overlap matrix
USE m_hsmt_ab
USE m_constants, ONLY : fpi_const,tpi_const
USE m_types
USE m_ylm
IMPLICIT NONE
TYPE(t_sym),INTENT(IN) :: sym
TYPE(t_noco),INTENT(IN) :: noco
TYPE(t_cell),INTENT(IN) :: cell
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_lapw),INTENT(IN) :: lapw
TYPE(t_tlmplm),INTENT(IN) :: td
TYPE(t_usdus),INTENT(IN) :: ud
! ..
! .. Scalar Arguments ..
INTEGER, INTENT (IN) :: isp
! ..
! .. Array Arguments ..
REAL,INTENT(IN) :: gk(:,:,:),vk(:,:,:)
REAL,INTENT(IN) :: fj(:,0:,:,:),gj(:,0:,:,:)
TYPE(t_lapwmat),INTENT(INOUT)::smat,hmat
INTEGER:: n,nn,na,aboffset,l,ll,m
COMPLEX,ALLOCATABLE:: ab(:,:),tmpdata(:,:),tmp_s(:,:),tmp_h(:,:),ab1(:,:)
ALLOCATE(ab(lapw%nv(isp),2*atoms%lmaxd*(atoms%lmaxd+2)+2),ab1(lapw%nv(isp),2*atoms%lmaxd*(atoms%lmaxd+2)+2))
ALLOCATE(tmp_s(smat%matsize1,smat%matsize2),tmp_h(smat%matsize1,smat%matsize2))
tmp_s=0.0;tmp_h=0.0;ab=0.0;ab1=0.0
ntyploop: DO n=1,atoms%ntype
DO nn = 1,atoms%neq(n)
na = SUM(atoms%neq(:n-1))+nn
IF ((atoms%invsat(na)==0) .OR. (atoms%invsat(na)==1)) THEN
!---> Calculate Overlapp matrix
CALL timestart("ab-coefficients")
CALL hsmt_ab(sym,atoms,isp,n,na,cell,lapw,gk,vk,fj,gj,ab,aboffset)
CALL timestop("ab-coefficients")
CALL timestart("Overlapp")
CALL ZHERK("U","N",lapw%nv(isp),aboffset,1.,ab,SIZE(ab,1),1.0,tmp_s,SIZE(tmp_s,1))
DO l=0,atoms%lmax(n)
ll=l*(l+1)
DO m=-l,l
ab1(:,1+ll+m)=SQRT(ud%ddn(l,n,isp))*ab(:,aboffset+1+ll+m)
ENDDO
ENDDO
CALL ZHERK("U","N",lapw%nv(isp),aboffset,1.,ab1,SIZE(ab,1),1.0,tmp_s,SIZE(tmp_s,1))
CALL timestop("Overlapp")
CALL timestart("Hamiltonian")
!Calculate Hamiltonian
CALL zgemm("N","N",SIZE(ab,1),2*aboffset,2*aboffset,CMPLX(1.0,0.0),ab,SIZE(ab,1),td%h_loc(:,:,n,isp),SIZE(td%h_loc,1),CMPLX(0.,0.),ab1,SIZE(ab,1))
! CALL zgemm("N","C",lapw%nv(isp),lapw%nv(isp),2*aboffset,CMPLX(1.0,0.0),ab,SIZE(ab,1),ab1,SIZE(ab,1),CMPLX(1.0,0),tmp_h,SIZE(tmp_h,1))
CALL ZHERK("U","N",lapw%nv(isp),2*aboffset,1.,ab1,SIZE(ab,1),1.0,tmp_h,SIZE(tmp_h,1))
CALL timestop("Hamiltonian")
ENDIF
END DO
END DO ntyploop
!Copy tmp array back
IF (smat%l_real) THEN
smat%data_r=smat%data_r+tmp_s
hmat%data_r=hmat%data_r+tmp_h-td%e_shift*tmp_s
ELSE
smat%data_c=smat%data_c+tmp_s
hmat%data_c=hmat%data_c+tmp_h-td%e_shift*tmp_s
ENDIF
END SUBROUTINE hsmt_blas
#if 1==2
!this version uses zherk for Hamiltonian
ntyploop: DO n=1,atoms%ntype
DO nn = 1,atoms%neq(n)
na = SUM(atoms%neq(:n-1))+nn
IF ((atoms%invsat(na)==0) .OR. (atoms%invsat(na)==1)) THEN
!---> Calculate Overlapp matrix
CALL timestart("ab-coefficients")
CALL hsmt_ab(sym,atoms,isp,n,na,cell,lapw,gk,vk,fj,gj,ab,aboffset)
CALL timestop("ab-coefficients")
CALL timestart("Overlapp")
CALL ZHERK("U","N",lapw%nv(isp),aboffset,1.,ab,SIZE(ab,1),1.0,tmp_s,SIZE(tmp_s,1))
DO l=0,atoms%lmax(n)
ll=l*(l+1)
DO m=-l,l
ab1(:,1+ll+m)=SQRT(ud%ddn(l,n,isp))*ab(:,aboffset+1+ll+m)
ENDDO
ENDDO
CALL ZHERK("U","N",lapw%nv(isp),aboffset,1.,ab1,SIZE(ab,1),1.0,tmp_s,SIZE(tmp_s,1))
CALL timestop("Overlapp")
CALL timestart("Hamiltonian")
!Calculate Hamiltonian
CALL zgemm("N","N",SIZE(ab,1),2*aboffset,2*aboffset,CMPLX(1.0,0.0),ab,SIZE(ab,1),td%h_loc(:,:,n,isp),SIZE(td%h_loc,1),CMPLX(0.,0.),ab1,SIZE(ab,1))
CALL ZHERK("U","N",lapw%nv(isp),2*aboffset,1.,ab1,SIZE(ab,1),1.0,tmp_h,SIZE(tmp_h,1))
CALL timestop("Hamiltonian")
ENDIF
END DO
END DO ntyploop
!Copy tmp array back
IF (smat%l_real) THEN
smat%data_r=smat%data_r+tmp_s
hmat%data_r=hmat%data_r+tmp_h-td%e_shift*tmp_s
ELSE
smat%data_c=smat%data_c+tmp_s
hmat%data_c=hmat%data_c+tmp_h-td%e_shift*tmp_s
ENDIF
#endif
END MODULE m_hsmt_blas
eigen/hsmt_extra.F90 deleted 100644 → 0
View file @ d86baa66
This diff is collapsed.
eigen/hsmt_hlptomat.F90 deleted 100644 → 0
View file @ d86baa66
module m_hsmt_hlptomat
#include "juDFT_env.h"
implicit none
contains
subroutine hsmt_hlptomat(nlotot,nv,sub_comm,chi11,chi21,chi22,aahlp,aa,bbhlp,bb)
!hsmt_hlptomat: aa/bbhlp - to -aa/bb matrix
!Rotate the aahlp&bbhlp arrays from the local spin-frame into the global frame
!and add the data to the aa&bb arrays, call mingeselle in distributed case
#ifdef CPP_MPI
USE m_mingeselle
#endif
implicit none
integer, intent(in) :: nlotot,nv(:),sub_comm
complex, intent(in) :: chi11,chi21,chi22
complex, intent(inout) :: aahlp(:)
complex, intent(inout) :: aa(:)
complex, optional,intent(inout) :: bb(:),bbhlp(:)
integer :: ii,ij,ki,kj,n_rank,n_size
REAL :: aa_r(1),bb_r(1) !dummy arguments for mingeselle
#ifdef CPP_MPI
#include "mpif.h"
CALL MPI_COMM_RANK(sub_comm,n_rank,ki)
CALL MPI_COMM_SIZE(sub_comm,n_size,ki)
#else
n_size=1
#endif
IF (n_size==1) THEN
DO ki = 1, nv(1)+nlotot
!---> spin-up spin-up part
ii = (ki-1)*(ki)/2
ij = (ki-1)*(ki)/2
aa(ij+1:ij+ki)=aa(ij+1:ij+ki)+chi11*aahlp(ii+1:ii+ki)
if (present(bb)) bb(ij+1:ij+ki)=bb(ij+1:ij+ki)+chi11*bbhlp(ii+1:ii+ki)
!---> spin-down spin-down part
ij = (nv(1)+nlotot+ki-1)*(nv(1)+nlotot+ki)/2+nv(1)+nlotot
aa(ij+1:ij+ki)=aa(ij+1:ij+ki)+chi22*aahlp(ii+1:ii+ki)
if (present(bb)) bb(ij+1:ij+ki)=bb(ij+1:ij+ki)+chi22*bbhlp(ii+1:ii+ki)
!---> spin-down spin-up part, lower triangle
ij = (nv(1)+nlotot+ki-1)*(nv(1)+nlotot+ki)/2
aa(ij+1:ij+ki)=aa(ij+1:ij+ki)+chi21*aahlp(ii+1:ii+ki)
if (present(bb)) bb(ij+1:ij+ki)=bb(ij+1:ij+ki)+chi21*bbhlp(ii+1:ii+ki)
!---> spin-down spin-up part, upper triangle.
DO kj = 1,ki-1
ij = (nv(1)+nlotot+kj-1)*(nv(1)+nlotot+kj)/2 + ki
aa(ij) = aa(ij) + conjg(aahlp(ii+kj))*chi21
if (present(bb)) bb(ij) = bb(ij) + conjg(bbhlp(ii+kj))*chi21
ENDDO
ENDDO
ELSE
aa(:size(aahlp)) = aa(:size(aahlp))+aahlp*chi11
aahlp = conjg(aahlp)*chi21
IF (present(bb).and.nlotot>1) THEN
!CALL juDFT_error("noco+LO and EVP is broken")
bb(:size(aahlp)) = bb(:size(aahlp))+bbhlp*chi11
bbhlp = conjg(bbhlp)*chi21
ENDIF
#ifdef CPP_MPI
CALL mingeselle(SUB_COMM,n_size,n_rank,nv,&
aahlp,.false.,aa_r,aa)
IF (present(bb).and.nlotot>1) CALL mingeselle(SUB_COMM,n_size,n_rank,nv,&
bbhlp,.false.,bb_r,bb)
#endif
ENDIF
end subroutine
end module m_hsmt_hlptomat
eigen/hsmt_overlap.F90 deleted 100644 → 0
View file @ d86baa66
This diff is collapsed.
eigen/hsmt_simple.F90 deleted 100644 → 0
View file @ d86baa66
!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grnberg Institut, Forschungszentrum Jlich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------
MODULE m_hsmt_simple
use m_juDFT
implicit none
CONTAINS
SUBROUTINE hsmt_simple(jspin,bkpt,DIMENSION,input,sym,cell,atoms,lapw,td,noco,usdus,enpara,hmat,smat)
use m_types
use m_hsmt_fjgj
USE m_hsmt_blas
TYPE(t_dimension),INTENT(IN) :: DIMENSION
TYPE(t_input),INTENT(IN) :: input
TYPE(t_sym),INTENT(IN) :: sym
TYPE(t_cell),INTENT(IN) :: cell
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_enpara),INTENT(IN) :: enpara
TYPE(t_lapw),INTENT(IN) :: lapw
TYPE(t_usdus),INTENT(IN) :: usdus
TYPE(t_noco),INTENT(IN) :: noco
TYPE(t_tlmplm),INTENT(IN) :: td
TYPE(t_lapwmat),INTENT(INOUT) :: smat,hmat
INTEGER,INTENT(IN) :: jspin
REAL, INTENT (IN) :: bkpt(3)
integer::k,jsp,n,nn,i
REAL, ALLOCATABLE :: fj(:,:,:,:),gj(:,:,:,:)
REAL, ALLOCATABLE :: gk(:,:,:),vk(:,:,:)
REAL :: v(3),diff_h,diff_s
REAL, PARAMETER :: eps = 1.0e-30
ALLOCATE(fj(dimension%nbasfcn,0:atoms%lmaxd,atoms%ntype,input%jspins))
ALLOCATE(gj(dimension%nbasfcn,0:atoms%lmaxd,atoms%ntype,input%jspins))
DO jsp=jspin,jspin
!Set up the k+G+qss vectors
ALLOCATE(vk(dimension%nbasfcn,3,1),gk(dimension%nbasfcn,3,1))
DO k = 1,lapw%nv(jsp)
v=bkpt+(/lapw%k1(k,jsp),lapw%k2(k,jsp),lapw%k3(k,jsp)/)!-noco%qss/2
vk(k,:,1) = v
gk(k,:,1) = MATMUL(TRANSPOSE(cell%bmat),v)/MAX (lapw%rk(k,jsp),eps)
ENDDO
CALL hsmt_fjgj(input,atoms,jsp,cell,lapw,usdus,fj,gj)
CALL timestart("hsmt_blas")
CALL hsmt_blas(sym,atoms,jsp,noco,cell,lapw,td,usdus,gk,vk,fj,gj,smat,hmat)
CALL timestop("hsmt_blas")
ENDDO
!CALL hsmt_lo()
end SUBROUTINE hsmt_simple
end MODULE m_hsmt_simple
eigen/hsmt_soc_init.F90 deleted 100644 → 0
View file @ d86baa66
!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------
MODULE m_socinit
USE m_juDFT
IMPLICIT NONE
CONTAINS
!>Initialization of SOC matrix elements used in first variation SOC
!!
SUBROUTINE socinit(mpi,atoms,sphhar,enpara,input,vr,noco,& !in
usdus,rsoc) !out
!Initialized the radial-spin-orbit elements in rsoc
!needed for first variation SOC
USE m_soinit
USE m_types
IMPLICIT NONE
TYPE(t_mpi),INTENT(IN) :: mpi
TYPE(t_input),INTENT(IN) :: input
TYPE(t_noco),INTENT(IN) :: noco
TYPE(t_sphhar),INTENT(IN) :: sphhar
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_enpara),INTENT(IN) :: enpara
! ..
! .. Scalar Arguments ..
! ..
! .. Array Arguments ..
REAL, INTENT (IN) :: vr(:,0:,:,:)!(atoms%jmtd,0:sphhar%nlhd,atoms%ntype,DIMENSION%jspd)
TYPE(t_usdus),INTENT(INOUT):: usdus
TYPE(t_rsoc),INTENT(OUT) :: rsoc
! ..
! .. Local Scalars ..
INTEGER l,n
! for Spin-orbit...
LOGICAL :: l_test
LOGICAL, SAVE :: first_k = .TRUE.
CHARACTER*3 :: chntype
ALLOCATE(rsoc%rsopp(atoms%ntype,atoms%lmaxd,2,2),rsoc%rsoppd (atoms%ntype,atoms%lmaxd,2,2))
ALLOCATE(rsoc%rsopdp (atoms%ntype,atoms%lmaxd,2,2),rsoc%rsopdpd(atoms%ntype,atoms%lmaxd,2,2))
ALLOCATE(rsoc%rsoplop (atoms%ntype,atoms%nlod,2,2),rsoc%rsoplopd(atoms%ntype,atoms%nlod,2,2))
ALLOCATE(rsoc%rsopdplo(atoms%ntype,atoms%nlod,2,2),rsoc%rsopplo (atoms%ntype,atoms%nlod,2,2))
ALLOCATE(rsoc%rsoploplop(atoms%ntype,atoms%nlod,atoms%nlod,2,2))
CALL soinit(atoms,input,enpara,vr,noco%soc_opt(atoms%ntype+2),&
rsoc%rsopp,rsoc%rsoppd,rsoc%rsopdp,rsoc%rsopdpd,usdus,&
rsoc%rsoplop,rsoc%rsoplopd,rsoc%rsopdplo,rsoc%rsopplo,rsoc%rsoploplop)
INQUIRE(file="socscale",exist=l_test)
IF (l_test) THEN
OPEN(99,file="socscale")
READ(99,*) n
CLOSE(99)
WRITE(*,*) "SOC scaled by ",n,"%"
rsoc%rsopp(:,:,:,:) = n/100.* rsoc%rsopp
rsoc%rsopdp(:,:,:,:) = n/100.*rsoc%rsopdp
rsoc%rsoppd(:,:,:,:) = n/100.*rsoc%rsoppd
rsoc%rsopdpd(:,:,:,:) = n/100.*rsoc%rsopdpd
rsoc%rsoplop(:,:,:,:) = n/100.*rsoc%rsoplop
rsoc%rsoplopd(:,:,:,:) = n/100.*rsoc%rsoplopd
rsoc%rsopdplo(:,:,:,:) = n/100.*rsoc%rsopdplo
rsoc%rsopplo(:,:,:,:) = n/100.* rsoc%rsopplo
rsoc%rsoploplop(:,:,:,:,:) = n/100.*rsoc%rsoploplop
ENDIF
IF (noco%soc_opt(atoms%ntype+1)) THEN
DO n= 1,atoms%ntype
IF (.NOT. noco%soc_opt(n)) THEN
rsoc%rsopp(n,:,:,:) = 0.0
rsoc%rsopdp(n,:,:,:) = 0.0
rsoc%rsoppd(n,:,:,:) = 0.0
rsoc%rsopdpd(n,:,:,:) = 0.0
rsoc%rsoplop(n,:,:,:) = 0.0
rsoc%rsoplopd(n,:,:,:) = 0.0
rsoc%rsopdplo(n,:,:,:) = 0.0
rsoc%rsopplo(n,:,:,:) = 0.0
rsoc%rsoploplop(n,:,:,:,:) = 0.0
ENDIF
ENDDO
ENDIF
IF ((first_k).AND.(mpi%irank.EQ.0)) THEN
DO n = 1,atoms%ntype
WRITE (6,FMT=8000)
WRITE (6,FMT=9000)
WRITE (6,FMT=8001) (2*rsoc%rsopp(n,l,1,1),l=1,3)
WRITE (6,FMT=8001) (2*rsoc%rsopp(n,l,2,2),l=1,3)
WRITE (6,FMT=8001) (2*rsoc%rsopp(n,l,2,1),l=1,3)
ENDDO
IF (noco%soc_opt(atoms%ntype+1)) THEN
WRITE (chntype,'(i3)') atoms%ntype
WRITE (6,fmt='(A,2x,'//chntype//'l1)') 'SOC contribution of certain atom types included in Hamiltonian:',&
(noco%soc_opt(n),n=1,atoms%ntype)
ELSE
WRITE(6,fmt='(A,1x,A)') 'SOC contribution of all atom types included in Hamiltonian.'
ENDIF
IF (noco%soc_opt(atoms%ntype+2)) THEN
WRITE(6,fmt='(A)') 'SOC Hamiltonian is constructed by neglecting B_xc.'
ENDIF
first_k=.FALSE.
ENDIF
8000 FORMAT (' spin - orbit parameter HR ')
8001 FORMAT (8f8.4)
9000 FORMAT (5x,' p ',5x,' d ', 5x, ' f ')
RETURN
END SUBROUTINE socinit
END MODULE m_hsmt_socinit
eigen/hsmt_sph_new.F90 deleted 100644 → 0
View file @ d86baa66
MODULE m_hsmt_sph
use m_juDFT
implicit none
CONTAINS
SUBROUTINE hsmt_sph(dimension,atoms,SUB_COMM,n_size,n_rank,sphhar,isp,ab_dim,&
input,hlpmsize,noco,l_socfirst,cell,nintsp, lapw,el,usdus,vr,gk,rsoc,isigma, aa,bb,fj,gj)
#include"cpp_double.h"
USE m_constants, ONLY : fpi_const,tpi_const
USE m_sphbes
USE m_dsphbs
USE m_ylm
USE m_hsmt_socinit,ONLY:t_rsoc
USE m_hsmt_spinor
USE m_radovlp
#ifdef CPP_MPI
USE m_mingeselle
#endif
USE m_types
IMPLICIT NONE
TYPE(t_dimension),INTENT(IN):: dimension