Commit fdac2fb9 authored by Daniel Wortmann's avatar Daniel Wortmann

Deleted some old versions of subroutines in eigen

parent 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
!--------------------------------------------------------------------------------
! 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
This diff is collapsed.
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
This diff is collapsed.
!--------------------------------------------------------------------------------
! 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
!--------------------------------------------------------------------------------
! 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)