Commit 176226ca authored by Daniel Wortmann's avatar Daniel Wortmann

Deleted unused files, Fixes #177

parent ad511e1d
This diff is collapsed.
This diff is collapsed.
!--------------------------------------------------------------------------------
! 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_geneigprobl
USE m_juDFT
!**********************************************************
! Solve the generalized eigenvalue problem
! Frank Freimuth, November 2006
!**********************************************************
CONTAINS
SUBROUTINE geneigprobl(nbasfcn, nsize,neigd,l_J,eig,ne,a_r,b_r,z_r,a_c,b_c,z_c)
#include"cpp_double.h"
USE m_packed_to_full
IMPLICIT NONE
! ... Arguments ...
INTEGER, INTENT (IN) :: nbasfcn
INTEGER, INTENT (IN) :: neigd
INTEGER, INTENT (IN) :: nsize
LOGICAL, INTENT (IN) :: l_J
REAL, INTENT(OUT) :: eig(:)
INTEGER, INTENT(OUT) :: ne
REAL,OPTIONAL, ALLOCATABLE, INTENT (INOUT) :: a_r(:),b_r(:)
REAL,OPTIONAL, ALLOCATABLE, INTENT (INOUT) :: z_r(:,:)
COMPLEX,OPTIONAL, ALLOCATABLE, INTENT (INOUT) :: a_c(:),b_c(:)
COMPLEX,OPTIONAL, ALLOCATABLE, INTENT (INOUT) :: z_c(:,:)
! ... Local Variables ..
INTEGER iind,ind1,ind2,info,lwork,liwork,lrwork,err,i
INTEGER sizez,iu
REAL :: lb,ub
! 'sizez' is needed, as some compilers sometimes produce errors,
! if the size command is used directly as a lapack argument.
REAL toler, eigTemp(nsize)
REAL, ALLOCATABLE :: work(:)
INTEGER, ALLOCATABLE :: iwork(:),isuppz(:)
REAL, ALLOCATABLE :: largea_r(:,:),largeb_r(:,:)
COMPLEX, ALLOCATABLE :: largea_c(:,:),largeb_c(:,:)
COMPLEX,ALLOCATABLE :: cwork(:)
LOGICAL :: l_real
l_real=PRESENT(a_r)
!**********************************
!expand from packed to full storage: full storage lapack-routines
!are faster than the packed lapack-routines.
!**********************************
!hamiltonian
IF (l_real) THEN
call packed_to_full(nsize,a_r,largea_r)
DEALLOCATE (a_r)
call packed_to_full(nsize,b_r,largeb_r)
DEALLOCATE (b_r)
ELSE
call packed_to_full(nsize,a_c,largea_c)
DEALLOCATE (a_c)
call packed_to_full(nsize,b_c,largeb_c)
DEALLOCATE (b_c)
ENDIF
IF (l_real) then
CALL CPP_LAPACK_spotrf('U',nsize,largeb_r,nsize,info)
IF (info /= 0) CALL juDFT_error("error in spotrf",calledby ="geneigprobl")
CALL CPP_LAPACK_ssygst(1,'U',nsize,largea_r,nsize,largeb_r,nsize,info)
IF (info /= 0) CALL juDFT_error("error in ssygst",calledby ="geneigprobl")
toler = 2.0*TINY(toler)
liwork = 10*nsize
ALLOCATE ( iwork(liwork), stat=err )
IF (err/=0) CALL juDFT_error("error allocating iwork",calledby ="geneigprobl")
lwork = 26*nsize
ALLOCATE ( work(lwork), stat=err )
IF (err/=0) CALL juDFT_error(" error allocating work",calledby ="geneigprobl")
ALLOCATE ( isuppz(2*nsize), stat=err )
IF (err /= 0) CALL juDFT_error("error allocating isuppz",calledby ="geneigprobl")
IF (ALLOCATED(z_r)) THEN
IF (.NOT.(SIZE(z_r,1)==nbasfcn.AND.SIZE(z_r,2)==neigd)) DEALLOCATE(z_r)
ENDIF
IF (.NOT.ALLOCATED(z_r)) THEN
ALLOCATE ( z_r(nbasfcn,neigd), stat=err )
IF (err/=0) THEN
WRITE(*,*) nbasfcn,neigd,err
CALL juDFT_error("error allocating z",calledby ="geneigprobl")
ENDIF
ENDIF
sizez= SIZE(z_r,1)
iu = MIN(nsize,neigd)
IF (l_J) THEN
CALL CPP_LAPACK_ssyevr('N','I','U',nsize,largea_r, nsize,lb,ub,1,iu,toler,ne,eigTemp,z_r,&
sizez,isuppz,work,lwork,iwork,liwork,info)
ELSE
CALL CPP_LAPACK_ssyevr('V','I','U',nsize,largea_r,nsize,lb,ub,1,iu,toler,ne,eigTemp,z_r,&
sizez,isuppz,work,lwork,iwork,liwork,info)
ENDIF
IF (info /= 0) CALL juDFT_error("error in ssyevr",calledby ="geneigprobl")
DEALLOCATE (isuppz,work,iwork)
CALL CPP_LAPACK_strtrs('U','N','N',nsize,ne,largeb_r, nsize,z_r,sizez,info)
IF (info /= 0) CALL juDFT_error("error in strtrs",calledby ="geneigprobl")
ELSE
CALL CPP_LAPACK_cpotrf('U',nsize,largeb_c,nsize,info)
IF (info /= 0) CALL juDFT_error("error in cpotrf",calledby ="geneigprobl")
CALL CPP_LAPACK_chegst(1,'U',nsize,largea_c,nsize,largeb_c,nsize,info)
IF (info /= 0) CALL juDFT_error(" error in chegst",calledby ="geneigprobl")
toler = 2.0*TINY(toler)
liwork = 50*nsize
ALLOCATE ( iwork(liwork), stat=err )
IF (err/=0) CALL juDFT_error("error allocating iwork",calledby ="geneigprobl")
lwork = 20*nsize
ALLOCATE( cwork(lwork), stat=err )
IF (err/=0) CALL juDFT_error("error allocating cwork",calledby ="geneigprobl")
ALLOCATE( isuppz(10*nsize), stat=err )
IF (err/=0) CALL juDFT_error("error allocating isuppz",calledby ="geneigprobl")
lrwork = 84*nsize
ALLOCATE (work(lrwork), stat=err )
IF (err/=0) CALL juDFT_error(" error allocating work",calledby ="geneigprobl")
IF (ALLOCATED(z_c)) THEN
IF (.NOT.(SIZE(z_c,1)==nbasfcn.AND.SIZE(z_c,2)==neigd)) DEALLOCATE(z_c)
ENDIF
IF (.NOT.ALLOCATED(z_c)) THEN
ALLOCATE ( z_c(nbasfcn,neigd), stat=err )
IF (err/=0) THEN
WRITE(*,*) nbasfcn,neigd,err
CALL juDFT_error("error allocating z",calledby ="geneigprobl")
ENDIF
ENDIF
sizez= SIZE(z_c,1)
iu = MIN(nsize,neigd)
IF (l_J) THEN
CALL CPP_LAPACK_cheevr('N','I','U',nsize,largea_c, nsize,lb,ub,1,iu,toler,ne,eigTemp,z_c,&
sizez,isuppz,cwork,lwork,work,lrwork,iwork,liwork,info)
ELSE
CALL CPP_LAPACK_cheevr('V','I','U',nsize,largea_c, nsize,lb,ub,1,iu,toler,ne,eigTemp,z_c,&
sizez,isuppz,cwork,lwork,work,lrwork,iwork,liwork,info)
ENDIF
IF (info /= 0) CALL juDFT_error("error in cheevr",calledby ="geneigprobl")
DEALLOCATE ( isuppz )
DEALLOCATE ( work )
DEALLOCATE ( iwork )
DEALLOCATE ( cwork )
CALL CPP_LAPACK_ctrtrs('U','N','N',nsize,ne,largeb_c, nsize,z_c,sizez,info)
IF (info /= 0) CALL juDFT_error("error in ctrtrs",calledby ="geneigprobl")
ENDIF
DO i = 1, neigd
eig(i) = eigTemp(i)
END DO
END SUBROUTINE geneigprobl
END MODULE m_geneigprobl
This diff is collapsed.
This diff is collapsed.
!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Gruenberg Institut, Forschungszentrum Juelich, 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_packed_to_full
! Contains a service routine to expand a packed storage matrix to full storage
! A real and complex version is provided with a common interface
use m_juDFT
implicit none
private
interface packed_to_full
module procedure packed_to_full_r,packed_to_full_c
end interface packed_to_full
public packed_to_full
contains
subroutine packed_to_full_r(n,packed,full)
integer,intent(in) :: n
real,intent(in) :: packed(:)
real,allocatable,intent(out) :: full(:,:)
integer:: i,err,i1,i2
ALLOCATE ( full(n,n), stat=err )
if (err/=0) call judft_error("Allocation of full matrix failed",calledby="packed_to_full")
i=0
DO i1=1,n
DO i2=1,i1
i=i+1
full(i2,i1)=packed(i)
full(i1,i2)=packed(i)
ENDDO
ENDDO
end subroutine packed_to_full_r
subroutine packed_to_full_c(n,packed,full)
integer,intent(in) :: n
complex,intent(in) :: packed(:)
complex,allocatable,intent(out) :: full(:,:)
integer:: i,err,i1,i2
ALLOCATE ( full(n,n), stat=err )
if (err/=0) call judft_error("Allocation of full matrix failed",calledby="packed_to_full")
i=0
DO i1=1,n
DO i2=1,i1
i=i+1
full(i2,i1)=packed(i)
full(i1,i2)=conjg(packed(i))
ENDDO
ENDDO
end subroutine packed_to_full_c
end MODULE m_packed_to_full
This diff is collapsed.
This diff is collapsed.
!--------------------------------------------------------------------------------
! 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.
!--------------------------------------------------------------------------------
! NOTE: this contains only the interface, the actual code is included by the
! proprocessor from the file zsymsecloc_cpp.F90
!
MODULE m_zsymsecloc
use m_juDFT
!*******************************************************
! Solve the generalized secular equation.
! For film-systems exhibiting
! z-reflexion symmetry, the basis is transformed to
! even and odd functions and the even-even and odd-odd
! blocks are diagonalized separately.
! If local orbitals are present in a film with z-reflection,
! locrectify is used to construct linear combinations of
! the local orbitals that are eigenfunctions of the z-
! reflexion operation.
! Frank Freimuth, January 2006
!*******************************************************
INTERFACE zsymsecloc
MODULE procedure zsymsecloc_r,zsymsecloc_c
END INTERFACE zsymsecloc
CONTAINS
SUBROUTINE zsymsecloc_r(jsp,input,lapw,bkpt,atoms, kveclo, sym,l_zref,cell, dimension,matsize, nsize, jij,matind,nred,eig,ne, a,b, z)
#define CPP_REALDATA
#include "zsymsecloc_cpp.F90"
END SUBROUTINE zsymsecloc_r
SUBROUTINE zsymsecloc_c(jsp,input,lapw,bkpt,atoms, kveclo, sym,l_zref,cell, dimension,matsize, nsize, jij,matind,nred,eig,ne, a,b, z)
#undef CPP_REALDATA
#include "zsymsecloc_cpp.F90"
END SUBROUTINE zsymsecloc_c
END MODULE m_zsymsecloc
This diff is collapsed.
!--------------------------------------------------------------------------------
! 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_socinit
!--------------------------------------------------------------------------------
! 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_soinit
!
!**********************************************************************
! generates radial spin-orbit matrix elements:sorad
!**********************************************************************
!
CONTAINS
SUBROUTINE soinit(atoms,input,enpara, vr,spav,rsoc,usdus)
USE m_sorad
USE m_types
IMPLICIT NONE
TYPE(t_enpara),INTENT(IN) :: enpara
TYPE(t_input),INTENT(IN) :: input
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_usdus),INTENT(INOUT):: usdus
TYPE(t_rsoc),INTENT(INOUT) :: rsoc
!
! .. Scalar Arguments ..
! ..
! .. Scalar Arguments ..
LOGICAL, INTENT (IN) :: spav ! if T, spin-averaged pot is used
! ..
! .. Array Arguments ..
REAL, INTENT (IN) :: vr(:,0:,:,:) !(atoms%jmtd,0:sphhar%nlhd,atoms%ntype,dimension%jspd)
! ..
! .. Local Scalars ..
INTEGER i,jspin,n
! ..
! .. Local Arrays ..
REAL vr0(atoms%jmtd,size(vr,4))
! ..
rsoc%rsopp =0.0
rsoppd =0.0
rsopdp =0.0
rsopdpd=0.0
rsoplop =0.0
rsoplopd=0.0
rsopdplo=0.0
rsopplo=0.0
rsoploplop=0.0
DO n = 1,atoms%ntype
vr0=0.0
vr0(:atoms%jri(n),:) = vr(:atoms%jri(n),0,n,:)
CALL sorad(&
atoms,input,n,vr0,enpara,spav,&
rsopp,rsopdpd,rsoppd,rsopdp,usdus,&
rsoplop,rsoplopd,rsopdplo,rsopplo,rsoploplop)
END DO ! end-do-loop : atoms%ntype
END SUBROUTINE soinit
END MODULE m_soinit
This diff is collapsed.
module nvtx
! See https://devblogs.nvidia.com/parallelforall/customize-cuda-fortran-profiling-nvtx/
use iso_c_binding
implicit none
integer,private :: col(7) = [ Z'0000ff00', Z'000000ff', Z'00ffff00', Z'00ff00ff', Z'0000ffff', Z'00ff0000', Z'00ffffff']
character(len=256),private :: tempName
type, bind(C):: nvtxEventAttributes
integer(C_INT16_T):: version=1
integer(C_INT16_T):: size=48 !
integer(C_INT):: category=0
integer(C_INT):: colorType=1 ! NVTX_COLOR_ARGB = 1
integer(C_INT):: color
integer(C_INT):: payloadType=0 ! NVTX_PAYLOAD_UNKNOWN = 0
integer(C_INT):: reserved0
integer(C_INT64_T):: payload ! union uint,int,double
integer(C_INT):: messageType=1 ! NVTX_MESSAGE_TYPE_ASCII = 1
type(C_PTR):: message ! ascii char
end type
interface nvtxRangePush
! push range with custom label and standard color
subroutine nvtxRangePushA(name) bind(C, name='nvtxRangePushA')
use iso_c_binding
character(kind=C_CHAR,len=*) :: name
end subroutine
! push range with custom label and custom color
subroutine nvtxRangePushEx(event) bind(C, name='nvtxRangePushEx')
use iso_c_binding
import:: nvtxEventAttributes
type(nvtxEventAttributes):: event
end subroutine
end interface
interface nvtxRangePop
subroutine nvtxRangePop() bind(C, name='nvtxRangePop')
end subroutine
end interface
contains
subroutine nvtxStartRange(name,id)
character(kind=c_char,len=*) :: name
integer, optional:: id
type(nvtxEventAttributes):: event
tempName=trim(name)//c_null_char
if ( .not. present(id)) then
call nvtxRangePush(tempName)
else
event%color=col(mod(id,7)+1)
event%message=c_loc(tempName)
call nvtxRangePushEx(event)
end if
end subroutine
subroutine nvtxEndRange
call nvtxRangePop
end subroutine
end module nvtx
module m_eig66_parallel
#include "juDFT_env.h"
! Do the IO of the eig-file into memory, different from simple approach by
! using k-point parallelism
! The eig-file is split into four arrays:
! eig_int contains the basis-set information/integers (nv,nmat,ne,k1,k2,k3,kveclo)
! eig_real contains the basis-set information/real (el,evac,ello,bkpt,wtkpt)
! eig_eig contains the eigenvalues
! eig_vec contains the eigenvectors
! The record number is given by nrec=nk+(jspin-1)*nkpts
implicit none
INTEGER,ALLOCATABLE :: eig_int(:,:)
REAL,ALLOCATABLE :: eig_real(:,:)
REAL,ALLOCATABLE :: eig_eig(:,:)
REAL,ALLOCATABLE :: eig_vecr(:,:)
COMPLEX,ALLOCATABLE :: eig_vecc(:,:)
integer :: size_k,isize
INTEGER:: ntypes,lmax,nlo,jspins,nkpts
contains
subroutine open_eig(nmat,neig,nkpts_in,jspins_in,lmax_in,nlo_in,ntype_in,l_create,nlotot,l_noco)
INTEGER, INTENT(IN) :: nmat,neig,nkpts_in,jspins_in,nlo_in,ntype_in,lmax_in,nlotot
LOGICAL, INTENT(IN) :: l_noco,l_create
integer:: length,e
CALL MPI_COMM_SIZE(MPI_COMM_WORLD,isize,e)
if (mod(nkpts_in/isize).ne.0) call judft_error("Could not distribute k-points in eig66_parallel")
if (allocated(eig_int)) then
if (.not.l_create) return
call close_eig(.true.)
endif
ntypes=ntype_in
lmax=lmax_in
nlo=nlo_in
jspins=jspins_in
nkpts=nkpts_in/isize
!eig_int
length=3 !nv+nmat+ne
length=length+nmat*3 !k1,k2,k3
length=length+nlotot !kveclo
size_k=nmat
allocate(eig_int(length,jspins*nkpts))
!eig_real
length=3+1+2 !bk,wk,evac
length=length+lmax*ntypes !el
length=length+nlo*ntypes !ello
ALLOCATE(eig_real(length,jspins*nkpts))
!eig_eig
length=jspins
if (l_noco) length=1
allocate(eig_eig(neig,length*nkpts))
!eig_vec
#ifdef CPP_INVERSION
allocate(eig_vecr(nmat*neig,length*nkpts))
#ifdef CPP_SOC
call judft_error("SOC+INVERSION can not be used with eigenvalues stored in memory")
#endif
#else
allocate(eig_vecc(nmat*neig,length*nkpts))
#endif
end subroutine open_eig
subroutine close_eig(delete)
logical,intent(in),optional::delete
if (present(delete)) THEN
if (delete) THEN
if (allocated(eig_int)) deallocate(eig_int)
if (allocated(eig_real)) deallocate(eig_real)
if (allocated(eig_eig)) deallocate(eig_eig)
if (allocated(eig_vecr)) deallocate(eig_vecr)
if (allocated(eig_vecc)) deallocate(eig_vecc)
endif
endif
end subroutine close_eig
subroutine read_eig(nk,jspin,nv,nmat,k1,k2,k3,bk,wk,neig,eig,el,&
ello,evac,kveclo,n_start,n_end,zr,zc)
implicit none
INTEGER, INTENT(IN) :: nk,jspin
INTEGER, INTENT(OUT),OPTIONAL :: nv,nmat
INTEGER, INTENT(OUT),OPTIONAL :: neig
REAL, INTENT(OUT),OPTIONAL :: eig(:)
INTEGER, INTENT(OUT),OPTIONAL :: k1(:),k2(:),k3(:),kveclo(:)
REAL, INTENT(OUT),OPTIONAL :: evac(:),ello(:,:),el(:,:)
REAL, INTENT(OUT),OPTIONAL :: bk(:),wk
INTEGER, INTENT(IN),OPTIONAL :: n_start,n_end
REAL, INTENT(OUT),OPTIONAL :: zr(:,:)
COMPLEX, INTENT(OUT),OPTIONAL :: zc(:,:)
INTEGER::nrec
nrec=nk/isize+(jspin-1)*nkpts/isize+1
! data from eig_int
if (present(nv)) nv=eig_int(1,nrec)
if (present(nmat)) nmat=eig_int(2,nrec)
if (present(neig)) then
neig=eig_int(3,nrec)
endif
if (present(k1)) then
if (.not.present(k2).or..not.present(k3)) call juDFT_error("BUG: always read k1,k2,k3")
k1=eig_int(3+1:3+size_k,nrec)
k2=eig_int(3+size_k+1:3+2*size_k,nrec)
k3=eig_int(3+2*size_k+1:3+3*size_k,nrec)
endif
if (present(kveclo)) kveclo=eig_int(4+3*size_k:3+3*size_k+size(kveclo),nrec)
!data from eig_real
if (present(bk)) bk=eig_real(1:3,nrec)
if (present(wk)) wk=eig_real(4,nrec)
if (present(evac)) evac=eig_real(5:6,nrec)
if (present(el)) el=reshape(eig_real(7:7+size(el)-1,nrec),shape(el))
if (present(ello)) ello=reshape(eig_real(size(eig_real,1)-size(ello)+1:,nrec),shape(ello))
!data from eig_eig
if (present(eig)) THEN
eig=0.0
eig=eig_eig(:size(eig),nrec)
ENDIF
!data from eig_vec
if (present(zr)) then
write(*,*) "R-Z:",nrec,shape(zr)
if (.not.allocated(eig_vecr)) call juDFT_error("BUG: can not read real vectors from memory")
zr=reshape(eig_vecr(:size(zr),nrec),shape(zr))
endif
if (present(zc)) then
write(*,*) "R-ZC:",nrec,shape(zc)
if (.not.allocated(eig_vecc)) call juDFT_error("BUG: can not read complex vectors from memory")
zc=reshape(eig_vecc(:size(zc),nrec),shape(zc))
endif
end subroutine read_eig
subroutine write_eig(nk,jspin,neig,nv,nmat,k1,k2,k3,bk,wk, &
eig,el,ello,evac, &
nlotot,kveclo,n_size,n_rank,zr,zc)
INTEGER, INTENT(IN) :: nk,jspin
INTEGER, INTENT(IN),OPTIONAL :: n_size,n_rank
REAL, INTENT(IN),OPTIONAL :: wk
INTEGER, INTENT(IN),OPTIONAL :: neig,nv,nmat,nlotot
INTEGER, INTENT(IN),OPTIONAL :: k1(:),k2(:),k3(:),kveclo(:)
REAL, INTENT(IN),OPTIONAL :: bk(3),eig(:),el(:,:)
REAL, INTENT(IN),OPTIONAL :: evac(:),ello(:,:)
REAL, INTENT(IN),OPTIONAL :: zr(:,:)
COMPLEX,INTENT(IN),OPTIONAL :: zc(:,:)