Commit dd2e78bf authored by Daniel Wortmann's avatar Daniel Wortmann

Files missing for last commit

parent 45b7d160
!--------------------------------------------------------------------------------
! 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.
!--------------------------------------------------------------------------------
USE m_juDFT
USE elpa1
#ifdef CPP_ELPA2
USE elpa2
#endif
IMPLICIT NONE
INCLUDE 'mpif.h'
INTEGER, INTENT (IN) :: m,n
INTEGER, INTENT (IN) :: SUB_COMM
INTEGER, INTENT (INOUT) :: num
REAL, INTENT (OUT) :: eig(:)
CPP_REALCOMPLEX, ALLOCATABLE, INTENT (INOUT) :: a(:),b(:)
CPP_REALCOMPLEX, INTENT (OUT) :: z(:,:)
!
#include "elpa_cpp.F90"
END SUBROUTINE elpa_r
!... Local variables
!
INTEGER :: sc_desc(9) !SCALAPACK DESCRIPTOR
INTEGER :: np,nb,myid,npcol,nprow,mycol,myrow,myrowssca
INTEGER :: mycolssca,ictextblacs,mpi_comm_rows
INTEGER :: mpi_comm_cols
INTEGER :: num2
LOGICAL :: ok
INTEGER :: err,ierr
INTEGER :: i,k,n_col,n_row
! large distributed Matrices
REAL,ALLOCATABLE :: eig2(:)
CPP_REALCOMPLEX, ALLOCATABLE :: asca(:,:), bsca(:,:),tmp2(:,:)
CPP_REALCOMPLEX, ALLOCATABLE :: eigvec(:,:)
INTEGER, EXTERNAL :: numroc, indxl2g !SCALAPACK functions
CALL priv_create_blacsgrid(sub_comm,m, np,nb,myid,npcol,nprow,mycol,myrow,myrowssca,mycolssca,&
ictextblacs,sc_desc,mpi_comm_rows,mpi_comm_cols)
! Number of columns the local process gets in ScaLAPACK distribution
ALLOCATE ( asca(myrowssca,mycolssca), stat=err )
IF (err/=0) CALL juDFT_error("allocate asca", calledby="chani_elpa")
asca=0.0
ALLOCATE ( bsca(myrowssca,mycolssca), stat=err )
IF (err/=0) CALL juDFT_error("allocate bsca", calledby="chani_elpa")
bsca=0.0
!
! transfer to ScaLAPACK block cyclic 2d distribution with
! block-size nb
!
!print *,"Before subredist"
CALL subredist1(a,m,asca,myrowssca,SUB_COMM, nprow, npcol, myid, ierr, nb )
CALL subredist1(b,m,bsca,myrowssca,SUB_COMM, nprow, npcol, myid, ierr, nb )
! for saving memory one might deallocate(a,b)
!print *,"Before Allocate"
ALLOCATE ( eig2(m), stat=err ) ! The eigenvalue array for ScaLAPACK
IF (err.NE.0) CALL juDFT_error('Failed to allocated "eig2"', calledby ='elpa')
ALLOCATE ( eigvec(myrowssca,mycolssca), stat=err ) ! Eigenvectors for ScaLAPACK
IF (err.NE.0) CALL juDFT_error('Failed to allocated "eigvec"',calledby ='elpa')
ALLOCATE ( tmp2(myrowssca,mycolssca), stat=err ) ! tmp_array
IF (err.NE.0) CALL juDFT_error('Failed to allocated "tmp2"', calledby ='elpa')
!print *,"Before elpa"
!ELPA -start here
! Solve generalized problem
!
! 1. Calculate Cholesky factorization of Matrix B = U**T * U
! and invert triangular matrix U
!
! Please note: cholesky_complex/invert_trm_complex are not trimmed for speed.
! The only reason having them is that the Scalapack counterpart
! PDPOTRF very often fails on higher processor numbers for unknown reasons!
#ifdef CPP_ELPA_NEW
CALL CPP_CHOLESKY (m,bsca,SIZE(bsca,1),nb,mycolssca,mpi_comm_rows,mpi_comm_cols,.false.,ok)
CALL CPP_invert_trm(m,bsca,SIZE(bsca,1),nb,mycolssca,mpi_comm_rows,mpi_comm_cols,.false.,ok)
#else
CALL CPP_CHOLESKY (m,bsca,SIZE(bsca,1),nb, mpi_comm_rows,mpi_comm_cols)
CALL CPP_invert_trm(m, bsca, SIZE(bsca,1), nb, mpi_comm_rows, mpi_comm_cols)
#endif
! 2. Calculate U**-T * A * U**-1
! 2a. eigvec = U**-T * A
! A is only set in the upper half, solve_evp_real needs a full matrix
! Set lower half from upper half
CALL CPP_transpose (m,m,CPP_ONE,asca,1,1,sc_desc, CPP_ZERO,eigvec,1,1,sc_desc)
DO i=1,SIZE(asca,1)
! Get global column corresponding to i and number of local rows up to
! and including the diagonal, these are unchanged in A
n_col = indxl2g(i, nb, mycol, 0, npcol)
n_row = numroc (n_col, nb, myrow, 0, nprow)
asca(n_row+1:myrowssca,i) = eigvec(n_row+1:myrowssca,i)
ENDDO
CALL CPP_mult ('U', 'L',m, m,bsca,myrowssca,asca,SIZE(asca,1),nb, mpi_comm_rows, mpi_comm_cols,eigvec,myrowssca)
! 2b. tmp2 = eigvec**T
CALL CPP_transpose(m,m,CPP_ONE,eigvec,1,1,sc_desc,CPP_ZERO,tmp2,1,1,sc_desc)
! 2c. A = U**-T * tmp2 ( = U**-T * Aorig * U**-1 )
CALL CPP_mult ('U', 'U', m, m, bsca, SIZE(bsca,1), tmp2,&
SIZE(tmp2,1),nb, mpi_comm_rows, mpi_comm_cols, asca, SIZE(asca,1))
! A is only set in the upper half, solve_evp_real needs a full matrix
! Set lower half from upper half
CALL CPP_transpose(m,m,CPP_ONE,asca,1,1,sc_desc, CPP_ZERO,eigvec,1,1,sc_desc)
DO i=1,SIZE(asca,1)
! Get global column corresponding to i and number of local rows up to
! and including the diagonal, these are unchanged in A
n_col = indxl2g(i, nb, mycol, 0, npcol)
n_row = numroc (n_col, nb, myrow, 0, nprow)
asca(n_row+1:myrowssca,i) = eigvec(n_row+1:myrowssca,i)
ENDDO
! 3. Calculate eigenvalues/eigenvectors of U**-T * A * U**-1
! Eigenvectors go to eigvec
num2=num
#ifdef CPP_ELPA_NEW
#ifdef CPP_ELPA2
err=CPP_solve_evp_2stage(m,num2,asca,SIZE(asca,1),&
eig2,eigvec,SIZE(asca,1), nb,mycolssca, mpi_comm_rows, mpi_comm_cols,sub_comm)
#else
err=CPP_solve_evp(m, num2,asca,SIZE(asca,1),&
eig2,eigvec, SIZE(asca,1), nb,mpi_comm_rows, mpi_comm_cols)
#endif
#else
#ifdef CPP_ELPA2
CALL CPP_solve_evp_2stage(m,&
num2,asca,SIZE(asca,1),eig2,eigvec,SIZE(asca,1), nb,mpi_comm_rows, mpi_comm_cols,sub_comm)
#else
CALL CPP_solve_evp(m, num2,&
asca,SIZE(asca,1),eig2,eigvec, SIZE(asca,1), nb,mpi_comm_rows, mpi_comm_cols)
#endif
#endif
! 4. Backtransform eigenvectors: Z = U**-1 * eigvec
! mult_ah_b_complex needs the transpose of U**-1, thus tmp2 = (U**-1)**T
CALL CPP_transpose(m,m,CPP_ONE,bsca,1,1,sc_desc,CPP_ZERO,tmp2,1,1,sc_desc)
CALL CPP_mult ('L', 'N',m, num2, tmp2, SIZE(asca,1),&
eigvec, SIZE(asca,1),nb,mpi_comm_rows, mpi_comm_cols, asca, SIZE(asca,1))
! END of ELPA stuff
CALL BLACS_GRIDEXIT(ictextblacs,ierr)
CALL MPI_COMM_FREE(mpi_comm_rows,ierr)
CALL MPI_COMM_FREE(mpi_comm_cols,ierr)
!print *,"elpa done"
!
! Put those eigenvalues expected by chani to eig, i.e. for
! process i these are eigenvalues i+1, np+i+1, 2*np+i+1...
! Only num=num2/np eigenvalues per process
!
num=FLOOR(REAL(num2)/np)
IF (myid.LT.num2-(num2/np)*np) num=num+1
k=1
DO i=myid+1,num2,np
eig(k)=eig2(i)
k=k+1
ENDDO
!write(*,"(a,i5,99f10.4)") "ELPA:",myid,eig
!
! Redistribute eigvec from ScaLAPACK distribution to each process
! having all eigenvectors corresponding to his eigenvalues as above
!
CALL subredist2(z,m,num2,asca,myrowssca,SUB_COMM,nprow,npcol, myid,ierr,nb)
!
DEALLOCATE ( asca )
DEALLOCATE ( bsca )
DEALLOCATE (eigvec, tmp2, eig2)
!--------------------------------------------------------------------------------
! 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
!--------------------------------------------------------------------------------
! 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.
!--------------------------------------------------------------------------------
! This file is included in zsymsecloc.F90 twice with CPP_REALDATA set and unset
! to create both code for real and complex
#include"cpp_double.h"
USE m_locrectify
USE m_geneigprobl
USE m_types
IMPLICIT NONE
TYPE(t_dimension),INTENT(IN) :: dimension
TYPE(t_input),INTENT(IN) :: input
TYPE(t_jij),INTENT(IN) :: jij
TYPE(t_sym),INTENT(IN) :: sym
TYPE(t_cell),INTENT(IN) :: cell
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_lapw),INTENT(IN) :: lapw
real,intent(in) ::bkpt(3)
integer,intent(in)::kveclo(atoms%nlotot)
! ..
! .. Scalar Arguments ..
INTEGER, INTENT (IN) :: matsize,jsp
INTEGER, INTENT (INOUT) :: nsize
INTEGER, INTENT (OUT) :: ne
INTEGER, INTENT (IN) :: nred
! ..
! .. Array Arguments ..
INTEGER, INTENT (IN) :: matind(dimension%nbasfcn,2)
REAL, INTENT (OUT) :: eig(dimension%neigd)
#ifdef CPP_REALDATA
REAL, ALLOCATABLE, INTENT (INOUT) :: a(:),b(:)
REAL, ALLOCATABLE, INTENT (INOUT) :: z(:,:)
#else
COMPLEX, ALLOCATABLE, INTENT (INOUT)::a(:),b(:)
COMPLEX, ALLOCATABLE, INTENT (INOUT) :: z(:,:)
#endif
#ifdef CPP_REALDATA
real locrec(atoms%nlotot,atoms%nlotot)
real,allocatable::atemp(:,:)
real,allocatable::btemp(:,:)
real,allocatable::aa(:)
real,allocatable::bb(:)
real,allocatable::z1(:,:)
real,allocatable::z2(:,:)
real,allocatable::ztemp(:,:)
real recsqrtwo,dobzero
#else
complex locrec(atoms%nlotot,atoms%nlotot)
complex,allocatable:: atemp(:,:)
complex,allocatable:: btemp(:,:)
complex,allocatable::aa(:)
complex,allocatable::bb(:)
complex,allocatable::z1(:,:)
complex,allocatable::z2(:,:)
complex,allocatable::ztemp(:,:)
complex recsqrtwo,dobzero
#endif
logical l_verbose
logical kindlocrec(atoms%nlotot)
real,allocatable::etemp1(:),etemp2(:)
integer iind,jind,ii,info,iu,pos1,pos2,pos3,i2,j2
integer ne1,ne2,i1,j1,i,jg,j
logical,allocatable:: evensort(:)
integer evenlocs,oddlocs
integer evenlocindex(atoms%nlotot)
integer oddlocindex(atoms%nlotot)
! print*,"in zsymsecloc"
deallocate(z)
!******************************************
! l_zref=.false. => simply call eigensolver
!******************************************
if(.not.sym%l_zref)then
#ifdef CPP_REALDATA
call geneigprobl(dimension%nbasfcn, nsize,dimension%neigd,jij%l_j,eig,ne,a,b,z)
#else
call geneigprobl(dimension%nbasfcn, nsize,dimension%neigd,jij%l_j,eig,ne,a_c=a,b_c=b,z_c=z)
#endif
allocate(a(dimension%nbasfcn*(dimension%nbasfcn+1)/2))
allocate(b(dimension%nbasfcn*(dimension%nbasfcn+1)/2))
return
!******************************************
! l_zref=.true. => blockdiagonalize
! hamiltonian and overlap-matrix by
! transforming to even/odd basisfunctions
!******************************************
else
inquire(file='verbose',exist=l_verbose)
if(.not.l_verbose)inquire(file='veryverbose',exist=l_verbose)
iu=dimension%neigd/2
#ifdef CPP_REALDATA
recsqrtwo=1.0/sqrt(2.0)
dobzero=0.0
#else
recsqrtwo=cmplx(1.0/sqrt(2.0),0.0)
dobzero=cmplx(0.0,0.0)
#endif
if(atoms%nlotot.gt.0)then
!*********************************************
! Find even/odd linear combinations of locs
!*********************************************
if(l_verbose)then
print*,"find lincos of locs that are eigenfunctions of zreflection"
print*,"apws=",lapw%nv(jsp)
print*,"atoms%nlotot=",atoms%nlotot
print*,"basis-size=",nsize
endif
IF(nsize/=(lapw%nv(jsp)+atoms%nlotot)) &
CALL juDFT_error("nsize /= lapw%nv + atoms%nlotot" ,calledby ="zsymsecloc")
#ifdef CPP_REALDATA
call locrectify(jsp,input,lapw,bkpt,atoms, kveclo, sym,cell,&
kindlocrec,evenlocs,oddlocs, evenlocindex,oddlocindex,locrec)
#else
call locrectify(jsp,input,lapw,bkpt,atoms, kveclo, sym,cell,&
kindlocrec,evenlocs,oddlocs, evenlocindex,oddlocindex,locrec_c=locrec)
#endif
!*********************************************
! Perform basis-transformation of Hamiltonian
! and Overlap matrix. The new basis is the basis
! of even / odd (with respect to z-reflection)
! local orbitals.
!*********************************************
allocate(atemp(lapw%nv(jsp),atoms%nlotot))
allocate(btemp(atoms%nlotot,lapw%nv(jsp)))
do iind=1,atoms%nlotot
pos1=((lapw%nv(jsp)+iind)*(lapw%nv(jsp)+iind-1))/2
atemp(1:lapw%nv(jsp),iind)=a(pos1+1:pos1+lapw%nv(jsp))
enddo
#ifdef CPP_REALDATA
call CPP_BLAS_sgemm('T','T',atoms%nlotot,lapw%nv(jsp),atoms%nlotot,real(1.0),&
locrec,atoms%nlotot,atemp,lapw%nv(jsp),real(0.0),btemp,atoms%nlotot)
#else
call CPP_BLAS_cgemm('C','T',atoms%nlotot,lapw%nv(jsp),atoms%nlotot,cmplx(1.0,0.0),&
locrec,atoms%nlotot,atemp,lapw%nv(jsp),cmplx(0.0,0.0),btemp,atoms%nlotot)
#endif
atemp(:,:) = transpose(btemp)
do iind=1,atoms%nlotot
pos1=((lapw%nv(jsp)+iind)*(lapw%nv(jsp)+iind-1))/2
a(pos1+1:pos1+lapw%nv(jsp))=atemp(1:lapw%nv(jsp),iind)
enddo
do iind=1,atoms%nlotot
pos1=((lapw%nv(jsp)+iind)*(lapw%nv(jsp)+iind-1))/2
atemp(1:lapw%nv(jsp),iind)=b(pos1+1:pos1+lapw%nv(jsp))
enddo
#ifdef CPP_REALDATA
call CPP_BLAS_sgemm('T','T',atoms%nlotot,lapw%nv(jsp),atoms%nlotot,real(1.0),&
locrec,atoms%nlotot,atemp,lapw%nv(jsp),real(0.0),btemp,atoms%nlotot)
#else
call CPP_BLAS_cgemm('C','T',atoms%nlotot,lapw%nv(jsp),atoms%nlotot,cmplx(1.0,0.0),&
locrec,atoms%nlotot,atemp,lapw%nv(jsp),cmplx(0.0,0.0),btemp,atoms%nlotot)
#endif
atemp(:,:) = transpose(btemp)
do iind=1,atoms%nlotot
pos1=((lapw%nv(jsp)+iind)*(lapw%nv(jsp)+iind-1))/2
b(pos1+1:pos1+lapw%nv(jsp))=atemp(1:lapw%nv(jsp),iind)
enddo
deallocate(atemp)
deallocate(btemp)
allocate(atemp(atoms%nlotot,atoms%nlotot))
allocate(btemp(atoms%nlotot,atoms%nlotot))
do iind=1,atoms%nlotot
pos1=((lapw%nv(jsp)+iind)*(lapw%nv(jsp)+iind-1))/2
do jind=1,iind-1
atemp(iind,jind)=a(pos1+lapw%nv(jsp)+jind)
#ifdef CPP_REALDATA
atemp(jind,iind)=a(pos1+lapw%nv(jsp)+jind)
#else
atemp(jind,iind)=conjg(a(pos1+lapw%nv(jsp)+jind))
#endif
enddo
atemp(iind,iind)=a(pos1+lapw%nv(jsp)+iind)
enddo
#ifdef CPP_REALDATA
call CPP_BLAS_sgemm('T','N',atoms%nlotot,atoms%nlotot,atoms%nlotot,real(1.0),&
locrec,atoms%nlotot,atemp,atoms%nlotot,real(0.0),btemp,atoms%nlotot)
call CPP_BLAS_sgemm('N','N',atoms%nlotot,atoms%nlotot,atoms%nlotot,real(1.0),&
btemp,atoms%nlotot,locrec,atoms%nlotot,real(0.0),atemp,atoms%nlotot)
#else
call CPP_BLAS_cgemm('C','N',atoms%nlotot,atoms%nlotot,atoms%nlotot,cmplx(1.0,0.0),&
locrec,atoms%nlotot,atemp,atoms%nlotot,cmplx(0.0,0.0),btemp,atoms%nlotot)
call CPP_BLAS_cgemm('N','N',atoms%nlotot,atoms%nlotot,atoms%nlotot,cmplx(1.0,0.0),&
btemp,atoms%nlotot,locrec,atoms%nlotot,cmplx(0.0,0.0),atemp,atoms%nlotot)
#endif
do iind=1,atoms%nlotot
pos1=((lapw%nv(jsp)+iind)*(lapw%nv(jsp)+iind-1))/2
do jind=1,iind
a(pos1+lapw%nv(jsp)+jind)=atemp(iind,jind)
enddo
enddo
do iind=1,atoms%nlotot
pos1=((lapw%nv(jsp)+iind)*(lapw%nv(jsp)+iind-1))/2
do jind=1,iind-1
atemp(iind,jind)=b(pos1+lapw%nv(jsp)+jind)
#ifdef CPP_REALDATA
atemp(jind,iind)=b(pos1+lapw%nv(jsp)+jind)
#else
atemp(jind,iind)=conjg(b(pos1+lapw%nv(jsp)+jind))
#endif
enddo
atemp(iind,iind)=b(pos1+lapw%nv(jsp)+iind)
enddo
#ifdef CPP_REALDATA
call CPP_BLAS_sgemm('T','N',atoms%nlotot,atoms%nlotot,atoms%nlotot,real(1.0),&
locrec,atoms%nlotot,atemp,atoms%nlotot,real(0.0),btemp,atoms%nlotot)
call CPP_BLAS_sgemm('N','N',atoms%nlotot,atoms%nlotot,atoms%nlotot,real(1.0),&
btemp,atoms%nlotot,locrec,atoms%nlotot,real(0.0),atemp,atoms%nlotot)
#else
call CPP_BLAS_cgemm('C','N',atoms%nlotot,atoms%nlotot,atoms%nlotot,cmplx(1.0,0.0),&
locrec,atoms%nlotot,atemp,atoms%nlotot,cmplx(0.0,0.0),btemp,atoms%nlotot)
call CPP_BLAS_cgemm('N','N',atoms%nlotot,atoms%nlotot,atoms%nlotot,cmplx(1.0,0.0),&
btemp,atoms%nlotot,locrec,atoms%nlotot,cmplx(0.0,0.0),atemp,atoms%nlotot)
#endif
do iind=1,atoms%nlotot
pos1=((lapw%nv(jsp)+iind)*(lapw%nv(jsp)+iind-1))/2
do jind=1,iind
b(pos1+lapw%nv(jsp)+jind)=atemp(iind,jind)
enddo
enddo
deallocate(atemp)
deallocate(btemp)
else
evenlocs=0
oddlocs=0
endif ! atoms%nlotot.gt.0
!*********************************************
! Test matind.
!*********************************************
ii=0
jind=0
pos1=0
do iind=1,nred
IF(matind(iind,1)<matind(iind,2)) CALL juDFT_error("mat1mat2" ,calledby ="zsymsecloc")
IF(matind(iind,1)<pos1) CALL juDFT_error("matpos1",calledby ="zsymsecloc")
pos1=matind(iind,1)
if(matind(iind,1).ne.matind(iind,2))then
ii=ii+1
else
jind=jind+1
endif
enddo
IF(2*ii+jind/=lapw%nv(jsp)) CALL juDFT_error("matind",calledby="zsymsecloc")
!*****************************************************************
!Transform into representation with even-even- and odd-odd-blocks.
!First step: Transform the lapw-lapw-part.
!*****************************************************************
allocate( aa( ((nred+evenlocs)*(nred+evenlocs+1))/2 ) )
allocate( bb( ((nred+evenlocs)*(nred+evenlocs+1))/2 ) )
i2=0
j2=0
DO i=1,nred
DO j=1,i
i1=(matind(i,1)-1)*matind(i,1)/2+matind(j,1)
j1=(matind(i,1)-1)*matind(i,1)/2+matind(j,2)
i2=i2+1
aa(i2)=a(i1)+a(j1)
bb(i2)=b(i1)+b(j1)
IF ((matind(i,1).NE.matind(i,2)).AND. (matind(j,1).NE.matind(j,2))) THEN
j2=j2+1
a(j2)=a(i1)-a(j1)
b(j2)=b(i1)-b(j1)
ENDIF
ENDDO
ENDDO
if(atoms%nlotot.gt.0)then
!******************************************************
!the lapw-lo- and lo-lo-parts for the even-even-block.
!******************************************************
allocate(atemp(lapw%nv(jsp),atoms%nlotot))
allocate(btemp(nred,evenlocs))
!hamiltonian
do iind=1,atoms%nlotot
pos1=((lapw%nv(jsp)+iind)*(lapw%nv(jsp)+iind-1))/2
atemp(1:lapw%nv(jsp),iind)=a(pos1+1:pos1+lapw%nv(jsp))
enddo
do jind=1,evenlocs
do iind=1,nred
btemp(iind,jind)=(atemp(matind(iind,1),evenlocindex(jind))&
+atemp(matind(iind,2),evenlocindex(jind)))*recsqrtwo
enddo
enddo
do iind=1,evenlocs
pos1=((nred+iind)*(nred+iind-1))/2
aa(pos1+1:pos1+nred)=btemp(1:nred,iind)
enddo
!metric
do iind=1,atoms%nlotot
pos1=((lapw%nv(jsp)+iind)*(lapw%nv(jsp)+iind-1))/2
atemp(1:lapw%nv(jsp),iind)=b(pos1+1:pos1+lapw%nv(jsp))
enddo
do jind=1,evenlocs
do iind=1,nred
btemp(iind,jind)=(atemp(matind(iind,1),evenlocindex(jind))&
+atemp(matind(iind,2),evenlocindex(jind)))*recsqrtwo
enddo
enddo
do iind=1,evenlocs
pos1=((nred+iind)*(nred+iind-1))/2
bb(pos1+1:pos1+nred)=btemp(1:nred,iind)
enddo
deallocate(btemp)
deallocate(atemp)
!hamiltonian
do iind=1,evenlocs
do jind=1,iind
pos1=((lapw%nv(jsp)+evenlocindex(iind))*(lapw%nv(jsp)+evenlocindex(iind)-1))/2
pos2=((nred+iind)*(nred+iind-1))/2
aa(pos2+nred+jind)=a(pos1+lapw%nv(jsp)+evenlocindex(jind))
enddo
enddo
!metric
do iind=1,evenlocs
do jind=1,iind
pos1=((lapw%nv(jsp)+evenlocindex(iind))*(lapw%nv(jsp)+evenlocindex(iind)-1))/2
pos2=((nred+iind)*(nred+iind-1))/2
bb(pos2+nred+jind)=b(pos1+lapw%nv(jsp)+evenlocindex(jind))
enddo
enddo
!******************************************************
!the lapw-lo- and lo-lo-parts for the odd-odd-block
!******************************************************
allocate(atemp(lapw%nv(jsp),atoms%nlotot))
allocate(btemp(lapw%nv(jsp)-nred,oddlocs))