Commit 40c0881e authored by Alexander Neukirchen's avatar Alexander Neukirchen

Built a short routine to switch between harmonics.

parent 84ed8b62
......@@ -67,6 +67,7 @@ CONTAINS
USE m_metagga
USE m_plot
USE m_xcBfield
USE m_lh_tofrom_lm
#ifdef CPP_MPI
USE m_mpi_bc_potden
#endif
......@@ -115,6 +116,8 @@ CONTAINS
INCLUDE 'mpif.h'
INTEGER :: ierr(2),n
#endif
REAL, ALLOCATABLE :: flh(:,:),flh2(:,:)
COMPLEX, ALLOCATABLE :: flm(:,:)
mpi%mpi_comm = mpi_comm
......@@ -519,19 +522,32 @@ CONTAINS
!CALL builddivtest(stars,atoms,sphhar,vacuum,sym,cell,1,testDen)
!CALL makeVectorField(stars,atoms,sphhar,vacuum,input,noco,inDen,1.0,testDen)
CALL makeVectorField(stars,atoms,sphhar,vacuum,input,noco,vtot,2.0,testDen)
!CALL makeVectorField(stars,atoms,sphhar,vacuum,input,noco,vtot,2.0,testDen)
!CALL checkplotinp()
CALL savxsf(stars, atoms, sphhar, vacuum, input, oneD, sym, cell, noco, .FALSE., .FALSE., 'testDen ', testDen(1), testDen(1), testDen(2), testDen(3))
!CALL savxsf(stars, atoms, sphhar, vacuum, input, oneD, sym, cell, noco, .FALSE., .FALSE., 'testDen ', testDen(1), testDen(1), testDen(2), testDen(3))
!CALL savxsf(stars, atoms, sphhar, vacuum, input, oneD, sym, cell, noco, .FALSE., .FALSE., 'testDeny ', testDen(2))
!CALL savxsf(stars, atoms, sphhar, vacuum, input, oneD, sym, cell, noco, .FALSE., .FALSE., 'testDenz ', testDen(3))
CALL sourcefree(mpi,dimension,field,stars,atoms,sphhar,vacuum,input,oneD,sym,cell,noco,testDen)
!CALL sourcefree(mpi,dimension,field,stars,atoms,sphhar,vacuum,input,oneD,sym,cell,noco,testDen)
!DO i=1,3
!CALL testGrad(i)%init_potden_simple(stars%ng3,atoms%jmtd,sphhar%nlhd,atoms%ntype,atoms%n_u,1,.FALSE.,.FALSE.,POTDEN_TYPE_POTTOT,vacuum%nmzd,vacuum%nmzxyd,stars%ng2)
!ALLOCATE(testGrad(i)%pw_w,mold=testGrad(i)%pw)
!ENDDO
!CALL divpotgrad(stars,atoms,sphhar,vacuum,sym,cell,noco,testDen(3),testGrad)
!CALL savxsf(stars, atoms, sphhar, vacuum, input, oneD, sym, cell, noco, .FALSE., .FALSE., 'testGrad ', testGrad(1), testGrad(1), testGrad(2), testGrad(3))
ALLOCATE (flh(atoms%jri(1),0:sphhar%nlh(atoms%ntypsy(1))),flm(atoms%jri(1),sphhar%nlh(atoms%ntypsy(1))+1),flh2(atoms%jri(1),0:sphhar%nlh(atoms%ntypsy(1))))
flh=inDen%mt(:,:,1,1)
flh(:,1)=-flh(:,0)
flh(:,2)=0*flh(:,0)
flh(:,3)=flh(:,0)
flh(:,4)=flh(:,0)
flh(:,5)=2*flh(:,0)
flh(:,6)=3*flh(:,0)
flh(:,7)=4*flh(:,0)
flh(:,8)=5*flh(:,0)
CALL lh_to_lm(atoms, sphhar, 1, flh, flm)
CALL lh_from_lm(atoms, sphhar, 1, flm, flh2)
CALL add_usage_data("Iterations",iter)
IF (mpi%irank.EQ.0) CALL closeXMLElement('scfLoop')
......
......@@ -32,6 +32,7 @@ math/DoubleFactorial.f90
math/ExpSave.f90
math/intgr.F90
math/ylm4.F90
math/lh_tofrom_lm.f90
)
if (FLEUR_USE_FFTMKL)
set(fleur_F90 ${fleur_F90} math/mkl_dfti.f90)
......
MODULE m_lh_tofrom_lm
CONTAINS
SUBROUTINE lh_to_lm(atoms, lathar, iType, flh, flm)
USE m_types
IMPLICIT NONE
TYPE(t_atoms), INTENT(IN) :: atoms
TYPE(t_sphhar), INTENT(IN) :: lathar
INTEGER, INTENT(IN) :: iType
REAL, INTENT(IN) :: flh(:,0:) ! (iR,iLH)
COMPLEX, INTENT(INOUT) :: flm(:,:) ! (iR,lm)
INTEGER :: iAtom, iLH, ns, l, iM, m, lm, iR, lh, imem
COMPLEX, ALLOCATABLE :: cMat(:,:), gVec(:,:)
REAL, ALLOCATABLE :: fVec(:,:)
iAtom = SUM(atoms%neq(:iType-1)) + 1
ns = atoms%ntypsy(iAtom)
flm = CMPLX(0.0,0.0)
DO l = 0, atoms%lmax(iType)
ALLOCATE (cMat(-l:l,-l:l))
ALLOCATE (fVec(-l:l,atoms%jri(iType)))
ALLOCATE (gVec(-l:l,atoms%jri(iType)))
cMat=CMPLX(0.0,0.0)
DO M = -l, l
lh = l*(l+1)+M
fVec(M,:)=flh(:,lh)
DO imem = 1, lathar%nmem(lh,ns)
cMat(M,lathar%mlh(imem,lh,ns))=lathar%clnu(imem,lh,ns)
END DO
END DO
DO iR = 1, atoms%jri(iType)
gVec(:,iR)=MATMUL(fVec(:,iR),cMat)
END DO
DO m = -l, l
flm(:,l*(l+1)+1+m)=gVec(m,:)
END DO
DEALLOCATE (cMat,fVec,gVec)
END DO
END SUBROUTINE lh_to_lm
SUBROUTINE lh_from_lm(atoms, lathar, iType, flm, flh)
USE m_types
IMPLICIT NONE
TYPE(t_atoms), INTENT(IN) :: atoms
TYPE(t_sphhar), INTENT(IN) :: lathar
INTEGER, INTENT(IN) :: iType
COMPLEX, INTENT(IN) :: flm(:,:) ! (iR,lm)
REAL, INTENT(INOUT) :: flh(:,0:) ! (iR,iLH)
INTEGER :: iAtom, iLH, ns, l, iM, m, lm, iR, info, lh, imem, info2
INTEGER, ALLOCATABLE :: ipiv(:)
COMPLEX, ALLOCATABLE :: cMat(:,:),fVec(:,:)
EXTERNAL zgetrf, zgetrs
iAtom = SUM(atoms%neq(:iType-1)) + 1
ns = atoms%ntypsy(iAtom)
flh = 0.0
DO l = 0, atoms%lmax(iType)
ALLOCATE (cMat(-l:l,-l:l))
ALLOCATE (fVec(-l:l,atoms%jri(iType)))
ALLOCATE (ipiv(-l:l))
cMat=CMPLX(0.0,0.0)
DO M = -l, l
lh = l*(l+1)+M
fVec(M,:)=flm(:,lh+1)
DO imem = 1, lathar%nmem(lh,ns)
cMat(M,lathar%mlh(imem,lh,ns))=lathar%clnu(imem,lh,ns)
END DO
END DO
CALL zgetrf(2*l+1,2*l+1,cMat,2*l+1,ipiv,info)
DO iR = 1, atoms%jri(iType)
CALL zgetrs('T',2*l+1,1,cMat,2*l+1,ipiv,fVec(:,iR),2*l+1,info2)
END DO
DO M = -l, l
flh(:,l*(l+1)+M)=REAL(fVec(M,:))
END DO
DEALLOCATE (cMat,fVec,ipiv)
END DO
END SUBROUTINE lh_from_lm
END MODULE m_lh_tofrom_lm
  • @micha The routine seems to work just fine considering a to and from test. Thanks for the initial snippet I could start from! :)

Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment