### Deleted unused files, Fixes #177

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(:,:) <