diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 4adffb484..4d850d6f2 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -3,7 +3,9 @@ name: CI on: pull_request: push: - + branches: + - develop + jobs: pre-commit: runs-on: ubuntu-20.04 @@ -47,7 +49,8 @@ jobs: else cp ./.github/workflows/config/make.inc.gfort ./make.inc fi - make -j default w90chk2chk libs + #make -j default w90chk2chk libs + make all - name: run tests env: W90BINARYPARALLEL: ${{ matrix.w90-binary-parallel }} diff --git a/.gitignore b/.gitignore index 504bb9297..4e7318d5a 100644 --- a/.gitignore +++ b/.gitignore @@ -5,6 +5,7 @@ make.inc w90chk2chk.x w90spn2spn.x libwannier.a +libwan2.a libwannier.so libwannier.dylib *~ diff --git a/Makefile b/Makefile index a9af35772..a6e0e1e8b 100644 --- a/Makefile +++ b/Makefile @@ -24,22 +24,19 @@ all: wannier lib post w90chk2chk w90pov w90vdw w90spn2spn doc: thedoc -serialobjs: objdir - (cd $(ROOTDIR)/src/obj && $(MAKE) -f $(REALMAKEFILE) serialobjs) - -w90chk2chk: objdir serialobjs +w90chk2chk: objdir (cd $(ROOTDIR)/src/obj && $(MAKE) -f $(REALMAKEFILE) w90chk2chk) -w90spn2spn: objdir serialobjs +w90spn2spn: objdir (cd $(ROOTDIR)/src/obj && $(MAKE) -f $(REALMAKEFILE) w90spn2spn) -wannier: objdir serialobjs +wannier: objdir (cd $(ROOTDIR)/src/obj && $(MAKE) -f $(REALMAKEFILE) wannier) -lib: objdir serialobjs +lib: objdir (cd $(ROOTDIR)/src/obj && $(MAKE) -f $(REALMAKEFILE) libs) -dynlib: objdir serialobjs +dynlib: objdir (cd $(ROOTDIR)/src/obj && $(MAKE) -f $(REALMAKEFILE) dynlibs) w90pov: @@ -50,8 +47,8 @@ w90vdw: libs: lib -post: objdirp - (cd $(ROOTDIR)/src/objp && $(MAKE) -f $(REALMAKEFILE) post) +post: objdir + (cd $(ROOTDIR)/src/obj && $(MAKE) -f $(REALMAKEFILE) post) clean: cd $(ROOTDIR) && rm -f *~ @@ -61,11 +58,6 @@ clean: $(MAKE) -f $(REALMAKEFILE) clean && \ cd ../ && rm -rf obj ; \ fi ) - @( cd $(ROOTDIR) && if [ -d src/objp ] ; \ - then cd src/objp && \ - $(MAKE) -f $(REALMAKEFILE) clean && \ - cd ../ && rm -rf objp ; \ - fi ) $(MAKE) -C $(ROOTDIR)/doc/user_guide clean $(MAKE) -C $(ROOTDIR)/doc/tutorial clean $(MAKE) -C $(ROOTDIR)/utility/w90pov clean @@ -73,7 +65,7 @@ clean: cd $(ROOTDIR)/test-suite && ./clean_tests veryclean: clean - cd $(ROOTDIR) && rm -f wannier90.x postw90.x libwannier.a w90chk2chk.x w90spn2spn.x + cd $(ROOTDIR) && rm -f wannier90.x postw90.x libwannier.a libwan2.a w90chk2chk.x w90spn2spn.x cd $(ROOTDIR)/doc && rm -f user_guide.pdf tutorial.pdf cd $(ROOTDIR)/doc/user_guide && rm -f user_guide.ps cd $(ROOTDIR)/doc/tutorial && rm -f tutorial.ps @@ -212,9 +204,4 @@ objdir: then mkdir src/obj ; \ fi ) ; -objdirp: - @( cd $(ROOTDIR) && if [ ! -d src/objp ] ; \ - then mkdir src/objp ; \ - fi ) ; - -.PHONY: wannier default all doc lib libs post clean veryclean thedoc dist test-serial test-parallel dist-lite objdir objdirp serialobjs tests w90spn2spn install +.PHONY: wannier default all doc lib libs post clean veryclean thedoc dist test-serial test-parallel dist-lite objdir objdirp tests w90spn2spn install diff --git a/README.install b/README.install index 3922601d2..a3dc9dd2a 100644 --- a/README.install +++ b/README.install @@ -85,6 +85,28 @@ non-optimised BLAS. http://www.netlib.org/lapack/ +Parallel builds +--------------- + + wannier90.x and postw90.x both support parallel execution using MPI. wannier90 + is paralellised over k-points: gamma-only mode is not currently parallelised. + + There are three common ways for using MPI with fortran: + 1. "use mpi_f08" uses a complete fortran08 interface with custom types, this + allows detailed checking of arguments in MPI function calls + 2. "use mpi" uses a fortran90 style interface, limited checking + 3. "include 'mpif.h'" uses a legacy interface, no checking at all + + Methods 1 and 2 require module files built by the same version of compiler that + is to be used to compile wannier90. + + The specific interface to be used must be chosen by setting COMMS in make.inc + to one of "mpi08", "mpi90" or "mpih" (plain "mpi" is the same as "mpi90"). + + Particularly when wannier90 is to be used in library mode, the MPI interface + specified by COMMS must be the same as that used in the calling code; otherwise + using the fortran08 is recommended. + Linux x86,x86-64 ---------------- diff --git a/src/Makefile.2 b/src/Makefile.2 index 391435530..94a7565bc 100644 --- a/src/Makefile.2 +++ b/src/Makefile.2 @@ -4,7 +4,7 @@ include ../../make.inc -# Contains definition of OBJS, OBJSLIB, OBJS_POST, LIBRARY, DYNLIBRARY +# Contains definition of OBJS, OBJS_POST, LIBRARY, DYNLIBRARY include ../Makefile.header POSTDIR = ../postw90/ @@ -15,8 +15,18 @@ else COMMS = serial endif -ifeq ($(COMMS),mpi) -TEMP1 = -DMPI +ifeq ($(COMMS),mpi08) +TEMP1 = -DMPI -DMPI08 +TEMP2 = $(MPIF90) +else ifeq ($(COMMS),mpih) +TEMP1 = -DMPI -DMPIH +TEMP2 = $(MPIF90) +else ifeq ($(COMMS),mpi90) +TEMP1 = -DMPI -DMPI90 +TEMP2 = $(MPIF90) +else ifeq ($(COMMS),mpi) +# default to f90 style "use mpi" +TEMP1 = -DMPI -DMPI90 TEMP2 = $(MPIF90) else TEMP1 = @@ -24,23 +34,24 @@ TEMP2 = $(F90) endif -wannier libs dynlibs w90chk2chk serialobjs w90spn2spn: POSTOPTS = $(TEMP1) -wannier libs dynlibs w90chk2chk serialobjs w90spn2spn: COMPILER = $(TEMP2) +wannier libs dynlibs w90chk2chk w90spn2spn: POSTOPTS = $(TEMP1) +wannier libs dynlibs w90chk2chk w90spn2spn: COMPILER = $(TEMP2) wannier: ../../wannier90.x w90chk2chk: ../../w90chk2chk.x w90spn2spn: ../../w90spn2spn.x -serialobjs: $(OBJS) - ../../w90chk2chk.x: $(OBJS) ../w90chk2chk.F90 - $(COMPILER) ../w90chk2chk.F90 $(LDOPTS) $(OBJS) $(LIBS) -o ../../w90chk2chk.x + $(COMPILER) $(POSTOPTS) ../w90chk2chk.F90 $(LDOPTS) $(OBJS) $(LIBS) -o ../../w90chk2chk.x ../../w90spn2spn.x: $(OBJS) ../w90spn2spn.F90 - $(COMPILER) ../w90spn2spn.F90 $(LDOPTS) $(OBJS) $(LIBS) -o ../../w90spn2spn.x + $(COMPILER) $(POSTOPTS) ../w90spn2spn.F90 $(LDOPTS) $(OBJS) $(LIBS) -o ../../w90spn2spn.x -../../wannier90.x: $(OBJS) ../wannier_prog.F90 - $(COMPILER) ../wannier_prog.F90 $(POSTOPTS) $(LDOPTS) $(OBJS) $(LIBS) -o ../../wannier90.x +../../wannier90.x: $(LIBRARYV2) ../wannier_prog.F90 + $(COMPILER) ../wannier_prog.F90 $(POSTOPTS) $(LDOPTS) $(LIBRARYV2) $(LIBS) -o ../../wannier90.x +$(LIBRARYV2): $(OBJS) + $(AR) $(ARFLAGS) $(LIBRARYV2) $(OBJS) + post: POSTOPTS = $(TEMP1) post: COMPILER = $(TEMP2) post: mpi_test ../../postw90.x @@ -68,16 +79,16 @@ endif -libs: $(LIBRARY) +libs: $(LIBRARY) $(LIBRARYV2) dynlibs: $(DYNLIBRARY) -$(LIBRARY): $(OBJS) $(OBJSLIB) - $(AR) $(ARFLAGS) $(LIBRARY) $(OBJSLIB) $(OBJS) +$(LIBRARY): $(OBJS) $(OBJS_LIBV1) + $(AR) $(ARFLAGS) $(LIBRARY) $(OBJS) $(OBJS_LIBV1) -$(DYNLIBRARY): $(OBJS) $(OBJSLIB) +$(DYNLIBRARY): $(OBJS) $(OBJS) $(OBJS_LIBV1) echo $(COMPILER) - $(COMPILER) $(SHAREDLIBFLAGS) $(POSTOPTS) $(LDOPTS) $(OBJS) $(OBJSLIB) $(LIBS) -o $@ + $(COMPILER) $(SHAREDLIBFLAGS) $(POSTOPTS) $(LDOPTS) $(OBJS) $(OBJS_LIBV1) $(LIBS) -o $@ clean: rm -f *.o *.mod *.MOD *.obj @@ -85,83 +96,102 @@ clean: constants.o: ../constants.F90 $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../constants.F90 -io.o: ../io.F90 constants.o +comms-abort.o: ../comms-abort.F90 ../../make.inc + $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../comms-abort.F90 + +io.o: ../io.F90 constants.o comms-abort.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../io.F90 utility.o: ../utility.F90 constants.o io.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../utility.F90 -parameters.o: ../parameters.F90 constants.o io.o utility.o comms.o - $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../parameters.F90 +wannier90_types.o: ../wannier90_types.F90 constants.o io.o + $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../wannier90_types.F90 -hamiltonian.o: ../hamiltonian.F90 ws_distance.o constants.o io.o utility.o parameters.o +wannier90_readwrite.o: ../wannier90_readwrite.F90 constants.o io.o types.o wannier90_types.o readwrite.o + $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../wannier90_readwrite.F90 + +readwrite.o: ../readwrite.F90 types.o constants.o io.o utility.o comms.o + $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../readwrite.F90 + +types.o: ../types.F90 constants.o io.o utility.o comms.o + $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../types.F90 + +hamiltonian.o: ../hamiltonian.F90 ws_distance.o constants.o io.o utility.o types.o wannier90_types.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../hamiltonian.F90 -overlap.o: ../overlap.F90 constants.o io.o utility.o parameters.o sitesym.o +overlap.o: ../overlap.F90 constants.o io.o utility.o types.o sitesym.o wannier90_types.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../overlap.F90 -kmesh.o: ../kmesh.F90 constants.o io.o utility.o parameters.o +kmesh.o: ../kmesh.F90 constants.o io.o utility.o types.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../kmesh.F90 -disentangle.o: ../disentangle.F90 constants.o io.o parameters.o sitesym.o comms.o +disentangle.o: ../disentangle.F90 constants.o io.o types.o sitesym.o comms.o wannier90_types.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../disentangle.F90 -wannierise.o: ../wannierise.F90 hamiltonian.o constants.o io.o utility.o parameters.o sitesym.o comms.o +wannierise.o: ../wannierise.F90 hamiltonian.o constants.o io.o utility.o types.o sitesym.o comms.o wannier90_types.o wannier90_readwrite.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../wannierise.F90 -plot.o: ../plot.F90 constants.o io.o utility.o parameters.o hamiltonian.o ws_distance.o comms.o +plot.o: ../plot.F90 constants.o io.o utility.o types.o hamiltonian.o ws_distance.o wannier90_types.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../plot.F90 -ws_distance.o: ../ws_distance.F90 constants.o io.o parameters.o +ws_distance.o: ../ws_distance.F90 constants.o io.o types.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../ws_distance.F90 -transport.o: ../transport.F90 constants.o io.o parameters.o hamiltonian.o +transport.o: ../transport.F90 constants.o io.o types.o hamiltonian.o wannier90_types.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../transport.F90 -sitesym.o : ../sitesym.F90 utility.o parameters.o constants.o +sitesym.o : ../sitesym.F90 utility.o types.o constants.o wannier90_types.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../sitesym.F90 -comms.o: ../comms.F90 constants.o io.o +comms.o: ../comms.F90 constants.o io.o ../../make.inc $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../comms.F90 -boltzwann.o: $(POSTDIR)boltzwann.F90 constants.o parameters.o io.o utility.o postw90_common.o get_oper.o wan_ham.o comms.o spin.o dos.o +boltzwann.o: $(POSTDIR)boltzwann.F90 constants.o types.o io.o utility.o postw90_common.o get_oper.o wan_ham.o comms.o spin.o dos.o postw90_types.o ws_distance.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c $(POSTDIR)boltzwann.F90 -geninterp.o: $(POSTDIR)geninterp.F90 constants.o parameters.o io.o get_oper.o postw90_common.o comms.o utility.o wan_ham.o +geninterp.o: $(POSTDIR)geninterp.F90 constants.o types.o io.o get_oper.o postw90_common.o comms.o utility.o wan_ham.o postw90_types.o ws_distance.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c $(POSTDIR)geninterp.F90 -get_oper.o: $(POSTDIR)get_oper.F90 parameters.o constants.o comms.o postw90_common.o io.o utility.o +get_oper.o: $(POSTDIR)get_oper.F90 types.o constants.o comms.o postw90_common.o io.o utility.o postw90_types.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c $(POSTDIR)get_oper.F90 -spin.o: $(POSTDIR)spin.F90 comms.o parameters.o constants.o utility.o postw90_common.o get_oper.o io.o wan_ham.o +spin.o: $(POSTDIR)spin.F90 comms.o types.o constants.o utility.o postw90_common.o get_oper.o io.o wan_ham.o postw90_types.o ws_distance.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c $(POSTDIR)spin.F90 -dos.o: $(POSTDIR)dos.F90 comms.o parameters.o constants.o utility.o io.o wan_ham.o postw90_common.o get_oper.o spin.o +dos.o: $(POSTDIR)dos.F90 comms.o types.o postw90_types.o constants.o utility.o io.o wan_ham.o postw90_common.o get_oper.o spin.o ws_distance.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c $(POSTDIR)dos.F90 -kpath.o: $(POSTDIR)kpath.F90 comms.o parameters.o constants.o io.o spin.o berry.o +kpath.o: $(POSTDIR)kpath.F90 comms.o types.o constants.o io.o spin.o berry.o postw90_types.o ws_distance.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c $(POSTDIR)kpath.F90 -kslice.o: $(POSTDIR)kslice.F90 comms.o parameters.o constants.o io.o spin.o berry.o +kslice.o: $(POSTDIR)kslice.F90 comms.o types.o constants.o io.o spin.o berry.o postw90_types.o ws_distance.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c $(POSTDIR)kslice.F90 -berry.o: $(POSTDIR)berry.F90 comms.o parameters.o constants.o utility.o postw90_common.o get_oper.o io.o spin.o wan_ham.o +berry.o: $(POSTDIR)berry.F90 comms.o types.o constants.o utility.o postw90_common.o get_oper.o io.o spin.o wan_ham.o postw90_types.o ws_distance.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c $(POSTDIR)berry.F90 -gyrotropic.o: $(POSTDIR)gyrotropic.F90 comms.o parameters.o constants.o utility.o postw90_common.o get_oper.o io.o spin.o wan_ham.o berry.o +gyrotropic.o: $(POSTDIR)gyrotropic.F90 comms.o types.o constants.o utility.o postw90_common.o get_oper.o io.o spin.o wan_ham.o berry.o postw90_types.o ws_distance.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c $(POSTDIR)gyrotropic.F90 -wan_ham.o: $(POSTDIR)wan_ham.F90 parameters.o constants.o utility.o postw90_common.o get_oper.o +wan_ham.o: $(POSTDIR)wan_ham.F90 types.o postw90_types.o constants.o utility.o postw90_common.o get_oper.o ws_distance.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c $(POSTDIR)wan_ham.F90 -postw90_common.o: $(POSTDIR)postw90_common.F90 ws_distance.o comms.o parameters.o utility.o constants.o io.o +postw90_common.o: $(POSTDIR)postw90_common.F90 postw90_types.o ws_distance.o comms.o types.o utility.o constants.o io.o $(COMPILER) $(POSTOPTS) $(FCOPTS) -c $(POSTDIR)postw90_common.F90 -wannier_lib.o: ./constants.o ./io.o ./utility.o ./parameters.o \ +postw90_types.o: $(POSTDIR)postw90_types.F90 comms.o types.o utility.o constants.o io.o + $(COMPILER) $(POSTOPTS) $(FCOPTS) -c $(POSTDIR)postw90_types.F90 + +postw90_readwrite.o: $(POSTDIR)postw90_readwrite.F90 comms.o postw90_types.o types.o utility.o constants.o io.o + $(COMPILER) $(POSTOPTS) $(FCOPTS) -c $(POSTDIR)postw90_readwrite.F90 + +wannier_lib.o: ./constants.o ./io.o ./utility.o ./types.o \ ./hamiltonian.o ./kmesh.o ./overlap.o ./disentangle.o \ - ./wannierise.o ./plot.o ./transport.o ../wannier_lib.F90 - $(COMPILER) $(FCOPTS) -c ../wannier_lib.F90 + ./wannierise.o ./plot.o ./transport.o ./wannier90_types.o \ + ./wannier90_readwrite.o ../wannier_lib.F90 + $(COMPILER) $(POSTOPTS) $(FCOPTS) -c ../wannier_lib.F90 -.PHONY: wannier libs post clean mpi_test serialobjs w90spn2spn +.PHONY: wannier libs post clean mpi_test w90spn2spn diff --git a/src/Makefile.header b/src/Makefile.header index b6b6a387b..81fe4d319 100644 --- a/src/Makefile.header +++ b/src/Makefile.header @@ -1,12 +1,15 @@ -OBJS = constants.o io.o utility.o parameters.o hamiltonian.o overlap.o \ - kmesh.o disentangle.o ws_distance.o wannierise.o plot.o transport.o sitesym.o comms.o +OBJS = constants.o io.o utility.o types.o hamiltonian.o overlap.o kmesh.o disentangle.o \ + ws_distance.o wannierise.o plot.o transport.o sitesym.o comms.o wannier90_types.o \ + wannier90_readwrite.o comms-abort.o readwrite.o -OBJSLIB = wannier_lib.o +OBJS_LIBV1 = wannier_lib.o -OBJS_POST = ws_distance.o parameters.o kmesh.o io.o comms.o utility.o get_oper.o constants.o \ - postw90_common.o wan_ham.o spin.o dos.o berry.o gyrotropic.o kpath.o kslice.o boltzwann.o geninterp.o +OBJS_POST = ws_distance.o types.o kmesh.o io.o comms.o utility.o get_oper.o constants.o \ + postw90_common.o wan_ham.o spin.o dos.o berry.o gyrotropic.o kpath.o kslice.o \ + boltzwann.o geninterp.o postw90_types.o postw90_readwrite.o comms-abort.o readwrite.o LIBRARY = ../../libwannier.a +LIBRARYV2 = ../../libwan2.a ## Dynamic library section ## Define some defaults (good for linux) if none is defined in the make.inc diff --git a/src/comms-abort.F90 b/src/comms-abort.F90 new file mode 100644 index 000000000..a12749c17 --- /dev/null +++ b/src/comms-abort.F90 @@ -0,0 +1,86 @@ +!-*- mode: F90 -*-! +!------------------------------------------------------------! +! This file is distributed as part of the Wannier90 code and ! +! under the terms of the GNU General Public License. See the ! +! file `LICENSE' in the root directory of the Wannier90 ! +! distribution, or http://www.gnu.org/copyleft/gpl.txt ! +! ! +! The webpage of the Wannier90 code is www.wannier.org ! +! ! +! The Wannier90 code is hosted on GitHub: ! +! ! +! https://github.com/wannier-developers/wannier90 ! +!------------------------------------------------------------! +! +! this routine contains the MPI parts of io_error() (called everywhere) +! io_error previously called mpi_abort(mpi_comm_world) directly, but this means that the io +! module is dependent on the MPI compilation environment +! +! it is anyway undesirable in a library to ever call mpi_abort (that is up to the calling program) +! and indeed the communicator may not be "world" as was previously assumed +! +! routine here is temporary workaround until better error handling is introduced +! as soon as io_error no longer needs to stop/mpi_abort, this routine should be deleted, also +! +! this needs to be it's own module because comms module already depends on io, therfore io cannot +! be made to depend on comms (otherwise module dependencies are circular) +! JJ Aug 2021 + + subroutine comms_abort(seedname, error_msg, stdout) + +#ifdef MPI +# if !(defined(MPI08) || defined(MPI90) || defined(MPIH)) +# error "You need to define which MPI interface you are using" +# endif +#endif + +#ifdef MPI08 + use mpi_f08 ! use f08 interface if possible +#endif +#ifdef MPI90 + use mpi ! next best, use fortran90 interface +#endif + + implicit none + +#ifdef MPIH + include 'mpif.h' ! worst case, use legacy interface +#endif + + character(len=50), intent(in) :: seedname + character(len=*), intent(in) :: error_msg + integer, intent(in) :: stdout + +#ifdef MPI + character(len=50) :: filename + integer :: num_nodes, whoami, ierr, stderr + + ! this routine is not aware of any communicator other than WORLD + call mpi_comm_size(MPI_COMM_WORLD, num_nodes, ierr) + call mpi_comm_rank(MPI_COMM_WORLD, whoami, ierr) + + if (num_nodes > 1) then + if (whoami > 99999) then + write (filename, '(a,a,I0,a)') trim(seedname), '.node_', whoami, '.werr' + else + write (filename, '(a,a,I5.5,a)') trim(seedname), '.node_', whoami, '.werr' + endif + open (newunit=stderr, file=trim(filename), form='formatted', err=105) + write (stderr, '(1x,a)') trim(error_msg) + close (stderr) + end if +105 write (*, '(1x,a)') trim(error_msg) + + if (whoami == 0) then + write (stdout, *) 'Exiting.......' + write (stdout, '(1x,a)') trim(error_msg) + close (stdout) + end if + + call mpi_abort(MPI_COMM_WORLD, 1, ierr) +#else + write (stdout, *) 'Exiting.......' + write (stdout, '(1x,a)') trim(error_msg) +#endif + + end subroutine comms_abort diff --git a/src/comms.F90 b/src/comms.F90 index 054b7ccd7..eee9fea16 100644 --- a/src/comms.F90 +++ b/src/comms.F90 @@ -12,7 +12,7 @@ ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! ! ! -! COMMS: set of MPI wrapper ! +! COMMS: set of MPI wrappers ! ! written 2006-2012 Jonathan R. Yates ! ! later additions Giovanni Pizzi ! ! ! @@ -24,40 +24,60 @@ module w90_comms use w90_constants, only: dp use w90_io, only: io_error - implicit none +#ifdef MPI +# if !(defined(MPI08) || defined(MPI90) || defined(MPIH)) +# error "You need to define which MPI interface you are using" +# endif +#endif - private +#ifdef MPI08 + use mpi_f08 ! use f08 interface if possible +#endif +#ifdef MPI90 + use mpi ! next best, use fortran90 interface +#endif -#ifdef MPI - include 'mpif.h' + implicit none + +#ifdef MPIH + include 'mpif.h' ! worst case, use legacy interface #endif - logical, public, save :: on_root - !! Are we the root node - integer, public, save :: num_nodes - !! Number of nodes - integer, public, save :: my_node_id - !! ID of this node - integer, public, parameter :: root_id = 0 - !! ID of the root node + private - integer, parameter :: mpi_send_tag = 77 !abitrary + integer, parameter :: mpi_send_tag = 77 !arbitrary + integer, parameter :: root_id = 0 !not arbitrary - public :: comms_setup - public :: comms_setup_vars - public :: comms_end -! public :: comms_abort ! [GP]: do not use, use io_error instead - public :: comms_bcast ! send data from the root node - public :: comms_send ! send data from one node to another - public :: comms_recv ! accept data from one node to another - public :: comms_reduce ! reduce data onto root node (n.b. not allreduce); - ! note that on all other nodes, the data is lost public :: comms_allreduce ! reduce data onto all nodes + public :: comms_array_split public :: comms_barrier ! puts a barrier so that the code goes on only when all nodes reach the barrier + public :: comms_bcast ! send data from the root node + public :: comms_end public :: comms_gatherv ! gets chunks of an array from all nodes and gathers them on the root node - public :: comms_scatterv ! sends chunks of an array to all nodes scattering them from the root node + public :: comms_recv ! accept data from one node to another + public :: comms_reduce ! reduce data onto root node (n.b. not allreduce); data is lost on all other nodes + public :: comms_scatterv ! sends chunks of an array to all nodes scattering them from the root node + public :: comms_send ! send data from one node to another + public :: mpirank + public :: mpisize - public :: comms_array_split + type, public :: w90comm_type +#ifdef MPI08 + type(mpi_comm) :: comm ! f08 mpi interface +#else + integer :: comm ! f90 mpi or no mpi +#endif + end type + + type, public :: w90stat_type +#ifdef MPI08 + type(mpi_status) :: stat ! f08 mpi interface +#elif MPI90 + integer :: stat(MPI_STATUS_SIZE) +#else + integer :: stat ! not used +#endif + end type interface comms_bcast module procedure comms_bcast_int @@ -122,41 +142,29 @@ module w90_comms contains - subroutine comms_setup - !! Set up communications - implicit none - -#ifdef MPI + ! mpi rank function for convenience + integer function mpirank(comm) + type(w90comm_type), intent(in) :: comm integer :: ierr - - call mpi_init(ierr) - if (ierr .ne. 0) call io_error('MPI initialisation error') +#ifdef MPI + call mpi_comm_rank(comm%comm, mpirank, ierr) +#else + mpirank = 0 #endif + end function - call comms_setup_vars - - end subroutine comms_setup - - subroutine comms_setup_vars - !! Set up variables related to communicators - !! This should be called also in library mode - implicit none - -#ifdef MPI + ! mpi size function for convenience + integer function mpisize(comm) + type(w90comm_type), intent(in) :: comm integer :: ierr - call mpi_comm_rank(mpi_comm_world, my_node_id, ierr) - call mpi_comm_size(mpi_comm_world, num_nodes, ierr) +#ifdef MPI + call mpi_comm_size(comm%comm, mpisize, ierr) #else - num_nodes = 1 - my_node_id = 0 + mpisize = 1 #endif + end function - on_root = .false. - if (my_node_id == root_id) on_root = .true. - - end subroutine comms_setup_vars - - subroutine comms_array_split(numpoints, counts, displs) + subroutine comms_array_split(numpoints, counts, displs, comm) !! Given an array of size numpoints, we want to split on num_nodes nodes. This function returns !! two arrays: count and displs. !! @@ -172,14 +180,15 @@ subroutine comms_array_split(numpoints, counts, displs) !! do i=displs(my_node_id)+1,displs(my_node_id)+counts(my_node_id) !! use w90_io - integer, intent(in) :: numpoints - !! Number of elements of the array to be scattered - integer, dimension(0:num_nodes - 1), intent(out) :: counts - !! Array (of size num_nodes) with the number of elements of the array on each node - integer, dimension(0:num_nodes - 1), intent(out) :: displs - !! Array (of size num_nodes) with the displacement relative to the global array + integer, intent(in) :: numpoints !! Number of elements of the array to be scattered + integer, intent(inout) :: counts(0:) !! Array (of size num_nodes) with the number of elements of the array on each node + integer, intent(inout) :: displs(0:) !! Array (of size num_nodes) with the displacement relative to the global array + type(w90comm_type), intent(in) :: comm integer :: ratio, remainder, i + integer :: num_nodes + + num_nodes = mpisize(comm) ratio = numpoints/num_nodes remainder = MOD(numpoints, num_nodes) @@ -208,746 +217,728 @@ subroutine comms_end end subroutine comms_end - subroutine comms_barrier + subroutine comms_barrier(comm) !! A barrier to synchronise all nodes implicit none + type(w90comm_type), intent(in) :: comm #ifdef MPI integer :: ierr - call mpi_barrier(mpi_comm_world, ierr) + call mpi_barrier(comm%comm, ierr) #endif end subroutine comms_barrier -! subroutine comms_abort -! -! implicit none -! -! integer :: ierr -! -!#ifdef MPI -! call MPI_abort(MPI_comm_world,1,ierr) -!#else -! STOP -!#endif -! -! end subroutine comms_abort - - subroutine comms_bcast_int(array, size) + subroutine comms_bcast_int(array, size, stdout, seedname, comm) !! Send integar array from root node to all nodes implicit none integer, intent(inout) :: array - integer, intent(in) :: size + integer, intent(in) :: size + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_bcast(array, size, MPI_integer, root_id, mpi_comm_world, error) + call mpi_bcast(array, size, MPI_INTEGER, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_bcast_int') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_bcast_int', stdout, seedname) end if #endif - - return - end subroutine comms_bcast_int - subroutine comms_bcast_real(array, size) + subroutine comms_bcast_real(array, size, stdout, seedname, comm) !! Send real array from root node to all nodes implicit none real(kind=dp), intent(inout) :: array - integer, intent(in) :: size + integer, intent(in) :: size + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_bcast(array, size, MPI_double_precision, root_id, mpi_comm_world, error) + call mpi_bcast(array, size, MPI_DOUBLE_PRECISION, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_bcast_real') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_bcast_real', stdout, seedname) end if #endif - return - end subroutine comms_bcast_real - subroutine comms_bcast_logical(array, size) + subroutine comms_bcast_logical(array, size, stdout, seedname, comm) !! Send logical array from root node to all nodes implicit none logical, intent(inout) :: array - integer, intent(in) :: size + integer, intent(in) :: size + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_bcast(array, size, MPI_logical, root_id, mpi_comm_world, error) + call mpi_bcast(array, size, MPI_LOGICAL, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_bcast_logical') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_bcast_logical', stdout, seedname) end if #endif - return - end subroutine comms_bcast_logical - subroutine comms_bcast_char(array, size) + subroutine comms_bcast_char(array, size, stdout, seedname, comm) !! Send character array from root node to all nodes implicit none character(len=*), intent(inout) :: array - integer, intent(in) :: size + integer, intent(in) :: size + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_bcast(array, size, MPI_character, root_id, mpi_comm_world, error) + call mpi_bcast(array, size, MPI_CHARACTER, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_bcast_char') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_bcast_char', stdout, seedname) end if #endif - return - end subroutine comms_bcast_char - subroutine comms_bcast_cmplx(array, size) + subroutine comms_bcast_cmplx(array, size, stdout, seedname, comm) !! Send character array from root node to all nodes implicit none complex(kind=dp), intent(inout) :: array - integer, intent(in) :: size + integer, intent(in) :: size + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_bcast(array, size, MPI_double_complex, root_id, mpi_comm_world, error) + call mpi_bcast(array, size, MPI_DOUBLE_COMPLEX, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_bcast_cmplx') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_bcast_cmplx', stdout, seedname) end if #endif - return - end subroutine comms_bcast_cmplx !--------- SEND ---------------- - subroutine comms_send_logical(array, size, to) + subroutine comms_send_logical(array, size, to, stdout, seedname, comm) !! Send logical array to specified node implicit none logical, intent(inout) :: array - integer, intent(in) :: size - integer, intent(in) :: to + integer, intent(in) :: size + integer, intent(in) :: to + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_send(array, size, MPI_logical, to, & - mpi_send_tag, mpi_comm_world, error) + call mpi_send(array, size, MPI_LOGICAL, to, mpi_send_tag, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_send_logical') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_send_logical', stdout, seedname) end if #endif - return - end subroutine comms_send_logical - subroutine comms_send_int(array, size, to) + subroutine comms_send_int(array, size, to, stdout, seedname, comm) !! Send integer array to specified node implicit none integer, intent(inout) :: array - integer, intent(in) :: size - integer, intent(in) :: to + integer, intent(in) :: size + integer, intent(in) :: to + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_send(array, size, MPI_integer, to, & - mpi_send_tag, mpi_comm_world, error) + call mpi_send(array, size, MPI_INTEGER, to, mpi_send_tag, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_send_int') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_send_int', stdout, seedname) end if #endif - return - end subroutine comms_send_int - subroutine comms_send_char(array, size, to) + subroutine comms_send_char(array, size, to, stdout, seedname, comm) !! Send character array to specified node implicit none character(len=*), intent(inout) :: array - integer, intent(in) :: size - integer, intent(in) :: to + integer, intent(in) :: size + integer, intent(in) :: to + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_send(array, size, MPI_character, to, & - mpi_send_tag, mpi_comm_world, error) + call mpi_send(array, size, MPI_CHARACTER, to, mpi_send_tag, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_send_char') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_send_char', stdout, seedname) end if #endif - return - end subroutine comms_send_char - subroutine comms_send_real(array, size, to) + subroutine comms_send_real(array, size, to, stdout, seedname, comm) !! Send real array to specified node implicit none real(kind=dp), intent(inout) :: array - integer, intent(in) :: size - integer, intent(in) :: to + integer, intent(in) :: size + integer, intent(in) :: to + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_send(array, size, MPI_double_precision, to, & - mpi_send_tag, mpi_comm_world, error) + call mpi_send(array, size, MPI_DOUBLE_PRECISION, to, mpi_send_tag, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_send_real') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_send_real', stdout, seedname) end if #endif - return - end subroutine comms_send_real - subroutine comms_send_cmplx(array, size, to) + subroutine comms_send_cmplx(array, size, to, stdout, seedname, comm) !! Send complex array to specified node implicit none complex(kind=dp), intent(inout) :: array - integer, intent(in) :: size - integer, intent(in) :: to + integer, intent(in) :: size + integer, intent(in) :: to + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_send(array, size, MPI_double_complex, to, & - mpi_send_tag, mpi_comm_world, error) + call mpi_send(array, size, MPI_DOUBLE_COMPLEX, to, mpi_send_tag, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_send_cmplx') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_send_cmplx', stdout, seedname) end if #endif - return - end subroutine comms_send_cmplx !--------- RECV ---------------- - subroutine comms_recv_logical(array, size, from) + subroutine comms_recv_logical(array, size, from, stdout, seedname, comm) !! Receive logical array from specified node implicit none logical, intent(inout) :: array - integer, intent(in) :: size - integer, intent(in) :: from + integer, intent(in) :: size + integer, intent(in) :: from + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error - integer :: status(MPI_status_size) + type(w90stat_type) :: status + integer :: ierr - call MPI_recv(array, size, MPI_logical, from, & - mpi_send_tag, mpi_comm_world, status, error) + call mpi_recv(array, size, MPI_LOGICAL, from, mpi_send_tag, comm%comm, status%stat, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_recv_logical') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_recv_logical', stdout, seedname) end if #endif - return - end subroutine comms_recv_logical - subroutine comms_recv_int(array, size, from) + subroutine comms_recv_int(array, size, from, stdout, seedname, comm) !! Receive integer array from specified node implicit none integer, intent(inout) :: array - integer, intent(in) :: size - integer, intent(in) :: from + integer, intent(in) :: size + integer, intent(in) :: from + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error - integer :: status(MPI_status_size) + type(w90stat_type) :: status + integer :: ierr - call MPI_recv(array, size, MPI_integer, from, & - mpi_send_tag, mpi_comm_world, status, error) + call mpi_recv(array, size, MPI_INTEGER, from, mpi_send_tag, comm%comm, status%stat, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_recv_int') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_recv_int', stdout, seedname) end if #endif - return - end subroutine comms_recv_int - subroutine comms_recv_char(array, size, from) + subroutine comms_recv_char(array, size, from, stdout, seedname, comm) !! Receive character array from specified node implicit none character(len=*), intent(inout) :: array - integer, intent(in) :: size - integer, intent(in) :: from + integer, intent(in) :: size + integer, intent(in) :: from + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error - integer :: status(MPI_status_size) + type(w90stat_type) :: status + integer :: ierr - call MPI_recv(array, size, MPI_character, from, & - mpi_send_tag, mpi_comm_world, status, error) + call mpi_recv(array, size, MPI_CHARACTER, from, mpi_send_tag, comm%comm, status%stat, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_recv_char') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_recv_char', stdout, seedname) end if #endif - return - end subroutine comms_recv_char - subroutine comms_recv_real(array, size, from) + subroutine comms_recv_real(array, size, from, stdout, seedname, comm) !! Receive real array from specified node implicit none real(kind=dp), intent(inout) :: array - integer, intent(in) :: size - integer, intent(in) :: from + integer, intent(in) :: size + integer, intent(in) :: from + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error - integer :: status(MPI_status_size) + type(w90stat_type) :: status + integer :: ierr - call MPI_recv(array, size, MPI_double_precision, from, & - mpi_send_tag, mpi_comm_world, status, error) + call mpi_recv(array, size, MPI_DOUBLE_PRECISION, from, mpi_send_tag, comm%comm, & + status%stat, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_recv_real') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_recv_real', stdout, seedname) end if #endif - return - end subroutine comms_recv_real - subroutine comms_recv_cmplx(array, size, from) + subroutine comms_recv_cmplx(array, size, from, stdout, seedname, comm) !! Receive complex array from specified node implicit none complex(kind=dp), intent(inout) :: array - integer, intent(in) :: size - integer, intent(in) :: from + integer, intent(in) :: size + integer, intent(in) :: from + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error - - integer :: status(MPI_status_size) + type(w90stat_type) :: status + integer :: ierr - call MPI_recv(array, size, MPI_double_complex, from, & - mpi_send_tag, mpi_comm_world, status, error) + call mpi_recv(array, size, MPI_DOUBLE_COMPLEX, from, mpi_send_tag, comm%comm, & + status%stat, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_recv_cmplx') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_recv_cmplx', stdout, seedname) end if - #endif - return - end subroutine comms_recv_cmplx -! subroutine comms_error -! -! implicit none -! -!#ifdef MPI -! integer :: error -! -! call MPI_abort(MPI_comm_world,1,error) -! -!#endif -! -! end subroutine comms_error - - ! COMMS_REDUCE (collect data on the root node) - - subroutine comms_reduce_int(array, size, op) + subroutine comms_reduce_int(array, size, op, stdout, seedname, comm) !! Reduce integer data to root node implicit none integer, intent(inout) :: array - integer, intent(in) :: size + integer, intent(in) :: size character(len=*), intent(in) :: op + type(w90comm_type), intent(in) :: comm + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname #ifdef MPI - integer :: error, ierr - - integer, allocatable :: array_red(:) - - allocate (array_red(size), stat=ierr) - if (ierr /= 0) then - call io_error('failure to allocate array_red in comms_reduce_int') - end if + integer :: ierr + integer :: rank + rank = mpirank(comm) + + ! note, JJ 23/2/2021 + ! previously this routine alloc'd/used/dealloc'd a temp array + ! to be used as receive buffer for MPI_reduce + ! this temp array was then copied to argument "array" + ! but: "array" needs to be of scalar type for the polymorphism to work + ! so: need to copy array into a (fake) scalar + ! previously: a subroutine my_icopy was used to help to do this. + ! probably just reducing in place is better? select case (op) - case ('SUM') - call MPI_reduce(array, array_red, size, MPI_integer, MPI_sum, root_id, mpi_comm_world, error) + if (rank == root_id) then + call mpi_reduce(MPI_IN_PLACE, array, size, MPI_INTEGER, MPI_SUM, root_id, comm%comm, & + ierr) + else + call mpi_reduce(array, array, size, MPI_INTEGER, MPI_SUM, root_id, comm%comm, ierr) + endif case ('PRD') - call MPI_reduce(array, array_red, size, MPI_integer, MPI_prod, root_id, mpi_comm_world, error) + if (rank == root_id) then + call mpi_reduce(MPI_IN_PLACE, array, size, MPI_INTEGER, MPI_PROD, root_id, comm%comm, & + ierr) + else + call mpi_reduce(array, array, size, MPI_INTEGER, MPI_PROD, root_id, comm%comm, ierr) + endif case default - call io_error('Unknown operation in comms_reduce_int') - + call io_error('Unknown operation in comms_reduce_int', stdout, seedname) end select - call my_icopy(size, array_red, 1, array, 1) - - if (error .ne. MPI_success) then - call io_error('Error in comms_reduce_int') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_reduce_int', stdout, seedname) end if - - if (allocated(array_red)) deallocate (array_red) #endif - return - end subroutine comms_reduce_int - subroutine comms_reduce_real(array, size, op) + subroutine comms_reduce_real(array, size, op, stdout, seedname, comm) !! Reduce real data to root node implicit none real(kind=dp), intent(inout) :: array - integer, intent(in) :: size + integer, intent(in) :: size character(len=*), intent(in) :: op + type(w90comm_type), intent(in) :: comm + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname #ifdef MPI - integer :: error, ierr - - real(kind=dp), allocatable :: array_red(:) - - allocate (array_red(size), stat=ierr) - if (ierr /= 0) then - call io_error('failure to allocate array_red in comms_reduce_real') - end if + integer :: ierr + integer :: rank + rank = mpirank(comm) select case (op) case ('SUM') - call MPI_reduce(array, array_red, size, MPI_double_precision, MPI_sum, root_id, mpi_comm_world, error) + if (rank == root_id) then + call mpi_reduce(MPI_IN_PLACE, array, size, MPI_DOUBLE_PRECISION, MPI_SUM, root_id, & + comm%comm, ierr) + else + call mpi_reduce(array, array, size, MPI_DOUBLE_PRECISION, MPI_SUM, root_id, comm%comm, & + ierr) + endif case ('PRD') - call MPI_reduce(array, array_red, size, MPI_double_precision, MPI_prod, root_id, mpi_comm_world, error) + if (rank == root_id) then + call mpi_reduce(MPI_IN_PLACE, array, size, MPI_DOUBLE_PRECISION, MPI_PROD, root_id, & + comm%comm, ierr) + else + call mpi_reduce(array, array, size, MPI_DOUBLE_PRECISION, MPI_PROD, root_id, comm%comm, & + ierr) + endif case ('MIN') - call MPI_reduce(array, array_red, size, MPI_double_precision, MPI_MIN, root_id, mpi_comm_world, error) + if (rank == root_id) then + call mpi_reduce(MPI_IN_PLACE, array, size, MPI_DOUBLE_PRECISION, MPI_MIN, root_id, & + comm%comm, ierr) + else + call mpi_reduce(array, array, size, MPI_DOUBLE_PRECISION, MPI_MIN, root_id, comm%comm, & + ierr) + endif case ('MAX') - call MPI_reduce(array, array_red, size, MPI_double_precision, MPI_max, root_id, mpi_comm_world, error) + if (rank == root_id) then + call mpi_reduce(MPI_IN_PLACE, array, size, MPI_DOUBLE_PRECISION, MPI_MAX, root_id, & + comm%comm, ierr) + else + call mpi_reduce(array, array, size, MPI_DOUBLE_PRECISION, MPI_MAX, root_id, comm%comm, & + ierr) + endif case default - call io_error('Unknown operation in comms_reduce_real') + call io_error('Unknown operation in comms_reduce_real', stdout, seedname) end select - call dcopy(size, array_red, 1, array, 1) - - if (error .ne. MPI_success) then - call io_error('Error in comms_reduce_real') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_reduce_real', stdout, seedname) end if - - if (allocated(array_red)) deallocate (array_red) #endif - return - end subroutine comms_reduce_real - subroutine comms_reduce_cmplx(array, size, op) + subroutine comms_reduce_cmplx(array, size, op, stdout, seedname, comm) !! Reduce complex data to root node implicit none complex(kind=dp), intent(inout) :: array - integer, intent(in) :: size + integer, intent(in) :: size character(len=*), intent(in) :: op + type(w90comm_type), intent(in) :: comm + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname #ifdef MPI - integer :: error, ierr - - complex(kind=dp), allocatable :: array_red(:) - - allocate (array_red(size), stat=ierr) - if (ierr /= 0) then - call io_error('failure to allocate array_red in comms_reduce_cmplx') - end if + integer :: ierr + integer :: rank + rank = mpirank(comm) select case (op) case ('SUM') - call MPI_reduce(array, array_red, size, MPI_double_complex, MPI_sum, root_id, mpi_comm_world, error) + if (rank == root_id) then + call mpi_reduce(MPI_IN_PLACE, array, size, MPI_DOUBLE_COMPLEX, MPI_SUM, root_id, & + comm%comm, ierr) + else + call mpi_reduce(array, array, size, MPI_DOUBLE_COMPLEX, MPI_SUM, root_id, comm%comm, & + ierr) + end if case ('PRD') - call MPI_reduce(array, array_red, size, MPI_double_complex, MPI_prod, root_id, mpi_comm_world, error) + if (rank == root_id) then + call mpi_reduce(MPI_IN_PLACE, array, size, MPI_DOUBLE_COMPLEX, MPI_PROD, root_id, & + comm%comm, ierr) + else + call mpi_reduce(array, array, size, MPI_DOUBLE_COMPLEX, MPI_PROD, root_id, comm%comm, & + ierr) + end if case default - call io_error('Unknown operation in comms_reduce_cmplx') + call io_error('Unknown operation in comms_reduce_cmplx', stdout, seedname) end select - call zcopy(size, array_red, 1, array, 1) - - if (error .ne. MPI_success) then - call io_error('Error in comms_reduce_cmplx') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_reduce_cmplx', stdout, seedname) end if - if (allocated(array_red)) deallocate (array_red) #endif - return - end subroutine comms_reduce_cmplx - subroutine comms_allreduce_real(array, size, op) + subroutine comms_allreduce_real(array, size, op, stdout, seedname, comm) !! Reduce real data to all nodes implicit none real(kind=dp), intent(inout) :: array - integer, intent(in) :: size + integer, intent(in) :: size character(len=*), intent(in) :: op + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error, ierr - - real(kind=dp), allocatable :: array_red(:) - - allocate (array_red(size), stat=ierr) - if (ierr /= 0) then - call io_error('failure to allocate array_red in comms_allreduce_real') - end if + integer :: ierr select case (op) case ('SUM') - call MPI_allreduce(array, array_red, size, MPI_double_precision, MPI_sum, mpi_comm_world, error) + call mpi_allreduce(MPI_IN_PLACE, array, size, MPI_DOUBLE_PRECISION, MPI_SUM, comm%comm, & + ierr) case ('PRD') - call MPI_allreduce(array, array_red, size, MPI_double_precision, MPI_prod, mpi_comm_world, error) + call mpi_allreduce(MPI_IN_PLACE, array, size, MPI_DOUBLE_PRECISION, MPI_PROD, comm%comm, & + ierr) case ('MIN') - call MPI_allreduce(array, array_red, size, MPI_double_precision, MPI_MIN, mpi_comm_world, error) + call mpi_allreduce(MPI_IN_PLACE, array, size, MPI_DOUBLE_PRECISION, MPI_MIN, comm%comm, & + ierr) case ('MAX') - call MPI_allreduce(array, array_red, size, MPI_double_precision, MPI_max, mpi_comm_world, error) + call mpi_allreduce(MPI_IN_PLACE, array, size, MPI_DOUBLE_PRECISION, MPI_MAX, comm%comm, & + ierr) case default - call io_error('Unknown operation in comms_allreduce_real') + call io_error('Unknown operation in comms_allreduce_real', stdout, seedname) end select - call dcopy(size, array_red, 1, array, 1) - - if (error .ne. MPI_success) then - call io_error('Error in comms_allreduce_real') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_allreduce_real', stdout, seedname) end if - - if (allocated(array_red)) deallocate (array_red) #endif - return - end subroutine comms_allreduce_real - subroutine comms_allreduce_cmplx(array, size, op) + subroutine comms_allreduce_cmplx(array, size, op, stdout, seedname, comm) !! Reduce complex data to all nodes implicit none complex(kind=dp), intent(inout) :: array - integer, intent(in) :: size + integer, intent(in) :: size character(len=*), intent(in) :: op + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error, ierr - - complex(kind=dp), allocatable :: array_red(:) - - allocate (array_red(size), stat=ierr) - if (ierr /= 0) then - call io_error('failure to allocate array_red in comms_allreduce_cmplx') - end if + integer :: ierr select case (op) case ('SUM') - call MPI_allreduce(array, array_red, size, MPI_double_complex, MPI_sum, mpi_comm_world, error) + call mpi_allreduce(MPI_IN_PLACE, array, size, MPI_DOUBLE_COMPLEX, MPI_SUM, comm%comm, & + ierr) case ('PRD') - call MPI_allreduce(array, array_red, size, MPI_double_complex, MPI_prod, mpi_comm_world, error) + call mpi_allreduce(MPI_IN_PLACE, array, size, MPI_DOUBLE_COMPLEX, MPI_PROD, comm%comm, & + ierr) case default - call io_error('Unknown operation in comms_allreduce_cmplx') + call io_error('Unknown operation in comms_allreduce_cmplx', stdout, seedname) end select - call zcopy(size, array_red, 1, array, 1) - - if (error .ne. MPI_success) then - call io_error('Error in comms_allreduce_cmplx') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_allreduce_cmplx', stdout, seedname) end if - - if (allocated(array_red)) deallocate (array_red) #endif - return - end subroutine comms_allreduce_cmplx - subroutine comms_gatherv_real_1(array, localcount, rootglobalarray, counts, displs) + subroutine comms_gatherv_real_1(array, localcount, rootglobalarray, counts, displs, stdout, & + seedname, comm) !! Gather real data to root node (for arrays of rank 1) implicit none - real(kind=dp), dimension(:), intent(inout) :: array - !! local array for sending data - integer, intent(in) :: localcount - !! localcount elements will be sent to the root node - real(kind=dp), dimension(:), intent(inout) :: rootglobalarray - !! array on the root node to which data will be sent - integer, dimension(num_nodes), intent(in) :: counts - !! how data should be partitioned, see MPI documentation or - !! function comms_array_split - integer, dimension(num_nodes), intent(in) :: displs + real(kind=dp), intent(inout) :: array(:) !! local array for sending data + integer, intent(in) :: localcount !! localcount elements will be sent to the root node + real(kind=dp), intent(inout) :: rootglobalarray(:) !! array on the root node to which data will be sent + integer, intent(in) :: counts(0:) !! how data should be partitioned, see MPI documentation or function comms_array_split + integer, intent(in) :: displs(0:) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_gatherv(array, localcount, MPI_double_precision, rootglobalarray, counts, & - displs, MPI_double_precision, root_id, mpi_comm_world, error) + call mpi_gatherv(array, localcount, MPI_DOUBLE_PRECISION, rootglobalarray, counts, & + displs, MPI_DOUBLE_PRECISION, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_gatherv_real_1') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_gatherv_real_1', stdout, seedname) end if - #else - call dcopy(localcount, array, 1, rootglobalarray, 1) + !call dcopy(localcount, array, 1, rootglobalarray, 1) + rootglobalarray = array #endif - return - end subroutine comms_gatherv_real_1 - subroutine comms_gatherv_real_2(array, localcount, rootglobalarray, counts, displs) + subroutine comms_gatherv_real_2(array, localcount, rootglobalarray, counts, displs, & + stdout, seedname, comm) !! Gather real data to root node (for arrays of rank 2) implicit none - real(kind=dp), dimension(:, :), intent(inout) :: array - !! local array for sending data - integer, intent(in) :: localcount - !! localcount elements will be sent to the root node - real(kind=dp), dimension(:, :), intent(inout) :: rootglobalarray - !! array on the root node to which data will be sent - integer, dimension(num_nodes), intent(in) :: counts - !! how data should be partitioned, see MPI documentation or - !! function comms_array_split - integer, dimension(num_nodes), intent(in) :: displs + real(kind=dp), intent(inout) :: array(:, :) !! local array for sending data + integer, intent(in) :: localcount !! localcount elements will be sent to the root node + real(kind=dp), intent(inout) :: rootglobalarray(:, :) !! array on the root node to which data will be sent + integer, intent(in) :: counts(0:) !! how data should be partitioned, see MPI documentation or function comms_array_split + integer, intent(in) :: displs(0:) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_gatherv(array, localcount, MPI_double_precision, rootglobalarray, counts, & - displs, MPI_double_precision, root_id, mpi_comm_world, error) + call mpi_gatherv(array, localcount, MPI_DOUBLE_PRECISION, rootglobalarray, counts, & + displs, MPI_DOUBLE_PRECISION, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_gatherv_real_2') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_gatherv_real_2', stdout, seedname) end if - #else - call dcopy(localcount, array, 1, rootglobalarray, 1) + !call dcopy(localcount, array, 1, rootglobalarray, 1) + rootglobalarray = array #endif - return - end subroutine comms_gatherv_real_2 - subroutine comms_gatherv_real_3(array, localcount, rootglobalarray, counts, displs) + subroutine comms_gatherv_real_3(array, localcount, rootglobalarray, counts, displs, stdout, & + seedname, comm) !! Gather real data to root node (for arrays of rank 3) implicit none - real(kind=dp), dimension(:, :, :), intent(inout) :: array - !! local array for sending data - integer, intent(in) :: localcount - !! localcount elements will be sent to the root node - real(kind=dp), dimension(:, :, :), intent(inout) :: rootglobalarray - !! array on the root node to which data will be sent - integer, dimension(num_nodes), intent(in) :: counts - !! how data should be partitioned, see MPI documentation or - !! function comms_array_split - integer, dimension(num_nodes), intent(in) :: displs + real(kind=dp), intent(inout) :: array(:, :, :) !! local array for sending data + integer, intent(in) :: localcount !! localcount elements will be sent to the root node + real(kind=dp), intent(inout) :: rootglobalarray(:, :, :) !! array on the root node to which data will be sent + integer, intent(in) :: counts(0:) !! how data should be partitioned, see MPI documentation or function comms_array_split + integer, intent(in) :: displs(0:) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_gatherv(array, localcount, MPI_double_precision, rootglobalarray, counts, & - displs, MPI_double_precision, root_id, mpi_comm_world, error) + call mpi_gatherv(array, localcount, MPI_DOUBLE_PRECISION, rootglobalarray, counts, & + displs, MPI_DOUBLE_PRECISION, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_gatherv_real_3') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_gatherv_real_3', stdout, seedname) end if #else - call dcopy(localcount, array, 1, rootglobalarray, 1) + !call dcopy(localcount, array, 1, rootglobalarray, 1) + rootglobalarray = array #endif - return - end subroutine comms_gatherv_real_3 - subroutine comms_gatherv_real_2_3(array, localcount, rootglobalarray, counts, displs) + subroutine comms_gatherv_real_2_3(array, localcount, rootglobalarray, counts, displs, stdout, & + seedname, comm) !! Gather real data to root node (for arrays of rank 2 and 3, respectively) implicit none - real(kind=dp), dimension(:, :), intent(inout) :: array - !! local array for sending data - integer, intent(in) :: localcount - !! localcount elements will be sent to the root node - real(kind=dp), dimension(:, :, :), intent(inout) :: rootglobalarray - !! array on the root node to which data will be sent - integer, dimension(num_nodes), intent(in) :: counts - !! how data should be partitioned, see MPI documentation or - !! function comms_array_split - integer, dimension(num_nodes), intent(in) :: displs + real(kind=dp), intent(inout) :: array(:, :) !! local array for sending data + integer, intent(in) :: localcount !! localcount elements will be sent to the root node + real(kind=dp), intent(inout) :: rootglobalarray(:, :, :) !! array on the root node to which data will be sent + integer, intent(in) :: counts(0:) !! how data should be partitioned, see MPI documentation or function comms_array_split + integer, intent(in) :: displs(0:) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_gatherv(array, localcount, MPI_double_precision, rootglobalarray, counts, & - displs, MPI_double_precision, root_id, mpi_comm_world, error) + call mpi_gatherv(array, localcount, MPI_DOUBLE_PRECISION, rootglobalarray, counts, displs, & + MPI_DOUBLE_PRECISION, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_gatherv_real_2_3') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_gatherv_real_2_3', stdout, seedname) end if #else call dcopy(localcount, array, 1, rootglobalarray, 1) + !rootglobalarray = array ! shapes don't match #endif - return - end subroutine comms_gatherv_real_2_3 ! Array: local array for sending data; localcount elements will be sent @@ -956,173 +947,183 @@ end subroutine comms_gatherv_real_2_3 ! counts, displs : how data should be partitioned, see MPI documentation or ! function comms_array_split - subroutine comms_gatherv_cmplx_1(array, localcount, rootglobalarray, counts, displs) + subroutine comms_gatherv_cmplx_1(array, localcount, rootglobalarray, counts, displs, stdout, & + seedname, comm) !! Gather complex data to root node (for arrays of rank 1) implicit none - complex(kind=dp), dimension(:), intent(inout) :: array - integer, intent(in) :: localcount - complex(kind=dp), dimension(:), intent(inout) :: rootglobalarray - integer, dimension(num_nodes), intent(in) :: counts - integer, dimension(num_nodes), intent(in) :: displs + complex(kind=dp), intent(inout) :: array(:) + integer, intent(in) :: localcount + complex(kind=dp), intent(inout) :: rootglobalarray(:) + integer, intent(in) :: counts(0:) + integer, intent(in) :: displs(0:) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_gatherv(array, localcount, MPI_double_complex, rootglobalarray, counts, & - displs, MPI_double_complex, root_id, mpi_comm_world, error) + call mpi_gatherv(array, localcount, MPI_DOUBLE_COMPLEX, rootglobalarray, counts, displs, & + MPI_DOUBLE_COMPLEX, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_gatherv_cmplx_1') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_gatherv_cmplx_1', stdout, seedname) end if #else - call zcopy(localcount, array, 1, rootglobalarray, 1) + !call zcopy(localcount, array, 1, rootglobalarray, 1) + rootglobalarray = array #endif - return - end subroutine comms_gatherv_cmplx_1 - subroutine comms_gatherv_cmplx_2(array, localcount, rootglobalarray, counts, displs) + subroutine comms_gatherv_cmplx_2(array, localcount, rootglobalarray, counts, displs, stdout, & + seedname, comm) !! Gather complex data to root node (for arrays of rank 2) implicit none - complex(kind=dp), dimension(:, :), intent(inout) :: array - integer, intent(in) :: localcount - complex(kind=dp), dimension(:, :), intent(inout) :: rootglobalarray - integer, dimension(num_nodes), intent(in) :: counts - integer, dimension(num_nodes), intent(in) :: displs + complex(kind=dp), intent(inout) :: array(:, :) + integer, intent(in) :: localcount + complex(kind=dp), intent(inout) :: rootglobalarray(:, :) + integer, intent(in) :: counts(0:) + integer, intent(in) :: displs(0:) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_gatherv(array, localcount, MPI_double_complex, rootglobalarray, counts, & - displs, MPI_double_complex, root_id, mpi_comm_world, error) + call mpi_gatherv(array, localcount, MPI_DOUBLE_COMPLEX, rootglobalarray, counts, displs, & + MPI_DOUBLE_COMPLEX, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_gatherv_cmplx_2') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_gatherv_cmplx_2', stdout, seedname) end if #else call zcopy(localcount, array, 1, rootglobalarray, 1) + rootglobalarray = array #endif - return - end subroutine comms_gatherv_cmplx_2 -!!JRY subroutine comms_gatherv_logical(array,localcount,rootglobalarray,counts,displs) -!! !! Gather real data to root node -!! implicit none - - subroutine comms_gatherv_cmplx_3(array, localcount, rootglobalarray, counts, displs) + subroutine comms_gatherv_cmplx_3(array, localcount, rootglobalarray, counts, displs, stdout, & + seedname, comm) !! Gather complex data to root node (for arrays of rank 3) implicit none - complex(kind=dp), dimension(:, :, :), intent(inout) :: array - integer, intent(in) :: localcount - complex(kind=dp), dimension(:, :, :), intent(inout) :: rootglobalarray - integer, dimension(num_nodes), intent(in) :: counts - integer, dimension(num_nodes), intent(in) :: displs + complex(kind=dp), intent(inout) :: array(:, :, :) + integer, intent(in) :: localcount + complex(kind=dp), intent(inout) :: rootglobalarray(:, :, :) + integer, intent(in) :: counts(0:) + integer, intent(in) :: displs(0:) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_gatherv(array, localcount, MPI_double_complex, rootglobalarray, counts, & - displs, MPI_double_complex, root_id, mpi_comm_world, error) + call mpi_gatherv(array, localcount, MPI_DOUBLE_COMPLEX, rootglobalarray, counts, displs, & + MPI_DOUBLE_COMPLEX, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_gatherv_cmplx_3') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_gatherv_cmplx_3', stdout, seedname) end if #else - call zcopy(localcount, array, 1, rootglobalarray, 1) + !call zcopy(localcount, array, 1, rootglobalarray, 1) + rootglobalarray = array #endif - return - end subroutine comms_gatherv_cmplx_3 - subroutine comms_gatherv_cmplx_3_4(array, localcount, rootglobalarray, counts, displs) + subroutine comms_gatherv_cmplx_3_4(array, localcount, rootglobalarray, counts, displs, stdout, & + seedname, comm) !! Gather complex data to root node (for arrays of rank 3 and 4, respectively) implicit none - complex(kind=dp), dimension(:, :, :), intent(inout) :: array - integer, intent(in) :: localcount - complex(kind=dp), dimension(:, :, :, :), intent(inout) :: rootglobalarray - integer, dimension(num_nodes), intent(in) :: counts - integer, dimension(num_nodes), intent(in) :: displs + complex(kind=dp), intent(inout) :: array(:, :, :) + integer, intent(in) :: localcount + complex(kind=dp), intent(inout) :: rootglobalarray(:, :, :, :) + integer, intent(in) :: counts(0:) + integer, intent(in) :: displs(0:) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_gatherv(array, localcount, MPI_double_complex, rootglobalarray, counts, & - displs, MPI_double_complex, root_id, mpi_comm_world, error) + call mpi_gatherv(array, localcount, MPI_DOUBLE_COMPLEX, rootglobalarray, counts, displs, & + MPI_DOUBLE_COMPLEX, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_gatherv_cmplx_3_4') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_gatherv_cmplx_3_4', stdout, seedname) end if #else call zcopy(localcount, array, 1, rootglobalarray, 1) + !rootglobalarray = array ! shapes don't match #endif - return - end subroutine comms_gatherv_cmplx_3_4 - subroutine comms_gatherv_cmplx_4(array, localcount, rootglobalarray, counts, displs) + subroutine comms_gatherv_cmplx_4(array, localcount, rootglobalarray, counts, displs, stdout, & + seedname, comm) !! Gather complex data to root node (for arrays of rank 4) implicit none - complex(kind=dp), dimension(:, :, :, :), intent(inout) :: array - integer, intent(in) :: localcount - complex(kind=dp), dimension(:, :, :, :), intent(inout) :: rootglobalarray - integer, dimension(num_nodes), intent(in) :: counts - integer, dimension(num_nodes), intent(in) :: displs + complex(kind=dp), intent(inout) :: array(:, :, :, :) + integer, intent(in) :: localcount + complex(kind=dp), intent(inout) :: rootglobalarray(:, :, :, :) + integer, intent(in) :: counts(0:) + integer, intent(in) :: displs(0:) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_gatherv(array, localcount, MPI_double_complex, rootglobalarray, counts, & - displs, MPI_double_complex, root_id, mpi_comm_world, error) + call mpi_gatherv(array, localcount, MPI_DOUBLE_COMPLEX, rootglobalarray, counts, displs, & + MPI_DOUBLE_COMPLEX, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_gatherv_cmplx_4') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_gatherv_cmplx_4', stdout, seedname) end if #else - call zcopy(localcount, array, 1, rootglobalarray, 1) + !call zcopy(localcount, array, 1, rootglobalarray, 1) + rootglobalarray = array #endif - return - end subroutine comms_gatherv_cmplx_4 - subroutine comms_gatherv_logical(array, localcount, rootglobalarray, counts, displs) + subroutine comms_gatherv_logical(array, localcount, rootglobalarray, counts, displs, stdout, & + seedname, comm) !! Gather real data to root node implicit none - logical, intent(inout) :: array - !! local array for sending data - integer, intent(in) :: localcount - !! localcount elements will be sent to the root node - logical, intent(inout) :: rootglobalarray - !! array on the root node to which data will be sent - integer, dimension(num_nodes), intent(in) :: counts - !! how data should be partitioned, see MPI documentation or - !! function comms_array_split - integer, dimension(num_nodes), intent(in) :: displs + logical, intent(inout) :: array !! local array for sending data + integer, intent(in) :: localcount !! localcount elements will be sent to the root node + logical, intent(inout) :: rootglobalarray !! array on the root node to which data will be sent + integer, intent(in) :: counts(0:) !! how data should be partitioned, see MPI documentation or function comms_array_split + integer, intent(in) :: displs(0:) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_gatherv(array, localcount, MPI_logical, rootglobalarray, counts, & - displs, MPI_logical, root_id, mpi_comm_world, error) + call mpi_gatherv(array, localcount, MPI_LOGICAL, rootglobalarray, counts, displs, & + MPI_LOGICAL, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_gatherv_logical') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_gatherv_logical', stdout, seedname) end if #else ! rootglobalarray(1:localcount)=array(1:localcount) @@ -1130,274 +1131,222 @@ subroutine comms_gatherv_logical(array, localcount, rootglobalarray, counts, dis end subroutine comms_gatherv_logical - subroutine comms_scatterv_real_1(array, localcount, rootglobalarray, counts, displs) + subroutine comms_scatterv_real_1(array, localcount, rootglobalarray, counts, displs, stdout, & + seedname, comm) !! Scatter real data from root node (array of rank 1) implicit none - real(kind=dp), dimension(:), intent(inout) :: array - !! local array for getting data - integer, intent(in) :: localcount - !! localcount elements will be fetched from the root node - real(kind=dp), dimension(:), intent(inout) :: rootglobalarray - !! array on the root node from which data will be sent - integer, dimension(num_nodes), intent(in) :: counts - !! how data should be partitioned, see MPI documentation or function comms_array_split - integer, dimension(num_nodes), intent(in) :: displs + real(kind=dp), intent(inout) :: array(:) !! local array for getting data + integer, intent(in) :: localcount !! localcount elements will be fetched from the root node + real(kind=dp), intent(inout) :: rootglobalarray(:) !! array on the root node from which data will be sent + integer, intent(in) :: counts(0:) !! how data should be partitioned, see MPI documentation or function comms_array_split + integer, intent(in) :: displs(0:) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_scatterv(rootglobalarray, counts, displs, MPI_double_precision, & - array, localcount, MPI_double_precision, root_id, mpi_comm_world, error) + call mpi_scatterv(rootglobalarray, counts, displs, MPI_DOUBLE_PRECISION, array, localcount, & + MPI_DOUBLE_PRECISION, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_scatterv_real_1') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_scatterv_real_1', stdout, seedname) end if #else - call dcopy(localcount, rootglobalarray, 1, array, 1) + !call dcopy(localcount, rootglobalarray, 1, array, 1) + array = rootglobalarray #endif - return - end subroutine comms_scatterv_real_1 - subroutine comms_scatterv_real_2(array, localcount, rootglobalarray, counts, displs) + subroutine comms_scatterv_real_2(array, localcount, rootglobalarray, counts, displs, stdout, & + seedname, comm) !! Scatter real data from root node (array of rank 2) implicit none - real(kind=dp), dimension(:, :), intent(inout) :: array - !! local array for getting data - integer, intent(in) :: localcount - !! localcount elements will be fetched from the root node - real(kind=dp), dimension(:, :), intent(inout) :: rootglobalarray - !! array on the root node from which data will be sent - integer, dimension(num_nodes), intent(in) :: counts - !! how data should be partitioned, see MPI documentation or function comms_array_split - integer, dimension(num_nodes), intent(in) :: displs + real(kind=dp), intent(inout) :: array(:, :) !! local array for getting data + integer, intent(in) :: localcount !! localcount elements will be fetched from the root node + real(kind=dp), intent(inout) :: rootglobalarray(:, :) !! array on the root node from which data will be sent + integer, intent(in) :: counts(0:) !! how data should be partitioned, see MPI documentation or function comms_array_split + integer, intent(in) :: displs(0:) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_scatterv(rootglobalarray, counts, displs, MPI_double_precision, & - array, localcount, MPI_double_precision, root_id, mpi_comm_world, error) + call mpi_scatterv(rootglobalarray, counts, displs, MPI_DOUBLE_PRECISION, array, localcount, & + MPI_DOUBLE_PRECISION, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_scatterv_real_2') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_scatterv_real_2', stdout, seedname) end if #else - call dcopy(localcount, rootglobalarray, 1, array, 1) + !call dcopy(localcount, rootglobalarray, 1, array, 1) + array = rootglobalarray #endif - return - end subroutine comms_scatterv_real_2 - subroutine comms_scatterv_real_3(array, localcount, rootglobalarray, counts, displs) + subroutine comms_scatterv_real_3(array, localcount, rootglobalarray, counts, displs, stdout, & + seedname, comm) !! Scatter real data from root node (array of rank 3) implicit none - real(kind=dp), dimension(:, :, :), intent(inout) :: array - !! local array for getting data - integer, intent(in) :: localcount - !! localcount elements will be fetched from the root node - real(kind=dp), dimension(:, :, :), intent(inout) :: rootglobalarray - !! array on the root node from which data will be sent - integer, dimension(num_nodes), intent(in) :: counts - !! how data should be partitioned, see MPI documentation or function comms_array_split - integer, dimension(num_nodes), intent(in) :: displs + real(kind=dp), intent(inout) :: array(:, :, :) !! local array for getting data + integer, intent(in) :: localcount !! localcount elements will be fetched from the root node + real(kind=dp), intent(inout) :: rootglobalarray(:, :, :) !! array on the root node from which data will be sent + integer, intent(in) :: counts(0:) !! how data should be partitioned, see MPI documentation or function comms_array_split + integer, intent(in) :: displs(0:) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_scatterv(rootglobalarray, counts, displs, MPI_double_precision, & - array, localcount, MPI_double_precision, root_id, mpi_comm_world, error) + call mpi_scatterv(rootglobalarray, counts, displs, MPI_DOUBLE_PRECISION, array, localcount, & + MPI_DOUBLE_PRECISION, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_scatterv_real_3') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_scatterv_real_3', stdout, seedname) end if #else - call dcopy(localcount, rootglobalarray, 1, array, 1) + !call dcopy(localcount, rootglobalarray, 1, array, 1) + array = rootglobalarray #endif - return - end subroutine comms_scatterv_real_3 - subroutine comms_scatterv_cmplx_4(array, localcount, rootglobalarray, counts, displs) + subroutine comms_scatterv_cmplx_4(array, localcount, rootglobalarray, counts, displs, stdout, seedname, comm) !! Scatter complex data from root node (array of rank 4) implicit none - complex(kind=dp), dimension(:, :, :, :), intent(inout) :: array - !! local array for getting data - integer, intent(in) :: localcount - !! localcount elements will be fetched from the root node - complex(kind=dp), dimension(:, :, :, :), intent(inout) :: rootglobalarray - !! array on the root node from which data will be sent - integer, dimension(num_nodes), intent(in) :: counts - !! how data should be partitioned, see MPI documentation or function comms_array_split - integer, dimension(num_nodes), intent(in) :: displs + complex(kind=dp), intent(inout) :: array(:, :, :, :) !! local array for getting data + integer, intent(in) :: localcount !! localcount elements will be fetched from the root node + complex(kind=dp), intent(inout) :: rootglobalarray(:, :, :, :) !! array on the root node from which data will be sent + integer, intent(in) :: counts(0:) !! how data should be partitioned, see MPI documentation or function comms_array_split + integer, intent(in) :: displs(0:) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_scatterv(rootglobalarray, counts, displs, MPI_double_complex, & - array, localcount, MPI_double_complex, root_id, mpi_comm_world, error) + call mpi_scatterv(rootglobalarray, counts, displs, MPI_DOUBLE_COMPLEX, array, localcount, & + MPI_DOUBLE_COMPLEX, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_scatterv_cmplx_4') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_scatterv_cmplx_4', stdout, seedname) end if #else - call zcopy(localcount, rootglobalarray, 1, array, 1) + !call zcopy(localcount, rootglobalarray, 1, array, 1) + array = rootglobalarray #endif - return - end subroutine comms_scatterv_cmplx_4 - subroutine comms_scatterv_int_1(array, localcount, rootglobalarray, counts, displs) + subroutine comms_scatterv_int_1(array, localcount, rootglobalarray, counts, displs, stdout, & + seedname, comm) !! Scatter integer data from root node (array of rank 1) implicit none - integer, dimension(:), intent(inout) :: array - !! local array for getting data - integer, intent(in) :: localcount - !! localcount elements will be fetched from the root node - integer, dimension(:), intent(inout) :: rootglobalarray - !! array on the root node from which data will be sent - integer, dimension(num_nodes), intent(in) :: counts - !! how data should be partitioned, see MPI documentation or function comms_array_split - integer, dimension(num_nodes), intent(in) :: displs + integer, intent(inout) :: array(:) !! local array for getting data + integer, intent(in) :: localcount !! localcount elements will be fetched from the root node + integer, intent(inout) :: rootglobalarray(:) !! array on the root node from which data will be sent + integer, intent(in) :: counts(0:) !! how data should be partitioned, see MPI documentation or function comms_array_split + integer, intent(in) :: displs(0:) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_scatterv(rootglobalarray, counts, displs, MPI_Integer, & - Array, localcount, MPI_Integer, root_id, mpi_comm_world, error) + call mpi_scatterv(rootglobalarray, counts, displs, MPI_INTEGER, array, localcount, & + MPI_INTEGER, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_scatterv_real') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_scatterv_real', stdout, seedname) end if #else - call my_icopy(localcount, rootglobalarray, 1, array, 1) + !call my_icopy(localcount, rootglobalarray, 1, array, 1) + array = rootglobalarray #endif - return - end subroutine comms_scatterv_int_1 - subroutine comms_scatterv_int_2(array, localcount, rootglobalarray, counts, displs) + subroutine comms_scatterv_int_2(array, localcount, rootglobalarray, counts, displs, stdout, & + seedname, comm) !! Scatter integer data from root node (array of rank 2) implicit none - integer, dimension(:, :), intent(inout) :: array - !! local array for getting data - integer, intent(in) :: localcount - !! localcount elements will be fetched from the root node - integer, dimension(:, :), intent(inout) :: rootglobalarray - !! array on the root node from which data will be sent - integer, dimension(num_nodes), intent(in) :: counts - !! how data should be partitioned, see MPI documentation or function comms_array_split - integer, dimension(num_nodes), intent(in) :: displs + integer, intent(inout) :: array(:, :) !! local array for getting data + integer, intent(in) :: localcount !! localcount elements will be fetched from the root node + integer, intent(inout) :: rootglobalarray(:, :) !! array on the root node from which data will be sent + integer, intent(in) :: counts(0:) !! how data should be partitioned, see MPI documentation or function comms_array_split + integer, intent(in) :: displs(0:) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_scatterv(rootglobalarray, counts, displs, MPI_Integer, & - Array, localcount, MPI_Integer, root_id, mpi_comm_world, error) + call mpi_scatterv(rootglobalarray, counts, displs, MPI_INTEGER, array, localcount, & + MPI_INTEGER, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_scatterv_int_2') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_scatterv_int_2', stdout, seedname) end if #else - call my_icopy(localcount, rootglobalarray, 1, array, 1) + !call my_icopy(localcount, rootglobalarray, 1, array, 1) + array = rootglobalarray #endif - return - end subroutine comms_scatterv_int_2 - subroutine comms_scatterv_int_3(array, localcount, rootglobalarray, counts, displs) + subroutine comms_scatterv_int_3(array, localcount, rootglobalarray, counts, displs, stdout, & + seedname, comm) !! Scatter integer data from root node (array of rank 3) implicit none - integer, dimension(:, :, :), intent(inout) :: array - !! local array for getting data - integer, intent(in) :: localcount - !! localcount elements will be fetched from the root node - integer, dimension(:, :, :), intent(inout) :: rootglobalarray - !! array on the root node from which data will be sent - integer, dimension(num_nodes), intent(in) :: counts - !! how data should be partitioned, see MPI documentation or function comms_array_split - integer, dimension(num_nodes), intent(in) :: displs + integer, intent(inout) :: array(:, :, :) !! local array for getting data + integer, intent(in) :: localcount !! localcount elements will be fetched from the root node + integer, intent(inout) :: rootglobalarray(:, :, :) !! array on the root node from which data will be sent + integer, intent(in) :: counts(0:) !! how data should be partitioned, see MPI documentation or function comms_array_split + integer, intent(in) :: displs(0:) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm #ifdef MPI - integer :: error + integer :: ierr - call MPI_scatterv(rootglobalarray, counts, displs, MPI_Integer, & - Array, localcount, MPI_Integer, root_id, mpi_comm_world, error) + call mpi_scatterv(rootglobalarray, counts, displs, MPI_INTEGER, array, localcount, & + MPI_INTEGER, root_id, comm%comm, ierr) - if (error .ne. MPI_success) then - call io_error('Error in comms_scatterv_int_3') + if (ierr .ne. MPI_SUCCESS) then + call io_error('Error in comms_scatterv_int_3', stdout, seedname) end if #else - call my_icopy(localcount, rootglobalarray, 1, array, 1) + !call my_icopy(localcount, rootglobalarray, 1, array, 1) + array = rootglobalarray #endif - return - end subroutine comms_scatterv_int_3 - end module w90_comms -subroutine my_ICOPY(N, ZX, INCX, ZY, INCY) - ! .. Scalar Arguments .. - integer INCX, INCY, N - ! .. - ! .. Array Arguments .. - integer ZX(*), ZY(*) - ! .. - ! - ! Purpose - ! ======= - ! - ! copies a vector, x, to a vector, y. - ! jack dongarra, linpack, 4/11/78. - ! modified 12/3/93, array(1) declarations changed to array(*) - ! - ! - ! .. Local Scalars .. - integer I, IX, IY - ! .. - if (N .le. 0) return - if (INCX .eq. 1 .and. INCY .eq. 1) GO TO 20 - ! - ! code for unequal increments or equal increments - ! not equal to 1 - ! - IX = 1 - IY = 1 - if (INCX .lt. 0) IX = (-N + 1)*INCX + 1 - if (INCY .lt. 0) IY = (-N + 1)*INCY + 1 - do I = 1, N - ZY(IY) = ZX(IX) - IX = IX + INCX - IY = IY + INCY - end do - return - ! - ! code for both increments equal to 1 - ! -20 do I = 1, N - ZY(I) = ZX(I) - end do - return -end subroutine my_ICOPY diff --git a/src/constants.F90 b/src/constants.F90 index 8b9a98043..05172a7ae 100644 --- a/src/constants.F90 +++ b/src/constants.F90 @@ -11,6 +11,10 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! w90_constants: physical constants and tolerances ! +! ! +!------------------------------------------------------------! module w90_constants @@ -34,8 +38,6 @@ module w90_constants !aam_2012-04-11; fix to run on MacBook Air integer, parameter, public :: dp = kind(1.0d0) !! double precision -! integer, parameter, public :: dp = selected_real_kind(14,200) -! integer, parameter, public :: dp = selected_real_kind(15,300) real(kind=dp), parameter, public :: pi = 3.141592653589793238462643383279_dp !! $$\pi$$ real(kind=dp), parameter, public :: twopi = 2*pi @@ -84,69 +86,92 @@ module w90_constants #ifdef CODATA2006 ! ##### CODATA 2006 ##### ! !#warning "WANNIER90 INFO: Using CODATA 2006 constant values" - real(kind=dp), parameter, public :: elem_charge_SI = 1.602176487e-19_dp ! C + real(kind=dp), parameter :: elem_charge_SI = 1.602176487e-19_dp ! C !! e - real(kind=dp), parameter, public :: elec_mass_SI = 9.10938215e-31_dp ! kg + real(kind=dp), parameter :: elec_mass_SI = 9.10938215e-31_dp ! kg !! $$m_e$$ - real(kind=dp), parameter, public :: hbar_SI = 1.054571628e-34_dp ! J * s + real(kind=dp), parameter :: hbar_SI = 1.054571628e-34_dp ! J * s !! $$\hbar$$ - real(kind=dp), parameter, public :: k_B_SI = 1.3806504e-23_dp ! J / K + real(kind=dp), parameter :: k_B_SI = 1.3806504e-23_dp ! J / K !! $$k_B$$ - real(kind=dp), parameter, public :: bohr_magn_SI = 927.400915e-26_dp ! J / T + real(kind=dp), parameter :: bohr_magn_SI = 927.400915e-26_dp ! J / T !! $$\mu_B$$ - real(kind=dp), parameter, public :: eps0_SI = 8.854187817e-12_dp ! F / m + real(kind=dp), parameter :: eps0_SI = 8.854187817e-12_dp ! F / m !! $$\epsilon_0$$ - real(kind=dp), parameter, public :: speedlight_SI = 299792458.0_dp ! m / s + real(kind=dp), parameter :: speedlight_SI = 299792458.0_dp ! m / s !! $$c$$ - real(kind=dp), parameter, public :: eV_au = 3.674932540e-2_dp ! (see table of Conv. Factors) + real(kind=dp), parameter :: eV_au = 3.674932540e-2_dp ! (see table of Conv. Factors) !! eV in atomic units - real(kind=dp), parameter, public :: eV_seconds = 6.582119e-16_dp + real(kind=dp), parameter :: eV_seconds = 6.582119e-16_dp !! Electron Volt in seconds - real(kind=dp), parameter, public :: bohr_angstrom_internal = 0.52917720859_dp + real(kind=dp), parameter :: bohr_angstrom_internal = 0.52917720859_dp !! Bohr to $$\AA$$ ! Leave the length to this value, and don't exceed in length (needed for output formatting) - character(len=75), parameter, public :: constants_version_str1 = "-> Using CODATA 2006 constant values" - character(len=75), parameter, public :: constants_version_str2 = " (http://physics.nist.gov/cuu/Constants/index.html)" + character(len=75), parameter :: constants_version_str1 = "-> Using CODATA 2006 constant values" + character(len=75), parameter :: constants_version_str2 = " (http://physics.nist.gov/cuu/Constants/index.html)" #endif #ifdef CODATA2010 ! ##### CODATA 2010 ##### ! !#warning "WANNIER90 INFO: Using CODATA 2010 constant values" - real(kind=dp), parameter, public :: elem_charge_SI = 1.602176565e-19_dp + real(kind=dp), parameter :: elem_charge_SI = 1.602176565e-19_dp !! elemental charge - real(kind=dp), parameter, public :: elec_mass_SI = 9.10938291e-31_dp + real(kind=dp), parameter :: elec_mass_SI = 9.10938291e-31_dp !! electron mass - real(kind=dp), parameter, public :: hbar_SI = 1.054571726e-34_dp + real(kind=dp), parameter :: hbar_SI = 1.054571726e-34_dp !! hbar - real(kind=dp), parameter, public :: k_B_SI = 1.3806488e-23_dp + real(kind=dp), parameter :: k_B_SI = 1.3806488e-23_dp !! Boltzman Constant - real(kind=dp), parameter, public :: bohr_magn_SI = 927.400968e-26_dp + real(kind=dp), parameter :: bohr_magn_SI = 927.400968e-26_dp !! Bohr magneton - real(kind=dp), parameter, public :: eps0_SI = 8.854187817e-12_dp + real(kind=dp), parameter :: eps0_SI = 8.854187817e-12_dp !! Vacuum Dielectric Constant - real(kind=dp), parameter, public :: speedlight_SI = 299792458.0_dp + real(kind=dp), parameter :: speedlight_SI = 299792458.0_dp !! Speed of light - real(kind=dp), parameter, public :: eV_au = 3.674932379e-2_dp + real(kind=dp), parameter :: eV_au = 3.674932379e-2_dp !! Electron Volt in atomic units - real(kind=dp), parameter, public :: eV_seconds = 6.582119e-16_dp + real(kind=dp), parameter :: eV_seconds = 6.582119e-16_dp !! Electron Volt in seconds - real(kind=dp), parameter, public :: bohr_angstrom_internal = 0.52917721092_dp + real(kind=dp), parameter :: bohr_angstrom_internal = 0.52917721092_dp !! Bohr to Anstrom Conversion factor ! Leave the length to this value, and don't exceed in length (needed for output formatting) - character(len=75), parameter, public :: constants_version_str1 = "-> Using CODATA 2010 constant values" - character(len=75), parameter, public :: constants_version_str2 = " (http://physics.nist.gov/cuu/Constants/index.html)" + character(len=75), parameter :: constants_version_str1 = "-> Using CODATA 2010 constant values" + character(len=75), parameter :: constants_version_str2 = " (http://physics.nist.gov/cuu/Constants/index.html)" #endif #ifdef USE_WANNIER90_V1_BOHR !#warning "WANNIER90 INFO: Using WANNIER ver. 1 version of bohr" - real(kind=dp), parameter, public :: bohr = 0.5291772108_dp + real(kind=dp), parameter :: bohr = 0.5291772108_dp ! Leave the length to this value, and don't exceed in length (needed for output formatting) - character(len=75), parameter, public :: bohr_version_str = "-> Using Bohr value from Wannier90 ver. 1.x (DEPRECATED!)" + character(len=75), parameter :: bohr_version_str = "-> Using Bohr value from Wannier90 ver. 1.x (DEPRECATED!)" #else !#warning "WANNIER90 INFO: Using CODATA version of bohr" - real(kind=dp), parameter, public :: bohr = bohr_angstrom_internal + real(kind=dp), parameter :: bohr = bohr_angstrom_internal ! Leave the length to this value, and don't exceed in length (needed for output formatting) - character(len=75), parameter, public :: bohr_version_str = "-> Using Bohr value from CODATA" + character(len=75), parameter :: bohr_version_str = "-> Using Bohr value from CODATA" #endif + type w90_physical_constants_type + real(kind=dp) :: bohr = bohr + character(len=75) :: bohr_version_str = bohr_version_str + character(len=75) :: constants_version_str1 = constants_version_str1 + character(len=75) :: constants_version_str2 = constants_version_str2 + end type w90_physical_constants_type + + type pw90_physical_constants_type + real(kind=dp) :: elem_charge_SI = elem_charge_SI ! elemental charge + real(kind=dp) :: elec_mass_SI = elec_mass_SI ! electron mass + real(kind=dp) :: hbar_SI = hbar_SI ! hbar + real(kind=dp) :: k_B_SI = k_B_SI ! Boltzman Constant + real(kind=dp) :: eps0_SI = eps0_SI ! Vacuum Dielectric Constant + real(kind=dp) :: eV_au = eV_au ! Electron Volt in atomic units + real(kind=dp) :: eV_seconds = eV_seconds ! Electron Volt in seconds + real(kind=dp) :: bohr = bohr + character(len=75) :: bohr_version_str = bohr_version_str + character(len=75) :: constants_version_str1 = constants_version_str1 + character(len=75) :: constants_version_str2 = constants_version_str2 + end type pw90_physical_constants_type + + public :: w90_physical_constants_type, pw90_physical_constants_type + end module w90_constants diff --git a/src/disentangle.F90 b/src/disentangle.F90 index ff3b95165..588921a95 100644 --- a/src/disentangle.F90 +++ b/src/disentangle.F90 @@ -11,156 +11,211 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! w90_disentangle: extract subspace from entangled bands ! +! ! +!------------------------------------------------------------! module w90_disentangle + !! This module contains the core routines to extract an optimal !! subspace from a set of entangled bands. + use w90_comms, only: comms_bcast, comms_array_split, comms_gatherv, comms_allreduce, & + w90comm_type, mpisize, mpirank use w90_constants, only: dp, cmplx_0, cmplx_1 - use w90_io, only: io_error, stdout, io_stopwatch - use w90_parameters, only: num_bands, num_wann, a_matrix, u_matrix_opt, & - u_matrix, m_matrix_orig, lwindow, dis_conv_window, devel_flag, & - nntot, timing_level, omega_invariant, u_matrix, lsitesymmetry, & - lenconfac, iprint, wbtot, dis_num_iter, dis_mix_ratio, dis_win_min, & - dis_win_max, dis_froz_min, dis_froz_max, dis_spheres_num, & - dis_spheres_first_wann, num_kpts, nnlist, ndimwin, wb, gamma_only, & - eigval, length_unit, dis_spheres, m_matrix, dis_conv_tol, frozen_states, & - optimisation, recip_lattice, kpt_latt, & - m_matrix_orig_local, m_matrix_local - - use w90_comms, only: on_root, my_node_id, num_nodes, & - comms_bcast, comms_array_split, & - comms_gatherv, comms_allreduce - - use w90_sitesym, only: sitesym_slim_d_matrix_band, & - sitesym_replace_d_matrix_band, sitesym_symmetrize_u_matrix, & - sitesym_symmetrize_zmatrix, sitesym_dis_extract_symmetry !RS: + use w90_io, only: io_error, io_stopwatch + use w90_types, only: dis_manifold_type, kmesh_info_type, print_output_type + use w90_wannier90_types, only: dis_control_type, dis_spheres_type, sitesym_type + use w90_sitesym, only: sitesym_slim_d_matrix_band, sitesym_replace_d_matrix_band, & + sitesym_symmetrize_u_matrix, sitesym_symmetrize_zmatrix, & + sitesym_dis_extract_symmetry implicit none - private - - real(kind=dp), allocatable :: eigval_opt(:, :) - !! At input it contains a large set of eigenvalues. At - !! it is slimmed down to contain only those inside the energy window. - - logical :: linner - !! Is there a frozen window - logical, allocatable :: lfrozen(:, :) - !! true if the i-th band inside outer window is frozen - integer, allocatable :: nfirstwin(:) - !! index of lowest band inside outer window at nkp-th - integer, allocatable :: ndimfroz(:) - !! number of frozen bands at nkp-th k point - integer, allocatable :: indxfroz(:, :) - !! number of bands inside outer window at nkp-th k point - integer, allocatable :: indxnfroz(:, :) - !! outer-window band index for the i-th non-frozen state - !! (equals 1 if it is the bottom of outer window) - public :: dis_main contains - !==================================================================! - subroutine dis_main() - !==================================================================! + !================================================! + + subroutine dis_main(dis_control, dis_spheres, dis_manifold, kmesh_info, kpt_latt, sitesym, & + print_output, a_matrix, m_matrix, m_matrix_local, m_matrix_orig, & + m_matrix_orig_local, u_matrix, u_matrix_opt, eigval, real_lattice, & + omega_invariant, num_bands, num_kpts, num_wann, optimisation, gamma_only, & + lsitesymmetry, stdout, seedname, comm) + !================================================! + ! !! Main disentanglement routine - ! ! - ! ! - ! ! - !==================================================================! + ! + !================================================! + use w90_io, only: io_file_unit + use w90_utility, only: utility_recip_lattice_base + + ! arguments + integer, intent(in) :: num_bands, num_kpts, num_wann + integer, intent(in) :: optimisation + integer, intent(in) :: stdout + + logical, intent(in) :: lsitesymmetry + logical, intent(in) :: gamma_only + + real(kind=dp), intent(in) :: eigval(:, :) ! (num_bands, num_kpts) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(inout) :: omega_invariant + + complex(kind=dp), intent(inout) :: a_matrix(:, :, :) ! (num_bands, num_wann, num_kpts) + complex(kind=dp), intent(inout) :: u_matrix(:, :, :) ! (num_wann, num_wann, num_kpts) + complex(kind=dp), intent(inout) :: u_matrix_opt(:, :, :) ! (num_bands, num_wann, num_kpts) + complex(kind=dp), intent(inout), allocatable :: m_matrix(:, :, :, :) + complex(kind=dp), intent(inout), allocatable :: m_matrix_local(:, :, :, :) + complex(kind=dp), intent(inout), allocatable :: m_matrix_orig(:, :, :, :) + complex(kind=dp), intent(inout), allocatable :: m_matrix_orig_local(:, :, :, :) + + type(dis_control_type), intent(inout) :: dis_control + type(dis_spheres_type), intent(in) :: dis_spheres + type(dis_manifold_type), intent(inout) :: dis_manifold + type(kmesh_info_type), intent(in) :: kmesh_info + real(kind=dp), intent(in) :: kpt_latt(:, :) + type(print_output_type), intent(in) :: print_output + type(sitesym_type), intent(inout) :: sitesym + type(w90comm_type), intent(in) :: comm + + character(len=50), intent(in) :: seedname ! internal variables - integer :: nkp, nkp2, nn, j, ierr, page_unit - integer :: nkp_global + real(kind=dp) :: recip_lattice(3, 3), volume + integer :: nkp, nkp2, nn, j, ierr, page_unit, nkp_global + logical :: linner !! Is there a frozen window + logical :: lfrozen(num_bands, num_kpts) !! true if the i-th band inside outer window is frozen + integer :: nfirstwin(num_kpts) !! index of lowest band inside outer window at nkp-th + integer :: ndimfroz(num_kpts) !! number of frozen bands at nkp-th k point + integer :: indxfroz(num_bands, num_kpts) !! number of bands inside outer window at nkp-th k point + integer :: indxnfroz(num_bands, num_kpts) !! outer-window band index for the i-th non-frozen state + !! (equals 1 if it is the bottom of outer window) + + real(kind=dp), allocatable :: eigval_opt(:, :) !! At input it contains a large set of eigenvalues. At + !! it is slimmed down to contain only those inside the energy window. + complex(kind=dp), allocatable :: cwb(:, :), cww(:, :) - ! Needed to split an array on different nodes - integer, dimension(0:num_nodes - 1) :: counts - integer, dimension(0:num_nodes - 1) :: displs - if (timing_level > 0) call io_stopwatch('dis: main', 1) + ! pllel setup + integer, allocatable :: counts(:) + integer, allocatable :: displs(:) + integer :: num_nodes, my_node_id + logical :: on_root = .false. + + num_nodes = mpisize(comm) + my_node_id = mpirank(comm) + if (my_node_id == 0) on_root = .true. + allocate (counts(0:num_nodes - 1)) + allocate (displs(0:num_nodes - 1)) + + if (print_output%timing_level > 0) call io_stopwatch('dis: main', 1, stdout, seedname) - call comms_array_split(num_kpts, counts, displs) + call utility_recip_lattice_base(real_lattice, recip_lattice, volume) + call comms_array_split(num_kpts, counts, displs, comm) if (on_root) write (stdout, '(/1x,a)') & '*------------------------------- DISENTANGLE --------------------------------*' ! Allocate arrays allocate (eigval_opt(num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating eigval_opt in dis_main') + if (ierr /= 0) call io_error('Error in allocating eigval_opt in dis_main', stdout, seedname) eigval_opt = eigval ! Set up energy windows - call dis_windows() + call dis_windows(dis_spheres, dis_manifold, eigval_opt, kpt_latt, recip_lattice, indxfroz, & + indxnfroz, ndimfroz, nfirstwin, print_output%iprint, num_bands, num_kpts, & + num_wann, print_output%timing_level, lfrozen, linner, on_root, seedname, stdout) ! Construct the unitarized projection - call dis_project() + call dis_project(a_matrix, u_matrix_opt, dis_manifold%ndimwin, nfirstwin, num_bands, num_kpts, & + num_wann, print_output%timing_level, on_root, seedname, stdout) ! If there is an inner window, need to modify projection procedure ! (Sec. III.G SMV) if (linner) then - if (lsitesymmetry) call io_error('in symmetry-adapted mode, frozen window not implemented yet') !YN: RS: + if (lsitesymmetry) then + call io_error('in symmetry-adapted mode, frozen window not implemented yet', stdout, & + seedname) !YN: RS: + endif if (on_root) write (stdout, '(3x,a)') 'Using an inner window (linner = T)' - call dis_proj_froz() + call dis_proj_froz(u_matrix_opt, indxfroz, ndimfroz, dis_manifold%ndimwin, & + print_output%iprint, num_bands, num_kpts, num_wann, & + print_output%timing_level, lfrozen, on_root, seedname, stdout) else if (on_root) write (stdout, '(3x,a)') 'No inner window (linner = F)' endif ! Debug - call internal_check_orthonorm() + call internal_check_orthonorm(u_matrix_opt, dis_manifold%ndimwin, num_kpts, num_wann, & + print_output%timing_level, on_root, seedname, stdout) ! Slim down the original Mmn(k,b) - call internal_slim_m() + call internal_slim_m(m_matrix_orig_local, dis_manifold%ndimwin, nfirstwin, kmesh_info%nnlist, & + kmesh_info%nntot, num_bands, num_kpts, print_output%timing_level, & + seedname, stdout, comm) - lwindow = .false. + dis_manifold%lwindow = .false. do nkp = 1, num_kpts - do j = nfirstwin(nkp), nfirstwin(nkp) + ndimwin(nkp) - 1 - lwindow(j, nkp) = .true. + do j = nfirstwin(nkp), nfirstwin(nkp) + dis_manifold%ndimwin(nkp) - 1 + dis_manifold%lwindow(j, nkp) = .true. end do end do - if (lsitesymmetry) call sitesym_slim_d_matrix_band(lwindow) !RS: calculate initial U_{opt}(Rk) from U_{opt}(k) - if (lsitesymmetry) call sitesym_symmetrize_u_matrix(num_bands, u_matrix_opt, lwindow) !RS: + if (lsitesymmetry) then + call sitesym_symmetrize_u_matrix(sitesym, u_matrix_opt, num_bands, num_bands, num_kpts, & + num_wann, seedname, stdout, dis_manifold%lwindow) + endif + + !RS: calculate initial U_{opt}(Rk) from U_{opt}(k) ! Extract the optimally-connected num_wann-dimensional subspaces -![ysl-b] - if (.not. gamma_only) then - call dis_extract() + + if (gamma_only) then + call dis_extract_gamma(dis_control, kmesh_info, sitesym, print_output, dis_manifold, & + m_matrix_orig, u_matrix_opt, eigval_opt, omega_invariant, indxnfroz, & + ndimfroz, my_node_id, num_bands, num_kpts, num_nodes, num_wann, & + lsitesymmetry, on_root, seedname, stdout) else - call dis_extract_gamma() + call dis_extract(dis_control, kmesh_info, sitesym, print_output, dis_manifold, & + m_matrix_orig_local, u_matrix_opt, eigval_opt, omega_invariant, indxnfroz, & + ndimfroz, my_node_id, num_bands, num_kpts, num_nodes, num_wann, & + lsitesymmetry, on_root, seedname, stdout, comm) end if -![ysl-e] ! Allocate workspace allocate (cwb(num_wann, num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cwb in dis_main') + if (ierr /= 0) call io_error('Error in allocating cwb in dis_main', stdout, seedname) allocate (cww(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cww in dis_main') + if (ierr /= 0) call io_error('Error in allocating cww in dis_main', stdout, seedname) ! Find the num_wann x num_wann overlap matrices between ! the basis states of the optimal subspaces do nkp = 1, counts(my_node_id) nkp_global = nkp + displs(my_node_id) - do nn = 1, nntot - nkp2 = nnlist(nkp_global, nn) - call zgemm('C', 'N', num_wann, ndimwin(nkp2), ndimwin(nkp_global), cmplx_1, & - u_matrix_opt(:, :, nkp_global), num_bands, m_matrix_orig_local(:, :, nn, nkp), num_bands, & - cmplx_0, cwb, num_wann) - call zgemm('N', 'N', num_wann, num_wann, ndimwin(nkp2), cmplx_1, & - cwb, num_wann, u_matrix_opt(:, :, nkp2), num_bands, & - cmplx_0, cww, num_wann) + do nn = 1, kmesh_info%nntot + nkp2 = kmesh_info%nnlist(nkp_global, nn) + call zgemm('C', 'N', num_wann, dis_manifold%ndimwin(nkp2), dis_manifold%ndimwin(nkp_global), & + cmplx_1, u_matrix_opt(:, :, nkp_global), num_bands, & + m_matrix_orig_local(:, :, nn, nkp), num_bands, cmplx_0, cwb, num_wann) + call zgemm('N', 'N', num_wann, num_wann, dis_manifold%ndimwin(nkp2), cmplx_1, cwb, & + num_wann, u_matrix_opt(:, :, nkp2), num_bands, cmplx_0, cww, num_wann) m_matrix_orig_local(1:num_wann, 1:num_wann, nn, nkp) = cww(:, :) enddo enddo ! Find the initial u_matrix - if (lsitesymmetry) call sitesym_replace_d_matrix_band() !RS: replace d_matrix_band here + if (lsitesymmetry) call sitesym_replace_d_matrix_band(sitesym, num_wann) !RS: replace d_matrix_band here ![ysl-b] - if (.not. gamma_only) then - call internal_find_u() + if (gamma_only) then + call internal_find_u_gamma(a_matrix, u_matrix, u_matrix_opt, dis_manifold%ndimwin, num_wann, & + print_output%timing_level, seedname, stdout) else - call internal_find_u_gamma() + call internal_find_u(sitesym, a_matrix, u_matrix, u_matrix_opt, dis_manifold%ndimwin, & + num_bands, num_kpts, num_wann, print_output%timing_level, & + lsitesymmetry, on_root, seedname, stdout, comm) end if ![ysl-e] @@ -170,80 +225,83 @@ subroutine dis_main() ! Update the m_matrix accordingly do nkp = 1, counts(my_node_id) nkp_global = nkp + displs(my_node_id) - do nn = 1, nntot - nkp2 = nnlist(nkp_global, nn) + do nn = 1, kmesh_info%nntot + nkp2 = kmesh_info%nnlist(nkp_global, nn) call zgemm('C', 'N', num_wann, num_wann, num_wann, cmplx_1, & - u_matrix(:, :, nkp_global), num_wann, m_matrix_orig_local(:, :, nn, nkp), num_bands, & - cmplx_0, cwb, num_wann) - call zgemm('N', 'N', num_wann, num_wann, num_wann, cmplx_1, & - cwb, num_wann, u_matrix(:, :, nkp2), num_wann, & - cmplx_0, cww, num_wann) + u_matrix(:, :, nkp_global), num_wann, m_matrix_orig_local(:, :, nn, nkp), & + num_bands, cmplx_0, cwb, num_wann) + call zgemm('N', 'N', num_wann, num_wann, num_wann, cmplx_1, cwb, num_wann, & + u_matrix(:, :, nkp2), num_wann, cmplx_0, cww, num_wann) write (page_unit) cww(:, :) enddo enddo rewind (page_unit) deallocate (m_matrix_orig_local, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating m_matrix_orig_local in dis_main') + if (ierr /= 0) call io_error('Error deallocating m_matrix_orig_local in dis_main', stdout, & + seedname) if (on_root) then - allocate (m_matrix(num_wann, num_wann, nntot, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating m_matrix in dis_main') + deallocate (m_matrix) + allocate (m_matrix(num_wann, num_wann, kmesh_info%nntot, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating m_matrix in dis_main', stdout, seedname) endif - allocate (m_matrix_local(num_wann, num_wann, nntot, counts(my_node_id)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating m_matrix_local in dis_main') + deallocate (m_matrix_local) + allocate (m_matrix_local(num_wann, num_wann, kmesh_info%nntot, counts(my_node_id)), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating m_matrix_local in dis_main', stdout, & + seedname) do nkp = 1, counts(my_node_id) - do nn = 1, nntot + do nn = 1, kmesh_info%nntot read (page_unit) m_matrix_local(:, :, nn, nkp) end do end do - call comms_gatherv(m_matrix_local, num_wann*num_wann*nntot*counts(my_node_id), & - m_matrix, num_wann*num_wann*nntot*counts, num_wann*num_wann*nntot*displs) + call comms_gatherv(m_matrix_local, num_wann*num_wann*kmesh_info%nntot*counts(my_node_id), & + m_matrix, num_wann*num_wann*kmesh_info%nntot*counts, & + num_wann*num_wann*kmesh_info%nntot*displs, stdout, seedname, comm) close (page_unit) else if (on_root) then - allocate (m_matrix(num_wann, num_wann, nntot, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating m_matrix in dis_main') - else - allocate (m_matrix(0, 0, 0, 0), stat=ierr) + deallocate (m_matrix) + allocate (m_matrix(num_wann, num_wann, kmesh_info%nntot, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating m_matrix in dis_main', stdout, seedname) endif - allocate (m_matrix_local(num_wann, num_wann, nntot, counts(my_node_id)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating m_matrix_local in dis_main') + deallocate (m_matrix_local) + allocate (m_matrix_local(num_wann, num_wann, kmesh_info%nntot, counts(my_node_id)), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating m_matrix_local in dis_main', stdout, & + seedname) ! Update the m_matrix accordingly do nkp = 1, counts(my_node_id) nkp_global = nkp + displs(my_node_id) - do nn = 1, nntot - nkp2 = nnlist(nkp_global, nn) + do nn = 1, kmesh_info%nntot + nkp2 = kmesh_info%nnlist(nkp_global, nn) call zgemm('C', 'N', num_wann, num_wann, num_wann, cmplx_1, & - u_matrix(:, :, nkp_global), num_wann, m_matrix_orig_local(:, :, nn, nkp), num_bands, & - cmplx_0, cwb, num_wann) - call zgemm('N', 'N', num_wann, num_wann, num_wann, cmplx_1, & - cwb, num_wann, u_matrix(:, :, nkp2), num_wann, & - cmplx_0, cww, num_wann) + u_matrix(:, :, nkp_global), num_wann, m_matrix_orig_local(:, :, nn, nkp), & + num_bands, cmplx_0, cwb, num_wann) + call zgemm('N', 'N', num_wann, num_wann, num_wann, cmplx_1, cwb, num_wann, & + u_matrix(:, :, nkp2), num_wann, cmplx_0, cww, num_wann) m_matrix_local(:, :, nn, nkp) = cww(:, :) enddo enddo - call comms_gatherv(m_matrix_local, num_wann*num_wann*nntot*counts(my_node_id), & - m_matrix, num_wann*num_wann*nntot*counts, num_wann*num_wann*nntot*displs) + call comms_gatherv(m_matrix_local, num_wann*num_wann*kmesh_info%nntot*counts(my_node_id), & + m_matrix, num_wann*num_wann*kmesh_info%nntot*counts, & + num_wann*num_wann*kmesh_info%nntot*displs, stdout, seedname, comm) deallocate (m_matrix_orig_local, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating m_matrix_orig_local in dis_main') + if (ierr /= 0) call io_error('Error deallocating m_matrix_orig_local in dis_main', stdout, & + seedname) endif - deallocate (a_matrix, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating a_matrix in dis_main') - ! Deallocate workspace deallocate (cww, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cww in dis_main') + if (ierr /= 0) call io_error('Error in deallocating cww in dis_main', stdout, seedname) deallocate (cwb, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cwb in dis_main') + if (ierr /= 0) call io_error('Error in deallocating cwb in dis_main', stdout, seedname) !zero the unused elements of u_matrix_opt (just in case...) do nkp = 1, num_kpts do j = 1, num_wann - if (ndimwin(nkp) < num_bands) & - u_matrix_opt(ndimwin(nkp) + 1:, j, nkp) = cmplx_0 + if (dis_manifold%ndimwin(nkp) < num_bands) & + u_matrix_opt(dis_manifold%ndimwin(nkp) + 1:, j, nkp) = cmplx_0 enddo enddo @@ -264,362 +322,400 @@ subroutine dis_main() !~ endif !~![ysl-e] - ! Deallocate module arrays - call internal_dealloc() - - if (timing_level > 0 .and. on_root) call io_stopwatch('dis: main', 2) + if (print_output%timing_level > 0 .and. on_root) call io_stopwatch('dis: main', 2, stdout, & + seedname) return + !================================================! + end subroutine dis_main - contains + subroutine internal_check_orthonorm(u_matrix_opt, ndimwin, num_kpts, num_wann, timing_level, & + on_root, seedname, stdout) + !================================================! + ! + !! This subroutine checks that the states in the columns of the + !! final matrix U_opt are orthonormal at every k-point, i.e., + !! that the matrix is unitary in the sense that + !! conjg(U_opt).U_opt = 1 (but not U_opt.conjg(U_opt) = 1). + !! + !! In particular, this checks whether the projected gaussians + !! are indeed orthogonal to the frozen states, at those k-points + !! where both are present in the trial subspace. + ! + !================================================! - !================================================================! - subroutine internal_check_orthonorm() - !================================================================! - ! ! - !! This subroutine checks that the states in the columns of the - !! final matrix U_opt are orthonormal at every k-point, i.e., - !! that the matrix is unitary in the sense that - !! conjg(U_opt).U_opt = 1 (but not U_opt.conjg(U_opt) = 1). - !! - !! In particular, this checks whether the projected gaussians - !! are indeed orthogonal to the frozen states, at those k-points - !! where both are present in the trial subspace. - ! ! - !================================================================! + use w90_constants, only: eps8 - use w90_constants, only: eps8 + implicit none - implicit none + ! arguments + integer, intent(in) :: timing_level + integer, intent(in) :: stdout + integer, intent(in) :: num_kpts, num_wann + integer, intent(in) :: ndimwin(:) ! (num_kpts) - integer :: nkp, l, m, j - complex(kind=dp) :: ctmp + complex(kind=dp), intent(inout) :: u_matrix_opt(:, :, :) + character(len=50), intent(in) :: seedname - if (timing_level > 1) call io_stopwatch('dis: main: check_orthonorm', 1) + logical, intent(in) :: on_root - do nkp = 1, num_kpts - do l = 1, num_wann - do m = 1, l - ctmp = cmplx_0 - do j = 1, ndimwin(nkp) - ctmp = ctmp + conjg(u_matrix_opt(j, m, nkp))*u_matrix_opt(j, l, nkp) - enddo - if (l .eq. m) then - if (abs(ctmp - cmplx_1) .gt. eps8) then - if (on_root) write (stdout, '(3i6,2f16.12)') nkp, l, m, ctmp - if (on_root) write (stdout, '(1x,a)') 'The trial orbitals for disentanglement are not orthonormal' -! write(stdout,'(1x,a)') 'Try re-running the calculation with the input keyword' -! write(stdout,'(1x,a)') ' devel_flag=orth-fix' -! write(stdout,'(1x,a)') 'Please report the sucess or failure of this to the Wannier90 developers' - call io_error('Error in dis_main: orthonormal error 1') + ! local variables + integer :: nkp, l, m, j + + complex(kind=dp) :: ctmp + + if (timing_level > 1) call io_stopwatch('dis: main: check_orthonorm', 1, stdout, seedname) + + do nkp = 1, num_kpts + do l = 1, num_wann + do m = 1, l + ctmp = cmplx_0 + do j = 1, ndimwin(nkp) + ctmp = ctmp + conjg(u_matrix_opt(j, m, nkp))*u_matrix_opt(j, l, nkp) + enddo + if (l .eq. m) then + if (abs(ctmp - cmplx_1) .gt. eps8) then + if (on_root) then + write (stdout, '(3i6,2f16.12)') nkp, l, m, ctmp + write (stdout, '(1x,a)') & + 'The trial orbitals for disentanglement are not orthonormal' endif - else - if (abs(ctmp) .gt. eps8) then - if (on_root) write (stdout, '(3i6,2f16.12)') nkp, l, m, ctmp - if (on_root) write (stdout, '(1x,a)') 'The trial orbitals for disentanglement are not orthonormal' -! write(stdout,'(1x,a)') 'Try re-running the calculation with the input keyword' -! write(stdout,'(1x,a)') ' devel_flag=orth-fix' -! write(stdout,'(1x,a)') 'Please report the sucess or failure of this to the Wannier90 developers' - call io_error('Error in dis_main: orthonormal error 2') + call io_error('Error in dis_main: orthonormal error 1', stdout, seedname) + endif + else + if (abs(ctmp) .gt. eps8) then + if (on_root) then + write (stdout, '(3i6,2f16.12)') nkp, l, m, ctmp + write (stdout, '(1x,a)') & + 'The trial orbitals for disentanglement are not orthonormal' endif + call io_error('Error in dis_main: orthonormal error 2', stdout, seedname) endif - enddo + endif enddo enddo + enddo - if (timing_level > 1 .and. on_root) call io_stopwatch('dis: main: check_orthonorm', 2) + if (timing_level > 1 .and. on_root) call io_stopwatch('dis: main: check_orthonorm', 2, stdout, & + seedname) - return + return + !================================================! + end subroutine internal_check_orthonorm - end subroutine internal_check_orthonorm + subroutine internal_slim_m(m_matrix_orig_local, ndimwin, nfirstwin, nnlist, nntot, num_bands, & + num_kpts, timing_level, seedname, stdout, comm) + !================================================! + ! + !! This subroutine slims down the original Mmn(k,b), removing + !! rows and columns corresponding to u_nks that fall outside + !! the outer energy window. + ! + !================================================! - !================================================================! - subroutine internal_slim_m() - !================================================================! - ! ! - !! This subroutine slims down the original Mmn(k,b), removing - !! rows and columns corresponding to u_nks that fall outside - !! the outer energy window. - ! ! - !================================================================! + implicit none - implicit none + ! arguments + type(w90comm_type), intent(in) :: comm - integer :: nkp, nkp2, nn, i, j, m, n, ierr - integer :: nkp_global - complex(kind=dp), allocatable :: cmtmp(:, :) - ! Needed to split an array on different nodes - integer, dimension(0:num_nodes - 1) :: counts - integer, dimension(0:num_nodes - 1) :: displs + integer, intent(in) :: timing_level + integer, intent(in) :: num_bands, num_kpts + integer, intent(in) :: stdout + integer, intent(in) :: ndimwin(:) + integer, intent(in) :: nntot, nnlist(:, :) ! (num_kpts, nntot) + integer, intent(in) :: nfirstwin(:) ! (num_kpts) index of lowest band inside outer window at nkp-th - if (timing_level > 1 .and. on_root) call io_stopwatch('dis: main: slim_m', 1) + complex(kind=dp), intent(inout) :: m_matrix_orig_local(:, :, :, :) - call comms_array_split(num_kpts, counts, displs) + character(len=50), intent(in) :: seedname - allocate (cmtmp(num_bands, num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cmtmp in dis_main') + ! local variables + integer :: nkp, nkp2, nn, i, j, m, n, ierr + integer :: nkp_global - do nkp = 1, counts(my_node_id) - nkp_global = nkp + displs(my_node_id) - do nn = 1, nntot - nkp2 = nnlist(nkp_global, nn) - do j = 1, ndimwin(nkp2) - n = nfirstwin(nkp2) + j - 1 - do i = 1, ndimwin(nkp_global) - m = nfirstwin(nkp_global) + i - 1 - cmtmp(i, j) = m_matrix_orig_local(m, n, nn, nkp) - enddo + complex(kind=dp), allocatable :: cmtmp(:, :) + + integer, allocatable :: counts(:) + integer, allocatable :: displs(:) + integer :: num_nodes, my_node_id + logical :: on_root = .false. + + num_nodes = mpisize(comm) + my_node_id = mpirank(comm) + if (my_node_id == 0) on_root = .true. + allocate (counts(0:num_nodes - 1)) + allocate (displs(0:num_nodes - 1)) + + if (timing_level > 1 .and. on_root) call io_stopwatch('dis: main: slim_m', 1, stdout, seedname) + + call comms_array_split(num_kpts, counts, displs, comm) + + allocate (cmtmp(num_bands, num_bands), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating cmtmp in dis_main', stdout, seedname) + + do nkp = 1, counts(my_node_id) + nkp_global = nkp + displs(my_node_id) + do nn = 1, nntot + nkp2 = nnlist(nkp_global, nn) + do j = 1, ndimwin(nkp2) + n = nfirstwin(nkp2) + j - 1 + do i = 1, ndimwin(nkp_global) + m = nfirstwin(nkp_global) + i - 1 + cmtmp(i, j) = m_matrix_orig_local(m, n, nn, nkp) enddo - m_matrix_orig_local(:, :, nn, nkp) = cmplx_0 - do j = 1, ndimwin(nkp2) - do i = 1, ndimwin(nkp_global) - m_matrix_orig_local(i, j, nn, nkp) = cmtmp(i, j) - enddo + enddo + m_matrix_orig_local(:, :, nn, nkp) = cmplx_0 + do j = 1, ndimwin(nkp2) + do i = 1, ndimwin(nkp_global) + m_matrix_orig_local(i, j, nn, nkp) = cmtmp(i, j) enddo enddo enddo + enddo - deallocate (cmtmp, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cmtmp in dis_main') - - if (timing_level > 1 .and. on_root) call io_stopwatch('dis: main: slim_m', 2) - - return - - end subroutine internal_slim_m - - !================================================================! - subroutine internal_find_u() - !================================================================! - ! ! - !! This subroutine finds the initial guess for the square unitary - !! rotation matrix u_matrix. The method is similar to Sec. III.D - !! of SMV, but with square instead of rectangular matrices: - !! - !! First find caa, the square overlap matrix , - !! where psitilde is an eigenstate of the optimal subspace. - !! - !! Note that, contrary to what is implied in Sec. III.E of SMV, - !! this does *not* need to be computed by brute: instead we take - !! advantage of the previous computation of overlaps with the - !! same projections that are used to initiate the minimization of - !! Omega. - !! - !! Note: |psi> U_opt = |psitilde> and obviously - !! 1 .and. on_root) call io_stopwatch('dis: main: find_u', 1) - - ! Currently, this part is not parallelized; thus, we perform the task only on root and then broadcast the result. - if (on_root) then - ! Allocate arrays needed for ZGESVD - allocate (svals(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating svals in dis_main') - allocate (rwork(5*num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating rwork in dis_main') - allocate (cv(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cv in dis_main') - allocate (cz(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cz in dis_main') - allocate (cwork(4*num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cwork in dis_main') - allocate (caa(num_wann, num_wann, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating caa in dis_main') + deallocate (cmtmp, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating cmtmp in dis_main', stdout, seedname) - do nkp = 1, num_kpts - if (lsitesymmetry) then !YN: RS: - if (ir2ik(ik2ir(nkp)) .ne. nkp) cycle !YN: RS: - endif !YN: RS: - call zgemm('C', 'N', num_wann, num_wann, ndimwin(nkp), cmplx_1, & - u_matrix_opt(:, :, nkp), num_bands, a_matrix(:, :, nkp), num_bands, & - cmplx_0, caa(:, :, nkp), num_wann) - ! Singular-value decomposition - call ZGESVD('A', 'A', num_wann, num_wann, caa(:, :, nkp), num_wann, & - svals, cz, num_wann, cv, num_wann, cwork, 4*num_wann, rwork, info) - if (info .ne. 0) then - if (on_root) write (stdout, *) ' ERROR: IN ZGESVD IN dis_main' - if (on_root) write (stdout, *) 'K-POINT NKP=', nkp, ' INFO=', info - if (info .lt. 0) then - if (on_root) write (stdout, *) 'THE ', -info, '-TH ARGUMENT HAD ILLEGAL VALUE' - endif - call io_error('dis_main: problem in ZGESVD 1') - endif - ! u_matrix is the initial guess for the unitary rotation of the - ! basis states given by the subroutine extract - call zgemm('N', 'N', num_wann, num_wann, num_wann, cmplx_1, & - cz, num_wann, cv, num_wann, cmplx_0, u_matrix(:, :, nkp), num_wann) - enddo - endif - call comms_bcast(u_matrix(1, 1, 1), num_wann*num_wann*num_kpts) -! if (lsitesymmetry) call sitesym_symmetrize_u_matrix(num_wann,u_matrix) !RS: + if (timing_level > 1 .and. on_root) call io_stopwatch('dis: main: slim_m', 2, stdout, seedname) - if (on_root) then - ! Deallocate arrays for ZGESVD - deallocate (caa, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating caa in dis_main') - deallocate (cwork, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cwork in dis_main') - deallocate (cz, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cz in dis_main') - deallocate (cv, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cv in dis_main') - deallocate (rwork, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating rwork in dis_main') - deallocate (svals, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating svals in dis_main') - endif + return + !================================================! + end subroutine internal_slim_m + + subroutine internal_find_u(sitesym, a_matrix, u_matrix, u_matrix_opt, ndimwin, num_bands, & + num_kpts, num_wann, timing_level, lsitesymmetry, on_root, seedname, & + stdout, comm) + !================================================! + ! + !! This subroutine finds the initial guess for the square unitary + !! rotation matrix u_matrix. The method is similar to Sec. III.D + !! of SMV, but with square instead of rectangular matrices: + !! + !! First find caa, the square overlap matrix , + !! where psitilde is an eigenstate of the optimal subspace. + !! + !! Note that, contrary to what is implied in Sec. III.E of SMV, + !! this does *not* need to be computed by brute: instead we take + !! advantage of the previous computation of overlaps with the + !! same projections that are used to initiate the minimization of + !! Omega. + !! + !! Note: |psi> U_opt = |psitilde> and obviously + !! 1) call io_stopwatch('dis: main: find_u', 2) + implicit none - return + ! arguments + integer, intent(in) :: timing_level + integer, intent(in) :: stdout + integer, intent(in) :: num_bands, num_kpts, num_wann + integer, intent(in) :: ndimwin(:) ! (num_kpts) - end subroutine internal_find_u + complex(kind=dp), intent(in) :: a_matrix(:, :, :) + complex(kind=dp), intent(inout) :: u_matrix(:, :, :) + complex(kind=dp), intent(inout) :: u_matrix_opt(:, :, :) -![ysl-b] - !================================================================! - subroutine internal_find_u_gamma() - !================================================================! - ! ! - !! Make initial u_matrix real - !! Must be the case when gamma_only = .true. - ! ! - !================================================================! - - implicit none - - integer :: info, ierr - real(kind=dp), allocatable :: u_opt_r(:, :) - real(kind=dp), allocatable :: a_matrix_r(:, :) - real(kind=dp), allocatable :: raa(:, :) - ! For DGESVD - real(kind=dp), allocatable :: svals(:) - real(kind=dp), allocatable :: work(:) - real(kind=dp), allocatable :: rv(:, :) - real(kind=dp), allocatable :: rz(:, :) - - if (timing_level > 1) call io_stopwatch('dis: main: find_u_gamma', 1) - - ! Allocate arrays needed for getting a_matrix_r - allocate (u_opt_r(ndimwin(1), num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating u_opt_r in dis_main') - allocate (a_matrix_r(ndimwin(1), num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating a_matrix_r in dis_main') - - ! Allocate arrays needed for DGESVD + logical, intent(in) :: on_root, lsitesymmetry + + type(sitesym_type), intent(inout) :: sitesym + type(w90comm_type), intent(in) :: comm + + character(len=50), intent(in) :: seedname + + ! local variables + integer :: nkp, info, ierr + complex(kind=dp), allocatable :: caa(:, :, :) + ! For ZGESVD + real(kind=dp), allocatable :: svals(:) + real(kind=dp), allocatable :: rwork(:) + + complex(kind=dp), allocatable :: cv(:, :) + complex(kind=dp), allocatable :: cz(:, :) + complex(kind=dp), allocatable :: cwork(:) + + if (timing_level > 1 .and. on_root) call io_stopwatch('dis: main: find_u', 1, stdout, seedname) + + ! Currently, this part is not parallelized; thus, we perform the task only on root and then broadcast the result. + if (on_root) then + ! Allocate arrays needed for ZGESVD allocate (svals(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating svals in dis_main') - allocate (work(5*num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating rwork in dis_main') - allocate (rv(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cv in dis_main') - allocate (rz(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cz in dis_main') - allocate (raa(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating raa in dis_main') - - u_opt_r(:, :) = real(u_matrix_opt(1:ndimwin(1), 1:num_wann, 1), dp) - - a_matrix_r(:, :) = real(a_matrix(1:ndimwin(1), 1:num_wann, 1), kind=dp) - - call dgemm('T', 'N', num_wann, num_wann, ndimwin(1), 1.0_dp, & - u_opt_r, ndimwin(1), a_matrix_r, ndimwin(1), & - 0.0_dp, raa, num_wann) - ! Singular-value decomposition - call DGESVD('A', 'A', num_wann, num_wann, raa, num_wann, & - svals, rz, num_wann, rv, num_wann, work, 5*num_wann, info) - if (info .ne. 0) then - write (stdout, *) ' ERROR: IN DGESVD IN dis_main' - write (stdout, *) 'K-POINT = Gamma', ' INFO=', info - if (info .lt. 0) then - write (stdout, *) 'THE ', -info, '-TH ARGUMENT HAD ILLEGAL VALUE' + if (ierr /= 0) call io_error('Error in allocating svals in dis_main', stdout, seedname) + allocate (rwork(5*num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating rwork in dis_main', stdout, seedname) + allocate (cv(num_wann, num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating cv in dis_main', stdout, seedname) + allocate (cz(num_wann, num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating cz in dis_main', stdout, seedname) + allocate (cwork(4*num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating cwork in dis_main', stdout, seedname) + allocate (caa(num_wann, num_wann, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating caa in dis_main', stdout, seedname) + + do nkp = 1, num_kpts + if (lsitesymmetry) then !YN: RS: + if (sitesym%ir2ik(sitesym%ik2ir(nkp)) .ne. nkp) cycle !YN: RS: + endif !YN: RS: + call zgemm('C', 'N', num_wann, num_wann, ndimwin(nkp), cmplx_1, u_matrix_opt(:, :, nkp), & + num_bands, a_matrix(:, :, nkp), num_bands, cmplx_0, caa(:, :, nkp), num_wann) + ! Singular-value decomposition + call ZGESVD('A', 'A', num_wann, num_wann, caa(:, :, nkp), num_wann, svals, cz, num_wann, & + cv, num_wann, cwork, 4*num_wann, rwork, info) + if (info .ne. 0) then + if (on_root) write (stdout, *) ' ERROR: IN ZGESVD IN dis_main' + if (on_root) write (stdout, *) 'K-POINT NKP=', nkp, ' INFO=', info + if (info .lt. 0) then + if (on_root) write (stdout, *) 'THE ', -info, '-TH ARGUMENT HAD ILLEGAL VALUE' + endif + call io_error('dis_main: problem in ZGESVD 1', stdout, seedname) endif - call io_error('dis_main: problem in DGESVD 1') - endif - ! u_matrix is the initial guess for the unitary rotation of the - ! basis states given by the subroutine extract - call dgemm('N', 'N', num_wann, num_wann, num_wann, 1.0_dp, & - rz, num_wann, rv, num_wann, 0.0_dp, raa, num_wann) - - u_matrix(:, :, 1) = cmplx(raa(:, :), 0.0_dp, dp) - - ! Deallocate arrays for DGESVD - deallocate (raa, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating raa in dis_main') - deallocate (rz, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating rz in dis_main') - deallocate (rv, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating rv in dis_main') - deallocate (work, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating work in dis_main') + ! u_matrix is the initial guess for the unitary rotation of the + ! basis states given by the subroutine extract + call zgemm('N', 'N', num_wann, num_wann, num_wann, cmplx_1, cz, num_wann, cv, num_wann, & + cmplx_0, u_matrix(:, :, nkp), num_wann) + enddo + endif + call comms_bcast(u_matrix(1, 1, 1), num_wann*num_wann*num_kpts, stdout, seedname, comm) +! if (lsitesymmetry) call sitesym_symmetrize_u_matrix(num_wann,u_matrix) !RS: + + if (on_root) then + ! Deallocate arrays for ZGESVD + deallocate (caa, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating caa in dis_main', stdout, seedname) + deallocate (cwork, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating cwork in dis_main', stdout, seedname) + deallocate (cz, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating cz in dis_main', stdout, seedname) + deallocate (cv, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating cv in dis_main', stdout, seedname) + deallocate (rwork, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating rwork in dis_main', stdout, seedname) deallocate (svals, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating svals in dis_main') + if (ierr /= 0) call io_error('Error deallocating svals in dis_main', stdout, seedname) + endif - ! Deallocate arrays for a_matrix_r - deallocate (a_matrix_r, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating a_matrix_r in dis_main') - deallocate (u_opt_r, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating u_opt_r in dis_main') + if (lsitesymmetry) then + call sitesym_symmetrize_u_matrix(sitesym, u_matrix, num_bands, num_wann, num_kpts, num_wann, & + seedname, stdout) + endif - if (timing_level > 1) call io_stopwatch('dis: main: find_u_gamma', 2) + if (timing_level > 1) call io_stopwatch('dis: main: find_u', 2, stdout, seedname) - return + return + !================================================! + end subroutine internal_find_u - end subroutine internal_find_u_gamma -![ysl-e] +![ysl-b] + subroutine internal_find_u_gamma(a_matrix, u_matrix, u_matrix_opt, ndimwin, num_wann, & + timing_level, seedname, stdout) + !================================================! + ! + !! Make initial u_matrix real + !! Must be the case when gamma_only = .true. + ! + !================================================! + + implicit none + + ! arguments + integer, intent(in) :: timing_level, num_wann + integer, intent(in) :: stdout + integer, intent(in) :: ndimwin(:) - !==================================! - subroutine internal_dealloc() - !==================================! - !! Deallocate module data - ! ! - !==================================! + complex(kind=dp), intent(in) :: a_matrix(:, :, :) + complex(kind=dp), intent(inout) :: u_matrix(:, :, :) + complex(kind=dp), intent(inout) :: u_matrix_opt(:, :, :) + character(len=50), intent(in) :: seedname - implicit none + ! local variables + integer :: info, ierr - integer :: ierr + real(kind=dp), allocatable :: u_opt_r(:, :) + real(kind=dp), allocatable :: a_matrix_r(:, :) + real(kind=dp), allocatable :: raa(:, :) + ! For DGESVD + real(kind=dp), allocatable :: svals(:) + real(kind=dp), allocatable :: work(:) + real(kind=dp), allocatable :: rv(:, :) + real(kind=dp), allocatable :: rz(:, :) - ! Module arrays allocated in dis_windows - deallocate (lfrozen, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating lfrozen in dis_main') - deallocate (indxnfroz, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating indxnfroz in dis_main') - deallocate (indxfroz, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating indxfroz in dis_main') - deallocate (ndimfroz, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating ndimfroz in dis_main') - deallocate (nfirstwin, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating nfirstwin in dis_main') + if (timing_level > 1) call io_stopwatch('dis: main: find_u_gamma', 1, stdout, seedname) + + ! Allocate arrays needed for getting a_matrix_r + allocate (u_opt_r(ndimwin(1), num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating u_opt_r in dis_main', stdout, seedname) + allocate (a_matrix_r(ndimwin(1), num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating a_matrix_r in dis_main', stdout, seedname) + + ! Allocate arrays needed for DGESVD + allocate (svals(num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating svals in dis_main', stdout, seedname) + allocate (work(5*num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating rwork in dis_main', stdout, seedname) + allocate (rv(num_wann, num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating cv in dis_main', stdout, seedname) + allocate (rz(num_wann, num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating cz in dis_main', stdout, seedname) + allocate (raa(num_wann, num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating raa in dis_main', stdout, seedname) + + u_opt_r(:, :) = real(u_matrix_opt(1:ndimwin(1), 1:num_wann, 1), dp) + + a_matrix_r(:, :) = real(a_matrix(1:ndimwin(1), 1:num_wann, 1), kind=dp) + + call dgemm('T', 'N', num_wann, num_wann, ndimwin(1), 1.0_dp, u_opt_r, ndimwin(1), a_matrix_r, & + ndimwin(1), 0.0_dp, raa, num_wann) + ! Singular-value decomposition + call DGESVD('A', 'A', num_wann, num_wann, raa, num_wann, svals, rz, num_wann, rv, num_wann, & + work, 5*num_wann, info) + if (info .ne. 0) then + write (stdout, *) ' ERROR: IN DGESVD IN dis_main' + write (stdout, *) 'K-POINT = Gamma', ' INFO=', info + if (info .lt. 0) then + write (stdout, *) 'THE ', -info, '-TH ARGUMENT HAD ILLEGAL VALUE' + endif + call io_error('dis_main: problem in DGESVD 1', stdout, seedname) + endif + ! u_matrix is the initial guess for the unitary rotation of the + ! basis states given by the subroutine extract + call dgemm('N', 'N', num_wann, num_wann, num_wann, 1.0_dp, rz, num_wann, rv, num_wann, 0.0_dp, & + raa, num_wann) - ! Module arrays allocated in dis_main - deallocate (eigval_opt, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating eigval_opt in dis_main') + u_matrix(:, :, 1) = cmplx(raa(:, :), 0.0_dp, dp) - return + ! Deallocate arrays for DGESVD + deallocate (raa, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating raa in dis_main', stdout, seedname) + deallocate (rz, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating rz in dis_main', stdout, seedname) + deallocate (rv, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating rv in dis_main', stdout, seedname) + deallocate (work, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating work in dis_main', stdout, seedname) + deallocate (svals, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating svals in dis_main', stdout, seedname) - end subroutine internal_dealloc + ! Deallocate arrays for a_matrix_r + deallocate (a_matrix_r, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating a_matrix_r in dis_main', stdout, seedname) + deallocate (u_opt_r, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating u_opt_r in dis_main', stdout, seedname) - end subroutine dis_main + if (timing_level > 1) call io_stopwatch('dis: main: find_u_gamma', 2, stdout, seedname) + + return + !================================================! + end subroutine internal_find_u_gamma +![ysl-e] - !==================================================================! - subroutine dis_windows() - !==================================================================! - ! ! + subroutine dis_windows(dis_spheres, dis_manifold, eigval_opt, kpt_latt, recip_lattice, & + indxfroz, indxnfroz, ndimfroz, nfirstwin, iprint, num_bands, num_kpts, & + num_wann, timing_level, lfrozen, linner, on_root, seedname, stdout) + !================================================! + ! !! This subroutine selects the states that are inside the outer !! window (ie, the energy window out of which we fish out the !! optimally-connected subspace) and those that are inside the @@ -633,18 +729,8 @@ subroutine dis_windows() !! Note - in windows eigval_opt are shifted, so the lowest ones go !! from nfirstwin(nkp) to nfirstwin(nkp)+ndimwin(nkp)-1, and above !! they are set to zero. - ! ! - !==================================================================! - - implicit none - - ! internal variables - integer :: i, j, nkp, ierr - integer :: imin, imax, kifroz_min, kifroz_max - !~~ GS-start - real(kind=dp) :: dk(3), kdr2 - logical :: dis_ok - !~~ GS-end + ! + !================================================! ! OUTPUT: ! ndimwin(nkp) number of bands inside outer window at nkp-th k poi @@ -661,19 +747,36 @@ subroutine dis_windows() ! it is slimmed down to contain only those inside the ! energy window, stored in nb=1,...,ndimwin(nkp) - if (timing_level > 1 .and. on_root) call io_stopwatch('dis: windows', 1) + implicit none + + ! arguments + type(dis_spheres_type), intent(in) :: dis_spheres + type(dis_manifold_type), intent(inout) :: dis_manifold ! ndimwin alone is modified + + integer, intent(in) :: iprint, timing_level + integer, intent(in) :: stdout + integer, intent(in) :: num_bands, num_kpts, num_wann + integer, intent(inout) :: ndimfroz(:) + integer, intent(inout) :: indxfroz(:, :) + integer, intent(inout) :: indxnfroz(:, :) + integer, intent(inout) :: nfirstwin(:) + + real(kind=dp), intent(in) :: kpt_latt(3, num_kpts), recip_lattice(3, 3) + real(kind=dp), intent(inout) :: eigval_opt(:, :) + + character(len=50), intent(in) :: seedname - ! Allocate module arrays - allocate (nfirstwin(num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating nfirstwin in dis_windows') - allocate (ndimfroz(num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ndimfroz in dis_windows') - allocate (indxfroz(num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating indxfroz in dis_windows') - allocate (indxnfroz(num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating indxnfroz in dis_windows') - allocate (lfrozen(num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating lfrozen in dis_windows') + logical, intent(in) :: on_root + logical, intent(inout) :: linner + logical, intent(inout) :: lfrozen(:, :) + + ! local variables + integer :: i, j, nkp + integer :: imin, imax, kifroz_min, kifroz_max + real(kind=dp) :: dk(3) + logical :: dis_ok + + if (timing_level > 1 .and. on_root) call io_stopwatch('dis: windows', 1, stdout, seedname) linner = .false. @@ -684,11 +787,11 @@ subroutine dis_windows() if (on_root) write (stdout, '(1x,a)') & '| --------------- |' if (on_root) write (stdout, '(1x,a,f10.5,a,f10.5,a)') & - '| Outer: ', dis_win_min, ' to ', dis_win_max, & + '| Outer: ', dis_manifold%win_min, ' to ', dis_manifold%win_max, & ' (eV) |' - if (frozen_states) then + if (dis_manifold%frozen_states) then if (on_root) write (stdout, '(1x,a,f10.5,a,f10.5,a)') & - '| Inner: ', dis_froz_min, ' to ', dis_froz_max, & + '| Inner: ', dis_manifold%froz_min, ' to ', dis_manifold%froz_max, & ' (eV) |' else if (on_root) write (stdout, '(1x,a)') & @@ -699,62 +802,65 @@ subroutine dis_windows() do nkp = 1, num_kpts ! Check which eigenvalues fall within the outer window - if ((eigval_opt(1, nkp) .gt. dis_win_max) .or. & - (eigval_opt(num_bands, nkp) .lt. dis_win_min)) then - if (on_root) write (stdout, *) ' ERROR AT K-POINT: ', nkp - if (on_root) write (stdout, *) ' ENERGY WINDOW (eV): [', dis_win_min, ',', dis_win_max, ']' - if (on_root) write (stdout, *) ' EIGENVALUE RANGE (eV): [', & - eigval_opt(1, nkp), ',', eigval_opt(num_bands, nkp), ']' - call io_error('dis_windows: The outer energy window contains no eigenvalues') + if ((eigval_opt(1, nkp) .gt. dis_manifold%win_max) .or. & + (eigval_opt(num_bands, nkp) .lt. dis_manifold%win_min)) then + if (on_root) then + write (stdout, *) ' ERROR AT K-POINT: ', nkp + write (stdout, *) ' ENERGY WINDOW (eV): [', dis_manifold%win_min, ',', & + dis_manifold%win_max, ']' + write (stdout, *) ' EIGENVALUE RANGE (eV): [', & + eigval_opt(1, nkp), ',', eigval_opt(num_bands, nkp), ']' + call io_error('dis_windows: The outer energy window contains no eigenvalues', stdout, seedname) + endif endif ! Note: we assume that eigvals are ordered from the bottom up imin = 0 do i = 1, num_bands if (imin .eq. 0) then - if ((eigval_opt(i, nkp) .ge. dis_win_min) .and. & - (eigval_opt(i, nkp) .le. dis_win_max)) imin = i + if ((eigval_opt(i, nkp) .ge. dis_manifold%win_min) .and. & + (eigval_opt(i, nkp) .le. dis_manifold%win_max)) imin = i imax = i endif - if (eigval_opt(i, nkp) .le. dis_win_max) imax = i + if (eigval_opt(i, nkp) .le. dis_manifold%win_max) imax = i enddo - ndimwin(nkp) = imax - imin + 1 + dis_manifold%ndimwin(nkp) = imax - imin + 1 nfirstwin(nkp) = imin !~~ GS-start ! disentangle at the current k-point only if it is within one of the ! spheres centered at the k-points listed in kpt_dis - if (dis_spheres_num .gt. 0) then + if (dis_spheres%num .gt. 0) then dis_ok = .false. ! loop on the sphere centers - do i = 1, dis_spheres_num - dk = kpt_latt(:, nkp) - dis_spheres(1:3, i) + do i = 1, dis_spheres%num + dk = kpt_latt(:, nkp) - dis_spheres%spheres(1:3, i) dk = matmul(anint(dk) - dk, recip_lattice(:, :)) ! if the current k-point is included in at least one sphere, ! then perform disentanglement as usual - if (abs(dot_product(dk, dk)) .lt. dis_spheres(4, i)**2) then + if (abs(dot_product(dk, dk)) .lt. dis_spheres%spheres(4, i)**2) then dis_ok = .true. exit endif enddo ! this kpoint is not included in any sphere: no disentaglement if (.not. dis_ok) then - ndimwin(nkp) = num_wann - nfirstwin(nkp) = dis_spheres_first_wann + dis_manifold%ndimwin(nkp) = num_wann + nfirstwin(nkp) = dis_spheres%first_wann endif endif !~~ GS-end - if (ndimwin(nkp) .lt. num_wann) then - if (on_root) write (stdout, 483) 'Error at k-point ', nkp, & - ' ndimwin=', ndimwin(nkp), ' num_wann=', num_wann -483 format(1x, a17, i4, a8, i3, a9, i3) - call io_error('dis_windows: Energy window contains fewer states than number of target WFs') + if (dis_manifold%ndimwin(nkp) .lt. num_wann) then + if (on_root) write (stdout, '(1x, a17, i4, a8, i3, a9, i3)') 'Error at k-point ', nkp, & + ' ndimwin=', dis_manifold%ndimwin(nkp), ' num_wann=', num_wann + call io_error('dis_windows: Energy window contains fewer states than number of target WFs', & + stdout, seedname) endif - do i = 1, ndimwin(nkp) + do i = 1, dis_manifold%ndimwin(nkp) lfrozen(i, nkp) = .false. enddo @@ -763,16 +869,16 @@ subroutine dis_windows() kifroz_max = -1 ! (note that the above obeys kifroz_max-kifroz_min+1=kdimfroz=0, as we w - if (frozen_states) then + if (dis_manifold%frozen_states) then do i = imin, imax if (kifroz_min .eq. 0) then - if ((eigval_opt(i, nkp) .ge. dis_froz_min) .and. & - (eigval_opt(i, nkp) .le. dis_froz_max)) then + if ((eigval_opt(i, nkp) .ge. dis_manifold%froz_min) .and. & + (eigval_opt(i, nkp) .le. dis_manifold%froz_max)) then ! Relative to bottom of outer window kifroz_min = i - imin + 1 kifroz_max = i - imin + 1 endif - elseif (eigval_opt(i, nkp) .le. dis_froz_max) then + elseif (eigval_opt(i, nkp) .le. dis_manifold%froz_max) then kifroz_max = kifroz_max + 1 ! DEBUG ! if(kifroz_max.ne.i-imin+1) stop 'something wrong...' @@ -790,7 +896,7 @@ subroutine dis_windows() ' TARGET BANDS') if (on_root) write (stdout, 402) (eigval_opt(i, nkp), i=imin, imax) 402 format('BANDS: (eV)', 10(F10.5, 1X)) - call io_error('dis_windows: More states in the frozen window than target WFs') + call io_error('dis_windows: More states in the frozen window than target WFs', stdout, seedname) endif if (ndimfroz(nkp) .gt. 0) linner = .true. @@ -806,18 +912,20 @@ subroutine dis_windows() lfrozen(indxfroz(i, nkp), nkp) = .true. enddo if (indxfroz(ndimfroz(nkp), nkp) .ne. kifroz_max) then - if (on_root) write (stdout, *) ' Error at k-point ', nkp, ' frozen band #', i - if (on_root) write (stdout, *) ' ndimfroz=', ndimfroz(nkp) - if (on_root) write (stdout, *) ' kifroz_min=', kifroz_min - if (on_root) write (stdout, *) ' kifroz_max=', kifroz_max - if (on_root) write (stdout, *) ' indxfroz(i,nkp)=', indxfroz(i, nkp) - call io_error('dis_windows: Something fishy...') + if (on_root) then + write (stdout, *) ' Error at k-point ', nkp, ' frozen band #', i + write (stdout, *) ' ndimfroz=', ndimfroz(nkp) + write (stdout, *) ' kifroz_min=', kifroz_min + write (stdout, *) ' kifroz_max=', kifroz_max + write (stdout, *) ' indxfroz(i,nkp)=', indxfroz(i, nkp) + endif + call io_error('dis_windows: Something fishy...', stdout, seedname) endif endif ! Generate index array for non-frozen states i = 0 - do j = 1, ndimwin(nkp) + do j = 1, dis_manifold%ndimwin(nkp) ! if (lfrozen(j,nkp).eqv..false.) then if (.not. lfrozen(j, nkp)) then i = i + 1 @@ -825,20 +933,20 @@ subroutine dis_windows() endif enddo - if (i .ne. ndimwin(nkp) - ndimfroz(nkp)) then + if (i .ne. dis_manifold%ndimwin(nkp) - ndimfroz(nkp)) then if (on_root) write (stdout, *) ' Error at k-point: ', nkp - if (on_root) write (stdout, '(3(a,i5))') ' i: ', i, ' ndimwin: ', ndimwin(nkp), & - ' ndimfroz: ', ndimfroz(nkp) - call io_error('dis_windows: i .ne. (ndimwin-ndimfroz) at k-point') + if (on_root) write (stdout, '(3(a,i5))') ' i: ', i, ' ndimwin: ', & + dis_manifold%ndimwin(nkp), ' ndimfroz: ', ndimfroz(nkp) + call io_error('dis_windows: i .ne. (ndimwin-ndimfroz) at k-point', stdout, seedname) endif ! Slim down eigval vector at present k - do i = 1, ndimwin(nkp) + do i = 1, dis_manifold%ndimwin(nkp) j = nfirstwin(nkp) + i - 1 eigval_opt(i, nkp) = eigval_opt(j, nkp) enddo - do i = ndimwin(nkp) + 1, num_bands + do i = dis_manifold%ndimwin(nkp) + 1, num_bands eigval_opt(i, nkp) = 0.0_dp enddo @@ -894,34 +1002,31 @@ subroutine dis_windows() if (on_root) write (stdout, '(3x,a,i4)') 'Number of target bands to extract: ', num_wann if (iprint > 1) then - if (on_root) write (stdout, '(1x,a)') & - '+----------------------------------------------------------------------------+' - if (on_root) write (stdout, '(1x,a)') & - '| Windows |' - if (on_root) write (stdout, '(1x,a)') & - '| ------- |' - if (on_root) write (stdout, '(1x,a)') & - '| K-point Ndimwin Ndimfroz Nfirstwin |' - if (on_root) write (stdout, '(1x,a)') & + if (on_root) write (stdout, '(4(1x,a,/),(1x,a))') & + '+----------------------------------------------------------------------------+', & + '| Windows |', & + '| ------- |', & + '| K-point Ndimwin Ndimfroz Nfirstwin |', & '| ---------------------------------------------- |' + do nkp = 1, num_kpts - if (on_root) write (stdout, 403) nkp, ndimwin(nkp), ndimfroz(nkp), nfirstwin(nkp) + if (on_root) write (stdout, 403) nkp, dis_manifold%ndimwin(nkp), ndimfroz(nkp), nfirstwin(nkp) enddo 403 format(1x, '|', 14x, i6, 7x, i6, 7x, i6, 6x, i6, 18x, '|') if (on_root) write (stdout, '(1x,a)') & '+----------------------------------------------------------------------------+' endif - if (timing_level > 1) call io_stopwatch('dis: windows', 2) + if (timing_level > 1) call io_stopwatch('dis: windows', 2, stdout, seedname) return - + !================================================! end subroutine dis_windows - !==================================================================! - subroutine dis_project() - !==================================================================! - ! ! + subroutine dis_project(a_matrix, u_matrix_opt, ndimwin, nfirstwin, num_bands, num_kpts, & + num_wann, timing_level, on_root, seedname, stdout) + !================================================! + ! !! Construct projections for the start of the disentanglement routine !! !! Original notes from Nicola (refers only to the square case) @@ -964,23 +1069,38 @@ subroutine dis_project() !! num_wann x num_wann and diagonal, and CVdag is !! num_wann x num_wann and unitary. !! - !==================================================================! + !================================================! use w90_constants, only: eps5 implicit none - ! internal variables + ! arguments + integer, intent(in) :: timing_level + integer, intent(in) :: stdout + integer, intent(in) :: num_bands, num_kpts, num_wann + integer, intent(in) :: ndimwin(:) + integer, intent(in) :: nfirstwin(:) + + complex(kind=dp), intent(inout) :: a_matrix(:, :, :) + complex(kind=dp), intent(inout) :: u_matrix_opt(:, :, :) + + logical, intent(in) :: on_root + character(len=50), intent(in) :: seedname + + ! local variables integer :: i, j, l, m, nkp, info, ierr + real(kind=dp), allocatable :: svals(:) real(kind=dp), allocatable :: rwork(:) - complex(kind=dp) :: ctmp2 + + complex(kind=dp) :: ctmp2 complex(kind=dp), allocatable :: cwork(:) complex(kind=dp), allocatable :: cz(:, :) complex(kind=dp), allocatable :: cvdag(:, :) ! complex(kind=dp), allocatable :: catmpmat(:,:,:) - if (timing_level > 1) call io_stopwatch('dis: project', 1) + if (timing_level > 1) call io_stopwatch('dis: project', 1, stdout, seedname) if (on_root) write (stdout, '(/1x,a)') & ' Unitarised projection of Wannier functions ' @@ -992,15 +1112,15 @@ subroutine dis_project() ! allocate(catmpmat(num_bands,num_bands,num_kpts),stat=ierr) ! if (ierr/=0) call io_error('Error in allocating catmpmat in dis_project') allocate (svals(num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating svals in dis_project') + if (ierr /= 0) call io_error('Error in allocating svals in dis_project', stdout, seedname) allocate (rwork(5*num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating rwork in dis_project') + if (ierr /= 0) call io_error('Error in allocating rwork in dis_project', stdout, seedname) allocate (cvdag(num_bands, num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cvdag in dis_project') + if (ierr /= 0) call io_error('Error in allocating cvdag in dis_project', stdout, seedname) allocate (cz(num_bands, num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cz in dis_project') + if (ierr /= 0) call io_error('Error in allocating cz in dis_project', stdout, seedname) allocate (cwork(4*num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cwork in dis_project') + if (ierr /= 0) call io_error('Error in allocating cwork in dis_project', stdout, seedname) ! here we slim down the ca matrix ! up to here num_bands(=num_bands) X num_wann(=num_wann) @@ -1041,7 +1161,7 @@ subroutine dis_project() if (info .lt. 0) then if (on_root) write (stdout, *) ' THE ', -info, '-TH ARGUMENT HAD ILLEGAL VALUE' endif - call io_error('dis_project: problem in ZGESVD 1') + call io_error('dis_project: problem in ZGESVD 1', stdout, seedname) endif ! NOTE THAT - AT LEAST FOR LINUX MKL LAPACK - THE OUTPUT OF ZGESVD @@ -1094,7 +1214,7 @@ subroutine dis_project() if (on_root) write (stdout, '(1x,a,f12.6,1x,f12.6)') & '[u_matrix_opt.transpose(u_matrix_opt)]_ij= ', & real(ctmp2, dp), aimag(ctmp2) - call io_error('dis_project: Error in unitarity of initial U in dis_project') + call io_error('dis_project: Error in unitarity of initial U in dis_project', stdout, seedname) endif if ((i .ne. j) .and. (abs(ctmp2) .gt. eps5)) then if (on_root) write (stdout, *) ' ERROR: unitarity of initial U' @@ -1103,7 +1223,7 @@ subroutine dis_project() if (on_root) write (stdout, '(1x,a,f12.6,1x,f12.6)') & '[u_matrix_opt.transpose(u_matrix_opt)]_ij= ', & real(ctmp2, dp), aimag(ctmp2) - call io_error('dis_project: Error in unitarity of initial U in dis_project') + call io_error('dis_project: Error in unitarity of initial U in dis_project', stdout, seedname) endif enddo enddo @@ -1111,43 +1231,57 @@ subroutine dis_project() ! NKP deallocate (cwork, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cwork in dis_project') + if (ierr /= 0) call io_error('Error in deallocating cwork in dis_project', stdout, seedname) deallocate (cz, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cz in dis_project') + if (ierr /= 0) call io_error('Error in deallocating cz in dis_project', stdout, seedname) deallocate (cvdag, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cvdag in dis_project') + if (ierr /= 0) call io_error('Error in deallocating cvdag in dis_project', stdout, seedname) deallocate (rwork, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating rwork in dis_project') + if (ierr /= 0) call io_error('Error in deallocating rwork in dis_project', stdout, seedname) deallocate (svals, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating svals in dis_project') + if (ierr /= 0) call io_error('Error in deallocating svals in dis_project', stdout, seedname) ! deallocate(catmpmat,stat=ierr) ! if (ierr/=0) call io_error('Error in deallocating catmpmat in dis_project') if (on_root) write (stdout, '(a)') ' done' - if (timing_level > 1) call io_stopwatch('dis: project', 2) + if (timing_level > 1) call io_stopwatch('dis: project', 2, stdout, seedname) return - + !================================================! end subroutine dis_project - !==================================================================! - subroutine dis_proj_froz() - !==================================================================! - ! ! + subroutine dis_proj_froz(u_matrix_opt, indxfroz, ndimfroz, ndimwin, iprint, num_bands, & + num_kpts, num_wann, timing_level, lfrozen, on_root, seedname, stdout) + !================================================! + ! !! COMPUTES THE LEADING EIGENVECTORS OF Q_froz . P_s . Q_froz, !! WHERE P_s PROJECTOR OPERATOR ONTO THE SUBSPACE S OF THE PROJECTED !! GAUSSIANS, P_f THE PROJECTOR ONTO THE FROZEN STATES, AND !! Q_froz = 1 - P_froz, ALL EXP IN THE BASIS OF THE BLOCH !! EIGENSTATES INSIDE THE OUTER ENERGY WINDOW !! (See Eq. (27) in Sec. III.G of SMV) - ! ! - !==================================================================! + ! + !================================================! use w90_constants, only: eps8 implicit none + ! arguments + integer, intent(in) :: timing_level, iprint + integer, intent(in) :: stdout + integer, intent(in) :: num_bands, num_kpts, num_wann + integer, intent(in) :: ndimwin(:) + integer, intent(in) :: ndimfroz(:) + integer, intent(in) :: indxfroz(:, :) + + complex(kind=dp), intent(inout) :: u_matrix_opt(:, :, :) + + logical, intent(in) :: on_root, lfrozen(:, :) + + character(len=50), intent(in) :: seedname + ! INPUT: num_wann,ndimwin,ndimfroz,indxfroz,lfrozen ! MODIFIED: u_matrix_opt (At input it contains the gaussians projected onto ! the window states in the routine project.f. At output @@ -1161,8 +1295,10 @@ subroutine dis_proj_froz() ! ********************************************************* integer, allocatable :: iwork(:) integer, allocatable :: ifail(:) + real(kind=dp), allocatable :: w(:) real(kind=dp), allocatable :: rwork(:) + complex(kind=dp), allocatable :: cap(:) complex(kind=dp), allocatable :: cwork(:) complex(kind=dp), allocatable :: cz(:, :) @@ -1186,41 +1322,44 @@ subroutine dis_proj_froz() integer :: goods, il, iu, nkp, l, j, n, m, info, ierr integer :: counter, loop_f, loop_v, vmap(num_bands) integer :: nzero - logical :: take - character(len=4) :: rep + complex(kind=dp) :: ctmp complex(kind=dp), allocatable :: cp_s(:, :) complex(kind=dp), allocatable :: cq_froz(:, :) complex(kind=dp), allocatable :: cpq(:, :) complex(kind=dp), allocatable :: cqpq(:, :) - if (timing_level > 1) call io_stopwatch('dis: proj_froz', 1) + logical :: take + + character(len=4) :: rep + + if (timing_level > 1) call io_stopwatch('dis: proj_froz', 1, stdout, seedname) if (on_root) write (stdout, '(3x,a)', advance='no') 'In dis_proj_froz...' allocate (iwork(5*num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating iwork in dis_proj_froz') + if (ierr /= 0) call io_error('Error allocating iwork in dis_proj_froz', stdout, seedname) allocate (ifail(num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating ifail in dis_proj_froz') + if (ierr /= 0) call io_error('Error allocating ifail in dis_proj_froz', stdout, seedname) allocate (w(num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating w in dis_proj_froz') + if (ierr /= 0) call io_error('Error allocating w in dis_proj_froz', stdout, seedname) allocate (rwork(7*num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating rwork in dis_proj_froz') + if (ierr /= 0) call io_error('Error allocating rwork in dis_proj_froz', stdout, seedname) allocate (cap((num_bands*(num_bands + 1))/2), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cap in dis_proj_froz') + if (ierr /= 0) call io_error('Error allocating cap in dis_proj_froz', stdout, seedname) allocate (cwork(2*num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cwork in dis_proj_froz') + if (ierr /= 0) call io_error('Error allocating cwork in dis_proj_froz', stdout, seedname) allocate (cz(num_bands, num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cz in dis_proj_froz') + if (ierr /= 0) call io_error('Error allocating cz in dis_proj_froz', stdout, seedname) allocate (cp_s(num_bands, num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cp_s in dis_proj_froz') + if (ierr /= 0) call io_error('Error allocating cp_s in dis_proj_froz', stdout, seedname) allocate (cq_froz(num_bands, num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cq_froz in dis_proj_froz') + if (ierr /= 0) call io_error('Error allocating cq_froz in dis_proj_froz', stdout, seedname) allocate (cpq(num_bands, num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cpq in dis_proj_froz') + if (ierr /= 0) call io_error('Error allocating cpq in dis_proj_froz', stdout, seedname) allocate (cqpq(num_bands, num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cqpq in dis_proj_froz') + if (ierr /= 0) call io_error('Error allocating cqpq in dis_proj_froz', stdout, seedname) do nkp = 1, num_kpts @@ -1273,7 +1412,7 @@ subroutine dis_proj_froz() if (abs(cqpq(m, n) - conjg(cqpq(n, m))) .gt. eps8) then if (on_root) write (stdout, *) ' matrix CQPQ is not hermitian' if (on_root) write (stdout, *) ' k-point ', nkp - call io_error('dis_proj_froz: error') + call io_error('dis_proj_froz: error', stdout, seedname) endif enddo enddo @@ -1287,8 +1426,8 @@ subroutine dis_proj_froz() enddo il = ndimwin(nkp) - (num_wann - ndimfroz(nkp)) + 1 iu = ndimwin(nkp) - call ZHPEVX('V', 'A', 'U', ndimwin(nkp), cap, 0.0_dp, 0.0_dp, il, & - iu, -1.0_dp, m, w, cz, num_bands, cwork, rwork, iwork, ifail, info) + call ZHPEVX('V', 'A', 'U', ndimwin(nkp), cap, 0.0_dp, 0.0_dp, il, iu, -1.0_dp, m, w, cz, & + num_bands, cwork, rwork, iwork, ifail, info) !~ write(stdout,*) 'w:' !~ do n=1,ndimwin(nkp) @@ -1303,11 +1442,11 @@ subroutine dis_proj_froz() if (info .lt. 0) then if (on_root) write (stdout, *) ' *** ERROR *** ZHPEVX WHILE DIAGONALIZING CQPQ MATRIX' if (on_root) write (stdout, *) ' THE ', -info, ' ARGUMENT OF ZHPEVX HAD AN ILLEGAL VALUE' - call io_error('dis_proj_frozen: error') + call io_error('dis_proj_frozen: error', stdout, seedname) elseif (info .gt. 0) then if (on_root) write (stdout, *) ' *** ERROR *** ZHPEVX WHILE DIAGONALIZING CQPQ MATRIX' if (on_root) write (stdout, *) info, 'EIGENVECTORS FAILED TO CONVERGE' - call io_error('dis_proj_frozen: error') + call io_error('dis_proj_frozen: error', stdout, seedname) endif ! ENDDEBUG @@ -1316,7 +1455,7 @@ subroutine dis_proj_froz() if (on_root) write (stdout, *) ' *** ERROR *** in dis_proj_froz' if (on_root) write (stdout, *) ' Number of eigenvalues/vectors obtained is', & m, ' not equal to the number asked,', ndimwin(nkp) - call io_error('dis_proj_frozen: error') + call io_error('dis_proj_frozen: error', stdout, seedname) endif ! ENDDEBUG @@ -1331,7 +1470,7 @@ subroutine dis_proj_froz() if (iprint > 2 .and. on_root) write (stdout, '(a,i3,a,f16.12)') ' lambda(', j, ')=', w(j) !~[aam] if ( (w(j).lt.eps8).or.(w(j).gt.1.0_dp + eps8) ) then if ((w(j) .lt. -eps8) .or. (w(j) .gt. 1.0_dp + eps8)) then - call io_error('dis_proj_frozen: error - Eigenvalues not between 0 and 1') + call io_error('dis_proj_frozen: error - Eigenvalues not between 0 and 1', stdout, seedname) endif enddo ! ENDDEBUG @@ -1350,111 +1489,112 @@ subroutine dis_proj_froz() ! checking their orthogonality to the frozen states. ! === For version 1.0.1 we make this the default === - if (index(devel_flag, 'no-orth-fix') == 0) then - nzero = 0; goods = 0 - do j = ndimwin(nkp), ndimwin(nkp) - (num_wann - ndimfroz(nkp)) + 1, -1 - if (w(j) < eps8) then - nzero = nzero + 1 - else - goods = goods + 1 - end if + !if (index(devel_flag, 'no-orth-fix') == 0) then + nzero = 0; goods = 0 + do j = ndimwin(nkp), ndimwin(nkp) - (num_wann - ndimfroz(nkp)) + 1, -1 + if (w(j) < eps8) then + nzero = nzero + 1 + else + goods = goods + 1 + end if + end do + if (nzero > 0) then + if (iprint > 2 .and. on_root) then + write (stdout, *) ' ' + write (stdout, '(1x,a,i0,a)') 'An eigenvalue of QPQ is close to zero at kpoint ', & + nkp, '. Using safety check.' + write (stdout, '(1x,a,i4,a,i4)') 'We must find ', nzero, & + ' eigenvectors with zero eigenvalues out of a set of ', ndimwin(nkp) - goods + endif + !First lets put the 'good' states into vamp + vmap = 0 + counter = 1 + do j = ndimwin(nkp), ndimwin(nkp) - goods + 1, -1 + vmap(counter) = j + counter = counter + 1 end do - if (nzero > 0) then - if (iprint > 2 .and. on_root) then - write (stdout, *) ' ' - write (stdout, '(1x,a,i0,a)') 'An eigenvalue of QPQ is close to zero at kpoint ' & - , nkp, '. Using safety check.' - write (stdout, '(1x,a,i4,a,i4)') 'We must find ', nzero, & - ' eigenvectors with zero eigenvalues out of a set of ', ndimwin(nkp) - goods - endif - !First lets put the 'good' states into vamp - vmap = 0 - counter = 1 - do j = ndimwin(nkp), ndimwin(nkp) - goods + 1, -1 - vmap(counter) = j - counter = counter + 1 - end do - if (iprint > 2 .and. on_root) then - do loop_f = 1, ndimwin(nkp) - write (stdout, '(1x,a,i4,a,es13.6)') 'Eigenvector number', loop_f, ' Eigenvalue: ', w(loop_f) - do loop_v = 1, ndimwin(nkp) - write (stdout, '(20x,2f12.8)') cz(loop_v, loop_f) - end do - write (stdout, *) - end do - end if - - ! We need to find nzero vectors out of the remining ndimwin(nkp)-goods vectors - - do loop_f = 1, nzero - do loop_v = ndimwin(nkp), 1, -1 !loop backwards for efficiency only - if (any(vmap == loop_v)) cycle - !check to see if vector is orthogonal to frozen states in u_matrix_opt - take = .true. - do m = 1, ndimfroz(nkp) - ctmp = cmplx_0 - do j = 1, ndimwin(nkp) - ctmp = ctmp + conjg(u_matrix_opt(j, m, nkp))*cz(j, loop_v) - enddo - if (abs(ctmp) .gt. eps8) then - take = .false. - endif - enddo - if (take) then !vector is good and we add it to vmap - vmap(goods + loop_f) = loop_v - exit - end if + if (iprint > 2 .and. on_root) then + do loop_f = 1, ndimwin(nkp) + write (stdout, '(1x,a,i4,a,es13.6)') 'Eigenvector number', loop_f, & + ' Eigenvalue: ', w(loop_f) + do loop_v = 1, ndimwin(nkp) + write (stdout, '(20x,2f12.8)') cz(loop_v, loop_f) end do + write (stdout, *) end do + end if - if (iprint > 2 .and. on_root) then - write (rep, '(i4)') num_wann - ndimfroz(nkp) - write (stdout, '(1x,a,'//trim(rep)//'(i0,1x))') 'We use the following eigenvectors: ' & - , vmap(1:(num_wann - ndimfroz(nkp))) - end if - do l = 1, num_wann - ndimfroz(nkp) - if (vmap(l) == 0) call io_error('dis_proj_froz: Ortho-fix failed to find enough vectors') - end do - - ! put the correct eigenvectors into u_matrix_opt, and we're all done! - counter = 1 - do l = ndimfroz(nkp) + 1, num_wann - u_matrix_opt(1:ndimwin(nkp), l, nkp) = cz(1:ndimwin(nkp), vmap(counter)) - counter = counter + 1 - enddo - - else ! we don't need to use the fix + ! We need to find nzero vectors out of the remining ndimwin(nkp)-goods vectors - do l = ndimfroz(nkp) + 1, num_wann - u_matrix_opt(1:ndimwin(nkp), l, nkp) = cz(1:ndimwin(nkp), il) - il = il + 1 - enddo + do loop_f = 1, nzero + do loop_v = ndimwin(nkp), 1, -1 !loop backwards for efficiency only + if (any(vmap == loop_v)) cycle + !check to see if vector is orthogonal to frozen states in u_matrix_opt + take = .true. + do m = 1, ndimfroz(nkp) + ctmp = cmplx_0 + do j = 1, ndimwin(nkp) + ctmp = ctmp + conjg(u_matrix_opt(j, m, nkp))*cz(j, loop_v) + enddo + if (abs(ctmp) .gt. eps8) then + take = .false. + endif + enddo + if (take) then !vector is good and we add it to vmap + vmap(goods + loop_f) = loop_v + exit + end if + end do + end do - if (il - 1 .ne. iu) then - call io_error('dis_proj_frozen: error - il-1.ne.iu (in ortho-fix)') + if (iprint > 2 .and. on_root) then + write (rep, '(i4)') num_wann - ndimfroz(nkp) + write (stdout, '(1x,a,'//trim(rep)//'(i0,1x))') & + 'We use the following eigenvectors: ', vmap(1:(num_wann - ndimfroz(nkp))) + end if + do l = 1, num_wann - ndimfroz(nkp) + if (vmap(l) == 0) then + call io_error('dis_proj_froz: Ortho-fix failed to find enough vectors', stdout, seedname) endif + end do - end if + ! put the correct eigenvectors into u_matrix_opt, and we're all done! + counter = 1 + do l = ndimfroz(nkp) + 1, num_wann + u_matrix_opt(1:ndimwin(nkp), l, nkp) = cz(1:ndimwin(nkp), vmap(counter)) + counter = counter + 1 + enddo - else ! if .not. using ortho-fix + else ! we don't need to use the fix - ! PICK THE num_wann-nDIMFROZ(NKP) LEADING EIGENVECTORS AS TRIAL STATES - ! and PUT THEM RIGHT AFTER THE FROZEN STATES IN u_matrix_opt do l = ndimfroz(nkp) + 1, num_wann - if (on_root) write (stdout, *) 'il=', il u_matrix_opt(1:ndimwin(nkp), l, nkp) = cz(1:ndimwin(nkp), il) il = il + 1 enddo - ! DEBUG if (il - 1 .ne. iu) then - call io_error('dis_proj_frozen: error - il-1.ne.iu') + call io_error('dis_proj_frozen: error - il-1.ne.iu (in ortho-fix)', stdout, seedname) endif - ! ENDDEBUG end if + ! PICK THE num_wann-nDIMFROZ(NKP) LEADING EIGENVECTORS AS TRIAL STATES + ! and PUT THEM RIGHT AFTER THE FROZEN STATES IN u_matrix_opt + !do l = ndimfroz(nkp) + 1, num_wann + ! if (on_root) write (stdout, *) 'il=', il + ! u_matrix_opt(1:ndimwin(nkp), l, nkp) = cz(1:ndimwin(nkp), il) + ! il = il + 1 + !enddo + + ! DEBUG + !if (il - 1 .ne. iu) then + ! call io_error('dis_proj_frozen: error - il-1.ne.iu', stdout, seedname) + !endif + ! ENDDEBUG + + !end if + endif ! num_wann>nDIMFROZ(NKP) ! Put the frozen states in the lowest columns of u_matrix_opt @@ -1474,50 +1614,47 @@ subroutine dis_proj_froz() enddo ! NKP deallocate (cqpq, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cqpq in dis_proj_froz') + if (ierr /= 0) call io_error('Error deallocating cqpq in dis_proj_froz', stdout, seedname) deallocate (cpq, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cpq in dis_proj_froz') + if (ierr /= 0) call io_error('Error deallocating cpq in dis_proj_froz', stdout, seedname) deallocate (cq_froz, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cq_froz in dis_proj_froz') + if (ierr /= 0) call io_error('Error deallocating cq_froz in dis_proj_froz', stdout, seedname) deallocate (cp_s, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cp_s in dis_proj_froz') + if (ierr /= 0) call io_error('Error deallocating cp_s in dis_proj_froz', stdout, seedname) deallocate (cz, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cz in dis_proj_froz') + if (ierr /= 0) call io_error('Error deallocating cz in dis_proj_froz', stdout, seedname) deallocate (cwork, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cwork in dis_proj_froz') + if (ierr /= 0) call io_error('Error deallocating cwork in dis_proj_froz', stdout, seedname) deallocate (cap, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cap in dis_proj_froz') + if (ierr /= 0) call io_error('Error deallocating cap in dis_proj_froz', stdout, seedname) deallocate (rwork, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating rwork in dis_proj_froz') + if (ierr /= 0) call io_error('Error deallocating rwork in dis_proj_froz', stdout, seedname) deallocate (w, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating w in dis_proj_froz') + if (ierr /= 0) call io_error('Error deallocating w in dis_proj_froz', stdout, seedname) deallocate (ifail, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating ifail in dis_proj_froz') + if (ierr /= 0) call io_error('Error deallocating ifail in dis_proj_froz', stdout, seedname) deallocate (iwork, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating iwork in dis_proj_froz') + if (ierr /= 0) call io_error('Error deallocating iwork in dis_proj_froz', stdout, seedname) if (on_root) write (stdout, '(a)') ' done' - if (timing_level > 1) call io_stopwatch('dis: proj_froz', 2) + if (timing_level > 1) call io_stopwatch('dis: proj_froz', 2, stdout, seedname) return - + !================================================! end subroutine dis_proj_froz - !==================================================================! - subroutine dis_extract() - !==================================================================! - ! ! + subroutine dis_extract(dis_control, kmesh_info, sitesym, print_output, dis_manifold, & + m_matrix_orig_local, u_matrix_opt, eigval_opt, omega_invariant, & + indxnfroz, ndimfroz, my_node_id, num_bands, num_kpts, num_nodes, & + num_wann, lsitesymmetry, on_root, seedname, stdout, comm) + !================================================! + ! !! Extracts an num_wann-dimensional subspace at each k by !! minimizing Omega_I - ! ! - !==================================================================! - - use w90_io, only: io_wallclocktime - use w90_sitesym, only: ir2ik, ik2ir, nkptirr, nsymmetry, kptsym !YN: RS: - - implicit none + ! + !================================================! ! MODIFIED: ! u_matrix_opt (At input it contains the initial guess for the optima @@ -1553,6 +1690,34 @@ subroutine dis_extract() ! periodic image in the "home Brillouin zone") ! cm(n,m,nkp,nnx) Overlap matrix + use w90_io, only: io_wallclocktime + use w90_wannier90_types, only: sitesym_type + + implicit none + + ! arguments + integer, intent(in) :: num_nodes, my_node_id + integer, intent(in) :: stdout + integer, intent(in) :: num_bands, num_kpts, num_wann + integer, intent(in) :: ndimfroz(:) ! (num_kpts) + integer, intent(in) :: indxnfroz(:, :) ! (num_bands,num_kpts) + + real(kind=dp), intent(inout) :: eigval_opt(:, :) + real(kind=dp), intent(out) :: omega_invariant + + complex(kind=dp), intent(inout) :: m_matrix_orig_local(:, :, :, :) + complex(kind=dp), intent(inout) :: u_matrix_opt(:, :, :) + + logical, intent(in) :: on_root, lsitesymmetry + character(len=50), intent(in) :: seedname + + type(dis_control_type), intent(in) :: dis_control + type(dis_manifold_type), intent(in) :: dis_manifold + type(kmesh_info_type), intent(in) :: kmesh_info + type(print_output_type), intent(in) :: print_output + type(sitesym_type), intent(in) :: sitesym + type(w90comm_type), intent(in) :: comm + ! Internal variables integer :: i, j, l, m, n, nn, nkp, nkp2, info, ierr, ndimk, p integer :: icompflag, iter, ndiff @@ -1584,15 +1749,16 @@ subroutine dis_extract() complex(kind=dp), allocatable :: cwb(:, :), cww(:, :), cbw(:, :) real(kind=dp), allocatable :: history(:) - logical :: dis_converged + logical :: dis_converged complex(kind=dp) :: lambda(num_wann, num_wann) !RS: ! Needed to split an array on different nodes - integer, dimension(0:num_nodes - 1) :: counts - integer, dimension(0:num_nodes - 1) :: displs + integer :: counts(0:num_nodes - 1) + integer :: displs(0:num_nodes - 1) integer :: nkp_loc - if (timing_level > 1 .and. on_root) call io_stopwatch('dis: extract', 1) + if (print_output%timing_level > 1 .and. on_root) call io_stopwatch('dis: extract', 1, stdout, & + seedname) if (on_root) write (stdout, '(/1x,a)') & ' Extraction of optimally-connected subspace ' @@ -1600,53 +1766,53 @@ subroutine dis_extract() ' ------------------------------------------ ' allocate (cwb(num_wann, num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cwb in dis_extract') + if (ierr /= 0) call io_error('Error allocating cwb in dis_extract', stdout, seedname) allocate (cww(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cww in dis_extract') + if (ierr /= 0) call io_error('Error allocating cww in dis_extract', stdout, seedname) allocate (cbw(num_bands, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cbw in dis_extract') + if (ierr /= 0) call io_error('Error allocating cbw in dis_extract', stdout, seedname) cwb = cmplx_0; cww = cmplx_0; cbw = cmplx_0 allocate (iwork(5*num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating iwork in dis_extract') + if (ierr /= 0) call io_error('Error allocating iwork in dis_extract', stdout, seedname) allocate (ifail(num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating ifail in dis_extract') + if (ierr /= 0) call io_error('Error allocating ifail in dis_extract', stdout, seedname) allocate (w(num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating w in dis_extract') + if (ierr /= 0) call io_error('Error allocating w in dis_extract', stdout, seedname) allocate (rwork(7*num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating rwork in dis_extract') + if (ierr /= 0) call io_error('Error allocating rwork in dis_extract', stdout, seedname) allocate (cap((num_bands*(num_bands + 1))/2), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cap in dis_extract') + if (ierr /= 0) call io_error('Error allocating cap in dis_extract', stdout, seedname) allocate (cwork(2*num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cwork in dis_extract') + if (ierr /= 0) call io_error('Error allocating cwork in dis_extract', stdout, seedname) allocate (cz(num_bands, num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cz in dis_extract') + if (ierr /= 0) call io_error('Error allocating cz in dis_extract', stdout, seedname) ! for MPI - call comms_array_split(num_kpts, counts, displs) + call comms_array_split(num_kpts, counts, displs, comm) allocate (u_matrix_opt_loc(num_bands, num_wann, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error allocating u_matrix_opt_loc in dis_extract') + if (ierr /= 0) call io_error('Error allocating u_matrix_opt_loc in dis_extract', stdout, seedname) ! Copy matrix elements from global U matrix to local U matrix do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) u_matrix_opt_loc(:, :, nkp_loc) = u_matrix_opt(:, :, nkp) enddo allocate (wkomegai1_loc(max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error allocating wkomegai1_loc in dis_extract') + if (ierr /= 0) call io_error('Error allocating wkomegai1_loc in dis_extract', stdout, seedname) allocate (czmat_in_loc(num_bands, num_bands, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error allocating czmat_in_loc in dis_extract') + if (ierr /= 0) call io_error('Error allocating czmat_in_loc in dis_extract', stdout, seedname) allocate (czmat_out_loc(num_bands, num_bands, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error allocating czmat_out_loc in dis_extract') + if (ierr /= 0) call io_error('Error allocating czmat_out_loc in dis_extract', stdout, seedname) allocate (wkomegai1(num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating wkomegai1 in dis_extract') + if (ierr /= 0) call io_error('Error allocating wkomegai1 in dis_extract', stdout, seedname) allocate (czmat_in(num_bands, num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating czmat_in in dis_extract') + if (ierr /= 0) call io_error('Error allocating czmat_in in dis_extract', stdout, seedname) allocate (czmat_out(num_bands, num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating czmat_out in dis_extract') + if (ierr /= 0) call io_error('Error allocating czmat_out in dis_extract', stdout, seedname) - allocate (history(dis_conv_window), stat=ierr) - if (ierr /= 0) call io_error('Error allocating history in dis_extract') + allocate (history(dis_control%conv_window), stat=ierr) + if (ierr /= 0) call io_error('Error allocating history in dis_extract', stdout, seedname) ! ******************************************** ! ENERGY WINDOWS AND SUBSPACES AT EACH K-POINT @@ -1683,12 +1849,14 @@ subroutine dis_extract() ! nitere total number of iterations ! DEBUG - if (iprint > 2) then - if (on_root) write (stdout, '(a,/)') ' Original eigenvalues inside outer window:' - do nkp = 1, num_kpts - if (on_root) write (stdout, '(a,i3,3x,20(f9.5,1x))') ' K-point ', nkp, & - (eigval_opt(i, nkp), i=1, ndimwin(nkp)) - enddo + if (print_output%iprint > 2) then + if (on_root) then + write (stdout, '(a,/)') ' Original eigenvalues inside outer window:' + do nkp = 1, num_kpts + write (stdout, '(a,i3,3x,20(f9.5,1x))') ' K-point ', nkp, & + (eigval_opt(i, nkp), i=1, dis_manifold%ndimwin(nkp)) + enddo + endif endif ! ENDDEBUG @@ -1707,22 +1875,30 @@ subroutine dis_extract() ! ------------------ ! BIG ITERATION LOOP ! ------------------ - do iter = 1, dis_num_iter + do iter = 1, dis_control%num_iter - if (timing_level > 1 .and. on_root) call io_stopwatch('dis: extract_1', 1) + if (print_output%timing_level > 1 .and. on_root) call io_stopwatch('dis: extract_1', 1, stdout, seedname) if (iter .eq. 1) then ! Initialize Z matrix at k points w/ non-frozen states do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) - if (num_wann .gt. ndimfroz(nkp)) call internal_zmatrix(nkp, nkp_loc, czmat_in_loc(:, :, nkp_loc)) + if (num_wann .gt. ndimfroz(nkp)) then + call internal_zmatrix(cbw, czmat_in_loc(:, :, nkp_loc), m_matrix_orig_local, & + u_matrix_opt, kmesh_info%wb, indxnfroz, ndimfroz, & + dis_manifold%ndimwin, kmesh_info%nnlist, nkp, nkp_loc, & + kmesh_info%nntot, num_bands, num_wann, print_output%timing_level, & + on_root, seedname, stdout) + endif enddo if (lsitesymmetry) then - call comms_gatherv(czmat_in_loc, num_bands*num_bands*counts(my_node_id), & - czmat_in, num_bands*num_bands*counts, num_bands*num_bands*displs) - call comms_bcast(czmat_in(1, 1, 1), num_bands*num_bands*num_kpts) - call sitesym_symmetrize_zmatrix(czmat_in, lwindow) !RS: + call comms_gatherv(czmat_in_loc, num_bands*num_bands*counts(my_node_id), czmat_in, & + num_bands*num_bands*counts, num_bands*num_bands*displs, stdout, & + seedname, comm) + call comms_bcast(czmat_in(1, 1, 1), num_bands*num_bands*num_kpts, stdout, seedname, comm) + call sitesym_symmetrize_zmatrix(sitesym, czmat_in, num_bands, num_kpts, & + dis_manifold%lwindow) !RS: do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) czmat_in_loc(:, :, nkp_loc) = czmat_in(:, :, nkp) @@ -1735,15 +1911,15 @@ subroutine dis_extract() do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) if (lsitesymmetry) then !YN: RS: - if (ir2ik(ik2ir(nkp)) .ne. nkp) cycle !YN: RS: + if (sitesym%ir2ik(sitesym%ik2ir(nkp)) .ne. nkp) cycle !YN: RS: endif !YN: RS: if (num_wann .gt. ndimfroz(nkp)) then - ndimk = ndimwin(nkp) - ndimfroz(nkp) + ndimk = dis_manifold%ndimwin(nkp) - ndimfroz(nkp) do i = 1, ndimk do j = 1, i czmat_in_loc(j, i, nkp_loc) = & - cmplx(dis_mix_ratio, 0.0_dp, dp)*czmat_out_loc(j, i, nkp_loc) & - + cmplx(1.0_dp - dis_mix_ratio, 0.0_dp, dp)*czmat_in_loc(j, i, nkp_loc) + cmplx(dis_control%mix_ratio, 0.0_dp, dp)*czmat_out_loc(j, i, nkp_loc) & + + cmplx(1.0_dp - dis_control%mix_ratio, 0.0_dp, dp)*czmat_in_loc(j, i, nkp_loc) ! hermiticity czmat_in_loc(i, j, nkp_loc) = conjg(czmat_in_loc(j, i, nkp_loc)) enddo @@ -1752,9 +1928,9 @@ subroutine dis_extract() enddo endif ! [if iter=1] - if (timing_level > 1 .and. on_root) call io_stopwatch('dis: extract_1', 2) + if (print_output%timing_level > 1 .and. on_root) call io_stopwatch('dis: extract_1', 2, stdout, seedname) - if (timing_level > 1 .and. on_root) call io_stopwatch('dis: extract_2', 1) + if (print_output%timing_level > 1 .and. on_root) call io_stopwatch('dis: extract_2', 1, stdout, seedname) womegai1 = 0.0_dp ! wkomegai1 is defined by Eq. (18) of SMV. @@ -1762,10 +1938,11 @@ subroutine dis_extract() ! every k (before updating any k), so that for iter>1 overlaps are with ! non-frozen neighboring states from the previous iteration - wkomegai1 = real(num_wann, dp)*wbtot + wkomegai1 = real(num_wann, dp)*kmesh_info%wbtot if (lsitesymmetry) then !RS: - do nkp = 1, nkptirr !RS: - wkomegai1(ir2ik(nkp)) = wkomegai1(ir2ik(nkp))*nsymmetry/count(kptsym(:, nkp) .eq. ir2ik(nkp)) !RS: + do nkp = 1, sitesym%nkptirr !RS: + wkomegai1(sitesym%ir2ik(nkp)) = wkomegai1(sitesym%ir2ik(nkp))* & + sitesym%nsymmetry/count(sitesym%kptsym(:, nkp) .eq. sitesym%ir2ik(nkp)) !RS: enddo !RS: endif !RS: do nkp_loc = 1, counts(my_node_id) @@ -1776,27 +1953,27 @@ subroutine dis_extract() do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) if (ndimfroz(nkp) .gt. 0) then - if (lsitesymmetry) call io_error('not implemented in symmetry-adapted mode') !YN: RS: - do nn = 1, nntot - nkp2 = nnlist(nkp, nn) - call zgemm('C', 'N', ndimfroz(nkp), ndimwin(nkp2), ndimwin(nkp), cmplx_1, & - u_matrix_opt(:, :, nkp), num_bands, m_matrix_orig_local(:, :, nn, nkp_loc), num_bands, cmplx_0, & - cwb, num_wann) - call zgemm('N', 'N', ndimfroz(nkp), num_wann, ndimwin(nkp2), cmplx_1, & - cwb, num_wann, u_matrix_opt(:, :, nkp2), num_bands, cmplx_0, cww, num_wann) + if (lsitesymmetry) call io_error('not implemented in symmetry-adapted mode', stdout, seedname) !YN: RS: + do nn = 1, kmesh_info%nntot + nkp2 = kmesh_info%nnlist(nkp, nn) + call zgemm('C', 'N', ndimfroz(nkp), dis_manifold%ndimwin(nkp2), dis_manifold%ndimwin(nkp), & + cmplx_1, u_matrix_opt(:, :, nkp), num_bands, & + m_matrix_orig_local(:, :, nn, nkp_loc), num_bands, cmplx_0, cwb, num_wann) + call zgemm('N', 'N', ndimfroz(nkp), num_wann, dis_manifold%ndimwin(nkp2), cmplx_1, cwb, & + num_wann, u_matrix_opt(:, :, nkp2), num_bands, cmplx_0, cww, num_wann) rsum = 0.0_dp do n = 1, num_wann do m = 1, ndimfroz(nkp) rsum = rsum + real(cww(m, n), dp)**2 + aimag(cww(m, n))**2 enddo enddo - wkomegai1_loc(nkp_loc) = wkomegai1_loc(nkp_loc) - wb(nn)*rsum + wkomegai1_loc(nkp_loc) = wkomegai1_loc(nkp_loc) - kmesh_info%wb(nn)*rsum enddo endif enddo - if (timing_level > 1 .and. on_root) call io_stopwatch('dis: extract_2', 2) + if (print_output%timing_level > 1 .and. on_root) call io_stopwatch('dis: extract_2', 2, stdout, seedname) - if (timing_level > 1 .and. on_root) call io_stopwatch('dis: extract_3', 1) + if (print_output%timing_level > 1 .and. on_root) call io_stopwatch('dis: extract_3', 1, stdout, seedname) !! ! send chunks of wkomegai1 to root node !! call comms_gatherv(wkomegai1_loc, counts(my_node_id), wkomegai1, counts, displs) @@ -1807,46 +1984,50 @@ subroutine dis_extract() do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) if (lsitesymmetry) then !RS: - if (ir2ik(ik2ir(nkp)) .ne. nkp) cycle !RS: + if (sitesym%ir2ik(sitesym%ik2ir(nkp)) .ne. nkp) cycle !RS: end if !RS: if (lsitesymmetry) then !RS: - call sitesym_dis_extract_symmetry(nkp, ndimwin(nkp), czmat_in_loc(:, :, nkp_loc), lambda, u_matrix_opt_loc(:, :, nkp_loc)) !RS: - + call sitesym_dis_extract_symmetry(sitesym, lambda, u_matrix_opt_loc(:, :, nkp_loc), & + czmat_in_loc(:, :, nkp_loc), nkp, & + dis_manifold%ndimwin(nkp), num_bands, num_wann, & + seedname, stdout) !RS: do j = 1, num_wann !RS: - wkomegai1_loc(nkp_loc) = wkomegai1_loc(nkp_loc) - real(lambda(j, j), kind=dp) !RS: + wkomegai1_loc(nkp_loc) = wkomegai1_loc(nkp_loc) - real(lambda(j, j), kind=dp) !RS: enddo !RS: else !RS: if (num_wann .gt. ndimfroz(nkp)) then ! Diagonalize Z matrix - do j = 1, ndimwin(nkp) - ndimfroz(nkp) + do j = 1, dis_manifold%ndimwin(nkp) - ndimfroz(nkp) do i = 1, j cap(i + ((j - 1)*j)/2) = czmat_in_loc(i, j, nkp_loc) enddo enddo - ndiff = ndimwin(nkp) - ndimfroz(nkp) + ndiff = dis_manifold%ndimwin(nkp) - ndimfroz(nkp) call ZHPEVX('V', 'A', 'U', ndiff, cap, 0.0_dp, 0.0_dp, 0, 0, & -1.0_dp, m, w, cz, num_bands, cwork, rwork, iwork, ifail, info) if (info .lt. 0) then - if (on_root) write (stdout, *) ' *** ERROR *** ZHPEVX WHILE DIAGONALIZING Z MATRIX' - if (on_root) write (stdout, *) ' THE ', -info, ' ARGUMENT OF ZHPEVX HAD AN ILLEGAL VALUE' - call io_error(' dis_extract: error') + if (on_root) then + write (stdout, *) ' *** ERROR *** ZHPEVX WHILE DIAGONALIZING Z MATRIX' + write (stdout, *) ' THE ', -info, ' ARGUMENT OF ZHPEVX HAD AN ILLEGAL VALUE' + endif + call io_error(' dis_extract: error', stdout, seedname) endif if (info .gt. 0) then if (on_root) write (stdout, *) ' *** ERROR *** ZHPEVX WHILE DIAGONALIZING Z MATRIX' if (on_root) write (stdout, *) info, ' EIGENVECTORS FAILED TO CONVERGE' - call io_error(' dis_extract: error') + call io_error(' dis_extract: error', stdout, seedname) endif ! Update the optimal subspace by incorporating the num_wann-ndimfroz(nkp) l ! eigenvectors of the Z matrix into u_matrix_opt. Also, add contribution from ! non-frozen states to wkomegai1(nkp) (minus the corresponding eigenvalu m = ndimfroz(nkp) - do j = ndimwin(nkp) - num_wann + 1, ndimwin(nkp) - ndimfroz(nkp) + do j = dis_manifold%ndimwin(nkp) - num_wann + 1, dis_manifold%ndimwin(nkp) - ndimfroz(nkp) m = m + 1 wkomegai1_loc(nkp_loc) = wkomegai1_loc(nkp_loc) - w(j) - u_matrix_opt_loc(1:ndimwin(nkp), m, nkp_loc) = cmplx_0 - ndimk = ndimwin(nkp) - ndimfroz(nkp) + u_matrix_opt_loc(1:dis_manifold%ndimwin(nkp), m, nkp_loc) = cmplx_0 + ndimk = dis_manifold%ndimwin(nkp) - ndimfroz(nkp) do i = 1, ndimk p = indxnfroz(i, nkp) u_matrix_opt_loc(p, m, nkp_loc) = cz(i, j) @@ -1860,37 +2041,37 @@ subroutine dis_extract() ! wkomegai1(nkp), add it to womegai1 womegai1 = womegai1 + wkomegai1_loc(nkp_loc) - if (index(devel_flag, 'compspace') > 0) then - - ! AT THE LAST ITERATION FIND A BASIS FOR THE (NDIMWIN(NKP)-num_wann)-DIMENS - ! COMPLEMENT SPACE - - if (iter .eq. dis_num_iter) then - allocate (camp(num_bands, num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating camp in dis_extract') - allocate (camp_loc(num_bands, num_bands, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error allocating ucamp_loc in dis_extract') - - if (ndimwin(nkp) .gt. num_wann) then - do j = 1, ndimwin(nkp) - num_wann - if (num_wann .gt. ndimfroz(nkp)) then - ! USE THE NON-LEADING EIGENVECTORS OF THE Z-MATRIX - camp_loc(1:ndimwin(nkp), j, nkp_loc) = cz(1:ndimwin(nkp), j) - else - ! Then num_wann=NDIMFROZ(NKP) - ! USE THE ORIGINAL NON-FROZEN BLOCH EIGENSTATES - do i = 1, ndimwin(nkp) - camp_loc(i, j, nkp_loc) = cmplx_0 - if (i .eq. indxnfroz(j, nkp)) camp_loc(i, j, nkp_loc) = cmplx_1 - enddo - endif - enddo - else - icompflag = 1 - endif - endif + !if (index(print_output%devel_flag, 'compspace') > 0) then + + ! AT THE LAST ITERATION FIND A BASIS FOR THE (NDIMWIN(NKP)-num_wann)-DIMENS + ! COMPLEMENT SPACE - end if ! index(devel_flag,'compspace')>0 + ! if (iter .eq. dis_control%num_iter) then + ! allocate (camp(num_bands, num_bands, num_kpts), stat=ierr) + ! if (ierr /= 0) call io_error('Error allocating camp in dis_extract', stdout, seedname) + ! allocate (camp_loc(num_bands, num_bands, max(1, counts(my_node_id))), stat=ierr) + ! if (ierr /= 0) call io_error('Error allocating ucamp_loc in dis_extract', stdout, seedname) + + ! if (dis_manifold%ndimwin(nkp) .gt. num_wann) then + ! do j = 1, dis_manifold%ndimwin(nkp) - num_wann + ! if (num_wann .gt. ndimfroz(nkp)) then + ! ! USE THE NON-LEADING EIGENVECTORS OF THE Z-MATRIX + ! camp_loc(1:dis_manifold%ndimwin(nkp), j, nkp_loc) = cz(1:dis_manifold%ndimwin(nkp), j) + ! else + ! Then num_wann=NDIMFROZ(NKP) + ! USE THE ORIGINAL NON-FROZEN BLOCH EIGENSTATES + ! do i = 1, dis_manifold%ndimwin(nkp) + ! camp_loc(i, j, nkp_loc) = cmplx_0 + ! if (i .eq. indxnfroz(j, nkp)) camp_loc(i, j, nkp_loc) = cmplx_1 + ! enddo + ! endif + ! enddo + ! else + ! icompflag = 1 + ! endif + ! endif + + !end if ! index(print_output%devel_flag,'compspace')>0 enddo ! [Loop over k points (nkp)] @@ -1900,23 +2081,26 @@ subroutine dis_extract() !! ! send back the whole wkomegai1 array to other nodes !! call comms_bcast(wkomegai1(1), num_kpts) - call comms_allreduce(womegai1, 1, 'SUM') + call comms_allreduce(womegai1, 1, 'SUM', stdout, seedname, comm) - call comms_gatherv(u_matrix_opt_loc, num_bands*num_wann*counts(my_node_id), & - u_matrix_opt, num_bands*num_wann*counts, num_bands*num_wann*displs) - call comms_bcast(u_matrix_opt(1, 1, 1), num_bands*num_wann*num_kpts) - if (lsitesymmetry) call sitesym_symmetrize_u_matrix(num_bands, u_matrix_opt, lwindow) !RS: + call comms_gatherv(u_matrix_opt_loc, num_bands*num_wann*counts(my_node_id), u_matrix_opt, & + num_bands*num_wann*counts, num_bands*num_wann*displs, stdout, seedname, & + comm) + call comms_bcast(u_matrix_opt(1, 1, 1), num_bands*num_wann*num_kpts, stdout, seedname, comm) + if (lsitesymmetry) call sitesym_symmetrize_u_matrix(sitesym, u_matrix_opt, num_bands, & + num_bands, num_kpts, num_wann, seedname, & + stdout, dis_manifold%lwindow) !RS: + !if (index(print_output%devel_flag, 'compspace') > 0) then + ! if (iter .eq. dis_control%num_iter) then + ! call comms_gatherv(camp_loc, num_bands*num_bands*counts(my_node_id), camp, & + ! num_bands*num_bands*counts, num_bands*num_bands*displs, stdout, & + ! seedname, comm) - if (index(devel_flag, 'compspace') > 0) then - if (iter .eq. dis_num_iter) then - call comms_gatherv(camp_loc, num_bands*num_bands*counts(my_node_id), & - camp, num_bands*num_bands*counts, num_bands*num_bands*displs) + ! call comms_bcast(camp(1, 1, 1), num_bands*num_bands*num_kpts, stdout, seedname, comm) + ! endif + !endif - call comms_bcast(camp(1, 1, 1), num_bands*num_bands*num_kpts) - endif - endif - - if (timing_level > 1 .and. on_root) call io_stopwatch('dis: extract_3', 2) + if (print_output%timing_level > 1 .and. on_root) call io_stopwatch('dis: extract_3', 2, stdout, seedname) womegai1 = womegai1/real(num_kpts, dp) @@ -1956,68 +2140,79 @@ subroutine dis_extract() ! Compute womegai using the updated subspaces at all k, i.e., ! replacing (i-1) by (i) in Eq. (12) SMV - if (timing_level > 1 .and. on_root) call io_stopwatch('dis: extract_4', 1) + if (print_output%timing_level > 1 .and. on_root) call io_stopwatch('dis: extract_4', 1, stdout, seedname) womegai = 0.0_dp do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) wkomegai = 0.0_dp - do nn = 1, nntot - nkp2 = nnlist(nkp, nn) - call zgemm('C', 'N', num_wann, ndimwin(nkp2), ndimwin(nkp), cmplx_1, & - u_matrix_opt(:, :, nkp), num_bands, m_matrix_orig_local(:, :, nn, nkp_loc), num_bands, cmplx_0, & - cwb, num_wann) - call zgemm('N', 'N', num_wann, num_wann, ndimwin(nkp2), cmplx_1, & - cwb, num_wann, u_matrix_opt(:, :, nkp2), num_bands, cmplx_0, cww, num_wann) + do nn = 1, kmesh_info%nntot + nkp2 = kmesh_info%nnlist(nkp, nn) + call zgemm('C', 'N', num_wann, dis_manifold%ndimwin(nkp2), dis_manifold%ndimwin(nkp), cmplx_1, & + u_matrix_opt(:, :, nkp), num_bands, m_matrix_orig_local(:, :, nn, nkp_loc), & + num_bands, cmplx_0, cwb, num_wann) + call zgemm('N', 'N', num_wann, num_wann, dis_manifold%ndimwin(nkp2), cmplx_1, cwb, num_wann, & + u_matrix_opt(:, :, nkp2), num_bands, cmplx_0, cww, num_wann) rsum = 0.0_dp do n = 1, num_wann do m = 1, num_wann rsum = rsum + real(cww(m, n), dp)**2 + aimag(cww(m, n))**2 enddo enddo - wkomegai = wkomegai + wb(nn)*rsum + wkomegai = wkomegai + kmesh_info%wb(nn)*rsum enddo - wkomegai = real(num_wann, dp)*wbtot - wkomegai + wkomegai = real(num_wann, dp)*kmesh_info%wbtot - wkomegai womegai = womegai + wkomegai enddo - call comms_allreduce(womegai, 1, 'SUM') + call comms_allreduce(womegai, 1, 'SUM', stdout, seedname, comm) womegai = womegai/real(num_kpts, dp) ! [Loop over k (nkp)] - if (timing_level > 1 .and. on_root) call io_stopwatch('dis: extract_4', 2) + if (print_output%timing_level > 1 .and. on_root) call io_stopwatch('dis: extract_4', 2, stdout, seedname) delta_womegai = womegai1/womegai - 1.0_dp - if (on_root) write (stdout, 124) iter, womegai1*lenconfac**2, womegai*lenconfac**2, & - delta_womegai, io_wallclocktime() + if (on_root) then + write (stdout, 124) iter, womegai1*print_output%lenconfac**2, & + womegai*print_output%lenconfac**2, delta_womegai, io_wallclocktime() + endif 124 format(2x, i6, 3x, f14.8, 3x, f14.8, 6x, es10.3, 2x, f8.2, 4x, '<-- DIS') ! Construct the updated Z matrix, CZMAT_OUT, at k points w/ non-frozen s do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) - if (num_wann .gt. ndimfroz(nkp)) call internal_zmatrix(nkp, nkp_loc, czmat_out_loc(:, :, nkp_loc)) + if (num_wann .gt. ndimfroz(nkp)) then + call internal_zmatrix(cbw, czmat_out_loc(:, :, nkp_loc), m_matrix_orig_local, & + u_matrix_opt, kmesh_info%wb, indxnfroz, ndimfroz, & + dis_manifold%ndimwin, kmesh_info%nnlist, nkp, nkp_loc, & + kmesh_info%nntot, num_bands, num_wann, print_output%timing_level, & + on_root, seedname, stdout) + endif enddo if (lsitesymmetry) then - call comms_gatherv(czmat_out_loc, num_bands*num_bands*counts(my_node_id), & - czmat_out, num_bands*num_bands*counts, num_bands*num_bands*displs) - call comms_bcast(czmat_out(1, 1, 1), num_bands*num_bands*num_kpts) - call sitesym_symmetrize_zmatrix(czmat_out, lwindow) !RS: + call comms_gatherv(czmat_out_loc, num_bands*num_bands*counts(my_node_id), czmat_out, & + num_bands*num_bands*counts, num_bands*num_bands*displs, stdout, & + seedname, comm) + call comms_bcast(czmat_out(1, 1, 1), num_bands*num_bands*num_kpts, stdout, seedname, comm) + call sitesym_symmetrize_zmatrix(sitesym, czmat_out, num_bands, num_kpts, dis_manifold%lwindow) !RS: do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) czmat_out_loc(:, :, nkp_loc) = czmat_out(:, :, nkp) end do end if - call internal_test_convergence() + call internal_test_convergence(history, delta_womegai, dis_control%conv_tol, iter, & + dis_control%conv_window, dis_converged, seedname, stdout) if (dis_converged) then - if (on_root) write (stdout, '(/13x,a,es10.3,a,i2,a)') & - '<<< Delta <', dis_conv_tol, & - ' over ', dis_conv_window, ' iterations >>>' - if (on_root) write (stdout, '(13x,a)') '<<< Disentanglement convergence criteria satisfied >>>' + if (on_root) then + write (stdout, '(/13x,a,es10.3,a,i2,a)') '<<< Delta <', dis_control%conv_tol, & + ' over ', dis_control%conv_window, ' iterations >>>' + write (stdout, '(13x,a)') '<<< Disentanglement convergence criteria satisfied >>>' + endif exit endif @@ -2025,57 +2220,59 @@ subroutine dis_extract() ! [BIG ITERATION LOOP (iter)] deallocate (czmat_out, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating czmat_out in dis_extract') + if (ierr /= 0) call io_error('Error deallocating czmat_out in dis_extract', stdout, seedname) deallocate (czmat_in, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating czmat_in in dis_extract') + if (ierr /= 0) call io_error('Error deallocating czmat_in in dis_extract', stdout, seedname) deallocate (czmat_out_loc, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating czmat_out_loc in dis_extract') + if (ierr /= 0) call io_error('Error deallocating czmat_out_loc in dis_extract', stdout, seedname) deallocate (czmat_in_loc, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating czmat_in_loc in dis_extract') + if (ierr /= 0) call io_error('Error deallocating czmat_in_loc in dis_extract', stdout, seedname) if (on_root) then allocate (ceamp(num_bands, num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating ceamp in dis_extract') + if (ierr /= 0) call io_error('Error allocating ceamp in dis_extract', stdout, seedname) allocate (cham(num_bands, num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cham in dis_extract') + if (ierr /= 0) call io_error('Error allocating cham in dis_extract', stdout, seedname) endif if (.not. dis_converged) then - if (on_root) write (stdout, '(/5x,a)') & - '<<< Warning: Maximum number of disentanglement iterations reached >>>' - if (on_root) write (stdout, '(10x,a)') '<<< Disentanglement convergence criteria not satisfied >>>' - endif - - if (index(devel_flag, 'compspace') > 0) then - - if (icompflag .eq. 1) then - if (iprint > 2) then - if (on_root) write (stdout, ('(/4x,a)')) & - 'WARNING: Complement subspace has zero dimensions at the following k-points:' - i = 0 - if (on_root) write (stdout, '(4x)', advance='no') - do nkp = 1, num_kpts - if (ndimwin(nkp) .eq. num_wann) then - i = i + 1 - if (i .le. 12) then - if (on_root) write (stdout, '(i6)', advance='no') nkp - else - i = 1 - if (on_root) write (stdout, '(/4x)', advance='no') - if (on_root) write (stdout, '(i6)', advance='no') nkp - endif - endif - enddo - endif + if (on_root) then + write (stdout, '(/5x,a)') & + '<<< Warning: Maximum number of disentanglement iterations reached >>>' + write (stdout, '(10x,a)') '<<< Disentanglement convergence criteria not satisfied >>>' endif - endif + !if (index(print_output%devel_flag, 'compspace') > 0) then + + ! if (icompflag .eq. 1) then + ! if (print_output%iprint > 2) then + ! if (on_root) write (stdout, ('(/4x,a)')) & + ! 'WARNING: Complement subspace has zero dimensions at the following k-points:' + ! i = 0 + ! if (on_root) write (stdout, '(4x)', advance='no') + ! do nkp = 1, num_kpts + ! if (dis_manifold%ndimwin(nkp) .eq. num_wann) then + ! i = i + 1 + ! if (i .le. 12) then + ! if (on_root) write (stdout, '(i6)', advance='no') nkp + ! else + ! i = 1 + ! if (on_root) write (stdout, '(/4x)', advance='no') + ! if (on_root) write (stdout, '(i6)', advance='no') nkp + ! endif + ! endif + ! enddo + ! endif + ! endif + + !endif + ! Write the final womegai. This should remain unchanged during the ! subsequent minimization of Omega_tilde in wannierise.f90 ! We store it in the checkpoint file as a sanity check if (on_root) write (stdout, '(/8x,a,f14.8,a/)') 'Final Omega_I ', & - womegai*lenconfac**2, ' ('//trim(length_unit)//'^2)' + womegai*print_output%lenconfac**2, ' ('//trim(print_output%length_unit)//'^2)' ! Set public variable omega_invariant omega_invariant = womegai @@ -2088,7 +2285,7 @@ subroutine dis_extract() do j = 1, num_wann do i = 1, num_wann cham(i, j, nkp) = cmplx_0 - do l = 1, ndimwin(nkp) + do l = 1, dis_manifold%ndimwin(nkp) cham(i, j, nkp) = cham(i, j, nkp) + conjg(u_matrix_opt(l, i, nkp)) & *u_matrix_opt(l, j, nkp)*eigval_opt(l, nkp) enddo @@ -2101,18 +2298,18 @@ subroutine dis_extract() enddo enddo - call ZHPEVX('V', 'A', 'U', num_wann, cap, 0.0_dp, 0.0_dp, 0, 0, -1.0_dp, & - m, w, cz, num_bands, cwork, rwork, iwork, ifail, info) + call ZHPEVX('V', 'A', 'U', num_wann, cap, 0.0_dp, 0.0_dp, 0, 0, -1.0_dp, m, w, cz, & + num_bands, cwork, rwork, iwork, ifail, info) if (info .lt. 0) then if (on_root) write (stdout, *) ' *** ERROR *** ZHPEVX WHILE DIAGONALIZING HAMILTONIAN' if (on_root) write (stdout, *) ' THE ', -info, ' ARGUMENT OF ZHPEVX HAD AN ILLEGAL VALUE' - call io_error(' dis_extract: error') + call io_error(' dis_extract: error', stdout, seedname) endif if (info .gt. 0) then if (on_root) write (stdout, *) ' *** ERROR *** ZHPEVX WHILE DIAGONALIZING HAMILTONIAN' if (on_root) write (stdout, *) info, 'EIGENVECTORS FAILED TO CONVERGE' - call io_error(' dis_extract: error') + call io_error(' dis_extract: error', stdout, seedname) endif ! Store the energy eigenvalues of the optimal subspace (used in wann_ban @@ -2121,7 +2318,7 @@ subroutine dis_extract() ! CALCULATE AMPLITUDES OF THE CORRESPONDING ENERGY EIGENVECTORS IN TERMS ! THE ORIGINAL ("WINDOW SPACE") ENERGY EIGENVECTORS do j = 1, num_wann - do i = 1, ndimwin(nkp) + do i = 1, dis_manifold%ndimwin(nkp) ceamp(i, j, nkp) = cmplx_0 do l = 1, num_wann ceamp(i, j, nkp) = ceamp(i, j, nkp) + cz(l, j)*u_matrix_opt(i, l, nkp) @@ -2132,7 +2329,7 @@ subroutine dis_extract() enddo ! DEBUG - if (iprint > 2) then + if (print_output%iprint > 2) then if (on_root) write (stdout, '(/,a,/)') ' Eigenvalues inside optimal subspace:' do nkp = 1, num_kpts if (on_root) write (stdout, '(a,i3,2x,20(f9.5,1x))') ' K-point ', & @@ -2147,7 +2344,7 @@ subroutine dis_extract() if (.not. lsitesymmetry) then !YN: do nkp = 1, num_kpts do j = 1, num_wann - u_matrix_opt(1:ndimwin(nkp), j, nkp) = ceamp(1:ndimwin(nkp), j, nkp) + u_matrix_opt(1:dis_manifold%ndimwin(nkp), j, nkp) = ceamp(1:dis_manifold%ndimwin(nkp), j, nkp) enddo enddo !else !YN: @@ -2156,53 +2353,55 @@ subroutine dis_extract() ! 'Note(symmetry-adapted mode): u_matrix_opt are no longer the eigenstates of the subspace Hamiltonian.' !RS: endif !YN: endif - call comms_bcast(eigval_opt(1, 1), num_bands*num_kpts) - call comms_bcast(u_matrix_opt(1, 1, 1), num_bands*num_wann*num_kpts) - - if (index(devel_flag, 'compspace') > 0) then - - if (icompflag .eq. 1) then - if (iprint > 2) then - if (on_root) write (stdout, *) 'AT SOME K-POINT(S) COMPLEMENT SUBSPACE HAS ZERO DIMENSIONALITY' - if (on_root) write (stdout, *) '=> DID NOT CREATE FILE COMPSPACE.DAT' - endif - else - ! DIAGONALIZE THE HAMILTONIAN IN THE COMPLEMENT SUBSPACE, WRITE THE - ! CORRESPONDING EIGENFUNCTIONS AND ENERGY EIGENVALUES - do nkp = 1, num_kpts - do j = 1, ndimwin(nkp) - num_wann - do i = 1, ndimwin(nkp) - num_wann - cham(i, j, nkp) = cmplx_0 - do l = 1, ndimwin(nkp) - cham(i, j, nkp) = cham(i, j, nkp) + conjg(camp(l, i, nkp)) & - *camp(l, j, nkp)*eigval_opt(l, nkp) - enddo - enddo - enddo - do j = 1, ndimwin(nkp) - num_wann - do i = 1, j - cap(i + ((j - 1)*j)/2) = cham(i, j, nkp) - enddo - enddo - ndiff = ndimwin(nkp) - num_wann - call ZHPEVX('V', 'A', 'U', ndiff, cap, 0.0_dp, 0.0_dp, 0, 0, & - -1.0_dp, m, w, cz, num_bands, cwork, rwork, iwork, ifail, info) - if (info .lt. 0) then - if (on_root) write (stdout, *) '*** ERROR *** ZHPEVX WHILE DIAGONALIZING HAMILTONIAN' - if (on_root) write (stdout, *) 'THE ', -info, ' ARGUMENT OF ZHPEVX HAD AN ILLEGAL VALUE' - call io_error(' dis_extract: error') - endif - if (info .gt. 0) then - if (on_root) write (stdout, *) '*** ERROR *** ZHPEVX WHILE DIAGONALIZING HAMILTONIAN' - if (on_root) write (stdout, *) info, 'EIGENVECTORS FAILED TO CONVERGE' - call io_error(' dis_extract: error') - endif - ! CALCULATE AMPLITUDES OF THE ENERGY EIGENVECTORS IN THE COMPLEMENT SUBS - ! TERMS OF THE ORIGINAL ENERGY EIGENVECTORS - do j = 1, ndimwin(nkp) - num_wann - do i = 1, ndimwin(nkp) - camp(i, j, nkp) = cmplx_0 - do l = 1, ndimwin(nkp) - num_wann + call comms_bcast(eigval_opt(1, 1), num_bands*num_kpts, stdout, seedname, comm) + call comms_bcast(u_matrix_opt(1, 1, 1), num_bands*num_wann*num_kpts, stdout, seedname, comm) + + !if (index(print_output%devel_flag, 'compspace') > 0) then + + ! if (icompflag .eq. 1) then + ! if (print_output%iprint > 2) then + ! if (on_root) then + ! write (stdout, *) 'AT SOME K-POINT(S) COMPLEMENT SUBSPACE HAS ZERO DIMENSIONALITY' + ! write (stdout, *) '=> DID NOT CREATE FILE COMPSPACE.DAT' + ! endif + ! endif + ! else + ! DIAGONALIZE THE HAMILTONIAN IN THE COMPLEMENT SUBSPACE, WRITE THE + ! CORRESPONDING EIGENFUNCTIONS AND ENERGY EIGENVALUES + ! do nkp = 1, num_kpts + ! do j = 1, dis_manifold%ndimwin(nkp) - num_wann + ! do i = 1, dis_manifold%ndimwin(nkp) - num_wann + ! cham(i, j, nkp) = cmplx_0 + ! do l = 1, dis_manifold%ndimwin(nkp) + ! cham(i, j, nkp) = cham(i, j, nkp) + conjg(camp(l, i, nkp)) & + ! *camp(l, j, nkp)*eigval_opt(l, nkp) + ! enddo + ! enddo + ! enddo + ! do j = 1, dis_manifold%ndimwin(nkp) - num_wann + ! do i = 1, j + ! cap(i + ((j - 1)*j)/2) = cham(i, j, nkp) + ! enddo + ! enddo + ! ndiff = dis_manifold%ndimwin(nkp) - num_wann + ! call ZHPEVX('V', 'A', 'U', ndiff, cap, 0.0_dp, 0.0_dp, 0, 0, & + ! -1.0_dp, m, w, cz, num_bands, cwork, rwork, iwork, ifail, info) + ! if (info .lt. 0) then + ! if (on_root) write (stdout, *) '*** ERROR *** ZHPEVX WHILE DIAGONALIZING HAMILTONIAN' + ! if (on_root) write (stdout, *) 'THE ', -info, ' ARGUMENT OF ZHPEVX HAD AN ILLEGAL VALUE' + ! call io_error(' dis_extract: error', stdout, seedname) + ! endif + ! if (info .gt. 0) then + ! if (on_root) write (stdout, *) '*** ERROR *** ZHPEVX WHILE DIAGONALIZING HAMILTONIAN' + ! if (on_root) write (stdout, *) info, 'EIGENVECTORS FAILED TO CONVERGE' + ! call io_error(' dis_extract: error', stdout, seedname) + ! endif + ! CALCULATE AMPLITUDES OF THE ENERGY EIGENVECTORS IN THE COMPLEMENT SUBS + ! TERMS OF THE ORIGINAL ENERGY EIGENVECTORS + ! do j = 1, dis_manifold%ndimwin(nkp) - num_wann + ! do i = 1, dis_manifold%ndimwin(nkp) + ! camp(i, j, nkp) = cmplx_0 + ! do l = 1, dis_manifold%ndimwin(nkp) - num_wann !write(stdout,*) 'i=',i,' j=',j,' l=',l !write(stdout,*) ' camp(i,j,nkp)=',camp(i,j,nkp) !write(stdout,*) ' cz(l,j)=',cz(l,j) @@ -2211,229 +2410,226 @@ subroutine dis_extract() ! aam: 20/10/2006 -- the second dimension of u_matrix_opt is out of bounds (allocated as num_wann)! ! commenting this line out. ! camp(i,j,nkp) = camp(i,j,nkp) + cz(l,j) * u_matrix_opt(i,l,nkp) - enddo - enddo - enddo - enddo ! [loop over k points (nkp)] + ! enddo + ! enddo + ! enddo + ! enddo ! [loop over k points (nkp)] - endif ! [if icompflag=1] + ! endif ! [if icompflag=1] - endif ![if(index(devel_flag,'compspace')>0)] + !endif ![if(index(devel_flag,'compspace')>0)] deallocate (history, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating history in dis_extract') + if (ierr /= 0) call io_error('Error deallocating history in dis_extract', stdout, seedname) if (on_root) then deallocate (cham, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cham in dis_extract') + if (ierr /= 0) call io_error('Error deallocating cham in dis_extract', stdout, seedname) endif if (allocated(camp)) then deallocate (camp, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating camp in dis_extract') + if (ierr /= 0) call io_error('Error deallocating camp in dis_extract', stdout, seedname) end if if (allocated(camp_loc)) then deallocate (camp_loc, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating camp_loc in dis_extract') + if (ierr /= 0) call io_error('Error deallocating camp_loc in dis_extract', stdout, seedname) endif if (on_root) then deallocate (ceamp, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating ceamp in dis_extract') + if (ierr /= 0) call io_error('Error deallocating ceamp in dis_extract', stdout, seedname) endif deallocate (u_matrix_opt_loc, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating u_matrix_opt_loc in dis_extract') + if (ierr /= 0) call io_error('Error deallocating u_matrix_opt_loc in dis_extract', stdout, seedname) deallocate (wkomegai1_loc, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating wkomegai1_loc in dis_extract') + if (ierr /= 0) call io_error('Error deallocating wkomegai1_loc in dis_extract', stdout, seedname) deallocate (wkomegai1, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating wkomegai1 in dis_extract') + if (ierr /= 0) call io_error('Error deallocating wkomegai1 in dis_extract', stdout, seedname) deallocate (cz, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cz in dis_extract') + if (ierr /= 0) call io_error('Error deallocating cz in dis_extract', stdout, seedname) deallocate (cwork, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cwork in dis_extract') + if (ierr /= 0) call io_error('Error deallocating cwork in dis_extract', stdout, seedname) deallocate (cap, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cap in dis_extract') + if (ierr /= 0) call io_error('Error deallocating cap in dis_extract', stdout, seedname) deallocate (rwork, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating rwork in dis_extract') + if (ierr /= 0) call io_error('Error deallocating rwork in dis_extract', stdout, seedname) deallocate (w, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating w in dis_extract') + if (ierr /= 0) call io_error('Error deallocating w in dis_extract', stdout, seedname) deallocate (ifail, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating ifail in dis_extract') + if (ierr /= 0) call io_error('Error deallocating ifail in dis_extract', stdout, seedname) deallocate (iwork, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating iwork in dis_extract') + if (ierr /= 0) call io_error('Error deallocating iwork in dis_extract', stdout, seedname) deallocate (cbw, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cbw in dis_extract') + if (ierr /= 0) call io_error('Error deallocating cbw in dis_extract', stdout, seedname) deallocate (cww, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cww in dis_extract') + if (ierr /= 0) call io_error('Error deallocating cww in dis_extract', stdout, seedname) deallocate (cwb, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cwb in dis_extract') + if (ierr /= 0) call io_error('Error deallocating cwb in dis_extract', stdout, seedname) if (on_root) write (stdout, '(1x,a/)') & '+----------------------------------------------------------------------------+' - if (timing_level > 1 .and. on_root) call io_stopwatch('dis: extract', 2) + if (print_output%timing_level > 1 .and. on_root) call io_stopwatch('dis: extract', 2, stdout, seedname) return + !================================================! + end subroutine dis_extract - contains + subroutine internal_test_convergence(history, delta_womegai, dis_conv_tol, iter, & + dis_conv_window, dis_converged, seedname, stdout) + !================================================! + ! + !! Check if we have converged + ! + !================================================! - subroutine internal_test_convergence() - !! Check if we have converged + implicit none - implicit none + ! arguments + integer, intent(in) :: iter, dis_conv_window + integer, intent(in) :: stdout - integer :: ierr - real(kind=dp), allocatable :: temp_hist(:) + real(kind=dp), intent(inout) :: history(:) + real(kind=dp), intent(in) :: delta_womegai, dis_conv_tol - allocate (temp_hist(dis_conv_window), stat=ierr) - if (ierr /= 0) call io_error('Error allocating temp_hist in dis_extract') + logical, intent(inout) :: dis_converged - if (iter .le. dis_conv_window) then - history(iter) = delta_womegai - else - temp_hist = eoshift(history, 1, delta_womegai) - history = temp_hist - endif - - dis_converged = .false. - if (iter .ge. dis_conv_window) then - dis_converged = all(abs(history) .lt. dis_conv_tol) - endif + character(len=50), intent(in) :: seedname - deallocate (temp_hist, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating temp_hist in dis_extract') + ! local variables + integer :: ierr + real(kind=dp), allocatable :: temp_hist(:) - return + allocate (temp_hist(dis_conv_window), stat=ierr) + if (ierr /= 0) call io_error('Error allocating temp_hist in dis_extract', stdout, seedname) - end subroutine internal_test_convergence + if (iter .le. dis_conv_window) then + history(iter) = delta_womegai + else + temp_hist = eoshift(history, 1, delta_womegai) + history = temp_hist + endif - !==================================================================! - subroutine internal_zmatrix(nkp, nkp_loc, cmtrx) - !==================================================================! - !! Compute the Z-matrix - ! ! - ! ! - ! ! - !==================================================================! + dis_converged = .false. + if (iter .ge. dis_conv_window) then + dis_converged = all(abs(history) .lt. dis_conv_tol) + endif - implicit none + deallocate (temp_hist, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating temp_hist in dis_extract', stdout, seedname) - integer, intent(in) :: nkp - integer, intent(in) :: nkp_loc - !! Which kpoint - complex(kind=dp), intent(out) :: cmtrx(num_bands, num_bands) - !! (M,N)-TH ENTRY IN THE (NDIMWIN(NKP)-NDIMFROZ(NKP)) x (NDIMWIN(NKP)-NDIMFRO - !! HERMITIAN MATRIX AT THE NKP-TH K-POINT + return + !================================================! + end subroutine internal_test_convergence - ! Internal variables - integer :: l, m, n, p, q, nn, nkp2, ndimk - complex(kind=dp) :: csum + subroutine internal_zmatrix(cbw, cmtrx, m_matrix_orig_local, u_matrix_opt, wb, indxnfroz, & + ndimfroz, ndimwin, nnlist, nkp, nkp_loc, nntot, num_bands, num_wann, & + timing_level, on_root, seedname, stdout) + !================================================! + ! + !! Compute the Z-matrix + ! + !================================================! - if (timing_level > 1 .and. on_root) call io_stopwatch('dis: extract: zmatrix', 1) + implicit none - cmtrx = cmplx_0 - ndimk = ndimwin(nkp) - ndimfroz(nkp) - do nn = 1, nntot - nkp2 = nnlist(nkp, nn) - call zgemm('N', 'N', num_bands, num_wann, ndimwin(nkp2), cmplx_1, & - m_matrix_orig_local(:, :, nn, nkp_loc), num_bands, u_matrix_opt(:, :, nkp2), num_bands, & - cmplx_0, cbw, num_bands) - do n = 1, ndimk - q = indxnfroz(n, nkp) - do m = 1, n - p = indxnfroz(m, nkp) - csum = cmplx_0 - do l = 1, num_wann - csum = csum + cbw(p, l)*conjg(cbw(q, l)) - enddo - cmtrx(m, n) = cmtrx(m, n) + cmplx(wb(nn), 0.0_dp, kind=dp)*csum - cmtrx(n, m) = conjg(cmtrx(m, n)) + ! arguments + integer, intent(in) :: num_bands, num_wann + integer, intent(in) :: timing_level + integer, intent(in) :: stdout + integer, intent(in) :: ndimwin(:) + integer, intent(in) :: nntot, nnlist(:, :) + integer, intent(in) :: indxnfroz(:, :) + integer, intent(in) :: ndimfroz(:) + integer, intent(in) :: nkp + integer, intent(in) :: nkp_loc + + real(kind=dp), intent(in) :: wb(:) + + complex(kind=dp), intent(in) :: u_matrix_opt(:, :, :) + complex(kind=dp), intent(in) :: m_matrix_orig_local(:, :, :, :) + complex(kind=dp), intent(in) :: cbw(:, :) + complex(kind=dp), intent(out) :: cmtrx(:, :) + !! (M,N)-TH ENTRY IN THE (NDIMWIN(NKP)-NDIMFROZ(NKP)) x (NDIMWIN(NKP)-NDIMFRO + !! HERMITIAN MATRIX AT THE NKP-TH K-POINT + + character(len=50), intent(in) :: seedname + + logical, intent(in) :: on_root + ! local variables + integer :: l, m, n, p, q, nn, nkp2, ndimk + complex(kind=dp) :: csum + + if (timing_level > 1 .and. on_root) call io_stopwatch('dis: extract: zmatrix', 1, stdout, seedname) + + cmtrx = cmplx_0 + ndimk = ndimwin(nkp) - ndimfroz(nkp) + do nn = 1, nntot + nkp2 = nnlist(nkp, nn) + call zgemm('N', 'N', num_bands, num_wann, ndimwin(nkp2), cmplx_1, & + m_matrix_orig_local(:, :, nn, nkp_loc), num_bands, u_matrix_opt(:, :, nkp2), & + num_bands, cmplx_0, cbw, num_bands) + do n = 1, ndimk + q = indxnfroz(n, nkp) + do m = 1, n + p = indxnfroz(m, nkp) + csum = cmplx_0 + do l = 1, num_wann + csum = csum + cbw(p, l)*conjg(cbw(q, l)) enddo + cmtrx(m, n) = cmtrx(m, n) + cmplx(wb(nn), 0.0_dp, kind=dp)*csum + cmtrx(n, m) = conjg(cmtrx(m, n)) enddo enddo + enddo - if (timing_level > 1 .and. on_root) call io_stopwatch('dis: extract: zmatrix', 2) - - return - - end subroutine internal_zmatrix - -!~ !==================================================================! -!~! function dis_zeig(nkp,m,cmk) -!~ function dis_zeig(nkp,m) -!~ !==================================================================! -!~ ! ! -!~ ! ! -!~ ! ! -!~ ! ! -!~ !==================================================================! -!~ -!~ ! Computes _mk = sum_{n=1}^N sum_b w_b ||^2 -!~ ! [See Eqs. (12) and (17) of SMV] -!~ -!~ implicit none -!~ -!~ integer, intent(in) :: nkp -!~ integer, intent(in) :: m -!~! complex(kind=dp), intent(in) :: cmk(num_bands,num_bands,nntot) -!~ -!~ ! Internal variables -!~ real(kind=dp) :: dis_zeig -!~ complex(kind=dp) :: cdot_bloch -!~ integer :: n,nn,ndnnx,ndnn,nnsh,nkp2,l,j -!~ -!~ dis_zeig=0.0_dp -!~ -!~! do nn=1,nntot -!~! nkp2=nnlist(nkp,nn) -!~ do n = 1, num_wann -!~ do nn = 1, nntot -!~ nkp2 = nnlist(nkp,nn) -!~ ! Dotproduct -!~ cdot_bloch = cmplx_0 -!~ do l = 1, ndimwin(nkp) -!~ do j = 1, ndimwin(nkp2) -!~ cdot_bloch = cdot_bloch + & -!~! conjg(u_matrix_opt(l,m,nkp)) * u_matrix_opt(j,n,nkp2) * cmk(l,j,nn) -!~ conjg(u_matrix_opt(l,m,nkp)) * u_matrix_opt(j,n,nkp2) * m_matrix_orig(l,j,nn,nkp) -!~ enddo -!~ enddo -!~ write(stdout,'(a,4i5,2f15.10)') 'zeig:',nkp,nn,m,n,cdot_bloch -!~! call zgemm('C','N',num_wann,ndimwin(nkp2),ndimwin(nkp),cmplx_1,& -!~! u_matrix_opt(:,:,nkp),num_bands,m_matrix_orig(:,:,nn,nkp),num_bands,cmplx_0,& -!~! cwb,num_wann) -!~! call zgemm('N','N',num_wann,num_wann,ndimwin(nkp2),cmplx_1,& -!~! cwb,num_wann,u_matrix_opt(:,:,nkp),num_bands,cmplx_0,cww,num_wann) -!~ -!~ dis_zeig = dis_zeig + wb(nn) * abs(cdot_bloch)**2 -!~ -!~! do n=1,num_wann -!~! dis_zeig = dis_zeig + wb(nn) * abs(cww(m,n))**2 -!~! enddo -!~ -!~ enddo -!~ enddo -!~ -!~ return -!~ -!~ end function dis_zeig - - end subroutine dis_extract + if (timing_level > 1 .and. on_root) call io_stopwatch('dis: extract: zmatrix', 2, stdout, seedname) + return + !================================================! + end subroutine internal_zmatrix ![ysl-b] - !==================================================================! - subroutine dis_extract_gamma() - !==================================================================! - ! ! + + subroutine dis_extract_gamma(dis_control, kmesh_info, sitesym, print_output, dis_manifold, & + m_matrix_orig, u_matrix_opt, eigval_opt, omega_invariant, & + indxnfroz, ndimfroz, my_node_id, num_bands, num_kpts, num_nodes, & + num_wann, lsitesymmetry, on_root, seedname, stdout) + !================================================! + ! !! Extracts an num_wann-dimensional subspace at each k by !! minimizing Omega_I (Gamma point version) - ! ! - !==================================================================! + ! + !================================================! use w90_io, only: io_time + use w90_wannier90_types, only: sitesym_type implicit none + ! arguments + type(dis_control_type), intent(in) :: dis_control + type(dis_manifold_type), intent(in) :: dis_manifold + type(kmesh_info_type), intent(in) :: kmesh_info + type(print_output_type), intent(in) :: print_output + type(sitesym_type), intent(in) :: sitesym + + integer, intent(in) :: num_nodes, my_node_id + integer, intent(in) :: stdout + integer, intent(in) :: num_bands, num_kpts, num_wann + integer, intent(in) :: ndimfroz(:) + integer, intent(in) :: indxnfroz(:, :) + + real(kind=dp), intent(inout) :: eigval_opt(:, :) + real(kind=dp), intent(out) :: omega_invariant + + complex(kind=dp), allocatable :: m_matrix_orig(:, :, :, :) ! non-gamma uses _local variant ? + complex(kind=dp), intent(inout) :: u_matrix_opt(:, :, :) + + logical, intent(in) :: on_root, lsitesymmetry ! lsitesym not yet used + + character(len=50), intent(in) :: seedname + ! MODIFIED: ! u_matrix_opt (At input it contains the initial guess for the optimal ! subspace (expressed in terms of the original states inside the window). At @@ -2469,33 +2665,30 @@ subroutine dis_extract_gamma() ! cm(n,m,nkp,nnx) Overlap matrix ! Internal variables - integer :: i, j, l, m, n, nn, nkp, nkp2, info, ierr, ndimk, p + integer, allocatable :: ifail(:) + integer, allocatable :: iwork(:) integer :: icompflag, iter, ndiff - real(kind=dp) :: womegai, wkomegai, womegai1, rsum, delta_womegai - real(kind=dp), allocatable :: wkomegai1(:) - complex(kind=dp), allocatable :: ceamp(:, :, :) + integer :: i, j, l, m, n, nn, nkp, nkp2, info, ierr, ndimk, p + complex(kind=dp), allocatable :: camp(:, :, :) + complex(kind=dp), allocatable :: ceamp(:, :, :) complex(kind=dp), allocatable :: cham(:, :, :) -!@@@ - real(kind=dp), allocatable :: rzmat_in(:, :, :) - real(kind=dp), allocatable :: rzmat_out(:, :, :) -!@@@ - integer, allocatable :: iwork(:) - integer, allocatable :: ifail(:) -!@@@ - real(kind=dp), allocatable :: work(:) + complex(kind=dp), allocatable :: cwb(:, :), cww(:, :), cbw(:, :) + complex(kind=dp), allocatable :: cz(:, :) + real(kind=dp), allocatable :: cap_r(:) + real(kind=dp), allocatable :: history(:) real(kind=dp), allocatable :: rz(:, :) -!@@@ + real(kind=dp), allocatable :: rzmat_in(:, :, :) + real(kind=dp), allocatable :: rzmat_out(:, :, :) real(kind=dp), allocatable :: w(:) - complex(kind=dp), allocatable :: cz(:, :) - - complex(kind=dp), allocatable :: cwb(:, :), cww(:, :), cbw(:, :) + real(kind=dp), allocatable :: wkomegai1(:) + real(kind=dp), allocatable :: work(:) + real(kind=dp) :: womegai, wkomegai, womegai1, rsum, delta_womegai - real(kind=dp), allocatable :: history(:) - logical :: dis_converged + logical :: dis_converged - if (timing_level > 1) call io_stopwatch('dis: extract', 1) + if (print_output%timing_level > 1) call io_stopwatch('dis: extract', 1, stdout, seedname) write (stdout, '(/1x,a)') & ' Extraction of optimally-connected subspace ' @@ -2503,40 +2696,36 @@ subroutine dis_extract_gamma() ' ------------------------------------------ ' allocate (cwb(num_wann, num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cwb in dis_extract_gamma') + if (ierr /= 0) call io_error('Error allocating cwb in dis_extract_gamma', stdout, seedname) allocate (cww(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cww in dis_extract_gamma') + if (ierr /= 0) call io_error('Error allocating cww in dis_extract_gamma', stdout, seedname) allocate (cbw(num_bands, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cbw in dis_extract_gamma') + if (ierr /= 0) call io_error('Error allocating cbw in dis_extract_gamma', stdout, seedname) cwb = cmplx_0; cww = cmplx_0; cbw = cmplx_0 allocate (iwork(5*num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating iwork in dis_extract_gamma') + if (ierr /= 0) call io_error('Error allocating iwork in dis_extract_gamma', stdout, seedname) allocate (ifail(num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating ifail in dis_extract_gamma') + if (ierr /= 0) call io_error('Error allocating ifail in dis_extract_gamma', stdout, seedname) allocate (w(num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating w in dis_extract_gamma') + if (ierr /= 0) call io_error('Error allocating w in dis_extract_gamma', stdout, seedname) allocate (cz(num_bands, num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cz in dis_extract_gamma') -!@@@ + if (ierr /= 0) call io_error('Error allocating cz in dis_extract_gamma', stdout, seedname) allocate (work(8*num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating work in dis_extract_gamma') + if (ierr /= 0) call io_error('Error allocating work in dis_extract_gamma', stdout, seedname) allocate (cap_r((num_bands*(num_bands + 1))/2), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cap_r in dis_extract_gamma') + if (ierr /= 0) call io_error('Error allocating cap_r in dis_extract_gamma', stdout, seedname) allocate (rz(num_bands, num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating rz in dis_extract_gamma') -!@@@ + if (ierr /= 0) call io_error('Error allocating rz in dis_extract_gamma', stdout, seedname) allocate (wkomegai1(num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating wkomegai1 in dis_extract_gamma') -!@@@ + if (ierr /= 0) call io_error('Error allocating wkomegai1 in dis_extract_gamma', stdout, seedname) allocate (rzmat_in(num_bands, num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating rzmat_in in dis_extract') + if (ierr /= 0) call io_error('Error allocating rzmat_in in dis_extract', stdout, seedname) allocate (rzmat_out(num_bands, num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating rzmat_out in dis_extract') -!@@@ - allocate (history(dis_conv_window), stat=ierr) - if (ierr /= 0) call io_error('Error allocating history in dis_extract_gamma') + if (ierr /= 0) call io_error('Error allocating rzmat_out in dis_extract', stdout, seedname) + allocate (history(dis_control%conv_window), stat=ierr) + if (ierr /= 0) call io_error('Error allocating history in dis_extract_gamma', stdout, seedname) ! ******************************************** ! ENERGY WINDOWS AND SUBSPACES AT EACH K-POINT @@ -2573,11 +2762,11 @@ subroutine dis_extract_gamma() ! nitere total number of iterations ! DEBUG - if (iprint > 2) then + if (print_output%iprint > 2) then write (stdout, '(a,/)') ' Original eigenvalues inside outer window:' do nkp = 1, num_kpts write (stdout, '(a,i3,3x,20(f9.5,1x))') ' K-point ', nkp, & - (eigval_opt(i, nkp), i=1, ndimwin(nkp)) + (eigval_opt(i, nkp), i=1, dis_manifold%ndimwin(nkp)) enddo endif ! ENDDEBUG @@ -2597,24 +2786,29 @@ subroutine dis_extract_gamma() ! ------------------ ! BIG ITERATION LOOP ! ------------------ - do iter = 1, dis_num_iter + do iter = 1, dis_control%num_iter if (iter .eq. 1) then ! Initialize Z matrix at k points w/ non-frozen states do nkp = 1, num_kpts - if (num_wann .gt. ndimfroz(nkp)) call internal_zmatrix_gamma(nkp, rzmat_in(:, :, nkp)) + if (num_wann .gt. ndimfroz(nkp)) then + call internal_zmatrix_gamma(cbw, m_matrix_orig, u_matrix_opt, rzmat_in(:, :, nkp), & + kmesh_info%wb, indxnfroz, ndimfroz, dis_manifold%ndimwin, & + kmesh_info%nnlist, nkp, kmesh_info%nntot, num_bands, & + num_wann, print_output%timing_level, seedname, stdout) + endif enddo else ! [iter.ne.1] ! Update Z matrix at k points with non-frozen states, using a mixing sch do nkp = 1, num_kpts if (num_wann .gt. ndimfroz(nkp)) then - ndimk = ndimwin(nkp) - ndimfroz(nkp) + ndimk = dis_manifold%ndimwin(nkp) - ndimfroz(nkp) do i = 1, ndimk do j = 1, i rzmat_in(j, i, nkp) = & - dis_mix_ratio*rzmat_out(j, i, nkp) & - + (1.0_dp - dis_mix_ratio)*rzmat_in(j, i, nkp) + dis_control%mix_ratio*rzmat_out(j, i, nkp) & + + (1.0_dp - dis_control%mix_ratio)*rzmat_in(j, i, nkp) ! hermiticity rzmat_in(i, j, nkp) = rzmat_in(j, i, nkp) enddo @@ -2630,15 +2824,15 @@ subroutine dis_extract_gamma() ! every k (before updating any k), so that for iter>1 overlaps are with ! non-frozen neighboring states from the previous iteration - wkomegai1 = real(num_wann, dp)*wbtot + wkomegai1 = real(num_wann, dp)*kmesh_info%wbtot do nkp = 1, num_kpts if (ndimfroz(nkp) .gt. 0) then - do nn = 1, nntot - nkp2 = nnlist(nkp, nn) - call zgemm('C', 'N', ndimfroz(nkp), ndimwin(nkp2), ndimwin(nkp), cmplx_1, & - u_matrix_opt(:, :, nkp), num_bands, m_matrix_orig(:, :, nn, nkp), num_bands, cmplx_0, & - cwb, num_wann) - call zgemm('N', 'N', ndimfroz(nkp), num_wann, ndimwin(nkp2), cmplx_1, & + do nn = 1, kmesh_info%nntot + nkp2 = kmesh_info%nnlist(nkp, nn) + call zgemm('C', 'N', ndimfroz(nkp), dis_manifold%ndimwin(nkp2), dis_manifold%ndimwin(nkp), & + cmplx_1, u_matrix_opt(:, :, nkp), num_bands, m_matrix_orig(:, :, nn, nkp), & + num_bands, cmplx_0, cwb, num_wann) + call zgemm('N', 'N', ndimfroz(nkp), num_wann, dis_manifold%ndimwin(nkp2), cmplx_1, & cwb, num_wann, u_matrix_opt(:, :, nkp2), num_bands, cmplx_0, cww, num_wann) rsum = 0.0_dp do n = 1, num_wann @@ -2646,7 +2840,7 @@ subroutine dis_extract_gamma() rsum = rsum + real(cww(m, n), dp)**2 + aimag(cww(m, n))**2 enddo enddo - wkomegai1(nkp) = wkomegai1(nkp) - wb(nn)*rsum + wkomegai1(nkp) = wkomegai1(nkp) - kmesh_info%wb(nn)*rsum enddo endif enddo @@ -2655,23 +2849,23 @@ subroutine dis_extract_gamma() do nkp = 1, num_kpts if (num_wann .gt. ndimfroz(nkp)) then ! Diagonalize Z matrix - do j = 1, ndimwin(nkp) - ndimfroz(nkp) + do j = 1, dis_manifold%ndimwin(nkp) - ndimfroz(nkp) do i = 1, j cap_r(i + ((j - 1)*j)/2) = rzmat_in(i, j, nkp) enddo enddo - ndiff = ndimwin(nkp) - ndimfroz(nkp) + ndiff = dis_manifold%ndimwin(nkp) - ndimfroz(nkp) call DSPEVX('V', 'A', 'U', ndiff, cap_r, 0.0_dp, 0.0_dp, 0, 0, & -1.0_dp, m, w, rz, num_bands, work, iwork, ifail, info) if (info .lt. 0) then write (stdout, *) ' *** ERROR *** DSPEVX WHILE DIAGONALIZING Z MATRIX' write (stdout, *) ' THE ', -info, ' ARGUMENT OF DSPEVX HAD AN ILLEGAL VALUE' - call io_error(' dis_extract_gamma: error') + call io_error(' dis_extract_gamma: error', stdout, seedname) endif if (info .gt. 0) then write (stdout, *) ' *** ERROR *** DSPEVX WHILE DIAGONALIZING Z MATRIX' write (stdout, *) info, ' EIGENVECTORS FAILED TO CONVERGE' - call io_error(' dis_extract_gamma: error') + call io_error(' dis_extract_gamma: error', stdout, seedname) endif cz(:, :) = cmplx(rz(:, :), 0.0_dp, dp) ! @@ -2679,11 +2873,11 @@ subroutine dis_extract_gamma() ! eigenvectors of the Z matrix into u_matrix_opt. Also, add contribution from ! non-frozen states to wkomegai1(nkp) (minus the corresponding eigenvalu m = ndimfroz(nkp) - do j = ndimwin(nkp) - num_wann + 1, ndimwin(nkp) - ndimfroz(nkp) + do j = dis_manifold%ndimwin(nkp) - num_wann + 1, dis_manifold%ndimwin(nkp) - ndimfroz(nkp) m = m + 1 wkomegai1(nkp) = wkomegai1(nkp) - w(j) - u_matrix_opt(1:ndimwin(nkp), m, nkp) = cmplx_0 - ndimk = ndimwin(nkp) - ndimfroz(nkp) + u_matrix_opt(1:dis_manifold%ndimwin(nkp), m, nkp) = cmplx_0 + ndimk = dis_manifold%ndimwin(nkp) - ndimfroz(nkp) do i = 1, ndimk p = indxnfroz(i, nkp) u_matrix_opt(p, m, nkp) = cz(i, j) @@ -2698,31 +2892,31 @@ subroutine dis_extract_gamma() ! AT THE LAST ITERATION FIND A BASIS FOR THE (NDIMWIN(NKP)-num_wann)-DIMENS ! COMPLEMENT SPACE - if (index(devel_flag, 'compspace') > 0) then - - if (iter .eq. dis_num_iter) then - allocate (camp(num_bands, num_bands, num_kpts), stat=ierr) - camp = cmplx_0 - if (ierr /= 0) call io_error('Error allocating camp in dis_extract_gamma') - if (ndimwin(nkp) .gt. num_wann) then - do j = 1, ndimwin(nkp) - num_wann - if (num_wann .gt. ndimfroz(nkp)) then - ! USE THE NON-LEADING EIGENVECTORS OF THE Z-MATRIX - camp(1:ndimwin(nkp), j, nkp) = cz(1:ndimwin(nkp), j) - else - ! Then num_wann=NDIMFROZ(NKP) - ! USE THE ORIGINAL NON-FROZEN BLOCH EIGENSTATES - do i = 1, ndimwin(nkp) - camp(i, j, nkp) = cmplx_0 - if (i .eq. indxnfroz(j, nkp)) camp(i, j, nkp) = cmplx_1 - enddo - endif - enddo - else - icompflag = 1 - endif - endif - end if + !if (index(print_output%devel_flag, 'compspace') > 0) then + + ! if (iter .eq. dis_control%num_iter) then + ! allocate (camp(num_bands, num_bands, num_kpts), stat=ierr) + ! camp = cmplx_0 + ! if (ierr /= 0) call io_error('Error allocating camp in dis_extract_gamma', stdout, seedname) + ! if (dis_manifold%ndimwin(nkp) .gt. num_wann) then + ! do j = 1, dis_manifold%ndimwin(nkp) - num_wann + ! if (num_wann .gt. ndimfroz(nkp)) then + ! ! USE THE NON-LEADING EIGENVECTORS OF THE Z-MATRIX + ! camp(1:dis_manifold%ndimwin(nkp), j, nkp) = cz(1:dis_manifold%ndimwin(nkp), j) + ! else + ! ! Then num_wann=NDIMFROZ(NKP) + ! ! USE THE ORIGINAL NON-FROZEN BLOCH EIGENSTATES + ! do i = 1, dis_manifold%ndimwin(nkp) + ! camp(i, j, nkp) = cmplx_0 + ! if (i .eq. indxnfroz(j, nkp)) camp(i, j, nkp) = cmplx_1 + ! enddo + ! endif + ! enddo + ! else + ! icompflag = 1 + ! endif + ! endif + !end if enddo ! [Loop over k points (nkp)] @@ -2769,22 +2963,22 @@ subroutine dis_extract_gamma() womegai = 0.0_dp do nkp = 1, num_kpts wkomegai = 0.0_dp - do nn = 1, nntot - nkp2 = nnlist(nkp, nn) - call zgemm('C', 'N', num_wann, ndimwin(nkp2), ndimwin(nkp), cmplx_1, & - u_matrix_opt(:, :, nkp), num_bands, m_matrix_orig(:, :, nn, nkp), num_bands, cmplx_0, & - cwb, num_wann) - call zgemm('N', 'N', num_wann, num_wann, ndimwin(nkp2), cmplx_1, & - cwb, num_wann, u_matrix_opt(:, :, nkp2), num_bands, cmplx_0, cww, num_wann) + do nn = 1, kmesh_info%nntot + nkp2 = kmesh_info%nnlist(nkp, nn) + call zgemm('C', 'N', num_wann, dis_manifold%ndimwin(nkp2), dis_manifold%ndimwin(nkp), & + cmplx_1, u_matrix_opt(:, :, nkp), num_bands, m_matrix_orig(:, :, nn, nkp), & + num_bands, cmplx_0, cwb, num_wann) + call zgemm('N', 'N', num_wann, num_wann, dis_manifold%ndimwin(nkp2), cmplx_1, cwb, & + num_wann, u_matrix_opt(:, :, nkp2), num_bands, cmplx_0, cww, num_wann) rsum = 0.0_dp do n = 1, num_wann do m = 1, num_wann rsum = rsum + real(cww(m, n), dp)**2 + aimag(cww(m, n))**2 enddo enddo - wkomegai = wkomegai + wb(nn)*rsum + wkomegai = wkomegai + kmesh_info%wb(nn)*rsum enddo - wkomegai = real(num_wann, dp)*wbtot - wkomegai + wkomegai = real(num_wann, dp)*kmesh_info%wbtot - wkomegai womegai = womegai + wkomegai enddo womegai = womegai/real(num_kpts, dp) @@ -2792,22 +2986,28 @@ subroutine dis_extract_gamma() delta_womegai = womegai1/womegai - 1.0_dp - write (stdout, 124) iter, womegai1*lenconfac**2, womegai*lenconfac**2, & - delta_womegai, io_time() + write (stdout, 124) iter, womegai1*print_output%lenconfac**2, & + womegai*print_output%lenconfac**2, delta_womegai, io_time() 124 format(2x, i6, 3x, f14.8, 3x, f14.8, 6x, es10.3, 2x, f8.2, 4x, '<-- DIS') ! Construct the updated Z matrix, CZMAT_OUT, at k points w/ non-frozen s do nkp = 1, num_kpts - if (num_wann .gt. ndimfroz(nkp)) call internal_zmatrix_gamma(nkp, rzmat_out(:, :, nkp)) + if (num_wann .gt. ndimfroz(nkp)) then + call internal_zmatrix_gamma(cbw, m_matrix_orig, u_matrix_opt, rzmat_out(:, :, nkp), & + kmesh_info%wb, indxnfroz, ndimfroz, dis_manifold%ndimwin, & + kmesh_info%nnlist, nkp, kmesh_info%nntot, num_bands, & + num_wann, print_output%timing_level, seedname, stdout) + endif enddo - call internal_test_convergence() + call internal_test_convergence(history, delta_womegai, dis_control%conv_tol, iter, & + dis_control%conv_window, dis_converged, seedname, stdout) if (dis_converged) then write (stdout, '(/13x,a,es10.3,a,i2,a)') & - '<<< Delta <', dis_conv_tol, & - ' over ', dis_conv_window, ' iterations >>>' + '<<< Delta <', dis_control%conv_tol, & + ' over ', dis_control%conv_window, ' iterations >>>' write (stdout, '(13x,a)') '<<< Disentanglement convergence criteria satisfied >>>' exit endif @@ -2816,14 +3016,14 @@ subroutine dis_extract_gamma() ! [BIG ITERATION LOOP (iter)] deallocate (rzmat_out, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating rzmat_out in dis_extract_gamma') + if (ierr /= 0) call io_error('Error deallocating rzmat_out in dis_extract_gamma', stdout, seedname) deallocate (rzmat_in, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating rzmat_in in dis_extract_gamma') + if (ierr /= 0) call io_error('Error deallocating rzmat_in in dis_extract_gamma', stdout, seedname) allocate (ceamp(num_bands, num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating ceamp in dis_extract_gamma') + if (ierr /= 0) call io_error('Error allocating ceamp in dis_extract_gamma', stdout, seedname) allocate (cham(num_bands, num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cham in dis_extract_gamma') + if (ierr /= 0) call io_error('Error allocating cham in dis_extract_gamma', stdout, seedname) if (.not. dis_converged) then write (stdout, '(/5x,a)') & @@ -2832,13 +3032,13 @@ subroutine dis_extract_gamma() endif if (icompflag .eq. 1) then - if (iprint > 2) then + if (print_output%iprint > 2) then write (stdout, ('(/4x,a)')) & 'WARNING: Complement subspace has zero dimensions at the following k-points:' i = 0 write (stdout, '(4x)', advance='no') do nkp = 1, num_kpts - if (ndimwin(nkp) .eq. num_wann) then + if (dis_manifold%ndimwin(nkp) .eq. num_wann) then i = i + 1 if (i .le. 12) then write (stdout, '(i6)', advance='no') nkp @@ -2856,7 +3056,7 @@ subroutine dis_extract_gamma() ! subsequent minimization of Omega_tilde in wannierise.f90 ! We store it in the checkpoint file as a sanity check write (stdout, '(/8x,a,f14.8,a/)') 'Final Omega_I ', & - womegai*lenconfac**2, ' ('//trim(length_unit)//'^2)' + womegai*print_output%lenconfac**2, ' ('//trim(print_output%length_unit)//'^2)' ! Set public variable omega_invariant omega_invariant = womegai @@ -2867,13 +3067,12 @@ subroutine dis_extract_gamma() do j = 1, num_wann do i = 1, num_wann cham(i, j, nkp) = cmplx_0 - do l = 1, ndimwin(nkp) + do l = 1, dis_manifold%ndimwin(nkp) cham(i, j, nkp) = cham(i, j, nkp) + conjg(u_matrix_opt(l, i, nkp)) & *u_matrix_opt(l, j, nkp)*eigval_opt(l, nkp) enddo enddo enddo -!@@@ do j = 1, num_wann do i = 1, j cap_r(i + ((j - 1)*j)/2) = real(cham(i, j, nkp), dp) @@ -2886,25 +3085,24 @@ subroutine dis_extract_gamma() if (info .lt. 0) then write (stdout, *) ' *** ERROR *** DSPEVX WHILE DIAGONALIZING HAMILTONIAN' write (stdout, *) ' THE ', -info, ' ARGUMENT OF DSPEVX HAD AN ILLEGAL VALUE' - call io_error(' dis_extract_gamma: error') + call io_error(' dis_extract_gamma: error', stdout, seedname) endif if (info .gt. 0) then write (stdout, *) ' *** ERROR *** DSPEVX WHILE DIAGONALIZING HAMILTONIAN' write (stdout, *) info, 'EIGENVECTORS FAILED TO CONVERGE' - call io_error(' dis_extract_gamma: error') + call io_error(' dis_extract_gamma: error', stdout, seedname) endif cz = cmplx_0 cz(1:num_wann, 1:num_wann) = cmplx(rz(1:num_wann, 1:num_wann), 0.0_dp, dp) -!@@@ ! Store the energy eigenvalues of the optimal subspace (used in wann_ban eigval_opt(1:num_wann, nkp) = w(1:num_wann) ! CALCULATE AMPLITUDES OF THE CORRESPONDING ENERGY EIGENVECTORS IN TERMS ! THE ORIGINAL ("WINDOW SPACE") ENERGY EIGENVECTORS do j = 1, num_wann - do i = 1, ndimwin(nkp) + do i = 1, dis_manifold%ndimwin(nkp) ceamp(i, j, nkp) = cmplx_0 do l = 1, num_wann ceamp(i, j, nkp) = ceamp(i, j, nkp) + cz(l, j)*u_matrix_opt(i, l, nkp) @@ -2914,7 +3112,7 @@ subroutine dis_extract_gamma() ! NKP enddo ! DEBUG - if (iprint > 2) then + if (print_output%iprint > 2) then write (stdout, '(/,a,/)') ' Eigenvalues inside optimal subspace:' do nkp = 1, num_kpts write (stdout, '(a,i3,2x,20(f9.5,1x))') ' K-point ', & @@ -2928,65 +3126,63 @@ subroutine dis_extract_gamma() ! an optimal Fourier-interpolated band structure: see Sec. III.E of SMV. do nkp = 1, num_kpts do j = 1, num_wann - u_matrix_opt(1:ndimwin(nkp), j, nkp) = ceamp(1:ndimwin(nkp), j, nkp) + u_matrix_opt(1:dis_manifold%ndimwin(nkp), j, nkp) = ceamp(1:dis_manifold%ndimwin(nkp), j, nkp) enddo enddo ! aam: 01/05/2009: added devel_flag if statement as the complementary ! subspace code was causing catastrophic seg-faults - if (index(devel_flag, 'compspace') > 0) then - - ! The compliment subspace code needs work: jry - if (icompflag .eq. 1) then - if (iprint > 2) then - write (stdout, *) 'AT SOME K-POINT(S) COMPLEMENT SUBSPACE HAS ZERO DIMENSIONALITY' - write (stdout, *) '=> DID NOT CREATE FILE COMPSPACE.DAT' - endif - else - ! DIAGONALIZE THE HAMILTONIAN IN THE COMPLEMENT SUBSPACE, WRITE THE - ! CORRESPONDING EIGENFUNCTIONS AND ENERGY EIGENVALUES - do nkp = 1, num_kpts - do j = 1, ndimwin(nkp) - num_wann - do i = 1, ndimwin(nkp) - num_wann - cham(i, j, nkp) = cmplx_0 - do l = 1, ndimwin(nkp) - cham(i, j, nkp) = cham(i, j, nkp) + conjg(camp(l, i, nkp)) & - *camp(l, j, nkp)*eigval_opt(l, nkp) - enddo - enddo - enddo -!@@@ - do j = 1, ndimwin(nkp) - num_wann - do i = 1, j - cap_r(i + ((j - 1)*j)/2) = real(cham(i, j, nkp), dp) - enddo - enddo - ndiff = ndimwin(nkp) - num_wann - - call DSPEVX('V', 'A', 'U', ndiff, cap_r, 0.0_dp, 0.0_dp, 0, 0, -1.0_dp, & - m, w, rz, num_bands, work, iwork, ifail, info) - - if (info .lt. 0) then - write (stdout, *) '*** ERROR *** DSPEVX WHILE DIAGONALIZING HAMILTONIAN' - write (stdout, *) 'THE ', -info, ' ARGUMENT OF DSPEVX HAD AN ILLEGAL VALUE' - call io_error(' dis_extract_gamma: error') - endif - if (info .gt. 0) then - write (stdout, *) '*** ERROR *** DSPEVX WHILE DIAGONALIZING HAMILTONIAN' - write (stdout, *) info, 'EIGENVECTORS FAILED TO CONVERGE' - call io_error(' dis_extract_gamma: error') - endif - - cz = cmplx_0 - cz(1:ndiff, 1:ndiff) = cmplx(rz(1:ndiff, 1:ndiff), 0.0_dp, dp) - -!@@@ - ! CALCULATE AMPLITUDES OF THE ENERGY EIGENVECTORS IN THE COMPLEMENT SUBS - ! TERMS OF THE ORIGINAL ENERGY EIGENVECTORS - do j = 1, ndimwin(nkp) - num_wann - do i = 1, ndimwin(nkp) - camp(i, j, nkp) = cmplx_0 - do l = 1, ndimwin(nkp) - num_wann + !if (index(print_output%devel_flag, 'compspace') > 0) then + + ! The compliment subspace code needs work: jry + ! if (icompflag .eq. 1) then + ! if (print_output%iprint > 2) then + ! write (stdout, *) 'AT SOME K-POINT(S) COMPLEMENT SUBSPACE HAS ZERO DIMENSIONALITY' + ! write (stdout, *) '=> DID NOT CREATE FILE COMPSPACE.DAT' + ! endif + ! else + ! DIAGONALIZE THE HAMILTONIAN IN THE COMPLEMENT SUBSPACE, WRITE THE + ! CORRESPONDING EIGENFUNCTIONS AND ENERGY EIGENVALUES + ! do nkp = 1, num_kpts + ! do j = 1, dis_manifold%ndimwin(nkp) - num_wann + ! do i = 1, dis_manifold%ndimwin(nkp) - num_wann + ! cham(i, j, nkp) = cmplx_0 + ! do l = 1, dis_manifold%ndimwin(nkp) + ! cham(i, j, nkp) = cham(i, j, nkp) + conjg(camp(l, i, nkp)) & + ! *camp(l, j, nkp)*eigval_opt(l, nkp) + ! enddo + ! enddo + ! enddo + ! do j = 1, dis_manifold%ndimwin(nkp) - num_wann + ! do i = 1, j + ! cap_r(i + ((j - 1)*j)/2) = real(cham(i, j, nkp), dp) + ! enddo + ! enddo + ! ndiff = dis_manifold%ndimwin(nkp) - num_wann + + ! call DSPEVX('V', 'A', 'U', ndiff, cap_r, 0.0_dp, 0.0_dp, 0, 0, -1.0_dp, & + ! m, w, rz, num_bands, work, iwork, ifail, info) + + ! if (info .lt. 0) then + ! write (stdout, *) '*** ERROR *** DSPEVX WHILE DIAGONALIZING HAMILTONIAN' + ! write (stdout, *) 'THE ', -info, ' ARGUMENT OF DSPEVX HAD AN ILLEGAL VALUE' + ! call io_error(' dis_extract_gamma: error', stdout, seedname) + ! endif + ! if (info .gt. 0) then + ! write (stdout, *) '*** ERROR *** DSPEVX WHILE DIAGONALIZING HAMILTONIAN' + ! write (stdout, *) info, 'EIGENVECTORS FAILED TO CONVERGE' + ! call io_error(' dis_extract_gamma: error', stdout, seedname) + ! endif + + ! cz = cmplx_0 + ! cz(1:ndiff, 1:ndiff) = cmplx(rz(1:ndiff, 1:ndiff), 0.0_dp, dp) + + ! CALCULATE AMPLITUDES OF THE ENERGY EIGENVECTORS IN THE COMPLEMENT SUBS + ! TERMS OF THE ORIGINAL ENERGY EIGENVECTORS + ! do j = 1, dis_manifold%ndimwin(nkp) - num_wann + ! do i = 1, dis_manifold%ndimwin(nkp) + ! camp(i, j, nkp) = cmplx_0 + ! do l = 1, dis_manifold%ndimwin(nkp) - num_wann !write(stdout,*) 'i=',i,' j=',j,' l=',l !write(stdout,*) ' camp(i,j,nkp)=',camp(i,j,nkp) !write(stdout,*) ' cz(l,j)=',cz(l,j) @@ -2995,147 +3191,126 @@ subroutine dis_extract_gamma() ! aam: 20/10/2006 -- the second dimension of u_matrix_opt is out of bounds (allocated as num_wann)! ! commenting this line out. ! camp(i,j,nkp) = camp(i,j,nkp) + cz(l,j) * u_matrix_opt(i,l,nkp) - enddo - enddo - enddo - enddo - ! [loop over k points (nkp)] + ! enddo + ! enddo + ! enddo + ! enddo + ! [loop over k points (nkp)] - endif - ! [if icompflag=1] + ! endif + ! [if icompflag=1] - endif + !endif ! [if index(devel_flag,'compspace')>0] deallocate (history, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating history in dis_extract_gamma') + if (ierr /= 0) call io_error('Error deallocating history in dis_extract_gamma', stdout, & + seedname) deallocate (cham, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cham in dis_extract_gamma') + if (ierr /= 0) call io_error('Error deallocating cham in dis_extract_gamma', stdout, seedname) if (allocated(camp)) then deallocate (camp, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating camp in dis_extract_gamma') + if (ierr /= 0) call io_error('Error deallocating camp in dis_extract_gamma', stdout, seedname) end if deallocate (ceamp, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating ceamp in dis_extract_gamma') + if (ierr /= 0) call io_error('Error deallocating ceamp in dis_extract_gamma', stdout, seedname) deallocate (wkomegai1, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating wkomegai1 in dis_extract_gamma') + if (ierr /= 0) call io_error('Error deallocating wkomegai1 in dis_extract_gamma', stdout, & + seedname) -!@@@ deallocate (rz, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating rz in dis_extract_gamma') + if (ierr /= 0) call io_error('Error deallocating rz in dis_extract_gamma', stdout, seedname) deallocate (cap_r, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cap_r in dis_extract_gamma') + if (ierr /= 0) call io_error('Error deallocating cap_r in dis_extract_gamma', stdout, seedname) deallocate (work, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating work in dis_extract_gamma') -!@@@ + if (ierr /= 0) call io_error('Error deallocating work in dis_extract_gamma', stdout, seedname) deallocate (cz, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cz in dis_extract_gamma') + if (ierr /= 0) call io_error('Error deallocating cz in dis_extract_gamma', stdout, seedname) deallocate (w, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating w in dis_extract_gamma') + if (ierr /= 0) call io_error('Error deallocating w in dis_extract_gamma', stdout, seedname) deallocate (ifail, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating ifail in dis_extract_gamma') + if (ierr /= 0) call io_error('Error deallocating ifail in dis_extract_gamma', stdout, seedname) deallocate (iwork, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating iwork in dis_extract_gamma') + if (ierr /= 0) call io_error('Error deallocating iwork in dis_extract_gamma', stdout, seedname) deallocate (cbw, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cbw in dis_extract_gamma') + if (ierr /= 0) call io_error('Error deallocating cbw in dis_extract_gamma', stdout, seedname) deallocate (cww, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cww in dis_extract_gamma') + if (ierr /= 0) call io_error('Error deallocating cww in dis_extract_gamma', stdout, seedname) deallocate (cwb, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cwb in dis_extract_gamma') + if (ierr /= 0) call io_error('Error deallocating cwb in dis_extract_gamma', stdout, seedname) write (stdout, '(1x,a/)') & '+----------------------------------------------------------------------------+' - if (timing_level > 1) call io_stopwatch('dis: extract_gamma', 2) + if (print_output%timing_level > 1) call io_stopwatch('dis: extract_gamma', 2, stdout, seedname) return + !================================================! + end subroutine dis_extract_gamma - contains - - subroutine internal_test_convergence() - !! Test for convergence (Gamma point routine) - - implicit none - - integer :: ierr - real(kind=dp), allocatable :: temp_hist(:) - - allocate (temp_hist(dis_conv_window), stat=ierr) - if (ierr /= 0) call io_error('Error allocating temp_hist in dis_extract_gamma') - - if (iter .le. dis_conv_window) then - history(iter) = delta_womegai - else - temp_hist = eoshift(history, 1, delta_womegai) - history = temp_hist - endif - - dis_converged = .false. - if (iter .ge. dis_conv_window) then - dis_converged = all(abs(history) .lt. dis_conv_tol) - endif - - deallocate (temp_hist, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating temp_hist in dis_extract_gamma') - - return - - end subroutine internal_test_convergence + subroutine internal_zmatrix_gamma(cbw, m_matrix_orig, u_matrix_opt, rmtrx, wb, indxnfroz, & + ndimfroz, ndimwin, nnlist, nkp, nntot, num_bands, num_wann, & + timing_level, seedname, stdout) + !================================================! + ! + !! Compute Z-matrix (Gamma point routine) + ! + !================================================! - !==================================================================! - subroutine internal_zmatrix_gamma(nkp, rmtrx) - !==================================================================! - !! Compute Z-matrix (Gamma point routine) - ! ! - ! ! - ! ! - !==================================================================! + implicit none - implicit none + ! arguments + integer, intent(in) :: timing_level, stdout + integer, intent(in) :: num_bands, num_wann, nkp, nntot + integer, intent(in) :: ndimwin(:) + integer, intent(in) :: nnlist(:, :) + integer, intent(in) :: ndimfroz(:) + integer, intent(in) :: indxnfroz(:, :) - integer, intent(in) :: nkp - !! Which k-point - real(kind=dp), intent(out) :: rmtrx(num_bands, num_bands) - !!(M,N)-TH ENTRY IN THE (NDIMWIN(NKP)-NDIMFROZ(NKP)) x (NDIMWIN(NKP)-NDIMFRO - !! HERMITIAN MATRIX AT THE NKP-TH K-POINT + real(kind=dp), intent(in) :: wb(:) + real(kind=dp), intent(out) :: rmtrx(:, :) - ! Internal variables - integer :: l, m, n, p, q, nn, nkp2, ndimk - complex(kind=dp) :: csum + complex(kind=dp), intent(in) :: cbw(:, :) + complex(kind=dp), intent(in) :: m_matrix_orig(:, :, :, :) + complex(kind=dp), intent(inout) :: u_matrix_opt(:, :, :) - if (timing_level > 1) call io_stopwatch('dis: extract_gamma: zmatrix_gamma', 1) + character(len=50), intent(in) :: seedname - rmtrx = 0.0_dp - ndimk = ndimwin(nkp) - ndimfroz(nkp) - do nn = 1, nntot - nkp2 = nnlist(nkp, nn) - call zgemm('N', 'N', num_bands, num_wann, ndimwin(nkp2), cmplx_1, & - m_matrix_orig(:, :, nn, nkp), num_bands, u_matrix_opt(:, :, nkp2), num_bands, & - cmplx_0, cbw, num_bands) - do n = 1, ndimk - q = indxnfroz(n, nkp) - do m = 1, n - p = indxnfroz(m, nkp) - csum = cmplx_0 - do l = 1, num_wann - csum = csum + cbw(p, l)*conjg(cbw(q, l)) - enddo - rmtrx(m, n) = rmtrx(m, n) + wb(nn)*real(csum, dp) - rmtrx(n, m) = rmtrx(m, n) + ! Internal variables + integer :: l, m, n, p, q, nn, nkp2, ndimk + complex(kind=dp) :: csum + + if (timing_level > 1) call io_stopwatch('dis: extract_gamma: zmatrix_gamma', 1, stdout, & + seedname) + + rmtrx = 0.0_dp + ndimk = ndimwin(nkp) - ndimfroz(nkp) + do nn = 1, nntot + nkp2 = nnlist(nkp, nn) + call zgemm('N', 'N', num_bands, num_wann, ndimwin(nkp2), cmplx_1, & + m_matrix_orig(:, :, nn, nkp), num_bands, u_matrix_opt(:, :, nkp2), num_bands, & + cmplx_0, cbw, num_bands) + do n = 1, ndimk + q = indxnfroz(n, nkp) + do m = 1, n + p = indxnfroz(m, nkp) + csum = cmplx_0 + do l = 1, num_wann + csum = csum + cbw(p, l)*conjg(cbw(q, l)) enddo + rmtrx(m, n) = rmtrx(m, n) + wb(nn)*real(csum, dp) + rmtrx(n, m) = rmtrx(m, n) enddo enddo + enddo - if (timing_level > 1) call io_stopwatch('dis: extract_gamma: zmatrix_gamma', 2) - - return - - end subroutine internal_zmatrix_gamma - - end subroutine dis_extract_gamma + if (timing_level > 1) call io_stopwatch('dis: extract_gamma: zmatrix_gamma', 2, stdout, & + seedname) -![ysl-e] + return + !================================================! + end subroutine internal_zmatrix_gamma end module w90_disentangle diff --git a/src/hamiltonian.F90 b/src/hamiltonian.F90 index 15a96d3c7..700e47ab1 100644 --- a/src/hamiltonian.F90 +++ b/src/hamiltonian.F90 @@ -11,195 +11,267 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! w90_hamiltonian: Hamiltonian in Wannier basis ! +! ! +!------------------------------------------------------------! module w90_hamiltonian - !! Module to obtain the Hamiltonian in a wannier basis + + !! Module to obtain the Hamiltonian in a Wannier basis !! This is a simplified routine, more sophisticated properties !! are found in postw90 (e.g. w90_get_oper) + use w90_constants, only: dp - use w90_comms, only: on_root + use w90_types implicit none - private - ! - complex(kind=dp), public, save, allocatable :: ham_r(:, :, :) - !! Hamiltonian matrix in WF representation - ! - integer, public, save, allocatable :: irvec(:, :) - !! The irpt-th Wigner-Seitz grid point has components - !! irvec(1:3,irpt) in the basis of the lattice vectors - ! - integer, public, save, allocatable :: shift_vec(:, :) - ! - integer, public, save, allocatable :: ndegen(:) - !! Weight of the irpt-th point is 1/ndegen(irpt) - ! - integer, public, save :: nrpts - !! number of Wigner-Seitz grid points - ! - integer, public, save :: rpt_origin - !! index of R=0 - ! - real(kind=dp), public, save, allocatable :: wannier_centres_translated(:, :) - !! translated Wannier centres - + public :: hamiltonian_dealloc public :: hamiltonian_get_hr - public :: hamiltonian_write_hr public :: hamiltonian_setup - public :: hamiltonian_dealloc + public :: hamiltonian_write_hr public :: hamiltonian_write_rmn public :: hamiltonian_write_tb - ! Module variables - logical, save :: ham_have_setup = .false. - logical, save :: have_translated = .false. - logical, save :: use_translation = .false. - logical, save :: have_ham_r = .false. - logical, save :: have_ham_k = .false. - logical, save :: hr_written = .false. - logical, save :: tb_written = .false. - - complex(kind=dp), save, allocatable :: ham_k(:, :, :) - contains - !============================================! - subroutine hamiltonian_setup() + !================================================! + + subroutine hamiltonian_setup(ham_logical, print_output, ws_region, w90_calculation, ham_k, & + ham_r, real_lattice, wannier_centres_translated, irvec, mp_grid, & + ndegen, num_kpts, num_wann, nrpts, rpt_origin, bands_plot_mode, & + stdout, seedname, transport_mode) + !================================================! + ! !! Allocate arrays and setup data - !============================================! + ! + !================================================! use w90_constants, only: cmplx_0 use w90_io, only: io_error - use w90_parameters, only: num_wann, num_kpts, bands_plot, transport, & - bands_plot_mode, transport_mode + use w90_types, only: print_output_type, ws_region_type + use w90_wannier90_types, only: w90_calculation_type, ham_logical_type implicit none - integer :: ierr + ! arguments + type(ws_region_type), intent(in) :: ws_region + type(print_output_type), intent(in) :: print_output + type(w90_calculation_type), intent(in) :: w90_calculation + type(ham_logical_type), intent(inout) :: ham_logical + + integer, intent(in) :: mp_grid(3) + integer, intent(inout), allocatable :: irvec(:, :) + integer, intent(inout), allocatable :: ndegen(:) + integer, intent(in) :: num_kpts + integer, intent(in) :: num_wann + integer, intent(inout) :: nrpts + integer, intent(inout) :: rpt_origin + integer, intent(in) :: stdout - if (ham_have_setup) return + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(inout), allocatable :: wannier_centres_translated(:, :) + complex(kind=dp), intent(inout), allocatable :: ham_k(:, :, :) + complex(kind=dp), intent(inout), allocatable :: ham_r(:, :, :) + + character(len=*), intent(in) :: bands_plot_mode + character(len=50), intent(in) :: seedname + character(len=20), intent(in) :: transport_mode + + ! local variables + integer :: ierr + + if (ham_logical%ham_have_setup) return ! ! Determine whether to use translation ! - if (bands_plot .and. (index(bands_plot_mode, 'cut') .ne. 0)) use_translation = .true. - if (transport .and. (index(transport_mode, 'bulk') .ne. 0)) use_translation = .true. - if (transport .and. (index(transport_mode, 'lcr') .ne. 0)) use_translation = .true. + if (w90_calculation%bands_plot .and. (index(bands_plot_mode, 'cut') .ne. 0)) & + ham_logical%use_translation = .true. + if (w90_calculation%transport .and. (index(transport_mode, 'bulk') .ne. 0)) & + ham_logical%use_translation = .true. + if (w90_calculation%transport .and. (index(transport_mode, 'lcr') .ne. 0)) & + ham_logical%use_translation = .true. ! ! Set up Wigner-Seitz vectors ! - call hamiltonian_wigner_seitz(count_pts=.true.) + call hamiltonian_wigner_seitz(ws_region, print_output, real_lattice, irvec, mp_grid, & + ndegen, nrpts, rpt_origin, seedname, stdout, count_pts=.true.) ! allocate (irvec(3, nrpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating irvec in hamiltonian_setup') + if (ierr /= 0) call io_error('Error in allocating irvec in hamiltonian_setup', stdout, seedname) irvec = 0 ! allocate (ndegen(nrpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ndegen in hamiltonian_setup') + if (ierr /= 0) call io_error('Error in allocating ndegen in hamiltonian_setup', stdout, & + seedname) ndegen = 0 ! allocate (ham_r(num_wann, num_wann, nrpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ham_r in hamiltonian_setup') + if (ierr /= 0) call io_error('Error in allocating ham_r in hamiltonian_setup', stdout, seedname) ham_r = cmplx_0 ! allocate (ham_k(num_wann, num_wann, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ham_k in hamiltonian_setup') + if (ierr /= 0) call io_error('Error in allocating ham_k in hamiltonian_setup', stdout, seedname) ham_k = cmplx_0 ! ! Set up the wigner_seitz vectors ! - call hamiltonian_wigner_seitz(count_pts=.false.) + call hamiltonian_wigner_seitz(ws_region, print_output, real_lattice, irvec, mp_grid, & + ndegen, nrpts, rpt_origin, seedname, stdout, count_pts=.false.) ! allocate (wannier_centres_translated(3, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating wannier_centres_translated in hamiltonian_setup') + if (ierr /= 0) call io_error & + ('Error allocating wannier_centres_translated in hamiltonian_setup', stdout, seedname) wannier_centres_translated = 0.0_dp - ham_have_setup = .true. + ham_logical%ham_have_setup = .true. return end subroutine hamiltonian_setup - !============================================! - subroutine hamiltonian_dealloc() + !================================================! + subroutine hamiltonian_dealloc(ham_logical, ham_k, ham_r, wannier_centres_translated, irvec, & + ndegen, stdout, seedname) + !================================================! + ! !! Deallocate module data - !============================================! + ! + !================================================! use w90_io, only: io_error + use w90_wannier90_types, only: ham_logical_type implicit none + ! arguments + type(ham_logical_type), intent(inout) :: ham_logical + + integer, intent(inout), allocatable :: ndegen(:) + integer, intent(inout), allocatable :: irvec(:, :) + integer, intent(in) :: stdout + + real(kind=dp), intent(inout), allocatable :: wannier_centres_translated(:, :) + + complex(kind=dp), intent(inout), allocatable :: ham_r(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: ham_k(:, :, :) + + character(len=50), intent(in) :: seedname + + ! local variables integer :: ierr if (allocated(ham_r)) then deallocate (ham_r, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating ham_r in hamiltonian_dealloc') + if (ierr /= 0) call io_error('Error in deallocating ham_r in hamiltonian_dealloc', stdout, & + seedname) end if if (allocated(ham_k)) then deallocate (ham_k, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating ham_k in hamiltonian_dealloc') + if (ierr /= 0) call io_error('Error in deallocating ham_k in hamiltonian_dealloc', stdout, & + seedname) end if if (allocated(irvec)) then deallocate (irvec, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating irvec in hamiltonian_dealloc') + if (ierr /= 0) call io_error('Error in deallocating irvec in hamiltonian_dealloc', stdout, & + seedname) end if if (allocated(ndegen)) then deallocate (ndegen, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating ndegen in hamiltonian_dealloc') + if (ierr /= 0) call io_error('Error in deallocating ndegen in hamiltonian_dealloc', stdout, & + seedname) end if if (allocated(wannier_centres_translated)) then deallocate (wannier_centres_translated, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating wannier_centres_translated in param_dealloc') + if (ierr /= 0) & + call io_error('Error in deallocating wannier_centres_translated in w90_readwrite_dealloc', stdout, & + seedname) end if - ham_have_setup = .false. - have_translated = .false. - use_translation = .false. - have_ham_r = .false. - have_ham_k = .false. - hr_written = .false. - tb_written = .false. + ham_logical%ham_have_setup = .false. + ham_logical%have_translated = .false. + ham_logical%use_translation = .false. + ham_logical%have_ham_r = .false. + ham_logical%have_ham_k = .false. + ham_logical%hr_written = .false. + ham_logical%tb_written = .false. return + !================================================! end subroutine hamiltonian_dealloc - !============================================! - subroutine hamiltonian_get_hr() - !============================================! - ! ! + !================================================! + subroutine hamiltonian_get_hr(atom_data, dis_manifold, ham_logical, real_space_ham, & + print_output, ham_k, ham_r, u_matrix, u_matrix_opt, eigval, & + kpt_latt, real_lattice, wannier_centres, & + wannier_centres_translated, irvec, shift_vec, nrpts, num_bands, & + num_kpts, num_wann, have_disentangled, stdout, seedname, & + lsitesymmetry) + !================================================! + ! !! Calculate the Hamiltonian in the WF basis - ! ! - !============================================! + ! + !================================================! use w90_constants, only: cmplx_0, cmplx_i, twopi use w90_io, only: io_error, io_stopwatch - use w90_parameters, only: num_bands, num_kpts, num_wann, u_matrix, & - eigval, kpt_latt, u_matrix_opt, lwindow, ndimwin, & - have_disentangled, timing_level - use w90_parameters, only: lsitesymmetry !YN: + use w90_types, only: atom_data_type, dis_manifold_type, print_output_type + use w90_wannier90_types, only: real_space_ham_type, ham_logical_type implicit none - integer, allocatable :: shift_vec(:, :) - complex(kind=dp) :: fac + ! arguments + type(ham_logical_type), intent(inout) :: ham_logical + type(atom_data_type), intent(in) :: atom_data + type(real_space_ham_type), intent(inout) :: real_space_ham + type(print_output_type), intent(in) :: print_output + type(dis_manifold_type), intent(in) :: dis_manifold + + integer, intent(inout), allocatable :: shift_vec(:, :) + integer, intent(inout) :: irvec(:, :) + integer, intent(inout) :: nrpts + integer, intent(in) :: num_bands + integer, intent(in) :: num_kpts + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + + real(kind=dp), intent(inout) :: wannier_centres_translated(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: wannier_centres(:, :) + real(kind=dp), intent(in) :: kpt_latt(:, :) + real(kind=dp), intent(in) :: eigval(:, :) + + complex(kind=dp), intent(inout) :: ham_r(:, :, :) + complex(kind=dp), intent(in) :: u_matrix(:, :, :) + complex(kind=dp), intent(in) :: u_matrix_opt(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: ham_k(:, :, :) + + logical, intent(in) :: lsitesymmetry !YN: + logical, intent(in) :: have_disentangled + + character(len=50), intent(in) :: seedname + + ! local variables + integer :: loop_kpt, i, j, m, irpt, ierr, counter real(kind=dp) :: rdotk real(kind=dp) :: eigval_opt(num_bands, num_kpts) real(kind=dp) :: eigval2(num_wann, num_kpts) real(kind=dp) :: irvec_tmp(3) - integer :: loop_kpt, i, j, m, irpt, ideg, ierr, counter complex(kind=dp) :: utmp(num_bands, num_wann) !RS: + complex(kind=dp) :: fac - if (timing_level > 1) call io_stopwatch('hamiltonian: get_hr', 1) + if (print_output%timing_level > 1) call io_stopwatch('hamiltonian: get_hr', 1, stdout, seedname) - if (have_ham_r) then - if (have_translated .eqv. use_translation) then + if (ham_logical%have_ham_r) then + if (ham_logical%have_translated .eqv. ham_logical%use_translation) then goto 200 else goto 100 endif end if - if (have_ham_k) go to 100 + if (ham_logical%have_ham_k) go to 100 !~ if (.not. allocated(ham_k)) then !~ allocate(ham_k(num_wann,num_wann,num_kpts),stat=ierr) @@ -217,7 +289,7 @@ subroutine hamiltonian_get_hr() do loop_kpt = 1, num_kpts counter = 0 do j = 1, num_bands - if (lwindow(j, loop_kpt)) then + if (dis_manifold%lwindow(j, loop_kpt)) then counter = counter + 1 eigval_opt(counter, loop_kpt) = eigval(j, loop_kpt) end if @@ -229,31 +301,34 @@ subroutine hamiltonian_get_hr() ! but we choose u_matrix_opt such that the Hamiltonian is ! diagonal at each kpoint. (I guess we should check it here) - if (.not. lsitesymmetry) then !YN: + if (.not. lsitesymmetry) then !YN: do loop_kpt = 1, num_kpts do j = 1, num_wann - do m = 1, ndimwin(loop_kpt) + do m = 1, dis_manifold%ndimwin(loop_kpt) eigval2(j, loop_kpt) = eigval2(j, loop_kpt) + eigval_opt(m, loop_kpt)* & - real(conjg(u_matrix_opt(m, j, loop_kpt))*u_matrix_opt(m, j, loop_kpt), dp) + real(conjg(u_matrix_opt(m, j, loop_kpt))* & + u_matrix_opt(m, j, loop_kpt), dp) enddo enddo enddo - else !YN: - ! u_matrix_opt are not the eigenvectors of the Hamiltonian any more !RS: - ! so we have to calculate ham_k in the following way !RS: - do loop_kpt = 1, num_kpts !RS: - utmp(1:ndimwin(loop_kpt), :) = & !RS: - matmul(u_matrix_opt(1:ndimwin(loop_kpt), :, loop_kpt), u_matrix(:, :, loop_kpt)) !RS: - do j = 1, num_wann !RS: - do i = 1, j !RS: - do m = 1, ndimwin(loop_kpt) !RS: - ham_k(i, j, loop_kpt) = ham_k(i, j, loop_kpt) + eigval_opt(m, loop_kpt)*conjg(utmp(m, i))*utmp(m, j) !RS: - enddo !RS: - if (i .lt. j) ham_k(j, i, loop_kpt) = conjg(ham_k(i, j, loop_kpt)) !RS: - enddo !RS: - enddo !RS: - enddo !RS: - endif !YN: + else !YN: + ! u_matrix_opt are not the eigenvectors of the Hamiltonian any more !RS: + ! so we have to calculate ham_k in the following way !RS: + do loop_kpt = 1, num_kpts !RS: + utmp(1:dis_manifold%ndimwin(loop_kpt), :) = & !RS: + matmul(u_matrix_opt(1:dis_manifold%ndimwin(loop_kpt), :, loop_kpt), & + u_matrix(:, :, loop_kpt)) !RS: + do j = 1, num_wann !RS: + do i = 1, j !RS: + do m = 1, dis_manifold%ndimwin(loop_kpt) !RS: + ham_k(i, j, loop_kpt) = ham_k(i, j, loop_kpt) + eigval_opt(m, loop_kpt)* & + conjg(utmp(m, i))*utmp(m, j) !RS: + enddo !RS: + if (i .lt. j) ham_k(j, i, loop_kpt) = conjg(ham_k(i, j, loop_kpt)) !RS: + enddo !RS: + enddo !RS: + enddo !RS: + endif !YN: else eigval2(1:num_wann, :) = eigval(1:num_wann, :) @@ -265,7 +340,7 @@ subroutine hamiltonian_get_hr() ! H(k)=U^{dagger}(k).H_0(k).U(k) ! Note: we enforce hermiticity here - if (.not. lsitesymmetry .or. .not. have_disentangled) then !YN: + if (.not. lsitesymmetry .or. .not. have_disentangled) then !YN: do loop_kpt = 1, num_kpts do j = 1, num_wann do i = 1, j @@ -277,9 +352,9 @@ subroutine hamiltonian_get_hr() enddo enddo enddo - endif !YN: + endif !YN: - have_ham_k = .true. + ham_logical%have_ham_k = .true. 100 continue @@ -292,7 +367,7 @@ subroutine hamiltonian_get_hr() ham_r = cmplx_0 - if (.not. use_translation) then + if (.not. ham_logical%use_translation) then do irpt = 1, nrpts do loop_kpt = 1, num_kpts @@ -302,14 +377,16 @@ subroutine hamiltonian_get_hr() enddo enddo - have_translated = .false. + ham_logical%have_translated = .false. else allocate (shift_vec(3, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating shift_vec in hamiltonian_get_hr') - call internal_translate_centres() - + if (ierr /= 0) call io_error('Error in allocating shift_vec in hamiltonian_get_hr', stdout, & + seedname) + call internal_translate_centres(atom_data, real_space_ham, real_lattice, & + wannier_centres, wannier_centres_translated, shift_vec, & + print_output%iprint, num_wann, seedname, stdout) do irpt = 1, nrpts do loop_kpt = 1, num_kpts do i = 1, num_wann @@ -325,7 +402,7 @@ subroutine hamiltonian_get_hr() enddo enddo - have_translated = .true. + ham_logical%have_translated = .true. end if @@ -339,41 +416,60 @@ subroutine hamiltonian_get_hr() ! call ws_translate_dist(nrpts, irvec) ! endif - have_ham_r = .true. + ham_logical%have_ham_r = .true. 200 continue if (allocated(shift_vec)) then deallocate (shift_vec, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating shift_vec in hamiltonian_get_hr') + if (ierr /= 0) call io_error('Error in deallocating shift_vec in hamiltonian_get_hr', & + stdout, seedname) end if - if (timing_level > 1) call io_stopwatch('hamiltonian: get_hr', 2) + if (print_output%timing_level > 1) call io_stopwatch('hamiltonian: get_hr', 2, stdout, seedname) return contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - !====================================================! - subroutine internal_translate_centres() + !================================================! + subroutine internal_translate_centres(atom_data, real_space_ham, real_lattice, & + wannier_centres, wannier_centres_translated, shift_vec, & + iprint, num_wann, seedname, stdout) + !================================================! + ! !! Translate the centres of the WF into the home cell - !====================================================! + ! + !================================================! - use w90_parameters, only: num_wann, real_lattice, recip_lattice, wannier_centres, & - num_atoms, atoms_pos_cart, translation_centre_frac, & - automatic_translation, num_species, atoms_species_num, lenconfac - use w90_io, only: stdout, io_error - use w90_utility, only: utility_cart_to_frac, utility_frac_to_cart + use w90_io, only: io_error + use w90_utility, only: utility_cart_to_frac, utility_frac_to_cart, utility_inverse_mat + use w90_types, only: atom_data_type + use w90_wannier90_types, only: real_space_ham_type implicit none - ! <<>> + ! arguments + type(atom_data_type), intent(in) :: atom_data + type(real_space_ham_type), intent(inout) :: real_space_ham + + integer, intent(inout) :: shift_vec(:, :) + integer, intent(in) :: iprint + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + + real(kind=dp), intent(inout) :: wannier_centres_translated(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: wannier_centres(:, :) + + character(len=50), intent(in) :: seedname + + ! local variables + real(kind=dp) :: inv_lattice(3, 3) integer :: iw, ierr, nat, nsp, ind real(kind=dp), allocatable :: r_home(:, :), r_frac(:, :) - real(kind=dp) :: c_pos_cart(3), c_pos_frac(3) - real(kind=dp) :: r_frac_min(3) + real(kind=dp) :: c_pos_cart(3), c_pos_frac(3) + real(kind=dp) :: r_frac_min(3) !~ if (.not.allocated(wannier_centres_translated)) then !~ allocate(wannier_centres_translated(3,num_wann),stat=ierr) @@ -382,29 +478,32 @@ subroutine internal_translate_centres() !~ end if allocate (r_home(3, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating r_home in internal_translate_centres') + if (ierr /= 0) call io_error('Error in allocating r_home in internal_translate_centres', & + stdout, seedname) allocate (r_frac(3, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating r_frac in internal_translate_centres') + if (ierr /= 0) call io_error('Error in allocating r_frac in internal_translate_centres', & + stdout, seedname) r_home = 0.0_dp; r_frac = 0.0_dp - if (automatic_translation) then + call utility_inverse_mat(real_lattice, inv_lattice) + if (real_space_ham%automatic_translation) then ! Calculate centre of atomic positions c_pos_cart = 0.0_dp; c_pos_frac = 0.0_dp - do nsp = 1, num_species - do nat = 1, atoms_species_num(nsp) - c_pos_cart(:) = c_pos_cart(:) + atoms_pos_cart(:, nat, nsp) + do nsp = 1, atom_data%num_species + do nat = 1, atom_data%species_num(nsp) + c_pos_cart(:) = c_pos_cart(:) + atom_data%pos_cart(:, nat, nsp) enddo enddo - c_pos_cart = c_pos_cart/num_atoms + c_pos_cart = c_pos_cart/atom_data%num_atoms ! Cartesian --> fractional - call utility_cart_to_frac(c_pos_cart, translation_centre_frac, recip_lattice) + call utility_cart_to_frac(c_pos_cart, real_space_ham%translation_centre_frac, inv_lattice) end if ! Wannier function centres will be in [c_pos_frac-0.5,c_pos_frac+0.5] - r_frac_min(:) = translation_centre_frac(:) - 0.5_dp + r_frac_min(:) = real_space_ham%translation_centre_frac(:) - 0.5_dp ! Cartesian --> fractional do iw = 1, num_wann - call utility_cart_to_frac(wannier_centres(:, iw), r_frac(:, iw), recip_lattice) + call utility_cart_to_frac(wannier_centres(:, iw), r_frac(:, iw), inv_lattice) ! Rationalise r_frac - r_frac_min to interval [0,1] ! by applying shift of -floor(r_frac - r_frac_min) shift_vec(:, iw) = -floor(r_frac(:, iw) - r_frac_min(:)) @@ -416,11 +515,12 @@ subroutine internal_translate_centres() ! NEVER overwrite wannier_centres !wannier_centres = r_home - if (on_root) then + if (iprint > 0) then write (stdout, '(1x,a)') 'Translated centres' - write (stdout, '(4x,a,3f10.6)') 'translation centre in fractional coordinate:', translation_centre_frac(:) + write (stdout, '(4x,a,3f10.6)') 'translation centre in fractional coordinate:', & + real_space_ham%translation_centre_frac(:) do iw = 1, num_wann - write (stdout, 888) iw, (r_home(ind, iw)*lenconfac, ind=1, 3) + write (stdout, 888) iw, (r_home(ind, iw)*print_output%lenconfac, ind=1, 3) end do write (stdout, '(1x,a78)') repeat('-', 78) write (stdout, *) @@ -428,9 +528,11 @@ subroutine internal_translate_centres() wannier_centres_translated = r_home deallocate (r_frac, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating r_frac in internal_translate_centres') + if (ierr /= 0) call io_error('Error in deallocating r_frac in internal_translate_centres', & + stdout, seedname) deallocate (r_home, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating r_home in internal_translate_centres') + if (ierr /= 0) call io_error('Error in deallocating r_home in internal_translate_centres', & + stdout, seedname) return @@ -440,23 +542,38 @@ end subroutine internal_translate_centres end subroutine hamiltonian_get_hr - !============================================! - subroutine hamiltonian_write_hr() - !============================================! + !================================================! + subroutine hamiltonian_write_hr(ham_logical, ham_r, irvec, ndegen, nrpts, num_wann, & + timing_level, seedname, stdout) + !================================================! + ! !! Write the Hamiltonian in the WF basis - !============================================! + ! + !================================================! + + use w90_io, only: io_error, io_stopwatch, io_file_unit, io_date + use w90_wannier90_types, only: ham_logical_type - use w90_io, only: io_error, io_stopwatch, io_file_unit, & - seedname, io_date - use w90_parameters, only: num_wann, timing_level + ! arguments + type(ham_logical_type), intent(inout) :: ham_logical + integer, intent(inout) :: nrpts + integer, intent(in) :: ndegen(:) + integer, intent(inout) :: irvec(:, :) + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + integer, intent(in) :: timing_level + complex(kind=dp), intent(in) :: ham_r(:, :, :) + character(len=50), intent(in) :: seedname + + ! local variables integer :: i, j, irpt, file_unit character(len=33) :: header character(len=9) :: cdate, ctime - if (hr_written) return + if (ham_logical%hr_written) return - if (timing_level > 1) call io_stopwatch('hamiltonian: write_hr', 1) + if (timing_level > 1) call io_stopwatch('hamiltonian: write_hr', 1, stdout, seedname) ! write the whole matrix with all the indices @@ -482,28 +599,30 @@ subroutine hamiltonian_write_hr() close (file_unit) - hr_written = .true. + ham_logical%hr_written = .true. - if (timing_level > 1) call io_stopwatch('hamiltonian: write_hr', 2) + if (timing_level > 1) call io_stopwatch('hamiltonian: write_hr', 2, stdout, seedname) return -101 call io_error('Error: hamiltonian_write_hr: problem opening file '//trim(seedname)//'_hr.dat') +101 call io_error('Error: hamiltonian_write_hr: problem opening file '//trim(seedname)//'_hr.dat', & + stdout, seedname) end subroutine hamiltonian_write_hr - !================================================================================! - subroutine hamiltonian_wigner_seitz(count_pts) - !================================================================================! + !================================================! + subroutine hamiltonian_wigner_seitz(ws_region, print_output, real_lattice, irvec, mp_grid, & + ndegen, nrpts, rpt_origin, seedname, stdout, count_pts) + !================================================! !! Calculates a grid of points that fall inside of (and eventually on the !! surface of) the Wigner-Seitz supercell centered on the origin of the B !! lattice with primitive translations nmonkh(1)*a_1+nmonkh(2)*a_2+nmonkh(3)*a_3 - !================================================================================! + !================================================! - use w90_constants, only: eps7, eps8 - use w90_io, only: io_error, io_stopwatch, stdout - use w90_parameters, only: iprint, mp_grid, real_metric, timing_level, & - ws_search_size, ws_distance_tol + use w90_constants, only: eps8 + use w90_io, only: io_error, io_stopwatch + use w90_utility, only: utility_metric + use w90_types, only: print_output_type, ws_region_type ! irvec(i,irpt) The irpt-th Wigner-Seitz grid point has components ! irvec(1:3,irpt) in the basis of the lattice vectors @@ -512,21 +631,41 @@ subroutine hamiltonian_wigner_seitz(count_pts) implicit none - logical, intent(in) :: count_pts - !! Only count points and return + ! arguments + type(ws_region_type), intent(in) :: ws_region + type(print_output_type), intent(in) :: print_output + + integer, intent(inout) :: nrpts + integer, intent(inout), allocatable :: ndegen(:) + integer, intent(inout), allocatable :: irvec(:, :) + integer, intent(inout) :: rpt_origin + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: real_lattice(3, 3) + + character(len=50), intent(in) :: seedname + + logical, intent(in) :: count_pts + + ! local variables integer :: ndiff(3) - real(kind=dp) :: tot, dist_min - real(kind=dp), allocatable :: dist(:) integer :: n1, n2, n3, i1, i2, i3, icnt, i, j, ierr, dist_dim + real(kind=dp) :: tot, dist_min + real(kind=dp), allocatable :: dist(:) + real(kind=dp) :: real_metric(3, 3) - if (timing_level > 1) call io_stopwatch('hamiltonian: wigner_seitz', 1) + if (print_output%timing_level > 1) & + call io_stopwatch('hamiltonian: wigner_seitz', 1, stdout, seedname) + call utility_metric(real_lattice, real_metric) dist_dim = 1 do i = 1, 3 - dist_dim = dist_dim*((ws_search_size(i) + 1)*2 + 1) + dist_dim = dist_dim*((ws_region%ws_search_size(i) + 1)*2 + 1) end do allocate (dist(dist_dim), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating dist in hamiltonian_wigner_seitz') + if (ierr /= 0) call io_error('Error in allocating dist in hamiltonian_wigner_seitz', stdout, & + seedname) ! The Wannier functions live in a supercell of the real space unit cell ! this supercell is mp_grid unit cells long in each direction @@ -545,17 +684,17 @@ subroutine hamiltonian_wigner_seitz(count_pts) ! that live in a supercell which is (2*ws_search_size+1)**2 ! larger than the Born-von Karman supercell. ! We need to find which among these live in the Wigner-Seitz cell - do n1 = -ws_search_size(1)*mp_grid(1), ws_search_size(1)*mp_grid(1) - do n2 = -ws_search_size(2)*mp_grid(2), ws_search_size(2)*mp_grid(2) - do n3 = -ws_search_size(3)*mp_grid(3), ws_search_size(3)*mp_grid(3) + do n1 = -ws_region%ws_search_size(1)*mp_grid(1), ws_region%ws_search_size(1)*mp_grid(1) + do n2 = -ws_region%ws_search_size(2)*mp_grid(2), ws_region%ws_search_size(2)*mp_grid(2) + do n3 = -ws_region%ws_search_size(3)*mp_grid(3), ws_region%ws_search_size(3)*mp_grid(3) ! Loop over the lattice vectors R of the Born-von Karman supercell ! that contains all the points of the previous loop. ! There are (2*(ws_search_size+1)+1)**3 points R. R=0 corresponds to ! i1=i2=i3=0, or icnt=((2*(ws_search_size+1)+1)**3 + 1)/2 icnt = 0 - do i1 = -ws_search_size(1) - 1, ws_search_size(1) + 1 - do i2 = -ws_search_size(2) - 1, ws_search_size(2) + 1 - do i3 = -ws_search_size(3) - 1, ws_search_size(3) + 1 + do i1 = -ws_region%ws_search_size(1) - 1, ws_region%ws_search_size(1) + 1 + do i2 = -ws_region%ws_search_size(2) - 1, ws_region%ws_search_size(2) + 1 + do i3 = -ws_region%ws_search_size(3) - 1, ws_region%ws_search_size(3) + 1 icnt = icnt + 1 ! Calculate distance squared |r-R|^2 ndiff(1) = n1 - i1*mp_grid(1) @@ -573,12 +712,13 @@ subroutine hamiltonian_wigner_seitz(count_pts) enddo ! AAM: On first pass, we reference unallocated variables (ndegen,irvec) dist_min = minval(dist) - if (abs(dist((dist_dim + 1)/2) - dist_min) .lt. ws_distance_tol**2) then + if (abs(dist((dist_dim + 1)/2) - dist_min) .lt. ws_region%ws_distance_tol**2) then nrpts = nrpts + 1 if (.not. count_pts) then ndegen(nrpts) = 0 do i = 1, dist_dim - if (abs(dist(i) - dist_min) .lt. ws_distance_tol**2) ndegen(nrpts) = ndegen(nrpts) + 1 + if (abs(dist(i) - dist_min) .lt. ws_region%ws_distance_tol**2) & + ndegen(nrpts) = ndegen(nrpts) + 1 end do irvec(1, nrpts) = n1 irvec(2, nrpts) = n2 @@ -597,9 +737,11 @@ subroutine hamiltonian_wigner_seitz(count_pts) enddo ! deallocate (dist, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating dist hamiltonian_wigner_seitz') + if (ierr /= 0) call io_error('Error in deallocating dist hamiltonian_wigner_seitz', stdout, & + seedname) if (count_pts) then - if (timing_level > 1) call io_stopwatch('hamiltonian: wigner_seitz', 2) + if (print_output%timing_level > 1) & + call io_stopwatch('hamiltonian: wigner_seitz', 2, stdout, seedname) return end if @@ -609,7 +751,7 @@ subroutine hamiltonian_wigner_seitz(count_pts) tot = tot + 1.0_dp/real(ndegen(i), dp) enddo - if (iprint >= 3 .and. on_root) then + if (print_output%iprint >= 3) then write (stdout, '(1x,i4,a,/)') nrpts, ' lattice points in Wigner-Seitz supercell:' do i = 1, nrpts write (stdout, '(4x,a,3(i3,1x),a,i2)') ' vector ', irvec(1, i), irvec(2, i), & @@ -619,30 +761,49 @@ subroutine hamiltonian_wigner_seitz(count_pts) write (stdout, '(1x,a,i12)') ' mp_grid product = ', mp_grid(1)*mp_grid(2)*mp_grid(3) endif if (abs(tot - real(mp_grid(1)*mp_grid(2)*mp_grid(3), dp)) > eps8) then - call io_error('ERROR in hamiltonian_wigner_seitz: error in finding Wigner-Seitz points') + call io_error('ERROR in hamiltonian_wigner_seitz: error in finding Wigner-Seitz points', & + stdout, seedname) endif - if (timing_level > 1) call io_stopwatch('hamiltonian: wigner_seitz', 2) + if (print_output%timing_level > 1) & + call io_stopwatch('hamiltonian: wigner_seitz', 2, stdout, seedname) return end subroutine hamiltonian_wigner_seitz - !============================================! - subroutine hamiltonian_write_rmn() + !================================================! + subroutine hamiltonian_write_rmn(kmesh_info, m_matrix, kpt_latt, irvec, nrpts, num_kpts, & + num_wann, stdout, seedname) + !================================================! + ! !! Write out the matrix elements of r - !============================================! - use w90_parameters, only: m_matrix, wb, bk, num_wann, num_kpts, kpt_latt, & - nntot, write_bvec + ! + !================================================! + use w90_constants, only: twopi, cmplx_i - use w90_io, only: io_error, io_file_unit, seedname, io_date + use w90_io, only: io_error, io_file_unit, io_date + use w90_types, only: kmesh_info_type implicit none - complex(kind=dp) :: fac - real(kind=dp) :: rdotk - integer :: loop_rpt, m, n, nkp, ind, nn, file_unit - complex(kind=dp) :: position(3) + ! arguments + type(kmesh_info_type), intent(in) :: kmesh_info + + integer, intent(inout) :: nrpts + integer, intent(inout) :: irvec(:, :) + integer, intent(in) :: num_wann + integer, intent(in) :: num_kpts + integer, intent(in) :: stdout + real(kind=dp), intent(in) :: kpt_latt(:, :) + complex(kind=dp), intent(in) :: m_matrix(:, :, :, :) + character(len=50), intent(in) :: seedname + + ! local variables + integer :: loop_rpt, m, n, nkp, ind, nn, file_unit + real(kind=dp) :: rdotk + complex(kind=dp) :: fac + complex(kind=dp) :: position(3) character(len=33) :: header character(len=9) :: cdate, ctime @@ -663,7 +824,7 @@ subroutine hamiltonian_write_rmn() rdotk = twopi*dot_product(kpt_latt(:, nkp), real(irvec(:, loop_rpt), dp)) fac = exp(-cmplx_i*rdotk)/real(num_kpts, dp) do ind = 1, 3 - do nn = 1, nntot + do nn = 1, kmesh_info%nntot if (m .eq. n) then ! For loop_rpt==rpt_origin, this reduces to ! Eq.(32) of Marzari and Vanderbilt PRB 56, @@ -671,12 +832,12 @@ subroutine hamiltonian_write_rmn() ! Wang, Yates, Souza and Vanderbilt PRB 74, ! 195118 (2006), modified according to ! Eqs.(27,29) of Marzari and Vanderbilt - position(ind) = position(ind) - & - wb(nn)*bk(ind, nn, nkp)*aimag(log(m_matrix(n, m, nn, nkp)))*fac + position(ind) = position(ind) - kmesh_info%wb(nn)*kmesh_info%bk(ind, nn, nkp) & + *aimag(log(m_matrix(n, m, nn, nkp)))*fac else ! Eq.(44) Wang, Yates, Souza and Vanderbilt PRB 74, 195118 (2006) - position(ind) = position(ind) + & - cmplx_i*wb(nn)*bk(ind, nn, nkp)*m_matrix(n, m, nn, nkp)*fac + position(ind) = position(ind) + cmplx_i*kmesh_info%wb(nn) & + *kmesh_info%bk(ind, nn, nkp)*m_matrix(n, m, nn, nkp)*fac endif end do end do @@ -690,36 +851,59 @@ subroutine hamiltonian_write_rmn() return -101 call io_error('Error: hamiltonian_write_rmn: problem opening file '//trim(seedname)//'_r') +101 call io_error('Error: hamiltonian_write_rmn: problem opening file '//trim(seedname)//'_r', & + stdout, seedname) end subroutine hamiltonian_write_rmn - !============================================! - subroutine hamiltonian_write_tb() - !============================================! + !================================================! + subroutine hamiltonian_write_tb(ham_logical, kmesh_info, ham_r, m_matrix, kpt_latt, & + real_lattice, irvec, ndegen, nrpts, num_kpts, num_wann, stdout, & + timing_level, seedname) + !================================================! !! Write in a single file all the information !! that is needed to set up a Wannier-based !! tight-binding model: !! * lattice vectors !! * <0n|H|Rn> !! * <0n|r|Rn> - !============================================! + !================================================! - use w90_io, only: io_error, io_stopwatch, io_file_unit, & - seedname, io_date - use w90_parameters, only: real_lattice, num_wann, timing_level, & - m_matrix, wb, bk, num_kpts, kpt_latt, nntot + use w90_io, only: io_error, io_stopwatch, io_file_unit, io_date use w90_constants, only: twopi, cmplx_i + use w90_types, only: kmesh_info_type + use w90_wannier90_types, only: ham_logical_type - integer :: i, j, irpt, ik, nn, idir, file_unit - character(len=33) :: header - character(len=9) :: cdate, ctime - complex(kind=dp) :: fac, pos_r(3) + ! arguments + type(kmesh_info_type), intent(in) :: kmesh_info + type(ham_logical_type), intent(inout) :: ham_logical + + integer :: i, j, irpt, ik, nn, idir, file_unit + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + integer, intent(in) :: num_kpts + integer, intent(in) :: timing_level + integer, intent(inout) :: nrpts + integer, intent(in) :: ndegen(:) + integer, intent(inout) :: irvec(:, :) + + real(kind=dp), intent(in) :: kpt_latt(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + + complex(kind=dp), intent(in) :: ham_r(:, :, :) + complex(kind=dp), intent(in) :: m_matrix(:, :, :, :) + + character(len=50), intent(in) :: seedname + + ! local variables real(kind=dp) :: rdotk + complex(kind=dp) :: fac, pos_r(3) + character(len=33) :: header + character(len=9) :: cdate, ctime - if (tb_written) return + if (ham_logical%tb_written) return - if (timing_level > 1) call io_stopwatch('hamiltonian: write_tb', 1) + if (timing_level > 1) call io_stopwatch('hamiltonian: write_tb', 1, stdout, seedname) file_unit = io_file_unit() open (file_unit, file=trim(seedname)//'_tb.dat', form='formatted', & @@ -762,7 +946,7 @@ subroutine hamiltonian_write_tb() rdotk = twopi*dot_product(kpt_latt(:, ik), real(irvec(:, irpt), dp)) fac = exp(-cmplx_i*rdotk)/real(num_kpts, dp) do idir = 1, 3 - do nn = 1, nntot + do nn = 1, kmesh_info%nntot if (i == j) then ! For irpt==rpt_origin, this reduces to ! Eq.(32) of Marzari and Vanderbilt PRB 56, @@ -770,12 +954,12 @@ subroutine hamiltonian_write_tb() ! Wang, Yates, Souza and Vanderbilt PRB 74, ! 195118 (2006), modified according to ! Eqs.(27,29) of Marzari and Vanderbilt - pos_r(idir) = pos_r(idir) - & - wb(nn)*bk(idir, nn, ik)*aimag(log(m_matrix(i, i, nn, ik)))*fac + pos_r(idir) = pos_r(idir) - kmesh_info%wb(nn)*kmesh_info%bk(idir, nn, ik) & + *aimag(log(m_matrix(i, i, nn, ik)))*fac else ! Eq.(44) Wang, Yates, Souza and Vanderbilt PRB 74, 195118 (2006) - pos_r(idir) = pos_r(idir) + & - cmplx_i*wb(nn)*bk(idir, nn, ik)*m_matrix(j, i, nn, ik)*fac + pos_r(idir) = pos_r(idir) + cmplx_i*kmesh_info%wb(nn) & + *kmesh_info%bk(idir, nn, ik)*m_matrix(j, i, nn, ik)*fac endif end do end do @@ -784,17 +968,16 @@ subroutine hamiltonian_write_tb() end do end do end do - close (file_unit) - tb_written = .true. + ham_logical%tb_written = .true. - if (timing_level > 1) call io_stopwatch('hamiltonian: write_tb', 2) + if (timing_level > 1) call io_stopwatch('hamiltonian: write_tb', 2, stdout, seedname) return 101 call io_error('Error: hamiltonian_write_tb: problem opening file ' & - //trim(seedname)//'_tb.dat') + //trim(seedname)//'_tb.dat', stdout, seedname) end subroutine hamiltonian_write_tb diff --git a/src/io.F90 b/src/io.F90 index 1a0ad5271..ea08687bf 100644 --- a/src/io.F90 +++ b/src/io.F90 @@ -11,75 +11,67 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! w90_io: file io and timing functions ! +! ! +!------------------------------------------------------------! module w90_io + !! Module to handle operations related to file input and output. use w90_constants, only: dp + implicit none private -#ifdef MPI - include 'mpif.h' -#endif + integer, parameter, public :: maxlen = 255 !! Max column width of input file + logical, public, save :: post_proc_flag !! Are we in post processing mode + character(len=10), parameter, public :: w90_version = '3.1.0 ' !! Label for this version of wannier90 - integer, public, save :: stdout - !! Unit on which stdout is written - character(len=50), public, save :: seedname - !! The seedname for this run - integer, parameter, public :: maxlen = 255 - !! Max column width of input file - logical, public, save :: post_proc_flag - !! Are we in post processing mode - character(len=10), public, parameter:: w90_version = '3.1.0 ' - !! Label for this version of wannier90 - - type timing_data - !! Data about each stopwatch - for timing routines - integer :: ncalls - !! Number of times stopwatch has been called - real(kind=DP) :: ctime - !! Total time on stopwatch - real(kind=DP) :: ptime - !! Temporary record of time when watch is started - character(len=60) :: label - !! What is this stopwatch timing - end type timing_data - - integer, parameter :: nmax = 100 - !! Maximum number of stopwatches - type(timing_data) :: clocks(nmax) - !! Data for the stopwatches - integer, save :: nnames = 0 - !! Number of active stopwatches + type timing_data_type !! Data about each stopwatch - for timing routines + integer :: ncalls !! Number of times stopwatch has been called + real(kind=DP) :: ctime !! Total time on stopwatch + real(kind=DP) :: ptime !! Temporary record of time when watch is started + character(len=60) :: label !! What is this stopwatch timing + end type timing_data_type + + integer, parameter :: nmax = 100 !! Maximum number of stopwatches + type(timing_data_type) :: clocks(nmax) !! Data for the stopwatches + integer, save :: nnames = 0 !! Number of active stopwatches - public :: io_stopwatch public :: io_commandline - public :: io_print_timings - public :: io_get_seedname - public :: io_time - public :: io_wallclocktime public :: io_date public :: io_error public :: io_file_unit + public :: io_get_seedname + public :: io_print_timings + public :: io_stopwatch + public :: io_time + public :: io_wallclocktime contains - !===================================== - subroutine io_stopwatch(tag, mode) - !===================================== + !================================================ + + subroutine io_stopwatch(tag, mode, stdout, seedname) + !================================================ + ! !! Stopwatch to time parts of the code - !===================================== + ! + !================================================ implicit none character(len=*), intent(in) :: tag !! Which stopwatch to act upon integer, intent(in) :: mode + character(len=50), intent(in) :: seedname !! Action 1=start 2=stop integer :: i + integer :: stdout real(kind=dp) :: t call cpu_time(t) @@ -97,7 +89,7 @@ subroutine io_stopwatch(tag, mode) enddo nnames = nnames + 1 - if (nnames .gt. nmax) call io_error('Maximum number of calls to io_stopwatch exceeded') + if (nnames .gt. nmax) call io_error('Maximum number of calls to io_stopwatch exceeded', stdout, seedname) clocks(nnames)%label = tag clocks(nnames)%ctime = 0.0_dp @@ -118,7 +110,7 @@ subroutine io_stopwatch(tag, mode) case default write (stdout, *) ' Name = ', trim(tag), ' mode = ', mode - call io_error('Value of mode not recognised in io_stopwatch') + call io_error('Value of mode not recognised in io_stopwatch', stdout, seedname) end select @@ -126,15 +118,18 @@ subroutine io_stopwatch(tag, mode) end subroutine io_stopwatch - !===================================== - subroutine io_print_timings() - !===================================== + !================================================ + subroutine io_print_timings(stdout) + !================================================ + ! !! Output timing information to stdout - !===================================== + ! + !================================================ implicit none integer :: i + integer :: stdout write (stdout, '(/1x,a)') '*===========================================================================*' write (stdout, '(1x,a)') '| TIMING INFORMATION |' @@ -151,17 +146,19 @@ subroutine io_print_timings() end subroutine io_print_timings - !======================================= - subroutine io_get_seedname() - !======================================= + !================================================ + subroutine io_get_seedname(seedname) + !================================================ ! !! Get the seedname from the commandline - !======================================= + ! + !================================================ implicit none integer :: num_arg character(len=50) :: ctemp + character(len=50), intent(inout) :: seedname post_proc_flag = .false. @@ -195,12 +192,13 @@ subroutine io_get_seedname() end subroutine io_get_seedname - !======================================= - subroutine io_commandline(prog, dryrun) - !======================================= + !================================================ + subroutine io_commandline(prog, dryrun, seedname) + !================================================ ! !! Parse the commandline - !======================================= + ! + !================================================ implicit none @@ -208,6 +206,7 @@ subroutine io_commandline(prog, dryrun) !! Name of the calling program logical, intent(out) :: dryrun !! Have we been asked for a dryrun + character(len=50), intent(inout) :: seedname integer :: num_arg, loop character(len=50), allocatable :: ctemp(:) @@ -303,55 +302,26 @@ subroutine io_commandline(prog, dryrun) end subroutine io_commandline - !======================================== - subroutine io_error(error_msg) - !======================================== + !================================================ + subroutine io_error(error_msg, stdout, seedname) + !================================================ + ! !! Abort the code giving an error message - !======================================== + ! + !================================================ implicit none - character(len=*), intent(in) :: error_msg - -#ifdef MPI - character(len=50) :: filename - integer :: stderr, ierr, whoami, num_nodes - - call mpi_comm_rank(mpi_comm_world, whoami, ierr) - call mpi_comm_size(mpi_comm_world, num_nodes, ierr) - if (num_nodes > 1) then - if (whoami > 99999) then - write (filename, '(a,a,I0,a)') trim(seedname), '.node_', whoami, '.werr' - else - write (filename, '(a,a,I5.5,a)') trim(seedname), '.node_', whoami, '.werr' - endif - stderr = io_file_unit() - open (unit=stderr, file=trim(filename), form='formatted', err=105) - write (stderr, '(1x,a)') trim(error_msg) - close (stderr) - end if - -105 write (*, '(1x,a)') trim(error_msg) -106 write (*, '(1x,a,I0,a)') "Error on node ", & - whoami, ": examine the output/error files for details" - - if (whoami == 0) then - write (stdout, *) 'Exiting.......' - write (stdout, '(1x,a)') trim(error_msg) - close (stdout) - end if - - call MPI_abort(MPI_comm_world, 1, ierr) - -#else - write (stdout, *) 'Exiting.......' - write (stdout, '(1x,a)') trim(error_msg) + character(len=*), intent(in) :: error_msg + character(len=50), intent(in) :: seedname + integer :: stdout + ! calls mpi_abort on mpi_comm_world iff compiled with MPI support + call comms_abort(seedname, error_msg, stdout) close (stdout) write (*, '(1x,a)') trim(error_msg) write (*, '(A)') "Error: examine the output/error file for details" -#endif #ifdef EXIT_FLAG call exit(1) @@ -361,14 +331,14 @@ subroutine io_error(error_msg) end subroutine io_error - !======================================================= + !================================================ subroutine io_date(cdate, ctime) - !======================================================= + !================================================ ! !! Returns two strings containing the date and the time !! in human-readable format. Uses a standard f90 call. ! - !======================================================= + !================================================ implicit none character(len=9), intent(out) :: cdate !! The date @@ -387,14 +357,14 @@ subroutine io_date(cdate, ctime) end subroutine io_date - !=========================================================== + !================================================ function io_time() - !=========================================================== + !================================================ ! !! Returns elapsed CPU time in seconds since its first call. !! Uses standard f90 call ! - !=========================================================== + !================================================ use w90_constants, only: dp implicit none @@ -418,14 +388,15 @@ function io_time() return end function io_time - !==================================================================! + !================================================! function io_wallclocktime() - !==================================================================! - ! ! + !================================================! ! Returns elapsed wall clock time in seconds since its first call ! - ! ! - !=================================================================== + ! + !================================================ + use w90_constants, only: dp, i64 + implicit none real(kind=dp) :: io_wallclocktime @@ -447,14 +418,14 @@ function io_wallclocktime() return end function io_wallclocktime - !=========================================== + !================================================ function io_file_unit() - !=========================================== - ! + !================================================ !! Returns an unused unit number !! so we can later open a file on that unit. ! - !=========================================== + !================================================ + implicit none integer :: io_file_unit, unit diff --git a/src/kmesh.F90 b/src/kmesh.F90 index 011995be1..04f247e75 100644 --- a/src/kmesh.F90 +++ b/src/kmesh.F90 @@ -11,8 +11,13 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! w90_kmesh: operations on BZ mesh ! +! ! +!------------------------------------------------------------! module w90_kmesh + !! Routines to analyse the regular k-point mesh !! and determine the overlaps neccessary for a finite !! difference representation of the spread operator. @@ -22,8 +27,7 @@ module w90_kmesh !! Vanderbilt PRB 56 12847 (1997) use w90_constants, only: dp - use w90_parameters - use w90_comms, only: on_root + use w90_types, only: max_shells, num_nnmax ! JJ these are parameters used for dimensioning implicit none @@ -41,59 +45,76 @@ module w90_kmesh ! bka ! the b-directions (not considering inversion) from ! 1st k-point to its neighbours + public :: kmesh_dealloc public :: kmesh_get public :: kmesh_write - public :: kmesh_dealloc integer, parameter :: nsupcell = 5 !! Size of supercell (of recip cell) in which to search for k-point shells - integer :: lmn(3, (2*nsupcell + 1)**3) - !! Order in which to search the cells (ordered in dist from origin) - - real(kind=dp) :: bvec_inp(3, num_nnmax, max_shells) - !! The input b-vectors (only used in the rare case they are read from file) - contains - !======================================================= - subroutine kmesh_get() - !===================================================== + + !================================================ + subroutine kmesh_get(kmesh_input, kmesh_info, print_output, kpt_latt, real_lattice, & + num_kpts, gamma_only, seedname, stdout) + !================================================ ! !! Main routine to calculate the b-vectors ! - !===================================================== - use w90_io, only: stdout, io_error, io_stopwatch - use w90_utility, only: utility_compar + !================================================ + + use w90_io, only: io_error, io_stopwatch + use w90_utility, only: utility_compar, utility_recip_lattice, utility_frac_to_cart + use w90_types, only: kmesh_info_type, kmesh_input_type, print_output_type implicit none - ! Variables that are private + ! arguments + type(print_output_type), intent(in) :: print_output + type(kmesh_info_type), intent(inout) :: kmesh_info + type(kmesh_input_type), intent(inout) :: kmesh_input - integer :: nlist, nkp, nkp2, l, m, n, ndnn, ndnnx, ndnntot - integer :: nnsh, nn, nnx, loop, i, j - integer :: ifound, counter, na, nap, loop_s, loop_b, shell, nbvec, bnum - integer :: ifpos, ifneg, ierr, multi(search_shells) - integer :: nnshell(num_kpts, search_shells) - integer, allocatable :: nnlist_tmp(:, :), nncell_tmp(:, :, :) ![ysl] + integer, intent(in) :: num_kpts + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: kpt_latt(:, :) + character(len=50), intent(in) :: seedname + logical, intent(in) :: gamma_only - real(kind=dp) :: vkpp(3), vkpp2(3) - real(kind=dp) :: dist, dnn0, dnn1, bb1, bbn, ddelta + ! local variables real(kind=dp), parameter :: eta = 99999999.0_dp ! eta = very large + real(kind=dp), allocatable :: bvec_tmp(:, :) + real(kind=dp), allocatable :: kpt_cart(:, :) + real(kind=dp) :: bk_local(3, num_nnmax, num_kpts) !, kpbvec(3) real(kind=dp) :: bweight(max_shells) - real(kind=dp) :: dnn(search_shells) + real(kind=dp) :: dist, dnn0, dnn1, bb1, bbn, ddelta + real(kind=dp) :: dnn(kmesh_input%search_shells) + real(kind=dp) :: recip_lattice(3, 3), volume + real(kind=dp) :: vkpp(3), vkpp2(3) real(kind=dp) :: wb_local(num_nnmax) - real(kind=dp) :: bk_local(3, num_nnmax, num_kpts), kpbvec(3) - real(kind=dp), allocatable :: bvec_tmp(:, :) - ! Integer arrays that are public + integer, allocatable :: nnlist_tmp(:, :), nncell_tmp(:, :, :) ![ysl] + integer :: ifound, counter, na, nap, loop_s, loop_b, shell !, nbvec, bnum + integer :: ifpos, ifneg, ierr, multi(kmesh_input%search_shells) + integer :: lmn(3, (2*nsupcell + 1)**3) ! Order in which to search the cells (ordered in dist from origin) + integer :: nlist, nkp, nkp2, l, m, n, ndnn, ndnnx, ndnntot + integer :: nnshell(num_kpts, kmesh_input%search_shells) + integer :: nnsh, nn, nnx, loop, i, j + integer :: stdout - if (timing_level > 0) call io_stopwatch('kmesh: get', 1) + if (print_output%timing_level > 0) call io_stopwatch('kmesh: get', 1, stdout, seedname) - if (on_root) write (stdout, '(/1x,a)') & + call utility_recip_lattice(real_lattice, recip_lattice, volume, stdout, seedname) + if (print_output%iprint > 0) write (stdout, '(/1x,a)') & '*---------------------------------- K-MESH ----------------------------------*' ! Sort the cell neighbours so we loop in order of distance from the home shell - call kmesh_supercell_sort + call kmesh_supercell_sort(print_output, recip_lattice, lmn, seedname, stdout) + + allocate (kpt_cart(3, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating kpt_cart in kmesh_get', stdout, seedname) + do nkp = 1, num_kpts + call utility_frac_to_cart(kpt_latt(:, nkp), kpt_cart(:, nkp), recip_lattice) + enddo ! find the distance between k-point 1 and its nearest-neighbour shells ! if we have only one k-point, the n-neighbours are its periodic images @@ -101,7 +122,7 @@ subroutine kmesh_get() dnn0 = 0.0_dp dnn1 = eta ndnntot = 0 - do nlist = 1, search_shells + do nlist = 1, kmesh_input%search_shells do nkp = 1, num_kpts do loop = 1, (2*nsupcell + 1)**3 l = lmn(1, loop); m = lmn(2, loop); n = lmn(3, loop) @@ -110,29 +131,29 @@ subroutine kmesh_get() dist = sqrt((kpt_cart(1, 1) - vkpp(1))**2 & + (kpt_cart(2, 1) - vkpp(2))**2 + (kpt_cart(3, 1) - vkpp(3))**2) ! - if ((dist .gt. kmesh_tol) .and. (dist .gt. dnn0 + kmesh_tol)) then - if (dist .lt. dnn1 - kmesh_tol) then + if ((dist .gt. kmesh_input%tol) .and. (dist .gt. dnn0 + kmesh_input%tol)) then + if (dist .lt. dnn1 - kmesh_input%tol) then dnn1 = dist ! found a closer shell counter = 0 end if - if (dist .gt. (dnn1 - kmesh_tol) .and. dist .lt. (dnn1 + kmesh_tol)) then + if (dist .gt. (dnn1 - kmesh_input%tol) .and. dist .lt. (dnn1 + kmesh_input%tol)) then counter = counter + 1 ! count the multiplicity of the shell end if end if enddo enddo - if (dnn1 .lt. eta - kmesh_tol) ndnntot = ndnntot + 1 + if (dnn1 .lt. eta - kmesh_input%tol) ndnntot = ndnntot + 1 dnn(nlist) = dnn1 multi(nlist) = counter dnn0 = dnn1 dnn1 = eta enddo - if (on_root) then + if (print_output%iprint > 0) then write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' write (stdout, '(1x,a)') '| Distance to Nearest-Neighbour Shells |' write (stdout, '(1x,a)') '| ------------------------------------ |' - if (lenconfac .eq. 1.0_dp) then + if (print_output%lenconfac .eq. 1.0_dp) then write (stdout, '(1x,a)') '| Shell Distance (Ang^-1) Multiplicity |' write (stdout, '(1x,a)') '| ----- ----------------- ------------ |' else @@ -140,14 +161,15 @@ subroutine kmesh_get() write (stdout, '(1x,a)') '| ----- ------------------ ------------ |' endif do ndnn = 1, ndnntot - write (stdout, '(1x,a,11x,i3,17x,f10.6,19x,i4,12x,a)') '|', ndnn, dnn(ndnn)/lenconfac, multi(ndnn), '|' + write (stdout, '(1x,a,11x,i3,17x,f10.6,19x,i4,12x,a)') '|', ndnn, & + dnn(ndnn)/print_output%lenconfac, multi(ndnn), '|' enddo write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' endif - if (iprint >= 4) then + if (print_output%iprint >= 4) then ! Write out all the bvectors - if (on_root) then + if (print_output%iprint > 0) then write (stdout, '(1x,"|",76(" "),"|")') write (stdout, '(1x,a)') '| Complete list of b-vectors and their lengths |' write (stdout, '(1x,"|",76(" "),"|")') @@ -155,56 +177,61 @@ subroutine kmesh_get() endif allocate (bvec_tmp(3, maxval(multi)), stat=ierr) - if (ierr /= 0) call io_error('Error allocating bvec_tmp in kmesh_get') + if (ierr /= 0) call io_error('Error allocating bvec_tmp in kmesh_get', stdout, seedname) bvec_tmp = 0.0_dp counter = 0 - do shell = 1, search_shells - call kmesh_get_bvectors(multi(shell), 1, dnn(shell), bvec_tmp(:, 1:multi(shell))) + do shell = 1, kmesh_input%search_shells + call kmesh_get_bvectors(kmesh_input, print_output, bvec_tmp(:, 1:multi(shell)), kpt_cart, & + recip_lattice, dnn(shell), lmn, 1, multi(shell), num_kpts, & + seedname, stdout) do loop = 1, multi(shell) counter = counter + 1 - if (on_root) write (stdout, '(a,I4,1x,a,2x,3f12.6,2x,a,2x,f12.6,a)') ' | b-vector ', counter, ': (', & - bvec_tmp(:, loop)/lenconfac, ')', dnn(shell)/lenconfac, ' |' + if (print_output%iprint > 0) write (stdout, '(a,I4,1x,a,2x,3f12.6,2x,a,2x,f12.6,a)') ' | b-vector ', counter, ': (', & + bvec_tmp(:, loop)/print_output%lenconfac, ')', dnn(shell)/print_output%lenconfac, ' |' end do end do deallocate (bvec_tmp) - if (ierr /= 0) call io_error('Error deallocating bvec_tmp in kmesh_get') - if (on_root) write (stdout, '(1x,"|",76(" "),"|")') - if (on_root) write (stdout, '(1x,"+",76("-"),"+")') + if (ierr /= 0) call io_error('Error deallocating bvec_tmp in kmesh_get', stdout, seedname) + if (print_output%iprint > 0) write (stdout, '(1x,"|",76(" "),"|")') + if (print_output%iprint > 0) write (stdout, '(1x,"+",76("-"),"+")') end if ! Get the shell weights to satisfy the B1 condition - if (index(devel_flag, 'kmesh_degen') > 0) then - call kmesh_shell_from_file(multi, dnn, bweight) - else - if (num_shells == 0) then - call kmesh_shell_automatic(multi, dnn, bweight) - elseif (num_shells > 0) then - call kmesh_shell_fixed(multi, dnn, bweight) - end if - - if (on_root) then - write (stdout, '(1x,a)', advance='no') '| The following shells are used: ' - do ndnn = 1, num_shells - if (ndnn .eq. num_shells) then - write (stdout, '(i3,1x)', advance='no') shell_list(ndnn) - else - write (stdout, '(i3,",")', advance='no') shell_list(ndnn) - endif - enddo - do l = 1, 11 - num_shells - write (stdout, '(4x)', advance='no') - enddo - write (stdout, '("|")') - endif + !if (index(print_output%devel_flag, 'kmesh_degen') > 0) then + ! call kmesh_shell_from_file(kmesh_input, print_output, bvec_inp, bweight, dnn, kpt_cart, & + ! recip_lattice, lmn, multi, num_kpts, seedname, stdout) + !else + if (kmesh_input%num_shells == 0) then + call kmesh_shell_automatic(kmesh_input, print_output, bweight, dnn, kpt_cart, recip_lattice, & + lmn, multi, num_kpts, seedname, stdout) + elseif (kmesh_input%num_shells > 0) then + call kmesh_shell_fixed(kmesh_input, print_output, bweight, dnn, kpt_cart, recip_lattice, lmn, & + multi, num_kpts, seedname, stdout) end if - nntot = 0 - do loop_s = 1, num_shells - nntot = nntot + multi(shell_list(loop_s)) + if (print_output%iprint > 0) then + write (stdout, '(1x,a)', advance='no') '| The following shells are used: ' + do ndnn = 1, kmesh_input%num_shells + if (ndnn .eq. kmesh_input%num_shells) then + write (stdout, '(i3,1x)', advance='no') kmesh_input%shell_list(ndnn) + else + write (stdout, '(i3,",")', advance='no') kmesh_input%shell_list(ndnn) + endif + enddo + do l = 1, 11 - kmesh_input%num_shells + write (stdout, '(4x)', advance='no') + enddo + write (stdout, '("|")') + endif + !end if + + kmesh_info%nntot = 0 + do loop_s = 1, kmesh_input%num_shells + kmesh_info%nntot = kmesh_info%nntot + multi(kmesh_input%shell_list(loop_s)) end do - if (nntot > num_nnmax) then - if (on_root) then + if (kmesh_info%nntot > num_nnmax) then + if (print_output%iprint > 0) then write (stdout, '(a,i2,a)') ' **WARNING: kmesh has found >', num_nnmax, ' nearest neighbours**' write (stdout, '(a)') ' ' write (stdout, '(a)') ' This is probably caused by an error in your unit cell specification' @@ -228,41 +255,43 @@ subroutine kmesh_get() endif allocate (bvec_tmp(3, maxval(multi)), stat=ierr) - if (ierr /= 0) call io_error('Error allocating bvec_tmp in kmesh_get') + if (ierr /= 0) call io_error('Error allocating bvec_tmp in kmesh_get', stdout, seedname) bvec_tmp = 0.0_dp counter = 0 - do shell = 1, search_shells - call kmesh_get_bvectors(multi(shell), 1, dnn(shell), bvec_tmp(:, 1:multi(shell))) + do shell = 1, kmesh_input%search_shells + call kmesh_get_bvectors(kmesh_input, print_output, bvec_tmp(:, 1:multi(shell)), kpt_cart, & + recip_lattice, dnn(shell), lmn, 1, multi(shell), num_kpts, & + seedname, stdout) do loop = 1, multi(shell) counter = counter + 1 - if (on_root) write (stdout, '(a,I4,1x,a,2x,3f12.6,2x,a,2x,f12.6,a)') ' | b-vector ', counter, ': (', & - bvec_tmp(:, loop)/lenconfac, ')', dnn(shell)/lenconfac, ' |' + if (print_output%iprint > 0) write (stdout, '(a,I4,1x,a,2x,3f12.6,2x,a,2x,f12.6,a)') ' | b-vector ', counter, ': (', & + bvec_tmp(:, loop)/print_output%lenconfac, ')', dnn(shell)/print_output%lenconfac, ' |' end do end do - if (on_root) write (stdout, '(a)') ' ' + if (print_output%iprint > 0) write (stdout, '(a)') ' ' deallocate (bvec_tmp) - if (ierr /= 0) call io_error('Error deallocating bvec_tmp in kmesh_get') + if (ierr /= 0) call io_error('Error deallocating bvec_tmp in kmesh_get', stdout, seedname) - Call io_error('kmesh_get: something wrong, found too many nearest neighbours') + Call io_error('kmesh_get: something wrong, found too many nearest neighbours', stdout, seedname) end if - allocate (nnlist(num_kpts, nntot), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating nnlist in kmesh_get') - allocate (neigh(num_kpts, nntot/2), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating neigh in kmesh_get') - allocate (nncell(3, num_kpts, nntot), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating nncell in kmesh_get') + allocate (kmesh_info%nnlist(num_kpts, kmesh_info%nntot), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating nnlist in kmesh_get', stdout, seedname) + allocate (kmesh_info%neigh(num_kpts, kmesh_info%nntot/2), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating neigh in kmesh_get', stdout, seedname) + allocate (kmesh_info%nncell(3, num_kpts, kmesh_info%nntot), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating nncell in kmesh_get', stdout, seedname) - allocate (wb(nntot), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating wb in kmesh_get') - allocate (bka(3, nntot/2), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating bka in kmesh_get') - allocate (bk(3, nntot, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating bk in kmesh_get') + allocate (kmesh_info%wb(kmesh_info%nntot), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating wb in kmesh_get', stdout, seedname) + allocate (kmesh_info%bka(3, kmesh_info%nntot/2), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating bka in kmesh_get', stdout, seedname) + allocate (kmesh_info%bk(3, kmesh_info%nntot, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating bk in kmesh_get', stdout, seedname) nnx = 0 - do loop_s = 1, num_shells - do loop_b = 1, multi(shell_list(loop_s)) + do loop_s = 1, kmesh_input%num_shells + do loop_b = 1, multi(kmesh_input%shell_list(loop_s)) nnx = nnx + 1 wb_local(nnx) = bweight(loop_s) end do @@ -275,93 +304,93 @@ subroutine kmesh_get() ! go from k-point nkp to each neighbour bk(1:3,nkp,1...nnx). ! Comment: Now we have bk(3,nntot,num_kps) 09/04/2006 - if (on_root) then + if (print_output%iprint > 0) then write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' write (stdout, '(1x,a)') '| Shell # Nearest-Neighbours |' write (stdout, '(1x,a)') '| ----- -------------------- |' endif - if (index(devel_flag, 'kmesh_degen') == 0) then - ! - ! Standard routine - ! - nnshell = 0 - do nkp = 1, num_kpts - nnx = 0 - ok: do ndnnx = 1, num_shells - ndnn = shell_list(ndnnx) - do loop = 1, (2*nsupcell + 1)**3 - l = lmn(1, loop); m = lmn(2, loop); n = lmn(3, loop) - vkpp2 = matmul(lmn(:, loop), recip_lattice) - do nkp2 = 1, num_kpts - vkpp = vkpp2 + kpt_cart(:, nkp2) - dist = sqrt((kpt_cart(1, nkp) - vkpp(1))**2 & - + (kpt_cart(2, nkp) - vkpp(2))**2 + (kpt_cart(3, nkp) - vkpp(3))**2) - if ((dist .ge. dnn(ndnn)*(1 - kmesh_tol)) .and. (dist .le. dnn(ndnn)*(1 + kmesh_tol))) then - nnx = nnx + 1 - nnshell(nkp, ndnn) = nnshell(nkp, ndnn) + 1 - nnlist(nkp, nnx) = nkp2 - nncell(1, nkp, nnx) = l - nncell(2, nkp, nnx) = m - nncell(3, nkp, nnx) = n - bk_local(:, nnx, nkp) = vkpp(:) - kpt_cart(:, nkp) - endif - !if we have the right number of neighbours we can exit - if (nnshell(nkp, ndnn) == multi(ndnn)) cycle ok - enddo - enddo - ! check to see if too few neighbours here - end do ok - - end do - - else - ! - ! incase we set the bvectors explicitly - ! - nnshell = 0 - do nkp = 1, num_kpts - nnx = 0 - ok2: do loop = 1, (2*nsupcell + 1)**3 + !if (index(print_output%devel_flag, 'kmesh_degen') == 0) then + ! + ! Standard routine + ! + nnshell = 0 + do nkp = 1, num_kpts + nnx = 0 + ok: do ndnnx = 1, kmesh_input%num_shells + ndnn = kmesh_input%shell_list(ndnnx) + do loop = 1, (2*nsupcell + 1)**3 l = lmn(1, loop); m = lmn(2, loop); n = lmn(3, loop) vkpp2 = matmul(lmn(:, loop), recip_lattice) do nkp2 = 1, num_kpts vkpp = vkpp2 + kpt_cart(:, nkp2) - bnum = 0 - do ndnnx = 1, num_shells - do nbvec = 1, multi(ndnnx) - bnum = bnum + 1 - kpbvec = kpt_cart(:, nkp) + bvec_inp(:, nbvec, ndnnx) - dist = sqrt((kpbvec(1) - vkpp(1))**2 & - + (kpbvec(2) - vkpp(2))**2 + (kpbvec(3) - vkpp(3))**2) - if (abs(dist) < kmesh_tol) then - nnx = nnx + 1 - nnshell(nkp, ndnnx) = nnshell(nkp, ndnnx) + 1 - nnlist(nkp, bnum) = nkp2 - nncell(1, nkp, bnum) = l - nncell(2, nkp, bnum) = m - nncell(3, nkp, bnum) = n - bk_local(:, bnum, nkp) = bvec_inp(:, nbvec, ndnnx) - endif - enddo - end do - if (nnx == sum(multi)) exit ok2 - end do - enddo ok2 + dist = sqrt((kpt_cart(1, nkp) - vkpp(1))**2 & + + (kpt_cart(2, nkp) - vkpp(2))**2 + (kpt_cart(3, nkp) - vkpp(3))**2) + if ((dist .ge. dnn(ndnn)*(1 - kmesh_input%tol)) .and. (dist .le. dnn(ndnn)*(1 + kmesh_input%tol))) then + nnx = nnx + 1 + nnshell(nkp, ndnn) = nnshell(nkp, ndnn) + 1 + kmesh_info%nnlist(nkp, nnx) = nkp2 + kmesh_info%nncell(1, nkp, nnx) = l + kmesh_info%nncell(2, nkp, nnx) = m + kmesh_info%nncell(3, nkp, nnx) = n + bk_local(:, nnx, nkp) = vkpp(:) - kpt_cart(:, nkp) + endif + !if we have the right number of neighbours we can exit + if (nnshell(nkp, ndnn) == multi(ndnn)) cycle ok + enddo + enddo ! check to see if too few neighbours here - end do + end do ok - end if + end do - do ndnnx = 1, num_shells - ndnn = shell_list(ndnnx) - if (on_root) write (stdout, '(1x,a,24x,i3,13x,i3,33x,a)') '|', ndnn, nnshell(1, ndnn), '|' + !else + ! + ! incase we set the bvectors explicitly + ! + !nnshell = 0 + !do nkp = 1, num_kpts + ! nnx = 0 + ! ok2: do loop = 1, (2*nsupcell + 1)**3 + ! l = lmn(1, loop); m = lmn(2, loop); n = lmn(3, loop) + ! vkpp2 = matmul(lmn(:, loop), recip_lattice) + ! do nkp2 = 1, num_kpts + ! vkpp = vkpp2 + kpt_cart(:, nkp2) + ! bnum = 0 + ! do ndnnx = 1, kmesh_input%num_shells + ! do nbvec = 1, multi(ndnnx) + ! bnum = bnum + 1 + ! kpbvec = kpt_cart(:, nkp) + bvec_inp(:, nbvec, ndnnx) + ! dist = sqrt((kpbvec(1) - vkpp(1))**2 & + ! + (kpbvec(2) - vkpp(2))**2 + (kpbvec(3) - vkpp(3))**2) + ! if (abs(dist) < kmesh_input%tol) then + ! nnx = nnx + 1 + ! nnshell(nkp, ndnnx) = nnshell(nkp, ndnnx) + 1 + ! kmesh_info%nnlist(nkp, bnum) = nkp2 + ! kmesh_info%nncell(1, nkp, bnum) = l + ! kmesh_info%nncell(2, nkp, bnum) = m + ! kmesh_info%nncell(3, nkp, bnum) = n + ! bk_local(:, bnum, nkp) = bvec_inp(:, nbvec, ndnnx) + ! endif + ! enddo + ! end do + ! if (nnx == sum(multi)) exit ok2 + ! end do + ! enddo ok2 + ! check to see if too few neighbours here + !end do + + !end if + + do ndnnx = 1, kmesh_input%num_shells + ndnn = kmesh_input%shell_list(ndnnx) + if (print_output%iprint > 0) write (stdout, '(1x,a,24x,i3,13x,i3,33x,a)') '|', ndnn, nnshell(1, ndnn), '|' end do - if (on_root) write (stdout, '(1x,"+",76("-"),"+")') + if (print_output%iprint > 0) write (stdout, '(1x,"+",76("-"),"+")') do nkp = 1, num_kpts nnx = 0 - do ndnnx = 1, num_shells - ndnn = shell_list(ndnnx) + do ndnnx = 1, kmesh_input%num_shells + ndnn = kmesh_input%shell_list(ndnnx) do nnsh = 1, nnshell(nkp, ndnn) bb1 = 0.0_dp bbn = 0.0_dp @@ -370,9 +399,9 @@ subroutine kmesh_get() bb1 = bb1 + bk_local(i, nnx, 1)*bk_local(i, nnx, 1) bbn = bbn + bk_local(i, nnx, nkp)*bk_local(i, nnx, nkp) enddo - if (abs(sqrt(bb1) - sqrt(bbn)) .gt. kmesh_tol) then - if (on_root) write (stdout, '(1x,2f10.6)') bb1, bbn - call io_error('Non-symmetric k-point neighbours!') + if (abs(sqrt(bb1) - sqrt(bbn)) .gt. kmesh_input%tol) then + if (print_output%iprint > 0) write (stdout, '(1x,2f10.6)') bb1, bbn + call io_error('Non-symmetric k-point neighbours!', stdout, seedname) endif enddo enddo @@ -382,70 +411,72 @@ subroutine kmesh_get() ! We know it is true for kpt=1; but we check the rest to be safe. ! Eq. B1 in Appendix B PRB 56 12847 (1997) - if (.not. skip_B1_tests) then + if (.not. kmesh_input%skip_B1_tests) then do nkp = 1, num_kpts do i = 1, 3 do j = 1, 3 ddelta = 0.0_dp nnx = 0 - do ndnnx = 1, num_shells - ndnn = shell_list(ndnnx) + do ndnnx = 1, kmesh_input%num_shells + ndnn = kmesh_input%shell_list(ndnnx) do nnsh = 1, nnshell(1, ndnn) nnx = nnx + 1 ddelta = ddelta + wb_local(nnx)*bk_local(i, nnx, nkp)*bk_local(j, nnx, nkp) enddo enddo - if ((i .eq. j) .and. (abs(ddelta - 1.0_dp) .gt. kmesh_tol)) then - if (on_root) write (stdout, '(1x,2i3,f12.8)') i, j, ddelta - call io_error('Eq. (B1) not satisfied in kmesh_get (1)') + if ((i .eq. j) .and. (abs(ddelta - 1.0_dp) .gt. kmesh_input%tol)) then + if (print_output%iprint > 0) write (stdout, '(1x,2i3,f12.8)') i, j, ddelta + call io_error('Eq. (B1) not satisfied in kmesh_get (1)', stdout, seedname) endif - if ((i .ne. j) .and. (abs(ddelta) .gt. kmesh_tol)) then - if (on_root) write (stdout, '(1x,2i3,f12.8)') i, j, ddelta - call io_error('Eq. (B1) not satisfied in kmesh_get (2)') + if ((i .ne. j) .and. (abs(ddelta) .gt. kmesh_input%tol)) then + if (print_output%iprint > 0) write (stdout, '(1x,2i3,f12.8)') i, j, ddelta + call io_error('Eq. (B1) not satisfied in kmesh_get (2)', stdout, seedname) endif enddo enddo enddo end if - if (on_root) write (stdout, '(1x,a)') '| Completeness relation is fully satisfied [Eq. (B1), PRB 56, 12847 (1997)] |' - if (on_root) write (stdout, '(1x,"+",76("-"),"+")') + if (print_output%iprint > 0) then + write (stdout, '(1x,a)') '| Completeness relation is fully satisfied [Eq. (B1), PRB 56, 12847 (1997)] |' + write (stdout, '(1x,"+",76("-"),"+")') + endif ! - wbtot = 0.0_dp + kmesh_info%wbtot = 0.0_dp nnx = 0 - do ndnnx = 1, num_shells - ndnn = shell_list(ndnnx) + do ndnnx = 1, kmesh_input%num_shells + ndnn = kmesh_input%shell_list(ndnnx) do nnsh = 1, nnshell(1, ndnn) nnx = nnx + 1 - wbtot = wbtot + wb_local(nnx) + kmesh_info%wbtot = kmesh_info%wbtot + wb_local(nnx) enddo enddo - nnh = nntot/2 + kmesh_info%nnh = kmesh_info%nntot/2 ! make list of bka vectors from neighbours of first k-point ! delete any inverse vectors as you collect them na = 0 - do nn = 1, nntot + do nn = 1, kmesh_info%nntot ifound = 0 if (na .ne. 0) then do nap = 1, na - call utility_compar(bka(1, nap), bk_local(1, nn, 1), ifpos, ifneg) + call utility_compar(kmesh_info%bka(1, nap), bk_local(1, nn, 1), ifpos, ifneg) if (ifneg .eq. 1) ifound = 1 enddo endif if (ifound .eq. 0) then ! found new vector to add to set na = na + 1 - bka(1, na) = bk_local(1, nn, 1) - bka(2, na) = bk_local(2, nn, 1) - bka(3, na) = bk_local(3, nn, 1) + kmesh_info%bka(1, na) = bk_local(1, nn, 1) + kmesh_info%bka(2, na) = bk_local(2, nn, 1) + kmesh_info%bka(3, na) = bk_local(3, nn, 1) endif enddo - if (na .ne. nnh) call io_error('Did not find right number of bk directions') + if (na .ne. kmesh_info%nnh) call io_error('Did not find right number of bk directions', stdout, seedname) - if (on_root) then - if (lenconfac .eq. 1.0_dp) then + if (print_output%iprint > 0) then + if (print_output%lenconfac .eq. 1.0_dp) then write (stdout, '(1x,a)') '| b_k Vectors (Ang^-1) and Weights (Ang^2) |' write (stdout, '(1x,a)') '| ---------------------------------------- |' else @@ -454,12 +485,12 @@ subroutine kmesh_get() endif write (stdout, '(1x,a)') '| No. b_k(x) b_k(y) b_k(z) w_b |' write (stdout, '(1x,a)') '| --- -------------------------------- -------- |' - do i = 1, nntot + do i = 1, kmesh_info%nntot write (stdout, '(1x,"|",11x,i3,5x,3f12.6,3x,f10.6,8x,"|")') & - i, (bk_local(j, i, 1)/lenconfac, j=1, 3), wb_local(i)*lenconfac**2 + i, (bk_local(j, i, 1)/print_output%lenconfac, j=1, 3), wb_local(i)*print_output%lenconfac**2 enddo write (stdout, '(1x,"+",76("-"),"+")') - if (lenconfac .eq. 1.0_dp) then + if (print_output%lenconfac .eq. 1.0_dp) then write (stdout, '(1x,a)') '| b_k Directions (Ang^-1) |' write (stdout, '(1x,a)') '| ----------------------- |' else @@ -468,8 +499,8 @@ subroutine kmesh_get() endif write (stdout, '(1x,a)') '| No. x y z |' write (stdout, '(1x,a)') '| --- -------------------------------- |' - do i = 1, nnh - write (stdout, '(1x,"|",11x,i3,5x,3f12.6,21x,"|")') i, (bka(j, i)/lenconfac, j=1, 3) + do i = 1, kmesh_info%nnh + write (stdout, '(1x,"|",11x,i3,5x,3f12.6,21x,"|")') i, (kmesh_info%bka(j, i)/print_output%lenconfac, j=1, 3) enddo write (stdout, '(1x,"+",76("-"),"+")') write (stdout, *) ' ' @@ -477,31 +508,31 @@ subroutine kmesh_get() ! find index array do nkp = 1, num_kpts - do na = 1, nnh + do na = 1, kmesh_info%nnh ! first, zero the index array so we can check it gets filled - neigh(nkp, na) = 0 + kmesh_info%neigh(nkp, na) = 0 ! now search through list of neighbours of this k-point - do nn = 1, nntot - call utility_compar(bka(1, na), bk_local(1, nn, nkp), ifpos, ifneg) - if (ifpos .eq. 1) neigh(nkp, na) = nn + do nn = 1, kmesh_info%nntot + call utility_compar(kmesh_info%bka(1, na), bk_local(1, nn, nkp), ifpos, ifneg) + if (ifpos .eq. 1) kmesh_info%neigh(nkp, na) = nn enddo ! check found - if (neigh(nkp, na) .eq. 0) then - if (on_root) write (stdout, *) ' nkp,na=', nkp, na - call io_error('kmesh_get: failed to find neighbours for this kpoint') + if (kmesh_info%neigh(nkp, na) .eq. 0) then + if (print_output%iprint > 0) write (stdout, *) ' nkp,na=', nkp, na + call io_error('kmesh_get: failed to find neighbours for this kpoint', stdout, seedname) endif enddo enddo !fill in the global arrays from the local ones - do loop = 1, nntot - wb(loop) = wb_local(loop) + do loop = 1, kmesh_info%nntot + kmesh_info%wb(loop) = wb_local(loop) end do do loop_s = 1, num_kpts - do loop = 1, nntot - bk(:, loop, loop_s) = bk_local(:, loop, loop_s) + do loop = 1, kmesh_info%nntot + kmesh_info%bk(:, loop, loop_s) = bk_local(:, loop, loop_s) end do end do @@ -509,71 +540,71 @@ subroutine kmesh_get() if (gamma_only) then ! use half of the b-vectors - if (num_kpts .ne. 1) call io_error('Error in kmesh_get: wrong choice of gamma_only option') + if (num_kpts .ne. 1) call io_error('Error in kmesh_get: wrong choice of gamma_only option', stdout, seedname) ! reassign nnlist, nncell, wb, bk - allocate (nnlist_tmp(num_kpts, nntot), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating nnlist_tmp in kmesh_get') - allocate (nncell_tmp(3, num_kpts, nntot), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating nncell_tmp in kmesh_get') - - nnlist_tmp(:, :) = nnlist(:, :) - nncell_tmp(:, :, :) = nncell(:, :, :) - - deallocate (nnlist, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating nnlist in kmesh_get') - deallocate (nncell, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating nncell in kmesh_get') - deallocate (wb, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating wb in kmesh_get') - deallocate (bk, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating bk in kmesh_get') - - nntot = nntot/2 - - allocate (nnlist(num_kpts, nntot), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating nnlist in kmesh_get') - allocate (nncell(3, num_kpts, nntot), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating nncell in kmesh_get') - allocate (wb(nntot), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating wb in kmesh_get') - allocate (bk(3, nntot, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating bk in kmesh_get') + allocate (nnlist_tmp(num_kpts, kmesh_info%nntot), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating nnlist_tmp in kmesh_get', stdout, seedname) + allocate (nncell_tmp(3, num_kpts, kmesh_info%nntot), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating nncell_tmp in kmesh_get', stdout, seedname) + + nnlist_tmp(:, :) = kmesh_info%nnlist(:, :) + nncell_tmp(:, :, :) = kmesh_info%nncell(:, :, :) + + deallocate (kmesh_info%nnlist, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating nnlist in kmesh_get', stdout, seedname) + deallocate (kmesh_info%nncell, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating nncell in kmesh_get', stdout, seedname) + deallocate (kmesh_info%wb, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating wb in kmesh_get', stdout, seedname) + deallocate (kmesh_info%bk, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating bk in kmesh_get', stdout, seedname) + + kmesh_info%nntot = kmesh_info%nntot/2 + + allocate (kmesh_info%nnlist(num_kpts, kmesh_info%nntot), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating nnlist in kmesh_get', stdout, seedname) + allocate (kmesh_info%nncell(3, num_kpts, kmesh_info%nntot), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating nncell in kmesh_get', stdout, seedname) + allocate (kmesh_info%wb(kmesh_info%nntot), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating wb in kmesh_get', stdout, seedname) + allocate (kmesh_info%bk(3, kmesh_info%nntot, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating bk in kmesh_get', stdout, seedname) na = 0 - do nn = 1, 2*nntot + do nn = 1, 2*kmesh_info%nntot ifound = 0 if (na .ne. 0) then do nap = 1, na - call utility_compar(bk(1, nap, 1), bk_local(1, nn, 1), ifpos, ifneg) + call utility_compar(kmesh_info%bk(1, nap, 1), bk_local(1, nn, 1), ifpos, ifneg) if (ifneg .eq. 1) ifound = 1 enddo endif if (ifound .eq. 0) then ! found new vector to add to set na = na + 1 - bk(1, na, 1) = bk_local(1, nn, 1) - bk(2, na, 1) = bk_local(2, nn, 1) - bk(3, na, 1) = bk_local(3, nn, 1) - wb(na) = 2.0_dp*wb_local(nn) - nnlist(1, na) = nnlist_tmp(1, nn) - nncell(1, 1, na) = nncell_tmp(1, 1, nn) - nncell(2, 1, na) = nncell_tmp(2, 1, nn) - nncell(3, 1, na) = nncell_tmp(3, 1, nn) - neigh(1, na) = na + kmesh_info%bk(1, na, 1) = bk_local(1, nn, 1) + kmesh_info%bk(2, na, 1) = bk_local(2, nn, 1) + kmesh_info%bk(3, na, 1) = bk_local(3, nn, 1) + kmesh_info%wb(na) = 2.0_dp*wb_local(nn) + kmesh_info%nnlist(1, na) = nnlist_tmp(1, nn) + kmesh_info%nncell(1, 1, na) = nncell_tmp(1, 1, nn) + kmesh_info%nncell(2, 1, na) = nncell_tmp(2, 1, nn) + kmesh_info%nncell(3, 1, na) = nncell_tmp(3, 1, nn) + kmesh_info%neigh(1, na) = na ! check bk.eq.bka - call utility_compar(bk(1, na, 1), bka(1, na), ifpos, ifneg) - if (ifpos .ne. 1) call io_error('Error in kmesh_get: bk is not identical to bka in gamma_only option') + call utility_compar(kmesh_info%bk(1, na, 1), kmesh_info%bka(1, na), ifpos, ifneg) + if (ifpos .ne. 1) call io_error('Error in kmesh_get: bk is not identical to bka in gamma_only option', stdout, seedname) endif enddo - if (na .ne. nnh) call io_error('Did not find right number of b-vectors in gamma_only option') + if (na .ne. kmesh_info%nnh) call io_error('Did not find right number of b-vectors in gamma_only option', stdout, seedname) - if (on_root) then + if (print_output%iprint > 0) then write (stdout, '(1x,"+",76("-"),"+")') write (stdout, '(1x,a)') '| Gamma-point: number of the b-vectors is reduced by half |' write (stdout, '(1x,"+",76("-"),"+")') - if (lenconfac .eq. 1.0_dp) then + if (print_output%lenconfac .eq. 1.0_dp) then write (stdout, '(1x,a)') '| b_k Vectors (Ang^-1) and Weights (Ang^2) |' write (stdout, '(1x,a)') '| ---------------------------------------- |' else @@ -582,30 +613,34 @@ subroutine kmesh_get() endif write (stdout, '(1x,a)') '| No. b_k(x) b_k(y) b_k(z) w_b |' write (stdout, '(1x,a)') '| --- -------------------------------- -------- |' - do i = 1, nntot + do i = 1, kmesh_info%nntot write (stdout, '(1x,"|",11x,i3,5x,3f12.6,3x,f10.6,8x,"|")') & - i, (bk(j, i, 1)/lenconfac, j=1, 3), wb(i)*lenconfac**2 + i, (kmesh_info%bk(j, i, 1)/print_output%lenconfac, j=1, 3), kmesh_info%wb(i)*print_output%lenconfac**2 enddo write (stdout, '(1x,"+",76("-"),"+")') write (stdout, *) ' ' endif deallocate (nnlist_tmp, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating nnlist_tmp in kmesh_get') + if (ierr /= 0) call io_error('Error in deallocating nnlist_tmp in kmesh_get', stdout, seedname) deallocate (nncell_tmp, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating nncell_tmp in kmesh_get') + if (ierr /= 0) call io_error('Error in deallocating nncell_tmp in kmesh_get', stdout, seedname) endif ![ysl-e] - if (timing_level > 0) call io_stopwatch('kmesh: get', 2) + deallocate (kpt_cart, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating kpt_cart in kmesh_get', stdout, seedname) + + if (print_output%timing_level > 0) call io_stopwatch('kmesh: get', 2, stdout, seedname) return end subroutine kmesh_get - !==================================================================! - subroutine kmesh_write() + !================================================! + subroutine kmesh_write(exclude_bands, kmesh_info, proj_input, print_output, kpt_latt, & + real_lattice, num_kpts, num_proj, calc_only_A, spinors, seedname, stdout) !==================================================================! ! ! !! Writes nnkp file (list of overlaps needed) @@ -633,15 +668,34 @@ subroutine kmesh_write() ! calculate the M_mn(k,b) matrix elements -- Marzari & Vanderbilt ! ! PRB 56, 12847 (1997) Eq. (25) -- for each pair of band indices ! ! m and n. ! - !=================================================================== - use w90_io, only: io_file_unit, seedname, io_date, io_stopwatch + !==================================================================! + + use w90_io, only: io_file_unit, io_date, io_stopwatch + use w90_utility, only: utility_recip_lattice_base + use w90_types, only: kmesh_info_type, kmesh_input_type, & + proj_input_type, print_output_type implicit none - integer :: i, nkp, nn, nnkpout + integer, allocatable, intent(in) :: exclude_bands(:) + type(print_output_type), intent(in) :: print_output + type(kmesh_info_type), intent(in) :: kmesh_info + type(proj_input_type), intent(in) :: proj_input + + integer, intent(in) :: num_kpts + integer, intent(in) :: stdout + integer, intent(inout) :: num_proj + real(kind=dp), intent(in) :: kpt_latt(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + logical, intent(in) :: calc_only_A + logical, intent(in) :: spinors + character(len=50), intent(in) :: seedname + + real(kind=dp) :: recip_lattice(3, 3), volume + integer :: i, nkp, nn, nnkpout, num_exclude_bands character(len=9) :: cdate, ctime - if (timing_level > 0) call io_stopwatch('kmesh: write', 1) + if (print_output%timing_level > 0) call io_stopwatch('kmesh: write', 1, stdout, seedname) nnkpout = io_file_unit() open (unit=nnkpout, file=trim(seedname)//'.nnkp', form='formatted') @@ -661,6 +715,7 @@ subroutine kmesh_write() write (nnkpout, '(a/)') 'end real_lattice' ! Reciprocal lattice + call utility_recip_lattice_base(real_lattice, recip_lattice, volume) write (nnkpout, '(a)') 'begin recip_lattice' write (nnkpout, '(3f12.7)') (recip_lattice(1, i), i=1, 3) write (nnkpout, '(3f12.7)') (recip_lattice(2, i), i=1, 3) @@ -678,20 +733,20 @@ subroutine kmesh_write() if (spinors) then ! Projections write (nnkpout, '(a)') 'begin spinor_projections' - if (allocated(input_proj_site)) then + if (allocated(proj_input%site)) then write (nnkpout, '(i6)') num_proj do i = 1, num_proj write (nnkpout, '(3(f10.5,1x),2x,3i3)') & - input_proj_site(1, i), input_proj_site(2, i), input_proj_site(3, i), & - input_proj_l(i), input_proj_m(i), input_proj_radial(i) + proj_input%site(1, i), proj_input%site(2, i), proj_input%site(3, i), & + proj_input%l(i), proj_input%m(i), proj_input%radial(i) !~ write(nnkpout,'(3x,3f7.3,1x,3f7.3,1x,f7.2)') & write (nnkpout, '(2x,3f11.7,1x,3f11.7,1x,f7.2)') & - input_proj_z(1, i), input_proj_z(2, i), input_proj_z(3, i), & - input_proj_x(1, i), input_proj_x(2, i), input_proj_x(3, i), & - input_proj_zona(i) + proj_input%z(1, i), proj_input%z(2, i), proj_input%z(3, i), & + proj_input%x(1, i), proj_input%x(2, i), proj_input%x(3, i), & + proj_input%zona(i) write (nnkpout, '(2x,1i3,1x,3f11.7)') & - input_proj_s(i), & - input_proj_s_qaxis(1, i), input_proj_s_qaxis(2, i), input_proj_s_qaxis(3, i) + proj_input%s(i), & + proj_input%s_qaxis(1, i), proj_input%s_qaxis(2, i), proj_input%s_qaxis(3, i) enddo else ! No projections @@ -701,17 +756,17 @@ subroutine kmesh_write() else ! Projections write (nnkpout, '(a)') 'begin projections' - if (allocated(input_proj_site)) then + if (allocated(proj_input%site)) then write (nnkpout, '(i6)') num_proj do i = 1, num_proj write (nnkpout, '(3(f10.5,1x),2x,3i3)') & - input_proj_site(1, i), input_proj_site(2, i), input_proj_site(3, i), & - input_proj_l(i), input_proj_m(i), input_proj_radial(i) + proj_input%site(1, i), proj_input%site(2, i), proj_input%site(3, i), & + proj_input%l(i), proj_input%m(i), proj_input%radial(i) !~ write(nnkpout,'(3x,3f7.3,1x,3f7.3,1x,f7.2)') & write (nnkpout, '(2x,3f11.7,1x,3f11.7,1x,f7.2)') & - input_proj_z(1, i), input_proj_z(2, i), input_proj_z(3, i), & - input_proj_x(1, i), input_proj_x(2, i), input_proj_x(3, i), & - input_proj_zona(i) + proj_input%z(1, i), proj_input%z(2, i), proj_input%z(3, i), & + proj_input%x(1, i), proj_input%x(2, i), proj_input%x(3, i), & + proj_input%zona(i) enddo else ! No projections @@ -721,7 +776,7 @@ subroutine kmesh_write() endif ! Info for automatic generation of projections - if (auto_projections) then + if (proj_input%auto_projections) then write (nnkpout, '(a)') 'begin auto_projections' write (nnkpout, '(i6)') num_proj write (nnkpout, '(i6)') 0 @@ -730,16 +785,18 @@ subroutine kmesh_write() ! Nearest neighbour k-points write (nnkpout, '(a)') 'begin nnkpts' - write (nnkpout, '(i4)') nntot + write (nnkpout, '(i4)') kmesh_info%nntot do nkp = 1, num_kpts - do nn = 1, nntot + do nn = 1, kmesh_info%nntot write (nnkpout, '(2i6,3x,3i4)') & - nkp, nnlist(nkp, nn), (nncell(i, nkp, nn), i=1, 3) + nkp, kmesh_info%nnlist(nkp, nn), (kmesh_info%nncell(i, nkp, nn), i=1, 3) end do end do write (nnkpout, '(a/)') 'end nnkpts' !states to exclude + num_exclude_bands = 0 + if (allocated(exclude_bands)) num_exclude_bands = size(exclude_bands) write (nnkpout, '(a)') 'begin exclude_bands' write (nnkpout, '(i4)') num_exclude_bands if (num_exclude_bands > 0) then @@ -751,77 +808,94 @@ subroutine kmesh_write() close (nnkpout) - if (timing_level > 0) call io_stopwatch('kmesh: write', 2) + if (print_output%timing_level > 0) call io_stopwatch('kmesh: write', 2, stdout, seedname) return end subroutine kmesh_write - !======================================== - subroutine kmesh_dealloc() - !======================================== - ! + !================================================ + subroutine kmesh_dealloc(kmesh_info, stdout, seedname) + !================================================ !! Release memory from the kmesh module ! This routine now check to see if arrays ! are allocated, as there are some code ! paths that will not allocate on all nodes - !======================================== + !================================================ + use w90_io, only: io_error + use w90_types, only: kmesh_info_type + implicit none + + type(kmesh_info_type), intent(inout) :: kmesh_info + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + integer :: ierr ! Deallocate real arrays that are public - if (allocated(bk)) then - deallocate (bk, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating bk in kmesh_dealloc') + if (allocated(kmesh_info%bk)) then + deallocate (kmesh_info%bk, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating bk in kmesh_dealloc', stdout, seedname) endif - if (allocated(bka)) then - deallocate (bka, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating bka in kmesh_dealloc') + if (allocated(kmesh_info%bka)) then + deallocate (kmesh_info%bka, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating bka in kmesh_dealloc', stdout, seedname) endif - if (allocated(wb)) then - deallocate (wb, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating wb in kmesh_dealloc') + if (allocated(kmesh_info%wb)) then + deallocate (kmesh_info%wb, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating wb in kmesh_dealloc', stdout, seedname) end if ! Deallocate integer arrays that are public - if (allocated(neigh)) then - deallocate (neigh, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating neigh in kmesh_dealloc') + if (allocated(kmesh_info%neigh)) then + deallocate (kmesh_info%neigh, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating neigh in kmesh_dealloc', stdout, seedname) end if - if (allocated(nncell)) then - deallocate (nncell, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating nncell in kmesh_dealloc') + if (allocated(kmesh_info%nncell)) then + deallocate (kmesh_info%nncell, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating nncell in kmesh_dealloc', stdout, seedname) endif - if (allocated(nnlist)) then - deallocate (nnlist, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating nnlist in kmesh_dealloc') + if (allocated(kmesh_info%nnlist)) then + deallocate (kmesh_info%nnlist, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating nnlist in kmesh_dealloc', stdout, seedname) endif return end subroutine kmesh_dealloc - !================================================================== - subroutine kmesh_supercell_sort - !================================================================== - ! + !================================================ + subroutine kmesh_supercell_sort(print_output, recip_lattice, lmn, seedname, stdout) + !================================================ !! We look for kpoint neighbours in a large supercell of reciprocal !! unit cells. Done sequentially this is very slow. !! Here we order the cells by the distance from the origin. !! Doing the search in this order gives a dramatic speed up - ! - !================================================================== + !================================================ + use w90_io, only: io_stopwatch + use w90_types, only: print_output_type + implicit none + + type(print_output_type), intent(in) :: print_output + + integer, intent(in) :: stdout + integer, intent(inout) :: lmn(:, :) + real(kind=dp), intent(in) :: recip_lattice(3, 3) + character(len=50), intent(in) :: seedname + integer :: counter, l, m, n, loop + !! Order in which to search the cells (ordered in dist from origin) integer :: lmn_cp(3, (2*nsupcell + 1)**3), indx(1) real(kind=dp) :: pos(3) real(kind=dp) :: dist((2*nsupcell + 1)**3) real(kind=dp) :: dist_cp((2*nsupcell + 1)**3) - if (timing_level > 1) call io_stopwatch('kmesh: supercell_sort', 1) + if (print_output%timing_level > 1) call io_stopwatch('kmesh: supercell_sort', 1, stdout, seedname) counter = 1 lmn(:, counter) = 0 @@ -848,30 +922,46 @@ subroutine kmesh_supercell_sort lmn = lmn_cp dist = dist_cp - if (timing_level > 1) call io_stopwatch('kmesh: supercell_sort', 2) + if (print_output%timing_level > 1) call io_stopwatch('kmesh: supercell_sort', 2, stdout, seedname) end subroutine kmesh_supercell_sort - !============================================================= - subroutine kmesh_get_bvectors(multi, kpt, shell_dist, bvector) - !============================================================= + !================================================ + subroutine kmesh_get_bvectors(kmesh_input, print_output, bvector, kpt_cart, recip_lattice, shell_dist, & + lmn, kpt, multi, num_kpts, seedname, stdout) + !================================================ ! !! Returns the b-vectors for a given shell and kpoint. ! - !============================================================= + !================================================ + use w90_io, only: io_error, io_stopwatch + use w90_types, only: kmesh_input_type, print_output_type + implicit none + ! arguments + type(print_output_type), intent(in) :: print_output + type(kmesh_input_type), intent(in) :: kmesh_input + + integer, intent(in) :: num_kpts + integer, intent(in) :: stdout + integer, intent(in) :: lmn(:, :) integer, intent(in) :: multi ! the number of kpoints in the shell integer, intent(in) :: kpt ! which kpt is our 'origin' + + real(kind=dp), intent(in) :: recip_lattice(3, 3) + real(kind=dp), intent(in) ::kpt_cart(:, :) real(kind=dp), intent(in) :: shell_dist ! the bvectors real(kind=dp), intent(out) :: bvector(3, multi) ! the bvectors - integer :: loop, nkp2, num_bvec + character(len=50), intent(in) :: seedname + ! local variables + integer :: loop, nkp2, num_bvec real(kind=dp) :: dist, vkpp2(3), vkpp(3) - if (timing_level > 1) call io_stopwatch('kmesh: get_bvectors', 1) + if (print_output%timing_level > 1) call io_stopwatch('kmesh: get_bvectors', 1, stdout, seedname) bvector = 0.0_dp @@ -882,7 +972,7 @@ subroutine kmesh_get_bvectors(multi, kpt, shell_dist, bvector) vkpp = vkpp2 + kpt_cart(:, nkp2) dist = sqrt((kpt_cart(1, kpt) - vkpp(1))**2 & + (kpt_cart(2, kpt) - vkpp(2))**2 + (kpt_cart(3, kpt) - vkpp(3))**2) - if ((dist .ge. shell_dist*(1.0_dp - kmesh_tol)) .and. dist .le. shell_dist*(1.0_dp + kmesh_tol)) then + if ((dist .ge. shell_dist*(1.0_dp - kmesh_input%tol)) .and. dist .le. shell_dist*(1.0_dp + kmesh_input%tol)) then num_bvec = num_bvec + 1 bvector(:, num_bvec) = vkpp(:) - kpt_cart(:, kpt) endif @@ -891,33 +981,49 @@ subroutine kmesh_get_bvectors(multi, kpt, shell_dist, bvector) enddo enddo ok - if (num_bvec < multi) call io_error('kmesh_get_bvector: Not enough bvectors found') + if (num_bvec < multi) call io_error('kmesh_get_bvector: Not enough bvectors found', stdout, seedname) - if (timing_level > 1) call io_stopwatch('kmesh: get_bvectors', 2) + if (print_output%timing_level > 1) call io_stopwatch('kmesh: get_bvectors', 2, stdout, seedname) return end subroutine kmesh_get_bvectors - !========================================================================== - subroutine kmesh_shell_automatic(multi, dnn, bweight) - !========================================================================== - ! + !================================================ + subroutine kmesh_shell_automatic(kmesh_input, print_output, bweight, dnn, kpt_cart, recip_lattice, & + lmn, multi, num_kpts, seedname, stdout) + !================================================ !! Find the correct set of shells to satisfy B1 !! The stratagy is: !! 1) Take the bvectors from the next shell !! 2) Reject them if they are parallel to exisiting b vectors !! 3) Test to see if we satisfy B1, if not add another shell and repeat ! - !========================================================================== + !================================================ use w90_constants, only: eps5, eps6 - use w90_io, only: io_error, stdout, io_stopwatch + use w90_io, only: io_error, io_stopwatch + use w90_types, only: kmesh_input_type, print_output_type + implicit none - integer, intent(in) :: multi(search_shells) ! the number of kpoints in the shell - real(kind=dp), intent(in) :: dnn(search_shells) ! the bvectors + ! arguments + type(print_output_type), intent(in) :: print_output + type(kmesh_input_type), intent(inout) :: kmesh_input + + integer, intent(in) :: num_kpts + integer, intent(in) :: stdout + integer, intent(in) :: lmn(:, :) + integer, intent(in) :: multi(kmesh_input%search_shells) ! the number of kpoints in the shell + + real(kind=dp), intent(in) :: recip_lattice(3, 3) + real(kind=dp), intent(in) ::kpt_cart(:, :) + real(kind=dp), intent(in) :: dnn(kmesh_input%search_shells) ! the bvectors real(kind=dp), intent(out) :: bweight(max_shells) + + character(len=50), intent(in) :: seedname + + ! local variables real(kind=dp), allocatable :: bvector(:, :, :) ! the bvectors real(kind=dp), dimension(:), allocatable :: singv, tmp1, tmp2, tmp3 @@ -931,35 +1037,39 @@ subroutine kmesh_shell_automatic(multi, dnn, bweight) integer :: loop, shell - if (timing_level > 1) call io_stopwatch('kmesh: shell_automatic', 1) + if (print_output%timing_level > 1) call io_stopwatch('kmesh: shell_automatic', 1, stdout, seedname) allocate (bvector(3, maxval(multi), max_shells), stat=ierr) - if (ierr /= 0) call io_error('Error allocating bvector in kmesh_shell_automatic') + if (ierr /= 0) call io_error('Error allocating bvector in kmesh_shell_automatic', stdout, seedname) bvector = 0.0_dp; bweight = 0.0_dp - if (on_root) write (stdout, '(1x,a)') '| The b-vectors are chosen automatically |' + if (print_output%iprint > 0) then + write (stdout, '(1x,a)') '| The b-vectors are chosen automatically |' + endif b1sat = .false. - do shell = 1, search_shells - cur_shell = num_shells + 1 + do shell = 1, kmesh_input%search_shells + cur_shell = kmesh_input%num_shells + 1 ! get the b vectors for the new shell - call kmesh_get_bvectors(multi(shell), 1, dnn(shell), bvector(:, 1:multi(shell), cur_shell)) + call kmesh_get_bvectors(kmesh_input, print_output, bvector(:, 1:multi(shell), cur_shell), & + kpt_cart, recip_lattice, dnn(shell), lmn, 1, multi(shell), num_kpts, & + seedname, stdout) - if (iprint >= 3 .and. on_root) then + if (print_output%iprint >= 3) then write (stdout, '(1x,a8,1x,I2,a14,1x,I2,49x,a)') '| Shell:', shell, ' Multiplicity:', multi(shell), '|' do loop = 1, multi(shell) write (stdout, '(1x,a10,I2,1x,a1,4x,3f12.6,5x,a9,9x,a)') '| b-vector ', loop, ':', & - bvector(:, loop, cur_shell)/lenconfac, '('//trim(length_unit)//'^-1)', '|' + bvector(:, loop, cur_shell)/print_output%lenconfac, '('//trim(print_output%length_unit)//'^-1)', '|' end do end if ! We check that the new shell is not parrallel to an existing shell (cosine=1) lpar = .false. - if (num_shells > 0) then + if (kmesh_input%num_shells > 0) then do loop_bn = 1, multi(shell) - do loop_s = 1, num_shells - do loop_b = 1, multi(shell_list(loop_s)) + do loop_s = 1, kmesh_input%num_shells + do loop_b = 1, multi(kmesh_input%shell_list(loop_s)) delta = dot_product(bvector(:, loop_bn, cur_shell), bvector(:, loop_b, loop_s))/ & sqrt(dot_product(bvector(:, loop_bn, cur_shell), bvector(:, loop_bn, cur_shell))* & dot_product(bvector(:, loop_b, loop_s), bvector(:, loop_b, loop_s))) @@ -970,38 +1080,38 @@ subroutine kmesh_shell_automatic(multi, dnn, bweight) end if if (lpar) then - if (iprint >= 3 .and. on_root) then + if (print_output%iprint >= 3) then write (stdout, '(1x,a)') '| This shell is linearly dependent on existing shells: Trying next shell |' end if cycle end if - num_shells = num_shells + 1 - shell_list(num_shells) = shell + kmesh_input%num_shells = kmesh_input%num_shells + 1 + kmesh_input%shell_list(kmesh_input%num_shells) = shell allocate (tmp0(max_shells, max_shells), stat=ierr) - if (ierr /= 0) call io_error('Error allocating amat in kmesh_shell_automatic') + if (ierr /= 0) call io_error('Error allocating amat in kmesh_shell_automatic', stdout, seedname) allocate (tmp1(max_shells), stat=ierr) - if (ierr /= 0) call io_error('Error allocating amat in kmesh_shell_automatic') - allocate (tmp2(num_shells), stat=ierr) - if (ierr /= 0) call io_error('Error allocating amat in kmesh_shell_automatic') - allocate (tmp3(num_shells), stat=ierr) - if (ierr /= 0) call io_error('Error allocating amat in kmesh_shell_automatic') - allocate (amat(max_shells, num_shells), stat=ierr) - if (ierr /= 0) call io_error('Error allocating amat in kmesh_shell_automatic') + if (ierr /= 0) call io_error('Error allocating amat in kmesh_shell_automatic', stdout, seedname) + allocate (tmp2(kmesh_input%num_shells), stat=ierr) + if (ierr /= 0) call io_error('Error allocating amat in kmesh_shell_automatic', stdout, seedname) + allocate (tmp3(kmesh_input%num_shells), stat=ierr) + if (ierr /= 0) call io_error('Error allocating amat in kmesh_shell_automatic', stdout, seedname) + allocate (amat(max_shells, kmesh_input%num_shells), stat=ierr) + if (ierr /= 0) call io_error('Error allocating amat in kmesh_shell_automatic', stdout, seedname) allocate (umat(max_shells, max_shells), stat=ierr) - if (ierr /= 0) call io_error('Error allocating umat in kmesh_shell_automatic') - allocate (vmat(num_shells, num_shells), stat=ierr) - if (ierr /= 0) call io_error('Error allocating vmat in kmesh_shell_automatic') - allocate (smat(num_shells, max_shells), stat=ierr) - if (ierr /= 0) call io_error('Error allocating smat in kmesh_shell_automatic') - allocate (singv(num_shells), stat=ierr) - if (ierr /= 0) call io_error('Error allocating singv in kmesh_shell_automatic') + if (ierr /= 0) call io_error('Error allocating umat in kmesh_shell_automatic', stdout, seedname) + allocate (vmat(kmesh_input%num_shells, kmesh_input%num_shells), stat=ierr) + if (ierr /= 0) call io_error('Error allocating vmat in kmesh_shell_automatic', stdout, seedname) + allocate (smat(kmesh_input%num_shells, max_shells), stat=ierr) + if (ierr /= 0) call io_error('Error allocating smat in kmesh_shell_automatic', stdout, seedname) + allocate (singv(kmesh_input%num_shells), stat=ierr) + if (ierr /= 0) call io_error('Error allocating singv in kmesh_shell_automatic', stdout, seedname) amat(:, :) = 0.0_dp; umat(:, :) = 0.0_dp; vmat(:, :) = 0.0_dp; smat(:, :) = 0.0_dp; singv(:) = 0.0_dp amat = 0.0_dp - do loop_s = 1, num_shells - do loop_b = 1, multi(shell_list(loop_s)) + do loop_s = 1, kmesh_input%num_shells + do loop_b = 1, multi(kmesh_input%shell_list(loop_s)) amat(1, loop_s) = amat(1, loop_s) + bvector(1, loop_b, loop_s)*bvector(1, loop_b, loop_s) amat(2, loop_s) = amat(2, loop_s) + bvector(2, loop_b, loop_s)*bvector(2, loop_b, loop_s) amat(3, loop_s) = amat(3, loop_s) + bvector(3, loop_b, loop_s)*bvector(3, loop_b, loop_s) @@ -1012,27 +1122,34 @@ subroutine kmesh_shell_automatic(multi, dnn, bweight) end do info = 0 - call dgesvd('A', 'A', max_shells, num_shells, amat, max_shells, singv, umat, max_shells, vmat, num_shells, work, lwork, info) + call dgesvd('A', 'A', max_shells, kmesh_input%num_shells, amat, max_shells, singv, umat, & + max_shells, vmat, kmesh_input%num_shells, work, lwork, info) if (info < 0) then - if (on_root) write (stdout, '(1x,a,1x,I1,1x,a)') 'kmesh_shell_automatic: Argument', abs(info), 'of dgesvd is incorrect' - call io_error('kmesh_shell_automatic: Problem with Singular Value Decomposition') + if (print_output%iprint > 0) then + write (stdout, '(1x,a,1x,I1,1x,a)') 'kmesh_shell_automatic: Argument', abs(info), & + 'of dgesvd is incorrect' + endif + call io_error('kmesh_shell_automatic: Problem with Singular Value Decomposition', stdout, seedname) else if (info > 0) then - call io_error('kmesh_shell_automatic: Singular Value Decomposition did not converge') + call io_error('kmesh_shell_automatic: Singular Value Decomposition did not converge', stdout, seedname) end if if (any(abs(singv) < eps5)) then - if (num_shells == 1) then - call io_error('kmesh_shell_automatic: Singular Value Decomposition has found a very small singular value') + if (kmesh_input%num_shells == 1) then + call io_error('kmesh_shell_automatic: Singular Value Decomposition has found a very small singular value', & + stdout, seedname) else - if (on_root) write (stdout, '(1x,a)') '| SVD found small singular value, Rejecting this shell and trying the next |' + if (print_output%iprint > 0) then + write (stdout, '(1x,a)') '| SVD found small singular value, Rejecting this shell and trying the next |' + endif b1sat = .false. - num_shells = num_shells - 1 + kmesh_input%num_shells = kmesh_input%num_shells - 1 goto 200 end if end if smat = 0.0_dp - do loop_s = 1, num_shells + do loop_s = 1, kmesh_input%num_shells smat(loop_s, loop_s) = 1.0_dp/singv(loop_s) end do @@ -1042,12 +1159,12 @@ subroutine kmesh_shell_automatic(multi, dnn, bweight) tmp1 = matmul(tmp0, target) tmp2 = matmul(smat, tmp1) tmp3 = matmul(transpose(vmat), tmp2) - bweight(1:num_shells) = tmp3 + bweight(1:kmesh_input%num_shells) = tmp3 - if (iprint >= 2 .and. on_root) then - do loop_s = 1, num_shells + if (print_output%iprint >= 2) then + do loop_s = 1, kmesh_input%num_shells write (stdout, '(1x,a,I2,a,f12.7,5x,a8,36x,a)') '| Shell: ', loop_s, & - ' w_b ', bweight(loop_s)*lenconfac**2, '('//trim(length_unit)//'^2)', '|' + ' w_b ', bweight(loop_s)*print_output%lenconfac**2, '('//trim(print_output%length_unit)//'^2)', '|' end do end if @@ -1056,97 +1173,121 @@ subroutine kmesh_shell_automatic(multi, dnn, bweight) do loop_i = 1, 3 do loop_j = loop_i, 3 delta = 0.0_dp - do loop_s = 1, num_shells - do loop_b = 1, multi(shell_list(loop_s)) + do loop_s = 1, kmesh_input%num_shells + do loop_b = 1, multi(kmesh_input%shell_list(loop_s)) delta = delta + bweight(loop_s)*bvector(loop_i, loop_b, loop_s)*bvector(loop_j, loop_b, loop_s) end do end do if (loop_i == loop_j) then - if (abs(delta - 1.0_dp) > kmesh_tol) b1sat = .false. + if (abs(delta - 1.0_dp) > kmesh_input%tol) b1sat = .false. end if if (loop_i /= loop_j) then - if (abs(delta) > kmesh_tol) b1sat = .false. + if (abs(delta) > kmesh_input%tol) b1sat = .false. end if end do end do if (.not. b1sat) then - if (shell < search_shells .and. iprint >= 3) then - if (on_root) write (stdout, '(1x,a,24x,a1)') '| B1 condition is not satisfied: Adding another shell', '|' - elseif (shell == search_shells) then - if (on_root) write (stdout, *) ' ' - if (on_root) write (stdout, '(1x,a,i3,a)') 'Unable to satisfy B1 with any of the first ', search_shells, ' shells' - if (on_root) write (stdout, '(1x,a)') 'Check that you have specified your unit cell to a high precision' - if (on_root) write (stdout, '(1x,a)') 'Low precision might cause a loss of symmetry.' - if (on_root) write (stdout, '(1x,a)') ' ' - if (on_root) write (stdout, '(1x,a)') 'If your cell is very long, or you have an irregular MP grid' - if (on_root) write (stdout, '(1x,a)') 'Try increasing the parameter search_shells in the win file (default=30)' - if (on_root) write (stdout, *) ' ' - call io_error('kmesh_get_automatic') + if (shell < kmesh_input%search_shells .and. print_output%iprint >= 3) then + if (print_output%iprint > 0) write (stdout, '(1x,a,24x,a1)') '| B1 condition is not satisfied: Adding another shell', '|' + + elseif (shell == kmesh_input%search_shells) then + + if (print_output%iprint > 0) then + write (stdout, *) ' ' + write (stdout, '(1x,a,i3,a)') 'Unable to satisfy B1 with any of the first ', kmesh_input%search_shells, ' shells' + write (stdout, '(1x,a)') 'Check that you have specified your unit cell to a high precision' + write (stdout, '(1x,a)') 'Low precision might cause a loss of symmetry.' + write (stdout, '(1x,a)') ' ' + write (stdout, '(1x,a)') 'If your cell is very long, or you have an irregular MP grid' + write (stdout, '(1x,a)') 'Try increasing the parameter search_shells in the win file (default=30)' + write (stdout, *) ' ' + call io_error('kmesh_get_automatic', stdout, seedname) + end if + end if end if 200 continue deallocate (tmp0, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating amat in kmesh_shell_automatic') + if (ierr /= 0) call io_error('Error deallocating amat in kmesh_shell_automatic', stdout, seedname) deallocate (tmp1, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating amat in kmesh_shell_automatic') + if (ierr /= 0) call io_error('Error deallocating amat in kmesh_shell_automatic', stdout, seedname) deallocate (tmp2, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating amat in kmesh_shell_automatic') + if (ierr /= 0) call io_error('Error deallocating amat in kmesh_shell_automatic', stdout, seedname) deallocate (tmp3, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating amat in kmesh_shell_automatic') + if (ierr /= 0) call io_error('Error deallocating amat in kmesh_shell_automatic', stdout, seedname) deallocate (amat, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating amat in kmesh_shell_automatic') + if (ierr /= 0) call io_error('Error deallocating amat in kmesh_shell_automatic', stdout, seedname) deallocate (umat, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating umat in kmesh_shell_automatic') + if (ierr /= 0) call io_error('Error deallocating umat in kmesh_shell_automatic', stdout, seedname) deallocate (vmat, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating vmat in kmesh_shell_automatic') + if (ierr /= 0) call io_error('Error deallocating vmat in kmesh_shell_automatic', stdout, seedname) deallocate (smat, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating smat in kmesh_shell_automatic') + if (ierr /= 0) call io_error('Error deallocating smat in kmesh_shell_automatic', stdout, seedname) deallocate (singv, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating singv in kmesh_shell_automatic') + if (ierr /= 0) call io_error('Error deallocating singv in kmesh_shell_automatic', stdout, seedname) if (b1sat) exit end do if (.not. b1sat) then - if (on_root) write (stdout, *) ' ' - if (on_root) write (stdout, '(1x,a,i3,a)') 'Unable to satisfy B1 with any of the first ', search_shells, ' shells' - if (on_root) write (stdout, '(1x,a)') 'Your cell might be very long, or you may have an irregular MP grid' - if (on_root) write (stdout, '(1x,a)') 'Try increasing the parameter search_shells in the win file (default=12)' - if (on_root) write (stdout, *) ' ' - call io_error('kmesh_get_automatic') + if (print_output%iprint > 0) then + write (stdout, *) ' ' + write (stdout, '(1x,a,i3,a)') 'Unable to satisfy B1 with any of the first ', kmesh_input%search_shells, ' shells' + write (stdout, '(1x,a)') 'Your cell might be very long, or you may have an irregular MP grid' + write (stdout, '(1x,a)') 'Try increasing the parameter search_shells in the win file (default=12)' + write (stdout, *) ' ' + end if + call io_error('kmesh_get_automatic', stdout, seedname) end if - if (timing_level > 1) call io_stopwatch('kmesh: shell_automatic', 2) + if (print_output%timing_level > 1) call io_stopwatch('kmesh: shell_automatic', 2, stdout, seedname) return end subroutine kmesh_shell_automatic - !================================================================ - subroutine kmesh_shell_fixed(multi, dnn, bweight) - !================================================================ + !================================================ + subroutine kmesh_shell_fixed(kmesh_input, print_output, bweight, dnn, kpt_cart, recip_lattice, lmn, & + multi, num_kpts, seedname, stdout) + !================================================ ! !! Find the B1 weights for a set of shells specified by the user ! - !================================================================ + !================================================ use w90_constants, only: eps7 - use w90_io, only: io_error, stdout, io_stopwatch + use w90_io, only: io_error, io_stopwatch + use w90_types, only: kmesh_input_type, print_output_type + implicit none - integer, intent(in) :: multi(search_shells) ! the number of kpoints in the shell - real(kind=dp), intent(in) :: dnn(search_shells) ! the bvectors + ! arguments + type(print_output_type), intent(in) :: print_output + type(kmesh_input_type), intent(in) :: kmesh_input + + integer, intent(in) :: num_kpts + integer, intent(in) :: stdout + integer, intent(in) :: lmn(:, :) + integer, intent(in) :: multi(kmesh_input%search_shells) ! the number of kpoints in the shell + + real(kind=dp), intent(in) :: recip_lattice(3, 3) + real(kind=dp), intent(in) ::kpt_cart(:, :) + real(kind=dp), intent(in) :: dnn(kmesh_input%search_shells) ! the bvectors real(kind=dp), intent(out) :: bweight(max_shells) + + character(len=50), intent(in) :: seedname + + ! local variables real(kind=dp), allocatable :: bvector(:, :, :) - real(kind=dp) :: singv(num_shells) - real(kind=dp) :: amat(max_shells, num_shells) + real(kind=dp) :: singv(kmesh_input%num_shells) + real(kind=dp) :: amat(max_shells, kmesh_input%num_shells) real(kind=dp) :: umat(max_shells, max_shells) - real(kind=dp) :: vmat(num_shells, num_shells) - real(kind=dp) :: smat(num_shells, max_shells) + real(kind=dp) :: vmat(kmesh_input%num_shells, kmesh_input%num_shells) + real(kind=dp) :: smat(kmesh_input%num_shells, max_shells) integer, parameter :: lwork = max_shells*10 real(kind=dp) :: work(lwork) real(kind=dp), parameter :: target(6) = (/1.0_dp, 1.0_dp, 1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp/) @@ -1156,33 +1297,38 @@ subroutine kmesh_shell_fixed(multi, dnn, bweight) integer :: loop, shell - if (timing_level > 1) call io_stopwatch('kmesh: shell_fixed', 1) + if (print_output%timing_level > 1) call io_stopwatch('kmesh: shell_fixed', 1, stdout, seedname) - allocate (bvector(3, maxval(multi), num_shells), stat=ierr) - if (ierr /= 0) call io_error('Error allocating bvector in kmesh_shell_fixed') + allocate (bvector(3, maxval(multi), kmesh_input%num_shells), stat=ierr) + if (ierr /= 0) call io_error('Error allocating bvector in kmesh_shell_fixed', stdout, seedname) bvector = 0.0_dp; bweight = 0.0_dp amat = 0.0_dp; umat = 0.0_dp; vmat = 0.0_dp; smat = 0.0_dp; singv = 0.0_dp - if (on_root) write (stdout, '(1x,a)') '| The b-vectors are set in the win file |' + if (print_output%iprint > 0) then + write (stdout, '(1x,a)') '| The b-vectors are set in the win file |' + endif - do shell = 1, num_shells + do shell = 1, kmesh_input%num_shells ! get the b vectors for this shell - call kmesh_get_bvectors(multi(shell_list(shell)), 1, dnn(shell_list(shell)), & - bvector(:, 1:multi(shell_list(shell)), shell)) + call kmesh_get_bvectors(kmesh_input, print_output, & + bvector(:, 1:multi(kmesh_input%shell_list(shell)), shell), kpt_cart, & + recip_lattice, dnn(kmesh_input%shell_list(shell)), lmn, 1, & + multi(kmesh_input%shell_list(shell)), num_kpts, seedname, stdout) end do - if (iprint >= 3 .and. on_root) then - do shell = 1, num_shells - write (stdout, '(1x,a8,1x,I2,a14,1x,I2,49x,a)') '| Shell:', shell, ' Multiplicity:', multi(shell_list(shell)), '|' - do loop = 1, multi(shell_list(shell)) + if (print_output%iprint >= 3) then + do shell = 1, kmesh_input%num_shells + write (stdout, '(1x,a8,1x,I2,a14,1x,I2,49x,a)') '| Shell:', shell, ' Multiplicity:', & + multi(kmesh_input%shell_list(shell)), '|' + do loop = 1, multi(kmesh_input%shell_list(shell)) write (stdout, '(1x,a10,I2,1x,a1,4x,3f12.6,5x,a9,9x,a)') '| b-vector ', loop, ':', & - bvector(:, loop, shell)/lenconfac, '('//trim(length_unit)//'^-1)', '|' + bvector(:, loop, shell)/print_output%lenconfac, '('//trim(print_output%length_unit)//'^-1)', '|' end do end do end if - do loop_s = 1, num_shells - do loop_b = 1, multi(shell_list(loop_s)) + do loop_s = 1, kmesh_input%num_shells + do loop_b = 1, multi(kmesh_input%shell_list(loop_s)) amat(1, loop_s) = amat(1, loop_s) + bvector(1, loop_b, loop_s)*bvector(1, loop_b, loop_s) amat(2, loop_s) = amat(2, loop_s) + bvector(2, loop_b, loop_s)*bvector(2, loop_b, loop_s) amat(3, loop_s) = amat(3, loop_s) + bvector(3, loop_b, loop_s)*bvector(3, loop_b, loop_s) @@ -1193,78 +1339,98 @@ subroutine kmesh_shell_fixed(multi, dnn, bweight) end do info = 0 - call dgesvd('A', 'A', max_shells, num_shells, amat, max_shells, singv, umat, max_shells, vmat, num_shells, work, lwork, info) + call dgesvd('A', 'A', max_shells, kmesh_input%num_shells, amat, max_shells, singv, umat, & + max_shells, vmat, kmesh_input%num_shells, work, lwork, info) if (info < 0) then - if (on_root) write (stdout, '(1x,a,1x,I1,1x,a)') 'kmesh_shell_fixed: Argument', abs(info), 'of dgesvd is incorrect' - call io_error('kmesh_shell_fixed: Problem with Singular Value Decomposition') + if (print_output%iprint > 0) then + write (stdout, '(1x,a,1x,I1,1x,a)') 'kmesh_shell_fixed: Argument', abs(info), & + 'of dgesvd is incorrect' + endif + call io_error('kmesh_shell_fixed: Problem with Singular Value Decomposition', stdout, seedname) else if (info > 0) then - call io_error('kmesh_shell_fixed: Singular Value Decomposition did not converge') + call io_error('kmesh_shell_fixed: Singular Value Decomposition did not converge', stdout, seedname) end if if (any(abs(singv) < eps7)) & - call io_error('kmesh_shell_fixed: Singular Value Decomposition has found a very small singular value') + call io_error('kmesh_shell_fixed: Singular Value Decomposition has found a very small singular value', stdout, seedname) smat = 0.0_dp - do loop_s = 1, num_shells + do loop_s = 1, kmesh_input%num_shells smat(loop_s, loop_s) = 1/singv(loop_s) end do - bweight(1:num_shells) = matmul(transpose(vmat), matmul(smat, matmul(transpose(umat), target))) - if (iprint >= 2 .and. on_root) then - do loop_s = 1, num_shells -! write(stdout,'(1x,a,I2,a,f12.7,49x,a)') '| Shell: ',loop_s,' w_b ', bweight(loop_s),'|' + bweight(1:kmesh_input%num_shells) = matmul(transpose(vmat), matmul(smat, matmul(transpose(umat), target))) + if (print_output%iprint >= 2) then + do loop_s = 1, kmesh_input%num_shells write (stdout, '(1x,a,I2,a,f12.7,5x,a8,36x,a)') '| Shell: ', loop_s, & - ' w_b ', bweight(loop_s)*lenconfac**2, '('//trim(length_unit)//'^2)', '|' + ' w_b ', bweight(loop_s)*print_output%lenconfac**2, '('//trim(print_output%length_unit)//'^2)', '|' end do end if !check b1 b1sat = .true. - if (.not. skip_B1_tests) then + if (.not. kmesh_input%skip_B1_tests) then do loop_i = 1, 3 do loop_j = loop_i, 3 delta = 0.0_dp - do loop_s = 1, num_shells - do loop_b = 1, multi(shell_list(loop_s)) + do loop_s = 1, kmesh_input%num_shells + do loop_b = 1, multi(kmesh_input%shell_list(loop_s)) delta = delta + bweight(loop_s)*bvector(loop_i, loop_b, loop_s)*bvector(loop_j, loop_b, loop_s) end do end do if (loop_i == loop_j) then - if (abs(delta - 1.0_dp) > kmesh_tol) b1sat = .false. + if (abs(delta - 1.0_dp) > kmesh_input%tol) b1sat = .false. end if if (loop_i /= loop_j) then - if (abs(delta) > kmesh_tol) b1sat = .false. + if (abs(delta) > kmesh_input%tol) b1sat = .false. end if end do end do end if - if (.not. b1sat) call io_error('kmesh_shell_fixed: B1 condition not satisfied') + if (.not. b1sat) call io_error('kmesh_shell_fixed: B1 condition not satisfied', stdout, seedname) - if (timing_level > 1) call io_stopwatch('kmesh: shell_fixed', 2) + if (print_output%timing_level > 1) call io_stopwatch('kmesh: shell_fixed', 2, stdout, seedname) return end subroutine kmesh_shell_fixed - !================================================================= - subroutine kmesh_shell_from_file(multi, dnn, bweight) - !================================================================= - ! + !================================================ + subroutine kmesh_shell_from_file(kmesh_input, print_output, bvec_inp, bweight, dnn, kpt_cart, & + recip_lattice, lmn, multi, num_kpts, seedname, stdout) + !================================================ !! Find the B1 weights for a set of b-vectors given in a file. !! This routine is only activated via a devel_flag and is not !! intended for regular use. ! - !================================================================= + !================================================ use w90_constants, only: eps7 - use w90_io, only: io_error, stdout, io_stopwatch, io_file_unit, seedname, maxlen + use w90_io, only: io_error, io_stopwatch, io_file_unit, maxlen + use w90_types, only: kmesh_input_type, print_output_type + implicit none - integer, intent(inout) :: multi(search_shells) ! the number of kpoints in the shell - real(kind=dp), intent(in) :: dnn(search_shells) ! the bvectors + ! arguments + type(print_output_type), intent(in) :: print_output + type(kmesh_input_type), intent(inout) :: kmesh_input + + integer, intent(in) :: num_kpts + integer, intent(in) :: stdout + integer, intent(in) :: lmn(:, :) + integer, intent(inout) :: multi(kmesh_input%search_shells) ! the number of kpoints in the shell + + real(kind=dp), intent(in) :: recip_lattice(3, 3) + real(kind=dp), intent(in) ::kpt_cart(:, :) + real(kind=dp), intent(inout) :: bvec_inp(:, :, :) + real(kind=dp), intent(in) :: dnn(kmesh_input%search_shells) ! the bvectors real(kind=dp), intent(out) :: bweight(max_shells) + + character(len=50), intent(in) :: seedname + + ! local variables real(kind=dp), allocatable :: bvector(:, :) real(kind=dp), dimension(:), allocatable :: singv @@ -1281,19 +1447,23 @@ subroutine kmesh_shell_from_file(multi, dnn, bweight) integer :: loop, shell, pos, kshell_in, counter, length, i, loop2, num_lines, tot_num_lines character(len=maxlen) :: dummy, dummy2 - if (timing_level > 1) call io_stopwatch('kmesh: shell_fixed', 1) + if (print_output%timing_level > 1) call io_stopwatch('kmesh: shell_fixed', 1, stdout, seedname) allocate (bvector(3, sum(multi)), stat=ierr) - if (ierr /= 0) call io_error('Error allocating bvector in kmesh_shell_fixed') + if (ierr /= 0) call io_error('Error allocating bvector in kmesh_shell_fixed', stdout, seedname) bvector = 0.0_dp; bweight = 0.0_dp - if (on_root) write (stdout, '(1x,a)') '| The b-vectors are defined in the kshell file |' + if (print_output%iprint > 0) then + write (stdout, '(1x,a)') '| The b-vectors are defined in the kshell file |' + endif counter = 1 - do shell = 1, search_shells + do shell = 1, kmesh_input%search_shells ! get the b vectors - call kmesh_get_bvectors(multi(shell), 1, dnn(shell), & - bvector(:, counter:counter + multi(shell) - 1)) + call kmesh_get_bvectors(kmesh_input, print_output, bvector(:, counter:counter + multi(shell) - 1), & + kpt_cart, recip_lattice, dnn(shell), lmn, 1, multi(shell), num_kpts, & + seedname, stdout) + counter = counter + multi(shell) end do @@ -1312,10 +1482,10 @@ subroutine kmesh_shell_from_file(multi, dnn, bweight) end do -200 call io_error('Error: Problem (1) reading input file '//trim(seedname)//'.kshell') +200 call io_error('Error: Problem (1) reading input file '//trim(seedname)//'.kshell', stdout, seedname) 210 continue rewind (kshell_in) - num_shells = num_lines + kmesh_input%num_shells = num_lines multi(:) = 0 bvec_list = 1 @@ -1325,7 +1495,7 @@ subroutine kmesh_shell_from_file(multi, dnn, bweight) dummy2 = adjustl(dummy2) if (dummy2(1:1) == '!' .or. dummy2(1:1) == '#' .or. (len(trim(dummy2)) == 0)) cycle counter = counter + 1 - shell_list(counter) = counter + kmesh_input%shell_list(counter) = counter dummy = dummy2 length = 1 dummy = adjustl(dummy) @@ -1345,35 +1515,35 @@ subroutine kmesh_shell_from_file(multi, dnn, bweight) end do bvec_inp = 0.0_dp - do loop = 1, num_shells + do loop = 1, kmesh_input%num_shells do loop2 = 1, multi(loop) bvec_inp(:, loop2, loop) = bvector(:, bvec_list(loop2, loop)) end do end do - if (iprint >= 3 .and. on_root) then - do shell = 1, num_shells + if (print_output%iprint >= 3) then + do shell = 1, kmesh_input%num_shells write (stdout, '(1x,a8,1x,I2,a14,1x,I2,49x,a)') '| Shell:', shell, ' Multiplicity:', multi(shell), '|' do loop = 1, multi(shell) write (stdout, '(1x,a10,I2,1x,a1,4x,3f12.6,5x,a9,9x,a)') '| b-vector ', loop, ':', & - bvec_inp(:, loop, shell)/lenconfac, '('//trim(length_unit)//'^-1)', '|' + bvec_inp(:, loop, shell)/print_output%lenconfac, '('//trim(print_output%length_unit)//'^-1)', '|' end do end do end if - allocate (amat(max_shells, num_shells), stat=ierr) - if (ierr /= 0) call io_error('Error allocating amat in kmesh_shell_from_file') + allocate (amat(max_shells, kmesh_input%num_shells), stat=ierr) + if (ierr /= 0) call io_error('Error allocating amat in kmesh_shell_from_file', stdout, seedname) allocate (umat(max_shells, max_shells), stat=ierr) - if (ierr /= 0) call io_error('Error allocating umat in kmesh_shell_from_file') - allocate (vmat(num_shells, num_shells), stat=ierr) - if (ierr /= 0) call io_error('Error allocating vmat in kmesh_shell_from_file') - allocate (smat(num_shells, max_shells), stat=ierr) - if (ierr /= 0) call io_error('Error allocating smat in kmesh_shell_from_file') - allocate (singv(num_shells), stat=ierr) - if (ierr /= 0) call io_error('Error allocating singv in kmesh_shell_from_file') + if (ierr /= 0) call io_error('Error allocating umat in kmesh_shell_from_file', stdout, seedname) + allocate (vmat(kmesh_input%num_shells, kmesh_input%num_shells), stat=ierr) + if (ierr /= 0) call io_error('Error allocating vmat in kmesh_shell_from_file', stdout, seedname) + allocate (smat(kmesh_input%num_shells, max_shells), stat=ierr) + if (ierr /= 0) call io_error('Error allocating smat in kmesh_shell_from_file', stdout, seedname) + allocate (singv(kmesh_input%num_shells), stat=ierr) + if (ierr /= 0) call io_error('Error allocating singv in kmesh_shell_from_file', stdout, seedname) amat = 0.0_dp; umat = 0.0_dp; vmat = 0.0_dp; smat = 0.0_dp; singv = 0.0_dp - do loop_s = 1, num_shells + do loop_s = 1, kmesh_input%num_shells do loop_b = 1, multi(loop_s) amat(1, loop_s) = amat(1, loop_s) + bvec_inp(1, loop_b, loop_s)*bvec_inp(1, loop_b, loop_s) amat(2, loop_s) = amat(2, loop_s) + bvec_inp(2, loop_b, loop_s)*bvec_inp(2, loop_b, loop_s) @@ -1385,81 +1555,85 @@ subroutine kmesh_shell_from_file(multi, dnn, bweight) end do info = 0 - call dgesvd('A', 'A', max_shells, num_shells, amat, max_shells, singv, umat, max_shells, vmat, num_shells, work, lwork, info) + call dgesvd('A', 'A', max_shells, kmesh_input%num_shells, amat, max_shells, singv, umat, & + max_shells, vmat, kmesh_input%num_shells, work, lwork, info) if (info < 0) then - if (on_root) write (stdout, '(1x,a,1x,I1,1x,a)') 'kmesh_shell_fixed: Argument', abs(info), 'of dgesvd is incorrect' - call io_error('kmesh_shell_fixed: Problem with Singular Value Decomposition') + if (print_output%iprint > 0) then + write (stdout, '(1x,a,1x,I1,1x,a)') 'kmesh_shell_fixed: Argument', abs(info), & + 'of dgesvd is incorrect' + endif + call io_error('kmesh_shell_fixed: Problem with Singular Value Decomposition', stdout, seedname) else if (info > 0) then - call io_error('kmesh_shell_fixed: Singular Value Decomposition did not converge') + call io_error('kmesh_shell_fixed: Singular Value Decomposition did not converge', stdout, seedname) end if if (any(abs(singv) < eps7)) & - call io_error('kmesh_shell_fixed: Singular Value Decomposition has found a very small singular value') + call io_error('kmesh_shell_fixed: Singular Value Decomposition has found a very small singular value', stdout, seedname) smat = 0.0_dp - do loop_s = 1, num_shells + do loop_s = 1, kmesh_input%num_shells smat(loop_s, loop_s) = 1/singv(loop_s) end do - bweight(1:num_shells) = matmul(transpose(vmat), matmul(smat, matmul(transpose(umat), target))) - if (iprint >= 2 .and. on_root) then - do loop_s = 1, num_shells + bweight(1:kmesh_input%num_shells) = matmul(transpose(vmat), matmul(smat, matmul(transpose(umat), target))) + if (print_output%iprint >= 2) then + do loop_s = 1, kmesh_input%num_shells write (stdout, '(1x,a,I2,a,f12.7,5x,a8,36x,a)') '| Shell: ', loop_s, & - ' w_b ', bweight(loop_s)*lenconfac**2, '('//trim(length_unit)//'^2)', '|' + ' w_b ', bweight(loop_s)*print_output%lenconfac**2, '('//trim(print_output%length_unit)//'^2)', '|' end do end if !check b1 b1sat = .true. - if (.not. skip_B1_tests) then + if (.not. kmesh_input%skip_B1_tests) then do loop_i = 1, 3 do loop_j = loop_i, 3 delta = 0.0_dp - do loop_s = 1, num_shells + do loop_s = 1, kmesh_input%num_shells do loop_b = 1, multi(loop_s) delta = delta + bweight(loop_s)*bvec_inp(loop_i, loop_b, loop_s)*bvec_inp(loop_j, loop_b, loop_s) end do end do if (loop_i == loop_j) then - if (abs(delta - 1.0_dp) > kmesh_tol) b1sat = .false. + if (abs(delta - 1.0_dp) > kmesh_input%tol) b1sat = .false. end if if (loop_i /= loop_j) then - if (abs(delta) > kmesh_tol) b1sat = .false. + if (abs(delta) > kmesh_input%tol) b1sat = .false. end if end do end do end if - if (.not. b1sat) call io_error('kmesh_shell_fixed: B1 condition not satisfied') + if (.not. b1sat) call io_error('kmesh_shell_fixed: B1 condition not satisfied', stdout, seedname) - if (timing_level > 1) call io_stopwatch('kmesh: shell_fixed', 2) + if (print_output%timing_level > 1) call io_stopwatch('kmesh: shell_fixed', 2, stdout, seedname) return -101 call io_error('Error: Problem (2) reading input file '//trim(seedname)//'.kshell') -103 call io_error('Error: Problem (3) reading input file '//trim(seedname)//'.kshell') -230 call io_error('Error: Problem reading in param_get_keyword_vector') +101 call io_error('Error: Problem (2) reading input file '//trim(seedname)//'.kshell', stdout, seedname) +103 call io_error('Error: Problem (3) reading input file '//trim(seedname)//'.kshell', stdout, seedname) +230 call io_error('Error: Problem reading in w90_readwrite_get_keyword_vector', stdout, seedname) end subroutine kmesh_shell_from_file - !================================= + !================================================ function internal_maxloc(dist) - !================================= - ! + !================================================ !! A reproducible maxloc function !! so b-vectors come in the same !! order each time - !================================= + !================================================ use w90_constants, only: eps8 + implicit none real(kind=dp), intent(in) :: dist((2*nsupcell + 1)**3) !! Distances from the origin of the unit cells in the supercell. - integer :: internal_maxloc + integer :: internal_maxloc - integer :: guess(1), loop, counter - integer :: list((2*nsupcell + 1)**3) + integer :: guess(1), loop, counter + integer :: list((2*nsupcell + 1)**3) list = 0 counter = 1 diff --git a/src/overlap.F90 b/src/overlap.F90 index 0b0f84cf6..5f111efcd 100644 --- a/src/overlap.F90 +++ b/src/overlap.F90 @@ -11,117 +11,206 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! w90_overlap: setup overlap and projection matrices ! +! ! +!------------------------------------------------------------! module w90_overlap + !! This module reads in the overlap (Mmn) and Projections (Amn) !! and performs simple operations on them. use w90_constants, only: dp, cmplx_0, cmplx_1 - use w90_parameters, only: disentanglement - use w90_io, only: stdout - use w90_comms, only: on_root, comms_bcast + use w90_comms implicit none private -!~ public :: overlap_dis_read public :: overlap_allocate - public :: overlap_read public :: overlap_dealloc public :: overlap_project - public :: overlap_project_gamma ![ysl] -!~ public :: overlap_check_m_symmetry + public :: overlap_project_gamma + public :: overlap_read contains - !%%%%%%%%%%%%%%%%%%%%% - subroutine overlap_allocate() - !%%%%%%%%%%%%%%%%%%%%% + !================================================! + + subroutine overlap_allocate(a_matrix, m_matrix, m_matrix_local, m_matrix_orig, & + m_matrix_orig_local, u_matrix, u_matrix_opt, nntot, num_bands, & + num_kpts, num_wann, timing_level, seedname, stdout, comm) + !================================================! !! Allocate memory to read Mmn and Amn from files !! This must be called before calling overlap_read + ! + !================================================! - use w90_parameters, only: num_bands, num_wann, num_kpts, nntot, timing_level, & - u_matrix, m_matrix_orig, m_matrix_orig_local, a_matrix, & - u_matrix_opt, m_matrix, m_matrix_local use w90_io, only: io_error, io_stopwatch - use w90_comms, only: my_node_id, num_nodes, comms_array_split + ! arguments + integer, intent(in) :: nntot + integer, intent(in) :: num_bands + integer, intent(in) :: num_kpts + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + integer, intent(in) :: timing_level + + complex(kind=dp), allocatable :: a_matrix(:, :, :) + complex(kind=dp), allocatable :: m_matrix(:, :, :, :) + complex(kind=dp), allocatable :: m_matrix_local(:, :, :, :) + complex(kind=dp), allocatable :: m_matrix_orig(:, :, :, :) + complex(kind=dp), allocatable :: m_matrix_orig_local(:, :, :, :) + complex(kind=dp), allocatable :: u_matrix(:, :, :) + complex(kind=dp), allocatable :: u_matrix_opt(:, :, :) + + type(w90comm_type), intent(in) :: comm + + character(len=50), intent(in) :: seedname + + ! local variables + integer, allocatable :: counts(:) + integer, allocatable :: displs(:) integer :: ierr - ! Needed to split an array on different nodes - integer, dimension(0:num_nodes - 1) :: counts - integer, dimension(0:num_nodes - 1) :: displs + integer :: num_nodes, my_node_id + logical :: disentanglement + logical :: on_root = .false. + + disentanglement = (num_bands > num_wann) + + num_nodes = mpisize(comm) + my_node_id = mpirank(comm) + + if (my_node_id == 0) on_root = .true. + allocate (counts(0:num_nodes - 1)) + allocate (displs(0:num_nodes - 1)) - if (timing_level > 0) call io_stopwatch('overlap: allocate', 1) + if (timing_level > 0) call io_stopwatch('overlap: allocate', 1, stdout, seedname) - call comms_array_split(num_kpts, counts, displs) + call comms_array_split(num_kpts, counts, displs, comm) allocate (u_matrix(num_wann, num_wann, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating u_matrix in overlap_read') + if (ierr /= 0) call io_error('Error in allocating u_matrix in overlap_read', stdout, seedname) u_matrix = cmplx_0 if (disentanglement) then if (on_root) then allocate (m_matrix_orig(num_bands, num_bands, nntot, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating m_matrix_orig in overlap_read') + if (ierr /= 0) call io_error('Error in allocating m_matrix_orig in overlap_read', stdout, seedname) + allocate (m_matrix(1, 1, 1, 1)) else - allocate (m_matrix_orig(0, 0, 0, 0)) + allocate (m_matrix_orig(1, 1, 1, 1)) + allocate (m_matrix(1, 1, 1, 1)) endif + allocate (m_matrix_orig_local(num_bands, num_bands, nntot, counts(my_node_id)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating m_matrix_orig_local in overlap_read') + if (ierr /= 0) call io_error('Error in allocating m_matrix_orig_local in overlap_read', stdout, seedname) allocate (a_matrix(num_bands, num_wann, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating a_matrix in overlap_read') + if (ierr /= 0) call io_error('Error in allocating a_matrix in overlap_read', stdout, seedname) allocate (u_matrix_opt(num_bands, num_wann, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating u_matrix_opt in overlap_read') + if (ierr /= 0) call io_error('Error in allocating u_matrix_opt in overlap_read', stdout, seedname) + + allocate (m_matrix_local(1, 1, 1, 1)) + else if (on_root) then allocate (m_matrix(num_wann, num_wann, nntot, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating m_matrix in overlap_read') + if (ierr /= 0) call io_error('Error in allocating m_matrix in overlap_read', stdout, seedname) m_matrix = cmplx_0 + allocate (m_matrix_orig(1, 1, 1, 1)) else - allocate (m_matrix(0, 0, 0, 0)) + allocate (m_matrix(1, 1, 1, 1)) + allocate (m_matrix_orig(1, 1, 1, 1)) endif + allocate (m_matrix_local(num_wann, num_wann, nntot, counts(my_node_id)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating m_matrix_local in overlap_read') + if (ierr /= 0) call io_error('Error in allocating m_matrix_local in overlap_read', stdout, seedname) m_matrix_local = cmplx_0 + + allocate (m_matrix_orig_local(1, 1, 1, 1)) + allocate (a_matrix(1, 1, 1)) + allocate (u_matrix_opt(1, 1, 1)) + endif - if (timing_level > 0) call io_stopwatch('overlap: allocate', 2) + if (timing_level > 0) call io_stopwatch('overlap: allocate', 2, stdout, seedname) end subroutine overlap_allocate - !%%%%%%%%%%%%%%%%%%%%% - subroutine overlap_read() - !%%%%%%%%%%%%%%%%%%%%% + !================================================! + subroutine overlap_read(kmesh_info, select_projection, sitesym, a_matrix, m_matrix, & + m_matrix_local, m_matrix_orig, m_matrix_orig_local, u_matrix, & + u_matrix_opt, num_bands, num_kpts, num_proj, num_wann, timing_level, & + cp_pp, gamma_only, lsitesymmetry, use_bloch_phases, seedname, stdout, & + comm) + !================================================! !! Read the Mmn and Amn from files !! Note: one needs to call overlap_allocate first! + ! + !================================================! - use w90_parameters, only: num_bands, num_wann, num_kpts, nntot, nncell, nnlist, & - num_proj, lselproj, proj2wann_map, & - devel_flag, u_matrix, m_matrix, a_matrix, timing_level, & - m_matrix_orig, u_matrix_opt, cp_pp, use_bloch_phases, gamma_only, & ![ysl] - m_matrix_local, m_matrix_orig_local, lhasproj - use w90_io, only: io_file_unit, io_error, seedname, io_stopwatch - use w90_comms, only: my_node_id, num_nodes, & - comms_array_split, comms_scatterv + use w90_io, only: io_file_unit, io_error, io_stopwatch + use w90_types, only: kmesh_info_type + use w90_wannier90_types, only: select_projection_type, sitesym_type implicit none - integer :: nkp, nkp2, inn, nn, n, m, i, j + ! arguments + type(kmesh_info_type), intent(in) :: kmesh_info + type(select_projection_type), intent(in) :: select_projection + type(sitesym_type), intent(in) :: sitesym + type(w90comm_type), intent(in) :: comm + + integer, intent(in) :: num_bands + integer, intent(in) :: num_kpts + integer, intent(in) :: num_proj + integer, intent(in) :: num_wann + integer, intent(in) :: timing_level + integer, intent(in) :: stdout + + complex(kind=dp), intent(inout) :: a_matrix(:, :, :) + complex(kind=dp), intent(inout) :: m_matrix(:, :, :, :) + complex(kind=dp), intent(inout) :: m_matrix_local(:, :, :, :) + complex(kind=dp), intent(inout) :: m_matrix_orig(:, :, :, :) + complex(kind=dp), intent(inout) :: m_matrix_orig_local(:, :, :, :) + complex(kind=dp), intent(inout) :: u_matrix(:, :, :) + complex(kind=dp), intent(inout) :: u_matrix_opt(:, :, :) + + logical, intent(in) :: gamma_only + logical, intent(in) :: lsitesymmetry + logical, intent(in) :: cp_pp, use_bloch_phases + + character(len=50), intent(in) :: seedname + + ! local variables integer :: mmn_in, amn_in, num_mmn, num_amn - integer :: nnl, nnm, nnn, ncount integer :: nb_tmp, nkp_tmp, nntot_tmp, np_tmp, ierr - real(kind=dp) :: m_real, m_imag, a_real, a_imag, mu_tmp, sigma_tmp + integer :: nkp, nkp2, inn, nn, n, m + integer :: nnl, nnm, nnn, ncount + logical :: nn_found + real(kind=dp) :: m_real, m_imag, a_real, a_imag complex(kind=dp), allocatable :: mmn_tmp(:, :) character(len=50) :: dummy - logical :: nn_found - ! Needed to split an array on different nodes - integer, dimension(0:num_nodes - 1) :: counts - integer, dimension(0:num_nodes - 1) :: displs - if (timing_level > 0) call io_stopwatch('overlap: read', 1) + logical :: disentanglement + integer :: num_nodes, my_node_id + logical :: on_root = .false. + integer, allocatable :: counts(:) + integer, allocatable :: displs(:) + + disentanglement = (num_bands > num_wann) + + num_nodes = mpisize(comm) + my_node_id = mpirank(comm) - call comms_array_split(num_kpts, counts, displs) + if (my_node_id == 0) on_root = .true. + allocate (counts(0:num_nodes - 1)) + allocate (displs(0:num_nodes - 1)) + + if (timing_level > 0) call io_stopwatch('overlap: read', 1, stdout, seedname) + + call comms_array_split(num_kpts, counts, displs, comm) if (disentanglement) then if (on_root) then @@ -150,16 +239,16 @@ subroutine overlap_read() ! Checks if (nb_tmp .ne. num_bands) & - call io_error(trim(seedname)//'.mmn has not the right number of bands') + call io_error(trim(seedname)//'.mmn has not the right number of bands', stdout, seedname) if (nkp_tmp .ne. num_kpts) & - call io_error(trim(seedname)//'.mmn has not the right number of k-points') - if (nntot_tmp .ne. nntot) & - call io_error(trim(seedname)//'.mmn has not the right number of nearest neighbours') + call io_error(trim(seedname)//'.mmn has not the right number of k-points', stdout, seedname) + if (nntot_tmp .ne. kmesh_info%nntot) & + call io_error(trim(seedname)//'.mmn has not the right number of nearest neighbours', stdout, seedname) ! Read the overlaps - num_mmn = num_kpts*nntot + num_mmn = num_kpts*kmesh_info%nntot allocate (mmn_tmp(num_bands, num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating mmn_tmp in overlap_read') + if (ierr /= 0) call io_error('Error in allocating mmn_tmp in overlap_read', stdout, seedname) do ncount = 1, num_mmn read (mmn_in, *, err=103, end=103) nkp, nkp2, nnl, nnm, nnn do n = 1, num_bands @@ -170,24 +259,24 @@ subroutine overlap_read() enddo nn = 0 nn_found = .false. - do inn = 1, nntot - if ((nkp2 .eq. nnlist(nkp, inn)) .and. & - (nnl .eq. nncell(1, nkp, inn)) .and. & - (nnm .eq. nncell(2, nkp, inn)) .and. & - (nnn .eq. nncell(3, nkp, inn))) then + do inn = 1, kmesh_info%nntot + if ((nkp2 .eq. kmesh_info%nnlist(nkp, inn)) .and. & + (nnl .eq. kmesh_info%nncell(1, nkp, inn)) .and. & + (nnm .eq. kmesh_info%nncell(2, nkp, inn)) .and. & + (nnn .eq. kmesh_info%nncell(3, nkp, inn))) then if (.not. nn_found) then nn_found = .true. nn = inn else call io_error('Error reading '//trim(seedname)// & - '.mmn. More than one matching nearest neighbour found') + '.mmn. More than one matching nearest neighbour found', stdout, seedname) endif endif end do if (nn .eq. 0) then if (on_root) write (stdout, '(/a,i8,2i5,i4,2x,3i3)') & ' Error reading '//trim(seedname)//'.mmn:', ncount, nkp, nkp2, nn, nnl, nnm, nnn - call io_error('Neighbour not found') + call io_error('Neighbour not found', stdout, seedname) end if if (disentanglement) then m_matrix_orig(:, :, nn, nkp) = mmn_tmp(:, :) @@ -197,18 +286,18 @@ subroutine overlap_read() end if end do deallocate (mmn_tmp, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating mmn_tmp in overlap_read') + if (ierr /= 0) call io_error('Error in deallocating mmn_tmp in overlap_read', stdout, seedname) close (mmn_in) endif if (disentanglement) then -! call comms_bcast(m_matrix_orig(1,1,1,1),num_bands*num_bands*nntot*num_kpts) - call comms_scatterv(m_matrix_orig_local, num_bands*num_bands*nntot*counts(my_node_id), & - m_matrix_orig, num_bands*num_bands*nntot*counts, num_bands*num_bands*nntot*displs) + call comms_scatterv(m_matrix_orig_local, num_bands*num_bands*kmesh_info%nntot*counts(my_node_id), & + m_matrix_orig, num_bands*num_bands*kmesh_info%nntot*counts, & + num_bands*num_bands*kmesh_info%nntot*displs, stdout, seedname, comm) else -! call comms_bcast(m_matrix(1,1,1,1),num_wann*num_wann*nntot*num_kpts) - call comms_scatterv(m_matrix_local, num_wann*num_wann*nntot*counts(my_node_id), & - m_matrix, num_wann*num_wann*nntot*counts, num_wann*num_wann*nntot*displs) + call comms_scatterv(m_matrix_local, num_wann*num_wann*kmesh_info%nntot*counts(my_node_id), & + m_matrix, num_wann*num_wann*kmesh_info%nntot*counts, & + num_wann*num_wann*kmesh_info%nntot*displs, stdout, seedname, comm) endif if (.not. use_bloch_phases) then @@ -229,37 +318,37 @@ subroutine overlap_read() ! Checks if (nb_tmp .ne. num_bands) & - call io_error(trim(seedname)//'.amn has not the right number of bands') + call io_error(trim(seedname)//'.amn has not the right number of bands', stdout, seedname) if (nkp_tmp .ne. num_kpts) & - call io_error(trim(seedname)//'.amn has not the right number of k-points') + call io_error(trim(seedname)//'.amn has not the right number of k-points', stdout, seedname) if (np_tmp .ne. num_proj) & - call io_error(trim(seedname)//'.amn has not the right number of projections') + call io_error(trim(seedname)//'.amn has not the right number of projections', stdout, seedname) - if (num_proj > num_wann .and. .not. lselproj) & - call io_error(trim(seedname)//'.amn has too many projections to be used without selecting a subset') + if (num_proj > num_wann .and. .not. select_projection%lselproj) & + call io_error(trim(seedname)//'.amn has too many projections to be used without selecting a subset', stdout, seedname) ! Read the projections num_amn = num_bands*num_proj*num_kpts if (disentanglement) then do ncount = 1, num_amn read (amn_in, *, err=104, end=104) m, n, nkp, a_real, a_imag - if (proj2wann_map(n) < 0) cycle - a_matrix(m, proj2wann_map(n), nkp) = cmplx(a_real, a_imag, kind=dp) + if (select_projection%proj2wann_map(n) < 0) cycle + a_matrix(m, select_projection%proj2wann_map(n), nkp) = cmplx(a_real, a_imag, kind=dp) end do else do ncount = 1, num_amn read (amn_in, *, err=104, end=104) m, n, nkp, a_real, a_imag - if (proj2wann_map(n) < 0) cycle - u_matrix(m, proj2wann_map(n), nkp) = cmplx(a_real, a_imag, kind=dp) + if (select_projection%proj2wann_map(n) < 0) cycle + u_matrix(m, select_projection%proj2wann_map(n), nkp) = cmplx(a_real, a_imag, kind=dp) end do end if close (amn_in) endif if (disentanglement) then - call comms_bcast(a_matrix(1, 1, 1), num_bands*num_wann*num_kpts) + call comms_bcast(a_matrix(1, 1, 1), num_bands*num_wann*num_kpts, stdout, seedname, comm) else - call comms_bcast(u_matrix(1, 1, 1), num_wann*num_wann*num_kpts) + call comms_bcast(u_matrix(1, 1, 1), num_wann*num_wann*num_kpts, stdout, seedname, comm) endif else @@ -274,7 +363,8 @@ subroutine overlap_read() ! If post-processing a Car-Parinello calculation (gamma only) ! then rotate M and A to the basis of Kohn-Sham eigenstates - if (cp_pp) call overlap_rotate() + if (cp_pp) call overlap_rotate(a_matrix, m_matrix_orig, kmesh_info%nntot, num_bands, & + timing_level, seedname, stdout) ! Check Mmn(k,b) is symmetric in m and n for gamma_only case !~ if (gamma_only) call overlap_check_m_symmetry() @@ -299,9 +389,12 @@ subroutine overlap_read() !~[aam] if ((.not. disentanglement) .and. (.not. cp_pp) .and. (.not. use_bloch_phases)) then if (.not. gamma_only) then - call overlap_project() + call overlap_project(sitesym, m_matrix, m_matrix_local, u_matrix, kmesh_info%nnlist, & + kmesh_info%nntot, num_bands, num_kpts, num_wann, & + timing_level, lsitesymmetry, seedname, stdout, comm) else - call overlap_project_gamma() + call overlap_project_gamma(m_matrix, u_matrix, kmesh_info%nntot, num_wann, & + timing_level, seedname, stdout) endif endif !~[aam] @@ -314,13 +407,13 @@ subroutine overlap_read() !~ end if ![ysl-e] - if (timing_level > 0) call io_stopwatch('overlap: read', 2) + if (timing_level > 0) call io_stopwatch('overlap: read', 2, stdout, seedname) return -101 call io_error('Error: Problem opening input file '//trim(seedname)//'.mmn') -102 call io_error('Error: Problem opening input file '//trim(seedname)//'.amn') -103 call io_error('Error: Problem reading input file '//trim(seedname)//'.mmn') -104 call io_error('Error: Problem reading input file '//trim(seedname)//'.amn') +101 call io_error('Error: Problem opening input file '//trim(seedname)//'.mmn', stdout, seedname) +102 call io_error('Error: Problem opening input file '//trim(seedname)//'.amn', stdout, seedname) +103 call io_error('Error: Problem reading input file '//trim(seedname)//'.mmn', stdout, seedname) +104 call io_error('Error: Problem reading input file '//trim(seedname)//'.amn', stdout, seedname) end subroutine overlap_read @@ -471,23 +564,36 @@ end subroutine overlap_read !~ end subroutine overlap_symmetrize !~![ysl-e] - !%%%%%%%%%%%%%%%%%%%%% - subroutine overlap_rotate - !%%%%%%%%%%%%%%%%%%%%% + !================================================! + subroutine overlap_rotate(a_matrix, m_matrix_orig, nntot, num_bands, timing_level, seedname, & + stdout) + !================================================! + ! !! Only used when interfaced to the CP code !! Not sure why this is done here and not in CP + ! + !================================================! - use w90_parameters, only: num_bands, a_matrix, m_matrix_orig, nntot, timing_level use w90_io, only: io_file_unit, io_error, io_stopwatch implicit none + integer, intent(in) :: nntot + integer, intent(in) :: stdout + integer, intent(in) :: num_bands + integer, intent(in) :: timing_level + + complex(kind=dp), intent(inout) :: m_matrix_orig(:, :, :, :) + complex(kind=dp), intent(inout) :: a_matrix(:, :, :) + + character(len=50), intent(in) :: seedname + integer :: lam_unit, info, inn, i, j real(kind=DP) :: lambda(num_bands, num_bands) real(kind=DP) :: AP(num_bands*(num_bands + 1)/2) real(kind=DP) :: eig(num_bands), work(3*num_bands) - if (timing_level > 1) call io_stopwatch('overlap: rotate', 1) + if (timing_level > 1) call io_stopwatch('overlap: rotate', 1, stdout, seedname) lam_unit = io_file_unit() open (unit=lam_unit, file='lambda.dat', & @@ -505,7 +611,7 @@ subroutine overlap_rotate CALL DSPEV('V', 'U', num_bands, AP, eig, lambda, num_bands, work, info) if (info .ne. 0) & - call io_error('Diagonalization of lambda in overlap_rotate failed') + call io_error('Diagonalization of lambda in overlap_rotate failed', stdout, seedname) ! For debugging !~ write(stdout,*) 'EIGENVALUES - CHECK WITH CP OUTPUT' @@ -539,102 +645,119 @@ subroutine overlap_rotate !~ enddo !~ stop - if (timing_level > 1) call io_stopwatch('overlap: rotate', 2) + if (timing_level > 1) call io_stopwatch('overlap: rotate', 2, stdout, seedname) return end subroutine overlap_rotate - !%%%%%%%%%%%%%%%%%%%%% - subroutine overlap_dealloc() - !%%%%%%%%%%%%%%%%%%%%% + !================================================! + subroutine overlap_dealloc(a_matrix, m_matrix, m_matrix_local, m_matrix_orig, & + m_matrix_orig_local, u_matrix, u_matrix_opt, seedname, stdout, comm) + !================================================! + ! !! Dellocate memory + ! + !================================================! - use w90_parameters, only: u_matrix, m_matrix, m_matrix_orig, & - a_matrix, u_matrix_opt, & - m_matrix_local, m_matrix_orig_local use w90_io, only: io_error implicit none + ! arguments + complex(kind=dp), allocatable, intent(inout) :: m_matrix(:, :, :, :) + complex(kind=dp), allocatable, intent(inout) :: u_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: m_matrix_orig(:, :, :, :) + complex(kind=dp), allocatable, intent(inout) :: a_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: u_matrix_opt(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: m_matrix_local(:, :, :, :) + complex(kind=dp), allocatable, intent(inout) :: m_matrix_orig_local(:, :, :, :) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + type(w90comm_type), intent(in) :: comm + + ! local variables integer :: ierr + logical :: on_root = .false. + + if (mpirank(comm) == 0) on_root = .true. if (allocated(u_matrix_opt)) then deallocate (u_matrix_opt, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating u_matrix_opt in overlap_dealloc') + if (ierr /= 0) call io_error('Error deallocating u_matrix_opt in overlap_dealloc', stdout, seedname) end if if (allocated(a_matrix)) then deallocate (a_matrix, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating a_matrix in overlap_dealloc') + if (ierr /= 0) call io_error('Error deallocating a_matrix in overlap_dealloc', stdout, seedname) end if ! if (on_root) then if (allocated(m_matrix_orig)) then deallocate (m_matrix_orig, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating m_matrix_orig in overlap_dealloc') + if (ierr /= 0) call io_error('Error deallocating m_matrix_orig in overlap_dealloc', stdout, seedname) endif ! endif if (allocated(m_matrix_orig_local)) then deallocate (m_matrix_orig_local, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating m_matrix_orig_local in overlap_dealloc') + if (ierr /= 0) call io_error('Error deallocating m_matrix_orig_local in overlap_dealloc', stdout, seedname) endif -!~![ysl-b] -!~ if (allocated( ph_g)) then -!~ deallocate( ph_g, stat=ierr ) -!~ if (ierr/=0) call io_error('Error deallocating ph_g in overlap_dealloc') -!~ endif -!~![ysl-e] - -! if (on_root) then -! deallocate ( m_matrix, stat=ierr ) -! if (ierr/=0) call io_error('Error deallocating m_matrix in overlap_dealloc') -! endif -! deallocate ( m_matrix_local, stat=ierr ) -! if (ierr/=0) call io_error('Error deallocating m_matrix_local in overlap_dealloc') -! deallocate ( u_matrix, stat=ierr ) -! if (ierr/=0) call io_error('Error deallocating u_matrix in overlap_dealloc') -! if (on_root) then - if (allocated(m_matrix)) then - deallocate (m_matrix, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating m_matrix in overlap_dealloc') + if (on_root) then + if (allocated(m_matrix)) then + deallocate (m_matrix, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating m_matrix in overlap_dealloc', stdout, seedname) + endif endif -! endif if (allocated(m_matrix_local)) then deallocate (m_matrix_local, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating m_matrix_local in overlap_dealloc') + if (ierr /= 0) call io_error('Error deallocating m_matrix_local in overlap_dealloc', stdout, seedname) endif if (allocated(u_matrix)) then deallocate (u_matrix, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating u_matrix in overlap_dealloc') + if (ierr /= 0) call io_error('Error deallocating u_matrix in overlap_dealloc', stdout, seedname) endif return end subroutine overlap_dealloc - !==================================================================! - subroutine overlap_project() - !==================================================================! + !================================================! + subroutine overlap_project(sitesym, m_matrix, m_matrix_local, u_matrix, nnlist, nntot, & + num_bands, num_kpts, num_wann, timing_level, lsitesymmetry, & + seedname, stdout, comm) + !================================================! !! Construct initial guess from the projection via a Lowdin transformation !! See section 3 of the CPC 2008 !! Note that in this subroutine num_wann = num_bands !! since, if we are here, then disentanglement = FALSE - ! ! - ! ! - !==================================================================! + ! + !================================================! use w90_constants use w90_io, only: io_error, io_stopwatch - use w90_parameters, only: num_bands, num_wann, num_kpts, timing_level, & - u_matrix, m_matrix, nntot, nnlist, & - m_matrix_local use w90_utility, only: utility_zgemm - use w90_parameters, only: lsitesymmetry !RS: - use w90_sitesym, only: sitesym_symmetrize_u_matrix !RS: - use w90_comms, only: my_node_id, num_nodes, & - comms_array_split, comms_scatterv, comms_gatherv + use w90_sitesym, only: sitesym_symmetrize_u_matrix + use w90_wannier90_types, only: sitesym_type implicit none - ! internal variables + type(sitesym_type), intent(in) :: sitesym + type(w90comm_type), intent(in) :: comm + + integer, intent(in) :: nnlist(:, :) + integer, intent(in) :: nntot + integer, intent(in) :: num_bands + integer, intent(in) :: num_kpts + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + integer, intent(in) :: timing_level + + complex(kind=dp), intent(inout) :: m_matrix(:, :, :, :) + complex(kind=dp), intent(inout) :: u_matrix(:, :, :) + complex(kind=dp), intent(inout) :: m_matrix_local(:, :, :, :) + + logical, intent(in) :: lsitesymmetry + + character(len=50), intent(in) :: seedname + + ! local variables integer :: i, j, m, nkp, info, ierr, nn, nkp2 real(kind=dp), allocatable :: svals(:) real(kind=dp) :: rwork(5*num_bands) @@ -642,22 +765,31 @@ subroutine overlap_project() complex(kind=dp), allocatable :: cwork(:) complex(kind=dp), allocatable :: cz(:, :) complex(kind=dp), allocatable :: cvdag(:, :) - ! Needed to split an array on different nodes - integer, dimension(0:num_nodes - 1) :: counts - integer, dimension(0:num_nodes - 1) :: displs - if (timing_level > 1) call io_stopwatch('overlap: project', 1) + ! pllel setup + integer, allocatable :: counts(:) + integer, allocatable :: displs(:) + integer :: num_nodes, my_node_id + logical :: on_root = .false. + + num_nodes = mpisize(comm) + my_node_id = mpirank(comm) + if (my_node_id == 0) on_root = .true. + allocate (counts(0:num_nodes - 1)) + allocate (displs(0:num_nodes - 1)) - call comms_array_split(num_kpts, counts, displs) + if (timing_level > 1) call io_stopwatch('overlap: project', 1, stdout, seedname) + + call comms_array_split(num_kpts, counts, displs, comm) allocate (svals(num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating svals in overlap_project') + if (ierr /= 0) call io_error('Error in allocating svals in overlap_project', stdout, seedname) allocate (cz(num_bands, num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cz in overlap_project') + if (ierr /= 0) call io_error('Error in allocating cz in overlap_project', stdout, seedname) allocate (cvdag(num_bands, num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cvdag in overlap_project') + if (ierr /= 0) call io_error('Error in allocating cvdag in overlap_project', stdout, seedname) allocate (cwork(4*num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cwork in overlap_project') + if (ierr /= 0) call io_error('Error in allocating cwork in overlap_project', stdout, seedname) ! Calculate the transformation matrix CU = CS^(-1/2).CA, ! where CS = CA.CA^\dagger. @@ -675,7 +807,7 @@ subroutine overlap_project() if (info .lt. 0) then write (stdout, *) ' THE ', -info, '-TH ARGUMENT HAD ILLEGAL VALUE' endif - call io_error('Error in ZGESVD in overlap_project') + call io_error('Error in ZGESVD in overlap_project', stdout, seedname) endif ! u_matrix(:,:,nkp)=matmul(cz,cvdag) @@ -697,7 +829,7 @@ subroutine overlap_project() write (stdout, '(1x,a,f12.6,1x,f12.6)') & '[u_matrix.transpose(u_matrix)]_ij= ', & real(ctmp2, dp), aimag(ctmp2) - call io_error('Error in unitarity of initial U in overlap_project') + call io_error('Error in unitarity of initial U in overlap_project', stdout, seedname) endif if ((i .ne. j) .and. (abs(ctmp2) .gt. eps5)) then write (stdout, *) ' ERROR: unitarity of initial U' @@ -706,14 +838,15 @@ subroutine overlap_project() write (stdout, '(1x,a,f12.6,1x,f12.6)') & '[u_matrix.transpose(u_matrix)]_ij= ', & real(ctmp2, dp), aimag(ctmp2) - call io_error('Error in unitarity of initial U in overlap_project') + call io_error('Error in unitarity of initial U in overlap_project', stdout, seedname) endif enddo enddo enddo ! NKP - if (lsitesymmetry) call sitesym_symmetrize_u_matrix(num_wann, u_matrix) !RS: update U(Rk) + if (lsitesymmetry) call sitesym_symmetrize_u_matrix(sitesym, u_matrix, num_bands, num_wann, & + num_kpts, num_wann, seedname, stdout) !RS: update U(Rk) ! so now we have the U's that rotate the wavefunctions at each k-point. ! the matrix elements M_ij have also to be updated @@ -721,49 +854,58 @@ subroutine overlap_project() do nn = 1, nntot nkp2 = nnlist(nkp + displs(my_node_id), nn) ! cvdag = U^{dagger} . M (use as workspace) - call utility_zgemm(cvdag, u_matrix(:, :, nkp + displs(my_node_id)), 'C', m_matrix_local(:, :, nn, nkp), 'N', num_wann) + call utility_zgemm(cvdag, u_matrix(:, :, nkp + displs(my_node_id)), 'C', & + m_matrix_local(:, :, nn, nkp), 'N', num_wann) ! cz = cvdag . U call utility_zgemm(cz, cvdag, 'N', u_matrix(:, :, nkp2), 'N', num_wann) m_matrix_local(:, :, nn, nkp) = cz(:, :) end do end do call comms_gatherv(m_matrix_local, num_wann*num_wann*nntot*counts(my_node_id), & - m_matrix, num_wann*num_wann*nntot*counts, num_wann*num_wann*nntot*displs) + m_matrix, num_wann*num_wann*nntot*counts, num_wann*num_wann*nntot*displs, & + stdout, seedname, comm) deallocate (cwork, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cwork in overlap_project') + if (ierr /= 0) call io_error('Error in deallocating cwork in overlap_project', stdout, seedname) deallocate (cvdag, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cvdag in overlap_project') + if (ierr /= 0) call io_error('Error in deallocating cvdag in overlap_project', stdout, seedname) deallocate (cz, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cz in overlap_project') + if (ierr /= 0) call io_error('Error in deallocating cz in overlap_project', stdout, seedname) deallocate (svals, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating svals in overlap_project') + if (ierr /= 0) call io_error('Error in deallocating svals in overlap_project', stdout, seedname) - if (timing_level > 1) call io_stopwatch('overlap: project', 2) + if (timing_level > 1) call io_stopwatch('overlap: project', 2, stdout, seedname) return end subroutine overlap_project ![ysl-b] - !==================================================================! - subroutine overlap_project_gamma() - !==================================================================! + !================================================! + subroutine overlap_project_gamma(m_matrix, u_matrix, nntot, num_wann, timing_level, seedname, & + stdout) + !================================================! !! Construct initial guess from the projection via a Lowdin transformation !! See section 3 of the CPC 2008 !! Note that in this subroutine num_wann = num_bands !! since, if we are here, then disentanglement = FALSE !! Gamma specific version - ! ! - !==================================================================! + ! + !================================================! use w90_constants use w90_io, only: io_error, io_stopwatch - use w90_parameters, only: num_wann, timing_level, & - u_matrix, m_matrix, nntot!,num_kpts,nnlist use w90_utility, only: utility_zgemm implicit none + integer, intent(in) :: nntot + integer, intent(in) :: stdout + integer, intent(in) :: timing_level + integer, intent(in) :: num_wann + complex(kind=dp), intent(inout) :: m_matrix(:, :, :, :) + complex(kind=dp), intent(inout) :: u_matrix(:, :, :) + character(len=50), intent(in) :: seedname + ! internal variables integer :: i, j, m, info, ierr, nn real(kind=dp) :: rtmp2 @@ -781,27 +923,27 @@ subroutine overlap_project_gamma() !~ integer :: n,mdev, ndev, nndev,p(1) !~ real(kind=dp) :: dev, dev_tmp - if (timing_level > 1) call io_stopwatch('overlap: project_gamma', 1) + if (timing_level > 1) call io_stopwatch('overlap: project_gamma', 1, stdout, seedname) !~ allocate(ph_g(num_wann),stat=ierr) !~ if (ierr/=0) call io_error('Error in allocating ph_g in overlap_project_gamma') ! internal variables allocate (u_matrix_r(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating u_matrix_r in overlap_project_gamma') + if (ierr /= 0) call io_error('Error in allocating u_matrix_r in overlap_project_gamma', stdout, seedname) !~ allocate(u_cmp(num_wann),stat=ierr) !~ if (ierr/=0) call io_error('Error in allocating u_cmp in overlap_project_gamma') allocate (svals(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating svals in overlap_project_gamma') + if (ierr /= 0) call io_error('Error in allocating svals in overlap_project_gamma', stdout, seedname) allocate (work(5*num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating work in overlap_project_gamma') + if (ierr /= 0) call io_error('Error in allocating work in overlap_project_gamma', stdout, seedname) allocate (rz(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating rz in overlap_project_gamma') + if (ierr /= 0) call io_error('Error in allocating rz in overlap_project_gamma', stdout, seedname) allocate (rv(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating rv in overlap_project_gamma') + if (ierr /= 0) call io_error('Error in allocating rv in overlap_project_gamma', stdout, seedname) allocate (cz(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cz in overlap_project_gamma') + if (ierr /= 0) call io_error('Error in allocating cz in overlap_project_gamma', stdout, seedname) allocate (cvdag(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cvdag in overlap_project_gamma') + if (ierr /= 0) call io_error('Error in allocating cvdag in overlap_project_gamma', stdout, seedname) ! !~ ! If a wavefunction is real except for a phase factor e^(i*phi_m) = ph_g(m) @@ -866,7 +1008,7 @@ subroutine overlap_project_gamma() if (info .lt. 0) then write (stdout, *) 'THE ', -info, '-TH ARGUMENT HAD ILLEGAL VALUE' endif - call io_error('overlap_project_gamma: problem in DGESVD 1') + call io_error('overlap_project_gamma: problem in DGESVD 1', stdout, seedname) endif call dgemm('N', 'N', num_wann, num_wann, num_wann, 1.0_dp, & @@ -886,7 +1028,7 @@ subroutine overlap_project_gamma() write (stdout, '(1x,a,f12.6)') & '[u_matrix.transpose(u_matrix)]_ij= ', & rtmp2 - call io_error('Error in unitarity of initial U in overlap_project_gamma') + call io_error('Error in unitarity of initial U in overlap_project_gamma', stdout, seedname) endif if ((i .ne. j) .and. (abs(rtmp2) .gt. eps5)) then write (stdout, *) ' ERROR: unitarity of initial U' @@ -894,7 +1036,7 @@ subroutine overlap_project_gamma() write (stdout, '(1x,a,f12.6,1x,f12.6)') & '[u_matrix.transpose(u_matrix)]_ij= ', & rtmp2 - call io_error('Error in unitarity of initial U in overlap_project_gamma') + call io_error('Error in unitarity of initial U in overlap_project_gamma', stdout, seedname) endif enddo enddo @@ -913,23 +1055,23 @@ subroutine overlap_project_gamma() end do deallocate (cvdag, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cvdag in overlap_project_gamma') + if (ierr /= 0) call io_error('Error in deallocating cvdag in overlap_project_gamma', stdout, seedname) deallocate (cz, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cz in overlap_project_gamma') + if (ierr /= 0) call io_error('Error in deallocating cz in overlap_project_gamma', stdout, seedname) deallocate (rv, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating rv in overlap_project_gamma') + if (ierr /= 0) call io_error('Error in deallocating rv in overlap_project_gamma', stdout, seedname) deallocate (rz, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating rz in overlap_project_gamma') + if (ierr /= 0) call io_error('Error in deallocating rz in overlap_project_gamma', stdout, seedname) deallocate (work, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating work in overlap_project_gamma') + if (ierr /= 0) call io_error('Error in deallocating work in overlap_project_gamma', stdout, seedname) deallocate (svals, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating svals in overlap_project_gamma') + if (ierr /= 0) call io_error('Error in deallocating svals in overlap_project_gamma', stdout, seedname) !~ deallocate(u_cmp,stat=ierr) !~ if (ierr/=0) call io_error('Error in deallocating u_cmp in overlap_project_gamma') deallocate (u_matrix_r, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating u_matrix_r in overlap_project_gamma') + if (ierr /= 0) call io_error('Error in deallocating u_matrix_r in overlap_project_gamma', stdout, seedname) - if (timing_level > 1) call io_stopwatch('overlap: project_gamma', 2) + if (timing_level > 1) call io_stopwatch('overlap: project_gamma', 2, stdout, seedname) return diff --git a/src/parameters.F90 b/src/parameters.F90 deleted file mode 100644 index 0a28ecab2..000000000 --- a/src/parameters.F90 +++ /dev/null @@ -1,6512 +0,0 @@ -!-*- mode: F90 -*-! -!------------------------------------------------------------! -! This file is distributed as part of the Wannier90 code and ! -! under the terms of the GNU General Public License. See the ! -! file `LICENSE' in the root directory of the Wannier90 ! -! distribution, or http://www.gnu.org/copyleft/gpl.txt ! -! ! -! The webpage of the Wannier90 code is www.wannier.org ! -! ! -! The Wannier90 code is hosted on GitHub: ! -! ! -! https://github.com/wannier-developers/wannier90 ! -!------------------------------------------------------------! - -module w90_parameters - !! This module contains parameters to control the actions of wannier90. - !! Also routines to read the parameters and write them out again. - - use w90_constants, only: dp - use w90_io, only: stdout, maxlen - - implicit none - - private - - !Input - integer, public, save :: iprint - !! Controls the verbosity of the output - character(len=20), public, save :: energy_unit - !! Units for energy - character(len=20), public, save :: length_unit - !! Units for length - logical, public, save :: wvfn_formatted - !! Read the wvfn from fortran formatted file - logical, public, save :: spn_formatted - !! Read the spin from fortran formatted file - logical, public, save :: uHu_formatted - logical, public, save :: berry_uHu_formatted - !! Read the uHu from fortran formatted file - integer, public, save :: spin - !! Spin up=1 down=2 - integer, public, save :: num_bands - !! Number of bands - integer, public, save :: num_dump_cycles - !! Number of steps before writing checkpoint - integer, public, save :: num_print_cycles - !! Number of steps between writing output - integer, public, save :: slwf_num - !! Number of objective Wannier functions (others excluded from spread functional) - logical, public, save :: selective_loc - !! Selective localization - logical, public, save :: slwf_constrain - !! Constrained centres - real(kind=dp), allocatable, public, save :: ccentres_frac(:, :) - real(kind=dp), allocatable, public, save :: ccentres_cart(:, :) - real(kind=dp), public, save :: slwf_lambda - !! Centre constraints for each Wannier function. Co-ordinates of centre constraint defaults - !! to centre of trial orbital. Individual Lagrange multipliers, lambdas, default to global Lagrange multiplier. - character(len=50), public, save :: devel_flag - ! Adaptive vs. fixed smearing stuff [GP, Jul 12, 2012] - ! Only internal, always use the local variables defined by each module - ! that take this value as default - logical :: adpt_smr - real(kind=dp) :: adpt_smr_fac - real(kind=dp) :: adpt_smr_max - real(kind=dp) :: smr_fixed_en_width - ! GP: added a flag to check if this is the first run of param_read in library mode or not - logical, public, save :: library_param_read_first_pass - !IVO - logical, public, save :: spin_moment - real(kind=dp), public, save :: spin_axis_polar - real(kind=dp), public, save :: spin_axis_azimuth - logical, public, save :: use_degen_pert - real(kind=dp), public, save :: degen_thr - logical, public, save :: spin_decomp - integer, public, save :: num_valence_bands - logical :: found_fermi_energy - real(kind=dp), public, save :: scissors_shift - !IVO_END - ! [gp-begin, Apr 20, 2012] Smearing type - ! The prefactor is given with the above parameters smr_... - ! This is an internal variable, obtained from the input string smr_type - ! Only internal, always use the local variables defined by each module - ! that take this value as default - integer :: smr_index - ! [gp-end] - integer, allocatable, public, save :: exclude_bands(:) - integer, public, save :: num_wann - !! number of wannier functions - integer, public, save :: mp_grid(3) - !! Dimensions of the Monkhorst-Pack grid -! logical, public, save :: automatic_mp_grid - logical, public, save :: gamma_only - !! Use the special Gamma-point routines - real(kind=dp), public, save :: dis_win_min - !! lower bound of the disentanglement outer window - real(kind=dp), public, save :: dis_win_max - !! upper bound of the disentanglement outer window - real(kind=dp), public, save :: dis_froz_min - !! lower bound of the disentanglement inner (frozen) window - real(kind=dp), public, save :: dis_froz_max - !! upper bound of the disentanglement inner (frozen) window - integer, public, save :: dis_num_iter - !! number of disentanglement iteration steps - real(kind=dp), public, save :: dis_mix_ratio - !! Mixing ratio for the disentanglement routine - real(kind=dp), public, save :: dis_conv_tol - !! Convergence tolerance for the disentanglement - integer, public, save :: dis_conv_window - !! Size of the convergence window for disentanglement - ! GS-start - integer, public, save :: dis_spheres_first_wann - integer, public, save :: dis_spheres_num - real(kind=dp), allocatable, public, save :: dis_spheres(:, :) - ! GS-end - integer, public, save :: num_iter - !! Number of wannierisation iterations - integer, public, save :: num_cg_steps - !! Number of Conjugate Gradient steps - real(kind=dp), public, save :: conv_tol - integer, public, save :: conv_window - logical, public, save :: wannier_plot - integer, allocatable, public, save :: wannier_plot_list(:) - integer, public, save :: wannier_plot_supercell(3) - character(len=20), public, save :: wannier_plot_format - character(len=20), public, save :: wannier_plot_mode - character(len=20), public, save :: wannier_plot_spinor_mode - logical, public, save :: wannier_plot_spinor_phase - logical, public, save :: write_u_matrices - logical, public, save :: bands_plot - logical, public, save :: write_bvec - integer, public, save :: bands_num_points - character(len=20), public, save :: bands_plot_format - character(len=20), public, save :: bands_plot_mode - integer, allocatable, public, save :: bands_plot_project(:) - integer, public, save :: bands_plot_dim - logical, public, save :: write_hr - logical, public, save :: write_rmn - logical, public, save :: write_tb - real(kind=dp), public, save :: hr_cutoff - real(kind=dp), public, save :: dist_cutoff - character(len=20), public, save :: dist_cutoff_mode - real(kind=dp), public, save :: dist_cutoff_hc - character(len=20), public, save :: one_dim_axis - logical, public, save :: use_ws_distance - real(kind=dp), public, save :: ws_distance_tol - !! absolute tolerance for the distance to equivalent positions - integer, public, save :: ws_search_size(3) - !! maximum extension in each direction of the supercell of the BvK cell - !! to search for points inside the Wigner-Seitz cell - logical, public, save :: fermi_surface_plot - integer, public, save :: fermi_surface_num_points - character(len=20), public, save :: fermi_surface_plot_format - real(kind=dp), save :: fermi_energy - - ! module k p a t h - logical, public, save :: kpath - character(len=20), public, save :: kpath_task - integer, public, save :: kpath_num_points - character(len=20), public, save :: kpath_bands_colour - - ! module k s l i c e - logical, public, save :: kslice - character(len=20), public, save :: kslice_task - real(kind=dp), public, save :: kslice_corner(3) - real(kind=dp), public, save :: kslice_b1(3) - real(kind=dp), public, save :: kslice_b2(3) - integer, public, save :: kslice_2dkmesh(2) - character(len=20), public, save :: kslice_fermi_lines_colour - - ! module d o s - logical, public, save :: dos -! No need to save 'dos_plot', only used here (introduced 'dos_task') - logical, public :: dos_plot - character(len=20), public, save :: dos_task - logical, public, save :: dos_adpt_smr - real(kind=dp), public, save :: dos_adpt_smr_fac - integer, public, save :: dos_smr_index - real(kind=dp), public, save :: dos_smr_fixed_en_width - real(kind=dp), public, save :: dos_adpt_smr_max - real(kind=dp), public, save :: dos_energy_max - real(kind=dp), public, save :: dos_energy_min - real(kind=dp), public, save :: dos_energy_step - integer, public, save :: num_dos_project - integer, allocatable, public, save :: dos_project(:) -! character(len=20), public, save :: dos_plot_format - real(kind=dp), public, save :: dos_kmesh_spacing - integer, public, save :: dos_kmesh(3) -! real(kind=dp), public, save :: dos_gaussian_width - -! Module b e r r y - logical, public, save :: berry - character(len=120), public, save :: berry_task - real(kind=dp), public, save :: berry_kmesh_spacing - integer, public, save :: berry_kmesh(3) - ! --------------remove eventually---------------- -! integer, public, save :: alpha -! integer, public, save :: beta -! integer, public, save :: gamma - ! --------------remove eventually---------------- - integer, public, save :: berry_curv_adpt_kmesh - real(kind=dp), public, save :: berry_curv_adpt_kmesh_thresh - character(len=20), public, save :: berry_curv_unit - logical, public, save :: kubo_adpt_smr - real(kind=dp), public, save :: kubo_adpt_smr_fac - integer, public, save :: kubo_smr_index - real(kind=dp), public, save :: kubo_smr_fixed_en_width - real(kind=dp), public, save :: kubo_adpt_smr_max - integer, public, save :: sc_phase_conv - real(kind=dp), public, save :: sc_eta - real(kind=dp), public, save :: sc_w_thr - logical, public, save :: sc_use_eta_corr - logical, public, save :: wanint_kpoint_file -! logical, public, save :: sigma_abc_onlyorb - logical, public, save :: transl_inv - real(kind=dp), public, save :: kdotp_kpoint(3) - integer, public, save :: kdotp_num_bands - integer, allocatable, public, save :: kdotp_bands(:) - - ! spin Hall conductivity - logical, public, save :: shc_freq_scan - integer, public, save :: shc_alpha - integer, public, save :: shc_beta - integer, public, save :: shc_gamma - logical, public, save :: shc_bandshift - integer, public, save :: shc_bandshift_firstband - real(kind=dp), public, save :: shc_bandshift_energyshift - character(len=120), public, save :: shc_method - - logical, public, save :: gyrotropic - character(len=120), public, save :: gyrotropic_task - integer, public, save :: gyrotropic_kmesh(3) - real(kind=dp), public, save :: gyrotropic_kmesh_spacing - integer, public, save :: gyrotropic_smr_index - real(kind=dp), public, save :: gyrotropic_smr_fixed_en_width - real(kind=dp) :: gyrotropic_freq_min - real(kind=dp) :: gyrotropic_freq_max - real(kind=dp) :: gyrotropic_freq_step - integer, public, save :: gyrotropic_nfreq - complex(kind=dp), allocatable, public, save :: gyrotropic_freq_list(:) - real(kind=dp), public, save :: gyrotropic_box_corner(3), gyrotropic_box(3, 3) - real(kind=dp) :: gyrotropic_box_tmp(3) - real(kind=dp), public, save :: gyrotropic_degen_thresh - integer, allocatable, public, save :: gyrotropic_band_list(:) - integer, public, save :: gyrotropic_num_bands - real(kind=dp) :: smr_max_arg - real(kind=dp), public, save :: gyrotropic_smr_max_arg - real(kind=dp), public, save :: gyrotropic_eigval_max - - logical :: fermi_energy_scan - real(kind=dp) :: fermi_energy_min - real(kind=dp) :: fermi_energy_max - real(kind=dp) :: fermi_energy_step - integer, public, save :: nfermi - real(kind=dp), allocatable, public, save :: fermi_energy_list(:) - - real(kind=dp) :: kubo_freq_min - real(kind=dp) :: kubo_freq_max - real(kind=dp) :: kubo_freq_step - integer, public, save :: kubo_nfreq - complex(kind=dp), allocatable, public, save :: kubo_freq_list(:) - real(kind=dp), public, save :: kubo_eigval_max -! Module s p i n - real(kind=dp), public, save :: spin_kmesh_spacing - integer, public, save :: spin_kmesh(3) - - ! [gp-begin, Apr 13, 2012] - ! Global interpolation k mesh variables - ! These don't need to be public, since their values are copied in the variables of the - ! local interpolation meshes. JRY: added save attribute - real(kind=dp), save :: kmesh_spacing - integer, save :: kmesh(3) - logical, save :: global_kmesh_set - ! [gp-end] - - ! [gp-begin, Jun 1, 2012] - ! GeneralInterpolator variables - logical, public, save :: geninterp - logical, public, save :: geninterp_alsofirstder - logical, public, save :: geninterp_single_file - ! [gp-end, Jun 1, 2012] - - ! [gp-begin, Apr 12, 2012] - ! BoltzWann variables - logical, public, save :: boltzwann - logical, public, save :: boltz_calc_also_dos - integer, public, save :: boltz_2d_dir_num - character(len=4), save :: boltz_2d_dir - real(kind=dp), public, save :: boltz_dos_energy_step - real(kind=dp), public, save :: boltz_dos_energy_min - real(kind=dp), public, save :: boltz_dos_energy_max - logical, public, save :: boltz_dos_adpt_smr - real(kind=dp), public, save :: boltz_dos_smr_fixed_en_width - real(kind=dp), public, save :: boltz_dos_adpt_smr_fac - real(kind=dp), public, save :: boltz_dos_adpt_smr_max - real(kind=dp), public, save :: boltz_mu_min - real(kind=dp), public, save :: boltz_mu_max - real(kind=dp), public, save :: boltz_mu_step - real(kind=dp), public, save :: boltz_temp_min - real(kind=dp), public, save :: boltz_temp_max - real(kind=dp), public, save :: boltz_temp_step - real(kind=dp), public, save :: boltz_kmesh_spacing - integer, public, save :: boltz_kmesh(3) - real(kind=dp), public, save :: boltz_tdf_energy_step - integer, public, save :: boltz_TDF_smr_index - integer, public, save :: boltz_dos_smr_index - real(kind=dp), public, save :: boltz_relax_time - real(kind=dp), public, save :: boltz_TDF_smr_fixed_en_width - logical, public, save :: boltz_bandshift - integer, public, save :: boltz_bandshift_firstband - real(kind=dp), public, save :: boltz_bandshift_energyshift - ! [gp-end, Apr 12, 2012] - - logical, public, save :: transport - logical, public, save :: tran_easy_fix - character(len=20), public, save :: transport_mode - real(kind=dp), public, save :: tran_win_min - real(kind=dp), public, save :: tran_win_max - real(kind=dp), public, save :: tran_energy_step - integer, public, save :: tran_num_bb - integer, public, save :: tran_num_ll - integer, public, save :: tran_num_rr - integer, public, save :: tran_num_cc - integer, public, save :: tran_num_lc - integer, public, save :: tran_num_cr - integer, public, save :: tran_num_bandc - logical, public, save :: tran_write_ht - logical, public, save :: tran_read_ht - logical, public, save :: tran_use_same_lead - integer, public, save :: tran_num_cell_ll - integer, public, save :: tran_num_cell_rr - real(kind=dp), public, save :: tran_group_threshold - real(kind=dp), public, save :: translation_centre_frac(3) - integer, public, save :: num_shells - !! no longer an input keyword - logical, public, save :: skip_B1_tests - !! do not check the B1 condition - logical, public, save :: explicit_nnkpts - !! nnkpts block is in the input file (allowed only for post-proc setup) - integer, allocatable, public, save :: shell_list(:) - real(kind=dp), allocatable, public, save :: kpt_latt(:, :) - !! kpoints in lattice vecs - real(kind=dp), public, save :: real_lattice(3, 3) - logical, public, save :: postproc_setup - logical, public, save :: cp_pp - !! Car-Parinello post-proc flag/transport - - logical, public, save :: calc_only_A - logical, public, save :: use_bloch_phases - character(len=20), public, save :: restart - logical, public, save :: write_r2mn - logical, public, save :: guiding_centres - integer, public, save :: num_guide_cycles - integer, public, save :: num_no_guide_iter - real(kind=dp), public, save :: fixed_step - real(kind=dp), public, save :: trial_step - logical, public, save :: precond - logical, public, save :: write_proj - integer, public, save :: timing_level - logical, public, save :: spinors !are our WF spinors? - integer, public, save :: num_elec_per_state - logical, public, save :: translate_home_cell - logical, public, save :: write_xyz - logical, public, save :: write_hr_diag - real(kind=dp), public, save :: conv_noise_amp - integer, public, save :: conv_noise_num - real(kind=dp), public, save :: wannier_plot_radius - real(kind=dp), public, save :: wannier_plot_scale - integer, public, save :: search_shells !for kmesh - real(kind=dp), public, save :: kmesh_tol - integer, public, save :: optimisation - ! aam: for WF-based calculation of vdW C6 coefficients - logical, public, save :: write_vdw_data - - ! Restarts - real(kind=dp), public, save :: omega_invariant - character(len=20), public, save :: checkpoint - logical, public, save :: have_disentangled - - ! Atom sites - real(kind=dp), allocatable, public, save :: atoms_pos_frac(:, :, :) - real(kind=dp), allocatable, public, save :: atoms_pos_cart(:, :, :) - integer, allocatable, public, save :: atoms_species_num(:) - character(len=maxlen), allocatable, public, save :: atoms_label(:) - character(len=2), allocatable, public, save :: atoms_symbol(:) - integer, public, save :: num_atoms - integer, public, save :: num_species - - ! Projections - logical, public, save :: lhasproj - real(kind=dp), allocatable, public, save :: input_proj_site(:, :) - integer, allocatable, public, save :: input_proj_l(:) - integer, allocatable, public, save :: input_proj_m(:) - integer, allocatable, public, save :: input_proj_s(:) - real(kind=dp), allocatable, public, save :: input_proj_s_qaxis(:, :) - real(kind=dp), allocatable, public, save :: input_proj_z(:, :) - real(kind=dp), allocatable, public, save :: input_proj_x(:, :) - integer, allocatable, public, save :: input_proj_radial(:) - real(kind=dp), allocatable, public, save :: input_proj_zona(:) - real(kind=dp), allocatable, public, save :: proj_site(:, :) - integer, allocatable, public, save :: proj_l(:) - integer, allocatable, public, save :: proj_m(:) - integer, allocatable, public, save :: proj_s(:) - real(kind=dp), allocatable, public, save :: proj_s_qaxis(:, :) - real(kind=dp), allocatable, public, save :: proj_z(:, :) - real(kind=dp), allocatable, public, save :: proj_x(:, :) - integer, allocatable, public, save :: proj_radial(:) - real(kind=dp), allocatable, public, save :: proj_zona(:) - integer, public, save :: num_proj - ! projections selection - logical, public, save :: lselproj - integer, public, save :: num_select_projections - integer, allocatable, public, save :: select_projections(:) - integer, allocatable, public, save :: proj2wann_map(:) - ! a u t o m a t i c p r o j e c t i o n s - ! vv: Writes a new block in .nnkp - logical, public, save :: auto_projections - - !parameters dervied from input - integer, public, save :: num_kpts - real(kind=dp), public, save :: recip_lattice(3, 3) - real(kind=dp), public, save :: cell_volume - real(kind=dp), public, save :: real_metric(3, 3) - real(kind=dp), public, save :: recip_metric(3, 3) - integer, public, save :: bands_num_spec_points - character(len=20), allocatable, public, save ::bands_label(:) - real(kind=dp), allocatable, public, save ::bands_spec_points(:, :) - real(kind=dp), allocatable, public, save ::kpt_cart(:, :) !kpoints in cartesians - logical, public, save :: disentanglement - real(kind=dp), public, save :: lenconfac - integer, public, save :: num_wannier_plot - integer, public, save :: num_bands_project - integer, public, save :: num_exclude_bands - logical, public, save :: lfixstep - - ! kmesh parameters (set in kmesh) - - integer, public, save :: nnh ! the number of b-directions (bka) - integer, public, save :: nntot ! total number of neighbours for each k-point - integer, public, save, allocatable :: nnlist(:, :) ! list of neighbours for each k-point - integer, public, save, allocatable :: neigh(:, :) - integer, public, save, allocatable :: nncell(:, :, :) ! gives BZ of each neighbour of each k-point - real(kind=dp), public, save :: wbtot - real(kind=dp), public, save, allocatable :: wb(:) ! weights associated with neighbours of each k-point - real(kind=dp), public, save, allocatable :: bk(:, :, :) ! the b-vectors that go from each k-point to its neighbours - real(kind=dp), public, save, allocatable :: bka(:, :) ! the b-directions from 1st k-point to its neighbours - - ! disentangle parameters - integer, public, save, allocatable :: ndimwin(:) - logical, public, save, allocatable :: lwindow(:, :) - logical, public, save :: frozen_states - - ! a_matrix and m_matrix_orig can be calculated internally from bloch states - ! or read in from an ab-initio grid - ! a_matrix = projection of trial orbitals on bloch states - ! m_matrix_orig = overlap of bloch states - - complex(kind=dp), allocatable, save, public :: a_matrix(:, :, :) - complex(kind=dp), allocatable, save, public :: m_matrix_orig(:, :, :, :) - complex(kind=dp), allocatable, save, public :: m_matrix_orig_local(:, :, :, :) - real(kind=dp), allocatable, save, public :: eigval(:, :) - logical, save, public :: eig_found - -! $![ysl-b] -! $ ! ph_g = phase factor of Bloch functions at Gamma -! $ ! assuming that Bloch functions at Gamma are real except this phase factor -! $ complex(kind=dp), allocatable, save, public :: ph_g(:) -! $![ysl-e] - - ! u_matrix_opt gives the num_wann dimension optimal subspace from the - ! original bloch states - - complex(kind=dp), allocatable, save, public :: u_matrix_opt(:, :, :) - - ! u_matrix gives the unitary rotations from the optimal subspace to the - ! optimally smooth states. - ! m_matrix we store here, becuase it is needed for restart of wannierise - - complex(kind=dp), allocatable, save, public :: u_matrix(:, :, :) - complex(kind=dp), allocatable, save, public :: m_matrix(:, :, :, :) - complex(kind=dp), allocatable, save, public :: m_matrix_local(:, :, :, :) - - ! RS: symmetry-adapted Wannier functions - logical, public, save :: lsitesymmetry = .false. - real(kind=dp), public, save :: symmetrize_eps = 1.d-3 - - ! The maximum number of shells we need to satisfy B1 condition in kmesh - integer, parameter, public :: max_shells = 6 - integer, parameter, public :: num_nnmax = 12 - - ! Are we running as a library - logical, save, public :: library = .false. - - ! Are we running postw90? - logical, save, public :: ispostw90 = .false. - - ! IVO - ! Are we running postw90 starting from an effective model? - logical, save, public :: effective_model = .false. - - ! Wannier centres and spreads - real(kind=dp), public, save, allocatable :: wannier_centres(:, :) - real(kind=dp), public, save, allocatable :: wannier_spreads(:) - real(kind=dp), public, save :: omega_total - real(kind=dp), public, save :: omega_tilde - ! [ omega_invariant is declared above ] - - ! For Hamiltonian matrix in WF representation - logical, public, save :: automatic_translation - integer, public, save :: one_dim_dir - - ! Private data - integer :: num_lines - character(len=maxlen), allocatable :: in_data(:) - character(len=maxlen) :: ctmp - logical :: ltmp - ! AAM_2016-09-15: hr_plot is a deprecated input parameter. Replaced by write_hr. - logical :: hr_plot - - public :: param_read - public :: param_write - public :: param_postw90_write - public :: param_dealloc - public :: param_write_header - public :: param_write_chkpt - public :: param_read_chkpt - public :: param_lib_set_atoms - public :: param_memory_estimate - public :: param_get_smearing_type - public :: param_get_convention_type - public :: param_dist - public :: param_chkpt_dist - -contains - - !==================================================================! - subroutine param_read() - !==================================================================! - ! ! - !! Read parameters and calculate derived values - !! - !! Note on parallelization: this function should be called - !! from the root node only! - !! - ! ! - !=================================================================== - use w90_constants, only: bohr, eps6, cmplx_i - use w90_utility, only: utility_recip_lattice, utility_metric - use w90_io, only: io_error, io_file_unit, seedname, post_proc_flag - implicit none - - !local variables - real(kind=dp) :: real_lattice_tmp(3, 3) - integer :: nkp, i, j, n, k, itmp, i_temp, i_temp2, eig_unit, loop, ierr, iv_temp(3), rows - logical :: found, found2, lunits, chk_found - character(len=6) :: spin_str - real(kind=dp) :: cosa(3), rv_temp(3) - integer, allocatable, dimension(:, :) :: nnkpts_block - integer, allocatable, dimension(:) :: nnkpts_idx - - call param_in_file - - !%%%%%%%%%%%%%%%% - ! Site symmetry - !%%%%%%%%%%%%%%%% - - ! default value is lsitesymmetry=.false. - call param_get_keyword('site_symmetry', found, l_value=lsitesymmetry)!YN: - - ! default value is symmetrize_eps=0.001 - call param_get_keyword('symmetrize_eps', found, r_value=symmetrize_eps)!YN: - - !%%%%%%%%%%%%%%%% - ! Transport - !%%%%%%%%%%%%%%%% - - transport = .false. - call param_get_keyword('transport', found, l_value=transport) - - tran_read_ht = .false. - call param_get_keyword('tran_read_ht', found, l_value=tran_read_ht) - - tran_easy_fix = .false. - call param_get_keyword('tran_easy_fix', found, l_value=tran_easy_fix) - - if (transport .and. tran_read_ht) restart = ' ' - - !%%%%%%%%%%%%%%%% - !System variables - !%%%%%%%%%%%%%%%% - - timing_level = 1 ! Verbosity of timing output info - call param_get_keyword('timing_level', found, i_value=timing_level) - - iprint = 1 ! Verbosity - call param_get_keyword('iprint', found, i_value=iprint) - - optimisation = 3 ! Verbosity - call param_get_keyword('optimisation', found, i_value=optimisation) - - if (transport .and. tran_read_ht) goto 301 - - !ivo - call param_get_keyword('effective_model', found, l_value=effective_model) - - energy_unit = 'ev' ! - call param_get_keyword('energy_unit', found, c_value=energy_unit) - - length_unit = 'ang' ! - lenconfac = 1.0_dp - call param_get_keyword('length_unit', found, c_value=length_unit) - if (length_unit .ne. 'ang' .and. length_unit .ne. 'bohr') & - call io_error('Error: value of length_unit not recognised in param_read') - if (length_unit .eq. 'bohr') lenconfac = 1.0_dp/bohr - - wvfn_formatted = .false. ! formatted or "binary" file - call param_get_keyword('wvfn_formatted', found, l_value=wvfn_formatted) - - spn_formatted = .false. ! formatted or "binary" file - call param_get_keyword('spn_formatted', found, l_value=spn_formatted) - - uHu_formatted = .false. ! formatted or "binary" file - call param_get_keyword('uhu_formatted', found, l_value=uHu_formatted) - - spin = 1 - call param_get_keyword('spin', found, c_value=spin_str) - if (found) then - if (index(spin_str, 'up') > 0) then - spin = 1 - elseif (index(spin_str, 'down') > 0) then - spin = 2 - else - call io_error('Error: unrecognised value of spin found: '//trim(spin_str)) - end if - end if - - num_wann = -99 - call param_get_keyword('num_wann', found, i_value=num_wann) - if (.not. found) call io_error('Error: You must specify num_wann') - if (num_wann <= 0) call io_error('Error: num_wann must be greater than zero') - - num_exclude_bands = 0 - call param_get_range_vector('exclude_bands', found, num_exclude_bands, lcount=.true.) - if (found) then - if (num_exclude_bands < 1) call io_error('Error: problem reading exclude_bands') - if (allocated(exclude_bands)) deallocate (exclude_bands) - allocate (exclude_bands(num_exclude_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating exclude_bands in param_read') - call param_get_range_vector('exclude_bands', found, num_exclude_bands, .false., exclude_bands) - if (any(exclude_bands < 1)) & - call io_error('Error: exclude_bands must contain positive numbers') - end if - - ! AAM_2016-09-16: some changes to logic to patch a problem with uninitialised num_bands in library mode -! num_bands = -1 - call param_get_keyword('num_bands', found, i_value=i_temp) - if (found .and. library) write (stdout, '(/a)') ' Ignoring in input file' - if (.not. library .and. .not. effective_model) then - if (found) num_bands = i_temp - if (.not. found) num_bands = num_wann - end if - ! GP: I subtract it here, but only the first time when I pass the total number of bands - ! In later calls, I need to pass instead num_bands already subtracted. - if (library .and. library_param_read_first_pass) num_bands = num_bands - num_exclude_bands - if (.not. effective_model) then - if (found .and. num_bands < num_wann) then - write (stdout, *) 'num_bands', num_bands - write (stdout, *) 'num_wann', num_wann - call io_error('Error: num_bands must be greater than or equal to num_wann') - endif - endif - - num_dump_cycles = 100 ! frequency to write backups at - call param_get_keyword('num_dump_cycles', found, i_value=num_dump_cycles) - if (num_dump_cycles < 0) call io_error('Error: num_dump_cycles must be positive') - - num_print_cycles = 1 ! frequency to write at - call param_get_keyword('num_print_cycles', found, i_value=num_print_cycles) - if (num_print_cycles < 0) call io_error('Error: num_print_cycles must be positive') - - devel_flag = ' ' ! - call param_get_keyword('devel_flag', found, c_value=devel_flag) - -! mp_grid=-99 - call param_get_keyword_vector('mp_grid', found, 3, i_value=iv_temp) - if (found .and. library) write (stdout, '(a)') ' Ignoring in input file' - if (.not. library .and. .not. effective_model) then - if (found) mp_grid = iv_temp - if (.not. found) then - call io_error('Error: You must specify dimensions of the Monkhorst-Pack grid by setting mp_grid') - elseif (any(mp_grid < 1)) then - call io_error('Error: mp_grid must be greater than zero') - end if - num_kpts = mp_grid(1)*mp_grid(2)*mp_grid(3) - end if - -![ysl-b] - ltmp = .false. - call param_get_keyword('gamma_only', found, l_value=ltmp) - if (.not. library) then - gamma_only = ltmp - if (gamma_only .and. (num_kpts .ne. 1)) & - call io_error('Error: gamma_only is true, but num_kpts > 1') - else - if (found) write (stdout, '(a)') ' Ignoring in input file' - endif -![ysl-e] - -! aam: automatic_mp_grid no longer used -! automatic_mp_grid = .false. -! call param_get_keyword('automatic_mp_grid',found,l_value=automatic_mp_grid) - - postproc_setup = .false. ! set to true to write .nnkp file and exit - call param_get_keyword('postproc_setup', found, l_value=postproc_setup) - ! We allow this keyword to be overriden by a command line arg -pp - if (post_proc_flag) postproc_setup = .true. - - cp_pp = .false. ! set to true if doing CP post-processing - call param_get_keyword('cp_pp', found, l_value=cp_pp) - - calc_only_A = .false. - call param_get_keyword('calc_only_A', found, l_value=calc_only_A) - - restart = ' ' - call param_get_keyword('restart', found, c_value=restart) - if (found) then - if ((restart .ne. 'default') .and. (restart .ne. 'wannierise') & - .and. (restart .ne. 'plot') .and. (restart .ne. 'transport')) then - call io_error('Error in input file: value of restart not recognised') - else - inquire (file=trim(seedname)//'.chk', exist=chk_found) - if (.not. chk_found) & - call io_error('Error: restart requested but '//trim(seedname)//'.chk file not found') - endif - endif - !post processing takes priority (user is not warned of this) - if (postproc_setup) restart = ' ' - - write_r2mn = .false. - call param_get_keyword('write_r2mn', found, l_value=write_r2mn) - - write_proj = .false. - call param_get_keyword('write_proj', found, l_value=write_proj) - - ltmp = .false. ! by default our WF are not spinors - call param_get_keyword('spinors', found, l_value=ltmp) - if (.not. library) then - spinors = ltmp - else - if (found) write (stdout, '(a)') ' Ignoring in input file' - endif -! if(spinors .and. (2*(num_wann/2))/=num_wann) & -! call io_error('Error: For spinor WF num_wann must be even') - - ! We need to know if the bands are double degenerate due to spin, e.g. when - ! calculating the DOS - if (spinors) then - num_elec_per_state = 1 - else - num_elec_per_state = 2 - endif - call param_get_keyword('num_elec_per_state', found, i_value=num_elec_per_state) - if ((num_elec_per_state /= 1) .and. (num_elec_per_state /= 2)) & - call io_error('Error: num_elec_per_state can be only 1 or 2') - if (spinors .and. num_elec_per_state /= 1) & - call io_error('Error: when spinors = T num_elec_per_state must be 1') - - translate_home_cell = .false. - call param_get_keyword('translate_home_cell', found, l_value=translate_home_cell) - - write_xyz = .false. - call param_get_keyword('write_xyz', found, l_value=write_xyz) - - write_hr_diag = .false. - call param_get_keyword('write_hr_diag', found, l_value=write_hr_diag) - - !%%%%%%%%%%% - ! Wannierise - !%%%%%%%%%%% - - num_iter = 100 - call param_get_keyword('num_iter', found, i_value=num_iter) - if (num_iter < 0) call io_error('Error: num_iter must be positive') - - num_cg_steps = 5 - call param_get_keyword('num_cg_steps', found, i_value=num_cg_steps) - if (num_cg_steps < 0) call io_error('Error: num_cg_steps must be positive') - - conv_tol = 1.0e-10_dp - call param_get_keyword('conv_tol', found, r_value=conv_tol) - if (conv_tol < 0.0_dp) call io_error('Error: conv_tol must be positive') - - conv_noise_amp = -1.0_dp - call param_get_keyword('conv_noise_amp', found, r_value=conv_noise_amp) - - conv_window = -1 - if (conv_noise_amp > 0.0_dp) conv_window = 5 - call param_get_keyword('conv_window', found, i_value=conv_window) - - conv_noise_num = 3 - call param_get_keyword('conv_noise_num', found, i_value=conv_noise_num) - if (conv_noise_num < 0) call io_error('Error: conv_noise_num must be positive') - - guiding_centres = .false. - call param_get_keyword('guiding_centres', found, l_value=guiding_centres) - - num_guide_cycles = 1 - call param_get_keyword('num_guide_cycles', found, i_value=num_guide_cycles) - if (num_guide_cycles < 0) call io_error('Error: num_guide_cycles must be >= 0') - - num_no_guide_iter = 0 - call param_get_keyword('num_no_guide_iter', found, i_value=num_no_guide_iter) - if (num_no_guide_iter < 0) call io_error('Error: num_no_guide_iter must be >= 0') - - fixed_step = -999.0_dp; lfixstep = .false. - call param_get_keyword('fixed_step', found, r_value=fixed_step) - if (found .and. (fixed_step < 0.0_dp)) call io_error('Error: fixed_step must be > 0') - if (fixed_step > 0.0_dp) lfixstep = .true. - - trial_step = 2.0_dp - call param_get_keyword('trial_step', found, r_value=trial_step) - if (found .and. lfixstep) call io_error('Error: cannot specify both fixed_step and trial_step') - - precond = .false. - call param_get_keyword('precond', found, l_value=precond) - - slwf_num = num_wann - selective_loc = .false. - call param_get_keyword('slwf_num', found, i_value=slwf_num) - if (found) then - if (slwf_num .gt. num_wann .or. slwf_num .lt. 1) then - call io_error('Error: slwf_num must be an integer between 1 and num_wann') - end if - if (slwf_num .lt. num_wann) selective_loc = .true. - end if - - slwf_constrain = .false. - call param_get_keyword('slwf_constrain', found, l_value=slwf_constrain) - if (found .and. slwf_constrain) then - if (selective_loc) then - allocate (ccentres_frac(num_wann, 3), stat=ierr) - if (ierr /= 0) call io_error('Error allocating ccentres_frac in param_get_centre_constraints') - allocate (ccentres_cart(num_wann, 3), stat=ierr) - if (ierr /= 0) call io_error('Error allocating ccentres_cart in param_get_centre_constraints') - else - write (stdout, *) ' No selective localisation requested. Ignoring constraints on centres' - slwf_constrain = .false. - end if - end if - - slwf_lambda = 1.0_dp - call param_get_keyword('slwf_lambda', found, r_value=slwf_lambda) - if (found) then - if (slwf_lambda < 0.0_dp) call io_error('Error: slwf_lambda must be positive.') - endif - - !%%%%%%%%% - ! Plotting - !%%%%%%%%% - - wannier_plot = .false. - call param_get_keyword('wannier_plot', found, l_value=wannier_plot) - - wannier_plot_supercell = 2 - - call param_get_vector_length('wannier_plot_supercell', found, length=i) - if (found) then - if (i .eq. 1) then - call param_get_keyword_vector('wannier_plot_supercell', found, 1, & - i_value=wannier_plot_supercell) - wannier_plot_supercell(2) = wannier_plot_supercell(1) - wannier_plot_supercell(3) = wannier_plot_supercell(1) - elseif (i .eq. 3) then - call param_get_keyword_vector('wannier_plot_supercell', found, 3, & - i_value=wannier_plot_supercell) - else - call io_error('Error: wannier_plot_supercell must be provided as either one integer or a vector of three integers') - end if - if (any(wannier_plot_supercell <= 0)) & - call io_error('Error: wannier_plot_supercell elements must be greater than zero') - end if - - wannier_plot_format = 'xcrysden' - call param_get_keyword('wannier_plot_format', found, c_value=wannier_plot_format) - - wannier_plot_mode = 'crystal' - call param_get_keyword('wannier_plot_mode', found, c_value=wannier_plot_mode) - - wannier_plot_spinor_mode = 'total' - call param_get_keyword('wannier_plot_spinor_mode', found, c_value=wannier_plot_spinor_mode) - wannier_plot_spinor_phase = .true. - call param_get_keyword('wannier_plot_spinor_phase', found, l_value=wannier_plot_spinor_phase) - - call param_get_range_vector('wannier_plot_list', found, num_wannier_plot, lcount=.true.) - if (found) then - if (num_wannier_plot < 1) call io_error('Error: problem reading wannier_plot_list') - if (allocated(wannier_plot_list)) deallocate (wannier_plot_list) - allocate (wannier_plot_list(num_wannier_plot), stat=ierr) - if (ierr /= 0) call io_error('Error allocating wannier_plot_list in param_read') - call param_get_range_vector('wannier_plot_list', found, num_wannier_plot, .false., wannier_plot_list) - if (any(wannier_plot_list < 1) .or. any(wannier_plot_list > num_wann)) & - call io_error('Error: wannier_plot_list asks for a non-valid wannier function to be plotted') - else - ! we plot all wannier functions - num_wannier_plot = num_wann - if (allocated(wannier_plot_list)) deallocate (wannier_plot_list) - allocate (wannier_plot_list(num_wannier_plot), stat=ierr) - if (ierr /= 0) call io_error('Error allocating wannier_plot_list in param_read') - do loop = 1, num_wann - wannier_plot_list(loop) = loop - end do - end if - - wannier_plot_radius = 3.5_dp - call param_get_keyword('wannier_plot_radius', found, r_value=wannier_plot_radius) - - wannier_plot_scale = 1.0_dp - call param_get_keyword('wannier_plot_scale', found, r_value=wannier_plot_scale) - - ! checks - if (wannier_plot) then - if ((index(wannier_plot_format, 'xcrys') .eq. 0) .and. (index(wannier_plot_format, 'cub') .eq. 0)) & - call io_error('Error: wannier_plot_format not recognised') - if ((index(wannier_plot_mode, 'crys') .eq. 0) .and. (index(wannier_plot_mode, 'mol') .eq. 0)) & - call io_error('Error: wannier_plot_mode not recognised') - if ((index(wannier_plot_spinor_mode, 'total') .eq. 0) .and. (index(wannier_plot_spinor_mode, 'up') .eq. 0) & - .and. (index(wannier_plot_spinor_mode, 'down') .eq. 0)) & - call io_error('Error: wannier_plot_spinor_mode not recognised') - if (wannier_plot_radius < 0.0_dp) call io_error('Error: wannier_plot_radius must be positive') - if (wannier_plot_scale < 0.0_dp) call io_error('Error: wannier_plot_scale must be positive') - endif - - write_u_matrices = .false. - call param_get_keyword('write_u_matrices', found, l_value=write_u_matrices) - - bands_plot = .false. - call param_get_keyword('bands_plot', found, l_value=bands_plot) - - write_bvec = .false. - call param_get_keyword('write_bvec', found, l_value=write_bvec) - - bands_num_points = 100 - call param_get_keyword('bands_num_points', found, i_value=bands_num_points) - - bands_plot_format = 'gnuplot' - call param_get_keyword('bands_plot_format', found, c_value=bands_plot_format) - - bands_plot_mode = 's-k' - call param_get_keyword('bands_plot_mode', found, c_value=bands_plot_mode) - - bands_plot_dim = 3 - call param_get_keyword('bands_plot_dim', found, i_value=bands_plot_dim) - - num_bands_project = 0 - call param_get_range_vector('bands_plot_project', found, num_bands_project, lcount=.true.) - if (found) then - if (num_bands_project < 1) call io_error('Error: problem reading bands_plot_project') - if (allocated(bands_plot_project)) deallocate (bands_plot_project) - allocate (bands_plot_project(num_bands_project), stat=ierr) - if (ierr /= 0) call io_error('Error allocating bands_plot_project in param_read') - call param_get_range_vector('bands_plot_project', found, num_bands_project, .false., bands_plot_project) - if (any(bands_plot_project < 1) .or. any(bands_plot_project > num_wann)) & - call io_error('Error: bands_plot_project asks for a non-valid wannier function to be projected') - endif - - bands_num_spec_points = 0 - call param_get_block_length('kpoint_path', found, i_temp) - if (found) then - bands_num_spec_points = i_temp*2 - if (allocated(bands_label)) deallocate (bands_label) - allocate (bands_label(bands_num_spec_points), stat=ierr) - if (ierr /= 0) call io_error('Error allocating bands_label in param_read') - if (allocated(bands_spec_points)) deallocate (bands_spec_points) - allocate (bands_spec_points(3, bands_num_spec_points), stat=ierr) - if (ierr /= 0) call io_error('Error allocating bands_spec_points in param_read') - call param_get_keyword_kpath - end if - if (.not. found .and. bands_plot) & - call io_error('A bandstructure plot has been requested but there is no kpoint_path block') - - ! checks - if (bands_plot) then - if ((index(bands_plot_format, 'gnu') .eq. 0) .and. (index(bands_plot_format, 'xmgr') .eq. 0)) & - call io_error('Error: bands_plot_format not recognised') - if ((index(bands_plot_mode, 's-k') .eq. 0) .and. (index(bands_plot_mode, 'cut') .eq. 0)) & - call io_error('Error: bands_plot_mode not recognised') - if (bands_num_points < 0) call io_error('Error: bands_num_points must be positive') - endif - - fermi_surface_plot = .false. - call param_get_keyword('fermi_surface_plot', found, l_value=fermi_surface_plot) - - fermi_surface_num_points = 50 - call param_get_keyword('fermi_surface_num_points', found, i_value=fermi_surface_num_points) - - fermi_surface_plot_format = 'xcrysden' - call param_get_keyword('fermi_surface_plot_format', & - found, c_value=fermi_surface_plot_format) - - nfermi = 0 - found_fermi_energy = .false. - call param_get_keyword('fermi_energy', found, r_value=fermi_energy) - if (found) then - found_fermi_energy = .true. - nfermi = 1 - endif - ! - fermi_energy_scan = .false. - call param_get_keyword('fermi_energy_min', found, r_value=fermi_energy_min) - if (found) then - if (found_fermi_energy) call io_error( & - 'Error: Cannot specify both fermi_energy and fermi_energy_min') - fermi_energy_scan = .true. - fermi_energy_max = fermi_energy_min + 1.0_dp - call param_get_keyword('fermi_energy_max', found, & - r_value=fermi_energy_max) - if (found .and. fermi_energy_max <= fermi_energy_min) call io_error( & - 'Error: fermi_energy_max must be larger than fermi_energy_min') - fermi_energy_step = 0.01_dp - call param_get_keyword('fermi_energy_step', found, & - r_value=fermi_energy_step) - if (found .and. fermi_energy_step <= 0.0_dp) call io_error( & - 'Error: fermi_energy_step must be positive') - nfermi = nint(abs((fermi_energy_max - fermi_energy_min)/fermi_energy_step)) + 1 - endif - ! - if (found_fermi_energy) then - if (allocated(fermi_energy_list)) deallocate (fermi_energy_list) - allocate (fermi_energy_list(1), stat=ierr) - fermi_energy_list(1) = fermi_energy - elseif (fermi_energy_scan) then - if (nfermi .eq. 1) then - fermi_energy_step = 0.0_dp - else - fermi_energy_step = (fermi_energy_max - fermi_energy_min)/real(nfermi - 1, dp) - endif - if (allocated(fermi_energy_list)) deallocate (fermi_energy_list) - allocate (fermi_energy_list(nfermi), stat=ierr) - do i = 1, nfermi - fermi_energy_list(i) = fermi_energy_min + (i - 1)*fermi_energy_step - enddo -!! elseif(nfermi==0) then -!! ! This happens when both found_fermi_energy=.false. and -!! ! fermi_energy_scan=.false. Functionalities that require -!! ! specifying a Fermi level should give an error message -!! allocate(fermi_energy_list(1),stat=ierr) ! helps streamline things -!! -!! AAM_2017-03-27: if nfermi is zero (ie, fermi_energy* parameters are not set in input file) -!! then allocate fermi_energy_list with length 1 and set to zero as default. - else - if (allocated(fermi_energy_list)) deallocate (fermi_energy_list) - allocate (fermi_energy_list(1), stat=ierr) - fermi_energy_list(1) = 0.0_dp - endif - if (ierr /= 0) call io_error( & - 'Error allocating fermi_energy_list in param_read') - - ! checks - if (fermi_surface_plot) then - if ((index(fermi_surface_plot_format, 'xcrys') .eq. 0)) & - call io_error('Error: fermi_surface_plot_format not recognised') - if (fermi_surface_num_points < 0) & - call io_error('Error: fermi_surface_num_points must be positive') - endif - - kslice = .false. - call param_get_keyword('kslice', found, l_value=kslice) - - kslice_task = 'fermi_lines' - call param_get_keyword('kslice_task', found, c_value=kslice_task) - if (kslice .and. index(kslice_task, 'fermi_lines') == 0 .and. & - index(kslice_task, 'curv') == 0 .and. & - index(kslice_task, 'morb') == 0 .and. & - index(kslice_task, 'shc') == 0) call io_error & - ('Error: value of kslice_task not recognised in param_read') - if (kslice .and. index(kslice_task, 'curv') > 0 .and. & - index(kslice_task, 'morb') > 0) call io_error & - ("Error: kslice_task cannot include both 'curv' and 'morb'") - if (kslice .and. index(kslice_task, 'shc') > 0 .and. & - index(kslice_task, 'morb') > 0) call io_error & - ("Error: kslice_task cannot include both 'shc' and 'morb'") - if (kslice .and. index(kslice_task, 'shc') > 0 .and. & - index(kslice_task, 'curv') > 0) call io_error & - ("Error: kslice_task cannot include both 'shc' and 'curv'") - - kslice_2dkmesh(1:2) = 50 - call param_get_vector_length('kslice_2dkmesh', found, length=i) - if (found) then - if (i == 1) then - call param_get_keyword_vector('kslice_2dkmesh', found, 1, & - i_value=kslice_2dkmesh) - kslice_2dkmesh(2) = kslice_2dkmesh(1) - elseif (i == 2) then - call param_get_keyword_vector('kslice_2dkmesh', found, 2, & - i_value=kslice_2dkmesh) - else - call io_error('Error: kslice_2dkmesh must be provided as either' & - //' one integer or a vector of two integers') - endif - if (any(kslice_2dkmesh <= 0)) & - call io_error('Error: kslice_2dkmesh elements must be' & - //' greater than zero') - endif - - kslice_corner = 0.0_dp - call param_get_keyword_vector('kslice_corner', found, 3, r_value=kslice_corner) - - kslice_b1(1) = 1.0_dp - kslice_b1(2) = 0.0_dp - kslice_b1(3) = 0.0_dp - call param_get_keyword_vector('kslice_b1', found, 3, r_value=kslice_b1) - - kslice_b2(1) = 0.0_dp - kslice_b2(2) = 1.0_dp - kslice_b2(3) = 0.0_dp - call param_get_keyword_vector('kslice_b2', found, 3, r_value=kslice_b2) - - kslice_fermi_lines_colour = 'none' - call param_get_keyword('kslice_fermi_lines_colour', found, & - c_value=kslice_fermi_lines_colour) - if (kslice .and. index(kslice_fermi_lines_colour, 'none') == 0 .and. & - index(kslice_fermi_lines_colour, 'spin') == 0) call io_error & - ('Error: value of kslice_fermi_lines_colour not recognised ' & - //'in param_read') - -! slice_plot_format = 'plotmv' -! call param_get_keyword('slice_plot_format',found,c_value=slice_plot_format) - - ! [gp-begin, Apr 20, 2012] - - ! By default: Gaussian - smr_index = 0 - call param_get_keyword('smr_type', found, c_value=ctmp) - if (found) smr_index = get_smearing_index(ctmp, 'smr_type') - - ! By default: adaptive smearing - adpt_smr = .true. - call param_get_keyword('adpt_smr', found, l_value=adpt_smr) - - ! By default: a=sqrt(2) - adpt_smr_fac = sqrt(2.0_dp) - call param_get_keyword('adpt_smr_fac', found, r_value=adpt_smr_fac) - if (found .and. (adpt_smr_fac <= 0._dp)) & - call io_error('Error: adpt_smr_fac must be greater than zero') - - ! By default: 1 eV - adpt_smr_max = 1.0_dp - call param_get_keyword('adpt_smr_max', found, r_value=adpt_smr_max) - if (adpt_smr_max <= 0._dp) & - call io_error('Error: adpt_smr_max must be greater than zero') - - ! By default: if adpt_smr is manually set to false by the user, but he/she doesn't - ! define smr_fixed_en_width: NO smearing, i.e. just the histogram - smr_fixed_en_width = 0.0_dp - call param_get_keyword('smr_fixed_en_width', found, r_value=smr_fixed_en_width) - if (found .and. (smr_fixed_en_width < 0._dp)) & - call io_error('Error: smr_fixed_en_width must be greater than or equal to zero') - ! [gp-end] - - !IVO - - dos = .false. - call param_get_keyword('dos', found, l_value=dos) - - berry = .false. - call param_get_keyword('berry', found, l_value=berry) - - transl_inv = .false. - call param_get_keyword('transl_inv', found, l_value=transl_inv) - - berry_task = ' ' - call param_get_keyword('berry_task', found, c_value=berry_task) - if (berry .and. .not. found) call io_error & - ('Error: berry=T and berry_task is not set') - if (berry .and. index(berry_task, 'ahc') == 0 .and. index(berry_task, 'morb') == 0 & - .and. index(berry_task, 'kubo') == 0 .and. index(berry_task, 'sc') == 0 & - .and. index(berry_task, 'shc') == 0 .and. index(berry_task, 'kdotp') == 0) call io_error & - ('Error: value of berry_task not recognised in param_read') - - ! Stepan - gyrotropic = .false. - call param_get_keyword('gyrotropic', found, l_value=gyrotropic) - gyrotropic_task = 'all' - call param_get_keyword('gyrotropic_task', found, c_value=gyrotropic_task) - gyrotropic_box(:, :) = 0.0 - gyrotropic_degen_thresh = 0.0_dp - call param_get_keyword('gyrotropic_degen_thresh', found, r_value=gyrotropic_degen_thresh) - - do i = 1, 3 - gyrotropic_box(i, i) = 1.0_dp - gyrotropic_box_tmp(:) = 0.0_dp - call param_get_keyword_vector('gyrotropic_box_b'//achar(48 + i), found, 3, r_value=gyrotropic_box_tmp) - if (found) gyrotropic_box(i, :) = gyrotropic_box_tmp(:) - enddo - gyrotropic_box_corner(:) = 0.0_dp - call param_get_keyword_vector('gyrotropic_box_center', found, 3, r_value=gyrotropic_box_tmp) - if (found) gyrotropic_box_corner(:) = & - gyrotropic_box_tmp(:) - 0.5*(gyrotropic_box(1, :) + gyrotropic_box(2, :) + gyrotropic_box(3, :)) - - call param_get_range_vector('gyrotropic_band_list', found, gyrotropic_num_bands, lcount=.true.) - if (found) then - if (gyrotropic_num_bands < 1) call io_error('Error: problem reading gyrotropic_band_list') - if (allocated(gyrotropic_band_list)) deallocate (gyrotropic_band_list) - allocate (gyrotropic_band_list(gyrotropic_num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating gyrotropic_band_list in param_read') - call param_get_range_vector('gyrotropic_band_list', found, gyrotropic_num_bands, .false., gyrotropic_band_list) - if (any(gyrotropic_band_list < 1) .or. any(gyrotropic_band_list > num_wann)) & - call io_error('Error: gyrotropic_band_list asks for a non-valid bands') - else - ! include all bands in the calculation - gyrotropic_num_bands = num_wann - if (allocated(gyrotropic_band_list)) deallocate (gyrotropic_band_list) - allocate (gyrotropic_band_list(gyrotropic_num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating gyrotropic_band_list in param_read') - do loop = 1, num_wann - gyrotropic_band_list(loop) = loop - end do - end if - - smr_max_arg = 5.0 - call param_get_keyword('smr_max_arg', found, r_value=smr_max_arg) - if (found .and. (smr_max_arg <= 0._dp)) & - call io_error('Error: smr_max_arg must be greater than zero') - - gyrotropic_smr_max_arg = smr_max_arg - call param_get_keyword('gyrotropic_smr_max_arg', found, & - r_value=gyrotropic_smr_max_arg) - if (found .and. (gyrotropic_smr_max_arg <= 0._dp)) call io_error & - ('Error: gyrotropic_smr_max_arg must be greater than zero') - -!------------------------------------------------------- -! alpha=0 -! call param_get_keyword('alpha',found,i_value=alpha) - -! beta=0 -! call param_get_keyword('beta',found,i_value=beta) - -! gamma=0 -! call param_get_keyword('gamma',found,i_value=gamma) -!------------------------------------------------------- - - berry_curv_adpt_kmesh = 1 - call param_get_keyword('berry_curv_adpt_kmesh', found, & - i_value=berry_curv_adpt_kmesh) - if (berry_curv_adpt_kmesh < 1) & - call io_error( & - 'Error: berry_curv_adpt_kmesh must be a positive integer') - - berry_curv_adpt_kmesh_thresh = 100.0_dp - call param_get_keyword('berry_curv_adpt_kmesh_thresh', found, & - r_value=berry_curv_adpt_kmesh_thresh) - - berry_curv_unit = 'ang2' - call param_get_keyword('berry_curv_unit', found, c_value=berry_curv_unit) - if (berry_curv_unit .ne. 'ang2' .and. berry_curv_unit .ne. 'bohr2') & - call io_error & - ('Error: value of berry_curv_unit not recognised in param_read') - - wanint_kpoint_file = .false. - call param_get_keyword('wanint_kpoint_file', found, & - l_value=wanint_kpoint_file) - -! smear_temp = -1.0_dp -! call param_get_keyword('smear_temp',found,r_value=smear_temp) - - kubo_adpt_smr = adpt_smr - call param_get_keyword('kubo_adpt_smr', found, l_value=kubo_adpt_smr) - - kubo_adpt_smr_fac = adpt_smr_fac - call param_get_keyword('kubo_adpt_smr_fac', found, & - r_value=kubo_adpt_smr_fac) - if (found .and. (kubo_adpt_smr_fac <= 0._dp)) call io_error & - ('Error: kubo_adpt_smr_fac must be greater than zero') - - kubo_adpt_smr_max = adpt_smr_max - call param_get_keyword('kubo_adpt_smr_max', found, & - r_value=kubo_adpt_smr_max) - if (kubo_adpt_smr_max <= 0._dp) call io_error & - ('Error: kubo_adpt_smr_max must be greater than zero') - - kubo_smr_fixed_en_width = smr_fixed_en_width - call param_get_keyword('kubo_smr_fixed_en_width', found, & - r_value=kubo_smr_fixed_en_width) - if (found .and. (kubo_smr_fixed_en_width < 0._dp)) call io_error & - ('Error: kubo_smr_fixed_en_width must be greater than or equal to zero') - - gyrotropic_smr_fixed_en_width = smr_fixed_en_width - call param_get_keyword('gyrotropic_smr_fixed_en_width', found, & - r_value=gyrotropic_smr_fixed_en_width) - if (found .and. (gyrotropic_smr_fixed_en_width < 0._dp)) call io_error & - ('Error: gyrotropic_smr_fixed_en_width must be greater than or equal to zero') - - sc_phase_conv = 1 - call param_get_keyword('sc_phase_conv', found, i_value=sc_phase_conv) - if ((sc_phase_conv .ne. 1) .and. ((sc_phase_conv .ne. 2))) call io_error('Error: sc_phase_conv must be either 1 or 2') - - sc_use_eta_corr = .true. - call param_get_keyword('sc_use_eta_corr', found, l_value=sc_use_eta_corr) - - scissors_shift = 0.0_dp - call param_get_keyword('scissors_shift', found, & - r_value=scissors_shift) - - shc_freq_scan = .false. - call param_get_keyword('shc_freq_scan', found, l_value=shc_freq_scan) - - shc_alpha = 1 - call param_get_keyword('shc_alpha', found, i_value=shc_alpha) - if (found .and. (shc_alpha < 1 .or. shc_alpha > 3)) call io_error & - ('Error: shc_alpha must be 1, 2 or 3') - - shc_beta = 2 - call param_get_keyword('shc_beta', found, i_value=shc_beta) - if (found .and. (shc_beta < 1 .or. shc_beta > 3)) call io_error & - ('Error: shc_beta must be 1, 2 or 3') - - shc_gamma = 3 - call param_get_keyword('shc_gamma', found, i_value=shc_gamma) - if (found .and. (shc_gamma < 1 .or. shc_gamma > 3)) call io_error & - ('Error: shc_gamma must be 1, 2 or 3') - - shc_bandshift = .false. - call param_get_keyword('shc_bandshift', found, l_value=shc_bandshift) - shc_bandshift = shc_bandshift .and. berry .and. .not. (index(berry_task, 'shc') == 0) - if ((abs(scissors_shift) > 1.0e-7_dp) .and. shc_bandshift) & - call io_error('Error: shc_bandshift and scissors_shift cannot be used simultaneously') - - shc_bandshift_firstband = 0 - call param_get_keyword('shc_bandshift_firstband', found, i_value=shc_bandshift_firstband) - if (shc_bandshift .and. (.not. found)) & - call io_error('Error: shc_bandshift required but no shc_bandshift_firstband provided') - if ((shc_bandshift_firstband < 1) .and. found) & - call io_error('Error: shc_bandshift_firstband must >= 1') - - shc_bandshift_energyshift = 0._dp - call param_get_keyword('shc_bandshift_energyshift', found, r_value=shc_bandshift_energyshift) - if (shc_bandshift .and. (.not. found)) & - call io_error('Error: shc_bandshift required but no shc_bandshift_energyshift provided') - - shc_method = ' ' - call param_get_keyword('shc_method', found, c_value=shc_method) - if (index(berry_task, 'shc') > 0 .and. .not. found) call io_error & - ('Error: berry_task=shc and shc_method is not set') - if (index(berry_task, 'shc') > 0 .and. index(shc_method, 'qiao') == 0 & - .and. index(shc_method, 'ryoo') == 0) call io_error & - ('Error: value of shc_method not recognised in param_read') - - spin_moment = .false. - call param_get_keyword('spin_moment', found, & - l_value=spin_moment) - - spin_axis_polar = 0.0_dp - call param_get_keyword('spin_axis_polar', found, & - r_value=spin_axis_polar) - - spin_axis_azimuth = 0.0_dp - call param_get_keyword('spin_axis_azimuth', found, & - r_value=spin_axis_azimuth) - - spin_decomp = .false. - call param_get_keyword('spin_decomp', found, l_value=spin_decomp) - - if (spin_decomp .and. (num_elec_per_state .ne. 1)) then - call io_error('spin_decomp can be true only if num_elec_per_state is 1') - end if - - use_degen_pert = .false. - call param_get_keyword('use_degen_pert', found, & - l_value=use_degen_pert) - - degen_thr = 1.0d-4 - call param_get_keyword('degen_thr', found, r_value=degen_thr) - - kpath = .false. - call param_get_keyword('kpath', found, l_value=kpath) - - kpath_task = 'bands' - call param_get_keyword('kpath_task', found, c_value=kpath_task) - if (kpath .and. index(kpath_task, 'bands') == 0 .and. & - index(kpath_task, 'curv') == 0 .and. & - index(kpath_task, 'morb') == 0 .and. & - index(kpath_task, 'shc') == 0) call io_error & - ('Error: value of kpath_task not recognised in param_read') - if (bands_num_spec_points == 0 .and. kpath) & - call io_error('Error: a kpath plot has been requested but there is no kpoint_path block') - - kpath_num_points = 100 - call param_get_keyword('kpath_num_points', found, & - i_value=kpath_num_points) - if (kpath_num_points < 0) & - call io_error('Error: kpath_num_points must be positive') - - kpath_bands_colour = 'none' - call param_get_keyword('kpath_bands_colour', found, & - c_value=kpath_bands_colour) - if (kpath .and. index(kpath_bands_colour, 'none') == 0 .and. & - index(kpath_bands_colour, 'spin') == 0 .and. & - index(kpath_bands_colour, 'shc') == 0) call io_error & - ('Error: value of kpath_bands_colour not recognised in param_read') - if (kpath .and. index(kpath_task, 'shc') > 0 .and. & - index(kpath_task, 'spin') > 0) call io_error & - ("Error: kpath_task cannot include both 'shc' and 'spin'") - - ! set to a negative default value - num_valence_bands = -99 - call param_get_keyword('num_valence_bands', found, i_value=num_valence_bands) - if (found .and. (num_valence_bands .le. 0)) & - call io_error('Error: num_valence_bands should be greater than zero') - ! there is a check on this parameter later - - dos_task = 'dos_plot' - if (dos) then - dos_plot = .true. - else - dos_plot = .false. - endif - call param_get_keyword('dos_task', found, c_value=dos_task) - if (dos) then - if (index(dos_task, 'dos_plot') == 0 .and. & - index(dos_task, 'find_fermi_energy') == 0) call io_error & - ('Error: value of dos_task not recognised in param_read') - if (index(dos_task, 'dos_plot') > 0) dos_plot = .true. - if (index(dos_task, 'find_fermi_energy') > 0 .and. found_fermi_energy) & - call io_error & - ('Error: Cannot set "dos_task = find_fermi_energy" and give a value to "fermi_energy"') - end if - -! sigma_abc_onlyorb=.false. -! call param_get_keyword('sigma_abc_onlyorb',found,l_value=sigma_abc_onlyorb) - -! ------------------------------------------------------------------- - - !IVO_END - - dos_energy_step = 0.01_dp - call param_get_keyword('dos_energy_step', found, r_value=dos_energy_step) - - dos_adpt_smr = adpt_smr - call param_get_keyword('dos_adpt_smr', found, l_value=dos_adpt_smr) - - dos_adpt_smr_fac = adpt_smr_fac - call param_get_keyword('dos_adpt_smr_fac', found, r_value=dos_adpt_smr_fac) - if (found .and. (dos_adpt_smr_fac <= 0._dp)) & - call io_error('Error: dos_adpt_smr_fac must be greater than zero') - - dos_adpt_smr_max = adpt_smr_max - call param_get_keyword('dos_adpt_smr_max', found, r_value=dos_adpt_smr_max) - if (dos_adpt_smr_max <= 0._dp) call io_error & - ('Error: dos_adpt_smr_max must be greater than zero') - - dos_smr_fixed_en_width = smr_fixed_en_width - call param_get_keyword('dos_smr_fixed_en_width', found, r_value=dos_smr_fixed_en_width) - if (found .and. (dos_smr_fixed_en_width < 0._dp)) & - call io_error('Error: dos_smr_fixed_en_width must be greater than or equal to zero') - -! dos_gaussian_width = 0.1_dp -! call param_get_keyword('dos_gaussian_width',found,r_value=dos_gaussian_width) - -! dos_plot_format = 'gnuplot' -! call param_get_keyword('dos_plot_format',found,c_value=dos_plot_format) - - call param_get_range_vector('dos_project', found, num_dos_project, & - lcount=.true.) - if (found) then - if (num_dos_project < 1) call io_error('Error: problem reading dos_project') - if (allocated(dos_project)) deallocate (dos_project) - allocate (dos_project(num_dos_project), stat=ierr) - if (ierr /= 0) call io_error('Error allocating dos_project in param_read') - call param_get_range_vector('dos_project', found, num_dos_project, & - .false., dos_project) - if (any(dos_project < 1) .or. any(dos_project > num_wann)) call io_error & - ('Error: dos_project asks for out-of-range Wannier functions') - else - ! by default plot all - num_dos_project = num_wann - if (allocated(dos_project)) deallocate (dos_project) - allocate (dos_project(num_dos_project), stat=ierr) - if (ierr /= 0) call io_error('Error allocating dos_project in param_read') - do i = 1, num_dos_project - dos_project(i) = i - end do - endif - - hr_plot = .false. - call param_get_keyword('hr_plot', found, l_value=hr_plot) - if (found) call io_error('Input parameter hr_plot is no longer used. Please use write_hr instead.') - write_hr = .false. - call param_get_keyword('write_hr', found, l_value=write_hr) - - write_rmn = .false. - call param_get_keyword('write_rmn', found, l_value=write_rmn) - - write_tb = .false. - call param_get_keyword('write_tb', found, l_value=write_tb) - - hr_cutoff = 0.0_dp - call param_get_keyword('hr_cutoff', found, r_value=hr_cutoff) - - dist_cutoff_mode = 'three_dim' - call param_get_keyword('dist_cutoff_mode', found, c_value=dist_cutoff_mode) - if ((index(dist_cutoff_mode, 'three_dim') .eq. 0) & - .and. (index(dist_cutoff_mode, 'two_dim') .eq. 0) & - .and. (index(dist_cutoff_mode, 'one_dim') .eq. 0)) & - call io_error('Error: dist_cutoff_mode not recognised') - -! aam_2012-04-13: moved later -! dist_cutoff = 1000.0_dp -! call param_get_keyword('dist_cutoff',found,r_value=dist_cutoff) - - one_dim_axis = 'none' - call param_get_keyword('one_dim_axis', found, c_value=one_dim_axis) - one_dim_dir = 0 - if (index(one_dim_axis, 'x') > 0) one_dim_dir = 1 - if (index(one_dim_axis, 'y') > 0) one_dim_dir = 2 - if (index(one_dim_axis, 'z') > 0) one_dim_dir = 3 - if (transport .and. .not. tran_read_ht .and. (one_dim_dir .eq. 0)) call io_error('Error: one_dim_axis not recognised') - if (bands_plot .and. (index(bands_plot_mode, 'cut') .ne. 0)& - & .and. ((bands_plot_dim .ne. 3) .or. (index(dist_cutoff_mode, 'three_dim') .eq. 0))& - & .and. (one_dim_dir .eq. 0)) & - call io_error('Error: one_dim_axis not recognised') - -301 continue - - use_ws_distance = .true. - call param_get_keyword('use_ws_distance', found, l_value=use_ws_distance) - - ws_distance_tol = 1.e-5_dp - call param_get_keyword('ws_distance_tol', found, r_value=ws_distance_tol) - - ws_search_size = 2 - - call param_get_vector_length('ws_search_size', found, length=i) - if (found) then - if (i .eq. 1) then - call param_get_keyword_vector('ws_search_size', found, 1, & - i_value=ws_search_size) - ws_search_size(2) = ws_search_size(1) - ws_search_size(3) = ws_search_size(1) - elseif (i .eq. 3) then - call param_get_keyword_vector('ws_search_size', found, 3, & - i_value=ws_search_size) - else - call io_error('Error: ws_search_size must be provided as either one integer or a vector of three integers') - end if - if (any(ws_search_size <= 0)) & - call io_error('Error: ws_search_size elements must be greater than zero') - end if - - !%%%%%%%%%%%%%%%% - ! Transport - !%%%%%%%%%%%%%%%% - - transport_mode = 'bulk' - call param_get_keyword('transport_mode', found, c_value=transport_mode) - -! if ( .not.tran_read_ht .and. (index(transport_mode,'lcr').ne.0) ) & -! call io_error('Error: transport_mode.eq.lcr not compatible with tran_read_ht.eq.false') - - tran_win_min = -3.0_dp - call param_get_keyword('tran_win_min', found, r_value=tran_win_min) - - tran_win_max = 3.0_dp - call param_get_keyword('tran_win_max', found, r_value=tran_win_max) - - tran_energy_step = 0.01_dp - call param_get_keyword('tran_energy_step', found, r_value=tran_energy_step) - - tran_num_bb = 0 - call param_get_keyword('tran_num_bb', found, i_value=tran_num_bb) - - tran_num_ll = 0 - call param_get_keyword('tran_num_ll', found, i_value=tran_num_ll) - - tran_num_rr = 0 - call param_get_keyword('tran_num_rr', found, i_value=tran_num_rr) - - tran_num_cc = 0 - call param_get_keyword('tran_num_cc', found, i_value=tran_num_cc) - - tran_num_lc = 0 - call param_get_keyword('tran_num_lc', found, i_value=tran_num_lc) - - tran_num_cr = 0 - call param_get_keyword('tran_num_cr', found, i_value=tran_num_cr) - - tran_num_bandc = 0 - call param_get_keyword('tran_num_bandc', found, i_value=tran_num_bandc) - - tran_write_ht = .false. - call param_get_keyword('tran_write_ht', found, l_value=tran_write_ht) - - tran_use_same_lead = .true. - call param_get_keyword('tran_use_same_lead', found, l_value=tran_use_same_lead) - - tran_num_cell_ll = 0 - call param_get_keyword('tran_num_cell_ll', found, i_value=tran_num_cell_ll) - - tran_num_cell_rr = 0 - call param_get_keyword('tran_num_cell_rr', found, i_value=tran_num_cell_rr) - - tran_group_threshold = 0.15_dp - call param_get_keyword('tran_group_threshold', found, r_value=tran_group_threshold) - - dist_cutoff = 1000.0_dp - call param_get_keyword('dist_cutoff', found, r_value=dist_cutoff) - - dist_cutoff_hc = dist_cutoff - call param_get_keyword('dist_cutoff_hc', found, r_value=dist_cutoff_hc) - - ! checks - if (transport) then - if ((index(transport_mode, 'bulk') .eq. 0) .and. (index(transport_mode, 'lcr') .eq. 0)) & - call io_error('Error: transport_mode not recognised') - if (tran_num_bb < 0) call io_error('Error: tran_num_bb < 0') - if (tran_num_ll < 0) call io_error('Error: tran_num_ll < 0') - if (tran_num_rr < 0) call io_error('Error: tran_num_rr < 0') - if (tran_num_cc < 0) call io_error('Error: tran_num_cc < 0') - if (tran_num_lc < 0) call io_error('Error: tran_num_lc < 0') - if (tran_num_cr < 0) call io_error('Error: tran_num_cr < 0') - if (tran_num_bandc < 0) call io_error('Error: tran_num_bandc < 0') - if (tran_num_cell_ll < 0) call io_error('Error: tran_num_cell_ll < 0') - if (tran_num_cell_rr < 0) call io_error('Error: tran_num_cell_rr < 0') - if (tran_group_threshold < 0.0_dp) call io_error('Error: tran_group_threshold < 0') - endif - - if (transport .and. tran_read_ht) goto 302 - - !%%%%%%%%%%%%%%%% - ! Disentanglement - !%%%%%%%%%%%%%%%% - - disentanglement = .false. - if (num_bands > num_wann) disentanglement = .true. - - ! These must be read here, before the check on the existence of the .eig file! - geninterp = .false. - call param_get_keyword('geninterp', found, l_value=geninterp) - boltzwann = .false. - call param_get_keyword('boltzwann', found, l_value=boltzwann) - - ! Read the eigenvalues from wannier.eig - eig_found = .false. - if (.not. library .and. .not. effective_model) then - - if (.not. postproc_setup) then - inquire (file=trim(seedname)//'.eig', exist=eig_found) - if (.not. eig_found) then - if (disentanglement) then - call io_error('No '//trim(seedname)//'.eig file found. Needed for disentanglement') - else if ((bands_plot .or. dos_plot .or. fermi_surface_plot .or. write_hr .or. boltzwann & - .or. geninterp)) then - call io_error('No '//trim(seedname)//'.eig file found. Needed for interpolation') - end if - else - ! Allocate only here - allocate (eigval(num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating eigval in param_read') - - eig_unit = io_file_unit() - open (unit=eig_unit, file=trim(seedname)//'.eig', form='formatted', status='old', err=105) - do k = 1, num_kpts - do n = 1, num_bands - read (eig_unit, *, err=106, end=106) i, j, eigval(n, k) - if ((i .ne. n) .or. (j .ne. k)) then - write (stdout, '(a)') 'Found a mismatch in '//trim(seedname)//'.eig' - write (stdout, '(a,i0,a,i0)') 'Wanted band : ', n, ' found band : ', i - write (stdout, '(a,i0,a,i0)') 'Wanted kpoint: ', k, ' found kpoint: ', j - write (stdout, '(a)') ' ' - write (stdout, '(a)') 'A common cause of this error is using the wrong' - write (stdout, '(a)') 'number of bands. Check your input files.' - write (stdout, '(a)') 'If your pseudopotentials have shallow core states remember' - write (stdout, '(a)') 'to account for these electrons.' - write (stdout, '(a)') ' ' - call io_error('param_read: mismatch in '//trim(seedname)//'.eig') - end if - enddo - end do - close (eig_unit) - end if - end if - end if - - if (library .and. allocated(eigval)) eig_found = .true. - - dis_win_min = -1.0_dp; dis_win_max = 0.0_dp - if (eig_found) dis_win_min = minval(eigval) - call param_get_keyword('dis_win_min', found, r_value=dis_win_min) - - if (eig_found) dis_win_max = maxval(eigval) - call param_get_keyword('dis_win_max', found, r_value=dis_win_max) - if (eig_found .and. (dis_win_max .lt. dis_win_min)) & - call io_error('Error: param_read: check disentanglement windows') - - dis_froz_min = -1.0_dp; dis_froz_max = 0.0_dp - ! no default for dis_froz_max - frozen_states = .false. - call param_get_keyword('dis_froz_max', found, r_value=dis_froz_max) - if (found) then - frozen_states = .true. - dis_froz_min = dis_win_min ! default value for the bottom of frozen window - end if - call param_get_keyword('dis_froz_min', found2, r_value=dis_froz_min) - if (eig_found) then - if (dis_froz_max .lt. dis_froz_min) & - call io_error('Error: param_read: check disentanglement frozen windows') - if (found2 .and. .not. found) & - call io_error('Error: param_read: found dis_froz_min but not dis_froz_max') - endif - - dis_num_iter = 200 - call param_get_keyword('dis_num_iter', found, i_value=dis_num_iter) - if (dis_num_iter < 0) call io_error('Error: dis_num_iter must be positive') - - dis_mix_ratio = 0.5_dp - call param_get_keyword('dis_mix_ratio', found, r_value=dis_mix_ratio) - if (dis_mix_ratio <= 0.0_dp .or. dis_mix_ratio > 1.0_dp) & - call io_error('Error: dis_mix_ratio must be greater than 0.0 but not greater than 1.0') - - dis_conv_tol = 1.0e-10_dp - call param_get_keyword('dis_conv_tol', found, r_value=dis_conv_tol) - if (dis_conv_tol < 0.0_dp) call io_error('Error: dis_conv_tol must be positive') - - dis_conv_window = 3 - call param_get_keyword('dis_conv_window', found, i_value=dis_conv_window) - if (dis_conv_window < 0) call io_error('Error: dis_conv_window must be positive') - - ! GS-start - dis_spheres_first_wann = 1 - call param_get_keyword('dis_spheres_first_wann', found, i_value=dis_spheres_first_wann) - if (dis_spheres_first_wann < 1) call io_error('Error: dis_spheres_first_wann must be greater than 0') - if (dis_spheres_first_wann > num_bands - num_wann + 1) & - call io_error('Error: dis_spheres_first_wann is larger than num_bands-num_wann+1') - dis_spheres_num = 0 - call param_get_keyword('dis_spheres_num', found, i_value=dis_spheres_num) - if (dis_spheres_num < 0) call io_error('Error: dis_spheres_num cannot be negative') - if (dis_spheres_num > 0) then - allocate (dis_spheres(4, dis_spheres_num), stat=ierr) - if (ierr /= 0) call io_error('Error allocating dis_spheres in param_read') - call param_get_keyword_block('dis_spheres', found, dis_spheres_num, 4, r_value=dis_spheres) - if (.not. found) call io_error('Error: Did not find dis_spheres in the input file') - do nkp = 1, dis_spheres_num - if (dis_spheres(4, nkp) < 1.0e-15_dp) & - call io_error('Error: radius for dis_spheres must be > 0') - enddo - endif - ! GS-end - - ! [gp-begin, Jun 1, 2012] - !%%%%%%%%%%%%%%%%%%%% - ! General band interpolator (geninterp) - !%%%%%%%%%%%%%%%%%%%% - geninterp_alsofirstder = .false. - call param_get_keyword('geninterp_alsofirstder', found, l_value=geninterp_alsofirstder) - geninterp_single_file = .true. - call param_get_keyword('geninterp_single_file', found, l_value=geninterp_single_file) - ! [gp-end, Jun 1, 2012] - - ! [gp-begin, Apr 12, 2012] - !%%%%%%%%%%%%%%%%%%%% - ! Boltzmann transport - !%%%%%%%%%%%%%%%%%%%% - ! Note: to be put AFTER the disentanglement routines! - - boltz_calc_also_dos = .false. - call param_get_keyword('boltz_calc_also_dos', found, l_value=boltz_calc_also_dos) - - boltz_calc_also_dos = boltz_calc_also_dos .and. boltzwann - - ! 0 means the normal 3d case for the calculation of the Seebeck coefficient - ! The other valid possibilities are 1,2,3 for x,y,z respectively - boltz_2d_dir_num = 0 - call param_get_keyword('boltz_2d_dir', found, c_value=boltz_2d_dir) - if (found) then - if (trim(boltz_2d_dir) == 'no') then - boltz_2d_dir_num = 0 - elseif (trim(boltz_2d_dir) == 'x') then - boltz_2d_dir_num = 1 - elseif (trim(boltz_2d_dir) == 'y') then - boltz_2d_dir_num = 2 - elseif (trim(boltz_2d_dir) == 'z') then - boltz_2d_dir_num = 3 - else - call io_error('Error: boltz_2d_dir can only be "no", "x", "y" or "z".') - end if - end if - - boltz_dos_energy_step = 0.001_dp - call param_get_keyword('boltz_dos_energy_step', found, r_value=boltz_dos_energy_step) - if (found .and. (boltz_dos_energy_step <= 0._dp)) & - call io_error('Error: boltz_dos_energy_step must be positive') - - if (allocated(eigval)) then - boltz_dos_energy_min = minval(eigval) - 0.6667_dp - else - ! Boltz_dos cannot run if eigval is not allocated. - ! We just set here a default numerical value. - boltz_dos_energy_min = -1.0_dp - end if - call param_get_keyword('boltz_dos_energy_min', found, r_value=boltz_dos_energy_min) - if (allocated(eigval)) then - boltz_dos_energy_max = maxval(eigval) + 0.6667_dp - else - ! Boltz_dos cannot run if eigval is not allocated. - ! We just set here a default numerical value. - boltz_dos_energy_max = 0.0_dp - end if - call param_get_keyword('boltz_dos_energy_max', found, r_value=boltz_dos_energy_max) - if (boltz_dos_energy_max <= boltz_dos_energy_min) & - call io_error('Error: boltz_dos_energy_max must be greater than boltz_dos_energy_min') - - boltz_dos_adpt_smr = adpt_smr - call param_get_keyword('boltz_dos_adpt_smr', found, l_value=boltz_dos_adpt_smr) - - boltz_dos_adpt_smr_fac = adpt_smr_fac - call param_get_keyword('boltz_dos_adpt_smr_fac', found, r_value=boltz_dos_adpt_smr_fac) - if (found .and. (boltz_dos_adpt_smr_fac <= 0._dp)) & - call io_error('Error: boltz_dos_adpt_smr_fac must be greater than zero') - - boltz_dos_adpt_smr_max = adpt_smr_max - call param_get_keyword('boltz_dos_adpt_smr_max', found, r_value=boltz_dos_adpt_smr_max) - if (boltz_dos_adpt_smr_max <= 0._dp) call io_error & - ('Error: boltz_dos_adpt_smr_max must be greater than zero') - - boltz_dos_smr_fixed_en_width = smr_fixed_en_width - call param_get_keyword('boltz_dos_smr_fixed_en_width', found, r_value=boltz_dos_smr_fixed_en_width) - if (found .and. (boltz_dos_smr_fixed_en_width < 0._dp)) & - call io_error('Error: boltz_dos_smr_fixed_en_width must be greater than or equal to zero') - - boltz_mu_min = -999._dp - call param_get_keyword('boltz_mu_min', found, r_value=boltz_mu_min) - if ((.not. found) .and. boltzwann) & - call io_error('Error: BoltzWann required but no boltz_mu_min provided') - boltz_mu_max = -999._dp - call param_get_keyword('boltz_mu_max', found2, r_value=boltz_mu_max) - if ((.not. found2) .and. boltzwann) & - call io_error('Error: BoltzWann required but no boltz_mu_max provided') - if (found .and. found2 .and. (boltz_mu_max < boltz_mu_min)) & - call io_error('Error: boltz_mu_max must be greater than boltz_mu_min') - boltz_mu_step = 0._dp - call param_get_keyword('boltz_mu_step', found, r_value=boltz_mu_step) - if ((.not. found) .and. boltzwann) & - call io_error('Error: BoltzWann required but no boltz_mu_step provided') - if (found .and. (boltz_mu_step <= 0._dp)) & - call io_error('Error: boltz_mu_step must be greater than zero') - - boltz_temp_min = -999._dp - call param_get_keyword('boltz_temp_min', found, r_value=boltz_temp_min) - if ((.not. found) .and. boltzwann) & - call io_error('Error: BoltzWann required but no boltz_temp_min provided') - boltz_temp_max = -999._dp - call param_get_keyword('boltz_temp_max', found2, r_value=boltz_temp_max) - if ((.not. found2) .and. boltzwann) & - call io_error('Error: BoltzWann required but no boltz_temp_max provided') - if (found .and. found2 .and. (boltz_temp_max < boltz_temp_min)) & - call io_error('Error: boltz_temp_max must be greater than boltz_temp_min') - if (found .and. (boltz_temp_min <= 0._dp)) & - call io_error('Error: boltz_temp_min must be greater than zero') - boltz_temp_step = 0._dp - call param_get_keyword('boltz_temp_step', found, r_value=boltz_temp_step) - if ((.not. found) .and. boltzwann) & - call io_error('Error: BoltzWann required but no boltz_temp_step provided') - if (found .and. (boltz_temp_step <= 0._dp)) & - call io_error('Error: boltz_temp_step must be greater than zero') - - ! The interpolation mesh is read later on - - ! By default, the energy step for the TDF is 1 meV - boltz_tdf_energy_step = 0.001_dp - call param_get_keyword('boltz_tdf_energy_step', found, r_value=boltz_tdf_energy_step) - if (boltz_tdf_energy_step <= 0._dp) & - call io_error('Error: boltz_tdf_energy_step must be greater than zero') - - ! For TDF: TDF smeared in a NON-adaptive way; value in eV, default = 0._dp - ! (i.e., no smearing) - boltz_TDF_smr_fixed_en_width = smr_fixed_en_width - call param_get_keyword('boltz_tdf_smr_fixed_en_width', found, r_value=boltz_TDF_smr_fixed_en_width) - if (found .and. (boltz_TDF_smr_fixed_en_width < 0._dp)) & - call io_error('Error: boltz_TDF_smr_fixed_en_width must be greater than or equal to zero') - - ! By default: use the "global" smearing index - boltz_TDF_smr_index = smr_index - call param_get_keyword('boltz_tdf_smr_type', found, c_value=ctmp) - if (found) boltz_TDF_smr_index = get_smearing_index(ctmp, 'boltz_tdf_smr_type') - - ! By default: use the "global" smearing index - boltz_dos_smr_index = smr_index - call param_get_keyword('boltz_dos_smr_type', found, c_value=ctmp) - if (found) boltz_dos_smr_index = get_smearing_index(ctmp, 'boltz_dos_smr_type') - - ! By default: use the "global" smearing index - dos_smr_index = smr_index - call param_get_keyword('dos_smr_type', found, c_value=ctmp) - if (found) dos_smr_index = get_smearing_index(ctmp, 'dos_smr_type') - - ! By default: use the "global" smearing index - kubo_smr_index = smr_index - call param_get_keyword('kubo_smr_type', found, c_value=ctmp) - if (found) kubo_smr_index = get_smearing_index(ctmp, 'kubo_smr_type') - - ! By default: use the "global" smearing index - gyrotropic_smr_index = smr_index - call param_get_keyword('gyrotropic_smr_type', found, c_value=ctmp) - if (found) gyrotropic_smr_index = get_smearing_index(ctmp, 'gyrotropic_smr_type') - - ! By default: 10 fs relaxation time - boltz_relax_time = 10._dp - call param_get_keyword('boltz_relax_time', found, r_value=boltz_relax_time) - - boltz_bandshift = .false. - call param_get_keyword('boltz_bandshift', found, l_value=boltz_bandshift) - boltz_bandshift = boltz_bandshift .and. boltzwann - - boltz_bandshift_firstband = 0 - call param_get_keyword('boltz_bandshift_firstband', found, i_value=boltz_bandshift_firstband) - if (boltz_bandshift .and. (.not. found)) & - call io_error('Error: boltz_bandshift required but no boltz_bandshift_firstband provided') - boltz_bandshift_energyshift = 0._dp - call param_get_keyword('boltz_bandshift_energyshift', found, r_value=boltz_bandshift_energyshift) - if (boltz_bandshift .and. (.not. found)) & - call io_error('Error: boltz_bandshift required but no boltz_bandshift_energyshift provided') - ! [gp-end, Apr 12, 2012] - - !%%%%%%%%%%%%%%%% - ! Other Stuff - !%%%%%%%%%%%%%%%% - - ! aam: vdW - write_vdw_data = .false. - call param_get_keyword('write_vdw_data', found, l_value=write_vdw_data) - if (write_vdw_data) then - if ((.not. gamma_only) .or. (num_kpts .ne. 1)) & - call io_error('Error: write_vdw_data may only be used with a single k-point at Gamma') - endif - if (write_vdw_data .and. disentanglement .and. num_valence_bands .le. 0) & - call io_error('If writing vdw data and disentangling then num_valence_bands must be defined') - - if (frozen_states) then - dos_energy_max = dis_froz_max + 0.6667_dp - elseif (allocated(eigval)) then - dos_energy_max = maxval(eigval) + 0.6667_dp - else - dos_energy_max = dis_win_max + 0.6667_dp - end if - call param_get_keyword('dos_energy_max', found, r_value=dos_energy_max) - - if (allocated(eigval)) then - dos_energy_min = minval(eigval) - 0.6667_dp - else - dos_energy_min = dis_win_min - 0.6667_dp - end if - call param_get_keyword('dos_energy_min', found, r_value=dos_energy_min) - - kubo_freq_min = 0.0_dp - gyrotropic_freq_min = kubo_freq_min - call param_get_keyword('kubo_freq_min', found, r_value=kubo_freq_min) - ! - if (frozen_states) then - kubo_freq_max = dis_froz_max - fermi_energy_list(1) + 0.6667_dp - elseif (allocated(eigval)) then - kubo_freq_max = maxval(eigval) - minval(eigval) + 0.6667_dp - else - kubo_freq_max = dis_win_max - dis_win_min + 0.6667_dp - end if - gyrotropic_freq_max = kubo_freq_max - call param_get_keyword('kubo_freq_max', found, r_value=kubo_freq_max) - - ! - kubo_freq_step = 0.01_dp - call param_get_keyword('kubo_freq_step', found, r_value=kubo_freq_step) - if (found .and. kubo_freq_step < 0.0_dp) call io_error( & - 'Error: kubo_freq_step must be positive') - ! - kubo_nfreq = nint((kubo_freq_max - kubo_freq_min)/kubo_freq_step) + 1 - if (kubo_nfreq <= 1) kubo_nfreq = 2 - kubo_freq_step = (kubo_freq_max - kubo_freq_min)/(kubo_nfreq - 1) - ! - if (allocated(kubo_freq_list)) deallocate (kubo_freq_list) - allocate (kubo_freq_list(kubo_nfreq), stat=ierr) - if (ierr /= 0) & - call io_error('Error allocating kubo_freq_list in param_read') - do i = 1, kubo_nfreq - kubo_freq_list(i) = kubo_freq_min & - + (i - 1)*(kubo_freq_max - kubo_freq_min)/(kubo_nfreq - 1) - enddo - ! - ! TODO: Alternatively, read list of (complex) frequencies; kubo_nfreq is - ! the length of the list - - gyrotropic_freq_step = 0.01_dp - call param_get_keyword('gyrotropic_freq_min', found, r_value=gyrotropic_freq_min) - call param_get_keyword('gyrotropic_freq_max', found, r_value=gyrotropic_freq_max) - call param_get_keyword('gyrotropic_freq_step', found, r_value=gyrotropic_freq_step) - gyrotropic_nfreq = nint((gyrotropic_freq_max - gyrotropic_freq_min)/gyrotropic_freq_step) + 1 - if (gyrotropic_nfreq <= 1) gyrotropic_nfreq = 2 - gyrotropic_freq_step = (gyrotropic_freq_max - gyrotropic_freq_min)/(gyrotropic_nfreq - 1) - if (allocated(gyrotropic_freq_list)) deallocate (gyrotropic_freq_list) - allocate (gyrotropic_freq_list(gyrotropic_nfreq), stat=ierr) - if (ierr /= 0) & - call io_error('Error allocating gyrotropic_freq_list in param_read') - do i = 1, gyrotropic_nfreq - gyrotropic_freq_list(i) = gyrotropic_freq_min & - + (i - 1)*(gyrotropic_freq_max - gyrotropic_freq_min)/(gyrotropic_nfreq - 1) & - + cmplx_i*gyrotropic_smr_fixed_en_width - enddo - - if (frozen_states) then - kubo_eigval_max = dis_froz_max + 0.6667_dp - elseif (allocated(eigval)) then - kubo_eigval_max = maxval(eigval) + 0.6667_dp - else - kubo_eigval_max = dis_win_max + 0.6667_dp - end if - gyrotropic_eigval_max = kubo_eigval_max - - call param_get_keyword('kubo_eigval_max', found, r_value=kubo_eigval_max) - call param_get_keyword('gyrotropic_eigval_max', found, r_value=gyrotropic_eigval_max) - - automatic_translation = .true. - translation_centre_frac = 0.0_dp - call param_get_keyword_vector('translation_centre_frac', found, 3, r_value=rv_temp) - if (found) then - translation_centre_frac = rv_temp - automatic_translation = .false. - endif - - sc_eta = 0.04 - call param_get_keyword('sc_eta', found, r_value=sc_eta) - - sc_w_thr = 5.0d0 - call param_get_keyword('sc_w_thr', found, r_value=sc_w_thr) - - kdotp_kpoint(:) = 0.0_dp - call param_get_keyword_vector('kdotp_kpoint', found, 3, r_value=kdotp_kpoint) - - kdotp_num_bands = 0 - call param_get_keyword('kdotp_num_bands', found, i_value=kdotp_num_bands) - if (found) then - if (kdotp_num_bands < 1) call io_error('Error: problem reading kdotp_num_bands') - allocate (kdotp_bands(kdotp_num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating kdotp_num_bands in param_read') - call param_get_range_vector('kdotp_bands', found, kdotp_num_bands, .false., kdotp_bands) - if (any(kdotp_bands < 1)) & - call io_error('Error: kdotp_bands must contain positive numbers') - end if - - use_bloch_phases = .false. - call param_get_keyword('use_bloch_phases', found, l_value=use_bloch_phases) - if (disentanglement .and. use_bloch_phases) & - call io_error('Error: Cannot use bloch phases for disentanglement') - - search_shells = 36 - call param_get_keyword('search_shells', found, i_value=search_shells) - if (search_shells < 0) call io_error('Error: search_shells must be positive') - - kmesh_tol = 0.000001_dp - call param_get_keyword('kmesh_tol', found, r_value=kmesh_tol) - if (kmesh_tol < 0.0_dp) call io_error('Error: kmesh_tol must be positive') - - num_shells = 0 - call param_get_range_vector('shell_list', found, num_shells, lcount=.true.) - if (found) then - if (num_shells < 0 .or. num_shells > max_shells) & - call io_error('Error: number of shell in shell_list must be between zero and six') - if (allocated(shell_list)) deallocate (shell_list) - allocate (shell_list(num_shells), stat=ierr) - if (ierr /= 0) call io_error('Error allocating shell_list in param_read') - call param_get_range_vector('shell_list', found, num_shells, .false., shell_list) - if (any(shell_list < 1)) & - call io_error('Error: shell_list must contain positive numbers') - else - if (allocated(shell_list)) deallocate (shell_list) - allocate (shell_list(max_shells), stat=ierr) - if (ierr /= 0) call io_error('Error allocating shell_list in param_read') - end if - - call param_get_keyword('num_shells', found, i_value=itmp) - if (found .and. (itmp /= num_shells)) & - call io_error('Error: Found obsolete keyword num_shells. Its value does not agree with shell_list') - - ! If .true., does not perform the check of B1 of - ! Marzari, Vanderbild, PRB 56, 12847 (1997) - ! in kmesh.F90 - ! mainly needed for the interaction with Z2PACK - ! By default: .false. (perform the tests) - skip_B1_tests = .false. - call param_get_keyword('skip_b1_tests', found, l_value=skip_B1_tests) - - call param_get_keyword_block('unit_cell_cart', found, 3, 3, r_value=real_lattice_tmp) - if (found .and. library) write (stdout, '(a)') ' Ignoring in input file' - if (.not. library) then - real_lattice = transpose(real_lattice_tmp) - if (.not. found) call io_error('Error: Did not find the cell information in the input file') - end if - - if (.not. library) & - call utility_recip_lattice(real_lattice, recip_lattice, cell_volume) - call utility_metric(real_lattice, recip_lattice, real_metric, recip_metric) - - if (.not. effective_model) allocate (kpt_cart(3, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating kpt_cart in param_read') - if (.not. library .and. .not. effective_model) then - allocate (kpt_latt(3, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating kpt_latt in param_read') - end if - - call param_get_keyword_block('kpoints', found, num_kpts, 3, r_value=kpt_cart) - if (found .and. library) write (stdout, '(a)') ' Ignoring in input file' - if (.not. library .and. .not. effective_model) then - kpt_latt = kpt_cart - if (.not. found) call io_error('Error: Did not find the kpoint information in the input file') - end if - - ! Calculate the kpoints in cartesian coordinates - if (.not. effective_model) then - do nkp = 1, num_kpts - kpt_cart(:, nkp) = matmul(kpt_latt(:, nkp), recip_lattice(:, :)) - end do - endif - - ! get the nnkpts block -- this is allowed only in postproc-setup mode - call param_get_block_length('nnkpts', explicit_nnkpts, rows) - if (explicit_nnkpts) then - nntot = rows/num_kpts - if (modulo(rows, num_kpts) /= 0) then - call io_error('The number of rows in nnkpts must be a multiple of num_kpts') - end if - if (allocated(nnkpts_block)) deallocate (nnkpts_block) - allocate (nnkpts_block(5, rows), stat=ierr) - if (ierr /= 0) call io_error('Error allocating nnkpts_block in param_read') - call param_get_keyword_block('nnkpts', found, rows, 5, i_value=nnkpts_block) - ! check that postproc_setup is true - if (.not. postproc_setup) & - call io_error('Input parameter nnkpts_block is allowed only if postproc_setup = .true.') - ! assign the values in nnkpts_block to nnlist and nncell - ! this keeps track of how many neighbours have been seen for each k-point - if (allocated(nnkpts_idx)) deallocate (nnkpts_idx) - allocate (nnkpts_idx(num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating nnkpts_idx in param_read') - nnkpts_idx = 1 - ! allocating "global" nnlist & nncell - ! These are deallocated in kmesh_dealloc - if (allocated(nnlist)) deallocate (nnlist) - allocate (nnlist(num_kpts, nntot), stat=ierr) - if (ierr /= 0) call io_error('Error allocating nnlist in param_read') - if (allocated(nncell)) deallocate (nncell) - allocate (nncell(3, num_kpts, nntot), stat=ierr) - if (ierr /= 0) call io_error('Error allocating nncell in param_read') - do i = 1, num_kpts*nntot - k = nnkpts_block(1, i) - nnlist(k, nnkpts_idx(k)) = nnkpts_block(2, i) - nncell(:, k, nnkpts_idx(k)) = nnkpts_block(3:, i) - nnkpts_idx(k) = nnkpts_idx(k) + 1 - end do - ! check that all k-points have the same number of neighbours - if (any(nnkpts_idx /= (/(nntot + 1, i=1, num_kpts)/))) then - call io_error('Inconsistent number of nearest neighbours.') - end if - deallocate (nnkpts_idx, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating nnkpts_idx in param_read') - deallocate (nnkpts_block, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating nnkpts_block in param_read') - end if - - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! - ! k meshes ! - !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! - ! [GP-begin, Apr13, 2012] - ! Global interpolation k-mesh; this is overridden by "local" meshes of a given submodule - ! This bit of code must appear *before* all other codes for the local interpolation meshes, - ! BUT *after* having calculated the reciprocal-space vectors. - global_kmesh_set = .false. - kmesh_spacing = -1._dp - kmesh = 0 - call param_get_keyword('kmesh_spacing', found, r_value=kmesh_spacing) - if (found) then - if (kmesh_spacing .le. 0._dp) & - call io_error('Error: kmesh_spacing must be greater than zero') - global_kmesh_set = .true. - - call internal_set_kmesh(kmesh_spacing, recip_lattice, kmesh) - end if - call param_get_vector_length('kmesh', found, length=i) - if (found) then - if (global_kmesh_set) & - call io_error('Error: cannot set both kmesh and kmesh_spacing') - if (i .eq. 1) then - global_kmesh_set = .true. - call param_get_keyword_vector('kmesh', found, 1, i_value=kmesh) - kmesh(2) = kmesh(1) - kmesh(3) = kmesh(1) - elseif (i .eq. 3) then - global_kmesh_set = .true. - call param_get_keyword_vector('kmesh', found, 3, i_value=kmesh) - else - call io_error('Error: kmesh must be provided as either one integer or a vector of three integers') - end if - if (any(kmesh <= 0)) & - call io_error('Error: kmesh elements must be greater than zero') - end if - ! [GP-end] - - ! To be called after having read the global flag - call get_module_kmesh(moduleprefix='boltz', & - should_be_defined=boltzwann, & - module_kmesh=boltz_kmesh, & - module_kmesh_spacing=boltz_kmesh_spacing) - - call get_module_kmesh(moduleprefix='berry', & - should_be_defined=berry, & - module_kmesh=berry_kmesh, & - module_kmesh_spacing=berry_kmesh_spacing) - - call get_module_kmesh(moduleprefix='gyrotropic', & - should_be_defined=gyrotropic, & - module_kmesh=gyrotropic_kmesh, & - module_kmesh_spacing=gyrotropic_kmesh_spacing) - - call get_module_kmesh(moduleprefix='spin', & - should_be_defined=spin_moment, & - module_kmesh=spin_kmesh, & - module_kmesh_spacing=spin_kmesh_spacing) - - call get_module_kmesh(moduleprefix='dos', & - should_be_defined=dos, & - module_kmesh=dos_kmesh, & - module_kmesh_spacing=dos_kmesh_spacing) - - ! Atoms - if (.not. library) num_atoms = 0 - call param_get_block_length('atoms_frac', found, i_temp) - if (found .and. library) write (stdout, '(a)') ' Ignoring in input file' - call param_get_block_length('atoms_cart', found2, i_temp2, lunits) - if (found2 .and. library) write (stdout, '(a)') ' Ignoring in input file' - if (.not. library) then - if (found .and. found2) call io_error('Error: Cannot specify both atoms_frac and atoms_cart') - if (found .and. i_temp > 0) then - lunits = .false. - num_atoms = i_temp - elseif (found2 .and. i_temp2 > 0) then - num_atoms = i_temp2 - if (lunits) num_atoms = num_atoms - 1 - end if - if (num_atoms > 0) then - call param_get_atoms(lunits) - end if - endif - - ! Projections - auto_projections = .false. - call param_get_keyword('auto_projections', found, l_value=auto_projections) - num_proj = 0 - call param_get_block_length('projections', found, i_temp) - ! check to see that there are no unrecognised keywords - if (found) then - if (auto_projections) call io_error('Error: Cannot specify both auto_projections and projections block') - lhasproj = .true. - call param_get_projections(num_proj, lcount=.true.) - else - if (guiding_centres .and. .not. (gamma_only .and. use_bloch_phases)) & - call io_error('param_read: Guiding centres requested, but no projection block found') - lhasproj = .false. - num_proj = num_wann - end if - - lselproj = .false. - num_select_projections = 0 - call param_get_range_vector('select_projections', found, num_select_projections, lcount=.true.) - if (found) then - if (num_select_projections < 1) call io_error('Error: problem reading select_projections') - if (allocated(select_projections)) deallocate (select_projections) - allocate (select_projections(num_select_projections), stat=ierr) - if (ierr /= 0) call io_error('Error allocating select_projections in param_read') - call param_get_range_vector('select_projections', found, num_select_projections, .false., select_projections) - if (any(select_projections < 1)) & - call io_error('Error: select_projections must contain positive numbers') - if (num_select_projections < num_wann) & - call io_error('Error: too few projections selected') - if (num_select_projections > num_wann) & - call io_error('Error: too many projections selected') - if (.not. lhasproj) & - call io_error('Error: select_projections cannot be used without defining the projections') - if (maxval(select_projections(:)) > num_proj) & - call io_error('Error: select_projections contains a number greater than num_proj') - lselproj = .true. - end if - - if (allocated(proj2wann_map)) deallocate (proj2wann_map) - allocate (proj2wann_map(num_proj), stat=ierr) - if (ierr /= 0) call io_error('Error allocating proj2wann_map in param_read') - proj2wann_map = -1 - - if (lselproj) then - do i = 1, num_proj - do j = 1, num_wann - if (select_projections(j) == i) proj2wann_map(i) = j - enddo - enddo - else - do i = 1, num_wann - proj2wann_map(i) = i - enddo - endif - - if (lhasproj) call param_get_projections(num_proj, lcount=.false.) - - ! Constrained centres - call param_get_block_length('slwf_centres', found, i_temp) - if (found) then - if (slwf_constrain) then - ! Allocate array for constrained centres - call param_get_centre_constraints - else - write (stdout, '(a)') ' slwf_constrain set to false. Ignoring block ' - end if - ! Check that either projections or constrained centres are specified if slwf_constrain=.true. - elseif (.not. found) then - if (slwf_constrain) then - if (.not. allocated(proj_site)) then - call io_error('Error: slwf_constrain = true, but neither & - & block nor & - & are specified.') - else - ! Allocate array for constrained centres - call param_get_centre_constraints - end if - end if - end if - ! Warning - if (slwf_constrain .and. allocated(proj_site) .and. .not. found) & - & write (stdout, '(a)') ' Warning: No block found, but slwf_constrain set to true. & - & Desired centres for SLWF same as projection centres.' - -302 continue - - if (any(len_trim(in_data(:)) > 0)) then - write (stdout, '(1x,a)') 'The following section of file '//trim(seedname)//'.win contained unrecognised keywords' - write (stdout, *) - do loop = 1, num_lines - if (len_trim(in_data(loop)) > 0) then - write (stdout, '(1x,a)') trim(in_data(loop)) - end if - end do - write (stdout, *) - call io_error('Unrecognised keyword(s) in input file, see also output file') - end if - - if (transport .and. tran_read_ht) goto 303 - - ! For aesthetic purposes, convert some things to uppercase - call param_uppercase() - -303 continue - - deallocate (in_data, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating in_data in param_read') - - if (transport .and. tran_read_ht) return - - ! =============================== ! - ! Some checks and initialisations ! - ! =============================== ! - -! if (restart.ne.' ') disentanglement=.false. - - if (disentanglement) then - if (allocated(ndimwin)) deallocate (ndimwin) - allocate (ndimwin(num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating ndimwin in param_read') - if (allocated(lwindow)) deallocate (lwindow) - allocate (lwindow(num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating lwindow in param_read') - endif - -! if ( wannier_plot .and. (index(wannier_plot_format,'cub').ne.0) ) then -! cosa(1)=dot_product(real_lattice(1,:),real_lattice(2,:)) -! cosa(2)=dot_product(real_lattice(1,:),real_lattice(3,:)) -! cosa(3)=dot_product(real_lattice(2,:),real_lattice(3,:)) -! cosa = abs(cosa) -! if (any(cosa.gt.eps6)) & -! call io_error('Error: plotting in cube format requires orthogonal lattice vectors') -! endif - - ! Initialise - omega_total = -999.0_dp - omega_tilde = -999.0_dp - omega_invariant = -999.0_dp - have_disentangled = .false. - - if (allocated(wannier_centres)) deallocate (wannier_centres) - allocate (wannier_centres(3, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating wannier_centres in param_read') - wannier_centres = 0.0_dp - if (allocated(wannier_spreads)) deallocate (wannier_spreads) - allocate (wannier_spreads(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating wannier_spreads in param_read') - wannier_spreads = 0.0_dp - - return - -105 call io_error('Error: Problem opening eigenvalue file '//trim(seedname)//'.eig') -106 call io_error('Error: Problem reading eigenvalue file '//trim(seedname)//'.eig') - - end subroutine param_read - - subroutine internal_set_kmesh(spacing, reclat, mesh) - !! This routines returns the three integers that define the interpolation k-mesh, satisfying - !! the condition that the spacing between two neighboring points along each of the three - !! k_x, k_y and k_z directions is at smaller than a given spacing. - !! - !! The reclat is defined as: - !! * 'b_1' = (recip_lattice(1,I), i=1,3) - !! * 'b_2' = (recip_lattice(2,I), i=1,3) - !! * 'b_3' = (recip_lattice(3,I), i=1,3) - !! - !! spacing must be > 0 (and in particular different from zero). We don't check this here. - !! - implicit none - real(kind=dp), intent(in) :: spacing - !! Minimum spacing between neighboring points, in angstrom^(-1) - real(kind=dp), dimension(3, 3), intent(in) :: reclat - !! Matrix of the reciprocal lattice vectors in cartesian coordinates, in angstrom^(-1) - integer, dimension(3), intent(out) :: mesh - !! Will contain the three integers defining the interpolation k-mesh - - real(kind=dp), dimension(3) :: blen - integer :: i - - do i = 1, 3 - blen(i) = sqrt(sum(reclat(i, :)**2)) - end do - - do i = 1, 3 - mesh(i) = int(floor(blen(i)/spacing)) + 1 - end do - - end subroutine internal_set_kmesh - - subroutine get_module_kmesh(moduleprefix, should_be_defined, module_kmesh, module_kmesh_spacing) - !! This function reads and sets the interpolation mesh variables needed by a given module - !> - !! This function MUST be called after having read the global kmesh and kmesh_spacing!! - !! if the user didn't provide an interpolation_mesh_spacing, it is set to -1, so that - !! one can check in the code what the user asked for - !! The function takes care also of setting the default value to the global one if no local - !! keyword is defined - use w90_io, only: io_error - character(len=*), intent(in) :: moduleprefix - !!The prefix that is appended before the name of the variables. In particular, - !!if the prefix is for instance XXX, the two variables that are read from the - !!input file are XXX_kmesh and XXX_kmesh_spacing. - logical, intent(in) :: should_be_defined - !! A logical flag: if it is true, at the end the code stops if no value is specified. - !! Define it to .false. if no check should be performed. - !! Often, you can simply pass the flag that activates the module itself. - integer, dimension(3), intent(out) :: module_kmesh - !! the integer array (length 3) where the interpolation mesh will be saved - real(kind=dp), intent(out) :: module_kmesh_spacing - !! the real number on which the min mesh spacing is saved. -1 if it the - !!user specifies in input the mesh and not the mesh_spacing - - logical :: found, found2 - integer :: i - - ! Default values - module_kmesh_spacing = -1._dp - module_kmesh = 0 - call param_get_keyword(trim(moduleprefix)//'_kmesh_spacing', found, r_value=module_kmesh_spacing) - if (found) then - if (module_kmesh_spacing .le. 0._dp) & - call io_error('Error: '//trim(moduleprefix)//'_kmesh_spacing must be greater than zero') - - call internal_set_kmesh(module_kmesh_spacing, recip_lattice, module_kmesh) - end if - call param_get_vector_length(trim(moduleprefix)//'_kmesh', found2, length=i) - if (found2) then - if (found) & - call io_error('Error: cannot set both '//trim(moduleprefix)//'_kmesh and ' & - //trim(moduleprefix)//'_kmesh_spacing') - if (i .eq. 1) then - call param_get_keyword_vector(trim(moduleprefix)//'_kmesh', found2, 1, i_value=module_kmesh) - module_kmesh(2) = module_kmesh(1) - module_kmesh(3) = module_kmesh(1) - elseif (i .eq. 3) then - call param_get_keyword_vector(trim(moduleprefix)//'_kmesh', found2, 3, i_value=module_kmesh) - else - call io_error('Error: '//trim(moduleprefix)// & - '_kmesh must be provided as either one integer or a vector of 3 integers') - end if - if (any(module_kmesh <= 0)) & - call io_error('Error: '//trim(moduleprefix)//'_kmesh elements must be greater than zero') - end if - - if ((found .eqv. .false.) .and. (found2 .eqv. .false.)) then - ! This is the case where no "local" interpolation k-mesh is provided in the input - if (global_kmesh_set) then - module_kmesh = kmesh - ! I set also boltz_kmesh_spacing so that I can check if it is < 0 or not, and if it is - ! > 0 I can print on output the mesh spacing that was chosen - module_kmesh_spacing = kmesh_spacing - else - if (should_be_defined) & - call io_error('Error: '//trim(moduleprefix)//' module required, but no interpolation mesh given.') - end if - end if - end subroutine get_module_kmesh - - function param_get_smearing_type(smearing_index) - !! This function returns a string describing the type of smearing - !! associated to a given smr_index integer value. - integer, intent(in) :: smearing_index - !! The integer index for which we want to get the string - character(len=80) :: param_get_smearing_type - - character(len=4) :: orderstr - - if (smearing_index > 0) then - write (orderstr, '(I0)') smearing_index - param_get_smearing_type = "Methfessel-Paxton of order "//trim(orderstr) - else if (smearing_index .eq. 0) then - param_get_smearing_type = "Gaussian" - else if (smearing_index .eq. -1) then - param_get_smearing_type = "Marzari-Vanderbilt cold smearing" - else if (smearing_index .eq. -99) then - param_get_smearing_type = "Fermi-Dirac smearing" - else - param_get_smearing_type = "Unknown type of smearing" - end if - - end function param_get_smearing_type - - function param_get_convention_type(sc_phase_conv) - !! This function returns a string describing the convention - !! associated to a sc_phase_conv integer value. - integer, intent(in) :: sc_phase_conv - !! The integer index for which we want to get the string - character(len=80) :: param_get_convention_type - - character(len=4) :: orderstr - - if (sc_phase_conv .eq. 1) then - param_get_convention_type = "Tight-binding convention" - else if (sc_phase_conv .eq. 2) then - param_get_convention_type = "Wannier90 convention" - else - param_get_convention_type = "Unknown type of convention" - end if - - end function param_get_convention_type - - function get_smearing_index(string, keyword) - !! This function parses a string containing the type of - !! smearing and returns the correct index for the smearing_index variable - ! - !! If the string is not valid, an io_error is issued - use w90_io, only: io_error - character(len=*), intent(in) :: string - !! The string read from input - character(len=*), intent(in) :: keyword - !! The keyword that was read (e.g., smr_type), so that we can print a more useful error message - integer :: get_smearing_index - - integer :: pos - - get_smearing_index = 0 ! To avoid warnings of unset variables - - if (index(string, 'm-v') > 0) then - get_smearing_index = -1 - elseif (index(string, 'm-p') > 0) then - pos = index(string, 'm-p') - if (len(trim(string(pos + 3:))) .eq. 0) then - ! If the string is only 'm-p', we assume that 'm-p1' was intended - get_smearing_index = 1 - else - read (string(pos + 3:), *, err=337) get_smearing_index - if (get_smearing_index < 0) & - call io_error('Wrong m-p smearing order in keyword '//trim(keyword)) - end if - elseif (index(string, 'f-d') > 0) then - get_smearing_index = -99 - ! Some aliases - elseif (index(string, 'cold') > 0) then - get_smearing_index = -1 - elseif (index(string, 'gauss') > 0) then - get_smearing_index = 0 - ! Unrecognised keyword - else - call io_error('Unrecognised value for keyword '//trim(keyword)) - end if - - return - -337 call io_error('Wrong m-p smearing order in keyword '//trim(keyword)) - - end function get_smearing_index - -!=================================================================== - subroutine param_uppercase - !=================================================================== - ! ! - !! Convert a few things to uppercase to look nice in the output - ! ! - !=================================================================== - - implicit none - - integer :: nsp, ic, loop, inner_loop - - ! Atom labels (eg, si --> Si) - do nsp = 1, num_species - ic = ichar(atoms_label(nsp) (1:1)) - if ((ic .ge. ichar('a')) .and. (ic .le. ichar('z'))) & - atoms_label(nsp) (1:1) = char(ic + ichar('Z') - ichar('z')) - enddo - - do nsp = 1, num_species - ic = ichar(atoms_symbol(nsp) (1:1)) - if ((ic .ge. ichar('a')) .and. (ic .le. ichar('z'))) & - atoms_symbol(nsp) (1:1) = char(ic + ichar('Z') - ichar('z')) - enddo - - ! Bands labels (eg, x --> X) - do loop = 1, bands_num_spec_points - do inner_loop = 1, len(bands_label(loop)) - ic = ichar(bands_label(loop) (inner_loop:inner_loop)) - if ((ic .ge. ichar('a')) .and. (ic .le. ichar('z'))) & - bands_label(loop) (inner_loop:inner_loop) = char(ic + ichar('Z') - ichar('z')) - enddo - enddo - - ! Length unit (ang --> Ang, bohr --> Bohr) - ic = ichar(length_unit(1:1)) - if ((ic .ge. ichar('a')) .and. (ic .le. ichar('z'))) & - length_unit(1:1) = char(ic + ichar('Z') - ichar('z')) - - return - - end subroutine param_uppercase - -!=================================================================== - subroutine param_write - !==================================================================! - ! ! - !! write wannier90 parameters to stdout - ! ! - !=================================================================== - - implicit none - - integer :: i, nkp, loop, nat, nsp - - if (transport .and. tran_read_ht) goto 401 - - ! System - write (stdout, *) - write (stdout, '(36x,a6)') '------' - write (stdout, '(36x,a6)') 'SYSTEM' - write (stdout, '(36x,a6)') '------' - write (stdout, *) - if (lenconfac .eq. 1.0_dp) then - write (stdout, '(30x,a21)') 'Lattice Vectors (Ang)' - else - write (stdout, '(28x,a22)') 'Lattice Vectors (Bohr)' - endif - write (stdout, 101) 'a_1', (real_lattice(1, I)*lenconfac, i=1, 3) - write (stdout, 101) 'a_2', (real_lattice(2, I)*lenconfac, i=1, 3) - write (stdout, 101) 'a_3', (real_lattice(3, I)*lenconfac, i=1, 3) - write (stdout, *) - write (stdout, '(19x,a17,3x,f11.5)', advance='no') & - 'Unit Cell Volume:', cell_volume*lenconfac**3 - if (lenconfac .eq. 1.0_dp) then - write (stdout, '(2x,a7)') '(Ang^3)' - else - write (stdout, '(2x,a8)') '(Bohr^3)' - endif - write (stdout, *) - if (lenconfac .eq. 1.0_dp) then - write (stdout, '(24x,a33)') 'Reciprocal-Space Vectors (Ang^-1)' - else - write (stdout, '(22x,a34)') 'Reciprocal-Space Vectors (Bohr^-1)' - endif - write (stdout, 101) 'b_1', (recip_lattice(1, I)/lenconfac, i=1, 3) - write (stdout, 101) 'b_2', (recip_lattice(2, I)/lenconfac, i=1, 3) - write (stdout, 101) 'b_3', (recip_lattice(3, I)/lenconfac, i=1, 3) - write (stdout, *) ' ' - ! Atoms - if (num_atoms > 0) then - write (stdout, '(1x,a)') '*----------------------------------------------------------------------------*' - if (lenconfac .eq. 1.0_dp) then - write (stdout, '(1x,a)') '| Site Fractional Coordinate Cartesian Coordinate (Ang) |' - else - write (stdout, '(1x,a)') '| Site Fractional Coordinate Cartesian Coordinate (Bohr) |' - endif - write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' - do nsp = 1, num_species - do nat = 1, atoms_species_num(nsp) - write (stdout, '(1x,a1,1x,a2,1x,i3,3F10.5,3x,a1,1x,3F10.5,4x,a1)') & - & '|', atoms_symbol(nsp), nat, atoms_pos_frac(:, nat, nsp),& - & '|', atoms_pos_cart(:, nat, nsp)*lenconfac, '|' - end do - end do - write (stdout, '(1x,a)') '*----------------------------------------------------------------------------*' - else - write (stdout, '(25x,a)') 'No atom positions specified' - end if - ! Constrained centres - if (selective_loc .and. slwf_constrain) then - write (stdout, *) ' ' - write (stdout, '(1x,a)') '*----------------------------------------------------------------------------*' - write (stdout, '(1x,a)') '| Wannier# Original Centres Constrained centres |' - write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' - do i = 1, slwf_num - write (stdout, '(1x,a1,2x,i3,2x,3F10.5,3x,a1,1x,3F10.5,4x,a1)') & - & '|', i, ccentres_frac(i, :), '|', wannier_centres(:, i), '|' - end do - write (stdout, '(1x,a)') '*----------------------------------------------------------------------------*' - end if - ! Projections - if (iprint > 1 .and. allocated(input_proj_site)) then - write (stdout, '(32x,a)') '-----------' - write (stdout, '(32x,a)') 'PROJECTIONS' - write (stdout, '(32x,a)') '-----------' - write (stdout, *) ' ' - write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' - write (stdout, '(1x,a)') '| Frac. Coord. l mr r z-axis x-axis Z/a |' - write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' - do nsp = 1, num_proj - write (stdout, '(1x,a1,3(1x,f5.2),1x,i2,1x,i2,1x,i2,3(1x,f6.3),3(1x,f6.3),2x,f4.1,1x,a1)')& - & '|', input_proj_site(1, nsp), input_proj_site(2, nsp), & - input_proj_site(3, nsp), input_proj_l(nsp), input_proj_m(nsp), input_proj_radial(nsp), & - input_proj_z(1, nsp), input_proj_z(2, nsp), input_proj_z(3, nsp), input_proj_x(1, nsp), & - input_proj_x(2, nsp), input_proj_x(3, nsp), input_proj_zona(nsp), '|' - end do - write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' - write (stdout, *) ' ' - end if - - if (iprint > 1 .and. lselproj .and. allocated(proj_site)) then - write (stdout, '(30x,a)') '--------------------' - write (stdout, '(30x,a)') 'SELECTED PROJECTIONS' - write (stdout, '(30x,a)') '--------------------' - write (stdout, *) ' ' - write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' - write (stdout, '(1x,a)') '| Frac. Coord. l mr r z-axis x-axis Z/a |' - write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' - do nsp = 1, num_wann - if (proj2wann_map(nsp) < 0) cycle - write (stdout, '(1x,a1,3(1x,f5.2),1x,i2,1x,i2,1x,i2,3(1x,f6.3),3(1x,f6.3),2x,f4.1,1x,a1)')& - & '|', proj_site(1, nsp), proj_site(2, nsp), & - proj_site(3, nsp), proj_l(nsp), proj_m(nsp), proj_radial(nsp), & - proj_z(1, nsp), proj_z(2, nsp), proj_z(3, nsp), proj_x(1, nsp), & - proj_x(2, nsp), proj_x(3, nsp), proj_zona(nsp), '|' - end do - write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' - write (stdout, *) ' ' - end if - - ! K-points - write (stdout, '(32x,a)') '------------' - write (stdout, '(32x,a)') 'K-POINT GRID' - write (stdout, '(32x,a)') '------------' - write (stdout, *) ' ' - write (stdout, '(13x,a,i3,1x,a1,i3,1x,a1,i3,6x,a,i5)') 'Grid size =', mp_grid(1), 'x', mp_grid(2), 'x', mp_grid(3), & - 'Total points =', num_kpts - write (stdout, *) ' ' - if (iprint > 1) then - write (stdout, '(1x,a)') '*----------------------------------------------------------------------------*' - if (lenconfac .eq. 1.0_dp) then - write (stdout, '(1x,a)') '| k-point Fractional Coordinate Cartesian Coordinate (Ang^-1) |' - else - write (stdout, '(1x,a)') '| k-point Fractional Coordinate Cartesian Coordinate (Bohr^-1) |' - endif - write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' - do nkp = 1, num_kpts - write (stdout, '(1x,a1,i6,1x,3F10.5,3x,a1,1x,3F10.5,4x,a1)') '|', nkp, kpt_latt(:, nkp), '|', & - kpt_cart(:, nkp)/lenconfac, '|' - end do - write (stdout, '(1x,a)') '*----------------------------------------------------------------------------*' - write (stdout, *) ' ' - end if - ! Main - write (stdout, *) ' ' - write (stdout, '(1x,a78)') '*---------------------------------- MAIN ------------------------------------*' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Number of Wannier Functions :', num_wann, '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Number of Objective Wannier Functions :', slwf_num, '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Number of input Bloch states :', num_bands, '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Output verbosity (1=low, 5=high) :', iprint, '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Timing Level (1=low, 5=high) :', timing_level, '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Optimisation (0=memory, 3=speed) :', optimisation, '|' - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Length Unit :', trim(length_unit), '|' - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Post-processing setup (write *.nnkp) :', postproc_setup, '|' - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Using Gamma-only branch of algorithms :', gamma_only, '|' - !YN: RS: - if (lsitesymmetry) then - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Using symmetry-adapted WF mode :', lsitesymmetry, '|' - write (stdout, '(1x,a46,8x,E10.3,13x,a1)') '| Tolerance for symmetry condition on U :', symmetrize_eps, '|' - endif - - if (cp_pp .or. iprint > 2) & - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| CP code post-processing :', cp_pp, '|' - if (wannier_plot .or. iprint > 2) then - if (wvfn_formatted) then - write (stdout, '(1x,a46,9x,a9,13x,a1)') '| Wavefunction (UNK) file-type :', 'formatted', '|' - else - write (stdout, '(1x,a46,7x,a11,13x,a1)') '| Wavefunction (UNK) file-type :', 'unformatted', '|' - endif - if (spin == 1) then - write (stdout, '(1x,a46,16x,a2,13x,a1)') '| Wavefunction spin channel :', 'up', '|' - else - write (stdout, '(1x,a46,14x,a4,13x,a1)') '| Wavefunction spin channel :', 'down', '|' - endif - endif - - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - - ! Wannierise - write (stdout, '(1x,a78)') '*------------------------------- WANNIERISE ---------------------------------*' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Total number of iterations :', num_iter, '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Number of CG steps before reset :', num_cg_steps, '|' - if (lfixstep) then - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Fixed step length for minimisation :', fixed_step, '|' - else - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Trial step length for line search :', trial_step, '|' - endif - write (stdout, '(1x,a46,8x,E10.3,13x,a1)') '| Convergence tolerence :', conv_tol, '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Convergence window :', conv_window, '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Iterations between writing output :', num_print_cycles, '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Iterations between backing up to disk :', num_dump_cycles, '|' - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Write r^2_nm to file :', write_r2mn, '|' - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Write xyz WF centres to file :', write_xyz, '|' - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Write on-site energies <0n|H|0n> to file :', write_hr_diag, '|' - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Use guiding centre to control phases :', guiding_centres, '|' - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Use phases for initial projections :', use_bloch_phases, '|' - if (guiding_centres .or. iprint > 2) then - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Iterations before starting guiding centres:', num_no_guide_iter, '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Iterations between using guiding centres :', num_guide_cycles, '|' - end if - if (selective_loc .or. iprint > 2) then - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Perform selective localization :', selective_loc, '|' - end if - if (slwf_constrain .or. iprint > 2) then - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Use constrains in selective localization :', slwf_constrain, '|' - write (stdout, '(1x,a46,8x,E10.3,13x,a1)') '| Value of the Lagrange multiplier :',& - &slwf_lambda, '|' - end if - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - ! - ! Disentanglement - ! - if (disentanglement .or. iprint > 2) then - write (stdout, '(1x,a78)') '*------------------------------- DISENTANGLE --------------------------------*' - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Using band disentanglement :', disentanglement, '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Total number of iterations :', dis_num_iter, '|' - write (stdout, '(1x,a46,10x,F8.3,13x,a1)') '| Mixing ratio :', dis_mix_ratio, '|' - write (stdout, '(1x,a46,8x,ES10.3,13x,a1)') '| Convergence tolerence :', dis_conv_tol, '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Convergence window :', dis_conv_window, '|' - ! GS-start - if (dis_spheres_num .gt. 0) then - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Number of spheres in k-space :', dis_spheres_num, '|' - do nkp = 1, dis_spheres_num - write (stdout, '(1x,a13,I4,a2,2x,3F8.3,a15,F8.3,9x,a1)') & - '| center n.', nkp, ' :', dis_spheres(1:3, nkp), ', radius =', dis_spheres(4, nkp), '|' - enddo - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Index of first Wannier band :', dis_spheres_first_wann, '|' - endif - ! GS-end - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - end if - ! - ! Plotting - ! - if (wannier_plot .or. bands_plot .or. fermi_surface_plot .or. kslice & - .or. dos_plot .or. write_hr .or. iprint > 2) then - ! - write (stdout, '(1x,a78)') '*-------------------------------- PLOTTING ----------------------------------*' - ! - if (wannier_plot .or. iprint > 2) then - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Plotting Wannier functions :', wannier_plot, '|' - write (stdout, '(1x,a46,1x,I5,a1,I5,a1,I5,13x,a1)') & - '| Size of supercell for plotting :', & - wannier_plot_supercell(1), 'x', wannier_plot_supercell(2), 'x', & - wannier_plot_supercell(3), '|' - - if (translate_home_cell) then - write (stdout, '(1x,a46,10x,L8,13x,a1)') & - '| Translating WFs to home cell :', translate_home_cell, '|' - end if - - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plotting mode (molecule or crystal) :', trim(wannier_plot_mode), '|' - if (spinors) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plotting mode for spinor WFs :', & - trim(wannier_plot_spinor_mode), '|' - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Include phase for spinor WFs :', & - wannier_plot_spinor_phase, '|' - end if - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plotting format :', trim(wannier_plot_format), '|' - if (index(wannier_plot_format, 'cub') > 0 .or. iprint > 2) then - write (stdout, '(1x,a46,10x,F8.3,13x,a1)') '| Plot radius :', wannier_plot_radius, '|' - write (stdout, '(1x,a46,10x,F8.3,13x,a1)') '| Plot scale :', wannier_plot_scale, '|' - endif - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - end if - ! - if (fermi_surface_plot .or. iprint > 2) then - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Plotting Fermi surface :', fermi_surface_plot, '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Number of plotting points (along b_1) :', fermi_surface_num_points, '|' - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plotting format :' & - , trim(fermi_surface_plot_format), '|' - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - end if - ! - if (bands_plot .or. iprint > 2) then - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Plotting interpolated bandstructure :', bands_plot, '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Number of K-path sections :', bands_num_spec_points/2, '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Divisions along first K-path section :', bands_num_points, '|' - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Output format :', trim(bands_plot_format), '|' - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Output mode :', trim(bands_plot_mode), '|' - if (index(bands_plot_mode, 'cut') .ne. 0) then - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Dimension of the system :', bands_plot_dim, '|' - if (bands_plot_dim .eq. 1) & - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| System extended in :', trim(one_dim_axis), '|' - if (bands_plot_dim .eq. 2) & - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| System confined in :', trim(one_dim_axis), '|' - write (stdout, '(1x,a46,10x,F8.3,13x,a1)') '| Hamiltonian cut-off value :', hr_cutoff, '|' - write (stdout, '(1x,a46,10x,F8.3,13x,a1)') '| Hamiltonian cut-off distance :', dist_cutoff, '|' - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Hamiltonian cut-off distance mode :', trim(dist_cutoff_mode), '|' - endif - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - write (stdout, '(1x,a78)') '| K-space path sections: |' - if (bands_num_spec_points == 0) then - write (stdout, '(1x,a78)') '| None defined |' - else - do loop = 1, bands_num_spec_points, 2 - write (stdout, '(1x,a10,1x,a5,1x,3F7.3,5x,a3,1x,a5,1x,3F7.3,3x,a1)') '| From:', bands_label(loop), & - (bands_spec_points(i, loop), i=1, 3), 'To:', bands_label(loop + 1), (bands_spec_points(i, loop + 1), i=1, 3), '|' - end do - end if - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - end if - ! - if (write_hr .or. iprint > 2) then - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Plotting Hamiltonian in WF basis :', write_hr, '|' - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - endif - if (write_vdw_data .or. iprint > 2) then - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Writing data for Van der Waals post-proc :', write_vdw_data, '|' - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - endif - ! - endif - -401 continue - ! - ! Transport - ! - if (transport .or. iprint > 2) then - ! - write (stdout, '(1x,a78)') '*------------------------------- TRANSPORT ----------------------------------*' - ! - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Transport mode :', trim(transport_mode), '|' - ! - if (tran_read_ht) then - ! - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Hamiltonian from external files :', 'T', '|' - ! - else - ! - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Hamiltonian from external files :', 'F', '|' - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| System extended in :', trim(one_dim_axis), '|' - ! - end if - - write (stdout, '(1x,a78)') '| Centre of the unit cell to which WF are translated (fract. coords): |' - write (stdout, '(1x,a1,35x,F12.6,a1,F12.6,a1,F12.6,3x,a1)') '|', translation_centre_frac(1), ',', & - translation_centre_frac(2), ',', & - translation_centre_frac(3), '|' - - if (size(fermi_energy_list) == 1) then - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Fermi energy (eV) :', fermi_energy_list(1), '|' - else - write (stdout, '(1x,a21,I8,a12,f8.3,a4,f8.3,a3,13x,a1)') '| Fermi energy :', size(fermi_energy_list), & - ' steps from ', fermi_energy_list(1), ' to ', & - fermi_energy_list(size(fermi_energy_list)), ' eV', '|' - end if - ! - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - ! - endif - -101 format(20x, a3, 2x, 3F11.6) - - end subroutine param_write - -!=================================================================== - subroutine param_postw90_write - !==================================================================! - ! ! - !! write postw90 parameters to stdout - ! ! - !=================================================================== - - implicit none - - integer :: i, loop, nat, nsp - - ! System - write (stdout, *) - write (stdout, '(36x,a6)') '------' - write (stdout, '(36x,a6)') 'SYSTEM' - write (stdout, '(36x,a6)') '------' - write (stdout, *) - if (lenconfac .eq. 1.0_dp) then - write (stdout, '(30x,a21)') 'Lattice Vectors (Ang)' - else - write (stdout, '(28x,a22)') 'Lattice Vectors (Bohr)' - endif - write (stdout, 101) 'a_1', (real_lattice(1, I)*lenconfac, i=1, 3) - write (stdout, 101) 'a_2', (real_lattice(2, I)*lenconfac, i=1, 3) - write (stdout, 101) 'a_3', (real_lattice(3, I)*lenconfac, i=1, 3) - write (stdout, *) - write (stdout, '(19x,a17,3x,f11.5)', advance='no') & - 'Unit Cell Volume:', cell_volume*lenconfac**3 - if (lenconfac .eq. 1.0_dp) then - write (stdout, '(2x,a7)') '(Ang^3)' - else - write (stdout, '(2x,a8)') '(Bohr^3)' - endif - write (stdout, *) - if (lenconfac .eq. 1.0_dp) then - write (stdout, '(24x,a33)') 'Reciprocal-Space Vectors (Ang^-1)' - else - write (stdout, '(22x,a34)') 'Reciprocal-Space Vectors (Bohr^-1)' - endif - write (stdout, 101) 'b_1', (recip_lattice(1, I)/lenconfac, i=1, 3) - write (stdout, 101) 'b_2', (recip_lattice(2, I)/lenconfac, i=1, 3) - write (stdout, 101) 'b_3', (recip_lattice(3, I)/lenconfac, i=1, 3) - write (stdout, *) ' ' - ! Atoms - if (num_atoms > 0) then - write (stdout, '(1x,a)') '*----------------------------------------------------------------------------*' - if (lenconfac .eq. 1.0_dp) then - write (stdout, '(1x,a)') '| Site Fractional Coordinate Cartesian Coordinate (Ang) |' - else - write (stdout, '(1x,a)') '| Site Fractional Coordinate Cartesian Coordinate (Bohr) |' - endif - write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' - do nsp = 1, num_species - do nat = 1, atoms_species_num(nsp) - write (stdout, '(1x,a1,1x,a2,1x,i3,3F10.5,3x,a1,1x,3F10.5,4x,a1)') & - & '|', atoms_symbol(nsp), nat, atoms_pos_frac(:, nat, nsp),& - & '|', atoms_pos_cart(:, nat, nsp)*lenconfac, '|' - end do - end do - write (stdout, '(1x,a)') '*----------------------------------------------------------------------------*' - else - write (stdout, '(25x,a)') 'No atom positions specified' - end if - write (stdout, *) ' ' - ! Main - write (stdout, *) ' ' - - write (stdout, '(1x,a78)') '*-------------------------------- POSTW90 -----------------------------------*' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Number of Wannier Functions :', num_wann, '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Number of electrons per state :', num_elec_per_state, '|' - if (abs(scissors_shift) > 1.0e-7_dp .or. iprint > 0) then - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Scissor shift applied to conduction bands :', scissors_shift, '|' - if (num_valence_bands > 0) then - write (stdout, '(1x,a46,10x,i8,13x,a1)') '| Number of valence bands :', num_valence_bands, '|' - else - write (stdout, '(1x,a78)') '| Number of valence bands : not defined |' - endif - endif - if (spin_decomp .or. iprint > 2) & - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Spin decomposition :', spin_decomp, '|' - if (spin_moment .or. iprint > 2) & - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Compute Spin moment :', spin_moment, '|' - if (spin_decomp .or. spin_moment .or. iprint > 2) then - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Polar angle of spin quantisation axis :', spin_axis_polar, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Azimuthal angle of spin quantisation axis :', spin_axis_azimuth, '|' - if (spn_formatted) then - write (stdout, '(1x,a46,9x,a9,13x,a1)') '| Spn file-type :', 'formatted', '|' - else - write (stdout, '(1x,a46,7x,a11,13x,a1)') '| Spn file-type :', 'unformatted', '|' - endif - if (uHu_formatted) then - write (stdout, '(1x,a46,9x,a9,13x,a1)') '| uHu file-type :', 'formatted', '|' - else - write (stdout, '(1x,a46,7x,a11,13x,a1)') '| uHu file-type :', 'unformatted', '|' - endif - end if - - if (size(fermi_energy_list) == 1) then - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Fermi energy (eV) :', fermi_energy_list(1), '|' - else - write (stdout, '(1x,a21,I8,a12,f8.3,a4,f8.3,a3,13x,a1)') '| Fermi energy :', size(fermi_energy_list), & - ' steps from ', fermi_energy_list(1), ' to ', & - fermi_energy_list(size(fermi_energy_list)), ' eV', '|' - end if - - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Output verbosity (1=low, 5=high) :', iprint, '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Timing Level (1=low, 5=high) :', timing_level, '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Optimisation (0=memory, 3=speed) :', optimisation, '|' - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Length Unit :', trim(length_unit), '|' - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - write (stdout, '(1x,a78)') '*------------------------ Global Smearing Parameters ------------------------*' - if (adpt_smr) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Adaptive width smearing :', ' T', '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Adaptive smearing factor :', adpt_smr_fac, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Maximum allowed smearing width (eV) :', adpt_smr_max, '|' - - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Fixed width smearing :', ' T', '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Smearing width :', smr_fixed_en_width, '|' - endif - write (stdout, '(1x,a21,5x,a47,4x,a1)') '| Smearing Function ', trim(param_get_smearing_type(smr_index)), '|' - if (global_kmesh_set) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Global interpolation k-points defined :', ' T', '|' - if (kmesh_spacing > 0.0_dp) then - write (stdout, '(1x,a15,i4,1x,a1,i4,1x,a1,i4,16x,a11,f8.3,11x,1a)') '| Grid size = ', & - kmesh(1), 'x', kmesh(2), 'x', kmesh(3), ' Spacing = ', kmesh_spacing, '|' - else - write (stdout, '(1x,a46,2x,i4,1x,a1,i4,1x,a1,i4,13x,1a)') '| Grid size :' & - , kmesh(1), 'x', kmesh(2), 'x', kmesh(3), '|' - endif - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Global interpolation k-points defined :', ' F', '|' - endif - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - - ! DOS - if (dos .or. iprint > 2) then - write (stdout, '(1x,a78)') '*---------------------------------- DOS -------------------------------------*' - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Plotting Density of States :', dos, '|' - if (num_dos_project > 1) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Wannier Projected DOS :', ' T', '|' - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Wannier Projected DOS :', ' F', '|' - endif - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Minimum energy range for DOS plot :', dos_energy_min, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Maximum energy range for DOS plot :', dos_energy_max, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Energy step for DOS plot :', dos_energy_step, '|' - if (dos_adpt_smr .eqv. adpt_smr .and. dos_adpt_smr_fac == adpt_smr_fac .and. dos_adpt_smr_max == adpt_smr_max & - .and. dos_smr_fixed_en_width == smr_fixed_en_width .and. smr_index == dos_smr_index) then - write (stdout, '(1x,a78)') '| Using global smearing parameters |' - else - if (dos_adpt_smr) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Adaptive width smearing :', ' T', '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Adaptive smearing factor :', dos_adpt_smr_fac, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Maximum allowed smearing width :', dos_adpt_smr_max, '|' - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Fixed width smearing :', ' T', '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Smearing width :', dos_smr_fixed_en_width, '|' - endif - write (stdout, '(1x,a21,5x,a47,4x,a1)') '| Smearing Function ', trim(param_get_smearing_type(dos_smr_index)), '|' - endif - if (kmesh(1) == dos_kmesh(1) .and. kmesh(2) == dos_kmesh(2) .and. kmesh(3) == dos_kmesh(3)) then - write (stdout, '(1x,a78)') '| Using global k-point set for interpolation |' - else - if (dos_kmesh_spacing > 0.0_dp) then - write (stdout, '(1x,a15,i4,1x,a1,i4,1x,a1,i4,16x,a11,f8.3,11x,1a)') '| Grid size = ', & - dos_kmesh(1), 'x', dos_kmesh(2), 'x', dos_kmesh(3), ' Spacing = ', dos_kmesh_spacing, '|' - else - write (stdout, '(1x,a46,2x,i4,1x,a1,i4,1x,a1,i4,13x,1a)') '| Grid size :' & - , dos_kmesh(1), 'x', dos_kmesh(2), 'x', dos_kmesh(3), '|' - endif - endif - endif - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - - if (kpath .or. iprint > 2) then - write (stdout, '(1x,a78)') '*--------------------------------- KPATH ------------------------------------*' - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Plot Properties along a path in k-space :', kpath, '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Divisions along first kpath section :', kpath_num_points, '|' - if (index(kpath_task, 'bands') > 0) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot energy bands :', ' T', '|' - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot energy bands :', ' F', '|' - endif - if (index(kpath_task, 'curv') > 0) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot Berry curvature :', ' T', '|' - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot Berry curvature :', ' F', '|' - endif - if (index(kpath_task, 'morb') > 0) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot orbital magnetisation contribution :', ' T', '|' - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot orbital magnetisation contribution :', ' F', '|' - endif - if (index(kpath_task, 'shc') > 0) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot spin Hall conductivity contribution :', ' T', '|' - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot spin Hall conductivity contribution :', ' F', '|' - endif - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Property used to colour code the bands :', trim(kpath_bands_colour), '|' - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - write (stdout, '(1x,a78)') '| K-space path sections: |' - if (bands_num_spec_points == 0) then - write (stdout, '(1x,a78)') '| None defined |' - else - do loop = 1, bands_num_spec_points, 2 - write (stdout, '(1x,a10,2x,a1,2x,3F7.3,5x,a3,2x,a1,2x,3F7.3,7x,a1)') '| From:', bands_label(loop), & - (bands_spec_points(i, loop), i=1, 3), 'To:', bands_label(loop + 1), (bands_spec_points(i, loop + 1), i=1, 3), '|' - end do - end if - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - endif - - if (kslice .or. iprint > 2) then - write (stdout, '(1x,a78)') '*--------------------------------- KSLICE -----------------------------------*' - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Plot Properties along a slice in k-space :', kslice, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Fermi level used for slice :', fermi_energy_list(1), '|' - write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Divisions along first kpath section :', kpath_num_points, '|' - if (index(kslice_task, 'fermi_lines') > 0) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot energy contours (fermi lines) :', ' T', '|' - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot energy contours (fermi lines) :', ' F', '|' - endif - if (index(kslice_task, 'curv') > 0) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot Berry curvature (sum over occ states):', ' T', '|' - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot Berry curvature (sum over occ states):', ' F', '|' - endif - if (index(kslice_task, 'morb') > 0) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot orbital magnetisation contribution :', ' T', '|' - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot orbital magnetisation contribution :', ' F', '|' - endif - if (index(kslice_task, 'shc') > 0) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot spin Hall conductivity contribution :', ' T', '|' - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot spin Hall conductivity contribution :', ' F', '|' - endif - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Property used to colour code the lines :', & - trim(kslice_fermi_lines_colour), '|' - write (stdout, '(1x,a78)') '| 2D slice parameters (in reduced coordinates): |' - write (stdout, '(1x,a14,2x,3F8.3,37x,a1)') '| Corner: ', (kslice_corner(i), i=1, 3), '|' - write (stdout, '(1x,a14,2x,3F8.3,10x,a12,2x,i4,9x,a1)') & - '| Vector1: ', (kslice_b1(i), i=1, 3), ' Divisions:', kslice_2dkmesh(1), '|' - write (stdout, '(1x,a14,2x,3F8.3,10x,a12,2x,i4,9x,a1)') & - '| Vector2: ', (kslice_b2(i), i=1, 3), ' Divisions:', kslice_2dkmesh(1), '|' - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - endif - - if (berry .or. iprint > 2) then - write (stdout, '(1x,a78)') '*--------------------------------- BERRY ------------------------------------*' - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Compute Berry Phase related properties :', berry, '|' - if (index(berry_task, 'kubo') > 0) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Optical Conductivity and JDOS :', ' T', '|' - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Optical Conductivity and JDOS :', ' F', '|' - endif - if (index(berry_task, 'ahc') > 0) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Anomalous Hall Conductivity :', ' T', '|' - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Anomalous Hall Conductivity :', ' F', '|' - endif - if (index(berry_task, 'sc') > 0) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Shift Current :', ' T', '|' - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Shift Current :', ' F', '|' - endif - if (index(berry_task, 'kdotp') > 0) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute k.p expansion coefficients :', ' T', '|' - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute k.p expansion coefficients :', ' F', '|' - endif - if (index(berry_task, 'morb') > 0) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Orbital Magnetisation :', ' T', '|' - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Orbital Magnetisation :', ' F', '|' - endif - if (index(berry_task, 'shc') > 0) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Spin Hall Conductivity :', ' T', '|' - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Spin Hall Conductivity :', ' F', '|' - endif - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Lower frequency for optical responses :', kubo_freq_min, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Upper frequency for optical responses :', kubo_freq_max, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Step size for optical responses :', kubo_freq_step, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Upper eigenvalue for optical responses :', kubo_eigval_max, '|' - if (index(berry_task, 'sc') > 0) then - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Smearing factor for shift current :', sc_eta, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Frequency theshold for shift current :', sc_w_thr, '|' - write (stdout, '(1x,a46,1x,a27,3x,a1)') '| Bloch sums :', & - trim(param_get_convention_type(sc_phase_conv)), '|' - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Finite eta correction for shift current :', & - sc_use_eta_corr, '|' - end if - if (index(berry_task, 'kdotp') > 0) then - write (stdout, '(1x,a46,10x,f8.3,1x,f8.3,1xf8.3,1x,13x,a1)') '| Chosen k-point kdotp_kpoint :', & - kdotp_kpoint(1), kdotp_kpoint(2), kdotp_kpoint(3), '|' - write (stdout, '(1x,a46,10x,i4,13x,a1)') '| kdotp_num_bands :', kdotp_num_bands, '|' - write (stdout, '(1x,a46,10x,*(i4))') '| kdotp_bands :', & - (kdotp_bands(i), i=1, kdotp_num_bands) - end if - if (kubo_adpt_smr .eqv. adpt_smr .and. kubo_adpt_smr_fac == adpt_smr_fac .and. kubo_adpt_smr_max == adpt_smr_max & - .and. kubo_smr_fixed_en_width == smr_fixed_en_width .and. smr_index == kubo_smr_index) then - write (stdout, '(1x,a78)') '| Using global smearing parameters |' - else - if (kubo_adpt_smr) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Adaptive width smearing :', ' T', '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Adaptive smearing factor :', kubo_adpt_smr_fac, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Maximum allowed smearing width :', kubo_adpt_smr_max, '|' - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Fixed width smearing :', ' T', '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Smearing width :', kubo_smr_fixed_en_width, '|' - endif - write (stdout, '(1x,a21,5x,a47,4x,a1)') '| Smearing Function ', trim(param_get_smearing_type(kubo_smr_index)), '|' - endif - if (kmesh(1) == berry_kmesh(1) .and. kmesh(2) == berry_kmesh(2) .and. kmesh(3) == berry_kmesh(3)) then - write (stdout, '(1x,a78)') '| Using global k-point set for interpolation |' - else - if (berry_kmesh_spacing > 0.0_dp) then - write (stdout, '(1x,a15,i4,1x,a1,i4,1x,a1,i4,16x,a11,f8.3,11x,1a)') '| Grid size = ', & - berry_kmesh(1), 'x', berry_kmesh(2), 'x', berry_kmesh(3), ' Spacing = ', berry_kmesh_spacing, '|' - else - write (stdout, '(1x,a46,2x,i4,1x,a1,i4,1x,a1,i4,13x,1a)') '| Grid size :' & - , berry_kmesh(1), 'x', berry_kmesh(2), 'x', berry_kmesh(3), '|' - endif - endif - if (berry_curv_adpt_kmesh > 1) then - write (stdout, '(1x,a46,10x,i8,13x,a1)') '| Using an adaptive refinement mesh of size :', berry_curv_adpt_kmesh, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Threshold for adaptive refinement :', & - berry_curv_adpt_kmesh_thresh, '|' - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Adaptive refinement :', ' none', '|' - endif - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - endif - - if (gyrotropic .or. iprint > 2) then - write (stdout, '(1x,a78)') '*--------------------------------- GYROTROPIC ------------------------------------*' - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Compute Gyrotropic properties :', gyrotropic, '|' - write (stdout, '(1x,a46,10x,a20,1x,a1)') '| gyrotropic_task :', gyrotropic_task, '|' - call parameters_gyro_write_task(gyrotropic_task, '-d0', 'calculate the D tensor') - call parameters_gyro_write_task(gyrotropic_task, '-dw', 'calculate the tildeD tensor') - call parameters_gyro_write_task(gyrotropic_task, '-c', 'calculate the C tensor') - call parameters_gyro_write_task(gyrotropic_task, '-k', 'calculate the K tensor') - call parameters_gyro_write_task(gyrotropic_task, '-noa', 'calculate the interbad natural optical activity') - call parameters_gyro_write_task(gyrotropic_task, '-dos', 'calculate the density of states') - - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Lower frequency for tildeD,NOA :', gyrotropic_freq_min, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Upper frequency :', gyrotropic_freq_max, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Step size for frequency :', gyrotropic_freq_step, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Upper eigenvalue :', gyrotropic_eigval_max, '|' - if (gyrotropic_smr_fixed_en_width == smr_fixed_en_width .and. smr_index == gyrotropic_smr_index) then - write (stdout, '(1x,a78)') '| Using global smearing parameters |' - else - write (stdout, '(1x,a78)') '| Using local smearing parameters |' - endif - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Fixed width smearing :', ' T', '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Smearing width :', & - gyrotropic_smr_fixed_en_width, '|' - write (stdout, '(1x,a21,5x,a47,4x,a1)') '| Smearing Function :', & - trim(param_get_smearing_type(gyrotropic_smr_index)), '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| degen_thresh :', gyrotropic_degen_thresh, '|' - - if (kmesh(1) == gyrotropic_kmesh(1) .and. kmesh(2) == gyrotropic_kmesh(2) .and. kmesh(3) == gyrotropic_kmesh(3)) then - write (stdout, '(1x,a78)') '| Using global k-point set for interpolation |' - elseif (gyrotropic_kmesh_spacing > 0.0_dp) then - write (stdout, '(1x,a15,i4,1x,a1,i4,1x,a1,i4,16x,a11,f8.3,11x,1a)') '| Grid size = ', & - gyrotropic_kmesh(1), 'x', gyrotropic_kmesh(2), 'x', gyrotropic_kmesh(3), ' Spacing = ', gyrotropic_kmesh_spacing, '|' - else - write (stdout, '(1x,a46,2x,i4,1x,a1,i4,1x,a1,i4,13x,1a)') '| Grid size :' & - , gyrotropic_kmesh(1), 'x', gyrotropic_kmesh(2), 'x', gyrotropic_kmesh(3), '|' - endif - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Adaptive refinement :', ' not implemented', '|' - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - endif - - if (boltzwann .or. iprint > 2) then - write (stdout, '(1x,a78)') '*------------------------------- BOLTZWANN ----------------------------------*' - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Compute Boltzmann transport properties :', boltzwann, '|' - if (boltz_2d_dir_num > 0) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| 2d structure: non-periodic dimension :', trim(boltz_2d_dir), '|' - else - write (stdout, '(1x,a78)') '| 3d Structure : T |' - endif - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Relaxation Time (fs) :', boltz_relax_time, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Minimum Value of Chemical Potential (eV) :', boltz_mu_min, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Maximum Value of Chemical Potential (eV) :', boltz_mu_max, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Step size for Chemical Potential (eV) :', boltz_mu_step, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Minimum Value of Temperature (K) :', boltz_temp_min, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Maximum Value of Temperature (K) :', boltz_temp_max, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Step size for Temperature (K) :', boltz_temp_step, '|' - - if (kmesh(1) == boltz_kmesh(1) .and. kmesh(2) == boltz_kmesh(2) .and. kmesh(3) == boltz_kmesh(3)) then - write (stdout, '(1x,a78)') '| Using global k-point set for interpolation |' - else - if (boltz_kmesh_spacing > 0.0_dp) then - write (stdout, '(1x,a15,i4,1x,a1,i4,1x,a1,i4,16x,a11,f8.3,11x,1a)') '| Grid size = ', & - boltz_kmesh(1), 'x', boltz_kmesh(2), 'x', boltz_kmesh(3), ' Spacing = ', boltz_kmesh_spacing, '|' - else - write (stdout, '(1x,a46,2x,i4,1x,a1,i4,1x,a1,i4,13x,1a)') '| Grid size :' & - , boltz_kmesh(1), 'x', boltz_kmesh(2), 'x', boltz_kmesh(3), '|' - endif - endif - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Step size for TDF (eV) :', boltz_tdf_energy_step, '|' - write (stdout, '(1x,a25,5x,a43,4x,a1)') '| TDF Smearing Function ', trim(param_get_smearing_type(boltz_tdf_smr_index)), '|' - if (boltz_tdf_smr_fixed_en_width > 0.0_dp) then - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') & - '| TDF fixed Smearing width (eV) :', boltz_tdf_smr_fixed_en_width, '|' - else - write (stdout, '(1x,a78)') '| TDF fixed Smearing width : unsmeared |' - endif - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Compute DOS at same time :', boltz_calc_also_dos, '|' - if (boltz_calc_also_dos .and. iprint > 2) then - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Minimum energy range for DOS plot :', boltz_dos_energy_min, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Maximum energy range for DOS plot :', boltz_dos_energy_max, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Energy step for DOS plot :', boltz_dos_energy_step, '|' - if (boltz_dos_adpt_smr .eqv. adpt_smr .and. boltz_dos_adpt_smr_fac == adpt_smr_fac & - .and. boltz_dos_adpt_smr_max == adpt_smr_max & - .and. boltz_dos_smr_fixed_en_width == smr_fixed_en_width .and. smr_index == boltz_dos_smr_index) then - write (stdout, '(1x,a78)') '| Using global smearing parameters |' - else - if (boltz_dos_adpt_smr) then - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| DOS Adaptive width smearing :', ' T', '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') & - '| DOS Adaptive smearing factor :', boltz_dos_adpt_smr_fac, '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') & - '| DOS Maximum allowed smearing width :', boltz_dos_adpt_smr_max, '|' - else - write (stdout, '(1x,a46,10x,a8,13x,a1)') '| DOS Fixed width smearing :', ' T', '|' - write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| DOS Smearing width :', & - boltz_dos_smr_fixed_en_width, '|' - endif - write (stdout, '(1x,a21,5x,a47,4x,a1)') '| Smearing Function ', trim(param_get_smearing_type(boltz_dos_smr_index)), '|' - endif - endif - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - endif - - if (geninterp .or. iprint > 2) then - write (stdout, '(1x,a78)') '*------------------------Generic Band Interpolation--------------------------*' - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Compute Properties at given k-points :', geninterp, '|' - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Calculate band gradients :', geninterp_alsofirstder, '|' - write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Write data into a single file :', geninterp_single_file, '|' - write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' - endif - -101 format(20x, a3, 2x, 3F11.6) - - end subroutine param_postw90_write - - subroutine param_write_header - !! Write a suitable header for the calculation - version authors etc - use w90_io, only: io_date, w90_version - use w90_constants, only: bohr_version_str, constants_version_str1, constants_version_str2 - implicit none - - character(len=9) :: cdate, ctime - - call io_date(cdate, ctime) - - write (stdout, *) - write (stdout, *) ' +---------------------------------------------------+' - write (stdout, *) ' | |' - write (stdout, *) ' | WANNIER90 |' - write (stdout, *) ' | |' - write (stdout, *) ' +---------------------------------------------------+' - write (stdout, *) ' | |' - write (stdout, *) ' | Welcome to the Maximally-Localized |' - write (stdout, *) ' | Generalized Wannier Functions code |' - write (stdout, *) ' | http://www.wannier.org |' - write (stdout, *) ' | |' - write (stdout, *) ' | |' - write (stdout, *) ' | Wannier90 Developer Group: |' - write (stdout, *) ' | Giovanni Pizzi (EPFL) |' - write (stdout, *) ' | Valerio Vitale (Cambridge) |' - write (stdout, *) ' | David Vanderbilt (Rutgers University) |' - write (stdout, *) ' | Nicola Marzari (EPFL) |' - write (stdout, *) ' | Ivo Souza (Universidad del Pais Vasco) |' - write (stdout, *) ' | Arash A. Mostofi (Imperial College London) |' - write (stdout, *) ' | Jonathan R. Yates (University of Oxford) |' - write (stdout, *) ' | |' - write (stdout, *) ' | For the full list of Wannier90 3.x authors, |' - write (stdout, *) ' | please check the code documentation and the |' - write (stdout, *) ' | README on the GitHub page of the code |' - write (stdout, *) ' | |' - write (stdout, *) ' | |' - write (stdout, *) ' | Please cite |' - write (stdout, *) ' | |' - write (stdout, *) ' | [ref] "Wannier90 as a community code: |' - write (stdout, *) ' | new features and applications", |' - write (stdout, *) ' | G. Pizzi et al., J. Phys. Cond. Matt. 32, |' - write (stdout, *) ' | 165902 (2020). |' - write (stdout, *) ' | http://doi.org/10.1088/1361-648X/ab51ff |' - write (stdout, *) ' | |' - write (stdout, *) ' | in any publications arising from the use of |' - write (stdout, *) ' | this code. For the method please cite |' - write (stdout, *) ' | |' - write (stdout, *) ' | [ref] "Maximally Localized Generalised Wannier |' - write (stdout, *) ' | Functions for Composite Energy Bands" |' - write (stdout, *) ' | N. Marzari and D. Vanderbilt |' - write (stdout, *) ' | Phys. Rev. B 56 12847 (1997) |' - write (stdout, *) ' | |' - write (stdout, *) ' | [ref] "Maximally Localized Wannier Functions |' - write (stdout, *) ' | for Entangled Energy Bands" |' - write (stdout, *) ' | I. Souza, N. Marzari and D. Vanderbilt |' - write (stdout, *) ' | Phys. Rev. B 65 035109 (2001) |' - write (stdout, *) ' | |' - write (stdout, *) ' | |' - write (stdout, *) ' | Copyright (c) 1996-2020 |' - write (stdout, *) ' | The Wannier90 Developer Group and |' - write (stdout, *) ' | individual contributors |' - write (stdout, *) ' | |' - write (stdout, *) ' | Release: ', adjustl(w90_version), ' 5th March 2020 |' - write (stdout, *) ' | |' - write (stdout, *) ' | This program is free software; you can |' - write (stdout, *) ' | redistribute it and/or modify it under the terms |' - write (stdout, *) ' | of the GNU General Public License as published by |' - write (stdout, *) ' | the Free Software Foundation; either version 2 of |' - write (stdout, *) ' | the License, or (at your option) any later version|' - write (stdout, *) ' | |' - write (stdout, *) ' | This program is distributed in the hope that it |' - write (stdout, *) ' | will be useful, but WITHOUT ANY WARRANTY; without |' - write (stdout, *) ' | even the implied warranty of MERCHANTABILITY or |' - write (stdout, *) ' | FITNESS FOR A PARTICULAR PURPOSE. See the GNU |' - write (stdout, *) ' | General Public License for more details. |' - write (stdout, *) ' | |' - write (stdout, *) ' | You should have received a copy of the GNU General|' - write (stdout, *) ' | Public License along with this program; if not, |' - write (stdout, *) ' | write to the Free Software Foundation, Inc., |' - write (stdout, *) ' | 675 Mass Ave, Cambridge, MA 02139, USA. |' - write (stdout, *) ' | |' - write (stdout, *) ' +---------------------------------------------------+' - write (stdout, *) ' | Execution started on ', cdate, ' at ', ctime, ' |' - write (stdout, *) ' +---------------------------------------------------+' - write (stdout, *) '' - write (stdout, '(1X,A)') '******************************************************************************' - write (stdout, '(1X,A)') '* '//constants_version_str1//'*' - write (stdout, '(1X,A)') '* '//constants_version_str2//'*' - write (stdout, '(1X,A)') '* '//bohr_version_str//'*' - write (stdout, '(1X,A)') '******************************************************************************' - write (stdout, *) '' - - end subroutine param_write_header - -!==================================================================! - subroutine param_dealloc - !==================================================================! - ! ! - !! release memory from allocated parameters - ! ! - !=================================================================== - use w90_io, only: io_error - - implicit none - integer :: ierr - - if (allocated(ndimwin)) then - deallocate (ndimwin, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating ndimwin in param_dealloc') - end if - if (allocated(lwindow)) then - deallocate (lwindow, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating lwindow in param_dealloc') - end if - if (allocated(eigval)) then - deallocate (eigval, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating eigval in param_dealloc') - endif - if (allocated(shell_list)) then - deallocate (shell_list, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating shell_list in param_dealloc') - endif - if (allocated(kpt_latt)) then - deallocate (kpt_latt, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating kpt_latt in param_dealloc') - endif - if (allocated(kpt_cart)) then - deallocate (kpt_cart, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating kpt_cart in param_dealloc') - endif - if (allocated(bands_label)) then - deallocate (bands_label, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating bands_label in param_dealloc') - end if - if (allocated(bands_spec_points)) then - deallocate (bands_spec_points, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating bands_spec_points in param_dealloc') - end if - if (allocated(atoms_label)) then - deallocate (atoms_label, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating atoms_label in param_dealloc') - end if - if (allocated(atoms_symbol)) then - deallocate (atoms_symbol, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating atoms_symbol in param_dealloc') - end if - if (allocated(atoms_pos_frac)) then - deallocate (atoms_pos_frac, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating atom_pos_frac in param_dealloc') - end if - if (allocated(atoms_pos_cart)) then - deallocate (atoms_pos_cart, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating atoms_pos_cart in param_dealloc') - end if - if (allocated(atoms_species_num)) then - deallocate (atoms_species_num, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating atoms_species_num in param_dealloc') - end if - if (allocated(input_proj_site)) then - deallocate (input_proj_site, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating input_proj_site in param_dealloc') - end if - if (allocated(input_proj_l)) then - deallocate (input_proj_l, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating input_proj_l in param_dealloc') - end if - if (allocated(input_proj_m)) then - deallocate (input_proj_m, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating input_proj_m in param_dealloc') - end if - if (allocated(input_proj_s)) then - deallocate (input_proj_s, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating input_proj_s in param_dealloc') - end if - if (allocated(input_proj_s_qaxis)) then - deallocate (input_proj_s_qaxis, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating input_proj_s_qaxis in param_dealloc') - end if - if (allocated(input_proj_z)) then - deallocate (input_proj_z, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating input_proj_z in param_dealloc') - end if - if (allocated(input_proj_x)) then - deallocate (input_proj_x, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating input_proj_x in param_dealloc') - end if - if (allocated(input_proj_radial)) then - deallocate (input_proj_radial, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating input_proj_radial in param_dealloc') - end if - if (allocated(input_proj_zona)) then - deallocate (input_proj_zona, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating input_proj_zona in param_dealloc') - end if - if (allocated(proj_site)) then - deallocate (proj_site, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating proj_site in param_dealloc') - end if - if (allocated(proj_l)) then - deallocate (proj_l, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating proj_l in param_dealloc') - end if - if (allocated(proj_m)) then - deallocate (proj_m, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating proj_m in param_dealloc') - end if - if (allocated(proj_s)) then - deallocate (proj_s, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating proj_s in param_dealloc') - end if - if (allocated(proj_s_qaxis)) then - deallocate (proj_s_qaxis, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating proj_s_qaxis in param_dealloc') - end if - if (allocated(proj_z)) then - deallocate (proj_z, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating proj_z in param_dealloc') - end if - if (allocated(proj_x)) then - deallocate (proj_x, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating proj_x in param_dealloc') - end if - if (allocated(proj_radial)) then - deallocate (proj_radial, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating proj_radial in param_dealloc') - end if - if (allocated(proj_zona)) then - deallocate (proj_zona, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating proj_zona in param_dealloc') - end if - if (allocated(wannier_plot_list)) then - deallocate (wannier_plot_list, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating wannier_plot_list in param_dealloc') - end if - if (allocated(exclude_bands)) then - deallocate (exclude_bands, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating exclude_bands in param_dealloc') - end if - if (allocated(wannier_centres)) then - deallocate (wannier_centres, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating wannier_centres in param_dealloc') - end if - if (allocated(wannier_spreads)) then - deallocate (wannier_spreads, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating wannier_spreads in param_dealloc') - endif - if (allocated(bands_plot_project)) then - deallocate (bands_plot_project, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating bands_plot_project in param_dealloc') - endif - if (allocated(dos_project)) then - deallocate (dos_project, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating dos_project in param_dealloc') - endif - if (allocated(fermi_energy_list)) then - deallocate (fermi_energy_list, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating fermi_energy_list in param_dealloc') - endif - if (allocated(kubo_freq_list)) then - deallocate (kubo_freq_list, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating kubo_freq_list in param_dealloc') - endif - if (allocated(dis_spheres)) then - deallocate (dis_spheres, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating dis_spheres in param_dealloc') - endif - if (allocated(ccentres_frac)) then - deallocate (ccentres_frac, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating ccentres_frac in param_dealloc') - endif - if (allocated(ccentres_cart)) then - deallocate (ccentres_cart, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating ccentres_cart in param_dealloc') - end if - return - - end subroutine param_dealloc - -!~ !================================! -!~ subroutine param_write_um -!~ !================================! -!~ ! ! -!~ ! Dump the U and M to *_um.dat ! -!~ ! ! -!~ !================================! -!~ -!~ -!~ use w90_io, only : io_file_unit,io_error,seedname,io_date -!~ implicit none -!~ -!~ integer :: i,j,k,l,um_unit -!~ character (len=9) :: cdate, ctime -!~ character(len=33) :: header -!~ -!~ call io_date(cdate, ctime) -!~ header='written on '//cdate//' at '//ctime -!~ -!~ um_unit=io_file_unit() -!~ open(unit=um_unit,file=trim(seedname)//'_um.dat',form='unformatted') -!~ write(um_unit) header -!~ write(um_unit) omega_invariant -!~ write(um_unit) num_wann,num_kpts,num_nnmax -!~ write(um_unit) (((u_matrix(i,j,k),i=1,num_wann),j=1,num_wann),k=1,num_kpts) -!~ write(um_unit) ((((m_matrix(i,j,k,l),i=1,num_wann),j=1,num_wann),k=1,nntot),l=1,num_kpts) -!~ close(um_unit) -!~ -!~ return -!~ -!~ end subroutine param_write_um - -!~ !================================! -!~ subroutine param_read_um -!~ !================================! -!~ ! ! -!~ ! Restore U and M from file ! -!~ ! ! -!~ !================================! -!~ -!~ use w90_io, only : io_file_unit,io_error,seedname -!~ implicit none -!~ -!~ integer :: tmp_num_wann,tmp_num_kpts,tmp_num_nnmax -!~ integer :: i,j,k,l,um_unit,ierr -!~ character(len=33) :: header -!~ real(kind=dp) :: tmp_omi -!~ -!~ um_unit=io_file_unit() -!~ open(unit=um_unit,file=trim(seedname)//'_um.dat',status="old",form='unformatted',err=105) -!~ read(um_unit) header -!~ write(stdout,'(1x,4(a))') 'Reading U and M from file ',trim(seedname),'_um.dat ', header -!~ read(um_unit) tmp_omi -!~ if ( have_disentangled ) then -!~ if ( abs(tmp_omi-omega_invariant).gt.1.0e-10_dp ) & -!~ call io_error('Error in restart: omega_invariant in .chk and um.dat files do not match') -!~ endif -!~ read(um_unit) tmp_num_wann,tmp_num_kpts,tmp_num_nnmax -!~ if(tmp_num_wann/=num_wann) call io_error('Error in param_read_um: num_wann mismatch') -!~ if(tmp_num_kpts/=num_kpts) call io_error('Error in param_read_um: num_kpts mismatch') -!~ if(tmp_num_nnmax/=num_nnmax) call io_error('Error in param_read_um: num_nnmax mismatch') -!~ if (.not.allocated(u_matrix)) then -!~ allocate(u_matrix(num_wann,num_wann,num_kpts),stat=ierr) -!~ if (ierr/=0) call io_error('Error allocating u_matrix in param_read_um') -!~ endif -!~ read(um_unit) (((u_matrix(i,j,k),i=1,num_wann),j=1,num_wann),k=1,num_kpts) -!~ if (.not.allocated(m_matrix)) then -!~ allocate(m_matrix(num_wann,num_wann,nntot,num_kpts),stat=ierr) -!~ if (ierr/=0) call io_error('Error allocating m_matrix in param_read_um') -!~ endif -!~ read(um_unit) ((((m_matrix(i,j,k,l),i=1,num_wann),j=1,num_wann),k=1,nntot),l=1,num_kpts) -!~ close(um_unit) -!~ -!~ return -!~ -!~105 call io_error('Error: Problem opening file '//trim(seedname)//'_um.dat in param_read_um') -!~ -! $ end subroutine param_read_um - -!=================================================! - subroutine param_write_chkpt(chkpt) - !=================================================! - !! Write checkpoint file - !! IMPORTANT! If you change the chkpt format, adapt - !! accordingly also the w90chk2chk.x utility! - !! Also, note that this routine writes the u_matrix and the m_matrix - in parallel - !! mode these are however stored in distributed form in, e.g., u_matrix_loc only, so - !! if you are changing the u_matrix, remember to gather it from u_matrix_loc first! - !=================================================! - - use w90_io, only: io_file_unit, io_date, seedname - - implicit none - - character(len=*), intent(in) :: chkpt - - integer :: chk_unit, nkp, i, j, k, l - character(len=9) :: cdate, ctime - character(len=33) :: header - character(len=20) :: chkpt1 - - write (stdout, '(/1x,3a)', advance='no') 'Writing checkpoint file ', trim(seedname), '.chk...' - - call io_date(cdate, ctime) - header = 'written on '//cdate//' at '//ctime - - chk_unit = io_file_unit() - open (unit=chk_unit, file=trim(seedname)//'.chk', form='unformatted') - - write (chk_unit) header ! Date and time - write (chk_unit) num_bands ! Number of bands - write (chk_unit) num_exclude_bands ! Number of excluded bands - write (chk_unit) (exclude_bands(i), i=1, num_exclude_bands) ! Excluded bands - write (chk_unit) ((real_lattice(i, j), i=1, 3), j=1, 3) ! Real lattice - write (chk_unit) ((recip_lattice(i, j), i=1, 3), j=1, 3) ! Reciprocal lattice - write (chk_unit) num_kpts ! Number of k-points - write (chk_unit) (mp_grid(i), i=1, 3) ! M-P grid - write (chk_unit) ((kpt_latt(i, nkp), i=1, 3), nkp=1, num_kpts) ! K-points - write (chk_unit) nntot ! Number of nearest k-point neighbours - write (chk_unit) num_wann ! Number of wannier functions - chkpt1 = adjustl(trim(chkpt)) - write (chk_unit) chkpt1 ! Position of checkpoint - write (chk_unit) have_disentangled ! Whether a disentanglement has been performed - if (have_disentangled) then - write (chk_unit) omega_invariant ! Omega invariant - ! lwindow, ndimwin and U_matrix_opt - write (chk_unit) ((lwindow(i, nkp), i=1, num_bands), nkp=1, num_kpts) - write (chk_unit) (ndimwin(nkp), nkp=1, num_kpts) - write (chk_unit) (((u_matrix_opt(i, j, nkp), i=1, num_bands), j=1, num_wann), nkp=1, num_kpts) - endif - write (chk_unit) (((u_matrix(i, j, k), i=1, num_wann), j=1, num_wann), k=1, num_kpts) ! U_matrix - write (chk_unit) ((((m_matrix(i, j, k, l), i=1, num_wann), j=1, num_wann), k=1, nntot), l=1, num_kpts) ! M_matrix - write (chk_unit) ((wannier_centres(i, j), i=1, 3), j=1, num_wann) - write (chk_unit) (wannier_spreads(i), i=1, num_wann) - close (chk_unit) - - write (stdout, '(a/)') ' done' - - return - - end subroutine param_write_chkpt - -!=================================================! - subroutine param_read_chkpt() - !=================================================! - !! Read checkpoint file - !! IMPORTANT! If you change the chkpt format, adapt - !! accordingly also the w90chk2chk.x utility! - !! - !! Note on parallelization: this function should be called - !! from the root node only! - !! - !! This function should be called - !=================================================! - - use w90_constants, only: eps6 - use w90_io, only: io_error, io_file_unit, stdout, seedname - - implicit none - - integer :: chk_unit, nkp, i, j, k, l, ntmp, ierr - character(len=33) :: header - real(kind=dp) :: tmp_latt(3, 3), tmp_kpt_latt(3, num_kpts) - integer :: tmp_excl_bands(1:num_exclude_bands), tmp_mp_grid(1:3) - - write (stdout, '(1x,3a)') 'Reading restart information from file ', trim(seedname), '.chk :' - - chk_unit = io_file_unit() - open (unit=chk_unit, file=trim(seedname)//'.chk', status='old', form='unformatted', err=121) - - ! Read comment line - read (chk_unit) header - write (stdout, '(1x,a)', advance='no') trim(header) - - ! Consistency checks - read (chk_unit) ntmp ! Number of bands - if (ntmp .ne. num_bands) call io_error('param_read_chk: Mismatch in num_bands') - read (chk_unit) ntmp ! Number of excluded bands - if (ntmp .ne. num_exclude_bands) & - call io_error('param_read_chk: Mismatch in num_exclude_bands') - read (chk_unit) (tmp_excl_bands(i), i=1, num_exclude_bands) ! Excluded bands - do i = 1, num_exclude_bands - if (tmp_excl_bands(i) .ne. exclude_bands(i)) & - call io_error('param_read_chk: Mismatch in exclude_bands') - enddo - read (chk_unit) ((tmp_latt(i, j), i=1, 3), j=1, 3) ! Real lattice - do j = 1, 3 - do i = 1, 3 - if (abs(tmp_latt(i, j) - real_lattice(i, j)) .gt. eps6) & - call io_error('param_read_chk: Mismatch in real_lattice') - enddo - enddo - read (chk_unit) ((tmp_latt(i, j), i=1, 3), j=1, 3) ! Reciprocal lattice - do j = 1, 3 - do i = 1, 3 - if (abs(tmp_latt(i, j) - recip_lattice(i, j)) .gt. eps6) & - call io_error('param_read_chk: Mismatch in recip_lattice') - enddo - enddo - read (chk_unit) ntmp ! K-points - if (ntmp .ne. num_kpts) & - call io_error('param_read_chk: Mismatch in num_kpts') - read (chk_unit) (tmp_mp_grid(i), i=1, 3) ! M-P grid - do i = 1, 3 - if (tmp_mp_grid(i) .ne. mp_grid(i)) & - call io_error('param_read_chk: Mismatch in mp_grid') - enddo - read (chk_unit) ((tmp_kpt_latt(i, nkp), i=1, 3), nkp=1, num_kpts) - do nkp = 1, num_kpts - do i = 1, 3 - if (abs(tmp_kpt_latt(i, nkp) - kpt_latt(i, nkp)) .gt. eps6) & - call io_error('param_read_chk: Mismatch in kpt_latt') - enddo - enddo - read (chk_unit) ntmp ! nntot - if (ntmp .ne. nntot) & - call io_error('param_read_chk: Mismatch in nntot') - read (chk_unit) ntmp ! num_wann - if (ntmp .ne. num_wann) & - call io_error('param_read_chk: Mismatch in num_wann') - ! End of consistency checks - - read (chk_unit) checkpoint ! checkpoint - checkpoint = adjustl(trim(checkpoint)) - - read (chk_unit) have_disentangled ! whether a disentanglement has been performed - - if (have_disentangled) then - - read (chk_unit) omega_invariant ! omega invariant - - ! lwindow - if (.not. allocated(lwindow)) then - allocate (lwindow(num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating lwindow in param_read_chkpt') - endif - read (chk_unit, err=122) ((lwindow(i, nkp), i=1, num_bands), nkp=1, num_kpts) - - ! ndimwin - if (.not. allocated(ndimwin)) then - allocate (ndimwin(num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating ndimwin in param_read_chkpt') - endif - read (chk_unit, err=123) (ndimwin(nkp), nkp=1, num_kpts) - - ! U_matrix_opt - if (.not. allocated(u_matrix_opt)) then - allocate (u_matrix_opt(num_bands, num_wann, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating u_matrix_opt in param_read_chkpt') - endif - read (chk_unit, err=124) (((u_matrix_opt(i, j, nkp), i=1, num_bands), j=1, num_wann), nkp=1, num_kpts) - - endif - - ! U_matrix - if (.not. allocated(u_matrix)) then - allocate (u_matrix(num_wann, num_wann, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating u_matrix in param_read_chkpt') - endif - read (chk_unit, err=125) (((u_matrix(i, j, k), i=1, num_wann), j=1, num_wann), k=1, num_kpts) - - ! M_matrix - if (.not. allocated(m_matrix)) then - allocate (m_matrix(num_wann, num_wann, nntot, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating m_matrix in param_read_chkpt') - endif - read (chk_unit, err=126) ((((m_matrix(i, j, k, l), i=1, num_wann), j=1, num_wann), k=1, nntot), l=1, num_kpts) - - ! wannier_centres - read (chk_unit, err=127) ((wannier_centres(i, j), i=1, 3), j=1, num_wann) - - ! wannier spreads - read (chk_unit, err=128) (wannier_spreads(i), i=1, num_wann) - - close (chk_unit) - - write (stdout, '(a/)') ' ... done' - - return - -121 if (ispostw90) then - call io_error('Error opening '//trim(seedname)//'.chk in param_read_chkpt: did you run wannier90.x first?') - else - call io_error('Error opening '//trim(seedname)//'.chk in param_read_chkpt') - end if -122 call io_error('Error reading lwindow from '//trim(seedname)//'.chk in param_read_chkpt') -123 call io_error('Error reading ndimwin from '//trim(seedname)//'.chk in param_read_chkpt') -124 call io_error('Error reading u_matrix_opt from '//trim(seedname)//'.chk in param_read_chkpt') -125 call io_error('Error reading u_matrix from '//trim(seedname)//'.chk in param_read_chkpt') -126 call io_error('Error reading m_matrix from '//trim(seedname)//'.chk in param_read_chkpt') -127 call io_error('Error reading wannier_centres from '//trim(seedname)//'.chk in param_read_chkpt') -128 call io_error('Error reading wannier_spreads from '//trim(seedname)//'.chk in param_read_chkpt') - - end subroutine param_read_chkpt - -!===========================================================! - subroutine param_chkpt_dist - !===========================================================! - ! ! - !! Distribute the chk files - ! ! - !===========================================================! - - use w90_constants, only: dp, cmplx_0, cmplx_i, twopi - use w90_io, only: io_error, io_file_unit, & - io_date, io_time, io_stopwatch - use w90_comms, only: on_root, comms_bcast - - implicit none - - integer :: ierr, loop_kpt, m, i, j - - call comms_bcast(checkpoint, len(checkpoint)) - - if (.not. on_root .and. .not. allocated(u_matrix)) then - allocate (u_matrix(num_wann, num_wann, num_kpts), stat=ierr) - if (ierr /= 0) & - call io_error('Error allocating u_matrix in param_chkpt_dist') - endif - call comms_bcast(u_matrix(1, 1, 1), num_wann*num_wann*num_kpts) - -! if (.not.on_root .and. .not.allocated(m_matrix)) then -! allocate(m_matrix(num_wann,num_wann,nntot,num_kpts),stat=ierr) -! if (ierr/=0)& -! call io_error('Error allocating m_matrix in param_chkpt_dist') -! endif -! call comms_bcast(m_matrix(1,1,1,1),num_wann*num_wann*nntot*num_kpts) - - call comms_bcast(have_disentangled, 1) - - if (have_disentangled) then - if (.not. on_root) then - - if (.not. allocated(u_matrix_opt)) then - allocate (u_matrix_opt(num_bands, num_wann, num_kpts), stat=ierr) - if (ierr /= 0) & - call io_error('Error allocating u_matrix_opt in param_chkpt_dist') - endif - - if (.not. allocated(lwindow)) then - allocate (lwindow(num_bands, num_kpts), stat=ierr) - if (ierr /= 0) & - call io_error('Error allocating lwindow in param_chkpt_dist') - endif - - if (.not. allocated(ndimwin)) then - allocate (ndimwin(num_kpts), stat=ierr) - if (ierr /= 0) & - call io_error('Error allocating ndimwin in param_chkpt_dist') - endif - - end if - - call comms_bcast(u_matrix_opt(1, 1, 1), num_bands*num_wann*num_kpts) - call comms_bcast(lwindow(1, 1), num_bands*num_kpts) - call comms_bcast(ndimwin(1), num_kpts) - call comms_bcast(omega_invariant, 1) - end if - call comms_bcast(wannier_centres(1, 1), 3*num_wann) - call comms_bcast(wannier_spreads(1), num_wann) - - end subroutine param_chkpt_dist - -!=======================================! - subroutine param_in_file - !=======================================! - !! Load the *.win file into a character - !! array in_file, ignoring comments and - !! blank lines and converting everything - !! to lowercase characters - !=======================================! - - use w90_io, only: io_file_unit, io_error, seedname - use w90_utility, only: utility_lowercase - - implicit none - - integer :: in_unit, tot_num_lines, ierr, line_counter, loop, in1, in2 - character(len=maxlen) :: dummy - integer :: pos - character, parameter :: TABCHAR = char(9) - - in_unit = io_file_unit() - open (in_unit, file=trim(seedname)//'.win', form='formatted', status='old', err=101) - - num_lines = 0; tot_num_lines = 0 - do - read (in_unit, '(a)', iostat=ierr, err=200, end=210) dummy - ! [GP-begin, Apr13, 2012]: I convert all tabulation characters to spaces - pos = index(dummy, TABCHAR) - do while (pos .ne. 0) - dummy(pos:pos) = ' ' - pos = index(dummy, TABCHAR) - end do - ! [GP-end] - dummy = adjustl(dummy) - tot_num_lines = tot_num_lines + 1 - if (.not. dummy(1:1) == '!' .and. .not. dummy(1:1) == '#') then - if (len(trim(dummy)) > 0) num_lines = num_lines + 1 - endif - - end do - -101 call io_error('Error: Problem opening input file '//trim(seedname)//'.win') -200 call io_error('Error: Problem reading input file '//trim(seedname)//'.win') -210 continue - rewind (in_unit) - - allocate (in_data(num_lines), stat=ierr) - if (ierr /= 0) call io_error('Error allocating in_data in param_in_file') - - line_counter = 0 - do loop = 1, tot_num_lines - read (in_unit, '(a)', iostat=ierr, err=200) dummy - ! [GP-begin, Apr13, 2012]: I convert all tabulation characters to spaces - pos = index(dummy, TABCHAR) - do while (pos .ne. 0) - dummy(pos:pos) = ' ' - pos = index(dummy, TABCHAR) - end do - ! [GP-end] - dummy = utility_lowercase(dummy) - dummy = adjustl(dummy) - if (dummy(1:1) == '!' .or. dummy(1:1) == '#') cycle - if (len(trim(dummy)) == 0) cycle - line_counter = line_counter + 1 - in1 = index(dummy, '!') - in2 = index(dummy, '#') - if (in1 == 0 .and. in2 == 0) in_data(line_counter) = dummy - if (in1 == 0 .and. in2 > 0) in_data(line_counter) = dummy(:in2 - 1) - if (in2 == 0 .and. in1 > 0) in_data(line_counter) = dummy(:in1 - 1) - if (in2 > 0 .and. in1 > 0) in_data(line_counter) = dummy(:min(in1, in2) - 1) - end do - - close (in_unit) - - end subroutine param_in_file - -!===========================================================================! - subroutine param_get_keyword(keyword, found, c_value, l_value, i_value, r_value) - !===========================================================================! - ! ! - !! Finds the value of the required keyword. - ! ! - !===========================================================================! - - use w90_io, only: io_error - - implicit none - - character(*), intent(in) :: keyword - !! Keyword to examine - logical, intent(out) :: found - !! Is keyword present - character(*), optional, intent(inout) :: c_value - !! Keyword value - logical, optional, intent(inout) :: l_value - !! Keyword value - integer, optional, intent(inout) :: i_value - !! Keyword value - real(kind=dp), optional, intent(inout) :: r_value - !! Keyword value - - integer :: kl, in, loop, itmp - character(len=maxlen) :: dummy - - kl = len_trim(keyword) - - found = .false. - - do loop = 1, num_lines - in = index(in_data(loop), trim(keyword)) - if (in == 0 .or. in > 1) cycle - itmp = in + len(trim(keyword)) - if (in_data(loop) (itmp:itmp) /= '=' & - .and. in_data(loop) (itmp:itmp) /= ':' & - .and. in_data(loop) (itmp:itmp) /= ' ') cycle - if (found) then - call io_error('Error: Found keyword '//trim(keyword)//' more than once in input file') - endif - found = .true. - dummy = in_data(loop) (kl + 1:) - in_data(loop) (1:maxlen) = ' ' - dummy = adjustl(dummy) - if (dummy(1:1) == '=' .or. dummy(1:1) == ':') then - dummy = dummy(2:) - dummy = adjustl(dummy) - end if - end do - - if (found) then - if (present(c_value)) c_value = dummy - if (present(l_value)) then - if (index(dummy, 't') > 0) then - l_value = .true. - elseif (index(dummy, 'f') > 0) then - l_value = .false. - else - call io_error('Error: Problem reading logical keyword '//trim(keyword)) - endif - endif - if (present(i_value)) read (dummy, *, err=220, end=220) i_value - if (present(r_value)) read (dummy, *, err=220, end=220) r_value - end if - - return - -220 call io_error('Error: Problem reading keyword '//trim(keyword)) - - end subroutine param_get_keyword - -!=========================================================================================! - subroutine param_get_keyword_vector(keyword, found, length, c_value, l_value, i_value, r_value) - !=========================================================================================! - ! ! - !! Finds the values of the required keyword vector - ! ! - !=========================================================================================! - - use w90_io, only: io_error - - implicit none - - character(*), intent(in) :: keyword - !! Keyword to examine - logical, intent(out) :: found - !! Is keyword present - integer, intent(in) :: length - !! Length of vecotr to read - character(*), optional, intent(inout) :: c_value(length) - !! Keyword data - logical, optional, intent(inout) :: l_value(length) - !! Keyword data - integer, optional, intent(inout) :: i_value(length) - !! Keyword data - real(kind=dp), optional, intent(inout) :: r_value(length) - !! Keyword data - - integer :: kl, in, loop, i - character(len=maxlen) :: dummy - - kl = len_trim(keyword) - - found = .false. - - do loop = 1, num_lines - in = index(in_data(loop), trim(keyword)) - if (in == 0 .or. in > 1) cycle - if (found) then - call io_error('Error: Found keyword '//trim(keyword)//' more than once in input file') - endif - found = .true. - dummy = in_data(loop) (kl + 1:) - in_data(loop) (1:maxlen) = ' ' - dummy = adjustl(dummy) - if (dummy(1:1) == '=' .or. dummy(1:1) == ':') then - dummy = dummy(2:) - dummy = adjustl(dummy) - end if - end do - - if (found) then - if (present(c_value)) read (dummy, *, err=230, end=230) (c_value(i), i=1, length) - if (present(l_value)) then - ! I don't think we need this. Maybe read into a dummy charater - ! array and convert each element to logical - call io_error('param_get_keyword_vector unimplemented for logicals') - endif - if (present(i_value)) read (dummy, *, err=230, end=230) (i_value(i), i=1, length) - if (present(r_value)) read (dummy, *, err=230, end=230) (r_value(i), i=1, length) - end if - - return - -230 call io_error('Error: Problem reading keyword '//trim(keyword)//' in param_get_keyword_vector') - - end subroutine param_get_keyword_vector - -!========================================================! - subroutine param_get_vector_length(keyword, found, length) - !======================================================! - ! ! - !! Returns the length of a keyword vector - ! ! - !======================================================! - - use w90_io, only: io_error - - implicit none - - character(*), intent(in) :: keyword - !! Keyword to examine - logical, intent(out) :: found - !! Is keyword present - integer, intent(out) :: length - !! length of vector - - integer :: kl, in, loop, pos - character(len=maxlen) :: dummy - - kl = len_trim(keyword) - - found = .false. - - do loop = 1, num_lines - in = index(in_data(loop), trim(keyword)) - if (in == 0 .or. in > 1) cycle - if (found) then - call io_error('Error: Found keyword '//trim(keyword)//' more than once in input file') - endif - found = .true. - dummy = in_data(loop) (kl + 1:) - dummy = adjustl(dummy) - if (dummy(1:1) == '=' .or. dummy(1:1) == ':') then - dummy = dummy(2:) - dummy = adjustl(dummy) - end if - end do - - length = 0 - if (found) then - if (len_trim(dummy) == 0) call io_error('Error: keyword '//trim(keyword)//' is blank') - length = 1 - dummy = adjustl(dummy) - do - pos = index(dummy, ' ') - dummy = dummy(pos + 1:) - dummy = adjustl(dummy) - if (len_trim(dummy) > 0) then - length = length + 1 - else - exit - endif - - end do - - end if - - return - - end subroutine param_get_vector_length - -!==============================================================================================! - subroutine param_get_keyword_block(keyword, found, rows, columns, c_value, l_value, i_value, r_value) - !==============================================================================================! - ! ! - !! Finds the values of the required data block - ! ! - !==============================================================================================! - - use w90_constants, only: bohr - use w90_io, only: io_error - - implicit none - - character(*), intent(in) :: keyword - !! Keyword to examine - logical, intent(out) :: found - !! Is keyword present - integer, intent(in) :: rows - !! Number of rows - integer, intent(in) :: columns - !! Number of columns - character(*), optional, intent(inout) :: c_value(columns, rows) - !! keyword block data - logical, optional, intent(inout) :: l_value(columns, rows) - !! keyword block data - integer, optional, intent(inout) :: i_value(columns, rows) - !! keyword block data - real(kind=dp), optional, intent(inout) :: r_value(columns, rows) - !! keyword block data - - integer :: in, ins, ine, loop, i, line_e, line_s, counter, blen - logical :: found_e, found_s, lconvert - character(len=maxlen) :: dummy, end_st, start_st - - found_s = .false. - found_e = .false. - - start_st = 'begin '//trim(keyword) - end_st = 'end '//trim(keyword) - - do loop = 1, num_lines - ins = index(in_data(loop), trim(keyword)) - if (ins == 0) cycle - in = index(in_data(loop), 'begin') - if (in == 0 .or. in > 1) cycle - line_s = loop - if (found_s) then - call io_error('Error: Found '//trim(start_st)//' more than once in input file') - endif - found_s = .true. - end do - - if (.not. found_s) then - found = .false. - return - end if - - do loop = 1, num_lines - ine = index(in_data(loop), trim(keyword)) - if (ine == 0) cycle - in = index(in_data(loop), 'end') - if (in == 0 .or. in > 1) cycle - line_e = loop - if (found_e) then - call io_error('Error: Found '//trim(end_st)//' more than once in input file') - endif - found_e = .true. - end do - - if (.not. found_e) then - call io_error('Error: Found '//trim(start_st)//' but no '//trim(end_st)//' in input file') - end if - - if (line_e <= line_s) then - call io_error('Error: '//trim(end_st)//' comes before '//trim(start_st)//' in input file') - end if - - ! number of lines of data in block - blen = line_e - line_s - 1 - - ! if( blen /= rows) then - ! if ( index(trim(keyword),'unit_cell_cart').ne.0 ) then - ! if ( blen /= rows+1 ) call io_error('Error: Wrong number of lines in block '//trim(keyword)) - ! else - ! call io_error('Error: Wrong number of lines in block '//trim(keyword)) - ! endif - ! endif - - if ((blen .ne. rows) .and. (blen .ne. rows + 1)) & - call io_error('Error: Wrong number of lines in block '//trim(keyword)) - - if ((blen .eq. rows + 1) .and. (index(trim(keyword), 'unit_cell_cart') .eq. 0)) & - call io_error('Error: Wrong number of lines in block '//trim(keyword)) - - found = .true. - - lconvert = .false. - if (blen == rows + 1) then - dummy = in_data(line_s + 1) - if (index(dummy, 'ang') .ne. 0) then - lconvert = .false. - elseif (index(dummy, 'bohr') .ne. 0) then - lconvert = .true. - else - call io_error('Error: Units in block '//trim(keyword)//' not recognised') - endif - in_data(line_s) (1:maxlen) = ' ' - line_s = line_s + 1 - endif - -! r_value=1.0_dp - counter = 0 - do loop = line_s + 1, line_e - 1 - dummy = in_data(loop) - counter = counter + 1 - if (present(c_value)) read (dummy, *, err=240, end=240) (c_value(i, counter), i=1, columns) - if (present(l_value)) then - ! I don't think we need this. Maybe read into a dummy charater - ! array and convert each element to logical - call io_error('param_get_keyword_block unimplemented for logicals') - endif - if (present(i_value)) read (dummy, *, err=240, end=240) (i_value(i, counter), i=1, columns) - if (present(r_value)) read (dummy, *, err=240, end=240) (r_value(i, counter), i=1, columns) - end do - - if (lconvert) then - if (present(r_value)) then - r_value = r_value*bohr - endif - endif - - in_data(line_s:line_e) (1:maxlen) = ' ' - - return - -240 call io_error('Error: Problem reading block keyword '//trim(keyword)) - - end subroutine param_get_keyword_block - -!=====================================================! - subroutine param_get_block_length(keyword, found, rows, lunits) - !=====================================================! - ! ! - !! Finds the length of the data block - ! ! - !=====================================================! - - use w90_io, only: io_error - - implicit none - - character(*), intent(in) :: keyword - !! Keyword to examine - logical, intent(out) :: found - !! Is keyword present - integer, intent(out) :: rows - !! Number of rows - logical, optional, intent(out) :: lunits - !! Have we found a unit specification - - integer :: i, in, ins, ine, loop, line_e, line_s - logical :: found_e, found_s - character(len=maxlen) :: end_st, start_st, dummy - character(len=2) :: atsym - real(kind=dp) :: atpos(3) - - rows = 0 - found_s = .false. - found_e = .false. - - start_st = 'begin '//trim(keyword) - end_st = 'end '//trim(keyword) - - do loop = 1, num_lines - ins = index(in_data(loop), trim(keyword)) - if (ins == 0) cycle - in = index(in_data(loop), 'begin') - if (in == 0 .or. in > 1) cycle - line_s = loop - if (found_s) then - call io_error('Error: Found '//trim(start_st)//' more than once in input file') - endif - found_s = .true. - end do - - if (.not. found_s) then - found = .false. - return - end if - - do loop = 1, num_lines - ine = index(in_data(loop), trim(keyword)) - if (ine == 0) cycle - in = index(in_data(loop), 'end') - if (in == 0 .or. in > 1) cycle - line_e = loop - if (found_e) then - call io_error('Error: Found '//trim(end_st)//' more than once in input file') - endif - found_e = .true. - end do - - if (.not. found_e) then - call io_error('Error: Found '//trim(start_st)//' but no '//trim(end_st)//' in input file') - end if - - if (line_e <= line_s) then - call io_error('Error: '//trim(end_st)//' comes before '//trim(start_st)//' in input file') - end if - - rows = line_e - line_s - 1 - - found = .true. - - ! Ignore atoms_cart and atoms_frac blocks if running in library mode - if (library) then - if (trim(keyword) .eq. 'atoms_cart' .or. trim(keyword) .eq. 'atoms_frac') then - in_data(line_s:line_e) (1:maxlen) = ' ' - endif - endif - - if (present(lunits)) then - dummy = in_data(line_s + 1) - ! write(stdout,*) dummy - ! write(stdout,*) trim(dummy) - read (dummy, *, end=555) atsym, (atpos(i), i=1, 3) - lunits = .false. - endif - - if (rows <= 0) then !cope with empty blocks - found = .false. - in_data(line_s:line_e) (1:maxlen) = ' ' - end if - - return - -555 lunits = .true. - - if (rows <= 1) then !cope with empty blocks - found = .false. - in_data(line_s:line_e) (1:maxlen) = ' ' - end if - - return - - end subroutine param_get_block_length - -!===================================! - subroutine param_get_atoms(lunits) - !===================================! - ! ! - !! Fills the atom data block - ! ! - !===================================! - - use w90_constants, only: bohr - use w90_utility, only: utility_frac_to_cart, utility_cart_to_frac - use w90_io, only: io_error - implicit none - - logical, intent(in) :: lunits - !! Do we expect a first line with the units - - real(kind=dp) :: atoms_pos_frac_tmp(3, num_atoms) - real(kind=dp) :: atoms_pos_cart_tmp(3, num_atoms) - character(len=20) :: keyword - integer :: in, ins, ine, loop, i, line_e, line_s, counter - integer :: i_temp, loop2, max_sites, ierr, ic - logical :: found_e, found_s, found, frac - character(len=maxlen) :: dummy, end_st, start_st - character(len=maxlen) :: ctemp(num_atoms) - character(len=maxlen) :: atoms_label_tmp(num_atoms) - logical :: lconvert - - keyword = "atoms_cart" - frac = .false. - call param_get_block_length("atoms_frac", found, i_temp) - if (found) then - keyword = "atoms_frac" - frac = .true. - end if - - found_s = .false. - found_e = .false. - - start_st = 'begin '//trim(keyword) - end_st = 'end '//trim(keyword) - - do loop = 1, num_lines - ins = index(in_data(loop), trim(keyword)) - if (ins == 0) cycle - in = index(in_data(loop), 'begin') - if (in == 0 .or. in > 1) cycle - line_s = loop - if (found_s) then - call io_error('Error: Found '//trim(start_st)//' more than once in input file') - endif - found_s = .true. - end do - - do loop = 1, num_lines - ine = index(in_data(loop), trim(keyword)) - if (ine == 0) cycle - in = index(in_data(loop), 'end') - if (in == 0 .or. in > 1) cycle - line_e = loop - if (found_e) then - call io_error('Error: Found '//trim(end_st)//' more than once in input file') - endif - found_e = .true. - end do - - if (.not. found_e) then - call io_error('Error: Found '//trim(start_st)//' but no '//trim(end_st)//' in input file') - end if - - if (line_e <= line_s) then - call io_error('Error: '//trim(end_st)//' comes before '//trim(start_st)//' in input file') - end if - - lconvert = .false. - if (lunits) then - dummy = in_data(line_s + 1) - if (index(dummy, 'ang') .ne. 0) then - lconvert = .false. - elseif (index(dummy, 'bohr') .ne. 0) then - lconvert = .true. - else - call io_error('Error: Units in block atoms_cart not recognised in param_get_atoms') - endif - in_data(line_s) (1:maxlen) = ' ' - line_s = line_s + 1 - endif - - counter = 0 - do loop = line_s + 1, line_e - 1 - dummy = in_data(loop) - counter = counter + 1 - if (frac) then - read (dummy, *, err=240, end=240) atoms_label_tmp(counter), (atoms_pos_frac_tmp(i, counter), i=1, 3) - else - read (dummy, *, err=240, end=240) atoms_label_tmp(counter), (atoms_pos_cart_tmp(i, counter), i=1, 3) - end if - end do - - if (lconvert) atoms_pos_cart_tmp = atoms_pos_cart_tmp*bohr - - in_data(line_s:line_e) (1:maxlen) = ' ' - - if (frac) then - do loop = 1, num_atoms - call utility_frac_to_cart(atoms_pos_frac_tmp(:, loop), atoms_pos_cart_tmp(:, loop), real_lattice) - end do - else - do loop = 1, num_atoms - call utility_cart_to_frac(atoms_pos_cart_tmp(:, loop), atoms_pos_frac_tmp(:, loop), recip_lattice) - end do - end if - - ! Now we sort the data into the proper structures - num_species = 1 - ctemp(1) = atoms_label_tmp(1) - do loop = 2, num_atoms - do loop2 = 1, loop - 1 - if (trim(atoms_label_tmp(loop)) == trim(atoms_label_tmp(loop2))) exit - if (loop2 == loop - 1) then - num_species = num_species + 1 - ctemp(num_species) = atoms_label_tmp(loop) - end if - end do - end do - - allocate (atoms_species_num(num_species), stat=ierr) - if (ierr /= 0) call io_error('Error allocating atoms_species_num in param_get_atoms') - allocate (atoms_label(num_species), stat=ierr) - if (ierr /= 0) call io_error('Error allocating atoms_label in param_get_atoms') - allocate (atoms_symbol(num_species), stat=ierr) - if (ierr /= 0) call io_error('Error allocating atoms_symbol in param_get_atoms') - atoms_species_num(:) = 0 - - do loop = 1, num_species - atoms_label(loop) = ctemp(loop) - do loop2 = 1, num_atoms - if (trim(atoms_label(loop)) == trim(atoms_label_tmp(loop2))) then - atoms_species_num(loop) = atoms_species_num(loop) + 1 - end if - end do - end do - - max_sites = maxval(atoms_species_num) - allocate (atoms_pos_frac(3, max_sites, num_species), stat=ierr) - if (ierr /= 0) call io_error('Error allocating atoms_pos_frac in param_get_atoms') - allocate (atoms_pos_cart(3, max_sites, num_species), stat=ierr) - if (ierr /= 0) call io_error('Error allocating atoms_pos_cart in param_get_atoms') - - do loop = 1, num_species - counter = 0 - do loop2 = 1, num_atoms - if (trim(atoms_label(loop)) == trim(atoms_label_tmp(loop2))) then - counter = counter + 1 - atoms_pos_frac(:, counter, loop) = atoms_pos_frac_tmp(:, loop2) - atoms_pos_cart(:, counter, loop) = atoms_pos_cart_tmp(:, loop2) - end if - end do - end do - - ! Strip any numeric characters from atoms_label to get atoms_symbol - do loop = 1, num_species - atoms_symbol(loop) (1:2) = atoms_label(loop) (1:2) - ic = ichar(atoms_symbol(loop) (2:2)) - if ((ic .lt. ichar('a')) .or. (ic .gt. ichar('z'))) & - atoms_symbol(loop) (2:2) = ' ' - end do - - return - -240 call io_error('Error: Problem reading block keyword '//trim(keyword)) - - end subroutine param_get_atoms - -!=====================================================! - subroutine param_lib_set_atoms(atoms_label_tmp, atoms_pos_cart_tmp) - !=====================================================! - ! ! - !! Fills the atom data block during a library call - ! ! - !=====================================================! - - use w90_utility, only: utility_cart_to_frac, utility_lowercase - use w90_io, only: io_error - - implicit none - - character(len=*), intent(in) :: atoms_label_tmp(num_atoms) - !! Atom labels - real(kind=dp), intent(in) :: atoms_pos_cart_tmp(3, num_atoms) - !! Atom positions - - real(kind=dp) :: atoms_pos_frac_tmp(3, num_atoms) - integer :: loop2, max_sites, ierr, ic, loop, counter - character(len=maxlen) :: ctemp(num_atoms) - character(len=maxlen) :: tmp_string - - do loop = 1, num_atoms - call utility_cart_to_frac(atoms_pos_cart_tmp(:, loop), & - atoms_pos_frac_tmp(:, loop), recip_lattice) - enddo - - ! Now we sort the data into the proper structures - num_species = 1 - ctemp(1) = atoms_label_tmp(1) - do loop = 2, num_atoms - do loop2 = 1, loop - 1 - if (trim(atoms_label_tmp(loop)) == trim(atoms_label_tmp(loop2))) exit - if (loop2 == loop - 1) then - num_species = num_species + 1 - ctemp(num_species) = atoms_label_tmp(loop) - end if - end do - end do - - allocate (atoms_species_num(num_species), stat=ierr) - if (ierr /= 0) call io_error('Error allocating atoms_species_num in param_lib_set_atoms') - allocate (atoms_label(num_species), stat=ierr) - if (ierr /= 0) call io_error('Error allocating atoms_label in param_lib_set_atoms') - allocate (atoms_symbol(num_species), stat=ierr) - if (ierr /= 0) call io_error('Error allocating atoms_symbol in param_lib_set_atoms') - atoms_species_num(:) = 0 - - do loop = 1, num_species - atoms_label(loop) = ctemp(loop) - do loop2 = 1, num_atoms - if (trim(atoms_label(loop)) == trim(atoms_label_tmp(loop2))) then - atoms_species_num(loop) = atoms_species_num(loop) + 1 - end if - end do - end do - - max_sites = maxval(atoms_species_num) - allocate (atoms_pos_frac(3, max_sites, num_species), stat=ierr) - if (ierr /= 0) call io_error('Error allocating atoms_pos_frac in param_lib_set_atoms') - allocate (atoms_pos_cart(3, max_sites, num_species), stat=ierr) - if (ierr /= 0) call io_error('Error allocating atoms_pos_cart in param_lib_set_atoms') - - do loop = 1, num_species - counter = 0 - do loop2 = 1, num_atoms - if (trim(atoms_label(loop)) == trim(atoms_label_tmp(loop2))) then - counter = counter + 1 - atoms_pos_frac(:, counter, loop) = atoms_pos_frac_tmp(:, loop2) - atoms_pos_cart(:, counter, loop) = atoms_pos_cart_tmp(:, loop2) - end if - end do - end do - - ! Strip any numeric characters from atoms_label to get atoms_symbol - do loop = 1, num_species - atoms_symbol(loop) (1:2) = atoms_label(loop) (1:2) - ic = ichar(atoms_symbol(loop) (2:2)) - if ((ic .lt. ichar('a')) .or. (ic .gt. ichar('z'))) & - atoms_symbol(loop) (2:2) = ' ' - tmp_string = trim(adjustl(utility_lowercase(atoms_symbol(loop)))) - atoms_symbol(loop) (1:2) = tmp_string(1:2) - tmp_string = trim(adjustl(utility_lowercase(atoms_label(loop)))) - atoms_label(loop) (1:2) = tmp_string(1:2) - end do - - return - - end subroutine param_lib_set_atoms - -!====================================================================! - subroutine param_get_range_vector(keyword, found, length, lcount, i_value) - !====================================================================! - !! Read a range vector eg. 1,2,3,4-10 or 1 3 400:100 - !! if(lcount) we return the number of states in length - !====================================================================! - use w90_io, only: io_error - - implicit none - - character(*), intent(in) :: keyword - !! Keyword to examine - logical, intent(out) :: found - !! Is keyword found - integer, intent(inout) :: length - !! Number of states - logical, intent(in) :: lcount - !! If T only count states - integer, optional, intent(out) :: i_value(length) - !! States specified in range vector - - integer :: kl, in, loop, num1, num2, i_punc - integer :: counter, i_digit, loop_r, range_size - character(len=maxlen) :: dummy - character(len=10), parameter :: c_digit = "0123456789" - character(len=2), parameter :: c_range = "-:" - character(len=3), parameter :: c_sep = " ,;" - character(len=5), parameter :: c_punc = " ,;-:" - character(len=5) :: c_num1, c_num2 - - if (lcount .and. present(i_value)) call io_error('param_get_range_vector: incorrect call') - - kl = len_trim(keyword) - - found = .false. - - do loop = 1, num_lines - in = index(in_data(loop), trim(keyword)) - if (in == 0 .or. in > 1) cycle - if (found) then - call io_error('Error: Found keyword '//trim(keyword)//' more than once in input file') - endif - found = .true. - dummy = in_data(loop) (kl + 1:) - dummy = adjustl(dummy) - if (.not. lcount) in_data(loop) (1:maxlen) = ' ' - if (dummy(1:1) == '=' .or. dummy(1:1) == ':') then - dummy = dummy(2:) - dummy = adjustl(dummy) - end if - end do - - if (.not. found) return - - counter = 0 - if (len_trim(dummy) == 0) call io_error('Error: keyword '//trim(keyword)//' is blank') - dummy = adjustl(dummy) - do - i_punc = scan(dummy, c_punc) - if (i_punc == 0) call io_error('Error parsing keyword '//trim(keyword)) - c_num1 = dummy(1:i_punc - 1) - read (c_num1, *, err=101, end=101) num1 - dummy = adjustl(dummy(i_punc:)) - !look for range - if (scan(dummy, c_range) == 1) then - i_digit = scan(dummy, c_digit) - dummy = adjustl(dummy(i_digit:)) - i_punc = scan(dummy, c_punc) - c_num2 = dummy(1:i_punc - 1) - read (c_num2, *, err=101, end=101) num2 - dummy = adjustl(dummy(i_punc:)) - range_size = abs(num2 - num1) + 1 - do loop_r = 1, range_size - counter = counter + 1 - if (.not. lcount) i_value(counter) = min(num1, num2) + loop_r - 1 - end do - else - counter = counter + 1 - if (.not. lcount) i_value(counter) = num1 - end if - - if (scan(dummy, c_sep) == 1) dummy = adjustl(dummy(2:)) - if (scan(dummy, c_range) == 1) call io_error('Error parsing keyword '//trim(keyword)//' incorrect range') - if (index(dummy, ' ') == 1) exit - end do - - if (lcount) length = counter - if (.not. lcount) then - do loop = 1, counter - 1 - do loop_r = loop + 1, counter - if (i_value(loop) == i_value(loop_r)) & - call io_error('Error parsing keyword '//trim(keyword)//' duplicate values') - end do - end do - end if - - return - -101 call io_error('Error parsing keyword '//trim(keyword)) - - end subroutine param_get_range_vector - - subroutine param_get_centre_constraints - !=============================================================================! - ! ! - !! assigns projection centres as default centre constraints and global - !! Lagrange multiplier as individual Lagrange multipliers then reads - !! the centre_constraints block for individual centre constraint parameters - ! ! - !=============================================================================! - use w90_io, only: io_error - use w90_utility, only: utility_frac_to_cart - integer :: loop1, index1, constraint_num, index2, loop2 - integer :: column, start, finish, wann, ierr - !logical :: found - character(len=maxlen) :: dummy - - do loop1 = 1, num_wann - do loop2 = 1, 3 - ccentres_frac(loop1, loop2) = proj_site(loop2, loop1) - end do - end do - - constraint_num = 0 - do loop1 = 1, num_lines - dummy = in_data(loop1) - if (constraint_num > 0) then - if (trim(dummy) == '') cycle - index1 = index(dummy, 'begin') - if (index1 > 0) call io_error("slwf_centres block hasn't ended yet") - index1 = index(dummy, 'end') - if (index1 > 0) then - index1 = index(dummy, 'slwf_centres') - if (index1 == 0) call io_error('Wrong ending of block (need to end slwf_centres)') - in_data(loop1) (1:maxlen) = ' ' - exit - end if - column = 0 - start = 1 - finish = 1 - do loop2 = 1, len_trim(dummy) - if (start == loop2 .and. dummy(loop2:loop2) == ' ') then - start = loop2 + 1 - end if - if (start < loop2) then - if (dummy(loop2:loop2) == ' ') then - finish = loop2 - 1 - call param_get_centre_constraint_from_column(column, start, finish, wann, dummy) - start = loop2 + 1 - finish = start - end if - end if - if (loop2 == len_trim(dummy) .and. dummy(loop2:loop2) /= ' ') then - finish = loop2 - call param_get_centre_constraint_from_column(column, start, finish, wann, dummy) - start = loop2 + 1 - finish = start - end if - end do - in_data(loop1) (1:maxlen) = ' ' - constraint_num = constraint_num + 1 - end if - index1 = index(dummy, 'slwf_centres') - if (index1 > 0) then - index1 = index(dummy, 'begin') - if (index1 > 0) then - constraint_num = 1 - in_data(loop1) (1:maxlen) = ' ' - end if - end if - end do - do loop1 = 1, num_wann - call utility_frac_to_cart(ccentres_frac(loop1, :), ccentres_cart(loop1, :), real_lattice) - end do - end subroutine param_get_centre_constraints - - subroutine param_get_centre_constraint_from_column(column, start, finish, wann, dummy) - !===================================! - ! ! - !! assigns value read to constraint - !! parameters based on column - ! ! - !===================================! - use w90_io, only: io_error - integer, intent(inout):: column, start, finish, wann - character(len=maxlen), intent(inout):: dummy - if (column == 0) then - read (dummy(start:finish), '(i3)') wann - end if - if (column > 0) then - if (column > 4) call io_error("Didn't expect anything else after Lagrange multiplier") - if (column < 4) read (dummy(start:finish), '(f10.10)') ccentres_frac(wann, column) - end if - column = column + 1 - end subroutine param_get_centre_constraint_from_column - -!===================================! - subroutine param_get_projections(num_proj, lcount) - !===================================! - ! ! - !! Fills the projection data block - ! ! - !===================================! - - use w90_constants, only: bohr, eps6, eps2 - use w90_utility, only: utility_cart_to_frac, & - utility_string_to_coord, utility_strip - use w90_io, only: io_error - - implicit none - - integer, intent(inout) :: num_proj - logical, intent(in) :: lcount - - real(kind=dp) :: pos_frac(3) - real(kind=dp) :: pos_cart(3) - character(len=20) :: keyword - integer :: in, ins, ine, loop, line_e, line_s, counter - integer :: sites, species, line, pos1, pos2, pos3, m_tmp, l_tmp, mstate - integer :: loop_l, loop_m, loop_sites, ierr, loop_s, spn_counter - logical :: found_e, found_s - character(len=maxlen) :: dummy, end_st, start_st - character(len=maxlen) :: ctemp, ctemp2, ctemp3, ctemp4, ctemp5, m_string - ! - integer, parameter :: min_l = -5 - integer, parameter :: max_l = 3 - integer, parameter :: min_m = 1 - integer, parameter :: max_m = 7 - integer :: ang_states(min_m:max_m, min_l:max_l) - ! default values for the optional part of the projection definitions - real(kind=dp), parameter :: proj_z_def(3) = (/0.0_dp, 0.0_dp, 1.0_dp/) - real(kind=dp), parameter :: proj_x_def(3) = (/1.0_dp, 0.0_dp, 0.0_dp/) - real(kind=dp), parameter :: proj_s_qaxis_def(3) = (/0.0_dp, 0.0_dp, 1.0_dp/) - real(kind=dp), parameter :: proj_zona_def = 1.0_dp - integer, parameter :: proj_radial_def = 1 - ! - real(kind=dp) :: proj_z_tmp(3) - real(kind=dp) :: proj_x_tmp(3) - real(kind=dp) :: proj_s_qaxis_tmp(3) - real(kind=dp) :: proj_zona_tmp - integer :: proj_radial_tmp - logical :: lconvert, lrandom, proj_u_tmp, proj_d_tmp - logical :: lpartrandom - ! - real(kind=dp) :: xnorm, znorm, cosphi, sinphi, xnorm_new, cosphi_new - - keyword = "projections" - - found_s = .false. - found_e = .false. - - start_st = 'begin '//trim(keyword) - end_st = 'end '//trim(keyword) - -! if(spinors) num_proj=num_wann/2 - - if (.not. lcount) then - allocate (input_proj_site(3, num_proj), stat=ierr) - if (ierr /= 0) call io_error('Error allocating input_proj_site in param_get_projections') - allocate (input_proj_l(num_proj), stat=ierr) - if (ierr /= 0) call io_error('Error allocating input_proj_l in param_get_projections') - allocate (input_proj_m(num_proj), stat=ierr) - if (ierr /= 0) call io_error('Error allocating input_proj_m in param_get_projections') - allocate (input_proj_z(3, num_proj), stat=ierr) - if (ierr /= 0) call io_error('Error allocating input_proj_z in param_get_projections') - allocate (input_proj_x(3, num_proj), stat=ierr) - if (ierr /= 0) call io_error('Error allocating input_proj_x in param_get_projections') - allocate (input_proj_radial(num_proj), stat=ierr) - if (ierr /= 0) call io_error('Error allocating input_proj_radial in param_get_projections') - allocate (input_proj_zona(num_proj), stat=ierr) - if (ierr /= 0) call io_error('Error allocating input_proj_zona in param_get_projections') - if (spinors) then - allocate (input_proj_s(num_proj), stat=ierr) - if (ierr /= 0) call io_error('Error allocating input_proj_s in param_get_projections') - allocate (input_proj_s_qaxis(3, num_proj), stat=ierr) - if (ierr /= 0) call io_error('Error allocating input_proj_s_qaxis in param_get_projections') - endif - - allocate (proj_site(3, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating proj_site in param_get_projections') - allocate (proj_l(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating proj_l in param_get_projections') - allocate (proj_m(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating proj_m in param_get_projections') - allocate (proj_z(3, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating proj_z in param_get_projections') - allocate (proj_x(3, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating proj_x in param_get_projections') - allocate (proj_radial(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating proj_radial in param_get_projections') - allocate (proj_zona(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating proj_zona in param_get_projections') - if (spinors) then - allocate (proj_s(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating proj_s in param_get_projections') - allocate (proj_s_qaxis(3, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating proj_s_qaxis in param_get_projections') - endif - endif - - do loop = 1, num_lines - ins = index(in_data(loop), trim(keyword)) - if (ins == 0) cycle - in = index(in_data(loop), 'begin') - if (in == 0 .or. in > 1) cycle - line_s = loop - if (found_s) then - call io_error('Error: Found '//trim(start_st)//' more than once in input file') - endif - found_s = .true. - end do - - do loop = 1, num_lines - ine = index(in_data(loop), trim(keyword)) - if (ine == 0) cycle - in = index(in_data(loop), 'end') - if (in == 0 .or. in > 1) cycle - line_e = loop - if (found_e) then - call io_error('param_get_projections: Found '//trim(end_st)//' more than once in input file') - endif - found_e = .true. - end do - - if (.not. found_e) then - call io_error('param_get_projections: Found '//trim(start_st)//' but no '//trim(end_st)//' in input file') - end if - - if (line_e <= line_s) then - call io_error('param_get_projections: '//trim(end_st)//' comes before '//trim(start_st)//' in input file') - end if - - dummy = in_data(line_s + 1) - lconvert = .false. - lrandom = .false. - lpartrandom = .false. - if (index(dummy, 'ang') .ne. 0) then - if (.not. lcount) in_data(line_s) (1:maxlen) = ' ' - line_s = line_s + 1 - elseif (index(dummy, 'bohr') .ne. 0) then - if (.not. lcount) in_data(line_s) (1:maxlen) = ' ' - line_s = line_s + 1 - lconvert = .true. - elseif (index(dummy, 'random') .ne. 0) then - if (.not. lcount) in_data(line_s) (1:maxlen) = ' ' - line_s = line_s + 1 - if (index(in_data(line_s + 1), end_st) .ne. 0) then - lrandom = .true. ! all projections random - else - lpartrandom = .true. ! only some projections random - if (index(in_data(line_s + 1), 'ang') .ne. 0) then - if (.not. lcount) in_data(line_s) (1:maxlen) = ' ' - line_s = line_s + 1 - elseif (index(in_data(line_s + 1), 'bohr') .ne. 0) then - if (.not. lcount) in_data(line_s) (1:maxlen) = ' ' - line_s = line_s + 1 - lconvert = .true. - endif - endif - endif - - counter = 0 - if (.not. lrandom) then - do line = line_s + 1, line_e - 1 - ang_states = 0 - !Assume the default values - proj_z_tmp = proj_z_def - proj_x_tmp = proj_x_def - proj_zona_tmp = proj_zona_def - proj_radial_tmp = proj_radial_def - if (spinors) then - proj_s_qaxis_tmp = proj_s_qaxis_def - spn_counter = 2 - proj_u_tmp = .true. - proj_d_tmp = .true. - else - spn_counter = 1 - endif - ! Strip input line of all spaces - dummy = utility_strip(in_data(line)) - dummy = adjustl(dummy) - pos1 = index(dummy, ':') - if (pos1 == 0) & - call io_error('param_read_projection: malformed projection definition: '//trim(dummy)) - sites = 0 - ctemp = dummy(:pos1 - 1) - ! Read the atomic site - if (index(ctemp, 'c=') > 0) then - sites = -1 - ctemp = ctemp(3:) - call utility_string_to_coord(ctemp, pos_cart) - if (lconvert) pos_cart = pos_cart*bohr - call utility_cart_to_frac(pos_cart(:), pos_frac(:), recip_lattice) - elseif (index(ctemp, 'f=') > 0) then - sites = -1 - ctemp = ctemp(3:) - call utility_string_to_coord(ctemp, pos_frac) - else - if (num_species == 0) & - call io_error('param_get_projection: Atom centred projection requested but no atoms defined') - do loop = 1, num_species - if (trim(ctemp) == atoms_label(loop)) then - species = loop - sites = atoms_species_num(loop) - exit - end if - if (loop == num_species) call io_error('param_get_projection: Atom site not recognised '//trim(ctemp)) - end do - end if - - dummy = dummy(pos1 + 1:) - - ! scan for quantisation direction - pos1 = index(dummy, '[') - if (spinors) then - if (pos1 > 0) then - ctemp = (dummy(pos1 + 1:)) - pos2 = index(ctemp, ']') - if (pos2 == 0) call io_error & - ('param_get_projections: no closing square bracket for spin quantisation dir') - ctemp = ctemp(:pos2 - 1) - call utility_string_to_coord(ctemp, proj_s_qaxis_tmp) - dummy = dummy(:pos1 - 1) ! remove [ ] section - endif - else - if (pos1 > 0) call io_error('param_get_projections: spin qdir is defined but spinors=.false.') - endif - - ! scan for up or down - pos1 = index(dummy, '(') - if (spinors) then - if (pos1 > 0) then - proj_u_tmp = .false.; proj_d_tmp = .false. - ctemp = (dummy(pos1 + 1:)) - pos2 = index(ctemp, ')') - if (pos2 == 0) call io_error('param_get_projections: no closing bracket for spin') - ctemp = ctemp(:pos2 - 1) - if (index(ctemp, 'u') > 0) proj_u_tmp = .true. - if (index(ctemp, 'd') > 0) proj_d_tmp = .true. - if (proj_u_tmp .and. proj_d_tmp) then - spn_counter = 2 - elseif (.not. proj_u_tmp .and. .not. proj_d_tmp) then - call io_error('param_get_projections: found brackets but neither u or d') - else - spn_counter = 1 - endif - dummy = dummy(:pos1 - 1) ! remove ( ) section - endif - else - if (pos1 > 0) call io_error('param_get_projections: spin is defined but spinors=.false.') - endif - - !Now we know the sites for this line. Get the angular momentum states - pos1 = index(dummy, ':') - if (pos1 > 0) then - ctemp = dummy(:pos1 - 1) - else - ctemp = dummy - end if - ctemp2 = ctemp - do - pos2 = index(ctemp2, ';') - if (pos2 == 0) then - ctemp3 = ctemp2 - else - ctemp3 = ctemp2(:pos2 - 1) - endif - if (index(ctemp3, 'l=') == 1) then - mstate = index(ctemp3, ',') - if (mstate > 0) then - read (ctemp3(3:mstate - 1), *, err=101, end=101) l_tmp - else - read (ctemp3(3:), *, err=101, end=101) l_tmp - end if - if (l_tmp < -5 .or. l_tmp > 3) call io_error('param_get_projection: Incorrect l state requested') - if (mstate == 0) then - if (l_tmp >= 0) then - do loop_m = 1, 2*l_tmp + 1 - ang_states(loop_m, l_tmp) = 1 - end do - elseif (l_tmp == -1) then !sp - ang_states(1:2, l_tmp) = 1 - elseif (l_tmp == -2) then !sp2 - ang_states(1:3, l_tmp) = 1 - elseif (l_tmp == -3) then !sp3 - ang_states(1:4, l_tmp) = 1 - elseif (l_tmp == -4) then !sp3d - ang_states(1:5, l_tmp) = 1 - elseif (l_tmp == -5) then !sp3d2 - ang_states(1:6, l_tmp) = 1 - endif - else - if (index(ctemp3, 'mr=') /= mstate + 1) & - call io_error('param_get_projection: Problem reading m state') - ctemp4 = ctemp3(mstate + 4:) - do - pos3 = index(ctemp4, ',') - if (pos3 == 0) then - ctemp5 = ctemp4 - else - ctemp5 = ctemp4(:pos3 - 1) - endif - read (ctemp5(1:), *, err=102, end=102) m_tmp - if (l_tmp >= 0) then - if ((m_tmp > 2*l_tmp + 1) .or. (m_tmp <= 0)) call io_error('param_get_projection: m is > l !') - elseif (l_tmp == -1 .and. (m_tmp > 2 .or. m_tmp <= 0)) then - call io_error('param_get_projection: m has incorrect value (1)') - elseif (l_tmp == -2 .and. (m_tmp > 3 .or. m_tmp <= 0)) then - call io_error('param_get_projection: m has incorrect value (2)') - elseif (l_tmp == -3 .and. (m_tmp > 4 .or. m_tmp <= 0)) then - call io_error('param_get_projection: m has incorrect value (3)') - elseif (l_tmp == -4 .and. (m_tmp > 5 .or. m_tmp <= 0)) then - call io_error('param_get_projection: m has incorrect value (4)') - elseif (l_tmp == -5 .and. (m_tmp > 6 .or. m_tmp <= 0)) then - call io_error('param_get_projection: m has incorrect value (5)') - endif - ang_states(m_tmp, l_tmp) = 1 - if (pos3 == 0) exit - ctemp4 = ctemp4(pos3 + 1:) - enddo - end if - else - do - pos3 = index(ctemp3, ',') - if (pos3 == 0) then - ctemp4 = ctemp3 - else - ctemp4 = ctemp3(:pos3 - 1) - endif - read (ctemp4(1:), *, err=106, end=106) m_string - select case (trim(adjustl(m_string))) - case ('s') - ang_states(1, 0) = 1 - case ('p') - ang_states(1:3, 1) = 1 - case ('pz') - ang_states(1, 1) = 1 - case ('px') - ang_states(2, 1) = 1 - case ('py') - ang_states(3, 1) = 1 - case ('d') - ang_states(1:5, 2) = 1 - case ('dz2') - ang_states(1, 2) = 1 - case ('dxz') - ang_states(2, 2) = 1 - case ('dyz') - ang_states(3, 2) = 1 - case ('dx2-y2') - ang_states(4, 2) = 1 - case ('dxy') - ang_states(5, 2) = 1 - case ('f') - ang_states(1:7, 3) = 1 - case ('fz3') - ang_states(1, 3) = 1 - case ('fxz2') - ang_states(2, 3) = 1 - case ('fyz2') - ang_states(3, 3) = 1 - case ('fxyz') - ang_states(4, 3) = 1 - case ('fz(x2-y2)') - ang_states(5, 3) = 1 - case ('fx(x2-3y2)') - ang_states(6, 3) = 1 - case ('fy(3x2-y2)') - ang_states(7, 3) = 1 - case ('sp') - ang_states(1:2, -1) = 1 - case ('sp-1') - ang_states(1, -1) = 1 - case ('sp-2') - ang_states(2, -1) = 1 - case ('sp2') - ang_states(1:3, -2) = 1 - case ('sp2-1') - ang_states(1, -2) = 1 - case ('sp2-2') - ang_states(2, -2) = 1 - case ('sp2-3') - ang_states(3, -2) = 1 - case ('sp3') - ang_states(1:4, -3) = 1 - case ('sp3-1') - ang_states(1, -3) = 1 - case ('sp3-2') - ang_states(2, -3) = 1 - case ('sp3-3') - ang_states(3, -3) = 1 - case ('sp3-4') - ang_states(4, -3) = 1 - case ('sp3d') - ang_states(1:5, -4) = 1 - case ('sp3d-1') - ang_states(1, -4) = 1 - case ('sp3d-2') - ang_states(2, -4) = 1 - case ('sp3d-3') - ang_states(3, -4) = 1 - case ('sp3d-4') - ang_states(4, -4) = 1 - case ('sp3d-5') - ang_states(5, -4) = 1 - case ('sp3d2') - ang_states(1:6, -5) = 1 - case ('sp3d2-1') - ang_states(1, -5) = 1 - case ('sp3d2-2') - ang_states(2, -5) = 1 - case ('sp3d2-3') - ang_states(3, -5) = 1 - case ('sp3d2-4') - ang_states(4, -5) = 1 - case ('sp3d2-5') - ang_states(5, -5) = 1 - case ('sp3d2-6') - ang_states(6, -5) = 1 - case default - call io_error('param_get_projection: Problem reading l state '//trim(ctemp3)) - end select - if (pos3 == 0) exit - ctemp3 = ctemp3(pos3 + 1:) - enddo - endif - if (pos2 == 0) exit - ctemp2 = ctemp2(pos2 + 1:) - enddo - ! check for non-default values - if (pos1 > 0) then - dummy = dummy(pos1 + 1:) - ! z axis - pos1 = index(dummy, 'z=') - if (pos1 > 0) then - ctemp = (dummy(pos1 + 2:)) - pos2 = index(ctemp, ':') - if (pos2 > 0) ctemp = ctemp(:pos2 - 1) - call utility_string_to_coord(ctemp, proj_z_tmp) - endif - ! x axis - pos1 = index(dummy, 'x=') - if (pos1 > 0) then - ctemp = (dummy(pos1 + 2:)) - pos2 = index(ctemp, ':') - if (pos2 > 0) ctemp = ctemp(:pos2 - 1) - call utility_string_to_coord(ctemp, proj_x_tmp) - endif - ! diffusivity of orbital - pos1 = index(dummy, 'zona=') - if (pos1 > 0) then - ctemp = (dummy(pos1 + 5:)) - pos2 = index(ctemp, ':') - if (pos2 > 0) ctemp = ctemp(:pos2 - 1) - read (ctemp, *, err=104, end=104) proj_zona_tmp - endif - ! nodes for the radial part - pos1 = index(dummy, 'r=') - if (pos1 > 0) then - ctemp = (dummy(pos1 + 2:)) - pos2 = index(ctemp, ':') - if (pos2 > 0) ctemp = ctemp(:pos2 - 1) - read (ctemp, *, err=105, end=105) proj_radial_tmp - endif - end if - ! if (sites == -1) then - ! if (counter + spn_counter*sum(ang_states) > num_proj) & - ! call io_error('param_get_projection: too many projections defined') - ! else - ! if (counter + spn_counter*sites*sum(ang_states) > num_proj) & - ! call io_error('param_get_projection: too many projections defined') - ! end if - ! - if (sites == -1) then - do loop_l = min_l, max_l - do loop_m = min_m, max_m - if (ang_states(loop_m, loop_l) == 1) then - do loop_s = 1, spn_counter - counter = counter + 1 - if (lcount) cycle - input_proj_site(:, counter) = pos_frac - input_proj_l(counter) = loop_l - input_proj_m(counter) = loop_m - input_proj_z(:, counter) = proj_z_tmp - input_proj_x(:, counter) = proj_x_tmp - input_proj_radial(counter) = proj_radial_tmp - input_proj_zona(counter) = proj_zona_tmp - if (spinors) then - if (spn_counter == 1) then - if (proj_u_tmp) input_proj_s(counter) = 1 - if (proj_d_tmp) input_proj_s(counter) = -1 - else - if (loop_s == 1) input_proj_s(counter) = 1 - if (loop_s == 2) input_proj_s(counter) = -1 - endif - input_proj_s_qaxis(:, counter) = proj_s_qaxis_tmp - endif - end do - endif - end do - end do - else - do loop_sites = 1, sites - do loop_l = min_l, max_l - do loop_m = min_m, max_m - if (ang_states(loop_m, loop_l) == 1) then - do loop_s = 1, spn_counter - counter = counter + 1 - if (lcount) cycle - input_proj_site(:, counter) = atoms_pos_frac(:, loop_sites, species) - input_proj_l(counter) = loop_l - input_proj_m(counter) = loop_m - input_proj_z(:, counter) = proj_z_tmp - input_proj_x(:, counter) = proj_x_tmp - input_proj_radial(counter) = proj_radial_tmp - input_proj_zona(counter) = proj_zona_tmp - if (spinors) then - if (spn_counter == 1) then - if (proj_u_tmp) input_proj_s(counter) = 1 - if (proj_d_tmp) input_proj_s(counter) = -1 - else - if (loop_s == 1) input_proj_s(counter) = 1 - if (loop_s == 2) input_proj_s(counter) = -1 - endif - input_proj_s_qaxis(:, counter) = proj_s_qaxis_tmp - endif - end do - end if - end do - end do - end do - end if - - end do !end loop over projection block - - ! check there are enough projections and add random projections if required - if (.not. lpartrandom) then - if (counter .lt. num_wann) call io_error( & - 'param_get_projections: too few projection functions defined') - end if - end if ! .not. lrandom - - if (lcount) then - if (counter .lt. num_wann) then - num_proj = num_wann - else - num_proj = counter - endif - return - endif - - if (lpartrandom .or. lrandom) then - call random_seed() ! comment out this line for reproducible random positions! - do loop = counter + 1, num_wann - call random_number(input_proj_site(:, loop)) - input_proj_l(loop) = 0 - input_proj_m(loop) = 1 - input_proj_z(:, loop) = proj_z_def - input_proj_x(:, loop) = proj_x_def - input_proj_zona(loop) = proj_zona_def - input_proj_radial(loop) = proj_radial_def - if (spinors) then - if (modulo(loop, 2) == 1) then - input_proj_s(loop) = 1 - else - input_proj_s(loop) = -1 - end if - input_proj_s_qaxis(1, loop) = 0. - input_proj_s_qaxis(2, loop) = 0. - input_proj_s_qaxis(3, loop) = 1. - end if - enddo - endif - - ! I shouldn't get here, but just in case - if (.not. lcount) in_data(line_s:line_e) (1:maxlen) = ' ' - -!~ ! Check -!~ do loop=1,num_wann -!~ if ( abs(sum(proj_z(:,loop)*proj_x(:,loop))).gt.1.0e-6_dp ) then -!~ write(stdout,*) ' Projection:',loop -!~ call io_error(' Error in projections: z and x axes are not orthogonal') -!~ endif -!~ enddo - - ! Normalise z-axis and x-axis and check/fix orthogonality - do loop = 1, num_proj - - znorm = sqrt(sum(input_proj_z(:, loop)*input_proj_z(:, loop))) - xnorm = sqrt(sum(input_proj_x(:, loop)*input_proj_x(:, loop))) - input_proj_z(:, loop) = input_proj_z(:, loop)/znorm ! normalise z - input_proj_x(:, loop) = input_proj_x(:, loop)/xnorm ! normalise x - cosphi = sum(input_proj_z(:, loop)*input_proj_x(:, loop)) - - ! Check whether z-axis and z-axis are orthogonal - if (abs(cosphi) .gt. eps6) then - - ! Special case of circularly symmetric projections (pz, dz2, fz3) - ! just choose an x-axis that is perpendicular to the given z-axis - if ((input_proj_l(loop) .ge. 0) .and. (input_proj_m(loop) .eq. 1)) then - proj_x_tmp(:) = input_proj_x(:, loop) ! copy of original x-axis - call random_seed() - call random_number(proj_z_tmp(:)) ! random vector - ! calculate new x-axis as the cross (vector) product of random vector with z-axis - input_proj_x(1, loop) = proj_z_tmp(2)*input_proj_z(3, loop) - proj_z_tmp(3)*input_proj_z(2, loop) - input_proj_x(2, loop) = proj_z_tmp(3)*input_proj_z(1, loop) - proj_z_tmp(1)*input_proj_z(3, loop) - input_proj_x(3, loop) = proj_z_tmp(1)*input_proj_z(2, loop) - proj_z_tmp(2)*input_proj_z(1, loop) - xnorm_new = sqrt(sum(input_proj_x(:, loop)*input_proj_x(:, loop))) - input_proj_x(:, loop) = input_proj_x(:, loop)/xnorm_new ! normalise - goto 555 - endif - - ! If projection axes non-orthogonal enough, then - ! user may have made a mistake and should check - if (abs(cosphi) .gt. eps2) then - write (stdout, *) ' Projection:', loop - call io_error(' Error in projections: z and x axes are not orthogonal') - endif - - ! If projection axes are "reasonably orthogonal", project x-axis - ! onto plane perpendicular to z-axis to make them more so - sinphi = sqrt(1 - cosphi*cosphi) - proj_x_tmp(:) = input_proj_x(:, loop) ! copy of original x-axis - ! calculate new x-axis: - ! x = z \cross (x_tmp \cross z) / sinphi = ( x_tmp - z(z.x_tmp) ) / sinphi - input_proj_x(:, loop) = (proj_x_tmp(:) - cosphi*input_proj_z(:, loop))/sinphi - - ! Final check -555 cosphi_new = sum(input_proj_z(:, loop)*input_proj_x(:, loop)) - if (abs(cosphi_new) .gt. eps6) then - write (stdout, *) ' Projection:', loop - call io_error(' Error: z and x axes are still not orthogonal after projection') - endif - - endif - - enddo - - do loop = 1, num_proj - if (proj2wann_map(loop) < 0) cycle - proj_site(:, proj2wann_map(loop)) = input_proj_site(:, loop) - proj_l(proj2wann_map(loop)) = input_proj_l(loop) - proj_m(proj2wann_map(loop)) = input_proj_m(loop) - proj_z(:, proj2wann_map(loop)) = input_proj_z(:, loop) - proj_x(:, proj2wann_map(loop)) = input_proj_x(:, loop) - proj_radial(proj2wann_map(loop)) = input_proj_radial(loop) - proj_zona(proj2wann_map(loop)) = input_proj_zona(loop) - enddo - - if (spinors) then - do loop = 1, num_proj - if (proj2wann_map(loop) < 0) cycle - proj_s(proj2wann_map(loop)) = input_proj_s(loop) - proj_s_qaxis(:, proj2wann_map(loop)) = input_proj_s_qaxis(:, loop) - enddo - endif - - return - -101 call io_error('param_get_projection: Problem reading l state into integer '//trim(ctemp3)) -102 call io_error('param_get_projection: Problem reading m state into integer '//trim(ctemp3)) -104 call io_error('param_get_projection: Problem reading zona into real '//trim(ctemp)) -105 call io_error('param_get_projection: Problem reading radial state into integer '//trim(ctemp)) -106 call io_error('param_get_projection: Problem reading m state into string '//trim(ctemp3)) - - end subroutine param_get_projections - -!===================================! - subroutine param_get_keyword_kpath - !===================================! - ! ! - !! Fills the kpath data block - ! ! - !===================================! - use w90_io, only: io_error - - implicit none - - character(len=20) :: keyword - integer :: in, ins, ine, loop, i, line_e, line_s, counter - logical :: found_e, found_s - character(len=maxlen) :: dummy, end_st, start_st - - keyword = "kpoint_path" - - found_s = .false. - found_e = .false. - - start_st = 'begin '//trim(keyword) - end_st = 'end '//trim(keyword) - - do loop = 1, num_lines - ins = index(in_data(loop), trim(keyword)) - if (ins == 0) cycle - in = index(in_data(loop), 'begin') - if (in == 0 .or. in > 1) cycle - line_s = loop - if (found_s) then - call io_error('Error: Found '//trim(start_st)//' more than once in input file') - endif - found_s = .true. - end do - - do loop = 1, num_lines - ine = index(in_data(loop), trim(keyword)) - if (ine == 0) cycle - in = index(in_data(loop), 'end') - if (in == 0 .or. in > 1) cycle - line_e = loop - if (found_e) then - call io_error('Error: Found '//trim(end_st)//' more than once in input file') - endif - found_e = .true. - end do - - if (.not. found_e) then - call io_error('Error: Found '//trim(start_st)//' but no '//trim(end_st)//' in input file') - end if - - if (line_e <= line_s) then - call io_error('Error: '//trim(end_st)//' comes before '//trim(start_st)//' in input file') - end if - - counter = 0 - do loop = line_s + 1, line_e - 1 - - counter = counter + 2 - dummy = in_data(loop) - read (dummy, *, err=240, end=240) bands_label(counter - 1), (bands_spec_points(i, counter - 1), i=1, 3) & - , bands_label(counter), (bands_spec_points(i, counter), i=1, 3) - end do - - in_data(line_s:line_e) (1:maxlen) = ' ' - - return - -240 call io_error('param_get_keyword_kpath: Problem reading kpath '//trim(dummy)) - - end subroutine param_get_keyword_kpath - -!===========================================! - subroutine param_memory_estimate - !===========================================! - ! ! - !! Estimate how much memory we will allocate - ! ! - !===========================================! - - use w90_comms, only: on_root - - implicit none - - real(kind=dp), parameter :: size_log = 1.0_dp - real(kind=dp), parameter :: size_int = 4.0_dp - real(kind=dp), parameter :: size_real = 8.0_dp - real(kind=dp), parameter :: size_cmplx = 16.0_dp - real(kind=dp) :: mem_wan, mem_wan1, mem_param, mem_dis, mem_dis2, mem_dis1 - real(kind=dp) :: mem_bw - integer :: NumPoints1, NumPoints2, NumPoints3, ndim - real(kind=dp) :: TDF_exceeding_energy - - mem_param = 0 - mem_dis = 0 - mem_dis1 = 0 - mem_dis2 = 0 - mem_wan = 0 - mem_wan1 = 0 - mem_bw = 0 - - ! First the data stored in the parameters module - mem_param = mem_param + num_wann*num_wann*num_kpts*size_cmplx !u_matrix - if (.not. disentanglement) & - mem_param = mem_param + num_wann*num_wann*nntot*num_kpts*size_cmplx !m_matrix - - if (disentanglement) then - mem_param = mem_param + num_bands*num_wann*num_kpts*size_cmplx ! u_matrix_opt - endif - - if (allocated(atoms_species_num)) then - mem_param = mem_param + (num_species)*size_int !atoms_species_num - mem_param = mem_param + (num_species)*size_real !atoms_label - mem_param = mem_param + (num_species)*size_real !atoms_symbol - mem_param = mem_param + (3*maxval(atoms_species_num)*num_species)*size_real !atoms_pos_frac - mem_param = mem_param + (3*maxval(atoms_species_num)*num_species)*size_real !atoms_pos_cart - endif - - if (allocated(input_proj_site)) then - mem_param = mem_param + (3*num_proj)*size_real !input_proj_site - mem_param = mem_param + (num_proj)*size_int !input_proj_l - mem_param = mem_param + (num_proj)*size_int !input_proj_m - mem_param = mem_param + (3*num_proj)*size_real !input_proj_z - mem_param = mem_param + (3*num_proj)*size_real !input_proj_x - mem_param = mem_param + (num_proj)*size_real !input_proj_radial - mem_param = mem_param + (num_proj)*size_real !input_proj_zona - endif - - if (allocated(proj_site)) then - mem_param = mem_param + (3*num_wann)*size_real !proj_site - mem_param = mem_param + (num_wann)*size_int !proj_l - mem_param = mem_param + (num_wann)*size_int !proj_m - mem_param = mem_param + (3*num_wann)*size_real !proj_z - mem_param = mem_param + (3*num_wann)*size_real !proj_x - mem_param = mem_param + (num_wann)*size_real !proj_radial - mem_param = mem_param + (num_wann)*size_real !proj_zona - endif - - mem_param = mem_param + num_kpts*nntot*size_int !nnlist - mem_param = mem_param + num_kpts*nntot/2*size_int !neigh - mem_param = mem_param + 3*num_kpts*nntot*size_int !nncell - mem_param = mem_param + nntot*size_real !wb - mem_param = mem_param + 3*nntot/2*size_real !bka - mem_param = mem_param + 3*nntot*num_kpts*size_real !bk - - mem_param = mem_param + num_bands*num_kpts*size_real !eigval - mem_param = mem_param + 3*num_kpts*size_real !kpt_cart - mem_param = mem_param + 3*num_kpts*size_real !kpt_latt - if (disentanglement) then - mem_param = mem_param + num_kpts*size_int !ndimwin - mem_param = mem_param + num_bands*num_kpts*size_log !lwindow - endif - mem_param = mem_param + 3*num_wann*size_real !wannier_centres - mem_param = mem_param + num_wann*size_real !wannier_spreads - - if (disentanglement) then - ! Module vars - mem_dis = mem_dis + num_bands*num_kpts*size_real !eigval_opt - mem_dis = mem_dis + num_kpts*size_int !nfirstwin - mem_dis = mem_dis + num_kpts*size_int !ndimfroz - mem_dis = mem_dis + num_bands*num_kpts*size_int !indxfroz - mem_dis = mem_dis + num_bands*num_kpts*size_int !indxnfroz - mem_dis = mem_dis + num_bands*num_kpts*size_log !lfrozen - - !the memory high-water wiil occur in dis_extract or when we allocate m_matrix - - mem_dis1 = mem_dis1 + num_wann*num_bands*size_cmplx !cwb - mem_dis1 = mem_dis1 + num_wann*num_wann*size_cmplx !cww - mem_dis1 = mem_dis1 + num_bands*num_wann*size_cmplx !cbw - mem_dis1 = mem_dis1 + 5*num_bands*size_int !iwork - mem_dis1 = mem_dis1 + num_bands*size_int !ifail - mem_dis1 = mem_dis1 + num_bands*size_real !w - if (gamma_only) then - mem_dis1 = mem_dis1 + (num_bands*(num_bands + 1))/2*size_real !cap_r - mem_dis1 = mem_dis1 + 8*num_bands*size_real !work - mem_dis1 = mem_dis1 + num_bands*num_bands*size_real !rz - else - mem_dis1 = mem_dis1 + 7*num_bands*size_real !rwork - mem_dis1 = mem_dis1 + (num_bands*(num_bands + 1))/2*size_cmplx !cap - mem_dis1 = mem_dis1 + 2*num_bands*size_cmplx !cwork - mem_dis1 = mem_dis1 + num_bands*num_bands*size_cmplx !cz - end if - mem_dis1 = mem_dis1 + num_kpts*size_real !wkomegai1 - mem_dis1 = mem_dis1 + num_bands*num_bands*num_kpts*size_cmplx !ceamp - mem_dis1 = mem_dis1 + num_bands*num_bands*num_kpts*size_cmplx !cham - mem_dis2 = mem_dis2 + num_wann*num_wann*nntot*num_kpts*size_cmplx!m_matrix - - if (optimisation <= 0) then - mem_dis = mem_dis + mem_dis1 - else - mem_dis = mem_dis + max(mem_dis1, mem_dis2) - endif - - mem_dis = mem_dis + num_bands*num_bands*nntot*num_kpts*size_cmplx ! m_matrix_orig - mem_dis = mem_dis + num_bands*num_wann*num_kpts*size_cmplx ! a_matrix - - endif - - !Wannierise - - mem_wan1 = mem_wan1 + (num_wann*num_wann*nntot*num_kpts)*size_cmplx ! 'm0' - if (optimisation > 0) then - mem_wan = mem_wan + mem_wan1 - endif - mem_wan = mem_wan + (num_wann*num_wann*num_kpts)*size_cmplx ! 'u0' - mem_wan = mem_wan + (num_wann*nntot*num_kpts)*size_real ! 'rnkb' - mem_wan = mem_wan + (num_wann*nntot*num_kpts)*size_real ! 'ln_tmp' - mem_wan = mem_wan + (num_wann*nntot*num_kpts)*size_cmplx ! 'csheet' - mem_wan = mem_wan + (num_wann*nntot*num_kpts)*size_real ! 'sheet' - mem_wan = mem_wan + (3*num_wann)*size_real ! 'rave' - mem_wan = mem_wan + (num_wann)*size_real ! 'r2ave' - mem_wan = mem_wan + (num_wann)*size_real ! 'rave2' - mem_wan = mem_wan + (3*num_wann)*size_real ! 'rguide' - mem_wan = mem_wan + (num_wann*num_wann)*size_cmplx ! 'cz' - if (gamma_only) then - mem_wan = mem_wan + num_wann*num_wann*nntot*2*size_cmplx ! m_w - mem_wan = mem_wan + num_wann*num_wann*size_cmplx ! uc_rot - mem_wan = mem_wan + num_wann*num_wann*size_real ! ur_rot - !internal_svd_omega_i - mem_wan = mem_wan + 10*num_wann*size_cmplx ! cw1 - mem_wan = mem_wan + 10*num_wann*size_cmplx ! cw2 - mem_wan = mem_wan + num_wann*num_wann*size_cmplx ! cv1 - mem_wan = mem_wan + num_wann*num_wann*size_cmplx ! cv2 - mem_wan = mem_wan + num_wann*num_wann*size_real ! cpad1 - mem_wan = mem_wan + num_wann*size_cmplx ! singvd - else - mem_wan = mem_wan + (num_wann)*size_cmplx ! 'cwschur1' - mem_wan = mem_wan + (10*num_wann)*size_cmplx ! 'cwschur2' - mem_wan = mem_wan + (num_wann)*size_cmplx ! 'cwschur3' - mem_wan = mem_wan + (num_wann)*size_cmplx ! 'cwschur4' - mem_wan = mem_wan + (num_wann*num_wann*num_kpts)*size_cmplx ! 'cdq' - mem_wan = mem_wan + (num_wann*num_wann)*size_cmplx ! 'cmtmp' - mem_wan = mem_wan + (num_wann*num_wann*num_kpts)*size_cmplx ! 'cdqkeep' - mem_wan = mem_wan + (num_wann*num_wann)*size_cmplx ! 'tmp_cdq' - mem_wan = mem_wan + (num_wann)*size_real ! 'evals' - mem_wan = mem_wan + (4*num_wann)*size_cmplx ! 'cwork' - mem_wan = mem_wan + (3*num_wann - 2)*size_real ! 'rwork' - !d_omega - mem_wan = mem_wan + (num_wann*num_wann)*size_cmplx ! 'cr' - mem_wan = mem_wan + (num_wann*num_wann)*size_cmplx ! 'crt' - end if - - if (ispostw90) then - if (boltzwann) then - if (spin_decomp) then - ndim = 3 - else - ndim = 1 - end if - - ! I set a big value to have a rough estimate - TDF_exceeding_energy = 2._dp - NumPoints1 = int(floor((boltz_temp_max - boltz_temp_min)/boltz_temp_step)) + 1 ! temperature array - NumPoints2 = int(floor((boltz_mu_max - boltz_mu_min)/boltz_mu_step)) + 1 ! mu array - NumPoints3 = int(floor((dis_win_max - dis_win_min + 2._dp*TDF_exceeding_energy)/boltz_tdf_energy_step)) + 1 ! tdfenergyarray - mem_bw = mem_bw + NumPoints1*size_real !TempArray - mem_bw = mem_bw + NumPoints1*size_real !KTArray - mem_bw = mem_bw + NumPoints2*size_real !MuArray - mem_bw = mem_bw + NumPoints3*size_real !TDFEnergyArray - mem_bw = mem_bw + 6*NumPoints3*ndim*size_real !TDFArray - mem_bw = mem_bw + 6*NumPoints3*size_real !IntegrandArray - mem_bw = mem_bw + (9*4 + 6)*size_real - !ElCondTimesSeebeckFP,ThisElCond,ElCondInverse,ThisSeebeck,ElCondTimesSeebeck - mem_bw = mem_bw + 6*NumPoints1*NumPoints2*size_real !ElCond - mem_bw = mem_bw + 6*NumPoints1*NumPoints2*size_real !Seebeck - mem_bw = mem_bw + 6*NumPoints1*NumPoints2*size_real !ThermCond - ! I put a upper bound here below (as if there was only 1 node), because I do not have any knowledge at this point - ! of the number of processors, so I cannot have a correct estimate - mem_bw = mem_bw + 6*NumPoints1*NumPoints2*size_real !LocalElCond - mem_bw = mem_bw + 6*NumPoints1*NumPoints2*size_real !LocalSeebeck - mem_bw = mem_bw + 6*NumPoints1*NumPoints2*size_real !LocalThermCond - - mem_bw = mem_bw + num_wann*num_wann*size_cmplx !HH - mem_bw = mem_bw + 3*num_wann*num_wann*size_cmplx !delHH - mem_bw = mem_bw + num_wann*num_wann*size_cmplx !UU - mem_bw = mem_bw + 3*num_wann*size_real !del_eig - mem_bw = mem_bw + num_wann*size_real !eig - mem_bw = mem_bw + num_wann*size_real !levelspacing_k - - NumPoints1 = int(floor((boltz_dos_energy_max - boltz_dos_energy_min)/boltz_dos_energy_step)) + 1!dosnumpoints - mem_bw = mem_bw + NumPoints1*size_real !DOS_EnergyArray - mem_bw = mem_bw + 6*ndim*NumPoints3*size_real !TDF_k - mem_bw = mem_bw + ndim*NumPoints1*size_real !DOS_k - mem_bw = mem_bw + ndim*NumPoints1*size_real !DOS_all - end if - end if - - if (disentanglement) & - mem_wan = mem_wan + num_wann*num_wann*nntot*num_kpts*size_cmplx !m_matrix - - if (on_root) then - write (stdout, '(1x,a)') '*============================================================================*' - write (stdout, '(1x,a)') '| MEMORY ESTIMATE |' - write (stdout, '(1x,a)') '| Maximum RAM allocated during each phase of the calculation |' - write (stdout, '(1x,a)') '*============================================================================*' - if (disentanglement) & - write (stdout, '(1x,"|",24x,a15,f16.2,a,18x,"|")') 'Disentanglement:', (mem_param + mem_dis)/(1024**2), ' Mb' - write (stdout, '(1x,"|",24x,a15,f16.2,a,18x,"|")') 'Wannierise:', (mem_param + mem_wan)/(1024**2), ' Mb' - if (optimisation > 0 .and. iprint > 1) then - write (stdout, '(1x,a)') '| |' - write (stdout, '(1x,a)') '| N.B. by setting optimisation=0 memory usage will be reduced to: |' - if (disentanglement) & - write (stdout, '(1x,"|",24x,a15,f16.2,a,18x,"|")') 'Disentanglement:', & - (mem_param + mem_dis - max(mem_dis1, mem_dis2) + mem_dis1)/(1024**2), ' Mb' - if (gamma_only) then - write (stdout, '(1x,"|",24x,a15,f16.2,a,18x,"|")') 'Wannierise:', (mem_param + mem_wan)/(1024**2), ' Mb' - else - write (stdout, '(1x,"|",24x,a15,f16.2,a,18x,"|")') 'Wannierise:', & - (mem_param + mem_wan - mem_wan1)/(1024**2), ' Mb' - end if - write (stdout, '(1x,a)') '| However, this will result in more i/o and slow down the calculation |' - endif - - if (ispostw90) then - if (boltzwann) & - write (stdout, '(1x,"|",24x,a15,f16.2,a,18x,"|")') 'BoltzWann:', (mem_param + mem_bw)/(1024**2), ' Mb' - end if - - write (stdout, '(1x,"|",24x,a15,f16.2,a,18x,"|")') 'plot_wannier:', (mem_param + mem_wan)/(1024**2), ' Mb' - write (stdout, '(1x,a)') '*----------------------------------------------------------------------------*' - write (stdout, *) ' ' - endif - -! if(disentanglement) then -! write(*,'(a12,f12.4,a)') 'Disentangle',(mem_param+mem_dis)/(1024**2),' Mb' -! end if -! write(*,'(a12,f12.4,a)') 'Wannierise ',(mem_wan+mem_param)/(1024**2),' Mb' -! write(*,'(a12,f12.4,a)') 'Module',(mem_param)/(1024**2),' Mb' - - return - end subroutine param_memory_estimate - -!===========================================================! - subroutine param_dist - !===========================================================! - ! ! - !! distribute the parameters across processors ! - ! ! - !===========================================================! - - use w90_constants, only: dp, cmplx_0, cmplx_i, twopi - use w90_io, only: io_error, io_file_unit, io_date, io_time, & - io_stopwatch - use w90_comms, only: comms_bcast, on_root - - integer :: ierr - - call comms_bcast(effective_model, 1) - call comms_bcast(eig_found, 1) - call comms_bcast(postproc_setup, 1) - if (.not. effective_model) then - call comms_bcast(mp_grid(1), 3) - call comms_bcast(num_kpts, 1) - call comms_bcast(num_bands, 1) - endif - call comms_bcast(num_wann, 1) - call comms_bcast(timing_level, 1) - call comms_bcast(iprint, 1) - call comms_bcast(energy_unit, 1) - call comms_bcast(length_unit, 1) - call comms_bcast(wvfn_formatted, 1) - call comms_bcast(spn_formatted, 1) - call comms_bcast(uHu_formatted, 1) - call comms_bcast(berry_uHu_formatted, 1) - call comms_bcast(spin, 1) - call comms_bcast(num_dump_cycles, 1) - call comms_bcast(num_print_cycles, 1) - call comms_bcast(num_atoms, 1) ! Ivo: not used in postw90, right? - call comms_bcast(num_species, 1) ! Ivo: not used in postw90, right? - call comms_bcast(real_lattice(1, 1), 9) - call comms_bcast(recip_lattice(1, 1), 9) - call comms_bcast(real_metric(1, 1), 9) - call comms_bcast(recip_metric(1, 1), 9) - call comms_bcast(cell_volume, 1) - call comms_bcast(dos_energy_step, 1) - call comms_bcast(dos_adpt_smr, 1) - call comms_bcast(dos_smr_index, 1) - call comms_bcast(dos_kmesh_spacing, 1) - call comms_bcast(dos_kmesh(1), 3) - call comms_bcast(dos_adpt_smr_max, 1) - call comms_bcast(dos_smr_fixed_en_width, 1) - call comms_bcast(dos_adpt_smr_fac, 1) - call comms_bcast(num_dos_project, 1) - call comms_bcast(num_exclude_bands, 1) - if (num_exclude_bands > 0) then - if (.not. on_root) then - allocate (exclude_bands(num_exclude_bands), stat=ierr) - if (ierr /= 0) & - call io_error('Error in allocating exclude_bands in param_dist') - endif - call comms_bcast(exclude_bands(1), num_exclude_bands) - end if - - call comms_bcast(gamma_only, 1) - call comms_bcast(dis_win_min, 1) - call comms_bcast(dis_win_max, 1) - call comms_bcast(dis_froz_min, 1) - call comms_bcast(dis_froz_max, 1) - call comms_bcast(dis_num_iter, 1) - call comms_bcast(dis_mix_ratio, 1) - call comms_bcast(dis_conv_tol, 1) - call comms_bcast(dis_conv_window, 1) - call comms_bcast(dis_spheres_first_wann, 1) - call comms_bcast(dis_spheres_num, 1) - if (dis_spheres_num > 0) then - if (.not. on_root) then - allocate (dis_spheres(4, dis_spheres_num), stat=ierr) - if (ierr /= 0) & - call io_error('Error in allocating dis_spheres in param_dist') - endif - call comms_bcast(dis_spheres(1, 1), 4*dis_spheres_num) - end if - call comms_bcast(num_iter, 1) - call comms_bcast(num_cg_steps, 1) - call comms_bcast(conv_tol, 1) - call comms_bcast(conv_window, 1) - call comms_bcast(guiding_centres, 1) - call comms_bcast(wannier_plot, 1) - call comms_bcast(num_wannier_plot, 1) - if (num_wannier_plot > 0) then - if (.not. on_root) then - allocate (wannier_plot_list(num_wannier_plot), stat=ierr) - if (ierr /= 0) & - call io_error('Error in allocating wannier_plot_list in param_dist') - endif - call comms_bcast(wannier_plot_list(1), num_wannier_plot) - end if - call comms_bcast(wannier_plot_supercell(1), 3) - call comms_bcast(wannier_plot_format, len(wannier_plot_format)) - call comms_bcast(wannier_plot_mode, len(wannier_plot_mode)) - call comms_bcast(wannier_plot_spinor_mode, len(wannier_plot_spinor_mode)) - call comms_bcast(write_u_matrices, 1) - call comms_bcast(bands_plot, 1) - call comms_bcast(write_bvec, 1) - call comms_bcast(bands_num_points, 1) - call comms_bcast(bands_plot_format, len(bands_plot_format)) - call comms_bcast(bands_plot_mode, len(bands_plot_mode)) - call comms_bcast(num_bands_project, 1) - - if (num_bands_project > 0) then - if (.not. on_root) then - allocate (bands_plot_project(num_bands_project), stat=ierr) - if (ierr /= 0) & - call io_error('Error in allocating bands_plot_project in param_dist') - endif - call comms_bcast(bands_plot_project(1), num_bands_project) - end if - call comms_bcast(bands_plot_dim, 1) - call comms_bcast(write_hr, 1) - call comms_bcast(write_rmn, 1) - call comms_bcast(write_tb, 1) - call comms_bcast(hr_cutoff, 1) - call comms_bcast(dist_cutoff, 1) - call comms_bcast(dist_cutoff_mode, len(dist_cutoff_mode)) - call comms_bcast(dist_cutoff_hc, 1) - call comms_bcast(one_dim_axis, len(one_dim_axis)) - call comms_bcast(use_ws_distance, 1) - call comms_bcast(ws_distance_tol, 1) - call comms_bcast(ws_search_size(1), 3) - call comms_bcast(fermi_surface_plot, 1) - call comms_bcast(fermi_surface_num_points, 1) - call comms_bcast(fermi_surface_plot_format, len(fermi_surface_plot_format)) - call comms_bcast(fermi_energy, 1) !! used? - - call comms_bcast(berry, 1) - call comms_bcast(berry_task, len(berry_task)) - call comms_bcast(berry_kmesh_spacing, 1) - call comms_bcast(berry_kmesh(1), 3) - call comms_bcast(berry_curv_adpt_kmesh, 1) - call comms_bcast(berry_curv_adpt_kmesh_thresh, 1) - call comms_bcast(berry_curv_unit, len(berry_curv_unit)) -! Stepan Tsirkin - call comms_bcast(gyrotropic, 1) - call comms_bcast(gyrotropic_task, len(gyrotropic_task)) - call comms_bcast(gyrotropic_kmesh_spacing, 1) - call comms_bcast(gyrotropic_kmesh(1), 3) - call comms_bcast(gyrotropic_smr_fixed_en_width, 1) - call comms_bcast(gyrotropic_smr_index, 1) - call comms_bcast(gyrotropic_eigval_max, 1) - call comms_bcast(gyrotropic_nfreq, 1) - call comms_bcast(gyrotropic_degen_thresh, 1) - call comms_bcast(gyrotropic_num_bands, 1) - call comms_bcast(gyrotropic_box(1, 1), 9) - call comms_bcast(gyrotropic_box_corner(1), 3) - call comms_bcast(gyrotropic_smr_max_arg, 1) - call comms_bcast(gyrotropic_smr_fixed_en_width, 1) - call comms_bcast(gyrotropic_smr_index, 1) - - call comms_bcast(kubo_adpt_smr, 1) - call comms_bcast(kubo_adpt_smr_fac, 1) - call comms_bcast(kubo_adpt_smr_max, 1) - call comms_bcast(kubo_smr_fixed_en_width, 1) - call comms_bcast(kubo_smr_index, 1) - call comms_bcast(kubo_eigval_max, 1) - call comms_bcast(kubo_nfreq, 1) - call comms_bcast(nfermi, 1) - call comms_bcast(dos_energy_min, 1) - call comms_bcast(dos_energy_max, 1) - call comms_bcast(spin_kmesh_spacing, 1) - call comms_bcast(spin_kmesh(1), 3) - call comms_bcast(wanint_kpoint_file, 1) -! Junfeng Qiao - call comms_bcast(shc_freq_scan, 1) - call comms_bcast(shc_alpha, 1) - call comms_bcast(shc_beta, 1) - call comms_bcast(shc_gamma, 1) - call comms_bcast(shc_bandshift, 1) - call comms_bcast(shc_bandshift_firstband, 1) - call comms_bcast(shc_bandshift_energyshift, 1) - call comms_bcast(shc_method, len(shc_method)) - - call comms_bcast(devel_flag, len(devel_flag)) - call comms_bcast(spin_moment, 1) - call comms_bcast(spin_axis_polar, 1) - call comms_bcast(spin_axis_azimuth, 1) - call comms_bcast(spin_decomp, 1) - call comms_bcast(use_degen_pert, 1) - call comms_bcast(degen_thr, 1) - call comms_bcast(num_valence_bands, 1) - call comms_bcast(dos, 1) - call comms_bcast(dos_task, len(dos_task)) - call comms_bcast(kpath, 1) - call comms_bcast(kpath_task, len(kpath_task)) - call comms_bcast(kpath_bands_colour, len(kpath_bands_colour)) - call comms_bcast(kslice, 1) - call comms_bcast(kslice_task, len(kslice_task)) - call comms_bcast(transl_inv, 1) - call comms_bcast(num_elec_per_state, 1) - call comms_bcast(scissors_shift, 1) - ! - -! ---------------------------------------------- - call comms_bcast(geninterp, 1) - call comms_bcast(geninterp_alsofirstder, 1) - call comms_bcast(geninterp_single_file, 1) - ! [gp-begin, Apr 12, 2012] - ! BoltzWann variables - call comms_bcast(boltzwann, 1) - call comms_bcast(boltz_calc_also_dos, 1) - call comms_bcast(boltz_2d_dir_num, 1) - call comms_bcast(boltz_dos_energy_step, 1) - call comms_bcast(boltz_dos_energy_min, 1) - call comms_bcast(boltz_dos_energy_max, 1) - call comms_bcast(boltz_dos_adpt_smr, 1) - call comms_bcast(boltz_dos_smr_fixed_en_width, 1) - call comms_bcast(boltz_dos_adpt_smr_fac, 1) - call comms_bcast(boltz_dos_adpt_smr_max, 1) - call comms_bcast(boltz_mu_min, 1) - call comms_bcast(boltz_mu_max, 1) - call comms_bcast(boltz_mu_step, 1) - call comms_bcast(boltz_temp_min, 1) - call comms_bcast(boltz_temp_max, 1) - call comms_bcast(boltz_temp_step, 1) - call comms_bcast(boltz_kmesh_spacing, 1) - call comms_bcast(boltz_kmesh(1), 3) - call comms_bcast(boltz_tdf_energy_step, 1) - call comms_bcast(boltz_relax_time, 1) - call comms_bcast(boltz_TDF_smr_fixed_en_width, 1) - call comms_bcast(boltz_TDF_smr_index, 1) - call comms_bcast(boltz_dos_smr_index, 1) - call comms_bcast(boltz_bandshift, 1) - call comms_bcast(boltz_bandshift_firstband, 1) - call comms_bcast(boltz_bandshift_energyshift, 1) - ! [gp-end] - call comms_bcast(use_ws_distance, 1) - call comms_bcast(disentanglement, 1) - - call comms_bcast(transport, 1) - call comms_bcast(tran_easy_fix, 1) - call comms_bcast(transport_mode, len(transport_mode)) - call comms_bcast(tran_win_min, 1) - call comms_bcast(tran_win_max, 1) - call comms_bcast(tran_energy_step, 1) - call comms_bcast(tran_num_bb, 1) - call comms_bcast(tran_num_ll, 1) - call comms_bcast(tran_num_rr, 1) - call comms_bcast(tran_num_cc, 1) - call comms_bcast(tran_num_lc, 1) - call comms_bcast(tran_num_cr, 1) - call comms_bcast(tran_num_bandc, 1) - call comms_bcast(tran_write_ht, 1) - call comms_bcast(tran_read_ht, 1) - call comms_bcast(tran_use_same_lead, 1) - call comms_bcast(tran_num_cell_ll, 1) - call comms_bcast(tran_num_cell_rr, 1) - call comms_bcast(tran_group_threshold, 1) - call comms_bcast(translation_centre_frac(1), 3) - call comms_bcast(num_shells, 1) - call comms_bcast(skip_B1_tests, 1) - call comms_bcast(explicit_nnkpts, 1) - - call comms_bcast(calc_only_A, 1) - call comms_bcast(use_bloch_phases, 1) - call comms_bcast(restart, len(restart)) - call comms_bcast(write_r2mn, 1) - call comms_bcast(num_guide_cycles, 1) - call comms_bcast(num_no_guide_iter, 1) - call comms_bcast(fixed_step, 1) - call comms_bcast(trial_step, 1) - call comms_bcast(precond, 1) - call comms_bcast(write_proj, 1) - call comms_bcast(timing_level, 1) - call comms_bcast(spinors, 1) - call comms_bcast(num_elec_per_state, 1) - call comms_bcast(translate_home_cell, 1) - call comms_bcast(write_xyz, 1) - call comms_bcast(write_hr_diag, 1) - call comms_bcast(conv_noise_amp, 1) - call comms_bcast(conv_noise_num, 1) - call comms_bcast(wannier_plot_radius, 1) - call comms_bcast(wannier_plot_scale, 1) - call comms_bcast(kmesh_tol, 1) - call comms_bcast(optimisation, 1) - call comms_bcast(write_vdw_data, 1) - call comms_bcast(lenconfac, 1) - call comms_bcast(lfixstep, 1) - call comms_bcast(lsitesymmetry, 1) - call comms_bcast(frozen_states, 1) - call comms_bcast(symmetrize_eps, 1) - - !vv: Constrained centres - call comms_bcast(slwf_num, 1) - call comms_bcast(slwf_constrain, 1) - call comms_bcast(slwf_lambda, 1) - call comms_bcast(selective_loc, 1) - if (selective_loc .and. slwf_constrain) then - if (.not. on_root) then - allocate (ccentres_frac(num_wann, 3), stat=ierr) - if (ierr /= 0) call io_error('Error allocating ccentres_frac in param_get_centre_constraints') - allocate (ccentres_cart(num_wann, 3), stat=ierr) - if (ierr /= 0) call io_error('Error allocating ccentres_cart in param_get_centre_constraints') - endif - call comms_bcast(ccentres_frac(1, 1), 3*num_wann) - call comms_bcast(ccentres_cart(1, 1), 3*num_wann) - end if - - ! vv: automatic projections - call comms_bcast(auto_projections, 1) - - call comms_bcast(num_proj, 1) - call comms_bcast(lhasproj, 1) - if (lhasproj) then - if (.not. on_root) then - allocate (input_proj_site(3, num_proj), stat=ierr) - if (ierr /= 0) call io_error('Error allocating input_proj_site in param_dist') - allocate (proj_site(3, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating proj_site in param_dist') - endif - call comms_bcast(input_proj_site(1, 1), 3*num_proj) - call comms_bcast(proj_site(1, 1), 3*num_wann) - endif - - ! These variables are different from the ones above in that they are - ! allocatable, and in param_read they were allocated on the root node only - ! - if (.not. on_root) then - allocate (fermi_energy_list(nfermi), stat=ierr) - if (ierr /= 0) call io_error( & - 'Error allocating fermi_energy_read in postw90_param_dist') - allocate (kubo_freq_list(kubo_nfreq), stat=ierr) - if (ierr /= 0) call io_error( & - 'Error allocating kubo_freq_list in postw90_param_dist') - allocate (dos_project(num_dos_project), stat=ierr) - if (ierr /= 0) & - call io_error('Error allocating dos_project in postw90_param_dist') - if (.not. effective_model) then - if (eig_found) then - allocate (eigval(num_bands, num_kpts), stat=ierr) - if (ierr /= 0) & - call io_error('Error allocating eigval in postw90_param_dist') - end if - allocate (kpt_latt(3, num_kpts), stat=ierr) - if (ierr /= 0) & - call io_error('Error allocating kpt_latt in postw90_param_dist') - endif - allocate (gyrotropic_band_list(gyrotropic_num_bands), stat=ierr) - if (ierr /= 0) call io_error( & - 'Error allocating gyrotropic_num_bands in postw90_param_dist') - allocate (gyrotropic_freq_list(gyrotropic_nfreq), stat=ierr) - if (ierr /= 0) call io_error( & - 'Error allocating gyrotropic_freq_list in postw90_param_dist') - end if - - if (nfermi > 0) call comms_bcast(fermi_energy_list(1), nfermi) - if (kubo_nfreq > 0) call comms_bcast(kubo_freq_list(1), kubo_nfreq) - if (gyrotropic_nfreq > 0) & - call comms_bcast(gyrotropic_freq_list(1), gyrotropic_nfreq) - if (gyrotropic_num_bands > 0) & - call comms_bcast(gyrotropic_band_list(1), gyrotropic_num_bands) - if (num_dos_project > 0) call comms_bcast(dos_project(1), num_dos_project) - if (.not. effective_model) then - if (eig_found) then - call comms_bcast(eigval(1, 1), num_bands*num_kpts) - end if - call comms_bcast(kpt_latt(1, 1), 3*num_kpts) - endif - - if (.not. effective_model .and. .not. explicit_nnkpts) then - - call comms_bcast(nnh, 1) - call comms_bcast(nntot, 1) - call comms_bcast(wbtot, 1) - - if (.not. on_root) then - allocate (nnlist(num_kpts, nntot), stat=ierr) - if (ierr /= 0) & - call io_error('Error in allocating nnlist in param_dist') - allocate (neigh(num_kpts, nntot/2), stat=ierr) - if (ierr /= 0) & - call io_error('Error in allocating neigh in param_dist') - allocate (nncell(3, num_kpts, nntot), stat=ierr) - if (ierr /= 0) & - call io_error('Error in allocating nncell in param_dist') - allocate (wb(nntot), stat=ierr) - if (ierr /= 0) & - call io_error('Error in allocating wb in param_dist') - allocate (bka(3, nntot/2), stat=ierr) - if (ierr /= 0) & - call io_error('Error in allocating bka in param_dist') - allocate (bk(3, nntot, num_kpts), stat=ierr) - if (ierr /= 0) & - call io_error('Error in allocating bk in param_dist') - end if - - call comms_bcast(nnlist(1, 1), num_kpts*nntot) - call comms_bcast(neigh(1, 1), num_kpts*nntot/2) - call comms_bcast(nncell(1, 1, 1), 3*num_kpts*nntot) - call comms_bcast(wb(1), nntot) - call comms_bcast(bka(1, 1), 3*nntot/2) - call comms_bcast(bk(1, 1, 1), 3*nntot*num_kpts) - - endif - - call comms_bcast(omega_total, 1) - call comms_bcast(omega_tilde, 1) - call comms_bcast(omega_invariant, 1) - call comms_bcast(have_disentangled, 1) - - if (.not. on_root) then - allocate (wannier_centres(3, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating wannier_centres in param_dist') - wannier_centres = 0.0_dp - allocate (wannier_spreads(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating wannier_spreads in param_dist') - wannier_spreads = 0.0_dp - if (disentanglement) then - allocate (ndimwin(num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating ndimwin in param_dist') - allocate (lwindow(num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating lwindow in param_dist') - endif - endif - - end subroutine param_dist - - subroutine parameters_gyro_write_task(task, key, comment) - use w90_io, only: stdout - - character(len=*), intent(in) :: task, key, comment - character(len=42) :: comment1 - - comment1 = comment - if ((index(task, key) > 0) .or. (index(task, 'all') > 0)) then - write (stdout, '(1x,a2,a42,a2,10x,a8,13x,a1)') '| ', comment1, ' :', ' T', '|' - else - write (stdout, '(1x,a2,a42,a2,10x,a8,13x,a1)') '| ', comment1, ' :', ' F', '|' - endif - end subroutine parameters_gyro_write_task - -end module w90_parameters diff --git a/src/plot.F90 b/src/plot.F90 index 70a5b3f2c..696dc7e77 100644 --- a/src/plot.F90 +++ b/src/plot.F90 @@ -11,56 +11,132 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! w90_plot: plot various data ! +! ! +!------------------------------------------------------------! module w90_plot + !! This module handles various plots - use w90_comms, only: on_root, my_node_id, num_nodes, & - comms_reduce, comms_array_split + use w90_comms, only: comms_array_split, comms_reduce, w90comm_type, mpisize, mpirank implicit none private + public :: plot_main contains - !============================================! - subroutine plot_main() + !================================================! + + subroutine plot_main(atom_data, band_plot, dis_manifold, fermi_energy_list, fermi_surface_plot, & + ham_logical, kmesh_info, kpt_latt, output_file, wvfn_read, real_space_ham, & + kpoint_path, print_output, wannier_data, wannier_plot, ws_region, & + w90_calculation, ham_k, ham_r, m_matrix, u_matrix, u_matrix_opt, eigval, & + real_lattice, wannier_centres_translated, bohr, irvec, mp_grid, ndegen, & + shift_vec, nrpts, num_bands, num_kpts, num_wann, rpt_origin, & + transport_mode, have_disentangled, lsitesymmetry, spinors, seedname, & + stdout, comm) + !================================================! + ! !! Main plotting routine - !============================================! - - use w90_constants, only: eps6 - use w90_io, only: stdout, io_stopwatch - use w90_parameters, only: num_kpts, bands_plot, dos_plot, & - kpt_latt, fermi_surface_plot, & - wannier_plot, timing_level, write_bvec, & - write_hr, write_rmn, write_tb, write_u_matrices - use w90_hamiltonian, only: hamiltonian_get_hr, hamiltonian_write_hr, & - hamiltonian_setup, hamiltonian_write_rmn, & - hamiltonian_write_tb, nrpts, irvec - use w90_ws_distance, only: done_ws_distance, ws_translate_dist, & - ws_write_vec + ! + !================================================! + + use w90_constants, only: eps6, dp + use w90_hamiltonian, only: hamiltonian_get_hr, hamiltonian_write_hr, hamiltonian_setup, & + hamiltonian_write_rmn, hamiltonian_write_tb + use w90_io, only: io_stopwatch + use w90_types, only: kmesh_info_type, wannier_data_type, atom_data_type, dis_manifold_type, & + kpoint_path_type, print_output_type, ws_region_type, ws_distance_type + use w90_utility, only: utility_recip_lattice_base + use w90_wannier90_types, only: w90_calculation_type, wvfn_read_type, output_file_type, & + fermi_surface_plot_type, band_plot_type, wannier_plot_type, real_space_ham_type, & + ham_logical_type + use w90_ws_distance, only: ws_translate_dist, ws_write_vec implicit none - integer :: nkp + ! arguments + type(atom_data_type), intent(in) :: atom_data + type(band_plot_type), intent(in) :: band_plot + type(dis_manifold_type), intent(in) :: dis_manifold + type(fermi_surface_plot_type), intent(in) :: fermi_surface_plot + type(ham_logical_type), intent(inout) :: ham_logical + type(kmesh_info_type), intent(in) :: kmesh_info + type(kpoint_path_type), intent(in) :: kpoint_path + type(output_file_type), intent(in) :: output_file + type(print_output_type), intent(in) :: print_output + type(real_space_ham_type), intent(inout) :: real_space_ham + type(w90_calculation_type), intent(in) :: w90_calculation + type(w90comm_type), intent(in) :: comm + type(wannier_data_type), intent(in) :: wannier_data + type(wannier_plot_type), intent(in) :: wannier_plot + type(ws_region_type), intent(in) :: ws_region + type(wvfn_read_type), intent(in) :: wvfn_read + + complex(kind=dp), intent(in) :: m_matrix(:, :, :, :) + complex(kind=dp), intent(in) :: u_matrix_opt(:, :, :) + complex(kind=dp), intent(in) :: u_matrix(:, :, :) + complex(kind=dp), intent(inout), allocatable :: ham_r(:, :, :) + complex(kind=dp), intent(inout), allocatable :: ham_k(:, :, :) + + real(kind=dp), intent(in), allocatable :: fermi_energy_list(:) + real(kind=dp), intent(in) :: bohr + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: kpt_latt(:, :) + real(kind=dp), intent(inout), allocatable :: wannier_centres_translated(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_bands + integer, intent(in) :: num_kpts + integer, intent(in) :: num_wann + integer, intent(inout), allocatable :: irvec(:, :) + integer, intent(inout), allocatable :: ndegen(:) + integer, intent(inout), allocatable :: shift_vec(:, :) + integer, intent(inout) :: nrpts + integer, intent(inout) :: rpt_origin + integer, intent(in) :: stdout + + character(len=20), intent(in) :: transport_mode + character(len=50), intent(in) :: seedname + + logical, intent(in) :: have_disentangled + logical, intent(in) :: lsitesymmetry + logical, intent(in) :: spinors + + ! local variables + type(ws_distance_type) :: ws_distance + real(kind=dp) :: recip_lattice(3, 3), volume + integer :: nkp, bands_num_spec_points, my_node_id, num_nodes logical :: have_gamma + logical :: on_root = .false. + + num_nodes = mpisize(comm) + my_node_id = mpirank(comm) + + if (my_node_id == 0) on_root = .true. if (on_root) then - if (timing_level > 0) call io_stopwatch('plot: main', 1) + if (print_output%timing_level > 0) call io_stopwatch('plot: main', 1, stdout, seedname) + call utility_recip_lattice_base(real_lattice, recip_lattice, volume) ! Print the header only if there is something to plot - if (bands_plot .or. dos_plot .or. fermi_surface_plot .or. write_hr .or. & - wannier_plot .or. write_u_matrices .or. write_tb) then + if (w90_calculation%bands_plot .or. w90_calculation%fermi_surface_plot .or. & + output_file%write_hr .or. w90_calculation%wannier_plot .or. output_file%write_u_matrices & + .or. output_file%write_tb) then write (stdout, '(1x,a)') '*---------------------------------------------------------------------------*' write (stdout, '(1x,a)') '| PLOTTING |' write (stdout, '(1x,a)') '*---------------------------------------------------------------------------*' write (stdout, *) end if - if (bands_plot .or. dos_plot .or. fermi_surface_plot .or. write_hr .or. & - write_tb) then + if (w90_calculation%bands_plot .or. w90_calculation%fermi_surface_plot .or. & + output_file%write_hr .or. output_file%write_tb) then ! Check if the kmesh includes the gamma point have_gamma = .false. do nkp = 1, num_kpts @@ -70,80 +146,131 @@ subroutine plot_main() write (stdout, '(1x,a)') '!!!! Kpoint grid does not include Gamma. '// & & ' Interpolation may be incorrect. !!!!' ! Transform Hamiltonian to WF basis - ! - call hamiltonian_setup() - ! - call hamiltonian_get_hr() - ! - if (bands_plot) call plot_interpolate_bands - ! - if (fermi_surface_plot) call plot_fermi_surface - ! - if (write_hr) call hamiltonian_write_hr() - ! - if (write_rmn) call hamiltonian_write_rmn() - ! - if (write_tb) call hamiltonian_write_tb() - ! - if (write_hr .or. write_rmn .or. write_tb) then - if (.not. done_ws_distance) call ws_translate_dist(nrpts, irvec) - call ws_write_vec(nrpts, irvec) + + call hamiltonian_setup(ham_logical, print_output, ws_region, w90_calculation, ham_k, ham_r, & + real_lattice, wannier_centres_translated, irvec, mp_grid, ndegen, & + num_kpts, num_wann, nrpts, rpt_origin, band_plot%mode, stdout, & + seedname, transport_mode) + + call hamiltonian_get_hr(atom_data, dis_manifold, ham_logical, real_space_ham, print_output, & + ham_k, ham_r, u_matrix, u_matrix_opt, eigval, kpt_latt, & + real_lattice, wannier_data%centres, wannier_centres_translated, & + irvec, shift_vec, nrpts, num_bands, num_kpts, num_wann, & + have_disentangled, stdout, seedname, lsitesymmetry) + + bands_num_spec_points = 0 + + if (allocated(kpoint_path%labels)) bands_num_spec_points = size(kpoint_path%labels) + + if (w90_calculation%bands_plot) then + call plot_interpolate_bands(mp_grid, real_lattice, band_plot, kpoint_path, real_space_ham, & + ws_region, print_output, recip_lattice, num_wann, & + wannier_data, ham_r, irvec, ndegen, nrpts, & + wannier_centres_translated, ws_distance, & + bands_num_spec_points, stdout, seedname) + endif + + if (w90_calculation%fermi_surface_plot) then + call plot_fermi_surface(fermi_energy_list, recip_lattice, fermi_surface_plot, num_wann, & + ham_r, irvec, ndegen, nrpts, print_output%timing_level, stdout, & + seedname) + endif + + if (output_file%write_hr) call hamiltonian_write_hr(ham_logical, ham_r, irvec, ndegen, & + nrpts, num_wann, & + print_output%timing_level, seedname, & + stdout) + + if (output_file%write_rmn) call hamiltonian_write_rmn(kmesh_info, m_matrix, kpt_latt, & + irvec, nrpts, num_kpts, num_wann, & + stdout, seedname) + + if (output_file%write_tb) call hamiltonian_write_tb(ham_logical, kmesh_info, ham_r, & + m_matrix, kpt_latt, real_lattice, & + irvec, ndegen, nrpts, num_kpts, & + num_wann, stdout, & + print_output%timing_level, seedname) + + if (output_file%write_hr .or. output_file%write_rmn .or. output_file%write_tb) then + if (.not. ws_distance%done) call ws_translate_dist(ws_distance, stdout, seedname, & + ws_region, num_wann, & + wannier_data%centres, real_lattice, & + mp_grid, nrpts, irvec) + call ws_write_vec(ws_distance, nrpts, irvec, num_wann, ws_region%use_ws_distance, & + stdout, seedname) end if end if - end if + end if !on_root - if (wannier_plot) call plot_wannier + if (w90_calculation%wannier_plot) call plot_wannier(wannier_plot, wvfn_read, wannier_data, & + print_output, u_matrix_opt, dis_manifold, & + real_lattice, atom_data, kpt_latt, & + u_matrix, num_kpts, num_bands, num_wann, & + have_disentangled, spinors, bohr, & + stdout, seedname, comm) if (on_root) then - if (write_bvec) call plot_bvec + if (output_file%write_bvec) call plot_bvec(kmesh_info, num_kpts, stdout, seedname) - if (write_u_matrices) call plot_u_matrices + if (output_file%write_u_matrices) call plot_u_matrices(u_matrix_opt, u_matrix, kpt_latt, & + have_disentangled, num_wann, num_kpts, & + num_bands, seedname) - if (timing_level > 0) call io_stopwatch('plot: main', 2) + if (print_output%timing_level > 0) call io_stopwatch('plot: main', 2, stdout, seedname) end if end subroutine plot_main - !-----------------------------------! + !----------------------------------------------------------------- !----------------- Private Routines ------------------------------ - !-----------------------------------! - - !============================================! - subroutine plot_interpolate_bands - !============================================! + !----------------------------------------------------------------- + + !================================================! + subroutine plot_interpolate_bands(mp_grid, real_lattice, band_plot, kpoint_path, real_space_ham, & + ws_region, print_output, recip_lattice, num_wann, wannier_data, & + ham_r, irvec, ndegen, nrpts, wannier_centres_translated, & + ws_distance, bands_num_spec_points, stdout, seedname) + !================================================! ! ! !! Plots the interpolated band structure ! ! - !============================================! - - use w90_constants, only: dp, cmplx_0, cmplx_i, twopi - use w90_io, only: io_error, stdout, io_file_unit, seedname, & - io_time, io_stopwatch - use w90_parameters, only: num_wann, bands_num_points, recip_metric, & - bands_num_spec_points, timing_level, & - bands_spec_points, bands_label, bands_plot_format, & - bands_plot_mode, num_bands_project, bands_plot_project, & - use_ws_distance - use w90_hamiltonian, only: irvec, nrpts, ndegen, ham_r - use w90_ws_distance, only: irdist_ws, wdist_ndeg, & - ws_translate_dist + !================================================! + + use w90_constants, only: dp, cmplx_0, twopi + use w90_io, only: io_error, io_file_unit, io_time, io_stopwatch + use w90_ws_distance, only: ws_translate_dist + use w90_utility, only: utility_metric + use w90_types, only: wannier_data_type, kpoint_path_type, print_output_type, ws_region_type, & + ws_distance_type + use w90_wannier90_types, only: band_plot_type, real_space_ham_type implicit none - complex(kind=dp), allocatable :: ham_r_cut(:, :, :) - complex(kind=dp), allocatable :: ham_pack(:) - complex(kind=dp) :: fac - complex(kind=dp), allocatable :: ham_kprm(:, :) - complex(kind=dp), allocatable :: U_int(:, :) - complex(kind=dp), allocatable :: cwork(:) - real(kind=dp), allocatable :: rwork(:) - real(kind=dp) :: kpath_len(bands_num_spec_points/2) - integer :: kpath_pts(bands_num_spec_points/2) - logical :: kpath_print_first_point(bands_num_spec_points/2) - real(kind=dp), allocatable :: xval(:) - real(kind=dp), allocatable :: eig_int(:, :), plot_kpoint(:, :) - real(kind=dp), allocatable :: bands_proj(:, :) - real(kind=dp) :: rdotk, vec(3), emin, emax, time0 + ! arguments + type(band_plot_type), intent(in) :: band_plot + type(kpoint_path_type), intent(in) :: kpoint_path + type(print_output_type), intent(in) :: print_output + type(real_space_ham_type), intent(in) :: real_space_ham + type(wannier_data_type), intent(in) :: wannier_data + type(ws_distance_type), intent(inout) :: ws_distance + type(ws_region_type), intent(in) :: ws_region + + integer, intent(inout) :: nrpts + integer, intent(in) :: ndegen(:) + integer, intent(in) :: irvec(:, :) + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_wann + integer, intent(in) :: bands_num_spec_points + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: recip_lattice(3, 3) + real(kind=dp), intent(in) :: wannier_centres_translated(:, :) + + complex(kind=dp), intent(in) :: ham_r(:, :, :) + character(len=50), intent(in) :: seedname + + ! local variables integer, allocatable :: irvec_cut(:, :) integer :: irvec_max(3) integer :: nrpts_cut @@ -153,39 +280,59 @@ subroutine plot_interpolate_bands integer :: loop_spts, total_pts, loop_i, nkp, ideg integer :: num_paths, num_spts, ierr integer :: bndunit, gnuunit, loop_w, loop_p - character(len=20), allocatable :: glabel(:) - character(len=10), allocatable :: xlabel(:) - character(len=10), allocatable :: ctemp(:) + integer :: kpath_pts(bands_num_spec_points/2) integer, allocatable :: idx_special_points(:) + + real(kind=dp) :: kpath_len(bands_num_spec_points/2) + real(kind=dp) :: rdotk, vec(3), emin, emax, time0 + real(kind=dp), allocatable :: rwork(:) + real(kind=dp), allocatable :: xval(:) + real(kind=dp), allocatable :: eig_int(:, :), plot_kpoint(:, :) + real(kind=dp), allocatable :: bands_proj(:, :) real(kind=dp), allocatable :: xval_special_points(:) + real(kind=dp) :: recip_metric(3, 3) + + complex(kind=dp) :: fac + complex(kind=dp), allocatable :: ham_r_cut(:, :, :) + complex(kind=dp), allocatable :: ham_pack(:) + complex(kind=dp), allocatable :: ham_kprm(:, :) + complex(kind=dp), allocatable :: U_int(:, :) + complex(kind=dp), allocatable :: cwork(:) + + logical :: kpath_print_first_point(bands_num_spec_points/2) + + character(len=20), allocatable :: glabel(:) + character(len=10), allocatable :: xlabel(:) + character(len=10), allocatable :: ctemp(:) ! - if (timing_level > 1) call io_stopwatch('plot: interpolate_bands', 1) + if (print_output%timing_level > 1) call io_stopwatch('plot: interpolate_bands', 1, stdout, seedname) ! time0 = io_time() + call utility_metric(recip_lattice, recip_metric) write (stdout, *) write (stdout, '(1x,a)') 'Calculating interpolated band-structure' write (stdout, *) ! allocate (ham_pack((num_wann*(num_wann + 1))/2), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ham_pack in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in allocating ham_pack in plot_interpolate_bands', stdout, seedname) allocate (ham_kprm(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ham_kprm in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in allocating ham_kprm in plot_interpolate_bands', stdout, seedname) allocate (U_int(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating U_int in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in allocating U_int in plot_interpolate_bands', stdout, seedname) allocate (cwork(2*num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cwork in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in allocating cwork in plot_interpolate_bands', stdout, seedname) allocate (rwork(7*num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating rwork in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in allocating rwork in plot_interpolate_bands', stdout, seedname) allocate (iwork(5*num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating iwork in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in allocating iwork in plot_interpolate_bands', stdout, seedname) allocate (ifail(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ifail in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in allocating ifail in plot_interpolate_bands', stdout, seedname) allocate (idx_special_points(bands_num_spec_points), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating idx_special_points in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in allocating idx_special_points in plot_interpolate_bands', stdout, seedname) allocate (xval_special_points(bands_num_spec_points), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating xval_special_points in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in allocating xval_special_points in plot_interpolate_bands', stdout, seedname) idx_special_points = -1 xval_special_points = -1._dp ! @@ -202,8 +349,10 @@ subroutine plot_interpolate_bands do i = 2, num_paths ! If either the coordinates are different or the label is different, compute again the point ! (it will end up at the same x coordinate) - if ((SUM((bands_spec_points(:, (i - 1)*2) - bands_spec_points(:, (i - 1)*2 + 1))**2) > 1.e-6) .or. & - (TRIM(bands_label((i - 1)*2)) .ne. TRIM(bands_label((i - 1)*2 + 1)))) then + if ((SUM((kpoint_path%points(:, (i - 1)*2) - & + kpoint_path%points(:, (i - 1)*2 + 1))**2) > 1.e-6) .or. & + (TRIM(kpoint_path%labels((i - 1)*2)) .ne. & + TRIM(kpoint_path%labels((i - 1)*2 + 1)))) then kpath_print_first_point(i) = .true. end if enddo @@ -215,12 +364,13 @@ subroutine plot_interpolate_bands end do do loop_spts = 1, num_paths - vec = bands_spec_points(:, 2*loop_spts) - bands_spec_points(:, 2*loop_spts - 1) + vec = kpoint_path%points(:, 2*loop_spts) - kpoint_path%points(:, 2*loop_spts - 1) kpath_len(loop_spts) = sqrt(dot_product(vec, (matmul(recip_metric, vec)))) if (loop_spts == 1) then - kpath_pts(loop_spts) = bands_num_points + kpath_pts(loop_spts) = kpoint_path%num_points_first_segment else - kpath_pts(loop_spts) = nint(real(bands_num_points, dp)*kpath_len(loop_spts)/kpath_len(1)) + kpath_pts(loop_spts) = nint(real(kpoint_path%num_points_first_segment, dp) & + *kpath_len(loop_spts)/kpath_len(1)) ! At least 1 point !if (kpath_pts(loop_spts) .eq. 0) kpath_pts(loop_spts) = 1 end if @@ -231,19 +381,19 @@ subroutine plot_interpolate_bands end do allocate (plot_kpoint(3, total_pts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating plot_kpoint in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in allocating plot_kpoint in plot_interpolate_bands', stdout, seedname) allocate (xval(total_pts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating xval in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in allocating xval in plot_interpolate_bands', stdout, seedname) allocate (eig_int(num_wann, total_pts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating eig_int in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in allocating eig_int in plot_interpolate_bands', stdout, seedname) allocate (bands_proj(num_wann, total_pts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating bands_proj in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in allocating bands_proj in plot_interpolate_bands', stdout, seedname) allocate (glabel(num_spts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating num_spts in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in allocating num_spts in plot_interpolate_bands', stdout, seedname) allocate (xlabel(num_spts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating xlabel in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in allocating xlabel in plot_interpolate_bands', stdout, seedname) allocate (ctemp(bands_num_spec_points), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ctemp in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in allocating ctemp in plot_interpolate_bands', stdout, seedname) eig_int = 0.0_dp; bands_proj = 0.0_dp ! ! Find the position of each kpoint in the path @@ -261,7 +411,7 @@ subroutine plot_interpolate_bands ! on the x axis, there was a jump in the path here. xval(counter) = xval(counter - 1) endif - plot_kpoint(:, counter) = bands_spec_points(:, 2*loop_spts - 1) + plot_kpoint(:, counter) = kpoint_path%points(:, 2*loop_spts - 1) idx_special_points(2*loop_spts - 1) = counter xval_special_points(2*loop_spts - 1) = xval(counter) @@ -278,15 +428,16 @@ subroutine plot_interpolate_bands else xval(counter) = xval(counter - 1) + kpath_len(loop_spts)/real(kpath_pts(loop_spts), dp) endif - plot_kpoint(:, counter) = bands_spec_points(:, 2*loop_spts - 1) + & - (bands_spec_points(:, 2*loop_spts) - bands_spec_points(:, 2*loop_spts - 1))* & + plot_kpoint(:, counter) = kpoint_path%points(:, 2*loop_spts - 1) + & + (kpoint_path%points(:, 2*loop_spts) & + - kpoint_path%points(:, 2*loop_spts - 1))* & (real(loop_i, dp)/real(kpath_pts(loop_spts), dp)) end do idx_special_points(2*loop_spts) = counter xval_special_points(2*loop_spts) = xval(counter) end do !xval(total_pts)=sum(kpath_len) - plot_kpoint(:, total_pts) = bands_spec_points(:, bands_num_spec_points) + plot_kpoint(:, total_pts) = kpoint_path%points(:, bands_num_spec_points) ! ! Write out the kpoints in the path ! @@ -303,9 +454,10 @@ subroutine plot_interpolate_bands bndunit = io_file_unit() open (bndunit, file=trim(seedname)//'_band.labelinfo.dat', form='formatted') do loop_spts = 1, bands_num_spec_points - if ((MOD(loop_spts, 2) .eq. 1) .and. (kpath_print_first_point((loop_spts + 1)/2) .eqv. .false.)) cycle + if ((MOD(loop_spts, 2) .eq. 1) .and. & + (kpath_print_first_point((loop_spts + 1)/2) .eqv. .false.)) cycle write (bndunit, '(a,3x,I10,3x,4f18.10)') & - bands_label(loop_spts), & + kpoint_path%labels(loop_spts), & idx_special_points(loop_spts), & xval_special_points(loop_spts), & (plot_kpoint(loop_i, idx_special_points(loop_spts)), loop_i=1, 3) @@ -314,35 +466,43 @@ subroutine plot_interpolate_bands ! ! Cut H matrix in real-space ! - if (index(bands_plot_mode, 'cut') .ne. 0) call plot_cut_hr() + if (index(band_plot%mode, 'cut') .ne. 0) then + call plot_cut_hr(band_plot, real_space_ham, real_lattice, mp_grid, num_wann, & + wannier_centres_translated, stdout) + endif ! ! Interpolate the Hamiltonian at each kpoint ! - if (use_ws_distance) then - if (index(bands_plot_mode, 's-k') .ne. 0) then - call ws_translate_dist(nrpts, irvec, force_recompute=.true.) - elseif (index(bands_plot_mode, 'cut') .ne. 0) then - call ws_translate_dist(nrpts_cut, irvec_cut, force_recompute=.true.) + if (ws_region%use_ws_distance) then + if (index(band_plot%mode, 's-k') .ne. 0) then + call ws_translate_dist(ws_distance, stdout, seedname, ws_region, num_wann, & + wannier_data%centres, real_lattice, mp_grid, nrpts, & + irvec, force_recompute=.true.) + elseif (index(band_plot%mode, 'cut') .ne. 0) then + call ws_translate_dist(ws_distance, stdout, seedname, ws_region, num_wann, & + wannier_data%centres, real_lattice, mp_grid, nrpts_cut, & + irvec_cut, force_recompute=.true.) else - call io_error('Error in plot_interpolate bands: value of bands_plot_mode not recognised') + call io_error('Error in plot_interpolate bands: value of bands_plot_mode not recognised', stdout, seedname) endif endif ! [lp] the s-k and cut codes are very similar when use_ws_distance is used, a complete - ! mercge after this point is not impossible + ! merge after this point is not impossible do loop_kpt = 1, total_pts ham_kprm = cmplx_0 ! - if (index(bands_plot_mode, 's-k') .ne. 0) then + if (index(band_plot%mode, 's-k') .ne. 0) then do irpt = 1, nrpts ! [lp] Shift the WF to have the minimum distance IJ, see also ws_distance.F90 - if (use_ws_distance) then + if (ws_region%use_ws_distance) then do j = 1, num_wann do i = 1, num_wann - do ideg = 1, wdist_ndeg(i, j, irpt) + do ideg = 1, ws_distance%ndeg(i, j, irpt) rdotk = twopi*dot_product(plot_kpoint(:, loop_kpt), & - real(irdist_ws(:, ideg, i, j, irpt), dp)) - fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(ndegen(irpt)*wdist_ndeg(i, j, irpt), dp) + real(ws_distance%irdist(:, ideg, i, j, irpt), dp)) + fac = cmplx(cos(rdotk), sin(rdotk), dp) & + /real(ndegen(irpt)*ws_distance%ndeg(i, j, irpt), dp) ham_kprm(i, j) = ham_kprm(i, j) + fac*ham_r(i, j, irpt) enddo enddo @@ -355,16 +515,16 @@ subroutine plot_interpolate_bands endif end do ! end of s-k mode - elseif (index(bands_plot_mode, 'cut') .ne. 0) then + elseif (index(band_plot%mode, 'cut') .ne. 0) then do irpt = 1, nrpts_cut ! [lp] Shift the WF to have the minimum distance IJ, see also ws_distance.F90 - if (use_ws_distance) then + if (ws_region%use_ws_distance) then do j = 1, num_wann do i = 1, num_wann - do ideg = 1, wdist_ndeg(i, j, irpt) + do ideg = 1, ws_distance%ndeg(i, j, irpt) rdotk = twopi*dot_product(plot_kpoint(:, loop_kpt), & - real(irdist_ws(:, ideg, i, j, irpt), dp)) - fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(wdist_ndeg(i, j, irpt), dp) + real(ws_distance%irdist(:, ideg, i, j, irpt), dp)) + fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(ws_distance%ndeg(i, j, irpt), dp) ham_kprm(i, j) = ham_kprm(i, j) + fac*ham_r_cut(i, j, irpt) enddo enddo @@ -389,18 +549,19 @@ subroutine plot_interpolate_bands nfound, eig_int(1, loop_kpt), U_int, num_wann, cwork, rwork, iwork, ifail, info) if (info < 0) then write (stdout, '(a,i3,a)') 'THE ', -info, ' ARGUMENT OF ZHPEVX HAD AN ILLEGAL VALUE' - call io_error('Error in plot_interpolate_bands') + call io_error('Error in plot_interpolate_bands', stdout, seedname) endif if (info > 0) then write (stdout, '(i3,a)') info, ' EIGENVECTORS FAILED TO CONVERGE' - call io_error('Error in plot_interpolate_bands') + call io_error('Error in plot_interpolate_bands', stdout, seedname) endif ! Compute projection onto WF if requested - if (num_bands_project > 0) then + if (allocated(band_plot%project)) then do loop_w = 1, num_wann do loop_p = 1, num_wann - if (any(bands_plot_project == loop_p)) then - bands_proj(loop_w, loop_kpt) = bands_proj(loop_w, loop_kpt) + abs(U_int(loop_p, loop_w))**2 + if (any(band_plot%project == loop_p)) then + bands_proj(loop_w, loop_kpt) = bands_proj(loop_w, loop_kpt) + & + abs(U_int(loop_p, loop_w))**2 end if end do end do @@ -414,30 +575,37 @@ subroutine plot_interpolate_bands emin = minval(eig_int) - 1.0_dp emax = maxval(eig_int) + 1.0_dp - if (index(bands_plot_format, 'gnu') > 0) call plot_interpolate_gnuplot - if (index(bands_plot_format, 'xmgr') > 0) call plot_interpolate_xmgrace - + if (index(band_plot%format, 'gnu') > 0) call plot_interpolate_gnuplot(band_plot, & + kpoint_path, & + bands_num_spec_points, & + num_wann) + if (index(band_plot%format, 'xmgr') > 0) call plot_interpolate_xmgrace(kpoint_path, & + bands_num_spec_points, & + num_wann) write (stdout, '(1x,a,f11.3,a)') & 'Time to calculate interpolated band structure ', io_time() - time0, ' (sec)' write (stdout, *) if (allocated(ham_r_cut)) deallocate (ham_r_cut, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating ham_r_cut in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in deallocating ham_r_cut in plot_interpolate_bands', stdout, seedname) if (allocated(irvec_cut)) deallocate (irvec_cut, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating irvec_cut in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in deallocating irvec_cut in plot_interpolate_bands', stdout, seedname) ! - if (timing_level > 1) call io_stopwatch('plot: interpolate_bands', 2) + if (print_output%timing_level > 1) call io_stopwatch('plot: interpolate_bands', 2, stdout, seedname) ! if (allocated(idx_special_points)) deallocate (idx_special_points, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating idx_special_points in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in deallocating idx_special_points in & + &plot_interpolate_bands', stdout, seedname) if (allocated(xval_special_points)) deallocate (xval_special_points, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating xval_special_points in plot_interpolate_bands') + if (ierr /= 0) call io_error('Error in deallocating xval_special_points in & + &plot_interpolate_bands', stdout, seedname) contains - !============================================! - subroutine plot_cut_hr() - !============================================! + !================================================! + subroutine plot_cut_hr(band_plot, real_space_ham, real_lattice, mp_grid, num_wann, & + wannier_centres_translated, stdout) + !================================================! ! !! In real-space picture, ham_r(j,i,k) is an interaction between !! j_th WF at 0 and i_th WF at the lattice point translated @@ -453,17 +621,26 @@ subroutine plot_cut_hr() !! limitation: when bands_plot_dim .ne. 3 !! one_dim_vec must be parallel to one of the cartesian axis !! and perpendicular to the other two primitive lattice vectors - !============================================! + !================================================! use w90_constants, only: dp, cmplx_0, eps8 - use w90_io, only: io_error, stdout - use w90_parameters, only: num_wann, mp_grid, real_lattice, & - one_dim_dir, bands_plot_dim, & - hr_cutoff, dist_cutoff, dist_cutoff_mode - use w90_hamiltonian, only: wannier_centres_translated + use w90_io, only: io_error + use w90_wannier90_types, only: band_plot_type, real_space_ham_type implicit none - ! + + ! arguments + type(real_space_ham_type), intent(in) :: real_space_ham + type(band_plot_type), intent(in) :: band_plot + + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: wannier_centres_translated(:, :) + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + + ! local variables integer :: nrpts_tmp integer :: one_dim_vec, two_dim_vec(2) integer :: i, j, n1, n2, n3, i1, i2, i3 @@ -474,23 +651,23 @@ subroutine plot_cut_hr() real(kind=dp) :: dist allocate (ham_r_tmp(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ham_r_tmp in plot_cut_hr') + if (ierr /= 0) call io_error('Error in allocating ham_r_tmp in plot_cut_hr', stdout, seedname) irvec_max = maxval(irvec, DIM=2) + 1 - if (bands_plot_dim .ne. 3) then + if (real_space_ham%system_dim .ne. 3) then ! Find one_dim_vec which is parallel to one_dim_dir ! two_dim_vec - the other two lattice vectors ! Along the confined directions, take only irvec=0 j = 0 do i = 1, 3 - if (abs(abs(real_lattice(one_dim_dir, i)) & + if (abs(abs(real_lattice(real_space_ham%one_dim_dir, i)) & - sqrt(dot_product(real_lattice(:, i), real_lattice(:, i)))) .lt. eps8) then one_dim_vec = i j = j + 1 end if end do - if (j .ne. 1) call io_error('Error: 1-d lattice vector not defined in plot_cut_hr') + if (j .ne. 1) call io_error('Error: 1-d lattice vector not defined in plot_cut_hr', stdout, seedname) j = 0 do i = 1, 3 if (i .ne. one_dim_vec) then @@ -498,20 +675,20 @@ subroutine plot_cut_hr() two_dim_vec(j) = i end if end do - if (bands_plot_dim .eq. 1) then + if (real_space_ham%system_dim .eq. 1) then irvec_max(two_dim_vec(1)) = 0 irvec_max(two_dim_vec(2)) = 0 end if - if (bands_plot_dim .eq. 2) irvec_max(one_dim_vec) = 0 + if (real_space_ham%system_dim .eq. 2) irvec_max(one_dim_vec) = 0 end if nrpts_cut = (2*irvec_max(1) + 1)*(2*irvec_max(2) + 1)*(2*irvec_max(3) + 1) allocate (ham_r_cut(num_wann, num_wann, nrpts_cut), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ham_r_cut in plot_cut_hr') + if (ierr /= 0) call io_error('Error in allocating ham_r_cut in plot_cut_hr', stdout, seedname) allocate (irvec_cut(3, nrpts_cut), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating irvec_cut in plot_cut_hr') + if (ierr /= 0) call io_error('Error in allocating irvec_cut in plot_cut_hr', stdout, seedname) allocate (shift_vec(3, nrpts_cut), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating shift_vec in plot_cut_hr') + if (ierr /= 0) call io_error('Error in allocating shift_vec in plot_cut_hr', stdout, seedname) nrpts_tmp = 0 do n1 = -irvec_max(1), irvec_max(1) @@ -536,7 +713,7 @@ subroutine plot_cut_hr() if (nrpts_tmp .ne. nrpts_cut) then write (stdout, '(a)') 'FAILED TO EXPAND ham_r' - call io_error('Error in plot_cut_hr') + call io_error('Error in plot_cut_hr', stdout, seedname) end if ! AAM: 29/10/2009 Bug fix thanks to Dr Shujun Hu, NIMS, Japan. @@ -550,28 +727,30 @@ subroutine plot_cut_hr() ! note: dist_cutoff_mode does not necessarily follow bands_plot_dim ! e.g. for 1-d system (bands_plot_dim=1) we can still apply 3-d dist_cutoff (dist_cutoff_mode=three_dim) - if (index(dist_cutoff_mode, 'one_dim') > 0) then + if (index(real_space_ham%dist_cutoff_mode, 'one_dim') > 0) then do i = 1, num_wann do j = 1, num_wann - dist_ij_vec(one_dim_dir) = & - wannier_centres_translated(one_dim_dir, i) - wannier_centres_translated(one_dim_dir, j) + dist_ij_vec(real_space_ham%one_dim_dir) = & + wannier_centres_translated(real_space_ham%one_dim_dir, i) - & + wannier_centres_translated(real_space_ham%one_dim_dir, j) do irpt = 1, nrpts_cut - dist_vec(one_dim_dir) = dist_ij_vec(one_dim_dir) + shift_vec(one_dim_dir, irpt) - dist = abs(dist_vec(one_dim_dir)) - if (dist .gt. dist_cutoff) & + dist_vec(real_space_ham%one_dim_dir) = dist_ij_vec(real_space_ham%one_dim_dir) + & + shift_vec(real_space_ham%one_dim_dir, irpt) + dist = abs(dist_vec(real_space_ham%one_dim_dir)) + if (dist .gt. real_space_ham%dist_cutoff) & ham_r_cut(j, i, irpt) = cmplx_0 end do end do end do - else if (index(dist_cutoff_mode, 'two_dim') > 0) then + else if (index(real_space_ham%dist_cutoff_mode, 'two_dim') > 0) then do i = 1, num_wann do j = 1, num_wann dist_ij_vec(:) = wannier_centres_translated(:, i) - wannier_centres_translated(:, j) do irpt = 1, nrpts_cut dist_vec(:) = dist_ij_vec(:) + shift_vec(:, irpt) - dist_vec(one_dim_dir) = 0.0_dp + dist_vec(real_space_ham%one_dim_dir) = 0.0_dp dist = sqrt(dot_product(dist_vec, dist_vec)) - if (dist .gt. dist_cutoff) & + if (dist .gt. real_space_ham%dist_cutoff) & ham_r_cut(j, i, irpt) = cmplx_0 end do end do @@ -583,7 +762,7 @@ subroutine plot_cut_hr() do irpt = 1, nrpts_cut dist_vec(:) = dist_ij_vec(:) + shift_vec(:, irpt) dist = sqrt(dot_product(dist_vec, dist_vec)) - if (dist .gt. dist_cutoff) & + if (dist .gt. real_space_ham%dist_cutoff) & ham_r_cut(j, i, irpt) = cmplx_0 end do end do @@ -593,7 +772,7 @@ subroutine plot_cut_hr() do irpt = 1, nrpts_cut do i = 1, num_wann do j = 1, num_wann - if (abs(ham_r_cut(j, i, irpt)) .lt. hr_cutoff) & + if (abs(ham_r_cut(j, i, irpt)) .lt. real_space_ham%hr_cutoff) & ham_r_cut(j, i, irpt) = cmplx_0 end do end do @@ -614,21 +793,26 @@ subroutine plot_cut_hr() end subroutine plot_cut_hr - !============================================! - subroutine plot_interpolate_gnuplot - !============================================! - ! ! + !================================================! + subroutine plot_interpolate_gnuplot(band_plot, kpoint_path, bands_num_spec_points, num_wann) + !================================================! + ! !! Plots the interpolated band structure in gnuplot format - !============================================! + ! + !================================================! use w90_constants, only: dp - use w90_io, only: io_file_unit, seedname - use w90_parameters, only: num_wann, bands_num_spec_points, & - bands_label, num_bands_project + use w90_io, only: io_file_unit + use w90_types, only: kpoint_path_type + use w90_wannier90_types, only: band_plot_type implicit none - ! + ! arguments + type(band_plot_type), intent(in) :: band_plot + type(kpoint_path_type), intent(in) :: kpoint_path + integer, intent(in) :: num_wann, bands_num_spec_points + bndunit = io_file_unit() open (bndunit, file=trim(seedname)//'_band.dat', form='formatted') gnuunit = io_file_unit() @@ -638,7 +822,7 @@ subroutine plot_interpolate_gnuplot ! do i = 1, num_wann do nkp = 1, total_pts - if (num_bands_project > 0) then + if (allocated(band_plot%project)) then write (bndunit, '(3E16.8)') xval(nkp), eig_int(i, nkp), bands_proj(i, nkp) else write (bndunit, '(2E16.8)') xval(nkp), eig_int(i, nkp) @@ -648,15 +832,16 @@ subroutine plot_interpolate_gnuplot enddo close (bndunit) ! Axis labels - glabel(1) = TRIM(bands_label(1)) + glabel(1) = TRIM(kpoint_path%labels(1)) do i = 2, num_paths - if (bands_label(2*(i - 1)) /= bands_label(2*(i - 1) + 1)) then - glabel(i) = TRIM(bands_label(2*(i - 1)))//'|'//TRIM(bands_label(2*(i - 1) + 1)) + if (kpoint_path%labels(2*(i - 1)) /= kpoint_path%labels(2*(i - 1) + 1)) then + glabel(i) = TRIM(kpoint_path%labels(2*(i - 1)))//'|'// & + TRIM(kpoint_path%labels(2*(i - 1) + 1)) else - glabel(i) = TRIM(bands_label(2*(i - 1))) + glabel(i) = TRIM(kpoint_path%labels(2*(i - 1))) end if end do - glabel(num_paths + 1) = TRIM(bands_label(2*num_paths)) + glabel(num_paths + 1) = TRIM(kpoint_path%labels(2*num_paths)) ! gnu file write (gnuunit, 701) xval(total_pts), emin, emax do i = 1, num_paths - 1 @@ -668,14 +853,15 @@ subroutine plot_interpolate_gnuplot write (gnuunit, *) 'plot ', '"'//trim(seedname)//'_band.dat', '"' close (gnuunit) - if (num_bands_project > 0) then + if (allocated(band_plot%project)) then gnuunit = io_file_unit() open (gnuunit, file=trim(seedname)//'_band_proj.gnu', form='formatted') write (gnuunit, '(a)') '#File to plot a colour-mapped Bandstructure' write (gnuunit, '(a)') 'set palette defined ( 0 "blue", 3 "green", 6 "yellow", 10 "red" )' write (gnuunit, '(a)') 'unset ztics' write (gnuunit, '(a)') 'unset key' - write (gnuunit, '(a)') '# can make pointsize smaller (~0.5). Too small and nothing is printed' + write (gnuunit, '(a)') '# can make pointsize smaller (~0.5). Too small and nothing is & + &printed' write (gnuunit, '(a)') 'set pointsize 0.8' write (gnuunit, '(a)') 'set grid xtics' write (gnuunit, '(a)') 'set view 0,0' @@ -685,30 +871,36 @@ subroutine plot_interpolate_gnuplot (glabel(i + 1), sum(kpath_len(1:i)), i=1, bands_num_spec_points/2 - 1) write (gnuunit, 703) glabel(1 + bands_num_spec_points/2), sum(kpath_len(:)) - write (gnuunit, '(a,a,a,a)') 'splot ', '"'//trim(seedname)//'_band.dat', '"', ' u 1:2:3 w p pt 13 palette' + write (gnuunit, '(a,a,a,a)') 'splot ', '"'//trim(seedname)//'_band.dat', '"', & + ' u 1:2:3 w p pt 13 palette' write (gnuunit, '(a)') '#use the next lines to make a nice figure for a paper' write (gnuunit, '(a)') '#set term postscript enhanced eps color lw 0.5 dl 0.5' write (gnuunit, '(a)') '#set pointsize 0.275' end if ! -701 format('set style data dots', /, 'set nokey', /, 'set xrange [0:', F8.5, ']', /, 'set yrange [', F9.5, ' :', F9.5, ']') +701 format('set style data dots', /, 'set nokey', /, 'set xrange [0:', F8.5, ']', /, & + 'set yrange [', F9.5, ' :', F9.5, ']') 702 format('set xtics (', :20('"', A, '" ', F8.5, ',')) 703 format(A, '" ', F8.5, ')') 705 format('set arrow from ', F8.5, ',', F10.5, ' to ', F8.5, ',', F10.5, ' nohead') end subroutine plot_interpolate_gnuplot - subroutine plot_interpolate_xmgrace - !============================================! - ! ! + !================================================! + subroutine plot_interpolate_xmgrace(kpoint_path, bands_num_spec_points, num_wann) + !================================================! + ! !! Plots the interpolated band structure in Xmgrace format - !============================================! + ! + !================================================! - use w90_io, only: io_file_unit, seedname, io_date - use w90_parameters, only: num_wann, bands_num_spec_points + use w90_io, only: io_file_unit, io_date + use w90_types, only: kpoint_path_type implicit none + type(kpoint_path_type), intent(in) :: kpoint_path + integer, intent(in) :: num_wann, bands_num_spec_points character(len=9) :: cdate, ctime call io_date(cdate, ctime) @@ -718,10 +910,10 @@ subroutine plot_interpolate_xmgrace ! Switch any G to Gamma do i = 1, bands_num_spec_points - if (bands_label(i) == 'G') then + if (kpoint_path%labels(i) == 'G') then ctemp(i) = '\xG\0' else - ctemp(i) = bands_label(i) + ctemp(i) = kpoint_path%labels(i) end if end do @@ -763,7 +955,8 @@ subroutine plot_interpolate_xmgrace write (gnuunit, '(a,i0)') '@ xaxis tick spec ', 1 + bands_num_spec_points/2 write (gnuunit, '(a)') '@ xaxis tick major 0, 0' do i = 1, bands_num_spec_points/2 - write (gnuunit, '(a,i0,a,a)') '@ xaxis ticklabel ', i - 1, ',', '"'//trim(adjustl(xlabel(i)))//'"' + write (gnuunit, '(a,i0,a,a)') '@ xaxis ticklabel ', i - 1, ',', '"'// & + trim(adjustl(xlabel(i)))//'"' write (gnuunit, '(a,i0,a,f10.5)') '@ xaxis tick major ', i, ' , ', sum(kpath_len(1:i)) end do write (gnuunit, '(a,i0,a)') '@ xaxis ticklabel ', bands_num_spec_points/2 & @@ -789,23 +982,35 @@ end subroutine plot_interpolate_xmgrace end subroutine plot_interpolate_bands - !===========================================================! - subroutine plot_fermi_surface - !===========================================================! - ! ! + !================================================! + subroutine plot_fermi_surface(fermi_energy_list, recip_lattice, fermi_surface_plot, num_wann, & + ham_r, irvec, ndegen, nrpts, timing_level, stdout, seedname) + !================================================! + ! !! Prepares a Xcrysden bxsf file to view the fermi surface - ! ! - !===========================================================! + ! + !================================================! - use w90_constants, only: dp, cmplx_0, cmplx_i, twopi - use w90_io, only: io_error, stdout, io_file_unit, seedname, & - io_date, io_time, io_stopwatch - use w90_parameters, only: num_wann, fermi_surface_num_points, timing_level, & - recip_lattice, nfermi, fermi_energy_list - use w90_hamiltonian, only: irvec, nrpts, ndegen, ham_r + use w90_constants, only: dp, cmplx_0, twopi + use w90_io, only: io_error, io_file_unit, io_date, io_time, io_stopwatch + use w90_wannier90_types, only: fermi_surface_plot_type implicit none + ! arguments + type(fermi_surface_plot_type), intent(in) :: fermi_surface_plot + complex(kind=dp), intent(in) :: ham_r(:, :, :) + character(len=50), intent(in) :: seedname + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + real(kind=dp), intent(in) :: recip_lattice(3, 3) + integer, intent(in) :: irvec(:, :) + integer, intent(in) :: ndegen(:) + integer, intent(in) :: nrpts + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + integer, intent(in) :: timing_level + + ! local variables complex(kind=dp), allocatable :: ham_pack(:) complex(kind=dp) :: fac complex(kind=dp), allocatable :: ham_kprm(:, :) @@ -817,49 +1022,52 @@ subroutine plot_fermi_surface integer, allocatable :: iwork(:), ifail(:) integer :: loop_x, loop_y, loop_z, INFO, ikp, i, j, ierr integer :: irpt, nfound, npts_plot, loop_kpt, bxsf_unit + integer :: fermi_n character(len=9) :: cdate, ctime ! - if (timing_level > 1) call io_stopwatch('plot: fermi_surface', 1) + if (timing_level > 1) call io_stopwatch('plot: fermi_surface', 1, stdout, seedname) time0 = io_time() write (stdout, *) write (stdout, '(1x,a)') 'Calculating Fermi surface' write (stdout, *) ! - if (nfermi > 1) call io_error("Error in plot: nfermi>1. Set the fermi level " & - //"using the input parameter 'fermi_level'") + fermi_n = 0 + if (allocated(fermi_energy_list)) fermi_n = size(fermi_energy_list) + if (fermi_n > 1) call io_error("Error in plot: nfermi>1. Set the fermi level " & + //"using the input parameter 'fermi_level'", stdout, seedname) ! allocate (ham_pack((num_wann*(num_wann + 1))/2), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ham_pack plot_fermi_surface') + if (ierr /= 0) call io_error('Error in allocating ham_pack plot_fermi_surface', stdout, seedname) allocate (ham_kprm(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ham_kprm plot_fermi_surface') + if (ierr /= 0) call io_error('Error in allocating ham_kprm plot_fermi_surface', stdout, seedname) allocate (U_int(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating U_int in plot_fermi_surface') + if (ierr /= 0) call io_error('Error in allocating U_int in plot_fermi_surface', stdout, seedname) allocate (cwork(2*num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cwork in plot_fermi_surface') + if (ierr /= 0) call io_error('Error in allocating cwork in plot_fermi_surface', stdout, seedname) allocate (rwork(7*num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating rwork in plot_fermi_surface') + if (ierr /= 0) call io_error('Error in allocating rwork in plot_fermi_surface', stdout, seedname) allocate (iwork(5*num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating iwork in plot_fermi_surface') + if (ierr /= 0) call io_error('Error in allocating iwork in plot_fermi_surface', stdout, seedname) allocate (ifail(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ifail in plot_fermi_surface') + if (ierr /= 0) call io_error('Error in allocating ifail in plot_fermi_surface', stdout, seedname) ! - npts_plot = (fermi_surface_num_points + 1)**3 + npts_plot = (fermi_surface_plot%num_points + 1)**3 allocate (eig_int(num_wann, npts_plot), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating eig_int in plot_fermi_surface') + if (ierr /= 0) call io_error('Error in allocating eig_int in plot_fermi_surface', stdout, seedname) eig_int = 0.0_dp U_int = (0.0_dp, 0.0_dp) ! ikp = 0 - do loop_x = 1, fermi_surface_num_points + 1 - do loop_y = 1, fermi_surface_num_points + 1 - do loop_z = 1, fermi_surface_num_points + 1 + do loop_x = 1, fermi_surface_plot%num_points + 1 + do loop_y = 1, fermi_surface_plot%num_points + 1 + do loop_z = 1, fermi_surface_plot%num_points + 1 ikp = ikp + 1 ham_kprm = cmplx_0 do irpt = 1, nrpts rdotk = twopi*real((loop_x - 1)*irvec(1, irpt) + & (loop_y - 1)*irvec(2, irpt) + (loop_z - 1)* & - irvec(3, irpt), dp)/real(fermi_surface_num_points, dp) + irvec(3, irpt), dp)/real(fermi_surface_plot%num_points, dp) fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(ndegen(irpt), dp) ham_kprm = ham_kprm + fac*ham_r(:, :, irpt) end do @@ -873,11 +1081,11 @@ subroutine plot_fermi_surface nfound, eig_int(1, ikp), U_int, num_wann, cwork, rwork, iwork, ifail, info) if (info < 0) then write (stdout, '(a,i3,a)') 'THE ', -info, ' ARGUMENT OF ZHPEVX HAD AN ILLEGAL VALUE' - call io_error('Error in plot_fermi_surface') + call io_error('Error in plot_fermi_surface', stdout, seedname) endif if (info > 0) then write (stdout, '(i3,a)') info, ' EIGENVECTORS FAILED TO CONVERGE' - call io_error('Error in plot_fermi_surface') + call io_error('Error in plot_fermi_surface', stdout, seedname) endif end do end do @@ -901,7 +1109,8 @@ subroutine plot_fermi_surface write (bxsf_unit, *) 'from_wannier_code' write (bxsf_unit, *) ' BEGIN_BANDGRID_3D_fermi' write (bxsf_unit, *) num_wann - write (bxsf_unit, *) fermi_surface_num_points + 1, fermi_surface_num_points + 1, fermi_surface_num_points + 1 + write (bxsf_unit, *) fermi_surface_plot%num_points + 1, fermi_surface_plot%num_points + 1, & + fermi_surface_plot%num_points + 1 write (bxsf_unit, *) '0.0 0.0 0.0' write (bxsf_unit, *) (recip_lattice(1, i), i=1, 3) write (bxsf_unit, *) (recip_lattice(2, i), i=1, 3) @@ -916,39 +1125,66 @@ subroutine plot_fermi_surface write (bxsf_unit, *) ' END_BLOCK_BANDGRID_3D' close (bxsf_unit) - write (stdout, '(1x,a,f11.3,a)') 'Time to calculate interpolated Fermi surface ', io_time() - time0, ' (sec)' + write (stdout, '(1x,a,f11.3,a)') 'Time to calculate interpolated Fermi surface ', & + io_time() - time0, ' (sec)' write (stdout, *) ! - if (timing_level > 1) call io_stopwatch('plot: fermi_surface', 2) + if (timing_level > 1) call io_stopwatch('plot: fermi_surface', 2, stdout, seedname) ! return end subroutine plot_fermi_surface - !============================================! - subroutine plot_wannier - !============================================! - ! ! + !================================================! + subroutine plot_wannier(wannier_plot, wvfn_read, wannier_data, print_output, u_matrix_opt, & + dis_manifold, real_lattice, atom_data, kpt_latt, u_matrix, num_kpts, & + num_bands, num_wann, have_disentangled, spinors, bohr, stdout, seedname, & + comm) + !================================================! !! Plot the WF in Xcrysden format !! based on code written by Michel Posternak - ! ! - !============================================! + ! + !================================================! use w90_constants, only: dp, cmplx_0, cmplx_i, twopi, cmplx_1 - use w90_io, only: io_error, stdout, io_file_unit, seedname, & - io_date, io_stopwatch - use w90_parameters, only: num_wann, num_bands, num_kpts, u_matrix, spin, & - ngs => wannier_plot_supercell, kpt_latt, num_species, atoms_species_num, & - atoms_symbol, atoms_pos_cart, num_atoms, real_lattice, have_disentangled, & - ndimwin, lwindow, u_matrix_opt, num_wannier_plot, wannier_plot_list, & - wannier_plot_mode, wvfn_formatted, timing_level, wannier_plot_format, & - spinors, wannier_plot_spinor_mode, wannier_plot_spinor_phase + use w90_io, only: io_error, io_file_unit, io_date, io_stopwatch + use w90_types, only: wannier_data_type, atom_data_type, dis_manifold_type, print_output_type + use w90_wannier90_types, only: wvfn_read_type, wannier_plot_type + use w90_comms, only: w90comm_type implicit none + ! arguments + type(atom_data_type), intent(in) :: atom_data + type(dis_manifold_type), intent(in) :: dis_manifold + type(print_output_type), intent(in) :: print_output + type(wannier_data_type), intent(in) :: wannier_data + type(wannier_plot_type), intent(in) :: wannier_plot + type(wvfn_read_type), intent(in) :: wvfn_read + type(w90comm_type), intent(in) :: comm + + complex(kind=dp), intent(in) :: u_matrix(:, :, :) + complex(kind=dp), intent(in) :: u_matrix_opt(:, :, :) + + real(kind=dp), intent(in) :: bohr + real(kind=dp), intent(in) :: kpt_latt(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + + integer, intent(in) :: num_bands + integer, intent(in) :: num_kpts + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + + logical, intent(in) :: have_disentangled + logical, intent(in) :: spinors + + character(len=50), intent(in) :: seedname + + ! local variables real(kind=dp) :: scalfac, tmax, tmaxx, x_0ang, y_0ang, z_0ang real(kind=dp) :: fxcry(3), dirl(3, 3), w_real, w_imag, ratmax, ratio real(kind=dp) :: upspinor, dnspinor, upphase, dnphase + complex(kind=dp), allocatable :: wann_func(:, :, :, :) complex(kind=dp), allocatable :: r_wvfn(:, :) complex(kind=dp), allocatable :: r_wvfn_tmp(:, :) @@ -957,379 +1193,412 @@ subroutine plot_wannier complex(kind=dp), allocatable :: r_wvfn_tmp_nc(:, :, :) ! add the spinor dim. complex(kind=dp) :: catmp, wmod - logical :: have_file + logical :: have_file, on_root + + integer :: num_nodes, my_node_id integer :: i, j, nsp, nat, nbnd, counter, ierr integer :: loop_kpt, ik, ix, iy, iz, nk, ngx, ngy, ngz, nxx, nyy, nzz integer :: loop_b, nx, ny, nz, npoint, file_unit, loop_w, num_inc - integer :: ispinor - ! Needed to split an array on different nodes - integer, dimension(0:num_nodes - 1) :: counts - integer, dimension(0:num_nodes - 1) :: displs + integer, allocatable :: counts(:) + integer, allocatable :: displs(:) + integer :: wann_plot_num + character(len=11) :: wfnname character(len=60) :: wanxsf, wancube character(len=9) :: cdate, ctime logical :: inc_band(num_bands) - ! - if (timing_level > 1) call io_stopwatch('plot: wannier', 1) - ! - if (.not. spinors) then - write (wfnname, 200) 1, spin - else - write (wfnname, 199) 1 - endif - inquire (file=wfnname, exist=have_file) - if (.not. have_file) call io_error('plot_wannier: file '//wfnname//' not found') - - file_unit = io_file_unit() - if (wvfn_formatted) then - open (unit=file_unit, file=wfnname, form='formatted') - read (file_unit, *) ngx, ngy, ngz, nk, nbnd - else - open (unit=file_unit, file=wfnname, form='unformatted') - read (file_unit) ngx, ngy, ngz, nk, nbnd - end if - close (file_unit) -200 format('UNK', i5.5, '.', i1) -199 format('UNK', i5.5, '.', 'NC') - - allocate (wann_func(-((ngs(1))/2)*ngx:((ngs(1) + 1)/2)*ngx - 1, & - -((ngs(2))/2)*ngy:((ngs(2) + 1)/2)*ngy - 1, & - -((ngs(3))/2)*ngz:((ngs(3) + 1)/2)*ngz - 1, num_wannier_plot), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating wann_func in plot_wannier') - wann_func = cmplx_0 - if (spinors) then - allocate (wann_func_nc(-((ngs(1))/2)*ngx:((ngs(1) + 1)/2)*ngx - 1, & - -((ngs(2))/2)*ngy:((ngs(2) + 1)/2)*ngy - 1, & - -((ngs(3))/2)*ngz:((ngs(3) + 1)/2)*ngz - 1, 2, num_wannier_plot), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating wann_func_nc in plot_wannier') - wann_func_nc = cmplx_0 - endif - if (.not. spinors) then - if (have_disentangled) then - allocate (r_wvfn_tmp(ngx*ngy*ngz, maxval(ndimwin)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating r_wvfn_tmp in plot_wannier') - end if - allocate (r_wvfn(ngx*ngy*ngz, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating r_wvfn in plot_wannier') - else - if (have_disentangled) then - allocate (r_wvfn_tmp_nc(ngx*ngy*ngz, maxval(ndimwin), 2), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating r_wvfn_tmp_nc in plot_wannier') - end if - allocate (r_wvfn_nc(ngx*ngy*ngz, num_wann, 2), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating r_wvfn_nc in plot_wannier') - endif + num_nodes = mpisize(comm) + my_node_id = mpirank(comm) - call comms_array_split(num_kpts, counts, displs) ! for MPI on kpoints - call io_date(cdate, ctime) - do loop_kpt = displs(my_node_id) + 1, displs(my_node_id) + counts(my_node_id) - - inc_band = .true. - num_inc = num_wann - if (have_disentangled) then - inc_band(:) = lwindow(:, loop_kpt) - num_inc = ndimwin(loop_kpt) - end if + on_root = .false. + if (my_node_id == 0) on_root = .true. + allocate (counts(0:num_nodes - 1)) + allocate (displs(0:num_nodes - 1)) + ! + if (print_output%timing_level > 1) call io_stopwatch('plot: wannier', 1, stdout, seedname) + ! + associate (ngs=>wannier_plot%supercell) + ! if (.not. spinors) then - write (wfnname, 200) loop_kpt, spin + write (wfnname, 200) 1, wvfn_read%spin_channel else - write (wfnname, 199) loop_kpt + write (wfnname, 199) 1 endif + inquire (file=wfnname, exist=have_file) + if (.not. have_file) call io_error('plot_wannier: file '//wfnname//' not found', stdout, seedname) + file_unit = io_file_unit() - if (wvfn_formatted) then + if (wvfn_read%formatted) then open (unit=file_unit, file=wfnname, form='formatted') - read (file_unit, *) ix, iy, iz, ik, nbnd + read (file_unit, *) ngx, ngy, ngz, nk, nbnd else open (unit=file_unit, file=wfnname, form='unformatted') - read (file_unit) ix, iy, iz, ik, nbnd + read (file_unit) ngx, ngy, ngz, nk, nbnd end if + close (file_unit) - if ((ix /= ngx) .or. (iy /= ngy) .or. (iz /= ngz) .or. (ik /= loop_kpt)) then - write (stdout, '(1x,a,a)') 'WARNING: mismatch in file', trim(wfnname) - write (stdout, '(1x,5(a6,I5))') ' ix=', ix, ' iy=', iy, ' iz=', iz, ' ik=', ik, ' nbnd=', nbnd - write (stdout, '(1x,5(a6,I5))') ' ngx=', ngx, ' ngy=', ngy, ' ngz=', ngz, ' kpt=', loop_kpt, 'bands=', num_bands - call io_error('plot_wannier') - end if +200 format('UNK', i5.5, '.', i1) +199 format('UNK', i5.5, '.', 'NC') - if (have_disentangled) then - counter = 1 - do loop_b = 1, num_bands - if (counter > num_inc) exit - if (wvfn_formatted) then - do nx = 1, ngx*ngy*ngz - read (file_unit, *) w_real, w_imag - if (.not. spinors) then - r_wvfn_tmp(nx, counter) = cmplx(w_real, w_imag, kind=dp) - else - r_wvfn_tmp_nc(nx, counter, 1) = cmplx(w_real, w_imag, kind=dp) ! up-spinor - endif - end do - if (spinors) then + if (allocated(wannier_plot%list)) then + wann_plot_num = size(wannier_plot%list) + else + wann_plot_num = 0 + endif + allocate (wann_func(-((ngs(1))/2)*ngx:((ngs(1) + 1)/2)*ngx - 1, & + -((ngs(2))/2)*ngy:((ngs(2) + 1)/2)*ngy - 1, & + -((ngs(3))/2)*ngz:((ngs(3) + 1)/2)*ngz - 1, wann_plot_num), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating wann_func in plot_wannier', stdout, seedname) + wann_func = cmplx_0 + if (spinors) then + allocate (wann_func_nc(-((ngs(1))/2)*ngx:((ngs(1) + 1)/2)*ngx - 1, & + -((ngs(2))/2)*ngy:((ngs(2) + 1)/2)*ngy - 1, & + -((ngs(3))/2)*ngz:((ngs(3) + 1)/2)*ngz - 1, 2, wann_plot_num), & + stat=ierr) + if (ierr /= 0) call io_error('Error in allocating wann_func_nc in plot_wannier', stdout, seedname) + wann_func_nc = cmplx_0 + endif + if (.not. spinors) then + if (have_disentangled) then + allocate (r_wvfn_tmp(ngx*ngy*ngz, maxval(dis_manifold%ndimwin)), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating r_wvfn_tmp in plot_wannier', stdout, seedname) + end if + allocate (r_wvfn(ngx*ngy*ngz, num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating r_wvfn in plot_wannier', stdout, seedname) + else + if (have_disentangled) then + allocate (r_wvfn_tmp_nc(ngx*ngy*ngz, maxval(dis_manifold%ndimwin), 2), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating r_wvfn_tmp_nc in plot_wannier', stdout, seedname) + end if + allocate (r_wvfn_nc(ngx*ngy*ngz, num_wann, 2), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating r_wvfn_nc in plot_wannier', stdout, seedname) + endif + + call io_date(cdate, ctime) + do loop_kpt = 1, num_kpts + + inc_band = .true. + num_inc = num_wann + if (have_disentangled) then + inc_band(:) = dis_manifold%lwindow(:, loop_kpt) + num_inc = dis_manifold%ndimwin(loop_kpt) + end if + + if (.not. spinors) then + write (wfnname, 200) loop_kpt, wvfn_read%spin_channel + else + write (wfnname, 199) loop_kpt + endif + file_unit = io_file_unit() + if (wvfn_read%formatted) then + open (unit=file_unit, file=wfnname, form='formatted') + read (file_unit, *) ix, iy, iz, ik, nbnd + else + open (unit=file_unit, file=wfnname, form='unformatted') + read (file_unit) ix, iy, iz, ik, nbnd + end if + + if ((ix /= ngx) .or. (iy /= ngy) .or. (iz /= ngz) .or. (ik /= loop_kpt)) then + write (stdout, '(1x,a,a)') 'WARNING: mismatch in file', trim(wfnname) + write (stdout, '(1x,5(a6,I5))') ' ix=', ix, ' iy=', iy, ' iz=', iz, ' ik=', ik, ' nbnd=', nbnd + write (stdout, '(1x,5(a6,I5))') ' ngx=', ngx, ' ngy=', ngy, ' ngz=', ngz, ' kpt=', loop_kpt, 'bands=', num_bands + call io_error('plot_wannier', stdout, seedname) + end if + + if (have_disentangled) then + counter = 1 + do loop_b = 1, num_bands + if (counter > num_inc) exit + if (wvfn_read%formatted) then do nx = 1, ngx*ngy*ngz read (file_unit, *) w_real, w_imag - r_wvfn_tmp_nc(nx, counter, 2) = cmplx(w_real, w_imag, kind=dp) ! down-spinor + if (.not. spinors) then + r_wvfn_tmp(nx, counter) = cmplx(w_real, w_imag, kind=dp) + else + r_wvfn_tmp_nc(nx, counter, 1) = cmplx(w_real, w_imag, kind=dp) ! up-spinor + endif end do - endif - else - if (.not. spinors) then - read (file_unit) (r_wvfn_tmp(nx, counter), nx=1, ngx*ngy*ngz) + if (spinors) then + do nx = 1, ngx*ngy*ngz + read (file_unit, *) w_real, w_imag + r_wvfn_tmp_nc(nx, counter, 2) = cmplx(w_real, w_imag, kind=dp) ! down-spinor + end do + endif else - read (file_unit) (r_wvfn_tmp_nc(nx, counter, 1), nx=1, ngx*ngy*ngz) ! up-spinor - read (file_unit) (r_wvfn_tmp_nc(nx, counter, 2), nx=1, ngx*ngy*ngz) ! down-spinor - endif - end if - if (inc_band(loop_b)) counter = counter + 1 - end do - else - do loop_b = 1, num_bands - if (wvfn_formatted) then - do nx = 1, ngx*ngy*ngz - read (file_unit, *) w_real, w_imag if (.not. spinors) then - r_wvfn(nx, loop_b) = cmplx(w_real, w_imag, kind=dp) + read (file_unit) (r_wvfn_tmp(nx, counter), nx=1, ngx*ngy*ngz) else - r_wvfn_nc(nx, loop_b, 1) = cmplx(w_real, w_imag, kind=dp) ! up-spinor + read (file_unit) (r_wvfn_tmp_nc(nx, counter, 1), nx=1, ngx*ngy*ngz) ! up-spinor + read (file_unit) (r_wvfn_tmp_nc(nx, counter, 2), nx=1, ngx*ngy*ngz) ! down-spinor endif - end do - if (spinors) then - do nx = 1, ngx*ngy*ngz - read (file_unit, *) w_real, w_imag - r_wvfn_nc(nx, loop_b, 2) = cmplx(w_real, w_imag, kind=dp) ! down-spinor - end do - endif - else - if (.not. spinors) then - read (file_unit) (r_wvfn(nx, loop_b), nx=1, ngx*ngy*ngz) - else - read (file_unit) (r_wvfn_nc(nx, loop_b, 1), nx=1, ngx*ngy*ngz) ! up-spinor - read (file_unit) (r_wvfn_nc(nx, loop_b, 2), nx=1, ngx*ngy*ngz) ! down-spinor - endif - end if - end do - end if - - close (file_unit) - - if (have_disentangled) then - if (.not. spinors) then - r_wvfn = cmplx_0 - do loop_w = 1, num_wann - do loop_b = 1, num_inc - r_wvfn(:, loop_w) = r_wvfn(:, loop_w) + & - u_matrix_opt(loop_b, loop_w, loop_kpt)*r_wvfn_tmp(:, loop_b) - end do + end if + if (inc_band(loop_b)) counter = counter + 1 end do else - r_wvfn_nc = cmplx_0 - do loop_w = 1, num_wann - do loop_b = 1, num_inc - call zaxpy(ngx*ngy*ngz, u_matrix_opt(loop_b, loop_w, loop_kpt), r_wvfn_tmp_nc(1, loop_b, 1), 1, & ! up-spinor - r_wvfn_nc(1, loop_w, 1), 1) - call zaxpy(ngx*ngy*ngz, u_matrix_opt(loop_b, loop_w, loop_kpt), r_wvfn_tmp_nc(1, loop_b, 2), 1, & ! down-spinor - r_wvfn_nc(1, loop_w, 2), 1) - end do - end do - endif - end if - - ! nxx, nyy, nzz span a parallelogram in the real space mesh, of side - ! 2*nphir, and centered around the maximum of phi_i, nphimx(i, 1 2 3) - ! - ! nx ny nz are the nxx nyy nzz brought back to the unit cell in - ! which u_nk(r)=cptwrb(r,n) is represented - ! - ! There is a big performance improvement in looping over num_wann - ! in the inner loop. This is poor memory access for wann_func and - ! but the reduced number of operations wins out. - - do nzz = -((ngs(3))/2)*ngz, ((ngs(3) + 1)/2)*ngz - 1 - nz = mod(nzz, ngz) - if (nz .lt. 1) nz = nz + ngz - do nyy = -((ngs(2))/2)*ngy, ((ngs(2) + 1)/2)*ngy - 1 - ny = mod(nyy, ngy) - if (ny .lt. 1) ny = ny + ngy - do nxx = -((ngs(1))/2)*ngx, ((ngs(1) + 1)/2)*ngx - 1 - nx = mod(nxx, ngx) - if (nx .lt. 1) nx = nx + ngx - - scalfac = kpt_latt(1, loop_kpt)*real(nxx - 1, dp)/real(ngx, dp) + & - kpt_latt(2, loop_kpt)*real(nyy - 1, dp)/real(ngy, dp) + & - kpt_latt(3, loop_kpt)*real(nzz - 1, dp)/real(ngz, dp) - npoint = nx + (ny - 1)*ngx + (nz - 1)*ngy*ngx - catmp = exp(twopi*cmplx_i*scalfac) - do loop_b = 1, num_wann - do loop_w = 1, num_wannier_plot + do loop_b = 1, num_bands + if (wvfn_read%formatted) then + do nx = 1, ngx*ngy*ngz + read (file_unit, *) w_real, w_imag if (.not. spinors) then - wann_func(nxx, nyy, nzz, loop_w) = & - wann_func(nxx, nyy, nzz, loop_w) + & - u_matrix(loop_b, wannier_plot_list(loop_w), loop_kpt)*r_wvfn(npoint, loop_b)*catmp + r_wvfn(nx, loop_b) = cmplx(w_real, w_imag, kind=dp) else - wann_func_nc(nxx, nyy, nzz, 1, loop_w) = & - wann_func_nc(nxx, nyy, nzz, 1, loop_w) + & ! up-spinor - u_matrix(loop_b, wannier_plot_list(loop_w), loop_kpt)*r_wvfn_nc(npoint, loop_b, 1)*catmp - wann_func_nc(nxx, nyy, nzz, 2, loop_w) = & - wann_func_nc(nxx, nyy, nzz, 2, loop_w) + & ! down-spinor - u_matrix(loop_b, wannier_plot_list(loop_w), loop_kpt)*r_wvfn_nc(npoint, loop_b, 2)*catmp - if (loop_b == num_wann) then ! last loop - upspinor = real(wann_func_nc(nxx, nyy, nzz, 1, loop_w)* & - conjg(wann_func_nc(nxx, nyy, nzz, 1, loop_w)), dp) - dnspinor = real(wann_func_nc(nxx, nyy, nzz, 2, loop_w)* & - conjg(wann_func_nc(nxx, nyy, nzz, 2, loop_w)), dp) - if (wannier_plot_spinor_phase) then - upphase = sign(1.0_dp, real(wann_func_nc(nxx, nyy, nzz, 1, loop_w), dp)) - dnphase = sign(1.0_dp, real(wann_func_nc(nxx, nyy, nzz, 2, loop_w), dp)) - else - upphase = 1.0_dp; dnphase = 1.0_dp - endif - select case (wannier_plot_spinor_mode) - case ('total') - wann_func(nxx, nyy, nzz, loop_w) = cmplx(sqrt(upspinor + dnspinor), 0.0_dp, dp) - case ('up') - wann_func(nxx, nyy, nzz, loop_w) = cmplx(sqrt(upspinor), 0.0_dp, dp)*upphase - case ('down') - wann_func(nxx, nyy, nzz, loop_w) = cmplx(sqrt(dnspinor), 0.0_dp, dp)*dnphase - case default - call io_error('plot_wannier: Invalid wannier_plot_spinor_mode '//trim(wannier_plot_spinor_mode)) - end select - wann_func(nxx, nyy, nzz, loop_w) = wann_func(nxx, nyy, nzz, loop_w)/real(num_kpts, dp) - endif + r_wvfn_nc(nx, loop_b, 1) = cmplx(w_real, w_imag, kind=dp) ! up-spinor endif end do - end do + if (spinors) then + do nx = 1, ngx*ngy*ngz + read (file_unit, *) w_real, w_imag + r_wvfn_nc(nx, loop_b, 2) = cmplx(w_real, w_imag, kind=dp) ! down-spinor + end do + endif + else + if (.not. spinors) then + read (file_unit) (r_wvfn(nx, loop_b), nx=1, ngx*ngy*ngz) + else + read (file_unit) (r_wvfn_nc(nx, loop_b, 1), nx=1, ngx*ngy*ngz) ! up-spinor + read (file_unit) (r_wvfn_nc(nx, loop_b, 2), nx=1, ngx*ngy*ngz) ! down-spinor + endif + end if end do - end do + end if - end do + close (file_unit) - end do !loop over kpoints + if (have_disentangled) then + if (.not. spinors) then + r_wvfn = cmplx_0 + do loop_w = 1, num_wann + do loop_b = 1, num_inc + r_wvfn(:, loop_w) = r_wvfn(:, loop_w) + & + u_matrix_opt(loop_b, loop_w, loop_kpt)*r_wvfn_tmp(:, loop_b) + end do + end do + else + r_wvfn_nc = cmplx_0 + do loop_w = 1, num_wann + do loop_b = 1, num_inc + call zaxpy(ngx*ngy*ngz, u_matrix_opt(loop_b, loop_w, loop_kpt), r_wvfn_tmp_nc(1, loop_b, 1), 1, & ! up-spinor + r_wvfn_nc(1, loop_w, 1), 1) + call zaxpy(ngx*ngy*ngz, u_matrix_opt(loop_b, loop_w, loop_kpt), r_wvfn_tmp_nc(1, loop_b, 2), 1, & ! down-spinor + r_wvfn_nc(1, loop_w, 2), 1) + end do + end do + endif + end if - if (spinors) then - call comms_reduce(wann_func_nc(-((ngs(1))/2)*ngx, -((ngs(2))/2)*ngy, -((ngs(3))/2)*ngz, 1, 1), & - size(wann_func_nc), 'SUM') - else - call comms_reduce(wann_func(-((ngs(1))/2)*ngx, -((ngs(2))/2)*ngy, -((ngs(3))/2)*ngz, 1), & - size(wann_func), 'SUM') - endif + ! nxx, nyy, nzz span a parallelogram in the real space mesh, of side + ! 2*nphir, and centered around the maximum of phi_i, nphimx(i, 1 2 3) + ! + ! nx ny nz are the nxx nyy nzz brought back to the unit cell in + ! which u_nk(r)=cptwrb(r,n) is represented + ! + ! There is a big performance improvement in looping over num_wann + ! in the inner loop. This is poor memory access for wann_func and + ! but the reduced number of operations wins out. - if (on_root) then - if (spinors) then do nzz = -((ngs(3))/2)*ngz, ((ngs(3) + 1)/2)*ngz - 1 + nz = mod(nzz, ngz) + if (nz .lt. 1) nz = nz + ngz do nyy = -((ngs(2))/2)*ngy, ((ngs(2) + 1)/2)*ngy - 1 + ny = mod(nyy, ngy) + if (ny .lt. 1) ny = ny + ngy do nxx = -((ngs(1))/2)*ngx, ((ngs(1) + 1)/2)*ngx - 1 - do loop_w = 1, num_wannier_plot - upspinor = real(wann_func_nc(nxx, nyy, nzz, 1, loop_w)* & - conjg(wann_func_nc(nxx, nyy, nzz, 1, loop_w)), dp) - dnspinor = real(wann_func_nc(nxx, nyy, nzz, 2, loop_w)* & - conjg(wann_func_nc(nxx, nyy, nzz, 2, loop_w)), dp) - if (wannier_plot_spinor_phase) then - upphase = sign(1.0_dp, real(wann_func_nc(nxx, nyy, nzz, 1, loop_w), dp)) - dnphase = sign(1.0_dp, real(wann_func_nc(nxx, nyy, nzz, 2, loop_w), dp)) - else - upphase = 1.0_dp; dnphase = 1.0_dp - endif - select case (wannier_plot_spinor_mode) - case ('total') - wann_func(nxx, nyy, nzz, loop_w) = cmplx(sqrt(upspinor + dnspinor), 0.0_dp, dp) - case ('up') - wann_func(nxx, nyy, nzz, loop_w) = cmplx(sqrt(upspinor), 0.0_dp, dp)*upphase - case ('down') - wann_func(nxx, nyy, nzz, loop_w) = cmplx(sqrt(dnspinor), 0.0_dp, dp)*dnphase - case default - call io_error('plot_wannier: Invalid wannier_plot_spinor_mode '//trim(wannier_plot_spinor_mode)) - end select - wann_func(nxx, nyy, nzz, loop_w) = wann_func(nxx, nyy, nzz, loop_w)/real(num_kpts, dp) + nx = mod(nxx, ngx) + if (nx .lt. 1) nx = nx + ngx + + scalfac = kpt_latt(1, loop_kpt)*real(nxx - 1, dp)/real(ngx, dp) + & + kpt_latt(2, loop_kpt)*real(nyy - 1, dp)/real(ngy, dp) + & + kpt_latt(3, loop_kpt)*real(nzz - 1, dp)/real(ngz, dp) + npoint = nx + (ny - 1)*ngx + (nz - 1)*ngy*ngx + catmp = exp(twopi*cmplx_i*scalfac) + do loop_b = 1, num_wann + do loop_w = 1, wann_plot_num + if (.not. spinors) then + wann_func(nxx, nyy, nzz, loop_w) = wann_func(nxx, nyy, nzz, loop_w) + & + u_matrix(loop_b, wannier_plot%list(loop_w), loop_kpt)* & + r_wvfn(npoint, loop_b)*catmp + else + wann_func_nc(nxx, nyy, nzz, 1, loop_w) = & + wann_func_nc(nxx, nyy, nzz, 1, loop_w) + & ! up-spinor + u_matrix(loop_b, wannier_plot%list(loop_w), loop_kpt)*r_wvfn_nc(npoint, loop_b, 1)*catmp + wann_func_nc(nxx, nyy, nzz, 2, loop_w) = & + wann_func_nc(nxx, nyy, nzz, 2, loop_w) + & ! down-spinor + u_matrix(loop_b, wannier_plot%list(loop_w), loop_kpt)*r_wvfn_nc(npoint, loop_b, 2)*catmp + if (loop_b == num_wann) then ! last loop + upspinor = real(wann_func_nc(nxx, nyy, nzz, 1, loop_w)* & + conjg(wann_func_nc(nxx, nyy, nzz, 1, loop_w)), dp) + dnspinor = real(wann_func_nc(nxx, nyy, nzz, 2, loop_w)* & + conjg(wann_func_nc(nxx, nyy, nzz, 2, loop_w)), dp) + if (wannier_plot%spinor_phase) then + upphase = sign(1.0_dp, real(wann_func_nc(nxx, nyy, nzz, 1, loop_w), dp)) + dnphase = sign(1.0_dp, real(wann_func_nc(nxx, nyy, nzz, 2, loop_w), dp)) + else + upphase = 1.0_dp; dnphase = 1.0_dp + endif + select case (wannier_plot%spinor_mode) + case ('total') + wann_func(nxx, nyy, nzz, loop_w) = cmplx(sqrt(upspinor + dnspinor), 0.0_dp, dp) + case ('up') + wann_func(nxx, nyy, nzz, loop_w) = cmplx(sqrt(upspinor), 0.0_dp, dp)*upphase + case ('down') + wann_func(nxx, nyy, nzz, loop_w) = cmplx(sqrt(dnspinor), 0.0_dp, dp)*dnphase + case default + call io_error('plot_wannier: Invalid wannier_plot_spinor_mode '& + &//trim(wannier_plot%spinor_mode), stdout, seedname) + end select + wann_func(nxx, nyy, nzz, loop_w) = & + wann_func(nxx, nyy, nzz, loop_w)/real(num_kpts, dp) + endif + endif + end do end do end do end do end do - endif - endif - if (on_root) then - if (.not. spinors) then !!!!! For spinor Wannier functions, the steps below are not necessary. - ! fix the global phase by setting the wannier to - ! be real at the point where it has max. modulus + end do !loop over kpoints - do loop_w = 1, num_wannier_plot - tmaxx = 0.0 - wmod = cmplx_1 + if (spinors) then + call comms_reduce(wann_func_nc(-((ngs(1))/2)*ngx, -((ngs(2))/2)*ngy, -((ngs(3))/2)*ngz, 1, 1), & + size(wann_func_nc), 'SUM', stdout, seedname, comm) + else + call comms_reduce(wann_func(-((ngs(1))/2)*ngx, -((ngs(2))/2)*ngy, -((ngs(3))/2)*ngz, 1), & + size(wann_func), 'SUM', stdout, seedname, comm) + endif + + if (on_root) then + if (spinors) then do nzz = -((ngs(3))/2)*ngz, ((ngs(3) + 1)/2)*ngz - 1 do nyy = -((ngs(2))/2)*ngy, ((ngs(2) + 1)/2)*ngy - 1 do nxx = -((ngs(1))/2)*ngx, ((ngs(1) + 1)/2)*ngx - 1 - wann_func(nxx, nyy, nzz, loop_w) = wann_func(nxx, nyy, nzz, loop_w)/real(num_kpts, dp) - tmax = real(wann_func(nxx, nyy, nzz, loop_w)* & - conjg(wann_func(nxx, nyy, nzz, loop_w)), dp) - if (tmax > tmaxx) then - tmaxx = tmax - wmod = wann_func(nxx, nyy, nzz, loop_w) - end if + do loop_w = 1, wann_plot_num + upspinor = real(wann_func_nc(nxx, nyy, nzz, 1, loop_w)* & + conjg(wann_func_nc(nxx, nyy, nzz, 1, loop_w)), dp) + dnspinor = real(wann_func_nc(nxx, nyy, nzz, 2, loop_w)* & + conjg(wann_func_nc(nxx, nyy, nzz, 2, loop_w)), dp) + if (wannier_plot%spinor_phase) then + upphase = sign(1.0_dp, real(wann_func_nc(nxx, nyy, nzz, 1, loop_w), dp)) + dnphase = sign(1.0_dp, real(wann_func_nc(nxx, nyy, nzz, 2, loop_w), dp)) + else + upphase = 1.0_dp; dnphase = 1.0_dp + endif + select case (wannier_plot%spinor_mode) + case ('total') + wann_func(nxx, nyy, nzz, loop_w) = cmplx(sqrt(upspinor + dnspinor), 0.0_dp, dp) + case ('up') + wann_func(nxx, nyy, nzz, loop_w) = cmplx(sqrt(upspinor), 0.0_dp, dp)*upphase + case ('down') + wann_func(nxx, nyy, nzz, loop_w) = cmplx(sqrt(dnspinor), 0.0_dp, dp)*dnphase + case default + call io_error('plot_wannier: Invalid wannier_plot_spinor_mode ' & + //trim(wannier_plot%spinor_mode), stdout, seedname) + end select + wann_func(nxx, nyy, nzz, loop_w) = wann_func(nxx, nyy, nzz, loop_w)/real(num_kpts, dp) + end do end do end do + wmod = wmod/sqrt(real(wmod)**2 + aimag(wmod)**2) + wann_func(:, :, :, loop_w) = wann_func(:, :, :, loop_w)/wmod end do - wmod = wmod/sqrt(real(wmod)**2 + aimag(wmod)**2) - wann_func(:, :, :, loop_w) = wann_func(:, :, :, loop_w)/wmod - end do - ! - ! Check the 'reality' of the WF - ! - do loop_w = 1, num_wannier_plot - ratmax = 0.0_dp - do nzz = -((ngs(3))/2)*ngz, ((ngs(3) + 1)/2)*ngz - 1 - do nyy = -((ngs(2))/2)*ngy, ((ngs(2) + 1)/2)*ngy - 1 - do nxx = -((ngs(1))/2)*ngx, ((ngs(1) + 1)/2)*ngx - 1 - if (abs(real(wann_func(nxx, nyy, nzz, loop_w), dp)) >= 0.01_dp) then - ratio = abs(aimag(wann_func(nxx, nyy, nzz, loop_w)))/ & - abs(real(wann_func(nxx, nyy, nzz, loop_w), dp)) - ratmax = max(ratmax, ratio) - end if + endif + endif + + if (on_root) then + if (.not. spinors) then !!!!! For spinor Wannier functions, the steps below are not necessary. + ! fix the global phase by setting the wannier to + ! be real at the point where it has max. modulus + + do loop_w = 1, wann_plot_num + tmaxx = 0.0 + wmod = cmplx_1 + do nzz = -((ngs(3))/2)*ngz, ((ngs(3) + 1)/2)*ngz - 1 + do nyy = -((ngs(2))/2)*ngy, ((ngs(2) + 1)/2)*ngy - 1 + do nxx = -((ngs(1))/2)*ngx, ((ngs(1) + 1)/2)*ngx - 1 + wann_func(nxx, nyy, nzz, loop_w) = wann_func(nxx, nyy, nzz, loop_w)/real(num_kpts, dp) + tmax = real(wann_func(nxx, nyy, nzz, loop_w)* & + conjg(wann_func(nxx, nyy, nzz, loop_w)), dp) + if (tmax > tmaxx) then + tmaxx = tmax + wmod = wann_func(nxx, nyy, nzz, loop_w) + end if + end do end do end do + wmod = wmod/sqrt(real(wmod)**2 + aimag(wmod)**2) + wann_func(:, :, :, loop_w) = wann_func(:, :, :, loop_w)/wmod end do - write (stdout, '(6x,a,i4,7x,a,f11.6)') 'Wannier Function Num: ', wannier_plot_list(loop_w), & - 'Maximum Im/Re Ratio = ', ratmax - end do - endif !!!!! - write (stdout, *) ' ' - if (wannier_plot_format .eq. 'xcrysden') then - call internal_xsf_format() - elseif (wannier_plot_format .eq. 'cube') then - call internal_cube_format() - else - call io_error('wannier_plot_format not recognised in wannier_plot') - endif + ! + ! Check the 'reality' of the WF + ! + do loop_w = 1, wann_plot_num + ratmax = 0.0_dp + do nzz = -((ngs(3))/2)*ngz, ((ngs(3) + 1)/2)*ngz - 1 + do nyy = -((ngs(2))/2)*ngy, ((ngs(2) + 1)/2)*ngy - 1 + do nxx = -((ngs(1))/2)*ngx, ((ngs(1) + 1)/2)*ngx - 1 + if (abs(real(wann_func(nxx, nyy, nzz, loop_w), dp)) >= 0.01_dp) then + ratio = abs(aimag(wann_func(nxx, nyy, nzz, loop_w)))/ & + abs(real(wann_func(nxx, nyy, nzz, loop_w), dp)) + ratmax = max(ratmax, ratio) + end if + end do + end do + end do + write (stdout, '(6x,a,i4,7x,a,f11.6)') 'Wannier Function Num: ', wannier_plot%list(loop_w), & + 'Maximum Im/Re Ratio = ', ratmax + end do + endif !!!!! + write (stdout, *) ' ' + if (wannier_plot%format .eq. 'xcrysden') then + call internal_xsf_format() + elseif (wannier_plot%format .eq. 'cube') then + call internal_cube_format(atom_data, wannier_data, wvfn_read, have_disentangled, & + real_lattice, bohr) + else + call io_error('wannier_plot_format not recognised in wannier_plot', stdout, seedname) + endif - if (timing_level > 1) call io_stopwatch('plot: wannier', 2) - end if + if (print_output%timing_level > 1) call io_stopwatch('plot: wannier', 2, stdout, seedname) + end if !on_root + + end associate return contains - !============================================! - subroutine internal_cube_format() - !============================================! - ! ! + !================================================! + subroutine internal_cube_format(atom_data, wannier_data, wvfn_read, have_disentangled, & + real_lattice, bohr) + !================================================! + ! !! Write WFs in Gaussian cube format. - ! ! - !============================================! + ! + !================================================! - use w90_constants, only: bohr - use w90_parameters, only: recip_lattice, iprint, & - wannier_plot_radius, wannier_centres, atoms_symbol, & - wannier_plot_scale, atoms_pos_frac, num_atoms - use w90_utility, only: utility_translate_home, & - utility_cart_to_frac, utility_frac_to_cart + use w90_utility, only: utility_translate_home, utility_cart_to_frac, utility_frac_to_cart, & + utility_inverse_mat, utility_recip_lattice_base + use w90_types, only: wannier_data_type, atom_data_type + use w90_wannier90_types, only: wvfn_read_type implicit none + type(wvfn_read_type), intent(in) :: wvfn_read + type(wannier_data_type), intent(in) :: wannier_data + type(atom_data_type), intent(in) :: atom_data + real(kind=dp), intent(in) :: bohr + + real(kind=dp), intent(in) :: real_lattice(3, 3) + logical, intent(in) :: have_disentangled + real(kind=dp), allocatable :: wann_cube(:, :, :) + real(kind=dp) :: inv_lattice(3, 3), recip_lattice(3, 3), pos_frac(3), volume real(kind=dp) :: rstart(3), rend(3), rlength(3), orig(3), dgrid(3) real(kind=dp) :: moda(3), modb(3) real(kind=dp) :: val_Q real(kind=dp) :: comf(3), wcf(3), diff(3), difc(3), dist - integer :: ierr, iname, max_elements, iw + integer :: ierr, iname, max_elements integer :: isp, iat, nzz, nyy, nxx, loop_w, qxx, qyy, qzz, wann_index integer :: istart(3), iend(3), ilength(3) integer :: ixx, iyy, izz @@ -1349,261 +1618,270 @@ subroutine internal_cube_format() & 'Ac', 'Th', 'Pa', 'U ', 'Np', 'Pu', 'Am', 'Cm', 'Bk', 'Cf', 'Es', 'Fm', 'Md', 'No', 'Lr', & & 'Rf', 'Db', 'Sg', 'Bh', 'Hs', 'Mt'/) - allocate (atomic_Z(num_species), stat=ierr) - if (ierr .ne. 0) call io_error('Error: allocating atomic_Z in wannier_plot') + associate (ngs=>wannier_plot%supercell) - lmol = .false. - lcrys = .false. - if (index(wannier_plot_mode, 'mol') > 0) lmol = .true. ! molecule mode - if (index(wannier_plot_mode, 'crys') > 0) lcrys = .true. ! crystal mode + allocate (atomic_Z(atom_data%num_species), stat=ierr) + if (ierr .ne. 0) call io_error('Error: allocating atomic_Z in wannier_plot', stdout, seedname) - val_Q = 1.0_dp ! dummy value for cube file + call utility_recip_lattice_base(real_lattice, recip_lattice, volume) + lmol = .false. + lcrys = .false. + if (index(wannier_plot%mode, 'mol') > 0) lmol = .true. ! molecule mode + if (index(wannier_plot%mode, 'crys') > 0) lcrys = .true. ! crystal mode - ! Assign atomic numbers to species - max_elements = size(periodic_table) - do isp = 1, num_species - do iname = 1, max_elements - if (atoms_symbol(isp) .eq. periodic_table(iname)) then - atomic_Z(isp) = iname - exit - endif - enddo - end do + val_Q = 1.0_dp ! dummy value for cube file -202 format(a, '_', i5.5, '.cube') - - ! Lengths of real and reciprocal lattice vectors - do i = 1, 3 - moda(i) = sqrt(real_lattice(i, 1)*real_lattice(i, 1) & - + real_lattice(i, 2)*real_lattice(i, 2) & - + real_lattice(i, 3)*real_lattice(i, 3)) - modb(i) = sqrt(recip_lattice(i, 1)*recip_lattice(i, 1) & - + recip_lattice(i, 2)*recip_lattice(i, 2) & - + recip_lattice(i, 3)*recip_lattice(i, 3)) - enddo + ! Assign atomic numbers to species + max_elements = size(periodic_table) + do isp = 1, atom_data%num_species + do iname = 1, max_elements + if (atom_data%symbol(isp) .eq. periodic_table(iname)) then + atomic_Z(isp) = iname + exit + endif + enddo + end do - ! Grid spacing in each lattice direction - dgrid(1) = moda(1)/ngx; dgrid(2) = moda(2)/ngy; dgrid(3) = moda(3)/ngz +202 format(a, '_', i5.5, '.cube') - ! Find "centre of mass" of atomic positions (in fractional coordinates) - comf(:) = 0.0_dp - do isp = 1, num_species - do iat = 1, atoms_species_num(isp) - comf(:) = comf(:) + atoms_pos_frac(:, iat, isp) + ! Lengths of real and reciprocal lattice vectors + do i = 1, 3 + moda(i) = sqrt(real_lattice(i, 1)*real_lattice(i, 1) & + + real_lattice(i, 2)*real_lattice(i, 2) & + + real_lattice(i, 3)*real_lattice(i, 3)) + modb(i) = sqrt(recip_lattice(i, 1)*recip_lattice(i, 1) & + + recip_lattice(i, 2)*recip_lattice(i, 2) & + + recip_lattice(i, 3)*recip_lattice(i, 3)) enddo - enddo - comf(:) = comf(:)/num_atoms - - ! Loop over WFs - do loop_w = 1, num_wannier_plot - wann_index = wannier_plot_list(loop_w) - write (wancube, 202) trim(seedname), wann_index + ! Grid spacing in each lattice direction + dgrid(1) = moda(1)/ngx; dgrid(2) = moda(2)/ngy; dgrid(3) = moda(3)/ngz - ! Find start and end of cube wrt simulation (home) cell origin - do i = 1, 3 - ! ... in terms of distance along each lattice vector direction i - rstart(i) = (wannier_centres(1, wann_index)*recip_lattice(i, 1) & - + wannier_centres(2, wann_index)*recip_lattice(i, 2) & - + wannier_centres(3, wann_index)*recip_lattice(i, 3))*moda(i)/twopi & - - twopi*wannier_plot_radius/(moda(i)*modb(i)) - rend(i) = (wannier_centres(1, wann_index)*recip_lattice(i, 1) & - + wannier_centres(2, wann_index)*recip_lattice(i, 2) & - + wannier_centres(3, wann_index)*recip_lattice(i, 3))*moda(i)/twopi & - + twopi*wannier_plot_radius/(moda(i)*modb(i)) + ! Find "centre of mass" of atomic positions (in fractional coordinates) + call utility_inverse_mat(real_lattice, inv_lattice) + comf(:) = 0.0_dp + do isp = 1, atom_data%num_species + do iat = 1, atom_data%species_num(isp) + call utility_cart_to_frac(atom_data%pos_cart(:, iat, isp), pos_frac, inv_lattice) + comf(:) = comf(:) + pos_frac(:) + enddo enddo + comf(:) = comf(:)/atom_data%num_atoms + + ! Loop over WFs + do loop_w = 1, wann_plot_num + + wann_index = wannier_plot%list(loop_w) + write (wancube, 202) trim(seedname), wann_index + + ! Find start and end of cube wrt simulation (home) cell origin + do i = 1, 3 + ! ... in terms of distance along each lattice vector direction i + rstart(i) = (wannier_data%centres(1, wann_index)*recip_lattice(i, 1) & + + wannier_data%centres(2, wann_index)*recip_lattice(i, 2) & + + wannier_data%centres(3, wann_index)*recip_lattice(i, 3))*moda(i)/twopi & + - twopi*wannier_plot%radius/(moda(i)*modb(i)) + rend(i) = (wannier_data%centres(1, wann_index)*recip_lattice(i, 1) & + + wannier_data%centres(2, wann_index)*recip_lattice(i, 2) & + + wannier_data%centres(3, wann_index)*recip_lattice(i, 3))*moda(i)/twopi & + + twopi*wannier_plot%radius/(moda(i)*modb(i)) + enddo - rlength(:) = rend(:) - rstart(:) - ilength(:) = ceiling(rlength(:)/dgrid(:)) + rlength(:) = rend(:) - rstart(:) + ilength(:) = ceiling(rlength(:)/dgrid(:)) - ! ... in terms of integer gridpoints along each lattice vector direction i - istart(:) = floor(rstart(:)/dgrid(:)) + 1 - iend(:) = istart(:) + ilength(:) - 1 + ! ... in terms of integer gridpoints along each lattice vector direction i + istart(:) = floor(rstart(:)/dgrid(:)) + 1 + iend(:) = istart(:) + ilength(:) - 1 - ! Origin of cube wrt simulation (home) cell in Cartesian co-ordinates - do i = 1, 3 - orig(i) = real(istart(1) - 1, dp)*dgrid(1)*real_lattice(1, i)/moda(1) & - + real(istart(2) - 1, dp)*dgrid(2)*real_lattice(2, i)/moda(2) & - + real(istart(3) - 1, dp)*dgrid(3)*real_lattice(3, i)/moda(3) - enddo + ! Origin of cube wrt simulation (home) cell in Cartesian co-ordinates + do i = 1, 3 + orig(i) = real(istart(1) - 1, dp)*dgrid(1)*real_lattice(1, i)/moda(1) & + + real(istart(2) - 1, dp)*dgrid(2)*real_lattice(2, i)/moda(2) & + + real(istart(3) - 1, dp)*dgrid(3)*real_lattice(3, i)/moda(3) + enddo - ! Debugging - if (iprint > 3) then - write (stdout, '(a,i12)') 'loop_w =', loop_w - write (stdout, '(a,3f12.6)') 'comf =', (comf(i), i=1, 3) - write (stdout, '(a,3i12)') 'ngi =', ngx, ngy, ngz - write (stdout, '(a,3f12.6)') 'dgrid =', (dgrid(i), i=1, 3) - write (stdout, '(a,3f12.6)') 'rstart =', (rstart(i), i=1, 3) - write (stdout, '(a,3f12.6)') 'rend =', (rend(i), i=1, 3) - write (stdout, '(a,3f12.6)') 'rlength =', (rlength(i), i=1, 3) - write (stdout, '(a,3i12)') 'istart =', (istart(i), i=1, 3) - write (stdout, '(a,3i12)') 'iend =', (iend(i), i=1, 3) - write (stdout, '(a,3i12)') 'ilength =', (ilength(i), i=1, 3) - write (stdout, '(a,3f12.6)') 'orig =', (orig(i), i=1, 3) - write (stdout, '(a,3f12.6)') 'wann_cen=', (wannier_centres(i, wann_index), i=1, 3) - endif + ! Debugging + if (print_output%iprint > 3) then + write (stdout, '(a,i12)') 'loop_w =', loop_w + write (stdout, '(a,3f12.6)') 'comf =', (comf(i), i=1, 3) + write (stdout, '(a,3i12)') 'ngi =', ngx, ngy, ngz + write (stdout, '(a,3f12.6)') 'dgrid =', (dgrid(i), i=1, 3) + write (stdout, '(a,3f12.6)') 'rstart =', (rstart(i), i=1, 3) + write (stdout, '(a,3f12.6)') 'rend =', (rend(i), i=1, 3) + write (stdout, '(a,3f12.6)') 'rlength =', (rlength(i), i=1, 3) + write (stdout, '(a,3i12)') 'istart =', (istart(i), i=1, 3) + write (stdout, '(a,3i12)') 'iend =', (iend(i), i=1, 3) + write (stdout, '(a,3i12)') 'ilength =', (ilength(i), i=1, 3) + write (stdout, '(a,3f12.6)') 'orig =', (orig(i), i=1, 3) + write (stdout, '(a,3f12.6)') 'wann_cen=', (wannier_data%centres(i, wann_index), i=1, 3) + endif - allocate (wann_cube(1:ilength(1), 1:ilength(2), 1:ilength(3)), stat=ierr) - if (ierr .ne. 0) call io_error('Error: allocating wann_cube in wannier_plot') + allocate (wann_cube(1:ilength(1), 1:ilength(2), 1:ilength(3)), stat=ierr) + if (ierr .ne. 0) call io_error('Error: allocating wann_cube in wannier_plot', stdout, seedname) - ! initialise - wann_cube = 0.0_dp + ! initialise + wann_cube = 0.0_dp - do nzz = 1, ilength(3) - qzz = nzz + istart(3) - 1 - izz = int((abs(qzz) - 1)/ngz) + do nzz = 1, ilength(3) + qzz = nzz + istart(3) - 1 + izz = int((abs(qzz) - 1)/ngz) ! if (qzz.lt.-ngz) qzz=qzz+izz*ngz ! if (qzz.gt.(ngs(3)-1)*ngz-1) then - if (qzz .lt. (-((ngs(3))/2)*ngz)) qzz = qzz + izz*ngz - if (qzz .gt. ((ngs(3) + 1)/2)*ngz - 1) then - write (stdout, *) 'Error plotting WF cube. Try one of the following:' - write (stdout, *) ' (1) increase wannier_plot_supercell;' - write (stdout, *) ' (2) decrease wannier_plot_radius;' - write (stdout, *) ' (3) set wannier_plot_format=xcrysden' - call io_error('Error plotting WF cube.') - endif - do nyy = 1, ilength(2) - qyy = nyy + istart(2) - 1 - iyy = int((abs(qyy) - 1)/ngy) -! if (qyy.lt.-ngy) qyy=qyy+iyy*ngy -! if (qyy.gt.(ngs(2)-1)*ngy-1) then - if (qyy .lt. (-((ngs(2))/2)*ngy)) qyy = qyy + iyy*ngy - if (qyy .gt. ((ngs(2) + 1)/2)*ngy - 1) then + if (qzz .lt. (-((ngs(3))/2)*ngz)) qzz = qzz + izz*ngz + if (qzz .gt. ((ngs(3) + 1)/2)*ngz - 1) then write (stdout, *) 'Error plotting WF cube. Try one of the following:' write (stdout, *) ' (1) increase wannier_plot_supercell;' write (stdout, *) ' (2) decrease wannier_plot_radius;' write (stdout, *) ' (3) set wannier_plot_format=xcrysden' - call io_error('Error plotting WF cube.') + call io_error('Error plotting WF cube.', stdout, seedname) endif - do nxx = 1, ilength(1) - qxx = nxx + istart(1) - 1 - ixx = int((abs(qxx) - 1)/ngx) -! if (qxx.lt.-ngx) qxx=qxx+ixx*ngx -! if (qxx.gt.(ngs(1)-1)*ngx-1) then - if (qxx .lt. (-((ngs(1))/2)*ngx)) qxx = qxx + ixx*ngx - if (qxx .gt. ((ngs(1) + 1)/2)*ngx - 1) then + do nyy = 1, ilength(2) + qyy = nyy + istart(2) - 1 + iyy = int((abs(qyy) - 1)/ngy) +! if (qyy.lt.-ngy) qyy=qyy+iyy*ngy +! if (qyy.gt.(ngs(2)-1)*ngy-1) then + if (qyy .lt. (-((ngs(2))/2)*ngy)) qyy = qyy + iyy*ngy + if (qyy .gt. ((ngs(2) + 1)/2)*ngy - 1) then write (stdout, *) 'Error plotting WF cube. Try one of the following:' write (stdout, *) ' (1) increase wannier_plot_supercell;' write (stdout, *) ' (2) decrease wannier_plot_radius;' write (stdout, *) ' (3) set wannier_plot_format=xcrysden' - call io_error('Error plotting WF cube.') + call io_error('Error plotting WF cube.', stdout, seedname) endif - wann_cube(nxx, nyy, nzz) = real(wann_func(qxx, qyy, qzz, loop_w), dp) + do nxx = 1, ilength(1) + qxx = nxx + istart(1) - 1 + ixx = int((abs(qxx) - 1)/ngx) +! if (qxx.lt.-ngx) qxx=qxx+ixx*ngx +! if (qxx.gt.(ngs(1)-1)*ngx-1) then + if (qxx .lt. (-((ngs(1))/2)*ngx)) qxx = qxx + ixx*ngx + if (qxx .gt. ((ngs(1) + 1)/2)*ngx - 1) then + write (stdout, *) 'Error plotting WF cube. Try one of the following:' + write (stdout, *) ' (1) increase wannier_plot_supercell;' + write (stdout, *) ' (2) decrease wannier_plot_radius;' + write (stdout, *) ' (3) set wannier_plot_format=xcrysden' + call io_error('Error plotting WF cube.', stdout, seedname) + endif + wann_cube(nxx, nyy, nzz) = real(wann_func(qxx, qyy, qzz, loop_w), dp) + enddo enddo enddo - enddo - ! WF centre in fractional coordinates - call utility_cart_to_frac(wannier_centres(:, wann_index), wcf(:), recip_lattice) + ! WF centre in fractional coordinates + call utility_cart_to_frac(wannier_data%centres(:, wann_index), wcf(:), inv_lattice) - ! The vector (in fractional coordinates) from WF centre to "centre of mass" - diff(:) = comf(:) - wcf(:) + ! The vector (in fractional coordinates) from WF centre to "centre of mass" + diff(:) = comf(:) - wcf(:) - ! Corresponding nearest cell vector - irdiff(:) = nint(diff(:)) + ! Corresponding nearest cell vector + irdiff(:) = nint(diff(:)) - if (iprint > 3) then - write (stdout, '(a,3f12.6)') 'wcf =', (wcf(i), i=1, 3) - write (stdout, '(a,3f12.6)') 'diff =', (diff(i), i=1, 3) - write (stdout, '(a,3i12)') 'irdiff =', (irdiff(i), i=1, 3) - endif + if (print_output%iprint > 3) then + write (stdout, '(a,3f12.6)') 'wcf =', (wcf(i), i=1, 3) + write (stdout, '(a,3f12.6)') 'diff =', (diff(i), i=1, 3) + write (stdout, '(a,3i12)') 'irdiff =', (irdiff(i), i=1, 3) + endif - if (lmol) then ! In "molecule mode" translate origin of cube to bring it in coincidence with the atomic positions - orig(:) = orig(:) + real(irdiff(1), kind=dp)*real_lattice(1, :) & - + real(irdiff(2), kind=dp)*real_lattice(2, :) & - + real(irdiff(3), kind=dp)*real_lattice(3, :) - if (iprint > 3) write (stdout, '(a,3f12.6,/)') 'orig-new=', (orig(i), i=1, 3) - else ! In "crystal mode" count number of atoms within a given radius of wannier centre - icount = 0 - do isp = 1, num_species - do iat = 1, atoms_species_num(isp) - do nzz = -ngs(3)/2, (ngs(3) + 1)/2 - do nyy = -ngs(2)/2, (ngs(2) + 1)/2 - do nxx = -ngs(1)/2, (ngs(1) + 1)/2 - diff(:) = atoms_pos_frac(:, iat, isp) - wcf(:) & - + (/real(nxx, kind=dp), real(nyy, kind=dp), real(nzz, kind=dp)/) - call utility_frac_to_cart(diff, difc, real_lattice) - dist = sqrt(difc(1)*difc(1) + difc(2)*difc(2) + difc(3)*difc(3)) - if (dist .le. (wannier_plot_scale*wannier_plot_radius)) then - icount = icount + 1 - endif + if (lmol) then ! In "molecule mode" translate origin of cube to bring it in coincidence with the atomic positions + orig(:) = orig(:) + real(irdiff(1), kind=dp)*real_lattice(1, :) & + + real(irdiff(2), kind=dp)*real_lattice(2, :) & + + real(irdiff(3), kind=dp)*real_lattice(3, :) + if (print_output%iprint > 3) write (stdout, '(a,3f12.6,/)') 'orig-new=', (orig(i), i=1, 3) + else ! In "crystal mode" count number of atoms within a given radius of wannier centre + icount = 0 + do isp = 1, atom_data%num_species + do iat = 1, atom_data%species_num(isp) + call utility_cart_to_frac(atom_data%pos_cart(:, iat, isp), pos_frac, inv_lattice) + do nzz = -ngs(3)/2, (ngs(3) + 1)/2 + do nyy = -ngs(2)/2, (ngs(2) + 1)/2 + do nxx = -ngs(1)/2, (ngs(1) + 1)/2 + diff(:) = pos_frac(:) - wcf(:) & + + (/real(nxx, kind=dp), real(nyy, kind=dp), real(nzz, kind=dp)/) + call utility_frac_to_cart(diff, difc, real_lattice) + dist = sqrt(difc(1)*difc(1) + difc(2)*difc(2) + difc(3)*difc(3)) + if (dist .le. (wannier_plot%scale*wannier_plot%radius)) then + icount = icount + 1 + endif + enddo enddo enddo - enddo - enddo ! iat - enddo ! isp - if (iprint > 3) write (stdout, '(a,i12)') 'icount =', icount - endif + enddo ! iat + enddo ! isp + if (print_output%iprint > 3) write (stdout, '(a,i12)') 'icount =', icount + endif - ! Write cube file (everything in Bohr) - file_unit = io_file_unit() - open (unit=file_unit, file=trim(wancube), form='formatted', status='unknown') - ! First two lines are comments - write (file_unit, *) ' Generated by Wannier90 code http://www.wannier.org' - write (file_unit, *) ' On ', cdate, ' at ', ctime - ! Number of atoms, origin of cube (Cartesians) wrt simulation (home) cell - if (lmol) then - write (file_unit, '(i4,3f13.5)') num_atoms, orig(1)/bohr, orig(2)/bohr, orig(3)/bohr - else - write (file_unit, '(i4,3f13.5)') icount, orig(1)/bohr, orig(2)/bohr, orig(3)/bohr - endif - ! Number of grid points in each direction, lattice vector - write (file_unit, '(i4,3f13.5)') ilength(1), real_lattice(1, 1)/(real(ngx, dp)*bohr), & - real_lattice(1, 2)/(real(ngx, dp)*bohr), real_lattice(1, 3)/(real(ngx, dp)*bohr) - write (file_unit, '(i4,3f13.5)') ilength(2), real_lattice(2, 1)/(real(ngy, dp)*bohr), & - real_lattice(2, 2)/(real(ngy, dp)*bohr), real_lattice(2, 3)/(real(ngy, dp)*bohr) - write (file_unit, '(i4,3f13.5)') ilength(3), real_lattice(3, 1)/(real(ngz, dp)*bohr), & - real_lattice(3, 2)/(real(ngz, dp)*bohr), real_lattice(3, 3)/(real(ngz, dp)*bohr) - - ! Atomic number, valence charge, position of atom + ! Write cube file (everything in Bohr) + file_unit = io_file_unit() + open (unit=file_unit, file=trim(wancube), form='formatted', status='unknown') + ! First two lines are comments + write (file_unit, *) ' Generated by Wannier90 code http://www.wannier.org' + write (file_unit, *) ' On ', cdate, ' at ', ctime + ! Number of atoms, origin of cube (Cartesians) wrt simulation (home) cell + if (lmol) then + write (file_unit, '(i4,3f13.5)') atom_data%num_atoms, orig(1)/bohr, orig(2)/bohr, orig(3)/bohr + else + write (file_unit, '(i4,3f13.5)') icount, orig(1)/bohr, orig(2)/bohr, orig(3)/bohr + endif + ! Number of grid points in each direction, lattice vector + write (file_unit, '(i4,3f13.5)') ilength(1), real_lattice(1, 1)/(real(ngx, dp)*bohr), & + real_lattice(1, 2)/(real(ngx, dp)*bohr), real_lattice(1, 3)/(real(ngx, dp)*bohr) + write (file_unit, '(i4,3f13.5)') ilength(2), real_lattice(2, 1)/(real(ngy, dp)*bohr), & + real_lattice(2, 2)/(real(ngy, dp)*bohr), real_lattice(2, 3)/(real(ngy, dp)*bohr) + write (file_unit, '(i4,3f13.5)') ilength(3), real_lattice(3, 1)/(real(ngz, dp)*bohr), & + real_lattice(3, 2)/(real(ngz, dp)*bohr), real_lattice(3, 3)/(real(ngz, dp)*bohr) + + ! Atomic number, valence charge, position of atom ! do isp=1,num_species ! do iat=1,atoms_species_num(isp) ! write(file_unit,'(i4,4f13.5)') atomic_Z(isp), val_Q, (atoms_pos_cart(i,iat,isp)/bohr,i=1,3) ! end do ! end do - do isp = 1, num_species - do iat = 1, atoms_species_num(isp) - if (lmol) then ! In "molecule mode", write atomic coordinates as they appear in input file - write (file_unit, '(i4,4f13.5)') atomic_Z(isp), val_Q, (atoms_pos_cart(i, iat, isp)/bohr, i=1, 3) - else ! In "crystal mode", write atoms in supercell within a given radius of Wannier centre - do nzz = -ngs(3)/2, (ngs(3) + 1)/2 - do nyy = -ngs(2)/2, (ngs(2) + 1)/2 - do nxx = -ngs(1)/2, (ngs(1) + 1)/2 - diff(:) = atoms_pos_frac(:, iat, isp) - wcf(:) & - + (/real(nxx, kind=dp), real(nyy, kind=dp), real(nzz, kind=dp)/) - call utility_frac_to_cart(diff, difc, real_lattice) - dist = sqrt(difc(1)*difc(1) + difc(2)*difc(2) + difc(3)*difc(3)) - if (dist .le. (wannier_plot_scale*wannier_plot_radius)) then - diff(:) = atoms_pos_frac(:, iat, isp) & + do isp = 1, atom_data%num_species + do iat = 1, atom_data%species_num(isp) + if (lmol) then ! In "molecule mode", write atomic coordinates as they appear in input file + write (file_unit, '(i4,4f13.5)') atomic_Z(isp), val_Q, (atom_data%pos_cart(i, iat, isp)/bohr, i=1, 3) + else ! In "crystal mode", write atoms in supercell within a given radius of Wannier centre + call utility_cart_to_frac(atom_data%pos_cart(:, iat, isp), pos_frac, inv_lattice) + do nzz = -ngs(3)/2, (ngs(3) + 1)/2 + do nyy = -ngs(2)/2, (ngs(2) + 1)/2 + do nxx = -ngs(1)/2, (ngs(1) + 1)/2 + diff(:) = pos_frac(:) - wcf(:) & + (/real(nxx, kind=dp), real(nyy, kind=dp), real(nzz, kind=dp)/) call utility_frac_to_cart(diff, difc, real_lattice) - write (file_unit, '(i4,4f13.5)') atomic_Z(isp), val_Q, (difc(i)/bohr, i=1, 3) - endif + dist = sqrt(difc(1)*difc(1) + difc(2)*difc(2) + difc(3)*difc(3)) + if (dist .le. (wannier_plot%scale*wannier_plot%radius)) then + diff(:) = pos_frac(:) & + + (/real(nxx, kind=dp), real(nyy, kind=dp), real(nzz, kind=dp)/) + call utility_frac_to_cart(diff, difc, real_lattice) + write (file_unit, '(i4,4f13.5)') atomic_Z(isp), val_Q, (difc(i)/bohr, i=1, 3) + endif + enddo enddo enddo + endif + enddo ! iat + enddo ! isp + + ! Volumetric data in batches of 6 values per line, 'z'-direction first. + do nxx = 1, ilength(1) + do nyy = 1, ilength(2) + do nzz = 1, ilength(3) + write (file_unit, '(E13.5)', advance='no') wann_cube(nxx, nyy, nzz) + if ((mod(nzz, 6) .eq. 0) .or. (nzz .eq. ilength(3))) write (file_unit, '(a)') '' enddo - endif - enddo ! iat - enddo ! isp - - ! Volumetric data in batches of 6 values per line, 'z'-direction first. - do nxx = 1, ilength(1) - do nyy = 1, ilength(2) - do nzz = 1, ilength(3) - write (file_unit, '(E13.5)', advance='no') wann_cube(nxx, nyy, nzz) - if ((mod(nzz, 6) .eq. 0) .or. (nzz .eq. ilength(3))) write (file_unit, '(a)') '' enddo enddo - enddo - deallocate (wann_cube, stat=ierr) - if (ierr .ne. 0) call io_error('Error: deallocating wann_cube in wannier_plot') + deallocate (wann_cube, stat=ierr) + if (ierr .ne. 0) call io_error('Error: deallocating wann_cube in wannier_plot', stdout, seedname) - end do + end do + + deallocate (atomic_Z, stat=ierr) + if (ierr .ne. 0) call io_error('Error: deallocating atomic_Z in wannier_plot', stdout, seedname) - deallocate (atomic_Z, stat=ierr) - if (ierr .ne. 0) call io_error('Error: deallocating atomic_Z in wannier_plot') + end associate return @@ -1615,98 +1893,110 @@ subroutine internal_xsf_format() 201 format(a, '_', i5.5, '.xsf') - ! this is to create the WF...xsf output, to be read by XCrySDen - ! (coordinates + isosurfaces) - - x_0ang = -real(((ngs(1))/2)*ngx + 1, dp)/real(ngx, dp)*real_lattice(1, 1) - & - real(((ngs(2))/2)*ngy + 1, dp)/real(ngy, dp)*real_lattice(2, 1) - & - real(((ngs(3))/2)*ngz + 1, dp)/real(ngz, dp)*real_lattice(3, 1) - y_0ang = -real(((ngs(1))/2)*ngx + 1, dp)/real(ngx, dp)*real_lattice(1, 2) - & - real(((ngs(2))/2)*ngy + 1, dp)/real(ngy, dp)*real_lattice(2, 2) - & - real(((ngs(3))/2)*ngz + 1, dp)/real(ngz, dp)*real_lattice(3, 2) - z_0ang = -real(((ngs(1))/2)*ngx + 1, dp)/real(ngx, dp)*real_lattice(1, 3) - & - real(((ngs(2))/2)*ngy + 1, dp)/real(ngy, dp)*real_lattice(2, 3) - & - real(((ngs(3))/2)*ngz + 1, dp)/real(ngz, dp)*real_lattice(3, 3) - - fxcry(1) = real(ngs(1)*ngx - 1, dp)/real(ngx, dp) - fxcry(2) = real(ngs(2)*ngy - 1, dp)/real(ngy, dp) - fxcry(3) = real(ngs(3)*ngz - 1, dp)/real(ngz, dp) - do j = 1, 3 - dirl(:, j) = fxcry(:)*real_lattice(:, j) - end do + associate (ngs=>wannier_plot%supercell) + + ! this is to create the WF...xsf output, to be read by XCrySDen + ! (coordinates + isosurfaces) + + x_0ang = -real(((ngs(1))/2)*ngx + 1, dp)/real(ngx, dp)*real_lattice(1, 1) - & + real(((ngs(2))/2)*ngy + 1, dp)/real(ngy, dp)*real_lattice(2, 1) - & + real(((ngs(3))/2)*ngz + 1, dp)/real(ngz, dp)*real_lattice(3, 1) + y_0ang = -real(((ngs(1))/2)*ngx + 1, dp)/real(ngx, dp)*real_lattice(1, 2) - & + real(((ngs(2))/2)*ngy + 1, dp)/real(ngy, dp)*real_lattice(2, 2) - & + real(((ngs(3))/2)*ngz + 1, dp)/real(ngz, dp)*real_lattice(3, 2) + z_0ang = -real(((ngs(1))/2)*ngx + 1, dp)/real(ngx, dp)*real_lattice(1, 3) - & + real(((ngs(2))/2)*ngy + 1, dp)/real(ngy, dp)*real_lattice(2, 3) - & + real(((ngs(3))/2)*ngz + 1, dp)/real(ngz, dp)*real_lattice(3, 3) + + fxcry(1) = real(ngs(1)*ngx - 1, dp)/real(ngx, dp) + fxcry(2) = real(ngs(2)*ngy - 1, dp)/real(ngy, dp) + fxcry(3) = real(ngs(3)*ngz - 1, dp)/real(ngz, dp) + do j = 1, 3 + dirl(:, j) = fxcry(:)*real_lattice(:, j) + end do - do loop_b = 1, num_wannier_plot + do loop_b = 1, wann_plot_num - write (wanxsf, 201) trim(seedname), wannier_plot_list(loop_b) + write (wanxsf, 201) trim(seedname), wannier_plot%list(loop_b) - file_unit = io_file_unit() - open (unit=file_unit, file=trim(wanxsf), form='formatted', status='unknown') - write (file_unit, *) ' #' - write (file_unit, *) ' # Generated by the Wannier90 code http://www.wannier.org' - write (file_unit, *) ' # On ', cdate, ' at ', ctime - write (file_unit, *) ' #' - ! should pass this into the code - if (index(wannier_plot_mode, 'mol') > 0) then - write (file_unit, '("ATOMS")') - else - write (file_unit, '("CRYSTAL")') - write (file_unit, '("PRIMVEC")') - write (file_unit, '(3f12.7)') real_lattice(1, 1), real_lattice(1, 2), real_lattice(1, 3) - write (file_unit, '(3f12.7)') real_lattice(2, 1), real_lattice(2, 2), real_lattice(2, 3) - write (file_unit, '(3f12.7)') real_lattice(3, 1), real_lattice(3, 2), real_lattice(3, 3) - write (file_unit, '("CONVVEC")') - write (file_unit, '(3f12.7)') real_lattice(1, 1), real_lattice(1, 2), real_lattice(1, 3) - write (file_unit, '(3f12.7)') real_lattice(2, 1), real_lattice(2, 2), real_lattice(2, 3) - write (file_unit, '(3f12.7)') real_lattice(3, 1), real_lattice(3, 2), real_lattice(3, 3) - write (file_unit, '("PRIMCOORD")') - write (file_unit, '(i6," 1")') num_atoms - endif - do nsp = 1, num_species - do nat = 1, atoms_species_num(nsp) - write (file_unit, '(a2,3x,3f12.7)') atoms_symbol(nsp), (atoms_pos_cart(i, nat, nsp), i=1, 3) + file_unit = io_file_unit() + open (unit=file_unit, file=trim(wanxsf), form='formatted', status='unknown') + write (file_unit, *) ' #' + write (file_unit, *) ' # Generated by the Wannier90 code http://www.wannier.org' + write (file_unit, *) ' # On ', cdate, ' at ', ctime + write (file_unit, *) ' #' + ! should pass this into the code + if (index(wannier_plot%mode, 'mol') > 0) then + write (file_unit, '("ATOMS")') + else + write (file_unit, '("CRYSTAL")') + write (file_unit, '("PRIMVEC")') + write (file_unit, '(3f12.7)') real_lattice(1, 1), real_lattice(1, 2), real_lattice(1, 3) + write (file_unit, '(3f12.7)') real_lattice(2, 1), real_lattice(2, 2), real_lattice(2, 3) + write (file_unit, '(3f12.7)') real_lattice(3, 1), real_lattice(3, 2), real_lattice(3, 3) + write (file_unit, '("CONVVEC")') + write (file_unit, '(3f12.7)') real_lattice(1, 1), real_lattice(1, 2), real_lattice(1, 3) + write (file_unit, '(3f12.7)') real_lattice(2, 1), real_lattice(2, 2), real_lattice(2, 3) + write (file_unit, '(3f12.7)') real_lattice(3, 1), real_lattice(3, 2), real_lattice(3, 3) + write (file_unit, '("PRIMCOORD")') + write (file_unit, '(i6," 1")') atom_data%num_atoms + endif + do nsp = 1, atom_data%num_species + do nat = 1, atom_data%species_num(nsp) + write (file_unit, '(a2,3x,3f12.7)') atom_data%symbol(nsp), (atom_data%pos_cart(i, nat, nsp), i=1, 3) + end do end do - end do - write (file_unit, '(/)') - write (file_unit, '("BEGIN_BLOCK_DATAGRID_3D",/,"3D_field",/, "BEGIN_DATAGRID_3D_UNKNOWN")') - write (file_unit, '(3i6)') ngs(1)*ngx, ngs(2)*ngy, ngs(3)*ngz - write (file_unit, '(3f12.6)') x_0ang, y_0ang, z_0ang - write (file_unit, '(3f12.7)') dirl(1, 1), dirl(1, 2), dirl(1, 3) - write (file_unit, '(3f12.7)') dirl(2, 1), dirl(2, 2), dirl(2, 3) - write (file_unit, '(3f12.7)') dirl(3, 1), dirl(3, 2), dirl(3, 3) - write (file_unit, '(6e13.5)') & - (((real(wann_func(nx, ny, nz, loop_b)), nx=-((ngs(1))/2)*ngx, ((ngs(1) + 1)/2)*ngx - 1), & - ny=-((ngs(2))/2)*ngy, ((ngs(2) + 1)/2)*ngy - 1), nz=-((ngs(3))/2)*ngz, ((ngs(3) + 1)/2)*ngz - 1) - write (file_unit, '("END_DATAGRID_3D",/, "END_BLOCK_DATAGRID_3D")') - close (file_unit) + write (file_unit, '(/)') + write (file_unit, '("BEGIN_BLOCK_DATAGRID_3D",/,"3D_field",/, "BEGIN_DATAGRID_3D_UNKNOWN")') + write (file_unit, '(3i6)') ngs(1)*ngx, ngs(2)*ngy, ngs(3)*ngz + write (file_unit, '(3f12.6)') x_0ang, y_0ang, z_0ang + write (file_unit, '(3f12.7)') dirl(1, 1), dirl(1, 2), dirl(1, 3) + write (file_unit, '(3f12.7)') dirl(2, 1), dirl(2, 2), dirl(2, 3) + write (file_unit, '(3f12.7)') dirl(3, 1), dirl(3, 2), dirl(3, 3) + write (file_unit, '(6e13.5)') & + (((real(wann_func(nx, ny, nz, loop_b)), nx=-((ngs(1))/2)*ngx, ((ngs(1) + 1)/2)*ngx - 1), & + ny=-((ngs(2))/2)*ngy, ((ngs(2) + 1)/2)*ngy - 1), nz=-((ngs(3))/2)*ngz, ((ngs(3) + 1)/2)*ngz - 1) + write (file_unit, '("END_DATAGRID_3D",/, "END_BLOCK_DATAGRID_3D")') + close (file_unit) - end do + end do + end associate return - end subroutine internal_xsf_format end subroutine plot_wannier - !============================================! - subroutine plot_u_matrices - !============================================! - ! ! + !================================================! + subroutine plot_u_matrices(u_matrix_opt, u_matrix, kpt_latt, have_disentangled, & + num_wann, num_kpts, num_bands, seedname) + !================================================! + ! !! Plot u_matrix and u_matrix_opt to textfiles in readable format - ! ! - !============================================! + ! + !================================================! - use w90_parameters, only: num_bands, num_kpts, num_wann, have_disentangled, & - kpt_latt, u_matrix, u_matrix_opt - use w90_io, only: io_error, stdout, io_file_unit, seedname, & - io_time, io_stopwatch, io_date + use w90_io, only: io_error, io_file_unit, io_time, io_stopwatch, io_date + use w90_constants, only: dp implicit none + + real(kind=dp), intent(in) :: kpt_latt(:, :) + integer :: matunit integer :: i, j, nkp character(len=33) :: header character(len=9) :: cdate, ctime + integer, intent(in) :: num_wann + integer, intent(in) :: num_kpts + integer, intent(in) :: num_bands + complex(kind=dp), intent(in) :: u_matrix_opt(:, :, :) + complex(kind=dp), intent(in) :: u_matrix(:, :, :) + logical, intent(in) :: have_disentangled + character(len=50), intent(in) :: seedname + call io_date(cdate, ctime) header = 'written on '//cdate//' at '//ctime @@ -1738,23 +2028,30 @@ subroutine plot_u_matrices end subroutine plot_u_matrices - !============================================! - subroutine plot_bvec() - !! + !================================================! + subroutine plot_bvec(kmesh_info, num_kpts, stdout, seedname) + !================================================! !! June 2018: RM and SP !! Write to file the matrix elements of bvector and their weights !! This is used by EPW to compute the velocity. !! You need "write_bvec = .true." in your wannier input !! - !============================================! - use w90_parameters, only: wb, bk, num_kpts, nntot - use w90_io, only: io_error, io_file_unit, seedname, io_date - ! + !================================================! + + use w90_io, only: io_error, io_file_unit, io_date + use w90_constants, only: dp + use w90_types, only: kmesh_info_type + implicit none - ! + + type(kmesh_info_type), intent(in) :: kmesh_info + integer, intent(in) :: stdout integer :: nkp, nn, file_unit character(len=33) :: header character(len=9) :: cdate, ctime + + integer, intent(in) :: num_kpts + character(len=50), intent(in) :: seedname ! file_unit = io_file_unit() call io_date(cdate, ctime) @@ -1762,17 +2059,17 @@ subroutine plot_bvec() ! open (file_unit, file=trim(seedname)//'.bvec', form='formatted', status='unknown', err=101) write (file_unit, *) header ! Date and time - write (file_unit, *) num_kpts, nntot + write (file_unit, *) num_kpts, kmesh_info%nntot do nkp = 1, num_kpts - do nn = 1, nntot - write (file_unit, '(4F14.8)') bk(:, nn, nkp), wb(nn) + do nn = 1, kmesh_info%nntot + write (file_unit, '(4F14.8)') kmesh_info%bk(:, nn, nkp), kmesh_info%wb(nn) enddo enddo close (file_unit) ! return ! -101 call io_error('Error: plot_bvec: problem opening file '//trim(seedname)//'.bvec') +101 call io_error('Error: plot_bvec: problem opening file '//trim(seedname)//'.bvec', stdout, seedname) end subroutine plot_bvec diff --git a/src/postw90/berry.F90 b/src/postw90/berry.F90 index 5d7d7fc28..8e7dfd75e 100644 --- a/src/postw90/berry.F90 +++ b/src/postw90/berry.F90 @@ -11,10 +11,13 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! - -! --------------------------------------------------------------- +! ! +! w90_berry: computes Berry phase and related properties ! +! ! +!------------------------------------------------------------! module w90_berry + !! This module computes various "Berry phase" related properties !! !! Key REFERENCES @@ -38,8 +41,11 @@ module w90_berry private - public :: berry_main, berry_get_imf_klist, berry_get_imfgh_klist, berry_get_sc_klist, & - berry_get_shc_klist, berry_get_kdotp!, berry_alpha_S, berry_alpha_beta_S, berry_beta_S + public :: berry_get_imfgh_klist + public :: berry_get_imf_klist + public :: berry_get_kdotp + public :: berry_get_shc_klist + public :: berry_main ! Pseudovector <--> Antisymmetric tensor ! @@ -48,7 +54,7 @@ module w90_berry ! z <--> (x,y) ! integer, dimension(3), parameter :: alpha_A = (/2, 3, 1/) - integer, dimension(3), parameter :: beta_A = (/3, 1, 2/) + integer, dimension(3), parameter :: beta_A = (/3, 1, 2/) ! Independent components of a symmetric tensor ! @@ -60,66 +66,109 @@ module w90_berry ! 6 <--> yz ! integer, dimension(6), parameter :: alpha_S = (/1, 2, 3, 1, 1, 2/) - integer, dimension(6), parameter :: beta_S = (/1, 2, 3, 2, 3, 3/) + integer, dimension(6), parameter :: beta_S = (/1, 2, 3, 2, 3, 3/) integer, dimension(6), parameter, public :: berry_alpha_S = alpha_S integer, dimension(6), parameter, public:: berry_beta_S = beta_S -! integer, dimension(3,3) , parameter, public:: berry_alpha_beta_S= (/ (/1,4,5/), (/ 4,2,6 /) , (/ 5,6,3 /) /) - integer, parameter, public:: berry_alpha_beta_S(3, 3) = reshape((/1, 4, 5, 4, 2, 6, 5, 6, 3/), (/3, 3/)) -!(/ (/1,4,5/), (/ 4,2,6 /) , (/ 5,6,3 /) /) + integer, parameter, public:: berry_alpha_beta_S(3, 3) = & + reshape((/1, 4, 5, 4, 2, 6, 5, 6, 3/), (/3, 3/)) contains - !===========================================================! - ! PUBLIC PROCEDURES ! - !===========================================================! - - subroutine berry_main - !============================================================! - ! ! + !================================================! + ! PUBLIC PROCEDURES + !================================================! + subroutine berry_main(pw90_berry, dis_manifold, fermi_energy_list, kmesh_info, kpoint_dist, & + kpt_latt, pw90_band_deriv_degen, pw90_oper_read, pw90_spin, physics, & + ws_region, pw90_spin_hall, wannier_data, ws_distance, wigner_seitz, & + print_output, AA_R, BB_R, CC_R, HH_R, SH_R, SHR_R, SR_R, SS_R, SAA_R, & + SBB_R, u_matrix, v_matrix, eigval, real_lattice, scissors_shift, mp_grid, & + fermi_n, num_wann, num_kpts, num_bands, num_valence_bands, & + effective_model, have_disentangled, spin_decomp, seedname, stdout, comm) + !================================================! + ! !! Computes the following quantities: !! (i) Anomalous Hall conductivity (from Berry curvature) !! (ii) Complex optical conductivity (Kubo-Greenwood) & JDOS !! (iii) Orbital magnetization !! (iv) Nonlinear shift current !! (v) Spin Hall conductivity - ! ! - !============================================================! - - use w90_constants, only: dp, cmplx_0, cmplx_i, elem_charge_SI, hbar_SI, & - eV_au, bohr, pi, eV_seconds - use w90_comms, only: on_root, num_nodes, my_node_id, comms_reduce - use w90_io, only: io_error, stdout, io_file_unit, seedname, & - io_stopwatch - use w90_postw90_common, only: nrpts, irvec, num_int_kpts_on_node, int_kpts, & - weight - use w90_parameters, only: timing_level, iprint, num_wann, berry_kmesh, & - berry_curv_adpt_kmesh, & - berry_curv_adpt_kmesh_thresh, & - wanint_kpoint_file, cell_volume, transl_inv, & - berry_task, berry_curv_unit, spin_decomp, & - kubo_nfreq, kubo_freq_list, nfermi, & - fermi_energy_list, shc_freq_scan, & - kubo_adpt_smr, kubo_adpt_smr_fac, & - kubo_adpt_smr_max, kubo_smr_fixed_en_width, & - scissors_shift, num_valence_bands, & - shc_bandshift, shc_bandshift_firstband, shc_bandshift_energyshift, shc_method, & - kdotp_kpoint, kdotp_num_bands, kdotp_bands - use w90_get_oper, only: get_HH_R, get_AA_R, get_BB_R, get_CC_R, & - get_SS_R, get_SHC_R, get_SAA_R, get_SBB_R - - real(kind=dp), allocatable :: adkpt(:, :) + ! + !================================================! + + use w90_comms, only: comms_reduce, w90comm_type, mpirank, mpisize + use w90_constants, only: dp, cmplx_0, pi, pw90_physical_constants_type + use w90_utility, only: utility_recip_lattice_base + use w90_get_oper, only: get_HH_R, get_AA_R, get_BB_R, get_CC_R, get_SS_R, get_SHC_R, & + get_SAA_R, get_SBB_R + use w90_io, only: io_error, io_file_unit, io_stopwatch + use w90_types, only: print_output_type, wannier_data_type, & + dis_manifold_type, kmesh_info_type, ws_region_type, ws_distance_type + use w90_postw90_types, only: pw90_berry_mod_type, pw90_spin_mod_type, & + pw90_spin_hall_type, pw90_band_deriv_degen_type, pw90_oper_read_type, wigner_seitz_type, & + kpoint_dist_type + + implicit none + + ! arguments + type(pw90_berry_mod_type), intent(inout) :: pw90_berry + type(dis_manifold_type), intent(in) :: dis_manifold + type(kmesh_info_type), intent(in) :: kmesh_info + type(kpoint_dist_type), intent(in) :: kpoint_dist + type(pw90_band_deriv_degen_type), intent(in) :: pw90_band_deriv_degen + type(pw90_oper_read_type), intent(in) :: pw90_oper_read + type(pw90_spin_mod_type), intent(in) :: pw90_spin + type(print_output_type), intent(in) :: print_output + type(pw90_physical_constants_type), intent(in) :: physics + type(ws_region_type), intent(in) :: ws_region + type(pw90_spin_hall_type), intent(in) :: pw90_spin_hall + type(w90comm_type), intent(in) :: comm + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + complex(kind=dp), allocatable, intent(inout) :: AA_R(:, :, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: BB_R(:, :, :, :) ! <0|H(r-R)|R> + complex(kind=dp), allocatable, intent(inout) :: CC_R(:, :, :, :, :) ! <0|r_alpha.H(r-R)_beta|R> + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: SH_R(:, :, :, :) ! <0n|sigma_x,y,z.H|Rm> + complex(kind=dp), allocatable, intent(inout) :: SHR_R(:, :, :, :, :) ! <0n|sigma_x,y,z.H.(r-R)_alpha|Rm> + complex(kind=dp), allocatable, intent(inout) :: SR_R(:, :, :, :, :) ! <0n|sigma_x,y,z.(r-R)_alpha|Rm> + complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) ! <0n|sigma_x,y,z|Rm> + !spin Hall using Ryoo's method + complex(kind=dp), allocatable, intent(inout) :: SAA_R(:, :, :, :, :) ! <0n|sigma_x,y,z.(r-R)_alpha|Rm> + !! $$\langle 0n | \sigma_{x,y,z}.(\hat{r}-R)_{\alpha} | Rm \rangle$$ + complex(kind=dp), allocatable, intent(inout) :: SBB_R(:, :, :, :, :) ! <0n|sigma_x,y,z.H.(r-R)_alpha|Rm> + !! $$\langle 0n | \sigma_{x,y,z}.H.(\hat{r}-R)_{\alpha} | Rm \rangle$$ + complex(kind=dp), intent(in) :: u_matrix(:, :, :), v_matrix(:, :, :) + + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: scissors_shift + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + real(kind=dp), intent(in) :: kpt_latt(:, :) + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_wann, num_kpts, num_bands, num_valence_bands, fermi_n + integer, intent(in) :: stdout + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + logical, intent(in) :: spin_decomp + logical, intent(in) :: effective_model + + ! local variables + real(kind=dp), allocatable :: adkpt(:, :) ! AHC and orbital magnetization, calculated for a list of Fermi levels ! ! First index labels J0,J1,J2 terms, second labels the Cartesian component ! - real(kind=dp) :: imf_k_list(3, 3, nfermi), imf_list(3, 3, nfermi), imf_list2(3, 3, nfermi) - real(kind=dp) :: img_k_list(3, 3, nfermi), img_list(3, 3, nfermi) - real(kind=dp) :: imh_k_list(3, 3, nfermi), imh_list(3, 3, nfermi) - real(kind=dp) :: ahc_list(3, 3, nfermi) - real(kind=dp) :: LCtil_list(3, 3, nfermi), ICtil_list(3, 3, nfermi), & - Morb_list(3, 3, nfermi) - real(kind=dp) :: imf_k_list_dummy(3, 3, nfermi) ! adaptive refinement of AHC + real(kind=dp) :: imf_k_list(3, 3, fermi_n), imf_list(3, 3, fermi_n), imf_list2(3, 3, fermi_n) + real(kind=dp) :: img_k_list(3, 3, fermi_n), img_list(3, 3, fermi_n) + real(kind=dp) :: imh_k_list(3, 3, fermi_n), imh_list(3, 3, fermi_n) + real(kind=dp) :: ahc_list(3, 3, fermi_n) + real(kind=dp) :: LCtil_list(3, 3, fermi_n), ICtil_list(3, 3, fermi_n), Morb_list(3, 3, fermi_n) + real(kind=dp) :: imf_k_list_dummy(3, 3, fermi_n) ! adaptive refinement of AHC ! shift current real(kind=dp), allocatable :: sc_k_list(:, :, :) real(kind=dp), allocatable :: sc_list(:, :, :) @@ -147,32 +196,45 @@ subroutine berry_main real(kind=dp), allocatable :: jdos_spn(:, :) ! Spin Hall conductivity - real(kind=dp), allocatable :: shc_fermi(:), shc_k_fermi(:) + real(kind=dp), allocatable :: shc_fermi(:), shc_k_fermi(:) complex(kind=dp), allocatable :: shc_freq(:), shc_k_freq(:) ! for fermi energy scan, adaptive kmesh - real(kind=dp), allocatable :: shc_k_fermi_dummy(:) + real(kind=dp), allocatable :: shc_k_fermi_dummy(:) + + real(kind=dp) :: cell_volume + real(kind=dp) :: kweight, kweight_adpt, kpt(3), db1, db2, db3, fac, rdum, vdum(3) + + integer :: n, i, j, k, jk, ikpt, if, ierr, loop_x, loop_y, loop_z, kdotp_nbands + integer :: loop_xyz, loop_adpt, adpt_counter_list(fermi_n), ifreq, file_unit + integer :: my_node_id, num_nodes - real(kind=dp) :: kweight, kweight_adpt, kpt(3), kpt_ad(3), & - db1, db2, db3, fac, freq, rdum, vdum(3) - integer :: n, i, j, k, jk, ikpt, if, ispn, ierr, loop_x, loop_y, loop_z, & - loop_xyz, loop_adpt, adpt_counter_list(nfermi), ifreq, & - file_unit character(len=120) :: file_name - logical :: eval_ahc, eval_morb, eval_kubo, not_scannable, eval_sc, eval_shc, & - eval_kdotp - logical :: ladpt_kmesh - logical :: ladpt(nfermi) - if (nfermi == 0) call io_error( & - 'Must specify one or more Fermi levels when berry=true') + logical :: eval_ahc, eval_morb, eval_kubo, not_scannable, eval_sc, eval_shc, eval_kdotp + logical :: ladpt_kmesh + logical :: ladpt(fermi_n) + + my_node_id = mpirank(comm) + num_nodes = mpisize(comm) - if (timing_level > 1 .and. on_root) call io_stopwatch('berry: prelims', 1) + if (fermi_n == 0) call io_error( & + 'Must specify one or more Fermi levels when berry=true', stdout, seedname) + + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('berry: prelims', 1, stdout, seedname) + + cell_volume = real_lattice(1, 1)*(real_lattice(2, 2)*real_lattice(3, 3) - & + real_lattice(3, 2)*real_lattice(2, 3)) + & + real_lattice(1, 2)*(real_lattice(2, 3)*real_lattice(3, 1) - & + real_lattice(3, 3)*real_lattice(2, 1)) + & + real_lattice(1, 3)*(real_lattice(2, 1)*real_lattice(3, 2) - & + real_lattice(3, 1)*real_lattice(2, 2)) ! Mesh spacing in reduced coordinates ! - db1 = 1.0_dp/real(berry_kmesh(1), dp) - db2 = 1.0_dp/real(berry_kmesh(2), dp) - db3 = 1.0_dp/real(berry_kmesh(3), dp) + db1 = 1.0_dp/real(pw90_berry%kmesh%mesh(1), dp) + db2 = 1.0_dp/real(pw90_berry%kmesh%mesh(2), dp) + db3 = 1.0_dp/real(pw90_berry%kmesh%mesh(3), dp) eval_ahc = .false. eval_morb = .false. @@ -180,27 +242,42 @@ subroutine berry_main eval_sc = .false. eval_shc = .false. eval_kdotp = .false. - if (index(berry_task, 'ahc') > 0) eval_ahc = .true. - if (index(berry_task, 'morb') > 0) eval_morb = .true. - if (index(berry_task, 'kubo') > 0) eval_kubo = .true. - if (index(berry_task, 'sc') > 0) eval_sc = .true. - if (index(berry_task, 'shc') > 0) eval_shc = .true. - if (index(berry_task, 'kdotp') > 0) eval_kdotp = .true. + + if (index(pw90_berry%task, 'ahc') > 0) eval_ahc = .true. + if (index(pw90_berry%task, 'morb') > 0) eval_morb = .true. + if (index(pw90_berry%task, 'kubo') > 0) eval_kubo = .true. + if (index(pw90_berry%task, 'sc') > 0) eval_sc = .true. + if (index(pw90_berry%task, 'shc') > 0) eval_shc = .true. + if (index(pw90_berry%task, 'kdotp') > 0) eval_kdotp = .true. ! Wannier matrix elements, allocations and initializations ! if (eval_ahc) then - call get_HH_R - call get_AA_R + call get_HH_R(dis_manifold, kpt_latt, print_output, wigner_seitz, HH_R, u_matrix, v_matrix, & + eigval, real_lattice, scissors_shift, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, seedname, stdout, comm) + call get_AA_R(pw90_berry, dis_manifold, kmesh_info, kpt_latt, print_output, AA_R, HH_R, & + v_matrix, eigval, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, & + num_wann, effective_model, have_disentangled, seedname, stdout, comm) imf_list = 0.0_dp adpt_counter_list = 0 endif if (eval_morb) then - call get_HH_R - call get_AA_R - call get_BB_R - call get_CC_R + call get_HH_R(dis_manifold, kpt_latt, print_output, wigner_seitz, HH_R, u_matrix, v_matrix, & + eigval, real_lattice, scissors_shift, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, seedname, stdout, comm) + call get_AA_R(pw90_berry, dis_manifold, kmesh_info, kpt_latt, print_output, AA_R, HH_R, & + v_matrix, eigval, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, & + num_wann, effective_model, have_disentangled, seedname, stdout, comm) + call get_BB_R(dis_manifold, kmesh_info, kpt_latt, print_output, BB_R, v_matrix, eigval, & + scissors_shift, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, & + num_wann, have_disentangled, seedname, stdout, comm) + + call get_CC_R(dis_manifold, kmesh_info, kpt_latt, print_output, pw90_oper_read, CC_R, & + v_matrix, eigval, scissors_shift, wigner_seitz%irvec, wigner_seitz%nrpts, & + num_bands, num_kpts, num_wann, have_disentangled, seedname, stdout, comm) + imf_list2 = 0.0_dp img_list = 0.0_dp imh_list = 0.0_dp @@ -208,31 +285,38 @@ subroutine berry_main ! List here berry_tasks that assume nfermi=1 ! - not_scannable = eval_kubo .or. (eval_shc .and. shc_freq_scan) - if (not_scannable .and. nfermi .ne. 1) call io_error( & + not_scannable = eval_kubo .or. (eval_shc .and. pw90_spin_hall%freq_scan) + if (not_scannable .and. fermi_n .ne. 1) call io_error( & 'The berry_task(s) you chose require that you specify a single ' & - //'Fermi energy: scanning the Fermi energy is not implemented') + //'Fermi energy: scanning the Fermi energy is not implemented', stdout, seedname) if (eval_kubo) then - call get_HH_R - call get_AA_R - allocate (kubo_H_k(3, 3, kubo_nfreq)) - allocate (kubo_H(3, 3, kubo_nfreq)) - allocate (kubo_AH_k(3, 3, kubo_nfreq)) - allocate (kubo_AH(3, 3, kubo_nfreq)) - allocate (jdos_k(kubo_nfreq)) - allocate (jdos(kubo_nfreq)) + call get_HH_R(dis_manifold, kpt_latt, print_output, wigner_seitz, HH_R, u_matrix, v_matrix, & + eigval, real_lattice, scissors_shift, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, seedname, stdout, comm) + call get_AA_R(pw90_berry, dis_manifold, kmesh_info, kpt_latt, print_output, AA_R, HH_R, & + v_matrix, eigval, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, & + num_wann, effective_model, have_disentangled, seedname, stdout, comm) + allocate (kubo_H_k(3, 3, pw90_berry%kubo_nfreq)) + allocate (kubo_H(3, 3, pw90_berry%kubo_nfreq)) + allocate (kubo_AH_k(3, 3, pw90_berry%kubo_nfreq)) + allocate (kubo_AH(3, 3, pw90_berry%kubo_nfreq)) + allocate (jdos_k(pw90_berry%kubo_nfreq)) + allocate (jdos(pw90_berry%kubo_nfreq)) kubo_H = cmplx_0 kubo_AH = cmplx_0 jdos = 0.0_dp if (spin_decomp) then - call get_SS_R - allocate (kubo_H_k_spn(3, 3, 3, kubo_nfreq)) - allocate (kubo_H_spn(3, 3, 3, kubo_nfreq)) - allocate (kubo_AH_k_spn(3, 3, 3, kubo_nfreq)) - allocate (kubo_AH_spn(3, 3, 3, kubo_nfreq)) - allocate (jdos_k_spn(3, kubo_nfreq)) - allocate (jdos_spn(3, kubo_nfreq)) + + call get_SS_R(dis_manifold, kpt_latt, print_output, pw90_oper_read, SS_R, v_matrix, & + eigval, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, & + num_wann, have_disentangled, seedname, stdout, comm) + allocate (kubo_H_k_spn(3, 3, 3, pw90_berry%kubo_nfreq)) + allocate (kubo_H_spn(3, 3, 3, pw90_berry%kubo_nfreq)) + allocate (kubo_AH_k_spn(3, 3, 3, pw90_berry%kubo_nfreq)) + allocate (kubo_AH_spn(3, 3, 3, pw90_berry%kubo_nfreq)) + allocate (jdos_k_spn(3, pw90_berry%kubo_nfreq)) + allocate (jdos_spn(3, pw90_berry%kubo_nfreq)) kubo_H_spn = cmplx_0 kubo_AH_spn = cmplx_0 jdos_spn = 0.0_dp @@ -240,34 +324,53 @@ subroutine berry_main endif if (eval_sc) then - call get_HH_R - call get_AA_R - allocate (sc_k_list(3, 6, kubo_nfreq)) - allocate (sc_list(3, 6, kubo_nfreq)) + call get_HH_R(dis_manifold, kpt_latt, print_output, wigner_seitz, HH_R, u_matrix, v_matrix, & + eigval, real_lattice, scissors_shift, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, seedname, stdout, comm) + call get_AA_R(pw90_berry, dis_manifold, kmesh_info, kpt_latt, print_output, AA_R, HH_R, & + v_matrix, eigval, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, & + num_wann, effective_model, have_disentangled, seedname, stdout, comm) + allocate (sc_k_list(3, 6, pw90_berry%kubo_nfreq)) + allocate (sc_list(3, 6, pw90_berry%kubo_nfreq)) sc_k_list = 0.0_dp sc_list = 0.0_dp endif if (eval_shc) then - call get_HH_R - call get_AA_R - call get_SS_R - if (index(shc_method, 'qiao') > 0) then - call get_SHC_R + + call get_HH_R(dis_manifold, kpt_latt, print_output, wigner_seitz, HH_R, u_matrix, v_matrix, & + eigval, real_lattice, scissors_shift, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, seedname, stdout, comm) + call get_AA_R(pw90_berry, dis_manifold, kmesh_info, kpt_latt, print_output, AA_R, HH_R, & + v_matrix, eigval, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, & + num_wann, effective_model, have_disentangled, seedname, stdout, comm) + call get_SS_R(dis_manifold, kpt_latt, print_output, pw90_oper_read, SS_R, v_matrix, eigval, & + wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, num_wann, & + have_disentangled, seedname, stdout, comm) + + if (index(pw90_spin_hall%method, 'qiao') > 0) then + call get_SHC_R(dis_manifold, kmesh_info, kpt_latt, print_output, pw90_oper_read, & + pw90_spin_hall, SH_R, SHR_R, SR_R, v_matrix, eigval, scissors_shift, & + wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, num_wann, & + num_valence_bands, have_disentangled, seedname, stdout, comm) else - call get_SAA_R - call get_SBB_R + call get_SAA_R(dis_manifold, kmesh_info, kpt_latt, print_output, SAA_R, v_matrix, eigval, & + scissors_shift, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, num_wann, & + have_disentangled, seedname, stdout, comm) + call get_SBB_R(dis_manifold, kmesh_info, kpt_latt, print_output, SBB_R, v_matrix, eigval, & + scissors_shift, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, num_wann, & + have_disentangled, seedname, stdout, comm) endif - if (shc_freq_scan) then - allocate (shc_freq(kubo_nfreq)) - allocate (shc_k_freq(kubo_nfreq)) + if (pw90_spin_hall%freq_scan) then + allocate (shc_freq(pw90_berry%kubo_nfreq)) + allocate (shc_k_freq(pw90_berry%kubo_nfreq)) shc_freq = 0.0_dp shc_k_freq = 0.0_dp else - allocate (shc_fermi(nfermi)) - allocate (shc_k_fermi(nfermi)) - allocate (shc_k_fermi_dummy(nfermi)) + allocate (shc_fermi(fermi_n)) + allocate (shc_k_fermi(fermi_n)) + allocate (shc_k_fermi_dummy(fermi_n)) shc_fermi = 0.0_dp shc_k_fermi = 0.0_dp !only used for fermiscan & adpt kmesh @@ -278,12 +381,15 @@ subroutine berry_main endif if (eval_kdotp) then - call get_HH_R - allocate (kdotp(kdotp_num_bands, kdotp_num_bands, 3, 3, 3)) + call get_HH_R(dis_manifold, kpt_latt, print_output, wigner_seitz, HH_R, u_matrix, v_matrix, & + eigval, real_lattice, scissors_shift, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, seedname, stdout, comm) + kdotp_nbands = size(pw90_berry%kdotp_bands); + allocate (kdotp(kdotp_nbands, kdotp_nbands, 3, 3, 3)) kdotp = cmplx_0 endif - if (on_root) then + if (print_output%iprint > 0) then write (stdout, '(/,/,1x,a)') & 'Properties calculated in module b e r r y' @@ -312,106 +418,117 @@ subroutine berry_main if (eval_shc) then write (stdout, '(/,3x,a)') '* Spin Hall Conductivity' - if (index(shc_method, 'qiao') > 0) then + if (index(pw90_spin_hall%method, 'qiao') > 0) then write (stdout, '(/,3x,a)') ' Qiao''s SHC (Phys.Rev.B 98.214402)' else write (stdout, '(/,3x,a)') ' Ryoo''s SHC (Phys.Rev.B 99.235113)' endif - if (shc_freq_scan) then + if (pw90_spin_hall%freq_scan) then write (stdout, '(/,3x,a)') ' Frequency scan' else write (stdout, '(/,3x,a)') ' Fermi energy scan' endif endif - if (eval_kdotp) write (stdout, '(/,3x,a)') & - '* k.p expansion coefficients' + if (eval_kdotp) write (stdout, '(/,3x,a)') '* k.p expansion coefficients' - if (transl_inv) then + if (pw90_berry%transl_inv) then if (eval_morb) & - call io_error('transl_inv=T disabled for morb') + call io_error('transl_inv=T disabled for morb', stdout, seedname) write (stdout, '(/,1x,a)') & 'Using a translationally-invariant discretization for the' write (stdout, '(1x,a)') & 'band-diagonal Wannier matrix elements of r, etc.' endif - if (timing_level > 1) then - call io_stopwatch('berry: prelims', 2) - call io_stopwatch('berry: k-interpolation', 1) + if (print_output%timing_level > 1) then + call io_stopwatch('berry: prelims', 2, stdout, seedname) + call io_stopwatch('berry: k-interpolation', 1, stdout, seedname) endif - end if !on_root - - if (eval_kdotp) then - call berry_get_kdotp(kdotp) - end if + if (eval_kdotp) then + ! JJ pw90_berry%kdotp_bands is only allocated on process 0 + ! this causes a segfault at 2895 (accessing nonexistent element zero) + ! moving to process 0 (on_root) only + call berry_get_kdotp(kdotp, dis_manifold, kpt_latt, print_output, pw90_berry, & + pw90_band_deriv_degen, wannier_data, ws_distance, wigner_seitz, & + ws_region, HH_R, u_matrix, v_matrix, eigval, real_lattice, & + scissors_shift, mp_grid, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, seedname, & + stdout, comm) + end if + end if ! print_output%iprint > 0, aka "on_root" ! Set up adaptive refinement mesh ! - allocate (adkpt(3, berry_curv_adpt_kmesh**3), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating adkpt in berry') + allocate (adkpt(3, pw90_berry%curv_adpt_kmesh**3), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating adkpt in berry', stdout, seedname) ikpt = 0 ! ! OLD VERSION (only works correctly for odd grids including original point) ! - ! do i=-(berry_curv_adpt_kmesh-1)/2,(berry_curv_adpt_kmesh-1)/2 - ! do j=-(berry_curv_adpt_kmesh-1)/2,(berry_curv_adpt_kmesh-1)/2 - ! do k=-(berry_curv_adpt_kmesh-1)/2,(berry_curv_adpt_kmesh-1)/2 + ! do i=-(pw90_berry_curv_adpt_kmesh-1)/2,(pw90_berry_curv_adpt_kmesh-1)/2 + ! do j=-(pw90_berry_curv_adpt_kmesh-1)/2,(pw90_berry_curv_adpt_kmesh-1)/2 + ! do k=-(pw90_berry_curv_adpt_kmesh-1)/2,(pw90_berry_curv_adpt_kmesh-1)/2 ! ikpt=ikpt+1 - ! adkpt(1,ikpt)=i*db1/berry_curv_adpt_kmesh - ! adkpt(2,ikpt)=j*db2/berry_curv_adpt_kmesh - ! adkpt(3,ikpt)=k*db3/berry_curv_adpt_kmesh + ! adkpt(1,ikpt)=i*db1/pw90_berry_curv_adpt_kmesh + ! adkpt(2,ikpt)=j*db2/pw90_berry_curv_adpt_kmesh + ! adkpt(3,ikpt)=k*db3/pw90_berry_curv_adpt_kmesh ! end do ! end do ! end do ! ! NEW VERSION (both even and odd grids) ! - do i = 0, berry_curv_adpt_kmesh - 1 - do j = 0, berry_curv_adpt_kmesh - 1 - do k = 0, berry_curv_adpt_kmesh - 1 + do i = 0, pw90_berry%curv_adpt_kmesh - 1 + do j = 0, pw90_berry%curv_adpt_kmesh - 1 + do k = 0, pw90_berry%curv_adpt_kmesh - 1 ikpt = ikpt + 1 - adkpt(1, ikpt) = db1*((i + 0.5_dp)/berry_curv_adpt_kmesh - 0.5_dp) - adkpt(2, ikpt) = db2*((j + 0.5_dp)/berry_curv_adpt_kmesh - 0.5_dp) - adkpt(3, ikpt) = db3*((k + 0.5_dp)/berry_curv_adpt_kmesh - 0.5_dp) + adkpt(1, ikpt) = db1*((i + 0.5_dp)/pw90_berry%curv_adpt_kmesh - 0.5_dp) + adkpt(2, ikpt) = db2*((j + 0.5_dp)/pw90_berry%curv_adpt_kmesh - 0.5_dp) + adkpt(3, ikpt) = db3*((k + 0.5_dp)/pw90_berry%curv_adpt_kmesh - 0.5_dp) end do end do end do ! Loop over interpolation k-points ! - if (wanint_kpoint_file) then + if (pw90_berry%wanint_kpoint_file) then - ! NOTE: still need to specify berry_kmesh in the input file + ! NOTE: still need to specify pw90_berry_kmesh in the input file ! ! - Must use the correct nominal value in order to ! correctly set up adaptive smearing in kubo - if (on_root) write (stdout, '(/,1x,a,i10,a)') & + if (print_output%iprint > 0) write (stdout, '(/,1x,a,i10,a)') & 'Reading interpolation grid from file kpoint.dat: ', & - sum(num_int_kpts_on_node), ' points' + sum(kpoint_dist%num_int_kpts_on_node), ' points' ! Loop over k-points on the irreducible wedge of the Brillouin ! zone, read from file 'kpoint.dat' ! - do loop_xyz = 1, num_int_kpts_on_node(my_node_id) - kpt(:) = int_kpts(:, loop_xyz) - kweight = weight(loop_xyz) - kweight_adpt = kweight/berry_curv_adpt_kmesh**3 + do loop_xyz = 1, kpoint_dist%num_int_kpts_on_node(my_node_id) + kpt(:) = kpoint_dist%int_kpts(:, loop_xyz) + kweight = kpoint_dist%weight(loop_xyz) + kweight_adpt = kweight/pw90_berry%curv_adpt_kmesh**3 ! . ! ***BEGIN COPY OF CODE BLOCK 1*** ! if (eval_ahc) then - call berry_get_imf_klist(kpt, imf_k_list) + call berry_get_imf_klist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, & + print_output, wannier_data, ws_distance, wigner_seitz, AA_R, & + BB_R, CC_R, HH_R, u_matrix, v_matrix, eigval, kpt, & + real_lattice, imf_k_list, scissors_shift, mp_grid, num_bands, & + num_kpts, num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm) ladpt = .false. - do if = 1, nfermi + do if = 1, fermi_n vdum(1) = sum(imf_k_list(:, 1, if)) vdum(2) = sum(imf_k_list(:, 2, if)) vdum(3) = sum(imf_k_list(:, 3, if)) - if (berry_curv_unit == 'bohr2') vdum = vdum/bohr**2 + if (pw90_berry%curv_unit == 'bohr2') vdum = vdum/physics%bohr**2 rdum = sqrt(dot_product(vdum, vdum)) - if (rdum > berry_curv_adpt_kmesh_thresh) then + if (rdum > pw90_berry%curv_adpt_kmesh_thresh) then adpt_counter_list(if) = adpt_counter_list(if) + 1 ladpt(if) = .true. else @@ -419,12 +536,17 @@ subroutine berry_main endif enddo if (any(ladpt)) then - do loop_adpt = 1, berry_curv_adpt_kmesh**3 + do loop_adpt = 1, pw90_berry%curv_adpt_kmesh**3 ! Using imf_k_list here would corrupt values for other ! frequencies, hence dummy. Only if-th element is used - call berry_get_imf_klist(kpt(:) + adkpt(:, loop_adpt), & - imf_k_list_dummy, ladpt=ladpt) - do if = 1, nfermi + call berry_get_imf_klist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, & + print_output, wannier_data, ws_distance, wigner_seitz, & + AA_R, BB_R, CC_R, HH_R, u_matrix, v_matrix, eigval, & + kpt(:) + adkpt(:, loop_adpt), real_lattice, & + imf_k_list_dummy, scissors_shift, mp_grid, num_bands, & + num_kpts, num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm, ladpt=ladpt) + do if = 1, fermi_n if (ladpt(if)) then imf_list(:, :, if) = imf_list(:, :, if) & + imf_k_list_dummy(:, :, if)*kweight_adpt @@ -435,7 +557,13 @@ subroutine berry_main end if if (eval_morb) then - call berry_get_imfgh_klist(kpt, imf_k_list, img_k_list, imh_k_list) + call berry_get_imfgh_klist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, & + print_output, wannier_data, ws_distance, wigner_seitz, AA_R, & + BB_R, CC_R, HH_R, u_matrix, v_matrix, eigval, kpt, & + real_lattice, scissors_shift, mp_grid, fermi_n, num_bands, & + num_kpts, num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm, imf_k_list, & + img_k_list, imh_k_list) imf_list2 = imf_list2 + imf_k_list*kweight img_list = img_list + img_k_list*kweight imh_list = imh_list + imh_k_List*kweight @@ -443,10 +571,22 @@ subroutine berry_main if (eval_kubo) then if (spin_decomp) then - call berry_get_kubo_k(kpt, kubo_H_k, kubo_AH_k, jdos_k, & - kubo_H_k_spn, kubo_AH_k_spn, jdos_k_spn) + call berry_get_kubo_k(pw90_berry, dis_manifold, fermi_energy_list, kpt_latt, & + pw90_band_deriv_degen, pw90_spin, ws_region, print_output, & + wannier_data, ws_distance, wigner_seitz, AA_R, HH_R, kubo_AH_k, & + kubo_H_k, SS_R, u_matrix, v_matrix, eigval, kpt, real_lattice, & + jdos_k, scissors_shift, mp_grid, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, & + spin_decomp, seedname, stdout, comm, kubo_AH_k_spn, & + kubo_H_k_spn, jdos_k_spn) else - call berry_get_kubo_k(kpt, kubo_H_k, kubo_AH_k, jdos_k) + call berry_get_kubo_k(pw90_berry, dis_manifold, fermi_energy_list, kpt_latt, & + pw90_band_deriv_degen, pw90_spin, ws_region, print_output, & + wannier_data, ws_distance, wigner_seitz, AA_R, HH_R, kubo_AH_k, & + kubo_H_k, SS_R, u_matrix, v_matrix, eigval, kpt, real_lattice, & + jdos_k, scissors_shift, mp_grid, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, & + spin_decomp, seedname, stdout, comm) endif kubo_H = kubo_H + kubo_H_k*kweight kubo_AH = kubo_AH + kubo_AH_k*kweight @@ -459,11 +599,15 @@ subroutine berry_main endif if (eval_sc) then - call berry_get_sc_klist(kpt, sc_k_list) + call berry_get_sc_klist(pw90_berry, dis_manifold, fermi_energy_list, kmesh_info, & + kpt_latt, ws_region, print_output, pw90_band_deriv_degen, & + wannier_data, ws_distance, wigner_seitz, AA_R, HH_R, u_matrix, & + v_matrix, eigval, kpt, real_lattice, sc_k_list, scissors_shift, & + mp_grid, num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, stdout, comm) sc_list = sc_list + sc_k_list*kweight end if - ! ! ***END COPY OF CODE BLOCK 1*** if (eval_shc) then @@ -472,9 +616,19 @@ subroutine berry_main ! than later calls due to the time spent on ! berry_get_shc_klist -> wham_get_eig_deleig -> ! pw90common_fourier_R_to_k -> ws_translate_dist - call berry_print_progress(loop_xyz, 1, num_int_kpts_on_node(my_node_id), 1) - if (.not. shc_freq_scan) then - call berry_get_shc_klist(kpt, shc_k_fermi=shc_k_fermi) + if (print_output%iprint > 0) then + call berry_print_progress(kpoint_dist%num_int_kpts_on_node(my_node_id), loop_xyz, & + 1, 1, stdout) + endif + if (.not. pw90_spin_hall%freq_scan) then + call berry_get_shc_klist(pw90_berry, dis_manifold, fermi_energy_list, kpt_latt, & + pw90_band_deriv_degen, ws_region, pw90_spin_hall, & + print_output, wannier_data, ws_distance, wigner_seitz, AA_R, & + HH_R, SH_R, SHR_R, SR_R, SS_R, SAA_R, SBB_R, u_matrix, & + v_matrix, eigval, kpt, real_lattice, scissors_shift, mp_grid, & + fermi_n, num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, stdout, comm, & + shc_k_fermi=shc_k_fermi) !check whether needs to tigger adpt kmesh or not. !Since the calculated shc_k at one Fermi energy can be reused !by all the Fermi energies, if we find out that at a specific @@ -485,11 +639,11 @@ subroutine berry_main ladpt_kmesh = .false. !if adpt_kmesh==1, no need to calculate on the same kpt again. !This happens if adpt_kmesh==1 while adpt_kmesh_thresh is low. - if (berry_curv_adpt_kmesh > 1) then - do if = 1, nfermi + if (pw90_berry%curv_adpt_kmesh > 1) then + do if = 1, fermi_n rdum = abs(shc_k_fermi(if)) - if (berry_curv_unit == 'bohr2') rdum = rdum/bohr**2 - if (rdum > berry_curv_adpt_kmesh_thresh) then + if (pw90_berry%curv_unit == 'bohr2') rdum = rdum/physics%bohr**2 + if (rdum > pw90_berry%curv_adpt_kmesh_thresh) then adpt_counter_list(1) = adpt_counter_list(1) + 1 ladpt_kmesh = .true. exit @@ -499,18 +653,32 @@ subroutine berry_main ladpt_kmesh = .false. end if if (ladpt_kmesh) then - do loop_adpt = 1, berry_curv_adpt_kmesh**3 + do loop_adpt = 1, pw90_berry%curv_adpt_kmesh**3 !Using shc_k here would corrupt values for other !kpt, hence dummy. Only if-th element is used. - call berry_get_shc_klist(kpt(:) + adkpt(:, loop_adpt), & - shc_k_fermi=shc_k_fermi_dummy) + call berry_get_shc_klist(pw90_berry, dis_manifold, fermi_energy_list, kpt_latt, & + pw90_band_deriv_degen, ws_region, pw90_spin_hall, & + print_output, wannier_data, ws_distance, wigner_seitz, & + AA_R, HH_R, SH_R, SHR_R, SR_R, SS_R, SAA_R, SBB_R, & + u_matrix, v_matrix, eigval, kpt(:) + adkpt(:, loop_adpt), & + real_lattice, scissors_shift, mp_grid, fermi_n, & + num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, stdout, & + comm, shc_k_fermi=shc_k_fermi_dummy) shc_fermi = shc_fermi + kweight_adpt*shc_k_fermi_dummy end do else shc_fermi = shc_fermi + kweight*shc_k_fermi end if else ! freq_scan, no adaptive kmesh - call berry_get_shc_klist(kpt, shc_k_freq=shc_k_freq) + call berry_get_shc_klist(pw90_berry, dis_manifold, fermi_energy_list, kpt_latt, & + pw90_band_deriv_degen, ws_region, pw90_spin_hall, & + print_output, wannier_data, ws_distance, wigner_seitz, AA_R, & + HH_R, SH_R, SHR_R, SR_R, SS_R, SAA_R, SBB_R, u_matrix, & + v_matrix, eigval, kpt, real_lattice, scissors_shift, mp_grid, & + fermi_n, num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, stdout, comm, & + shc_k_freq=shc_k_freq) shc_freq = shc_freq + kweight*shc_k_freq end if end if @@ -520,30 +688,35 @@ subroutine berry_main else! Do not read 'kpoint.dat'. Loop over a regular grid in the full BZ kweight = db1*db2*db3 - kweight_adpt = kweight/berry_curv_adpt_kmesh**3 - - do loop_xyz = my_node_id, PRODUCT(berry_kmesh) - 1, num_nodes - loop_x = loop_xyz/(berry_kmesh(2)*berry_kmesh(3)) - loop_y = (loop_xyz - loop_x*(berry_kmesh(2) & - *berry_kmesh(3)))/berry_kmesh(3) - loop_z = loop_xyz - loop_x*(berry_kmesh(2)*berry_kmesh(3)) & - - loop_y*berry_kmesh(3) + kweight_adpt = kweight/pw90_berry%curv_adpt_kmesh**3 + + do loop_xyz = my_node_id, PRODUCT(pw90_berry%kmesh%mesh) - 1, num_nodes + loop_x = loop_xyz/(pw90_berry%kmesh%mesh(2)*pw90_berry%kmesh%mesh(3)) + loop_y = (loop_xyz - loop_x*(pw90_berry%kmesh%mesh(2) & + *pw90_berry%kmesh%mesh(3)))/pw90_berry%kmesh%mesh(3) + loop_z = loop_xyz - loop_x*(pw90_berry%kmesh%mesh(2)*pw90_berry%kmesh%mesh(3)) & + - loop_y*pw90_berry%kmesh%mesh(3) kpt(1) = loop_x*db1 kpt(2) = loop_y*db2 kpt(3) = loop_z*db3 ! ***BEGIN CODE BLOCK 1*** - ! if (eval_ahc) then - call berry_get_imf_klist(kpt, imf_k_list) + + call berry_get_imf_klist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, & + print_output, wannier_data, ws_distance, wigner_seitz, AA_R, & + BB_R, CC_R, HH_R, u_matrix, v_matrix, eigval, kpt, & + real_lattice, imf_k_list, scissors_shift, mp_grid, num_bands, & + num_kpts, num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm) ladpt = .false. - do if = 1, nfermi + do if = 1, fermi_n vdum(1) = sum(imf_k_list(:, 1, if)) vdum(2) = sum(imf_k_list(:, 2, if)) vdum(3) = sum(imf_k_list(:, 3, if)) - if (berry_curv_unit == 'bohr2') vdum = vdum/bohr**2 + if (pw90_berry%curv_unit == 'bohr2') vdum = vdum/physics%bohr**2 rdum = sqrt(dot_product(vdum, vdum)) - if (rdum > berry_curv_adpt_kmesh_thresh) then + if (rdum > pw90_berry%curv_adpt_kmesh_thresh) then adpt_counter_list(if) = adpt_counter_list(if) + 1 ladpt(if) = .true. else @@ -551,12 +724,17 @@ subroutine berry_main endif enddo if (any(ladpt)) then - do loop_adpt = 1, berry_curv_adpt_kmesh**3 + do loop_adpt = 1, pw90_berry%curv_adpt_kmesh**3 ! Using imf_k_list here would corrupt values for other ! frequencies, hence dummy. Only if-th element is used - call berry_get_imf_klist(kpt(:) + adkpt(:, loop_adpt), & - imf_k_list_dummy, ladpt=ladpt) - do if = 1, nfermi + call berry_get_imf_klist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, & + print_output, wannier_data, ws_distance, wigner_seitz, & + AA_R, BB_R, CC_R, HH_R, u_matrix, v_matrix, eigval, & + kpt(:) + adkpt(:, loop_adpt), real_lattice, & + imf_k_list_dummy, scissors_shift, mp_grid, num_bands, & + num_kpts, num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm, ladpt=ladpt) + do if = 1, fermi_n if (ladpt(if)) then imf_list(:, :, if) = imf_list(:, :, if) & + imf_k_list_dummy(:, :, if)*kweight_adpt @@ -567,7 +745,13 @@ subroutine berry_main end if if (eval_morb) then - call berry_get_imfgh_klist(kpt, imf_k_list, img_k_list, imh_k_list) + call berry_get_imfgh_klist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, & + print_output, wannier_data, ws_distance, wigner_seitz, AA_R, & + BB_R, CC_R, HH_R, u_matrix, v_matrix, eigval, kpt, & + real_lattice, scissors_shift, mp_grid, fermi_n, num_bands, & + num_kpts, num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm, imf_k_list, & + img_k_list, imh_k_list) imf_list2 = imf_list2 + imf_k_list*kweight img_list = img_list + img_k_list*kweight imh_list = imh_list + imh_k_List*kweight @@ -575,10 +759,22 @@ subroutine berry_main if (eval_kubo) then if (spin_decomp) then - call berry_get_kubo_k(kpt, kubo_H_k, kubo_AH_k, jdos_k, & - kubo_H_k_spn, kubo_AH_k_spn, jdos_k_spn) + call berry_get_kubo_k(pw90_berry, dis_manifold, fermi_energy_list, kpt_latt, & + pw90_band_deriv_degen, pw90_spin, ws_region, print_output, & + wannier_data, ws_distance, wigner_seitz, AA_R, HH_R, kubo_AH_k, & + kubo_H_k, SS_R, u_matrix, v_matrix, eigval, kpt, real_lattice, & + jdos_k, scissors_shift, mp_grid, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, & + spin_decomp, seedname, stdout, comm, kubo_AH_k_spn, & + kubo_H_k_spn, jdos_k_spn) else - call berry_get_kubo_k(kpt, kubo_H_k, kubo_AH_k, jdos_k) + call berry_get_kubo_k(pw90_berry, dis_manifold, fermi_energy_list, kpt_latt, & + pw90_band_deriv_degen, pw90_spin, ws_region, print_output, & + wannier_data, ws_distance, wigner_seitz, AA_R, HH_R, kubo_AH_k, & + kubo_H_k, SS_R, u_matrix, v_matrix, eigval, kpt, real_lattice, & + jdos_k, scissors_shift, mp_grid, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, & + spin_decomp, seedname, stdout, comm) endif kubo_H = kubo_H + kubo_H_k*kweight kubo_AH = kubo_AH + kubo_AH_k*kweight @@ -591,11 +787,15 @@ subroutine berry_main endif if (eval_sc) then - call berry_get_sc_klist(kpt, sc_k_list) + call berry_get_sc_klist(pw90_berry, dis_manifold, fermi_energy_list, kmesh_info, & + kpt_latt, ws_region, print_output, pw90_band_deriv_degen, & + wannier_data, ws_distance, wigner_seitz, AA_R, HH_R, u_matrix, & + v_matrix, eigval, kpt, real_lattice, sc_k_list, scissors_shift, & + mp_grid, num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, stdout, comm) sc_list = sc_list + sc_k_list*kweight end if - ! ! ***END CODE BLOCK 1*** if (eval_shc) then @@ -604,9 +804,19 @@ subroutine berry_main ! than later calls due to the time spent on ! berry_get_shc_klist -> wham_get_eig_deleig -> ! pw90common_fourier_R_to_k -> ws_translate_dist - call berry_print_progress(loop_xyz, my_node_id, PRODUCT(berry_kmesh) - 1, num_nodes) - if (.not. shc_freq_scan) then - call berry_get_shc_klist(kpt, shc_k_fermi=shc_k_fermi) + if (print_output%iprint > 0) then + call berry_print_progress(PRODUCT(pw90_berry%kmesh%mesh) - 1, loop_xyz, my_node_id, & + num_nodes, stdout) + endif + if (.not. pw90_spin_hall%freq_scan) then + call berry_get_shc_klist(pw90_berry, dis_manifold, fermi_energy_list, kpt_latt, & + pw90_band_deriv_degen, ws_region, pw90_spin_hall, & + print_output, wannier_data, ws_distance, wigner_seitz, AA_R, & + HH_R, SH_R, SHR_R, SR_R, SS_R, SAA_R, SBB_R, u_matrix, & + v_matrix, eigval, kpt, real_lattice, scissors_shift, mp_grid, & + fermi_n, num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, stdout, comm, & + shc_k_fermi=shc_k_fermi) !check whether needs to tigger adpt kmesh or not. !Since the calculated shc_k at one Fermi energy can be reused !by all the Fermi energies, if we find out that at a specific @@ -617,11 +827,11 @@ subroutine berry_main ladpt_kmesh = .false. !if adpt_kmesh==1, no need to calculate on the same kpt again. !This happens if adpt_kmesh==1 while adpt_kmesh_thresh is low. - if (berry_curv_adpt_kmesh > 1) then - do if = 1, nfermi + if (pw90_berry%curv_adpt_kmesh > 1) then + do if = 1, fermi_n rdum = abs(shc_k_fermi(if)) - if (berry_curv_unit == 'bohr2') rdum = rdum/bohr**2 - if (rdum > berry_curv_adpt_kmesh_thresh) then + if (pw90_berry%curv_unit == 'bohr2') rdum = rdum/physics%bohr**2 + if (rdum > pw90_berry%curv_adpt_kmesh_thresh) then adpt_counter_list(1) = adpt_counter_list(1) + 1 ladpt_kmesh = .true. exit @@ -631,18 +841,32 @@ subroutine berry_main ladpt_kmesh = .false. end if if (ladpt_kmesh) then - do loop_adpt = 1, berry_curv_adpt_kmesh**3 + do loop_adpt = 1, pw90_berry%curv_adpt_kmesh**3 !Using shc_k here would corrupt values for other !kpt, hence dummy. Only if-th element is used. - call berry_get_shc_klist(kpt(:) + adkpt(:, loop_adpt), & - shc_k_fermi=shc_k_fermi_dummy) + call berry_get_shc_klist(pw90_berry, dis_manifold, fermi_energy_list, kpt_latt, & + pw90_band_deriv_degen, ws_region, pw90_spin_hall, & + print_output, wannier_data, ws_distance, wigner_seitz, & + AA_R, HH_R, SH_R, SHR_R, SR_R, SS_R, SAA_R, SBB_R, & + u_matrix, v_matrix, eigval, kpt(:) + adkpt(:, loop_adpt), & + real_lattice, scissors_shift, mp_grid, fermi_n, & + num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, & + seedname, stdout, comm, shc_k_fermi=shc_k_fermi_dummy) shc_fermi = shc_fermi + kweight_adpt*shc_k_fermi_dummy end do else shc_fermi = shc_fermi + kweight*shc_k_fermi end if else ! freq_scan, no adaptive kmesh - call berry_get_shc_klist(kpt, shc_k_freq=shc_k_freq) + call berry_get_shc_klist(pw90_berry, dis_manifold, fermi_energy_list, kpt_latt, & + pw90_band_deriv_degen, ws_region, pw90_spin_hall, & + print_output, wannier_data, ws_distance, wigner_seitz, AA_R, & + HH_R, SH_R, SHR_R, SR_R, SS_R, SAA_R, SBB_R, u_matrix, & + v_matrix, eigval, kpt, real_lattice, scissors_shift, mp_grid, & + fermi_n, num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, stdout, comm, & + shc_k_freq=shc_k_freq) shc_freq = shc_freq + kweight*shc_k_freq end if end if @@ -652,127 +876,131 @@ subroutine berry_main end if !wanint_kpoint_file ! Collect contributions from all nodes - ! if (eval_ahc) then - call comms_reduce(imf_list(1, 1, 1), 3*3*nfermi, 'SUM') - call comms_reduce(adpt_counter_list(1), nfermi, 'SUM') + call comms_reduce(imf_list(1, 1, 1), 3*3*fermi_n, 'SUM', stdout, seedname, comm) + call comms_reduce(adpt_counter_list(1), fermi_n, 'SUM', stdout, seedname, comm) endif if (eval_morb) then - call comms_reduce(imf_list2(1, 1, 1), 3*3*nfermi, 'SUM') - call comms_reduce(img_list(1, 1, 1), 3*3*nfermi, 'SUM') - call comms_reduce(imh_list(1, 1, 1), 3*3*nfermi, 'SUM') + call comms_reduce(imf_list2(1, 1, 1), 3*3*fermi_n, 'SUM', stdout, seedname, comm) + call comms_reduce(img_list(1, 1, 1), 3*3*fermi_n, 'SUM', stdout, seedname, comm) + call comms_reduce(imh_list(1, 1, 1), 3*3*fermi_n, 'SUM', stdout, seedname, comm) end if if (eval_kubo) then - call comms_reduce(kubo_H(1, 1, 1), 3*3*kubo_nfreq, 'SUM') - call comms_reduce(kubo_AH(1, 1, 1), 3*3*kubo_nfreq, 'SUM') - call comms_reduce(jdos(1), kubo_nfreq, 'SUM') + call comms_reduce(kubo_H(1, 1, 1), 3*3*pw90_berry%kubo_nfreq, 'SUM', stdout, seedname, comm) + call comms_reduce(kubo_AH(1, 1, 1), 3*3*pw90_berry%kubo_nfreq, 'SUM', stdout, seedname, comm) + call comms_reduce(jdos(1), pw90_berry%kubo_nfreq, 'SUM', stdout, seedname, comm) if (spin_decomp) then - call comms_reduce(kubo_H_spn(1, 1, 1, 1), 3*3*3*kubo_nfreq, 'SUM') - call comms_reduce(kubo_AH_spn(1, 1, 1, 1), 3*3*3*kubo_nfreq, 'SUM') - call comms_reduce(jdos_spn(1, 1), 3*kubo_nfreq, 'SUM') + call comms_reduce(kubo_H_spn(1, 1, 1, 1), 3*3*3*pw90_berry%kubo_nfreq, 'SUM', stdout, & + seedname, comm) + call comms_reduce(kubo_AH_spn(1, 1, 1, 1), 3*3*3*pw90_berry%kubo_nfreq, 'SUM', stdout, & + seedname, comm) + call comms_reduce(jdos_spn(1, 1), 3*pw90_berry%kubo_nfreq, 'SUM', stdout, seedname, comm) endif endif if (eval_sc) then - call comms_reduce(sc_list(1, 1, 1), 3*6*kubo_nfreq, 'SUM') + call comms_reduce(sc_list(1, 1, 1), 3*6*pw90_berry%kubo_nfreq, 'SUM', stdout, seedname, comm) end if if (eval_shc) then - if (shc_freq_scan) then - call comms_reduce(shc_freq(1), kubo_nfreq, 'SUM') + if (pw90_spin_hall%freq_scan) then + call comms_reduce(shc_freq(1), pw90_berry%kubo_nfreq, 'SUM', stdout, seedname, comm) else - call comms_reduce(shc_fermi(1), nfermi, 'SUM') - call comms_reduce(adpt_counter_list(1), nfermi, 'SUM') + call comms_reduce(shc_fermi(1), fermi_n, 'SUM', stdout, seedname, comm) + call comms_reduce(adpt_counter_list(1), fermi_n, 'SUM', stdout, seedname, comm) end if end if - if (on_root) then + if (print_output%iprint > 0) then - if (timing_level > 1) call io_stopwatch('berry: k-interpolation', 2) + if (print_output%timing_level > 1) call io_stopwatch('berry: k-interpolation', 2, stdout, & + seedname) write (stdout, '(1x,a)') ' ' - if (eval_ahc .and. berry_curv_adpt_kmesh .ne. 1) then - if (.not. wanint_kpoint_file) write (stdout, '(1x,a28,3(i0,1x))') & - 'Regular interpolation grid: ', berry_kmesh + if (eval_ahc .and. pw90_berry%curv_adpt_kmesh .ne. 1) then + if (.not. pw90_berry%wanint_kpoint_file) write (stdout, '(1x,a28,3(i0,1x))') & + 'Regular interpolation grid: ', pw90_berry%kmesh%mesh write (stdout, '(1x,a28,3(i0,1x))') 'Adaptive refinement grid: ', & - berry_curv_adpt_kmesh, berry_curv_adpt_kmesh, berry_curv_adpt_kmesh - if (berry_curv_unit == 'ang2') then + pw90_berry%curv_adpt_kmesh, pw90_berry%curv_adpt_kmesh, pw90_berry%curv_adpt_kmesh + if (pw90_berry%curv_unit == 'ang2') then write (stdout, '(1x,a28,a17,f6.2,a)') & 'Refinement threshold: ', 'Berry curvature >', & - berry_curv_adpt_kmesh_thresh, ' Ang^2' - elseif (berry_curv_unit == 'bohr2') then + pw90_berry%curv_adpt_kmesh_thresh, ' Ang^2' + elseif (pw90_berry%curv_unit == 'bohr2') then write (stdout, '(1x,a28,a17,f6.2,a)') & 'Refinement threshold: ', 'Berry curvature >', & - berry_curv_adpt_kmesh_thresh, ' bohr^2' + pw90_berry%curv_adpt_kmesh_thresh, ' bohr^2' endif - if (nfermi == 1) then - if (wanint_kpoint_file) then + if (fermi_n == 1) then + if (pw90_berry%wanint_kpoint_file) then write (stdout, '(1x,a30,i5,a,f5.2,a)') & ' Points triggering refinement: ', & adpt_counter_list(1), '(', & 100*real(adpt_counter_list(1), dp) & - /sum(num_int_kpts_on_node), '%)' + /sum(kpoint_dist%num_int_kpts_on_node), '%)' else write (stdout, '(1x,a30,i5,a,f5.2,a)') & ' Points triggering refinement: ', & adpt_counter_list(1), '(', & - 100*real(adpt_counter_list(1), dp)/product(berry_kmesh), '%)' + 100*real(adpt_counter_list(1), dp)/product(pw90_berry%kmesh%mesh), '%)' endif endif elseif (eval_shc) then - if (berry_curv_adpt_kmesh .ne. 1) then - if (.not. wanint_kpoint_file) write (stdout, '(1x,a28,3(i0,1x))') & - 'Regular interpolation grid: ', berry_kmesh - if (.not. shc_freq_scan) then + if (pw90_berry%curv_adpt_kmesh .ne. 1) then + if (.not. pw90_berry%wanint_kpoint_file) write (stdout, '(1x,a28,3(i0,1x))') & + 'Regular interpolation grid: ', pw90_berry%kmesh%mesh + if (.not. pw90_spin_hall%freq_scan) then write (stdout, '(1x,a28,3(i0,1x))') & 'Adaptive refinement grid: ', & - berry_curv_adpt_kmesh, berry_curv_adpt_kmesh, berry_curv_adpt_kmesh - if (berry_curv_unit == 'ang2') then + pw90_berry%curv_adpt_kmesh, pw90_berry%curv_adpt_kmesh, pw90_berry%curv_adpt_kmesh + if (pw90_berry%curv_unit == 'ang2') then write (stdout, '(1x,a28,f12.2,a)') & 'Refinement threshold: ', & - berry_curv_adpt_kmesh_thresh, ' Ang^2' - elseif (berry_curv_unit == 'bohr2') then + pw90_berry%curv_adpt_kmesh_thresh, ' Ang^2' + elseif (pw90_berry%curv_unit == 'bohr2') then write (stdout, '(1x,a28,f12.2,a)') & 'Refinement threshold: ', & - berry_curv_adpt_kmesh_thresh, ' bohr^2' + pw90_berry%curv_adpt_kmesh_thresh, ' bohr^2' endif - if (wanint_kpoint_file) then + if (pw90_berry%wanint_kpoint_file) then write (stdout, '(1x,a30,i8,a,f6.2,a)') & ' Points triggering refinement: ', adpt_counter_list(1), '(', & - 100*real(adpt_counter_list(1), dp)/sum(num_int_kpts_on_node), '%)' + 100*real(adpt_counter_list(1), dp)/sum(kpoint_dist%num_int_kpts_on_node), '%)' else write (stdout, '(1x,a30,i8,a,f6.2,a)') & ' Points triggering refinement: ', adpt_counter_list(1), '(', & - 100*real(adpt_counter_list(1), dp)/product(berry_kmesh), '%)' + 100*real(adpt_counter_list(1), dp)/product(pw90_berry%kmesh%mesh), '%)' endif endif else - if (.not. wanint_kpoint_file) write (stdout, '(1x,a20,3(i0,1x))') & - 'Interpolation grid: ', berry_kmesh(1:3) + if (.not. pw90_berry%wanint_kpoint_file) write (stdout, & + '(1x,a20,3(i0,1x))') 'Interpolation grid: ', pw90_berry%kmesh%mesh(1:3) endif write (stdout, '(a)') '' - if (kubo_adpt_smr) then + if (pw90_berry%kubo_smearing%use_adaptive) then write (stdout, '(1x,a)') 'Using adaptive smearing' - write (stdout, '(7x,a,f8.3)') 'adaptive smearing prefactor ', kubo_adpt_smr_fac - write (stdout, '(7x,a,f8.3,a)') 'adaptive smearing max width ', kubo_adpt_smr_max, ' eV' + write (stdout, '(7x,a,f8.3)') 'adaptive smearing prefactor ', & + pw90_berry%kubo_smearing%adaptive_prefactor + write (stdout, '(7x,a,f8.3,a)') 'adaptive smearing max width ', & + pw90_berry%kubo_smearing%adaptive_max_width, ' eV' else write (stdout, '(1x,a)') 'Using fixed smearing' write (stdout, '(7x,a,f8.3,a)') 'fixed smearing width ', & - kubo_smr_fixed_en_width, ' eV' + pw90_berry%kubo_smearing%fixed_width, ' eV' endif write (stdout, '(a)') '' if (abs(scissors_shift) > 1.0e-7_dp) then write (stdout, '(1X,A,I0,A,G18.10,A)') "Using scissors_shift to shift energy bands with index > ", & num_valence_bands, " by ", scissors_shift, " eV." endif - if (shc_bandshift) then + if (pw90_spin_hall%bandshift) then write (stdout, '(1X,A,I0,A,G18.10,A)') "Using shc_bandshift to shift energy bands with index >= ", & - shc_bandshift_firstband, " by ", shc_bandshift_energyshift, " eV." + pw90_spin_hall%bandshift_firstband, " by ", pw90_spin_hall%bandshift_energyshift, " eV." endif else - if (.not. wanint_kpoint_file) write (stdout, '(1x,a20,3(i0,1x))') & - 'Interpolation grid: ', berry_kmesh(1:3) + if (.not. pw90_berry%wanint_kpoint_file) write (stdout, & + '(1x,a20,3(i0,1x))') 'Interpolation grid: ', pw90_berry%kmesh%mesh(1:3) endif if (eval_ahc) then @@ -799,16 +1027,16 @@ subroutine berry_main ! (iii) Multiply by -e^2/hbar in SI, with has units ofconductance, ! (Ohm)^{-1}, or Siemens (S), to get the final result in S/cm ! - ! =========================== + !================================================== ! fac = -e^2/(hbar.V_c*10^-8) - ! =========================== + !================================================== ! ! with 'V_c' in Angstroms^3, and 'e', 'hbar' in SI units ! -------------------------------------------------------------------- ! - fac = -1.0e8_dp*elem_charge_SI**2/(hbar_SI*cell_volume) + fac = -1.0e8_dp*physics%elem_charge_SI**2/(physics%hbar_SI*cell_volume) ahc_list(:, :, :) = imf_list(:, :, :)*fac - if (nfermi > 1) then + if (fermi_n > 1) then write (stdout, '(/,1x,a)') & '---------------------------------' write (stdout, '(1x,a)') & @@ -820,30 +1048,30 @@ subroutine berry_main file_unit = io_file_unit() open (file_unit, FILE=file_name, STATUS='UNKNOWN', FORM='FORMATTED') endif - do if = 1, nfermi - if (nfermi > 1) write (file_unit, '(4(F12.6,1x))') & + do if = 1, fermi_n + if (fermi_n > 1) write (file_unit, '(4(F12.6,1x))') & fermi_energy_list(if), sum(ahc_list(:, 1, if)), & sum(ahc_list(:, 2, if)), sum(ahc_list(:, 3, if)) write (stdout, '(/,1x,a18,F10.4)') 'Fermi energy (ev):', & fermi_energy_list(if) - if (nfermi > 1) then - if (wanint_kpoint_file) then + if (fermi_n > 1) then + if (pw90_berry%wanint_kpoint_file) then write (stdout, '(1x,a30,i5,a,f5.2,a)') & ' Points triggering refinement: ', & adpt_counter_list(if), '(', & 100*real(adpt_counter_list(if), dp) & - /sum(num_int_kpts_on_node), '%)' + /sum(kpoint_dist%num_int_kpts_on_node), '%)' else write (stdout, '(1x,a30,i5,a,f5.2,a)') & ' Points triggering refinement: ', & adpt_counter_list(if), '(', & 100*real(adpt_counter_list(if), dp) & - /product(berry_kmesh), '%)' + /product(pw90_berry%kmesh%mesh), '%)' endif endif write (stdout, '(/,1x,a)') & 'AHC (S/cm) x y z' - if (iprint > 1) then + if (print_output%iprint > 1) then write (stdout, '(1x,a)') & '==========' write (stdout, '(1x,a9,2x,3(f10.4,1x))') 'J0 term :', & @@ -863,7 +1091,7 @@ subroutine berry_main sum(ahc_list(:, 3, if)) endif enddo - if (nfermi > 1) close (file_unit) + if (fermi_n > 1) close (file_unit) endif if (eval_morb) then @@ -894,8 +1122,8 @@ subroutine berry_main ! by 2 to convert it to Bohr magnetons ! -------------------------------------------------------------------- ! - fac = -eV_au/bohr**2 - if (nfermi > 1) then + fac = -physics%eV_au/physics%bohr**2 + if (fermi_n > 1) then write (stdout, '(/,1x,a)') & '---------------------------------' write (stdout, '(1x,a)') & @@ -907,20 +1135,20 @@ subroutine berry_main file_unit = io_file_unit() open (file_unit, FILE=file_name, STATUS='UNKNOWN', FORM='FORMATTED') endif - do if = 1, nfermi + do if = 1, fermi_n LCtil_list(:, :, if) = (img_list(:, :, if) & - fermi_energy_list(if)*imf_list2(:, :, if))*fac ICtil_list(:, :, if) = (imh_list(:, :, if) & - fermi_energy_list(if)*imf_list2(:, :, if))*fac Morb_list(:, :, if) = LCtil_list(:, :, if) + ICtil_list(:, :, if) - if (nfermi > 1) write (file_unit, '(4(F12.6,1x))') & + if (fermi_n > 1) write (file_unit, '(4(F12.6,1x))') & fermi_energy_list(if), sum(Morb_list(1:3, 1, if)), & sum(Morb_list(1:3, 2, if)), sum(Morb_list(1:3, 3, if)) write (stdout, '(/,/,1x,a,F12.6)') 'Fermi energy (ev) =', & fermi_energy_list(if) write (stdout, '(/,/,1x,a)') & 'M_orb (bohr magn/cell) x y z' - if (iprint > 1) then + if (print_output%iprint > 1) then write (stdout, '(1x,a)') & '======================' write (stdout, '(1x,a22,2x,3(f10.4,1x))') 'Local circulation :', & @@ -942,7 +1170,7 @@ subroutine berry_main sum(Morb_list(1:3, 3, if)) endif enddo - if (nfermi > 1) close (file_unit) + if (fermi_n > 1) close (file_unit) endif ! -----------------------------! @@ -952,7 +1180,7 @@ subroutine berry_main if (eval_kubo) then ! ! Convert to S/cm - fac = 1.0e8_dp*elem_charge_SI**2/(hbar_SI*cell_volume) + fac = 1.0e8_dp*physics%elem_charge_SI**2/(physics%hbar_SI*cell_volume) kubo_H = kubo_H*fac kubo_AH = kubo_AH*fac if (spin_decomp) then @@ -978,9 +1206,9 @@ subroutine berry_main file_unit = io_file_unit() write (stdout, '(/,3x,a)') '* '//file_name open (file_unit, FILE=file_name, STATUS='UNKNOWN', FORM='FORMATTED') - do ifreq = 1, kubo_nfreq + do ifreq = 1, pw90_berry%kubo_nfreq if (spin_decomp) then - write (file_unit, '(9E16.8)') real(kubo_freq_list(ifreq), dp), & + write (file_unit, '(9E16.8)') real(pw90_berry%kubo_freq_list(ifreq), dp), & real(0.5_dp*(kubo_H(i, j, ifreq) + kubo_H(j, i, ifreq)), dp), & aimag(0.5_dp*(kubo_AH(i, j, ifreq) + kubo_AH(j, i, ifreq))), & real(0.5_dp*(kubo_H_spn(i, j, 1, ifreq) & @@ -996,7 +1224,7 @@ subroutine berry_main aimag(0.5_dp*(kubo_AH_spn(i, j, 3, ifreq) & + kubo_AH_spn(j, i, 3, ifreq))) else - write (file_unit, '(3E16.8)') real(kubo_freq_list(ifreq), dp), & + write (file_unit, '(3E16.8)') real(pw90_berry%kubo_freq_list(ifreq), dp), & real(0.5_dp*(kubo_H(i, j, ifreq) + kubo_H(j, i, ifreq)), dp), & aimag(0.5_dp*(kubo_AH(i, j, ifreq) + kubo_AH(j, i, ifreq))) endif @@ -1015,9 +1243,9 @@ subroutine berry_main file_unit = io_file_unit() write (stdout, '(/,3x,a)') '* '//file_name open (file_unit, FILE=file_name, STATUS='UNKNOWN', FORM='FORMATTED') - do ifreq = 1, kubo_nfreq + do ifreq = 1, pw90_berry%kubo_nfreq if (spin_decomp) then - write (file_unit, '(9E16.8)') real(kubo_freq_list(ifreq), dp), & + write (file_unit, '(9E16.8)') real(pw90_berry%kubo_freq_list(ifreq), dp), & real(0.5_dp*(kubo_AH(i, j, ifreq) - kubo_AH(j, i, ifreq)), dp), & aimag(0.5_dp*(kubo_H(i, j, ifreq) - kubo_H(j, i, ifreq))), & real(0.5_dp*(kubo_AH_spn(i, j, 1, ifreq) & @@ -1033,7 +1261,7 @@ subroutine berry_main aimag(0.5_dp*(kubo_H_spn(i, j, 3, ifreq) & - kubo_H_spn(j, i, 3, ifreq))) else - write (file_unit, '(3E16.8)') real(kubo_freq_list(ifreq), dp), & + write (file_unit, '(3E16.8)') real(pw90_berry%kubo_freq_list(ifreq), dp), & real(0.5_dp*(kubo_AH(i, j, ifreq) - kubo_AH(j, i, ifreq)), dp), & aimag(0.5_dp*(kubo_H(i, j, ifreq) - kubo_H(j, i, ifreq))) endif @@ -1047,12 +1275,12 @@ subroutine berry_main write (stdout, '(/,3x,a)') '* '//file_name file_unit = io_file_unit() open (file_unit, FILE=file_name, STATUS='UNKNOWN', FORM='FORMATTED') - do ifreq = 1, kubo_nfreq + do ifreq = 1, pw90_berry%kubo_nfreq if (spin_decomp) then - write (file_unit, '(5E16.8)') real(kubo_freq_list(ifreq), dp), & + write (file_unit, '(5E16.8)') real(pw90_berry%kubo_freq_list(ifreq), dp), & jdos(ifreq), jdos_spn(:, ifreq) else - write (file_unit, '(2E16.8)') real(kubo_freq_list(ifreq), dp), & + write (file_unit, '(2E16.8)') real(pw90_berry%kubo_freq_list(ifreq), dp), & jdos(ifreq) endif enddo @@ -1088,14 +1316,14 @@ subroutine berry_main ! (iii) Multiply by ( pi.e^3/(4.hbar^2) ) in SI, which multiplied by [T] in seconds from (ii), gives final ! units of A/V^2 ! - ! =========================== + !================================================== ! fac = eV_seconds.( pi.e^3/(4.hbar^2.V_c) ) - ! =========================== + !================================================== ! ! with 'V_c' in Angstroms^3, and 'e', 'hbar' in SI units ! -------------------------------------------------------------------- - fac = eV_seconds*pi*elem_charge_SI**3/(4*hbar_SI**(2)*cell_volume) + fac = physics%eV_seconds*pi*physics%elem_charge_SI**3/(4*physics%hbar_SI**(2)*cell_volume) write (stdout, '(/,1x,a)') & '----------------------------------------------------------' write (stdout, '(1x,a)') & @@ -1113,8 +1341,8 @@ subroutine berry_main file_unit = io_file_unit() write (stdout, '(/,3x,a)') '* '//file_name open (file_unit, FILE=file_name, STATUS='UNKNOWN', FORM='FORMATTED') - do ifreq = 1, kubo_nfreq - write (file_unit, '(2E18.8E3)') real(kubo_freq_list(ifreq), dp), & + do ifreq = 1, pw90_berry%kubo_nfreq + write (file_unit, '(2E18.8E3)') real(pw90_berry%kubo_freq_list(ifreq), dp), & fac*sc_list(i, jk, ifreq) enddo close (file_unit) @@ -1142,8 +1370,8 @@ subroutine berry_main ! fac = 1.0e8 * e^2 / hbar / V / 2.0 ! and the final unit of spin Hall conductivity is (hbar/e)S/cm ! - fac = 1.0e8_dp*elem_charge_SI**2/(hbar_SI*cell_volume)/2.0_dp - if (shc_freq_scan) then + fac = 1.0e8_dp*physics%elem_charge_SI**2/(physics%hbar_SI*cell_volume)/2.0_dp + if (pw90_spin_hall%freq_scan) then shc_freq = shc_freq*fac else shc_fermi = shc_fermi*fac @@ -1156,7 +1384,7 @@ subroutine berry_main write (stdout, '(1x,a)') & '----------------------------------------------------------' ! - if (.not. shc_freq_scan) then + if (.not. pw90_spin_hall%freq_scan) then file_name = trim(seedname)//'-shc-fermiscan'//'.dat' else file_name = trim(seedname)//'-shc-freqscan'//'.dat' @@ -1165,19 +1393,19 @@ subroutine berry_main file_unit = io_file_unit() write (stdout, '(/,3x,a)') '* '//file_name open (file_unit, FILE=file_name, STATUS='UNKNOWN', FORM='FORMATTED') - if (.not. shc_freq_scan) then + if (.not. pw90_spin_hall%freq_scan) then write (file_unit, '(a,3x,a,3x,a)') & '#No.', 'Fermi energy(eV)', 'SHC((hbar/e)*S/cm)' - do n = 1, nfermi + do n = 1, fermi_n write (file_unit, '(I4,1x,F12.6,1x,E17.8)') & n, fermi_energy_list(n), shc_fermi(n) enddo else write (file_unit, '(a,3x,a,3x,a,3x,a)') '#No.', 'Frequency(eV)', & 'Re(sigma)((hbar/e)*S/cm)', 'Im(sigma)((hbar/e)*S/cm)' - do n = 1, kubo_nfreq + do n = 1, pw90_berry%kubo_nfreq write (file_unit, '(I4,1x,F12.6,1x,1x,2(E17.8,1x))') n, & - real(kubo_freq_list(n), dp), real(shc_freq(n), dp), aimag(shc_freq(n)) + real(pw90_berry%kubo_freq_list(n), dp), real(shc_freq(n), dp), aimag(shc_freq(n)) enddo endif close (file_unit) @@ -1226,39 +1454,107 @@ subroutine berry_main end if - end if !on_root + end if !print_output%iprint >0, aka "on_root" end subroutine berry_main - subroutine berry_get_imf_klist(kpt, imf_k_list, occ, ladpt) - !============================================================! - ! ! + !================================================! + subroutine berry_get_imf_klist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, print_output, & + wannier_data, ws_distance, wigner_seitz, AA_R, BB_R, CC_R, HH_R, u_matrix, & + v_matrix, eigval, kpt, real_lattice, imf_k_list, scissors_shift, & + mp_grid, num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, & + stdout, comm, occ, ladpt) + !================================================! + ! !! Calculates the Berry curvature traced over the occupied !! states, -2Im[f(k)] [Eq.33 CTVR06, Eq.6 LVTS12] for a list !! of Fermi energies, and stores it in axial-vector form - ! ! - !============================================================! - ! Arguments ! - real(kind=dp), intent(in) :: kpt(3) - real(kind=dp), intent(out), dimension(:, :, :) :: imf_k_list - real(kind=dp), intent(in), optional, dimension(:) :: occ - logical, intent(in), optional, dimension(:) :: ladpt - + !================================================! + + use w90_types, only: print_output_type, wannier_data_type, & + dis_manifold_type, ws_region_type, ws_distance_type + use w90_comms, only: w90comm_type + use w90_postw90_types, only: wigner_seitz_type + + implicit none + + ! arguments + type(dis_manifold_type), intent(in) :: dis_manifold + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + real(kind=dp), intent(in) :: kpt_latt(:, :) + type(print_output_type), intent(in) :: print_output + type(ws_region_type), intent(in) :: ws_region + type(w90comm_type), intent(in) :: comm + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + integer, intent(in) :: num_wann, num_bands, num_kpts, num_valence_bands + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: kpt(3) + real(kind=dp), intent(out) :: imf_k_list(:, :, :) + real(kind=dp), intent(in) :: scissors_shift + + complex(kind=dp), intent(in) :: u_matrix(:, :, :), v_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: AA_R(:, :, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: BB_R(:, :, :, :) ! <0|H(r-R)|R> + complex(kind=dp), allocatable, intent(inout) :: CC_R(:, :, :, :, :) ! <0|r_alpha.H(r-R)_beta|R> + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + logical, intent(in) :: effective_model + + real(kind=dp), intent(in), optional :: occ(:) + logical, intent(in), optional :: ladpt(:) + + ! local variables + integer :: fermi_n + + fermi_n = 0 + if (allocated(fermi_energy_list)) fermi_n = size(fermi_energy_list) if (present(occ)) then - call berry_get_imfgh_klist(kpt, imf_k_list, occ=occ) + call berry_get_imfgh_klist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, print_output, & + wannier_data, ws_distance, wigner_seitz, AA_R, BB_R, CC_R, HH_R, u_matrix, & + v_matrix, eigval, kpt, real_lattice, scissors_shift, mp_grid, & + fermi_n, num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, & + stdout, comm, imf_k_list, occ=occ) else if (present(ladpt)) then - call berry_get_imfgh_klist(kpt, imf_k_list, ladpt=ladpt) + call berry_get_imfgh_klist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, print_output, & + wannier_data, ws_distance, wigner_seitz, AA_R, BB_R, CC_R, HH_R, & + u_matrix, v_matrix, eigval, kpt, real_lattice, scissors_shift, & + mp_grid, fermi_n, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, & + seedname, stdout, comm, imf_k_list, ladpt=ladpt) else - call berry_get_imfgh_klist(kpt, imf_k_list) + call berry_get_imfgh_klist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, print_output, & + wannier_data, ws_distance, wigner_seitz, AA_R, BB_R, CC_R, HH_R, & + u_matrix, v_matrix, eigval, kpt, real_lattice, scissors_shift, & + mp_grid, fermi_n, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, & + seedname, stdout, comm, imf_k_list) endif endif end subroutine berry_get_imf_klist - subroutine berry_get_imfgh_klist(kpt, imf_k_list, img_k_list, imh_k_list, occ, ladpt) - !=========================================================! + !================================================! + subroutine berry_get_imfgh_klist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, print_output, & + wannier_data, ws_distance, wigner_seitz, AA_R, BB_R, CC_R, HH_R, & + u_matrix, v_matrix, eigval, kpt, real_lattice, & + scissors_shift, mp_grid, fermi_n, num_bands, num_kpts, & + num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm, imf_k_list, & + img_k_list, imh_k_list, occ, ladpt) + !================================================! ! !! Calculates the three quantities needed for the orbital !! magnetization: @@ -1274,24 +1570,56 @@ subroutine berry_get_imfgh_klist(kpt, imf_k_list, img_k_list, imh_k_list, occ, l ! 'img_k_list' are only calculated if both of them are ! present. ! - !=========================================================! + !================================================! - use w90_constants, only: dp, cmplx_0, cmplx_i - use w90_utility, only: utility_re_tr_prod, utility_im_tr_prod - use w90_parameters, only: num_wann, nfermi + use w90_comms, only: w90comm_type, mpirank + use w90_constants, only: dp, cmplx_i + use w90_types, only: print_output_type, wannier_data_type, & + dis_manifold_type, kmesh_info_type, ws_region_type, ws_distance_type use w90_postw90_common, only: pw90common_fourier_R_to_k_vec, pw90common_fourier_R_to_k + use w90_postw90_types, only: wigner_seitz_type + use w90_utility, only: utility_re_tr_prod, utility_im_tr_prod, utility_zgemm_new use w90_wan_ham, only: wham_get_eig_UU_HH_JJlist, wham_get_occ_mat_list - use w90_get_oper, only: AA_R, BB_R, CC_R - use w90_utility, only: utility_zgemm_new - - ! Arguments - ! - real(kind=dp), intent(in) :: kpt(3) - real(kind=dp), intent(out), dimension(:, :, :), optional & - :: imf_k_list, img_k_list, imh_k_list - real(kind=dp), intent(in), optional, dimension(:) :: occ - logical, intent(in), optional, dimension(:) :: ladpt + implicit none + + ! arguments + type(dis_manifold_type), intent(in) :: dis_manifold + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + real(kind=dp), intent(in) :: kpt_latt(:, :) + type(print_output_type), intent(in) :: print_output + type(ws_region_type), intent(in) :: ws_region + type(w90comm_type), intent(in) :: comm + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + integer, intent(in) :: num_wann, num_bands, num_kpts, num_valence_bands, fermi_n + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: kpt(3) + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: scissors_shift + + complex(kind=dp), intent(in) :: u_matrix(:, :, :), v_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: AA_R(:, :, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: BB_R(:, :, :, :) ! <0|H(r-R)|R> + complex(kind=dp), allocatable, intent(inout) :: CC_R(:, :, :, :, :) ! <0|r_alpha.H(r-R)_beta|R> + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + + real(kind=dp), intent(out), optional :: imf_k_list(:, :, :) + real(kind=dp), intent(out), optional :: img_k_list(:, :, :) + real(kind=dp), intent(out), optional :: imh_k_list(:, :, :) + real(kind=dp), intent(in), optional :: occ(:) + logical, intent(in) :: effective_model + logical, intent(in), optional :: ladpt(:) + + ! local variables complex(kind=dp), allocatable :: HH(:, :) complex(kind=dp), allocatable :: UU(:, :) complex(kind=dp), allocatable :: f_list(:, :, :) @@ -1302,18 +1630,20 @@ subroutine berry_get_imfgh_klist(kpt, imf_k_list, img_k_list, imh_k_list, occ, l complex(kind=dp), allocatable :: OOmega(:, :, :) complex(kind=dp), allocatable :: JJp_list(:, :, :, :) complex(kind=dp), allocatable :: JJm_list(:, :, :, :) - real(kind=dp) :: eig(num_wann) - integer :: i, j, ife, nfermi_loc - real(kind=dp) :: s - logical :: todo(nfermi) - ! Temporary space for matrix products - complex(kind=dp), allocatable, dimension(:, :, :) :: tmp + complex(kind=dp), allocatable :: tmp(:, :, :) + + real(kind=dp) :: eig(num_wann) + real(kind=dp) :: s + + integer :: i, j, ife, nfermi_loc + + logical :: todo(fermi_n) if (present(occ)) then nfermi_loc = 1 else - nfermi_loc = nfermi + nfermi_loc = fermi_n endif if (present(ladpt)) then @@ -1335,15 +1665,29 @@ subroutine berry_get_imfgh_klist(kpt, imf_k_list, img_k_list, imh_k_list, occ, l ! if (present(occ)) then - call wham_get_eig_UU_HH_JJlist(kpt, eig, UU, HH, JJp_list, JJm_list, occ=occ) - call wham_get_occ_mat_list(UU, f_list, g_list, occ=occ) + call wham_get_eig_UU_HH_JJlist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, print_output, & + wannier_data, ws_distance, wigner_seitz, HH, HH_R, JJm_list, JJp_list, & + u_matrix, UU, v_matrix, eig, eigval, kpt, real_lattice, & + scissors_shift, mp_grid, num_bands, num_kpts, & + num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm, occ=occ) + call wham_get_occ_mat_list(fermi_energy_list, f_list, g_list, UU, num_wann, seedname, & + stdout, occ=occ) + else - call wham_get_eig_UU_HH_JJlist(kpt, eig, UU, HH, JJp_list, JJm_list) - call wham_get_occ_mat_list(UU, f_list, g_list, eig=eig) + call wham_get_eig_UU_HH_JJlist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, print_output, & + wannier_data, ws_distance, wigner_seitz, HH, HH_R, JJm_list, JJp_list, & + u_matrix, UU, v_matrix, eig, eigval, kpt, real_lattice, & + scissors_shift, mp_grid, num_bands, num_kpts, & + num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm) + call wham_get_occ_mat_list(fermi_energy_list, f_list, g_list, UU, num_wann, seedname, & + stdout, eig=eig) endif - call pw90common_fourier_R_to_k_vec(kpt, AA_R, OO_true=AA, OO_pseudo=OOmega) - + call pw90common_fourier_R_to_k_vec(ws_region, wannier_data, ws_distance, wigner_seitz, AA_R, kpt, & + real_lattice, mp_grid, num_wann, seedname, & + stdout, OO_true=AA, OO_pseudo=OOmega) if (present(imf_k_list)) then ! Trace formula for -2Im[f], Eq.(51) LVTS12 ! @@ -1384,10 +1728,14 @@ subroutine berry_get_imfgh_klist(kpt, imf_k_list, img_k_list, imh_k_list, occ, l ! tmp(:,:,3) ..... HH . OOmega(:,:,i) ! tmp(:,:,4:5) ... working matrices for matrix products of inner loop - call pw90common_fourier_R_to_k_vec(kpt, BB_R, OO_true=BB) + call pw90common_fourier_R_to_k_vec(ws_region, wannier_data, ws_distance, wigner_seitz, BB_R, kpt, & + real_lattice, mp_grid, num_wann, seedname, & + stdout, OO_true=BB) do j = 1, 3 do i = 1, j - call pw90common_fourier_R_to_k(kpt, CC_R(:, :, :, i, j), CC(:, :, i, j), 0) + call pw90common_fourier_R_to_k(ws_region, wannier_data, ws_distance, & + wigner_seitz, CC(:, :, i, j), CC_R(:, :, :, i, j), kpt, & + real_lattice, mp_grid, 0, num_wann, seedname, stdout) CC(:, :, j, i) = conjg(transpose(CC(:, :, i, j))) end do end do @@ -1452,61 +1800,96 @@ subroutine berry_get_imfgh_klist(kpt, imf_k_list, img_k_list, imh_k_list, occ, l end subroutine berry_get_imfgh_klist - !===========================================================! - ! PRIVATE PROCEDURES ! - !===========================================================! - - subroutine berry_get_kubo_k(kpt, kubo_H_k, kubo_AH_k, jdos_k, & - kubo_H_k_spn, kubo_AH_k_spn, jdos_k_spn) - !====================================================================! - ! ! + !================================================! + ! PRIVATE PROCEDURES + !================================================! + + subroutine berry_get_kubo_k(pw90_berry, dis_manifold, fermi_energy_list, kpt_latt, pw90_band_deriv_degen, pw90_spin, & + ws_region, print_output, wannier_data, ws_distance, wigner_seitz, AA_R, HH_R, & + kubo_AH_k, kubo_H_k, SS_R, u_matrix, v_matrix, eigval, kpt, & + real_lattice, jdos_k, scissors_shift, mp_grid, & + num_bands, num_kpts, num_wann, num_valence_bands, effective_model, & + have_disentangled, spin_decomp, seedname, stdout, comm, & + kubo_AH_k_spn, kubo_H_k_spn, jdos_k_spn) + !================================================! + ! !! Contribution from point k to the complex interband optical !! conductivity, separated into Hermitian (H) and anti-Hermitian (AH) !! parts. Also returns the joint density of states - ! ! - !====================================================================! + ! + !================================================! use w90_constants, only: dp, cmplx_0, cmplx_i, pi - use w90_utility, only: utility_diagonalize, utility_rotate, utility_w0gauss - use w90_parameters, only: num_wann, kubo_nfreq, kubo_freq_list, & - fermi_energy_list, kubo_eigval_max, & - kubo_adpt_smr, kubo_smr_fixed_en_width, & - kubo_adpt_smr_max, kubo_adpt_smr_fac, & - kubo_smr_index, berry_kmesh, spin_decomp + use w90_comms, only: w90comm_type + use w90_utility, only: utility_diagonalize, utility_rotate, utility_w0gauss, & + utility_recip_lattice_base + use w90_types, only: print_output_type, wannier_data_type, & + dis_manifold_type, ws_region_type, ws_distance_type + use w90_postw90_types, only: pw90_berry_mod_type, pw90_spin_mod_type, & + pw90_band_deriv_degen_type, wigner_seitz_type use w90_postw90_common, only: pw90common_get_occ, pw90common_fourier_R_to_k_new, & pw90common_fourier_R_to_k_vec, pw90common_kmesh_spacing - use w90_wan_ham, only: wham_get_D_h, wham_get_eig_deleig - use w90_get_oper, only: HH_R, AA_R use w90_spin, only: spin_get_nk + use w90_wan_ham, only: wham_get_D_h, wham_get_eig_deleig + + implicit none + + ! arguments + type(pw90_berry_mod_type), intent(inout) :: pw90_berry + type(dis_manifold_type), intent(in) :: dis_manifold + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + real(kind=dp), intent(in) :: kpt_latt(:, :) + type(pw90_band_deriv_degen_type), intent(in) :: pw90_band_deriv_degen + type(pw90_spin_mod_type), intent(in) :: pw90_spin + type(print_output_type), intent(in) :: print_output + type(ws_region_type), intent(in) :: ws_region + type(w90comm_type), intent(in) :: comm + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + integer, intent(in) :: num_wann, num_bands, num_kpts, num_valence_bands + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: kpt(3) + real(kind=dp), intent(out) :: jdos_k(:) + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: scissors_shift + + complex(kind=dp), intent(out) :: kubo_H_k(:, :, :) + complex(kind=dp), intent(out) :: kubo_AH_k(:, :, :) + complex(kind=dp), intent(in) :: u_matrix(:, :, :), v_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: AA_R(:, :, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) ! <0n|sigma_x,y,z|Rm> + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + logical, intent(in) :: spin_decomp + logical, intent(in) :: effective_model - ! Arguments - ! ! Last three arguments should be present iff spin_decomp=T (but ! this is not checked: do it?) - ! - real(kind=dp), intent(in) :: kpt(3) - complex(kind=dp), dimension(:, :, :), intent(out) :: kubo_H_k - complex(kind=dp), dimension(:, :, :), intent(out) :: kubo_AH_k - real(kind=dp), dimension(:), intent(out) :: jdos_k - complex(kind=dp), optional, dimension(:, :, :, :), intent(out) :: kubo_H_k_spn - complex(kind=dp), optional, dimension(:, :, :, :), intent(out) :: kubo_AH_k_spn - real(kind=dp), optional, dimension(:, :), intent(out) :: jdos_k_spn + real(kind=dp), optional, intent(out) :: jdos_k_spn(:, :) + complex(kind=dp), optional, intent(out) :: kubo_AH_k_spn(:, :, :, :) + complex(kind=dp), optional, intent(out) :: kubo_H_k_spn(:, :, :, :) + ! local variables complex(kind=dp), allocatable :: HH(:, :) complex(kind=dp), allocatable :: delHH(:, :, :) complex(kind=dp), allocatable :: UU(:, :) complex(kind=dp), allocatable :: D_h(:, :, :) complex(kind=dp), allocatable :: AA(:, :, :) + real(kind=dp) :: recip_lattice(3, 3), volume ! Adaptive smearing ! - real(kind=dp) :: del_eig(num_wann, 3), joint_level_spacing, & - eta_smr, Delta_k, arg, vdum(3) - - integer :: i, j, n, m, ifreq, ispn - real(kind=dp) :: eig(num_wann), occ(num_wann), delta, & - rfac1, rfac2, occ_prod, spn_nk(num_wann) + real(kind=dp) :: del_eig(num_wann, 3), joint_level_spacing, eta_smr, Delta_k, arg, vdum(3) + real(kind=dp) :: eig(num_wann), occ(num_wann), delta, rfac1, rfac2, occ_prod, spn_nk(num_wann) complex(kind=dp) :: cfac, omega + integer :: i, j, n, m, ifreq, ispn allocate (HH(num_wann, num_wann)) allocate (delHH(num_wann, num_wann, 3)) @@ -1514,35 +1897,46 @@ subroutine berry_get_kubo_k(kpt, kubo_H_k, kubo_AH_k, jdos_k, & allocate (D_h(num_wann, num_wann, 3)) allocate (AA(num_wann, num_wann, 3)) - if (kubo_adpt_smr) then - call wham_get_eig_deleig(kpt, eig, del_eig, HH, delHH, UU) - Delta_k = pw90common_kmesh_spacing(berry_kmesh) + if (pw90_berry%kubo_smearing%use_adaptive) then + call wham_get_eig_deleig(dis_manifold, kpt_latt, pw90_band_deriv_degen, ws_region, print_output, wannier_data, & + ws_distance, wigner_seitz, delHH, HH, HH_R, u_matrix, UU, v_matrix, & + del_eig, eig, eigval, kpt, real_lattice, scissors_shift, mp_grid, & + num_bands, num_kpts, num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm) + + call utility_recip_lattice_base(real_lattice, recip_lattice, volume) + Delta_k = pw90common_kmesh_spacing(pw90_berry%kmesh%mesh, recip_lattice) else - call pw90common_fourier_R_to_k_new(kpt, HH_R, OO=HH, & - OO_dx=delHH(:, :, 1), & - OO_dy=delHH(:, :, 2), & - OO_dz=delHH(:, :, 3)) - call utility_diagonalize(HH, num_wann, eig, UU) + call pw90common_fourier_R_to_k_new(ws_region, wannier_data, ws_distance, wigner_seitz, HH_R, kpt, & + real_lattice, mp_grid, num_wann, seedname, stdout, & + OO=HH, OO_dx=delHH(:, :, 1), & + OO_dy=delHH(:, :, 2), OO_dz=delHH(:, :, 3)) + + call utility_diagonalize(HH, num_wann, eig, UU, stdout, seedname) endif - call pw90common_get_occ(eig, occ, fermi_energy_list(1)) - call wham_get_D_h(delHH, UU, eig, D_h) + call pw90common_get_occ(fermi_energy_list(1), eig, occ, num_wann) + + call wham_get_D_h(delHH, D_h, UU, eig, num_wann) - call pw90common_fourier_R_to_k_vec(kpt, AA_R, OO_true=AA) + call pw90common_fourier_R_to_k_vec(ws_region, wannier_data, ws_distance, wigner_seitz, AA_R, kpt, & + real_lattice, mp_grid, num_wann, seedname, & + stdout, OO_true=AA) do i = 1, 3 AA(:, :, i) = utility_rotate(AA(:, :, i), UU, num_wann) enddo AA = AA + cmplx_i*D_h ! Eq.(25) WYSV06 ! Replace imaginary part of frequency with a fixed value - if (.not. kubo_adpt_smr .and. kubo_smr_fixed_en_width /= 0.0_dp) & - kubo_freq_list = real(kubo_freq_list, dp) & - + cmplx_i*kubo_smr_fixed_en_width + if (.not. pw90_berry%kubo_smearing%use_adaptive .and. pw90_berry%kubo_smearing%fixed_width /= 0.0_dp) & + pw90_berry%kubo_freq_list = real(pw90_berry%kubo_freq_list, dp) & + + cmplx_i*pw90_berry%kubo_smearing%fixed_width kubo_H_k = cmplx_0 kubo_AH_k = cmplx_0 jdos_k = 0.0_dp if (spin_decomp) then - call spin_get_nk(kpt, spn_nk) + call spin_get_nk(ws_region, pw90_spin, wannier_data, ws_distance, wigner_seitz, HH_R, SS_R, kpt, & + real_lattice, spn_nk, mp_grid, num_wann, seedname, stdout) kubo_H_k_spn = cmplx_0 kubo_AH_k_spn = cmplx_0 jdos_k_spn = 0.0_dp @@ -1550,7 +1944,7 @@ subroutine berry_get_kubo_k(kpt, kubo_H_k, kubo_AH_k, jdos_k, & do m = 1, num_wann do n = 1, num_wann if (n == m) cycle - if (eig(m) > kubo_eigval_max .or. eig(n) > kubo_eigval_max) cycle + if (eig(m) > pw90_berry%kubo_eigval_max .or. eig(n) > pw90_berry%kubo_eigval_max) cycle if (spin_decomp) then if (spn_nk(n) >= 0 .and. spn_nk(m) >= 0) then ispn = 1 ! up --> up transition @@ -1560,25 +1954,25 @@ subroutine berry_get_kubo_k(kpt, kubo_H_k, kubo_AH_k, jdos_k, & ispn = 3 ! spin-flip end if end if - if (kubo_adpt_smr) then + if (pw90_berry%kubo_smearing%use_adaptive) then ! Eq.(35) YWVS07 vdum(:) = del_eig(m, :) - del_eig(n, :) joint_level_spacing = sqrt(dot_product(vdum(:), vdum(:)))*Delta_k - eta_smr = min(joint_level_spacing*kubo_adpt_smr_fac, & - kubo_adpt_smr_max) + eta_smr = min(joint_level_spacing*pw90_berry%kubo_smearing%adaptive_prefactor, & + pw90_berry%kubo_smearing%adaptive_max_width) else - eta_smr = kubo_smr_fixed_en_width + eta_smr = pw90_berry%kubo_smearing%fixed_width endif rfac1 = (occ(m) - occ(n))*(eig(m) - eig(n)) occ_prod = occ(n)*(1.0_dp - occ(m)) - do ifreq = 1, kubo_nfreq + do ifreq = 1, pw90_berry%kubo_nfreq ! ! Complex frequency for the anti-Hermitian conductivity ! - if (kubo_adpt_smr) then - omega = real(kubo_freq_list(ifreq), dp) + cmplx_i*eta_smr + if (pw90_berry%kubo_smearing%use_adaptive) then + omega = real(pw90_berry%kubo_freq_list(ifreq), dp) + cmplx_i*eta_smr else - omega = kubo_freq_list(ifreq) + omega = pw90_berry%kubo_freq_list(ifreq) endif ! ! Broadened delta function for the Hermitian conductivity and JDOS @@ -1586,7 +1980,7 @@ subroutine berry_get_kubo_k(kpt, kubo_H_k, kubo_AH_k, jdos_k, & arg = (eig(m) - eig(n) - real(omega, dp))/eta_smr ! If only Hermitean part were computed, could speed up ! by inserting here 'if(abs(arg)>10.0_dp) cycle' - delta = utility_w0gauss(arg, kubo_smr_index)/eta_smr + delta = utility_w0gauss(arg, pw90_berry%kubo_smearing%type_index, stdout, seedname)/eta_smr ! ! Lorentzian shape (for testing purposes) ! delta=1.0_dp/(1.0_dp+arg*arg)/pi @@ -1619,9 +2013,14 @@ subroutine berry_get_kubo_k(kpt, kubo_H_k, kubo_AH_k, jdos_k, & end subroutine berry_get_kubo_k - subroutine berry_get_sc_klist(kpt, sc_k_list) - !====================================================================! - ! ! + subroutine berry_get_sc_klist(pw90_berry, dis_manifold, fermi_energy_list, kmesh_info, kpt_latt, & + ws_region, print_output, pw90_band_deriv_degen, wannier_data, ws_distance, wigner_seitz, & + AA_R, HH_R, u_matrix, v_matrix, eigval, kpt, real_lattice, & + sc_k_list, scissors_shift, mp_grid, num_bands, & + num_kpts, num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm) + !================================================! + ! ! Contribution from point k to the nonlinear shift current ! [integrand of Eq.8 IATS18] ! Notation correspondence with IATS18: @@ -1634,30 +2033,58 @@ subroutine berry_get_sc_klist(kpt, sc_k_list) ! sum_AD <--> summatory of Eq. 32 IATS18 ! sum_HD <--> summatory of Eq. 30 IATS18 ! eig_da(n)-eig_da(m) <--> \mathbbm{Delta}_{nm} - ! ! - !====================================================================! - - ! Arguments ! + !================================================! + use w90_constants, only: dp, cmplx_0, cmplx_i use w90_utility, only: utility_re_tr, utility_im_tr, utility_w0gauss, utility_w0gauss_vec - use w90_parameters, only: num_wann, nfermi, kubo_nfreq, kubo_freq_list, fermi_energy_list, & - kubo_smr_index, berry_kmesh, kubo_adpt_smr_fac, & - kubo_adpt_smr_max, kubo_adpt_smr, kubo_eigval_max, & - kubo_smr_fixed_en_width, sc_phase_conv, sc_w_thr, sc_eta, sc_use_eta_corr + use w90_types, only: print_output_type, wannier_data_type, & + dis_manifold_type, kmesh_info_type, ws_region_type, ws_distance_type + use w90_postw90_types, only: pw90_berry_mod_type, pw90_band_deriv_degen_type, wigner_seitz_type use w90_postw90_common, only: pw90common_fourier_R_to_k_vec_dadb, & pw90common_fourier_R_to_k_new_second_d, pw90common_get_occ, & pw90common_kmesh_spacing, pw90common_fourier_R_to_k_vec_dadb_TB_conv - use w90_wan_ham, only: wham_get_eig_UU_HH_JJlist, wham_get_occ_mat_list, wham_get_D_h, & + use w90_wan_ham, only: wham_get_D_h, & wham_get_eig_UU_HH_AA_sc, wham_get_eig_deleig, wham_get_D_h_P_value, & wham_get_eig_deleig_TB_conv, wham_get_eig_UU_HH_AA_sc_TB_conv - use w90_get_oper, only: AA_R - use w90_utility, only: utility_rotate, utility_zdotu - ! Arguments - ! - real(kind=dp), intent(in) :: kpt(3) - real(kind=dp), intent(out), dimension(:, :, :) :: sc_k_list - + use w90_comms, only: w90comm_type + use w90_utility, only: utility_rotate, utility_zdotu, utility_recip_lattice_base + + implicit none + + ! arguments + type(pw90_berry_mod_type), intent(in) :: pw90_berry + type(dis_manifold_type), intent(in) :: dis_manifold + type(kmesh_info_type), intent(in) :: kmesh_info + type(pw90_band_deriv_degen_type), intent(in) :: pw90_band_deriv_degen + type(print_output_type), intent(in) :: print_output + type(ws_region_type), intent(in) :: ws_region + type(w90comm_type), intent(in) :: comm + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + integer, intent(in) :: num_wann, num_bands, num_kpts, num_valence_bands + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: kpt(3) + real(kind=dp), intent(out) :: sc_k_list(:, :, :) + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: scissors_shift + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + real(kind=dp), intent(in) :: kpt_latt(:, :) + + complex(kind=dp), intent(in) :: u_matrix(:, :, :), v_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: AA_R(:, :, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + logical, intent(in) :: effective_model + + ! local variables complex(kind=dp), allocatable :: UU(:, :) complex(kind=dp), allocatable :: AA(:, :, :), AA_bar(:, :, :) complex(kind=dp), allocatable :: AA_da(:, :, :, :), AA_da_bar(:, :, :, :) @@ -1665,15 +2092,18 @@ subroutine berry_get_sc_klist(kpt, sc_k_list) complex(kind=dp), allocatable :: HH_dadb(:, :, :, :), HH_dadb_bar(:, :, :, :) complex(kind=dp), allocatable :: HH(:, :) complex(kind=dp), allocatable :: D_h(:, :, :), D_h_no_eta(:, :, :) - real(kind=dp), allocatable :: eig(:) - real(kind=dp), allocatable :: eig_da(:, :) - real(kind=dp), allocatable :: occ(:) - complex(kind=dp) :: sum_AD(3, 3), sum_HD(3, 3), r_mn(3), gen_r_nm(3) - integer :: i, if, a, b, c, bc, n, m, r, ifreq, istart, iend, p - real(kind=dp) :: I_nm(3, 6), & - omega(kubo_nfreq), delta(kubo_nfreq), joint_level_spacing, & - eta_smr, Delta_k, arg, vdum(3), occ_fac, wstep, wmin, wmax + real(kind=dp), allocatable :: eig(:) + real(kind=dp), allocatable :: eig_da(:, :) + real(kind=dp), allocatable :: occ(:) + + real(kind=dp) :: recip_lattice(3, 3), volume + complex(kind=dp) :: sum_AD(3, 3), sum_HD(3, 3), r_mn(3), gen_r_nm(3) + integer :: a, b, c, bc, n, m, istart, iend + integer :: p ! i, if, r, ifreq + real(kind=dp) :: I_nm(3, 6) + real(kind=dp) :: omega(pw90_berry%kubo_nfreq), delta(pw90_berry%kubo_nfreq), joint_level_spacing + real(kind=dp) :: eta_smr, Delta_k, vdum(3), occ_fac, wstep, wmin, wmax allocate (UU(num_wann, num_wann)) allocate (AA(num_wann, num_wann, 3)) @@ -1697,32 +2127,54 @@ subroutine berry_get_sc_klist(kpt, sc_k_list) ! Gather W-gauge matrix objects ! ! choose the convention for the FT sums - if (sc_phase_conv .eq. 1) then ! use Wannier centres in the FT exponentials (so called TB convention) + if (pw90_berry%sc_phase_conv .eq. 1) then ! use Wannier centres in the FT exponentials (so called TB convention) ! get Hamiltonian and its first and second derivatives ! Note that below we calculate the UU matrix--> we have to use the same UU from here on for ! maintaining the gauge-covariance of the whole matrix element - call wham_get_eig_UU_HH_AA_sc_TB_conv(kpt, eig, UU, HH, HH_da, HH_dadb) + call wham_get_eig_UU_HH_AA_sc_TB_conv(pw90_berry, dis_manifold, kmesh_info, kpt_latt, ws_region, & + print_output, wannier_data, ws_distance, wigner_seitz, AA_R, HH, & + HH_da, HH_dadb, HH_R, u_matrix, UU, v_matrix, eig, & + eigval, kpt, real_lattice, scissors_shift, mp_grid, & + num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, stdout, & + comm) ! get position operator and its derivative ! note that AA_da(:,:,a,b) \propto \sum_R exp(iRk)*iR_{b}*<0|r_{a}|R> - call pw90common_fourier_R_to_k_vec_dadb_TB_conv(kpt, AA_R, OO_da=AA, OO_dadb=AA_da) + call pw90common_fourier_R_to_k_vec_dadb_TB_conv(ws_region, wannier_data, ws_distance, wigner_seitz, & + AA_R, kpt, real_lattice, mp_grid, num_wann, & + seedname, stdout, OO_da=AA, OO_dadb=AA_da) ! get eigenvalues and their k-derivatives - call wham_get_eig_deleig_TB_conv(kpt, eig, eig_da, HH_da, UU) - elseif (sc_phase_conv .eq. 2) then ! do not use Wannier centres in the FT exponentials (usual W90 convention) + call wham_get_eig_deleig_TB_conv(pw90_band_deriv_degen, HH_da, UU, eig, eig_da, num_wann, seedname, & + stdout) + elseif (pw90_berry%sc_phase_conv .eq. 2) then ! do not use Wannier centres in the FT exponentials (usual W90 convention) ! same as above - call wham_get_eig_UU_HH_AA_sc(kpt, eig, UU, HH, HH_da, HH_dadb) - call pw90common_fourier_R_to_k_vec_dadb(kpt, AA_R, OO_da=AA, OO_dadb=AA_da) - call wham_get_eig_deleig(kpt, eig, eig_da, HH, HH_da, UU) + call wham_get_eig_UU_HH_AA_sc(dis_manifold, kpt_latt, ws_region, print_output, wannier_data, & + ws_distance, wigner_seitz, HH, HH_da, HH_dadb, HH_R, u_matrix, UU, & + v_matrix, eig, eigval, kpt, real_lattice, scissors_shift, & + mp_grid, num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, stdout, comm) + call pw90common_fourier_R_to_k_vec_dadb(ws_region, wannier_data, ws_distance, wigner_seitz, AA_R, & + kpt, real_lattice, mp_grid, num_wann, & + seedname, stdout, OO_da=AA, OO_dadb=AA_da) + call wham_get_eig_deleig(dis_manifold, kpt_latt, pw90_band_deriv_degen, ws_region, print_output, wannier_data, & + ws_distance, wigner_seitz, HH_da, HH, HH_R, u_matrix, UU, v_matrix, & + eig_da, eig, eigval, kpt, real_lattice, scissors_shift, mp_grid, & + num_bands, num_kpts, num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm) end if ! get electronic occupations - call pw90common_get_occ(eig, occ, fermi_energy_list(1)) + call pw90common_get_occ(fermi_energy_list(1), eig, occ, num_wann) ! get D_h (Eq. (24) WYSV06) - call wham_get_D_h_P_value(HH_da, UU, eig, D_h) - call wham_get_D_h(HH_da, UU, eig, D_h_no_eta) + call wham_get_D_h_P_value(pw90_berry, HH_da, D_h, UU, eig, num_wann) + call wham_get_D_h(HH_da, D_h_no_eta, UU, eig, num_wann) ! calculate k-spacing in case of adaptive smearing - if (kubo_adpt_smr) Delta_k = pw90common_kmesh_spacing(berry_kmesh) + if (pw90_berry%kubo_smearing%use_adaptive) then + call utility_recip_lattice_base(real_lattice, recip_lattice, volume) + Delta_k = pw90common_kmesh_spacing(pw90_berry%kmesh%mesh, recip_lattice) + endif ! rotate quantities from W to H gauge (we follow wham_get_D_h for delHH_bar_i) do a = 1, 3 @@ -1739,9 +2191,9 @@ subroutine berry_get_sc_klist(kpt, sc_k_list) enddo ! setup for frequency-related quantities - omega = real(kubo_freq_list(:), dp) + omega = real(pw90_berry%kubo_freq_list(:), dp) wmin = omega(1) - wmax = omega(kubo_nfreq) + wmax = omega(pw90_berry%kubo_nfreq) wstep = omega(2) - omega(1) ! loop on initial and final bands @@ -1749,25 +2201,27 @@ subroutine berry_get_sc_klist(kpt, sc_k_list) do m = 1, num_wann ! cycle diagonal matrix elements and bands above the maximum if (n == m) cycle - if (eig(m) > kubo_eigval_max .or. eig(n) > kubo_eigval_max) cycle + if (eig(m) > pw90_berry%kubo_eigval_max .or. eig(n) > pw90_berry%kubo_eigval_max) cycle ! setup T=0 occupation factors occ_fac = (occ(n) - occ(m)) if (abs(occ_fac) < 1e-10) cycle ! set delta function smearing - if (kubo_adpt_smr) then + if (pw90_berry%kubo_smearing%use_adaptive) then vdum(:) = eig_da(m, :) - eig_da(n, :) joint_level_spacing = sqrt(dot_product(vdum(:), vdum(:)))*Delta_k - eta_smr = min(joint_level_spacing*kubo_adpt_smr_fac, & - kubo_adpt_smr_max) + eta_smr = min(joint_level_spacing*pw90_berry%kubo_smearing%adaptive_prefactor, & + pw90_berry%kubo_smearing%adaptive_max_width) else - eta_smr = kubo_smr_fixed_en_width + eta_smr = pw90_berry%kubo_smearing%fixed_width endif ! restrict to energy window spanning [-sc_w_thr*eta_smr,+sc_w_thr*eta_smr] ! outside this range, the two delta functions are virtually zero - if (((eig(n) - eig(m) + sc_w_thr*eta_smr < wmin) .or. (eig(n) - eig(m) - sc_w_thr*eta_smr > wmax)) .and. & - ((eig(m) - eig(n) + sc_w_thr*eta_smr < wmin) .or. (eig(m) - eig(n) - sc_w_thr*eta_smr > wmax))) cycle + if (((eig(n) - eig(m) + pw90_berry%sc_w_thr*eta_smr < wmin) .or. & + (eig(n) - eig(m) - pw90_berry%sc_w_thr*eta_smr > wmax)) .and. & + ((eig(m) - eig(n) + pw90_berry%sc_w_thr*eta_smr < wmin) .or. & + (eig(m) - eig(n) - pw90_berry%sc_w_thr*eta_smr > wmax))) cycle ! first compute the two sums over intermediate states between AA_bar and HH_da_bar with D_h ! appearing in Eqs. (30) and (32) of IATS18 @@ -1806,14 +2260,17 @@ subroutine berry_get_sc_klist(kpt, sc_k_list) ! Correction term due to finite sc_eta ! See Eq. (19) of Phys. Rev. B 103, 247101 (2021) - if (sc_use_eta_corr) then + if (pw90_berry%sc_use_eta_corr) then do p = 1, num_wann if (p == n .or. p == m) cycle gen_r_nm(:) = gen_r_nm(:) & - - sc_eta**2/((eig(p) - eig(m))**2 + sc_eta**2)/(eig(n) - eig(m)) & + - pw90_berry%sc_eta**2/((eig(p) - eig(m))**2 & + + pw90_berry%sc_eta**2)/(eig(n) - eig(m)) & *(AA_bar(n, p, :)*HH_da_bar(p, m, a) & - - (HH_da_bar(n, p, :) + cmplx_i*(eig(n) - eig(p))*AA_bar(n, p, :))*AA_bar(p, m, a)) & - + sc_eta**2/((eig(n) - eig(p))**2 + sc_eta**2)/(eig(n) - eig(m)) & + - (HH_da_bar(n, p, :) + cmplx_i*(eig(n) & + - eig(p))*AA_bar(n, p, :))*AA_bar(p, m, a)) & + + pw90_berry%sc_eta**2/((eig(n) - eig(p))**2 & + + pw90_berry%sc_eta**2)/(eig(n) - eig(m)) & *(HH_da_bar(n, p, a)*AA_bar(p, m, :) & - AA_bar(n, p, a)*(HH_da_bar(p, m, :) + cmplx_i*(eig(p) - eig(m))*AA_bar(p, m, :))) enddo @@ -1831,22 +2288,24 @@ subroutine berry_get_sc_klist(kpt, sc_k_list) ! compute delta(E_nm-w) ! choose energy window spanning [-sc_w_thr*eta_smr,+sc_w_thr*eta_smr] - istart = max(int((eig(n) - eig(m) - sc_w_thr*eta_smr - wmin)/wstep + 1), 1) - iend = min(int((eig(n) - eig(m) + sc_w_thr*eta_smr - wmin)/wstep + 1), kubo_nfreq) + istart = max(int((eig(n) - eig(m) - pw90_berry%sc_w_thr*eta_smr - wmin)/wstep + 1), 1) + iend = min(int((eig(n) - eig(m) + pw90_berry%sc_w_thr*eta_smr - wmin)/wstep + 1), pw90_berry%kubo_nfreq) ! multiply matrix elements with delta function for the relevant frequencies if (istart <= iend) then delta = 0.0 delta(istart:iend) = & - utility_w0gauss_vec((eig(m) - eig(n) + omega(istart:iend))/eta_smr, kubo_smr_index)/eta_smr + utility_w0gauss_vec((eig(m) - eig(n) + omega(istart:iend))/eta_smr, & + pw90_berry%kubo_smearing%type_index, stdout, seedname)/eta_smr call DGER(18, iend - istart + 1, occ_fac, I_nm, 1, delta(istart:iend), 1, sc_k_list(:, :, istart:iend), 18) endif ! same for delta(E_mn-w) - istart = max(int((eig(m) - eig(n) - sc_w_thr*eta_smr - wmin)/wstep + 1), 1) - iend = min(int((eig(m) - eig(n) + sc_w_thr*eta_smr - wmin)/wstep + 1), kubo_nfreq) + istart = max(int((eig(m) - eig(n) - pw90_berry%sc_w_thr*eta_smr - wmin)/wstep + 1), 1) + iend = min(int((eig(m) - eig(n) + pw90_berry%sc_w_thr*eta_smr - wmin)/wstep + 1), pw90_berry%kubo_nfreq) if (istart <= iend) then delta = 0.0 delta(istart:iend) = & - utility_w0gauss_vec((eig(n) - eig(m) + omega(istart:iend))/eta_smr, kubo_smr_index)/eta_smr + utility_w0gauss_vec((eig(n) - eig(m) + omega(istart:iend))/eta_smr, & + pw90_berry%kubo_smearing%type_index, stdout, seedname)/eta_smr call DGER(18, iend - istart + 1, occ_fac, I_nm, 1, delta(istart:iend), 1, sc_k_list(:, :, istart:iend), 18) endif @@ -1855,9 +2314,17 @@ subroutine berry_get_sc_klist(kpt, sc_k_list) end subroutine berry_get_sc_klist - subroutine berry_get_shc_klist(kpt, shc_k_fermi, shc_k_freq, shc_k_band) - !====================================================================! - ! ! + !================================================! + subroutine berry_get_shc_klist(pw90_berry, dis_manifold, fermi_energy_list, kpt_latt, & + pw90_band_deriv_degen, ws_region, pw90_spin_hall, print_output, & + wannier_data, ws_distance, wigner_seitz, AA_R, HH_R, SH_R, SHR_R, & + SR_R, SS_R, SAA_R, SBB_R, u_matrix, v_matrix, eigval, & + kpt, real_lattice, scissors_shift, mp_grid, & + fermi_n, num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, stdout, comm, & + shc_k_fermi, shc_k_freq, shc_k_band) + !================================================! + ! ! Contribution from a k-point to the spin Hall conductivity on a list ! of Fermi energies or a list of frequencies or a list of energy bands ! sigma_{alpha,beta}^{gamma}(k), alpha, beta, gamma = 1, 2, 3 @@ -1875,49 +2342,83 @@ subroutine berry_get_shc_klist(kpt, shc_k_fermi, shc_k_freq, shc_k_band) ! shc_k_freq: return a list for different frequencies ! shc_k_band: return a list for each energy band ! - ! Junfeng Qiao (18/8/2018) ! - !====================================================================! + ! Junfeng Qiao (18/8/2018) + !================================================! use w90_constants, only: dp, cmplx_0, cmplx_i - use w90_utility, only: utility_rotate - use w90_parameters, only: num_wann, kubo_eigval_max, kubo_nfreq, & - kubo_freq_list, kubo_adpt_smr, kubo_smr_fixed_en_width, & - kubo_adpt_smr_max, kubo_adpt_smr_fac, berry_kmesh, & - fermi_energy_list, nfermi, shc_alpha, shc_beta, shc_gamma, & - shc_bandshift, shc_bandshift_firstband, shc_bandshift_energyshift - use w90_postw90_common, only: pw90common_get_occ, & - pw90common_fourier_R_to_k_vec, pw90common_kmesh_spacing + use w90_utility, only: utility_rotate, utility_recip_lattice_base + use w90_comms, only: w90comm_type + use w90_types, only: print_output_type, wannier_data_type, & + dis_manifold_type, kmesh_info_type, ws_region_type, ws_distance_type + use w90_postw90_types, only: pw90_berry_mod_type, pw90_spin_hall_type, & + pw90_band_deriv_degen_type, wigner_seitz_type + use w90_postw90_common, only: pw90common_get_occ, pw90common_fourier_R_to_k_vec, & + pw90common_kmesh_spacing use w90_wan_ham, only: wham_get_D_h, wham_get_eig_deleig - use w90_get_oper, only: AA_R - !use w90_comms, only: my_node_id - !!! - - ! args - real(kind=dp), intent(in) :: kpt(3) - real(kind=dp), optional, intent(out) :: shc_k_fermi(nfermi) - complex(kind=dp), optional, intent(out) :: shc_k_freq(kubo_nfreq) + + implicit none + + ! arguments + type(pw90_berry_mod_type), intent(in) :: pw90_berry + type(dis_manifold_type), intent(in) :: dis_manifold + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + real(kind=dp), intent(in) :: kpt_latt(:, :) + type(pw90_band_deriv_degen_type), intent(in) :: pw90_band_deriv_degen + type(print_output_type), intent(in) :: print_output + type(ws_region_type), intent(in) :: ws_region + type(pw90_spin_hall_type), intent(in) :: pw90_spin_hall + type(w90comm_type), intent(in) :: comm + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + integer, intent(in) :: num_wann, num_bands, num_kpts, num_valence_bands, fermi_n + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: kpt(3) + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: scissors_shift + + complex(kind=dp), intent(in) :: u_matrix(:, :, :), v_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: AA_R(:, :, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: SR_R(:, :, :, :, :) ! <0n|sigma_x,y,z.(r-R)_alpha|Rm> + complex(kind=dp), allocatable, intent(inout) :: SHR_R(:, :, :, :, :) ! <0n|sigma_x,y,z.H.(r-R)_alpha|Rm> + complex(kind=dp), allocatable, intent(inout) :: SH_R(:, :, :, :) ! <0n|sigma_x,y,z.H|Rm> + complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) ! <0n|sigma_x,y,z|Rm> + complex(kind=dp), allocatable, intent(inout) :: SAA_R(:, :, :, :, :) + complex(kind=dp), allocatable, intent(inout) :: SBB_R(:, :, :, :, :) + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + logical, intent(in) :: effective_model + + complex(kind=dp), optional, intent(out) :: shc_k_freq(pw90_berry%kubo_nfreq) + real(kind=dp), optional, intent(out) :: shc_k_fermi(fermi_n) real(kind=dp), optional, intent(out) :: shc_k_band(num_wann) ! internal vars - logical :: lfreq, lfermi, lband complex(kind=dp), allocatable :: HH(:, :) complex(kind=dp), allocatable :: delHH(:, :, :) complex(kind=dp), allocatable :: UU(:, :) complex(kind=dp), allocatable :: D_h(:, :, :) complex(kind=dp), allocatable :: AA(:, :, :) + complex(kind=dp) :: js_k(num_wann, num_wann) + + logical :: lfreq, lfermi, lband - complex(kind=dp) :: js_k(num_wann, num_wann) + real(kind=dp) :: recip_lattice(3, 3), volume + integer :: n, m, i, ifreq ! Adaptive smearing - ! - real(kind=dp) :: del_eig(num_wann, 3), joint_level_spacing, & - eta_smr, Delta_k, vdum(3) - - integer :: n, m, i, ifreq - real(kind=dp) :: eig(num_wann) - real(kind=dp) :: occ_fermi(num_wann, nfermi), occ_freq(num_wann) - complex(kind=dp) :: omega_list(kubo_nfreq) - real(kind=dp) :: omega, rfac + real(kind=dp) :: del_eig(num_wann, 3), joint_level_spacing, eta_smr, Delta_k, vdum(3) + real(kind=dp) :: eig(num_wann) + real(kind=dp) :: occ_fermi(num_wann, fermi_n), occ_freq(num_wann) + real(kind=dp) :: omega, rfac + + complex(kind=dp) :: omega_list(pw90_berry%kubo_nfreq) complex(kind=dp) :: prod, cdum, cfac allocate (HH(num_wann, num_wann)) @@ -1942,34 +2443,44 @@ subroutine berry_get_shc_klist(kpt, shc_k_fermi, shc_k_freq, shc_k_band) lband = .true. endif - call wham_get_eig_deleig(kpt, eig, del_eig, HH, delHH, UU) - call wham_get_D_h(delHH, UU, eig, D_h) + call wham_get_eig_deleig(dis_manifold, kpt_latt, pw90_band_deriv_degen, ws_region, print_output, wannier_data, & + ws_distance, wigner_seitz, delHH, HH, HH_R, u_matrix, UU, v_matrix, & + del_eig, eig, eigval, kpt, real_lattice, scissors_shift, mp_grid, & + num_bands, num_kpts, num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm) + call wham_get_D_h(delHH, D_h, UU, eig, num_wann) ! Here I apply a scissor operator to the conduction bands, if required in the input - if (shc_bandshift) then - eig(shc_bandshift_firstband:) = eig(shc_bandshift_firstband:) + shc_bandshift_energyshift + if (pw90_spin_hall%bandshift) then + eig(pw90_spin_hall%bandshift_firstband:) = eig(pw90_spin_hall%bandshift_firstband:) + pw90_spin_hall%bandshift_energyshift end if - call pw90common_fourier_R_to_k_vec(kpt, AA_R, OO_true=AA) + call pw90common_fourier_R_to_k_vec(ws_region, wannier_data, ws_distance, wigner_seitz, AA_R, kpt, & + real_lattice, mp_grid, num_wann, seedname, & + stdout, OO_true=AA) do i = 1, 3 AA(:, :, i) = utility_rotate(AA(:, :, i), UU, num_wann) enddo AA = AA + cmplx_i*D_h ! Eq.(25) WYSV06 - call berry_get_js_k(kpt, eig, del_eig(:, shc_alpha), delHH(:, :, shc_alpha), & - D_h(:, :, shc_alpha), UU, js_k) + call berry_get_js_k(ws_region, pw90_spin_hall, wannier_data, ws_distance, wigner_seitz, & + D_h(:, :, pw90_spin_hall%alpha), js_k, SH_R, SHR_R, SR_R, SS_R, SAA_R, & + SBB_R, UU, eig, del_eig(:, pw90_spin_hall%alpha), & + delHH(:, :, pw90_spin_hall%alpha), kpt, real_lattice, mp_grid, num_wann, & + seedname, stdout) - ! adpt_smr only works with berry_kmesh, so do not use + ! adpt_smr only works with pw90_berry_kmesh, so do not use ! adpt_smr in kpath or kslice plots. - if (kubo_adpt_smr) then - Delta_k = pw90common_kmesh_spacing(berry_kmesh) + if (pw90_berry%kubo_smearing%use_adaptive) then + call utility_recip_lattice_base(real_lattice, recip_lattice, volume) + Delta_k = pw90common_kmesh_spacing(pw90_berry%kmesh%mesh, recip_lattice) endif if (lfreq) then - call pw90common_get_occ(eig, occ_freq, fermi_energy_list(1)) + call pw90common_get_occ(fermi_energy_list(1), eig, occ_freq, num_wann) elseif (lfermi) then ! get occ for different fermi_energy - do i = 1, nfermi - call pw90common_get_occ(eig, occ_fermi(:, i), fermi_energy_list(i)) + do i = 1, fermi_n + call pw90common_get_occ(fermi_energy_list(i), eig, occ_fermi(:, i), num_wann) end do end if do n = 1, num_wann @@ -1981,26 +2492,24 @@ subroutine berry_get_shc_klist(kpt, shc_k_fermi, shc_k_freq, shc_k_band) end if do m = 1, num_wann if (m == n) cycle - if (eig(m) > kubo_eigval_max .or. eig(n) > kubo_eigval_max) cycle + if (eig(m) > pw90_berry%kubo_eigval_max .or. eig(n) > pw90_berry%kubo_eigval_max) cycle rfac = eig(m) - eig(n) !this will calculate AHC !prod = -rfac*cmplx_i*AA(n, m, shc_alpha) * rfac*cmplx_i*AA(m, n, shc_beta) - prod = js_k(n, m)*cmplx_i*rfac*AA(m, n, shc_beta) - !prod = cmplx_i*rfac - !prod = js_k(n,m)*cmplx_i*rfac - if (kubo_adpt_smr) then + prod = js_k(n, m)*cmplx_i*rfac*AA(m, n, pw90_spin_hall%beta) + if (pw90_berry%kubo_smearing%use_adaptive) then ! Eq.(35) YWVS07 vdum(:) = del_eig(m, :) - del_eig(n, :) joint_level_spacing = sqrt(dot_product(vdum(:), vdum(:)))*Delta_k - eta_smr = min(joint_level_spacing*kubo_adpt_smr_fac, & - kubo_adpt_smr_max) + eta_smr = min(joint_level_spacing*pw90_berry%kubo_smearing%adaptive_prefactor, & + pw90_berry%kubo_smearing%adaptive_max_width) else - eta_smr = kubo_smr_fixed_en_width + eta_smr = pw90_berry%kubo_smearing%fixed_width endif if (lfreq) then - do ifreq = 1, kubo_nfreq - cdum = real(kubo_freq_list(ifreq), dp) + cmplx_i*eta_smr + do ifreq = 1, pw90_berry%kubo_nfreq + cdum = real(pw90_berry%kubo_freq_list(ifreq), dp) + cmplx_i*eta_smr cfac = -2.0_dp/(rfac**2 - cdum**2) omega_list(ifreq) = omega_list(ifreq) + cfac*aimag(prod) end do @@ -2011,7 +2520,7 @@ subroutine berry_get_shc_klist(kpt, shc_k_fermi, shc_k_freq, shc_k_band) enddo if (lfermi) then - do i = 1, nfermi + do i = 1, fermi_n shc_k_fermi(i) = shc_k_fermi(i) + occ_fermi(n, i)*omega end do else if (lfreq) then @@ -2030,12 +2539,15 @@ subroutine berry_get_shc_klist(kpt, shc_k_fermi, shc_k_freq, shc_k_band) contains - !===========================================================! - ! PRIVATE PROCEDURES ! - !===========================================================! - subroutine berry_get_js_k(kpt, eig, del_alpha_eig, delHH_alpha, D_alpha_h, UU, js_k) - !====================================================================! - ! ! + !================================================! + ! PRIVATE PROCEDURES + !================================================! + subroutine berry_get_js_k(ws_region, pw90_spin_hall, wannier_data, ws_distance, wigner_seitz, & + D_alpha_h, js_k, SH_R, SHR_R, SR_R, SS_R, SAA_R, SBB_R, UU, eig, & + del_alpha_eig, delHH_alpha, kpt, real_lattice, mp_grid, num_wann, & + seedname, stdout) + !================================================! + ! ! Contribution from point k to the ! ! @@ -2043,79 +2555,110 @@ subroutine berry_get_js_k(kpt, eig, del_alpha_eig, delHH_alpha, D_alpha_h, UU, j ! not divided by hbar (required by velocity operator) ! ! Junfeng Qiao (8/7/2018) - ! ! - !====================================================================! - + ! + !================================================! use w90_constants, only: dp, cmplx_0, cmplx_i use w90_utility, only: utility_rotate - use w90_parameters, only: num_wann, shc_alpha, shc_gamma, shc_method - use w90_postw90_common, only: pw90common_fourier_R_to_k_new, & - pw90common_fourier_R_to_k_vec - use w90_get_oper, only: SS_R, SR_R, SHR_R, SH_R, HH_R, SAA_R, SBB_R - - ! args - real(kind=dp), intent(in) :: kpt(3) - real(kind=dp), dimension(:), intent(in) :: eig - real(kind=dp), dimension(:), intent(in) :: del_alpha_eig + use w90_types, only: print_output_type, wannier_data_type, ws_region_type, & + ws_distance_type + use w90_postw90_types, only: pw90_spin_hall_type, wigner_seitz_type + use w90_postw90_common, only: pw90common_fourier_R_to_k_new, pw90common_fourier_R_to_k_vec + + implicit none + + ! arguments + type(ws_region_type), intent(in) :: ws_region + type(pw90_spin_hall_type), intent(in) :: pw90_spin_hall + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(in) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: kpt(3) + real(kind=dp), intent(in) :: eig(:) + real(kind=dp), intent(in) :: del_alpha_eig(:) + real(kind=dp), intent(in) :: real_lattice(3, 3) + complex(kind=dp), dimension(:, :), intent(in) :: delHH_alpha - complex(kind=dp), dimension(:, :), intent(in) :: D_alpha_h - complex(kind=dp), dimension(:, :), intent(in) :: UU - complex(kind=dp), dimension(:, :), intent(out) :: js_k + complex(kind=dp), intent(in) :: D_alpha_h(:, :) + complex(kind=dp), intent(in) :: UU(:, :) + complex(kind=dp), intent(out) :: js_k(:, :) + complex(kind=dp), allocatable, intent(inout) :: SR_R(:, :, :, :, :) ! <0n|sigma_x,y,z.(r-R)_alpha|Rm> + complex(kind=dp), allocatable, intent(inout) :: SHR_R(:, :, :, :, :) ! <0n|sigma_x,y,z.H.(r-R)_alpha|Rm> + complex(kind=dp), allocatable, intent(inout) :: SH_R(:, :, :, :) ! <0n|sigma_x,y,z.H|Rm> + complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) ! <0n|sigma_x,y,z|Rm> + complex(kind=dp), allocatable, intent(inout) :: SAA_R(:, :, :, :, :) + complex(kind=dp), allocatable, intent(inout) :: SBB_R(:, :, :, :, :) + + character(len=50), intent(in) :: seedname ! internal vars - complex(kind=dp) :: B_k(num_wann, num_wann) - complex(kind=dp) :: K_k(num_wann, num_wann) - complex(kind=dp) :: L_k(num_wann, num_wann) - complex(kind=dp) :: S_w(num_wann, num_wann) - complex(kind=dp) :: S_k(num_wann, num_wann) - complex(kind=dp) :: SR_w(num_wann, num_wann, 3) - complex(kind=dp) :: SR_alpha_k(num_wann, num_wann) - complex(kind=dp) :: SHR_w(num_wann, num_wann, 3) - complex(kind=dp) :: SHR_alpha_k(num_wann, num_wann) - complex(kind=dp) :: SH_w(num_wann, num_wann, 3) - complex(kind=dp) :: SH_k(num_wann, num_wann) - complex(kind=dp) :: eig_mat(num_wann, num_wann) - complex(kind=dp) :: del_eig_mat(num_wann, num_wann) + complex(kind=dp) :: B_k(num_wann, num_wann) + complex(kind=dp) :: K_k(num_wann, num_wann) + complex(kind=dp) :: L_k(num_wann, num_wann) + complex(kind=dp) :: S_w(num_wann, num_wann) + complex(kind=dp) :: S_k(num_wann, num_wann) + complex(kind=dp) :: SR_w(num_wann, num_wann, 3) + complex(kind=dp) :: SR_alpha_k(num_wann, num_wann) + complex(kind=dp) :: SHR_w(num_wann, num_wann, 3) + complex(kind=dp) :: SHR_alpha_k(num_wann, num_wann) + complex(kind=dp) :: SH_w(num_wann, num_wann, 3) + complex(kind=dp) :: SH_k(num_wann, num_wann) + complex(kind=dp) :: eig_mat(num_wann, num_wann) + complex(kind=dp) :: del_eig_mat(num_wann, num_wann) !ryoo complex(kind=dp) :: SAA(num_wann, num_wann, 3, 3) complex(kind=dp) :: SBB(num_wann, num_wann, 3, 3) complex(kind=dp) :: VV0(num_wann, num_wann) complex(kind=dp) :: spinvel0(num_wann, num_wann) - integer :: i, j + integer :: i - !=========== + !================================================ js_k = cmplx_0 - !=========== S_k =========== + !================================================ S_k =========== ! < u_k | sigma_gamma | u_k >, QZYZ18 Eq.(25) ! QZYZ18 Eq.(36) - call pw90common_fourier_R_to_k_new(kpt, SS_R(:, :, :, shc_gamma), OO=S_w) + call pw90common_fourier_R_to_k_new(ws_region, wannier_data, ws_distance, wigner_seitz, & + SS_R(:, :, :, pw90_spin_hall%gamma), kpt, real_lattice, & + mp_grid, num_wann, seedname, stdout, OO=S_w) ! QZYZ18 Eq.(30) S_k = utility_rotate(S_w, UU, num_wann) - if (index(shc_method, 'qiao') > 0) then !if Qiao - !=========== K_k =========== + if (index(pw90_spin_hall%method, 'qiao') > 0) then !if Qiao + !================================================ K_k =========== ! < u_k | sigma_gamma | \partial_alpha u_k >, QZYZ18 Eq.(26) ! QZYZ18 Eq.(37) - call pw90common_fourier_R_to_k_vec(kpt, SR_R(:, :, :, shc_gamma, :), OO_true=SR_w) + call pw90common_fourier_R_to_k_vec(ws_region, wannier_data, ws_distance, wigner_seitz, & + SR_R(:, :, :, pw90_spin_hall%gamma, :), kpt, & + real_lattice, mp_grid, num_wann, seedname, stdout, & + OO_true=SR_w) ! QZYZ18 Eq.(31) - SR_alpha_k = -cmplx_i*utility_rotate(SR_w(:, :, shc_alpha), UU, num_wann) + SR_alpha_k = -cmplx_i*utility_rotate(SR_w(:, :, pw90_spin_hall%alpha), UU, num_wann) K_k = SR_alpha_k + matmul(S_k, D_alpha_h) - !=========== L_k =========== + !================================================ L_k =========== ! < u_k | sigma_gamma.H | \partial_alpha u_k >, QZYZ18 Eq.(27) ! QZYZ18 Eq.(38) - call pw90common_fourier_R_to_k_vec(kpt, SHR_R(:, :, :, shc_gamma, :), OO_true=SHR_w) + call pw90common_fourier_R_to_k_vec(ws_region, wannier_data, ws_distance, wigner_seitz, & + SHR_R(:, :, :, pw90_spin_hall%gamma, :), kpt, & + real_lattice, mp_grid, num_wann, seedname, stdout, & + OO_true=SHR_w) ! QZYZ18 Eq.(32) - SHR_alpha_k = -cmplx_i*utility_rotate(SHR_w(:, :, shc_alpha), UU, num_wann) + SHR_alpha_k = -cmplx_i*utility_rotate(SHR_w(:, :, pw90_spin_hall%alpha), UU, num_wann) ! QZYZ18 Eq.(39) - call pw90common_fourier_R_to_k_vec(kpt, SH_R, OO_true=SH_w) + call pw90common_fourier_R_to_k_vec(ws_region, wannier_data, ws_distance, wigner_seitz, & + SH_R, kpt, real_lattice, mp_grid, num_wann, seedname, & + stdout, OO_true=SH_w) ! QZYZ18 Eq.(32) - SH_k = utility_rotate(SH_w(:, :, shc_gamma), UU, num_wann) + SH_k = utility_rotate(SH_w(:, :, pw90_spin_hall%gamma), UU, num_wann) L_k = SHR_alpha_k + matmul(SH_k, D_alpha_h) - !=========== B_k =========== + !================================================ B_k =========== ! < \psi_nk | sigma_gamma v_alpha | \psi_mk >, QZYZ18 Eq.(24) B_k = cmplx_0 do i = 1, num_wann @@ -2125,7 +2668,7 @@ subroutine berry_get_js_k(kpt, eig, del_alpha_eig, delHH_alpha, D_alpha_h, UU, j ! note * is not matmul B_k = del_eig_mat*S_k + eig_mat*K_k - L_k - !=========== js_k =========== + !================================================ js_k =========== ! QZYZ18 Eq.(23) ! note the S in SR_R,SHR_R,SH_R of get_SHC_R is sigma, ! to get spin current, we need to multiply it by hbar/2, @@ -2135,17 +2678,27 @@ subroutine berry_get_js_k(kpt, eig, del_alpha_eig, delHH_alpha, D_alpha_h, UU, j else !if Ryoo (PRB RPS19 Eq.(21)) !RPS19 Eqs.(37)-(40) - call pw90common_fourier_R_to_k_new(kpt, SAA_R(:, :, :, shc_gamma, shc_alpha), OO=SAA(:, :, shc_gamma, shc_alpha)) - call pw90common_fourier_R_to_k_new(kpt, SBB_R(:, :, :, shc_gamma, shc_alpha), OO=SBB(:, :, shc_gamma, shc_alpha)) - - call pw90common_fourier_R_to_k_new(kpt, HH_R, OO=HH, & + call pw90common_fourier_R_to_k_new(ws_region, wannier_data, ws_distance, wigner_seitz, & + SAA_R(:, :, :, pw90_spin_hall%gamma, pw90_spin_hall%alpha), & + kpt, real_lattice, mp_grid, num_wann, seedname, stdout, & + OO=SAA(:, :, pw90_spin_hall%gamma, pw90_spin_hall%alpha)) + call pw90common_fourier_R_to_k_new(ws_region, wannier_data, ws_distance, wigner_seitz, & + SBB_R(:, :, :, pw90_spin_hall%gamma, pw90_spin_hall%alpha), & + kpt, real_lattice, mp_grid, num_wann, seedname, & + stdout, OO=SBB(:, :, pw90_spin_hall%gamma, pw90_spin_hall%alpha)) + + call pw90common_fourier_R_to_k_new(ws_region, wannier_data, ws_distance, wigner_seitz, & + HH_R, kpt, real_lattice, mp_grid, num_wann, seedname, & + stdout, OO=HH, & OO_dx=delHH(:, :, 1), & OO_dy=delHH(:, :, 2), & OO_dz=delHH(:, :, 3)) VV0(:, :) = utility_rotate(delHH_alpha(:, :), UU, num_wann) - SAA(:, :, shc_gamma, shc_alpha) = utility_rotate(SAA(:, :, shc_gamma, shc_alpha), UU, num_wann) - SBB(:, :, shc_gamma, shc_alpha) = utility_rotate(SBB(:, :, shc_gamma, shc_alpha), UU, num_wann) + SAA(:, :, pw90_spin_hall%gamma, pw90_spin_hall%alpha) = & + utility_rotate(SAA(:, :, pw90_spin_hall%gamma, pw90_spin_hall%alpha), UU, num_wann) + SBB(:, :, pw90_spin_hall%gamma, pw90_spin_hall%alpha) = & + utility_rotate(SBB(:, :, pw90_spin_hall%gamma, pw90_spin_hall%alpha), UU, num_wann) spinVel0(:, :) = matmul(VV0(:, :), S_k(:, :)) + & matmul(S_k(:, :), VV0(:, :)) @@ -2153,93 +2706,135 @@ subroutine berry_get_js_k(kpt, eig, del_alpha_eig, delHH_alpha, D_alpha_h, UU, j do n = 1, num_wann do m = 1, num_wann !RPS19 Eq.(21) and Eq.(26) js_k(n, m) = spinVel0(n, m) & - - cmplx_i*(eig(m)*SAA(n, m, shc_gamma, shc_alpha) - SBB(n, m, shc_gamma, shc_alpha)) + - cmplx_i*(eig(m)*SAA(n, m, pw90_spin_hall%gamma, pw90_spin_hall%alpha) & + - SBB(n, m, pw90_spin_hall%gamma, pw90_spin_hall%alpha)) js_k(n, m) = js_k(n, m) & - + cmplx_i*(eig(n)*conjg(SAA(m, n, shc_gamma, shc_alpha)) - conjg(SBB(m, n, shc_gamma, shc_alpha))) + + cmplx_i*(eig(n)*conjg(SAA(m, n, pw90_spin_hall%gamma, pw90_spin_hall%alpha)) & + - conjg(SBB(m, n, pw90_spin_hall%gamma, pw90_spin_hall%alpha))) enddo enddo js_k = js_k/2.0_dp endif - !------------------------------------------------------------------- end subroutine berry_get_js_k end subroutine berry_get_shc_klist - subroutine berry_print_progress(loop_k, start_k, end_k, step_k) - !============================================================! + !================================================! + subroutine berry_print_progress(end_k, loop_k, start_k, step_k, stdout) + !================================================! ! print k-points calculation progress, seperated into 11 points, ! from 0%, 10%, ... to 100% ! start_k, end_k are inclusive ! loop_k should in the array start_k to end_k with step step_k - !============================================================! - use w90_comms, only: on_root - use w90_io, only: stdout, io_wallclocktime + ! + ! only call from root MPI process! + !================================================! + + use w90_io, only: io_wallclocktime - integer, intent(in) :: loop_k, start_k, end_k, step_k + implicit none + ! arguments + integer, intent(in) :: loop_k, start_k, end_k, step_k, stdout + + ! local variables real(kind=dp) :: cur_time, finished real(kind=dp), save :: prev_time integer :: i, j, n, last_k logical, dimension(9) :: kmesh_processed = (/(.false., i=1, 9)/) - if (on_root) then - ! The last loop_k in the array start:step:end - ! e.g. 4 of 0:4:7 = [0, 4], 11 of 3:4:11 = [3, 7, 11] - last_k = (CEILING((end_k - start_k + 1)/real(step_k)) - 1)*step_k + start_k - - if (loop_k == start_k) then - write (stdout, '(1x,a)') '' - write (stdout, '(1x,a)') 'Calculation started' - write (stdout, '(1x,a)') '-------------------------------' - write (stdout, '(1x,a)') ' k-points wall diff' - write (stdout, '(1x,a)') ' calculated time time' - write (stdout, '(1x,a)') ' ---------- ---- ----' - cur_time = io_wallclocktime() - prev_time = cur_time - write (stdout, '(5x,a,3x,f10.1,f10.1)') ' 0%', cur_time, cur_time - prev_time - else if (loop_k == last_k) then - cur_time = io_wallclocktime() - write (stdout, '(5x,a,3x,f10.1,f10.1)') '100%', cur_time, cur_time - prev_time - write (stdout, '(1x,a)') '' - else - finished = 10.0_dp*real(loop_k - start_k + 1)/real(end_k - start_k + 1) - do n = 1, size(kmesh_processed) - if ((.not. kmesh_processed(n)) .and. (finished >= n)) then - do i = n, size(kmesh_processed) - if (i <= finished) then - j = i - kmesh_processed(i) = .true. - end if - end do - cur_time = io_wallclocktime() - write (stdout, '(5x,i2,a,3x,f10.1,f10.1)') j, '0%', cur_time, cur_time - prev_time - prev_time = cur_time - exit - end if - end do - end if - end if ! on_root + ! The last loop_k in the array start:step:end + ! e.g. 4 of 0:4:7 = [0, 4], 11 of 3:4:11 = [3, 7, 11] + last_k = (CEILING((end_k - start_k + 1)/real(step_k)) - 1)*step_k + start_k + + if (loop_k == start_k) then + write (stdout, '(1x,a)') '' + write (stdout, '(1x,a)') 'Calculation started' + write (stdout, '(1x,a)') '-------------------------------' + write (stdout, '(1x,a)') ' k-points wall diff' + write (stdout, '(1x,a)') ' calculated time time' + write (stdout, '(1x,a)') ' ---------- ---- ----' + cur_time = io_wallclocktime() + prev_time = cur_time + write (stdout, '(5x,a,3x,f10.1,f10.1)') ' 0%', cur_time, cur_time - prev_time + else if (loop_k == last_k) then + cur_time = io_wallclocktime() + write (stdout, '(5x,a,3x,f10.1,f10.1)') '100%', cur_time, cur_time - prev_time + write (stdout, '(1x,a)') '' + else + finished = 10.0_dp*real(loop_k - start_k + 1)/real(end_k - start_k + 1) + do n = 1, size(kmesh_processed) + if ((.not. kmesh_processed(n)) .and. (finished >= n)) then + do i = n, size(kmesh_processed) + if (i <= finished) then + j = i + kmesh_processed(i) = .true. + end if + end do + cur_time = io_wallclocktime() + write (stdout, '(5x,i2,a,3x,f10.1,f10.1)') j, '0%', cur_time, cur_time - prev_time + prev_time = cur_time + exit + end if + end do + end if end subroutine berry_print_progress - subroutine berry_get_kdotp(kdotp) - !====================================================================! + subroutine berry_get_kdotp(kdotp, dis_manifold, kpt_latt, print_output, pw90_berry, & + pw90_band_deriv_degen, wannier_data, ws_distance, wigner_seitz, & + ws_region, HH_R, u_matrix, v_matrix, eigval, real_lattice, & + scissors_shift, mp_grid, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, seedname, & + stdout, comm) + !================================================! ! Extracts k.p expansion coefficients using quasi-degenerate ! (Lowdin) perturbation theory, adapted to the Wannier formalism, ! see Appendix in IAdJS19 for details - !====================================================================! + !================================================! - ! Arguments - ! use w90_constants, only: dp, cmplx_0, cmplx_i - use w90_parameters, only: num_wann, kdotp_kpoint, kdotp_num_bands, kdotp_bands use w90_wan_ham, only: wham_get_D_h, wham_get_eig_UU_HH_AA_sc, wham_get_eig_deleig, & wham_get_D_h_P_value use w90_utility, only: utility_rotate + use w90_types, only: print_output_type, wannier_data_type, & + dis_manifold_type, kmesh_info_type, ws_region_type, ws_distance_type + use w90_postw90_types, only: pw90_berry_mod_type, pw90_spin_mod_type, & + pw90_spin_hall_type, pw90_band_deriv_degen_type, pw90_oper_read_type, wigner_seitz_type, & + kpoint_dist_type + use w90_comms, only: w90comm_type + + implicit none + ! Arguments - ! + type(pw90_berry_mod_type), intent(in) :: pw90_berry + type(dis_manifold_type), intent(in) :: dis_manifold + type(pw90_band_deriv_degen_type), intent(in) :: pw90_band_deriv_degen + type(print_output_type), intent(in) :: print_output + type(ws_region_type), intent(in) :: ws_region + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + type(w90comm_type), intent(in) :: comm + complex(kind=dp), intent(out), dimension(:, :, :, :, :) :: kdotp + !complex(kind=dp), allocatable, intent(inout) :: AA_R(:, :, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + complex(kind=dp), intent(in) :: u_matrix(:, :, :), v_matrix(:, :, :) + + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: scissors_shift + real(kind=dp), intent(in) :: kpt_latt(:, :) + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_wann, num_kpts, num_bands, num_valence_bands + integer, intent(in) :: stdout + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + logical, intent(in) :: effective_model complex(kind=dp), allocatable :: UU(:, :) complex(kind=dp), allocatable :: HH_da(:, :, :), HH_da_bar(:, :, :) @@ -2249,9 +2844,12 @@ subroutine berry_get_kdotp(kdotp) real(kind=dp), allocatable :: eig_da(:, :) complex(kind=dp), allocatable :: D_h(:, :, :) - real(kind=dp) :: DeltaE_n, DeltaE_m - integer :: i, if, a, b, c, bc, n, m, r, ifreq, istart, iend - logical :: break_loop + ! local variables + !real(kind=dp) :: DeltaE_n, DeltaE_m + integer :: kdotp_num_bands + integer :: i, a, b, n, m, r !, c, bc,if, ifreq, istart, iend + logical :: break_loop + allocate (UU(num_wann, num_wann)) allocate (HH_da(num_wann, num_wann, 3)) allocate (HH_da_bar(num_wann, num_wann, 3)) @@ -2266,11 +2864,21 @@ subroutine berry_get_kdotp(kdotp) ! Gather W-gauge matrix objects ! ! get Hamiltonian and its first and second derivatives - call wham_get_eig_UU_HH_AA_sc(kdotp_kpoint, eig, UU, HH, HH_da, HH_dadb) + call wham_get_eig_UU_HH_AA_sc(dis_manifold, kpt_latt, ws_region, & + print_output, wannier_data, ws_distance, wigner_seitz, HH, & + HH_da, HH_dadb, HH_R, u_matrix, UU, v_matrix, eig, eigval, & + pw90_berry%kdotp_kpoint, real_lattice, scissors_shift, mp_grid, & + num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, stdout, comm) ! get eigenvalues and their k-derivatives - call wham_get_eig_deleig(kdotp_kpoint, eig, eig_da, HH, HH_da, UU) + call wham_get_eig_deleig(dis_manifold, kpt_latt, pw90_band_deriv_degen, ws_region, & + print_output, wannier_data, ws_distance, wigner_seitz, HH_da, HH, & + HH_R, u_matrix, UU, v_matrix, eig_da, eig, eigval, & + pw90_berry%kdotp_kpoint, real_lattice, scissors_shift, mp_grid, & + num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, stdout, comm) ! get D_h (Eq. (24) WYSV06) - call wham_get_D_h_P_value(HH_da, UU, eig, D_h) + call wham_get_D_h_P_value(pw90_berry, HH_da, D_h, UU, eig, num_wann) ! rotate quantities from W to H gauge HH_bar(:, :) = utility_rotate(HH(:, :), UU, num_wann) @@ -2283,21 +2891,23 @@ subroutine berry_get_kdotp(kdotp) enddo enddo + kdotp_num_bands = size(pw90_berry%kdotp_bands) ! loop on initial and final bands in k.p set (subset A in IAdJS19) do n = 1, kdotp_num_bands do m = 1, kdotp_num_bands ! zeroth order term - if (n == m) kdotp(n, m, 1, 1, 1) = eig(kdotp_bands(n)) + if (n == m) kdotp(n, m, 1, 1, 1) = eig(pw90_berry%kdotp_bands(n)) ! first order term do a = 1, 3 - kdotp(n, m, 2, a, 1) = HH_da_bar(kdotp_bands(n), kdotp_bands(m), a) + kdotp(n, m, 2, a, 1) = HH_da_bar(pw90_berry%kdotp_bands(n), pw90_berry%kdotp_bands(m), a) end do ! second order term do a = 1, 3 do b = 1, 3 ! add contribution independent of other states - kdotp(n, m, 3, a, b) = 0.5*(HH_dadb_bar(kdotp_bands(n), kdotp_bands(m), a, b)) + kdotp(n, m, 3, a, b) = 0.5*(HH_dadb_bar(pw90_berry%kdotp_bands(n), & + pw90_berry%kdotp_bands(m), a, b)) ! add contribution dependent on other states (subset B in IAdJS19) do r = 1, num_wann @@ -2305,13 +2915,15 @@ subroutine berry_get_kdotp(kdotp) ! cycle for bands in the k.p set (subset A) break_loop = .false. do i = 1, kdotp_num_bands - if (r == kdotp_bands(i)) break_loop = .true. + if (r == pw90_berry%kdotp_bands(i)) break_loop = .true. end do if (break_loop) cycle kdotp(n, m, 3, a, b) = kdotp(n, m, 3, a, b) + & - 0.5*HH_da_bar(kdotp_bands(n), r, a)*HH_da_bar(r, kdotp_bands(m), b) & - *((eig(kdotp_bands(n)) - eig(r))**(-1) + (eig(kdotp_bands(m)) - eig(r))**(-1)) + 0.5*HH_da_bar(pw90_berry%kdotp_bands(n), r, a) & + *HH_da_bar(r, pw90_berry%kdotp_bands(m), b) & + *((eig(pw90_berry%kdotp_bands(n)) - eig(r))**(-1) & + + (eig(pw90_berry%kdotp_bands(m)) - eig(r))**(-1)) end do end do diff --git a/src/postw90/boltzwann.F90 b/src/postw90/boltzwann.F90 index 750a3277d..21014c97e 100644 --- a/src/postw90/boltzwann.F90 +++ b/src/postw90/boltzwann.F90 @@ -11,8 +11,13 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! w90_boltzwann: Boltzman transport ! +! ! +!------------------------------------------------------------! module w90_boltzwann + !================================================! !! Compute Boltzman tranport properties !! !! BoltzWann routines by @@ -32,23 +37,19 @@ module w90_boltzwann !![1] G. Pizzi, D. Volja, B. Kozinsky, M. Fornari, N. Marzari !! Comp. Phys. Comm. 185, 422 (2014) !! DOI: 10.1016/j.cpc.2013.09.015 (arXiv:1305.1587) - !============================================================! - use w90_constants - use w90_parameters, only: & - boltz_mu_min, boltz_mu_max, boltz_mu_step, boltz_temp_min, boltz_temp_max, boltz_temp_step, & - boltz_kmesh_spacing, boltz_kmesh, boltz_tdf_energy_step, boltz_relax_time, & - boltz_bandshift, boltz_bandshift_firstband, boltz_bandshift_energyshift, & - timing_level, dis_win_min, dis_win_max, spin_decomp, boltz_dos_adpt_smr, & - boltz_dos_adpt_smr_fac, boltz_dos_smr_fixed_en_width, boltz_2d_dir_num, & - boltz_tdf_smr_fixed_en_width, cell_volume, num_elec_per_state, iprint - use w90_io, only: io_error, stdout, io_stopwatch, io_file_unit, seedname - use w90_utility, only: utility_inv3, utility_inv2 - use w90_postw90_common - use w90_comms + !================================================! + + use w90_comms, only: mpisize, mpirank, comms_gatherv, comms_array_split, comms_reduce, & + comms_allreduce, w90comm_type + use w90_constants, only: dp, pw90_physical_constants_type, min_smearing_binwidth_ratio use w90_dos, only: dos_get_k, dos_get_levelspacing + use w90_io, only: io_error, io_stopwatch, io_file_unit + use w90_utility, only: utility_inv3, utility_inv2 + implicit none private + public :: boltzwann_main ! Constants to identify the six components of a tensor when it is stored in packed form @@ -70,7 +71,15 @@ module w90_boltzwann contains - subroutine boltzwann_main() + !================================================! + + subroutine boltzwann_main(pw90_boltzwann, dis_manifold, pw90_dos, kpt_latt, & + pw90_band_deriv_degen, postw90_oper, pw90_spin, physics, ws_region, & + w90_system, wannier_data, ws_distance, wigner_seitz, print_output, & + HH_R, SS_R, v_matrix, u_matrix, eigval, real_lattice, scissors_shift, & + mp_grid, num_wann, num_bands, num_kpts, effective_model, & + have_disentangled, spin_decomp, seedname, stdout, comm) + !================================================! !! This is the main routine of the BoltzWann module. !! It calculates the transport coefficients using the Boltzmann transport equation. !! @@ -85,38 +94,97 @@ subroutine boltzwann_main() !! !! Files from 2 to 4 are output on a grid of (mu,T) points, where mu is the chemical potential in eV and !! T is the temperature in Kelvin. The grid is defined in the input. + !================================================! + + use w90_constants, only: dp + use w90_io, only: io_file_unit, io_error, io_stopwatch + use w90_comms, only: comms_bcast, w90comm_type, mpirank + use w90_types, only: dis_manifold_type, print_output_type, wannier_data_type, & + ws_region_type, w90_system_type, ws_distance_type + use w90_postw90_types, only: pw90_boltzwann_type, pw90_spin_mod_type, & + pw90_band_deriv_degen_type, pw90_dos_mod_type, pw90_oper_read_type, wigner_seitz_type + + implicit none + + ! arguments + type(pw90_boltzwann_type), intent(in) :: pw90_boltzwann + type(dis_manifold_type), intent(in) :: dis_manifold + type(pw90_dos_mod_type), intent(in) :: pw90_dos + type(pw90_band_deriv_degen_type), intent(in) :: pw90_band_deriv_degen + type(pw90_oper_read_type), intent(in) :: postw90_oper + type(pw90_spin_mod_type), intent(in) :: pw90_spin + type(print_output_type), intent(in) :: print_output + type(pw90_physical_constants_type), intent(in) :: physics + type(ws_region_type), intent(in) :: ws_region + type(w90comm_type), intent(in) :: comm + type(w90_system_type), intent(in) :: w90_system + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) ! <0n|sigma_x,y,z|Rm> + complex(kind=dp), intent(in) :: v_matrix(:, :, :), u_matrix(:, :, :) + + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: scissors_shift + real(kind=dp), intent(in) :: kpt_latt(:, :) + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_wann, num_bands, num_kpts + integer, intent(in) :: stdout + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + logical, intent(in) :: spin_decomp + logical, intent(in) :: effective_model + + ! local variables integer :: TempNumPoints, MuNumPoints, TDFEnergyNumPoints integer :: i, j, ierr, EnIdx, TempIdx, MuIdx - real(kind=dp), dimension(:), allocatable :: TempArray, MuArray, KTArray - real(kind=dp), dimension(:, :, :), allocatable :: TDF ! (coordinate,Energy) - real(kind=dp), dimension(:), allocatable :: TDFEnergyArray - real(kind=dp), dimension(:, :), allocatable :: IntegrandArray ! (coordinate, Energy) at a given T and mu - real(kind=dp), dimension(3, 3) :: SigmaS_FP, ThisElCond, ElCondInverse, ThisSeebeck - real(kind=dp), dimension(2, 2) :: ThisElCond2d, ElCondInverse2d - real(kind=dp), dimension(6) :: ElCondTimesSeebeck - real(kind=dp), dimension(:, :, :), allocatable :: ElCond ! (coordinate,Temp, mu) - real(kind=dp), dimension(:, :, :), allocatable :: SigmaS ! (coordinate,Temp, mu) - real(kind=dp), dimension(:, :, :), allocatable :: Seebeck ! (coordinate,Temp, mu) - real(kind=dp), dimension(:, :, :), allocatable :: Kappa ! (coordinate,Temp, mu) - real(kind=dp), dimension(:, :), allocatable :: LocalElCond ! (coordinate,Temp+mu combined index) - real(kind=dp), dimension(:, :), allocatable :: LocalSigmaS ! (coordinate,Temp+mu combined index) - real(kind=dp), dimension(:, :), allocatable :: LocalSeebeck ! (coordinate,Temp+mu combined index) - real(kind=dp), dimension(:, :), allocatable :: LocalKappa ! (coordinate,Temp+mu combined index) - real(kind=dp) :: Determinant + real(kind=dp), allocatable :: TempArray(:), MuArray(:), KTArray(:) + real(kind=dp), allocatable :: TDF(:, :, :) ! (coordinate,Energy) + real(kind=dp), allocatable :: TDFEnergyArray(:) + real(kind=dp), allocatable :: IntegrandArray(:, :) ! (coordinate, Energy) at a given T and mu + real(kind=dp) :: SigmaS_FP(3, 3), ThisElCond(3, 3), ElCondInverse(3, 3), ThisSeebeck(3, 3) + real(kind=dp) :: ThisElCond2d(2, 2), ElCondInverse2d(2, 2) + !real(kind=dp), dimension(6) :: ElCondTimesSeebeck + real(kind=dp), allocatable :: ElCond(:, :, :) ! (coordinate,Temp, mu) + real(kind=dp), allocatable :: SigmaS(:, :, :) ! (coordinate,Temp, mu) + real(kind=dp), allocatable :: Seebeck(:, :, :) ! (coordinate,Temp, mu) + real(kind=dp), allocatable :: Kappa(:, :, :) ! (coordinate,Temp, mu) + real(kind=dp), allocatable :: LocalElCond(:, :) ! (coordinate,Temp+mu combined index) + real(kind=dp), allocatable :: LocalSigmaS(:, :) ! (coordinate,Temp+mu combined index) + real(kind=dp), allocatable :: LocalSeebeck(:, :) ! (coordinate,Temp+mu combined index) + real(kind=dp), allocatable :: LocalKappa(:, :) ! (coordinate,Temp+mu combined index) + real(kind=dp) :: Determinant integer :: tdf_unit, elcond_unit, sigmas_unit, seebeck_unit, kappa_unit, ndim - ! Needed to split an array on different nodes - integer, dimension(0:num_nodes - 1) :: counts - integer, dimension(0:num_nodes - 1) :: displs integer :: LocalIdx, GlobalIdx ! I also add 3 times the smearing on each side of the TDF energy array to take into account also possible smearing effects real(kind=dp), parameter :: TDF_exceeding_energy_times_smr = 3._dp real(kind=dp) :: TDF_exceeding_energy + real(kind=dp) :: cell_volume integer :: NumberZeroDet - if (on_root .and. (timing_level > 0)) call io_stopwatch('boltzwann_main', 1) + integer, allocatable :: counts(:), displs(:) + integer :: my_node_id, num_nodes + logical :: on_root = .false. - if (on_root) then + my_node_id = mpirank(comm) + num_nodes = mpisize(comm) + if (my_node_id == 0) on_root = .true. + allocate (counts(0:num_nodes - 1)) + allocate (displs(0:num_nodes - 1)) + + cell_volume = real_lattice(1, 1)*(real_lattice(2, 2)*real_lattice(3, 3) - real_lattice(3, 2)*real_lattice(2, 3)) + & + real_lattice(1, 2)*(real_lattice(2, 3)*real_lattice(3, 1) - real_lattice(3, 3)*real_lattice(2, 1)) + & + real_lattice(1, 3)*(real_lattice(2, 1)*real_lattice(3, 2) - real_lattice(3, 1)*real_lattice(2, 2)) + + if (print_output%iprint > 0 .and. print_output%timing_level > 0) call io_stopwatch('boltzwann_main', 1, stdout, seedname) + + if (print_output%iprint > 0) then write (stdout, *) write (stdout, '(1x,a)') '*---------------------------------------------------------------------------*' write (stdout, '(1x,a)') '| Boltzmann Transport (BoltzWann module) |' @@ -129,58 +197,67 @@ subroutine boltzwann_main() write (stdout, *) end if - if (on_root) then - if (boltz_2d_dir_num /= 0) then + if (print_output%iprint > 0) then + if (pw90_boltzwann%dir_num_2d /= 0) then write (stdout, '(1x,a)') '> <' write (stdout, '(1x,a)') '> NOTE! Using the 2D version for the calculation of the Seebeck <' - if (boltz_2d_dir_num == 1) then + if (pw90_boltzwann%dir_num_2d == 1) then write (stdout, '(1x,a)') '> coefficient, where the non-periodic direction is x. <' - elseif (boltz_2d_dir_num == 2) then + elseif (pw90_boltzwann%dir_num_2d == 2) then write (stdout, '(1x,a)') '> coefficient, where the non-periodic direction is y. <' - elseif (boltz_2d_dir_num == 3) then + elseif (pw90_boltzwann%dir_num_2d == 3) then write (stdout, '(1x,a)') '> coefficient, where the non-periodic direction is z. <' - else - call io_error('Unrecognized value of boltz_2d_dir_num') end if write (stdout, '(1x,a)') '> <' write (stdout, '(1x,a)') '' end if end if + ! separate error condition from info printout above (which may be avoided entirely in lib mode?) + if (pw90_boltzwann%dir_num_2d < 0 .or. pw90_boltzwann%dir_num_2d > 3) then + call io_error('Unrecognized value of pw90_boltzwann_2d_dir_num', stdout, seedname) + endif + ! I precalculate the TempArray and the MuArray - TempNumPoints = int(floor((boltz_temp_max - boltz_temp_min)/boltz_temp_step)) + 1 + TempNumPoints = int(floor((pw90_boltzwann%temp_max - pw90_boltzwann%temp_min)/pw90_boltzwann%temp_step)) + 1 allocate (TempArray(TempNumPoints), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating TempArray in boltzwann_main') + if (ierr /= 0) call io_error('Error in allocating TempArray in boltzwann_main', stdout, seedname) do i = 1, TempNumPoints - TempArray(i) = boltz_temp_min + real(i - 1, dp)*boltz_temp_step + TempArray(i) = pw90_boltzwann%temp_min + real(i - 1, dp)*pw90_boltzwann%temp_step end do ! This array contains the same temperatures of the TempArray, but multiplied by k_boltzmann, in units of eV allocate (KTArray(TempNumPoints), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating KTArray in boltzwann_main') + if (ierr /= 0) call io_error('Error in allocating KTArray in boltzwann_main', stdout, seedname) ! (k_B in eV/kelvin is equal to k_B_SI / elem_charge_SI) - KTArray = TempArray*k_B_SI/elem_charge_SI + KTArray = TempArray*physics%k_B_SI/physics%elem_charge_SI - MuNumPoints = int(floor((boltz_mu_max - boltz_mu_min)/boltz_mu_step)) + 1 + MuNumPoints = int(floor((pw90_boltzwann%mu_max - pw90_boltzwann%mu_min)/pw90_boltzwann%mu_step)) + 1 allocate (MuArray(MuNumPoints), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating MuArray in boltzwann_main') + if (ierr /= 0) call io_error('Error in allocating MuArray in boltzwann_main', stdout, seedname) do i = 1, MuNumPoints - MuArray(i) = boltz_mu_min + real(i - 1, dp)*boltz_mu_step + MuArray(i) = pw90_boltzwann%mu_min + real(i - 1, dp)*pw90_boltzwann%mu_step end do + if (pw90_boltzwann%tdf_smearing%use_adaptive) then + call io_error('Adaptive smearing not allowed in Boltzwann TDF', stdout, seedname) + endif ! I precalculate the TDFEnergyArray ! I assume that dis_win_min and dis_win_max are set to sensible values, related to the max and min energy ! This is true if the .eig file is present. I can assume its presence since we need it to interpolate the ! bands. ! I also add 3 times the smearing on each side of the TDF energy array to take into account also possible smearing effects, ! or at least 0.2 eV - TDF_exceeding_energy = max(TDF_exceeding_energy_times_smr*boltz_TDF_smr_fixed_en_width, 0.2_dp) - TDFEnergyNumPoints = int(floor((dis_win_max - dis_win_min + 2._dp*TDF_exceeding_energy)/boltz_tdf_energy_step)) + 1 + TDF_exceeding_energy = max(TDF_exceeding_energy_times_smr*pw90_boltzwann%tdf_smearing%fixed_width, 0.2_dp) + TDFEnergyNumPoints = int(floor((dis_manifold%win_max - dis_manifold%win_min & + + 2._dp*TDF_exceeding_energy)/pw90_boltzwann%tdf_energy_step)) + 1 if (TDFEnergyNumPoints .eq. 1) TDFEnergyNumPoints = 2 allocate (TDFEnergyArray(TDFEnergyNumPoints), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating TDFEnergyArray in boltzwann_main') + if (ierr /= 0) call io_error('Error in allocating TDFEnergyArray in boltzwann_main', & + stdout, seedname) do i = 1, TDFEnergyNumPoints - TDFEnergyArray(i) = dis_win_min - TDF_exceeding_energy + real(i - 1, dp)*boltz_tdf_energy_step + TDFEnergyArray(i) = dis_manifold%win_min - TDF_exceeding_energy & + + real(i - 1, dp)*pw90_boltzwann%tdf_energy_step end do if (spin_decomp) then @@ -191,10 +268,15 @@ subroutine boltzwann_main() ! I allocate the array for the TDF allocate (TDF(6, TDFEnergyNumPoints, ndim), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating TDF in boltzwann_main') + if (ierr /= 0) call io_error('Error in allocating TDF in boltzwann_main', stdout, seedname) ! I call the subroutine that calculates the Transport Distribution Function - call calcTDFandDOS(TDF, TDFEnergyArray) + call calcTDFandDOS(pw90_boltzwann, dis_manifold, pw90_dos, kpt_latt, postw90_oper, pw90_band_deriv_degen, pw90_spin, & + ws_region, print_output, wannier_data, ws_distance, wigner_seitz, HH_R, SS_R, u_matrix, & + v_matrix, eigval, real_lattice, TDF, TDFEnergyArray, & + cell_volume, scissors_shift, mp_grid, num_bands, num_kpts, num_wann, & + w90_system%num_valence_bands, w90_system%num_elec_per_state, effective_model, & + have_disentangled, spin_decomp, seedname, stdout, comm) ! The TDF array contains now the TDF, or more precisely ! hbar^2 * TDF in units of eV * fs / angstrom @@ -217,35 +299,36 @@ subroutine boltzwann_main() end if end do close (tdf_unit) - if (iprint > 1) write (stdout, '(3X,A)') "Transport distribution function written on the "//trim(seedname)//"_tdf.dat file." + if (print_output%iprint > 1) & + write (stdout, '(3X,A)') "Transport distribution function written on the "//trim(seedname)//"_tdf.dat file." end if ! ********************************************************************************* ! I got the TDF and I printed it. Now I use it to calculate the transport properties. - if (on_root .and. (timing_level > 0)) call io_stopwatch('boltzwann_main: calc_props', 1) + if (on_root .and. (print_output%timing_level > 0)) call io_stopwatch('boltzwann_main: calc_props', 1, stdout, seedname) ! I obtain the counts and displs arrays, which tell how I should partition a big array ! on the different nodes. - call comms_array_split(TempNumPoints*MuNumPoints, counts, displs) + call comms_array_split(TempNumPoints*MuNumPoints, counts, displs, comm) ! I allocate the arrays for the spectra ! Allocate at least 1 entry allocate (LocalElCond(6, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating LocalElCond in boltzwann_main') + if (ierr /= 0) call io_error('Error in allocating LocalElCond in boltzwann_main', stdout, seedname) allocate (LocalSigmaS(6, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating LocalSigmaS in boltzwann_main') + if (ierr /= 0) call io_error('Error in allocating LocalSigmaS in boltzwann_main', stdout, seedname) allocate (LocalSeebeck(9, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating LocalSeebeck in boltzwann_main') + if (ierr /= 0) call io_error('Error in allocating LocalSeebeck in boltzwann_main', stdout, seedname) allocate (LocalKappa(6, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating LocalKappa in boltzwann_main') + if (ierr /= 0) call io_error('Error in allocating LocalKappa in boltzwann_main', stdout, seedname) LocalElCond = 0._dp LocalSeebeck = 0._dp LocalKappa = 0._dp ! I allocate the array that I will use to store the functions to be integrated allocate (IntegrandArray(6, TDFEnergyNumPoints), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating FermiDerivArray in boltzwann_main') + if (ierr /= 0) call io_error('Error in allocating FermiDerivArray in boltzwann_main', stdout, seedname) NumberZeroDet = 0 ! Now, I calculate the various spectra for all mu and T values @@ -265,7 +348,7 @@ subroutine boltzwann_main() end do ! Now, IntegrandArray contains (-dn/dE) * TDF_ij(E), where n is the Fermi distribution function ! Its integral is ElCond_ij/e^2 - LocalElCond(:, LocalIdx) = sum(IntegrandArray, DIM=2)*boltz_tdf_energy_step + LocalElCond(:, LocalIdx) = sum(IntegrandArray, DIM=2)*pw90_boltzwann%tdf_energy_step ! ElCond contains now (hbar^2/e^2) * sigma in eV*fs/angstrom, where sigma is the conductivity tensor ! (note that MinusFermiDerivative is in units of 1/eV, so that when I perform the integration ! ElCond has the same units of TDF) @@ -280,19 +363,19 @@ subroutine boltzwann_main() end do ! I calculate the inverse matrix of the conductivity - if (boltz_2d_dir_num /= 0) then + if (pw90_boltzwann%dir_num_2d /= 0) then ! Invert only the appropriate 2x2 submatrix - if (boltz_2d_dir_num == 1) then + if (pw90_boltzwann%dir_num_2d == 1) then ThisElCond2d(1, 1) = ThisElCond(2, 2) ThisElCond2d(1, 2) = ThisElCond(2, 3) ThisElCond2d(2, 1) = ThisElCond(3, 2) ThisElCond2d(2, 2) = ThisElCond(3, 3) - elseif (boltz_2d_dir_num == 2) then + elseif (pw90_boltzwann%dir_num_2d == 2) then ThisElCond2d(1, 1) = ThisElCond(1, 1) ThisElCond2d(1, 2) = ThisElCond(1, 3) ThisElCond2d(2, 1) = ThisElCond(3, 1) ThisElCond2d(2, 2) = ThisElCond(3, 3) - elseif (boltz_2d_dir_num == 3) then + elseif (pw90_boltzwann%dir_num_2d == 3) then ThisElCond2d(1, 1) = ThisElCond(1, 1) ThisElCond2d(1, 2) = ThisElCond(1, 2) ThisElCond2d(2, 1) = ThisElCond(2, 1) @@ -302,17 +385,17 @@ subroutine boltzwann_main() end if call utility_inv2(ThisElCond2d, ElCondInverse2d, Determinant) ElCondInverse = 0._dp ! Other elements must be set to zero - if (boltz_2d_dir_num == 1) then + if (pw90_boltzwann%dir_num_2d == 1) then ElCondInverse(2, 2) = ElCondInverse2d(1, 1) ElCondInverse(2, 3) = ElCondInverse2d(1, 2) ElCondInverse(3, 2) = ElCondInverse2d(2, 1) ElCondInverse(3, 3) = ElCondInverse2d(2, 2) - elseif (boltz_2d_dir_num == 2) then + elseif (pw90_boltzwann%dir_num_2d == 2) then ElCondInverse(1, 1) = ElCondInverse2d(1, 1) ElCondInverse(1, 3) = ElCondInverse2d(1, 2) ElCondInverse(3, 1) = ElCondInverse2d(2, 1) ElCondInverse(3, 3) = ElCondInverse2d(2, 2) - elseif (boltz_2d_dir_num == 3) then + elseif (pw90_boltzwann%dir_num_2d == 3) then ElCondInverse(1, 1) = ElCondInverse2d(1, 1) ElCondInverse(1, 2) = ElCondInverse2d(1, 2) ElCondInverse(2, 1) = ElCondInverse2d(2, 1) @@ -343,7 +426,7 @@ subroutine boltzwann_main() end do ! I store in SigmaS_FP the product of the two tensors in full-packed format - LocalSigmaS(:, LocalIdx) = sum(IntegrandArray, DIM=2)*boltz_tdf_energy_step/TempArray(TempIdx) + LocalSigmaS(:, LocalIdx) = sum(IntegrandArray, DIM=2)*pw90_boltzwann%tdf_energy_step/TempArray(TempIdx) do j = 1, 3 do i = 1, j ! Both upper and lower diagonal @@ -383,19 +466,19 @@ subroutine boltzwann_main() do EnIdx = 1, TDFEnergyNumPoints IntegrandArray(:, EnIdx) = IntegrandArray(:, EnIdx)*(TDFEnergyArray(EnIdx) - MuArray(MuIdx)) end do - LocalKappa(:, LocalIdx) = sum(IntegrandArray, DIM=2)*boltz_tdf_energy_step/TempArray(TempIdx) + LocalKappa(:, LocalIdx) = sum(IntegrandArray, DIM=2)*pw90_boltzwann%tdf_energy_step/TempArray(TempIdx) ! Kappa contains now the thermal conductivity in units of ! 1/hbar^2 * eV^3*fs/angstrom/kelvin end do ! I check if there were (mu,T) pairs for which we got sigma = 0 - call comms_reduce(NumberZeroDet, 1, 'SUM') + call comms_reduce(NumberZeroDet, 1, 'SUM', stdout, seedname, comm) if (on_root) then if ((NumberZeroDet .gt. 0)) then write (stdout, '(1X,A,I0,A)') "> WARNING! There are ", NumberZeroDet, " (mu,T) pairs for which the electrical" write (stdout, '(1X,A)') "> conductivity has zero determinant." write (stdout, '(1X,A)') "> Seebeck coefficient set to zero for those pairs." write (stdout, '(1X,A)') "> Check if this is physical or not." - write (stdout, '(1X,A)') "> (If you are dealing with a 2D system, set the boltz_2d_dir flag.)" + write (stdout, '(1X,A)') "> (If you are dealing with a 2D system, set the pw90_boltzwann_2d_dir flag.)" write (stdout, '(1X,A)') "" end if end if @@ -411,14 +494,14 @@ subroutine boltzwann_main() ! Now: e/C = elem_charge_SI; CV=Joule, CV/s=Watt, hbar/Watt = hbar_SI; ! moreover meter / angstrom = 1e10, fs / s = 1e-15 so that we finally get the ! CONVERSION FACTOR: elem_charge_SI**3 / (hbar_SI**2) * 1.e-5_dp - LocalElCond = LocalElCond*elem_charge_SI**3/(hbar_SI**2)*1.e-5_dp + LocalElCond = LocalElCond*physics%elem_charge_SI**3/(physics%hbar_SI**2)*1.e-5_dp ! THIS IS NOW THE ELECTRICAL CONDUCTIVITY IN SI UNITS, i.e. in 1/Ohm/meter ! *** Sigma * S **** ! Again, as above or below for Kappa, the conversion factor is ! * elem_charge_SI**3 / (hbar_SI**2) * 1.e-5_dp ! and brings the result to Ampere/m/K - LocalSigmaS = LocalSigmaS*elem_charge_SI**3/(hbar_SI**2)*1.e-5_dp + LocalSigmaS = LocalSigmaS*physics%elem_charge_SI**3/(physics%hbar_SI**2)*1.e-5_dp ! **** Seebeck coefficient **** ! THE SEEECK COEFFICIENTS IS ALREADY IN volt/kelvin, so nothing has to be done @@ -431,42 +514,46 @@ subroutine boltzwann_main() ! 1/hbar^2 * C^3 * V^3 * s / W * [e/C]^3 * (m/angstrom) * (fs / s) = ! 1/hbar^2 * J^2 * [e/C]^3 * (m/angstrom) * (fs / s) = ! elem_charge_SI**3 / (hbar_SI**2) * 1.e-5_dp, i.e. the same conversion factor as above - LocalKappa = LocalKappa*elem_charge_SI**3/(hbar_SI**2)*1.e-5_dp + LocalKappa = LocalKappa*physics%elem_charge_SI**3/(physics%hbar_SI**2)*1.e-5_dp ! THIS IS NOW THE THERMAL CONDUCTIVITY IN SI UNITS, i.e. in W/meter/K ! Now I send the different pieces to the local node if (on_root) then allocate (ElCond(6, TempNumPoints, MuNumPoints), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ElCond in boltzwann_main') + if (ierr /= 0) call io_error('Error in allocating ElCond in boltzwann_main', stdout, seedname) allocate (SigmaS(6, TempNumPoints, MuNumPoints), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating SigmaS in boltzwann_main') + if (ierr /= 0) call io_error('Error in allocating SigmaS in boltzwann_main', stdout, seedname) allocate (Seebeck(9, TempNumPoints, MuNumPoints), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating Seebeck in boltzwann_main') + if (ierr /= 0) call io_error('Error in allocating Seebeck in boltzwann_main', stdout, seedname) allocate (Kappa(6, TempNumPoints, MuNumPoints), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating Kappa in boltzwann_main') + if (ierr /= 0) call io_error('Error in allocating Kappa in boltzwann_main', stdout, seedname) else ! In principle, this should not be needed, because we use ElCond, ! Seebeck and Kappa only on the root node. However, since all ! processors call comms_gatherv a few lines below, and one argument ! is ElCond(1,1,1), some compilers complain. allocate (ElCond(1, 1, 1), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ElCond in boltzwann_main (2)') + if (ierr /= 0) call io_error('Error in allocating ElCond in boltzwann_main (2)', stdout, seedname) allocate (SigmaS(1, 1, 1), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating SigmaS in boltzwann_main (2)') + if (ierr /= 0) call io_error('Error in allocating SigmaS in boltzwann_main (2)', stdout, seedname) allocate (Seebeck(1, 1, 1), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating Seebeck in boltzwann_main (2)') + if (ierr /= 0) call io_error('Error in allocating Seebeck in boltzwann_main (2)', stdout, seedname) allocate (Kappa(1, 1, 1), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating Kappa in boltzwann_main (2)') + if (ierr /= 0) call io_error('Error in allocating Kappa in boltzwann_main (2)', stdout, seedname) end if ! The 6* factors are due to the fact that for each (T,mu) pair we have 6 components (xx,xy,yy,xz,yz,zz) ! NOTE THAT INSTEAD SEEBECK IS A FULL MATRIX AND HAS 9 COMPONENTS! - call comms_gatherv(LocalElCond, 6*counts(my_node_id), ElCond, 6*counts, 6*displs) - call comms_gatherv(LocalSigmaS, 6*counts(my_node_id), SigmaS, 6*counts, 6*displs) - call comms_gatherv(LocalSeebeck, 9*counts(my_node_id), Seebeck, 9*counts, 9*displs) - call comms_gatherv(LocalKappa, 6*counts(my_node_id), Kappa, 6*counts, 6*displs) + call comms_gatherv(LocalElCond, 6*counts(my_node_id), ElCond, 6*counts, 6*displs, stdout, & + seedname, comm) + call comms_gatherv(LocalSigmaS, 6*counts(my_node_id), SigmaS, 6*counts, 6*displs, stdout, & + seedname, comm) + call comms_gatherv(LocalSeebeck, 9*counts(my_node_id), Seebeck, 9*counts, 9*displs, stdout, & + seedname, comm) + call comms_gatherv(LocalKappa, 6*counts(my_node_id), Kappa, 6*counts, 6*displs, stdout, & + seedname, comm) - if (on_root .and. (timing_level > 0)) call io_stopwatch('boltzwann_main: calc_props', 2) + if (on_root .and. (print_output%timing_level > 0)) call io_stopwatch('boltzwann_main: calc_props', 2, stdout, seedname) ! Open files and print if (on_root) then @@ -481,7 +568,8 @@ subroutine boltzwann_main() end do end do close (elcond_unit) - if (iprint > 1) write (stdout, '(3X,A)') "Electrical conductivity written on the "//trim(seedname)//"_elcond.dat file." + if (print_output%iprint > 1) & + write (stdout, '(3X,A)') "Electrical conductivity written on the "//trim(seedname)//"_elcond.dat file." sigmas_unit = io_file_unit() open (unit=sigmas_unit, file=trim(seedname)//'_sigmas.dat') @@ -494,7 +582,7 @@ subroutine boltzwann_main() end do end do close (sigmas_unit) - if (iprint > 1) write (stdout, '(3X,A)') & + if (print_output%iprint > 1) write (stdout, '(3X,A)') & "sigma*S (sigma=el. conductivity, S=Seebeck coeff.) written on the "//trim(seedname)//"_sigmas.dat file." seebeck_unit = io_file_unit() @@ -509,7 +597,8 @@ subroutine boltzwann_main() end do end do close (seebeck_unit) - if (iprint > 1) write (stdout, '(3X,A)') "Seebeck coefficient written on the "//trim(seedname)//"_seebeck.dat file." + if (print_output%iprint > 1) & + write (stdout, '(3X,A)') "Seebeck coefficient written on the "//trim(seedname)//"_seebeck.dat file." kappa_unit = io_file_unit() open (unit=kappa_unit, file=trim(seedname)//'_kappa.dat') @@ -524,7 +613,8 @@ subroutine boltzwann_main() end do end do close (kappa_unit) - if (iprint > 1) write (stdout, '(3X,A)') "K coefficient written on the "//trim(seedname)//"_kappa.dat file." + if (print_output%iprint > 1) & + write (stdout, '(3X,A)') "K coefficient written on the "//trim(seedname)//"_kappa.dat file." end if if (on_root) then @@ -538,37 +628,37 @@ subroutine boltzwann_main() ! Before ending, I deallocate memory deallocate (TempArray, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating TempArray in boltzwann_main') + if (ierr /= 0) call io_error('Error in deallocating TempArray in boltzwann_main', stdout, seedname) deallocate (KTArray, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating KTArray in boltzwann_main') + if (ierr /= 0) call io_error('Error in deallocating KTArray in boltzwann_main', stdout, seedname) deallocate (MuArray, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating MuArray in boltzwann_main') + if (ierr /= 0) call io_error('Error in deallocating MuArray in boltzwann_main', stdout, seedname) deallocate (TDFEnergyArray, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating TDFEnergyArray in boltzwann_main') + if (ierr /= 0) call io_error('Error in deallocating TDFEnergyArray in boltzwann_main', stdout, seedname) deallocate (TDF, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating TDF in boltzwann_main') + if (ierr /= 0) call io_error('Error in deallocating TDF in boltzwann_main', stdout, seedname) deallocate (LocalElCond, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating LocalElCond in boltzwann_main') + if (ierr /= 0) call io_error('Error in deallocating LocalElCond in boltzwann_main', stdout, seedname) deallocate (LocalSigmaS, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating LocalSigmaS in boltzwann_main') + if (ierr /= 0) call io_error('Error in deallocating LocalSigmaS in boltzwann_main', stdout, seedname) deallocate (LocalSeebeck, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating LocalSeebeck in boltzwann_main') + if (ierr /= 0) call io_error('Error in deallocating LocalSeebeck in boltzwann_main', stdout, seedname) deallocate (LocalKappa, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating LocalKappa in boltzwann_main') + if (ierr /= 0) call io_error('Error in deallocating LocalKappa in boltzwann_main', stdout, seedname) deallocate (ElCond, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating ElCond in boltzwann_main') + if (ierr /= 0) call io_error('Error in deallocating ElCond in boltzwann_main', stdout, seedname) deallocate (SigmaS, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating SigmaS in boltzwann_main') + if (ierr /= 0) call io_error('Error in deallocating SigmaS in boltzwann_main', stdout, seedname) deallocate (Seebeck, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating Seebeck in boltzwann_main') + if (ierr /= 0) call io_error('Error in deallocating Seebeck in boltzwann_main', stdout, seedname) deallocate (Kappa, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating Kappa in boltzwann_main') + if (ierr /= 0) call io_error('Error in deallocating Kappa in boltzwann_main', stdout, seedname) deallocate (IntegrandArray, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating IntegrandArray in boltzwann_main') + if (ierr /= 0) call io_error('Error in deallocating IntegrandArray in boltzwann_main', stdout, seedname) - if (on_root .and. (timing_level > 0)) call io_stopwatch('boltzwann_main', 2) + if (on_root .and. (print_output%timing_level > 0)) call io_stopwatch('boltzwann_main', 2, stdout, seedname) 101 FORMAT(7G18.10) 102 FORMAT(19G18.10) @@ -577,7 +667,14 @@ subroutine boltzwann_main() end subroutine boltzwann_main - subroutine calcTDFandDOS(TDF, TDFEnergyArray) + !================================================! + subroutine calcTDFandDOS(pw90_boltzwann, dis_manifold, pw90_dos, kpt_latt, postw90_oper, pw90_band_deriv_degen, & + pw90_spin, ws_region, print_output, wannier_data, ws_distance, wigner_seitz, HH_R, & + SS_R, u_matrix, v_matrix, eigval, real_lattice, TDF, TDFEnergyArray, & + cell_volume, scissors_shift, mp_grid, num_bands, & + num_kpts, num_wann, num_valence_bands, num_elec_per_state, & + effective_model, have_disentangled, spin_decomp, seedname, stdout, comm) + !================================================! !! This routine calculates the Transport Distribution Function $$\sigma_{ij}(\epsilon)$$ (TDF) !! in units of 1/hbar^2 * eV*fs/angstrom, and possibly the DOS. !! @@ -595,20 +692,46 @@ subroutine calcTDFandDOS(TDF, TDFEnergyArray) !! Note that the order of indices of TDF is different w.r.t. the DOS array (the energy is not the first but !! the second index) !! - !! If the input flag boltz_bandshift is set to .true., the code will also shift the - !! conduction bands by a given amount, as defined by the boltz_bandshift_energyshift - !! and boltz_bandshift_firstband input flags. + !! If the input flag pw90_boltzwann_bandshift is set to .true., the code will also shift the + !! conduction bands by a given amount, as defined by the pw90_boltzwann_bandshift_energyshift + !! and pw90_boltzwann_bandshift_firstband input flags. !! - use w90_get_oper, only: get_HH_R, get_SS_R, HH_R - use w90_parameters, only: num_wann, boltz_calc_also_dos, & - boltz_dos_energy_step, boltz_dos_energy_min, boltz_dos_energy_max, & - boltz_dos_adpt_smr, boltz_dos_smr_fixed_en_width, boltz_dos_adpt_smr_fac, & - boltz_dos_adpt_smr_max, & - param_get_smearing_type, boltz_dos_smr_index, boltz_tdf_smr_index - use w90_utility, only: utility_diagonalize + !================================================! + + use w90_constants, only: dp + use w90_comms, only: comms_bcast, w90comm_type, mpirank + use w90_io, only: io_file_unit, io_error, io_stopwatch + use w90_utility, only: utility_recip_lattice_base + use w90_get_oper, only: get_HH_R, get_SS_R + use w90_types, only: print_output_type, wannier_data_type, dis_manifold_type, & + ws_region_type, ws_distance_type + use w90_postw90_types, only: pw90_boltzwann_type, pw90_spin_mod_type, & + pw90_band_deriv_degen_type, pw90_dos_mod_type, pw90_oper_read_type, wigner_seitz_type + use w90_readwrite, only: w90_readwrite_get_smearing_type use w90_wan_ham, only: wham_get_eig_deleig - real(kind=dp), dimension(:, :, :), intent(out) :: TDF ! (coordinate,Energy,spin) + implicit none + + ! arguments + type(pw90_boltzwann_type), intent(in) :: pw90_boltzwann + type(dis_manifold_type), intent(in) :: dis_manifold + type(pw90_dos_mod_type), intent(in) :: pw90_dos + real(kind=dp), intent(in) :: kpt_latt(:, :) + type(pw90_band_deriv_degen_type), intent(in) :: pw90_band_deriv_degen + type(pw90_oper_read_type), intent(in) :: postw90_oper + type(pw90_spin_mod_type), intent(in) :: pw90_spin + type(print_output_type), intent(in) :: print_output + type(ws_region_type), intent(in) :: ws_region + type(w90comm_type), intent(in) :: comm + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + integer, intent(in) :: num_wann, num_bands, num_kpts, num_valence_bands, num_elec_per_state + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + + real(kind=dp), intent(out) :: TDF(:, :, :) ! (coordinate,Energy,spin) !! The TDF(i,EnIdx,spin) output array, where: !! - i is an index from 1 to 6 giving the component of the symmetric tensor !! $$ Sigma_{ij}(\eps) $$, @@ -620,13 +743,28 @@ subroutine calcTDFandDOS(TDF, TDFEnergyArray) !! TDFEnergyArray(EndIdx) array (in eV). !! - Spin may be only 1 if spin_decomp=.false. If it is instead true, 1 contains the total TDF, !! 2 the spin-up component and 3 the spin-up component - real(kind=dp), dimension(:), intent(in) :: TDFEnergyArray + real(kind=dp), intent(in) :: TDFEnergyArray(:) !! TDFEnergyArray The array with the energies for which the TDF is calculated, in eV ! Comments: ! issue warnings if going outside of the energy window ! check that we actually get hbar*velocity in eV*angstrom - - real(kind=dp), dimension(3) :: kpt, orig_kpt + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: cell_volume + real(kind=dp), intent(in) :: scissors_shift + + complex(kind=dp), intent(in) :: v_matrix(:, :, :), u_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) ! <0n|sigma_x,y,z|Rm> + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + logical, intent(in) :: spin_decomp + logical, intent(in) :: effective_model + + ! local variables + real(kind=dp) :: recip_lattice(3, 3), volume + real(kind=dp) :: kpt(3), orig_kpt(3) integer :: loop_tot, loop_x, loop_y, loop_z, ierr complex(kind=dp), allocatable :: HH(:, :) @@ -638,18 +776,25 @@ subroutine calcTDFandDOS(TDF, TDFEnergyArray) real(kind=dp), allocatable :: DOS_EnergyArray(:) real(kind=dp), allocatable :: DOS_k(:, :), TDF_k(:, :, :) real(kind=dp), allocatable :: DOS_all(:, :) - real(kind=dp) :: kweight - integer :: ndim, DOS_NumPoints, i, j, k, EnIdx + real(kind=dp) :: kweight + integer :: ndim, DOS_NumPoints, i, j, k, EnIdx - character(len=20) :: numfieldsstr - integer :: boltzdos_unit, num_s_steps, NumPtsRefined + character(len=20) :: numfieldsstr + integer :: boltzdos_unit, NumPtsRefined real(kind=dp), parameter :: SPACING_THRESHOLD = 1.e-3 real(kind=dp) :: min_spacing, max_spacing - if (on_root .and. (timing_level > 0)) call io_stopwatch('calcTDF', 1) - if (on_root) then - if (boltz_calc_also_dos) then + integer :: my_node_id, num_nodes + logical :: on_root = .false. + + my_node_id = mpirank(comm) + num_nodes = mpisize(comm) + if (my_node_id == 0) on_root = .true. + + if (print_output%iprint > 0 .and. (print_output%timing_level > 0)) call io_stopwatch('calcTDF', 1, stdout, seedname) + if (print_output%iprint > 0) then + if (pw90_boltzwann%calc_also_dos) then write (stdout, '(3X,A)') "Calculating Transport Distribution function (TDF) and DOS..." else write (stdout, '(3X,A)') "Calculating Transport Distribution function (TDF)..." @@ -657,128 +802,143 @@ subroutine calcTDFandDOS(TDF, TDFEnergyArray) end if ! I call once the routine to calculate the Hamiltonian in real-space <0n|H|Rm> - call get_HH_R + + call get_HH_R(dis_manifold, kpt_latt, print_output, wigner_seitz, HH_R, u_matrix, v_matrix, eigval, & + real_lattice, scissors_shift, num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, stdout, comm) if (spin_decomp) then ndim = 3 - call get_SS_R + + call get_SS_R(dis_manifold, kpt_latt, print_output, postw90_oper, SS_R, v_matrix, eigval, & + wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, num_wann, have_disentangled, seedname, stdout, & + comm) else ndim = 1 end if ! Some initial checks if (size(TDF, 1) /= 6 .or. size(TDF, 2) /= size(TDFEnergyArray) .or. size(TDF, 3) /= ndim) then - call io_error('Wrong size for the TDF array in calcTDF') + call io_error('Wrong size for the TDF array in calcTDF', stdout, seedname) end if ! I zero the TDF array before starting TDF = 0._dp allocate (TDF_k(6, size(TDFEnergyArray), ndim), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating TDF_k in calcTDF') + if (ierr /= 0) call io_error('Error in allocating TDF_k in calcTDF', stdout, seedname) allocate (HH(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating HH in calcTDF') + if (ierr /= 0) call io_error('Error in allocating HH in calcTDF', stdout, seedname) allocate (delHH(num_wann, num_wann, 3), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating delHH in calcTDF') + if (ierr /= 0) call io_error('Error in allocating delHH in calcTDF', stdout, seedname) allocate (UU(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating UU in calcTDF') + if (ierr /= 0) call io_error('Error in allocating UU in calcTDF', stdout, seedname) - DOS_NumPoints = int(floor((boltz_dos_energy_max - boltz_dos_energy_min)/boltz_dos_energy_step)) + 1 + DOS_NumPoints = int(floor((pw90_boltzwann%dos_energy_max - pw90_boltzwann%dos_energy_min)/pw90_boltzwann%dos_energy_step)) + 1 if (DOS_NumPoints .eq. 1) DOS_NumPoints = 2 allocate (DOS_EnergyArray(DOS_NumPoints), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating DOS_EnergyArray in calcTDF') + if (ierr /= 0) call io_error('Error in allocating DOS_EnergyArray in calcTDF', stdout, seedname) do i = 1, DOS_NumPoints - DOS_EnergyArray(i) = boltz_dos_energy_min + real(i - 1, dp)*boltz_dos_energy_step + DOS_EnergyArray(i) = pw90_boltzwann%dos_energy_min + real(i - 1, dp)*pw90_boltzwann%dos_energy_step end do allocate (DOS_k(size(DOS_EnergyArray), ndim), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating DOS_k in calcTDF') + if (ierr /= 0) call io_error('Error in allocating DOS_k in calcTDF', stdout, seedname) allocate (DOS_all(size(DOS_EnergyArray), ndim), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating DOS_all in calcTDF') + if (ierr /= 0) call io_error('Error in allocating DOS_all in calcTDF', stdout, seedname) dos_all = 0.0_dp ! I open the output files - if (boltz_calc_also_dos .and. on_root) then + if (pw90_boltzwann%calc_also_dos .and. on_root) then boltzdos_unit = io_file_unit() open (unit=boltzdos_unit, file=trim(seedname)//'_boltzdos.dat') end if - if (boltz_calc_also_dos .and. on_root .and. (iprint > 1)) then + if (pw90_boltzwann%calc_also_dos .and. on_root .and. (print_output%iprint > 1)) then write (stdout, '(5X,A)') "Smearing for DOS: " - if (boltz_dos_adpt_smr) then - write (stdout, '(7X,A)') trim(param_get_smearing_type(boltz_dos_smr_index))//", adaptive" + if (pw90_boltzwann%dos_smearing%use_adaptive) then + write (stdout, '(7X,A)') trim(w90_readwrite_get_smearing_type(pw90_boltzwann%dos_smearing%type_index))//", adaptive" else - if (boltz_dos_smr_fixed_en_width/(DOS_EnergyArray(2) - DOS_EnergyArray(1)) < & + if (pw90_boltzwann%dos_smearing%fixed_width/(DOS_EnergyArray(2) - DOS_EnergyArray(1)) < & min_smearing_binwidth_ratio) then write (stdout, '(7X,A)') "Unsmeared (use smearing width larger than bin width to smear)" else - write (stdout, '(7X,A,G18.10)') trim(param_get_smearing_type(boltz_dos_smr_index))// & - ", non-adaptive, width (eV) =", boltz_dos_smr_fixed_en_width + write (stdout, '(7X,A,G18.10)') trim(w90_readwrite_get_smearing_type(pw90_boltzwann%dos_smearing%type_index))// & + ", non-adaptive, width (eV) =", pw90_boltzwann%dos_smearing%fixed_width end if end if end if - if (boltz_calc_also_dos .and. boltz_dos_adpt_smr .and. (boltz_dos_smr_fixed_en_width .ne. 0._dp) .and. on_root) then - write (stdout, '(5X,A)') "*** WARNING! boltz_dos_smr_fixed_en_width ignored since you chose" + if (pw90_boltzwann%calc_also_dos .and. pw90_boltzwann%dos_smearing%use_adaptive .and. & + (pw90_boltzwann%dos_smearing%fixed_width .ne. 0._dp) .and. on_root) then + write (stdout, '(5X,A)') "*** WARNING! pw90_boltzwann_dos_smr_fixed_en_width ignored since you chose" write (stdout, '(5X,A)') " an adaptive smearing." end if - if (on_root .and. (iprint > 1)) then - if (boltz_TDF_smr_fixed_en_width/(TDFEnergyArray(2) - TDFEnergyArray(1)) < min_smearing_binwidth_ratio) then + if (on_root .and. (print_output%iprint > 1)) then + if (pw90_boltzwann%tdf_smearing%fixed_width/(TDFEnergyArray(2) - TDFEnergyArray(1)) & + < min_smearing_binwidth_ratio) then write (stdout, '(5X,A)') "Smearing for TDF: " write (stdout, '(7X,A)') "Unsmeared (use smearing width larger than bin width to smear)" else write (stdout, '(5X,A)') "Smearing for TDF: " write (stdout, '(7X,A,G18.10)') & - trim(param_get_smearing_type(boltz_TDF_smr_index))//", non-adaptive, width (eV) =", & - boltz_TDF_smr_fixed_en_width + trim(w90_readwrite_get_smearing_type(pw90_boltzwann%tdf_smearing%type_index))//", non-adaptive, width (eV) =", & + pw90_boltzwann%tdf_smearing%fixed_width end if end if if (on_root) then write (stdout, '(5X,A,I0,A,I0,A,I0)') "k-grid used for band interpolation in BoltzWann: ", & - boltz_kmesh(1), 'x', boltz_kmesh(2), 'x', boltz_kmesh(3) + pw90_boltzwann%kmesh%mesh(1), 'x', pw90_boltzwann%kmesh%mesh(2), 'x', pw90_boltzwann%kmesh%mesh(3) write (stdout, '(5X,A,I1)') "Number of electrons per state: ", num_elec_per_state - write (stdout, '(5X,A,G18.10)') "Relaxation time (fs): ", boltz_relax_time - if (iprint > 1) then - write (stdout, '(5X,A,G18.10)') "Energy step for TDF (eV): ", boltz_tdf_energy_step + write (stdout, '(5X,A,G18.10)') "Relaxation time (fs): ", pw90_boltzwann%relax_time + if (print_output%iprint > 1) then + write (stdout, '(5X,A,G18.10)') "Energy step for TDF (eV): ", pw90_boltzwann%tdf_energy_step end if end if - kweight = 1.0_dp/real(PRODUCT(boltz_kmesh), kind=dp) + kweight = 1.0_dp/real(PRODUCT(pw90_boltzwann%kmesh%mesh), kind=dp) - if (boltz_bandshift .and. on_root) then - write (stdout, '(5X,A,I0,A,G18.10,A)') "Shifting energy bands with index >= ", boltz_bandshift_firstband, " by ", & - boltz_bandshift_energyshift, " eV." + if (pw90_boltzwann%bandshift .and. on_root) then + write (stdout, '(5X,A,I0,A,G18.10,A)') "Shifting energy bands with index >= ", pw90_boltzwann%bandshift_firstband, " by ", & + pw90_boltzwann%bandshift_energyshift, " eV." end if + call utility_recip_lattice_base(real_lattice, recip_lattice, volume) NumPtsRefined = 0 min_spacing = 1.e10_dp ! very large initial value max_spacing = 0.e0_dp ! I loop over all kpoints - do loop_tot = my_node_id, PRODUCT(boltz_kmesh) - 1, num_nodes + do loop_tot = my_node_id, PRODUCT(pw90_boltzwann%kmesh%mesh) - 1, num_nodes ! I get the coordinates for the x,y,z components starting from a single loop variable ! (which is better for parallelization purposes) ! Important! This works only if loop_tot starts from ZERO and ends with - ! PRODUCT(boltz_kmesh)-1, so be careful when parallelizing - loop_x = loop_tot/(boltz_kmesh(2)*boltz_kmesh(3)) - loop_y = (loop_tot - loop_x*(boltz_kmesh(2)*boltz_kmesh(3)))/boltz_kmesh(3) - loop_z = loop_tot - loop_x*(boltz_kmesh(2)*boltz_kmesh(3)) - loop_y*boltz_kmesh(3) + ! PRODUCT(pw90_boltzwann_kmesh)-1, so be careful when parallelizing + loop_x = loop_tot/(pw90_boltzwann%kmesh%mesh(2)*pw90_boltzwann%kmesh%mesh(3)) + loop_y = (loop_tot - loop_x*(pw90_boltzwann%kmesh%mesh(2)*pw90_boltzwann%kmesh%mesh(3)))/pw90_boltzwann%kmesh%mesh(3) + loop_z = loop_tot - loop_x*(pw90_boltzwann%kmesh%mesh(2)*pw90_boltzwann%kmesh%mesh(3)) - loop_y*pw90_boltzwann%kmesh%mesh(3) - ! kpt(i) is in in the [0,d-1]/d range, with d=boltz_kmesh(i) - kpt(1) = (real(loop_x, dp)/real(boltz_kmesh(1), dp)) - kpt(2) = (real(loop_y, dp)/real(boltz_kmesh(2), dp)) - kpt(3) = (real(loop_z, dp)/real(boltz_kmesh(3), dp)) + ! kpt(i) is in in the [0,d-1]/d range, with d=pw90_boltzwann_kmesh(i) + kpt(1) = (real(loop_x, dp)/real(pw90_boltzwann%kmesh%mesh(1), dp)) + kpt(2) = (real(loop_y, dp)/real(pw90_boltzwann%kmesh%mesh(2), dp)) + kpt(3) = (real(loop_z, dp)/real(pw90_boltzwann%kmesh%mesh(3), dp)) ! Here I get the band energies and the velocities - call wham_get_eig_deleig(kpt, eig, del_eig, HH, delHH, UU) - call dos_get_levelspacing(del_eig, boltz_kmesh, levelspacing_k) + call wham_get_eig_deleig(dis_manifold, kpt_latt, pw90_band_deriv_degen, ws_region, print_output, wannier_data, & + ws_distance, wigner_seitz, delHH, HH, HH_R, u_matrix, UU, v_matrix, & + del_eig, eig, eigval, kpt, real_lattice, scissors_shift, mp_grid, & + num_bands, num_kpts, num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm) + call dos_get_levelspacing(del_eig, pw90_boltzwann%kmesh%mesh, levelspacing_k, num_wann, recip_lattice) ! Here I apply a scissor operator to the conduction bands, if required in the input - if (boltz_bandshift) then - eig(boltz_bandshift_firstband:) = eig(boltz_bandshift_firstband:) + boltz_bandshift_energyshift + if (pw90_boltzwann%bandshift) then + eig(pw90_boltzwann%bandshift_firstband:) = eig(pw90_boltzwann%bandshift_firstband:) + pw90_boltzwann%bandshift_energyshift end if - call TDF_kpt(kpt, TDFEnergyArray, eig, del_eig, TDF_k) + call TDF_kpt(pw90_boltzwann, ws_region, pw90_spin, wannier_data, ws_distance, wigner_seitz, HH_R, SS_R, & + del_eig, eig, TDFEnergyArray, kpt, real_lattice, TDF_k, mp_grid, & + num_wann, num_elec_per_state, spin_decomp, seedname, stdout) ! As above, the sum of TDF_k * kweight amounts to calculate ! spin_degeneracy * V_cell/(2*pi)^3 * \int_BZ d^3k ! so that we divide by the cell_volume (in Angstrom^3) to have @@ -787,8 +947,8 @@ subroutine calcTDFandDOS(TDF, TDFEnergyArray) ! DOS part ! - if (boltz_calc_also_dos) then - if (boltz_dos_adpt_smr) then + if (pw90_boltzwann%calc_also_dos) then + if (pw90_boltzwann%dos_smearing%use_adaptive) then ! This may happen if at least one band has zero derivative (along all three directions) ! Then I substitute this point with its 8 neighbors (+/- 1/4 of the spacing with the next point on the grid @@ -802,15 +962,21 @@ subroutine calcTDFandDOS(TDF, TDFEnergyArray) do j = -1, 1, 2 do k = -1, 1, 2 kpt = orig_kpt + & - (/real(i, kind=dp)/real(boltz_kmesh(1), dp)/4._dp, & - real(j, kind=dp)/real(boltz_kmesh(2), dp)/4._dp, & - real(k, kind=dp)/real(boltz_kmesh(3), dp)/4._dp/) - call wham_get_eig_deleig(kpt, eig, del_eig, HH, delHH, UU) - call dos_get_levelspacing(del_eig, boltz_kmesh, levelspacing_k) - call dos_get_k(kpt, DOS_EnergyArray, eig, dos_k, & - smr_index=boltz_dos_smr_index, & - adpt_smr_fac=boltz_dos_adpt_smr_fac, & - adpt_smr_max=boltz_dos_adpt_smr_max, & + (/real(i, kind=dp)/real(pw90_boltzwann%kmesh%mesh(1), dp)/4._dp, & + real(j, kind=dp)/real(pw90_boltzwann%kmesh%mesh(2), dp)/4._dp, & + real(k, kind=dp)/real(pw90_boltzwann%kmesh%mesh(3), dp)/4._dp/) + call wham_get_eig_deleig(dis_manifold, kpt_latt, pw90_band_deriv_degen, ws_region, print_output, & + wannier_data, ws_distance, wigner_seitz, delHH, HH, HH_R, & + u_matrix, UU, v_matrix, del_eig, eig, eigval, kpt, & + real_lattice, scissors_shift, mp_grid, num_bands, & + num_kpts, num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm) + call dos_get_levelspacing(del_eig, pw90_boltzwann%kmesh%mesh, levelspacing_k, num_wann, & + recip_lattice) + call dos_get_k(num_elec_per_state, ws_region, kpt, DOS_EnergyArray, eig, dos_k, & + num_wann, wannier_data, real_lattice, mp_grid, pw90_dos, & + spin_decomp, pw90_spin, ws_distance, wigner_seitz, stdout, seedname, & + HH_R, SS_R, pw90_boltzwann%dos_smearing, & levelspacing_k=levelspacing_k) ! I divide by 8 because I'm substituting a point with its 8 neighbors dos_all = dos_all + dos_k*kweight/8. @@ -818,17 +984,18 @@ subroutine calcTDFandDOS(TDF, TDFEnergyArray) end do end do else - call dos_get_k(kpt, DOS_EnergyArray, eig, dos_k, & - smr_index=boltz_dos_smr_index, & - adpt_smr_fac=boltz_dos_adpt_smr_fac, & - adpt_smr_max=boltz_dos_adpt_smr_max, & + call dos_get_k(num_elec_per_state, ws_region, kpt, DOS_EnergyArray, eig, dos_k, & + num_wann, wannier_data, real_lattice, mp_grid, & + pw90_dos, spin_decomp, pw90_spin, ws_distance, wigner_seitz, stdout, & + seedname, HH_R, SS_R, pw90_boltzwann%dos_smearing, & levelspacing_k=levelspacing_k) dos_all = dos_all + dos_k*kweight end if else - call dos_get_k(kpt, DOS_EnergyArray, eig, dos_k, & - smr_index=boltz_dos_smr_index, & - smr_fixed_en_width=boltz_dos_smr_fixed_en_width) + call dos_get_k(num_elec_per_state, ws_region, kpt, DOS_EnergyArray, eig, dos_k, & + num_wann, wannier_data, real_lattice, mp_grid, pw90_dos, spin_decomp, & + pw90_spin, ws_distance, wigner_seitz, stdout, seedname, HH_R, SS_R, & + pw90_boltzwann%dos_smearing) ! This sum multiplied by kweight amounts to calculate ! spin_degeneracy * V_cell/(2*pi)^3 * \int_BZ d^3k ! So that the DOS will be in units of 1/eV, normalized so that @@ -841,38 +1008,38 @@ subroutine calcTDFandDOS(TDF, TDFEnergyArray) ! I sum the results of the calculation for the DOS on the root node only ! (I have to print the results only) - if (boltz_calc_also_dos) then - call comms_reduce(DOS_all(1, 1), size(DOS_all), 'SUM') - call comms_reduce(NumPtsRefined, 1, 'SUM') - call comms_reduce(min_spacing, 1, 'MIN') - call comms_reduce(max_spacing, 1, 'MAX') + if (pw90_boltzwann%calc_also_dos) then + call comms_reduce(DOS_all(1, 1), size(DOS_all), 'SUM', stdout, seedname, comm) + call comms_reduce(NumPtsRefined, 1, 'SUM', stdout, seedname, comm) + call comms_reduce(min_spacing, 1, 'MIN', stdout, seedname, comm) + call comms_reduce(max_spacing, 1, 'MAX', stdout, seedname, comm) end if ! I sum the results of the calculation on all nodes, and I store them on all ! nodes (because for the following, each node will do a different calculation, ! each of which will require the whole knowledge of the TDF array) - call comms_allreduce(TDF(1, 1, 1), size(TDF), 'SUM') + call comms_allreduce(TDF(1, 1, 1), size(TDF), 'SUM', stdout, seedname, comm) - if (boltz_calc_also_dos .and. on_root) then + if (pw90_boltzwann%calc_also_dos .and. on_root) then write (boltzdos_unit, '(A)') "# Written by the BoltzWann module of the Wannier90 code." write (boltzdos_unit, '(A)') "# The first column." - if (boltz_dos_adpt_smr) then + if (pw90_boltzwann%dos_smearing%use_adaptive) then write (boltzdos_unit, '(A)') '# The second column is the adaptively-smeared DOS' write (boltzdos_unit, '(A)') '# (see Yates et al., PRB 75, 195121 (2007)' if (spin_decomp) then write (boltzdos_unit, '(A)') '# The third column is the spin-up projection of the DOS' write (boltzdos_unit, '(A)') '# The fourth column is the spin-down projection of the DOS' end if - write (boltzdos_unit, '(A,1X,G14.6)') '# Smearing coefficient: ', boltz_dos_adpt_smr_fac + write (boltzdos_unit, '(A,1X,G14.6)') '# Smearing coefficient: ', pw90_boltzwann%dos_smearing%adaptive_prefactor write (boltzdos_unit, '(A,I0,A,I0)') '# Number of points refined: ', NumPtsRefined, & - ' out of ', product(boltz_kmesh) + ' out of ', product(pw90_boltzwann%kmesh%mesh) write (boltzdos_unit, '(A,G18.10,A,G18.10,A)') '# (Min spacing: ', min_spacing, & ', max spacing: ', max_spacing, ')' else - if (boltz_dos_smr_fixed_en_width/(DOS_EnergyArray(2) - DOS_EnergyArray(1)) < min_smearing_binwidth_ratio) then + if (pw90_boltzwann%dos_smearing%fixed_width/(DOS_EnergyArray(2) - DOS_EnergyArray(1)) < min_smearing_binwidth_ratio) then write (boltzdos_unit, '(A)') '# The second column is the unsmeared DOS.' else write (boltzdos_unit, '(A,G14.6,A)') '# The second column is the DOS for a fixed smearing of ', & - boltz_dos_smr_fixed_en_width, ' eV.' + pw90_boltzwann%dos_smearing%fixed_width, ' eV.' end if end if write (boltzdos_unit, '(A,1X,G14.6)') '# Cell volume (ang^3): ', cell_volume @@ -887,9 +1054,9 @@ subroutine calcTDFandDOS(TDF, TDFEnergyArray) end do end if - if (on_root .and. (timing_level > 0)) call io_stopwatch('calcTDF', 2) + if (on_root .and. (print_output%timing_level > 0)) call io_stopwatch('calcTDF', 2, stdout, seedname) if (on_root) then - if (boltz_calc_also_dos) then + if (pw90_boltzwann%calc_also_dos) then write (stdout, '(3X,A)') "TDF and DOS calculated." else write (stdout, '(3X,A)') "TDF calculated." @@ -897,34 +1064,38 @@ subroutine calcTDFandDOS(TDF, TDFEnergyArray) end if if (on_root) write (stdout, *) - if (on_root .and. boltz_calc_also_dos) then + if (on_root .and. pw90_boltzwann%calc_also_dos) then close (boltzdos_unit) - if (iprint > 1) write (stdout, '(3X,A)') "DOS written on the "//trim(seedname)//"_boltzdos.dat file." + if (print_output%iprint > 1) write (stdout, '(3X,A)') "DOS written on the "//trim(seedname)//"_boltzdos.dat file." end if deallocate (HH, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating HH in calcTDF') + if (ierr /= 0) call io_error('Error in deallocating HH in calcTDF', stdout, seedname) deallocate (delHH, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating delHH in calcTDF') + if (ierr /= 0) call io_error('Error in deallocating delHH in calcTDF', stdout, seedname) deallocate (UU, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating UU in calcTDF') + if (ierr /= 0) call io_error('Error in deallocating UU in calcTDF', stdout, seedname) deallocate (DOS_EnergyArray, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating DOS_EnergyArray in calcTDF') + if (ierr /= 0) call io_error('Error in deallocating DOS_EnergyArray in calcTDF', stdout, seedname) deallocate (DOS_k, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating DOS_k in calcTDF') + if (ierr /= 0) call io_error('Error in deallocating DOS_k in calcTDF', stdout, seedname) deallocate (DOS_all, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating DOS_all in calcTDF') + if (ierr /= 0) call io_error('Error in deallocating DOS_all in calcTDF', stdout, seedname) deallocate (TDF_k, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating TDF_k in calcTDF') + if (ierr /= 0) call io_error('Error in deallocating TDF_k in calcTDF', stdout, seedname) end subroutine calcTDFandDOS - !> This function calculates -dn(E)/dE, where n(E) is the Fermi distribution function. - !> - !> \param E Energy at which we want to calculate -dn(E)/dE, in 1/eV - !> \param mu Chemical potential in eV - !> \param KT k_Boltzmann * Temperature, in eV + !================================================! function MinusFermiDerivative(E, mu, KT) + !================================================! + !> This function calculates -dn(E)/dE, where n(E) is the Fermi distribution function. + !> + !> \param E Energy at which we want to calculate -dn(E)/dE, in 1/eV + !> \param mu Chemical potential in eV + !> \param KT k_Boltzmann * Temperature, in eV + !================================================! + real(kind=dp), intent(in) :: E real(kind=dp), intent(in) :: mu real(kind=dp), intent(in) :: KT @@ -947,12 +1118,16 @@ function MinusFermiDerivative(E, mu, KT) end function MinusFermiDerivative - subroutine TDF_kpt(kpt, EnergyArray, eig_k, deleig_k, TDF_k) + !================================================! + subroutine TDF_kpt(pw90_boltzwann, ws_region, pw90_spin, wannier_data, ws_distance, wigner_seitz, HH_R, SS_R, & + deleig_k, eig_k, EnergyArray, kpt, real_lattice, TDF_k, & + mp_grid, num_wann, num_elec_per_state, spin_decomp, seedname, stdout) + !================================================! !! This subroutine calculates the contribution to the TDF of a single k point !! !! This routine does not use the adaptive smearing; in fact, for non-zero temperatures !! one often doesn't even need to smear. It simply uses a standard smearing as defined by - !! the variables boltz_TDF_smr_fixed_en_width and boltz_TDF_smr_index + !! the variables pw90_boltzwann_TDF_smr_fixed_en_width and pw90_boltzwann_TDF_smr_index !! !! still to do: adapt spin_get_nk to read in input the UU rotation matrix !! @@ -970,28 +1145,44 @@ subroutine TDF_kpt(kpt, EnergyArray, eig_k, deleig_k, TDF_k) !! The TDF_k array must have dimensions 6 * size(EnergyArray) * ndim, where !! ndim=1 if spin_decomp==false, or ndim=3 if spin_decomp==true. This is not checked. !! + !================================================! + use w90_constants, only: dp, smearing_cutoff, min_smearing_binwidth_ratio use w90_utility, only: utility_w0gauss - use w90_parameters, only: num_wann, spin_decomp, num_elec_per_state, & - boltz_TDF_smr_fixed_en_width, boltz_TDF_smr_index, boltz_relax_time + use w90_types, only: print_output_type, wannier_data_type, ws_region_type, & + ws_distance_type + use w90_postw90_types, only: pw90_boltzwann_type, pw90_spin_mod_type, wigner_seitz_type use w90_spin, only: spin_get_nk + use w90_utility, only: utility_w0gauss - ! Arguments - ! - real(kind=dp), dimension(3), intent(in) :: kpt + implicit none + + ! arguments + type(pw90_boltzwann_type), intent(in) :: pw90_boltzwann + type(ws_region_type), intent(in) :: ws_region + type(pw90_spin_mod_type), intent(in) :: pw90_spin + type(wannier_data_type), intent(in) :: wannier_data + type(ws_distance_type), intent(inout) :: ws_distance + type(wigner_seitz_type), intent(in) :: wigner_seitz + + integer, intent(in) :: num_wann + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: kpt(3) !! the three coordinates of the k point vector whose DOS contribution we !! want to calculate (in relative coordinates) - real(kind=dp), dimension(:), intent(in) :: EnergyArray + real(kind=dp), intent(in) :: EnergyArray(:) !! array with the energy grid on which to calculate the DOS (in eV) !! It must have at least two elements - real(kind=dp), dimension(:), intent(in) :: eig_k + real(kind=dp), intent(in) :: eig_k(:) !! array with the eigenvalues at the given k point (in eV) - real(kind=dp), dimension(:, :), intent(in) :: deleig_k + real(kind=dp), intent(in) :: deleig_k(:, :) !! array with the band derivatives at the given k point !! (in eV * angstrom / (2pi) as internally given by the code) !! already corrected in case of degeneracies, as returned by the !! wham_get_deleig_a routine - real(kind=dp), dimension(:, :, :), intent(out) :: TDF_k + real(kind=dp), intent(out) :: TDF_k(:, :, :) !! TDF_k array in which the contribution is stored. Three dimensions: !! TDF_k(ij, energyidx, spinidx), where: !! - ij indexes the components of the TDF (symmetric) tensor (1=XX, 2=XY, ...); @@ -1000,23 +1191,30 @@ subroutine TDF_kpt(kpt, EnergyArray, eig_k, deleig_k, TDF_k) !! of the EnergyArray array; !! - spinidx=1 contains the total dos; if if spin_decomp==.true., then !! spinidx=2 and spinidx=3 contain the spin-up and spin-down contributions to the DOS + real(kind=dp), intent(in) :: real_lattice(3, 3) - ! Adaptive smearing - ! - real(kind=dp) :: smear, arg + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) ! <0n|sigma_x,y,z|Rm> - ! Misc/Dummy - ! - integer :: BandIdx, loop_f, min_f, max_f - real(kind=dp) :: rdum, spn_nk(num_wann), alpha_sq, beta_sq - real(kind=dp) :: binwidth, r_num_elec_per_state - logical :: DoSmearing + character(len=50), intent(in) :: seedname + + logical, intent(in) :: spin_decomp + integer, intent(in) :: num_elec_per_state + + ! local variables + real(kind=dp) :: smear, arg ! Adaptive smearing + real(kind=dp) :: rdum, spn_nk(num_wann), alpha_sq, beta_sq + real(kind=dp) :: binwidth, r_num_elec_per_state + integer :: BandIdx, loop_f, min_f, max_f + logical :: DoSmearing r_num_elec_per_state = real(num_elec_per_state, kind=dp) ! Get spin projections for every band ! - if (spin_decomp) call spin_get_nk(kpt, spn_nk) + if (spin_decomp) call spin_get_nk(ws_region, pw90_spin, wannier_data, ws_distance, wigner_seitz, & + HH_R, SS_R, kpt, real_lattice, spn_nk, & + mp_grid, num_wann, seedname, stdout) binwidth = EnergyArray(2) - EnergyArray(1) @@ -1035,7 +1233,7 @@ subroutine TDF_kpt(kpt, EnergyArray, eig_k, deleig_k, TDF_k) ! Faster optimization: I precalculate the indices ! Value of the smearing in eV; default = 0 eV, i.e. no smearing - smear = boltz_TDF_smr_fixed_en_width + smear = pw90_boltzwann%tdf_smearing%fixed_width if (smear/binwidth < min_smearing_binwidth_ratio) then min_f = max(nint((eig_k(BandIdx) - EnergyArray(1))/ & (EnergyArray(size(EnergyArray)) - EnergyArray(1)) & @@ -1057,7 +1255,7 @@ subroutine TDF_kpt(kpt, EnergyArray, eig_k, deleig_k, TDF_k) do loop_f = min_f, max_f if (DoSmearing) then arg = (EnergyArray(loop_f) - eig_k(BandIdx))/smear - rdum = utility_w0gauss(arg, boltz_TDF_smr_index)/smear + rdum = utility_w0gauss(arg, pw90_boltzwann%tdf_smearing%type_index, stdout, seedname)/smear else rdum = 1._dp/(EnergyArray(2) - EnergyArray(1)) end if @@ -1112,7 +1310,7 @@ subroutine TDF_kpt(kpt, EnergyArray, eig_k, deleig_k, TDF_k) ! I multiply it here, since I am assuming a constant relaxation time, independent of the band index ! (actually, it is also independent of k) - TDF_k = TDF_k*boltz_relax_time + TDF_k = TDF_k*pw90_boltzwann%relax_time end subroutine TDF_kpt diff --git a/src/postw90/dos.F90 b/src/postw90/dos.F90 index bc5cfff9d..24121b709 100644 --- a/src/postw90/dos.F90 +++ b/src/postw90/dos.F90 @@ -11,94 +11,149 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! w90_dos: compute density of states ! +! ! +!------------------------------------------------------------! module w90_dos + !! Compute Density of States + use w90_constants, only: dp implicit none private - public :: dos_main, dos_get_levelspacing, dos_get_k - - integer :: num_freq - !! Number of sampling points - real(kind=dp) :: d_omega - !! Step between energies + public :: dos_get_k + public :: dos_get_levelspacing + public :: dos_main contains - !=========================================================! - ! PUBLIC PROCEDURES ! - !=========================================================! - - subroutine dos_main - !=======================================================! - ! ! + !================================================! + ! PUBLIC PROCEDURES + !================================================! + + subroutine dos_main(pw90_berry, dis_manifold, pw90_dos, kpoint_dist, kpt_latt, pw90_oper_read, & + pw90_band_deriv_degen, pw90_spin, ws_region, w90_system, print_output, & + wannier_data, ws_distance, wigner_seitz, HH_R, SS_R, u_matrix, v_matrix, & + eigval, real_lattice, scissors_shift, mp_grid, num_bands, num_kpts, & + num_wann, effective_model, have_disentangled, spin_decomp, seedname, stdout, & + comm) + !================================================! + ! !! Computes the electronic density of states. Can !! resolve into up-spin and down-spin parts, project !! onto selected Wannier orbitals, and use adaptive !! broadening, as in PRB 75, 195121 (2007) [YWVS07]. - ! ! - !=======================================================! - - use w90_io, only: io_error, io_file_unit, io_date, io_stopwatch, & - seedname, stdout - use w90_comms, only: on_root, num_nodes, my_node_id, comms_reduce - use w90_postw90_common, only: num_int_kpts_on_node, int_kpts, weight, & - pw90common_fourier_R_to_k - use w90_parameters, only: num_wann, dos_energy_min, dos_energy_max, & - dos_energy_step, timing_level, & - wanint_kpoint_file, dos_kmesh, & - dos_smr_index, dos_adpt_smr, dos_adpt_smr_fac, & - dos_adpt_smr_max, spin_decomp, & - dos_smr_fixed_en_width, & - dos_project, num_dos_project - use w90_get_oper, only: get_HH_R, get_SS_R, HH_R + ! + !================================================! + + use w90_comms, only: comms_reduce, w90comm_type, mpirank, mpisize + use w90_postw90_common, only: pw90common_fourier_R_to_k + use w90_postw90_types, only: pw90_dos_mod_type, pw90_berry_mod_type, & + pw90_band_deriv_degen_type, pw90_spin_mod_type, pw90_oper_read_type, wigner_seitz_type, & + kpoint_dist_type + use w90_types, only: print_output_type, wannier_data_type, dis_manifold_type, & + ws_region_type, w90_system_type, ws_distance_type + use w90_get_oper, only: get_HH_R, get_SS_R + use w90_io, only: io_error, io_file_unit, io_date, io_stopwatch + use w90_utility, only: utility_diagonalize, utility_recip_lattice_base use w90_wan_ham, only: wham_get_eig_deleig - use w90_utility, only: utility_diagonalize + implicit none + + ! arguments + type(pw90_berry_mod_type), intent(in) :: pw90_berry + type(dis_manifold_type), intent(in) :: dis_manifold + type(pw90_dos_mod_type), intent(in) :: pw90_dos + type(kpoint_dist_type), intent(in) :: kpoint_dist + type(pw90_oper_read_type), intent(in) :: pw90_oper_read + type(pw90_band_deriv_degen_type), intent(in) :: pw90_band_deriv_degen + type(pw90_spin_mod_type), intent(in) :: pw90_spin + type(ws_region_type), intent(in) :: ws_region + type(w90_system_type), intent(in) :: w90_system + type(print_output_type), intent(in) :: print_output + type(wannier_data_type), intent(in) :: wannier_data + type(ws_distance_type), intent(inout) :: ws_distance + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(w90comm_type), intent(in) :: comm + + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) + complex(kind=dp), intent(in) :: u_matrix(:, :, :), v_matrix(:, :, :) + + real(kind=dp), intent(in) :: eigval(:, :), real_lattice(3, 3) + real(kind=dp), intent(in) :: scissors_shift + real(kind=dp), intent(in) :: kpt_latt(:, :) + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_bands, num_kpts, num_wann + integer, intent(in) :: stdout + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + logical, intent(in) :: spin_decomp + logical, intent(in) :: effective_model + + ! local variables ! 'dos_k' contains contrib. from one k-point, ! 'dos_all' from all nodes/k-points (first summed on one node and ! then reduced (i.e. summed) over all nodes) - ! + real(kind=dp) :: recip_lattice(3, 3), volume + + integer :: i, loop_x, loop_y, loop_z, loop_tot, ifreq + integer :: dos_unit, ndim, ierr + integer :: my_node_id, num_nodes + integer :: num_freq !! Number of sampling points + real(kind=dp), allocatable :: dos_k(:, :) real(kind=dp), allocatable :: dos_all(:, :) - - real(kind=dp) :: kweight, kpt(3), omega - integer :: i, loop_x, loop_y, loop_z, loop_tot, ifreq - integer :: dos_unit, ndim, ierr - real(kind=dp), dimension(:), allocatable :: dos_energyarray + real(kind=dp) :: kweight, kpt(3), omega + real(kind=dp), allocatable :: dos_energyarray(:) + real(kind=dp) :: del_eig(num_wann, 3) + real(kind=dp) :: eig(num_wann), levelspacing_k(num_wann) + real(kind=dp) :: d_omega !! Step between energies complex(kind=dp), allocatable :: HH(:, :) complex(kind=dp), allocatable :: delHH(:, :, :) complex(kind=dp), allocatable :: UU(:, :) - real(kind=dp) :: del_eig(num_wann, 3) - real(kind=dp) :: eig(num_wann), levelspacing_k(num_wann) + logical :: on_root = .false. + + my_node_id = mpirank(comm) + num_nodes = mpisize(comm) + if (my_node_id == 0) on_root = .true. - num_freq = nint((dos_energy_max - dos_energy_min)/dos_energy_step) + 1 + num_freq = nint((pw90_dos%energy_max - pw90_dos%energy_min)/pw90_dos%energy_step) + 1 if (num_freq == 1) num_freq = 2 - d_omega = (dos_energy_max - dos_energy_min)/(num_freq - 1) + d_omega = (pw90_dos%energy_max - pw90_dos%energy_min)/(num_freq - 1) allocate (dos_energyarray(num_freq), stat=ierr) if (ierr /= 0) call io_error('Error in allocating dos_energyarray in ' & - //'dos subroutine') + //'dos subroutine', stdout, seedname) do ifreq = 1, num_freq - dos_energyarray(ifreq) = dos_energy_min + real(ifreq - 1, dp)*d_omega + dos_energyarray(ifreq) = pw90_dos%energy_min + real(ifreq - 1, dp)*d_omega end do allocate (HH(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating HH in dos') + if (ierr /= 0) call io_error('Error in allocating HH in dos', stdout, seedname) allocate (delHH(num_wann, num_wann, 3), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating delHH in dos') + if (ierr /= 0) call io_error('Error in allocating delHH in dos', stdout, seedname) allocate (UU(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating UU in dos') + if (ierr /= 0) call io_error('Error in allocating UU in dos', stdout, seedname) + + call get_HH_R(dis_manifold, kpt_latt, print_output, wigner_seitz, HH_R, u_matrix, v_matrix, eigval, & + real_lattice, scissors_shift, num_bands, num_kpts, num_wann, & + w90_system%num_valence_bands, effective_model, have_disentangled, seedname, stdout, & + comm) - call get_HH_R if (spin_decomp) then ndim = 3 - call get_SS_R + call get_SS_R(dis_manifold, kpt_latt, print_output, pw90_oper_read, SS_R, v_matrix, eigval, & + wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, num_wann, & + have_disentangled, seedname, stdout, comm) else ndim = 1 end if @@ -106,9 +161,9 @@ subroutine dos_main allocate (dos_k(num_freq, ndim)) allocate (dos_all(num_freq, ndim)) - if (on_root) then + if (print_output%iprint > 0) then - if (timing_level > 1) call io_stopwatch('dos', 1) + if (print_output%timing_level > 1) call io_stopwatch('dos', 1, stdout, seedname) ! write(stdout,'(/,1x,a)') '============' ! write(stdout,'(1x,a)') 'Calculating:' @@ -119,92 +174,103 @@ subroutine dos_main write (stdout, '(1x,a)') & '--------------------------------------' - if (num_dos_project == num_wann) then + if (pw90_dos%num_project == num_wann) then write (stdout, '(/,3x,a)') '* Total density of states (_dos)' else write (stdout, '(/,3x,a)') & '* Density of states projected onto selected WFs (_dos)' write (stdout, '(3x,a)') 'Selected WFs |Rn> are:' - do i = 1, num_dos_project - write (stdout, '(5x,a,2x,i3)') 'n =', dos_project(i) + do i = 1, pw90_dos%num_project + write (stdout, '(5x,a,2x,i3)') 'n =', pw90_dos%project(i) enddo endif write (stdout, '(/,5x,a,f9.4,a,f9.4,a)') & - 'Energy range: [', dos_energy_min, ',', dos_energy_max, '] eV' + 'Energy range: [', pw90_dos%energy_min, ',', pw90_dos%energy_max, '] eV' write (stdout, '(/,5x,a,(f6.3,1x))') & 'Adaptive smearing width prefactor: ', & - dos_adpt_smr_fac + pw90_dos%smearing%adaptive_prefactor write (stdout, '(/,/,1x,a20,3(i0,1x))') 'Interpolation grid: ', & - dos_kmesh(1:3) + pw90_dos%kmesh%mesh(1:3) end if dos_all = 0.0_dp - if (wanint_kpoint_file) then + call utility_recip_lattice_base(real_lattice, recip_lattice, volume) + if (pw90_berry%wanint_kpoint_file) then ! ! Unlike for optical properties, this should always work for the DOS ! - if (on_root) write (stdout, '(/,1x,a)') 'Sampling the irreducible BZ only' + if (print_output%iprint > 0) write (stdout, '(/,1x,a)') 'Sampling the irreducible BZ only' ! Loop over k-points on the irreducible wedge of the Brillouin zone, ! read from file 'kpoint.dat' ! - do loop_tot = 1, num_int_kpts_on_node(my_node_id) - kpt(:) = int_kpts(:, loop_tot) - if (dos_adpt_smr) then - call wham_get_eig_deleig(kpt, eig, del_eig, HH, delHH, UU) - call dos_get_levelspacing(del_eig, dos_kmesh, levelspacing_k) - call dos_get_k(kpt, dos_energyarray, eig, dos_k, & - smr_index=dos_smr_index, & - adpt_smr_fac=dos_adpt_smr_fac, & - adpt_smr_max=dos_adpt_smr_max, & - levelspacing_k=levelspacing_k, & - UU=UU) + do loop_tot = 1, kpoint_dist%num_int_kpts_on_node(my_node_id) + kpt(:) = kpoint_dist%int_kpts(:, loop_tot) + if (pw90_dos%smearing%use_adaptive) then + call wham_get_eig_deleig(dis_manifold, kpt_latt, pw90_band_deriv_degen, ws_region, print_output, wannier_data, & + ws_distance, wigner_seitz, delHH, HH, HH_R, u_matrix, UU, v_matrix, & + del_eig, eig, eigval, kpt, real_lattice, & + scissors_shift, mp_grid, num_bands, num_kpts, num_wann, & + w90_system%num_valence_bands, effective_model, have_disentangled, & + seedname, stdout, comm) + call dos_get_levelspacing(del_eig, pw90_dos%kmesh%mesh, levelspacing_k, num_wann, & + recip_lattice) + call dos_get_k(w90_system%num_elec_per_state, ws_region, kpt, dos_energyarray, eig, dos_k, & + num_wann, wannier_data, real_lattice, mp_grid, pw90_dos, spin_decomp, & + pw90_spin, ws_distance, wigner_seitz, stdout, seedname, HH_R, SS_R, & + pw90_dos%smearing, levelspacing_k=levelspacing_k, UU=UU) else - call pw90common_fourier_R_to_k(kpt, HH_R, HH, 0) - call utility_diagonalize(HH, num_wann, eig, UU) - call dos_get_k(kpt, dos_energyarray, eig, dos_k, & - smr_index=dos_smr_index, & - smr_fixed_en_width=dos_smr_fixed_en_width, & - UU=UU) + call pw90common_fourier_R_to_k(ws_region, wannier_data, ws_distance, wigner_seitz, HH, HH_R, & + kpt, real_lattice, mp_grid, 0, num_wann, seedname, stdout) + call utility_diagonalize(HH, num_wann, eig, UU, stdout, seedname) + call dos_get_k(w90_system%num_elec_per_state, ws_region, kpt, dos_energyarray, eig, dos_k, & + num_wann, wannier_data, real_lattice, mp_grid, pw90_dos, & + spin_decomp, pw90_spin, ws_distance, wigner_seitz, stdout, seedname, HH_R, & + SS_R, pw90_dos%smearing, UU=UU) end if - dos_all = dos_all + dos_k*weight(loop_tot) + dos_all = dos_all + dos_k*kpoint_dist%weight(loop_tot) end do else - if (on_root) write (stdout, '(/,1x,a)') 'Sampling the full BZ' - - kweight = 1.0_dp/real(PRODUCT(dos_kmesh), kind=dp) - do loop_tot = my_node_id, PRODUCT(dos_kmesh) - 1, num_nodes - loop_x = loop_tot/(dos_kmesh(2)*dos_kmesh(3)) - loop_y = (loop_tot - loop_x*(dos_kmesh(2) & - *dos_kmesh(3)))/dos_kmesh(3) - loop_z = loop_tot - loop_x*(dos_kmesh(2)*dos_kmesh(3)) & - - loop_y*dos_kmesh(3) - kpt(1) = real(loop_x, dp)/real(dos_kmesh(1), dp) - kpt(2) = real(loop_y, dp)/real(dos_kmesh(2), dp) - kpt(3) = real(loop_z, dp)/real(dos_kmesh(3), dp) - if (dos_adpt_smr) then - call wham_get_eig_deleig(kpt, eig, del_eig, HH, delHH, UU) - call dos_get_levelspacing(del_eig, dos_kmesh, levelspacing_k) - call dos_get_k(kpt, dos_energyarray, eig, dos_k, & - smr_index=dos_smr_index, & - adpt_smr_fac=dos_adpt_smr_fac, & - adpt_smr_max=dos_adpt_smr_max, & - levelspacing_k=levelspacing_k, & - UU=UU) + if (print_output%iprint > 0) write (stdout, '(/,1x,a)') 'Sampling the full BZ' + + kweight = 1.0_dp/real(PRODUCT(pw90_dos%kmesh%mesh), kind=dp) + do loop_tot = my_node_id, PRODUCT(pw90_dos%kmesh%mesh) - 1, num_nodes + loop_x = loop_tot/(pw90_dos%kmesh%mesh(2)*pw90_dos%kmesh%mesh(3)) + loop_y = (loop_tot - loop_x*(pw90_dos%kmesh%mesh(2) & + *pw90_dos%kmesh%mesh(3)))/pw90_dos%kmesh%mesh(3) + loop_z = loop_tot - loop_x*(pw90_dos%kmesh%mesh(2)*pw90_dos%kmesh%mesh(3)) & + - loop_y*pw90_dos%kmesh%mesh(3) + kpt(1) = real(loop_x, dp)/real(pw90_dos%kmesh%mesh(1), dp) + kpt(2) = real(loop_y, dp)/real(pw90_dos%kmesh%mesh(2), dp) + kpt(3) = real(loop_z, dp)/real(pw90_dos%kmesh%mesh(3), dp) + if (pw90_dos%smearing%use_adaptive) then + call wham_get_eig_deleig(dis_manifold, kpt_latt, pw90_band_deriv_degen, ws_region, print_output, wannier_data, & + ws_distance, wigner_seitz, delHH, HH, HH_R, u_matrix, UU, v_matrix, & + del_eig, eig, eigval, kpt, real_lattice, & + scissors_shift, mp_grid, num_bands, num_kpts, num_wann, & + w90_system%num_valence_bands, effective_model, have_disentangled, & + seedname, stdout, comm) + call dos_get_levelspacing(del_eig, pw90_dos%kmesh%mesh, levelspacing_k, num_wann, & + recip_lattice) + call dos_get_k(w90_system%num_elec_per_state, ws_region, kpt, dos_energyarray, eig, dos_k, & + num_wann, wannier_data, real_lattice, mp_grid, pw90_dos, & + spin_decomp, pw90_spin, ws_distance, wigner_seitz, stdout, seedname, HH_R, & + SS_R, pw90_dos%smearing, levelspacing_k=levelspacing_k, UU=UU) else - call pw90common_fourier_R_to_k(kpt, HH_R, HH, 0) - call utility_diagonalize(HH, num_wann, eig, UU) - call dos_get_k(kpt, dos_energyarray, eig, dos_k, & - smr_index=dos_smr_index, & - smr_fixed_en_width=dos_smr_fixed_en_width, & - UU=UU) + call pw90common_fourier_R_to_k(ws_region, wannier_data, ws_distance, wigner_seitz, HH, HH_R, & + kpt, real_lattice, mp_grid, 0, num_wann, seedname, stdout) + call utility_diagonalize(HH, num_wann, eig, UU, stdout, seedname) + call dos_get_k(w90_system%num_elec_per_state, ws_region, kpt, dos_energyarray, eig, dos_k, & + num_wann, wannier_data, real_lattice, mp_grid, pw90_dos, & + spin_decomp, pw90_spin, ws_distance, wigner_seitz, stdout, seedname, HH_R, & + SS_R, pw90_dos%smearing, UU=UU) end if dos_all = dos_all + dos_k*kweight end do @@ -213,9 +279,9 @@ subroutine dos_main ! Collect contributions from all nodes ! - call comms_reduce(dos_all(1, 1), num_freq*ndim, 'SUM') + call comms_reduce(dos_all(1, 1), num_freq*ndim, 'SUM', stdout, seedname, comm) - if (on_root) then + if (print_output%iprint > 0) then write (stdout, '(1x,a)') 'Output data files:' write (stdout, '(/,3x,a)') trim(seedname)//'-dos.dat' dos_unit = io_file_unit() @@ -226,19 +292,19 @@ subroutine dos_main write (dos_unit, '(4E16.8)') omega, dos_all(ifreq, :) enddo close (dos_unit) - if (timing_level > 1) call io_stopwatch('dos', 2) + if (print_output%timing_level > 1) call io_stopwatch('dos', 2, stdout, seedname) end if deallocate (HH, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating HH in dos_main') + if (ierr /= 0) call io_error('Error in deallocating HH in dos_main', stdout, seedname) deallocate (delHH, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating delHH in dos_main') + if (ierr /= 0) call io_error('Error in deallocating delHH in dos_main', stdout, seedname) deallocate (UU, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating UU in dos_main') + if (ierr /= 0) call io_error('Error in deallocating UU in dos_main', stdout, seedname) end subroutine dos_main - ! ========================================================================= + !================================================== ! The next routine is commented. It should be working (apart for a ! missing broadcast at the very end, see comments there). However, @@ -246,11 +312,11 @@ end subroutine dos_main ! resample the BZ, but rather use the calculated DOS (maybe it can be ! something that is done at the end of the DOS routine?) !~ subroutine find_fermi_level -!~ !==============================================! +!~ !================================================! !~ ! ! !~ ! Finds the Fermi level by integrating the DOS ! !~ ! ! -!~ !==============================================! +!~ !================================================! !~ !~ use w90_io, only : stdout,io_error !~ use w90_comms @@ -270,7 +336,7 @@ end subroutine dos_main !~ sum_mid_node,sum_mid_all,emin,emax,emid,& !~ emin_node(0:num_nodes-1),emax_node(0:num_nodes-1),& !~ ef -!~ integer :: loop_x,loop_y,loop_z,loop_kpt,loop_nodes,& +!~ integer :: loop_x,loop_y,loop_z,loop_kpt,loop_nodes,& !~ loop_iter,ierr,num_int_kpts,ikp !~ !~ real(kind=dp), allocatable :: eig_node(:,:) @@ -466,66 +532,79 @@ end subroutine dos_main !> dos_get_levelspacing() routine !> If present: adaptive smearing !> If not present: fixed-energy-width smearing - subroutine dos_get_k(kpt, EnergyArray, eig_k, dos_k, smr_index, & - smr_fixed_en_width, adpt_smr_fac, adpt_smr_max, levelspacing_k, UU) + + !================================================! + subroutine dos_get_k(num_elec_per_state, ws_region, kpt, EnergyArray, eig_k, dos_k, num_wann, & + wannier_data, real_lattice, mp_grid, pw90_dos, spin_decomp, & + pw90_spin, ws_distance, wigner_seitz, stdout, seedname, HH_R, SS_R, & + smearing, levelspacing_k, UU) + !================================================! use w90_io, only: io_error use w90_constants, only: dp, smearing_cutoff, min_smearing_binwidth_ratio use w90_utility, only: utility_w0gauss - use w90_parameters, only: num_wann, spin_decomp, num_elec_per_state, & - num_dos_project, dos_project + use w90_postw90_types, only: pw90_spin_mod_type, pw90_dos_mod_type, pw90_smearing_type, & + wigner_seitz_type + use w90_types, only: wannier_data_type, ws_region_type, ws_distance_type use w90_spin, only: spin_get_nk + use w90_utility, only: utility_w0gauss ! Arguments - ! - real(kind=dp), dimension(3), intent(in) :: kpt - real(kind=dp), dimension(:), intent(in) :: EnergyArray - real(kind=dp), dimension(:), intent(in) :: eig_k - real(kind=dp), dimension(:, :), intent(out) :: dos_k - integer, intent(in) :: smr_index - real(kind=dp), intent(in), optional :: smr_fixed_en_width - real(kind=dp), intent(in), optional :: adpt_smr_fac - real(kind=dp), intent(in), optional :: adpt_smr_max - real(kind=dp), dimension(:), intent(in), optional :: levelspacing_k - complex(kind=dp), dimension(:, :), intent(in), optional :: UU - - ! Adaptive smearing - ! - real(kind=dp) :: eta_smr, arg - - ! Misc/Dummy - ! - integer :: i, j, loop_f, min_f, max_f, num_s_steps - real(kind=dp) :: rdum, spn_nk(num_wann), alpha_sq, beta_sq - real(kind=dp) :: binwidth, r_num_elec_per_state - logical :: DoSmearing + type(pw90_dos_mod_type), intent(in) :: pw90_dos + type(pw90_spin_mod_type), intent(in) :: pw90_spin + type(ws_region_type), intent(in) :: ws_region + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(in) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + type(pw90_smearing_type), intent(in) :: smearing + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_elec_per_state + integer, intent(in) :: num_wann + !integer, intent(in) :: smr_index + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: kpt(3) + real(kind=dp), intent(in) :: eig_k(:) + real(kind=dp), intent(in) :: EnergyArray(:) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(out) :: dos_k(:, :) + real(kind=dp), intent(in), optional :: levelspacing_k(:) + !real(kind=dp), intent(in), optional :: adpt_smr_fac + !real(kind=dp), intent(in), optional :: adpt_smr_max + !real(kind=dp), intent(in), optional :: smr_fixed_en_width + + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) + complex(kind=dp), intent(in), optional :: UU(:, :) + + logical, intent(in) :: spin_decomp + character(len=50), intent(in) :: seedname + + ! local variables + real(kind=dp) :: eta_smr, arg ! Adaptive smearing + real(kind=dp) :: rdum, spn_nk(num_wann), alpha_sq, beta_sq + real(kind=dp) :: binwidth, r_num_elec_per_state + integer :: i, j, loop_f, min_f, max_f + logical :: DoSmearing if (present(levelspacing_k)) then - if (present(smr_fixed_en_width)) & - call io_error('Cannot call doskpt with levelspacing_k and ' & - //'with smr_fixed_en_width parameters together') - if (.not. (present(adpt_smr_fac))) & - call io_error('Cannot call doskpt with levelspacing_k and ' & - //'without adpt_smr_fac parameter') - if (.not. (present(adpt_smr_max))) & - call io_error('Cannot call doskpt with levelspacing_k and ' & - //'without adpt_smr_max parameter') - else - if (present(adpt_smr_fac)) & + if (.not. smearing%use_adaptive) & call io_error('Cannot call doskpt without levelspacing_k and ' & - //'with adpt_smr_fac parameter') - if (present(adpt_smr_max)) & - call io_error('Cannot call doskpt without levelspacing_k and ' & - //'with adpt_smr_max parameter') - if (.not. (present(smr_fixed_en_width))) & + //'without adptative smearing', stdout, seedname) + else + if (smearing%use_adaptive) & call io_error('Cannot call doskpt without levelspacing_k and ' & - //'without smr_fixed_en_width parameter') + //'with adptative smearing', stdout, seedname) end if r_num_elec_per_state = real(num_elec_per_state, kind=dp) ! Get spin projections for every band ! - if (spin_decomp) call spin_get_nk(kpt, spn_nk) + if (spin_decomp) then + call spin_get_nk(ws_region, pw90_spin, wannier_data, ws_distance, wigner_seitz, HH_R, SS_R, & + kpt, real_lattice, spn_nk, mp_grid, num_wann, seedname, stdout) + endif binwidth = EnergyArray(2) - EnergyArray(1) @@ -540,10 +619,10 @@ subroutine dos_get_k(kpt, EnergyArray, eig_k, dos_k, smr_index, & end if if (.not. present(levelspacing_k)) then - eta_smr = smr_fixed_en_width + eta_smr = smearing%fixed_width else ! Eq.(35) YWVS07 - eta_smr = min(levelspacing_k(i)*adpt_smr_fac, adpt_smr_max) + eta_smr = min(levelspacing_k(i)*smearing%adaptive_prefactor, smearing%adaptive_max_width) ! eta_smr=max(eta_smr,min_smearing_binwidth_ratio) !! No: it would render the next if always false end if @@ -570,7 +649,7 @@ subroutine dos_get_k(kpt, EnergyArray, eig_k, dos_k, smr_index, & ! kind of smearing read from input (internal smearing_index variable) if (DoSmearing) then arg = (EnergyArray(loop_f) - eig_k(i))/eta_smr - rdum = utility_w0gauss(arg, smr_index)/eta_smr + rdum = utility_w0gauss(arg, smearing%type_index, stdout, seedname)/eta_smr else rdum = 1._dp/(EnergyArray(2) - EnergyArray(1)) end if @@ -578,7 +657,7 @@ subroutine dos_get_k(kpt, EnergyArray, eig_k, dos_k, smr_index, & ! ! Contribution to total DOS ! - if (num_dos_project == num_wann) then + if (pw90_dos%num_project == num_wann) then ! ! Total DOS (default): do not loop over j, to save time ! @@ -597,16 +676,16 @@ subroutine dos_get_k(kpt, EnergyArray, eig_k, dos_k, smr_index, & ! Partial DOS, projected onto the WFs with indices ! n=dos_project(1:num_dos_project) ! - do j = 1, num_dos_project + do j = 1, pw90_dos%num_project dos_k(loop_f, 1) = dos_k(loop_f, 1) + rdum*r_num_elec_per_state & - *abs(UU(dos_project(j), i))**2 + *abs(UU(pw90_dos%project(j), i))**2 if (spin_decomp) then ! Spin-up contribution dos_k(loop_f, 2) = dos_k(loop_f, 2) & - + rdum*alpha_sq*abs(UU(dos_project(j), i))**2 + + rdum*alpha_sq*abs(UU(pw90_dos%project(j), i))**2 ! Spin-down contribution dos_k(loop_f, 3) = dos_k(loop_f, 3) & - + rdum*beta_sq*abs(UU(dos_project(j), i))**2 + + rdum*beta_sq*abs(UU(pw90_dos%project(j), i))**2 end if enddo endif @@ -615,26 +694,29 @@ subroutine dos_get_k(kpt, EnergyArray, eig_k, dos_k, smr_index, & end subroutine dos_get_k - ! ========================================================================= - - subroutine dos_get_levelspacing(del_eig, kmesh, levelspacing) + !================================================== + subroutine dos_get_levelspacing(del_eig, kmesh, levelspacing, num_wann, recip_lattice) + !================================================== !! This subroutine calculates the level spacing, i.e. how much the level changes !! near a given point of the interpolation mesh - use w90_parameters, only: num_wann + !================================================== + use w90_postw90_common, only: pw90common_kmesh_spacing - real(kind=dp), dimension(num_wann, 3), intent(in) :: del_eig + integer, intent(in) :: num_wann + real(kind=dp), intent(in) :: del_eig(:, :) !! Band velocities, already corrected when degeneracies occur - integer, dimension(3), intent(in) :: kmesh + integer, intent(in) :: kmesh(3) !! array of three integers, giving the number of k points along !! each of the three directions defined by the reciprocal lattice vectors - real(kind=dp), dimension(num_wann), intent(out) :: levelspacing + real(kind=dp), intent(out) :: levelspacing(num_wann) !! On output, the spacing for each of the bands (in eV) + real(kind=dp), intent(in) :: recip_lattice(3, 3) real(kind=dp) :: Delta_k integer :: band - Delta_k = pw90common_kmesh_spacing(kmesh) + Delta_k = pw90common_kmesh_spacing(kmesh, recip_lattice) do band = 1, num_wann levelspacing(band) = & sqrt(dot_product(del_eig(band, :), del_eig(band, :)))*Delta_k @@ -655,7 +737,7 @@ end subroutine dos_get_levelspacing !~ !~ ! Arguments !~ ! -!~ real(kind=dp), intent(in) :: kpt(3) +!~ real(kind=dp), intent(in) :: kpt(3) !~ real(kind=dp), intent(out) :: eig(num_wann) !~ real(kind=dp), intent(out) :: levelspacing(num_wann) !~ @@ -667,7 +749,7 @@ end subroutine dos_get_levelspacing !~ ! !~ real(kind=dp) :: del_eig(num_wann,3),Delta_k !~ -!~ integer :: i +!~ integer :: i !~ !~ allocate(HH(num_wann,num_wann)) !~ allocate(delHH(num_wann,num_wann,3)) @@ -690,9 +772,9 @@ end subroutine dos_get_levelspacing !~ !~ end subroutine dos_get_eig_levelspacing_k -!~ !=========================================================! +!~ !================================================! !~ ! PRIVATE PROCEDURES ! -!~ !=========================================================! +!~ !================================================! !~ !~ !~ function count_states(energy,eig,levelspacing,npts) @@ -706,14 +788,14 @@ end subroutine dos_get_levelspacing !~ !~ ! Arguments !~ ! -!~ real(kind=dp) :: energy +!~ real(kind=dp) :: energy !~ real(kind=dp), dimension (:,:) :: eig !~ real(kind=dp), dimension (:,:) :: levelspacing -!~ integer :: npts +!~ integer :: npts !~ !~ ! Misc/Dummy !~ ! -!~ integer :: loop_k,i +!~ integer :: loop_k,i !~ real(kind=dp) :: sum,eta_smr,arg !~ !~ count_states=0.0_dp @@ -735,4 +817,3 @@ end subroutine dos_get_levelspacing !~ end function count_states end module w90_dos - diff --git a/src/postw90/geninterp.F90 b/src/postw90/geninterp.F90 index 8395a4819..869c82e68 100644 --- a/src/postw90/geninterp.F90 +++ b/src/postw90/geninterp.F90 @@ -12,49 +12,52 @@ ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! ! ! +! w90_geninterp: interpolation functions ! ! ! !------------------------------------------------------------! module w90_geninterp + !! Generic Interpolation Routine !! !! written by Giovanni Pizzi !! THEOS, EPFL, Station 12, 1015 Lausanne (Switzerland) !! June, 2012 - use w90_constants - use w90_parameters, only: geninterp_alsofirstder, num_wann, recip_lattice, real_lattice, & - timing_level, geninterp_single_file - use w90_io, only: io_error, stdout, io_stopwatch, io_file_unit, seedname, io_stopwatch - use w90_get_oper, only: get_HH_R, HH_R - use w90_comms - use w90_utility, only: utility_diagonalize - use w90_postw90_common, only: pw90common_fourier_R_to_k - use w90_wan_ham, only: wham_get_eig_deleig - use w90_io, only: io_date implicit none private + public :: geninterp_main contains - subroutine internal_write_header(outdat_unit, commentline) + !================================================== + + subroutine internal_write_header(outdat_unit, commentline, pw90_geninterp) + !================================================== !! Writes a header for the output file(s). + !================================================== + use w90_postw90_types, only: pw90_geninterp_mod_type + use w90_io, only: io_date + + ! arguments + type(pw90_geninterp_mod_type), intent(in) :: pw90_geninterp integer, intent(in) :: outdat_unit !! Integer with the output file unit. The file must be already open. - character(len=*) :: commentline !! no intent? + character(len=*) :: commentline !! no intent? !! String with the comment taken from the output, to be written on the output - character(len=9) :: cdate, ctime + ! local variables + character(len=9) :: cdate, ctime call io_date(cdate, ctime) write (outdat_unit, '(A)') "# Written on "//cdate//" at "//ctime ! Date and time ! I rewrite the comment line on the output write (outdat_unit, '(A)') "# Input file comment: "//trim(commentline) - if (geninterp_alsofirstder) then + if (pw90_geninterp%alsofirstder) then write (outdat_unit, '(A)') "# Kpt_idx K_x (1/ang) K_y (1/ang) K_z (1/ang) Energy (eV)"// & " EnergyDer_x EnergyDer_y EnergyDer_z" else @@ -62,7 +65,13 @@ subroutine internal_write_header(outdat_unit, commentline) end if end subroutine internal_write_header - subroutine geninterp_main() + !================================================== + subroutine geninterp_main(dis_manifold, pw90_geninterp, kpt_latt, pw90_band_deriv_degen, ws_region, print_output, & + wannier_data, ws_distance, wigner_seitz, HH_R, v_matrix, u_matrix, eigval, & + real_lattice, scissors_shift, mp_grid, num_bands, & + num_kpts, num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm) + !================================================== !! This routine prints the band energies (and possibly the band derivatives) !! !! This routine is parallel, even if ***the scaling is very bad*** since at the moment @@ -70,26 +79,77 @@ subroutine geninterp_main() !! But at least if works independently of the number of processors. !! I think that a way to write in parallel to the output would help a lot, !! so that we don't have to send all eigenvalues to the root node. - integer :: kpt_unit, outdat_unit, num_kpts, ierr, i, j, k, enidx + !================================================== + + use w90_constants, only: dp, pi + use w90_postw90_types, only: pw90_geninterp_mod_type, & + pw90_band_deriv_degen_type, wigner_seitz_type + use w90_types, only: dis_manifold_type, print_output_type, & + wannier_data_type, ws_region_type, ws_distance_type + use w90_io, only: io_error, io_stopwatch, io_file_unit, io_stopwatch + use w90_postw90_common, only: pw90common_fourier_R_to_k + use w90_utility, only: utility_diagonalize, utility_recip_lattice_base + use w90_wan_ham, only: wham_get_eig_deleig + use w90_get_oper, only: get_HH_R + use w90_comms, only: mpirank, mpisize, comms_bcast, comms_array_split, comms_scatterv, & + comms_gatherv, w90comm_type + + ! arguments + type(dis_manifold_type), intent(in) :: dis_manifold + type(pw90_geninterp_mod_type), intent(in) :: pw90_geninterp + type(pw90_band_deriv_degen_type), intent(in) :: pw90_band_deriv_degen + type(ws_region_type), intent(in) :: ws_region + type(print_output_type), intent(in) :: print_output + type(wannier_data_type), intent(in) :: wannier_data + type(ws_distance_type), intent(inout) :: ws_distance + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(w90comm_type), intent(in) :: comm + + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) + complex(kind=dp), intent(in) :: v_matrix(:, :, :), u_matrix(:, :, :) + + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: scissors_shift + real(kind=dp), intent(in) :: kpt_latt(:, :) + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_bands, num_kpts, num_wann, num_valence_bands, stdout + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + logical, intent(in) :: effective_model + + ! local variables + real(kind=dp) :: recip_lattice(3, 3), volume + integer :: kpt_unit, outdat_unit, ierr, i, j, enidx + integer :: nkinterp ! number of kpoints for which we perform the interpolation + integer, allocatable :: counts(:), displs(:) + integer :: my_node_id, num_nodes + integer, allocatable :: kpointidx(:), localkpointidx(:) + real(kind=dp), allocatable :: kpoints(:, :), localkpoints(:, :) + real(kind=dp) :: kpt(3), frac(3) + real(kind=dp), allocatable :: localdeleig(:, :, :) + real(kind=dp), allocatable :: globaldeleig(:, :, :) + real(kind=dp), allocatable :: localeig(:, :) + real(kind=dp), allocatable :: globaleig(:, :) + complex(kind=dp), allocatable :: HH(:, :) + complex(kind=dp), allocatable :: UU(:, :) + complex(kind=dp), allocatable :: delHH(:, :, :) character(len=500) :: commentline - character(len=50) :: cdum - integer, dimension(:), allocatable :: kpointidx, localkpointidx - real(kind=dp), dimension(:, :), allocatable :: kpoints, localkpoints - complex(kind=dp), dimension(:, :), allocatable :: HH - complex(kind=dp), dimension(:, :), allocatable :: UU - complex(kind=dp), dimension(:, :, :), allocatable :: delHH - real(kind=dp), dimension(3) :: kpt, frac - real(kind=dp), dimension(:, :, :), allocatable :: localdeleig - real(kind=dp), dimension(:, :, :), allocatable :: globaldeleig - real(kind=dp), dimension(:, :), allocatable :: localeig - real(kind=dp), dimension(:, :), allocatable :: globaleig - logical :: absoluteCoords - character(len=200) :: outdat_filename - - integer, dimension(0:num_nodes - 1) :: counts - integer, dimension(0:num_nodes - 1) :: displs - - if (on_root .and. (timing_level > 0)) call io_stopwatch('geninterp_main', 1) + character(len=50) :: cdum + character(len=200) :: outdat_filename + logical :: absoluteCoords + logical :: on_root = .false. + + my_node_id = mpirank(comm) + num_nodes = mpisize(comm) + if (my_node_id == 0) on_root = .true. + allocate (counts(0:num_nodes - 1)) + allocate (displs(0:num_nodes - 1)) + + if (print_output%iprint > 0 .and. (print_output%timing_level > 0)) & + call io_stopwatch('geninterp_main', 1, stdout, seedname) if (on_root) then write (stdout, *) @@ -98,7 +158,8 @@ subroutine geninterp_main() write (stdout, '(1x,a)') '*---------------------------------------------------------------------------*' kpt_unit = io_file_unit() - open (unit=kpt_unit, file=trim(seedname)//'_geninterp.kpt', form='formatted', status='old', err=105) + open (unit=kpt_unit, file=trim(seedname)//'_geninterp.kpt', form='formatted', status='old', & + err=105) ! First line: comment (e.g. creation date, author, ...) read (kpt_unit, '(A500)', err=106, end=106) commentline @@ -114,69 +175,76 @@ subroutine geninterp_main() absoluteCoords = .true. else call io_error('Error on second line of file '//trim(seedname)//'_geninterp.kpt: '// & - 'unable to recognize keyword') + 'unable to recognize keyword', stdout, seedname) end if ! Third line: number of following kpoints - read (kpt_unit, *, err=106, end=106) num_kpts + read (kpt_unit, *, err=106, end=106) nkinterp end if - call comms_bcast(num_kpts, 1) + call comms_bcast(nkinterp, 1, stdout, seedname, comm) allocate (HH(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating HH in calcTDF') + if (ierr /= 0) call io_error('Error in allocating HH in calcTDF', stdout, seedname) allocate (UU(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating UU in calcTDF') - if (geninterp_alsofirstder) then + if (ierr /= 0) call io_error('Error in allocating UU in calcTDF', stdout, seedname) + if (pw90_geninterp%alsofirstder) then allocate (delHH(num_wann, num_wann, 3), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating delHH in calcTDF') + if (ierr /= 0) call io_error('Error in allocating delHH in calcTDF', stdout, seedname) end if ! I call once the routine to calculate the Hamiltonian in real-space <0n|H|Rm> - call get_HH_R + call get_HH_R(dis_manifold, kpt_latt, print_output, wigner_seitz, HH_R, u_matrix, v_matrix, eigval, & + real_lattice, scissors_shift, num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, stdout, comm) if (on_root) then - allocate (kpointidx(num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating kpointidx in geinterp_main.') - allocate (kpoints(3, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating kpoints in geinterp_main.') - if (geninterp_single_file) then - allocate (globaleig(num_wann, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating globaleig in geinterp_main.') - allocate (globaldeleig(num_wann, 3, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating globaldeleig in geinterp_main.') + allocate (kpointidx(nkinterp), stat=ierr) + if (ierr /= 0) call io_error('Error allocating kpointidx in geinterp_main.', stdout, seedname) + allocate (kpoints(3, nkinterp), stat=ierr) + if (ierr /= 0) call io_error('Error allocating kpoints in geinterp_main.', stdout, seedname) + if (pw90_geninterp%single_file) then + allocate (globaleig(num_wann, nkinterp), stat=ierr) + if (ierr /= 0) call io_error('Error allocating globaleig in geinterp_main.', stdout, & + seedname) + allocate (globaldeleig(num_wann, 3, nkinterp), stat=ierr) + if (ierr /= 0) call io_error('Error allocating globaldeleig in geinterp_main.', stdout, & + seedname) end if else ! On the other nodes, I still allocate them with size 1 to avoid ! that some compilers still try to access the memory allocate (kpointidx(1), stat=ierr) - if (ierr /= 0) call io_error('Error allocating kpointidx in geinterp_main.') + if (ierr /= 0) call io_error('Error allocating kpointidx in geinterp_main.', stdout, seedname) allocate (kpoints(1, 1), stat=ierr) - if (ierr /= 0) call io_error('Error allocating kpoints in geinterp_main.') - if (geninterp_single_file) then + if (ierr /= 0) call io_error('Error allocating kpoints in geinterp_main.', stdout, seedname) + if (pw90_geninterp%single_file) then allocate (globaleig(num_wann, 1), stat=ierr) - if (ierr /= 0) call io_error('Error allocating globaleig in geinterp_main.') + if (ierr /= 0) call io_error('Error allocating globaleig in geinterp_main.', stdout, & + seedname) allocate (globaldeleig(num_wann, 3, 1), stat=ierr) - if (ierr /= 0) call io_error('Error allocating globaldeleig in geinterp_main.') + if (ierr /= 0) call io_error('Error allocating globaldeleig in geinterp_main.', stdout, & + seedname) end if end if ! I precalculate how to split on different nodes - call comms_array_split(num_kpts, counts, displs) + call comms_array_split(nkinterp, counts, displs, comm) allocate (localkpoints(3, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error allocating localkpoints in geinterp_main.') + if (ierr /= 0) call io_error('Error allocating localkpoints in geinterp_main.', stdout, & + seedname) allocate (localeig(num_wann, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error allocating localeig in geinterp_main.') + if (ierr /= 0) call io_error('Error allocating localeig in geinterp_main.', stdout, seedname) allocate (localdeleig(num_wann, 3, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error allocating localdeleig in geinterp_main.') + if (ierr /= 0) call io_error('Error allocating localdeleig in geinterp_main.', stdout, seedname) ! On root, I read numpoints_thischunk points if (on_root) then ! Lines with integer identifier and three coordinates ! (in crystallographic coordinates relative to the reciprocal lattice vectors) - do i = 1, num_kpts + do i = 1, nkinterp read (kpt_unit, *, err=106, end=106) kpointidx(i), kpt ! Internally, I need the relative (fractional) coordinates in units of the reciprocal-lattice vectors if (absoluteCoords .eqv. .false.) then @@ -195,22 +263,25 @@ subroutine geninterp_main() end if ! Now, I distribute the kpoints; 3* because I send kx, ky, kz - call comms_scatterv(localkpoints, 3*counts(my_node_id), kpoints, 3*counts, 3*displs) - if (.not. geninterp_single_file) then + call comms_scatterv(localkpoints, 3*counts(my_node_id), kpoints, 3*counts, 3*displs, stdout, & + seedname, comm) + if (.not. pw90_geninterp%single_file) then ! Allocate at least one entry, even if we don't use it allocate (localkpointidx(max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error allocating localkpointidx in geinterp_main.') - call comms_scatterv(localkpointidx, counts(my_node_id), kpointidx, counts, displs) + if (ierr /= 0) call io_error('Error allocating localkpointidx in geinterp_main.', stdout, & + seedname) + call comms_scatterv(localkpointidx, counts(my_node_id), kpointidx, counts, displs, stdout, & + seedname, comm) end if ! I open the output file(s) - if (geninterp_single_file) then + if (pw90_geninterp%single_file) then if (on_root) then outdat_filename = trim(seedname)//'_geninterp.dat' outdat_unit = io_file_unit() open (unit=outdat_unit, file=trim(outdat_filename), form='formatted', err=107) - call internal_write_header(outdat_unit, commentline) + call internal_write_header(outdat_unit, commentline, pw90_geninterp) end if else if (num_nodes > 99999) then @@ -221,45 +292,53 @@ subroutine geninterp_main() outdat_unit = io_file_unit() open (unit=outdat_unit, file=trim(outdat_filename), form='formatted', err=107) - call comms_bcast(commentline, len(commentline)) + call comms_bcast(commentline, len(commentline), stdout, seedname, comm) - call internal_write_header(outdat_unit, commentline) + call internal_write_header(outdat_unit, commentline, pw90_geninterp) end if ! And now, each node calculates its own k points do i = 1, counts(my_node_id) kpt = localkpoints(:, i) ! Here I get the band energies and the velocities (if required) - if (geninterp_alsofirstder) then - call wham_get_eig_deleig(kpt, localeig(:, i), localdeleig(:, :, i), HH, delHH, UU) + if (pw90_geninterp%alsofirstder) then + call wham_get_eig_deleig(dis_manifold, kpt_latt, pw90_band_deriv_degen, ws_region, print_output, wannier_data, & + ws_distance, wigner_seitz, delHH, HH, HH_R, u_matrix, UU, v_matrix, & + localdeleig(:, :, i), localeig(:, i), eigval, kpt, real_lattice, & + scissors_shift, mp_grid, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, & + seedname, stdout, comm) else - call pw90common_fourier_R_to_k(kpt, HH_R, HH, 0) - call utility_diagonalize(HH, num_wann, localeig(:, i), UU) + call pw90common_fourier_R_to_k(ws_region, wannier_data, ws_distance, wigner_seitz, HH, HH_R, kpt, & + real_lattice, mp_grid, 0, num_wann, seedname, stdout) + call utility_diagonalize(HH, num_wann, localeig(:, i), UU, stdout, seedname) end if end do - if (geninterp_single_file) then + call utility_recip_lattice_base(real_lattice, recip_lattice, volume) + if (pw90_geninterp%single_file) then ! Now, I get the results from the different nodes call comms_gatherv(localeig, num_wann*counts(my_node_id), globaleig, & - num_wann*counts, num_wann*displs) + num_wann*counts, num_wann*displs, stdout, seedname, comm) - if (geninterp_alsofirstder) then + if (pw90_geninterp%alsofirstder) then call comms_gatherv(localdeleig, 3*num_wann*counts(my_node_id), globaldeleig, & - 3*num_wann*counts, 3*num_wann*displs) + 3*num_wann*counts, 3*num_wann*displs, stdout, seedname, comm) end if ! Now the printing, only on root node if (on_root) then - do i = 1, num_kpts + do i = 1, nkinterp kpt = kpoints(:, i) ! First calculate the absolute coordinates for printing frac = 0._dp do j = 1, 3 - frac(j) = recip_lattice(1, j)*kpt(1) + recip_lattice(2, j)*kpt(2) + recip_lattice(3, j)*kpt(3) + frac(j) = recip_lattice(1, j)*kpt(1) + recip_lattice(2, j)*kpt(2) & + + recip_lattice(3, j)*kpt(3) end do ! I print each line - if (geninterp_alsofirstder) then + if (pw90_geninterp%alsofirstder) then do enidx = 1, num_wann write (outdat_unit, '(I10,7G18.10)') kpointidx(i), frac, & globaleig(enidx, i), globaldeleig(enidx, :, i) @@ -279,11 +358,12 @@ subroutine geninterp_main() ! First calculate the absolute coordinates for printing frac = 0._dp do j = 1, 3 - frac(j) = recip_lattice(1, j)*kpt(1) + recip_lattice(2, j)*kpt(2) + recip_lattice(3, j)*kpt(3) + frac(j) = recip_lattice(1, j)*kpt(1) + recip_lattice(2, j)*kpt(2) & + + recip_lattice(3, j)*kpt(3) end do ! I print each line - if (geninterp_alsofirstder) then + if (pw90_geninterp%alsofirstder) then do enidx = 1, num_wann write (outdat_unit, '(I10,7G18.10)') localkpointidx(i), frac, & localeig(enidx, i), localdeleig(enidx, :, i) @@ -316,13 +396,16 @@ subroutine geninterp_main() if (allocated(globaleig)) deallocate (globaleig) if (allocated(globaldeleig)) deallocate (globaldeleig) - if (on_root .and. (timing_level > 0)) call io_stopwatch('geninterp_main', 2) + if (on_root .and. (print_output%timing_level > 0)) call io_stopwatch('geninterp_main', 2, & + stdout, seedname) return -105 call io_error('Error: Problem opening k-point file '//trim(seedname)//'_geninterp.kpt') -106 call io_error('Error: Problem reading k-point file '//trim(seedname)//'_geninterp.kpt') -107 call io_error('Error: Problem opening output file '//trim(outdat_filename)) +105 call io_error('Error: Problem opening k-point file '//trim(seedname)//'_geninterp.kpt', & + stdout, seedname) +106 call io_error('Error: Problem reading k-point file '//trim(seedname)//'_geninterp.kpt', & + stdout, seedname) +107 call io_error('Error: Problem opening output file '//trim(outdat_filename), stdout, seedname) end subroutine geninterp_main end module w90_geninterp diff --git a/src/postw90/get_oper.F90 b/src/postw90/get_oper.F90 index f61c22070..bb72f88fa 100644 --- a/src/postw90/get_oper.F90 +++ b/src/postw90/get_oper.F90 @@ -11,84 +11,75 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! w90_get_oper: matrix elements of various operators ! +! ! +!------------------------------------------------------------! module w90_get_oper -!=========================================================== -!! Finds the Wannier matrix elements of various operators, -!! starting from k-space matrices generated by an interface -!! (e.g., pw2wannier90) to an ab initio package -!! (e.g., quantum-espresso) -!=========================================================== - use w90_constants, only: dp + !================================================ + !! Finds the Wannier matrix elements of various operators, + !! starting from k-space matrices generated by an interface + !! (e.g., pw2wannier90) to an ab initio package + !! (e.g., quantum-espresso) + !================================================ + + use w90_comms, only: comms_bcast, w90comm_type, mpirank + use w90_constants, only: dp, cmplx_0, cmplx_i, twopi + use w90_io, only: io_error, io_stopwatch, io_file_unit implicit none public - private :: fourier_q_to_R, get_win_min + private :: fourier_q_to_R + private :: get_win_min - complex(kind=dp), allocatable, save :: HH_R(:, :, :) ! <0n|r|Rm> - !! $$\langle 0n | H | Rm \rangle$$ - - complex(kind=dp), allocatable, save :: AA_R(:, :, :, :) ! <0n|r|Rm> - !! $$\langle 0n | \hat{r} | Rm \rangle$$ - - complex(kind=dp), allocatable, save :: BB_R(:, :, :, :) ! <0|H(r-R)|R> - !! $$\langle 0n | H(\hat{r}-R) | Rm \rangle$$ - - complex(kind=dp), allocatable, save :: CC_R(:, :, :, :, :) ! <0|r_alpha.H(r-R)_beta|R> - !! $$\langle 0n | \hat{r}_{\alpha}.H.(\hat{r}- R)_{\beta} | Rm \rangle$$ +contains - complex(kind=dp), allocatable, save :: FF_R(:, :, :, :, :) ! <0|r_alpha.(r-R)_beta|R> - !! $$\langle 0n | \hat{r}_{\alpha}.(\hat{r}-R)_{\beta} | Rm \rangle$$ + !================================================! + ! PUBLIC PROCEDURES + !================================================! - complex(kind=dp), allocatable, save :: SS_R(:, :, :, :) ! <0n|sigma_x,y,z|Rm> - !! $$\langle 0n | \sigma_{x,y,z} | Rm \rangle$$ + !================================================ + subroutine get_HH_R(dis_manifold, kpt_latt, print_output, wigner_seitz, HH_R, u_matrix, & + v_matrix, eigval, real_lattice, scissors_shift, num_bands, num_kpts, & + num_wann, num_valence_bands, effective_model, have_disentangled, seedname, & + stdout, comm) + !================================================ + ! + !! computes <0n|H|Rm>, in eV + !! (pwscf uses Ry, but pw2wannier90 converts to eV) + ! + !================================================ - !spin Hall using Qiao's method - complex(kind=dp), allocatable, save :: SR_R(:, :, :, :, :) ! <0n|sigma_x,y,z.(r-R)_alpha|Rm> - !! $$\langle 0n | \sigma_{x,y,z}.(\hat{r}-R)_{\alpha} | Rm \rangle$$ + use w90_postw90_types, only: wigner_seitz_type + use w90_types, only: dis_manifold_type, print_output_type - complex(kind=dp), allocatable, save :: SHR_R(:, :, :, :, :) ! <0n|sigma_x,y,z.H.(r-R)_alpha|Rm> - !! $$\langle 0n | \sigma_{x,y,z}.H.(\hat{r}-R)_{\alpha} | Rm \rangle$$ + implicit none - complex(kind=dp), allocatable, save :: SH_R(:, :, :, :) ! <0n|sigma_x,y,z.H|Rm> - !! $$\langle 0n | \sigma_{x,y,z}.H | Rm \rangle$$ + ! arguments + type(dis_manifold_type), intent(in) :: dis_manifold + type(print_output_type), intent(in) :: print_output + type(w90comm_type), intent(in) :: comm + type(wigner_seitz_type), intent(inout) :: wigner_seitz - !spin Hall using Ryoo's method - complex(kind=dp), allocatable, save :: SAA_R(:, :, :, :, :) ! <0n|sigma_x,y,z.(r-R)_alpha|Rm> - !! $$\langle 0n | \sigma_{x,y,z}.(\hat{r}-R)_{\alpha} | Rm \rangle$$ + integer, intent(in) :: num_bands, num_kpts, num_wann, num_valence_bands, stdout - complex(kind=dp), allocatable, save :: SBB_R(:, :, :, :, :) ! <0n|sigma_x,y,z.H.(r-R)_alpha|Rm> - !! $$\langle 0n | \sigma_{x,y,z}.H.(\hat{r}-R)_{\alpha} | Rm \rangle$$ + real(kind=dp), intent(in) :: eigval(:, :), real_lattice(3, 3) + real(kind=dp), intent(in) :: scissors_shift + real(kind=dp), intent(in) :: kpt_latt(:, :) -contains + complex(kind=dp), intent(in) :: u_matrix(:, :, :), v_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> - !======================================================! - ! PUBLIC PROCEDURES ! - !======================================================! + character(len=50), intent(in) :: seedname - !====================================================== - subroutine get_HH_R - !====================================================== - ! - !! computes <0n|H|Rm>, in eV - !! (pwscf uses Ry, but pw2wannier90 converts to eV) - ! - !====================================================== - - use w90_constants, only: dp, cmplx_0 - use w90_io, only: io_error, stdout, io_stopwatch, & - io_file_unit, seedname - use w90_parameters, only: num_wann, ndimwin, num_kpts, num_bands, & - eigval, u_matrix, have_disentangled, & - timing_level, scissors_shift, & - num_valence_bands, effective_model, & - real_lattice - use w90_postw90_common, only: nrpts, rpt_origin, v_matrix, ndegen, irvec, crvec - use w90_comms, only: on_root, comms_bcast + logical, intent(in) :: have_disentangled + logical, intent(in) :: effective_model + ! local variables integer :: i, j, n, m, ii, ik, winmin_q, file_unit, & ir, io, idum, ivdum(3), ivdum_old(3) integer, allocatable :: num_states(:) @@ -96,17 +87,20 @@ subroutine get_HH_R complex(kind=dp), allocatable :: HH_q(:, :, :) logical :: new_ir - !ivo complex(kind=dp), allocatable :: sciss_q(:, :, :) complex(kind=dp), allocatable :: sciss_R(:, :, :) - real(kind=dp) :: sciss_shift - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_HH_R', 1) + logical :: on_root = .false. + if (mpirank(comm) == 0) on_root = .true. + + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_HH_R', 1, stdout, seedname) if (.not. allocated(HH_R)) then - allocate (HH_R(num_wann, num_wann, nrpts)) + allocate (HH_R(num_wann, num_wann, wigner_seitz%nrpts)) else - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_HH_R', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_HH_R', 2, stdout, seedname) return end if @@ -133,8 +127,7 @@ subroutine get_HH_R if (io < 0) exit ! reached end of file if (i < 1 .or. i > num_wann .or. j < 1 .or. j > num_wann) then write (stdout, *) 'num_wann=', num_wann, ' i=', i, ' j=', j - call io_error & - ('Error in get_HH_R: orbital indices out of bounds') + call io_error('Error in get_HH_R: orbital indices out of bounds', stdout, seedname) endif if (n > 1) then if (ivdum(1) /= ivdum_old(1) .or. ivdum(2) /= ivdum_old(2) .or. & @@ -153,20 +146,20 @@ subroutine get_HH_R ! implemented.) HH_R(j, i, ir) = HH_R(j, i, ir) + cmplx(rdum_real, rdum_imag, kind=dp) if (new_ir) then - irvec(:, ir) = ivdum(:) - if (ivdum(1) == 0 .and. ivdum(2) == 0 .and. ivdum(3) == 0) rpt_origin = ir + wigner_seitz%irvec(:, ir) = ivdum(:) + if (ivdum(1) == 0 .and. ivdum(2) == 0 .and. ivdum(3) == 0) wigner_seitz%rpt_origin = ir endif n = n + 1 enddo close (file_unit) - if (ir /= nrpts) then - write (stdout, *) 'ir=', ir, ' nrpts=', nrpts - call io_error('Error in get_HH_R: inconsistent nrpts values') + if (ir /= wigner_seitz%nrpts) then + write (stdout, *) 'ir=', ir, ' nrpts=', wigner_seitz%nrpts + call io_error('Error in get_HH_R: inconsistent nrpts values', stdout, seedname) endif - do ir = 1, nrpts - crvec(:, ir) = matmul(transpose(real_lattice), irvec(:, ir)) + do ir = 1, wigner_seitz%nrpts + wigner_seitz%crvec(:, ir) = matmul(transpose(real_lattice), wigner_seitz%irvec(:, ir)) end do - ndegen(:) = 1 ! This is assumed when reading HH_R from file + wigner_seitz%ndegen(:) = 1 ! This is assumed when reading HH_R from file ! ! TODO: Implement scissors in this case? Need to choose a ! uniform k-mesh (the scissors correction is applied in @@ -178,13 +171,14 @@ subroutine get_HH_R if (abs(scissors_shift) > 1.0e-7_dp) & call io_error( & 'Error in get_HH_R: scissors shift not implemented for ' & - //'effective_model=T') + //'effective_model=T', stdout, seedname) endif - call comms_bcast(HH_R(1, 1, 1), num_wann*num_wann*nrpts) - call comms_bcast(ndegen(1), nrpts) - call comms_bcast(irvec(1, 1), 3*nrpts) - call comms_bcast(crvec(1, 1), 3*nrpts) - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_HH_R', 2) + call comms_bcast(HH_R(1, 1, 1), num_wann*num_wann*wigner_seitz%nrpts, stdout, seedname, comm) + call comms_bcast(wigner_seitz%ndegen(1), wigner_seitz%nrpts, stdout, seedname, comm) + call comms_bcast(wigner_seitz%irvec(1, 1), 3*wigner_seitz%nrpts, stdout, seedname, comm) + call comms_bcast(wigner_seitz%crvec(1, 1), 3*wigner_seitz%nrpts, stdout, seedname, comm) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_HH_R', 2, stdout, seedname) return endif @@ -199,11 +193,12 @@ subroutine get_HH_R HH_q = cmplx_0 do ik = 1, num_kpts if (have_disentangled) then - num_states(ik) = ndimwin(ik) + num_states(ik) = dis_manifold%ndimwin(ik) else num_states(ik) = num_wann endif - call get_win_min(ik, winmin_q) + + call get_win_min(num_bands, dis_manifold, ik, winmin_q, have_disentangled) do m = 1, num_wann do n = 1, m do i = 1, num_states(ik) @@ -216,13 +211,14 @@ subroutine get_HH_R enddo enddo enddo - call fourier_q_to_R(HH_q, HH_R) + + call fourier_q_to_R(num_kpts, wigner_seitz%nrpts, wigner_seitz%irvec, kpt_latt, HH_q, HH_R) ! Scissors correction for an insulator: shift conduction bands upwards by ! scissors_shift eV ! if (num_valence_bands > 0 .and. abs(scissors_shift) > 1.0e-7_dp) then - allocate (sciss_R(num_wann, num_wann, nrpts)) + allocate (sciss_R(num_wann, num_wann, wigner_seitz%nrpts)) allocate (sciss_q(num_wann, num_wann, num_kpts)) sciss_q = cmplx_0 do ik = 1, num_kpts @@ -236,41 +232,63 @@ subroutine get_HH_R enddo enddo enddo - call fourier_q_to_R(sciss_q, sciss_R) + + call fourier_q_to_R(num_kpts, wigner_seitz%nrpts, wigner_seitz%irvec, kpt_latt, sciss_q, & + sciss_R) do n = 1, num_wann - sciss_R(n, n, rpt_origin) = sciss_R(n, n, rpt_origin) + 1.0_dp + sciss_R(n, n, wigner_seitz%rpt_origin) = sciss_R(n, n, wigner_seitz%rpt_origin) + 1.0_dp end do sciss_R = sciss_R*scissors_shift HH_R = HH_R + sciss_R endif - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_HH_R', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_HH_R', 2, stdout, seedname) return 101 call io_error('Error in get_HH_R: problem opening file '// & - trim(seedname)//'_HH_R.dat') + trim(seedname)//'_HH_R.dat', stdout, seedname) end subroutine get_HH_R - !================================================== - subroutine get_AA_R - !================================================== + !================================================ + subroutine get_AA_R(pw90_berry, dis_manifold, kmesh_info, kpt_latt, print_output, AA_R, HH_R, & + v_matrix, eigval, irvec, nrpts, num_bands, num_kpts, num_wann, & + effective_model, have_disentangled, seedname, stdout, comm) + !================================================ ! !! AA_a(R) = <0|r_a|R> is the Fourier transform !! of the Berrry connection AA_a(k) = i !! (a=x,y,z) ! - !================================================== + !================================================ + + use w90_postw90_types, only: pw90_berry_mod_type, pw90_oper_read_type, pw90_spin_hall_type + use w90_types, only: dis_manifold_type, kmesh_info_type, print_output_type - use w90_constants, only: dp, cmplx_0, cmplx_i - use w90_parameters, only: num_kpts, nntot, num_wann, wb, bk, timing_level, & - num_bands, ndimwin, nnlist, have_disentangled, & - transl_inv, nncell, effective_model - use w90_postw90_common, only: nrpts - use w90_io, only: stdout, io_file_unit, io_error, io_stopwatch, & - seedname - use w90_comms, only: on_root, comms_bcast + implicit none + + ! arguments + type(pw90_berry_mod_type), intent(in) :: pw90_berry + type(dis_manifold_type), intent(in) :: dis_manifold + type(kmesh_info_type), intent(in) :: kmesh_info + type(print_output_type), intent(in) :: print_output + type(w90comm_type), intent(in) :: comm + + integer, intent(in) :: num_bands, num_kpts, num_wann, nrpts, stdout, irvec(:, :) + + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: kpt_latt(:, :) + complex(kind=dp), intent(in) :: v_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: AA_R(:, :, :, :) ! <0n|r|Rm> + + logical, intent(in) :: have_disentangled + logical, intent(in) :: effective_model + character(len=50), intent(in) :: seedname + + ! local variables complex(kind=dp), allocatable :: AA_q(:, :, :, :) complex(kind=dp), allocatable :: AA_q_diag(:, :) complex(kind=dp), allocatable :: S_o(:, :) @@ -285,13 +303,18 @@ subroutine get_AA_R rdum2_real, rdum2_imag, rdum3_real, rdum3_imag logical :: nn_found character(len=60) :: header + logical :: on_root = .false. - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_AA_R', 1) + if (mpirank(comm) == 0) on_root = .true. + + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_AA_R', 1, stdout, seedname) if (.not. allocated(AA_R)) then allocate (AA_R(num_wann, num_wann, nrpts, 3)) else - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_AA_R', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_AA_R', 2, stdout, seedname) return end if @@ -299,7 +322,7 @@ subroutine get_AA_R ! if (effective_model) then if (.not. allocated(HH_R)) call io_error( & - 'Error in get_AA_R: Must read file'//trim(seedname)//'_HH_R.dat first') + 'Error in get_AA_R: Must read file'//trim(seedname)//'_HH_R.dat first', stdout, seedname) AA_R = cmplx_0 if (on_root) then write (stdout, '(/a)') ' Reading position matrix elements from file ' & @@ -318,7 +341,7 @@ subroutine get_AA_R if (io < 0) exit if (i < 1 .or. i > num_wann .or. j < 1 .or. j > num_wann) then write (stdout, *) 'num_wann=', num_wann, ' i=', i, ' j=', j - call io_error('Error in get_AA_R: orbital indices out of bounds') + call io_error('Error in get_AA_R: orbital indices out of bounds', stdout, seedname) endif if (n > 1) then if (ivdum(1) /= ivdum_old(1) .or. ivdum(2) /= ivdum_old(2) .or. & @@ -336,11 +359,12 @@ subroutine get_AA_R ! elements is used, but it cannot be larger if (ir > nrpts) then write (stdout, *) 'ir=', ir, ' nrpts=', nrpts - call io_error('Error in get_AA_R: inconsistent nrpts values') + call io_error('Error in get_AA_R: inconsistent nrpts values', stdout, seedname) endif endif - call comms_bcast(AA_R(1, 1, 1, 1), num_wann*num_wann*nrpts*3) - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_AA_R', 2) + call comms_bcast(AA_R(1, 1, 1, 1), num_wann*num_wann*nrpts*3, stdout, seedname, comm) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_AA_R', 2, stdout, seedname) return endif @@ -360,7 +384,7 @@ subroutine get_AA_R allocate (num_states(num_kpts)) do ik = 1, num_kpts if (have_disentangled) then - num_states(ik) = ndimwin(ik) + num_states(ik) = dis_manifold%ndimwin(ik) else num_states(ik) = num_wann endif @@ -378,18 +402,18 @@ subroutine get_AA_R read (mmn_in, *, err=102, end=102) nb_tmp, nkp_tmp, nntot_tmp ! Checks if (nb_tmp .ne. num_bands) & - call io_error(trim(seedname)//'.mmn has wrong number of bands') + call io_error(trim(seedname)//'.mmn has wrong number of bands', stdout, seedname) if (nkp_tmp .ne. num_kpts) & - call io_error(trim(seedname)//'.mmn has wrong number of k-points') - if (nntot_tmp .ne. nntot) & + call io_error(trim(seedname)//'.mmn has wrong number of k-points', stdout, seedname) + if (nntot_tmp .ne. kmesh_info%nntot) & call io_error & - (trim(seedname)//'.mmn has wrong number of nearest neighbours') + (trim(seedname)//'.mmn has wrong number of nearest neighbours', stdout, seedname) AA_q = cmplx_0 ik_prev = 0 ! Composite loop over k-points ik (outer loop) and neighbors ik2 (inner) - do ncount = 1, num_kpts*nntot + do ncount = 1, num_kpts*kmesh_info%nntot ! !Read from .mmn file the original overlap matrix ! S_o= between ab initio eigenstates @@ -411,17 +435,17 @@ subroutine get_AA_R if (ik .ne. ik_prev) nn_count = 0 nn = 0 nn_found = .false. - do inn = 1, nntot - if ((ik2 .eq. nnlist(ik, inn)) .and. & - (nnl .eq. nncell(1, ik, inn)) .and. & - (nnm .eq. nncell(2, ik, inn)) .and. & - (nnn .eq. nncell(3, ik, inn))) then + do inn = 1, kmesh_info%nntot + if ((ik2 .eq. kmesh_info%nnlist(ik, inn)) .and. & + (nnl .eq. kmesh_info%nncell(1, ik, inn)) .and. & + (nnm .eq. kmesh_info%nncell(2, ik, inn)) .and. & + (nnn .eq. kmesh_info%nncell(3, ik, inn))) then if (.not. nn_found) then nn_found = .true. nn = inn else call io_error('Error reading '//trim(seedname)//'.mmn.& - & More than one matching nearest neighbour found') + & More than one matching nearest neighbour found', stdout, seedname) endif endif end do @@ -429,38 +453,39 @@ subroutine get_AA_R write (stdout, '(/a,i8,2i5,i4,2x,3i3)') & ' Error reading '//trim(seedname)//'.mmn:', & ncount, ik, ik2, nn, nnl, nnm, nnn - call io_error('Neighbour not found') + call io_error('Neighbour not found', stdout, seedname) end if nn_count = nn_count + 1 !Check: can also be place after nn=inn (?) ! Wannier-gauge overlap matrix S in the projected subspace ! - call get_gauge_overlap_matrix( & - ik, num_states(ik), & - nnlist(ik, nn), num_states(nnlist(ik, nn)), & - S_o, S) + call get_gauge_overlap_matrix(num_bands, num_wann, eigval, v_matrix, dis_manifold, & + ik, num_states(ik), kmesh_info%nnlist(ik, nn), & + num_states(kmesh_info%nnlist(ik, nn)), S_o, & + have_disentangled, S) ! Berry connection matrix ! Assuming all neighbors of a given point are read in sequence! ! - if (transl_inv .and. ik .ne. ik_prev) AA_q_diag(:, :) = cmplx_0 + if (pw90_berry%transl_inv .and. ik .ne. ik_prev) AA_q_diag(:, :) = cmplx_0 do idir = 1, 3 AA_q(:, :, ik, idir) = AA_q(:, :, ik, idir) & - + cmplx_i*wb(nn)*bk(idir, nn, ik)*S(:, :) - if (transl_inv) then + + cmplx_i*kmesh_info%wb(nn)*kmesh_info%bk(idir, nn, ik)*S(:, :) + if (pw90_berry%transl_inv) then ! ! Rewrite band-diagonal elements a la Eq.(31) of MV97 ! do i = 1, num_wann AA_q_diag(i, idir) = AA_q_diag(i, idir) & - - wb(nn)*bk(idir, nn, ik)*aimag(log(S(i, i))) + - kmesh_info%wb(nn)*kmesh_info%bk(idir, nn, ik) & + *aimag(log(S(i, i))) enddo endif end do ! Assuming all neighbors of a given point are read in sequence! - if (nn_count == nntot) then !looped over all neighbors + if (nn_count == kmesh_info%nntot) then !looped over all neighbors do idir = 1, 3 - if (transl_inv) then + if (pw90_berry%transl_inv) then do n = 1, num_wann AA_q(n, n, ik, idir) = AA_q_diag(n, idir) enddo @@ -482,51 +507,63 @@ subroutine get_AA_R enddo !ncount close (mmn_in) - !do ik=1,num_kpts - ! write(*,*) ik, real(AA_q(1,:,ik,3),dp) - !enddo - call fourier_q_to_R(AA_q(:, :, :, 1), AA_R(:, :, :, 1)) - call fourier_q_to_R(AA_q(:, :, :, 2), AA_R(:, :, :, 2)) - call fourier_q_to_R(AA_q(:, :, :, 3), AA_R(:, :, :, 3)) - !do ir=1,nrpts - ! write(*,*) ir, real(AA_R(1,:,ir,1),dp) - !enddo + + call fourier_q_to_R(num_kpts, nrpts, irvec, kpt_latt, AA_q(:, :, :, 1), AA_R(:, :, :, 1)) + call fourier_q_to_R(num_kpts, nrpts, irvec, kpt_latt, AA_q(:, :, :, 2), AA_R(:, :, :, 2)) + call fourier_q_to_R(num_kpts, nrpts, irvec, kpt_latt, AA_q(:, :, :, 3), AA_R(:, :, :, 3)) endif !on_root - call comms_bcast(AA_R(1, 1, 1, 1), num_wann*num_wann*nrpts*3) + call comms_bcast(AA_R(1, 1, 1, 1), num_wann*num_wann*nrpts*3, stdout, seedname, comm) - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_AA_R', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_AA_R', 2, stdout, seedname) return 101 call io_error & - ('Error: Problem opening input file '//trim(seedname)//'.mmn') + ('Error: Problem opening input file '//trim(seedname)//'.mmn', stdout, seedname) 102 call io_error & - ('Error: Problem reading input file '//trim(seedname)//'.mmn') + ('Error: Problem reading input file '//trim(seedname)//'.mmn', stdout, seedname) 103 call io_error('Error in get_AA_R: problem opening file '// & - trim(seedname)//'_AA_R.dat') + trim(seedname)//'_AA_R.dat', stdout, seedname) end subroutine get_AA_R - !===================================================== - subroutine get_BB_R - !===================================================== + !================================================ + subroutine get_BB_R(dis_manifold, kmesh_info, kpt_latt, print_output, BB_R, v_matrix, eigval, & + scissors_shift, irvec, nrpts, num_bands, num_kpts, num_wann, & + have_disentangled, seedname, stdout, comm) + !================================================ ! !! BB_a(R)=<0n|H(r-R)|Rm> is the Fourier transform of !! BB_a(k) = i (a=x,y,z) ! - !===================================================== - - use w90_constants, only: dp, cmplx_0, cmplx_i - use w90_parameters, only: num_kpts, nntot, nnlist, num_wann, num_bands, & - ndimwin, eigval, wb, bk, have_disentangled, & - timing_level, nncell, scissors_shift - use w90_postw90_common, only: nrpts, v_matrix - use w90_io, only: stdout, io_file_unit, io_error, io_stopwatch, & - seedname - use w90_comms, only: on_root, comms_bcast - - integer :: idir, n, m, nn, i, ii, j, jj, & + !================================================ + + use w90_types, only: dis_manifold_type, kmesh_info_type, print_output_type + + implicit none + + ! arguments + type(dis_manifold_type), intent(in) :: dis_manifold + type(kmesh_info_type), intent(in) :: kmesh_info + type(print_output_type), intent(in) :: print_output + type(w90comm_type), intent(in) :: comm + + integer, intent(in) :: num_bands, num_kpts, num_wann, nrpts, stdout, irvec(:, :) + + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: scissors_shift + real(kind=dp), intent(in) :: kpt_latt(:, :) + + complex(kind=dp), intent(in) :: v_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: BB_R(:, :, :, :) ! <0|H(r-R)|R> + + logical, intent(in) :: have_disentangled + character(len=50), intent(in) :: seedname + + ! local variables + integer :: idir, n, m, nn, & ik, ik2, inn, nnl, nnm, nnn, & winmin_q, winmin_qb, ncount, & nb_tmp, nkp_tmp, nntot_tmp, mmn_in @@ -539,18 +576,24 @@ subroutine get_BB_R logical :: nn_found character(len=60) :: header - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_BB_R', 1) + logical :: on_root = .false. + + if (mpirank(comm) == 0) on_root = .true. + + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_BB_R', 1, stdout, seedname) if (.not. allocated(BB_R)) then allocate (BB_R(num_wann, num_wann, nrpts, 3)) else - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_BB_R', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_BB_R', 2, stdout, seedname) return end if if (on_root) then if (abs(scissors_shift) > 1.0e-7_dp) & - call io_error('Error: scissors correction not yet implemented for BB_R') + call io_error('Error: scissors correction not yet implemented for BB_R', stdout, seedname) allocate (BB_q(num_wann, num_wann, num_kpts, 3)) allocate (S_o(num_bands, num_bands)) @@ -559,7 +602,7 @@ subroutine get_BB_R allocate (num_states(num_kpts)) do ik = 1, num_kpts if (have_disentangled) then - num_states(ik) = ndimwin(ik) + num_states(ik) = dis_manifold%ndimwin(ik) else num_states(ik) = num_wann endif @@ -577,16 +620,16 @@ subroutine get_BB_R read (mmn_in, *, err=104, end=104) nb_tmp, nkp_tmp, nntot_tmp ! Checks if (nb_tmp .ne. num_bands) & - call io_error(trim(seedname)//'.mmn has wrong number of bands') + call io_error(trim(seedname)//'.mmn has wrong number of bands', stdout, seedname) if (nkp_tmp .ne. num_kpts) & - call io_error(trim(seedname)//'.mmn has wrong number of k-points') - if (nntot_tmp .ne. nntot) & + call io_error(trim(seedname)//'.mmn has wrong number of k-points', stdout, seedname) + if (nntot_tmp .ne. kmesh_info%nntot) & call io_error & - (trim(seedname)//'.mmn has wrong number of nearest neighbours') + (trim(seedname)//'.mmn has wrong number of nearest neighbours', stdout, seedname) BB_q = cmplx_0 - do ncount = 1, num_kpts*nntot + do ncount = 1, num_kpts*kmesh_info%nntot ! !Read from .mmn file the original overlap matrix ! S_o= between ab initio eigenstates @@ -600,17 +643,17 @@ subroutine get_BB_R enddo nn = 0 nn_found = .false. - do inn = 1, nntot - if ((ik2 .eq. nnlist(ik, inn)) .and. & - (nnl .eq. nncell(1, ik, inn)) .and. & - (nnm .eq. nncell(2, ik, inn)) .and. & - (nnn .eq. nncell(3, ik, inn))) then + do inn = 1, kmesh_info%nntot + if ((ik2 .eq. kmesh_info%nnlist(ik, inn)) .and. & + (nnl .eq. kmesh_info%nncell(1, ik, inn)) .and. & + (nnm .eq. kmesh_info%nncell(2, ik, inn)) .and. & + (nnn .eq. kmesh_info%nncell(3, ik, inn))) then if (.not. nn_found) then nn_found = .true. nn = inn else call io_error('Error reading '//trim(seedname)//'.mmn.& - & More than one matching nearest neighbour found') + & More than one matching nearest neighbour found', stdout, seedname) endif endif end do @@ -618,61 +661,80 @@ subroutine get_BB_R write (stdout, '(/a,i8,2i5,i4,2x,3i3)') & ' Error reading '//trim(seedname)//'.mmn:', & ncount, ik, ik2, nn, nnl, nnm, nnn - call io_error('Neighbour not found') + call io_error('Neighbour not found', stdout, seedname) end if - call get_win_min(ik, winmin_q) - call get_win_min(nnlist(ik, nn), winmin_qb) - call get_gauge_overlap_matrix( & - ik, num_states(ik), & - nnlist(ik, nn), num_states(nnlist(ik, nn)), & - S_o, H=H_q_qb) + call get_win_min(num_bands, dis_manifold, ik, winmin_q, have_disentangled) + call get_win_min(num_bands, dis_manifold, kmesh_info%nnlist(ik, nn), winmin_qb, & + have_disentangled) + + call get_gauge_overlap_matrix(num_bands, num_wann, eigval, v_matrix, dis_manifold, & + ik, num_states(ik), kmesh_info%nnlist(ik, nn), & + num_states(kmesh_info%nnlist(ik, nn)), S_o, & + have_disentangled, H=H_q_qb) do idir = 1, 3 BB_q(:, :, ik, idir) = BB_q(:, :, ik, idir) & - + cmplx_i*wb(nn)*bk(idir, nn, ik)*H_q_qb(:, :) + + cmplx_i*kmesh_info%wb(nn)*kmesh_info%bk(idir, nn, ik) & + *H_q_qb(:, :) enddo enddo !ncount close (mmn_in) - call fourier_q_to_R(BB_q(:, :, :, 1), BB_R(:, :, :, 1)) - call fourier_q_to_R(BB_q(:, :, :, 2), BB_R(:, :, :, 2)) - call fourier_q_to_R(BB_q(:, :, :, 3), BB_R(:, :, :, 3)) + call fourier_q_to_R(num_kpts, nrpts, irvec, kpt_latt, BB_q(:, :, :, 1), BB_R(:, :, :, 1)) + call fourier_q_to_R(num_kpts, nrpts, irvec, kpt_latt, BB_q(:, :, :, 2), BB_R(:, :, :, 2)) + call fourier_q_to_R(num_kpts, nrpts, irvec, kpt_latt, BB_q(:, :, :, 3), BB_R(:, :, :, 3)) endif !on_root - call comms_bcast(BB_R(1, 1, 1, 1), num_wann*num_wann*nrpts*3) + call comms_bcast(BB_R(1, 1, 1, 1), num_wann*num_wann*nrpts*3, stdout, seedname, comm) - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_BB_R', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_BB_R', 2, stdout, seedname) return -103 call io_error & - ('Error: Problem opening input file '//trim(seedname)//'.mmn') -104 call io_error & - ('Error: Problem reading input file '//trim(seedname)//'.mmn') +103 call io_error('Error: Problem opening input file '//trim(seedname)//'.mmn', stdout, seedname) +104 call io_error('Error: Problem reading input file '//trim(seedname)//'.mmn', stdout, seedname) end subroutine get_BB_R - !============================================================= - subroutine get_CC_R - !============================================================= + !================================================ + subroutine get_CC_R(dis_manifold, kmesh_info, kpt_latt, print_output, pw90_oper_read, CC_R, & + v_matrix, eigval, scissors_shift, irvec, nrpts, num_bands, num_kpts, & + num_wann, have_disentangled, seedname, stdout, comm) + !================================================ ! !! CC_ab(R) = <0|r_a.H.(r-R)_b|R> is the Fourier transform of !! CC_ab(k) = (a,b=x,y,z) ! - !============================================================= - - use w90_constants, only: dp, cmplx_0 - use w90_parameters, only: num_kpts, nntot, nnlist, num_wann, & - num_bands, ndimwin, wb, bk, & - have_disentangled, timing_level, & - scissors_shift, uHu_formatted - use w90_postw90_common, only: nrpts, v_matrix - use w90_io, only: stdout, io_error, io_stopwatch, io_file_unit, & - seedname - use w90_comms, only: on_root, comms_bcast - - integer :: i, j, ii, jj, m, n, a, b, nn1, nn2, ik, nb_tmp, nkp_tmp, & + !================================================ + + use w90_postw90_types, only: pw90_oper_read_type + use w90_types, only: dis_manifold_type, kmesh_info_type, print_output_type + + implicit none + + ! arguments + type(dis_manifold_type), intent(in) :: dis_manifold + type(kmesh_info_type), intent(in) :: kmesh_info + type(pw90_oper_read_type), intent(in) :: pw90_oper_read + type(print_output_type), intent(in) :: print_output + type(w90comm_type), intent(in) :: comm + + integer, intent(in) :: num_bands, num_kpts, num_wann, nrpts, stdout, irvec(:, :) + + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: scissors_shift + real(kind=dp), intent(in) :: kpt_latt(:, :) + + complex(kind=dp), intent(in) :: v_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: CC_R(:, :, :, :, :) ! <0|r_alpha.H(r-R)_beta|R> + + logical, intent(in) :: have_disentangled + character(len=50), intent(in) :: seedname + + ! local variables + integer :: m, n, a, b, nn1, nn2, ik, nb_tmp, nkp_tmp, & nntot_tmp, uHu_in, qb1, qb2, winmin_qb1, winmin_qb2 integer, allocatable :: num_states(:) @@ -681,20 +743,25 @@ subroutine get_CC_R complex(kind=dp), allocatable :: H_qb1_q_qb2(:, :) real(kind=dp) :: c_real, c_img character(len=60) :: header + logical :: on_root = .false. + + if (mpirank(comm) == 0) on_root = .true. - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_CC_R', 1) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_CC_R', 1, stdout, seedname) if (.not. allocated(CC_R)) then allocate (CC_R(num_wann, num_wann, nrpts, 3, 3)) else - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_CC_R', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_CC_R', 2, stdout, seedname) return end if if (on_root) then if (abs(scissors_shift) > 1.0e-7_dp) & - call io_error('Error: scissors correction not yet implemented for CC_R') + call io_error('Error: scissors correction not yet implemented for CC_R', stdout, seedname) allocate (Ho_qb1_q_qb2(num_bands, num_bands)) allocate (H_qb1_q_qb2(num_wann, num_wann)) @@ -703,14 +770,14 @@ subroutine get_CC_R allocate (num_states(num_kpts)) do ik = 1, num_kpts if (have_disentangled) then - num_states(ik) = ndimwin(ik) + num_states(ik) = dis_manifold%ndimwin(ik) else num_states(ik) = num_wann endif enddo uHu_in = io_file_unit() - if (uHu_formatted) then + if (pw90_oper_read%uHu_formatted) then open (unit=uHu_in, file=trim(seedname)//".uHu", form='formatted', & status='old', action='read', err=105) write (stdout, '(/a)', advance='no') & @@ -729,27 +796,28 @@ subroutine get_CC_R endif if (nb_tmp .ne. num_bands) & call io_error & - (trim(seedname)//'.uHu has not the right number of bands') + (trim(seedname)//'.uHu has not the right number of bands', stdout, seedname) if (nkp_tmp .ne. num_kpts) & call io_error & - (trim(seedname)//'.uHu has not the right number of k-points') - if (nntot_tmp .ne. nntot) & + (trim(seedname)//'.uHu has not the right number of k-points', stdout, seedname) + if (nntot_tmp .ne. kmesh_info%nntot) & call io_error & - (trim(seedname)//'.uHu has not the right number of nearest neighbours') + (trim(seedname)//'.uHu has not the right number of nearest neighbours', stdout, seedname) CC_q = cmplx_0 do ik = 1, num_kpts - do nn2 = 1, nntot - qb2 = nnlist(ik, nn2) - call get_win_min(qb2, winmin_qb2) - do nn1 = 1, nntot - qb1 = nnlist(ik, nn1) - call get_win_min(qb1, winmin_qb1) + do nn2 = 1, kmesh_info%nntot + qb2 = kmesh_info%nnlist(ik, nn2) + + call get_win_min(num_bands, dis_manifold, qb2, winmin_qb2, have_disentangled) + do nn1 = 1, kmesh_info%nntot + qb1 = kmesh_info%nnlist(ik, nn1) + call get_win_min(num_bands, dis_manifold, qb1, winmin_qb1, have_disentangled) ! ! Read from .uHu file the matrices ! between the original ab initio eigenstates ! - if (uHu_formatted) then + if (pw90_oper_read%uHu_formatted) then do m = 1, num_bands do n = 1, num_bands read (uHu_in, *, err=106, end=106) c_real, c_img @@ -771,14 +839,15 @@ subroutine get_CC_R ! ! Transform to projected subspace, Wannier gauge ! - call get_gauge_overlap_matrix( & - qb1, num_states(qb1), & - qb2, num_states(qb2), & - Ho_qb1_q_qb2, H_qb1_q_qb2) + + call get_gauge_overlap_matrix(num_bands, num_wann, eigval, v_matrix, dis_manifold, & + qb1, num_states(qb1), qb2, num_states(qb2), & + Ho_qb1_q_qb2, have_disentangled, H_qb1_q_qb2) do b = 1, 3 do a = 1, b - CC_q(:, :, ik, a, b) = CC_q(:, :, ik, a, b) + wb(nn1)*bk(a, nn1, ik) & - *wb(nn2)*bk(b, nn2, ik)*H_qb1_q_qb2(:, :) + CC_q(:, :, ik, a, b) = CC_q(:, :, ik, a, b) & + + kmesh_info%wb(nn1)*kmesh_info%bk(a, nn1, ik) & + *kmesh_info%wb(nn2)*kmesh_info%bk(b, nn2, ik)*H_qb1_q_qb2(:, :) enddo enddo enddo !nn1 @@ -794,42 +863,57 @@ subroutine get_CC_R do b = 1, 3 do a = 1, 3 - call fourier_q_to_R(CC_q(:, :, :, a, b), CC_R(:, :, :, a, b)) + call fourier_q_to_R(num_kpts, nrpts, irvec, kpt_latt, CC_q(:, :, :, a, b), CC_R(:, :, :, a, b)) enddo enddo endif !on_root - call comms_bcast(CC_R(1, 1, 1, 1, 1), num_wann*num_wann*nrpts*3*3) + call comms_bcast(CC_R(1, 1, 1, 1, 1), num_wann*num_wann*nrpts*3*3, stdout, seedname, comm) - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_CC_R', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_CC_R', 2, stdout, seedname) return 105 call io_error & - ('Error: Problem opening input file '//trim(seedname)//'.uHu') + ('Error: Problem opening input file '//trim(seedname)//'.uHu', stdout, seedname) 106 call io_error & - ('Error: Problem reading input file '//trim(seedname)//'.uHu') + ('Error: Problem reading input file '//trim(seedname)//'.uHu', stdout, seedname) end subroutine get_CC_R - !=========================================================== - subroutine get_FF_R - !=========================================================== + !================================================ + subroutine get_FF_R(num_bands, num_kpts, num_wann, nrpts, irvec, v_matrix, FF_R, dis_manifold, & + kmesh_info, kpt_latt, print_output, have_disentangled, stdout, seedname, comm) + !================================================ ! !! FF_ab(R) = <0|r_a.(r-R)_b|R> is the Fourier transform of !! FF_ab(k) = (a=alpha,b=beta) ! - !=========================================================== + !================================================ + + use w90_types, only: dis_manifold_type, kmesh_info_type, print_output_type + + implicit none + + ! arguments + type(dis_manifold_type), intent(in) :: dis_manifold + type(kmesh_info_type), intent(in) :: kmesh_info + type(print_output_type), intent(in) :: print_output + type(w90comm_type), intent(in) :: comm + + integer, intent(in) :: num_bands, num_kpts, num_wann, nrpts, stdout, irvec(:, :) + + real(kind=dp), intent(in) :: kpt_latt(:, :) + + complex(kind=dp), intent(in) :: v_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: FF_R(:, :, :, :, :) ! <0|r_alpha.(r-R)_beta|R> + + character(len=50), intent(in) :: seedname - use w90_constants, only: dp, cmplx_0 - use w90_parameters, only: num_kpts, nntot, nnlist, num_wann, & - num_bands, ndimwin, wb, bk, & - have_disentangled, timing_level - use w90_postw90_common, only: nrpts, v_matrix - use w90_io, only: stdout, io_error, io_stopwatch, io_file_unit, & - seedname - use w90_comms, only: on_root, comms_bcast + logical, intent(in) :: have_disentangled + ! local variables integer :: i, j, ii, jj, m, n, a, b, nn1, nn2, ik, nb_tmp, nkp_tmp, nntot_tmp, & uIu_in, qb1, qb2, winmin_qb1, winmin_qb2 @@ -838,13 +922,18 @@ subroutine get_FF_R complex(kind=dp), allocatable :: Lo_qb1_q_qb2(:, :) complex(kind=dp), allocatable :: L_qb1_q_qb2(:, :) character(len=60) :: header + logical :: on_root = .false. - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_FF_R', 1) + if (mpirank(comm) == 0) on_root = .true. + + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_FF_R', 1, stdout, seedname) if (.not. allocated(FF_R)) then allocate (FF_R(num_wann, num_wann, nrpts, 3, 3)) else - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_FF_R', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_FF_R', 2, stdout, seedname) return end if @@ -857,7 +946,7 @@ subroutine get_FF_R allocate (num_states(num_kpts)) do ik = 1, num_kpts if (have_disentangled) then - num_states(ik) = ndimwin(ik) + num_states(ik) = dis_manifold%ndimwin(ik) else num_states(ik) = num_wann endif @@ -873,22 +962,23 @@ subroutine get_FF_R read (uIu_in, err=108, end=108) nb_tmp, nkp_tmp, nntot_tmp if (nb_tmp .ne. num_bands) & call io_error & - (trim(seedname)//'.uIu has not the right number of bands') + (trim(seedname)//'.uIu has not the right number of bands', stdout, seedname) if (nkp_tmp .ne. num_kpts) & call io_error & - (trim(seedname)//'.uIu has not the right number of k-points') - if (nntot_tmp .ne. nntot) & + (trim(seedname)//'.uIu has not the right number of k-points', stdout, seedname) + if (nntot_tmp .ne. kmesh_info%nntot) & call io_error & - (trim(seedname)//'.uIu has not the right number of nearest neighbours') + (trim(seedname)//'.uIu has not the right number of nearest neighbours', stdout, seedname) FF_q = cmplx_0 do ik = 1, num_kpts - do nn2 = 1, nntot - qb2 = nnlist(ik, nn2) - call get_win_min(qb2, winmin_qb2) - do nn1 = 1, nntot - qb1 = nnlist(ik, nn1) - call get_win_min(qb1, winmin_qb1) + do nn2 = 1, kmesh_info%nntot + qb2 = kmesh_info%nnlist(ik, nn2) + + call get_win_min(num_bands, dis_manifold, qb2, winmin_qb2, have_disentangled) + do nn1 = 1, kmesh_info%nntot + qb1 = kmesh_info%nnlist(ik, nn1) + call get_win_min(num_bands, dis_manifold, qb1, winmin_qb1, have_disentangled) ! ! Read from .uIu file the matrices ! between the original ab initio eigenstates @@ -925,8 +1015,9 @@ subroutine get_FF_R enddo do b = 1, 3 do a = 1, b - FF_q(:, :, ik, a, b) = FF_q(:, :, ik, a, b) + wb(nn1)*bk(a, nn1, ik) & - *wb(nn2)*bk(b, nn2, ik)*L_qb1_q_qb2(:, :) + FF_q(:, :, ik, a, b) = FF_q(:, :, ik, a, b) & + + kmesh_info%wb(nn1)*kmesh_info%bk(a, nn1, ik) & + *kmesh_info%wb(nn2)*kmesh_info%bk(b, nn2, ik)*L_qb1_q_qb2(:, :) enddo enddo enddo !nn1 @@ -942,51 +1033,71 @@ subroutine get_FF_R do b = 1, 3 do a = 1, 3 - call fourier_q_to_R(FF_q(:, :, :, a, b), FF_R(:, :, :, a, b)) + call fourier_q_to_R(num_kpts, nrpts, irvec, kpt_latt, FF_q(:, :, :, a, b), FF_R(:, :, :, a, b)) enddo enddo endif !on_root - call comms_bcast(FF_R(1, 1, 1, 1, 1), num_wann*num_wann*nrpts*3*3) + call comms_bcast(FF_R(1, 1, 1, 1, 1), num_wann*num_wann*nrpts*3*3, stdout, seedname, comm) - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_FF_R', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_FF_R', 2, stdout, seedname) return 107 call io_error & - ('Error: Problem opening input file '//trim(seedname)//'.uIu') + ('Error: Problem opening input file '//trim(seedname)//'.uIu', stdout, seedname) 108 call io_error & - ('Error: Problem reading input file '//trim(seedname)//'.uIu') + ('Error: Problem reading input file '//trim(seedname)//'.uIu', stdout, seedname) end subroutine get_FF_R - !================================================================ - subroutine get_SS_R - !================================================================ + !================================================ + subroutine get_SS_R(dis_manifold, kpt_latt, print_output, pw90_oper_read, SS_R, v_matrix, & + eigval, irvec, nrpts, num_bands, num_kpts, num_wann, have_disentangled, & + seedname, stdout, comm) + !================================================ ! !! Wannier representation of the Pauli matrices: <0n|sigma_a|Rm> !! (a=x,y,z) ! - !================================================================ + !================================================ - use w90_constants, only: dp, pi, cmplx_0 - use w90_parameters, only: num_wann, ndimwin, num_kpts, num_bands, & - timing_level, have_disentangled, spn_formatted - use w90_postw90_common, only: nrpts, v_matrix - use w90_io, only: io_error, io_stopwatch, stdout, seedname, & - io_file_unit - use w90_comms, only: on_root, comms_bcast + use w90_postw90_types, only: pw90_oper_read_type + use w90_types, only: dis_manifold_type, print_output_type implicit none + ! arguments + type(dis_manifold_type), intent(in) :: dis_manifold + type(pw90_oper_read_type), intent(in) :: pw90_oper_read + type(print_output_type), intent(in) :: print_output + type(w90comm_type), intent(in) :: comm + + integer, intent(in) :: stdout, nrpts, num_bands, num_kpts, num_wann, irvec(:, :) + + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: kpt_latt(:, :) + + complex(kind=dp), intent(in) :: v_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) ! <0n|sigma_x,y,z|Rm> + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + + ! local variables complex(kind=dp), allocatable :: spn_o(:, :, :, :), SS_q(:, :, :, :), spn_temp(:, :) real(kind=dp) :: s_real, s_img integer, allocatable :: num_states(:) - integer :: i, j, ii, jj, m, n, spn_in, ik, is, & - winmin, nb_tmp, nkp_tmp, ierr, s, counter + integer :: m, n, spn_in, ik, is, & + nb_tmp, nkp_tmp, ierr, s, counter character(len=60) :: header + logical :: on_root = .false. + + if (mpirank(comm) == 0) on_root = .true. - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_SS_R', 1) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_SS_R', 1, stdout, seedname) if (.not. allocated(SS_R)) then allocate (SS_R(num_wann, num_wann, nrpts, 3)) @@ -1002,7 +1113,7 @@ subroutine get_SS_R allocate (num_states(num_kpts)) do ik = 1, num_kpts if (have_disentangled) then - num_states(ik) = ndimwin(ik) + num_states(ik) = dis_manifold%ndimwin(ik) else num_states(ik) = num_wann endif @@ -1012,7 +1123,7 @@ subroutine get_SS_R ! (sigma_i = Pauli matrix) between ab initio eigenstates ! spn_in = io_file_unit() - if (spn_formatted) then + if (pw90_oper_read%spn_formatted) then open (unit=spn_in, file=trim(seedname)//'.spn', form='formatted', & status='old', err=109) write (stdout, '(/a)', advance='no') & @@ -1030,10 +1141,10 @@ subroutine get_SS_R read (spn_in, err=110, end=110) nb_tmp, nkp_tmp endif if (nb_tmp .ne. num_bands) & - call io_error(trim(seedname)//'.spn has wrong number of bands') + call io_error(trim(seedname)//'.spn has wrong number of bands', stdout, seedname) if (nkp_tmp .ne. num_kpts) & - call io_error(trim(seedname)//'.spn has wrong number of k-points') - if (spn_formatted) then + call io_error(trim(seedname)//'.spn has wrong number of k-points', stdout, seedname) + if (pw90_oper_read%spn_formatted) then do ik = 1, num_kpts do m = 1, num_bands do n = 1, m @@ -1052,7 +1163,7 @@ subroutine get_SS_R enddo else allocate (spn_temp(3, (num_bands*(num_bands + 1))/2), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating spm_temp in get_SS_R') + if (ierr /= 0) call io_error('Error in allocating spm_temp in get_SS_R', stdout, seedname) do ik = 1, num_kpts read (spn_in) ((spn_temp(s, m), s=1, 3), m=1, (num_bands*(num_bands + 1))/2) counter = 0 @@ -1069,7 +1180,7 @@ subroutine get_SS_R end do end do deallocate (spn_temp, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating spm_temp in get_SS_R') + if (ierr /= 0) call io_error('Error in deallocating spm_temp in get_SS_R', stdout, seedname) endif close (spn_in) @@ -1079,53 +1190,74 @@ subroutine get_SS_R SS_q(:, :, :, :) = cmplx_0 do ik = 1, num_kpts do is = 1, 3 - call get_gauge_overlap_matrix( & - ik, num_states(ik), & - ik, num_states(ik), & - spn_o(:, :, ik, is), SS_q(:, :, ik, is)) + + call get_gauge_overlap_matrix(num_bands, num_wann, eigval, v_matrix, dis_manifold, & + ik, num_states(ik), ik, num_states(ik), & + spn_o(:, :, ik, is), have_disentangled, SS_q(:, :, ik, is)) enddo !is enddo !ik - call fourier_q_to_R(SS_q(:, :, :, 1), SS_R(:, :, :, 1)) - call fourier_q_to_R(SS_q(:, :, :, 2), SS_R(:, :, :, 2)) - call fourier_q_to_R(SS_q(:, :, :, 3), SS_R(:, :, :, 3)) + call fourier_q_to_R(num_kpts, nrpts, irvec, kpt_latt, SS_q(:, :, :, 1), SS_R(:, :, :, 1)) + call fourier_q_to_R(num_kpts, nrpts, irvec, kpt_latt, SS_q(:, :, :, 2), SS_R(:, :, :, 2)) + call fourier_q_to_R(num_kpts, nrpts, irvec, kpt_latt, SS_q(:, :, :, 3), SS_R(:, :, :, 3)) endif !on_root - call comms_bcast(SS_R(1, 1, 1, 1), num_wann*num_wann*nrpts*3) + call comms_bcast(SS_R(1, 1, 1, 1), num_wann*num_wann*nrpts*3, stdout, seedname, comm) - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_SS_R', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) call io_stopwatch('get_oper: get_SS_R', 2, stdout, seedname) return 109 call io_error & - ('Error: Problem opening input file '//trim(seedname)//'.spn') + ('Error: Problem opening input file '//trim(seedname)//'.spn', stdout, seedname) 110 call io_error & - ('Error: Problem reading input file '//trim(seedname)//'.spn') + ('Error: Problem reading input file '//trim(seedname)//'.spn', stdout, seedname) end subroutine get_SS_R - !================================================== - subroutine get_SHC_R - !================================================== + !================================================ + subroutine get_SHC_R(dis_manifold, kmesh_info, kpt_latt, print_output, pw90_oper_read, & + pw90_spin_hall, SH_R, SHR_R, SR_R, v_matrix, eigval, scissors_shift, irvec, & + nrpts, num_bands, num_kpts, num_wann, num_valence_bands, have_disentangled, & + seedname, stdout, comm) + !================================================ ! !! Compute several matrices for spin Hall conductivity !! SR_R = <0n|sigma_{x,y,z}.(r-R)_alpha|Rm> !! SHR_R = <0n|sigma_{x,y,z}.H.(r-R)_alpha|Rm> !! SH_R = <0n|sigma_{x,y,z}.H|Rm> ! - !================================================== - - use w90_constants, only: dp, cmplx_0, cmplx_i - use w90_parameters, only: num_kpts, nntot, num_wann, wb, bk, timing_level, & - num_bands, ndimwin, nnlist, have_disentangled, & - transl_inv, nncell, spn_formatted, eigval, & - scissors_shift, num_valence_bands, & - shc_bandshift, shc_bandshift_firstband, shc_bandshift_energyshift - use w90_postw90_common, only: nrpts - use w90_io, only: stdout, io_file_unit, io_error, io_stopwatch, & - seedname - use w90_comms, only: on_root, comms_bcast + !================================================ + + use w90_postw90_types, only: pw90_oper_read_type, pw90_spin_hall_type + use w90_types, only: dis_manifold_type, kmesh_info_type, print_output_type + + implicit none + + ! arguments + type(dis_manifold_type), intent(in) :: dis_manifold + type(kmesh_info_type), intent(in) :: kmesh_info + type(pw90_oper_read_type), intent(in) :: pw90_oper_read + type(print_output_type), intent(in) :: print_output + type(pw90_spin_hall_type), intent(in) :: pw90_spin_hall + type(w90comm_type), intent(in) :: comm + + integer, intent(in) :: stdout, nrpts, num_bands, num_kpts, num_wann, num_valence_bands + integer, intent(in) :: irvec(:, :) + + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: scissors_shift + real(kind=dp), intent(in) :: kpt_latt(:, :) + + complex(kind=dp), intent(in) :: v_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: SR_R(:, :, :, :, :) ! <0n|sigma_x,y,z.(r-R)_alpha|Rm> + complex(kind=dp), allocatable, intent(inout) :: SHR_R(:, :, :, :, :) ! <0n|sigma_x,y,z.H.(r-R)_alpha|Rm> + complex(kind=dp), allocatable, intent(inout) :: SH_R(:, :, :, :) ! <0n|sigma_x,y,z.H|Rm> + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + + ! local variables complex(kind=dp), allocatable :: SR_q(:, :, :, :, :) complex(kind=dp), allocatable :: SHR_q(:, :, :, :, :) complex(kind=dp), allocatable :: SH_q(:, :, :, :) @@ -1144,35 +1276,40 @@ subroutine get_SHC_R real(kind=dp) :: s_real, s_img integer :: spn_in, counter, ierr, s, is - integer :: n, m, i, j, & + integer :: n, m, & ik, ik2, ik_prev, nn, inn, nnl, nnm, nnn, & idir, ncount, nn_count, mmn_in, & - nb_tmp, nkp_tmp, nntot_tmp, file_unit, & - ir, io, ivdum(3), ivdum_old(3) + nb_tmp, nkp_tmp, nntot_tmp integer, allocatable :: num_states(:) - real(kind=dp) :: m_real, m_imag, rdum1_real, rdum1_imag, & - rdum2_real, rdum2_imag, rdum3_real, rdum3_imag + real(kind=dp) :: m_real, m_imag logical :: nn_found character(len=60) :: header + logical :: on_root = .false. + + if (mpirank(comm) == 0) on_root = .true. - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_SHC_R', 1) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_SHC_R', 1, stdout, seedname) if (.not. allocated(SR_R)) then allocate (SR_R(num_wann, num_wann, nrpts, 3, 3)) else - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_SHC_R', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_SHC_R', 2, stdout, seedname) return end if if (.not. allocated(SHR_R)) then allocate (SHR_R(num_wann, num_wann, nrpts, 3, 3)) else - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_SHC_R', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_SHC_R', 2, stdout, seedname) return end if if (.not. allocated(SH_R)) then allocate (SH_R(num_wann, num_wann, nrpts, 3)) else - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_SHC_R', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_SHC_R', 2, stdout, seedname) return end if @@ -1185,7 +1322,7 @@ subroutine get_SHC_R allocate (num_states(num_kpts)) do ik = 1, num_kpts if (have_disentangled) then - num_states(ik) = ndimwin(ik) + num_states(ik) = dis_manifold%ndimwin(ik) else num_states(ik) = num_wann endif @@ -1195,7 +1332,7 @@ subroutine get_SHC_R ! (sigma_i = Pauli matrix) between ab initio eigenstates ! spn_in = io_file_unit() - if (spn_formatted) then + if (pw90_oper_read%spn_formatted) then open (unit=spn_in, file=trim(seedname)//'.spn', form='formatted', & status='old', err=109) write (stdout, '(/a)', advance='no') & @@ -1213,10 +1350,10 @@ subroutine get_SHC_R read (spn_in, err=110, end=110) nb_tmp, nkp_tmp endif if (nb_tmp .ne. num_bands) & - call io_error(trim(seedname)//'.spn has wrong number of bands') + call io_error(trim(seedname)//'.spn has wrong number of bands', stdout, seedname) if (nkp_tmp .ne. num_kpts) & - call io_error(trim(seedname)//'.spn has wrong number of k-points') - if (spn_formatted) then + call io_error(trim(seedname)//'.spn has wrong number of k-points', stdout, seedname) + if (pw90_oper_read%spn_formatted) then do ik = 1, num_kpts do m = 1, num_bands do n = 1, m @@ -1235,7 +1372,7 @@ subroutine get_SHC_R enddo else allocate (spn_temp(3, (num_bands*(num_bands + 1))/2), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating spm_temp in get_SHC_R') + if (ierr /= 0) call io_error('Error in allocating spm_temp in get_SHC_R', stdout, seedname) do ik = 1, num_kpts read (spn_in) ((spn_temp(s, m), s=1, 3), m=1, (num_bands*(num_bands + 1))/2) counter = 0 @@ -1252,7 +1389,7 @@ subroutine get_SHC_R end do end do deallocate (spn_temp, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating spm_temp in get_SHC_R') + if (ierr /= 0) call io_error('Error in deallocating spm_temp in get_SHC_R', stdout, seedname) endif close (spn_in) @@ -1275,9 +1412,9 @@ subroutine get_SHC_R do m = num_valence_bands + 1, num_bands H_o(m, m, ik) = H_o(m, m, ik) + scissors_shift end do - else if (shc_bandshift) then - do m = shc_bandshift_firstband, num_bands - H_o(m, m, ik) = H_o(m, m, ik) + shc_bandshift_energyshift + else if (pw90_spin_hall%bandshift) then + do m = pw90_spin_hall%bandshift_firstband, num_bands + H_o(m, m, ik) = H_o(m, m, ik) + pw90_spin_hall%bandshift_energyshift end do end if enddo @@ -1306,12 +1443,12 @@ subroutine get_SHC_R read (mmn_in, *, err=102, end=102) nb_tmp, nkp_tmp, nntot_tmp ! Checks if (nb_tmp .ne. num_bands) & - call io_error(trim(seedname)//'.mmn has wrong number of bands') + call io_error(trim(seedname)//'.mmn has wrong number of bands', stdout, seedname) if (nkp_tmp .ne. num_kpts) & - call io_error(trim(seedname)//'.mmn has wrong number of k-points') - if (nntot_tmp .ne. nntot) & + call io_error(trim(seedname)//'.mmn has wrong number of k-points', stdout, seedname) + if (nntot_tmp .ne. kmesh_info%nntot) & call io_error & - (trim(seedname)//'.mmn has wrong number of nearest neighbours') + (trim(seedname)//'.mmn has wrong number of nearest neighbours', stdout, seedname) SR_q = cmplx_0 SHR_q = cmplx_0 @@ -1324,15 +1461,15 @@ subroutine get_SHC_R do ik = 1, num_kpts do is = 1, 3 SH_o(:, :, ik, is) = matmul(spn_o(:, :, ik, is), H_o(:, :, ik)) - call get_gauge_overlap_matrix( & - ik, num_states(ik), & - ik, num_states(ik), & - SH_o(:, :, ik, is), SH_q(:, :, ik, is)) + + call get_gauge_overlap_matrix(num_bands, num_wann, eigval, v_matrix, dis_manifold, & + ik, num_states(ik), ik, num_states(ik), & + SH_o(:, :, ik, is), have_disentangled, SH_q(:, :, ik, is)) end do end do ! Composite loop over k-points ik (outer loop) and neighbors ik2 (inner) - do ncount = 1, num_kpts*nntot + do ncount = 1, num_kpts*kmesh_info%nntot ! !Read from .mmn file the original overlap matrix ! S_o= between ab initio eigenstates @@ -1354,17 +1491,17 @@ subroutine get_SHC_R if (ik .ne. ik_prev) nn_count = 0 nn = 0 nn_found = .false. - do inn = 1, nntot - if ((ik2 .eq. nnlist(ik, inn)) .and. & - (nnl .eq. nncell(1, ik, inn)) .and. & - (nnm .eq. nncell(2, ik, inn)) .and. & - (nnn .eq. nncell(3, ik, inn))) then + do inn = 1, kmesh_info%nntot + if ((ik2 .eq. kmesh_info%nnlist(ik, inn)) .and. & + (nnl .eq. kmesh_info%nncell(1, ik, inn)) .and. & + (nnm .eq. kmesh_info%nncell(2, ik, inn)) .and. & + (nnn .eq. kmesh_info%nncell(3, ik, inn))) then if (.not. nn_found) then nn_found = .true. nn = inn else call io_error('Error reading '//trim(seedname)//'.mmn.& - & More than one matching nearest neighbour found') + & More than one matching nearest neighbour found', stdout, seedname) endif endif end do @@ -1372,7 +1509,7 @@ subroutine get_SHC_R write (stdout, '(/a,i8,2i5,i4,2x,3i3)') & ' Error reading '//trim(seedname)//'.mmn:', & ncount, ik, ik2, nn, nnl, nnm, nnn - call io_error('Neighbour not found') + call io_error('Neighbour not found', stdout, seedname) end if nn_count = nn_count + 1 !Check: can also be place after nn=inn (?) @@ -1390,30 +1527,31 @@ subroutine get_SHC_R ! Transform to projected subspace, Wannier gauge ! ! QZYZ18 Eq.(50) - call get_gauge_overlap_matrix( & - ik, num_states(ik), & - ik, num_states(ik), & - spn_o(:, :, ik, is), SS_q(:, :, is)) + call get_gauge_overlap_matrix(num_bands, num_wann, eigval, v_matrix, dis_manifold, & + ik, num_states(ik), ik, num_states(ik), & + spn_o(:, :, ik, is), have_disentangled, SS_q(:, :, is)) ! QZYZ18 Eq.(50) - call get_gauge_overlap_matrix( & - ik, num_states(ik), & - nnlist(ik, nn), num_states(nnlist(ik, nn)), & - SM_o(:, :, is), SM_q(:, :, is)) + call get_gauge_overlap_matrix(num_bands, num_wann, eigval, v_matrix, dis_manifold, & + ik, num_states(ik), kmesh_info%nnlist(ik, nn), & + num_states(kmesh_info%nnlist(ik, nn)), SM_o(:, :, is), & + have_disentangled, SM_q(:, :, is)) ! QZYZ18 Eq.(51) - call get_gauge_overlap_matrix( & - ik, num_states(ik), & - nnlist(ik, nn), num_states(nnlist(ik, nn)), & - SHM_o(:, :, is), SHM_q(:, :, is)) + call get_gauge_overlap_matrix(num_bands, num_wann, eigval, v_matrix, dis_manifold, & + ik, num_states(ik), kmesh_info%nnlist(ik, nn), & + num_states(kmesh_info%nnlist(ik, nn)), SHM_o(:, :, is), & + have_disentangled, SHM_q(:, :, is)) ! Assuming all neighbors of a given point are read in sequence! ! do idir = 1, 3 ! QZYZ18 Eq.(50) SR_q(:, :, ik, is, idir) = SR_q(:, :, ik, is, idir) & - + wb(nn)*bk(idir, nn, ik)*(SM_q(:, :, is) - SS_q(:, :, is)) + + kmesh_info%wb(nn)*kmesh_info%bk(idir, nn, ik) & + *(SM_q(:, :, is) - SS_q(:, :, is)) ! QZYZ18 Eq.(51) SHR_q(:, :, ik, is, idir) = SHR_q(:, :, ik, is, idir) & - + wb(nn)*bk(idir, nn, ik)*(SHM_q(:, :, is) - SH_q(:, :, ik, is)) + + kmesh_info%wb(nn)*kmesh_info%bk(idir, nn, ik) & + *(SHM_q(:, :, is) - SH_q(:, :, ik, is)) end do end do @@ -1424,12 +1562,14 @@ subroutine get_SHC_R do is = 1, 3 ! QZYZ18 Eq.(46) - call fourier_q_to_R(SH_q(:, :, :, is), SH_R(:, :, :, is)) + call fourier_q_to_R(num_kpts, nrpts, irvec, kpt_latt, SH_q(:, :, :, is), SH_R(:, :, :, is)) do idir = 1, 3 ! QZYZ18 Eq.(44) - call fourier_q_to_R(SR_q(:, :, :, is, idir), SR_R(:, :, :, is, idir)) + call fourier_q_to_R(num_kpts, nrpts, irvec, kpt_latt, SR_q(:, :, :, is, idir), & + SR_R(:, :, :, is, idir)) ! QZYZ18 Eq.(45) - call fourier_q_to_R(SHR_q(:, :, :, is, idir), SHR_R(:, :, :, is, idir)) + call fourier_q_to_R(num_kpts, nrpts, irvec, kpt_latt, SHR_q(:, :, :, is, idir), & + SHR_R(:, :, :, is, idir)) end do end do SR_R = cmplx_i*SR_R @@ -1437,68 +1577,84 @@ subroutine get_SHC_R endif !on_root - call comms_bcast(SH_R(1, 1, 1, 1), num_wann*num_wann*nrpts*3) - call comms_bcast(SR_R(1, 1, 1, 1, 1), num_wann*num_wann*nrpts*3*3) - call comms_bcast(SHR_R(1, 1, 1, 1, 1), num_wann*num_wann*nrpts*3*3) + call comms_bcast(SH_R(1, 1, 1, 1), num_wann*num_wann*nrpts*3, stdout, seedname, comm) + call comms_bcast(SR_R(1, 1, 1, 1, 1), num_wann*num_wann*nrpts*3*3, stdout, seedname, comm) + call comms_bcast(SHR_R(1, 1, 1, 1, 1), num_wann*num_wann*nrpts*3*3, stdout, seedname, comm) ! end copying from get_AA_R, Junfeng Qiao - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_SHC_R', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_SHC_R', 2, stdout, seedname) return -101 call io_error & - ('Error: Problem opening input file '//trim(seedname)//'.mmn') -102 call io_error & - ('Error: Problem reading input file '//trim(seedname)//'.mmn') -109 call io_error & - ('Error: Problem opening input file '//trim(seedname)//'.spn') -110 call io_error & - ('Error: Problem reading input file '//trim(seedname)//'.spn') +101 call io_error('Error: Problem opening input file '//trim(seedname)//'.mmn', stdout, seedname) +102 call io_error('Error: Problem reading input file '//trim(seedname)//'.mmn', stdout, seedname) +109 call io_error('Error: Problem opening input file '//trim(seedname)//'.spn', stdout, seedname) +110 call io_error('Error: Problem reading input file '//trim(seedname)//'.spn', stdout, seedname) end subroutine get_SHC_R - !============================================================! - subroutine get_SBB_R - !============================================================! - ! ! - ! SBB_ab(R) = <0|s_a.H.(r-R)_b|R> is the Fourier transform of ! - ! SBB_ab(k) = (a,b=x,y,z) ! - ! ! - !============================================================! - - use w90_constants, only: dp, cmplx_0, cmplx_i - use w90_parameters, only: num_kpts, nntot, nnlist, num_wann, & - num_bands, ndimwin, wb, bk, & - have_disentangled, timing_level, & - scissors_shift - use w90_postw90_common, only: nrpts, v_matrix - use w90_io, only: stdout, io_error, io_stopwatch, io_file_unit, & - seedname - use w90_comms, only: on_root, comms_bcast - - integer :: i, j, ii, jj, m, n, a, b, nn1, nn2, ik, nb_tmp, nkp_tmp, & - nntot_tmp, sHu_in, qb1, qb2, winmin_q, winmin_qb2 + !================================================ + subroutine get_SBB_R(dis_manifold, kmesh_info, kpt_latt, print_output, SBB_R, v_matrix, eigval, & + scissors_shift, irvec, nrpts, num_bands, num_kpts, num_wann, & + have_disentangled, seedname, stdout, comm) + !================================================! + ! + ! SBB_ab(R) = <0|s_a.H.(r-R)_b|R> is the Fourier transform of + ! SBB_ab(k) = (a,b=x,y,z) + ! + !================================================! + + use w90_types, only: dis_manifold_type, kmesh_info_type, print_output_type + + implicit none + + ! arguments + type(dis_manifold_type), intent(in) :: dis_manifold + type(kmesh_info_type), intent(in) :: kmesh_info + type(print_output_type), intent(in) :: print_output + type(w90comm_type), intent(in) :: comm + + integer, intent(in) :: num_bands, num_kpts, num_wann, nrpts, stdout, irvec(:, :) + + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: scissors_shift + real(kind=dp), intent(in) :: kpt_latt(:, :) + + complex(kind=dp), intent(in) :: v_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: SBB_R(:, :, :, :, :) ! <0n|sigma_x,y,z.H.(r-R)_alpha|Rm> + + logical, intent(in) :: have_disentangled + character(len=50), intent(in) :: seedname + + ! local variables + integer :: i, j, ii, jj, m, n, a, b, nn2, ik, nb_tmp, nkp_tmp, & + nntot_tmp, sHu_in, qb2, winmin_q, winmin_qb2 integer :: ipol integer, allocatable :: num_states(:) complex(kind=dp), allocatable :: SBB_q(:, :, :, :, :) complex(kind=dp), allocatable :: Ho_q_qb2(:, :, :) complex(kind=dp), allocatable :: H_q_qb2(:, :) - real(kind=dp) :: c_real, c_img character(len=60) :: header + logical :: on_root = .false. - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_SBB_R', 1) + if (mpirank(comm) == 0) on_root = .true. - if (.not. allocated(BB_R)) then + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_SBB_R', 1, stdout, seedname) + + if (.not. allocated(SBB_R)) then allocate (SBB_R(num_wann, num_wann, nrpts, 3, 3)) else - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_SBB_R', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_SBB_R', 2, stdout, seedname) return end if if (on_root) then if (abs(scissors_shift) > 1.0e-7_dp) & - call io_error('Error: scissors correction not yet implemented for SBB_R') + call io_error('Error: scissors correction not yet implemented for SBB_R', stdout, seedname) allocate (Ho_q_qb2(num_bands, num_bands, 3)) allocate (H_q_qb2(num_wann, num_wann)) @@ -1507,7 +1663,7 @@ subroutine get_SBB_R allocate (num_states(num_kpts)) do ik = 1, num_kpts if (have_disentangled) then - num_states(ik) = ndimwin(ik) + num_states(ik) = dis_manifold%ndimwin(ik) else num_states(ik) = num_wann endif @@ -1523,21 +1679,21 @@ subroutine get_SBB_R read (sHu_in, err=112, end=112) nb_tmp, nkp_tmp, nntot_tmp if (nb_tmp .ne. num_bands) & call io_error & - (trim(seedname)//'.sHu has not the right number of bands') + (trim(seedname)//'.sHu has not the right number of bands', stdout, seedname) if (nkp_tmp .ne. num_kpts) & call io_error & - (trim(seedname)//'.sHu has not the right number of k-points') - if (nntot_tmp .ne. nntot) & + (trim(seedname)//'.sHu has not the right number of k-points', stdout, seedname) + if (nntot_tmp .ne. kmesh_info%nntot) & call io_error & - (trim(seedname)//'.sHu has not the right number of nearest neighbours') + (trim(seedname)//'.sHu has not the right number of nearest neighbours', stdout, seedname) SBB_q = cmplx_0 do ik = 1, num_kpts - call get_win_min(ik, winmin_q) - do nn2 = 1, nntot - qb2 = nnlist(ik, nn2) - call get_win_min(qb2, winmin_qb2) + call get_win_min(num_bands, dis_manifold, ik, winmin_q, have_disentangled) + do nn2 = 1, kmesh_info%nntot + qb2 = kmesh_info%nnlist(ik, nn2) + call get_win_min(num_bands, dis_manifold, qb2, winmin_qb2, have_disentangled) do ipol = 1, 3 ! ! Read from .sHu file the matrices @@ -1567,7 +1723,7 @@ subroutine get_SBB_R enddo do b = 1, 3 SBB_q(:, :, ik, ipol, b) = SBB_q(:, :, ik, ipol, b) + & - cmplx_i*wb(nn2)*bk(b, nn2, ik)*H_q_qb2(:, :) + cmplx_i*kmesh_info%wb(nn2)*kmesh_info%bk(b, nn2, ik)*H_q_qb2(:, :) enddo enddo !ipol enddo !nn2 @@ -1576,66 +1732,86 @@ subroutine get_SBB_R close (sHu_in) do b = 1, 3 do a = 1, 3 - call fourier_q_to_R(SBB_q(:, :, :, a, b), SBB_R(:, :, :, a, b)) + call fourier_q_to_R(num_kpts, nrpts, irvec, kpt_latt, SBB_q(:, :, :, a, b), SBB_R(:, :, :, a, b)) enddo enddo endif !on_root - call comms_bcast(SBB_R(1, 1, 1, 1, 1), num_wann*num_wann*nrpts*3*3) + call comms_bcast(SBB_R(1, 1, 1, 1, 1), num_wann*num_wann*nrpts*3*3, stdout, seedname, comm) - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_SBB_R', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_SBB_R', 2, stdout, seedname) return 111 call io_error & - ('Error: Problem opening input file '//trim(seedname)//'.sHu') + ('Error: Problem opening input file '//trim(seedname)//'.sHu', stdout, seedname) 112 call io_error & - ('Error: Problem reading input file '//trim(seedname)//'.sHu') + ('Error: Problem reading input file '//trim(seedname)//'.sHu', stdout, seedname) end subroutine get_SBB_R - !============================================================! - subroutine get_SAA_R - !============================================================! - ! ! - ! SAA_ab(R) = <0|s_a.(r-R)_b|R> is the Fourier transform of ! - ! SAA_ab(k) = (a,b=x,y,z) ! - ! ! - !============================================================! - - use w90_constants, only: dp, cmplx_0, cmplx_i - use w90_parameters, only: num_kpts, nntot, nnlist, num_wann, & - num_bands, ndimwin, wb, bk, & - have_disentangled, timing_level, & - scissors_shift - use w90_postw90_common, only: nrpts, v_matrix - use w90_io, only: stdout, io_error, io_stopwatch, io_file_unit, & - seedname - use w90_comms, only: on_root, comms_bcast, my_node_id - - integer :: i, j, ii, jj, m, n, a, b, nn1, nn2, ik, nb_tmp, nkp_tmp, & - nntot_tmp, sIu_in, qb1, qb2, winmin_q, winmin_qb2 + !================================================ + subroutine get_SAA_R(dis_manifold, kmesh_info, kpt_latt, print_output, SAA_R, v_matrix, eigval, & + scissors_shift, irvec, nrpts, num_bands, num_kpts, num_wann, & + have_disentangled, seedname, stdout, comm) + !================================================! + ! + ! SAA_ab(R) = <0|s_a.(r-R)_b|R> is the Fourier transform of + ! SAA_ab(k) = (a,b=x,y,z) + ! + !================================================! + + use w90_types, only: dis_manifold_type, kmesh_info_type, print_output_type + + implicit none + + ! arguments + type(dis_manifold_type), intent(in) :: dis_manifold + type(kmesh_info_type), intent(in) :: kmesh_info + type(print_output_type), intent(in) :: print_output + type(w90comm_type), intent(in) :: comm + + integer, intent(in) :: num_bands, num_kpts, num_wann, nrpts, stdout, irvec(:, :) + + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: scissors_shift + real(kind=dp), intent(in) :: kpt_latt(:, :) + + complex(kind=dp), intent(in) :: v_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: SAA_R(:, :, :, :, :) !<0n|sigma_x,y,z.(r-R)_alpha|Rm> + + logical, intent(in) :: have_disentangled + character(len=50), intent(in) :: seedname + + ! local variables + integer :: i, j, ii, jj, m, n, a, b, nn2, ik, nb_tmp, nkp_tmp, & + nntot_tmp, sIu_in, qb2, winmin_q, winmin_qb2 integer :: ipol integer, allocatable :: num_states(:) complex(kind=dp), allocatable :: SAA_q(:, :, :, :, :) complex(kind=dp), allocatable :: Ho_q_qb2(:, :, :) complex(kind=dp), allocatable :: H_q_qb2(:, :) - real(kind=dp) :: c_real, c_img character(len=60) :: header + logical :: on_root = .false. - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_SAA_R', 1) + if (mpirank(comm) == 0) on_root = .true. - if (.not. allocated(BB_R)) then + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_SAA_R', 1, stdout, seedname) + + if (.not. allocated(SAA_R)) then allocate (SAA_R(num_wann, num_wann, nrpts, 3, 3)) else - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_SAA_R', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('get_oper: get_SAA_R', 2, stdout, seedname) return end if if (on_root) then if (abs(scissors_shift) > 1.0e-7_dp) & - call io_error('Error: scissors correction not yet implemented for SAA_R') + call io_error('Error: scissors correction not yet implemented for SAA_R', stdout, seedname) allocate (Ho_q_qb2(num_bands, num_bands, 3)) allocate (H_q_qb2(num_wann, num_wann)) @@ -1644,7 +1820,7 @@ subroutine get_SAA_R allocate (num_states(num_kpts)) do ik = 1, num_kpts if (have_disentangled) then - num_states(ik) = ndimwin(ik) + num_states(ik) = dis_manifold%ndimwin(ik) else num_states(ik) = num_wann endif @@ -1660,21 +1836,21 @@ subroutine get_SAA_R read (sIu_in, err=114, end=114) nb_tmp, nkp_tmp, nntot_tmp if (nb_tmp .ne. num_bands) & call io_error & - (trim(seedname)//'.sIu has not the right number of bands') + (trim(seedname)//'.sIu has not the right number of bands', stdout, seedname) if (nkp_tmp .ne. num_kpts) & call io_error & - (trim(seedname)//'.sIu has not the right number of k-points') - if (nntot_tmp .ne. nntot) & + (trim(seedname)//'.sIu has not the right number of k-points', stdout, seedname) + if (nntot_tmp .ne. kmesh_info%nntot) & call io_error & - (trim(seedname)//'.sIu has not the right number of nearest neighbours') + (trim(seedname)//'.sIu has not the right number of nearest neighbours', stdout, seedname) SAA_q = cmplx_0 do ik = 1, num_kpts - call get_win_min(ik, winmin_q) - do nn2 = 1, nntot - qb2 = nnlist(ik, nn2) - call get_win_min(qb2, winmin_qb2) + call get_win_min(num_bands, dis_manifold, ik, winmin_q, have_disentangled) + do nn2 = 1, kmesh_info%nntot + qb2 = kmesh_info%nnlist(ik, nn2) + call get_win_min(num_bands, dis_manifold, qb2, winmin_qb2, have_disentangled) do ipol = 1, 3 ! ! Read from .sIu file the matrices @@ -1704,7 +1880,7 @@ subroutine get_SAA_R enddo do b = 1, 3 SAA_q(:, :, ik, ipol, b) = SAA_q(:, :, ik, ipol, b) + & - cmplx_i*wb(nn2)*bk(b, nn2, ik)*H_q_qb2(:, :) + cmplx_i*kmesh_info%wb(nn2)*kmesh_info%bk(b, nn2, ik)*H_q_qb2(:, :) enddo ! enddo !nn1 enddo !ipol @@ -1715,53 +1891,49 @@ subroutine get_SAA_R do b = 1, 3 do a = 1, 3 - call fourier_q_to_R(SAA_q(:, :, :, a, b), SAA_R(:, :, :, a, b)) + call fourier_q_to_R(num_kpts, nrpts, irvec, kpt_latt, SAA_q(:, :, :, a, b), SAA_R(:, :, :, a, b)) enddo enddo endif !on_root - call comms_bcast(SAA_R(1, 1, 1, 1, 1), num_wann*num_wann*nrpts*3*3) + call comms_bcast(SAA_R(1, 1, 1, 1, 1), num_wann*num_wann*nrpts*3*3, stdout, seedname, comm) - if (timing_level > 1 .and. on_root) call io_stopwatch('get_oper: get_SAA_R', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) call io_stopwatch('get_oper: get_SAA_R', 2, stdout, seedname) return 113 call io_error & - ('Error: Problem opening input file '//trim(seedname)//'.sIu') + ('Error: Problem opening input file '//trim(seedname)//'.sIu', stdout, seedname) 114 call io_error & - ('Error: Problem reading input file '//trim(seedname)//'.sIu') + ('Error: Problem reading input file '//trim(seedname)//'.sIu', stdout, seedname) end subroutine get_SAA_R - !=========================================================! - ! PRIVATE PROCEDURES ! - !=========================================================! + !================================================! + ! PRIVATE PROCEDURES + !================================================! - !=========================================================! - subroutine fourier_q_to_R(op_q, op_R) - !========================================================== + !================================================! + subroutine fourier_q_to_R(num_kpts, nrpts, irvec, kpt_latt, op_q, op_R) + !================================================ ! !! Fourier transforms Wannier-gauge representation !! of a given operator O from q-space to R-space: !! !! O_ij(q) --> O_ij(R) = (1/N_kpts) sum_q e^{-iqR} O_ij(q) ! - !========================================================== - - use w90_constants, only: dp, cmplx_0, cmplx_i, twopi - use w90_parameters, only: num_kpts, kpt_latt - use w90_postw90_common, only: nrpts, irvec + !================================================ implicit none ! Arguments - ! - complex(kind=dp), dimension(:, :, :), intent(in) :: op_q - !! Operator in q-space - complex(kind=dp), dimension(:, :, :), intent(out) :: op_R - !! Operator in R-space - - integer :: ir, ik - real(kind=dp) :: rdotq + real(kind=dp), intent(in) :: kpt_latt(:, :) + integer, intent(in) :: num_kpts, nrpts, irvec(:, :) + complex(kind=dp), intent(in) :: op_q(:, :, :) !! Operator in q-space + complex(kind=dp), intent(out) :: op_R(:, :, :) !! Operator in R-space + + ! local variables + integer :: ir, ik + real(kind=dp) :: rdotq complex(kind=dp) :: phase_fac op_R = cmplx_0 @@ -1776,27 +1948,26 @@ subroutine fourier_q_to_R(op_q, op_R) end subroutine fourier_q_to_R - !=============================================== - subroutine get_win_min(ik, win_min) - !=============================================== + !================================================ + subroutine get_win_min(num_bands, dis_manifold, ik, win_min, have_disentangled) + !================================================ ! !! Find the lower bound (band index) of the !! outer energy window at the specified k-point ! - !=============================================== + !================================================ - use w90_constants, only: dp - use w90_parameters, only: num_bands, lwindow, have_disentangled + use w90_types, only: dis_manifold_type, print_output_type implicit none ! Arguments - ! - integer, intent(in) :: ik - !! Index of the required k-point - integer, intent(out) :: win_min - !! Index of the lower band of the outer energy window + integer, intent(in) :: num_bands, ik !! Index of the required k-point + integer, intent(out) :: win_min !! Index of the lower band of the outer energy window + type(dis_manifold_type), intent(in) :: dis_manifold + logical, intent(in) :: have_disentangled + ! local variables integer :: j if (.not. have_disentangled) then @@ -1805,7 +1976,7 @@ subroutine get_win_min(ik, win_min) endif do j = 1, num_bands - if (lwindow(j, ik)) then + if (dis_manifold%lwindow(j, ik)) then win_min = j exit end if @@ -1813,9 +1984,10 @@ subroutine get_win_min(ik, win_min) end subroutine get_win_min - !========================================================== - subroutine get_gauge_overlap_matrix(ik_a, ns_a, ik_b, ns_b, S_o, S, H) - !========================================================== + !================================================ + subroutine get_gauge_overlap_matrix(num_bands, num_wann, eigval, v_matrix, dis_manifold, ik_a, & + ns_a, ik_b, ns_b, S_o, have_disentangled, S, H) + !================================================ ! ! Wannier-gauge overlap matrix S in the projected subspace ! @@ -1823,27 +1995,33 @@ subroutine get_gauge_overlap_matrix(ik_a, ns_a, ik_b, ns_b, S_o, S, H) ! possibliy give it a better name. The routine has been ! generalized multiple times. ! - !========================================================== + !================================================ - use w90_constants, only: dp, cmplx_0 - use w90_postw90_common, only: v_matrix - use w90_parameters, only: num_wann, eigval + use w90_types, only: dis_manifold_type use w90_utility, only: utility_zgemmm - integer, intent(in) :: ik_a, ns_a, ik_b, ns_b + implicit none + + ! arguments + type(dis_manifold_type), intent(in) :: dis_manifold + real(kind=dp), intent(in) :: eigval(:, :) + complex(kind=dp), intent(in) :: S_o(:, :), v_matrix(:, :, :) + integer, intent(in) :: num_wann, num_bands, ik_a, ns_a, ik_b, ns_b + logical, intent(in) :: have_disentangled - complex(kind=dp), dimension(:, :), intent(in) :: S_o - complex(kind=dp), dimension(:, :), intent(out), optional :: S, H + complex(kind=dp), intent(out), optional :: S(:, :), H(:, :) + ! local variables integer :: wm_a, wm_b - call get_win_min(ik_a, wm_a) - call get_win_min(ik_b, wm_b) + call get_win_min(num_bands, dis_manifold, ik_a, wm_a, have_disentangled) + call get_win_min(num_bands, dis_manifold, ik_b, wm_b, have_disentangled) call utility_zgemmm(v_matrix(1:ns_a, 1:num_wann, ik_a), 'C', & S_o(wm_a:wm_a + ns_a - 1, wm_b:wm_b + ns_b - 1), 'N', & v_matrix(1:ns_b, 1:num_wann, ik_b), 'N', & S, eigval(wm_a:wm_a + ns_a - 1, ik_a), H) + end subroutine get_gauge_overlap_matrix end module w90_get_oper diff --git a/src/postw90/gyrotropic.F90 b/src/postw90/gyrotropic.F90 index 044602322..9cb65e08b 100644 --- a/src/postw90/gyrotropic.F90 +++ b/src/postw90/gyrotropic.F90 @@ -11,18 +11,21 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! - -! --------------------------------------------------------------- +! ! +! w90_gyrotropic: various gyrotropic effects ! +! ! +!------------------------------------------------------------! module w90_gyrotropic + !! This module computes various "gyrotropic" effects !! as described in : !! TAS17 = arXiv:1710.03204 (2017) Gyrotropic effects in trigonal tellurium studied from first principles !! S.S.Tsirkin, P. Aguado Puente, I. Souza - ! --------------------------------------------------------------- use w90_constants, only: dp use w90_berry, only: berry_get_imf_klist, berry_get_imfgh_klist + implicit none private @@ -47,42 +50,82 @@ module w90_gyrotropic ! 5 <--> xz ! 6 <--> yz ! - integer, dimension(6), parameter :: alpha_S = (/1, 2, 3, 1, 1, 2/) - integer, dimension(6), parameter :: beta_S = (/1, 2, 3, 2, 3, 3/) + !integer, dimension(6), parameter :: alpha_S = (/1, 2, 3, 1, 1, 2/) + !integer, dimension(6), parameter :: beta_S = (/1, 2, 3, 2, 3, 3/) contains - !===========================================================! - ! PUBLIC PROCEDURES ! - !===========================================================! - - subroutine gyrotropic_main - !============================================================! - ! ! + !================================================! + ! PUBLIC PROCEDURES + !================================================! + + subroutine gyrotropic_main(pw90_berry, dis_manifold, fermi_energy_list, pw90_gyrotropic, kmesh_info, & + kpt_latt, physics, pw90_oper_read, pw90_band_deriv_degen, ws_region, w90_system, & + print_output, wannier_data, wigner_seitz, ws_distance, AA_R, BB_R, CC_R, HH_R, & + SS_R, u_matrix, v_matrix, eigval, real_lattice, & + scissors_shift, mp_grid, num_bands, num_kpts, num_wann, & + effective_model, have_disentangled, seedname, stdout, comm) + !================================================! + ! !! Computes the following quantities: !! (i) D tensor !! (ii) K tensor !! (iii) C tensor !! (iv) current-induced optical activity !! (v) natural optical activity - ! ! - !============================================================! - - use w90_constants, only: dp, cmplx_0, elem_charge_SI, hbar_SI, & - eV_au, bohr, elec_mass_SI, twopi, eps0_SI - use w90_comms, only: on_root, num_nodes, my_node_id, comms_reduce + ! + !================================================! + + use w90_comms, only: comms_reduce, w90comm_type, mpirank, mpisize + use w90_constants, only: dp, twopi, pw90_physical_constants_type + use w90_get_oper, only: get_HH_R, get_AA_R, get_BB_R, get_CC_R, get_SS_R + use w90_io, only: io_error, io_file_unit, io_stopwatch + use w90_postw90_types, only: pw90_gyrotropic_type, pw90_berry_mod_type, pw90_oper_read_type, & + pw90_band_deriv_degen_type, wigner_seitz_type + use w90_types, only: dis_manifold_type, print_output_type, & + kmesh_info_type, wannier_data_type, ws_region_type, w90_system_type, ws_distance_type use w90_utility, only: utility_det3 - use w90_io, only: io_error, stdout, io_file_unit, seedname, & - io_stopwatch - use w90_postw90_common, only: nrpts, irvec, num_int_kpts_on_node, int_kpts, & - weight - use w90_parameters, only: timing_level, iprint, num_wann, gyrotropic_kmesh, & - cell_volume, transl_inv, gyrotropic_task, & - gyrotropic_nfreq, gyrotropic_freq_list, nfermi, & - fermi_energy_list, gyrotropic_box, gyrotropic_box_corner, spinors - use w90_get_oper, only: get_HH_R, get_AA_R, get_BB_R, get_CC_R, & - get_SS_R + implicit none + + ! arguments + type(pw90_berry_mod_type), intent(in) :: pw90_berry + type(dis_manifold_type), intent(in) :: dis_manifold + type(pw90_gyrotropic_type), intent(in) :: pw90_gyrotropic + type(kmesh_info_type), intent(in) :: kmesh_info + type(pw90_band_deriv_degen_type), intent(in) :: pw90_band_deriv_degen + type(pw90_oper_read_type), intent(in) :: pw90_oper_read + type(print_output_type), intent(in) :: print_output + type(pw90_physical_constants_type), intent(in) :: physics + type(ws_region_type), intent(in) :: ws_region + type(w90comm_type), intent(in) :: comm + type(w90_system_type), intent(in) :: w90_system + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + complex(kind=dp), allocatable, intent(inout) :: AA_R(:, :, :, :) + complex(kind=dp), allocatable, intent(inout) :: BB_R(:, :, :, :) + complex(kind=dp), allocatable, intent(inout) :: CC_R(:, :, :, :, :) + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) + complex(kind=dp), intent(in) :: u_matrix(:, :, :), v_matrix(:, :, :) + + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: scissors_shift + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + real(kind=dp), intent(in) :: kpt_latt(:, :) + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_bands, num_kpts, num_wann + integer, intent(in) :: stdout + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + logical, intent(in) :: effective_model + + ! local variables real(kind=dp), allocatable :: gyro_K_spn(:, :, :) real(kind=dp), allocatable :: gyro_DOS(:) real(kind=dp), allocatable :: gyro_K_orb(:, :, :) @@ -96,23 +139,31 @@ subroutine gyrotropic_main character(len=30) :: units_tmp character(len=120) :: comment_tmp + real(kind=dp) :: cell_volume real(kind=dp) :: kweight, kpt(3), & - db1, db2, db3, fac, freq - integer :: n, i, j, k, ikpt, if, ierr, loop_x, loop_y, loop_z, & - loop_xyz, ifreq, & - file_unit + db1, db2, db3, fac + integer :: loop_x, loop_y, loop_z, loop_xyz + integer :: fermi_n logical :: eval_K, eval_C, eval_D, eval_Dw, eval_NOA, eval_spn, eval_DOS - if (nfermi == 0) call io_error( & - 'Must specify one or more Fermi levels when gyrotropic=true') + integer :: my_node_id, num_nodes + my_node_id = mpirank(comm) + num_nodes = mpisize(comm) - if (timing_level > 1 .and. on_root) call io_stopwatch('gyrotropic: prelims', 1) + if (.not. allocated(fermi_energy_list)) call io_error( & + 'Must specify one or more Fermi levels when gyrotropic=true', stdout, seedname) + + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('gyrotropic: prelims', 1, stdout, seedname) + + cell_volume = real_lattice(1, 1)*(real_lattice(2, 2)*real_lattice(3, 3) - real_lattice(3, 2)*real_lattice(2, 3)) + & + real_lattice(1, 2)*(real_lattice(2, 3)*real_lattice(3, 1) - real_lattice(3, 3)*real_lattice(2, 1)) + & + real_lattice(1, 3)*(real_lattice(2, 1)*real_lattice(3, 2) - real_lattice(3, 1)*real_lattice(2, 2)) ! Mesh spacing in reduced coordinates - ! - db1 = 1.0_dp/real(gyrotropic_kmesh(1), dp) - db2 = 1.0_dp/real(gyrotropic_kmesh(2), dp) - db3 = 1.0_dp/real(gyrotropic_kmesh(3), dp) + db1 = 1.0_dp/real(pw90_gyrotropic%kmesh%mesh(1), dp) + db2 = 1.0_dp/real(pw90_gyrotropic%kmesh%mesh(2), dp) + db3 = 1.0_dp/real(pw90_gyrotropic%kmesh%mesh(3), dp) eval_K = .false. eval_C = .false. @@ -122,80 +173,97 @@ subroutine gyrotropic_main eval_NOA = .false. eval_DOS = .false. - if (index(gyrotropic_task, '-k') > 0) eval_K = .true. - if (index(gyrotropic_task, '-c') > 0) eval_C = .true. - if (index(gyrotropic_task, '-d0') > 0) eval_D = .true. - if (index(gyrotropic_task, '-dw') > 0) eval_Dw = .true. - if (index(gyrotropic_task, '-spin') > 0) eval_spn = .true. - if (index(gyrotropic_task, '-noa') > 0) eval_NOA = .true. - if (index(gyrotropic_task, '-dos') > 0) eval_DOS = .true. - if (index(gyrotropic_task, 'all') > 0) then + if (index(pw90_gyrotropic%task, '-k') > 0) eval_K = .true. + if (index(pw90_gyrotropic%task, '-c') > 0) eval_C = .true. + if (index(pw90_gyrotropic%task, '-d0') > 0) eval_D = .true. + if (index(pw90_gyrotropic%task, '-dw') > 0) eval_Dw = .true. + if (index(pw90_gyrotropic%task, '-spin') > 0) eval_spn = .true. + if (index(pw90_gyrotropic%task, '-noa') > 0) eval_NOA = .true. + if (index(pw90_gyrotropic%task, '-dos') > 0) eval_DOS = .true. + if (index(pw90_gyrotropic%task, 'all') > 0) then eval_K = .true. eval_C = .true. eval_D = .true. eval_Dw = .true. - if (spinors) eval_spn = .true. + if (w90_system%spinors) eval_spn = .true. eval_NOA = .true. eval_DOS = .true. endif if (.not. (eval_K .or. eval_noa)) eval_spn = .false. - if ((.not. spinors) .and. eval_spn) call io_error( & - "spin contribution requested for gyrotropic, but the wavefunctions are not spinors") + if ((.not. w90_system%spinors) .and. eval_spn) call io_error( & + "spin contribution requested for gyrotropic, but the wavefunctions are not spinors", & + stdout, seedname) ! Wannier matrix elements, allocations and initializations - call get_HH_R + call get_HH_R(dis_manifold, kpt_latt, print_output, wigner_seitz, HH_R, u_matrix, v_matrix, eigval, & + real_lattice, scissors_shift, num_bands, num_kpts, num_wann, & + w90_system%num_valence_bands, effective_model, have_disentangled, seedname, stdout, & + comm) + if (eval_D .or. eval_Dw .or. eval_K .or. eval_NOA) then - call get_AA_R + + call get_AA_R(pw90_berry, dis_manifold, kmesh_info, kpt_latt, print_output, AA_R, HH_R, v_matrix, & + eigval, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, num_wann, & + effective_model, have_disentangled, seedname, stdout, comm) endif if (eval_spn) then - call get_SS_R + + call get_SS_R(dis_manifold, kpt_latt, print_output, pw90_oper_read, SS_R, v_matrix, eigval, & + wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, num_wann, have_disentangled, & + seedname, stdout, comm) endif + ! not allocated was tested at start of routine + fermi_n = size(fermi_energy_list) if (eval_K) then - call get_BB_R - call get_CC_R - allocate (gyro_K_orb(3, 3, nfermi)) + call get_BB_R(dis_manifold, kmesh_info, kpt_latt, print_output, BB_R, v_matrix, eigval, & + scissors_shift, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, num_wann, & + have_disentangled, seedname, stdout, comm) + call get_CC_R(dis_manifold, kmesh_info, kpt_latt, print_output, pw90_oper_read, CC_R, v_matrix, & + eigval, scissors_shift, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, & + num_wann, have_disentangled, seedname, stdout, comm) + allocate (gyro_K_orb(3, 3, fermi_n)) gyro_K_orb = 0.0_dp if (eval_spn) then - allocate (gyro_K_spn(3, 3, nfermi)) + allocate (gyro_K_spn(3, 3, fermi_n)) gyro_K_spn = 0.0_dp endif endif if (eval_D) then - allocate (gyro_D(3, 3, nfermi)) + allocate (gyro_D(3, 3, fermi_n)) gyro_D = 0.0_dp endif if (eval_DOS) then - allocate (gyro_DOS(nfermi)) + allocate (gyro_DOS(fermi_n)) gyro_DOS = 0.0_dp endif if (eval_C) then - allocate (gyro_C(3, 3, nfermi)) + allocate (gyro_C(3, 3, fermi_n)) gyro_C = 0.0_dp endif if (eval_Dw) then - allocate (gyro_Dw(3, 3, nfermi, gyrotropic_nfreq)) + allocate (gyro_Dw(3, 3, fermi_n, pw90_gyrotropic%nfreq)) gyro_Dw = 0.0_dp endif if (eval_NOA) then - allocate (gyro_NOA_orb(3, 3, nfermi, gyrotropic_nfreq)) + allocate (gyro_NOA_orb(3, 3, fermi_n, pw90_gyrotropic%nfreq)) gyro_NOA_orb = 0.0_dp if (eval_spn) then - allocate (gyro_NOA_spn(3, 3, nfermi, gyrotropic_nfreq)) + allocate (gyro_NOA_spn(3, 3, fermi_n, pw90_gyrotropic%nfreq)) gyro_NOA_spn = 0.0_dp endif endif - if (on_root) then + if (print_output%iprint > 0) then flush(stdout) write (stdout, '(/,/,1x,a)') 'Properties calculated in module g y r o t r o p i c' write (stdout, '(1x,a)') '------------------------------------------' @@ -226,75 +294,84 @@ subroutine gyrotropic_main endif endif - if (transl_inv) then + if (pw90_berry%transl_inv) then if (eval_K) & - call io_error('transl_inv=T disabled for K-tensor') + call io_error('transl_inv=T disabled for K-tensor', stdout, seedname) write (stdout, '(/,1x,a)') & 'Using a translationally-invariant discretization for the' write (stdout, '(1x,a)') & 'band-diagonal Wannier matrix elements of r, etc.' endif - if (timing_level > 1) then - call io_stopwatch('gyrotropic: prelims', 2) - call io_stopwatch('gyrotropic: k-interpolation', 1) + if (print_output%timing_level > 1) then + call io_stopwatch('gyrotropic: prelims', 2, stdout, seedname) + call io_stopwatch('gyrotropic: k-interpolation', 1, stdout, seedname) endif - write (stdout, '(1x,a20,3(i0,1x))') 'Interpolation grid: ', gyrotropic_kmesh(1:3) + write (stdout, '(1x,a20,3(i0,1x))') 'Interpolation grid: ', pw90_gyrotropic%kmesh%mesh(1:3) flush(stdout) - end if !on_root + end if ! print_output%iprint >0, aka "on_root" ! Do not read 'kpoint.dat'. Loop over a regular grid in the full BZ - kweight = db1*db2*db3*utility_det3(gyrotropic_box) + kweight = db1*db2*db3*utility_det3(pw90_gyrotropic%box) - do loop_xyz = my_node_id, PRODUCT(gyrotropic_kmesh) - 1, num_nodes - loop_x = loop_xyz/(gyrotropic_kmesh(2)*gyrotropic_kmesh(3)) - loop_y = (loop_xyz - loop_x*(gyrotropic_kmesh(2) & - *gyrotropic_kmesh(3)))/gyrotropic_kmesh(3) - loop_z = loop_xyz - loop_x*(gyrotropic_kmesh(2)*gyrotropic_kmesh(3)) & - - loop_y*gyrotropic_kmesh(3) + do loop_xyz = my_node_id, PRODUCT(pw90_gyrotropic%kmesh%mesh) - 1, num_nodes + loop_x = loop_xyz/(pw90_gyrotropic%kmesh%mesh(2)*pw90_gyrotropic%kmesh%mesh(3)) + loop_y = (loop_xyz - loop_x*(pw90_gyrotropic%kmesh%mesh(2) & + *pw90_gyrotropic%kmesh%mesh(3)))/pw90_gyrotropic%kmesh%mesh(3) + loop_z = loop_xyz - loop_x*(pw90_gyrotropic%kmesh%mesh(2)*pw90_gyrotropic%kmesh%mesh(3)) & + - loop_y*pw90_gyrotropic%kmesh%mesh(3) kpt(1) = loop_x*db1 kpt(2) = loop_y*db2 kpt(3) = loop_z*db3 - kpt(:) = gyrotropic_box_corner(:) + matmul(kpt, gyrotropic_box) - - call gyrotropic_get_k_list(kpt, kweight, & - gyro_K_spn, gyro_K_orb, gyro_D, gyro_Dw, gyro_C, & - gyro_DOS, gyro_NOA_orb, gyro_NOA_spn, & - eval_K, eval_D, eval_Dw, eval_NOA, eval_spn, eval_C, eval_dos) + kpt(:) = pw90_gyrotropic%box_corner(:) + matmul(kpt, pw90_gyrotropic%box) + + call gyrotropic_get_k_list(ws_region, w90_system%num_valence_bands, have_disentangled, kpt, & + kweight, gyro_K_spn, gyro_K_orb, gyro_D, gyro_Dw, gyro_C, & + gyro_DOS, gyro_NOA_orb, gyro_NOA_spn, eval_K, eval_D, eval_Dw, & + eval_NOA, eval_spn, eval_C, eval_dos, num_wann, print_output, & + fermi_energy_list, wannier_data, eigval, real_lattice, mp_grid, & + num_bands, num_kpts, u_matrix, v_matrix, dis_manifold, kpt_latt, & + pw90_gyrotropic, scissors_shift, effective_model, pw90_band_deriv_degen, & + ws_distance, wigner_seitz, stdout, seedname, comm, HH_R, AA_R, & + BB_R, CC_R, SS_R) end do !loop_xyz ! Collect contributions from all nodes - ! if (eval_K) then - call comms_reduce(gyro_K_orb(1, 1, 1), 3*3*nfermi, 'SUM') - if (eval_spn) call comms_reduce(gyro_K_spn(1, 1, 1), 3*3*nfermi, 'SUM') + call comms_reduce(gyro_K_orb(1, 1, 1), 3*3*fermi_n, 'SUM', stdout, seedname, comm) + if (eval_spn) call comms_reduce(gyro_K_spn(1, 1, 1), 3*3*fermi_n, 'SUM', stdout, & + seedname, comm) endif if (eval_D) & - call comms_reduce(gyro_D(1, 1, 1), 3*3*nfermi, 'SUM') + call comms_reduce(gyro_D(1, 1, 1), 3*3*fermi_n, 'SUM', stdout, seedname, comm) if (eval_C) & - call comms_reduce(gyro_C(1, 1, 1), 3*3*nfermi, 'SUM') + call comms_reduce(gyro_C(1, 1, 1), 3*3*fermi_n, 'SUM', stdout, seedname, comm) if (eval_Dw) & - call comms_reduce(gyro_Dw(1, 1, 1, 1), 3*3*nfermi*gyrotropic_nfreq, 'SUM') + call comms_reduce(gyro_Dw(1, 1, 1, 1), 3*3*fermi_n*pw90_gyrotropic%nfreq, 'SUM', stdout, & + seedname, comm) if (eval_dos) & - call comms_reduce(gyro_DOS(1), nfermi, 'SUM') + call comms_reduce(gyro_DOS(1), fermi_n, 'SUM', stdout, seedname, comm) if (eval_NOA) then - call comms_reduce(gyro_NOA_orb(1, 1, 1, 1), 3*3*nfermi*gyrotropic_nfreq, 'SUM') - if (eval_spn) call comms_reduce(gyro_NOA_spn(1, 1, 1, 1), 3*3*nfermi*gyrotropic_nfreq, 'SUM') + call comms_reduce(gyro_NOA_orb(1, 1, 1, 1), 3*3*fermi_n*pw90_gyrotropic%nfreq, 'SUM', stdout, & + seedname, comm) + if (eval_spn) call comms_reduce(gyro_NOA_spn(1, 1, 1, 1), 3*3*fermi_n*pw90_gyrotropic%nfreq, & + 'SUM', stdout, seedname, comm) endif - if (on_root) then + if (print_output%iprint > 0) then - if (timing_level > 1) call io_stopwatch('gyrotropic: k-interpolation', 2) + if (print_output%timing_level > 1) call io_stopwatch('gyrotropic: k-interpolation', 2, & + stdout, seedname) write (stdout, '(1x,a)') ' ' write (stdout, *) 'Calculation finished, writing results' flush(stdout) @@ -310,16 +387,17 @@ subroutine gyrotropic_main ! * Divide by V_c in Ang^3 to get a quantity with units of [L]^{-2} ! * Multiply by 10^20 to convert to SI ! * Multiply by -g_s.e.hbar/(4m_e) \simeq e.hbar/(2.m_e) in SI units - ! ============================== + !================================================== ! fac = 10^20*e*hbar/(2.m_e.V_c) - ! ============================== - fac = -1.0e20_dp*elem_charge_SI*hbar_SI/(2.*elec_mass_SI*cell_volume) + !================================================== + fac = -1.0e20_dp*physics%elem_charge_SI*physics%hbar_SI/(2.*physics%elec_mass_SI & + *cell_volume) gyro_K_spn(:, :, :) = gyro_K_spn(:, :, :)*fac f_out_name_tmp = 'K_spin' units_tmp = "Ampere" comment_tmp = "spin part of the K tensor -- Eq. 3 of TAS17" - call gyrotropic_outprint_tensor(f_out_name_tmp, arrEf=gyro_K_spn, units=units_tmp, & - comment=comment_tmp) + call gyrotropic_outprint_tensor(stdout, seedname, pw90_gyrotropic, fermi_energy_list, f_out_name_tmp, & + arrEf=gyro_K_spn, units=units_tmp, comment=comment_tmp) endif ! eval_K && eval_spin ! At this point gme_orb_list contains @@ -332,17 +410,17 @@ subroutine gyrotropic_main ! * Divide by V_c in Ang^3 to get a quantity with units of eV ! * Multiply by 'e' in SI to convert to SI (Joules) ! * Multiply by e/(2.hbar) to get K in Ampere - ! ==================================== + !================================================== ! fac = e^2/(2.hbar.V_c) - ! ==================================== - fac = elem_charge_SI**2/(2.*hbar_SI*cell_volume) + !================================================== + fac = physics%elem_charge_SI**2/(2.*physics%hbar_SI*cell_volume) gyro_K_orb(:, :, :) = gyro_K_orb(:, :, :)*fac f_out_name_tmp = 'K_orb' units_tmp = "Ampere" comment_tmp = "orbital part of the K tensor -- Eq. 3 of TAS17" - call gyrotropic_outprint_tensor(f_out_name_tmp, arrEf=gyro_K_orb, units=units_tmp, & - comment=comment_tmp) + call gyrotropic_outprint_tensor(stdout, seedname, pw90_gyrotropic, fermi_energy_list, f_out_name_tmp, & + arrEf=gyro_K_orb, units=units_tmp, comment=comment_tmp) endif ! eval_K if (eval_D) then @@ -352,8 +430,8 @@ subroutine gyrotropic_main f_out_name_tmp = 'D' units_tmp = "dimensionless" comment_tmp = "the D tensor -- Eq. 2 of TAS17" - call gyrotropic_outprint_tensor(f_out_name_tmp, arrEf=gyro_D, units=units_tmp, & - comment=comment_tmp) + call gyrotropic_outprint_tensor(stdout, seedname, pw90_gyrotropic, fermi_energy_list, f_out_name_tmp, & + arrEf=gyro_D, units=units_tmp, comment=comment_tmp) endif if (eval_Dw) then @@ -363,8 +441,8 @@ subroutine gyrotropic_main f_out_name_tmp = 'tildeD' units_tmp = "dimensionless" comment_tmp = "the tildeD tensor -- Eq. 12 of TAS17" - call gyrotropic_outprint_tensor(f_out_name_tmp, arrEfW=gyro_Dw, units=units_tmp, & - comment=comment_tmp) + call gyrotropic_outprint_tensor(stdout, seedname, pw90_gyrotropic, fermi_energy_list, f_out_name_tmp, & + arrEfW=gyro_Dw, units=units_tmp, comment=comment_tmp) endif if (eval_C) then @@ -379,14 +457,14 @@ subroutine gyrotropic_main ! multiply by 10^8*e in SI to get J/cm ! multiply by e/h in SI ! - fac = 1.0e+8_dp*elem_charge_SI**2/(twopi*hbar_SI*cell_volume) + fac = 1.0e+8_dp*physics%elem_charge_SI**2/(twopi*physics%hbar_SI*cell_volume) gyro_C(:, :, :) = gyro_C(:, :, :)*fac f_out_name_tmp = 'C' units_tmp = "Ampere/cm" comment_tmp = "the C tensor -- Eq. B6 of TAS17" - call gyrotropic_outprint_tensor(f_out_name_tmp, arrEf=gyro_C, units=units_tmp, & - comment=comment_tmp) + call gyrotropic_outprint_tensor(stdout, seedname, pw90_gyrotropic, fermi_energy_list, f_out_name_tmp, & + arrEf=gyro_C, units=units_tmp, comment=comment_tmp) endif if (eval_noa) then @@ -396,13 +474,14 @@ subroutine gyrotropic_main ! * Divide by e in SI to get J^{-1} ! * multiply by e^2/eps_0 to get meters ! *multiply dy 1e10 to get Ang - fac = 1e+10_dp*elem_charge_SI/(cell_volume*eps0_SI) + fac = 1e+10_dp*physics%elem_charge_SI/(cell_volume*physics%eps0_SI) gyro_NOA_orb = gyro_NOA_orb*fac f_out_name_tmp = 'NOA_orb' units_tmp = "Ang" comment_tmp = "the tensor $gamma_{abc}^{orb}$ (Eq. C12,C14 of TAS17)" - call gyrotropic_outprint_tensor(f_out_name_tmp, arrEfW=gyro_NOA_orb, units=units_tmp, & - comment=comment_tmp, symmetrize=.false.) + call gyrotropic_outprint_tensor(stdout, seedname, pw90_gyrotropic, fermi_energy_list, f_out_name_tmp, & + arrEfW=gyro_NOA_orb, units=units_tmp, comment=comment_tmp, & + symmetrize=.false.) if (eval_spn) then ! at this point gyro_NOA_spn is in eV^-2.Ang ! @@ -412,12 +491,13 @@ subroutine gyrotropic_main ! * multiply by e^2/eps_0 to get (J.m)^{-1} ! *multiply dy hbar^2/m_e to get m ! *multiply by 1e10 to get Ang - fac = 1e+30_dp*hbar_SI**2/(cell_volume*eps0_SI*elec_mass_SI) + fac = 1e+30_dp*physics%hbar_SI**2/(cell_volume*physics%eps0_SI*physics%elec_mass_SI) gyro_NOA_spn = gyro_NOA_spn*fac f_out_name_tmp = 'NOA_spin' units_tmp = "Ang" comment_tmp = "the tensor $gamma_{abc}^{spin}$ (Eq. C12,C15 of TAS17)" - call gyrotropic_outprint_tensor(f_out_name_tmp, arrEfW=gyro_NOA_spn, units=units_tmp, & + call gyrotropic_outprint_tensor(stdout, seedname, pw90_gyrotropic, fermi_energy_list, f_out_name_tmp, & + arrEfW=gyro_NOA_spn, units=units_tmp, & comment=comment_tmp, symmetrize=.false.) endif endif !eval_NOA @@ -431,18 +511,23 @@ subroutine gyrotropic_main f_out_name_tmp = 'DOS' units_tmp = "eV^{-1}.Ang^{-3}" comment_tmp = "density of states" - call gyrotropic_outprint_tensor(f_out_name_tmp, arrEf1d=gyro_DOS, units=units_tmp, & - comment=comment_tmp) + call gyrotropic_outprint_tensor(stdout, seedname, pw90_gyrotropic, fermi_energy_list, f_out_name_tmp, & + arrEf1d=gyro_DOS, units=units_tmp, comment=comment_tmp) endif - end if !on_root + end if !print_output%iprint >0, aka "on_root" end subroutine gyrotropic_main - subroutine gyrotropic_get_k_list(kpt, kweight, & - gyro_K_spn, gyro_K_orb, gyro_D, gyro_Dw, gyro_C, & - gyro_DOS, gyro_NOA_orb, gyro_NOA_spn, & - eval_K, eval_D, eval_Dw, eval_NOA, eval_spn, eval_C, eval_dos) + subroutine gyrotropic_get_k_list(ws_region, num_valence_bands, have_disentangled, kpt, kweight, & + gyro_K_spn, gyro_K_orb, gyro_D, gyro_Dw, gyro_C, gyro_DOS, & + gyro_NOA_orb, gyro_NOA_spn, eval_K, eval_D, eval_Dw, eval_NOA, & + eval_spn, eval_C, eval_dos, num_wann, print_output, & + fermi_energy_list, wannier_data, eigval, real_lattice, mp_grid, & + num_bands, num_kpts, u_matrix, v_matrix, dis_manifold, kpt_latt, & + pw90_gyrotropic, scissors_shift, effective_model, pw90_band_deriv_degen, & + ws_distance, wigner_seitz, stdout, seedname, comm, & + HH_R, AA_R, BB_R, CC_R, SS_R) !======================================================================! ! ! ! Contribution from point k to the GME tensor, Eq.(9) of ZMS16, ! @@ -464,43 +549,74 @@ subroutine gyrotropic_get_k_list(kpt, kweight, & ! gyro_C_k = delta(E_kn-E_f).(d E_{kn}/d k_i).(d E_{kn}/d k_j) ! ! [units of energy*length^3] ! ! ! - ! gyro_DOS_k = delta(E_kn-E_f) ! + ! gyro_DOS_k = delta(E_kn-E_f) ! ! [units of 1/Energy] ! ! ! - ! gme_NOA_orb_k = ????? ! + ! gme_NOA_orb_k = ????? ! ! ! - ! gme_NOA_spn_k = ?????? ! + ! gme_NOA_spn_k = ?????? ! ! ! !======================================================================! + use w90_comms, only: w90comm_type, mpirank use w90_constants, only: dp, cmplx_0, cmplx_i - use w90_utility, only: utility_rotate, utility_rotate_diag, utility_w0gauss - use w90_parameters, only: num_wann, fermi_energy_list, & - gyrotropic_smr_index, nfermi, gyrotropic_nfreq, & - gyrotropic_degen_thresh, gyrotropic_smr_max_arg, & - gyrotropic_band_list, gyrotropic_num_bands, & - gyrotropic_smr_fixed_en_width - use w90_postw90_common, only: pw90common_get_occ, & + use w90_io, only: io_error, io_stopwatch, io_file_unit + use w90_postw90_types, only: pw90_gyrotropic_type, pw90_band_deriv_degen_type, wigner_seitz_type + use w90_types, only: dis_manifold_type, print_output_type, & + wannier_data_type, ws_region_type, ws_distance_type + use w90_postw90_common, only: pw90common_fourier_R_to_k_new_second_d, & pw90common_fourier_R_to_k_vec - use w90_wan_ham, only: wham_get_eig_deleig, wham_get_D_h - - use w90_get_oper, only: HH_R, SS_R, AA_R use w90_spin, only: spin_get_S - use w90_io, only: stdout - - ! Arguments - ! - real(kind=dp), intent(in) :: kpt(3), kweight - real(kind=dp), dimension(:, :, :), intent(inout) :: gyro_K_spn, & - gyro_K_orb, & - gyro_D, & - gyro_C - real(kind=dp), dimension(:, :, :, :), intent(inout) :: gyro_Dw, gyro_NOA_spn, gyro_NOA_orb - real(kind=dp), dimension(:), intent(inout) :: gyro_DOS - - logical, intent(in) :: eval_K, eval_D, eval_Dw, & - eval_C, eval_NOA, eval_spn, eval_dos + use w90_utility, only: utility_diagonalize, utility_rotate, utility_rotate_diag, & + utility_w0gauss, utility_recip_lattice_base + use w90_wan_ham, only: wham_get_eig_deleig, wham_get_D_h + implicit none + + ! arguments + type(dis_manifold_type), intent(in) :: dis_manifold + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + type(pw90_gyrotropic_type), intent(in) :: pw90_gyrotropic + real(kind=dp), intent(in) :: kpt_latt(:, :) + type(pw90_band_deriv_degen_type), intent(in) :: pw90_band_deriv_degen + type(print_output_type), intent(in) :: print_output + type(ws_region_type), intent(in) :: ws_region + type(w90comm_type), intent(in) :: comm + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_bands, num_kpts, num_wann, num_valence_bands + integer, intent(in) :: stdout + + real(kind=dp), allocatable, intent(inout) :: gyro_DOS(:) + real(kind=dp), allocatable, intent(inout) :: gyro_Dw(:, :, :, :) + real(kind=dp), allocatable, intent(inout) :: gyro_NOA_spn(:, :, :, :) + real(kind=dp), allocatable, intent(inout) :: gyro_NOA_orb(:, :, :, :) + real(kind=dp), allocatable, intent(inout) :: gyro_K_spn(:, :, :) + real(kind=dp), allocatable, intent(inout) :: gyro_K_orb(:, :, :) + real(kind=dp), allocatable, intent(inout) :: gyro_D(:, :, :) + real(kind=dp), allocatable, intent(inout) :: gyro_C(:, :, :) + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: kpt(3), kweight + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: scissors_shift + + complex(kind=dp), allocatable, intent(inout) :: AA_R(:, :, :, :) + complex(kind=dp), allocatable, intent(inout) :: BB_R(:, :, :, :) + complex(kind=dp), allocatable, intent(inout) :: CC_R(:, :, :, :, :) + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) + complex(kind=dp), intent(in) :: u_matrix(:, :, :), v_matrix(:, :, :) + + character(len=50), intent(in) :: seedname + + logical, intent(in) :: eval_K, eval_D, eval_Dw, eval_C, eval_NOA, eval_spn, eval_dos + logical, intent(in) :: have_disentangled + logical, intent(in) :: effective_model + + ! local variables complex(kind=dp), allocatable :: UU(:, :) complex(kind=dp), allocatable :: HH(:, :) complex(kind=dp), allocatable :: delHH(:, :, :) @@ -510,7 +626,7 @@ subroutine gyrotropic_get_k_list(kpt, kweight, & real(kind=dp), allocatable :: curv_w_nk(:, :, :) - integer :: i, j, n, n1, m1, m, ifermi + integer :: i, j, n, n1, ifermi, fermi_n real(kind=dp) :: delta, occ(num_wann), & eig(num_wann), del_eig(num_wann, 3), & S(num_wann, 3), eta_smr, arg, & @@ -518,6 +634,10 @@ subroutine gyrotropic_get_k_list(kpt, kweight, & imf_k(3, 3, 1), img_k(3, 3, 1), imh_k(3, 3, 1) logical :: got_spin, got_orb_n + if (pw90_gyrotropic%smearing%use_adaptive) then + call io_error('Adaptive smearing not allowed in Gyrotropic', stdout, seedname) + endif + allocate (UU(num_wann, num_wann)) allocate (HH(num_wann, num_wann)) allocate (delHH(num_wann, num_wann, 3)) @@ -525,51 +645,59 @@ subroutine gyrotropic_get_k_list(kpt, kweight, & if (eval_spn) allocate (SS(num_wann, num_wann, 3)) - call wham_get_eig_deleig(kpt, eig, del_eig, HH, delHH, UU) + call wham_get_eig_deleig(dis_manifold, kpt_latt, pw90_band_deriv_degen, ws_region, print_output, wannier_data, & + ws_distance, wigner_seitz, delHH, HH, HH_R, u_matrix, UU, v_matrix, & + del_eig, eig, eigval, kpt, real_lattice, scissors_shift, mp_grid, & + num_bands, num_kpts, num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm) if (eval_Dw .or. eval_NOA) then allocate (AA(num_wann, num_wann, 3)) - call wham_get_D_h(delHH, UU, eig, D_h) - call pw90common_fourier_R_to_k_vec(kpt, AA_R, OO_true=AA) + call wham_get_D_h(delHH, D_h, UU, eig, num_wann) + call pw90common_fourier_R_to_k_vec(ws_region, wannier_data, ws_distance, wigner_seitz, AA_R, kpt, & + real_lattice, mp_grid, num_wann, seedname, & + stdout, OO_true=AA) do i = 1, 3 AA(:, :, i) = utility_rotate(AA(:, :, i), UU, num_wann) enddo AA = AA + cmplx_i*D_h ! Eq.(25) WYSV06 endif - if (eval_Dw) allocate (curv_w_nk(num_wann, gyrotropic_nfreq, 3)) + if (eval_Dw) allocate (curv_w_nk(num_wann, pw90_gyrotropic%nfreq, 3)) - eta_smr = gyrotropic_smr_fixed_en_width + eta_smr = pw90_gyrotropic%smearing%fixed_width got_spin = .false. - do n1 = 1, gyrotropic_num_bands - n = gyrotropic_band_list(n1) + do n1 = 1, pw90_gyrotropic%num_bands + n = pw90_gyrotropic%band_list(n1) ! ! ***ADJUSTABLE PARAMETER*** ! avoid degeneracies !--------------------------------------------------- if (n > 1) then - if (eig(n) - eig(n - 1) <= gyrotropic_degen_thresh) cycle + if (eig(n) - eig(n - 1) <= pw90_gyrotropic%degen_thresh) cycle endif if (n < num_wann) then - if (eig(n + 1) - eig(n) <= gyrotropic_degen_thresh) cycle + if (eig(n + 1) - eig(n) <= pw90_gyrotropic%degen_thresh) cycle endif !--------------------------------------------------- + fermi_n = size(fermi_energy_list) got_orb_n = .false. - do ifermi = 1, nfermi + do ifermi = 1, fermi_n arg = (eig(n) - fermi_energy_list(ifermi))/eta_smr ! ! To save time: far from the Fermi surface, negligible contribution ! !------------------------- - if (abs(arg) > gyrotropic_smr_max_arg) cycle + if (abs(arg) > pw90_gyrotropic%smearing%max_arg) cycle !------------------------- ! ! Spin is computed for all bands simultaneously ! if (eval_spn .and. .not. got_spin) then - call spin_get_S(kpt, S) + call spin_get_S(kpt, S, num_wann, ws_region, wannier_data, real_lattice, & + mp_grid, ws_distance, HH_R, SS_R, wigner_seitz, stdout, seedname) got_spin = .true. ! Do it for only one value of ifermi and n endif ! Orbital quantities are computed for each band separately @@ -578,7 +706,14 @@ subroutine gyrotropic_get_k_list(kpt, kweight, & ! Fake occupations: band n occupied, others empty occ = 0.0_dp occ(n) = 1.0_dp - call berry_get_imfgh_klist(kpt, imf_k, img_k, imh_k, occ) + + call berry_get_imfgh_klist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, & + print_output, wannier_data, ws_distance, wigner_seitz, AA_R, BB_R, CC_R, & + HH_R, u_matrix, v_matrix, eigval, kpt, real_lattice, & + scissors_shift, mp_grid, fermi_n, num_bands, & + num_kpts, num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm, imf_k, img_k, & + imh_k, occ) do i = 1, 3 orb_nk(i) = sum(imh_k(:, i, 1)) - sum(img_k(:, i, 1)) curv_nk(i) = sum(imf_k(:, i, 1)) @@ -586,19 +721,26 @@ subroutine gyrotropic_get_k_list(kpt, kweight, & else if (eval_D) then occ = 0.0_dp occ(n) = 1.0_dp - call berry_get_imf_klist(kpt, imf_k, occ) + + call berry_get_imf_klist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, print_output, & + wannier_data, ws_distance, wigner_seitz, AA_R, BB_R, CC_R, HH_R, & + u_matrix, v_matrix, eigval, kpt, real_lattice, & + imf_k, scissors_shift, mp_grid, num_bands, num_kpts, & + num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm, occ) do i = 1, 3 curv_nk(i) = sum(imf_k(:, i, 1)) enddo got_orb_n = .true. ! Do it for only one value of ifermi endif - if (eval_Dw) call gyrotropic_get_curv_w_k(eig, AA, curv_w_nk) + if (eval_Dw) call gyrotropic_get_curv_w_k(eig, AA, curv_w_nk, pw90_gyrotropic) got_orb_n = .true. ! Do it for only one value of ifermi endif ! - delta = utility_w0gauss(arg, gyrotropic_smr_index)/eta_smr*kweight ! Broadened delta(E_nk-E_f) + delta = utility_w0gauss(arg, pw90_gyrotropic%smearing%type_index, stdout, seedname) & + /eta_smr*kweight ! Broadened delta(E_nk-E_f) ! ! Loop over Cartesian tensor components ! @@ -625,48 +767,56 @@ subroutine gyrotropic_get_k_list(kpt, kweight, & if (eval_NOA) then if (eval_spn) then - call gyrotropic_get_NOA_k(kpt, kweight, eig, del_eig, AA, UU, gyro_NOA_orb, gyro_NOA_spn) + call gyrotropic_get_NOA_k(ws_region, kpt, kweight, eig, del_eig, AA, UU, gyro_NOA_orb, & + num_wann, print_output, fermi_energy_list, wannier_data, real_lattice, & + mp_grid, pw90_gyrotropic, ws_distance, wigner_seitz, stdout, & + seedname, SS_R, gyro_NOA_spn) else - call gyrotropic_get_NOA_k(kpt, kweight, eig, del_eig, AA, UU, gyro_NOA_orb) + call gyrotropic_get_NOA_k(ws_region, kpt, kweight, eig, del_eig, AA, UU, gyro_NOA_orb, & + num_wann, print_output, fermi_energy_list, wannier_data, real_lattice, & + mp_grid, pw90_gyrotropic, ws_distance, wigner_seitz, stdout, seedname, SS_R) endif endif end subroutine gyrotropic_get_k_list - subroutine gyrotropic_get_curv_w_k(eig, AA, curv_w_k) - !======================================================================! - ! ! - ! calculation of the band-resolved ! - ! frequency-dependent berry curvature ! - ! ! - ! tildeOmega(w)= ! - ! -eps_{bcd}sum_m ( w_mn^2/(wmn^2-w^2)) *Im[A_{nm,c}A_{mn,d} ! - ! ! - !======================================================================! + subroutine gyrotropic_get_curv_w_k(eig, AA, curv_w_k, pw90_gyrotropic) + !================================================! + ! + ! calculation of the band-resolved + ! frequency-dependent berry curvature + ! + ! tildeOmega(w)= + ! -eps_{bcd}sum_m ( w_mn^2/(wmn^2-w^2)) *Im[A_{nm,c}A_{mn,d} + ! + !================================================! + use w90_postw90_types, only: pw90_gyrotropic_type use w90_constants, only: dp - use w90_parameters, only: num_wann, gyrotropic_nfreq, gyrotropic_freq_list, & - gyrotropic_band_list, gyrotropic_num_bands - ! Arguments - ! - real(kind=dp), intent(in) :: eig(:) - complex(kind=dp), intent(in) :: AA(:, :, :) - real(kind=dp), dimension(:, :, :), intent(out) :: curv_w_k ! (num_wann,n_freq,3) + implicit none + + ! arguments + type(pw90_gyrotropic_type), intent(in) :: pw90_gyrotropic + real(kind=dp), intent(in) :: eig(:) + real(kind=dp), intent(out) :: curv_w_k(:, :, :) ! (num_wann,n_freq,3) + complex(kind=dp), intent(in) :: AA(:, :, :) + + ! local variables real(kind=dp), allocatable :: multWre(:) integer :: i, n, m, n1, m1 real(kind=dp) :: wmn - allocate (multWre(gyrotropic_nfreq)) + allocate (multWre(pw90_gyrotropic%nfreq)) curv_w_k(:, :, :) = 0_dp - do n1 = 1, gyrotropic_num_bands - n = gyrotropic_band_list(n1) - do m1 = 1, gyrotropic_num_bands - m = gyrotropic_band_list(m1) + do n1 = 1, pw90_gyrotropic%num_bands + n = pw90_gyrotropic%band_list(n1) + do m1 = 1, pw90_gyrotropic%num_bands + m = pw90_gyrotropic%band_list(m1) if (n == m) cycle wmn = eig(m) - eig(n) - multWre(:) = real(wmn**2/(wmn**2 - gyrotropic_freq_list(:)**2)) + multWre(:) = real(wmn**2/(wmn**2 - pw90_gyrotropic%freq_list(:)**2)) do i = 1, 3 curv_w_k(n, :, i) = curv_w_k(n, :, i) - & 2_dp*aimag(AA(n, m, alpha_A(i))*AA(m, n, beta_A(i)))*multWre @@ -676,104 +826,121 @@ subroutine gyrotropic_get_curv_w_k(eig, AA, curv_w_k) end subroutine gyrotropic_get_curv_w_k - subroutine gyrotropic_get_NOA_k(kpt, kweight, eig, del_eig, AA, UU, gyro_NOA_orb, gyro_NOA_spn) - !====================================================================! - ! ! - ! Contribution from point k to the real (antisymmetric) part ! - ! of the natural complex interband optical conductivity ! - ! ! + subroutine gyrotropic_get_NOA_k(ws_region, kpt, kweight, eig, del_eig, AA, UU, gyro_NOA_orb, & + num_wann, print_output, fermi_energy_list, wannier_data, real_lattice, & + mp_grid, pw90_gyrotropic, ws_distance, wigner_seitz, stdout, seedname, & + SS_R, gyro_NOA_spn) + !================================================! + ! + ! Contribution from point k to the real (antisymmetric) part + ! of the natural complex interband optical conductivity + ! ! Re gyro_NOA_orb = SUM_{n,l}^{oe} hbar^{-2}/(w_nl^2-w^2) * ! Re ( A_lnb Bnlac -Alna Bnlbc) ! -SUM_{n,l}^{oe} hbar^{-2}(3*w_ln^2-w^2)/(w_nl^2-w^2)^2 * ! Im ( A_lnb Bnlac -Alna Bnlac)nm_a A_mn_b ) - ! [units of Ang^3/eV] ! + ! [units of Ang^3/eV] - ! [units of Ang^3] ! + ! [units of Ang^3] ! Re gyro_NOA_spn_{ab,c} = SUM_{n,l}^{oe} hbar^{-2}/(w_nl^2-w^2) * ! Re ( A_lnb Bnlac -Alna Bnlbc) - ! [units of Ang/eV^2] ! + ! [units of Ang/eV^2] ! ! here a,b defined as epsilon_{abd}=1 (and NOA_dc tensor is saved) ! - !====================================================================! - - use w90_constants, only: dp, cmplx_0, cmplx_i, pi, cmplx_1 - use w90_utility, only: utility_rotate - use w90_parameters, only: num_wann, gyrotropic_nfreq, gyrotropic_freq_list, & - fermi_energy_list, nfermi, gyrotropic_eigval_max, & - gyrotropic_num_bands, gyrotropic_band_list, iprint - - use w90_comms, only: on_root - use w90_io, only: stdout, io_time, io_error + !================================================! + use w90_postw90_types, only: pw90_gyrotropic_type, wigner_seitz_type + use w90_constants, only: dp, cmplx_1 + use w90_io, only: io_time, io_error + use w90_types, only: print_output_type, wannier_data_type, ws_region_type, & + ws_distance_type use w90_postw90_common, only: pw90common_fourier_R_to_k_new - use w90_get_oper, only: SS_R use w90_spin, only: spin_get_S + use w90_utility, only: utility_rotate - ! Arguments - ! - real(kind=dp), intent(in) :: kpt(3), kweight - real(kind=dp), dimension(:, :, :, :), optional, intent(inout) :: gyro_NOA_spn - real(kind=dp), dimension(:, :, :, :), intent(inout) :: gyro_NOA_orb - complex(kind=dp), dimension(:, :, :), intent(in) :: AA - complex(kind=dp), dimension(:, :), intent(in) :: UU - real(kind=dp), dimension(:), intent(in) :: eig - real(kind=dp), dimension(:, :), intent(in) :: del_eig - - complex(kind=dp), allocatable :: Bnl_orb(:, :, :, :) - complex(kind=dp), allocatable :: Bnl_spin(:, :, :, :) - complex(kind=dp), allocatable :: SS(:, :, :) - complex(kind=dp), allocatable :: S_h(:, :, :) - - complex(kind=dp) :: multW1(gyrotropic_nfreq) - real(kind=dp) :: multWe(gyrotropic_nfreq), multWm(gyrotropic_nfreq) - + implicit none + + ! arguments + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + type(pw90_gyrotropic_type), intent(in) :: pw90_gyrotropic + type(print_output_type), intent(in) :: print_output + type(ws_region_type), intent(in) :: ws_region + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: del_eig(:, :) + real(kind=dp), intent(in) :: eig(:) + real(kind=dp), intent(inout) :: gyro_NOA_orb(:, :, :, :) + real(kind=dp), intent(inout), optional :: gyro_NOA_spn(:, :, :, :) + real(kind=dp), intent(in) :: kpt(3), kweight + real(kind=dp), intent(in) :: real_lattice(3, 3) + + character(len=50), intent(in) :: seedname + complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) + complex(kind=dp), intent(in) :: AA(:, :, :) + complex(kind=dp), intent(in) :: UU(:, :) + + ! local variables + integer :: j, n, l, n1, l1, a, b, c, ab, ifermi integer :: num_occ, num_unocc, occ_list(num_wann), unocc_list(num_wann) - real(kind=dp) :: wmn + real(kind=dp) :: wln + real(kind=dp) :: multWe(pw90_gyrotropic%nfreq), multWm(pw90_gyrotropic%nfreq) + complex(kind=dp) :: multW1(pw90_gyrotropic%nfreq) - integer :: i, j, n, l, n1, l1, a, b, c, ab, ifermi - real(kind=dp) :: wln + complex(kind=dp), allocatable :: S_h(:, :, :) + complex(kind=dp), allocatable :: SS(:, :, :) + complex(kind=dp), allocatable :: Bnl_orb(:, :, :, :) + complex(kind=dp), allocatable :: Bnl_spin(:, :, :, :) if (present(gyro_NOA_spn)) then allocate (SS(num_wann, num_wann, 3)) allocate (S_h(num_wann, num_wann, 3)) do j = 1, 3 ! spin direction - call pw90common_fourier_R_to_k_new(kpt, SS_R(:, :, :, j), OO=SS(:, :, j)) + call pw90common_fourier_R_to_k_new(ws_region, wannier_data, ws_distance, wigner_seitz, & + SS_R(:, :, :, j), kpt, real_lattice, & + mp_grid, num_wann, seedname, stdout, OO=SS(:, :, j)) S_h(:, :, j) = utility_rotate(SS(:, :, j), UU, num_wann) enddo endif - do ifermi = 1, nfermi + do ifermi = 1, size(fermi_energy_list) num_occ = 0 num_unocc = 0 - do n1 = 1, gyrotropic_num_bands - n = gyrotropic_band_list(n1) + do n1 = 1, pw90_gyrotropic%num_bands + n = pw90_gyrotropic%band_list(n1) if (eig(n) < fermi_energy_list(ifermi)) then num_occ = num_occ + 1 occ_list(num_occ) = n - elseif (eig(n) < gyrotropic_eigval_max) then + elseif (eig(n) < pw90_gyrotropic%eigval_max) then num_unocc = num_unocc + 1 unocc_list(num_unocc) = n endif enddo if (num_occ == 0) then - if (iprint .ge. 2) & + if (print_output%iprint .ge. 2) & write (stdout, *) "WARNING no occupied bands included in the calculation for kpt=", & kpt, ", EF[", ifermi, "]=", fermi_energy_list(ifermi), "eV" cycle endif if (num_unocc == 0) then - if (iprint .ge. 2) & + if (print_output%iprint .ge. 2) & write (stdout, *) "WARNING no unoccupied bands included in the calculation for kpt=", & kpt, ", EF[", ifermi, "]=", fermi_energy_list(ifermi), "eV" cycle endif allocate (Bnl_orb(num_occ, num_unocc, 3, 3)) - call gyrotropic_get_NOA_Bnl_orb(eig, del_eig, AA, num_occ, occ_list, num_unocc, unocc_list, Bnl_orb) + call gyrotropic_get_NOA_Bnl_orb(eig, del_eig, AA, num_occ, occ_list, num_unocc, unocc_list, & + Bnl_orb, pw90_gyrotropic) if (present(gyro_NOA_spn)) then allocate (Bnl_spin(num_occ, num_unocc, 3, 3)) @@ -786,7 +953,7 @@ subroutine gyrotropic_get_NOA_k(kpt, kweight, eig, del_eig, AA, UU, gyro_NOA_orb l = unocc_list(l1) wln = eig(l) - eig(n) - multW1(:) = cmplx_1/(wln*wln - gyrotropic_freq_list(:)**2) + multW1(:) = cmplx_1/(wln*wln - pw90_gyrotropic%freq_list(:)**2) multWm(:) = real(multW1)*kweight multWe(:) = real(-multW1(:)*(2*wln**2*multW1(:) + cmplx_1))*kweight do ab = 1, 3 @@ -795,13 +962,15 @@ subroutine gyrotropic_get_NOA_k(kpt, kweight, eig, del_eig, AA, UU, gyro_NOA_orb do c = 1, 3 gyro_NOA_orb(ab, c, ifermi, :) = & gyro_NOA_orb(ab, c, ifermi, :) + & - multWm(:)*real(AA(l, n, b)*Bnl_orb(n1, l1, a, c) - AA(l, n, a)*Bnl_orb(n1, l1, b, c)) + & + multWm(:)*real(AA(l, n, b)*Bnl_orb(n1, l1, a, c) - & + AA(l, n, a)*Bnl_orb(n1, l1, b, c)) + & multWe(:)*(del_eig(n, c) + del_eig(l, c))*aimag(AA(n, l, a)*AA(l, n, b)) if (present(gyro_NOA_spn)) & gyro_NOA_spn(ab, c, ifermi, :) = & gyro_NOA_spn(ab, c, ifermi, :) + & - multWm(:)*real(AA(l, n, b)*Bnl_spin(n1, l1, a, c) - AA(l, n, a)*Bnl_spin(n1, l1, b, c)) + multWm(:)*real(AA(l, n, b)*Bnl_spin(n1, l1, a, c) - & + AA(l, n, a)*Bnl_spin(n1, l1, b, c)) enddo ! c enddo ! ab @@ -813,30 +982,33 @@ subroutine gyrotropic_get_NOA_k(kpt, kweight, eig, del_eig, AA, UU, gyro_NOA_orb end subroutine gyrotropic_get_NOA_k - subroutine gyrotropic_get_NOA_Bnl_orb(eig, del_eig, AA, & - num_occ, occ_list, num_unocc, unocc_list, Bnl) - !====================================================================! - ! ! - ! Calculating the matrix ! - ! B_{nl,ac}(num_occ,num_unocc,3,3)= ! - ! -sum_m( (E_m-E_n)A_nma*Amlc +(E_l-E_m)A_nmc*A_mla - ! - ! -i( del_a (E_n+E_l) A_nlc ! - ! in units eV*Ang^2 ! - !====================================================================! - + subroutine gyrotropic_get_NOA_Bnl_orb(eig, del_eig, AA, num_occ, occ_list, num_unocc, & + unocc_list, Bnl, pw90_gyrotropic) + !================================================! + ! + ! Calculating the matrix + ! B_{nl,ac}(num_occ,num_unocc,3,3)= + ! -sum_m( (E_m-E_n)A_nma*Amlc +(E_l-E_m)A_nmc*A_mla - + ! -i( del_a (E_n+E_l) A_nlc + ! in units eV*Ang^2 + !================================================! + + use w90_postw90_types, only: pw90_gyrotropic_type use w90_constants, only: dp, cmplx_i, cmplx_0 - use w90_parameters, only: gyrotropic_num_bands, gyrotropic_band_list - ! Arguments - ! - integer, intent(in) ::num_occ, num_unocc - integer, dimension(:), intent(in) ::occ_list, unocc_list - real(kind=dp), dimension(:), intent(in) ::eig ! n - real(kind=dp), dimension(:, :), intent(in) ::del_eig ! n - complex(kind=dp), dimension(:, :, :), intent(in) ::AA ! n,l,a - complex(kind=dp), dimension(:, :, :, :), intent(out)::Bnl ! n,l,a,c - integer n, m, l, a, c, n1, m1, l1 + implicit none + + ! arguments + type(pw90_gyrotropic_type), intent(in) :: pw90_gyrotropic + integer, intent(in) :: num_occ, num_unocc + integer, intent(in) :: occ_list(:), unocc_list(:) + real(kind=dp), intent(in) :: eig(:) ! n + real(kind=dp), intent(in) :: del_eig(:, :) ! n + complex(kind=dp), intent(in) :: AA(:, :, :) ! n,l,a + complex(kind=dp), intent(out) :: Bnl(:, :, :, :) ! n,l,a,c + ! local variables + integer n, m, l, a, c, n1, m1, l1 Bnl(:, :, :, :) = cmplx_0 do a = 1, 3 @@ -846,8 +1018,8 @@ subroutine gyrotropic_get_NOA_Bnl_orb(eig, del_eig, AA, & do l1 = 1, num_unocc l = unocc_list(l1) Bnl(n1, l1, a, c) = -cmplx_i*(del_eig(n, a) + del_eig(l, a))*AA(n, l, c) - do m1 = 1, gyrotropic_num_bands - m = gyrotropic_band_list(m1) + do m1 = 1, pw90_gyrotropic%num_bands + m = pw90_gyrotropic%band_list(m1) Bnl(n1, l1, a, c) = Bnl(n1, l1, a, c) + & (eig(n) - eig(m))*AA(n, m, a)*AA(m, l, c) - & (eig(l) - eig(m))*AA(n, m, c)*AA(m, l, a) @@ -859,24 +1031,26 @@ subroutine gyrotropic_get_NOA_Bnl_orb(eig, del_eig, AA, & end subroutine gyrotropic_get_NOA_Bnl_orb - subroutine gyrotropic_get_NOA_Bnl_spin(S_h, & - num_occ, occ_list, num_unocc, unocc_list, Bnl) - !====================================================================! - ! ! - ! Calculating the matrix ! - ! B_{nl,ac}^spin(num_occ,num_unocc,3,3)= ! - ! -i eps_{abc} < u_n | sigma_b | u_l > ! - ! ( dimensionless ) ! - !====================================================================! + subroutine gyrotropic_get_NOA_Bnl_spin(S_h, num_occ, occ_list, num_unocc, unocc_list, Bnl) + !================================================! + ! + ! Calculating the matrix + ! B_{nl,ac}^spin(num_occ,num_unocc,3,3)= + ! -i eps_{abc} < u_n | sigma_b | u_l > + ! ( dimensionless ) + !================================================! use w90_constants, only: dp, cmplx_i, cmplx_0 - ! Arguments - ! - integer, intent(in) ::num_occ, num_unocc - integer, dimension(:), intent(in) ::occ_list, unocc_list - complex(kind=dp), dimension(:, :, :), intent(in) ::S_h ! n,l,a - complex(kind=dp), dimension(:, :, :, :), intent(out)::Bnl ! n,l,a,c + implicit none + + ! arguments + integer, intent(in) :: num_occ, num_unocc + integer, intent(in) :: occ_list(:), unocc_list(:) + complex(kind=dp), intent(in) :: S_h(:, :, :) ! n,l,a + complex(kind=dp), intent(out) :: Bnl(:, :, :, :) ! n,l,a,c + + ! local variables integer n, l, a, b, c, n1, l1 Bnl(:, :, :, :) = cmplx_0 @@ -897,21 +1071,35 @@ subroutine gyrotropic_get_NOA_Bnl_spin(S_h, & end subroutine gyrotropic_get_NOA_Bnl_spin - subroutine gyrotropic_outprint_tensor(f_out_name, arrEf, arrEF1D, arrEfW, units, comment, symmetrize) - use w90_parameters, only: gyrotropic_nfreq, gyrotropic_freq_list, & - nfermi, fermi_energy_list - use w90_io, only: io_file_unit, seedname, stdout + subroutine gyrotropic_outprint_tensor(stdout, seedname, pw90_gyrotropic, fermi_energy_list, & + f_out_name, arrEf, arrEF1D, arrEfW, units, comment, & + symmetrize) + !================================================! + + use w90_postw90_types, only: pw90_gyrotropic_type + use w90_io, only: io_file_unit + + implicit none + + ! arguments + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + type(pw90_gyrotropic_type), intent(in) :: pw90_gyrotropic + + integer, intent(in) :: stdout + real(kind=dp), intent(in), optional :: arrEf(:, :, :) + real(kind=dp), intent(in), optional :: arrEfW(:, :, :, :) + real(kind=dp), intent(in), optional :: arrEf1D(:) character(len=30), intent(in) :: f_out_name + character(len=50), intent(in) :: seedname character(len=30), intent(in), optional :: units character(len=120), intent(in), optional :: comment - real(kind=dp), dimension(:, :, :), intent(in), optional :: arrEf - real(kind=dp), dimension(:, :, :, :), intent(in), optional :: arrEfW - real(kind=dp), dimension(:), intent(in), optional :: arrEf1D + logical, optional, intent(in) :: symmetrize + ! local variables character(len=120) :: file_name - integer :: i, file_unit + integer :: i, file_unit, fermi_n logical :: lsym lsym = .true. @@ -928,37 +1116,48 @@ subroutine gyrotropic_outprint_tensor(f_out_name, arrEf, arrEF1D, arrEfW, units, if (present(comment)) write (file_unit, *) "#"//trim(comment) if (present(units)) write (file_unit, *) "# in units of [ "//trim(units)//" ] " + fermi_n = size(fermi_energy_list) if (present(arrEf)) then - call gyrotropic_outprint_tensor_w(file_unit, 0.0_dp, arr33N=arrEf, symmetrize=lsym) + call gyrotropic_outprint_tensor_w(fermi_energy_list, fermi_n, file_unit, 0.0_dp, arr33N=arrEf, symmetrize=lsym) elseif (present(arrEfW)) then - do i = 1, gyrotropic_nfreq - call gyrotropic_outprint_tensor_w(file_unit, real(gyrotropic_freq_list(i)), arr33N=arrEfW(:, :, :, i), symmetrize=lsym) + do i = 1, pw90_gyrotropic%nfreq + call gyrotropic_outprint_tensor_w(fermi_energy_list, fermi_n, file_unit, real(pw90_gyrotropic%freq_list(i)), & + arr33N=arrEfW(:, :, :, i), symmetrize=lsym) enddo elseif (present(arrEf1D)) then - call gyrotropic_outprint_tensor_w(file_unit, 0.0_dp, arrN=arrEf1D) + call gyrotropic_outprint_tensor_w(fermi_energy_list, fermi_n, file_unit, 0.0_dp, arrN=arrEf1D) endif close (file_unit) end subroutine gyrotropic_outprint_tensor - subroutine gyrotropic_outprint_tensor_w(file_unit, omega, arr33N, arrN, symmetrize) - use w90_parameters, only: nfermi, fermi_energy_list + subroutine gyrotropic_outprint_tensor_w(fermi_energy_list, fermi_n, file_unit, omega, arr33N, & + arrN, symmetrize) + !================================================! + + implicit none + + ! arguments + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) integer, intent(in) :: file_unit real(kind=dp), intent(in) :: omega - real(kind=dp), dimension(:, :, :), optional, intent(in) :: arr33N - real(kind=dp), dimension(:), optional, intent(in) :: arrN + integer, intent(in) :: fermi_n + real(kind=dp), optional, intent(in) :: arr33N(:, :, :) + real(kind=dp), optional, intent(in) :: arrN(:) + ! symmetrize= True - get symmetric and assimetric parts ! symmetrize= False - write the asymmetric (in xy) tensor gamma_{xyz} ! symmetrize not present - write as is logical, optional, intent(in) :: symmetrize - real(kind=dp) :: xx(nfermi), yy(nfermi), zz(nfermi), & - xy(nfermi), xz(nfermi), yz(nfermi), & - x(nfermi), y(nfermi), z(nfermi) - integer :: i - logical lsym + ! local variables + real(kind=dp) :: xx(fermi_n), yy(fermi_n), zz(fermi_n), & + xy(fermi_n), xz(fermi_n), yz(fermi_n), & + x(fermi_n), y(fermi_n), z(fermi_n) + integer :: i + logical :: lsym if (present(arr33N)) then lsym = .false. @@ -999,14 +1198,14 @@ subroutine gyrotropic_outprint_tensor_w(file_unit, omega, arr33N, arrN, symmetri write (file_unit, '(11a15)') '# EFERMI(eV)', "omega(eV)", 'xx', 'yy', 'zz', 'xy', 'xz', 'yz', 'zy', 'xz', 'yx' endif - do i = 1, nfermi + do i = 1, fermi_n write (file_unit, '(11E15.6)') fermi_energy_list(i), omega, xx(i), yy(i), zz(i), xy(i), xz(i), yz(i), x(i), y(i), z(i) enddo endif if (present(arrN)) then write (file_unit, '(2a15)') '# EFERMI(eV) ' - do i = 1, nfermi + do i = 1, fermi_n write (file_unit, '(11E15.6)') fermi_energy_list(i), arrN(i) enddo diff --git a/src/postw90/kpath.F90 b/src/postw90/kpath.F90 index 36eeb69a7..5c581c152 100644 --- a/src/postw90/kpath.F90 +++ b/src/postw90/kpath.F90 @@ -11,6 +11,10 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! w90_kpath: evaluate properties along a path in k-space ! +! ! +!------------------------------------------------------------! module w90_kpath @@ -36,41 +40,93 @@ module w90_kpath contains - !===========================================================! - ! PUBLIC PROCEDURES ! - !===========================================================! - - subroutine k_path + !================================================! + ! PUBLIC PROCEDURES + !================================================! + + subroutine k_path(pw90_berry, dis_manifold, fermi_energy_list, kmesh_info, pw90_kpath, kpt_latt, & + pw90_oper_read, pw90_band_deriv_degen, pw90_spin, ws_region, kpoint_path, pw90_spin_hall, print_output, & + wannier_data, ws_distance, wigner_seitz, AA_R, BB_R, CC_R, HH_R, SH_R, SHR_R, SR_R, & + SS_R, SAA_R, SBB_R, v_matrix, u_matrix, bohr, eigval, real_lattice, & + scissors_shift, mp_grid, fermi_n, num_wann, num_bands, num_kpts, & + num_valence_bands, effective_model, have_disentangled, seedname, stdout, comm) + !================================================! + ! !! Main routine + ! + !================================================! - use w90_comms - use w90_constants, only: dp, cmplx_0, cmplx_i, twopi, eps8 - use w90_io, only: io_error, io_file_unit, seedname, & - io_time, io_stopwatch, stdout - use w90_utility, only: utility_diagonalize + use w90_comms, only: w90comm_type, mpirank, mpisize, comms_array_split, comms_scatterv, & + comms_gatherv, comms_bcast + use w90_constants, only: dp, eps8 + use w90_get_oper, only: get_HH_R, get_AA_R, get_BB_R, get_CC_R, get_SS_R, get_SHC_R + use w90_io, only: io_error, io_file_unit, io_time, io_stopwatch use w90_postw90_common, only: pw90common_fourier_R_to_k - use w90_parameters, only: num_wann, kpath_task, & - bands_num_spec_points, bands_label, & - kpath_bands_colour, nfermi, fermi_energy_list, & - berry_curv_unit, shc_alpha, shc_beta, shc_gamma, kubo_adpt_smr - use w90_get_oper, only: get_HH_R, HH_R, get_AA_R, get_BB_R, get_CC_R, & - get_FF_R, get_SS_R, get_SHC_R + use w90_types, only: kpoint_path_type, print_output_type, wannier_data_type, & + dis_manifold_type, kmesh_info_type, ws_region_type, ws_distance_type + use w90_postw90_types, only: pw90_berry_mod_type, pw90_spin_hall_type, pw90_kpath_mod_type, & + pw90_spin_mod_type, pw90_band_deriv_degen_type, pw90_oper_read_type, wigner_seitz_type + use w90_berry, only: berry_get_imf_klist, berry_get_imfgh_klist, berry_get_shc_klist use w90_spin, only: spin_get_nk - use w90_berry, only: berry_get_imf_klist, berry_get_imfgh_klist, & - berry_get_shc_klist - use w90_constants, only: bohr - - integer, dimension(0:num_nodes - 1) :: counts, displs - - integer :: i, j, n, num_paths, num_spts, loop_path, loop_kpt, & - total_pts, counter, loop_i, dataunit, gnuunit, pyunit, & + use w90_utility, only: utility_diagonalize, utility_recip_lattice_base + + implicit none + + ! arguments + type(pw90_berry_mod_type), intent(in) :: pw90_berry + type(dis_manifold_type), intent(in) :: dis_manifold + type(kmesh_info_type), intent(in) :: kmesh_info + type(pw90_kpath_mod_type), intent(in) :: pw90_kpath + type(pw90_band_deriv_degen_type), intent(in) :: pw90_band_deriv_degen + type(pw90_oper_read_type), intent(in) :: pw90_oper_read + type(pw90_spin_mod_type), intent(in) :: pw90_spin + type(print_output_type), intent(in) :: print_output + type(ws_region_type), intent(in) :: ws_region + type(kpoint_path_type), intent(in) :: kpoint_path + type(pw90_spin_hall_type), intent(in) :: pw90_spin_hall + type(w90comm_type), intent(in) :: comm + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + complex(kind=dp), allocatable, intent(inout) :: AA_R(:, :, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: BB_R(:, :, :, :) ! <0|H(r-R)|R> + complex(kind=dp), allocatable, intent(inout) :: CC_R(:, :, :, :, :) ! <0|r_alpha.H(r-R)_beta|R> + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: SH_R(:, :, :, :) ! <0n|sigma_x,y,z.H|Rm> + complex(kind=dp), allocatable, intent(inout) :: SHR_R(:, :, :, :, :) ! <0n|sigma_x,y,z.H.(r-R)_alpha|Rm> + complex(kind=dp), allocatable, intent(inout) :: SR_R(:, :, :, :, :) ! <0n|sigma_x,y,z.(r-R)_alpha|Rm> + complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) ! <0n|sigma_x,y,z|Rm> + complex(kind=dp), allocatable, intent(inout) :: SAA_R(:, :, :, :, :) !<0n|sigma_x,y,z.(r-R)_alpha|Rm> + complex(kind=dp), allocatable, intent(inout) :: SBB_R(:, :, :, :, :) !<0n|sigma_x,y,z.H.(r-R)_alpha|Rm> + complex(kind=dp), intent(in) :: v_matrix(:, :, :), u_matrix(:, :, :) + + real(kind=dp), intent(in) :: bohr + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: scissors_shift + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + real(kind=dp), intent(in) :: kpt_latt(:, :) + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_wann, num_bands, num_kpts, num_valence_bands, fermi_n + integer, intent(in) :: stdout + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + logical, intent(in) :: effective_model + + ! local variables + real(kind=dp) :: recip_lattice(3, 3), volume + integer :: i, j, n, num_paths, num_spts, loop_kpt, & + total_pts, loop_i, dataunit, gnuunit, pyunit, & my_num_pts real(kind=dp) :: ymin, ymax, kpt(3), spn_k(num_wann), & - imf_k_list(3, 3, nfermi), img_k_list(3, 3, nfermi), & - imh_k_list(3, 3, nfermi), Morb_k(3, 3), & + imf_k_list(3, 3, fermi_n), img_k_list(3, 3, fermi_n), & + imh_k_list(3, 3, fermi_n), Morb_k(3, 3), & range, zmin, zmax - real(kind=dp) :: shc_k_band(num_wann), shc_k_fermi(nfermi) - real(kind=dp), allocatable, dimension(:) :: kpath_len + real(kind=dp) :: shc_k_band(num_wann), shc_k_fermi(fermi_n) + real(kind=dp), allocatable :: kpath_len(:) logical :: plot_bands, plot_curv, plot_morb, plot_shc character(len=120) :: file_name @@ -84,55 +140,94 @@ subroutine k_path shc(:), my_shc(:) character(len=3), allocatable :: glabel(:) + integer, allocatable :: counts(:), displs(:) + logical :: on_root = .false. + integer :: my_node_id, num_nodes + + my_node_id = mpirank(comm) + num_nodes = mpisize(comm) + allocate (counts(0:num_nodes - 1)) + allocate (displs(0:num_nodes - 1)) + if (my_node_id == 0) on_root = .true. + ! Everything is done on the root node (not worthwhile parallelizing) ! However, we still have to read and distribute the data if we ! are in parallel. So calls to get_oper are done on all nodes at the moment - ! - plot_bands = index(kpath_task, 'bands') > 0 - plot_curv = index(kpath_task, 'curv') > 0 - plot_morb = index(kpath_task, 'morb') > 0 - plot_shc = index(kpath_task, 'shc') > 0 + + plot_bands = index(pw90_kpath%task, 'bands') > 0 + plot_curv = index(pw90_kpath%task, 'curv') > 0 + plot_morb = index(pw90_kpath%task, 'morb') > 0 + plot_shc = index(pw90_kpath%task, 'shc') > 0 if (on_root) then - if (plot_shc .or. (plot_bands .and. kpath_bands_colour == 'shc')) then + if (plot_shc .or. (plot_bands .and. pw90_kpath%bands_colour == 'shc')) then ! not allowed to use adpt smr, since adpt smr needs berry_kmesh, ! see line 1837 of berry.F90 - if (kubo_adpt_smr) call io_error( & - 'Error: Must use fixed smearing when plotting spin Hall conductivity') + if (pw90_berry%kubo_smearing%use_adaptive) call io_error( & + 'Error: Must use fixed smearing when plotting spin Hall conductivity', stdout, seedname) end if if (plot_shc) then - if (nfermi == 0) then - call io_error('Error: must specify Fermi energy') - else if (nfermi /= 1) then + if (fermi_n == 0) then + call io_error('Error: must specify Fermi energy', stdout, seedname) + else if (fermi_n /= 1) then call io_error('Error: kpath plot only accept one Fermi energy, ' & - //'use fermi_energy instead of fermi_energy_min') + //'use fermi_energy instead of fermi_energy_min', stdout, seedname) end if end if end if - call k_path_print_info(plot_bands, plot_curv, plot_morb, plot_shc) + call k_path_print_info(plot_bands, plot_curv, plot_morb, plot_shc, fermi_energy_list, pw90_kpath, & + pw90_berry%curv_unit, stdout, seedname, comm) ! Set up the needed Wannier matrix elements - call get_HH_R - if (plot_curv .or. plot_morb) call get_AA_R + + call get_HH_R(dis_manifold, kpt_latt, print_output, wigner_seitz, HH_R, u_matrix, v_matrix, eigval, & + real_lattice, scissors_shift, num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, stdout, comm) + if (plot_curv .or. plot_morb) then + call get_AA_R(pw90_berry, dis_manifold, kmesh_info, kpt_latt, print_output, AA_R, HH_R, v_matrix, & + eigval, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, num_wann, & + effective_model, have_disentangled, seedname, stdout, comm) + endif if (plot_morb) then - call get_BB_R - call get_CC_R + + call get_BB_R(dis_manifold, kmesh_info, kpt_latt, print_output, BB_R, v_matrix, eigval, & + scissors_shift, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, num_wann, & + have_disentangled, seedname, stdout, comm) + + call get_CC_R(dis_manifold, kmesh_info, kpt_latt, print_output, pw90_oper_read, CC_R, v_matrix, & + eigval, scissors_shift, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, & + num_wann, have_disentangled, seedname, stdout, comm) endif - if (plot_shc .or. (plot_bands .and. kpath_bands_colour == 'shc')) then - call get_AA_R - call get_SS_R - call get_SHC_R + if (plot_shc .or. (plot_bands .and. pw90_kpath%bands_colour == 'shc')) then + + call get_AA_R(pw90_berry, dis_manifold, kmesh_info, kpt_latt, print_output, AA_R, HH_R, v_matrix, & + eigval, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, num_wann, & + effective_model, have_disentangled, seedname, stdout, comm) + call get_SS_R(dis_manifold, kpt_latt, print_output, pw90_oper_read, SS_R, v_matrix, eigval, & + wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, num_wann, have_disentangled, & + seedname, stdout, comm) + call get_SHC_R(dis_manifold, kmesh_info, kpt_latt, print_output, pw90_oper_read, pw90_spin_hall, SH_R, & + SHR_R, SR_R, v_matrix, eigval, scissors_shift, wigner_seitz%irvec, wigner_seitz%nrpts, & + num_bands, num_kpts, num_wann, num_valence_bands, have_disentangled, & + seedname, stdout, comm) endif - if (plot_bands .and. kpath_bands_colour == 'spin') call get_SS_R + if (plot_bands .and. pw90_kpath%bands_colour == 'spin') then + call get_SS_R(dis_manifold, kpt_latt, print_output, pw90_oper_read, SS_R, v_matrix, eigval, & + wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, num_wann, have_disentangled, & + seedname, stdout, comm) + end if + num_paths = 0 if (on_root) then + call utility_recip_lattice_base(real_lattice, recip_lattice, volume) ! Determine the number of k-points (total_pts) as well as ! their reciprocal-lattice coordinates long the path (plot_kpoint) ! and their associated horizontal coordinate for the plot (xval) - call k_path_get_points(num_paths, kpath_len, total_pts, xval, plot_kpoint) + call k_path_get_points(num_paths, kpath_len, total_pts, xval, plot_kpoint, kpoint_path, & + recip_lattice, pw90_kpath) ! (paths) num_spts = num_paths + 1 ! number of path endpoints (special pts) else @@ -141,10 +236,11 @@ subroutine k_path end if ! Broadcast number of k-points on the path - call comms_bcast(total_pts, 1) + call comms_bcast(total_pts, 1, stdout, seedname, comm) ! Partition set of k-points into junks - call comms_array_split(total_pts, counts, displs); +! call comms_array_split(total_pts, counts, displs); + call comms_array_split(total_pts, counts, displs, comm) !kpt_lo = displs(my_node_id)+1 !kpt_hi = displs(my_node_id)+counts(my_node_id) my_num_pts = counts(my_node_id) @@ -152,7 +248,7 @@ subroutine k_path ! Distribute coordinates allocate (my_plot_kpoint(3, my_num_pts)) call comms_scatterv(my_plot_kpoint, 3*my_num_pts, & - plot_kpoint, 3*counts, 3*displs) + plot_kpoint, 3*counts, 3*displs, stdout, seedname, comm) ! Value of the vertical coordinate in the actual plots: energy bands ! @@ -160,7 +256,7 @@ subroutine k_path allocate (HH(num_wann, num_wann)) allocate (UU(num_wann, num_wann)) allocate (my_eig(num_wann, my_num_pts)) - if (kpath_bands_colour /= 'none') allocate (my_color(num_wann, my_num_pts)) + if (pw90_kpath%bands_colour /= 'none') allocate (my_color(num_wann, my_num_pts)) end if ! Value of the vertical coordinate in the actual plots @@ -175,14 +271,17 @@ subroutine k_path kpt(:) = my_plot_kpoint(:, loop_kpt) if (plot_bands) then - call pw90common_fourier_R_to_k(kpt, HH_R, HH, 0) - call utility_diagonalize(HH, num_wann, my_eig(:, loop_kpt), UU) + call pw90common_fourier_R_to_k(ws_region, wannier_data, ws_distance, wigner_seitz, HH, HH_R, kpt, & + real_lattice, mp_grid, 0, num_wann, seedname, stdout) + call utility_diagonalize(HH, num_wann, my_eig(:, loop_kpt), UU, stdout, seedname) ! ! Color-code energy bands with the spin projection along the ! chosen spin quantization axis ! - if (kpath_bands_colour == 'spin') then - call spin_get_nk(kpt, spn_k) + if (pw90_kpath%bands_colour == 'spin') then + call spin_get_nk(ws_region, pw90_spin, wannier_data, ws_distance, wigner_seitz, HH_R, SS_R, kpt, & + real_lattice, spn_k, mp_grid, num_wann, seedname, stdout) + my_color(:, loop_kpt) = spn_k(:) ! ! The following is needed to prevent bands from disappearing @@ -196,14 +295,26 @@ subroutine k_path my_color(n, loop_kpt) = -1.0_dp + eps8 end if end do - else if (kpath_bands_colour == 'shc') then - call berry_get_shc_klist(kpt, shc_k_band=shc_k_band) + else if (pw90_kpath%bands_colour == 'shc') then + call berry_get_shc_klist(pw90_berry, dis_manifold, fermi_energy_list, kpt_latt, pw90_band_deriv_degen, & + ws_region, pw90_spin_hall, print_output, wannier_data, ws_distance, wigner_seitz, & + AA_R, HH_R, SH_R, SHR_R, SR_R, SS_R, SAA_R, SBB_R, u_matrix, v_matrix, & + eigval, kpt, real_lattice, scissors_shift, mp_grid, fermi_n, & + num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, stdout, comm, & + shc_k_band=shc_k_band) my_color(:, loop_kpt) = shc_k_band end if end if if (plot_morb) then - call berry_get_imfgh_klist(kpt, imf_k_list, img_k_list, imh_k_list) + call berry_get_imfgh_klist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, print_output, & + wannier_data, ws_distance, wigner_seitz, AA_R, BB_R, CC_R, HH_R, & + u_matrix, v_matrix, eigval, kpt, real_lattice, & + scissors_shift, mp_grid, fermi_n, num_bands, num_kpts, & + num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm, imf_k_list, & + img_k_list, imh_k_list) Morb_k = img_k_list(:, :, 1) + imh_k_list(:, :, 1) & - 2.0_dp*fermi_energy_list(1)*imf_k_list(:, :, 1) Morb_k = -Morb_k/2.0_dp ! differs by -1/2 from Eq.97 LVTS12 @@ -214,7 +325,12 @@ subroutine k_path if (plot_curv) then if (.not. plot_morb) then - call berry_get_imf_klist(kpt, imf_k_list) + call berry_get_imf_klist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, print_output, & + wannier_data, ws_distance, wigner_seitz, AA_R, BB_R, CC_R, HH_R, & + u_matrix, v_matrix, eigval, kpt, real_lattice, & + imf_k_list, scissors_shift, mp_grid, num_bands, num_kpts, & + num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm) end if my_curv(loop_kpt, 1) = sum(imf_k_list(:, 1, 1)) my_curv(loop_kpt, 2) = sum(imf_k_list(:, 2, 1)) @@ -222,7 +338,12 @@ subroutine k_path end if if (plot_shc) then - call berry_get_shc_klist(kpt, shc_k_fermi=shc_k_fermi) + call berry_get_shc_klist(pw90_berry, dis_manifold, fermi_energy_list, kpt_latt, pw90_band_deriv_degen, & + ws_region, pw90_spin_hall, print_output, wannier_data, ws_distance, wigner_seitz, & + AA_R, HH_R, SH_R, SHR_R, SR_R, SS_R, SAA_R, SBB_R, u_matrix, v_matrix, eigval, & + kpt, real_lattice, scissors_shift, mp_grid, fermi_n, num_bands, & + num_kpts, num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm, shc_k_fermi=shc_k_fermi) my_shc(loop_kpt) = shc_k_fermi(1) end if end do !loop_kpt @@ -231,11 +352,11 @@ subroutine k_path if (plot_bands) then allocate (eig(num_wann, total_pts)) call comms_gatherv(my_eig, num_wann*my_num_pts, & - eig, num_wann*counts, num_wann*displs) - if (kpath_bands_colour /= 'none') then + eig, num_wann*counts, num_wann*displs, stdout, seedname, comm) + if (pw90_kpath%bands_colour /= 'none') then allocate (color(num_wann, total_pts)) call comms_gatherv(my_color, num_wann*my_num_pts, & - color, num_wann*counts, num_wann*displs) + color, num_wann*counts, num_wann*displs, stdout, seedname, comm) end if end if @@ -243,7 +364,7 @@ subroutine k_path allocate (curv(total_pts, 3)) do i = 1, 3 call comms_gatherv(my_curv(:, i), my_num_pts, & - curv(:, i), counts, displs) + curv(:, i), counts, displs, stdout, seedname, comm) end do end if @@ -251,13 +372,13 @@ subroutine k_path allocate (morb(total_pts, 3)) do i = 1, 3 call comms_gatherv(my_morb(:, i), my_num_pts, & - morb(:, i), counts, displs) + morb(:, i), counts, displs, stdout, seedname, comm) end do end if if (plot_shc) then allocate (shc(total_pts)) - call comms_gatherv(my_shc, my_num_pts, shc, counts, displs) + call comms_gatherv(my_shc, my_num_pts, shc, counts, displs, stdout, seedname, comm) end if if (on_root) then @@ -279,26 +400,26 @@ subroutine k_path end do close (dataunit) end if - if (plot_curv .and. berry_curv_unit == 'bohr2') curv = curv/bohr**2 + if (plot_curv .and. pw90_berry%curv_unit == 'bohr2') curv = curv/bohr**2 - if (plot_bands .and. kpath_bands_colour == 'shc') then - if (berry_curv_unit == 'bohr2') color = color/bohr**2 + if (plot_bands .and. pw90_kpath%bands_colour == 'shc') then + if (pw90_berry%curv_unit == 'bohr2') color = color/bohr**2 end if if (plot_shc) then - if (berry_curv_unit == 'bohr2') shc = shc/bohr**2 + if (pw90_berry%curv_unit == 'bohr2') shc = shc/bohr**2 end if ! Axis labels ! - glabel(1) = ' '//bands_label(1)//' ' + glabel(1) = ' '//kpoint_path%labels(1)//' ' do i = 2, num_paths - if (bands_label(2*(i - 1)) /= bands_label(2*(i - 1) + 1)) then - glabel(i) = bands_label(2*(i - 1))//'/'//bands_label(2*(i - 1) + 1) + if (kpoint_path%labels(2*(i - 1)) /= kpoint_path%labels(2*(i - 1) + 1)) then + glabel(i) = kpoint_path%labels(2*(i - 1))//'/'//kpoint_path%labels(2*(i - 1) + 1) else - glabel(i) = ' '//bands_label(2*(i - 1))//' ' + glabel(i) = ' '//kpoint_path%labels(2*(i - 1))//' ' end if end do - glabel(num_spts) = ' '//bands_label(bands_num_spec_points)//' ' + glabel(num_spts) = ' '//kpoint_path%labels(num_paths*2)//' ' ! Now write the plotting files @@ -316,7 +437,7 @@ subroutine k_path open (dataunit, file=file_name, form='formatted') do i = 1, num_wann do loop_kpt = 1, total_pts - if (kpath_bands_colour == 'none') then + if (pw90_kpath%bands_colour == 'none') then write (dataunit, '(2E16.8)') xval(loop_kpt), eig(i, loop_kpt) else write (dataunit, '(3E16.8)') xval(loop_kpt), & @@ -343,13 +464,13 @@ subroutine k_path write (gnuunit, 705) sum(kpath_len(1:i)), ymin, & sum(kpath_len(1:i)), ymax end do - if (kpath_bands_colour == 'none') then + if (pw90_kpath%bands_colour == 'none') then write (gnuunit, 701) xval(total_pts), ymin, ymax write (gnuunit, 702, advance="no") glabel(1), 0.0_dp, & (glabel(i + 1), sum(kpath_len(1:i)), i=1, num_paths - 1) write (gnuunit, 703) glabel(1 + num_paths), sum(kpath_len(:)) write (gnuunit, *) 'plot ', '"'//trim(seedname)//'-bands.dat', '"' - else if (kpath_bands_colour == 'spin') then + else if (pw90_kpath%bands_colour == 'spin') then ! ! Only works with gnuplot v4.2 and higher ! @@ -363,7 +484,7 @@ subroutine k_path write (gnuunit, *) 'set zrange [-1:1]' write (gnuunit, *) 'splot ', '"'//trim(seedname)//'-bands.dat', & '" with dots palette' - else if (kpath_bands_colour == 'shc') then + else if (pw90_kpath%bands_colour == 'shc') then ! ! Only works with gnuplot v4.2 and higher ! @@ -399,9 +520,9 @@ subroutine k_path "-bands.dat')" write (pyunit, '(a)') "x=data[:,0]" write (pyunit, '(a)') "y=data[:,1]" - if (kpath_bands_colour == 'spin' & - .or. kpath_bands_colour == 'shc') write (pyunit, '(a)') "z=data[:,2]" - if (kpath_bands_colour == 'shc') write (pyunit, '(a)') & + if (pw90_kpath%bands_colour == 'spin' & + .or. pw90_kpath%bands_colour == 'shc') write (pyunit, '(a)') "z=data[:,2]" + if (pw90_kpath%bands_colour == 'shc') write (pyunit, '(a)') & "z=np.array([np.log10(abs(elem))*np.sign(elem) " & //"if abs(elem)>10 else elem/10.0 for elem in z])" write (pyunit, '(a)') "tick_labels=[]" @@ -420,10 +541,10 @@ subroutine k_path sum(kpath_len(1:j - 1)), ")" end if end do - if (kpath_bands_colour == 'none') then + if (pw90_kpath%bands_colour == 'none') then write (pyunit, '(a)') "pl.scatter(x,y,color='k',marker='+',s=0.1)" - else if (kpath_bands_colour == 'spin' .or. & - kpath_bands_colour == 'shc') then + else if (pw90_kpath%bands_colour == 'spin' .or. & + pw90_kpath%bands_colour == 'shc') then write (pyunit, '(a)') & "pl.scatter(x,y,c=z,marker='+',s=1,cmap=pl.cm.jet)" end if @@ -436,7 +557,7 @@ subroutine k_path //"[pl.ylim()[0],pl.ylim()[1]],color='gray'," & //"linestyle='-',linewidth=0.5)" write (pyunit, '(a)') "pl.ylabel('Energy [eV]')" - if (kpath_bands_colour == 'spin' .or. kpath_bands_colour == 'shc') then + if (pw90_kpath%bands_colour == 'spin' .or. pw90_kpath%bands_colour == 'shc') then write (pyunit, '(a)') & "pl.axes().set_aspect(aspect=0.65*max(x)/(max(y)-min(y)))" write (pyunit, '(a)') "pl.colorbar(shrink=0.7)" @@ -526,10 +647,10 @@ subroutine k_path write (pyunit, '(a)') " pl.plot([tick_locs[n],tick_locs[n]]," & //"[pl.ylim()[0],pl.ylim()[1]],color='gray'," & //"linestyle='-',linewidth=0.5)" - if (berry_curv_unit == 'ang2') then + if (pw90_berry%curv_unit == 'ang2') then write (pyunit, '(a)') "pl.ylabel('$-\Omega_"//achar(119 + i) & //"(\mathbf{k})$ [ $\AA^2$ ]')" - else if (berry_curv_unit == 'bohr2') then + else if (pw90_berry%curv_unit == 'bohr2') then write (pyunit, '(a)') "pl.ylabel('$-\Omega_"//achar(119 + i) & //"(\mathbf{k})$ [ bohr$^2$ ]')" end if @@ -705,15 +826,15 @@ subroutine k_path write (pyunit, '(a)') " pl.plot([tick_locs[n],tick_locs[n]]," & //"[pl.ylim()[0],pl.ylim()[1]],color='gray'," & //"linestyle='-',linewidth=0.5)" - if (berry_curv_unit == 'ang2') then + if (pw90_berry%curv_unit == 'ang2') then write (pyunit, '(a)') "pl.ylabel('$\Omega_{" & - //achar(119 + shc_alpha)//achar(119 + shc_beta) & - //"}^{spin"//achar(119 + shc_gamma) & + //achar(119 + pw90_spin_hall%alpha)//achar(119 + pw90_spin_hall%beta) & + //"}^{spin"//achar(119 + pw90_spin_hall%gamma) & //"}(\mathbf{k})$ [ $\AA^2$ ]')" - else if (berry_curv_unit == 'bohr2') then + else if (pw90_berry%curv_unit == 'bohr2') then write (pyunit, '(a)') "pl.ylabel('$\Omega_{" & - //achar(119 + shc_alpha)//achar(119 + shc_beta) & - //"}^{spin"//achar(119 + shc_gamma) & + //achar(119 + pw90_spin_hall%alpha)//achar(119 + pw90_spin_hall%beta) & + //"}^{spin"//achar(119 + pw90_spin_hall%gamma) & //"}(\mathbf{k})$ [ bohr$^2$ ]')" end if write (pyunit, '(a)') "outfile = '"//trim(seedname)// & @@ -764,15 +885,15 @@ subroutine k_path "-bands.dat')" write (pyunit, '(a)') "x=data[:,0]" write (pyunit, '(a,F12.6)') "y=data[:,1]-", fermi_energy_list(1) - if (kpath_bands_colour == 'spin' .or. kpath_bands_colour == 'shc') & + if (pw90_kpath%bands_colour == 'spin' .or. pw90_kpath%bands_colour == 'shc') & write (pyunit, '(a)') "z=data[:,2]" - if (kpath_bands_colour == 'shc') & + if (pw90_kpath%bands_colour == 'shc') & write (pyunit, '(a)') "z=np.array([np.log10(abs(elem))*np.sign(elem) " & //"if abs(elem)>10 else elem/10.0 for elem in z])" - if (kpath_bands_colour == 'none') then + if (pw90_kpath%bands_colour == 'none') then write (pyunit, '(a)') "pl.scatter(x,y,color='k',marker='+',s=0.1)" - else if (kpath_bands_colour == 'spin' & - .or. kpath_bands_colour == 'shc') then + else if (pw90_kpath%bands_colour == 'spin' & + .or. pw90_kpath%bands_colour == 'shc') then write (pyunit, '(a)') & "pl.scatter(x,y,c=z,marker='+',s=1,cmap=pl.cm.jet)" end if @@ -822,15 +943,15 @@ subroutine k_path write (pyunit, '(a)') " pl.plot([tick_locs[n],tick_locs[n]]," & //"[pl.ylim()[0],pl.ylim()[1]],color='gray'," & //"linestyle='-',linewidth=0.5)" - if (berry_curv_unit == 'ang2') then + if (pw90_berry%curv_unit == 'ang2') then write (pyunit, '(a)') "pl.ylabel('$log_{10}|\Omega_{" & - //achar(119 + shc_alpha)//achar(119 + shc_beta) & - //"}^{spin"//achar(119 + shc_gamma) & + //achar(119 + pw90_spin_hall%alpha)//achar(119 + pw90_spin_hall%beta) & + //"}^{spin"//achar(119 + pw90_spin_hall%gamma) & //"}(\mathbf{k})|$ [ $\AA^2$ ]')" - else if (berry_curv_unit == 'bohr2') then + else if (pw90_berry%curv_unit == 'bohr2') then write (pyunit, '(a)') "pl.ylabel('$\Omega_{" & - //achar(119 + shc_alpha)//achar(119 + shc_beta) & - //"}^{spin"//achar(119 + shc_gamma) & + //achar(119 + pw90_spin_hall%alpha)//achar(119 + pw90_spin_hall%beta) & + //"}^{spin"//achar(119 + pw90_spin_hall%gamma) & //"}(\mathbf{k})$ [ bohr$^2$ ]')" end if write (pyunit, '(a)') "outfile = '"//trim(seedname)// & @@ -882,15 +1003,15 @@ subroutine k_path "-bands.dat')" write (pyunit, '(a)') "x=data[:,0]" write (pyunit, '(a,F12.6)') "y=data[:,1]-", fermi_energy_list(1) - if (kpath_bands_colour == 'spin') write (pyunit, '(a)') "z=data[:,2]" - if (kpath_bands_colour == 'shc') then + if (pw90_kpath%bands_colour == 'spin') write (pyunit, '(a)') "z=data[:,2]" + if (pw90_kpath%bands_colour == 'shc') then write (pyunit, '(a)') "z=data[:,2]" write (pyunit, '(a)') "z=np.array([np.log10(abs(elem))*np.sign(elem) " & //"if abs(elem)>10 else elem/10.0 for elem in z])" end if - if (kpath_bands_colour == 'none') then + if (pw90_kpath%bands_colour == 'none') then write (pyunit, '(a)') "pl.scatter(x,y,color='k',marker='+',s=0.1)" - else if (kpath_bands_colour == 'spin' .or. kpath_bands_colour == 'shc') then + else if (pw90_kpath%bands_colour == 'spin' .or. pw90_kpath%bands_colour == 'shc') then write (pyunit, '(a)') & "pl.scatter(x,y,c=z,marker='+',s=1,cmap=pl.cm.jet)" end if @@ -929,10 +1050,10 @@ subroutine k_path //"[pl.ylim()[0],pl.ylim()[1]],color='gray'," & //"linestyle='-',linewidth=0.5)" if (plot_curv) then - if (berry_curv_unit == 'ang2') then + if (pw90_berry%curv_unit == 'ang2') then write (pyunit, '(a)') "pl.ylabel('$-\Omega_"//achar(119 + i) & //"(\mathbf{k})$ [ $\AA^2$ ]')" - else if (berry_curv_unit == 'bohr2') then + else if (pw90_berry%curv_unit == 'bohr2') then write (pyunit, '(a)') "pl.ylabel('$-\Omega_"//achar(119 + i) & //"(\mathbf{k})$ [ bohr$^2$ ]')" end if @@ -956,7 +1077,7 @@ subroutine k_path 'set xrange [0:', F8.5, ']', /, 'set yrange [', F16.8, ' :', F16.8, ']') 702 format('set xtics (', :20('"', A3, '" ', F8.5, ',')) 703 format(A3, '" ', F8.5, ')') -704 format('set palette defined (', F8.5, ' "red", 0 "green", ', F8.5, ' "blue")') +!704 format('set palette defined (', F8.5, ' "red", 0 "green", ', F8.5, ' "blue")') !not used 705 format('set arrow from ', F16.8, ',', F16.8, ' to ', F16.8, ',', F16.8, ' nohead') 706 format('unset key', /, & 'set xrange [0:', F9.5, ']', /, 'set yrange [', F16.8, ' :', F16.8, ']') @@ -965,16 +1086,30 @@ subroutine k_path end subroutine k_path - !===========================================================! + !================================================! ! PRIVATE PROCEDURES ! - !===========================================================! - subroutine k_path_print_info(plot_bands, plot_curv, plot_morb, plot_shc) - - use w90_comms, only: on_root - use w90_parameters, only: kpath_bands_colour, berry_curv_unit, nfermi - use w90_io, only: stdout, io_error - - logical, intent(in) :: plot_bands, plot_curv, plot_morb, plot_shc + !================================================! + subroutine k_path_print_info(plot_bands, plot_curv, plot_morb, plot_shc, fermi_energy_list, & + pw90_kpath, berry_curv_unit, stdout, seedname, comm) + !================================================! + + use w90_postw90_types, only: pw90_kpath_mod_type + use w90_comms, only: w90comm_type, mpirank + use w90_io, only: io_error + + ! arguments + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + type(pw90_kpath_mod_type), intent(in) :: pw90_kpath + type(w90comm_type), intent(in) :: comm + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + character(len=*), intent(in) :: berry_curv_unit + logical, intent(in) :: plot_bands, plot_curv, plot_morb, plot_shc + + ! local variables + integer :: fermi_n + logical :: on_root = .false. + if (mpirank(comm) == 0) on_root = .true. if (on_root) then write (stdout, '(/,/,1x,a)') & @@ -983,7 +1118,7 @@ subroutine k_path_print_info(plot_bands, plot_curv, plot_morb, plot_shc) '------------------------------------------' if (plot_bands) then - select case (kpath_bands_colour) + select case (pw90_kpath%bands_colour) case ("none") write (stdout, '(/,3x,a)') '* Energy bands in eV' case ("spin") @@ -992,20 +1127,22 @@ subroutine k_path_print_info(plot_bands, plot_curv, plot_morb, plot_shc) write (stdout, '(/,3x,a)') '* Energy bands in eV, coloured by SHC' end select end if + fermi_n = 0 + if (allocated(fermi_energy_list)) fermi_n = size(fermi_energy_list) if (plot_curv) then if (berry_curv_unit == 'ang2') then write (stdout, '(/,3x,a)') '* Negative Berry curvature in Ang^2' else if (berry_curv_unit == 'bohr2') then write (stdout, '(/,3x,a)') '* Negative Berry curvature in Bohr^2' endif - if (nfermi /= 1) call io_error( & - 'Must specify one Fermi level when kpath_task=curv') + if (fermi_n /= 1) call io_error( & + 'Must specify one Fermi level when kpath_task=curv', stdout, seedname) end if if (plot_morb) then write (stdout, '(/,3x,a)') & '* Orbital magnetization k-space integrand in eV.Ang^2' - if (nfermi /= 1) call io_error( & - 'Must specify one Fermi level when kpath_task=morb') + if (fermi_n /= 1) call io_error( & + 'Must specify one Fermi level when kpath_task=morb', stdout, seedname) end if if (plot_shc) then if (berry_curv_unit == 'ang2') then @@ -1015,44 +1152,55 @@ subroutine k_path_print_info(plot_bands, plot_curv, plot_morb, plot_shc) write (stdout, '(/,3x,a)') '* Berry curvature-like term for' & //' spin Hall conductivity in Bohr^2' end if - if (nfermi /= 1) call io_error( & - 'Must specify one Fermi level when kpath_task=shc') + if (fermi_n /= 1) call io_error( & + 'Must specify one Fermi level when kpath_task=shc', stdout, seedname) end if end if ! on_root end subroutine - !===================================================================! - subroutine k_path_get_points(num_paths, kpath_len, total_pts, xval, plot_kpoint) - !===================================================================! + !================================================! + subroutine k_path_get_points(num_paths, kpath_len, total_pts, xval, plot_kpoint, kpoint_path, & + recip_lattice, pw90_kpath) + !================================================! ! Determine the number of k-points (total_pts) as well as ! ! their reciprocal-lattice coordinates long the path (plot_kpoint) ! ! and their associated horizontal coordinate for the plot (xval) ! - !===================================================================! + !================================================! - use w90_parameters, only: kpath_num_points, & - bands_num_spec_points, & - bands_spec_points, & - recip_metric + use w90_postw90_types, only: pw90_kpath_mod_type + use w90_types, only: kpoint_path_type + use w90_utility, only: utility_metric - integer, intent(out) :: num_paths, total_pts - real(kind=dp), allocatable, dimension(:), intent(out) :: kpath_len, xval - real(kind=dp), allocatable, dimension(:, :), intent(out) :: plot_kpoint + ! arguments + type(pw90_kpath_mod_type), intent(in) :: pw90_kpath + type(kpoint_path_type), intent(in) :: kpoint_path + integer, intent(out) :: num_paths, total_pts + real(kind=dp), allocatable, intent(out) :: kpath_len(:), xval(:) + real(kind=dp), allocatable, intent(out) :: plot_kpoint(:, :) + real(kind=dp), intent(in) :: recip_lattice(3, 3) + ! local variables integer :: counter, loop_path, loop_i + integer, allocatable :: kpath_pts(:) + real(kind=dp) :: vec(3) + real(kind=dp) :: recip_metric(3, 3) - integer, allocatable, dimension(:) :: kpath_pts - real(kind=dp) :: vec(3) - + call utility_metric(recip_lattice, recip_metric) ! Work out how many points there are in the total path, and the ! positions of the special points ! - num_paths = bands_num_spec_points/2 ! number of straight line segments + if (allocated(kpoint_path%labels)) then + !num_paths = kpoint_path%bands_num_spec_points/2 ! number of straight line segments + num_paths = size(kpoint_path%labels)/2 + else + num_paths = 0 + endif allocate (kpath_pts(num_paths)) allocate (kpath_len(num_paths)) do loop_path = 1, num_paths - vec = bands_spec_points(:, 2*loop_path) & - - bands_spec_points(:, 2*loop_path - 1) + vec = kpoint_path%points(:, 2*loop_path) & + - kpoint_path%points(:, 2*loop_path - 1) kpath_len(loop_path) = & sqrt(dot_product(vec, (matmul(recip_metric, vec)))) ! @@ -1060,9 +1208,9 @@ subroutine k_path_get_points(num_paths, kpath_len, total_pts, xval, plot_kpoint) ! loop_path (all segments have the same density of points) ! if (loop_path == 1) then - kpath_pts(loop_path) = kpath_num_points + kpath_pts(loop_path) = pw90_kpath%num_points else - kpath_pts(loop_path) = nint(real(kpath_num_points, dp) & + kpath_pts(loop_path) = nint(real(pw90_kpath%num_points, dp) & *kpath_len(loop_path)/kpath_len(1)) end if end do @@ -1089,9 +1237,9 @@ subroutine k_path_get_points(num_paths, kpath_len, total_pts, xval, plot_kpoint) xval(counter) = xval(counter - 1) & + kpath_len(loop_path)/real(kpath_pts(loop_path), dp) end if - plot_kpoint(:, counter) = bands_spec_points(:, 2*loop_path - 1) & - + (bands_spec_points(:, 2*loop_path) & - - bands_spec_points(:, 2*loop_path - 1) & + plot_kpoint(:, counter) = kpoint_path%points(:, 2*loop_path - 1) & + + (kpoint_path%points(:, 2*loop_path) & + - kpoint_path%points(:, 2*loop_path - 1) & ) & *(real(loop_i - 1, dp)/real(kpath_pts(loop_path), dp)) end do @@ -1100,7 +1248,7 @@ subroutine k_path_get_points(num_paths, kpath_len, total_pts, xval, plot_kpoint) ! Last point ! xval(total_pts) = sum(kpath_len) - plot_kpoint(:, total_pts) = bands_spec_points(:, bands_num_spec_points) + plot_kpoint(:, total_pts) = kpoint_path%points(:, num_paths*2) end subroutine diff --git a/src/postw90/kslice.F90 b/src/postw90/kslice.F90 index dbf1baaa7..cfb7d1b66 100644 --- a/src/postw90/kslice.F90 +++ b/src/postw90/kslice.F90 @@ -11,6 +11,10 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! w90_kslice: properties evaluated on isosurface in BZ ! +! ! +!------------------------------------------------------------! module w90_kslice @@ -25,8 +29,8 @@ module w90_kslice !! !! The slice is defined in reduced coordinates by three input variables: !! - !! kslice_corner(1:3) is the lower left corner - !! kslice_b1(1:3) and kslice_b2(1:3) are the vectors subtending the slice + !! pw90_kslice_corner(1:3) is the lower left corner + !! pw90_kslice_b1(1:3) and pw90_kslice_b2(1:3) are the vectors subtending the slice implicit none @@ -36,41 +40,92 @@ module w90_kslice contains - !===========================================================! - ! PUBLIC PROCEDURES ! - !===========================================================! - - subroutine k_slice + !================================================! + ! PUBLIC PROCEDURES + !================================================! + + subroutine k_slice(pw90_berry, dis_manifold, fermi_energy_list, kmesh_info, kpt_latt, pw90_kslice, & + pw90_oper_read, pw90_band_deriv_degen, pw90_spin, ws_region, pw90_spin_hall, print_output, wannier_data, & + ws_distance, wigner_seitz, AA_R, BB_R, CC_R, HH_R, SH_R, SHR_R, SR_R, SS_R, SAA_R, SBB_R, & + v_matrix, u_matrix, bohr, eigval, real_lattice, & + scissors_shift, mp_grid, fermi_n, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, seedname, stdout, comm) + !================================================! + ! !! Main routine + ! + !================================================! - use w90_comms + use w90_postw90_types, only: pw90_kslice_mod_type, pw90_berry_mod_type, pw90_spin_mod_type, & + pw90_band_deriv_degen_type, pw90_oper_read_type, pw90_spin_hall_type, wigner_seitz_type + use w90_berry, only: berry_get_imf_klist, berry_get_imfgh_klist, berry_get_shc_klist + use w90_comms, only: comms_bcast, w90comm_type, mpirank, mpisize, comms_gatherv, comms_array_split use w90_constants, only: dp, twopi, eps8 - use w90_io, only: io_error, io_file_unit, seedname, & - io_time, io_stopwatch, stdout - use w90_utility, only: utility_diagonalize, utility_recip_lattice + use w90_get_oper, only: get_HH_R, get_AA_R, get_BB_R, get_CC_R, get_SS_R, get_SHC_R + use w90_io, only: io_error, io_file_unit, io_time, io_stopwatch + use w90_types, only: dis_manifold_type, kmesh_info_type, print_output_type, & + wannier_data_type, ws_region_type, ws_distance_type use w90_postw90_common, only: pw90common_fourier_R_to_k - use w90_parameters, only: num_wann, kslice, kslice_task, kslice_2dkmesh, & - kslice_corner, kslice_b1, kslice_b2, & - kslice_fermi_lines_colour, recip_lattice, & - nfermi, fermi_energy_list, berry_curv_unit, kubo_adpt_smr - use w90_get_oper, only: get_HH_R, HH_R, get_AA_R, get_BB_R, get_CC_R, & - get_SS_R, get_SHC_R - use w90_wan_ham, only: wham_get_eig_deleig use w90_spin, only: spin_get_nk - use w90_berry, only: berry_get_imf_klist, berry_get_imfgh_klist, berry_get_shc_klist - use w90_constants, only: bohr - - integer, dimension(0:num_nodes - 1) :: counts, displs + use w90_utility, only: utility_diagonalize, utility_recip_lattice, utility_recip_lattice_base + use w90_wan_ham, only: wham_get_eig_deleig + implicit none + + ! arguments + type(pw90_berry_mod_type), intent(in) :: pw90_berry + type(dis_manifold_type), intent(in) :: dis_manifold + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + type(kmesh_info_type), intent(in) :: kmesh_info + real(kind=dp), intent(in) :: kpt_latt(:, :) + type(pw90_kslice_mod_type), intent(in) :: pw90_kslice + type(pw90_band_deriv_degen_type), intent(in) :: pw90_band_deriv_degen + type(pw90_oper_read_type), intent(in) :: pw90_oper_read + type(pw90_spin_mod_type), intent(in) :: pw90_spin + type(print_output_type), intent(in) :: print_output + type(ws_region_type), intent(in) :: ws_region + type(pw90_spin_hall_type), intent(in) :: pw90_spin_hall + type(w90comm_type), intent(in) :: comm + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + complex(kind=dp), allocatable, intent(inout) :: AA_R(:, :, :, :) + complex(kind=dp), allocatable, intent(inout) :: BB_R(:, :, :, :) + complex(kind=dp), allocatable, intent(inout) :: CC_R(:, :, :, :, :) + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: SH_R(:, :, :, :) + complex(kind=dp), allocatable, intent(inout) :: SHR_R(:, :, :, :, :) + complex(kind=dp), allocatable, intent(inout) :: SR_R(:, :, :, :, :) + complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) + complex(kind=dp), allocatable, intent(inout) :: SAA_R(:, :, :, :, :) ! <0n|sigma_x,y,z.(r-R)_alpha|Rm> + complex(kind=dp), allocatable, intent(inout) :: SBB_R(:, :, :, :, :) ! <0n|sigma_x,y,z.H.(r-R)_alpha|Rm> + complex(kind=dp), intent(in) :: v_matrix(:, :, :), u_matrix(:, :, :) + + real(kind=dp), intent(in) :: bohr + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: scissors_shift + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_bands, num_kpts, num_wann, num_valence_bands, fermi_n + integer, intent(in) :: stdout + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + logical, intent(in) :: effective_model + + ! local variables + real(kind=dp) :: recip_lattice(3, 3), volume integer :: iloc, itot, i1, i2, n, n1, n2, n3, i, nkpts, my_nkpts integer :: scriptunit, dataunit, loop_kpt - real(kind=dp) :: avec_2d(3, 3), avec_3d(3, 3), bvec(3, 3), yvec(3), zvec(3), & + real(kind=dp) :: avec_2d(3, 3), bvec(3, 3), yvec(3), zvec(3), & b1mod, b2mod, ymod, cosb1b2, kcorner_cart(3), & areab1b2, cosyb2, kpt(3), kpt_x, kpt_y, k1, k2, & - imf_k_list(3, 3, nfermi), img_k_list(3, 3, nfermi), & - imh_k_list(3, 3, nfermi), Morb_k(3, 3), curv(3), morb(3), & + imf_k_list(3, 3, fermi_n), img_k_list(3, 3, fermi_n), & + imh_k_list(3, 3, fermi_n), Morb_k(3, 3), curv(3), morb(3), & spn_k(num_wann), del_eig(num_wann, 3), Delta_k, Delta_E, & - zhat(3), vdum(3), rdum, shc_k_fermi(nfermi) + zhat(3), vdum(3), rdum, shc_k_fermi(fermi_n) logical :: plot_fermi_lines, plot_curv, plot_morb, & fermi_lines_color, heatmap, plot_shc character(len=120) :: filename, square @@ -87,53 +142,85 @@ subroutine k_slice zdata(:, :), my_zdata(:, :) logical, allocatable :: spnmask(:, :), my_spnmask(:, :) - plot_fermi_lines = index(kslice_task, 'fermi_lines') > 0 - plot_curv = index(kslice_task, 'curv') > 0 - plot_morb = index(kslice_task, 'morb') > 0 - plot_shc = index(kslice_task, 'shc') > 0 - fermi_lines_color = kslice_fermi_lines_colour /= 'none' + integer, allocatable :: counts(:), displs(:) + logical :: on_root = .false. + integer :: my_node_id, num_nodes + + my_node_id = mpirank(comm) + num_nodes = mpisize(comm) + allocate (counts(0:num_nodes - 1)) + allocate (displs(0:num_nodes - 1)) + if (my_node_id == 0) on_root = .true. + + plot_fermi_lines = index(pw90_kslice%task, 'fermi_lines') > 0 + plot_curv = index(pw90_kslice%task, 'curv') > 0 + plot_morb = index(pw90_kslice%task, 'morb') > 0 + plot_shc = index(pw90_kslice%task, 'shc') > 0 + fermi_lines_color = pw90_kslice%fermi_lines_colour /= 'none' heatmap = plot_curv .or. plot_morb .or. plot_shc if (plot_fermi_lines .and. fermi_lines_color .and. heatmap) then call io_error('Error: spin-colored Fermi lines not allowed in ' & - //'curv/morb/shc heatmap plots') + //'curv/morb/shc heatmap plots', stdout, seedname) end if if (plot_shc) then - if (kubo_adpt_smr) then + if (pw90_berry%kubo_smearing%use_adaptive) then call io_error('Error: Must use fixed smearing when plotting ' & - //'spin Hall conductivity') + //'spin Hall conductivity', stdout, seedname) end if - if (nfermi == 0) then - call io_error('Error: must specify Fermi energy') - else if (nfermi /= 1) then + if (fermi_n == 0) then + call io_error('Error: must specify Fermi energy', stdout, seedname) + else if (fermi_n /= 1) then call io_error('Error: kpath plot only accept one Fermi energy, ' & - //'use fermi_energy instead of fermi_energy_min') + //'use fermi_energy instead of fermi_energy_min', stdout, seedname) end if end if if (on_root) then - call kslice_print_info(plot_fermi_lines, fermi_lines_color, & - plot_curv, plot_morb, plot_shc) + call kslice_print_info(plot_fermi_lines, fermi_lines_color, plot_curv, plot_morb, plot_shc, & + stdout, seedname, pw90_berry, fermi_energy_list) end if - call get_HH_R - if (plot_curv .or. plot_morb) call get_AA_R + call get_HH_R(dis_manifold, kpt_latt, print_output, wigner_seitz, HH_R, u_matrix, v_matrix, & + eigval, real_lattice, scissors_shift, num_bands, num_kpts, num_wann, & + num_Valence_bands, effective_model, have_disentangled, seedname, stdout, comm) + if (plot_curv .or. plot_morb) then + call get_AA_R(pw90_berry, dis_manifold, kmesh_info, kpt_latt, print_output, AA_R, HH_R, & + v_matrix, eigval, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, & + num_wann, effective_model, have_disentangled, seedname, stdout, comm) + endif if (plot_morb) then - call get_BB_R - call get_CC_R + call get_BB_R(dis_manifold, kmesh_info, kpt_latt, print_output, BB_R, v_matrix, eigval, & + scissors_shift, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, & + num_wann, have_disentangled, seedname, stdout, comm) + call get_CC_R(dis_manifold, kmesh_info, kpt_latt, print_output, pw90_oper_read, CC_R, & + v_matrix, eigval, scissors_shift, wigner_seitz%irvec, wigner_seitz%nrpts, & + num_bands, num_kpts, num_wann, have_disentangled, seedname, stdout, comm) endif if (plot_shc) then - call get_AA_R - call get_SS_R - call get_SHC_R - end if + call get_AA_R(pw90_berry, dis_manifold, kmesh_info, kpt_latt, print_output, AA_R, HH_R, & + v_matrix, eigval, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, & + num_wann, effective_model, have_disentangled, seedname, stdout, comm) + call get_SS_R(dis_manifold, kpt_latt, print_output, pw90_oper_read, SS_R, v_matrix, eigval, & + wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, num_wann, & + have_disentangled, seedname, stdout, comm) + call get_SHC_R(dis_manifold, kmesh_info, kpt_latt, print_output, pw90_oper_read, & + pw90_spin_hall, SH_R, SHR_R, SR_R, v_matrix, eigval, scissors_shift, & + wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, num_wann, & + num_valence_bands, have_disentangled, seedname, stdout, comm) - if (fermi_lines_color) call get_SS_R + end if + if (fermi_lines_color) then + call get_SS_R(dis_manifold, kpt_latt, print_output, pw90_oper_read, SS_R, v_matrix, eigval, & + wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, num_wann, & + have_disentangled, seedname, stdout, comm) + endif + call utility_recip_lattice_base(real_lattice, recip_lattice, volume) ! Set Cartesian components of the vectors (b1,b2) spanning the slice - ! - bvec(1, :) = matmul(kslice_b1(:), recip_lattice(:, :)) - bvec(2, :) = matmul(kslice_b2(:), recip_lattice(:, :)) + + bvec(1, :) = matmul(pw90_kslice%b1(:), recip_lattice(:, :)) + bvec(2, :) = matmul(pw90_kslice%b2(:), recip_lattice(:, :)) ! z_vec (orthogonal to the slice) zvec(1) = bvec(1, 2)*bvec(2, 3) - bvec(1, 3)*bvec(2, 2) zvec(2) = bvec(1, 3)*bvec(2, 1) - bvec(1, 1)*bvec(2, 3) @@ -145,14 +232,14 @@ subroutine k_slice ! Area (modulus b1 x b2 = z_vec) areab1b2 = sqrt(zvec(1)**2 + zvec(2)**2 + zvec(3)**2) if (areab1b2 < eps8) call io_error( & - 'Error in kslice: Vectors kslice_b1 and kslice_b2 ' & - //'not linearly independent') + 'Error in kslice: Vectors pw90_kslice_b1 and pw90_kslice_b2 ' & + //'not linearly independent', stdout, seedname) ! This is the unit vector zvec/|zvec| which completes the triad ! in the 2D case bvec(3, :) = zvec(:)/areab1b2 ! Now that we have bvec(3,:), we can compute the dual vectors ! avec_2d as in the 3D case - call utility_recip_lattice(bvec, avec_2d, rdum) + call utility_recip_lattice(bvec, avec_2d, rdum, stdout, seedname) ! Moduli b1,b2,y_vec b1mod = sqrt(bvec(1, 1)**2 + bvec(1, 2)**2 + bvec(1, 3)**2) b2mod = sqrt(bvec(2, 1)**2 + bvec(2, 2)**2 + bvec(2, 3)**2) @@ -169,10 +256,10 @@ subroutine k_slice square = 'False' end if - nkpts = (kslice_2dkmesh(1) + 1)*(kslice_2dkmesh(2) + 1) + nkpts = (pw90_kslice%kmesh2d(1) + 1)*(pw90_kslice%kmesh2d(2) + 1) ! Partition set of k-points into junks - call comms_array_split(nkpts, counts, displs); + call comms_array_split(nkpts, counts, displs, comm); my_nkpts = counts(my_node_id) allocate (my_coords(2, my_nkpts)) @@ -194,20 +281,20 @@ subroutine k_slice ! Loop over local portion of uniform mesh of k-points covering the slice, ! including all four borders - ! + do iloc = 1, my_nkpts itot = iloc - 1 + displs(my_node_id) - i2 = itot/(kslice_2dkmesh(1) + 1) ! slow - i1 = itot - i2*(kslice_2dkmesh(1) + 1) !fast + i2 = itot/(pw90_kslice%kmesh2d(1) + 1) ! slow + i1 = itot - i2*(pw90_kslice%kmesh2d(1) + 1) !fast ! k1 and k2 are the coefficients of the k-point in the basis - ! (kslice_b1,kslice_b2) - k1 = i1/real(kslice_2dkmesh(1), dp) - k2 = i2/real(kslice_2dkmesh(2), dp) - kpt = kslice_corner + k1*kslice_b1 + k2*kslice_b2 - ! Add to (k1,k2) the projection of kslice_corner on the - ! (kslice_b1,kslice_b2) plane, expressed as a linear - ! combination of kslice_b1 and kslice_b2 - kcorner_cart(:) = matmul(kslice_corner(:), recip_lattice(:, :)) + ! (pw90_kslice_b1,pw90_kslice_b2) + k1 = i1/real(pw90_kslice%kmesh2d(1), dp) + k2 = i2/real(pw90_kslice%kmesh2d(2), dp) + kpt = pw90_kslice%corner + k1*pw90_kslice%b1 + k2*pw90_kslice%b2 + ! Add to (k1,k2) the projection of pw90_kslice_corner on the + ! (pw90_kslice_b1,pw90_kslice_b2) plane, expressed as a linear + ! combination of pw90_kslice_b1 and pw90_kslice_b2 + kcorner_cart(:) = matmul(pw90_kslice%corner(:), recip_lattice(:, :)) k1 = k1 + dot_product(kcorner_cart, avec_2d(1, :))/twopi k2 = k2 + dot_product(kcorner_cart, avec_2d(2, :))/twopi ! Convert to (kpt_x,kpt_y), the 2D Cartesian coordinates @@ -219,7 +306,8 @@ subroutine k_slice if (plot_fermi_lines) then if (fermi_lines_color) then - call spin_get_nk(kpt, spn_k) + call spin_get_nk(ws_region, pw90_spin, wannier_data, ws_distance, wigner_seitz, HH_R, & + SS_R, kpt, real_lattice, spn_k, mp_grid, num_wann, seedname, stdout) do n = 1, num_wann if (spn_k(n) > 1.0_dp - eps8) then spn_k(n) = 1.0_dp - eps8 @@ -227,11 +315,19 @@ subroutine k_slice spn_k(n) = -1.0_dp + eps8 endif enddo - call wham_get_eig_deleig(kpt, eig, del_eig, HH, delHH, UU) - Delta_k = max(b1mod/kslice_2dkmesh(1), b2mod/kslice_2dkmesh(2)) + + call wham_get_eig_deleig(dis_manifold, kpt_latt, pw90_band_deriv_degen, ws_region, & + print_output, wannier_data, ws_distance, wigner_seitz, delHH, & + HH, HH_R, u_matrix, UU, v_matrix, del_eig, eig, eigval, kpt, & + real_lattice, scissors_shift, mp_grid, num_bands, num_kpts, & + num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm) + Delta_k = max(b1mod/pw90_kslice%kmesh2d(1), b2mod/pw90_kslice%kmesh2d(2)) else - call pw90common_fourier_R_to_k(kpt, HH_R, HH, 0) - call utility_diagonalize(HH, num_wann, eig, UU) + call pw90common_fourier_R_to_k(ws_region, wannier_data, ws_distance, wigner_seitz, HH, & + HH_R, kpt, real_lattice, mp_grid, 0, num_wann, seedname, & + stdout) + call utility_diagonalize(HH, num_wann, eig, UU, stdout, seedname) endif if (allocated(my_bandsdata)) then @@ -250,15 +346,27 @@ subroutine k_slice end if if (plot_curv) then - call berry_get_imf_klist(kpt, imf_k_list) + + call berry_get_imf_klist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, print_output, & + wannier_data, ws_distance, wigner_seitz, AA_R, BB_R, CC_R, HH_R, & + u_matrix, v_matrix, eigval, kpt, real_lattice, imf_k_list, & + scissors_shift, mp_grid, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, seedname, & + stdout, comm) curv(1) = sum(imf_k_list(:, 1, 1)) curv(2) = sum(imf_k_list(:, 2, 1)) curv(3) = sum(imf_k_list(:, 3, 1)) - if (berry_curv_unit == 'bohr2') curv = curv/bohr**2 + if (pw90_berry%curv_unit == 'bohr2') curv = curv/bohr**2 ! Print _minus_ the Berry curvature my_zdata(:, iloc) = -curv(:) else if (plot_morb) then - call berry_get_imfgh_klist(kpt, imf_k_list, img_k_list, imh_k_list) + call berry_get_imfgh_klist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, & + print_output, wannier_data, ws_distance, wigner_seitz, AA_R, & + BB_R, CC_R, HH_R, u_matrix, v_matrix, eigval, kpt, & + real_lattice, scissors_shift, mp_grid, fermi_n, num_bands, & + num_kpts, num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm, imf_k_list, & + img_k_list, imh_k_list) Morb_k = img_k_list(:, :, 1) + imh_k_list(:, :, 1) & - 2.0_dp*fermi_energy_list(1)*imf_k_list(:, :, 1) Morb_k = -Morb_k/2.0_dp ! differs by -1/2 from Eq.97 LVTS12 @@ -267,7 +375,13 @@ subroutine k_slice morb(3) = sum(Morb_k(:, 3)) my_zdata(:, iloc) = morb(:) else if (plot_shc) then - call berry_get_shc_klist(kpt, shc_k_fermi=shc_k_fermi) + call berry_get_shc_klist(pw90_berry, dis_manifold, fermi_energy_list, kpt_latt, & + pw90_band_deriv_degen, ws_region, pw90_spin_hall, print_output, & + wannier_data, ws_distance, wigner_seitz, AA_R, HH_R, SH_R, SHR_R, & + SR_R, SS_R, SAA_R, SBB_R, u_matrix, v_matrix, eigval, kpt, real_lattice, & + scissors_shift, mp_grid, fermi_n, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, seedname, & + stdout, comm, shc_k_fermi=shc_k_fermi) my_zdata(1, iloc) = shc_k_fermi(1) end if @@ -280,7 +394,7 @@ subroutine k_slice allocate (coords(1, 1)) end if call comms_gatherv(my_coords, 2*my_nkpts, & - coords, 2*counts, 2*displs) + coords, 2*counts, 2*displs, stdout, seedname, comm) if (allocated(my_spndata)) then if (on_root) then @@ -289,7 +403,7 @@ subroutine k_slice allocate (spndata(1, 1)) end if call comms_gatherv(my_spndata, num_wann*my_nkpts, & - spndata, num_wann*counts, num_wann*displs) + spndata, num_wann*counts, num_wann*displs, stdout, seedname, comm) end if if (allocated(my_spnmask)) then @@ -299,7 +413,7 @@ subroutine k_slice allocate (spnmask(1, 1)) end if call comms_gatherv(my_spnmask(1, 1), num_wann*my_nkpts, & - spnmask(1, 1), num_wann*counts, num_wann*displs) + spnmask(1, 1), num_wann*counts, num_wann*displs, stdout, seedname, comm) end if if (allocated(my_bandsdata)) then @@ -309,7 +423,7 @@ subroutine k_slice allocate (bandsdata(1, 1)) end if call comms_gatherv(my_bandsdata, num_wann*my_nkpts, & - bandsdata, num_wann*counts, num_wann*displs) + bandsdata, num_wann*counts, num_wann*displs, stdout, seedname, comm) end if ! This holds either -curv or morb @@ -320,7 +434,7 @@ subroutine k_slice allocate (zdata(1, 1)) end if call comms_gatherv(my_zdata, 3*my_nkpts, & - zdata, 3*counts, 3*displs) + zdata, 3*counts, 3*displs, stdout, seedname, comm) end if ! Write output files @@ -333,13 +447,13 @@ subroutine k_slice if (.not. fermi_lines_color) then filename = trim(seedname)//'-kslice-coord.dat' - call write_data_file(filename, '(2E16.8)', coords) + call write_data_file(stdout, filename, '(2E16.8)', coords) end if if (allocated(bandsdata)) then ! For python filename = trim(seedname)//'-kslice-bands.dat' - call write_data_file(filename, '(E16.8)', & + call write_data_file(stdout, filename, '(E16.8)', & reshape(bandsdata, [1, nkpts*num_wann])) ! For gnuplot, using 'grid data' format @@ -351,16 +465,16 @@ subroutine k_slice filename = trim(seedname)//'-bnd_' & //achar(48 + n1)//achar(48 + n2)//achar(48 + n3)//'.dat' - call write_coords_file(filename, '(3E16.8)', coords, & + call write_coords_file(stdout, filename, '(3E16.8)', coords, & reshape(bandsdata(n, :), [1, 1, nkpts]), & - blocklen=kslice_2dkmesh(1) + 1) + blocklen=pw90_kslice%kmesh2d(1) + 1) enddo endif end if if (allocated(spndata)) then filename = trim(seedname)//'-kslice-fermi-spn.dat' - call write_coords_file(filename, '(3E16.8)', coords, & + call write_coords_file(stdout, filename, '(3E16.8)', coords, & reshape(spndata, [1, num_wann, nkpts]), & spnmask) end if @@ -378,7 +492,7 @@ subroutine k_slice write (stdout, '(/,3x,a)') filename open (dataunit, file=filename, form='formatted') if (plot_shc) then - if (berry_curv_unit == 'bohr2') zdata = zdata/bohr**2 + if (pw90_berry%curv_unit == 'bohr2') zdata = zdata/bohr**2 do loop_kpt = 1, nkpts write (dataunit, '(1E16.8)') zdata(1, loop_kpt) end do @@ -457,8 +571,8 @@ subroutine k_slice filename = trim(seedname)//'-kslice-fermi_lines.py' write (stdout, '(/,3x,a)') filename open (scriptunit, file=filename, form='formatted') - call script_common(scriptunit, areab1b2, square) - call script_fermi_lines(scriptunit) + call script_common(scriptunit, areab1b2, square, seedname) + call script_fermi_lines(scriptunit, seedname, fermi_energy_list) write (scriptunit, '(a)') " " write (scriptunit, '(a)') "# Remove the axes" write (scriptunit, '(a)') "ax = pl.gca()" @@ -564,8 +678,8 @@ subroutine k_slice write (stdout, '(/,3x,a)') filename open (scriptunit, file=filename, form='formatted') endif - call script_common(scriptunit, areab1b2, square) - if (plot_fermi_lines) call script_fermi_lines(scriptunit) + call script_common(scriptunit, areab1b2, square, seedname) + if (plot_fermi_lines) call script_fermi_lines(scriptunit, seedname, fermi_energy_list) if (plot_curv) then write (scriptunit, '(a)') " " @@ -668,8 +782,8 @@ subroutine k_slice write (scriptunit, '(a)') "#import matplotlib" write (scriptunit, '(a)') "#matplotlib.use('Agg')" write (scriptunit, '(a)') "import matplotlib.pyplot as plt" - call script_common(scriptunit, areab1b2, square) - if (plot_fermi_lines) call script_fermi_lines(scriptunit) + call script_common(scriptunit, areab1b2, square, seedname) + if (plot_fermi_lines) call script_fermi_lines(scriptunit, seedname, fermi_energy_list) write (scriptunit, '(a)') " " write (scriptunit, '(a)') "def shiftedColorMap(cmap, start=0, " & @@ -792,24 +906,36 @@ subroutine k_slice end subroutine k_slice - !===========================================================! + !================================================! ! PRIVATE PROCEDURES - !===========================================================! + !================================================! - subroutine kslice_print_info(plot_fermi_lines, fermi_lines_color, plot_curv, plot_morb, plot_shc) - use w90_io, only: stdout, io_error - use w90_parameters, only: nfermi, fermi_energy_list, berry_curv_unit + subroutine kslice_print_info(plot_fermi_lines, fermi_lines_color, plot_curv, plot_morb, & + plot_shc, stdout, seedname, pw90_berry, fermi_energy_list) + !================================================! - logical, intent(in) :: plot_fermi_lines, fermi_lines_color, plot_curv, plot_morb, plot_shc + use w90_constants, only: dp + use w90_postw90_types, only: pw90_berry_mod_type + use w90_io, only: io_error + + type(pw90_berry_mod_type), intent(in) :: pw90_berry + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + integer, intent(in) :: stdout + logical, intent(in) :: plot_fermi_lines, fermi_lines_color, plot_curv, plot_morb, plot_shc + character(len=50), intent(in) :: seedname + + integer :: fermi_n write (stdout, '(/,/,1x,a)') & 'Properties calculated in module k s l i c e' write (stdout, '(1x,a)') & '--------------------------------------------' + fermi_n = 0 + if (allocated(fermi_energy_list)) fermi_n = size(fermi_energy_list) if (plot_fermi_lines) then - if (nfermi /= 1) call io_error( & - 'Must specify one Fermi level when kslice_task=fermi_lines') + if (fermi_n /= 1) call io_error( & + 'Must specify one Fermi level when kslice_task=fermi_lines', stdout, seedname) select case (fermi_lines_color) case (.false.) write (stdout, '(/,3x,a)') '* Fermi lines' @@ -821,38 +947,39 @@ subroutine kslice_print_info(plot_fermi_lines, fermi_lines_color, plot_curv, plo endif if (plot_curv) then - if (berry_curv_unit == 'ang2') then + if (pw90_berry%curv_unit == 'ang2') then write (stdout, '(/,3x,a)') '* Negative Berry curvature in Ang^2' - elseif (berry_curv_unit == 'bohr2') then + elseif (pw90_berry%curv_unit == 'bohr2') then write (stdout, '(/,3x,a)') '* Negative Berry curvature in Bohr^2' endif - if (nfermi /= 1) call io_error( & - 'Must specify one Fermi level when kslice_task=curv') + if (fermi_n /= 1) call io_error( & + 'Must specify one Fermi level when kslice_task=curv', stdout, seedname) elseif (plot_morb) then write (stdout, '(/,3x,a)') & '* Orbital magnetization k-space integrand in eV.Ang^2' - if (nfermi /= 1) call io_error( & - 'Must specify one Fermi level when kslice_task=morb') + if (fermi_n /= 1) call io_error( & + 'Must specify one Fermi level when kslice_task=morb', stdout, seedname) elseif (plot_shc) then - if (berry_curv_unit == 'ang2') then + if (pw90_berry%curv_unit == 'ang2') then write (stdout, '(/,3x,a)') '* Berry curvature-like term ' & //'of spin Hall conductivity in Ang^2' - elseif (berry_curv_unit == 'bohr2') then + elseif (pw90_berry%curv_unit == 'bohr2') then write (stdout, '(/,3x,a)') '* Berry curvature-like term ' & //'of spin Hall conductivity in Bohr^2' endif - if (nfermi /= 1) call io_error( & - 'Must specify one Fermi level when kslice_task=shc') + if (fermi_n /= 1) call io_error( & + 'Must specify one Fermi level when kslice_task=shc', stdout, seedname) endif end subroutine kslice_print_info - subroutine write_data_file(filename, fmt, data) - use w90_io, only: io_error, stdout, io_file_unit + subroutine write_data_file(stdout, filename, fmt, data) + use w90_io, only: io_error, io_file_unit use w90_constants, only: dp - character(len=*), intent(in) :: filename, fmt - real(kind=dp), intent(in) :: data(:, :) + integer, intent(in) :: stdout + character(len=*), intent(in) :: filename, fmt + real(kind=dp), intent(in) :: data(:, :) integer :: n, i, fileunit @@ -869,12 +996,15 @@ subroutine write_data_file(filename, fmt, data) close (fileunit) end subroutine - subroutine write_coords_file(filename, fmt, coords, vals, mask, blocklen) - use w90_io, only: io_error, stdout, io_file_unit + subroutine write_coords_file(stdout, filename, fmt, coords, vals, mask, blocklen) + !================================================! + + use w90_io, only: io_error, io_file_unit use w90_constants, only: dp - character(len=*), intent(in) :: filename, fmt - real(kind=dp), intent(in) :: coords(:, :), vals(:, :, :) + integer, intent(in) :: stdout + character(len=*), intent(in) :: filename, fmt + real(kind=dp), intent(in) :: coords(:, :), vals(:, :, :) logical, intent(in), optional :: mask(:, :) integer, intent(in), optional :: blocklen @@ -915,14 +1045,15 @@ subroutine write_coords_file(filename, fmt, coords, vals, mask, blocklen) close (fileunit) end subroutine - subroutine script_common(scriptunit, areab1b2, square) + subroutine script_common(scriptunit, areab1b2, square, seedname) + !================================================! use w90_constants, only: dp - use w90_io, only: seedname - integer, intent(in) :: scriptunit + integer, intent(in) :: scriptunit real(kind=dp), intent(in) :: areab1b2 - character(len=25) :: square + character(len=25), intent(in) :: square + character(len=50), intent(in) :: seedname write (scriptunit, '(a)') "import pylab as pl" write (scriptunit, '(a)') "import numpy as np" @@ -963,12 +1094,14 @@ subroutine script_common(scriptunit, areab1b2, square) end subroutine script_common - subroutine script_fermi_lines(scriptunit) - - use w90_io, only: seedname - use w90_parameters, only: fermi_energy_list + subroutine script_fermi_lines(scriptunit, seedname, fermi_energy_list) + !================================================! + use w90_constants, only: dp + implicit none + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) integer, intent(in) :: scriptunit + character(len=50), intent(in) :: seedname write (scriptunit, '(a)') & "# Energy level for isocontours (typically the Fermi level)" diff --git a/src/postw90/postw90.F90 b/src/postw90/postw90.F90 index 382b91172..6f6fb8dde 100644 --- a/src/postw90/postw90.F90 +++ b/src/postw90/postw90.F90 @@ -11,22 +11,28 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! postw90: postw90 main routine ! +! ! +!------------------------------------------------------------! program postw90 + !! The postw90 program - use w90_constants, only: dp, eps6 - use w90_parameters - use w90_io + use w90_constants, only: dp, eps6, pw90_physical_constants_type + use w90_types + use w90_postw90_types + use w90_readwrite, only: w90_readwrite_read_chkpt, w90_readwrite_write_header + use w90_postw90_readwrite + use w90_io use w90_kmesh - use w90_comms, only: on_root, num_nodes, comms_setup, comms_end, comms_bcast, comms_barrier + use w90_comms, only: comms_end, comms_bcast, comms_barrier, w90comm_type, mpirank, mpisize use w90_postw90_common, only: pw90common_wanint_setup, pw90common_wanint_get_kpoint_file, & - pw90common_wanint_param_dist, pw90common_wanint_data_dist + pw90common_wanint_w90_wannier90_readwrite_dist, pw90common_wanint_data_dist - ! These modules deal with the interpolation of specific physical properties - ! use w90_dos - use w90_berry + use w90_berry, only: berry_main use w90_gyrotropic use w90_spin use w90_kpath @@ -35,31 +41,181 @@ program postw90 use w90_boltzwann use w90_geninterp +#ifdef MPI +# if !(defined(MPI08) || defined(MPI90) || defined(MPIH)) +# error "You need to define which MPI interface you are using" +# endif +#endif + +#ifdef MPI08 + use mpi_f08 ! use f08 interface if possible +#endif +#ifdef MPI90 + use mpi ! next best, use fortran90 interface +#endif + implicit none - integer :: nkp, len_seedname - logical :: have_gamma +#ifdef MPIH + include 'mpif.h' ! worst case, use legacy interface +#endif + + type(pw90_physical_constants_type) :: physics + integer :: nkp, len_seedname + integer :: stdout + character(len=50) :: seedname + logical :: have_gamma real(kind=dp) :: time0, time1, time2 character(len=9) :: stat, pos logical :: wpout_found, werr_found, dryrun character(len=50) :: prog + character(len=20) :: checkpoint + ! this is a dummy that is not used in postw90, DO NOT use + complex(kind=dp), allocatable :: m_matrix(:, :, :, :) + + complex(kind=dp), allocatable :: HH_R(:, :, :) ! <0n|r|Rm> + !! $$\langle 0n | H | Rm \rangle$$ + + complex(kind=dp), allocatable :: AA_R(:, :, :, :) ! <0n|r|Rm> + !! $$\langle 0n | \hat{r} | Rm \rangle$$ + + complex(kind=dp), allocatable :: BB_R(:, :, :, :) ! <0|H(r-R)|R> + !! $$\langle 0n | H(\hat{r}-R) | Rm \rangle$$ + + complex(kind=dp), allocatable :: CC_R(:, :, :, :, :) ! <0|r_alpha.H(r-R)_beta|R> + !! $$\langle 0n | \hat{r}_{\alpha}.H.(\hat{r}- R)_{\beta} | Rm \rangle$$ + + complex(kind=dp), allocatable :: FF_R(:, :, :, :, :) ! <0|r_alpha.(r-R)_beta|R> + !! $$\langle 0n | \hat{r}_{\alpha}.(\hat{r}-R)_{\beta} | Rm \rangle$$ + + complex(kind=dp), allocatable :: SS_R(:, :, :, :) ! <0n|sigma_x,y,z|Rm> + !! $$\langle 0n | \sigma_{x,y,z} | Rm \rangle$$ + + !spin Hall using Qiao's method + complex(kind=dp), allocatable :: SR_R(:, :, :, :, :) ! <0n|sigma_x,y,z.(r-R)_alpha|Rm> + !! $$\langle 0n | \sigma_{x,y,z}.(\hat{r}-R)_{\alpha} | Rm \rangle$$ + + complex(kind=dp), allocatable :: SHR_R(:, :, :, :, :) ! <0n|sigma_x,y,z.H.(r-R)_alpha|Rm> + !! $$\langle 0n | \sigma_{x,y,z}.H.(\hat{r}-R)_{\alpha} | Rm \rangle$$ + + complex(kind=dp), allocatable :: SH_R(:, :, :, :) ! <0n|sigma_x,y,z.H|Rm> + !! $$\langle 0n | \sigma_{x,y,z}.H | Rm \rangle$$ + + !spin Hall using Ryoo's method + complex(kind=dp), allocatable :: SAA_R(:, :, :, :, :) ! <0n|sigma_x,y,z.(r-R)_alpha|Rm> + !! $$\langle 0n | \sigma_{x,y,z}.(\hat{r}-R)_{\alpha} | Rm \rangle$$ + + complex(kind=dp), allocatable :: SBB_R(:, :, :, :, :) ! <0n|sigma_x,y,z.H.(r-R)_alpha|Rm> + !! $$\langle 0n | \sigma_{x,y,z}.H.(\hat{r}-R)_{\alpha} | Rm \rangle$$ + + ! w90_parameters stuff + type(print_output_type) :: verbose + integer :: optimisation + type(w90_system_type) :: system + integer, allocatable :: exclude_bands(:) + integer :: num_exclude_bands + type(ws_region_type) :: ws_region + type(wannier_data_type) :: wann_data + type(kmesh_input_type) :: kmesh_data + type(kmesh_info_type) :: kmesh_info + real(kind=dp), allocatable :: kpt_latt(:, :) + integer :: num_kpts + type(dis_manifold_type) :: dis_window + real(kind=dp), allocatable :: fermi_energy_list(:) + integer :: fermi_n + type(atom_data_type) :: atoms + + integer :: num_bands + !! Number of bands + + integer :: num_wann + !! number of wannier functions + + ! a_matrix and m_matrix_orig can be calculated internally from bloch states + ! or read in from an ab-initio grid + ! a_matrix = projection of trial orbitals on bloch states + ! m_matrix_orig = overlap of bloch states + !BGS disentangle, hamiltonian, a wannierise print, and postw90/get_oper + real(kind=dp), allocatable :: eigval(:, :) + + ! u_matrix_opt in postw90 only for generation of v_matrix + ! u_matrix_opt gives the num_wann dimension optimal subspace from the + ! original bloch states + complex(kind=dp), allocatable :: u_matrix_opt(:, :, :) + + ! optimally smooth states. + ! m_matrix we store here, becuase it is needed for restart of wannierise + complex(kind=dp), allocatable :: u_matrix(:, :, :) + real(kind=dp) :: scissors_shift + integer :: mp_grid(3) + !! Dimensions of the Monkhorst-Pack grid + + integer :: num_proj + + real(kind=dp) :: real_lattice(3, 3) + + !parameters derived from input + !real(kind=dp) :: recip_lattice(3, 3) + + type(kpoint_path_type) :: spec_points + ! end w90_parameters + ! data from w90_postw90_types + type(pw90_calculation_type) :: pw90_calcs + + logical :: eig_found ! used to control broadcast of eigval + + type(pw90_oper_read_type) :: postw90_oper + type(pw90_spin_mod_type) :: pw90_spin + type(pw90_band_deriv_degen_type) :: pw90_ham + type(pw90_kpath_mod_type) :: kpath + type(pw90_kslice_mod_type) :: kslice + + ! module d o s + ! No need to save 'dos_plot', only used here (introduced 'dos_task') + logical :: dos_plot + + type(pw90_dos_mod_type) :: dos_data + type(pw90_berry_mod_type) :: berry + type(pw90_spin_hall_type) :: spin_hall + type(pw90_gyrotropic_type) :: gyrotropic + type(pw90_geninterp_mod_type) :: geninterp + type(pw90_boltzwann_type) :: boltz + ! end w90_postw90_types + ! from postw90_common + complex(kind=dp), allocatable :: v_matrix(:, :, :) + type(wigner_seitz_type) :: ws_vec + type(kpoint_dist_type) :: kpt_dist + logical :: gamma_only + logical :: have_disentangled + logical :: effective_model = .false. + + ! local vars + integer :: my_node_id, num_nodes, ierr + logical :: on_root = .false. + type(w90comm_type) :: comm + type(ws_distance_type) :: ws_distance + type(pw90_extra_io_type) :: write_data + real(kind=dp) :: omega_invariant - ! Put some descriptive comments here - ! - call comms_setup +#ifdef MPI + comm%comm = MPI_COMM_WORLD + call mpi_init(ierr) + if (ierr .ne. 0) call io_error('MPI initialisation error', stdout, seedname) ! JJ, fixme, what are stdout, seedname here? unassigned! +#endif - library = .false. - ispostw90 = .true. + my_node_id = mpirank(comm) + num_nodes = mpisize(comm) + if (my_node_id == 0) on_root = .true. if (on_root) then time0 = io_time() prog = 'postw90' - call io_commandline(prog, dryrun) + call io_commandline(prog, dryrun, seedname) len_seedname = len(seedname) end if - call comms_bcast(len_seedname, 1) - call comms_bcast(seedname, len_seedname) - call comms_bcast(dryrun, 1) + call comms_bcast(len_seedname, 1, stdout, seedname, comm) + call comms_bcast(seedname, len_seedname, stdout, seedname, comm) + call comms_bcast(dryrun, 1, stdout, seedname, comm) if (on_root) then ! If an error file (generated by postw90) exists, I delete it @@ -83,7 +239,8 @@ program postw90 stdout = io_file_unit() open (unit=stdout, file=trim(seedname)//'.wpout', status=trim(stat), position=trim(pos)) - call param_write_header + call w90_readwrite_write_header(physics%bohr_version_str, physics%constants_version_str1, & + physics%constants_version_str2, stdout) if (num_nodes == 1) then #ifdef MPI write (stdout, '(/,1x,a)') 'Running in serial (with parallel executable)' @@ -98,30 +255,41 @@ program postw90 ! Read onto the root node all the input parameters from seendame.win, ! as well as the energy eigenvalues on the ab-initio q-mesh from seedname.eig - ! + if (on_root) then - call param_read - call param_postw90_write + call w90_postw90_readwrite_read(ws_region, system, exclude_bands, verbose, wann_data, kmesh_data, & + kpt_latt, num_kpts, dis_window, fermi_energy_list, atoms, num_bands, & + num_wann, eigval, mp_grid, real_lattice, spec_points, & + pw90_calcs, postw90_oper, scissors_shift, effective_model, pw90_spin, & + pw90_ham, kpath, kslice, dos_data, berry, spin_hall, gyrotropic, & + geninterp, boltz, eig_found, write_data, gamma_only, physics%bohr, & + optimisation, stdout, seedname) + + call w90_postw90_readwrite_write(verbose, system, fermi_energy_list, atoms, num_wann, & + real_lattice, spec_points, pw90_calcs, postw90_oper, scissors_shift, & + pw90_spin, kpath, kslice, dos_data, berry, & + gyrotropic, geninterp, boltz, write_data, optimisation, stdout) time1 = io_time() write (stdout, '(1x,a25,f11.3,a)') & 'Time to read parameters ', time1 - time0, ' (sec)' if (.not. effective_model) then ! Check if the q-mesh includes the gamma point - ! + have_gamma = .false. do nkp = 1, num_kpts if (all(abs(kpt_latt(:, nkp)) < eps6)) have_gamma = .true. end do if (.not. have_gamma) write (stdout, '(1x,a)') & 'Ab-initio does not include Gamma. Interpolation may be incorrect!!!' - ! + ! Need nntot, wb, and bk to evaluate WF matrix elements of ! the position operator in reciprocal space. Also need ! nnlist to compute the additional matrix elements entering ! the orbital magnetization - ! - call kmesh_get + + call kmesh_get(kmesh_data, kmesh_info, verbose, kpt_latt, real_lattice, & + num_kpts, gamma_only, seedname, stdout) time2 = io_time() write (stdout, '(1x,a25,f11.3,a)') & 'Time to get kmesh ', time2 - time1, ' (sec)' @@ -132,7 +300,7 @@ program postw90 ! print the memory information related to wannier90.x. ! Note that the code for the memory estimation for the ! Boltzwann routine is already there. - ! call param_memory_estimate + ! call w90_wannier90_readwrite_memory_estimate end if if (dryrun) then @@ -147,49 +315,73 @@ program postw90 endif ! We now distribute a subset of the parameters to the other nodes - ! - call pw90common_wanint_param_dist + + call pw90common_wanint_w90_wannier90_readwrite_dist(verbose, ws_region, kmesh_info, kpt_latt, num_kpts, & + dis_window, system, fermi_energy_list, num_bands, num_wann, & + eigval, mp_grid, real_lattice, pw90_calcs, & + scissors_shift, effective_model, pw90_spin, pw90_ham, kpath, & + kslice, dos_data, berry, spin_hall, gyrotropic, geninterp, & + boltz, eig_found, stdout, seedname, comm) + fermi_n = 0 + if (allocated(fermi_energy_list)) fermi_n = size(fermi_energy_list) if (.not. effective_model) then - ! + ! Read files seedname.chk (overlap matrices, unitary matrices for ! both disentanglement and maximal localization, etc.) - ! - if (on_root) call param_read_chkpt() - ! + + if (on_root) then + num_exclude_bands = 0 + if (allocated(exclude_bands)) num_exclude_bands = size(exclude_bands) + call w90_readwrite_read_chkpt(dis_window, exclude_bands, kmesh_info, kpt_latt, wann_data, m_matrix, & + u_matrix, u_matrix_opt, real_lattice, omega_invariant, & + mp_grid, num_bands, num_exclude_bands, num_kpts, num_wann, checkpoint, & + have_disentangled, .true., seedname, stdout) + endif + ! Distribute the information in the um and chk files to the other nodes ! ! Ivo: For interpolation purposes we do not need u_matrix_opt and ! u_matrix separately, only their product v_matrix, and this ! is what is distributed now ! - call pw90common_wanint_data_dist - ! - end if + call pw90common_wanint_data_dist(num_wann, num_kpts, num_bands, u_matrix_opt, u_matrix, & + dis_window, wann_data, scissors_shift, v_matrix, & + system%num_valence_bands, have_disentangled, stdout, & + seedname, comm) + end if ! Read list of k-points in irreducible BZ and their weights ! ! Should this be done on root node only? ! - if (wanint_kpoint_file) call pw90common_wanint_get_kpoint_file + if (berry%wanint_kpoint_file) call pw90common_wanint_get_kpoint_file(kpt_dist, stdout, & + seedname, comm) ! Setup a number of common variables for all interpolation tasks - ! - call pw90common_wanint_setup + + call pw90common_wanint_setup(num_wann, verbose, real_lattice, mp_grid, effective_model, & + ws_vec, stdout, seedname, comm) if (on_root) then time1 = io_time() write (stdout, '(/1x,a25,f11.3,a)') & 'Time to read and process .chk ', time1 - time2, ' (sec)' endif - ! + ! Now perform one or more of the following tasks ! --------------------------------------------------------------- ! Density of states calculated using a uniform interpolation mesh ! --------------------------------------------------------------- - ! - if (dos .and. index(dos_task, 'dos_plot') > 0) call dos_main + + if (pw90_calcs%dos .and. index(dos_data%task, 'dos_plot') > 0) then + call dos_main(berry, dis_window, dos_data, kpt_dist, kpt_latt, postw90_oper, pw90_ham, & + pw90_spin, ws_region, system, verbose, wann_data, ws_distance, ws_vec, HH_R, & + SS_R, u_matrix, v_matrix, eigval, real_lattice, scissors_shift, & + mp_grid, num_bands, num_kpts, num_wann, effective_model, have_disentangled, & + pw90_calcs%spin_decomp, seedname, stdout, comm) + endif ! find_fermi_level commented for the moment in dos.F90 ! if(dos .and. index(dos_task,'find_fermi_energy')>0) call find_fermi_level @@ -197,20 +389,40 @@ program postw90 ! -------------------------------------------------------------------- ! Bands, Berry curvature, or orbital magnetization plot along a k-path ! -------------------------------------------------------------------- - ! - if (kpath) call k_path + if (pw90_calcs%kpath) then + call k_path(berry, dis_window, fermi_energy_list, kmesh_info, kpath, kpt_latt, postw90_oper, & + pw90_ham, pw90_spin, ws_region, spec_points, spin_hall, verbose, wann_data, & + ws_distance, ws_vec, AA_R, BB_R, CC_R, HH_R, SH_R, SHR_R, SR_R, SS_R, SAA_R, & + SBB_R, v_matrix, u_matrix, physics%bohr, eigval, real_lattice, scissors_shift, & + mp_grid, fermi_n, num_wann, num_bands, num_kpts, system%num_valence_bands, & + effective_model, have_disentangled, seedname, stdout, comm) + end if ! --------------------------------------------------------------------------- ! Bands, Berry curvature, or orbital magnetization plot on a slice in k-space ! --------------------------------------------------------------------------- - ! - if (kslice) call k_slice + + if (pw90_calcs%kslice) then + + call k_slice(berry, dis_window, fermi_energy_list, kmesh_info, kpt_latt, kslice, postw90_oper, & + pw90_ham, pw90_spin, ws_region, spin_hall, verbose, wann_data, ws_distance, & + ws_vec, AA_R, BB_R, CC_R, HH_R, SH_R, SHR_R, SR_R, SS_R, SAA_R, SBB_R, v_matrix, & + u_matrix, physics%bohr, eigval, real_lattice, scissors_shift, mp_grid, fermi_n, & + num_bands, num_kpts, num_wann, system%num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm) + end if ! -------------------- ! Spin magnetic moment ! -------------------- - ! - if (spin_moment) call spin_get_moment + + if (pw90_calcs%spin_moment) then + call spin_get_moment(dis_window, fermi_energy_list, kpt_dist, kpt_latt, postw90_oper, & + pw90_spin, ws_region, verbose, wann_data, ws_distance, ws_vec, HH_R, & + SS_R, u_matrix, v_matrix, eigval, real_lattice, scissors_shift, mp_grid, & + num_wann, num_bands, num_kpts, system%num_valence_bands, effective_model, & + have_disentangled, berry%wanint_kpoint_file, seedname, stdout, comm) + end if ! ------------------------------------------------------------------- ! dc Anomalous Hall conductivity and eventually (if 'mcd' string also @@ -229,23 +441,49 @@ program postw90 ! ----------------------------------------------------------------- ! Orbital magnetization ! ----------------------------------------------------------------- - ! - if (berry) call berry_main + + if (pw90_calcs%berry) then + call berry_main(berry, dis_window, fermi_energy_list, kmesh_info, kpt_dist, kpt_latt, & + pw90_ham, postw90_oper, pw90_spin, physics, ws_region, spin_hall, wann_data, & + ws_distance, ws_vec, verbose, AA_R, BB_R, CC_R, HH_R, SH_R, SHR_R, SR_R, SS_R, & + SAA_R, SBB_R, u_matrix, v_matrix, eigval, real_lattice, scissors_shift, & + mp_grid, fermi_n, num_wann, num_kpts, num_bands, system%num_valence_bands, & + effective_model, have_disentangled, pw90_calcs%spin_decomp, seedname, stdout, & + comm) + end if ! ----------------------------------------------------------------- ! Boltzmann transport coefficients (BoltzWann module) ! ----------------------------------------------------------------- - ! + if (on_root) then time1 = io_time() endif - if (geninterp) call geninterp_main + if (pw90_calcs%geninterp) then + call geninterp_main(dis_window, geninterp, kpt_latt, pw90_ham, ws_region, verbose, wann_data, & + ws_distance, ws_vec, HH_R, v_matrix, u_matrix, eigval, real_lattice, & + scissors_shift, mp_grid, num_bands, num_kpts, num_wann, & + system%num_valence_bands, effective_model, have_disentangled, seedname, & + stdout, comm) + end if - if (boltzwann) call boltzwann_main + if (pw90_calcs%boltzwann) then + call boltzwann_main(boltz, dis_window, dos_data, kpt_latt, pw90_ham, postw90_oper, pw90_spin, & + physics, ws_region, system, wann_data, ws_distance, ws_vec, verbose, HH_R, & + SS_R, v_matrix, u_matrix, eigval, real_lattice, scissors_shift, mp_grid, & + num_wann, num_bands, num_kpts, effective_model, have_disentangled, & + pw90_calcs%spin_decomp, seedname, stdout, comm) + end if - if (gyrotropic) call gyrotropic_main + if (pw90_calcs%gyrotropic) then + call gyrotropic_main(berry, dis_window, fermi_energy_list, gyrotropic, kmesh_info, kpt_latt, & + physics, postw90_oper, pw90_ham, ws_region, system, verbose, wann_data, & + ws_vec, ws_distance, AA_R, BB_R, CC_R, HH_R, SS_R, u_matrix, v_matrix, & + eigval, real_lattice, scissors_shift, mp_grid, num_bands, num_kpts, & + num_wann, effective_model, have_disentangled, seedname, stdout, comm) + endif - if (on_root .and. boltzwann) then + if (on_root .and. pw90_calcs%boltzwann) then time2 = io_time() write (stdout, '(/1x,a,f11.3,a)') & 'Time for BoltzWann (Boltzmann transport) ', time2 - time1, ' (sec)' @@ -253,11 +491,11 @@ program postw90 ! I put a barrier here before calling the final time printing routines, ! just to be sure that all processes have arrived here. - call comms_barrier + call comms_barrier(comm) if (on_root) then write (stdout, '(/,1x,a25,f11.3,a)') & 'Total Execution Time ', io_time(), ' (sec)' - if (timing_level > 0) call io_print_timings() + if (verbose%timing_level > 0) call io_print_timings(stdout) write (stdout, *) write (stdout, '(/,1x,a)') 'All done: postw90 exiting' close (stdout) diff --git a/src/postw90/postw90_common.F90 b/src/postw90/postw90_common.F90 index 8a4243230..e3aec6a7a 100644 --- a/src/postw90/postw90_common.F90 +++ b/src/postw90/postw90_common.F90 @@ -11,84 +11,79 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! w90_postw90_common: routines used throughout postw90 ! +! ! +!------------------------------------------------------------! module w90_postw90_common -!============================================================================== -!! This contains the common variables and procedures needed to set up a Wannier -!! interpolatation calculation for any physical property -!============================================================================== + !! This contains the common variables and procedures needed to set up a Wannier + !! interpolatation calculation for any physical property - ! Should we remove this 'use w90_comms' and invoke in individual routines - ! when needed? - ! - use w90_comms use w90_constants, only: dp implicit none private - public :: pw90common_wanint_setup, pw90common_wanint_get_kpoint_file, pw90common_wanint_param_dist - public :: pw90common_wanint_data_dist, pw90common_get_occ - public :: pw90common_fourier_R_to_k, pw90common_fourier_R_to_k_new, pw90common_fourier_R_to_k_vec - public :: nrpts, rpt_origin, v_matrix, ndegen, irvec, crvec - public :: num_int_kpts_on_node, int_kpts, weight + public :: pw90common_fourier_R_to_k + public :: pw90common_fourier_R_to_k_new + public :: pw90common_fourier_R_to_k_new_second_d + public :: pw90common_fourier_R_to_k_new_second_d_TB_conv + public :: pw90common_fourier_R_to_k_vec + public :: pw90common_fourier_R_to_k_vec_dadb + public :: pw90common_fourier_R_to_k_vec_dadb_TB_conv + public :: pw90common_get_occ public :: pw90common_kmesh_spacing - public :: pw90common_fourier_R_to_k_new_second_d, pw90common_fourier_R_to_k_new_second_d_TB_conv, & - pw90common_fourier_R_to_k_vec_dadb, pw90common_fourier_R_to_k_vec_dadb_TB_conv - -! AAM PROBABLY REMOVE THIS - ! This 'save' statement could probably be ommited, since this module - ! is USEd by the main program 'wannier_parint' - ! - save - -! AAM REMOVE THIS - ! Default accessibility is PUBLIC - ! -! private :: wigner_seitz -! -! private :: kmesh_spacing_singleinteger, kmesh_spacing_mesh + public :: pw90common_wanint_data_dist + public :: pw90common_wanint_get_kpoint_file + public :: pw90common_wanint_setup + public :: pw90common_wanint_w90_wannier90_readwrite_dist interface pw90common_kmesh_spacing module procedure kmesh_spacing_singleinteger module procedure kmesh_spacing_mesh end interface pw90common_kmesh_spacing - ! Parameters describing the direct lattice points R on a - ! Wigner-Seitz supercell - ! - integer, allocatable :: irvec(:, :) - real(kind=dp), allocatable :: crvec(:, :) - integer, allocatable :: ndegen(:) - integer :: nrpts - integer :: rpt_origin - - integer :: max_int_kpts_on_node, num_int_kpts - integer, allocatable :: num_int_kpts_on_node(:) - real(kind=dp), allocatable :: int_kpts(:, :), weight(:) - complex(kind=dp), allocatable :: v_matrix(:, :, :) - contains - !===========================================================! - ! PUBLIC PROCEDURES ! - !===========================================================! - + !================================================! + ! PUBLIC PROCEDURES ! Public procedures have names starting with wanint_ + !================================================! - subroutine pw90common_wanint_setup + subroutine pw90common_wanint_setup(num_wann, print_output, real_lattice, mp_grid, & + effective_model, wigner_seitz, stdout, seedname, comm) + !================================================! + ! !! Setup data ready for interpolation - use w90_constants, only: dp, cmplx_0 - use w90_io, only: io_error, io_file_unit, stdout, seedname - use w90_utility, only: utility_cart_to_frac - use w90_parameters, only: real_lattice, effective_model, num_wann + ! + !================================================! - integer :: ierr, i, j, k, ikpt, ir, file_unit, num_wann_loc + use w90_constants, only: dp + use w90_io, only: io_error, io_file_unit + use w90_types, only: print_output_type + use w90_comms, only: mpirank, w90comm_type, comms_bcast + use w90_postw90_types, only: wigner_seitz_type + + type(print_output_type), intent(in) :: print_output + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(w90comm_type), intent(in) :: comm + + real(kind=dp), intent(in) :: real_lattice(3, 3) + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + integer, intent(in) :: mp_grid(3) + logical, intent(in) :: effective_model + character(len=50), intent(in) :: seedname + + integer :: ierr, ir, file_unit, num_wann_loc + logical :: on_root = .false. + + if (mpirank(comm) == 0) on_root = .true. ! Find nrpts, the number of points in the Wigner-Seitz cell - ! if (effective_model) then if (on_root) then ! nrpts is read from file, together with num_wann @@ -99,250 +94,335 @@ subroutine pw90common_wanint_setup read (file_unit, *) num_wann_loc if (num_wann_loc /= num_wann) & call io_error('Inconsistent values of num_wann in ' & - //trim(seedname)//'_HH_R.dat and '//trim(seedname)//'.win') - read (file_unit, *) nrpts + //trim(seedname)//'_HH_R.dat and '//trim(seedname)//'.win', stdout, & + seedname) + read (file_unit, *) wigner_seitz%nrpts close (file_unit) endif - call comms_bcast(nrpts, 1) + call comms_bcast(wigner_seitz%nrpts, 1, stdout, seedname, comm) else - call wigner_seitz(count_pts=.true.) + call wignerseitz(print_output, real_lattice, mp_grid, wigner_seitz, stdout, seedname, & + .true., comm) endif ! Now can allocate several arrays - ! - allocate (irvec(3, nrpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating irvec in pw90common_wanint_setup') - irvec = 0 - allocate (crvec(3, nrpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating crvec in pw90common_wanint_setup') - crvec = 0.0_dp - allocate (ndegen(nrpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ndegen in pw90common_wanint_setup') - ndegen = 0 - ! + allocate (wigner_seitz%irvec(3, wigner_seitz%nrpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating irvec in pw90common_wanint_setup', stdout, & + seedname) + wigner_seitz%irvec = 0 + allocate (wigner_seitz%crvec(3, wigner_seitz%nrpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating crvec in pw90common_wanint_setup', stdout, & + seedname) + wigner_seitz%crvec = 0.0_dp + allocate (wigner_seitz%ndegen(wigner_seitz%nrpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating ndegen in pw90common_wanint_setup', stdout, & + seedname) + wigner_seitz%ndegen = 0 + ! Also rpt_origin, so that when effective_model=.true it is not ! passed to get_HH_R without being initialized. - rpt_origin = 0 + wigner_seitz%rpt_origin = 0 ! If effective_model, this is done in get_HH_R if (.not. effective_model) then - ! ! Set up the lattice vectors on the Wigner-Seitz supercell ! where the Wannier functions live - ! - call wigner_seitz(count_pts=.false.) - ! + + call wignerseitz(print_output, real_lattice, mp_grid, wigner_seitz, stdout, seedname, & + .false., comm) + ! Convert from reduced to Cartesian coordinates - ! - do ir = 1, nrpts + + do ir = 1, wigner_seitz%nrpts ! Note that 'real_lattice' stores the lattice vectors as *rows* - crvec(:, ir) = matmul(transpose(real_lattice), irvec(:, ir)) + wigner_seitz%crvec(:, ir) = matmul(transpose(real_lattice), wigner_seitz%irvec(:, ir)) end do endif return 101 call io_error('Error in pw90common_wanint_setup: problem opening file '// & - trim(seedname)//'_HH_R.dat') + trim(seedname)//'_HH_R.dat', stdout, seedname) end subroutine pw90common_wanint_setup - !===========================================================! - subroutine pw90common_wanint_get_kpoint_file - !===========================================================! - ! ! + !================================================! + subroutine pw90common_wanint_get_kpoint_file(kpoint_dist, stdout, seedname, comm) + !================================================! + ! !! read kpoints from kpoint.dat and distribute - ! ! - !===========================================================! + ! + !================================================! use w90_constants, only: dp - use w90_io, only: io_error, io_file_unit, & - io_date, io_time, io_stopwatch + use w90_io, only: io_error, io_file_unit, io_date, io_time, io_stopwatch + use w90_comms, only: mpirank, mpisize, w90comm_type, comms_send, comms_recv, comms_bcast + use w90_postw90_types, only: kpoint_dist_type + + ! arguments + type(kpoint_dist_type), intent(inout) :: kpoint_dist + type(w90comm_type), intent(in) :: comm + + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname - integer :: k_unit - integer :: loop_nodes, loop_kpt, i, ierr + ! local variables + integer :: loop_nodes, loop_kpt, i, ierr, my_node_id, num_nodes, k_unit real(kind=dp) :: sum + logical :: on_root = .false. + + my_node_id = mpirank(comm) + num_nodes = mpisize(comm) + + if (my_node_id == 0) on_root = .true. k_unit = io_file_unit() if (on_root) then open (unit=k_unit, file='kpoint.dat', status='old', form='formatted', err=106) - read (k_unit, *) num_int_kpts + read (k_unit, *) kpoint_dist%num_int_kpts end if - call comms_bcast(num_int_kpts, 1) - - allocate (num_int_kpts_on_node(0:num_nodes - 1)) - num_int_kpts_on_node(:) = num_int_kpts/num_nodes - max_int_kpts_on_node = num_int_kpts - (num_nodes - 1)*(num_int_kpts/num_nodes) - num_int_kpts_on_node(0) = max_int_kpts_on_node -! if(my_node_id < num_int_kpts- num_int_kpts_on_node*num_nodes) num_int_kpts_on_node= num_int_kpts_on_node+1 - - allocate (int_kpts(3, max_int_kpts_on_node), stat=ierr) - if (ierr /= 0) call io_error('Error allocating max_int_kpts_on_node in param_read_um') - int_kpts = 0.0_dp - allocate (weight(max_int_kpts_on_node), stat=ierr) - if (ierr /= 0) call io_error('Error allocating weight in param_read_um') - weight = 0.0_dp + call comms_bcast(kpoint_dist%num_int_kpts, 1, stdout, seedname, comm) + + allocate (kpoint_dist%num_int_kpts_on_node(0:num_nodes - 1)) + kpoint_dist%num_int_kpts_on_node(:) = kpoint_dist%num_int_kpts/num_nodes + kpoint_dist%max_int_kpts_on_node = kpoint_dist%num_int_kpts & + - (num_nodes - 1)*(kpoint_dist%num_int_kpts/num_nodes) + kpoint_dist%num_int_kpts_on_node(0) = kpoint_dist%max_int_kpts_on_node +! if(my_node_id < num_int_kpts- num_int_kpts_on_node*num_nodes) num_int_kpts_on_node= num_int_kpts_on_node+1 + + allocate (kpoint_dist%int_kpts(3, kpoint_dist%max_int_kpts_on_node), stat=ierr) + if (ierr /= 0) call io_error('Error allocating max_int_kpts_on_node in w90_wannier90_readwrite_read_um', stdout, & + seedname) + kpoint_dist%int_kpts = 0.0_dp + allocate (kpoint_dist%weight(kpoint_dist%max_int_kpts_on_node), stat=ierr) + if (ierr /= 0) call io_error('Error allocating weight in w90_wannier90_readwrite_read_um', stdout, seedname) + kpoint_dist%weight = 0.0_dp sum = 0.0_dp if (on_root) then do loop_nodes = 1, num_nodes - 1 - do loop_kpt = 1, num_int_kpts_on_node(loop_nodes) - read (k_unit, *) (int_kpts(i, loop_kpt), i=1, 3), weight(loop_kpt) - sum = sum + weight(loop_kpt) + do loop_kpt = 1, kpoint_dist%num_int_kpts_on_node(loop_nodes) + read (k_unit, *) (kpoint_dist%int_kpts(i, loop_kpt), i=1, 3), kpoint_dist%weight(loop_kpt) + sum = sum + kpoint_dist%weight(loop_kpt) end do - call comms_send(int_kpts(1, 1), 3*num_int_kpts_on_node(loop_nodes), loop_nodes) - call comms_send(weight(1), num_int_kpts_on_node(loop_nodes), loop_nodes) - + call comms_send(kpoint_dist%int_kpts(1, 1), & + 3*kpoint_dist%num_int_kpts_on_node(loop_nodes), loop_nodes, stdout, & + seedname, comm) + call comms_send(kpoint_dist%weight(1), kpoint_dist%num_int_kpts_on_node(loop_nodes), & + loop_nodes, stdout, seedname, comm) end do - do loop_kpt = 1, num_int_kpts_on_node(0) - read (k_unit, *) (int_kpts(i, loop_kpt), i=1, 3), weight(loop_kpt) - sum = sum + weight(loop_kpt) + do loop_kpt = 1, kpoint_dist%num_int_kpts_on_node(0) + read (k_unit, *) (kpoint_dist%int_kpts(i, loop_kpt), i=1, 3), kpoint_dist%weight(loop_kpt) + sum = sum + kpoint_dist%weight(loop_kpt) end do ! print*,'rsum',sum end if if (.not. on_root) then - call comms_recv(int_kpts(1, 1), 3*num_int_kpts_on_node(my_node_id), root_id) - call comms_recv(weight(1), num_int_kpts_on_node(my_node_id), root_id) - + call comms_recv(kpoint_dist%int_kpts(1, 1), 3*kpoint_dist%num_int_kpts_on_node(my_node_id), & + 0, stdout, seedname, comm) + call comms_recv(kpoint_dist%weight(1), kpoint_dist%num_int_kpts_on_node(my_node_id), 0, & + stdout, seedname, comm) end if return -106 call io_error('Error: Problem opening file kpoint.dat in pw90common_wanint_get_kpoint_file') +106 call io_error('Error: Problem opening file kpoint.dat in pw90common_wanint_get_kpoint_file', & + stdout, seedname) end subroutine pw90common_wanint_get_kpoint_file - !===========================================================! - subroutine pw90common_wanint_param_dist - !===========================================================! - ! ! + !================================================! + subroutine pw90common_wanint_w90_wannier90_readwrite_dist(print_output, ws_region, kmesh_info, kpt_latt, num_kpts, & + dis_manifold, w90_system, fermi_energy_list, num_bands, & + num_wann, eigval, mp_grid, real_lattice, & + pw90_calculation, scissors_shift, effective_model, & + pw90_spin, pw90_band_deriv_degen, pw90_kpath, & + pw90_kslice, pw90_dos, pw90_berry, pw90_spin_hall, & + pw90_gyrotropic, pw90_geninterp, pw90_boltzwann, & + eig_found, stdout, seedname, comm) + !================================================! + ! !! distribute the parameters across processors !! NOTE: we only send the ones postw90 uses, not all in w90 - ! ! - !===========================================================! + ! + !================================================! - use w90_constants, only: dp, cmplx_0, cmplx_i, twopi + use w90_constants, only: dp use w90_io, only: io_error, io_file_unit, io_date, io_time, & io_stopwatch - use w90_parameters + use w90_comms, only: mpirank, w90comm_type, comms_bcast + use w90_types + use w90_postw90_types, only: pw90_calculation_type, pw90_spin_mod_type, & + pw90_band_deriv_degen_type, pw90_kpath_mod_type, pw90_kslice_mod_type, pw90_dos_mod_type, & + pw90_berry_mod_type, pw90_spin_hall_type, pw90_gyrotropic_type, pw90_geninterp_mod_type, & + pw90_boltzwann_type + + type(print_output_type), intent(inout) :: print_output + type(ws_region_type), intent(inout) :: ws_region + type(w90_system_type), intent(inout) :: w90_system + type(kmesh_info_type), intent(inout) :: kmesh_info + type(dis_manifold_type), intent(inout) :: dis_manifold + type(pw90_calculation_type), intent(inout) :: pw90_calculation + type(pw90_spin_mod_type), intent(inout) :: pw90_spin + type(pw90_band_deriv_degen_type), intent(inout) :: pw90_band_deriv_degen + type(pw90_kpath_mod_type), intent(inout) :: pw90_kpath + type(pw90_kslice_mod_type), intent(inout) :: pw90_kslice + type(pw90_dos_mod_type), intent(inout) :: pw90_dos + type(pw90_berry_mod_type), intent(inout) :: pw90_berry + type(pw90_spin_hall_type), intent(inout) :: pw90_spin_hall + type(pw90_gyrotropic_type), intent(inout) :: pw90_gyrotropic + type(pw90_geninterp_mod_type), intent(inout) :: pw90_geninterp + type(pw90_boltzwann_type), intent(inout) :: pw90_boltzwann + type(w90comm_type), intent(in) :: comm + + real(kind=dp), allocatable, intent(inout) :: kpt_latt(:, :) + real(kind=dp), allocatable, intent(inout) :: fermi_energy_list(:) + real(kind=dp), allocatable, intent(inout) :: eigval(:, :) + real(kind=dp), intent(inout) :: real_lattice(3, 3) + real(kind=dp), intent(inout) :: scissors_shift + integer, intent(inout) :: num_kpts + integer, intent(inout) :: num_bands + integer, intent(inout) :: num_wann + integer, intent(inout) :: mp_grid(3) + logical, intent(inout) :: eig_found + logical, intent(inout) :: effective_model + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname integer :: ierr + integer :: iprintroot + integer :: fermi_n + logical :: on_root = .false. + + if (mpirank(comm) == 0) on_root = .true. - call comms_bcast(effective_model, 1) - call comms_bcast(eig_found, 1) + call comms_bcast(effective_model, 1, stdout, seedname, comm) + call comms_bcast(eig_found, 1, stdout, seedname, comm) if (.not. effective_model) then - call comms_bcast(mp_grid(1), 3) - call comms_bcast(num_kpts, 1) - call comms_bcast(num_bands, 1) + call comms_bcast(mp_grid(1), 3, stdout, seedname, comm) + call comms_bcast(num_kpts, 1, stdout, seedname, comm) + call comms_bcast(num_bands, 1, stdout, seedname, comm) endif - call comms_bcast(num_wann, 1) - call comms_bcast(timing_level, 1) - call comms_bcast(iprint, 1) - call comms_bcast(ws_distance_tol, 1) - call comms_bcast(ws_search_size(1), 3) + call comms_bcast(num_wann, 1, stdout, seedname, comm) + call comms_bcast(print_output%timing_level, 1, stdout, seedname, comm) + + !______________________________________ + !JJ fixme maybe? not so pretty solution to setting iprint to zero on non-root processes + iprintroot = print_output%iprint + print_output%iprint = 0 + call comms_bcast(print_output%iprint, 1, stdout, seedname, comm) + if (on_root) print_output%iprint = iprintroot + !______________________________________ + + call comms_bcast(ws_region%ws_distance_tol, 1, stdout, seedname, comm) + call comms_bcast(ws_region%ws_search_size(1), 3, stdout, seedname, comm) ! call comms_bcast(num_atoms,1) ! Ivo: not used in postw90, right? ! call comms_bcast(num_species,1) ! Ivo: not used in postw90, right? - call comms_bcast(real_lattice(1, 1), 9) - call comms_bcast(recip_lattice(1, 1), 9) - call comms_bcast(real_metric(1, 1), 9) - call comms_bcast(recip_metric(1, 1), 9) - call comms_bcast(cell_volume, 1) - call comms_bcast(dos_energy_step, 1) - call comms_bcast(dos_adpt_smr, 1) - call comms_bcast(dos_smr_index, 1) - call comms_bcast(dos_kmesh_spacing, 1) - call comms_bcast(dos_kmesh(1), 3) - call comms_bcast(dos_adpt_smr_max, 1) - call comms_bcast(dos_smr_fixed_en_width, 1) - call comms_bcast(dos_adpt_smr_fac, 1) - call comms_bcast(num_dos_project, 1) - - call comms_bcast(berry, 1) - call comms_bcast(berry_task, len(berry_task)) - call comms_bcast(berry_kmesh_spacing, 1) - call comms_bcast(berry_kmesh(1), 3) - call comms_bcast(berry_curv_adpt_kmesh, 1) - call comms_bcast(berry_curv_adpt_kmesh_thresh, 1) - call comms_bcast(berry_curv_unit, len(berry_curv_unit)) + call comms_bcast(real_lattice(1, 1), 9, stdout, seedname, comm) + !call comms_bcast(recip_lattice(1, 1), 9, stdout, seedname, comm) + !call comms_bcast(real_metric(1, 1), 9) + !call comms_bcast(recip_metric(1, 1), 9) + !call comms_bcast(cell_volume, 1, stdout, seedname, comm) + call comms_bcast(pw90_dos%energy_step, 1, stdout, seedname, comm) + call comms_bcast(pw90_dos%smearing%use_adaptive, 1, stdout, seedname, comm) + call comms_bcast(pw90_dos%smearing%type_index, 1, stdout, seedname, comm) + call comms_bcast(pw90_dos%kmesh%spacing, 1, stdout, seedname, comm) + call comms_bcast(pw90_dos%kmesh%mesh(1), 3, stdout, seedname, comm) + call comms_bcast(pw90_dos%smearing%adaptive_max_width, 1, stdout, seedname, comm) + call comms_bcast(pw90_dos%smearing%fixed_width, 1, stdout, seedname, comm) + call comms_bcast(pw90_dos%smearing%adaptive_prefactor, 1, stdout, seedname, comm) + call comms_bcast(pw90_dos%num_project, 1, stdout, seedname, comm) + + call comms_bcast(pw90_calculation%berry, 1, stdout, seedname, comm) + call comms_bcast(pw90_berry%task, len(pw90_berry%task), stdout, seedname, comm) + call comms_bcast(pw90_berry%kmesh%spacing, 1, stdout, seedname, comm) + call comms_bcast(pw90_berry%kmesh%mesh(1), 3, stdout, seedname, comm) + call comms_bcast(pw90_berry%curv_adpt_kmesh, 1, stdout, seedname, comm) + call comms_bcast(pw90_berry%curv_adpt_kmesh_thresh, 1, stdout, seedname, comm) + call comms_bcast(pw90_berry%curv_unit, len(pw90_berry%curv_unit), stdout, seedname, comm) ! Tsirkin - call comms_bcast(gyrotropic, 1) - call comms_bcast(gyrotropic_task, len(gyrotropic_task)) - call comms_bcast(gyrotropic_kmesh_spacing, 1) - call comms_bcast(gyrotropic_kmesh(1), 3) - call comms_bcast(gyrotropic_smr_fixed_en_width, 1) - call comms_bcast(gyrotropic_smr_index, 1) - call comms_bcast(gyrotropic_eigval_max, 1) - call comms_bcast(gyrotropic_nfreq, 1) - call comms_bcast(gyrotropic_degen_thresh, 1) - call comms_bcast(gyrotropic_num_bands, 1) - call comms_bcast(gyrotropic_box(1, 1), 9) - call comms_bcast(gyrotropic_box_corner(1), 3) - call comms_bcast(gyrotropic_smr_max_arg, 1) - call comms_bcast(gyrotropic_smr_fixed_en_width, 1) - call comms_bcast(gyrotropic_smr_index, 1) - - call comms_bcast(spinors, 1) - - call comms_bcast(shc_freq_scan, 1) - call comms_bcast(shc_alpha, 1) - call comms_bcast(shc_beta, 1) - call comms_bcast(shc_gamma, 1) - call comms_bcast(shc_bandshift, 1) - call comms_bcast(shc_bandshift_firstband, 1) - call comms_bcast(shc_bandshift_energyshift, 1) - call comms_bcast(shc_method, len(shc_method)) - - call comms_bcast(kubo_adpt_smr, 1) - call comms_bcast(kubo_adpt_smr_fac, 1) - call comms_bcast(kubo_adpt_smr_max, 1) - call comms_bcast(kubo_smr_fixed_en_width, 1) - call comms_bcast(kubo_smr_index, 1) - call comms_bcast(kubo_eigval_max, 1) - call comms_bcast(kubo_nfreq, 1) - call comms_bcast(nfermi, 1) - call comms_bcast(dos_energy_min, 1) - call comms_bcast(dos_energy_max, 1) - call comms_bcast(spin_kmesh_spacing, 1) - call comms_bcast(spin_kmesh(1), 3) - call comms_bcast(wanint_kpoint_file, 1) - call comms_bcast(dis_win_min, 1) - call comms_bcast(dis_win_max, 1) - call comms_bcast(sc_eta, 1) - call comms_bcast(sc_w_thr, 1) - call comms_bcast(sc_phase_conv, 1) - call comms_bcast(sc_use_eta_corr, 1) + call comms_bcast(pw90_calculation%gyrotropic, 1, stdout, seedname, comm) + call comms_bcast(pw90_gyrotropic%task, len(pw90_gyrotropic%task), stdout, seedname, comm) + call comms_bcast(pw90_gyrotropic%kmesh%spacing, 1, stdout, seedname, comm) + call comms_bcast(pw90_gyrotropic%kmesh%mesh(1), 3, stdout, seedname, comm) + call comms_bcast(pw90_gyrotropic%eigval_max, 1, stdout, seedname, comm) + call comms_bcast(pw90_gyrotropic%nfreq, 1, stdout, seedname, comm) + call comms_bcast(pw90_gyrotropic%degen_thresh, 1, stdout, seedname, comm) + call comms_bcast(pw90_gyrotropic%num_bands, 1, stdout, seedname, comm) + call comms_bcast(pw90_gyrotropic%box(1, 1), 9, stdout, seedname, comm) + call comms_bcast(pw90_gyrotropic%box_corner(1), 3, stdout, seedname, comm) + call comms_bcast(pw90_gyrotropic%smearing%use_adaptive, 1, stdout, seedname, comm) + call comms_bcast(pw90_gyrotropic%smearing%fixed_width, 1, stdout, seedname, comm) + call comms_bcast(pw90_gyrotropic%smearing%type_index, 1, stdout, seedname, comm) + call comms_bcast(pw90_gyrotropic%smearing%max_arg, 1, stdout, seedname, comm) + + call comms_bcast(w90_system%spinors, 1, stdout, seedname, comm) + + call comms_bcast(pw90_spin_hall%freq_scan, 1, stdout, seedname, comm) + call comms_bcast(pw90_spin_hall%alpha, 1, stdout, seedname, comm) + call comms_bcast(pw90_spin_hall%beta, 1, stdout, seedname, comm) + call comms_bcast(pw90_spin_hall%gamma, 1, stdout, seedname, comm) + call comms_bcast(pw90_spin_hall%bandshift, 1, stdout, seedname, comm) + call comms_bcast(pw90_spin_hall%bandshift_firstband, 1, stdout, seedname, comm) + call comms_bcast(pw90_spin_hall%bandshift_energyshift, 1, stdout, seedname, comm) + call comms_bcast(pw90_spin_hall%method, len(pw90_spin_hall%method), stdout, seedname, comm) + + call comms_bcast(pw90_berry%kubo_smearing%use_adaptive, 1, stdout, seedname, comm) + call comms_bcast(pw90_berry%kubo_smearing%adaptive_prefactor, 1, stdout, seedname, comm) + call comms_bcast(pw90_berry%kubo_smearing%adaptive_max_width, 1, stdout, seedname, comm) + call comms_bcast(pw90_berry%kubo_smearing%fixed_width, 1, stdout, seedname, comm) + call comms_bcast(pw90_berry%kubo_smearing%type_index, 1, stdout, seedname, comm) + call comms_bcast(pw90_berry%kubo_eigval_max, 1, stdout, seedname, comm) + call comms_bcast(pw90_berry%kubo_nfreq, 1, stdout, seedname, comm) + fermi_n = 0 + if (on_root) then + if (allocated(fermi_energy_list)) fermi_n = size(fermi_energy_list) + endif + call comms_bcast(fermi_n, 1, stdout, seedname, comm) + call comms_bcast(pw90_dos%energy_min, 1, stdout, seedname, comm) + call comms_bcast(pw90_dos%energy_max, 1, stdout, seedname, comm) + call comms_bcast(pw90_spin%kmesh%spacing, 1, stdout, seedname, comm) + call comms_bcast(pw90_spin%kmesh%mesh(1), 3, stdout, seedname, comm) + call comms_bcast(pw90_berry%wanint_kpoint_file, 1, stdout, seedname, comm) + call comms_bcast(dis_manifold%win_min, 1, stdout, seedname, comm) + call comms_bcast(dis_manifold%win_max, 1, stdout, seedname, comm) + call comms_bcast(pw90_berry%sc_eta, 1, stdout, seedname, comm) + call comms_bcast(pw90_berry%sc_w_thr, 1, stdout, seedname, comm) + call comms_bcast(pw90_berry%sc_phase_conv, 1, stdout, seedname, comm) + call comms_bcast(pw90_berry%sc_use_eta_corr, 1, stdout, seedname, comm) ! ---------------------------------------------- ! ! New input variables in development ! - call comms_bcast(devel_flag, len(devel_flag)) - call comms_bcast(spin_moment, 1) - call comms_bcast(spin_axis_polar, 1) - call comms_bcast(spin_axis_azimuth, 1) - call comms_bcast(spin_decomp, 1) - call comms_bcast(use_degen_pert, 1) - call comms_bcast(degen_thr, 1) - call comms_bcast(num_valence_bands, 1) - call comms_bcast(dos, 1) - call comms_bcast(dos_task, len(dos_task)) - call comms_bcast(kpath, 1) - call comms_bcast(kpath_task, len(kpath_task)) - call comms_bcast(kpath_bands_colour, len(kpath_bands_colour)) - call comms_bcast(kslice, 1) - call comms_bcast(kslice_task, len(kslice_task)) - call comms_bcast(kslice_corner(1), 3) - call comms_bcast(kslice_b1(1), 3) - call comms_bcast(kslice_b2(1), 3) - call comms_bcast(kslice_2dkmesh(1), 2) - call comms_bcast(kslice_fermi_lines_colour, len(kslice_fermi_lines_colour)) - call comms_bcast(transl_inv, 1) - call comms_bcast(num_elec_per_state, 1) - call comms_bcast(scissors_shift, 1) - ! + !call comms_bcast(print_output%devel_flag, len(print_output%devel_flag), stdout, seedname, comm) + call comms_bcast(pw90_calculation%spin_moment, 1, stdout, seedname, comm) + call comms_bcast(pw90_spin%axis_polar, 1, stdout, seedname, comm) + call comms_bcast(pw90_spin%axis_azimuth, 1, stdout, seedname, comm) + call comms_bcast(pw90_calculation%spin_decomp, 1, stdout, seedname, comm) + call comms_bcast(pw90_band_deriv_degen%use_degen_pert, 1, stdout, seedname, comm) + call comms_bcast(pw90_band_deriv_degen%degen_thr, 1, stdout, seedname, comm) + call comms_bcast(w90_system%num_valence_bands, 1, stdout, seedname, comm) + call comms_bcast(pw90_calculation%dos, 1, stdout, seedname, comm) + call comms_bcast(pw90_dos%task, len(pw90_dos%task), stdout, seedname, comm) + call comms_bcast(pw90_calculation%kpath, 1, stdout, seedname, comm) + call comms_bcast(pw90_kpath%task, len(pw90_kpath%task), stdout, seedname, comm) + call comms_bcast(pw90_kpath%bands_colour, len(pw90_kpath%bands_colour), stdout, seedname, comm) + call comms_bcast(pw90_calculation%kslice, 1, stdout, seedname, comm) + call comms_bcast(pw90_kslice%task, len(pw90_kslice%task), stdout, seedname, comm) + call comms_bcast(pw90_kslice%corner(1), 3, stdout, seedname, comm) + call comms_bcast(pw90_kslice%b1(1), 3, stdout, seedname, comm) + call comms_bcast(pw90_kslice%b2(1), 3, stdout, seedname, comm) + call comms_bcast(pw90_kslice%kmesh2d(1), 2, stdout, seedname, comm) + call comms_bcast(pw90_kslice%fermi_lines_colour, len(pw90_kslice%fermi_lines_colour), stdout, & + seedname, comm) + call comms_bcast(pw90_berry%transl_inv, 1, stdout, seedname, comm) + call comms_bcast(w90_system%num_elec_per_state, 1, stdout, seedname, comm) + call comms_bcast(scissors_shift, 1, stdout, seedname, comm) + ! Do these have to be broadcasted? (Plots done on root node only) ! ! call comms_bcast(bands_num_points,1) @@ -352,83 +432,86 @@ subroutine pw90common_wanint_param_dist ! if(allocated(bands_label)) & ! call comms_bcast(bands_label(:),len(bands_label(1))*bands_num_spec_points) ! ---------------------------------------------- - call comms_bcast(geninterp, 1) - call comms_bcast(geninterp_alsofirstder, 1) - call comms_bcast(geninterp_single_file, 1) + call comms_bcast(pw90_calculation%geninterp, 1, stdout, seedname, comm) + call comms_bcast(pw90_geninterp%alsofirstder, 1, stdout, seedname, comm) + call comms_bcast(pw90_geninterp%single_file, 1, stdout, seedname, comm) ! [gp-begin, Apr 12, 2012] ! BoltzWann variables - call comms_bcast(boltzwann, 1) - call comms_bcast(boltz_calc_also_dos, 1) - call comms_bcast(boltz_2d_dir_num, 1) - call comms_bcast(boltz_dos_energy_step, 1) - call comms_bcast(boltz_dos_energy_min, 1) - call comms_bcast(boltz_dos_energy_max, 1) - call comms_bcast(boltz_dos_adpt_smr, 1) - call comms_bcast(boltz_dos_smr_fixed_en_width, 1) - call comms_bcast(boltz_dos_adpt_smr_fac, 1) - call comms_bcast(boltz_dos_adpt_smr_max, 1) - call comms_bcast(boltz_mu_min, 1) - call comms_bcast(boltz_mu_max, 1) - call comms_bcast(boltz_mu_step, 1) - call comms_bcast(boltz_temp_min, 1) - call comms_bcast(boltz_temp_max, 1) - call comms_bcast(boltz_temp_step, 1) - call comms_bcast(boltz_kmesh_spacing, 1) - call comms_bcast(boltz_kmesh(1), 3) - call comms_bcast(boltz_tdf_energy_step, 1) - call comms_bcast(boltz_relax_time, 1) - call comms_bcast(boltz_TDF_smr_fixed_en_width, 1) - call comms_bcast(boltz_TDF_smr_index, 1) - call comms_bcast(boltz_dos_smr_index, 1) - call comms_bcast(boltz_bandshift, 1) - call comms_bcast(boltz_bandshift_firstband, 1) - call comms_bcast(boltz_bandshift_energyshift, 1) + call comms_bcast(pw90_calculation%boltzwann, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%calc_also_dos, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%dir_num_2d, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%dos_energy_step, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%dos_energy_min, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%dos_energy_max, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%dos_smearing%use_adaptive, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%dos_smearing%fixed_width, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%dos_smearing%adaptive_prefactor, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%dos_smearing%adaptive_max_width, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%mu_min, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%mu_max, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%mu_step, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%temp_min, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%temp_max, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%temp_step, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%kmesh%spacing, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%kmesh%mesh(1), 3, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%tdf_energy_step, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%relax_time, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%tdf_smearing%use_adaptive, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%tdf_smearing%fixed_width, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%tdf_smearing%type_index, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%dos_smearing%type_index, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%bandshift, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%bandshift_firstband, 1, stdout, seedname, comm) + call comms_bcast(pw90_boltzwann%bandshift_energyshift, 1, stdout, seedname, comm) ! [gp-end] - call comms_bcast(use_ws_distance, 1) + call comms_bcast(ws_region%use_ws_distance, 1, stdout, seedname, comm) ! These variables are different from the ones above in that they are - ! allocatable, and in param_read they were allocated on the root node only - ! + ! allocatable, and in w90_wannier90_readwrite_read they were allocated on the root node only + if (.not. on_root) then - allocate (fermi_energy_list(nfermi), stat=ierr) + allocate (fermi_energy_list(fermi_n), stat=ierr) if (ierr /= 0) call io_error( & - 'Error allocating fermi_energy_read in postw90_param_dist') - allocate (kubo_freq_list(kubo_nfreq), stat=ierr) + 'Error allocating fermi_energy_read in postw90_w90_wannier90_readwrite_dist', stdout, seedname) + allocate (pw90_berry%kubo_freq_list(pw90_berry%kubo_nfreq), stat=ierr) if (ierr /= 0) call io_error( & - 'Error allocating kubo_freq_list in postw90_param_dist') + 'Error allocating kubo_freq_list in postw90_w90_wannier90_readwrite_dist', stdout, seedname) - allocate (gyrotropic_band_list(gyrotropic_num_bands), stat=ierr) + allocate (pw90_gyrotropic%band_list(pw90_gyrotropic%num_bands), stat=ierr) if (ierr /= 0) call io_error( & - 'Error allocating gyrotropic_band_list in postw90_param_dist') + 'Error allocating gyrotropic_band_list in postw90_w90_wannier90_readwrite_dist', stdout, seedname) - allocate (gyrotropic_freq_list(gyrotropic_nfreq), stat=ierr) + allocate (pw90_gyrotropic%freq_list(pw90_gyrotropic%nfreq), stat=ierr) if (ierr /= 0) call io_error( & - 'Error allocating gyrotropic_freq_list in postw90_param_dist') + 'Error allocating gyrotropic_freq_list in postw90_w90_wannier90_readwrite_dist', stdout, seedname) - allocate (dos_project(num_dos_project), stat=ierr) + allocate (pw90_dos%project(pw90_dos%num_project), stat=ierr) if (ierr /= 0) & - call io_error('Error allocating dos_project in postw90_param_dist') + call io_error('Error allocating dos_project in postw90_w90_wannier90_readwrite_dist', stdout, seedname) if (.not. effective_model) then if (eig_found) then allocate (eigval(num_bands, num_kpts), stat=ierr) if (ierr /= 0) & - call io_error('Error allocating eigval in postw90_param_dist') + call io_error('Error allocating eigval in postw90_w90_wannier90_readwrite_dist', stdout, seedname) end if allocate (kpt_latt(3, num_kpts), stat=ierr) if (ierr /= 0) & - call io_error('Error allocating kpt_latt in postw90_param_dist') + call io_error('Error allocating kpt_latt in postw90_w90_wannier90_readwrite_dist', stdout, seedname) endif end if - if (nfermi > 0) call comms_bcast(fermi_energy_list(1), nfermi) - call comms_bcast(gyrotropic_freq_list(1), gyrotropic_nfreq) - call comms_bcast(gyrotropic_band_list(1), gyrotropic_num_bands) - call comms_bcast(kubo_freq_list(1), kubo_nfreq) - call comms_bcast(dos_project(1), num_dos_project) + + if (fermi_n > 0) call comms_bcast(fermi_energy_list(1), fermi_n, stdout, seedname, comm) + call comms_bcast(pw90_gyrotropic%freq_list(1), pw90_gyrotropic%nfreq, stdout, seedname, comm) + call comms_bcast(pw90_gyrotropic%band_list(1), pw90_gyrotropic%num_bands, stdout, seedname, & + comm) + call comms_bcast(pw90_berry%kubo_freq_list(1), pw90_berry%kubo_nfreq, stdout, seedname, comm) + call comms_bcast(pw90_dos%project(1), pw90_dos%num_project, stdout, seedname, comm) if (.not. effective_model) then if (eig_found) then - call comms_bcast(eigval(1, 1), num_bands*num_kpts) + call comms_bcast(eigval(1, 1), num_bands*num_kpts, stdout, seedname, comm) end if - call comms_bcast(kpt_latt(1, 1), 3*num_kpts) + call comms_bcast(kpt_latt(1, 1), 3*num_kpts, stdout, seedname, comm) endif ! kmesh: only nntot,wb, and bk are needed to evaluate the WF matrix @@ -438,69 +521,93 @@ subroutine pw90common_wanint_param_dist if (.not. effective_model) then - call comms_bcast(nnh, 1) - call comms_bcast(nntot, 1) + call comms_bcast(kmesh_info%nnh, 1, stdout, seedname, comm) + call comms_bcast(kmesh_info%nntot, 1, stdout, seedname, comm) if (.not. on_root) then - allocate (nnlist(num_kpts, nntot), stat=ierr) + allocate (kmesh_info%nnlist(num_kpts, kmesh_info%nntot), stat=ierr) if (ierr /= 0) & - call io_error('Error in allocating nnlist in pw90common_wanint_param_dist') - allocate (neigh(num_kpts, nntot/2), stat=ierr) + call io_error('Error in allocating nnlist in pw90common_wanint_w90_wannier90_readwrite_dist', stdout, & + seedname) + allocate (kmesh_info%neigh(num_kpts, kmesh_info%nntot/2), stat=ierr) if (ierr /= 0) & - call io_error('Error in allocating neigh in pw90common_wanint_param_dist') - allocate (nncell(3, num_kpts, nntot), stat=ierr) + call io_error('Error in allocating neigh in pw90common_wanint_w90_wannier90_readwrite_dist', stdout, & + seedname) + allocate (kmesh_info%nncell(3, num_kpts, kmesh_info%nntot), stat=ierr) if (ierr /= 0) & - call io_error('Error in allocating nncell in pw90common_wanint_param_dist') - allocate (wb(nntot), stat=ierr) + call io_error('Error in allocating nncell in pw90common_wanint_w90_wannier90_readwrite_dist', stdout, & + seedname) + allocate (kmesh_info%wb(kmesh_info%nntot), stat=ierr) if (ierr /= 0) & - call io_error('Error in allocating wb in pw90common_wanint_param_dist') - allocate (bka(3, nntot/2), stat=ierr) + call io_error('Error in allocating wb in pw90common_wanint_w90_wannier90_readwrite_dist', stdout, seedname) + allocate (kmesh_info%bka(3, kmesh_info%nntot/2), stat=ierr) if (ierr /= 0) & - call io_error('Error in allocating bka in pw90common_wanint_param_dist') - allocate (bk(3, nntot, num_kpts), stat=ierr) + call io_error('Error in allocating bka in pw90common_wanint_w90_wannier90_readwrite_dist', stdout, seedname) + allocate (kmesh_info%bk(3, kmesh_info%nntot, num_kpts), stat=ierr) if (ierr /= 0) & - call io_error('Error in allocating bk in pw90common_wanint_param_dist') + call io_error('Error in allocating bk in pw90common_wanint_w90_wannier90_readwrite_dist', stdout, seedname) end if - call comms_bcast(nnlist(1, 1), num_kpts*nntot) - call comms_bcast(neigh(1, 1), num_kpts*nntot/2) - call comms_bcast(nncell(1, 1, 1), 3*num_kpts*nntot) - call comms_bcast(wb(1), nntot) - call comms_bcast(bka(1, 1), 3*nntot/2) - call comms_bcast(bk(1, 1, 1), 3*nntot*num_kpts) + call comms_bcast(kmesh_info%nnlist(1, 1), num_kpts*kmesh_info%nntot, stdout, seedname, comm) + call comms_bcast(kmesh_info%neigh(1, 1), num_kpts*kmesh_info%nntot/2, stdout, seedname, comm) + call comms_bcast(kmesh_info%nncell(1, 1, 1), 3*num_kpts*kmesh_info%nntot, stdout, seedname, & + comm) + call comms_bcast(kmesh_info%wb(1), kmesh_info%nntot, stdout, seedname, comm) + call comms_bcast(kmesh_info%bka(1, 1), 3*kmesh_info%nntot/2, stdout, seedname, comm) + call comms_bcast(kmesh_info%bk(1, 1, 1), 3*kmesh_info%nntot*num_kpts, stdout, seedname, comm) endif - end subroutine pw90common_wanint_param_dist + end subroutine pw90common_wanint_w90_wannier90_readwrite_dist - !===========================================================! - subroutine pw90common_wanint_data_dist - !===========================================================! - ! ! + !================================================! + subroutine pw90common_wanint_data_dist(num_wann, num_kpts, num_bands, u_matrix_opt, u_matrix, & + dis_manifold, wannier_data, scissors_shift, v_matrix, & + num_valence_bands, have_disentangled, stdout, seedname, & + comm) + !================================================! + ! !! Distribute the um and chk files - ! ! - !===========================================================! + ! + !================================================! - use w90_constants, only: dp, cmplx_0, cmplx_i, twopi + use w90_constants, only: dp, cmplx_0 use w90_io, only: io_error, io_file_unit, & io_date, io_time, io_stopwatch - use w90_parameters, only: num_wann, num_kpts, num_bands, have_disentangled, & - u_matrix_opt, u_matrix, m_matrix, & - ndimwin, lwindow, nntot, wannier_centres, & - num_valence_bands, scissors_shift + use w90_types, only: dis_manifold_type, wannier_data_type + use w90_comms, only: w90comm_type, mpirank, comms_bcast implicit none + type(dis_manifold_type), intent(inout) :: dis_manifold + type(wannier_data_type), intent(inout) :: wannier_data + type(w90comm_type), intent(in) :: comm + + integer, intent(in) :: num_valence_bands + integer, intent(in) :: num_wann, num_kpts, num_bands + integer, intent(in) :: stdout + real(kind=dp), intent(in) :: scissors_shift + complex(kind=dp), allocatable :: v_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: u_matrix_opt(:, :, :), u_matrix(:, :, :) + logical, intent(inout) :: have_disentangled + + character(len=50), intent(in) :: seedname + integer :: ierr, loop_kpt, m, i, j + logical :: on_root = .false. + + if (mpirank(comm) == 0) on_root = .true. if (.not. on_root) then - ! wannier_centres is allocated in param_read, so only on root node - ! It is then read in param_read_chpkt + ! wannier_centres is allocated in w90_wannier90_readwrite_read, so only on root node + ! It is then read in w90_wannier90_readwrite_read_chpkt ! Therefore, now we need to allocate it on all nodes, and then broadcast it - allocate (wannier_centres(3, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating wannier_centres in pw90common_wanint_data_dist') + allocate (wannier_data%centres(3, num_wann), stat=ierr) + if (ierr /= 0) & + call io_error('Error allocating wannier_centres in pw90common_wanint_data_dist', & + stdout, seedname) end if - call comms_bcast(wannier_centres(1, 1), 3*num_wann) + call comms_bcast(wannier_data%centres(1, 1), 3*num_wann, stdout, seedname, comm) ! ------------------- ! Ivo: added 8april11 @@ -513,16 +620,16 @@ subroutine pw90common_wanint_data_dist ! Allocate on all nodes allocate (v_matrix(num_bands, num_wann, num_kpts), stat=ierr) if (ierr /= 0) & - call io_error('Error allocating v_matrix in pw90common_wanint_data_dist') + call io_error('Error allocating v_matrix in pw90common_wanint_data_dist', stdout, seedname) ! u_matrix and u_matrix_opt are stored on root only if (on_root) then if (.not. have_disentangled) then - v_matrix = u_matrix + v_matrix(1:num_wann, :, :) = u_matrix(1:num_wann, :, :) else v_matrix = cmplx_0 do loop_kpt = 1, num_kpts do j = 1, num_wann - do m = 1, ndimwin(loop_kpt) + do m = 1, dis_manifold%ndimwin(loop_kpt) do i = 1, num_wann v_matrix(m, j, loop_kpt) = v_matrix(m, j, loop_kpt) & + u_matrix_opt(m, i, loop_kpt)*u_matrix(i, j, loop_kpt) @@ -536,15 +643,15 @@ subroutine pw90common_wanint_data_dist if (allocated(u_matrix)) deallocate (u_matrix) endif endif - call comms_bcast(v_matrix(1, 1, 1), num_bands*num_wann*num_kpts) + call comms_bcast(v_matrix(1, 1, 1), num_bands*num_wann*num_kpts, stdout, seedname, comm) if (num_valence_bands > 0 .and. abs(scissors_shift) > 1.0e-7_dp) then if (.not. on_root .and. .not. allocated(u_matrix)) then allocate (u_matrix(num_wann, num_wann, num_kpts), stat=ierr) if (ierr /= 0) & - call io_error('Error allocating u_matrix in pw90common_wanint_data_dist') + call io_error('Error allocating u_matrix in pw90common_wanint_data_dist', stdout, seedname) endif - call comms_bcast(u_matrix(1, 1, 1), num_wann*num_wann*num_kpts) + call comms_bcast(u_matrix(1, 1, 1), num_wann*num_wann*num_kpts, stdout, seedname, comm) endif ! if (.not.on_root .and. .not.allocated(m_matrix)) then @@ -554,7 +661,7 @@ subroutine pw90common_wanint_data_dist ! endif ! call comms_bcast(m_matrix(1,1,1,1),num_wann*num_wann*nntot*num_kpts) - call comms_bcast(have_disentangled, 1) + call comms_bcast(have_disentangled, 1, stdout, seedname, comm) if (have_disentangled) then if (.not. on_root) then @@ -568,38 +675,43 @@ subroutine pw90common_wanint_data_dist ! call io_error('Error allocating u_matrix_opt in pw90common_wanint_data_dist') ! endif - if (.not. allocated(lwindow)) then - allocate (lwindow(num_bands, num_kpts), stat=ierr) + if (.not. allocated(dis_manifold%lwindow)) then + allocate (dis_manifold%lwindow(num_bands, num_kpts), stat=ierr) if (ierr /= 0) & - call io_error('Error allocating lwindow in pw90common_wanint_data_dist') + call io_error('Error allocating lwindow in pw90common_wanint_data_dist', stdout, & + seedname) endif - if (.not. allocated(ndimwin)) then - allocate (ndimwin(num_kpts), stat=ierr) + if (.not. allocated(dis_manifold%ndimwin)) then + allocate (dis_manifold%ndimwin(num_kpts), stat=ierr) if (ierr /= 0) & - call io_error('Error allocating ndimwin in pw90common_wanint_data_dist') + call io_error('Error allocating ndimwin in pw90common_wanint_data_dist', stdout, & + seedname) endif end if ! call comms_bcast(u_matrix_opt(1,1,1),num_bands*num_wann*num_kpts) - call comms_bcast(lwindow(1, 1), num_bands*num_kpts) - call comms_bcast(ndimwin(1), num_kpts) + call comms_bcast(dis_manifold%lwindow(1, 1), num_bands*num_kpts, stdout, seedname, comm) + call comms_bcast(dis_manifold%ndimwin(1), num_kpts, stdout, seedname, comm) end if end subroutine pw90common_wanint_data_dist -!======================================================================= +!================================================ - subroutine pw90common_get_occ(eig, occ, ef) + subroutine pw90common_get_occ(ef, eig, occ, num_wann) + !================================================! + ! !! Compute the electronic occupancy + ! + !================================================! - use w90_constants, only: dp !,eps7 - use w90_parameters, only: num_wann !,smear_temp -! use w90_constants, only : elem_charge_SI,k_B_SI + use w90_constants, only: dp + + ! arguments + integer, intent(in) :: num_wann - ! Arguments - ! real(kind=dp), intent(in) :: eig(num_wann) !! Eigenvalues real(kind=dp), intent(in) :: ef @@ -607,13 +719,10 @@ subroutine pw90common_get_occ(eig, occ, ef) real(kind=dp), intent(out) :: occ(num_wann) !! Occupancy of states - ! Misc/Dummy - ! - integer :: i -! real(kind=dp) :: kt + ! local variables + integer :: i ! State occupancies - ! ! if(smear_temp < eps7) then ! ! Use a step function occupancy (T=0) @@ -636,17 +745,16 @@ subroutine pw90common_get_occ(eig, occ, ef) end subroutine pw90common_get_occ -!======================================================================= - - function kmesh_spacing_singleinteger(num_points) - + !================================================ + function kmesh_spacing_singleinteger(num_points, recip_lattice) + !================================================ !! Set up the value of the interpolation mesh spacing, needed for !! adaptive smearing [see Eqs. (34-35) YWVS07]. Choose it as the largest of !! the three Delta_k's for each of the primitive translations b1, b2, and b3 - - use w90_parameters, only: recip_lattice + !================================================ integer, intent(in) :: num_points + real(kind=dp), intent(in) :: recip_lattice(3, 3) real(kind=dp) :: kmesh_spacing_singleinteger integer :: i @@ -658,35 +766,35 @@ function kmesh_spacing_singleinteger(num_points) ! (See my e-mail of 20Sept07) ! do i = 1, 3 - Delta_k_i(i) = sqrt(dot_product(recip_lattice(i, :), recip_lattice(i, :))) & - /num_points + Delta_k_i(i) = sqrt(dot_product(recip_lattice(i, :), recip_lattice(i, :)))/num_points end do kmesh_spacing_singleinteger = maxval(Delta_k_i) end function kmesh_spacing_singleinteger - function kmesh_spacing_mesh(mesh) + function kmesh_spacing_mesh(mesh, recip_lattice) !! Same as kmesh_spacing_singleinteger, but for a kmesh with three !! different mesh samplings along the three directions - use w90_parameters, only: recip_lattice integer, dimension(3), intent(in) :: mesh - real(kind=dp) :: kmesh_spacing_mesh + real(kind=dp), intent(in) :: recip_lattice(3, 3) + real(kind=dp) :: kmesh_spacing_mesh integer :: i real(kind=dp) :: Delta_k_i(3) do i = 1, 3 - Delta_k_i(i) = sqrt(dot_product(recip_lattice(i, :), recip_lattice(i, :))) & - /mesh(i) + Delta_k_i(i) = sqrt(dot_product(recip_lattice(i, :), recip_lattice(i, :)))/mesh(i) end do kmesh_spacing_mesh = maxval(Delta_k_i) end function kmesh_spacing_mesh - ! - !=========================================================! - subroutine pw90common_fourier_R_to_k(kpt, OO_R, OO, alpha) - !=========================================================! - ! ! + + !================================================! + subroutine pw90common_fourier_R_to_k(ws_region, wannier_data, ws_distance, wigner_seitz, OO, & + OO_R, kpt, real_lattice, mp_grid, alpha, num_wann, & + seedname, stdout) + !================================================! + ! !! For alpha=0: !! O_ij(R) --> O_ij(k) = sum_R e^{+ik.R}*O_ij(R) !! @@ -694,43 +802,60 @@ subroutine pw90common_fourier_R_to_k(kpt, OO_R, OO, alpha) !! sum_R [cmplx_i*R_alpha*e^{+ik.R}*O_ij(R)] !! where R_alpha is a Cartesian component of R !! ***REMOVE EVENTUALLY*** (replace with pw90common_fourier_R_to_k_new) - - ! ! - !=========================================================! + ! + !================================================! use w90_constants, only: dp, cmplx_0, cmplx_i, twopi - use w90_parameters, only: num_kpts, kpt_latt, num_wann, use_ws_distance - use w90_ws_distance, only: irdist_ws, crdist_ws, & - wdist_ndeg, ws_translate_dist + use w90_types, only: wannier_data_type, ws_region_type, ws_distance_type + use w90_ws_distance, only: ws_translate_dist + use w90_postw90_types, only: wigner_seitz_type implicit none - ! Arguments - ! - real(kind=dp) :: kpt(3) - complex(kind=dp), dimension(:, :, :), intent(in) :: OO_R - complex(kind=dp), dimension(:, :), intent(out) :: OO - integer :: alpha + ! arguments + type(ws_region_type), intent(in) :: ws_region + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(in) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + integer, intent(in) :: num_wann + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + integer, intent(in) :: alpha + real(kind=dp), intent(in) :: kpt(3), real_lattice(3, 3) + + complex(kind=dp), intent(in) :: OO_R(:, :, :) + complex(kind=dp), intent(out) :: OO(:, :) + + character(len=50), intent(in) :: seedname + + ! local variables integer :: ir, i, j, ideg real(kind=dp) :: rdotk complex(kind=dp) :: phase_fac - if (use_ws_distance) CALL ws_translate_dist(nrpts, irvec) + if (ws_region%use_ws_distance) then + CALL ws_translate_dist(ws_distance, stdout, seedname, ws_region, num_wann, & + wannier_data%centres, real_lattice, mp_grid, wigner_seitz%nrpts, & + wigner_seitz%irvec) + endif OO(:, :) = cmplx_0 - do ir = 1, nrpts + do ir = 1, wigner_seitz%nrpts ! [lp] Shift the WF to have the minimum distance IJ, see also ws_distance.F90 - if (use_ws_distance) then + if (ws_region%use_ws_distance) then do j = 1, num_wann do i = 1, num_wann - do ideg = 1, wdist_ndeg(i, j, ir) - rdotk = twopi*dot_product(kpt(:), real(irdist_ws(:, ideg, i, j, ir), dp)) - phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(ndegen(ir)*wdist_ndeg(i, j, ir), dp) + do ideg = 1, ws_distance%ndeg(i, j, ir) + rdotk = twopi*dot_product(kpt(:), real(ws_distance%irdist(:, ideg, i, j, ir), dp)) + phase_fac = cmplx(cos(rdotk), sin(rdotk), dp) & + /real(wigner_seitz%ndegen(ir)*ws_distance%ndeg(i, j, ir), dp) if (alpha == 0) then OO(i, j) = OO(i, j) + phase_fac*OO_R(i, j, ir) elseif (alpha == 1 .or. alpha == 2 .or. alpha == 3) then - OO(i, j) = OO(i, j) + cmplx_i*crdist_ws(alpha, ideg, i, j, ir)*phase_fac*OO_R(i, j, ir) + OO(i, j) = OO(i, j) + cmplx_i*ws_distance%crdist(alpha, ideg, i, j, ir) & + *phase_fac*OO_R(i, j, ir) else stop 'wrong value of alpha in pw90common_fourier_R_to_k' endif @@ -739,13 +864,13 @@ subroutine pw90common_fourier_R_to_k(kpt, OO_R, OO, alpha) enddo else ! [lp] Original code, without IJ-dependent shift: - rdotk = twopi*dot_product(kpt(:), irvec(:, ir)) - phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(ndegen(ir), dp) + rdotk = twopi*dot_product(kpt(:), wigner_seitz%irvec(:, ir)) + phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(wigner_seitz%ndegen(ir), dp) if (alpha == 0) then OO(:, :) = OO(:, :) + phase_fac*OO_R(:, :, ir) elseif (alpha == 1 .or. alpha == 2 .or. alpha == 3) then OO(:, :) = OO(:, :) + & - cmplx_i*crvec(alpha, ir)*phase_fac*OO_R(:, :, ir) + cmplx_i*wigner_seitz%crvec(alpha, ir)*phase_fac*OO_R(:, :, ir) else stop 'wrong value of alpha in pw90common_fourier_R_to_k' endif @@ -755,86 +880,107 @@ subroutine pw90common_fourier_R_to_k(kpt, OO_R, OO, alpha) end subroutine pw90common_fourier_R_to_k - ! ***NEW*** - ! - !=========================================================! - subroutine pw90common_fourier_R_to_k_new(kpt, OO_R, OO, OO_dx, OO_dy, OO_dz) - !=======================================================! - ! ! + !================================================! + subroutine pw90common_fourier_R_to_k_new(ws_region, wannier_data, ws_distance, wigner_seitz, & + OO_R, kpt, real_lattice, mp_grid, num_wann, seedname, & + stdout, OO, OO_dx, OO_dy, OO_dz) + !================================================! + ! !! For OO: !! $$O_{ij}(k) = \sum_R e^{+ik.R}.O_{ij}(R)$$ !! For $$OO_{dx,dy,dz}$$: !! $$\sum_R [i.R_{dx,dy,dz}.e^{+ik.R}.O_{ij}(R)]$$ !! where R_{x,y,z} are the Cartesian components of R - ! ! - !=======================================================! + ! + !================================================! use w90_constants, only: dp, cmplx_0, cmplx_i, twopi - use w90_parameters, only: timing_level, num_kpts, kpt_latt, num_wann, use_ws_distance - use w90_ws_distance, only: irdist_ws, crdist_ws, wdist_ndeg, ws_translate_dist + use w90_types, only: ws_region_type, wannier_data_type, ws_distance_type + use w90_ws_distance, only: ws_translate_dist + use w90_postw90_types, only: wigner_seitz_type implicit none - ! Arguments - ! - real(kind=dp) :: kpt(3) - complex(kind=dp), dimension(:, :, :), intent(in) :: OO_R - complex(kind=dp), optional, dimension(:, :), intent(out) :: OO - complex(kind=dp), optional, dimension(:, :), intent(out) :: OO_dx - complex(kind=dp), optional, dimension(:, :), intent(out) :: OO_dy - complex(kind=dp), optional, dimension(:, :), intent(out) :: OO_dz + ! arguments + type(ws_region_type), intent(in) :: ws_region + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(in) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + integer, intent(in) :: num_wann + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: kpt(3), real_lattice(3, 3) + + complex(kind=dp), intent(in) :: OO_R(:, :, :) + complex(kind=dp), optional, intent(out) :: OO(:, :) + complex(kind=dp), optional, intent(out) :: OO_dx(:, :) + complex(kind=dp), optional, intent(out) :: OO_dy(:, :) + complex(kind=dp), optional, intent(out) :: OO_dz(:, :) + character(len=50), intent(in) :: seedname + + ! local variables integer :: ir, i, j, ideg real(kind=dp) :: rdotk complex(kind=dp) :: phase_fac - if (use_ws_distance) CALL ws_translate_dist(nrpts, irvec) + if (ws_region%use_ws_distance) CALL ws_translate_dist(ws_distance, stdout, seedname, & + ws_region, num_wann, & + wannier_data%centres, real_lattice, & + mp_grid, wigner_seitz%nrpts, & + wigner_seitz%irvec) if (present(OO)) OO = cmplx_0 if (present(OO_dx)) OO_dx = cmplx_0 if (present(OO_dy)) OO_dy = cmplx_0 if (present(OO_dz)) OO_dz = cmplx_0 - do ir = 1, nrpts + do ir = 1, wigner_seitz%nrpts ! [lp] Shift the WF to have the minimum distance IJ, see also ws_distance.F90 - if (use_ws_distance) then + if (ws_region%use_ws_distance) then do j = 1, num_wann do i = 1, num_wann - do ideg = 1, wdist_ndeg(i, j, ir) - rdotk = twopi*dot_product(kpt(:), real(irdist_ws(:, ideg, i, j, ir), dp)) - phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(ndegen(ir)*wdist_ndeg(i, j, ir), dp) + do ideg = 1, ws_distance%ndeg(i, j, ir) + rdotk = twopi*dot_product(kpt(:), real(ws_distance%irdist(:, ideg, i, j, ir), dp)) + phase_fac = cmplx(cos(rdotk), sin(rdotk), dp) & + /real(wigner_seitz%ndegen(ir)*ws_distance%ndeg(i, j, ir), dp) if (present(OO)) OO(i, j) = OO(i, j) + phase_fac*OO_R(i, j, ir) if (present(OO_dx)) OO_dx(i, j) = OO_dx(i, j) + & - cmplx_i*crdist_ws(1, ideg, i, j, ir)* & + cmplx_i*ws_distance%crdist(1, ideg, i, j, ir)* & phase_fac*OO_R(i, j, ir) if (present(OO_dy)) OO_dy(i, j) = OO_dy(i, j) + & - cmplx_i*crdist_ws(2, ideg, i, j, ir)* & + cmplx_i*ws_distance%crdist(2, ideg, i, j, ir)* & phase_fac*OO_R(i, j, ir) if (present(OO_dz)) OO_dz(i, j) = OO_dz(i, j) + & - cmplx_i*crdist_ws(3, ideg, i, j, ir)* & + cmplx_i*ws_distance%crdist(3, ideg, i, j, ir)* & phase_fac*OO_R(i, j, ir) enddo enddo enddo else ! [lp] Original code, without IJ-dependent shift: - rdotk = twopi*dot_product(kpt(:), irvec(:, ir)) - phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(ndegen(ir), dp) + rdotk = twopi*dot_product(kpt(:), wigner_seitz%irvec(:, ir)) + phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(wigner_seitz%ndegen(ir), dp) if (present(OO)) OO(:, :) = OO(:, :) + phase_fac*OO_R(:, :, ir) if (present(OO_dx)) OO_dx(:, :) = OO_dx(:, :) + & - cmplx_i*crvec(1, ir)*phase_fac*OO_R(:, :, ir) + cmplx_i*wigner_seitz%crvec(1, ir)*phase_fac*OO_R(:, :, ir) if (present(OO_dy)) OO_dy(:, :) = OO_dy(:, :) + & - cmplx_i*crvec(2, ir)*phase_fac*OO_R(:, :, ir) + cmplx_i*wigner_seitz%crvec(2, ir)*phase_fac*OO_R(:, :, ir) if (present(OO_dz)) OO_dz(:, :) = OO_dz(:, :) + & - cmplx_i*crvec(3, ir)*phase_fac*OO_R(:, :, ir) + cmplx_i*wigner_seitz%crvec(3, ir)*phase_fac*OO_R(:, :, ir) endif enddo end subroutine pw90common_fourier_R_to_k_new - !=========================================================! - subroutine pw90common_fourier_R_to_k_new_second_d(kpt, OO_R, OO, OO_da, OO_dadb) - !=======================================================! - ! ! + !================================================! + subroutine pw90common_fourier_R_to_k_new_second_d(kpt, OO_R, num_wann, ws_region, wannier_data, & + real_lattice, mp_grid, ws_distance, & + wigner_seitz, stdout, seedname, OO, OO_da, & + OO_dadb) + !================================================! + ! !! For OO: !! $$O_{ij}(k) = \sum_R e^{+ik.R}.O_{ij}(R)$$ !! For $$OO_{dx,dy,dz}$$: @@ -843,53 +989,72 @@ subroutine pw90common_fourier_R_to_k_new_second_d(kpt, OO_R, OO, OO_da, OO_dadb) !! For $$OO_{dx1,dy1,dz1;dx2,dy2,dz2}$$: !! $$-\sum_R [R_{dx1,dy1,dz1}.R_{dx2,dy2,dz2}.e^{+ik.R}.O_{ij}(R)]$$ !! where R_{xi,yi,zi} are the Cartesian components of R - ! ! - !=======================================================! + ! + !================================================! use w90_constants, only: dp, cmplx_0, cmplx_i, twopi - use w90_parameters, only: timing_level, num_kpts, kpt_latt, num_wann, use_ws_distance - use w90_ws_distance, only: irdist_ws, crdist_ws, wdist_ndeg, ws_translate_dist + use w90_types, only: ws_region_type, wannier_data_type, ws_distance_type + use w90_ws_distance, only: ws_translate_dist + use w90_postw90_types, only: wigner_seitz_type implicit none - ! Arguments - ! - real(kind=dp) :: kpt(3) - complex(kind=dp), dimension(:, :, :), intent(in) :: OO_R - complex(kind=dp), optional, dimension(:, :), intent(out) :: OO - complex(kind=dp), optional, dimension(:, :, :), intent(out) :: OO_da - complex(kind=dp), optional, dimension(:, :, :, :), intent(out) :: OO_dadb + ! arguments + type(ws_region_type), intent(in) :: ws_region + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(in) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + real(kind=dp), intent(in) :: kpt(3), real_lattice(3, 3) + + character(len=50), intent(in) :: seedname + complex(kind=dp), intent(in) :: OO_R(:, :, :) + complex(kind=dp), optional, intent(out) :: OO(:, :) + complex(kind=dp), optional, intent(out) :: OO_da(:, :, :) + complex(kind=dp), optional, intent(out) :: OO_dadb(:, :, :, :) + + ! local variables integer :: ir, i, j, ideg, a, b real(kind=dp) :: rdotk complex(kind=dp) :: phase_fac - if (use_ws_distance) CALL ws_translate_dist(nrpts, irvec) + if (ws_region%use_ws_distance) CALL ws_translate_dist(ws_distance, stdout, seedname, & + ws_region, num_wann, & + wannier_data%centres, real_lattice, & + mp_grid, wigner_seitz%nrpts, & + wigner_seitz%irvec) if (present(OO)) OO = cmplx_0 if (present(OO_da)) OO_da = cmplx_0 if (present(OO_dadb)) OO_dadb = cmplx_0 - do ir = 1, nrpts + do ir = 1, wigner_seitz%nrpts ! [lp] Shift the WF to have the minimum distance IJ, see also ws_distance.F90 - if (use_ws_distance) then + if (ws_region%use_ws_distance) then do j = 1, num_wann do i = 1, num_wann - do ideg = 1, wdist_ndeg(i, j, ir) + do ideg = 1, ws_distance%ndeg(i, j, ir) - rdotk = twopi*dot_product(kpt(:), real(irdist_ws(:, ideg, i, j, ir), dp)) - phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(ndegen(ir)*wdist_ndeg(i, j, ir), dp) + rdotk = twopi*dot_product(kpt(:), real(ws_distance%irdist(:, ideg, i, j, ir), dp)) + phase_fac = cmplx(cos(rdotk), sin(rdotk), dp) & + /real(wigner_seitz%ndegen(ir)*ws_distance%ndeg(i, j, ir), dp) if (present(OO)) OO(i, j) = OO(i, j) + phase_fac*OO_R(i, j, ir) if (present(OO_da)) then do a = 1, 3 - OO_da(i, j, a) = OO_da(i, j, a) + cmplx_i*crdist_ws(a, ideg, i, j, ir)* & + OO_da(i, j, a) = OO_da(i, j, a) + cmplx_i*ws_distance%crdist(a, ideg, i, j, ir)* & phase_fac*OO_R(i, j, ir) enddo endif if (present(OO_dadb)) then do a = 1, 3 do b = 1, 3 - OO_dadb(i, j, a, b) = OO_dadb(i, j, a, b) - crdist_ws(a, ideg, i, j, ir)* & - crdist_ws(b, ideg, i, j, ir)*phase_fac*OO_R(i, j, ir) + OO_dadb(i, j, a, b) = OO_dadb(i, j, a, b) & + - ws_distance%crdist(a, ideg, i, j, ir) & + *ws_distance%crdist(b, ideg, i, j, ir) & + *phase_fac*OO_R(i, j, ir) enddo enddo end if @@ -899,19 +1064,21 @@ subroutine pw90common_fourier_R_to_k_new_second_d(kpt, OO_R, OO, OO_da, OO_dadb) enddo else ! [lp] Original code, without IJ-dependent shift: - rdotk = twopi*dot_product(kpt(:), irvec(:, ir)) - phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(ndegen(ir), dp) + rdotk = twopi*dot_product(kpt(:), wigner_seitz%irvec(:, ir)) + phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(wigner_seitz%ndegen(ir), dp) if (present(OO)) OO(:, :) = OO(:, :) + phase_fac*OO_R(:, :, ir) if (present(OO_da)) then do a = 1, 3 - OO_da(:, :, a) = OO_da(:, :, a) + cmplx_i*crvec(a, ir)*phase_fac*OO_R(:, :, ir) + OO_da(:, :, a) = OO_da(:, :, a) + cmplx_i*wigner_seitz%crvec(a, ir)*phase_fac & + *OO_R(:, :, ir) enddo endif if (present(OO_dadb)) then do a = 1, 3 do b = 1, 3 OO_dadb(:, :, a, b) = OO_dadb(:, :, a, b) - & - crvec(a, ir)*crvec(b, ir)*phase_fac*OO_R(:, :, ir) + wigner_seitz%crvec(a, ir)*wigner_seitz%crvec(b, ir)*phase_fac & + *OO_R(:, :, ir) enddo enddo end if @@ -920,8 +1087,12 @@ subroutine pw90common_fourier_R_to_k_new_second_d(kpt, OO_R, OO, OO_da, OO_dadb) end subroutine pw90common_fourier_R_to_k_new_second_d - subroutine pw90common_fourier_R_to_k_new_second_d_TB_conv(kpt, OO_R, oo_a_R, OO, OO_da, OO_dadb) - !=======================================================! + !================================================! + subroutine pw90common_fourier_R_to_k_new_second_d_TB_conv(kpt, OO_R, oo_a_R, num_wann, & + ws_region, wannier_data, real_lattice, & + mp_grid, ws_distance, wigner_seitz, & + stdout, seedname, OO, OO_da, OO_dadb) + !================================================! ! modified version of pw90common_fourier_R_to_k_new_second_d, includes wannier centres in ! the exponential inside the sum (so called TB convention) ! @@ -934,40 +1105,58 @@ subroutine pw90common_fourier_R_to_k_new_second_d_TB_conv(kpt, OO_R, oo_a_R, OO, !! $$-\sum_R [(R+tau_ij)_{dx1,dy1,dz1}.(R+tau_ij)_{dx2,dy2,dz2}.e^{+ik.(R+tau_ij)}.O_{ij}(R)]$$ !! where {xi,yi,zi} denote the Cartesian components and ! tau_ij = tau_j - tau_i, being tau_i=<0i|r|0i> the individual wannier centres - !=======================================================! + !================================================! use w90_constants, only: dp, cmplx_0, cmplx_i, twopi - use w90_parameters, only: timing_level, num_kpts, kpt_latt, num_wann, & - use_ws_distance, wannier_centres, recip_lattice - use w90_ws_distance, only: irdist_ws, crdist_ws, wdist_ndeg, ws_translate_dist - use w90_utility, only: utility_cart_to_frac + use w90_types, only: ws_region_type, wannier_data_type, ws_distance_type + use w90_ws_distance, only: ws_translate_dist + use w90_utility, only: utility_cart_to_frac, utility_inverse_mat + use w90_postw90_types, only: wigner_seitz_type implicit none - ! Arguments - ! - real(kind=dp) :: kpt(3) - complex(kind=dp), dimension(:, :, :), intent(in) :: OO_R - complex(kind=dp), optional, dimension(:, :), intent(out) :: OO - complex(kind=dp), optional, dimension(:, :, :), intent(out) :: OO_da - complex(kind=dp), optional, dimension(:, :, :, :), intent(out) :: OO_dadb - complex(kind=dp), dimension(:, :, :, :), intent(in) :: oo_a_R + ! arguments + type(ws_region_type), intent(in) :: ws_region + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(in) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance - integer :: ir, i, j, ideg, a, b - real(kind=dp) :: rdotk + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: kpt(3), real_lattice(3, 3) + + complex(kind=dp), intent(in) :: oo_a_R(:, :, :, :) + complex(kind=dp), intent(in) :: OO_R(:, :, :) + complex(kind=dp), optional, intent(out) :: OO(:, :) + complex(kind=dp), optional, intent(out) :: OO_da(:, :, :) + complex(kind=dp), optional, intent(out) :: OO_dadb(:, :, :, :) + + character(len=50), intent(in) :: seedname + + ! local variables + real(kind=dp) :: inv_lattice(3, 3) + integer :: ir, i, j, ideg, a, b + real(kind=dp) :: rdotk + real(kind=dp) :: local_wannier_centres(3, num_wann), wannier_centres_frac(3, num_wann) + real(kind=dp) :: r_sum(3) complex(kind=dp) :: phase_fac - real(kind=dp) :: local_wannier_centres(3, num_wann), wannier_centres_frac(3, num_wann) - real(kind=dp) :: r_sum(3) r_sum = 0.d0 - if (use_ws_distance) CALL ws_translate_dist(nrpts, irvec) + if (ws_region%use_ws_distance) CALL ws_translate_dist(ws_distance, stdout, seedname, & + ws_region, num_wann, & + wannier_data%centres, real_lattice, & + mp_grid, wigner_seitz%nrpts, & + wigner_seitz%irvec) ! calculate wannier centres in cartesian local_wannier_centres(:, :) = 0.d0 do j = 1, num_wann - do ir = 1, nrpts - if ((irvec(1, ir) .eq. 0) .and. (irvec(2, ir) .eq. 0) .and. (irvec(3, ir) .eq. 0)) then + do ir = 1, wigner_seitz%nrpts + if ((wigner_seitz%irvec(1, ir) .eq. 0) .and. (wigner_seitz%irvec(2, ir) .eq. 0) .and. & + (wigner_seitz%irvec(3, ir) .eq. 0)) then local_wannier_centres(1, j) = real(oo_a_R(j, j, ir, 1)) local_wannier_centres(2, j) = real(oo_a_R(j, j, ir, 2)) local_wannier_centres(3, j) = real(oo_a_R(j, j, ir, 3)) @@ -976,39 +1165,45 @@ subroutine pw90common_fourier_R_to_k_new_second_d_TB_conv(kpt, OO_R, oo_a_R, OO, enddo ! rotate wannier centres from cartesian to fractional coordinates wannier_centres_frac(:, :) = 0.d0 + call utility_inverse_mat(real_lattice, inv_lattice) do ir = 1, num_wann - call utility_cart_to_frac(local_wannier_centres(:, ir), wannier_centres_frac(:, ir), recip_lattice) + call utility_cart_to_frac(local_wannier_centres(:, ir), wannier_centres_frac(:, ir), & + inv_lattice) enddo if (present(OO)) OO = cmplx_0 if (present(OO_da)) OO_da = cmplx_0 if (present(OO_dadb)) OO_dadb = cmplx_0 - do ir = 1, nrpts + do ir = 1, wigner_seitz%nrpts ! [lp] Shift the WF to have the minimum distance IJ, see also ws_distance.F90 - if (use_ws_distance) then + if (ws_region%use_ws_distance) then do j = 1, num_wann do i = 1, num_wann - do ideg = 1, wdist_ndeg(i, j, ir) + do ideg = 1, ws_distance%ndeg(i, j, ir) - rdotk = twopi*dot_product(kpt(:), real(irdist_ws(:, ideg, i, j, ir) + & + rdotk = twopi*dot_product(kpt(:), real(ws_distance%irdist(:, ideg, i, j, ir) + & wannier_centres_frac(:, j) - wannier_centres_frac(:, i), dp)) - phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(ndegen(ir)*wdist_ndeg(i, j, ir), dp) + phase_fac = cmplx(cos(rdotk), sin(rdotk), dp) & + /real(wigner_seitz%ndegen(ir)*ws_distance%ndeg(i, j, ir), dp) if (present(OO)) OO(i, j) = OO(i, j) + phase_fac*OO_R(i, j, ir) if (present(OO_da)) then do a = 1, 3 OO_da(i, j, a) = OO_da(i, j, a) + cmplx_i* & - (crdist_ws(a, ideg, i, j, ir) + local_wannier_centres(a, j) - & - local_wannier_centres(a, i))*phase_fac*OO_R(i, j, ir) + (ws_distance%crdist(a, ideg, i, j, ir) & + + local_wannier_centres(a, j) & + - local_wannier_centres(a, i))*phase_fac*OO_R(i, j, ir) enddo endif if (present(OO_dadb)) then do a = 1, 3 do b = 1, 3 OO_dadb(i, j, a, b) = OO_dadb(i, j, a, b) - & - (crdist_ws(a, ideg, i, j, ir) + local_wannier_centres(a, j) - & - local_wannier_centres(a, i))* & - (crdist_ws(b, ideg, i, j, ir) + local_wannier_centres(b, j) - & - local_wannier_centres(b, i))*phase_fac*OO_R(i, j, ir) + (ws_distance%crdist(a, ideg, i, j, ir) & + + local_wannier_centres(a, j) & + - local_wannier_centres(a, i)) & + *(ws_distance%crdist(b, ideg, i, j, ir) & + + local_wannier_centres(b, j) - & + local_wannier_centres(b, i))*phase_fac*OO_R(i, j, ir) enddo enddo end if @@ -1020,14 +1215,15 @@ subroutine pw90common_fourier_R_to_k_new_second_d_TB_conv(kpt, OO_R, oo_a_R, OO, ! [lp] Original code, without IJ-dependent shift: do j = 1, num_wann do i = 1, num_wann - r_sum(:) = real(irvec(:, ir)) + wannier_centres_frac(:, j) - wannier_centres_frac(:, i) + r_sum(:) = real(wigner_seitz%irvec(:, ir)) & + + wannier_centres_frac(:, j) - wannier_centres_frac(:, i) rdotk = twopi*dot_product(kpt(:), r_sum(:)) - phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(ndegen(ir), dp) + phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(wigner_seitz%ndegen(ir), dp) if (present(OO)) OO(i, j) = OO(i, j) + phase_fac*OO_R(i, j, ir) if (present(OO_da)) then do a = 1, 3 OO_da(i, j, a) = OO_da(i, j, a) + cmplx_i* & - (crvec(a, ir) + local_wannier_centres(a, j) - & + (wigner_seitz%crvec(a, ir) + local_wannier_centres(a, j) - & local_wannier_centres(a, i))*phase_fac*OO_R(i, j, ir) enddo endif @@ -1036,8 +1232,9 @@ subroutine pw90common_fourier_R_to_k_new_second_d_TB_conv(kpt, OO_R, oo_a_R, OO, do b = 1, 3 OO_dadb(i, j, a, b) = & OO_dadb(i, j, a, b) - & - (crvec(a, ir) + local_wannier_centres(a, j) - local_wannier_centres(a, i))* & - (crvec(b, ir) + local_wannier_centres(b, j) - local_wannier_centres(b, i))* & + (wigner_seitz%crvec(a, ir) + local_wannier_centres(a, j) - & + local_wannier_centres(a, i))*(wigner_seitz%crvec(b, ir) + & + local_wannier_centres(b, j) - local_wannier_centres(b, i))* & phase_fac*OO_R(i, j, ir) enddo enddo @@ -1049,45 +1246,64 @@ subroutine pw90common_fourier_R_to_k_new_second_d_TB_conv(kpt, OO_R, oo_a_R, OO, end subroutine pw90common_fourier_R_to_k_new_second_d_TB_conv - ! ***NEW*** - ! - !=========================================================! - subroutine pw90common_fourier_R_to_k_vec(kpt, OO_R, OO_true, OO_pseudo) - !====================================================================! - ! ! + !================================================! + subroutine pw90common_fourier_R_to_k_vec(ws_region, wannier_data, ws_distance, wigner_seitz, & + OO_R, kpt, real_lattice, mp_grid, num_wann, seedname, & + stdout, OO_true, OO_pseudo) + !================================================! + ! !! For OO_true (true vector): !! $${\vec O}_{ij}(k) = \sum_R e^{+ik.R} {\vec O}_{ij}(R)$$ - ! ! - !====================================================================! + ! + !================================================! use w90_constants, only: dp, cmplx_0, cmplx_i, twopi - use w90_parameters, only: num_kpts, kpt_latt, num_wann, use_ws_distance - use w90_ws_distance, only: irdist_ws, crdist_ws, wdist_ndeg, ws_translate_dist + use w90_types, only: ws_region_type, wannier_data_type, ws_distance_type + use w90_ws_distance, only: ws_translate_dist + use w90_postw90_types, only: wigner_seitz_type implicit none - ! Arguments - ! - real(kind=dp) :: kpt(3) - complex(kind=dp), dimension(:, :, :, :), intent(in) :: OO_R - complex(kind=dp), optional, dimension(:, :, :), intent(out) :: OO_true - complex(kind=dp), optional, dimension(:, :, :), intent(out) :: OO_pseudo + ! arguments + type(ws_region_type), intent(in) :: ws_region + type(wannier_data_type), intent(in) :: wannier_data + type(ws_distance_type), intent(inout) :: ws_distance + type(wigner_seitz_type), intent(in) :: wigner_seitz + + integer, intent(in) :: num_wann + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: kpt(3), real_lattice(3, 3) + + complex(kind=dp), intent(in) :: OO_R(:, :, :, :) + complex(kind=dp), optional, intent(out) :: OO_true(:, :, :) + complex(kind=dp), optional, intent(out) :: OO_pseudo(:, :, :) + character(len=50), intent(in) :: seedname + + ! local variables integer :: ir, i, j, ideg real(kind=dp) :: rdotk complex(kind=dp) :: phase_fac - if (use_ws_distance) CALL ws_translate_dist(nrpts, irvec) + if (ws_region%use_ws_distance) CALL ws_translate_dist(ws_distance, stdout, seedname, & + ws_region, num_wann, & + wannier_data%centres, real_lattice, & + mp_grid, wigner_seitz%nrpts, & + wigner_seitz%irvec) + if (present(OO_true)) OO_true = cmplx_0 if (present(OO_pseudo)) OO_pseudo = cmplx_0 - do ir = 1, nrpts + do ir = 1, wigner_seitz%nrpts ! [lp] Shift the WF to have the minimum distance IJ, see also ws_distance.F90 - if (use_ws_distance) then + if (ws_region%use_ws_distance) then do j = 1, num_wann do i = 1, num_wann - do ideg = 1, wdist_ndeg(i, j, ir) - rdotk = twopi*dot_product(kpt(:), real(irdist_ws(:, ideg, i, j, ir), dp)) - phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(ndegen(ir)*wdist_ndeg(i, j, ir), dp) + do ideg = 1, ws_distance%ndeg(i, j, ir) + rdotk = twopi*dot_product(kpt(:), real(ws_distance%irdist(:, ideg, i, j, ir), dp)) + phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(wigner_seitz%ndegen(ir) & + *ws_distance%ndeg(i, j, ir), dp) if (present(OO_true)) then OO_true(i, j, 1) = OO_true(i, j, 1) + phase_fac*OO_R(i, j, ir, 1) OO_true(i, j, 2) = OO_true(i, j, 2) + phase_fac*OO_R(i, j, ir, 2) @@ -1095,22 +1311,28 @@ subroutine pw90common_fourier_R_to_k_vec(kpt, OO_R, OO_true, OO_pseudo) endif if (present(OO_pseudo)) then OO_pseudo(i, j, 1) = OO_pseudo(i, j, 1) & - + cmplx_i*crdist_ws(2, ideg, i, j, ir)*phase_fac*OO_R(i, j, ir, 3) & - - cmplx_i*crdist_ws(3, ideg, i, j, ir)*phase_fac*OO_R(i, j, ir, 2) + + cmplx_i*ws_distance%crdist(2, ideg, i, j, ir) & + *phase_fac*OO_R(i, j, ir, 3) & + - cmplx_i*ws_distance%crdist(3, ideg, i, j, ir) & + *phase_fac*OO_R(i, j, ir, 2) OO_pseudo(i, j, 2) = OO_pseudo(i, j, 2) & - + cmplx_i*crdist_ws(3, ideg, i, j, ir)*phase_fac*OO_R(i, j, ir, 1) & - - cmplx_i*crdist_ws(1, ideg, i, j, ir)*phase_fac*OO_R(i, j, ir, 3) + + cmplx_i*ws_distance%crdist(3, ideg, i, j, ir) & + *phase_fac*OO_R(i, j, ir, 1) & + - cmplx_i*ws_distance%crdist(1, ideg, i, j, ir) & + *phase_fac*OO_R(i, j, ir, 3) OO_pseudo(i, j, 3) = OO_pseudo(i, j, 3) & - + cmplx_i*crdist_ws(1, ideg, i, j, ir)*phase_fac*OO_R(i, j, ir, 2) & - - cmplx_i*crdist_ws(2, ideg, i, j, ir)*phase_fac*OO_R(i, j, ir, 1) + + cmplx_i*ws_distance%crdist(1, ideg, i, j, ir) & + *phase_fac*OO_R(i, j, ir, 2) & + - cmplx_i*ws_distance%crdist(2, ideg, i, j, ir) & + *phase_fac*OO_R(i, j, ir, 1) endif enddo enddo enddo else ! [lp] Original code, without IJ-dependent shift: - rdotk = twopi*dot_product(kpt(:), irvec(:, ir)) - phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(ndegen(ir), dp) + rdotk = twopi*dot_product(kpt(:), wigner_seitz%irvec(:, ir)) + phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(wigner_seitz%ndegen(ir), dp) if (present(OO_true)) then OO_true(:, :, 1) = OO_true(:, :, 1) + phase_fac*OO_R(:, :, ir, 1) OO_true(:, :, 2) = OO_true(:, :, 2) + phase_fac*OO_R(:, :, ir, 2) @@ -1118,61 +1340,82 @@ subroutine pw90common_fourier_R_to_k_vec(kpt, OO_R, OO_true, OO_pseudo) endif if (present(OO_pseudo)) then OO_pseudo(:, :, 1) = OO_pseudo(:, :, 1) & - + cmplx_i*crvec(2, ir)*phase_fac*OO_R(:, :, ir, 3) & - - cmplx_i*crvec(3, ir)*phase_fac*OO_R(:, :, ir, 2) + + cmplx_i*wigner_seitz%crvec(2, ir)*phase_fac*OO_R(:, :, ir, 3) & + - cmplx_i*wigner_seitz%crvec(3, ir)*phase_fac*OO_R(:, :, ir, 2) OO_pseudo(:, :, 2) = OO_pseudo(:, :, 2) & - + cmplx_i*crvec(3, ir)*phase_fac*OO_R(:, :, ir, 1) & - - cmplx_i*crvec(1, ir)*phase_fac*OO_R(:, :, ir, 3) + + cmplx_i*wigner_seitz%crvec(3, ir)*phase_fac*OO_R(:, :, ir, 1) & + - cmplx_i*wigner_seitz%crvec(1, ir)*phase_fac*OO_R(:, :, ir, 3) OO_pseudo(:, :, 3) = OO_pseudo(:, :, 3) & - + cmplx_i*crvec(1, ir)*phase_fac*OO_R(:, :, ir, 2) & - - cmplx_i*crvec(2, ir)*phase_fac*OO_R(:, :, ir, 1) + + cmplx_i*wigner_seitz%crvec(1, ir)*phase_fac*OO_R(:, :, ir, 2) & + - cmplx_i*wigner_seitz%crvec(2, ir)*phase_fac*OO_R(:, :, ir, 1) endif endif enddo end subroutine pw90common_fourier_R_to_k_vec - !=========================================================! - subroutine pw90common_fourier_R_to_k_vec_dadb(kpt, OO_R, OO_da, OO_dadb) - !====================================================================! - ! ! + !================================================! + subroutine pw90common_fourier_R_to_k_vec_dadb(ws_region, wannier_data, ws_distance, & + wigner_seitz, OO_R, kpt, real_lattice, mp_grid, & + num_wann, seedname, stdout, OO_da, OO_dadb) + !================================================! + ! !! For $$OO_{ij;dx,dy,dz}$$: !! $$O_{ij;dx,dy,dz}(k) = \sum_R e^{+ik.R} O_{ij;dx,dy,dz}(R)$$ !! For $$OO_{ij;dx1,dy1,dz1;dx2,dy2,dz2}$$: !! $$O_{ij;dx1,dy1,dz1;dx2,dy2,dz2}(k) = \sum_R e^{+ik.R} i.R_{dx2,dy2,dz2} !! .O_{ij;dx1,dy1,dz1}(R)$$ - ! ! - !====================================================================! + ! + !================================================! use w90_constants, only: dp, cmplx_0, cmplx_i, twopi - use w90_parameters, only: num_kpts, kpt_latt, num_wann, use_ws_distance - use w90_ws_distance, only: irdist_ws, crdist_ws, wdist_ndeg, ws_translate_dist + use w90_types, only: ws_region_type, wannier_data_type, ws_distance_type + use w90_ws_distance, only: ws_translate_dist + use w90_postw90_types, only: wigner_seitz_type implicit none - ! Arguments - ! - real(kind=dp) :: kpt(3) - complex(kind=dp), dimension(:, :, :, :), intent(in) :: OO_R - complex(kind=dp), optional, dimension(:, :, :), intent(out) :: OO_da - complex(kind=dp), optional, dimension(:, :, :, :), intent(out) :: OO_dadb + ! arguments + type(ws_region_type), intent(in) :: ws_region + type(wannier_data_type), intent(in) :: wannier_data + type(ws_distance_type), intent(inout) :: ws_distance + type(wigner_seitz_type), intent(in) :: wigner_seitz + + integer, intent(in) :: num_wann + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: kpt(3), real_lattice(3, 3) + + complex(kind=dp), intent(in) :: OO_R(:, :, :, :) + complex(kind=dp), optional, intent(out) :: OO_da(:, :, :) + complex(kind=dp), optional, intent(out) :: OO_dadb(:, :, :, :) + + character(len=50), intent(in) :: seedname + ! local variables integer :: ir, i, j, ideg, a, b real(kind=dp) :: rdotk complex(kind=dp) :: phase_fac - if (use_ws_distance) CALL ws_translate_dist(nrpts, irvec) + if (ws_region%use_ws_distance) CALL ws_translate_dist(ws_distance, stdout, seedname, & + ws_region, num_wann, & + wannier_data%centres, real_lattice, & + mp_grid, wigner_seitz%nrpts, & + wigner_seitz%irvec) + if (present(OO_da)) OO_da = cmplx_0 if (present(OO_dadb)) OO_dadb = cmplx_0 - do ir = 1, nrpts + do ir = 1, wigner_seitz%nrpts ! [lp] Shift the WF to have the minimum distance IJ, see also ws_distance.F90 - if (use_ws_distance) then + if (ws_region%use_ws_distance) then do j = 1, num_wann do i = 1, num_wann - do ideg = 1, wdist_ndeg(i, j, ir) + do ideg = 1, ws_distance%ndeg(i, j, ir) - rdotk = twopi*dot_product(kpt(:), real(irdist_ws(:, ideg, i, j, ir), dp)) - phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(ndegen(ir)*wdist_ndeg(i, j, ir), dp) + rdotk = twopi*dot_product(kpt(:), real(ws_distance%irdist(:, ideg, i, j, ir), dp)) + phase_fac = cmplx(cos(rdotk), sin(rdotk), dp) & + /real(wigner_seitz%ndegen(ir)*ws_distance%ndeg(i, j, ir), dp) if (present(OO_da)) then OO_da(i, j, 1) = OO_da(i, j, 1) + phase_fac*OO_R(i, j, ir, 1) OO_da(i, j, 2) = OO_da(i, j, 2) + phase_fac*OO_R(i, j, ir, 2) @@ -1181,8 +1424,9 @@ subroutine pw90common_fourier_R_to_k_vec_dadb(kpt, OO_R, OO_da, OO_dadb) if (present(OO_dadb)) then do a = 1, 3 do b = 1, 3 - OO_dadb(i, j, a, b) = OO_dadb(i, j, a, b) + & - cmplx_i*crdist_ws(b, ideg, i, j, ir)*phase_fac*OO_R(i, j, ir, a) + OO_dadb(i, j, a, b) = OO_dadb(i, j, a, b) & + + cmplx_i*ws_distance%crdist(b, ideg, i, j, ir) & + *phase_fac*OO_R(i, j, ir, a) enddo enddo endif @@ -1192,8 +1436,8 @@ subroutine pw90common_fourier_R_to_k_vec_dadb(kpt, OO_R, OO_da, OO_dadb) enddo else ! [lp] Original code, without IJ-dependent shift: - rdotk = twopi*dot_product(kpt(:), irvec(:, ir)) - phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(ndegen(ir), dp) + rdotk = twopi*dot_product(kpt(:), wigner_seitz%irvec(:, ir)) + phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(wigner_seitz%ndegen(ir), dp) if (present(OO_da)) then OO_da(:, :, 1) = OO_da(:, :, 1) + phase_fac*OO_R(:, :, ir, 1) OO_da(:, :, 2) = OO_da(:, :, 2) + phase_fac*OO_R(:, :, ir, 2) @@ -1202,7 +1446,8 @@ subroutine pw90common_fourier_R_to_k_vec_dadb(kpt, OO_R, OO_da, OO_dadb) if (present(OO_dadb)) then do a = 1, 3 do b = 1, 3 - OO_dadb(:, :, a, b) = OO_dadb(:, :, a, b) + cmplx_i*crvec(b, ir)*phase_fac*OO_R(:, :, ir, a) + OO_dadb(:, :, a, b) = OO_dadb(:, :, a, b) & + + cmplx_i*wigner_seitz%crvec(b, ir)*phase_fac*OO_R(:, :, ir, a) enddo enddo endif @@ -1211,10 +1456,13 @@ subroutine pw90common_fourier_R_to_k_vec_dadb(kpt, OO_R, OO_da, OO_dadb) end subroutine pw90common_fourier_R_to_k_vec_dadb - !=========================================================! - subroutine pw90common_fourier_R_to_k_vec_dadb_TB_conv(kpt, OO_R, OO_da, OO_dadb) - !====================================================================! - ! ! + !================================================! + subroutine pw90common_fourier_R_to_k_vec_dadb_TB_conv(ws_region, wannier_data, ws_distance, & + wigner_seitz, OO_R, kpt, real_lattice, & + mp_grid, num_wann, seedname, stdout, & + OO_da, OO_dadb) + !================================================! + ! ! modified version of pw90common_fourier_R_to_k_vec_dadb, includes wannier centres in ! the exponential inside the sum (so called TB convention) ! @@ -1224,24 +1472,37 @@ subroutine pw90common_fourier_R_to_k_vec_dadb_TB_conv(kpt, OO_R, OO_da, OO_dadb) !! $$O_{ij;dx1,dy1,dz1;dx2,dy2,dz2}(k) = \sum_R e^{+ik.(R+tau_ij)} i.(R+tau_ij)_{dx2,dy2,dz2} !! .O_{ij;dx1,dy1,dz1}(R)$$ ! with tau_ij = tau_j - tau_i, being tau_i=<0i|r|0i> the individual wannier centres - ! ! - !====================================================================! + ! + !================================================! use w90_constants, only: dp, cmplx_0, cmplx_i, twopi - use w90_parameters, only: num_kpts, kpt_latt, num_wann, use_ws_distance, & - wannier_centres, recip_lattice - use w90_ws_distance, only: irdist_ws, crdist_ws, wdist_ndeg, ws_translate_dist - use w90_utility, only: utility_cart_to_frac + use w90_types, only: ws_region_type, wannier_data_type, ws_distance_type + use w90_ws_distance, only: ws_translate_dist + use w90_utility, only: utility_cart_to_frac, utility_inverse_mat + use w90_postw90_types, only: wigner_seitz_type implicit none - ! Arguments - ! - real(kind=dp) :: kpt(3) - complex(kind=dp), dimension(:, :, :, :), intent(in) :: OO_R - complex(kind=dp), optional, dimension(:, :, :), intent(out) :: OO_da - complex(kind=dp), optional, dimension(:, :, :, :), intent(out) :: OO_dadb + ! arguments + type(ws_region_type), intent(in) :: ws_region + type(wannier_data_type), intent(in) :: wannier_data + type(ws_distance_type), intent(inout) :: ws_distance + type(wigner_seitz_type), intent(in) :: wigner_seitz + integer, intent(in) :: num_wann + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: kpt(3), real_lattice(3, 3) + + complex(kind=dp), intent(in) :: OO_R(:, :, :, :) + complex(kind=dp), optional, intent(out) :: OO_da(:, :, :) + complex(kind=dp), optional, intent(out) :: OO_dadb(:, :, :, :) + + character(len=50), intent(in) :: seedname + + ! local variables + real(kind=dp) :: inv_lattice(3, 3) integer :: ir, i, j, ideg, a, b real(kind=dp) :: rdotk complex(kind=dp) :: phase_fac @@ -1250,15 +1511,21 @@ subroutine pw90common_fourier_R_to_k_vec_dadb_TB_conv(kpt, OO_R, OO_da, OO_dadb) r_sum = 0.d0 - if (use_ws_distance) CALL ws_translate_dist(nrpts, irvec) + if (ws_region%use_ws_distance) CALL ws_translate_dist(ws_distance, stdout, seedname, & + ws_region, num_wann, & + wannier_data%centres, real_lattice, & + mp_grid, wigner_seitz%nrpts, & + wigner_seitz%irvec) + if (present(OO_da)) OO_da = cmplx_0 if (present(OO_dadb)) OO_dadb = cmplx_0 ! calculate wannier centres in cartesian local_wannier_centres(:, :) = 0.d0 do j = 1, num_wann - do ir = 1, nrpts - if ((irvec(1, ir) .eq. 0) .and. (irvec(2, ir) .eq. 0) .and. (irvec(3, ir) .eq. 0)) then + do ir = 1, wigner_seitz%nrpts + if ((wigner_seitz%irvec(1, ir) .eq. 0) .and. (wigner_seitz%irvec(2, ir) .eq. 0) & + .and. (wigner_seitz%irvec(3, ir) .eq. 0)) then local_wannier_centres(1, j) = real(OO_R(j, j, ir, 1)) local_wannier_centres(2, j) = real(OO_R(j, j, ir, 2)) local_wannier_centres(3, j) = real(OO_R(j, j, ir, 3)) @@ -1267,8 +1534,10 @@ subroutine pw90common_fourier_R_to_k_vec_dadb_TB_conv(kpt, OO_R, OO_da, OO_dadb) enddo ! rotate wannier centres from cartesian to fractional coordinates wannier_centres_frac(:, :) = 0.d0 + call utility_inverse_mat(real_lattice, inv_lattice) do ir = 1, num_wann - call utility_cart_to_frac(local_wannier_centres(:, ir), wannier_centres_frac(:, ir), recip_lattice) + call utility_cart_to_frac(local_wannier_centres(:, ir), wannier_centres_frac(:, ir), & + inv_lattice) enddo ! print *, 'wannier_centres_frac' @@ -1288,20 +1557,24 @@ subroutine pw90common_fourier_R_to_k_vec_dadb_TB_conv(kpt, OO_R, OO_da, OO_dadb) ! enddo ! stop - do ir = 1, nrpts + do ir = 1, wigner_seitz%nrpts ! [lp] Shift the WF to have the minimum distance IJ, see also ws_distance.F90 - if (use_ws_distance) then + if (ws_region%use_ws_distance) then do j = 1, num_wann do i = 1, num_wann - do ideg = 1, wdist_ndeg(i, j, ir) + do ideg = 1, ws_distance%ndeg(i, j, ir) - rdotk = twopi*dot_product(kpt(:), real(irdist_ws(:, ideg, i, j, ir) + & - wannier_centres_frac(:, j) - wannier_centres_frac(:, i), dp)) - phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(ndegen(ir)*wdist_ndeg(i, j, ir), dp) + rdotk = twopi*dot_product(kpt(:), real(ws_distance%irdist(:, ideg, i, j, ir) + & + wannier_centres_frac(:, j) & + - wannier_centres_frac(:, i), dp)) + phase_fac = cmplx(cos(rdotk), sin(rdotk), dp) & + /real(wigner_seitz%ndegen(ir)*ws_distance%ndeg(i, j, ir), dp) if (present(OO_da)) then ! if we are at the origin and at the same band, then the ! matrix element is zero in this convention - if ((irvec(1, ir) .eq. 0) .and. (irvec(2, ir) .eq. 0) .and. (irvec(3, ir) .eq. 0) .and. (i .eq. j)) then + if ((wigner_seitz%irvec(1, ir) .eq. 0) .and. & + (wigner_seitz%irvec(2, ir) .eq. 0) .and. & + (wigner_seitz%irvec(3, ir) .eq. 0) .and. (i .eq. j)) then cycle else OO_da(i, j, 1) = OO_da(i, j, 1) + phase_fac*OO_R(i, j, ir, 1) @@ -1311,14 +1584,18 @@ subroutine pw90common_fourier_R_to_k_vec_dadb_TB_conv(kpt, OO_R, OO_da, OO_dadb) endif if (present(OO_dadb)) then ! same skip as before - if ((irvec(1, ir) .eq. 0) .and. (irvec(2, ir) .eq. 0) .and. (irvec(3, ir) .eq. 0) .and. (i .eq. j)) then + if ((wigner_seitz%irvec(1, ir) .eq. 0) .and. & + (wigner_seitz%irvec(2, ir) .eq. 0) .and. & + (wigner_seitz%irvec(3, ir) .eq. 0) .and. (i .eq. j)) then cycle else do a = 1, 3 do b = 1, 3 OO_dadb(i, j, a, b) = OO_dadb(i, j, a, b) + cmplx_i* & - (crdist_ws(b, ideg, i, j, ir) + local_wannier_centres(b, j) - & - local_wannier_centres(b, i))*phase_fac*OO_R(i, j, ir, a) + (ws_distance%crdist(b, ideg, i, j, ir) & + + local_wannier_centres(b, j) & + - local_wannier_centres(b, i)) & + *phase_fac*OO_R(i, j, ir, a) enddo enddo endif @@ -1331,16 +1608,21 @@ subroutine pw90common_fourier_R_to_k_vec_dadb_TB_conv(kpt, OO_R, OO_da, OO_dadb) ! [lp] Original code, without IJ-dependent shift: do j = 1, num_wann do i = 1, num_wann - r_sum(:) = real(irvec(:, ir)) + wannier_centres_frac(:, j) - wannier_centres_frac(:, i) + r_sum(:) = real(wigner_seitz%irvec(:, ir)) & + + wannier_centres_frac(:, j) - wannier_centres_frac(:, i) rdotk = twopi*dot_product(kpt(:), r_sum(:)) - phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(ndegen(ir), dp) + phase_fac = cmplx(cos(rdotk), sin(rdotk), dp)/real(wigner_seitz%ndegen(ir), dp) if (present(OO_da)) then ! if we are at the origin and at the same band, then the ! matrix element is zero in this convention - if ((irvec(1, ir) .eq. 0) .and. (irvec(2, ir) .eq. 0) .and. (irvec(3, ir) .eq. 0) .and. (i .eq. j)) then - OO_da(i, j, 1) = OO_da(i, j, 1) + phase_fac*(OO_R(i, j, ir, 1) - local_wannier_centres(1, j)) - OO_da(i, j, 2) = OO_da(i, j, 2) + phase_fac*(OO_R(i, j, ir, 2) - local_wannier_centres(2, j)) - OO_da(i, j, 3) = OO_da(i, j, 3) + phase_fac*(OO_R(i, j, ir, 3) - local_wannier_centres(3, j)) + if ((wigner_seitz%irvec(1, ir) .eq. 0) .and. (wigner_seitz%irvec(2, ir) .eq. 0) .and. & + (wigner_seitz%irvec(3, ir) .eq. 0) .and. (i .eq. j)) then + OO_da(i, j, 1) = OO_da(i, j, 1) + phase_fac*(OO_R(i, j, ir, 1) & + - local_wannier_centres(1, j)) + OO_da(i, j, 2) = OO_da(i, j, 2) + phase_fac*(OO_R(i, j, ir, 2) & + - local_wannier_centres(2, j)) + OO_da(i, j, 3) = OO_da(i, j, 3) + phase_fac*(OO_R(i, j, ir, 3) & + - local_wannier_centres(3, j)) ! print *, 'OO_R(i,j,ir,1)', OO_R(i,j,ir,1) ! print *, 'local_wannier_centres(1,j)', local_wannier_centres(1,j) ! print *, 'OO_R(i,j,ir,2)', OO_R(i,j,ir,2) @@ -1354,11 +1636,14 @@ subroutine pw90common_fourier_R_to_k_vec_dadb_TB_conv(kpt, OO_R, OO_da, OO_dadb) endif if (present(OO_dadb)) then ! same skip as before - if ((irvec(1, ir) .eq. 0) .and. (irvec(2, ir) .eq. 0) .and. (irvec(3, ir) .eq. 0) .and. (i .eq. j)) then + if ((wigner_seitz%irvec(1, ir) .eq. 0) .and. (wigner_seitz%irvec(2, ir) .eq. 0) .and. & + (wigner_seitz%irvec(3, ir) .eq. 0) .and. (i .eq. j)) then do a = 1, 3 do b = 1, 3 - OO_dadb(i, j, a, b) = OO_dadb(i, j, a, b) + cmplx_i*(crvec(b, ir) + local_wannier_centres(b, j) - & - local_wannier_centres(b, i))*phase_fac* & + OO_dadb(i, j, a, b) = OO_dadb(i, j, a, b) + & + cmplx_i*(wigner_seitz%crvec(b, ir) + & + local_wannier_centres(b, j) & + - local_wannier_centres(b, i))*phase_fac* & (OO_R(i, j, ir, a) - local_wannier_centres(a, j)) enddo enddo @@ -1366,8 +1651,10 @@ subroutine pw90common_fourier_R_to_k_vec_dadb_TB_conv(kpt, OO_R, OO_da, OO_dadb) else do a = 1, 3 do b = 1, 3 - OO_dadb(i, j, a, b) = OO_dadb(i, j, a, b) + cmplx_i*(crvec(b, ir) + local_wannier_centres(b, j) - & - local_wannier_centres(b, i))*phase_fac*OO_R(i, j, ir, a) + OO_dadb(i, j, a, b) = OO_dadb(i, j, a, b) + & + cmplx_i*(wigner_seitz%crvec(b, ir) + & + local_wannier_centres(b, j) & + - local_wannier_centres(b, i))*phase_fac*OO_R(i, j, ir, a) enddo enddo endif @@ -1379,79 +1666,79 @@ subroutine pw90common_fourier_R_to_k_vec_dadb_TB_conv(kpt, OO_R, OO_da, OO_dadb) end subroutine pw90common_fourier_R_to_k_vec_dadb_TB_conv - !===========================================================! - ! PRIVATE PROCEDURES ! - !===========================================================! + !================================================! + ! PRIVATE PROCEDURES + !================================================! - !================================! - subroutine wigner_seitz(count_pts) - !================================! + !================================================! + subroutine wignerseitz(print_output, real_lattice, mp_grid, wigner_seitz, stdout, seedname, & + count_pts, comm) + !================================================! !! Calculates a grid of lattice vectors r that fall inside (and eventually !! on the surface of) the Wigner-Seitz supercell centered on the !! origin of the Bravais superlattice with primitive translations !! mp_grid(1)*a_1, mp_grid(2)*a_2, and mp_grid(3)*a_3 - !==========================================================================! + !================================================! - use w90_constants, only: eps8, dp - use w90_io, only: stdout, io_error, io_stopwatch - use w90_parameters, only: iprint, mp_grid, real_metric, timing_level, & - ws_search_size, ws_distance_tol + use w90_constants, only: dp + use w90_io, only: io_error, io_stopwatch + use w90_types, only: print_output_type + use w90_utility, only: utility_metric + use w90_comms, only: w90comm_type, mpirank + use w90_postw90_types, only: wigner_seitz_type ! irvec(i,irpt) The irpt-th Wigner-Seitz grid point has components ! irvec(1:3,irpt) in the basis of the lattice vectors ! ndegen(irpt) Weight of the irpt-th point is 1/ndegen(irpt) ! nrpts number of Wigner-Seitz grid points - implicit none + ! arguments + type(print_output_type), intent(in) :: print_output + type(w90comm_type), intent(in) :: comm + type(wigner_seitz_type), intent(inout) :: wigner_seitz + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout logical, intent(in) :: count_pts + real(kind=dp), intent(in) :: real_lattice(3, 3) + character(len=50), intent(in) :: seedname + ! local variables integer :: ndiff(3) - real(kind=dp) :: tot, dist_min - real(kind=dp), allocatable :: dist(:) + real(kind=dp) :: dist(125), tot, dist_min integer :: n1, n2, n3, i1, i2, i3, icnt, i, j, ir - integer :: ierr, dist_dim + real(kind=dp) :: real_metric(3, 3) + logical :: on_root = .false. + if (mpirank(comm) == 0) on_root = .true. - if (timing_level > 1 .and. on_root) & - call io_stopwatch('postw90_common: wigner_seitz', 1) - - dist_dim = 1 - do i = 1, 3 - dist_dim = dist_dim*((ws_search_size(i) + 1)*2 + 1) - end do - allocate (dist(dist_dim), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating dist in wigner_seitz') + if (print_output%timing_level > 1 .and. on_root) & + call io_stopwatch('postw90_common: wigner_seitz', 1, stdout, seedname) + call utility_metric(real_lattice, real_metric) ! The Wannier functions live in a periodic supercell of the real space unit ! cell. This supercell is mp_grid(i) unit cells long along each primitive ! translation vector a_i of the unit cell ! - ! We loop over grid points r on a unit cell that is (2*ws_search_size+1)**3 times - ! larger than this primitive supercell. + ! We loop over grid points r on a cell that is approx. 8 times + ! larger than this "primitive supercell." ! ! One of these points is in the W-S supercell if it is closer to R=0 than any ! of the other points R (where R are the translation vectors of the - ! supercell). + ! supercell). In practice it is sufficient to inspect only 125 R-points. ! In the end, nrpts contains the total number of grid points that have been ! found in the Wigner-Seitz cell - nrpts = 0 - ! Loop over the lattice vectors of the primitive cell - ! that live in a supercell which is (2*ws_search_size+1)**2 - ! larger than the Born-von Karman supercell. - ! We need to find which among these live in the Wigner-Seitz cell - do n1 = -ws_search_size(1)*mp_grid(1), ws_search_size(1)*mp_grid(1) - do n2 = -ws_search_size(2)*mp_grid(2), ws_search_size(2)*mp_grid(2) - do n3 = -ws_search_size(3)*mp_grid(3), ws_search_size(3)*mp_grid(3) - ! Loop over the lattice vectors R of the Born-von Karman supercell - ! that contains all the points of the previous loop. - ! There are (2*(ws_search_size+1)+1)**3 points R. R=0 corresponds to - ! i1=i2=i3=0, or icnt=((2*(ws_search_size+1)+1)**3 + 1)/2 + wigner_seitz%nrpts = 0 + do n1 = -mp_grid(1), mp_grid(1) + do n2 = -mp_grid(2), mp_grid(2) + do n3 = -mp_grid(3), mp_grid(3) + ! Loop over the 125 points R. R=0 corresponds to i1=i2=i3=0, + ! or icnt=63 icnt = 0 - do i1 = -ws_search_size(1) - 1, ws_search_size(1) + 1 - do i2 = -ws_search_size(2) - 1, ws_search_size(2) + 1 - do i3 = -ws_search_size(3) - 1, ws_search_size(3) + 1 + do i1 = -2, 2 + do i2 = -2, 2 + do i3 = -2, 2 icnt = icnt + 1 ! Calculate distance squared |r-R|^2 ndiff(1) = n1 - i1*mp_grid(1) @@ -1468,21 +1755,22 @@ subroutine wigner_seitz(count_pts) enddo enddo dist_min = minval(dist) - if (abs(dist((dist_dim + 1)/2) - dist_min) .lt. ws_distance_tol**2) then - nrpts = nrpts + 1 + if (abs(dist(63) - dist_min) .lt. 1.e-7_dp) then + wigner_seitz%nrpts = wigner_seitz%nrpts + 1 if (.not. count_pts) then - ndegen(nrpts) = 0 - do i = 1, dist_dim - if (abs(dist(i) - dist_min) .lt. ws_distance_tol**2) & - ndegen(nrpts) = ndegen(nrpts) + 1 + wigner_seitz%ndegen(wigner_seitz%nrpts) = 0 + do i = 1, 125 + if (abs(dist(i) - dist_min) .lt. 1.e-7_dp) & + wigner_seitz%ndegen(wigner_seitz%nrpts) = & + wigner_seitz%ndegen(wigner_seitz%nrpts) + 1 end do - irvec(1, nrpts) = n1 - irvec(2, nrpts) = n2 - irvec(3, nrpts) = n3 - ! + wigner_seitz%irvec(1, wigner_seitz%nrpts) = n1 + wigner_seitz%irvec(2, wigner_seitz%nrpts) = n2 + wigner_seitz%irvec(3, wigner_seitz%nrpts) = n3 + ! Remember which grid point r is at the origin - ! - if (n1 == 0 .and. n2 == 0 .and. n3 == 0) rpt_origin = nrpts + + if (n1 == 0 .and. n2 == 0 .and. n3 == 0) wigner_seitz%rpt_origin = wigner_seitz%nrpts endif end if @@ -1492,41 +1780,38 @@ subroutine wigner_seitz(count_pts) enddo !n1 enddo - ! - deallocate (dist, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating dist wigner_seitz') if (count_pts) then - if (timing_level > 1 .and. on_root) & - call io_stopwatch('postw90_common: wigner_seitz', 2) + if (print_output%timing_level > 1 .and. on_root) & + call io_stopwatch('postw90_common: wigner_seitz', 2, stdout, seedname) return end if - ! Check the "sum rule" - tot = 0.0_dp - do i = 1, nrpts - tot = tot + 1.0_dp/real(ndegen(i), dp) - enddo - - if (iprint >= 3 .and. on_root) then - write (stdout, '(1x,i4,a,/)') nrpts, & + if (print_output%iprint >= 3 .and. on_root) then + write (stdout, '(1x,i4,a,/)') wigner_seitz%nrpts, & ' lattice points in Wigner-Seitz supercell:' - do ir = 1, nrpts - write (stdout, '(4x,a,3(i3,1x),a,i2)') ' vector ', irvec(1, ir), & - irvec(2, ir), irvec(3, ir), ' degeneracy: ', ndegen(ir) + do ir = 1, wigner_seitz%nrpts + write (stdout, '(4x,a,3(i3,1x),a,i2)') ' vector ', wigner_seitz%irvec(1, ir), & + wigner_seitz%irvec(2, ir), wigner_seitz%irvec(3, ir), ' degeneracy: ', & + wigner_seitz%ndegen(ir) enddo - write (stdout, '(1x,a,f12.3)') ' tot = ', tot - write (stdout, '(1x,a,i12)') ' mp_grid product = ', mp_grid(1)*mp_grid(2)*mp_grid(3) - endif - if (abs(tot - real(mp_grid(1)*mp_grid(2)*mp_grid(3), dp)) > eps8) then - call io_error('ERROR in wigner_seitz: error in finding Wigner-Seitz points') - endif + ! Check the "sum rule" + tot = 0.0_dp + do ir = 1, wigner_seitz%nrpts + ! + ! Corrects weights in Fourier sums for R-vectors on the boundary of the + ! W-S supercell + ! + tot = tot + 1.0_dp/real(wigner_seitz%ndegen(ir), dp) + enddo + if (abs(tot - real(mp_grid(1)*mp_grid(2)*mp_grid(3), dp)) > 1.e-8_dp) & + call io_error('ERROR in wigner_seitz: error in finding Wigner-Seitz points', stdout, seedname) - if (timing_level > 1 .and. on_root) & - call io_stopwatch('postw90_common: wigner_seitz', 2) + if (print_output%timing_level > 1 .and. on_root) & + call io_stopwatch('postw90_common: wigner_seitz', 2, stdout, seedname) return - end subroutine wigner_seitz + end subroutine wignerseitz end module w90_postw90_common diff --git a/src/postw90/postw90_readwrite.F90 b/src/postw90/postw90_readwrite.F90 new file mode 100644 index 000000000..019f6b3ca --- /dev/null +++ b/src/postw90/postw90_readwrite.F90 @@ -0,0 +1,2155 @@ +!-*- mode: F90 -*-! +!------------------------------------------------------------! +! This file is distributed as part of the Wannier90 code and ! +! under the terms of the GNU General Public License. See the ! +! file `LICENSE' in the root directory of the Wannier90 ! +! distribution, or http://www.gnu.org/copyleft/gpl.txt ! +! ! +! The webpage of the Wannier90 code is www.wannier.org ! +! ! +! The Wannier90 code is hosted on GitHub: ! +! ! +! https://github.com/wannier-developers/wannier90 ! +!------------------------------------------------------------! +! ! +! w90_postw90_readwrite: input and output routines ! +! specific to postw90.x ! +! ! +!------------------------------------------------------------! + +module w90_postw90_readwrite + + !! Read/write routines specific to postw90.x data types + + use w90_constants, only: dp + use w90_io, only: maxlen + use w90_types, only: print_output_type, print_output_type, wannier_data_type, & + kmesh_input_type, kmesh_info_type, dis_manifold_type, atom_data_type, kpoint_path_type, & + proj_input_type, w90_system_type, ws_region_type + use w90_readwrite + use w90_postw90_types + + implicit none + + private + + ! These could be local to w90_wannier90_readwrite_read if they weren't also used by w90_wannier90_readwrite_write + type pw90_extra_io_type + ! from gyrotropic section + real(kind=dp) :: gyrotropic_freq_min + real(kind=dp) :: gyrotropic_freq_max + real(kind=dp) :: gyrotropic_freq_step + real(kind=dp) :: kubo_freq_min + real(kind=dp) :: kubo_freq_max + real(kind=dp) :: kubo_freq_step + ! Adaptive vs. fixed smearing stuff [GP, Jul 12, 2012] + ! Only internal, always use the local variables defined by each module + ! that take this value as default + type(pw90_smearing_type) :: smear + ! [gp-begin, Apr 13, 2012] + ! Global interpolation k mesh variables + ! These don't need to be public, since their values are copied in the variables of the + ! local interpolation meshes. JRY: added save attribute + type(kmesh_spacing_type) :: global_kmesh + logical :: global_kmesh_set + ! [gp-end] + character(len=4) :: boltz_2d_dir ! this could be local to read_boltzwann + end type pw90_extra_io_type + + public :: pw90_extra_io_type + public :: w90_postw90_readwrite_read + public :: w90_postw90_readwrite_write + +contains + + !================================================! + + subroutine w90_postw90_readwrite_read(ws_region, w90_system, exclude_bands, print_output, wannier_data, & + kmesh_input, kpt_latt, num_kpts, dis_manifold, fermi_energy_list, & + atom_data, num_bands, num_wann, eigval, mp_grid, real_lattice, & + kpoint_path, pw90_calculation, pw90_oper_read, scissors_shift, & + effective_model, pw90_spin, pw90_band_deriv_degen, pw90_kpath, & + pw90_kslice, pw90_dos, pw90_berry, pw90_spin_hall, & + pw90_gyrotropic, pw90_geninterp, pw90_boltzwann, eig_found, & + pw90_extra_io, gamma_only, bohr, optimisation, stdout, seedname) + !================================================! + ! + !! Read parameters and calculate derived values + !! + !! Note on parallelization: this function should be called + !! from the root node only! + !! + ! + !================================================ + use w90_utility, only: utility_recip_lattice + implicit none + + ! arguments + type(atom_data_type), intent(inout) :: atom_data + type(pw90_berry_mod_type), intent(inout) :: pw90_berry + type(pw90_boltzwann_type), intent(inout) :: pw90_boltzwann + type(dis_manifold_type), intent(inout) :: dis_manifold + type(pw90_dos_mod_type), intent(inout) :: pw90_dos + type(pw90_geninterp_mod_type), intent(inout) :: pw90_geninterp + type(pw90_gyrotropic_type), intent(inout) :: pw90_gyrotropic + type(pw90_kpath_mod_type), intent(inout) :: pw90_kpath + type(pw90_kslice_mod_type), intent(inout) :: pw90_kslice + type(kmesh_input_type), intent(inout) :: kmesh_input + type(pw90_band_deriv_degen_type), intent(inout) :: pw90_band_deriv_degen + type(pw90_oper_read_type), intent(inout) :: pw90_oper_read + type(pw90_spin_mod_type), intent(inout) :: pw90_spin + type(print_output_type), intent(inout) :: print_output + type(pw90_calculation_type), intent(inout) :: pw90_calculation + type(pw90_extra_io_type), intent(inout) :: pw90_extra_io + type(ws_region_type), intent(inout) :: ws_region + type(kpoint_path_type), intent(inout) :: kpoint_path + type(pw90_spin_hall_type), intent(inout) :: pw90_spin_hall + type(w90_system_type), intent(inout) :: w90_system + type(wannier_data_type), intent(inout) :: wannier_data + + integer, intent(inout) :: mp_grid(3) + integer, intent(inout) :: num_bands + integer, intent(inout) :: num_kpts + integer, intent(inout) :: num_wann + integer, intent(inout) :: optimisation + integer, intent(in) :: stdout + integer, allocatable, intent(inout) :: exclude_bands(:) + + real(kind=dp), allocatable, intent(inout) :: eigval(:, :) + real(kind=dp), intent(in) :: bohr + real(kind=dp), intent(inout) :: real_lattice(3, 3) + real(kind=dp), intent(inout) :: scissors_shift + real(kind=dp), allocatable, intent(inout) :: fermi_energy_list(:) + real(kind=dp), allocatable, intent(inout) :: kpt_latt(:, :) + + character(len=50), intent(in) :: seedname + + logical, intent(inout) :: eig_found + logical, intent(inout) :: gamma_only + logical, intent(inout) :: effective_model + + ! local variables + real(kind=dp) :: recip_lattice(3, 3), volume + integer :: num_exclude_bands + logical :: dos_plot + logical :: found_fermi_energy + logical :: disentanglement, library, ok + character(len=20) :: energy_unit + + library = .false. + call w90_readwrite_in_file(seedname, stdout) + call w90_readwrite_read_verbosity(print_output, stdout, seedname) + call w90_readwrite_read_algorithm_control(optimisation, stdout, seedname) + call w90_wannier90_readwrite_read_pw90_calcs(pw90_calculation, stdout, seedname) + call w90_wannier90_readwrite_read_effective_model(effective_model, stdout, seedname) + call w90_readwrite_read_units(print_output%lenconfac, print_output%length_unit, energy_unit, bohr, & + stdout, seedname) + call w90_wannier90_readwrite_read_oper(pw90_oper_read, stdout, seedname) + call w90_readwrite_read_num_wann(num_wann, stdout, seedname) + call w90_readwrite_read_exclude_bands(exclude_bands, num_exclude_bands, stdout, seedname) !for read_chkpt + call w90_readwrite_read_num_bands(effective_model, library, num_exclude_bands, num_bands, num_wann, & + .false., stdout, seedname) + disentanglement = (num_bands > num_wann) + !call w90_readwrite_read_devel(print_output%devel_flag, stdout, seedname) + call w90_readwrite_read_mp_grid(effective_model, library, mp_grid, num_kpts, & + stdout, seedname) + call w90_readwrite_read_gamma_only(gamma_only, num_kpts, library, stdout, seedname) + call w90_readwrite_read_system(library, w90_system, stdout, seedname) + call w90_readwrite_read_kpath(library, kpoint_path, ok, .false., stdout, seedname) + call w90_readwrite_read_fermi_energy(found_fermi_energy, fermi_energy_list, stdout, seedname) + call w90_wannier90_readwrite_read_kslice(pw90_calculation%kslice, pw90_kslice, stdout, seedname) + call w90_wannier90_readwrite_read_smearing(pw90_extra_io%smear, stdout, seedname) + call w90_wannier90_readwrite_read_scissors_shift(scissors_shift, stdout, seedname) + call w90_wannier90_readwrite_read_pw90spin(pw90_calculation%spin_moment, pw90_calculation%spin_decomp, & + pw90_spin, w90_system%num_elec_per_state, stdout, seedname) + call w90_wannier90_readwrite_read_gyrotropic(pw90_gyrotropic, num_wann, pw90_extra_io%smear%fixed_width, & + pw90_extra_io%smear%type_index, stdout, seedname) + call w90_wannier90_readwrite_read_berry(pw90_calculation, pw90_berry, pw90_extra_io%smear, stdout, seedname) + call w90_wannier90_readwrite_read_spin_hall(pw90_calculation, scissors_shift, pw90_spin_hall, pw90_berry%task, & + stdout, seedname) + call w90_wannier90_readwrite_read_pw90ham(pw90_band_deriv_degen, stdout, seedname) + call w90_wannier90_readwrite_read_pw90_kpath(pw90_calculation, pw90_kpath, kpoint_path, stdout, seedname) + call w90_wannier90_readwrite_read_dos(pw90_calculation, pw90_dos, found_fermi_energy, num_wann, & + pw90_extra_io%smear, dos_plot, stdout, seedname) + call w90_readwrite_read_ws_data(ws_region, stdout, seedname) + call w90_readwrite_read_eigvals(effective_model, pw90_calculation%boltzwann, & + pw90_calculation%geninterp, dos_plot, disentanglement, eig_found, & + eigval, library, .false., num_bands, num_kpts, stdout, seedname) + dis_manifold%win_min = -1.0_dp + dis_manifold%win_max = 0.0_dp + if (eig_found) dis_manifold%win_min = minval(eigval) + if (eig_found) dis_manifold%win_max = maxval(eigval) + call w90_readwrite_read_dis_manifold(eig_found, dis_manifold, stdout, seedname) + call w90_wannier90_readwrite_read_geninterp(pw90_geninterp, stdout, seedname) + call w90_wannier90_readwrite_read_boltzwann(pw90_boltzwann, eigval, pw90_extra_io%smear, & + pw90_calculation%boltzwann, pw90_extra_io%boltz_2d_dir, stdout, & + seedname) + call w90_wannier90_readwrite_read_energy_range(pw90_berry, pw90_dos, pw90_gyrotropic, dis_manifold, & + fermi_energy_list, eigval, pw90_extra_io, stdout, seedname) + call w90_readwrite_read_lattice(library, real_lattice, bohr, stdout, seedname) + call w90_readwrite_read_kmesh_data(kmesh_input, stdout, seedname) + call utility_recip_lattice(real_lattice, recip_lattice, volume, stdout, seedname) + call w90_readwrite_read_kpoints(effective_model, library, kpt_latt, num_kpts, & + bohr, stdout, seedname) + call w90_wannier90_readwrite_read_global_kmesh(pw90_extra_io%global_kmesh_set, pw90_extra_io%global_kmesh, & + recip_lattice, stdout, seedname) + call w90_wannier90_readwrite_read_local_kmesh(pw90_calculation, pw90_berry, pw90_dos, pw90_spin, & + pw90_gyrotropic, pw90_boltzwann, recip_lattice, & + pw90_extra_io%global_kmesh_set, pw90_extra_io%global_kmesh, & + stdout, seedname) + call w90_readwrite_read_atoms(library, atom_data, real_lattice, bohr, stdout, seedname) !pw90_write + call w90_readwrite_clean_infile(stdout, seedname) + ! For aesthetic purposes, convert some things to uppercase + call w90_readwrite_uppercase(atom_data, kpoint_path, print_output%length_unit) + call w90_readwrite_read_final_alloc(disentanglement, dis_manifold, wannier_data, num_wann, num_bands, & + num_kpts, stdout, seedname) + end subroutine w90_postw90_readwrite_read + + !================================================! + subroutine w90_wannier90_readwrite_read_pw90_calcs(pw90_calculation, stdout, seedname) + !================================================! + implicit none + integer, intent(in) :: stdout + type(pw90_calculation_type), intent(out) :: pw90_calculation + character(len=50), intent(in) :: seedname + logical :: found + + pw90_calculation%dos = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'dos', found, l_value=pw90_calculation%dos) + + pw90_calculation%berry = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'berry', found, l_value=pw90_calculation%berry) + + pw90_calculation%kpath = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'kpath', found, l_value=pw90_calculation%kpath) + + pw90_calculation%kslice = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'kslice', found, l_value=pw90_calculation%kslice) + + pw90_calculation%gyrotropic = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic', found, & + l_value=pw90_calculation%gyrotropic) + + pw90_calculation%geninterp = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'geninterp', found, l_value=pw90_calculation%geninterp) + pw90_calculation%boltzwann = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'boltzwann', found, l_value=pw90_calculation%boltzwann) + + end subroutine w90_wannier90_readwrite_read_pw90_calcs + + !================================================! + subroutine w90_wannier90_readwrite_read_effective_model(effective_model, stdout, seedname) + !================================================! + implicit none + integer, intent(in) :: stdout + logical, intent(inout) :: effective_model + character(len=50), intent(in) :: seedname + + logical :: found + + !ivo + call w90_readwrite_get_keyword(stdout, seedname, 'effective_model', found, l_value=effective_model) + end subroutine w90_wannier90_readwrite_read_effective_model + + !================================================! + subroutine w90_wannier90_readwrite_read_oper(pw90_oper_read, stdout, seedname) + !================================================! + implicit none + integer, intent(in) :: stdout + type(pw90_oper_read_type), intent(inout) :: pw90_oper_read + character(len=50), intent(in) :: seedname + + logical :: found + + pw90_oper_read%spn_formatted = .false. ! formatted or "binary" file + call w90_readwrite_get_keyword(stdout, seedname, 'spn_formatted', found, & + l_value=pw90_oper_read%spn_formatted) + + pw90_oper_read%uHu_formatted = .false. ! formatted or "binary" file + call w90_readwrite_get_keyword(stdout, seedname, 'uhu_formatted', found, & + l_value=pw90_oper_read%uHu_formatted) + end subroutine w90_wannier90_readwrite_read_oper + + !================================================! + subroutine w90_wannier90_readwrite_read_kslice(kslicel, pw90_kslice, stdout, seedname) + !================================================! + + use w90_io, only: io_error + + implicit none + integer, intent(in) :: stdout + logical, intent(in) :: kslicel + type(pw90_kslice_mod_type), intent(inout) :: pw90_kslice + character(len=50), intent(in) :: seedname + + integer :: i + logical :: found + + pw90_kslice%task = 'fermi_lines' + call w90_readwrite_get_keyword(stdout, seedname, 'kslice_task', found, c_value=pw90_kslice%task) + if (kslicel .and. index(pw90_kslice%task, 'fermi_lines') == 0 .and. & + index(pw90_kslice%task, 'curv') == 0 .and. & + index(pw90_kslice%task, 'morb') == 0 .and. & + index(pw90_kslice%task, 'shc') == 0) call io_error & + ('Error: value of kslice_task not recognised in w90_wannier90_readwrite_read', stdout, seedname) + if (kslicel .and. index(pw90_kslice%task, 'curv') > 0 .and. & + index(pw90_kslice%task, 'morb') > 0) call io_error & + ("Error: kslice_task cannot include both 'curv' and 'morb'", stdout, seedname) + if (kslicel .and. index(pw90_kslice%task, 'shc') > 0 .and. & + index(pw90_kslice%task, 'morb') > 0) call io_error & + ("Error: kslice_task cannot include both 'shc' and 'morb'", stdout, seedname) + if (kslicel .and. index(pw90_kslice%task, 'shc') > 0 .and. & + index(pw90_kslice%task, 'curv') > 0) call io_error & + ("Error: kslice_task cannot include both 'shc' and 'curv'", stdout, seedname) + + pw90_kslice%kmesh2d(1:2) = 50 + call w90_readwrite_get_vector_length(stdout, seedname, 'kslice_2dkmesh', found, length=i) + if (found) then + if (i == 1) then + call w90_readwrite_get_keyword_vector(stdout, seedname, 'kslice_2dkmesh', found, 1, & + i_value=pw90_kslice%kmesh2d) + pw90_kslice%kmesh2d(2) = pw90_kslice%kmesh2d(1) + elseif (i == 2) then + call w90_readwrite_get_keyword_vector(stdout, seedname, 'kslice_2dkmesh', found, 2, & + i_value=pw90_kslice%kmesh2d) + else + call io_error('Error: kslice_2dkmesh must be provided as either' & + //' one integer or a vector of two integers', stdout, seedname) + endif + if (any(pw90_kslice%kmesh2d <= 0)) & + call io_error('Error: kslice_2dkmesh elements must be' & + //' greater than zero', stdout, seedname) + endif + + pw90_kslice%corner = 0.0_dp + call w90_readwrite_get_keyword_vector(stdout, seedname, 'kslice_corner', found, 3, & + r_value=pw90_kslice%corner) + + pw90_kslice%b1(1) = 1.0_dp + pw90_kslice%b1(2) = 0.0_dp + pw90_kslice%b1(3) = 0.0_dp + call w90_readwrite_get_keyword_vector(stdout, seedname, 'kslice_b1', found, 3, r_value=pw90_kslice%b1) + + pw90_kslice%b2(1) = 0.0_dp + pw90_kslice%b2(2) = 1.0_dp + pw90_kslice%b2(3) = 0.0_dp + call w90_readwrite_get_keyword_vector(stdout, seedname, 'kslice_b2', found, 3, r_value=pw90_kslice%b2) + + pw90_kslice%fermi_lines_colour = 'none' + call w90_readwrite_get_keyword(stdout, seedname, 'kslice_fermi_lines_colour', found, & + c_value=pw90_kslice%fermi_lines_colour) + if (kslicel .and. index(pw90_kslice%fermi_lines_colour, 'none') == 0 .and. & + index(pw90_kslice%fermi_lines_colour, 'spin') == 0) call io_error & + ('Error: value of kslice_fermi_lines_colour not recognised ' & + //'in w90_wannier90_readwrite_read', stdout, seedname) + +! slice_plot_format = 'plotmv' +! call w90_readwrite_get_keyword('slice_plot_format',found,c_value=slice_plot_format) + end subroutine w90_wannier90_readwrite_read_kslice + + !================================================! + subroutine w90_wannier90_readwrite_read_smearing(pw90_smearing, stdout, seedname) + !================================================! + + use w90_io, only: io_error + + implicit none + type(pw90_smearing_type), intent(out) :: pw90_smearing + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + + logical :: found + character(len=maxlen) :: ctmp + ! [gp-begin, Apr 20, 2012] + + ! By default: Gaussian + pw90_smearing%type_index = 0 + call w90_readwrite_get_keyword(stdout, seedname, 'smr_type', found, c_value=ctmp) + if (found) pw90_smearing%type_index = w90_readwrite_get_smearing_index(ctmp, 'smr_type', stdout, seedname) + + ! By default: adaptive smearing + pw90_smearing%use_adaptive = .true. + call w90_readwrite_get_keyword(stdout, seedname, 'adpt_smr', found, l_value=pw90_smearing%use_adaptive) + + ! By default: a=sqrt(2) + pw90_smearing%adaptive_prefactor = sqrt(2.0_dp) + call w90_readwrite_get_keyword(stdout, seedname, 'adpt_smr_fac', found, & + r_value=pw90_smearing%adaptive_prefactor) + if (found .and. (pw90_smearing%adaptive_prefactor <= 0._dp)) & + call io_error('Error: adpt_smr_fac must be greater than zero', stdout, seedname) + + ! By default: 1 eV + pw90_smearing%adaptive_max_width = 1.0_dp + call w90_readwrite_get_keyword(stdout, seedname, 'adpt_smr_max', found, & + r_value=pw90_smearing%adaptive_max_width) + if (pw90_smearing%adaptive_max_width <= 0._dp) & + call io_error('Error: adpt_smr_max must be greater than zero', stdout, seedname) + + ! By default: if adpt_smr is manually set to false by the user, but he/she doesn't + ! define smr_fixed_en_width: NO smearing, i.e. just the histogram + pw90_smearing%fixed_width = 0.0_dp + call w90_readwrite_get_keyword(stdout, seedname, 'smr_fixed_en_width', found, & + r_value=pw90_smearing%fixed_width) + if (found .and. (pw90_smearing%fixed_width < 0._dp)) & + call io_error('Error: smr_fixed_en_width must be greater than or equal to zero', stdout, & + seedname) + ! [gp-end] + end subroutine w90_wannier90_readwrite_read_smearing + + !================================================! + subroutine w90_wannier90_readwrite_read_scissors_shift(scissors_shift, stdout, seedname) + !================================================! + implicit none + integer, intent(in) :: stdout + real(kind=dp), intent(inout) :: scissors_shift + character(len=50), intent(in) :: seedname + + logical :: found + + scissors_shift = 0.0_dp + call w90_readwrite_get_keyword(stdout, seedname, 'scissors_shift', found, r_value=scissors_shift) + + end subroutine w90_wannier90_readwrite_read_scissors_shift + + !================================================! + subroutine w90_wannier90_readwrite_read_pw90spin(spin_moment, spin_decomp, pw90_spin, num_elec_per_state, & + stdout, seedname) + !================================================! + + use w90_io, only: io_error + + implicit none + integer, intent(in) :: stdout + logical, intent(out) :: spin_moment ! from pw90_calculation + logical, intent(out) :: spin_decomp ! from pw90_common + type(pw90_spin_mod_type), intent(inout) :: pw90_spin + integer, intent(in) :: num_elec_per_state + character(len=50), intent(in) :: seedname + + logical :: found + + spin_moment = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'spin_moment', found, l_value=spin_moment) + + pw90_spin%axis_polar = 0.0_dp + call w90_readwrite_get_keyword(stdout, seedname, 'spin_axis_polar', found, r_value=pw90_spin%axis_polar) + + pw90_spin%axis_azimuth = 0.0_dp + call w90_readwrite_get_keyword(stdout, seedname, 'spin_axis_azimuth', found, & + r_value=pw90_spin%axis_azimuth) + + spin_decomp = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'spin_decomp', found, l_value=spin_decomp) + + if (spin_decomp .and. (num_elec_per_state .ne. 1)) then + call io_error('spin_decomp can be true only if num_elec_per_state is 1', stdout, seedname) + end if + + end subroutine w90_wannier90_readwrite_read_pw90spin + + !================================================! + subroutine w90_wannier90_readwrite_read_gyrotropic(pw90_gyrotropic, num_wann, smr_fixed_en_width, smr_index, & + stdout, seedname) + !================================================! + + use w90_io, only: io_error + + implicit none + integer, intent(in) :: stdout + type(pw90_gyrotropic_type), intent(out) :: pw90_gyrotropic + integer, intent(in) :: num_wann + real(kind=dp), intent(in) :: smr_fixed_en_width + integer, intent(in) :: smr_index + character(len=50), intent(in) :: seedname + + real(kind=dp) :: smr_max_arg + real(kind=dp) :: gyrotropic_box_tmp(3) + integer :: i, ierr, loop + logical :: found + character(len=maxlen) :: ctmp + + ! Stepan + pw90_gyrotropic%task = 'all' + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic_task', found, c_value=pw90_gyrotropic%task) + pw90_gyrotropic%box(:, :) = 0.0 + pw90_gyrotropic%degen_thresh = 0.0_dp + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic_degen_thresh', found, & + r_value=pw90_gyrotropic%degen_thresh) + + do i = 1, 3 + pw90_gyrotropic%box(i, i) = 1.0_dp + gyrotropic_box_tmp(:) = 0.0_dp + call w90_readwrite_get_keyword_vector(stdout, seedname, 'gyrotropic_box_b'//achar(48 + i), found, 3, & + r_value=gyrotropic_box_tmp) + if (found) pw90_gyrotropic%box(i, :) = gyrotropic_box_tmp(:) + enddo + pw90_gyrotropic%box_corner(:) = 0.0_dp + call w90_readwrite_get_keyword_vector(stdout, seedname, 'gyrotropic_box_center', found, 3, & + r_value=gyrotropic_box_tmp) + if (found) pw90_gyrotropic%box_corner(:) = & + gyrotropic_box_tmp(:) - 0.5*(pw90_gyrotropic%box(1, :) + pw90_gyrotropic%box(2, :) + & + pw90_gyrotropic%box(3, :)) + + call w90_readwrite_get_range_vector(stdout, seedname, 'gyrotropic_band_list', found, & + pw90_gyrotropic%num_bands, lcount=.true.) + if (found) then + if (pw90_gyrotropic%num_bands < 1) & + call io_error('Error: problem reading gyrotropic_band_list', stdout, seedname) + if (allocated(pw90_gyrotropic%band_list)) deallocate (pw90_gyrotropic%band_list) + allocate (pw90_gyrotropic%band_list(pw90_gyrotropic%num_bands), stat=ierr) + if (ierr /= 0) call io_error('Error allocating gyrotropic_band_list in w90_wannier90_readwrite_read', stdout, & + seedname) + call w90_readwrite_get_range_vector(stdout, seedname, 'gyrotropic_band_list', found, & + pw90_gyrotropic%num_bands, .false., pw90_gyrotropic%band_list) + if (any(pw90_gyrotropic%band_list < 1) .or. any(pw90_gyrotropic%band_list > num_wann)) & + call io_error('Error: gyrotropic_band_list asks for a non-valid bands', stdout, seedname) + else + ! include all bands in the calculation + pw90_gyrotropic%num_bands = num_wann + if (allocated(pw90_gyrotropic%band_list)) deallocate (pw90_gyrotropic%band_list) + allocate (pw90_gyrotropic%band_list(pw90_gyrotropic%num_bands), stat=ierr) + if (ierr /= 0) call io_error('Error allocating gyrotropic_band_list in w90_wannier90_readwrite_read', stdout, & + seedname) + do loop = 1, num_wann + pw90_gyrotropic%band_list(loop) = loop + end do + end if + + pw90_gyrotropic%smearing%use_adaptive = .false. + smr_max_arg = 5.0 + call w90_readwrite_get_keyword(stdout, seedname, 'smr_max_arg', found, r_value=smr_max_arg) + if (found .and. (smr_max_arg <= 0._dp)) & + call io_error('Error: smr_max_arg must be greater than zero', stdout, seedname) + + pw90_gyrotropic%smearing%max_arg = smr_max_arg + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic_smr_max_arg', found, & + r_value=pw90_gyrotropic%smearing%max_arg) + if (found .and. (pw90_gyrotropic%smearing%max_arg <= 0._dp)) call io_error & + ('Error: gyrotropic_smr_max_arg must be greater than zero', stdout, seedname) + + pw90_gyrotropic%smearing%fixed_width = smr_fixed_en_width + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic_smr_fixed_en_width', found, & + r_value=pw90_gyrotropic%smearing%fixed_width) + if (found .and. (pw90_gyrotropic%smearing%fixed_width < 0._dp)) call io_error & + ('Error: gyrotropic_smr_fixed_en_width must be greater than or equal to zero', stdout, & + seedname) + + ! By default: use the "global" smearing index + pw90_gyrotropic%smearing%type_index = smr_index + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic_smr_type', found, c_value=ctmp) + if (found) pw90_gyrotropic%smearing%type_index = w90_readwrite_get_smearing_index(ctmp, & + 'gyrotropic_smr_type', stdout, seedname) + + end subroutine w90_wannier90_readwrite_read_gyrotropic + + !================================================! + subroutine w90_wannier90_readwrite_read_berry(pw90_calculation, pw90_berry, pw90_smearing, stdout, seedname) + !================================================! + + use w90_io, only: io_error + + implicit none + integer, intent(in) :: stdout + type(pw90_calculation_type), intent(in) :: pw90_calculation + type(pw90_berry_mod_type), intent(out) :: pw90_berry + type(pw90_smearing_type), intent(in) :: pw90_smearing + character(len=50), intent(in) :: seedname + + logical :: found + integer :: kdotp_num_bands, ierr + character(len=maxlen) :: ctmp + +!------------------------------------------------------- +! alpha=0 +! call w90_readwrite_get_keyword('alpha',found,i_value=alpha) + +! beta=0 +! call w90_readwrite_get_keyword('beta',found,i_value=beta) + +! gamma=0 +! call w90_readwrite_get_keyword('gamma',found,i_value=gamma) +!------------------------------------------------------- + + pw90_berry%transl_inv = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'transl_inv', found, l_value=pw90_berry%transl_inv) + + pw90_berry%task = ' ' + call w90_readwrite_get_keyword(stdout, seedname, 'berry_task', found, c_value=pw90_berry%task) + if (pw90_calculation%berry .and. .not. found) call io_error & + ('Error: berry=T and berry_task is not set', stdout, seedname) + if (pw90_calculation%berry .and. index(pw90_berry%task, 'ahc') == 0 & + .and. index(pw90_berry%task, 'morb') == 0 & + .and. index(pw90_berry%task, 'kubo') == 0 .and. index(pw90_berry%task, 'sc') == 0 & + .and. index(pw90_berry%task, 'shc') == 0 .and. index(pw90_berry%task, 'kdotp') == 0) & + call io_error('Error: value of berry_task not recognised in w90_wannier90_readwrite_read', stdout, seedname) + + pw90_berry%curv_adpt_kmesh = 1 + call w90_readwrite_get_keyword(stdout, seedname, 'berry_curv_adpt_kmesh', found, & + i_value=pw90_berry%curv_adpt_kmesh) + if (pw90_berry%curv_adpt_kmesh < 1) & + call io_error( & + 'Error: berry_curv_adpt_kmesh must be a positive integer', stdout, seedname) + + pw90_berry%curv_adpt_kmesh_thresh = 100.0_dp + call w90_readwrite_get_keyword(stdout, seedname, 'berry_curv_adpt_kmesh_thresh', found, & + r_value=pw90_berry%curv_adpt_kmesh_thresh) + + pw90_berry%curv_unit = 'ang2' + call w90_readwrite_get_keyword(stdout, seedname, 'berry_curv_unit', found, c_value=pw90_berry%curv_unit) + if (pw90_berry%curv_unit .ne. 'ang2' .and. pw90_berry%curv_unit .ne. 'bohr2') & + call io_error & + ('Error: value of berry_curv_unit not recognised in w90_wannier90_readwrite_read', stdout, seedname) + + pw90_berry%wanint_kpoint_file = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'wanint_kpoint_file', found, & + l_value=pw90_berry%wanint_kpoint_file) + +! smear_temp = -1.0_dp +! call w90_readwrite_get_keyword('smear_temp',found,r_value=smear_temp) + + pw90_berry%kubo_smearing%use_adaptive = pw90_smearing%use_adaptive + call w90_readwrite_get_keyword(stdout, seedname, 'kubo_adpt_smr', found, & + l_value=pw90_berry%kubo_smearing%use_adaptive) + + pw90_berry%kubo_smearing%adaptive_prefactor = pw90_smearing%adaptive_prefactor + call w90_readwrite_get_keyword(stdout, seedname, 'kubo_adpt_smr_fac', found, & + r_value=pw90_berry%kubo_smearing%adaptive_prefactor) + if (found .and. (pw90_berry%kubo_smearing%adaptive_prefactor <= 0._dp)) call io_error & + ('Error: kubo_adpt_smr_fac must be greater than zero', stdout, seedname) + + pw90_berry%kubo_smearing%adaptive_max_width = pw90_smearing%adaptive_max_width + call w90_readwrite_get_keyword(stdout, seedname, 'kubo_adpt_smr_max', found, & + r_value=pw90_berry%kubo_smearing%adaptive_max_width) + if (pw90_berry%kubo_smearing%adaptive_max_width <= 0._dp) call io_error & + ('Error: kubo_adpt_smr_max must be greater than zero', stdout, seedname) + + pw90_berry%kubo_smearing%fixed_width = pw90_smearing%fixed_width + call w90_readwrite_get_keyword(stdout, seedname, 'kubo_smr_fixed_en_width', found, & + r_value=pw90_berry%kubo_smearing%fixed_width) + if (found .and. (pw90_berry%kubo_smearing%fixed_width < 0._dp)) call io_error & + ('Error: kubo_smr_fixed_en_width must be greater than or equal to zero', stdout, seedname) + + pw90_berry%sc_phase_conv = 1 + call w90_readwrite_get_keyword(stdout, seedname, 'sc_phase_conv', found, & + i_value=pw90_berry%sc_phase_conv) + if ((pw90_berry%sc_phase_conv .ne. 1) .and. ((pw90_berry%sc_phase_conv .ne. 2))) & + call io_error('Error: sc_phase_conv must be either 1 or 2', stdout, seedname) + + pw90_berry%sc_use_eta_corr = .true. + call w90_readwrite_get_keyword(stdout, seedname, 'sc_use_eta_corr', found, & + l_value=pw90_berry%sc_use_eta_corr) + + ! By default: use the "global" smearing index + pw90_berry%kubo_smearing%type_index = pw90_smearing%type_index + call w90_readwrite_get_keyword(stdout, seedname, 'kubo_smr_type', found, c_value=ctmp) + if (found) pw90_berry%kubo_smearing%type_index = w90_readwrite_get_smearing_index(ctmp, 'kubo_smr_type', & + stdout, seedname) + + pw90_berry%sc_eta = 0.04 + call w90_readwrite_get_keyword(stdout, seedname, 'sc_eta', found, r_value=pw90_berry%sc_eta) + + pw90_berry%sc_w_thr = 5.0d0 + call w90_readwrite_get_keyword(stdout, seedname, 'sc_w_thr', found, r_value=pw90_berry%sc_w_thr) + + pw90_berry%kdotp_kpoint(:) = 0.0_dp + call w90_readwrite_get_keyword_vector(stdout, seedname, 'kdotp_kpoint', found, 3, & + r_value=pw90_berry%kdotp_kpoint) + + kdotp_num_bands = 0 + call w90_readwrite_get_keyword(stdout, seedname, 'kdotp_num_bands', found, i_value=kdotp_num_bands) + if (found) then + if (kdotp_num_bands < 1) call io_error('Error: problem reading kdotp_num_bands', stdout, & + seedname) + allocate (pw90_berry%kdotp_bands(kdotp_num_bands), stat=ierr) + if (ierr /= 0) call io_error('Error allocating kdotp_num_bands in w90_wannier90_readwrite_read', stdout, & + seedname) + call w90_readwrite_get_range_vector(stdout, seedname, 'kdotp_bands', found, kdotp_num_bands, & + .false., pw90_berry%kdotp_bands) + if (any(pw90_berry%kdotp_bands < 1)) & + call io_error('Error: kdotp_bands must contain positive numbers', stdout, seedname) + end if + + end subroutine w90_wannier90_readwrite_read_berry + + !================================================! + subroutine w90_wannier90_readwrite_read_spin_hall(pw90_calculation, scissors_shift, pw90_spin_hall, berry_task, & + stdout, seedname) + !================================================! + + use w90_io, only: io_error + + implicit none + + type(pw90_calculation_type), intent(in) :: pw90_calculation + type(pw90_spin_hall_type), intent(out) :: pw90_spin_hall + + integer, intent(in) :: stdout + real(kind=dp), intent(in) :: scissors_shift + + character(len=*), intent(in) :: berry_task + character(len=50), intent(in) :: seedname + + logical :: found + + pw90_spin_hall%freq_scan = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'shc_freq_scan', found, & + l_value=pw90_spin_hall%freq_scan) + + pw90_spin_hall%alpha = 1 + call w90_readwrite_get_keyword(stdout, seedname, 'shc_alpha', found, i_value=pw90_spin_hall%alpha) + if (found .and. (pw90_spin_hall%alpha < 1 .or. pw90_spin_hall%alpha > 3)) call io_error & + ('Error: shc_alpha must be 1, 2 or 3', stdout, seedname) + + pw90_spin_hall%beta = 2 + call w90_readwrite_get_keyword(stdout, seedname, 'shc_beta', found, i_value=pw90_spin_hall%beta) + if (found .and. (pw90_spin_hall%beta < 1 .or. pw90_spin_hall%beta > 3)) call io_error & + ('Error: shc_beta must be 1, 2 or 3', stdout, seedname) + + pw90_spin_hall%gamma = 3 + call w90_readwrite_get_keyword(stdout, seedname, 'shc_gamma', found, i_value=pw90_spin_hall%gamma) + if (found .and. (pw90_spin_hall%gamma < 1 .or. pw90_spin_hall%gamma > 3)) call io_error & + ('Error: shc_gamma must be 1, 2 or 3', stdout, seedname) + + pw90_spin_hall%bandshift = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'shc_bandshift', found, & + l_value=pw90_spin_hall%bandshift) + pw90_spin_hall%bandshift = pw90_spin_hall%bandshift .and. pw90_calculation%berry .and. & + .not. (index(berry_task, 'shc') == 0) + if ((abs(scissors_shift) > 1.0e-7_dp) .and. pw90_spin_hall%bandshift) & + call io_error('Error: shc_bandshift and scissors_shift cannot be used simultaneously', & + stdout, seedname) + + pw90_spin_hall%bandshift_firstband = 0 + call w90_readwrite_get_keyword(stdout, seedname, 'shc_bandshift_firstband', found, & + i_value=pw90_spin_hall%bandshift_firstband) + if (pw90_spin_hall%bandshift .and. (.not. found)) & + call io_error('Error: shc_bandshift required but no shc_bandshift_firstband provided', & + stdout, seedname) + if ((pw90_spin_hall%bandshift_firstband < 1) .and. found) & + call io_error('Error: shc_bandshift_firstband must >= 1', stdout, seedname) + + pw90_spin_hall%bandshift_energyshift = 0._dp + call w90_readwrite_get_keyword(stdout, seedname, 'shc_bandshift_energyshift', found, & + r_value=pw90_spin_hall%bandshift_energyshift) + if (pw90_spin_hall%bandshift .and. (.not. found)) & + call io_error('Error: shc_bandshift required but no shc_bandshift_energyshift provided', & + stdout, seedname) + + pw90_spin_hall%method = ' ' + call w90_readwrite_get_keyword(stdout, seedname, 'shc_method', found, c_value=pw90_spin_hall%method) + if (index(berry_task, 'shc') > 0 .and. .not. found) call io_error & + ('Error: berry_task=shc and shc_method is not set', stdout, seedname) + if (index(berry_task, 'shc') > 0 .and. index(pw90_spin_hall%method, 'qiao') == 0 & + .and. index(pw90_spin_hall%method, 'ryoo') == 0) call io_error & + ('Error: value of shc_method not recognised in w90_wannier90_readwrite_read', stdout, seedname) + + end subroutine w90_wannier90_readwrite_read_spin_hall + + !================================================! + subroutine w90_wannier90_readwrite_read_pw90ham(pw90_band_deriv_degen, stdout, seedname) + !================================================! + implicit none + integer, intent(in) :: stdout + type(pw90_band_deriv_degen_type), intent(out) :: pw90_band_deriv_degen + character(len=50), intent(in) :: seedname + + logical :: found + + pw90_band_deriv_degen%use_degen_pert = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'use_degen_pert', found, & + l_value=pw90_band_deriv_degen%use_degen_pert) + + pw90_band_deriv_degen%degen_thr = 1.0d-4 + call w90_readwrite_get_keyword(stdout, seedname, 'degen_thr', found, & + r_value=pw90_band_deriv_degen%degen_thr) + + end subroutine w90_wannier90_readwrite_read_pw90ham + + !================================================! + subroutine w90_wannier90_readwrite_read_pw90_kpath(pw90_calculation, pw90_kpath, kpoint_path, stdout, seedname) + !================================================! + + use w90_io, only: io_error + + implicit none + + type(pw90_calculation_type), intent(in) :: pw90_calculation + type(pw90_kpath_mod_type), intent(out) :: pw90_kpath + type(kpoint_path_type), intent(in) :: kpoint_path + + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + + logical :: found + + pw90_kpath%task = 'bands' + call w90_readwrite_get_keyword(stdout, seedname, 'kpath_task', found, c_value=pw90_kpath%task) + if (pw90_calculation%kpath .and. index(pw90_kpath%task, 'bands') == 0 .and. & + index(pw90_kpath%task, 'curv') == 0 .and. & + index(pw90_kpath%task, 'morb') == 0 .and. & + index(pw90_kpath%task, 'shc') == 0) call io_error & + ('Error: value of kpath_task not recognised in w90_wannier90_readwrite_read', stdout, seedname) + if (.not. allocated(kpoint_path%labels) .and. pw90_calculation%kpath) & + call io_error('Error: a kpath plot has been requested but there is no kpoint_path block', & + stdout, seedname) + + pw90_kpath%num_points = 100 + call w90_readwrite_get_keyword(stdout, seedname, 'kpath_num_points', found, & + i_value=pw90_kpath%num_points) + if (pw90_kpath%num_points < 0) & + call io_error('Error: kpath_num_points must be positive', stdout, seedname) + + pw90_kpath%bands_colour = 'none' + call w90_readwrite_get_keyword(stdout, seedname, 'kpath_bands_colour', found, & + c_value=pw90_kpath%bands_colour) + if (pw90_calculation%kpath .and. index(pw90_kpath%bands_colour, 'none') == 0 .and. & + index(pw90_kpath%bands_colour, 'spin') == 0 .and. & + index(pw90_kpath%bands_colour, 'shc') == 0) call io_error & + ('Error: value of kpath_bands_colour not recognised in w90_wannier90_readwrite_read', stdout, seedname) + if (pw90_calculation%kpath .and. index(pw90_kpath%task, 'shc') > 0 .and. & + index(pw90_kpath%task, 'spin') > 0) call io_error & + ("Error: kpath_task cannot include both 'shc' and 'spin'", stdout, seedname) + + end subroutine w90_wannier90_readwrite_read_pw90_kpath + + !================================================! + subroutine w90_wannier90_readwrite_read_dos(pw90_calculation, pw90_dos, found_fermi_energy, num_wann, & + pw90_smearing, dos_plot, stdout, seedname) + !================================================! + + use w90_io, only: io_error + + implicit none + + type(pw90_calculation_type), intent(in) :: pw90_calculation + type(pw90_dos_mod_type), intent(out) :: pw90_dos + type(pw90_smearing_type), intent(in) :: pw90_smearing + + integer, intent(in) :: stdout + integer, intent(in) :: num_wann + logical, intent(out) :: dos_plot + logical, intent(in) :: found_fermi_energy + character(len=50), intent(in) :: seedname + + integer :: i, ierr + logical :: found + character(len=maxlen) :: ctmp + + pw90_dos%task = 'dos_plot' + if (pw90_calculation%dos) then + dos_plot = .true. + else + dos_plot = .false. + endif + call w90_readwrite_get_keyword(stdout, seedname, 'dos_task', found, c_value=pw90_dos%task) + if (pw90_calculation%dos) then + if (index(pw90_dos%task, 'dos_plot') == 0 .and. & + index(pw90_dos%task, 'find_fermi_energy') == 0) call io_error & + ('Error: value of dos_task not recognised in w90_wannier90_readwrite_read', stdout, seedname) + if (index(pw90_dos%task, 'dos_plot') > 0) dos_plot = .true. + if (index(pw90_dos%task, 'find_fermi_energy') > 0 .and. found_fermi_energy) & + call io_error & + ('Error: Cannot set "dos_task = find_fermi_energy" and give a value to "fermi_energy"', & + stdout, seedname) + end if + +! sigma_abc_onlyorb=.false. +! call w90_readwrite_get_keyword('sigma_abc_onlyorb',found,l_value=sigma_abc_onlyorb) + +! ------------------------------------------------------------------- + + !IVO_END + + pw90_dos%energy_step = 0.01_dp + call w90_readwrite_get_keyword(stdout, seedname, 'dos_energy_step', found, & + r_value=pw90_dos%energy_step) + + pw90_dos%smearing%use_adaptive = pw90_smearing%use_adaptive + call w90_readwrite_get_keyword(stdout, seedname, 'dos_adpt_smr', found, & + l_value=pw90_dos%smearing%use_adaptive) + + pw90_dos%smearing%adaptive_prefactor = pw90_smearing%adaptive_prefactor + call w90_readwrite_get_keyword(stdout, seedname, 'dos_adpt_smr_fac', found, & + r_value=pw90_dos%smearing%adaptive_prefactor) + if (found .and. (pw90_dos%smearing%adaptive_prefactor <= 0._dp)) & + call io_error('Error: dos_adpt_smr_fac must be greater than zero', stdout, seedname) + + pw90_dos%smearing%adaptive_max_width = pw90_smearing%adaptive_max_width + call w90_readwrite_get_keyword(stdout, seedname, 'dos_adpt_smr_max', found, & + r_value=pw90_dos%smearing%adaptive_max_width) + if (pw90_dos%smearing%adaptive_max_width <= 0._dp) call io_error & + ('Error: dos_adpt_smr_max must be greater than zero', stdout, seedname) + + pw90_dos%smearing%fixed_width = pw90_smearing%fixed_width + call w90_readwrite_get_keyword(stdout, seedname, 'dos_smr_fixed_en_width', found, & + r_value=pw90_dos%smearing%fixed_width) + if (found .and. (pw90_dos%smearing%fixed_width < 0._dp)) & + call io_error('Error: dos_smr_fixed_en_width must be greater than or equal to zero', stdout, & + seedname) + +! dos_gaussian_width = 0.1_dp +! call w90_readwrite_get_keyword('dos_gaussian_width',found,r_value=dos_gaussian_width) + +! dos_plot_format = 'gnuplot' +! call w90_readwrite_get_keyword('dos_plot_format',found,c_value=dos_plot_format) + + call w90_readwrite_get_range_vector(stdout, seedname, 'dos_project', found, & + pw90_dos%num_project, lcount=.true.) + if (found) then + if (pw90_dos%num_project < 1) call io_error('Error: problem reading dos_project', stdout, & + seedname) + if (allocated(pw90_dos%project)) deallocate (pw90_dos%project) + allocate (pw90_dos%project(pw90_dos%num_project), stat=ierr) + if (ierr /= 0) call io_error('Error allocating dos_project in w90_wannier90_readwrite_read', stdout, seedname) + call w90_readwrite_get_range_vector(stdout, seedname, 'dos_project', found, & + pw90_dos%num_project, .false., & + pw90_dos%project) + if (any(pw90_dos%project < 1) .or. & + any(pw90_dos%project > num_wann)) & + call io_error('Error: dos_project asks for out-of-range Wannier functions', stdout, & + seedname) + else + ! by default plot all + pw90_dos%num_project = num_wann + if (allocated(pw90_dos%project)) deallocate (pw90_dos%project) + allocate (pw90_dos%project(pw90_dos%num_project), stat=ierr) + if (ierr /= 0) call io_error('Error allocating dos_project in w90_wannier90_readwrite_read', stdout, seedname) + do i = 1, pw90_dos%num_project + pw90_dos%project(i) = i + end do + endif + + ! By default: use the "global" smearing index + pw90_dos%smearing%type_index = pw90_smearing%type_index + call w90_readwrite_get_keyword(stdout, seedname, 'dos_smr_type', found, c_value=ctmp) + if (found) pw90_dos%smearing%type_index = w90_readwrite_get_smearing_index(ctmp, 'dos_smr_type', stdout, & + seedname) + + end subroutine w90_wannier90_readwrite_read_dos + + !================================================! + subroutine w90_wannier90_readwrite_read_geninterp(pw90_geninterp, stdout, seedname) + !================================================! + ! [gp-begin, Jun 1, 2012] + ! General band interpolator (pw90_geninterp) + !================================================! + + implicit none + + type(pw90_geninterp_mod_type), intent(out) :: pw90_geninterp + + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + + logical :: found + + pw90_geninterp%alsofirstder = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'geninterp_alsofirstder', found, & + l_value=pw90_geninterp%alsofirstder) + pw90_geninterp%single_file = .true. + call w90_readwrite_get_keyword(stdout, seedname, 'geninterp_single_file', found, & + l_value=pw90_geninterp%single_file) + ! [gp-end, Jun 1, 2012] + + end subroutine w90_wannier90_readwrite_read_geninterp + + !================================================! + subroutine w90_wannier90_readwrite_read_boltzwann(pw90_boltzwann, eigval, pw90_smearing, do_boltzwann, & + boltz_2d_dir, stdout, seedname) + !================================================! + ! [gp-begin, Jun 1, 2012] + ! General band interpolator (pw90_geninterp) + !================================================! + + use w90_io, only: io_error + + implicit none + type(pw90_boltzwann_type), intent(inout) :: pw90_boltzwann + type(pw90_smearing_type), intent(in) :: pw90_smearing + + integer, intent(in) :: stdout + real(kind=dp), allocatable, intent(in) :: eigval(:, :) + logical, intent(in) :: do_boltzwann + character(len=4), intent(out) :: boltz_2d_dir + character(len=50), intent(in) :: seedname + + logical :: found, found2 + character(len=maxlen) :: ctmp + + ! [gp-begin, Apr 12, 2012] + !%%%%%%%%%%%%%%%%%%%% + ! Boltzmann transport + !%%%%%%%%%%%%%%%%%%%% + ! Note: to be put AFTER the disentanglement routines! + pw90_boltzwann%TDF_smearing%use_adaptive = .false. + + pw90_boltzwann%calc_also_dos = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_calc_also_dos', found, & + l_value=pw90_boltzwann%calc_also_dos) + + pw90_boltzwann%calc_also_dos = pw90_boltzwann%calc_also_dos .and. do_boltzwann + + ! 0 means the normal 3d case for the calculation of the Seebeck coefficient + ! The other valid possibilities are 1,2,3 for x,y,z respectively + pw90_boltzwann%dir_num_2d = 0 + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_2d_dir', found, c_value=boltz_2d_dir) + if (found) then + if (trim(boltz_2d_dir) == 'no') then + pw90_boltzwann%dir_num_2d = 0 + elseif (trim(boltz_2d_dir) == 'x') then + pw90_boltzwann%dir_num_2d = 1 + elseif (trim(boltz_2d_dir) == 'y') then + pw90_boltzwann%dir_num_2d = 2 + elseif (trim(boltz_2d_dir) == 'z') then + pw90_boltzwann%dir_num_2d = 3 + else + call io_error('Error: boltz_2d_dir can only be "no", "x", "y" or "z".', stdout, seedname) + end if + end if + + pw90_boltzwann%dos_energy_step = 0.001_dp + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_dos_energy_step', found, & + r_value=pw90_boltzwann%dos_energy_step) + if (found .and. (pw90_boltzwann%dos_energy_step <= 0._dp)) & + call io_error('Error: boltz_dos_energy_step must be positive', stdout, seedname) + + if (allocated(eigval)) then + pw90_boltzwann%dos_energy_min = minval(eigval) - 0.6667_dp + else + ! Boltz_dos cannot run if eigval is not allocated. + ! We just set here a default numerical value. + pw90_boltzwann%dos_energy_min = -1.0_dp + end if + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_dos_energy_min', found, & + r_value=pw90_boltzwann%dos_energy_min) + if (allocated(eigval)) then + pw90_boltzwann%dos_energy_max = maxval(eigval) + 0.6667_dp + else + ! Boltz_dos cannot run if eigval is not allocated. + ! We just set here a default numerical value. + pw90_boltzwann%dos_energy_max = 0.0_dp + end if + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_dos_energy_max', found, & + r_value=pw90_boltzwann%dos_energy_max) + if (pw90_boltzwann%dos_energy_max <= pw90_boltzwann%dos_energy_min) & + call io_error('Error: boltz_dos_energy_max must be greater than boltz_dos_energy_min', & + stdout, seedname) + + pw90_boltzwann%dos_smearing%use_adaptive = pw90_smearing%use_adaptive + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_dos_adpt_smr', found, & + l_value=pw90_boltzwann%dos_smearing%use_adaptive) + + pw90_boltzwann%dos_smearing%adaptive_prefactor = pw90_smearing%adaptive_prefactor + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_dos_adpt_smr_fac', found, & + r_value=pw90_boltzwann%dos_smearing%adaptive_prefactor) + if (found .and. (pw90_boltzwann%dos_smearing%adaptive_prefactor <= 0._dp)) & + call io_error('Error: boltz_dos_adpt_smr_fac must be greater than zero', stdout, seedname) + + pw90_boltzwann%dos_smearing%adaptive_max_width = pw90_smearing%adaptive_max_width + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_dos_adpt_smr_max', found, & + r_value=pw90_boltzwann%dos_smearing%adaptive_max_width) + if (pw90_boltzwann%dos_smearing%adaptive_max_width <= 0._dp) call io_error & + ('Error: boltz_dos_adpt_smr_max must be greater than zero', stdout, seedname) + + pw90_boltzwann%dos_smearing%fixed_width = pw90_smearing%fixed_width + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_dos_smr_fixed_en_width', found, & + r_value=pw90_boltzwann%dos_smearing%fixed_width) + if (found .and. (pw90_boltzwann%dos_smearing%fixed_width < 0._dp)) & + call io_error('Error: boltz_dos_smr_fixed_en_width must be greater than or equal to zero', & + stdout, seedname) + + pw90_boltzwann%mu_min = -999._dp + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_mu_min', found, r_value=pw90_boltzwann%mu_min) + if ((.not. found) .and. do_boltzwann) & + call io_error('Error: BoltzWann required but no boltz_mu_min provided', stdout, seedname) + pw90_boltzwann%mu_max = -999._dp + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_mu_max', found2, r_value=pw90_boltzwann%mu_max) + if ((.not. found2) .and. do_boltzwann) & + call io_error('Error: BoltzWann required but no boltz_mu_max provided', stdout, seedname) + if (found .and. found2 .and. (pw90_boltzwann%mu_max < pw90_boltzwann%mu_min)) & + call io_error('Error: boltz_mu_max must be greater than boltz_mu_min', stdout, seedname) + pw90_boltzwann%mu_step = 0._dp + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_mu_step', found, r_value=pw90_boltzwann%mu_step) + if ((.not. found) .and. do_boltzwann) & + call io_error('Error: BoltzWann required but no boltz_mu_step provided', stdout, seedname) + if (found .and. (pw90_boltzwann%mu_step <= 0._dp)) & + call io_error('Error: boltz_mu_step must be greater than zero', stdout, seedname) + + pw90_boltzwann%temp_min = -999._dp + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_temp_min', found, & + r_value=pw90_boltzwann%temp_min) + if ((.not. found) .and. do_boltzwann) & + call io_error('Error: BoltzWann required but no boltz_temp_min provided', stdout, seedname) + pw90_boltzwann%temp_max = -999._dp + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_temp_max', found2, & + r_value=pw90_boltzwann%temp_max) + if ((.not. found2) .and. do_boltzwann) & + call io_error('Error: BoltzWann required but no boltz_temp_max provided', stdout, seedname) + if (found .and. found2 .and. (pw90_boltzwann%temp_max < pw90_boltzwann%temp_min)) & + call io_error('Error: boltz_temp_max must be greater than boltz_temp_min', stdout, seedname) + if (found .and. (pw90_boltzwann%temp_min <= 0._dp)) & + call io_error('Error: boltz_temp_min must be greater than zero', stdout, seedname) + pw90_boltzwann%temp_step = 0._dp + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_temp_step', found, & + r_value=pw90_boltzwann%temp_step) + if ((.not. found) .and. do_boltzwann) & + call io_error('Error: BoltzWann required but no boltz_temp_step provided', stdout, seedname) + if (found .and. (pw90_boltzwann%temp_step <= 0._dp)) & + call io_error('Error: boltz_temp_step must be greater than zero', stdout, seedname) + + ! The interpolation mesh is read later on + + ! By default, the energy step for the TDF is 1 meV + pw90_boltzwann%tdf_energy_step = 0.001_dp + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_tdf_energy_step', found, & + r_value=pw90_boltzwann%tdf_energy_step) + if (pw90_boltzwann%tdf_energy_step <= 0._dp) & + call io_error('Error: boltz_tdf_energy_step must be greater than zero', stdout, seedname) + + ! For TDF: TDF smeared in a NON-adaptive way; value in eV, default = 0._dp + ! (i.e., no smearing) + pw90_boltzwann%tdf_smearing%fixed_width = pw90_smearing%fixed_width + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_tdf_smr_fixed_en_width', found, & + r_value=pw90_boltzwann%tdf_smearing%fixed_width) + if (found .and. (pw90_boltzwann%tdf_smearing%fixed_width < 0._dp)) & + call io_error('Error: boltz_TDF_smr_fixed_en_width must be greater than or equal to zero', & + stdout, seedname) + + ! By default: use the "global" smearing index + pw90_boltzwann%tdf_smearing%type_index = pw90_smearing%type_index + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_tdf_smr_type', found, c_value=ctmp) + if (found) pw90_boltzwann%tdf_smearing%type_index = w90_readwrite_get_smearing_index(ctmp, & + 'boltz_tdf_smr_type', stdout, seedname) + + ! By default: use the "global" smearing index + pw90_boltzwann%dos_smearing%type_index = pw90_smearing%type_index + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_dos_smr_type', found, c_value=ctmp) + if (found) pw90_boltzwann%dos_smearing%type_index = w90_readwrite_get_smearing_index(ctmp, & + 'boltz_dos_smr_type', stdout, seedname) + + ! By default: 10 fs relaxation time + pw90_boltzwann%relax_time = 10._dp + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_relax_time', found, & + r_value=pw90_boltzwann%relax_time) + + pw90_boltzwann%bandshift = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_bandshift', found, & + l_value=pw90_boltzwann%bandshift) + pw90_boltzwann%bandshift = pw90_boltzwann%bandshift .and. do_boltzwann + + pw90_boltzwann%bandshift_firstband = 0 + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_bandshift_firstband', found, & + i_value=pw90_boltzwann%bandshift_firstband) + if (pw90_boltzwann%bandshift .and. (.not. found)) & + call io_error('Error: boltz_bandshift required but no boltz_bandshift_firstband provided', & + stdout, seedname) + pw90_boltzwann%bandshift_energyshift = 0._dp + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_bandshift_energyshift', found, & + r_value=pw90_boltzwann%bandshift_energyshift) + if (pw90_boltzwann%bandshift .and. (.not. found)) & + call io_error('Error: boltz_bandshift required but no boltz_bandshift_energyshift provided', & + stdout, seedname) + ! [gp-end, Apr 12, 2012] + end subroutine w90_wannier90_readwrite_read_boltzwann + + !================================================! + subroutine w90_wannier90_readwrite_read_energy_range(pw90_berry, pw90_dos, pw90_gyrotropic, dis_manifold, & + fermi_energy_list, eigval, pw90_extra_io, stdout, seedname) + !================================================! + + use w90_constants, only: cmplx_i + use w90_io, only: io_error + + implicit none + + type(pw90_berry_mod_type), intent(inout) :: pw90_berry + type(pw90_dos_mod_type), intent(inout) :: pw90_dos + type(pw90_gyrotropic_type), intent(inout) :: pw90_gyrotropic + type(dis_manifold_type), intent(in) :: dis_manifold + + integer, intent(in) :: stdout + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + real(kind=dp), allocatable, intent(in) :: eigval(:, :) + type(pw90_extra_io_type), intent(inout) :: pw90_extra_io + character(len=50), intent(in) :: seedname + + integer :: i, ierr + logical :: found + + if (dis_manifold%frozen_states) then + pw90_dos%energy_max = dis_manifold%froz_max + 0.6667_dp + elseif (allocated(eigval)) then + pw90_dos%energy_max = maxval(eigval) + 0.6667_dp + else + pw90_dos%energy_max = dis_manifold%win_max + 0.6667_dp + end if + call w90_readwrite_get_keyword(stdout, seedname, 'dos_energy_max', found, & + r_value=pw90_dos%energy_max) + + if (allocated(eigval)) then + pw90_dos%energy_min = minval(eigval) - 0.6667_dp + else + pw90_dos%energy_min = dis_manifold%win_min - 0.6667_dp + end if + call w90_readwrite_get_keyword(stdout, seedname, 'dos_energy_min', found, & + r_value=pw90_dos%energy_min) + + pw90_extra_io%kubo_freq_min = 0.0_dp + pw90_extra_io%gyrotropic_freq_min = pw90_extra_io%kubo_freq_min + call w90_readwrite_get_keyword(stdout, seedname, 'kubo_freq_min', found, & + r_value=pw90_extra_io%kubo_freq_min) + + if (dis_manifold%frozen_states) then + pw90_extra_io%kubo_freq_max = dis_manifold%froz_max - fermi_energy_list(1) + 0.6667_dp + elseif (allocated(eigval)) then + pw90_extra_io%kubo_freq_max = maxval(eigval) - minval(eigval) + 0.6667_dp + else + pw90_extra_io%kubo_freq_max = dis_manifold%win_max - dis_manifold%win_min + 0.6667_dp + end if + pw90_extra_io%gyrotropic_freq_max = pw90_extra_io%kubo_freq_max + call w90_readwrite_get_keyword(stdout, seedname, 'kubo_freq_max', found, & + r_value=pw90_extra_io%kubo_freq_max) + + pw90_extra_io%kubo_freq_step = 0.01_dp + call w90_readwrite_get_keyword(stdout, seedname, 'kubo_freq_step', found, & + r_value=pw90_extra_io%kubo_freq_step) + if (found .and. pw90_extra_io%kubo_freq_step < 0.0_dp) call io_error( & + 'Error: kubo_freq_step must be positive', stdout, seedname) + + pw90_berry%kubo_nfreq = nint((pw90_extra_io%kubo_freq_max - pw90_extra_io%kubo_freq_min) & + /pw90_extra_io%kubo_freq_step) + 1 + if (pw90_berry%kubo_nfreq <= 1) pw90_berry%kubo_nfreq = 2 + pw90_extra_io%kubo_freq_step = (pw90_extra_io%kubo_freq_max - pw90_extra_io%kubo_freq_min) & + /(pw90_berry%kubo_nfreq - 1) + + if (allocated(pw90_berry%kubo_freq_list)) deallocate (pw90_berry%kubo_freq_list) + allocate (pw90_berry%kubo_freq_list(pw90_berry%kubo_nfreq), stat=ierr) + if (ierr /= 0) & + call io_error('Error allocating kubo_freq_list in w90_wannier90_readwrite_read', stdout, seedname) + do i = 1, pw90_berry%kubo_nfreq + pw90_berry%kubo_freq_list(i) = pw90_extra_io%kubo_freq_min + & + (i - 1)*(pw90_extra_io%kubo_freq_max - & + pw90_extra_io%kubo_freq_min)/(pw90_berry%kubo_nfreq - 1) + enddo + + ! TODO: Alternatively, read list of (complex) frequencies; kubo_nfreq is + ! the length of the list + + pw90_extra_io%gyrotropic_freq_step = 0.01_dp + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic_freq_min', found, & + r_value=pw90_extra_io%gyrotropic_freq_min) + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic_freq_max', found, & + r_value=pw90_extra_io%gyrotropic_freq_max) + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic_freq_step', found, & + r_value=pw90_extra_io%gyrotropic_freq_step) + pw90_gyrotropic%nfreq = nint((pw90_extra_io%gyrotropic_freq_max - & + pw90_extra_io%gyrotropic_freq_min)/ & + pw90_extra_io%gyrotropic_freq_step) + 1 + if (pw90_gyrotropic%nfreq <= 1) pw90_gyrotropic%nfreq = 2 + pw90_extra_io%gyrotropic_freq_step = (pw90_extra_io%gyrotropic_freq_max & + - pw90_extra_io%gyrotropic_freq_min)/ & + (pw90_gyrotropic%nfreq - 1) + if (allocated(pw90_gyrotropic%freq_list)) deallocate (pw90_gyrotropic%freq_list) + allocate (pw90_gyrotropic%freq_list(pw90_gyrotropic%nfreq), stat=ierr) + if (ierr /= 0) & + call io_error('Error allocating gyrotropic_freq_list in w90_wannier90_readwrite_read', stdout, seedname) + do i = 1, pw90_gyrotropic%nfreq + pw90_gyrotropic%freq_list(i) = pw90_extra_io%gyrotropic_freq_min & + + (i - 1)*(pw90_extra_io%gyrotropic_freq_max & + - pw90_extra_io%gyrotropic_freq_min)/(pw90_gyrotropic%nfreq - 1) & + + cmplx_i*pw90_gyrotropic%smearing%fixed_width + enddo + + if (dis_manifold%frozen_states) then + pw90_berry%kubo_eigval_max = dis_manifold%froz_max + 0.6667_dp + elseif (allocated(eigval)) then + pw90_berry%kubo_eigval_max = maxval(eigval) + 0.6667_dp + else + pw90_berry%kubo_eigval_max = dis_manifold%win_max + 0.6667_dp + end if + pw90_gyrotropic%eigval_max = pw90_berry%kubo_eigval_max + + call w90_readwrite_get_keyword(stdout, seedname, 'kubo_eigval_max', found, & + r_value=pw90_berry%kubo_eigval_max) + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic_eigval_max', found, & + r_value=pw90_gyrotropic%eigval_max) + end subroutine w90_wannier90_readwrite_read_energy_range + + !================================================! + subroutine w90_wannier90_readwrite_read_global_kmesh(global_kmesh_set, kmesh, recip_lattice, stdout, seedname) + !================================================! + + use w90_io, only: io_error + + implicit none + + type(kmesh_spacing_type), intent(out) :: kmesh + + integer, intent(in) :: stdout + logical, intent(out) :: global_kmesh_set + real(kind=dp), intent(in) :: recip_lattice(3, 3) + character(len=50), intent(in) :: seedname + + integer :: i + logical :: found + + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! + ! k meshes + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! + ! [GP-begin, Apr13, 2012] + ! Global interpolation k-mesh; this is overridden by "local" meshes of a given submodule + ! This bit of code must appear *before* all other codes for the local interpolation meshes, + ! BUT *after* having calculated the reciprocal-space vectors. + global_kmesh_set = .false. + kmesh%spacing = -1._dp + kmesh%mesh = 0 + call w90_readwrite_get_keyword(stdout, seedname, 'kmesh_spacing', found, r_value=kmesh%spacing) + if (found) then + if (kmesh%spacing .le. 0._dp) & + call io_error('Error: kmesh_spacing must be greater than zero', stdout, seedname) + global_kmesh_set = .true. + + call w90_readwrite_set_kmesh(kmesh%spacing, recip_lattice, kmesh%mesh) + end if + call w90_readwrite_get_vector_length(stdout, seedname, 'kmesh', found, length=i) + if (found) then + if (global_kmesh_set) & + call io_error('Error: cannot set both kmesh and kmesh_spacing', stdout, seedname) + if (i .eq. 1) then + global_kmesh_set = .true. + call w90_readwrite_get_keyword_vector(stdout, seedname, 'kmesh', found, 1, i_value=kmesh%mesh) + kmesh%mesh(2) = kmesh%mesh(1) + kmesh%mesh(3) = kmesh%mesh(1) + elseif (i .eq. 3) then + global_kmesh_set = .true. + call w90_readwrite_get_keyword_vector(stdout, seedname, 'kmesh', found, 3, i_value=kmesh%mesh) + else + call io_error('Error: kmesh must be provided as either one integer or a vector of three integers', & + stdout, seedname) + end if + if (any(kmesh%mesh <= 0)) & + call io_error('Error: kmesh elements must be greater than zero', stdout, seedname) + end if + ! [GP-end] + end subroutine w90_wannier90_readwrite_read_global_kmesh + + !================================================! + subroutine w90_wannier90_readwrite_read_local_kmesh(pw90_calculation, pw90_berry, pw90_dos, pw90_spin, & + pw90_gyrotropic, pw90_boltzwann, recip_lattice, & + global_kmesh_set, global_kmesh, stdout, seedname) + !================================================! + implicit none + + type(pw90_calculation_type), intent(in) :: pw90_calculation + type(pw90_berry_mod_type), intent(inout) :: pw90_berry + type(pw90_dos_mod_type), intent(inout) :: pw90_dos + type(pw90_spin_mod_type), intent(inout) :: pw90_spin + type(pw90_gyrotropic_type), intent(inout) :: pw90_gyrotropic + type(pw90_boltzwann_type), intent(inout) :: pw90_boltzwann + type(kmesh_spacing_type), intent(in) :: global_kmesh + + integer, intent(in) :: stdout + real(kind=dp), intent(in) :: recip_lattice(3, 3) + logical, intent(in) :: global_kmesh_set + + character(len=50), intent(in) :: seedname + + ! To be called after having read the global flag + call get_module_kmesh(stdout, seedname, recip_lattice, global_kmesh_set, global_kmesh, & + moduleprefix='boltz', should_be_defined=pw90_calculation%boltzwann, & + module_kmesh=pw90_boltzwann%kmesh) + + call get_module_kmesh(stdout, seedname, recip_lattice, global_kmesh_set, global_kmesh, & + moduleprefix='berry', should_be_defined=pw90_calculation%berry, & + module_kmesh=pw90_berry%kmesh) + + call get_module_kmesh(stdout, seedname, recip_lattice, global_kmesh_set, global_kmesh, & + moduleprefix='gyrotropic', & + should_be_defined=pw90_calculation%gyrotropic, & + module_kmesh=pw90_gyrotropic%kmesh) + + call get_module_kmesh(stdout, seedname, recip_lattice, global_kmesh_set, global_kmesh, & + moduleprefix='spin', should_be_defined=pw90_calculation%spin_moment, & + module_kmesh=pw90_spin%kmesh) + + call get_module_kmesh(stdout, seedname, recip_lattice, global_kmesh_set, global_kmesh, & + moduleprefix='dos', should_be_defined=pw90_calculation%dos, & + module_kmesh=pw90_dos%kmesh) + end subroutine w90_wannier90_readwrite_read_local_kmesh + + !================================================! + subroutine get_module_kmesh(stdout, seedname, recip_lattice, global_kmesh_set, global_kmesh, & + moduleprefix, should_be_defined, module_kmesh) + !================================================! + !! This function reads and sets the interpolation mesh variables needed by a given module + !> + !! This function MUST be called after having read the global kmesh and kmesh_spacing!! + !! if the user didn't provide an interpolation_mesh_spacing, it is set to -1, so that + !! one can check in the code what the user asked for + !! The function takes care also of setting the default value to the global one if no local + !! keyword is defined + !================================================! + + use w90_io, only: io_error + + integer, intent(in) :: stdout + real(kind=dp), intent(in) :: recip_lattice(3, 3) + character(len=*), intent(in) :: moduleprefix + !!The prefix that is appended before the name of the variables. In particular, + !!if the prefix is for instance XXX, the two variables that are read from the + !!input file are XXX_kmesh and XXX_kmesh_spacing. + logical, intent(in) :: should_be_defined + !! A logical flag: if it is true, at the end the code stops if no value is specified. + !! Define it to .false. if no check should be performed. + !! Often, you can simply pass the flag that activates the module itself. + type(kmesh_spacing_type), intent(out) :: module_kmesh + !! the integer array (length 3) where the interpolation mesh will be saved, and + !! the real number on which the min mesh spacing is saved. -1 if it the + !!user specifies in input the mesh and not the mesh_spacing + logical, intent(in) :: global_kmesh_set + type(kmesh_spacing_type), intent(in) :: global_kmesh + character(len=50), intent(in) :: seedname + + logical :: found, found2 + integer :: i + + ! Default values + module_kmesh%spacing = -1._dp + module_kmesh%mesh = 0 + call w90_readwrite_get_keyword(stdout, seedname, trim(moduleprefix)//'_kmesh_spacing', found, & + r_value=module_kmesh%spacing) + if (found) then + if (module_kmesh%spacing .le. 0._dp) & + call io_error('Error: '//trim(moduleprefix)//'_kmesh_spacing must be greater than zero', & + stdout, seedname) + + call w90_readwrite_set_kmesh(module_kmesh%spacing, recip_lattice, module_kmesh%mesh) + end if + call w90_readwrite_get_vector_length(stdout, seedname, trim(moduleprefix)//'_kmesh', found2, length=i) + if (found2) then + if (found) & + call io_error('Error: cannot set both '//trim(moduleprefix)//'_kmesh and ' & + //trim(moduleprefix)//'_kmesh_spacing', stdout, seedname) + if (i .eq. 1) then + call w90_readwrite_get_keyword_vector(stdout, seedname, trim(moduleprefix)//'_kmesh', found2, & + 1, i_value=module_kmesh%mesh) + module_kmesh%mesh(2) = module_kmesh%mesh(1) + module_kmesh%mesh(3) = module_kmesh%mesh(1) + elseif (i .eq. 3) then + call w90_readwrite_get_keyword_vector(stdout, seedname, trim(moduleprefix)//'_kmesh', found2, & + 3, i_value=module_kmesh%mesh) + else + call io_error('Error: '//trim(moduleprefix)// & + '_kmesh must be provided as either one integer or a vector of 3 integers', & + stdout, seedname) + end if + if (any(module_kmesh%mesh <= 0)) & + call io_error('Error: '//trim(moduleprefix)//'_kmesh elements must be greater than zero', & + stdout, seedname) + end if + + if ((found .eqv. .false.) .and. (found2 .eqv. .false.)) then + ! This is the case where no "local" interpolation k-mesh is provided in the input + if (global_kmesh_set) then + module_kmesh%mesh = global_kmesh%mesh + ! I set also boltz_kmesh_spacing so that I can check if it is < 0 or not, and if it is + ! > 0 I can print on output the mesh spacing that was chosen + module_kmesh%spacing = global_kmesh%spacing + else + if (should_be_defined) & + call io_error('Error: '//trim(moduleprefix)//' module required, but no interpolation mesh given.', & + stdout, seedname) + end if + end if + end subroutine get_module_kmesh + + !================================================ + subroutine w90_postw90_readwrite_write(print_output, w90_system, fermi_energy_list, atom_data, num_wann, & + real_lattice, kpoint_path, pw90_calculation, pw90_oper_read, & + scissors_shift, pw90_spin, pw90_kpath, pw90_kslice, pw90_dos, & + pw90_berry, pw90_gyrotropic, pw90_geninterp, pw90_boltzwann, & + pw90_extra_io, optimisation, stdout) + !================================================! + ! + !! write postw90 parameters to stdout + ! + !================================================ + use w90_utility, only: utility_recip_lattice_base, utility_inverse_mat, utility_cart_to_frac + + implicit none + + ! arguments + type(print_output_type), intent(in) :: print_output + type(w90_system_type), intent(in) :: w90_system + type(atom_data_type), intent(in) :: atom_data + type(kpoint_path_type), intent(in) :: kpoint_path + type(pw90_calculation_type), intent(in) :: pw90_calculation + type(pw90_oper_read_type), intent(in) :: pw90_oper_read + type(pw90_spin_mod_type), intent(in) :: pw90_spin + type(pw90_kpath_mod_type), intent(in) :: pw90_kpath + type(pw90_kslice_mod_type), intent(in) :: pw90_kslice + type(pw90_dos_mod_type), intent(in) :: pw90_dos + type(pw90_berry_mod_type), intent(in) :: pw90_berry + type(pw90_gyrotropic_type), intent(in) :: pw90_gyrotropic + type(pw90_geninterp_mod_type), intent(in) :: pw90_geninterp + type(pw90_boltzwann_type), intent(in) :: pw90_boltzwann + type(pw90_extra_io_type), intent(in) :: pw90_extra_io + + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: scissors_shift + integer, intent(in) :: num_wann + integer, intent(in) :: optimisation + integer, intent(in) :: stdout + + ! local variables + real(kind=dp) :: recip_lattice(3, 3), inv_lattice(3, 3), pos_frac(3), volume + real(kind=dp) :: cell_volume + integer :: i, loop, nat, nsp + + ! System + write (stdout, *) + write (stdout, '(36x,a6)') '------' + write (stdout, '(36x,a6)') 'SYSTEM' + write (stdout, '(36x,a6)') '------' + write (stdout, *) + if (print_output%lenconfac .eq. 1.0_dp) then + write (stdout, '(30x,a21)') 'Lattice Vectors (Ang)' + else + write (stdout, '(28x,a22)') 'Lattice Vectors (Bohr)' + endif + write (stdout, 101) 'a_1', (real_lattice(1, I)*print_output%lenconfac, i=1, 3) + write (stdout, 101) 'a_2', (real_lattice(2, I)*print_output%lenconfac, i=1, 3) + write (stdout, 101) 'a_3', (real_lattice(3, I)*print_output%lenconfac, i=1, 3) + write (stdout, *) + cell_volume = real_lattice(1, 1)*(real_lattice(2, 2)*real_lattice(3, 3) - & + real_lattice(3, 2)*real_lattice(2, 3)) + & + real_lattice(1, 2)*(real_lattice(2, 3)*real_lattice(3, 1) - & + real_lattice(3, 3)*real_lattice(2, 1)) + & + real_lattice(1, 3)*(real_lattice(2, 1)*real_lattice(3, 2) - & + real_lattice(3, 1)*real_lattice(2, 2)) + write (stdout, '(19x,a17,3x,f11.5)', advance='no') & + 'Unit Cell Volume:', cell_volume*print_output%lenconfac**3 + if (print_output%lenconfac .eq. 1.0_dp) then + write (stdout, '(2x,a7)') '(Ang^3)' + else + write (stdout, '(2x,a8)') '(Bohr^3)' + endif + write (stdout, *) + if (print_output%lenconfac .eq. 1.0_dp) then + write (stdout, '(24x,a33)') 'Reciprocal-Space Vectors (Ang^-1)' + else + write (stdout, '(22x,a34)') 'Reciprocal-Space Vectors (Bohr^-1)' + endif + call utility_recip_lattice_base(real_lattice, recip_lattice, volume) + write (stdout, 101) 'b_1', (recip_lattice(1, I)/print_output%lenconfac, i=1, 3) + write (stdout, 101) 'b_2', (recip_lattice(2, I)/print_output%lenconfac, i=1, 3) + write (stdout, 101) 'b_3', (recip_lattice(3, I)/print_output%lenconfac, i=1, 3) + write (stdout, *) ' ' + ! Atoms + if (atom_data%num_atoms > 0) then + write (stdout, '(1x,a)') '*----------------------------------------------------------------------------*' + if (print_output%lenconfac .eq. 1.0_dp) then + write (stdout, '(1x,a)') '| Site Fractional Coordinate Cartesian Coordinate (Ang) |' + else + write (stdout, '(1x,a)') '| Site Fractional Coordinate Cartesian Coordinate (Bohr) |' + endif + write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' + call utility_inverse_mat(real_lattice, inv_lattice) + do nsp = 1, atom_data%num_species + do nat = 1, atom_data%species_num(nsp) + call utility_cart_to_frac(atom_data%pos_cart(:, nat, nsp), pos_frac, inv_lattice) + write (stdout, '(1x,a1,1x,a2,1x,i3,3F10.5,3x,a1,1x,3F10.5,4x,a1)') & + & '|', atom_data%symbol(nsp), nat, pos_frac(:),& + & '|', atom_data%pos_cart(:, nat, nsp)*print_output%lenconfac, '|' + end do + end do + write (stdout, '(1x,a)') '*----------------------------------------------------------------------------*' + else + write (stdout, '(25x,a)') 'No atom positions specified' + end if + write (stdout, *) ' ' + ! Main + write (stdout, *) ' ' + + write (stdout, '(1x,a78)') '*-------------------------------- POSTW90 -----------------------------------*' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Number of Wannier Functions :', num_wann, '|' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Number of electrons per state :', & + w90_system%num_elec_per_state, '|' + if (abs(scissors_shift) > 1.0e-7_dp .or. print_output%iprint > 0) then + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Scissor shift applied to conduction bands :', scissors_shift, '|' + if (w90_system%num_valence_bands > 0) then + write (stdout, '(1x,a46,10x,i8,13x,a1)') '| Number of valence bands :', & + w90_system%num_valence_bands, '|' + else + write (stdout, '(1x,a78)') '| Number of valence bands : not defined |' + endif + endif + if (pw90_calculation%spin_decomp .or. print_output%iprint > 2) & + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Spin decomposition :', pw90_calculation%spin_decomp, '|' + if (pw90_calculation%spin_moment .or. print_output%iprint > 2) & + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Compute Spin moment :', pw90_calculation%spin_moment, '|' + if (pw90_calculation%spin_decomp .or. pw90_calculation%spin_moment .or. print_output%iprint > 2) then + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Polar angle of spin quantisation axis :', pw90_spin%axis_polar, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Azimuthal angle of spin quantisation axis :', pw90_spin%axis_azimuth, '|' + if (pw90_oper_read%spn_formatted) then + write (stdout, '(1x,a46,9x,a9,13x,a1)') '| Spn file-type :', 'formatted', '|' + else + write (stdout, '(1x,a46,7x,a11,13x,a1)') '| Spn file-type :', 'unformatted', '|' + endif + if (pw90_oper_read%uHu_formatted) then + write (stdout, '(1x,a46,9x,a9,13x,a1)') '| uHu file-type :', 'formatted', '|' + else + write (stdout, '(1x,a46,7x,a11,13x,a1)') '| uHu file-type :', 'unformatted', '|' + endif + end if + + if (size(fermi_energy_list) == 1) then + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Fermi energy (eV) :', fermi_energy_list(1), '|' + else + write (stdout, '(1x,a21,I8,a12,f8.3,a4,f8.3,a3,13x,a1)') '| Fermi energy :', size(fermi_energy_list), & + ' steps from ', fermi_energy_list(1), ' to ', & + fermi_energy_list(size(fermi_energy_list)), ' eV', '|' + end if + + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Output verbosity (1=low, 5=high) :', print_output%iprint, '|' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Timing Level (1=low, 5=high) :', print_output%timing_level, '|' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Optimisation (0=memory, 3=speed) :', optimisation, '|' + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Length Unit :', trim(print_output%length_unit), '|' + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + write (stdout, '(1x,a78)') '*------------------------ Global Smearing Parameters ------------------------*' + if (pw90_extra_io%smear%use_adaptive) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Adaptive width smearing :', ' T', '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Adaptive smearing factor :', & + pw90_extra_io%smear%adaptive_prefactor, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Maximum allowed smearing width (eV) :', & + pw90_extra_io%smear%adaptive_max_width, '|' + + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Fixed width smearing :', ' T', '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Smearing width :', & + pw90_extra_io%smear%fixed_width, '|' + endif + write (stdout, '(1x,a21,5x,a47,4x,a1)') '| Smearing Function ', & + trim(w90_readwrite_get_smearing_type(pw90_extra_io%smear%type_index)), '|' + if (pw90_extra_io%global_kmesh_set) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Global interpolation k-points defined :', ' T', '|' + if (pw90_extra_io%global_kmesh%spacing > 0.0_dp) then + write (stdout, '(1x,a15,i4,1x,a1,i4,1x,a1,i4,16x,a11,f8.3,11x,1a)') '| Grid size = ', & + pw90_extra_io%global_kmesh%mesh(1), 'x', pw90_extra_io%global_kmesh%mesh(2), 'x', & + pw90_extra_io%global_kmesh%mesh(3), ' Spacing = ', pw90_extra_io%global_kmesh%spacing, '|' + else + write (stdout, '(1x,a46,2x,i4,1x,a1,i4,1x,a1,i4,13x,1a)') '| Grid size :' & + , pw90_extra_io%global_kmesh%mesh(1), 'x', pw90_extra_io%global_kmesh%mesh(2), 'x', & + pw90_extra_io%global_kmesh%mesh(3), '|' + endif + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Global interpolation k-points defined :', ' F', '|' + endif + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + + ! DOS + if (pw90_calculation%dos .or. print_output%iprint > 2) then + write (stdout, '(1x,a78)') '*---------------------------------- DOS -------------------------------------*' + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Plotting Density of States :', pw90_calculation%dos, '|' + if (pw90_dos%num_project > 1) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Wannier Projected DOS :', ' T', '|' + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Wannier Projected DOS :', ' F', '|' + endif + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Minimum energy range for DOS plot :', pw90_dos%energy_min, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Maximum energy range for DOS plot :', pw90_dos%energy_max, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Energy step for DOS plot :', pw90_dos%energy_step, '|' + if (pw90_dos%smearing%use_adaptive .eqv. pw90_extra_io%smear%use_adaptive .and. & + pw90_dos%smearing%adaptive_prefactor == pw90_extra_io%smear%adaptive_prefactor .and. & + pw90_dos%smearing%adaptive_max_width == pw90_extra_io%smear%adaptive_max_width .and. & + pw90_dos%smearing%fixed_width == pw90_extra_io%smear%fixed_width .and. & + pw90_extra_io%smear%type_index == pw90_dos%smearing%type_index) then + write (stdout, '(1x,a78)') '| Using global smearing parameters |' + else + if (pw90_dos%smearing%use_adaptive) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Adaptive width smearing :', ' T', '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Adaptive smearing factor :', & + pw90_dos%smearing%adaptive_prefactor, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Maximum allowed smearing width :', & + pw90_dos%smearing%adaptive_max_width, '|' + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Fixed width smearing :', ' T', '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Smearing width :', & + pw90_dos%smearing%fixed_width, '|' + endif + write (stdout, '(1x,a21,5x,a47,4x,a1)') '| Smearing Function ', & + trim(w90_readwrite_get_smearing_type(pw90_dos%smearing%type_index)), '|' + endif + if (pw90_extra_io%global_kmesh%mesh(1) == pw90_dos%kmesh%mesh(1) .and. & + pw90_extra_io%global_kmesh%mesh(2) == pw90_dos%kmesh%mesh(2) .and. & + pw90_extra_io%global_kmesh%mesh(3) == pw90_dos%kmesh%mesh(3)) then + write (stdout, '(1x,a78)') '| Using global k-point set for interpolation |' + else + if (pw90_dos%kmesh%spacing > 0.0_dp) then + write (stdout, '(1x,a15,i4,1x,a1,i4,1x,a1,i4,16x,a11,f8.3,11x,1a)') '| Grid size = ', & + pw90_dos%kmesh%mesh(1), 'x', pw90_dos%kmesh%mesh(2), 'x', & + pw90_dos%kmesh%mesh(3), ' Spacing = ', pw90_dos%kmesh%spacing, '|' + else + write (stdout, '(1x,a46,2x,i4,1x,a1,i4,1x,a1,i4,13x,1a)') '| Grid size :', & + pw90_dos%kmesh%mesh(1), 'x', pw90_dos%kmesh%mesh(2), 'x', & + pw90_dos%kmesh%mesh(3), '|' + endif + endif + endif + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + + if (pw90_calculation%kpath .or. print_output%iprint > 2) then + write (stdout, '(1x,a78)') '*--------------------------------- KPATH ------------------------------------*' + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Plot Properties along a path in k-space :', pw90_calculation%kpath, '|' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Divisions along first kpath section :', pw90_kpath%num_points, '|' + if (index(pw90_kpath%task, 'bands') > 0) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot energy bands :', ' T', '|' + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot energy bands :', ' F', '|' + endif + if (index(pw90_kpath%task, 'curv') > 0) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot Berry curvature :', ' T', '|' + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot Berry curvature :', ' F', '|' + endif + if (index(pw90_kpath%task, 'morb') > 0) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot orbital magnetisation contribution :', ' T', '|' + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot orbital magnetisation contribution :', ' F', '|' + endif + if (index(pw90_kpath%task, 'shc') > 0) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot spin Hall conductivity contribution :', ' T', '|' + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot spin Hall conductivity contribution :', ' F', '|' + endif + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Property used to colour code the bands :', trim(pw90_kpath%bands_colour), '|' + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + write (stdout, '(1x,a78)') '| K-space path sections: |' + if (.not. allocated(kpoint_path%labels)) then + write (stdout, '(1x,a78)') '| None defined |' + else + do loop = 1, size(kpoint_path%labels), 2 + write (stdout, '(1x,a10,2x,a1,2x,3F7.3,5x,a3,2x,a1,2x,3F7.3,7x,a1)') '| From:', & + kpoint_path%labels(loop), (kpoint_path%points(i, loop), i=1, 3), & + 'To:', kpoint_path%labels(loop + 1), (kpoint_path%points(i, loop + 1), i=1, 3), '|' + end do + end if + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + endif + + if (pw90_calculation%kslice .or. print_output%iprint > 2) then + write (stdout, '(1x,a78)') '*--------------------------------- KSLICE -----------------------------------*' + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Plot Properties along a slice in k-space :', pw90_calculation%kslice, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Fermi level used for slice :', fermi_energy_list(1), '|' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Divisions along first kpath section :', pw90_kpath%num_points, '|' + if (index(pw90_kslice%task, 'fermi_lines') > 0) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot energy contours (fermi lines) :', ' T', '|' + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot energy contours (fermi lines) :', ' F', '|' + endif + if (index(pw90_kslice%task, 'curv') > 0) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot Berry curvature (sum over occ states):', ' T', '|' + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot Berry curvature (sum over occ states):', ' F', '|' + endif + if (index(pw90_kslice%task, 'morb') > 0) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot orbital magnetisation contribution :', ' T', '|' + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot orbital magnetisation contribution :', ' F', '|' + endif + if (index(pw90_kslice%task, 'shc') > 0) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot spin Hall conductivity contribution :', ' T', '|' + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plot spin Hall conductivity contribution :', ' F', '|' + endif + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Property used to colour code the lines :', & + trim(pw90_kslice%fermi_lines_colour), '|' + write (stdout, '(1x,a78)') '| 2D slice parameters (in reduced coordinates): |' + write (stdout, '(1x,a14,2x,3F8.3,37x,a1)') '| Corner: ', (pw90_kslice%corner(i), i=1, 3), '|' + write (stdout, '(1x,a14,2x,3F8.3,10x,a12,2x,i4,9x,a1)') & + '| Vector1: ', (pw90_kslice%b1(i), i=1, 3), ' Divisions:', pw90_kslice%kmesh2d(1), '|' + write (stdout, '(1x,a14,2x,3F8.3,10x,a12,2x,i4,9x,a1)') & + '| Vector2: ', (pw90_kslice%b2(i), i=1, 3), ' Divisions:', pw90_kslice%kmesh2d(1), '|' + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + endif + + if (pw90_calculation%berry .or. print_output%iprint > 2) then + write (stdout, '(1x,a78)') '*--------------------------------- BERRY ------------------------------------*' + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Compute Berry Phase related properties :', pw90_calculation%berry, '|' + if (index(pw90_berry%task, 'kubo') > 0) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Optical Conductivity and JDOS :', ' T', '|' + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Optical Conductivity and JDOS :', ' F', '|' + endif + if (index(pw90_berry%task, 'ahc') > 0) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Anomalous Hall Conductivity :', ' T', '|' + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Anomalous Hall Conductivity :', ' F', '|' + endif + if (index(pw90_berry%task, 'sc') > 0) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Shift Current :', ' T', '|' + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Shift Current :', ' F', '|' + endif + if (index(pw90_berry%task, 'kdotp') > 0) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute k.p expansion coefficients :', ' T', '|' + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute k.p expansion coefficients :', ' F', '|' + endif + if (index(pw90_berry%task, 'morb') > 0) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Orbital Magnetisation :', ' T', '|' + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Orbital Magnetisation :', ' F', '|' + endif + if (index(pw90_berry%task, 'shc') > 0) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Spin Hall Conductivity :', ' T', '|' + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Compute Spin Hall Conductivity :', ' F', '|' + endif + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Lower frequency for optical responses :', & + pw90_extra_io%kubo_freq_min, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Upper frequency for optical responses :', & + pw90_extra_io%kubo_freq_max, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Step size for optical responses :', & + pw90_extra_io%kubo_freq_step, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Upper eigenvalue for optical responses :', pw90_berry%kubo_eigval_max, '|' + if (index(pw90_berry%task, 'sc') > 0) then + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Smearing factor for shift current :', pw90_berry%sc_eta, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Frequency theshold for shift current :', pw90_berry%sc_w_thr, '|' + write (stdout, '(1x,a46,1x,a27,3x,a1)') '| Bloch sums :', & + trim(w90_readwrite_get_convention_type(pw90_berry%sc_phase_conv)), '|' + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Finite eta correction for shift current :', & + pw90_berry%sc_use_eta_corr, '|' + end if + if (index(pw90_berry%task, 'kdotp') > 0) then + write (stdout, '(1x,a46,10x,f8.3,1x,f8.3,1x,f8.3,1x,13x,a1)') '| Chosen k-point kdotp_kpoint :', & + pw90_berry%kdotp_kpoint(1), pw90_berry%kdotp_kpoint(2), pw90_berry%kdotp_kpoint(3), '|' + write (stdout, '(1x,a46,10x,i4,13x,a1)') '| kdotp_num_bands :', & + size(pw90_berry%kdotp_bands), '|' + write (stdout, '(1x,a46,10x,*(i4))') '| kdotp_bands :', & + pw90_berry%kdotp_bands(:) + end if + if (pw90_berry%kubo_smearing%use_adaptive .eqv. pw90_extra_io%smear%use_adaptive .and. & + pw90_berry%kubo_smearing%adaptive_prefactor == pw90_extra_io%smear%adaptive_prefactor .and. & + pw90_berry%kubo_smearing%adaptive_max_width == pw90_extra_io%smear%adaptive_max_width & + .and. pw90_berry%kubo_smearing%fixed_width == pw90_extra_io%smear%fixed_width .and. & + pw90_extra_io%smear%type_index == pw90_berry%kubo_smearing%type_index) then + write (stdout, '(1x,a78)') '| Using global smearing parameters |' + else + if (pw90_berry%kubo_smearing%use_adaptive) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Adaptive width smearing :', ' T', '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Adaptive smearing factor :', & + pw90_berry%kubo_smearing%adaptive_prefactor, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Maximum allowed smearing width :', & + pw90_berry%kubo_smearing%adaptive_max_width, '|' + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Fixed width smearing :', ' T', '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Smearing width :', & + pw90_berry%kubo_smearing%fixed_width, '|' + endif + write (stdout, '(1x,a21,5x,a47,4x,a1)') '| Smearing Function ', & + trim(w90_readwrite_get_smearing_type(pw90_berry%kubo_smearing%type_index)), '|' + endif + if (pw90_extra_io%global_kmesh%mesh(1) == pw90_berry%kmesh%mesh(1) .and. & + pw90_extra_io%global_kmesh%mesh(2) == pw90_berry%kmesh%mesh(2) .and. & + pw90_extra_io%global_kmesh%mesh(3) == pw90_berry%kmesh%mesh(3)) then + write (stdout, '(1x,a78)') '| Using global k-point set for interpolation |' + else + if (pw90_berry%kmesh%spacing > 0.0_dp) then + write (stdout, '(1x,a15,i4,1x,a1,i4,1x,a1,i4,16x,a11,f8.3,11x,1a)') '| Grid size = ', & + pw90_berry%kmesh%mesh(1), 'x', pw90_berry%kmesh%mesh(2), 'x', pw90_berry%kmesh%mesh(3), & + ' Spacing = ', pw90_berry%kmesh%spacing, '|' + else + write (stdout, '(1x,a46,2x,i4,1x,a1,i4,1x,a1,i4,13x,1a)') '| Grid size :' & + , pw90_berry%kmesh%mesh(1), 'x', pw90_berry%kmesh%mesh(2), 'x', pw90_berry%kmesh%mesh(3), '|' + endif + endif + if (pw90_berry%curv_adpt_kmesh > 1) then + write (stdout, '(1x,a46,10x,i8,13x,a1)') '| Using an adaptive refinement mesh of size :', pw90_berry%curv_adpt_kmesh, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Threshold for adaptive refinement :', & + pw90_berry%curv_adpt_kmesh_thresh, '|' + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Adaptive refinement :', ' none', '|' + endif + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + endif + + if (pw90_calculation%gyrotropic .or. print_output%iprint > 2) then + write (stdout, '(1x,a78)') '*--------------------------------- GYROTROPIC ------------------------------------*' + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Compute Gyrotropic properties :', pw90_calculation%gyrotropic, '|' + write (stdout, '(1x,a46,10x,a20,1x,a1)') '| gyrotropic_task :', pw90_gyrotropic%task, '|' + call parameters_gyro_write_task(pw90_gyrotropic%task, '-d0', 'calculate the D tensor', stdout) + call parameters_gyro_write_task(pw90_gyrotropic%task, '-dw', 'calculate the tildeD tensor', stdout) + call parameters_gyro_write_task(pw90_gyrotropic%task, '-c', 'calculate the C tensor', stdout) + call parameters_gyro_write_task(pw90_gyrotropic%task, '-k', 'calculate the K tensor', stdout) + call parameters_gyro_write_task(pw90_gyrotropic%task, '-noa', 'calculate the interbad natural optical activity', stdout) + call parameters_gyro_write_task(pw90_gyrotropic%task, '-dos', 'calculate the density of states', stdout) + + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Lower frequency for tildeD,NOA :', & + pw90_extra_io%gyrotropic_freq_min, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Upper frequency :', & + pw90_extra_io%gyrotropic_freq_max, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Step size for frequency :', & + pw90_extra_io%gyrotropic_freq_step, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Upper eigenvalue :', & + pw90_gyrotropic%eigval_max, '|' + if (pw90_gyrotropic%smearing%fixed_width == pw90_extra_io%smear%fixed_width & + .and. pw90_extra_io%smear%type_index == pw90_gyrotropic%smearing%type_index) then + write (stdout, '(1x,a78)') '| Using global smearing parameters |' + else + write (stdout, '(1x,a78)') '| Using local smearing parameters |' + endif + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Fixed width smearing :', ' T', '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Smearing width :', & + pw90_gyrotropic%smearing%fixed_width, '|' + write (stdout, '(1x,a21,5x,a47,4x,a1)') '| Smearing Function :', & + trim(w90_readwrite_get_smearing_type(pw90_gyrotropic%smearing%type_index)), '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| degen_thresh :', & + pw90_gyrotropic%degen_thresh, '|' + + if (pw90_extra_io%global_kmesh%mesh(1) == pw90_gyrotropic%kmesh%mesh(1) .and. & + pw90_extra_io%global_kmesh%mesh(2) == pw90_gyrotropic%kmesh%mesh(2) .and. & + pw90_extra_io%global_kmesh%mesh(3) == pw90_gyrotropic%kmesh%mesh(3)) then + write (stdout, '(1x,a78)') '| Using global k-point set for interpolation |' + elseif (pw90_gyrotropic%kmesh%spacing > 0.0_dp) then + write (stdout, '(1x,a15,i4,1x,a1,i4,1x,a1,i4,16x,a11,f8.3,11x,1a)') '| Grid size = ', & + pw90_gyrotropic%kmesh%mesh(1), 'x', pw90_gyrotropic%kmesh%mesh(2), 'x', pw90_gyrotropic%kmesh%mesh(3), & + ' Spacing = ', pw90_gyrotropic%kmesh%spacing, '|' + else + write (stdout, '(1x,a46,2x,i4,1x,a1,i4,1x,a1,i4,13x,1a)') '| Grid size :' & + , pw90_gyrotropic%kmesh%mesh(1), 'x', pw90_gyrotropic%kmesh%mesh(2), 'x', pw90_gyrotropic%kmesh%mesh(3), '|' + endif + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Adaptive refinement :', ' not implemented', '|' + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + endif + + if (pw90_calculation%boltzwann .or. print_output%iprint > 2) then + write (stdout, '(1x,a78)') '*------------------------------- BOLTZWANN ----------------------------------*' + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Compute Boltzmann transport properties :', & + pw90_calculation%boltzwann, '|' + if (pw90_boltzwann%dir_num_2d > 0) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| 2d structure: non-periodic dimension :', & + trim(pw90_extra_io%boltz_2d_dir), '|' + else + write (stdout, '(1x,a78)') '| 3d Structure : T |' + endif + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Relaxation Time (fs) :', pw90_boltzwann%relax_time, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Minimum Value of Chemical Potential (eV) :', pw90_boltzwann%mu_min, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Maximum Value of Chemical Potential (eV) :', pw90_boltzwann%mu_max, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Step size for Chemical Potential (eV) :', pw90_boltzwann%mu_step, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Minimum Value of Temperature (K) :', pw90_boltzwann%temp_min, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Maximum Value of Temperature (K) :', pw90_boltzwann%temp_max, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Step size for Temperature (K) :', pw90_boltzwann%temp_step, '|' + + if (pw90_extra_io%global_kmesh%mesh(1) == pw90_boltzwann%kmesh%mesh(1) .and. & + pw90_extra_io%global_kmesh%mesh(2) == pw90_boltzwann%kmesh%mesh(2) .and. & + pw90_extra_io%global_kmesh%mesh(3) == pw90_boltzwann%kmesh%mesh(3)) then + write (stdout, '(1x,a78)') '| Using global k-point set for interpolation |' + else + if (pw90_boltzwann%kmesh%spacing > 0.0_dp) then + write (stdout, '(1x,a15,i4,1x,a1,i4,1x,a1,i4,16x,a11,f8.3,11x,1a)') '| Grid size = ', & + pw90_boltzwann%kmesh%mesh(1), 'x', pw90_boltzwann%kmesh%mesh(2), 'x', pw90_boltzwann%kmesh%mesh(3), & + ' Spacing = ', pw90_boltzwann%kmesh%spacing, '|' + else + write (stdout, '(1x,a46,2x,i4,1x,a1,i4,1x,a1,i4,13x,1a)') '| Grid size :' & + , pw90_boltzwann%kmesh%mesh(1), 'x', pw90_boltzwann%kmesh%mesh(2), 'x', pw90_boltzwann%kmesh%mesh(3), '|' + endif + endif + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Step size for TDF (eV) :', & + pw90_boltzwann%tdf_energy_step, '|' + write (stdout, '(1x,a25,5x,a43,4x,a1)') '| TDF Smearing Function ', & + trim(w90_readwrite_get_smearing_type(pw90_boltzwann%tdf_smearing%type_index)), '|' + if (pw90_boltzwann%tdf_smearing%fixed_width > 0.0_dp) then + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') & + '| TDF fixed Smearing width (eV) :', pw90_boltzwann%tdf_smearing%fixed_width, '|' + else + write (stdout, '(1x,a78)') '| TDF fixed Smearing width : unsmeared |' + endif + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Compute DOS at same time :', pw90_boltzwann%calc_also_dos, '|' + if (pw90_boltzwann%calc_also_dos .and. print_output%iprint > 2) then + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Minimum energy range for DOS plot :', & + pw90_boltzwann%dos_energy_min, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Maximum energy range for DOS plot :', & + pw90_boltzwann%dos_energy_max, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Energy step for DOS plot :', & + pw90_boltzwann%dos_energy_step, '|' + if (pw90_boltzwann%dos_smearing%use_adaptive .eqv. pw90_extra_io%smear%use_adaptive .and. & + pw90_boltzwann%dos_smearing%adaptive_prefactor == pw90_extra_io%smear%adaptive_prefactor & + .and. pw90_boltzwann%dos_smearing%adaptive_max_width == pw90_extra_io%smear%adaptive_max_width & + .and. pw90_boltzwann%dos_smearing%fixed_width == pw90_extra_io%smear%fixed_width .and. & + pw90_extra_io%smear%type_index == pw90_boltzwann%dos_smearing%type_index) then + write (stdout, '(1x,a78)') '| Using global smearing parameters |' + else + if (pw90_boltzwann%dos_smearing%use_adaptive) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| DOS Adaptive width smearing :', ' T', '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') & + '| DOS Adaptive smearing factor :', pw90_boltzwann%dos_smearing%adaptive_prefactor, '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') & + '| DOS Maximum allowed smearing width :', pw90_boltzwann%dos_smearing%adaptive_max_width, '|' + else + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| DOS Fixed width smearing :', ' T', '|' + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| DOS Smearing width :', & + pw90_boltzwann%dos_smearing%fixed_width, '|' + endif + write (stdout, '(1x,a21,5x,a47,4x,a1)') '| Smearing Function ', & + trim(w90_readwrite_get_smearing_type(pw90_boltzwann%dos_smearing%type_index)), '|' + endif + endif + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + endif + + if (pw90_calculation%geninterp .or. print_output%iprint > 2) then + write (stdout, '(1x,a78)') '*------------------------Generic Band Interpolation--------------------------*' + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Compute Properties at given k-points :', pw90_calculation%geninterp, '|' + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Calculate band gradients :', pw90_geninterp%alsofirstder, '|' + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Write data into a single file :', pw90_geninterp%single_file, '|' + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + endif + +101 format(20x, a3, 2x, 3F11.6) + + end subroutine w90_postw90_readwrite_write + + !================================================! + subroutine w90_postw90_readwrite_dealloc(exclude_bands, wannier_data, kmesh_input, kpt_latt, dis_manifold, & + fermi_energy_list, atom_data, eigval, kpoint_path, pw90_dos, & + pw90_berry, proj_input, stdout, seedname) + !================================================! + + use w90_io, only: io_error + + implicit none + + type(wannier_data_type), intent(inout) :: wannier_data + type(kmesh_input_type), intent(inout) :: kmesh_input + type(proj_input_type), intent(inout) :: proj_input + type(dis_manifold_type), intent(inout) :: dis_manifold + type(atom_data_type), intent(inout) :: atom_data + type(kpoint_path_type), intent(inout) :: kpoint_path + type(pw90_dos_mod_type), intent(inout) :: pw90_dos + type(pw90_berry_mod_type), intent(inout) :: pw90_berry + + integer, intent(in) :: stdout + integer, allocatable, intent(inout) :: exclude_bands(:) + real(kind=dp), allocatable, intent(inout) :: kpt_latt(:, :) + real(kind=dp), allocatable, intent(inout) :: fermi_energy_list(:) + real(kind=dp), allocatable, intent(inout) :: eigval(:, :) + character(len=50), intent(in) :: seedname + + integer :: ierr + + call w90_readwrite_dealloc(exclude_bands, wannier_data, proj_input, kmesh_input, kpt_latt, & + dis_manifold, atom_data, eigval, kpoint_path, stdout, seedname) + if (allocated(pw90_dos%project)) then + deallocate (pw90_dos%project, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating dos_project in w90_postw90_readwrite_dealloc', & + stdout, seedname) + endif + if (allocated(fermi_energy_list)) then + deallocate (fermi_energy_list, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating fermi_energy_list in w90_postw90_readwrite_dealloc', & + stdout, seedname) + endif + if (allocated(pw90_berry%kubo_freq_list)) then + deallocate (pw90_berry%kubo_freq_list, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating kubo_freq_list in w90_postw90_readwrite_dealloc', & + stdout, seedname) + endif + end subroutine w90_postw90_readwrite_dealloc + + ! extra postw90 memory + !================================================! + subroutine w90_postw90_readwrite_mem_estimate(mem_param, mem_bw, dis_manifold, do_boltzwann, & + pw90_boltzwann, spin_decomp, num_wann, stdout) + !================================================! + ! note, should only be called from root node + !================================================! + + implicit none + + type(dis_manifold_type), intent(in) :: dis_manifold + type(pw90_boltzwann_type) :: pw90_boltzwann + + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + !real(kind=dp), parameter :: size_log = 1.0_dp + !real(kind=dp), parameter :: size_int = 4.0_dp + real(kind=dp), parameter :: size_real = 8.0_dp + real(kind=dp), parameter :: size_cmplx = 16.0_dp + real(kind=dp), intent(in) :: mem_param + real(kind=dp), intent(inout) :: mem_bw + logical, intent(in) :: do_boltzwann, spin_decomp + integer :: NumPoints1, NumPoints2, NumPoints3, ndim + real(kind=dp) :: TDF_exceeding_energy + + if (do_boltzwann) then + if (spin_decomp) then + ndim = 3 + else + ndim = 1 + end if + + ! I set a big value to have a rough estimate + TDF_exceeding_energy = 2._dp + NumPoints1 = int(floor((pw90_boltzwann%temp_max - pw90_boltzwann%temp_min)/ & + pw90_boltzwann%temp_step)) + 1 ! temperature array + NumPoints2 = int(floor((pw90_boltzwann%mu_max - pw90_boltzwann%mu_min)/ & + pw90_boltzwann%mu_step)) + 1 ! mu array + NumPoints3 = int(floor((dis_manifold%win_max - dis_manifold%win_min & + + 2._dp*TDF_exceeding_energy)/ & + pw90_boltzwann%tdf_energy_step)) + 1 ! tdfenergyarray + mem_bw = mem_bw + NumPoints1*size_real !TempArray + mem_bw = mem_bw + NumPoints1*size_real !KTArray + mem_bw = mem_bw + NumPoints2*size_real !MuArray + mem_bw = mem_bw + NumPoints3*size_real !TDFEnergyArray + mem_bw = mem_bw + 6*NumPoints3*ndim*size_real !TDFArray + mem_bw = mem_bw + 6*NumPoints3*size_real !IntegrandArray + mem_bw = mem_bw + (9*4 + 6)*size_real + !ElCondTimesSeebeckFP,ThisElCond,ElCondInverse,ThisSeebeck,ElCondTimesSeebeck + mem_bw = mem_bw + 6*NumPoints1*NumPoints2*size_real !ElCond + mem_bw = mem_bw + 6*NumPoints1*NumPoints2*size_real !Seebeck + mem_bw = mem_bw + 6*NumPoints1*NumPoints2*size_real !ThermCond + ! I put a upper bound here below (as if there was only 1 node), because I do not have any knowledge at this point + ! of the number of processors, so I cannot have a correct estimate + mem_bw = mem_bw + 6*NumPoints1*NumPoints2*size_real !LocalElCond + mem_bw = mem_bw + 6*NumPoints1*NumPoints2*size_real !LocalSeebeck + mem_bw = mem_bw + 6*NumPoints1*NumPoints2*size_real !LocalThermCond + + mem_bw = mem_bw + num_wann*num_wann*size_cmplx !HH + mem_bw = mem_bw + 3*num_wann*num_wann*size_cmplx !delHH + mem_bw = mem_bw + num_wann*num_wann*size_cmplx !UU + mem_bw = mem_bw + 3*num_wann*size_real !del_eig + mem_bw = mem_bw + num_wann*size_real !eig + mem_bw = mem_bw + num_wann*size_real !levelspacing_k + + NumPoints1 = int(floor((pw90_boltzwann%dos_energy_max - pw90_boltzwann%dos_energy_min)/ & + pw90_boltzwann%dos_energy_step)) + 1!dosnumpoints + mem_bw = mem_bw + NumPoints1*size_real !DOS_EnergyArray + mem_bw = mem_bw + 6*ndim*NumPoints3*size_real !TDF_k + mem_bw = mem_bw + ndim*NumPoints1*size_real !DOS_k + mem_bw = mem_bw + ndim*NumPoints1*size_real !DOS_all + end if + + if (do_boltzwann) & + write (stdout, '(1x,"|",24x,a15,f16.2,a,18x,"|")') 'BoltzWann:', & + (mem_param + mem_bw)/(1024**2), ' Mb' + + end subroutine w90_postw90_readwrite_mem_estimate + + !================================================! + subroutine parameters_gyro_write_task(task, key, comment, stdout) + !================================================! + integer, intent(in) :: stdout + character(len=*), intent(in) :: task, key, comment + character(len=42) :: comment1 + + comment1 = comment + if ((index(task, key) > 0) .or. (index(task, 'all') > 0)) then + write (stdout, '(1x,a2,a42,a2,10x,a8,13x,a1)') '| ', comment1, ' :', ' T', '|' + else + write (stdout, '(1x,a2,a42,a2,10x,a8,13x,a1)') '| ', comment1, ' :', ' F', '|' + endif + end subroutine parameters_gyro_write_task + +end module w90_postw90_readwrite diff --git a/src/postw90/postw90_types.F90 b/src/postw90/postw90_types.F90 new file mode 100644 index 000000000..96111e6e2 --- /dev/null +++ b/src/postw90/postw90_types.F90 @@ -0,0 +1,258 @@ +!-*- mode: F90 -*-! +!------------------------------------------------------------! +! This file is distributed as part of the Wannier90 code and ! +! under the terms of the GNU General Public License. See the ! +! file `LICENSE' in the root directory of the Wannier90 ! +! distribution, or http://www.gnu.org/copyleft/gpl.txt ! +! ! +! The webpage of the Wannier90 code is www.wannier.org ! +! ! +! The Wannier90 code is hosted on GitHub: ! +! ! +! https://github.com/wannier-developers/wannier90 ! +!------------------------------------------------------------! +! ! +! w90_postw90_types: data types specific to postw90.x ! +! ! +!------------------------------------------------------------! + +module w90_postw90_types + + ! Definition of types encapsulating various quantities, data and parameters. + ! Variables are grouped according to physical meaning and their use in the Wannier90 project. + ! + !! Here are defined types specific to postw90.x (not used by wannier90.x). + !! Types used by both wannier90.x and postw90.x are defined in types.F90. + !! Types specific to wannier90.x (not used by postw90.x) are defined in wannier90_types.F90. + + use w90_constants, only: dp + use w90_comms, only: w90comm_type + + implicit none + + public + + type pw90_calculation_type + !!================================================== + !! Contains information about the high-level task that pw90 is being asked to do, + !! including any global variables that affect all calculation branches. + !!================================================== + logical :: kpath + logical :: kslice + logical :: dos + logical :: berry + logical :: gyrotropic + logical :: geninterp + logical :: boltzwann + logical :: spin_moment + logical :: spin_decomp + end type pw90_calculation_type + + type pw90_oper_read_type + !!================================================== + !! Contains variables for determining whether formatted or unformatted input is read by get_oper.F90 + !!================================================== + logical :: spn_formatted + !! Read the spin from fortran formatted file + logical :: uHu_formatted + !! Read the uHu from fortran formatted file + end type pw90_oper_read_type + + type kmesh_spacing_type + real(kind=dp) :: spacing + integer :: mesh(3) + end type kmesh_spacing_type + + ! Module s p i n + type pw90_spin_mod_type + !!================================================== + !! Contains variables used in the spin module of postw90 + !!================================================== + real(kind=dp) :: axis_polar + real(kind=dp) :: axis_azimuth + type(kmesh_spacing_type) :: kmesh + end type pw90_spin_mod_type + + ! REVIEW_2021-08-09: A general comment, which we record here so we don't forget. + ! REVIEW_2021-08-09: It would be good to try to keep type and variable names + ! REVIEW_2021-08-09: as consistent as possible. As an example, at the top of berry.F90, we have + ! REVIEW_2021-08-09: type(kmesh_info_type), intent(in) :: kmesh_info ! consistent + ! REVIEW_2021-08-09: type(kpoint_dist_type), intent(in) :: kdist ! not consistent + ! REVIEW_2021-08-09: type(k_point_type), intent(in) :: k_points ! fixed + ! REVIEW_2021-08-09: This would make reading and debugging the code easier in future. + + type pw90_band_deriv_degen_type + !!================================================== + !! Contains variables for doing degenerate perturbation theory when bands are degenerate + !! and band derivatives are needed. + !!================================================== + logical :: use_degen_pert + real(kind=dp) :: degen_thr + end type pw90_band_deriv_degen_type + + ! module k p a t h (used by postw90/kpath) + type pw90_kpath_mod_type + !!================================================== + !! Contains control variables for the kpath module of postw90 + !!================================================== + character(len=20) :: task + integer :: num_points + character(len=20) :: bands_colour + end type pw90_kpath_mod_type + + ! module k s l i c e (postw90/kslice) + type pw90_kslice_mod_type + !!================================================== + !! Contains control variables for the kslice module of postw90 + !!================================================== + character(len=20) :: task + real(kind=dp) :: corner(3) + real(kind=dp) :: b1(3) + real(kind=dp) :: b2(3) + integer :: kmesh2d(2) + character(len=20) :: fermi_lines_colour + end type pw90_kslice_mod_type + + type pw90_smearing_type + !!================================================== + !! Contains variables for controlling the smearing. + !!================================================== + logical :: use_adaptive + real(kind=dp) :: adaptive_prefactor + integer :: type_index + real(kind=dp) :: fixed_width + real(kind=dp) :: adaptive_max_width + ! REVIEW_2021-08-09: Is this a speed-up that could be applied more generally? + ! BGS currently only implemented in gyrotropic + real(kind=dp) :: max_arg + end type pw90_smearing_type + + type pw90_dos_mod_type + !!================================================== + !! Contains variables for the dos module of postw90 + !!================================================== + character(len=20) :: task + type(pw90_smearing_type) :: smearing + real(kind=dp) :: energy_max + real(kind=dp) :: energy_min + real(kind=dp) :: energy_step + integer :: num_project + integer, allocatable :: project(:) + ! character(len=20) :: plot_format + type(kmesh_spacing_type) :: kmesh + ! real(kind=dp) :: gaussian_width + end type pw90_dos_mod_type + + ! Module b e r r y (mainly postw90/berry) + type pw90_berry_mod_type + !!================================================== + !! Contains variables for the berry module of postw90 + !!================================================== + character(len=120) :: task + type(kmesh_spacing_type) :: kmesh + integer :: curv_adpt_kmesh + real(kind=dp) :: curv_adpt_kmesh_thresh + character(len=20) :: curv_unit ! postw90/kpath, kslice as well + type(pw90_smearing_type) :: kubo_smearing + integer :: sc_phase_conv + real(kind=dp) :: sc_eta ! also postw90/wan_ham + real(kind=dp) :: sc_w_thr + logical :: sc_use_eta_corr + logical :: wanint_kpoint_file ! also postw90/spin, postw90/dos, postw90.F90 + logical :: transl_inv !also used in postw90/get_oper, postw90/gyrotropic + real(kind=dp) :: kdotp_kpoint(3) + integer, allocatable :: kdotp_bands(:) + integer :: kubo_nfreq + complex(kind=dp), allocatable :: kubo_freq_list(:) + real(kind=dp) :: kubo_eigval_max + end type pw90_berry_mod_type + + ! spin Hall conductivity (postw90 - common, get_oper, berry, kpath) + type pw90_spin_hall_type + !!================================================== + !! Contains variables controlling the calculation of spin hall conductivity in postw90 + !!================================================== + logical :: freq_scan + integer :: alpha + integer :: beta + integer :: gamma + logical :: bandshift + integer :: bandshift_firstband + real(kind=dp) :: bandshift_energyshift + character(len=120) :: method + end type pw90_spin_hall_type + + type pw90_gyrotropic_type ! postw90 - common, gyrotropic + !!================================================== + !! Contains variables for the gyrotropic module of postw90 + !!================================================== + character(len=120) :: task + type(kmesh_spacing_type) :: kmesh + integer :: nfreq + complex(kind=dp), allocatable :: freq_list(:) + real(kind=dp) :: box_corner(3), box(3, 3) + real(kind=dp) :: degen_thresh + integer, allocatable :: band_list(:) + integer :: num_bands + type(pw90_smearing_type) :: smearing + real(kind=dp) :: eigval_max + end type pw90_gyrotropic_type + + ! [gp-begin, Jun 1, 2012] + ! GeneralInterpolator variables - postw90/geninterp + type pw90_geninterp_mod_type + !!================================================== + !! Contains variables for the geninterp module of postw90 + !!================================================== + logical :: alsofirstder + logical :: single_file + end type pw90_geninterp_mod_type + ! [gp-end, Jun 1, 2012] + + ! [gp-begin, Apr 12, 2012] + ! BoltzWann variables (postw90/boltzwann.F90) + type pw90_boltzwann_type + !!================================================== + !! Contains variables for the boltzwann module of postw90 + !!================================================== + logical :: calc_also_dos + integer :: dir_num_2d + real(kind=dp) :: dos_energy_step + real(kind=dp) :: dos_energy_min + real(kind=dp) :: dos_energy_max + type(pw90_smearing_type) :: dos_smearing + real(kind=dp) :: mu_min + real(kind=dp) :: mu_max + real(kind=dp) :: mu_step + real(kind=dp) :: temp_min + real(kind=dp) :: temp_max + real(kind=dp) :: temp_step + type(kmesh_spacing_type) :: kmesh + real(kind=dp) :: tdf_energy_step + type(pw90_smearing_type) :: tdf_smearing ! TDF_smr_index and TDF_smr_fixed_en_width + real(kind=dp) :: relax_time + logical :: bandshift + integer :: bandshift_firstband + real(kind=dp) :: bandshift_energyshift + end type pw90_boltzwann_type + ! [gp-end, Apr 12, 2012] + + ! Parameters describing the direct lattice points R on a + ! Wigner-Seitz supercell + ! these were in postw90_common + ! + type wigner_seitz_type + integer, allocatable :: irvec(:, :) + real(kind=dp), allocatable :: crvec(:, :) + integer, allocatable :: ndegen(:) + integer :: nrpts + integer :: rpt_origin + end type wigner_seitz_type + + type kpoint_dist_type ! kpoints from file + integer :: max_int_kpts_on_node, num_int_kpts + integer, allocatable :: num_int_kpts_on_node(:) + real(kind=dp), allocatable :: int_kpts(:, :), weight(:) + end type kpoint_dist_type + +end module w90_postw90_types diff --git a/src/postw90/spin.F90 b/src/postw90/spin.F90 index 0f4c3606f..03b972c0a 100644 --- a/src/postw90/spin.F90 +++ b/src/postw90/spin.F90 @@ -11,8 +11,13 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! w90_spin: spin operations ! +! ! +!------------------------------------------------------------! module w90_spin + !! Module to compute spin use w90_constants, only: dp @@ -21,39 +26,94 @@ module w90_spin private - public :: spin_get_moment, spin_get_nk, spin_get_S + public :: spin_get_moment + public :: spin_get_nk + public :: spin_get_S contains - !===========================================================! - ! PUBLIC PROCEDURES ! - !===========================================================! - - subroutine spin_get_moment - !============================================================! - ! ! + !================================================! + ! PUBLIC PROCEDURES + !================================================! + + subroutine spin_get_moment(dis_manifold, fermi_energy_list, kpoint_dist, kpt_latt, pw90_oper_read, & + pw90_spin, ws_region, print_output, wannier_data, ws_distance, wigner_seitz, HH_R, & + SS_R, u_matrix, v_matrix, eigval, real_lattice, & + scissors_shift, mp_grid, num_wann, num_bands, num_kpts, & + num_valence_bands, effective_model, have_disentangled, & + wanint_kpoint_file, seedname, stdout, comm) + !================================================! + ! !! Computes the spin magnetic moment by Wannier interpolation - ! ! - !============================================================! - - use w90_constants, only: dp, pi, cmplx_i - use w90_comms, only: on_root, my_node_id, num_nodes, comms_reduce - use w90_io, only: io_error, stdout - use w90_postw90_common, only: num_int_kpts_on_node, int_kpts, weight - use w90_parameters, only: spin_kmesh, wanint_kpoint_file, & - nfermi, fermi_energy_list + ! + !================================================! + + use w90_constants, only: dp, pi + use w90_comms, only: comms_reduce, w90comm_type, mpirank, mpisize + use w90_io, only: io_error + use w90_postw90_types, only: pw90_spin_mod_type, pw90_oper_read_type, wigner_seitz_type, & + kpoint_dist_type + use w90_types, only: print_output_type, wannier_data_type, & + dis_manifold_type, ws_region_type, ws_distance_type use w90_get_oper, only: get_HH_R, get_SS_R + implicit none + + ! arguments + type(dis_manifold_type), intent(in) :: dis_manifold + type(kpoint_dist_type), intent(in) :: kpoint_dist + type(pw90_oper_read_type), intent(in) :: pw90_oper_read + type(pw90_spin_mod_type), intent(in) :: pw90_spin + type(print_output_type), intent(in) :: print_output + type(ws_region_type), intent(in) :: ws_region + type(w90comm_type), intent(in) :: comm + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) ! <0n|sigma_x,y,z|Rm> + complex(kind=dp), intent(in) :: u_matrix(:, :, :), v_matrix(:, :, :) + + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: scissors_shift + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + real(kind=dp), intent(in) :: kpt_latt(:, :) + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_wann, num_bands, num_kpts, num_valence_bands + integer, intent(in) :: stdout + + logical, intent(in) :: wanint_kpoint_file + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + logical, intent(in) :: effective_model + + ! local variables integer :: loop_x, loop_y, loop_z, loop_tot + integer :: fermi_n real(kind=dp) :: kweight, kpt(3), spn_k(3), spn_all(3), & spn_mom(3), magnitude, theta, phi, conv - if (nfermi > 1) call io_error('Routine spin_get_moment requires nfermi=1') + integer :: my_node_id, num_nodes + + my_node_id = mpirank(comm); + num_nodes = mpisize(comm); + fermi_n = 0 + if (allocated(fermi_energy_list)) fermi_n = size(fermi_energy_list) + if (fermi_n > 1) call io_error('Routine spin_get_moment requires nfermi=1', stdout, seedname) - call get_HH_R - call get_SS_R + call get_HH_R(dis_manifold, kpt_latt, print_output, wigner_seitz, HH_R, u_matrix, v_matrix, eigval, & + real_lattice, scissors_shift, num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, stdout, comm) - if (on_root) then + call get_SS_R(dis_manifold, kpt_latt, print_output, pw90_oper_read, SS_R, v_matrix, eigval, & + wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, num_wann, have_disentangled, & + seedname, stdout, comm) + + if (print_output%iprint > 0) then write (stdout, '(/,/,1x,a)') '------------' write (stdout, '(1x,a)') 'Calculating:' write (stdout, '(1x,a)') '------------' @@ -63,53 +123,57 @@ subroutine spin_get_moment spn_all = 0.0_dp if (wanint_kpoint_file) then - if (on_root) then + if (print_output%iprint > 0) then write (stdout, '(/,1x,a)') 'Sampling the irreducible BZ only' write (stdout, '(5x,a)') & 'WARNING: - IBZ implementation is currently limited to simple cases:' write (stdout, '(5x,a)') & ' Check results against a full BZ calculation!' end if - ! + ! Loop over k-points on the irreducible wedge of the Brillouin zone, ! read from file 'kpoint.dat' - ! - do loop_tot = 1, num_int_kpts_on_node(my_node_id) - kpt(:) = int_kpts(:, loop_tot) - kweight = weight(loop_tot) - call spin_get_moment_k(kpt, fermi_energy_list(1), spn_k) + + do loop_tot = 1, kpoint_dist%num_int_kpts_on_node(my_node_id) + kpt(:) = kpoint_dist%int_kpts(:, loop_tot) + kweight = kpoint_dist%weight(loop_tot) + call spin_get_moment_k(kpt, fermi_energy_list(1), spn_k, num_wann, ws_region, wannier_data, & + real_lattice, mp_grid, ws_distance, HH_R, SS_R, wigner_seitz, stdout, & + seedname) spn_all = spn_all + spn_k*kweight end do else - if (on_root) & + if (print_output%iprint > 0) & write (stdout, '(/,1x,a)') 'Sampling the full BZ (not using symmetry)' - kweight = 1.0_dp/real(PRODUCT(spin_kmesh), kind=dp) - do loop_tot = my_node_id, PRODUCT(spin_kmesh) - 1, num_nodes - loop_x = loop_tot/(spin_kmesh(2)*spin_kmesh(3)) - loop_y = (loop_tot - loop_x*(spin_kmesh(2)*spin_kmesh(3)))/spin_kmesh(3) - loop_z = loop_tot - loop_x*(spin_kmesh(2)*spin_kmesh(3)) & - - loop_y*spin_kmesh(3) - kpt(1) = (real(loop_x, dp)/real(spin_kmesh(1), dp)) - kpt(2) = (real(loop_y, dp)/real(spin_kmesh(2), dp)) - kpt(3) = (real(loop_z, dp)/real(spin_kmesh(3), dp)) - call spin_get_moment_k(kpt, fermi_energy_list(1), spn_k) + kweight = 1.0_dp/real(PRODUCT(pw90_spin%kmesh%mesh), kind=dp) + do loop_tot = my_node_id, PRODUCT(pw90_spin%kmesh%mesh) - 1, num_nodes + loop_x = loop_tot/(pw90_spin%kmesh%mesh(2)*pw90_spin%kmesh%mesh(3)) + loop_y = (loop_tot - loop_x*(pw90_spin%kmesh%mesh(2)*pw90_spin%kmesh%mesh(3)))/pw90_spin%kmesh%mesh(3) + loop_z = loop_tot - loop_x*(pw90_spin%kmesh%mesh(2)*pw90_spin%kmesh%mesh(3)) & + - loop_y*pw90_spin%kmesh%mesh(3) + kpt(1) = (real(loop_x, dp)/real(pw90_spin%kmesh%mesh(1), dp)) + kpt(2) = (real(loop_y, dp)/real(pw90_spin%kmesh%mesh(2), dp)) + kpt(3) = (real(loop_z, dp)/real(pw90_spin%kmesh%mesh(3), dp)) + call spin_get_moment_k(kpt, fermi_energy_list(1), spn_k, num_wann, ws_region, wannier_data, & + real_lattice, mp_grid, ws_distance, HH_R, SS_R, & + wigner_seitz, stdout, seedname) spn_all = spn_all + spn_k*kweight end do end if ! Collect contributions from all nodes - ! - call comms_reduce(spn_all(1), 3, 'SUM') + + call comms_reduce(spn_all(1), 3, 'SUM', stdout, seedname, comm) ! No factor of g=2 because the spin variable spans [-1,1], not ! [-1/2,1/2] (i.e., it is really the Pauli matrix sigma, not S) - ! + spn_mom(1:3) = -spn_all(1:3) - if (on_root) then + if (print_output%iprint > 0) then write (stdout, '(/,1x,a)') 'Spin magnetic moment (Bohr magn./cell)' write (stdout, '(1x,a,/)') '====================' write (stdout, '(1x,a18,f11.6)') 'x component:', spn_mom(1) @@ -117,7 +181,7 @@ subroutine spin_get_moment write (stdout, '(1x,a18,f11.6)') 'z component:', spn_mom(3) ! Polar and azimuthal angles of the magnetization (defined as in pwscf) - ! + conv = 180.0_dp/pi magnitude = sqrt(spn_mom(1)**2 + spn_mom(2)**2 + spn_mom(3)**2) theta = acos(spn_mom(3)/magnitude)*conv @@ -128,40 +192,56 @@ subroutine spin_get_moment end subroutine spin_get_moment -! ========================================================================= - - subroutine spin_get_nk(kpt, spn_nk) - !=============================================================! - ! ! + !================================================! + subroutine spin_get_nk(ws_region, pw90_spin, wannier_data, ws_distance, wigner_seitz, HH_R, SS_R, kpt, & + real_lattice, spn_nk, mp_grid, num_wann, seedname, stdout) + !================================================! + ! !! Computes (m=1,...,num_wann) !! where S.n = n_x.S_x + n_y.S_y + n_z.Z_z !! !! S_i are the Pauli matrices and n=(n_x,n_y,n_z) is the unit !! vector along the chosen spin quantization axis - ! ! - !============================================================ ! + ! + !================================================ ! - use w90_constants, only: dp, pi, cmplx_0, cmplx_i - use w90_io, only: io_error + use w90_constants, only: dp, pi use w90_utility, only: utility_diagonalize, utility_rotate_diag - use w90_parameters, only: num_wann, spin_axis_polar, & - spin_axis_azimuth + use w90_types, only: print_output_type, wannier_data_type, ws_region_type, & + ws_distance_type + use w90_postw90_types, only: pw90_spin_mod_type, wigner_seitz_type use w90_postw90_common, only: pw90common_fourier_R_to_k - use w90_get_oper, only: HH_R, SS_R - ! Arguments - ! + ! arguments + type(pw90_spin_mod_type), intent(in) :: pw90_spin + type(ws_region_type), intent(in) :: ws_region + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(in) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + integer, intent(in) :: num_wann + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + real(kind=dp), intent(in) :: kpt(3) real(kind=dp), intent(out) :: spn_nk(num_wann) + real(kind=dp), intent(in) :: real_lattice(3, 3) + + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) ! <0n|sigma_x,y,z|Rm> + + character(len=50), intent(in) :: seedname + + ! local variables ! Physics - ! + complex(kind=dp), allocatable :: HH(:, :) complex(kind=dp), allocatable :: UU(:, :) complex(kind=dp), allocatable :: SS(:, :, :), SS_n(:, :) ! Misc/Dummy - ! + integer :: is real(kind=dp) :: eig(num_wann), alpha(3), conv @@ -170,56 +250,79 @@ subroutine spin_get_nk(kpt, spn_nk) allocate (SS(num_wann, num_wann, 3)) allocate (SS_n(num_wann, num_wann)) - call pw90common_fourier_R_to_k(kpt, HH_R, HH, 0) - call utility_diagonalize(HH, num_wann, eig, UU) + call pw90common_fourier_R_to_k(ws_region, wannier_data, ws_distance, wigner_seitz, HH, HH_R, kpt, & + real_lattice, mp_grid, 0, num_wann, seedname, stdout) + call utility_diagonalize(HH, num_wann, eig, UU, stdout, seedname) do is = 1, 3 - call pw90common_fourier_R_to_k(kpt, SS_R(:, :, :, is), SS(:, :, is), 0) + call pw90common_fourier_R_to_k(ws_region, wannier_data, ws_distance, wigner_seitz, SS(:, :, is), & + SS_R(:, :, :, is), kpt, real_lattice, mp_grid, & + 0, num_wann, seedname, stdout) enddo ! Unit vector along the magnetization direction - ! + conv = 180.0_dp/pi - alpha(1) = sin(spin_axis_polar/conv)*cos(spin_axis_azimuth/conv) - alpha(2) = sin(spin_axis_polar/conv)*sin(spin_axis_azimuth/conv) - alpha(3) = cos(spin_axis_polar/conv) + alpha(1) = sin(pw90_spin%axis_polar/conv)*cos(pw90_spin%axis_azimuth/conv) + alpha(2) = sin(pw90_spin%axis_polar/conv)*sin(pw90_spin%axis_azimuth/conv) + alpha(3) = cos(pw90_spin%axis_polar/conv) ! Vector of spin matrices projected along the quantization axis - ! + SS_n(:, :) = alpha(1)*SS(:, :, 1) + alpha(2)*SS(:, :, 2) + alpha(3)*SS(:, :, 3) spn_nk(:) = real(utility_rotate_diag(SS_n, UU, num_wann), dp) end subroutine spin_get_nk - !===========================================================! - ! PRIVATE PROCEDURES ! - !===========================================================! + !================================================! + ! PRIVATE PROCEDURES + !================================================! - subroutine spin_get_moment_k(kpt, ef, spn_k) + subroutine spin_get_moment_k(kpt, ef, spn_k, num_wann, ws_region, wannier_data, real_lattice, & + mp_grid, ws_distance, HH_R, SS_R, wigner_seitz, stdout, seedname) + !================================================! !! Computes the spin magnetic moment by Wannier interpolation !! at the specified k-point - use w90_constants, only: dp, cmplx_0, cmplx_i - use w90_io, only: io_error + !================================================! + + use w90_constants, only: dp, cmplx_i use w90_utility, only: utility_diagonalize, utility_rotate_diag - use w90_parameters, only: num_wann + use w90_types, only: print_output_type, wannier_data_type, ws_region_type, & + ws_distance_type use w90_postw90_common, only: pw90common_fourier_R_to_k, pw90common_get_occ - use w90_get_oper, only: HH_R, SS_R - ! Arguments - ! - real(kind=dp), intent(in) :: kpt(3) - real(kind=dp), intent(in) :: ef + use w90_postw90_types, only: wigner_seitz_type + + ! arguments + type(ws_region_type), intent(in) :: ws_region + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(in) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: ef + real(kind=dp), intent(in) :: kpt(3) + real(kind=dp), intent(in) :: real_lattice(3, 3) real(kind=dp), intent(out) :: spn_k(3) + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) ! <0n|sigma_x,y,z|Rm> + + character(len=50), intent(in) :: seedname + + ! local variables ! Physics - ! + complex(kind=dp), allocatable :: HH(:, :) complex(kind=dp), allocatable :: SS(:, :, :) complex(kind=dp), allocatable :: UU(:, :) real(kind=dp) :: spn_nk(num_wann, 3) ! Misc/Dummy - ! + integer :: i, is real(kind=dp) :: eig(num_wann), occ(num_wann) @@ -227,13 +330,16 @@ subroutine spin_get_moment_k(kpt, ef, spn_k) allocate (UU(num_wann, num_wann)) allocate (SS(num_wann, num_wann, 3)) - call pw90common_fourier_R_to_k(kpt, HH_R, HH, 0) - call utility_diagonalize(HH, num_wann, eig, UU) - call pw90common_get_occ(eig, occ, ef) + call pw90common_fourier_R_to_k(ws_region, wannier_data, ws_distance, wigner_seitz, HH, HH_R, kpt, & + real_lattice, mp_grid, 0, num_wann, seedname, stdout) + call utility_diagonalize(HH, num_wann, eig, UU, stdout, seedname) + call pw90common_get_occ(ef, eig, occ, num_wann) spn_k(1:3) = 0.0_dp do is = 1, 3 - call pw90common_fourier_R_to_k(kpt, SS_R(:, :, :, is), SS(:, :, is), 0) + call pw90common_fourier_R_to_k(ws_region, wannier_data, ws_distance, wigner_seitz, SS(:, :, is), & + SS_R(:, :, :, is), kpt, real_lattice, mp_grid, & + 0, num_wann, seedname, stdout) spn_nk(:, is) = aimag(cmplx_i*utility_rotate_diag(SS(:, :, is), UU, num_wann)) do i = 1, num_wann spn_k(is) = spn_k(is) + occ(i)*spn_nk(i, is) @@ -242,46 +348,63 @@ subroutine spin_get_moment_k(kpt, ef, spn_k) end subroutine spin_get_moment_k - subroutine spin_get_S(kpt, S) - !===========================================================! - ! ! - ! Computes (n=1,...,num_wann) ! - ! where S = (S_x,S_y,S_z) is the vector of Pauli matrices ! - ! ! - !========================================================== ! + !================================================! + subroutine spin_get_S(kpt, S, num_wann, ws_region, wannier_data, real_lattice, & + mp_grid, ws_distance, HH_R, SS_R, wigner_seitz, stdout, seedname) + !================================================! + ! + ! Computes (n=1,...,num_wann) + ! where S = (S_x,S_y,S_z) is the vector of Pauli matrices + ! + !================================================ ! - use w90_constants, only: dp, pi, cmplx_0, cmplx_i - use w90_io, only: io_error + use w90_constants, only: dp use w90_utility, only: utility_diagonalize, utility_rotate_diag - use w90_parameters, only: num_wann + use w90_types, only: print_output_type, wannier_data_type, ws_region_type, & + ws_distance_type use w90_postw90_common, only: pw90common_fourier_R_to_k - use w90_get_oper, only: HH_R, SS_R + use w90_postw90_types, only: wigner_seitz_type + + ! arguments + type(ws_region_type), intent(in) :: ws_region + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(in) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout, num_wann - ! Arguments - ! real(kind=dp), intent(in) :: kpt(3) + real(kind=dp), intent(in) :: real_lattice(3, 3) real(kind=dp), intent(out) :: S(num_wann, 3) + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) ! <0n|sigma_x,y,z|Rm> + + character(len=50), intent(in) :: seedname + + ! local variables ! Physics - ! complex(kind=dp), allocatable :: HH(:, :) complex(kind=dp), allocatable :: UU(:, :) complex(kind=dp), allocatable :: SS(:, :, :) real(kind=dp) :: eig(num_wann) ! Misc/Dummy - ! integer :: i allocate (HH(num_wann, num_wann)) allocate (UU(num_wann, num_wann)) allocate (SS(num_wann, num_wann, 3)) - call pw90common_fourier_R_to_k(kpt, HH_R, HH, 0) - call utility_diagonalize(HH, num_wann, eig, UU) + call pw90common_fourier_R_to_k(ws_region, wannier_data, ws_distance, wigner_seitz, HH, HH_R, kpt, & + real_lattice, mp_grid, 0, num_wann, seedname, stdout) + call utility_diagonalize(HH, num_wann, eig, UU, stdout, seedname) do i = 1, 3 - call pw90common_fourier_R_to_k(kpt, SS_R(:, :, :, i), SS(:, :, i), 0) + call pw90common_fourier_R_to_k(ws_region, wannier_data, ws_distance, wigner_seitz, SS(:, :, i), & + SS_R(:, :, :, i), kpt, real_lattice, mp_grid, & + 0, num_wann, seedname, stdout) S(:, i) = real(utility_rotate_diag(SS(:, :, i), UU, num_wann), dp) enddo diff --git a/src/postw90/wan_ham.F90 b/src/postw90/wan_ham.F90 index dca7f87e7..30e68a876 100644 --- a/src/postw90/wan_ham.F90 +++ b/src/postw90/wan_ham.F90 @@ -11,8 +11,13 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! w90_wan_ham: Hamiltonian operations in Wannier basis ! +! ! +!------------------------------------------------------------! module w90_wan_ham + !! This module contain operations on the Hamiltonian in the WF basis use w90_constants, only: dp @@ -21,38 +26,47 @@ module w90_wan_ham private - public :: wham_get_D_h, wham_get_eig_deleig, wham_get_eig_deleig_TB_conv, wham_get_D_h_P_value - public :: wham_get_occ_mat_list, wham_get_eig_UU_HH_JJlist - public :: wham_get_eig_UU_HH_AA_sc, wham_get_eig_UU_HH_AA_sc_TB_conv + public :: wham_get_D_h + public :: wham_get_D_h_P_value + public :: wham_get_eig_deleig + public :: wham_get_eig_deleig_TB_conv + public :: wham_get_eig_UU_HH_AA_sc + public :: wham_get_eig_UU_HH_AA_sc_TB_conv + public :: wham_get_eig_UU_HH_JJlist + public :: wham_get_occ_mat_list contains - subroutine wham_get_D_h_a(delHH_a, UU, eig, ef, D_h_a) - !===============================================! - ! ! + !================================================! + + subroutine wham_get_D_h_a(delHH_a, UU, eig, ef, D_h_a, num_wann) + !================================================! + ! !! Compute D^H_a=UU^dag.del_a UU (a=alpha,beta), !! using Eq.(24) of WYSV06 - ! ! - !===============================================! + ! + !================================================! use w90_constants, only: dp, cmplx_0 - use w90_parameters, only: num_wann use w90_utility, only: utility_rotate use w90_postw90_common, only: pw90common_get_occ - ! Arguments - ! - complex(kind=dp), dimension(:, :), intent(in) :: delHH_a - complex(kind=dp), dimension(:, :), intent(in) :: UU - real(kind=dp), dimension(:), intent(in) :: eig - real(kind=dp), intent(in) :: ef - complex(kind=dp), dimension(:, :), intent(out) :: D_h_a + ! arguments + complex(kind=dp), intent(in) :: delHH_a(:, :) + complex(kind=dp), intent(in) :: UU(:, :) + complex(kind=dp), intent(out) :: D_h_a(:, :) + + real(kind=dp), intent(in) :: eig(:) + real(kind=dp), intent(in) :: ef + integer, intent(in) :: num_wann + + ! local variables complex(kind=dp), allocatable :: delHH_a_bar(:, :) real(kind=dp) :: occ(num_wann) integer :: n, m - call pw90common_get_occ(eig, occ, ef) + call pw90common_get_occ(ef, eig, occ, num_wann) allocate (delHH_a_bar(num_wann, num_wann)) delHH_a_bar = utility_rotate(delHH_a, UU, num_wann) @@ -69,29 +83,32 @@ subroutine wham_get_D_h_a(delHH_a, UU, eig, ef, D_h_a) end subroutine wham_get_D_h_a - subroutine wham_get_D_h(delHH, UU, eig, D_h) - !=========================================! - ! ! + !================================================! + subroutine wham_get_D_h(delHH, D_h, UU, eig, num_wann) + !================================================! + ! !! Compute D^H_a=UU^dag.del_a UU (a=x,y,z) !! using Eq.(24) of WYSV06 - ! ! - !=========================================! + ! + !================================================! ! TO DO: Implement version where energy denominators only connect ! occupied and empty states. In this case probably do not need ! to worry about avoiding small energy denominators use w90_constants, only: dp, cmplx_0 - use w90_parameters, only: num_wann use w90_utility, only: utility_rotate - ! Arguments - ! - complex(kind=dp), dimension(:, :, :), intent(in) :: delHH - complex(kind=dp), dimension(:, :), intent(in) :: UU - real(kind=dp), dimension(:), intent(in) :: eig - complex(kind=dp), dimension(:, :, :), intent(out) :: D_h + ! arguments + complex(kind=dp), intent(in) :: delHH(:, :, :) + complex(kind=dp), intent(in) :: UU(:, :) + complex(kind=dp), intent(out) :: D_h(:, :, :) + + real(kind=dp), intent(in) :: eig(:) + integer, intent(in) :: num_wann + + ! local variables complex(kind=dp), allocatable :: delHH_bar_i(:, :) integer :: n, m, i @@ -109,31 +126,37 @@ subroutine wham_get_D_h(delHH, UU, eig, D_h) end subroutine wham_get_D_h - subroutine wham_get_D_h_P_value(delHH, UU, eig, D_h) - !=========================================! - ! ! + !================================================! + subroutine wham_get_D_h_P_value(pw90_berry, delHH, D_h, UU, eig, num_wann) + !================================================! + ! !! Compute D^H_a=UU^dag.del_a UU (a=x,y,z) !! using Eq.(24) of WYSV06 ! and prescription for energy denominator ! from BK81 - ! ! - !=========================================! + ! + !================================================! ! TO DO: Implement version where energy denominators only connect ! occupied and empty states. In this case probably do not need ! to worry about avoiding small energy denominators use w90_constants, only: dp, cmplx_0 - use w90_parameters, only: num_wann, sc_eta + use w90_postw90_types, only: pw90_berry_mod_type !sc_eta use w90_utility, only: utility_rotate - ! Arguments - ! - complex(kind=dp), dimension(:, :, :), intent(in) :: delHH - complex(kind=dp), dimension(:, :), intent(in) :: UU - real(kind=dp), dimension(:), intent(in) :: eig - complex(kind=dp), dimension(:, :, :), intent(out) :: D_h + ! arguments + type(pw90_berry_mod_type), intent(in) :: pw90_berry + + integer, intent(in) :: num_wann + + real(kind=dp), intent(in) :: eig(:) + + complex(kind=dp), intent(in) :: delHH(:, :, :) + complex(kind=dp), intent(in) :: UU(:, :) + complex(kind=dp), intent(out) :: D_h(:, :, :) + ! local variables complex(kind=dp), allocatable :: delHH_bar_i(:, :) integer :: n, m, i real(kind=dp) :: deltaE @@ -147,46 +170,52 @@ subroutine wham_get_D_h_P_value(delHH, UU, eig, D_h) do n = 1, num_wann if (n == m) cycle deltaE = eig(m) - eig(n) - D_h(n, m, i) = delHH_bar_i(n, m)*(deltaE/(deltaE**(2) + sc_eta**(2))) + D_h(n, m, i) = delHH_bar_i(n, m)*(deltaE/(deltaE**(2) + pw90_berry%sc_eta**(2))) end do end do enddo end subroutine wham_get_D_h_P_value - subroutine wham_get_JJp_JJm_list(delHH, UU, eig, JJp_list, JJm_list, occ) - !===============================================! - ! ! - ! Compute JJ^+_a and JJ^-_a (a=Cartesian index) ! - ! for a list of Fermi energies ! - ! ! - ! This routine is a replacement for ! - ! wham_get_JJp_list and wham_getJJm_list. ! - ! It computes both lists at once in a more ! - ! efficient manner. ! - ! ! - ! Tsirkin: added the optional occ parameter ! - ! ! - !===============================================! + !================================================! + subroutine wham_get_JJp_JJm_list(delHH, UU, eig, JJp_list, JJm_list, num_wann, & + fermi_energy_list, occ) + !================================================! + ! ! + ! Compute JJ^+_a and JJ^-_a (a=Cartesian index) ! + ! for a list of Fermi energies ! + ! ! + ! This routine is a replacement for ! + ! wham_get_JJp_list and wham_getJJm_list. ! + ! It computes both lists at once in a more ! + ! efficient manner. ! + ! ! + ! Tsirkin: added the optional occ parameter ! + ! ! + !================================================! use w90_constants, only: dp, cmplx_0, cmplx_i - use w90_parameters, only: num_wann, nfermi, fermi_energy_list use w90_utility, only: utility_rotate_new - complex(kind=dp), dimension(:, :), intent(inout) :: delHH - complex(kind=dp), dimension(:, :), intent(in) :: UU - real(kind=dp), dimension(:), intent(in) :: eig - complex(kind=dp), dimension(:, :, :), intent(out) :: JJp_list - complex(kind=dp), dimension(:, :, :), intent(out) :: JJm_list + ! arguments + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + integer, intent(in) :: num_wann + real(kind=dp), intent(in) :: eig(:) real(kind=dp), intent(in), optional, dimension(:) :: occ + complex(kind=dp), intent(inout) :: delHH(:, :) + complex(kind=dp), intent(in) :: UU(:, :) + complex(kind=dp), intent(out) :: JJm_list(:, :, :) + complex(kind=dp), intent(out) :: JJp_list(:, :, :) - integer :: n, m, ife, nfermi_loc - real(kind=dp) :: fe + ! local variables + integer :: n, m, ife, nfermi_loc + real(kind=dp) :: fe if (present(occ)) then nfermi_loc = 1 else - nfermi_loc = nfermi + nfermi_loc = 0 + if (allocated(fermi_energy_list)) nfermi_loc = size(fermi_energy_list) endif call utility_rotate_new(delHH, UU, num_wann) @@ -219,52 +248,61 @@ subroutine wham_get_JJp_JJm_list(delHH, UU, eig, JJp_list, JJm_list, occ) end subroutine wham_get_JJp_JJm_list - subroutine wham_get_occ_mat_list(UU, f_list, g_list, eig, occ) -! subroutine wham_get_occ_mat_list(eig,UU,f_list,g_list) - !================================! - ! ! + !================================================! + subroutine wham_get_occ_mat_list(fermi_energy_list, f_list, g_list, UU, num_wann, seedname, & + stdout, eig, occ) + !================================================! + ! !! Occupation matrix f, and g=1-f !! for a list of Fermi energies - ! Tsirkin: !now optionally either eig or occ parameters may be supplied ! - ! (Changed consistently the calls from the Berry module) ! - !================================! + ! Tsirkin: !now optionally either eig or occ parameters may be supplied + ! (Changed consistently the calls from the Berry module) + !================================================! use w90_constants, only: dp, cmplx_0, cmplx_1 - use w90_parameters, only: num_wann, nfermi, fermi_energy_list use w90_postw90_common, only: pw90common_get_occ use w90_io, only: io_error - ! Arguments - ! - complex(kind=dp), dimension(:, :), intent(in) :: UU - complex(kind=dp), dimension(:, :, :), intent(out) :: f_list - complex(kind=dp), dimension(:, :, :), intent(out) :: g_list - real(kind=dp), intent(in), optional, dimension(:) :: eig - real(kind=dp), intent(in), optional, dimension(:) :: occ + ! arguments + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + + integer, intent(in) :: stdout + integer, intent(in) :: num_wann + + real(kind=dp), intent(in), optional :: eig(:) + real(kind=dp), intent(in), optional :: occ(:) + + complex(kind=dp), intent(in) :: UU(:, :) + complex(kind=dp), intent(out) :: f_list(:, :, :) + complex(kind=dp), intent(out) :: g_list(:, :, :) + character(len=50), intent(in) :: seedname + + ! local variables integer :: n, m, i, if, nfermi_loc real(kind=dp), allocatable :: occ_list(:, :) if (present(occ)) then nfermi_loc = 1 else - nfermi_loc = nfermi + nfermi_loc = 0 + if (allocated(fermi_energy_list)) nfermi_loc = size(fermi_energy_list) endif allocate (occ_list(num_wann, nfermi_loc)) if (present(occ) .and. present(eig)) then call io_error( & - 'occ_list and eig cannot be both arguments in get_occ_mat_list') + 'occ_list and eig cannot be both arguments in get_occ_mat_list', stdout, seedname) elseif (.not. present(occ) .and. .not. present(eig)) then call io_error( & - 'either occ_list or eig must be passed as arguments to get_occ_mat_list') + 'either occ_list or eig must be passed as arguments to get_occ_mat_list', stdout, seedname) endif if (present(occ)) then occ_list(:, 1) = occ(:) else do if = 1, nfermi_loc - call pw90common_get_occ(eig, occ_list(:, if), fermi_energy_list(if)) + call pw90common_get_occ(fermi_energy_list(if), eig, occ_list(:, if), num_wann) enddo endif @@ -284,27 +322,30 @@ subroutine wham_get_occ_mat_list(UU, f_list, g_list, eig, occ) end subroutine wham_get_occ_mat_list - subroutine wham_get_deleig_a(deleig_a, eig, delHH_a, UU) - !==========================! - ! ! + !================================================! + subroutine wham_get_deleig_a(deleig_a, eig, delHH_a, UU, num_wann, pw90_band_deriv_degen, & + stdout, seedname) + !================================================! + ! !! Band derivatives dE/dk_a - ! ! - !==========================! + ! + !================================================! - use w90_constants, only: dp, cmplx_0, cmplx_i - use w90_utility, only: utility_diagonalize, utility_rotate, & - utility_rotate_diag - use w90_parameters, only: num_wann, use_degen_pert, degen_thr + use w90_constants, only: dp !, cmplx_0, cmplx_i + use w90_utility, only: utility_diagonalize, utility_rotate, utility_rotate_diag + use w90_postw90_types, only: pw90_band_deriv_degen_type - ! Arguments - ! + ! arguments + type(pw90_band_deriv_degen_type), intent(in) :: pw90_band_deriv_degen + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + real(kind=dp), intent(in) :: eig(num_wann) real(kind=dp), intent(out) :: deleig_a(num_wann) - real(kind=dp), intent(in) :: eig(num_wann) - complex(kind=dp), dimension(:, :), intent(in) :: delHH_a - complex(kind=dp), dimension(:, :), intent(in) :: UU + complex(kind=dp), intent(in) :: delHH_a(:, :) + complex(kind=dp), intent(in) :: UU(:, :) + character(len=50), intent(in) :: seedname - ! Misc/Dummy - ! + ! local variables integer :: i, degen_min, degen_max, dim real(kind=dp) :: diff complex(kind=dp), allocatable :: delHH_bar_a(:, :), U_deg(:, :) @@ -312,7 +353,7 @@ subroutine wham_get_deleig_a(deleig_a, eig, delHH_a, UU) allocate (delHH_bar_a(num_wann, num_wann)) allocate (U_deg(num_wann, num_wann)) - if (use_degen_pert) then + if (pw90_band_deriv_degen%use_degen_pert) then delHH_bar_a = utility_rotate(delHH_a, UU, num_wann) @@ -326,47 +367,47 @@ subroutine wham_get_deleig_a(deleig_a, eig, delHH_a, UU) if (i + 1 <= num_wann) then diff = eig(i + 1) - eig(i) else - ! + ! i-th is the highest band, and it is non-degenerate - ! - diff = degen_thr + 1.0_dp + + diff = pw90_band_deriv_degen%degen_thr + 1.0_dp end if - if (diff < degen_thr) then - ! + if (diff < pw90_band_deriv_degen%degen_thr) then + ! Bands i and i+1 are degenerate - ! + degen_min = i degen_max = degen_min + 1 - ! + ! See if any higher bands are in the same degenerate group - ! + do if (degen_max + 1 > num_wann) exit diff = eig(degen_max + 1) - eig(degen_max) - if (diff < degen_thr) then + if (diff < pw90_band_deriv_degen%degen_thr) then degen_max = degen_max + 1 else exit end if end do - ! + ! Bands from degen_min to degen_max are degenerate. Diagonalize ! the submatrix in Eq.(31) YWVS07 over this degenerate subspace. ! The eigenvalues are the band gradients - ! - ! + dim = degen_max - degen_min + 1 call utility_diagonalize(delHH_bar_a(degen_min:degen_max, & degen_min:degen_max), dim, & - deleig_a(degen_min:degen_max), U_deg(1:dim, 1:dim)) - ! + deleig_a(degen_min:degen_max), U_deg(1:dim, 1:dim), & + stdout, seedname) + ! Scanned bands up to degen_max - ! + i = degen_max else - ! + ! Use non-degenerate form [Eq.(27) YWVS07] for current (i-th) band - ! + deleig_a(i) = real(delHH_bar_a(i, i), dp) end if end do @@ -374,180 +415,371 @@ subroutine wham_get_deleig_a(deleig_a, eig, delHH_a, UU) else ! Use non-degenerate form for all bands - ! + deleig_a(:) = real(utility_rotate_diag(delHH_a(:, :), UU, num_wann), dp) end if end subroutine wham_get_deleig_a - subroutine wham_get_eig_deleig(kpt, eig, del_eig, HH, delHH, UU) + !================================================! + subroutine wham_get_eig_deleig(dis_manifold, kpt_latt, pw90_band_deriv_degen, ws_region, & + print_output, wannier_data, ws_distance, wigner_seitz, delHH, HH, & + HH_R, u_matrix, UU, v_matrix, del_eig, eig, eigval, kpt, & + real_lattice, scissors_shift, mp_grid, num_bands, num_kpts, & + num_wann, num_valence_bands, effective_model, have_disentangled, & + seedname, stdout, comm) + !================================================! + ! !! Given a k point, this function returns eigenvalues E and !! derivatives of the eigenvalues dE/dk_a, using wham_get_deleig_a ! - use w90_parameters, only: num_wann - use w90_get_oper, only: HH_R, get_HH_R - use w90_postw90_common, only: pw90common_fourier_R_to_k + !================================================! + + use w90_constants, only: dp + use w90_postw90_types, only: pw90_band_deriv_degen_type, wigner_seitz_type + use w90_comms, only: w90comm_type, mpirank + use w90_constants, only: dp, cmplx_0 + use w90_get_oper, only: get_HH_R + use w90_io, only: io_error, io_stopwatch, io_file_unit + use w90_types, only: dis_manifold_type, print_output_type, wannier_data_type, & + ws_region_type, ws_distance_type + use w90_postw90_common, only: pw90common_fourier_R_to_k_new_second_d, & + pw90common_fourier_R_to_k use w90_utility, only: utility_diagonalize - real(kind=dp), dimension(3), intent(in) :: kpt - !! the three coordinates of the k point vector (in relative coordinates) - real(kind=dp), intent(out) :: eig(num_wann) - !! the calculated eigenvalues at kpt - real(kind=dp), intent(out) :: del_eig(num_wann, 3) + implicit none + + ! arguments + type(dis_manifold_type), intent(in) :: dis_manifold + real(kind=dp), intent(in) :: kpt_latt(:, :) + type(pw90_band_deriv_degen_type), intent(in) :: pw90_band_deriv_degen + type(print_output_type), intent(in) :: print_output + type(ws_region_type), intent(in) :: ws_region + type(w90comm_type), intent(in) :: comm + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + integer, intent(in) :: num_wann, num_kpts, num_bands, num_valence_bands + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: kpt(3)!! the three coordinates of the k point vector (in relative coordinates) + real(kind=dp), intent(out) :: eig(num_wann)!! the calculated eigenvalues at kpt + real(kind=dp), intent(out) :: del_eig(num_wann, 3) !! the calculated derivatives of the eigenvalues at kpt [first component: band; second component: 1,2,3 !! for the derivatives along the three k directions] - complex(kind=dp), dimension(:, :), intent(out) :: HH + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: scissors_shift + + complex(kind=dp), intent(out) :: HH(:, :) !! the Hamiltonian matrix at kpt - complex(kind=dp), dimension(:, :, :), intent(out) :: delHH + complex(kind=dp), intent(out) :: delHH(:, :, :) !! the delHH matrix (derivative of H) at kpt - complex(kind=dp), dimension(:, :), intent(out) :: UU + complex(kind=dp), intent(out) :: UU(:, :) !! the rotation matrix that gives the eigenvectors of HH + complex(kind=dp), intent(in) :: u_matrix(:, :, :), v_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + logical, intent(in) :: effective_model ! I call it to be sure that it has been called already once, ! and that HH_R contains the actual matrix. ! Further calls should return very fast. - call get_HH_R - - call pw90common_fourier_R_to_k(kpt, HH_R, HH, 0) - call utility_diagonalize(HH, num_wann, eig, UU) - call pw90common_fourier_R_to_k(kpt, HH_R, delHH(:, :, 1), 1) - call pw90common_fourier_R_to_k(kpt, HH_R, delHH(:, :, 2), 2) - call pw90common_fourier_R_to_k(kpt, HH_R, delHH(:, :, 3), 3) - call wham_get_deleig_a(del_eig(:, 1), eig, delHH(:, :, 1), UU) - call wham_get_deleig_a(del_eig(:, 2), eig, delHH(:, :, 2), UU) - call wham_get_deleig_a(del_eig(:, 3), eig, delHH(:, :, 3), UU) + call get_HH_R(dis_manifold, kpt_latt, print_output, wigner_seitz, HH_R, u_matrix, v_matrix, & + eigval, real_lattice, scissors_shift, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, seedname, stdout, comm) + + call pw90common_fourier_R_to_k(ws_region, wannier_data, ws_distance, wigner_seitz, HH, HH_R, & + kpt, real_lattice, mp_grid, 0, num_wann, seedname, stdout) + call utility_diagonalize(HH, num_wann, eig, UU, stdout, seedname) + call pw90common_fourier_R_to_k(ws_region, wannier_data, ws_distance, wigner_seitz, & + delHH(:, :, 1), HH_R, kpt, real_lattice, mp_grid, 1, num_wann, & + seedname, stdout) + call pw90common_fourier_R_to_k(ws_region, wannier_data, ws_distance, wigner_seitz, & + delHH(:, :, 2), HH_R, kpt, real_lattice, mp_grid, 2, num_wann, & + seedname, stdout) + call pw90common_fourier_R_to_k(ws_region, wannier_data, ws_distance, wigner_seitz, & + delHH(:, :, 3), HH_R, kpt, real_lattice, mp_grid, 3, num_wann, & + seedname, stdout) + call wham_get_deleig_a(del_eig(:, 1), eig, delHH(:, :, 1), UU, num_wann, pw90_band_deriv_degen, & + stdout, seedname) + call wham_get_deleig_a(del_eig(:, 2), eig, delHH(:, :, 2), UU, num_wann, pw90_band_deriv_degen, & + stdout, seedname) + call wham_get_deleig_a(del_eig(:, 3), eig, delHH(:, :, 3), UU, num_wann, pw90_band_deriv_degen, & + stdout, seedname) end subroutine wham_get_eig_deleig - subroutine wham_get_eig_deleig_TB_conv(kpt, eig, del_eig, delHH, UU) + !================================================! + subroutine wham_get_eig_deleig_TB_conv(pw90_band_deriv_degen, delHH, UU, eig, del_eig, num_wann, & + seedname, stdout) + !================================================! ! modified version of wham_get_eig_deleig for the TB convention ! avoids recalculating delHH and UU, works with input values - + ! !! Given a k point, this function returns eigenvalues E and !! derivatives of the eigenvalues dE/dk_a, using wham_get_deleig_a ! - use w90_parameters, only: num_wann - use w90_get_oper, only: HH_R, get_HH_R - use w90_postw90_common, only: pw90common_fourier_R_to_k - use w90_utility, only: utility_diagonalize + !================================================! + + use w90_postw90_types, only: pw90_band_deriv_degen_type + + ! arguments + type(pw90_band_deriv_degen_type), intent(in) :: pw90_band_deriv_degen - real(kind=dp), dimension(3), intent(in) :: kpt - !! the three coordinates of the k point vector (in relative coordinates) - real(kind=dp), intent(out) :: del_eig(num_wann, 3) - real(kind=dp), intent(in) :: eig(num_wann) - complex(kind=dp), dimension(:, :, :), intent(in) :: delHH + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + + real(kind=dp), intent(out) :: del_eig(num_wann, 3) + real(kind=dp), intent(in) :: eig(num_wann) + + complex(kind=dp), intent(in) :: delHH(:, :, :) !! the delHH matrix (derivative of H) at kpt - complex(kind=dp), dimension(:, :), intent(in) :: UU + complex(kind=dp), intent(in) :: UU(:, :) !! the rotation matrix that gives the eigenvectors of HH - call wham_get_deleig_a(del_eig(:, 1), eig, delHH(:, :, 1), UU) - call wham_get_deleig_a(del_eig(:, 2), eig, delHH(:, :, 2), UU) - call wham_get_deleig_a(del_eig(:, 3), eig, delHH(:, :, 3), UU) + character(len=50), intent(in) :: seedname + + call wham_get_deleig_a(del_eig(:, 1), eig, delHH(:, :, 1), UU, num_wann, pw90_band_deriv_degen, & + stdout, seedname) + call wham_get_deleig_a(del_eig(:, 2), eig, delHH(:, :, 2), UU, num_wann, pw90_band_deriv_degen, & + stdout, seedname) + call wham_get_deleig_a(del_eig(:, 3), eig, delHH(:, :, 3), UU, num_wann, pw90_band_deriv_degen, & + stdout, seedname) end subroutine wham_get_eig_deleig_TB_conv - subroutine wham_get_eig_UU_HH_JJlist(kpt, eig, UU, HH, JJp_list, JJm_list, occ) - !========================================================! - ! ! + !================================================! + subroutine wham_get_eig_UU_HH_JJlist(dis_manifold, fermi_energy_list, kpt_latt, ws_region, & + print_output, wannier_data, ws_distance, wigner_seitz, HH, & + HH_R, JJm_list, JJp_list, u_matrix, UU, v_matrix, eig, & + eigval, kpt, real_lattice, scissors_shift, mp_grid, & + num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, stdout, & + comm, occ) + !================================================! + ! !! Wrapper routine used to reduce number of Fourier calls - ! Added the optional occ parameter ! - !========================================================! + ! Added the optional occ parameter + ! + !================================================! - use w90_parameters, only: num_wann - use w90_get_oper, only: HH_R, get_HH_R - use w90_postw90_common, only: pw90common_fourier_R_to_k_new + use w90_constants, only: dp + use w90_postw90_common, only: pw90common_fourier_R_to_k_new_second_d, & + pw90common_fourier_R_to_k_new + use w90_get_oper, only: get_HH_R use w90_utility, only: utility_diagonalize - - real(kind=dp), dimension(3), intent(in) :: kpt - real(kind=dp), intent(out) :: eig(num_wann) - complex(kind=dp), dimension(:, :), intent(out) :: UU - complex(kind=dp), dimension(:, :), intent(out) :: HH - complex(kind=dp), dimension(:, :, :, :), intent(out) :: JJp_list - complex(kind=dp), dimension(:, :, :, :), intent(out) :: JJm_list - real(kind=dp), intent(in), optional, dimension(:) :: occ - + use w90_types, only: print_output_type, wannier_data_type, dis_manifold_type, & + ws_region_type, ws_distance_type + use w90_comms, only: w90comm_type, mpirank + use w90_postw90_types, only: wigner_seitz_type + + implicit none + + ! arguments + type(dis_manifold_type), intent(in) :: dis_manifold + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + real(kind=dp), intent(in) :: kpt_latt(:, :) + type(print_output_type), intent(in) :: print_output + type(ws_region_type), intent(in) :: ws_region + type(w90comm_type), intent(in) :: comm + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + integer, intent(in) :: num_wann, num_kpts, num_bands, num_valence_bands + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: kpt(3), real_lattice(3, 3) + real(kind=dp), intent(out) :: eig(:) + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: scissors_shift + real(kind=dp), intent(in), optional :: occ(:) + + complex(kind=dp), intent(out) :: UU(:, :) + complex(kind=dp), intent(out) :: HH(:, :) + complex(kind=dp), intent(out) :: JJp_list(:, :, :, :) + complex(kind=dp), intent(out) :: JJm_list(:, :, :, :) + complex(kind=dp), intent(in) :: u_matrix(:, :, :), v_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + logical, intent(in) :: effective_model + + ! local variables integer :: i complex(kind=dp), allocatable :: delHH(:, :, :) - call get_HH_R + call get_HH_R(dis_manifold, kpt_latt, print_output, wigner_seitz, HH_R, u_matrix, v_matrix, & + eigval, real_lattice, scissors_shift, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, seedname, stdout, comm) allocate (delHH(num_wann, num_wann, 3)) - call pw90common_fourier_R_to_k_new(kpt, HH_R, OO=HH, & - OO_dx=delHH(:, :, 1), & - OO_dy=delHH(:, :, 2), & + call pw90common_fourier_R_to_k_new(ws_region, wannier_data, ws_distance, wigner_seitz, HH_R, & + kpt, real_lattice, mp_grid, num_wann, seedname, & + stdout, OO=HH, OO_dx=delHH(:, :, 1), OO_dy=delHH(:, :, 2), & OO_dz=delHH(:, :, 3)) - call utility_diagonalize(HH, num_wann, eig, UU) + + call utility_diagonalize(HH, num_wann, eig, UU, stdout, seedname) do i = 1, 3 if (present(occ)) then - call wham_get_JJp_JJm_list(delHH(:, :, i), UU, eig, JJp_list(:, :, :, i), JJm_list(:, :, :, i), occ=occ) + call wham_get_JJp_JJm_list(delHH(:, :, i), UU, eig, JJp_list(:, :, :, i), & + JJm_list(:, :, :, i), num_wann, fermi_energy_list, occ=occ) else - call wham_get_JJp_JJm_list(delHH(:, :, i), UU, eig, JJp_list(:, :, :, i), JJm_list(:, :, :, i)) + call wham_get_JJp_JJm_list(delHH(:, :, i), UU, eig, JJp_list(:, :, :, i), & + JJm_list(:, :, :, i), num_wann, fermi_energy_list) endif enddo end subroutine wham_get_eig_UU_HH_JJlist - subroutine wham_get_eig_UU_HH_AA_sc_TB_conv(kpt, eig, UU, HH, HH_da, HH_dadb) - !========================================================! - ! ! + !================================================! + subroutine wham_get_eig_UU_HH_AA_sc_TB_conv(pw90_berry, dis_manifold, kmesh_info, kpt_latt, & + ws_region, print_output, wannier_data, ws_distance, & + wigner_seitz, AA_R, HH, HH_da, HH_dadb, HH_R, & + u_matrix, UU, v_matrix, eig, eigval, kpt, & + real_lattice, scissors_shift, mp_grid, & + num_bands, num_kpts, num_wann, num_valence_bands, & + effective_model, have_disentangled, seedname, & + stdout, comm) + !================================================! + ! ! modified version of wham_get_eig_UU_HH_AA_sc, calls routines ! satisfying the TB phase convention - ! ! - !========================================================! + ! + !================================================! - use w90_parameters, only: num_wann - use w90_get_oper, only: HH_R, get_HH_R, AA_R, get_AA_R - use w90_postw90_common, only: pw90common_fourier_R_to_k_new_second_d, & - pw90common_fourier_R_to_k_new_second_d_TB_conv + use w90_constants, only: dp + use w90_get_oper, only: get_HH_R, get_AA_R + use w90_postw90_common, only: pw90common_fourier_R_to_k_new_second_d_TB_conv + use w90_types, only: print_output_type, wannier_data_type, dis_manifold_type, & + kmesh_info_type, ws_region_type, ws_distance_type use w90_utility, only: utility_diagonalize - - real(kind=dp), dimension(3), intent(in) :: kpt - real(kind=dp), intent(out) :: eig(num_wann) - complex(kind=dp), dimension(:, :), intent(out) :: UU - complex(kind=dp), dimension(:, :), intent(out) :: HH - complex(kind=dp), dimension(:, :, :), intent(out) :: HH_da - complex(kind=dp), dimension(:, :, :, :), intent(out) :: HH_dadb - - integer :: i - - call get_HH_R - call get_AA_R - - call pw90common_fourier_R_to_k_new_second_d_TB_conv(kpt, HH_R, AA_R, OO=HH, & - OO_da=HH_da(:, :, :), & + use w90_postw90_types, only: pw90_berry_mod_type, wigner_seitz_type + use w90_comms, only: w90comm_type, mpirank + + implicit none + + ! arguments + type(pw90_berry_mod_type), intent(in) :: pw90_berry + type(dis_manifold_type), intent(in) :: dis_manifold + type(kmesh_info_type), intent(in) :: kmesh_info + real(kind=dp), intent(in) :: kpt_latt(:, :) + type(print_output_type), intent(in) :: print_output + type(ws_region_type), intent(in) :: ws_region + type(w90comm_type), intent(in) :: comm + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + integer, intent(in) :: num_wann, num_kpts, num_bands, num_valence_bands + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + + real(kind=dp), intent(out) :: eig(num_wann) + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: kpt(3), real_lattice(3, 3) + real(kind=dp), intent(in) :: scissors_shift + + complex(kind=dp), intent(out) :: UU(:, :) + complex(kind=dp), intent(out) :: HH(:, :) + complex(kind=dp), intent(out) :: HH_da(:, :, :) + complex(kind=dp), intent(out) :: HH_dadb(:, :, :, :) + complex(kind=dp), intent(in) :: u_matrix(:, :, :), v_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + complex(kind=dp), allocatable, intent(inout) :: AA_R(:, :, :, :) ! <0n|r|Rm> + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + logical, intent(in) :: effective_model + + call get_HH_R(dis_manifold, kpt_latt, print_output, wigner_seitz, HH_R, u_matrix, v_matrix, & + eigval, real_lattice, scissors_shift, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, seedname, stdout, comm) + + call get_AA_R(pw90_berry, dis_manifold, kmesh_info, kpt_latt, print_output, AA_R, HH_R, & + v_matrix, eigval, wigner_seitz%irvec, wigner_seitz%nrpts, num_bands, num_kpts, & + num_wann, effective_model, have_disentangled, seedname, stdout, comm) + + call pw90common_fourier_R_to_k_new_second_d_TB_conv(kpt, HH_R, AA_R, num_wann, ws_region, & + wannier_data, real_lattice, mp_grid, & + ws_distance, wigner_seitz, stdout, & + seedname, OO=HH, OO_da=HH_da(:, :, :), & OO_dadb=HH_dadb(:, :, :, :)) - call utility_diagonalize(HH, num_wann, eig, UU) + call utility_diagonalize(HH, num_wann, eig, UU, stdout, seedname) end subroutine wham_get_eig_UU_HH_AA_sc_TB_conv - subroutine wham_get_eig_UU_HH_AA_sc(kpt, eig, UU, HH, HH_da, HH_dadb) - !========================================================! - ! ! + subroutine wham_get_eig_UU_HH_AA_sc(dis_manifold, kpt_latt, ws_region, print_output, & + wannier_data, ws_distance, wigner_seitz, HH, HH_da, HH_dadb, & + HH_R, u_matrix, UU, v_matrix, eig, eigval, kpt, & + real_lattice, scissors_shift, mp_grid, num_bands, num_kpts, & + num_wann, num_valence_bands, effective_model, & + have_disentangled, seedname, stdout, comm) + !================================================! + ! !! Wrapper routine used to reduce number of Fourier calls - ! ! - !========================================================! + ! + !================================================! - use w90_parameters, only: num_wann - use w90_get_oper, only: HH_R, get_HH_R + use w90_constants, only: dp + use w90_get_oper, only: get_HH_R use w90_postw90_common, only: pw90common_fourier_R_to_k_new_second_d use w90_utility, only: utility_diagonalize - - real(kind=dp), dimension(3), intent(in) :: kpt - real(kind=dp), intent(out) :: eig(num_wann) - complex(kind=dp), dimension(:, :), intent(out) :: UU - complex(kind=dp), dimension(:, :), intent(out) :: HH - complex(kind=dp), dimension(:, :, :), intent(out) :: HH_da - complex(kind=dp), dimension(:, :, :, :), intent(out) :: HH_dadb - - integer :: i - - call get_HH_R - - call pw90common_fourier_R_to_k_new_second_d(kpt, HH_R, OO=HH, & - OO_da=HH_da(:, :, :), & + use w90_comms, only: w90comm_type, mpirank + use w90_types, only: print_output_type, wannier_data_type, dis_manifold_type, & + ws_region_type, ws_distance_type + use w90_utility, only: utility_diagonalize + use w90_postw90_types, only: wigner_seitz_type + + implicit none + + ! arguments + type(dis_manifold_type), intent(in) :: dis_manifold + real(kind=dp), intent(in) :: kpt_latt(:, :) + type(print_output_type), intent(in) :: print_output + type(ws_region_type), intent(in) :: ws_region + type(w90comm_type), intent(in) :: comm + type(wannier_data_type), intent(in) :: wannier_data + type(wigner_seitz_type), intent(inout) :: wigner_seitz + type(ws_distance_type), intent(inout) :: ws_distance + + integer, intent(in) :: num_wann, num_kpts, num_bands, num_valence_bands + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + + real(kind=dp), intent(out) :: eig(num_wann) + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: kpt(3), real_lattice(3, 3) + real(kind=dp), intent(in) :: scissors_shift + + complex(kind=dp), intent(out) :: UU(:, :) + complex(kind=dp), intent(out) :: HH(:, :) + complex(kind=dp), intent(out) :: HH_da(:, :, :) + complex(kind=dp), intent(out) :: HH_dadb(:, :, :, :) + complex(kind=dp), intent(in) :: u_matrix(:, :, :), v_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: HH_R(:, :, :) ! <0n|r|Rm> + + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + logical, intent(in) :: effective_model + + call get_HH_R(dis_manifold, kpt_latt, print_output, wigner_seitz, HH_R, u_matrix, v_matrix, & + eigval, real_lattice, scissors_shift, num_bands, num_kpts, num_wann, & + num_valence_bands, effective_model, have_disentangled, seedname, stdout, comm) + + call pw90common_fourier_R_to_k_new_second_d(kpt, HH_R, num_wann, ws_region, wannier_data, & + real_lattice, mp_grid, ws_distance, wigner_seitz, & + stdout, seedname, OO=HH, OO_da=HH_da(:, :, :), & OO_dadb=HH_dadb(:, :, :, :)) - call utility_diagonalize(HH, num_wann, eig, UU) + call utility_diagonalize(HH, num_wann, eig, UU, stdout, seedname) end subroutine wham_get_eig_UU_HH_AA_sc diff --git a/src/readwrite.F90 b/src/readwrite.F90 new file mode 100644 index 000000000..496e48fd8 --- /dev/null +++ b/src/readwrite.F90 @@ -0,0 +1,3643 @@ +!-*- mode: F90 -*-! +!------------------------------------------------------------! +! This file is distributed as part of the Wannier90 code and ! +! under the terms of the GNU General Public License. See the ! +! file `LICENSE' in the root directory of the Wannier90 ! +! distribution, or http://www.gnu.org/copyleft/gpl.txt ! +! ! +! The webpage of the Wannier90 code is www.wannier.org ! +! ! +! The Wannier90 code is hosted on GitHub: ! +! ! +! https://github.com/wannier-developers/wannier90 ! +!------------------------------------------------------------! +! ! +! w90_readwrite: input parsing and information printout ! +! routines for input/output for data used/needed by ! +! *both* wannier90.x and postw90.x ! +! ! +!------------------------------------------------------------! + +module w90_readwrite + + !! Common read/write routines for data needed by both + !! wannier90.x and postw90.x executables + + use w90_constants, only: dp + use w90_io, only: maxlen + use w90_types + + implicit none + + private + + ! Private data for processing input file + integer :: num_lines + character(len=maxlen), allocatable :: in_data(:) + + public :: w90_readwrite_chkpt_dist + public :: w90_readwrite_dealloc + public :: w90_readwrite_get_convention_type + public :: w90_readwrite_get_smearing_type + public :: w90_readwrite_lib_set_atoms + public :: w90_readwrite_read_chkpt + public :: w90_readwrite_write_header + ! for postw90 parameters + public :: w90_readwrite_get_block_length + public :: w90_readwrite_get_centre_constraints + public :: w90_readwrite_get_keyword + public :: w90_readwrite_get_keyword_block + public :: w90_readwrite_get_keyword_vector + public :: w90_readwrite_get_projections + public :: w90_readwrite_get_range_vector + public :: w90_readwrite_get_smearing_index + public :: w90_readwrite_get_vector_length + public :: w90_readwrite_in_file + public :: w90_readwrite_set_kmesh + public :: w90_readwrite_uppercase + ! common read routines + public :: w90_readwrite_clean_infile + public :: w90_readwrite_clear_keywords + public :: w90_readwrite_read_algorithm_control + public :: w90_readwrite_read_atoms + public :: w90_readwrite_read_devel + public :: w90_readwrite_read_dis_manifold + public :: w90_readwrite_read_eigvals + public :: w90_readwrite_read_exclude_bands + public :: w90_readwrite_read_fermi_energy + public :: w90_readwrite_read_final_alloc + public :: w90_readwrite_read_gamma_only + public :: w90_readwrite_read_kmesh_data + public :: w90_readwrite_read_kpath + public :: w90_readwrite_read_kpoints + public :: w90_readwrite_read_lattice + public :: w90_readwrite_read_mp_grid + public :: w90_readwrite_read_num_bands + public :: w90_readwrite_read_num_wann + public :: w90_readwrite_read_system + public :: w90_readwrite_read_units + public :: w90_readwrite_read_verbosity + public :: w90_readwrite_read_ws_data + + private :: clear_block + +contains + + !================================================! + subroutine w90_readwrite_read_verbosity(print_output, stdout, seedname) + implicit none + type(print_output_type), intent(inout) :: print_output + logical :: found + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + + print_output%timing_level = 1 ! Verbosity of timing output info + call w90_readwrite_get_keyword(stdout, seedname, 'timing_level', found, i_value=print_output%timing_level) + + print_output%iprint = 1 ! Verbosity + call w90_readwrite_get_keyword(stdout, seedname, 'iprint', found, i_value=print_output%iprint) + + end subroutine w90_readwrite_read_verbosity + + subroutine w90_readwrite_read_algorithm_control(optimisation, stdout, seedname) + implicit none + integer, intent(inout) :: optimisation + logical :: found + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + + optimisation = 3 ! Verbosity + call w90_readwrite_get_keyword(stdout, seedname, 'optimisation', found, i_value=optimisation) + + end subroutine w90_readwrite_read_algorithm_control + + subroutine w90_readwrite_read_units(lenconfac, length_unit, energy_unit, bohr, stdout, seedname) + use w90_io, only: io_error + implicit none + real(kind=dp), intent(out) :: lenconfac + integer, intent(in) :: stdout + character(len=*), intent(out) :: length_unit + character(len=*), intent(out) :: energy_unit + character(len=50), intent(in) :: seedname + real(kind=dp), intent(in) :: bohr + logical :: found + + energy_unit = 'ev' + call w90_readwrite_get_keyword(stdout, seedname, 'energy_unit', found, c_value=energy_unit) + + length_unit = 'ang' + lenconfac = 1.0_dp + call w90_readwrite_get_keyword(stdout, seedname, 'length_unit', found, c_value=length_unit) + if (length_unit .ne. 'ang' .and. length_unit .ne. 'bohr') & + call io_error('Error: value of length_unit not recognised in w90_wannier90_readwrite_read', stdout, seedname) + if (length_unit .eq. 'bohr') lenconfac = 1.0_dp/bohr + end subroutine w90_readwrite_read_units + + subroutine w90_readwrite_read_num_wann(num_wann, stdout, seedname) + use w90_io, only: io_error + implicit none + integer, intent(in) :: stdout + integer, intent(out) :: num_wann + character(len=50), intent(in) :: seedname + + logical :: found + + num_wann = -99 + call w90_readwrite_get_keyword(stdout, seedname, 'num_wann', found, i_value=num_wann) + if (.not. found) call io_error('Error: You must specify num_wann', stdout, seedname) + if (num_wann <= 0) call io_error('Error: num_wann must be greater than zero', stdout, seedname) + end subroutine w90_readwrite_read_num_wann + + subroutine w90_readwrite_read_exclude_bands(exclude_bands, num_exclude_bands, stdout, seedname) + use w90_io, only: io_error + implicit none + + integer, allocatable, intent(inout) :: exclude_bands(:) + integer, intent(out) :: num_exclude_bands + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + + integer :: ierr + logical :: found + + num_exclude_bands = 0 + call w90_readwrite_get_range_vector(stdout, seedname, 'exclude_bands', found, & + num_exclude_bands, lcount=.true.) + if (found) then + if (num_exclude_bands < 1) call io_error('Error: problem reading exclude_bands', stdout, seedname) + if (allocated(exclude_bands)) deallocate (exclude_bands) + allocate (exclude_bands(num_exclude_bands), stat=ierr) + if (ierr /= 0) call io_error('Error allocating exclude_bands in w90_wannier90_readwrite_read', stdout, seedname) + call w90_readwrite_get_range_vector(stdout, seedname, 'exclude_bands', found, & + num_exclude_bands, .false., exclude_bands) + if (any(exclude_bands < 1)) & + call io_error('Error: exclude_bands must contain positive numbers', stdout, seedname) + end if + end subroutine w90_readwrite_read_exclude_bands + + subroutine w90_readwrite_read_num_bands(pw90_effective_model, library, num_exclude_bands, num_bands, & + num_wann, library_w90_wannier90_readwrite_read_first_pass, stdout, seedname) + use w90_io, only: io_error + implicit none + logical, intent(in) :: pw90_effective_model, library + integer, intent(in) :: num_exclude_bands + integer, intent(inout) :: num_bands + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + logical, intent(in) :: library_w90_wannier90_readwrite_read_first_pass + character(len=50), intent(in) :: seedname + + integer :: i_temp + logical :: found + + call w90_readwrite_get_keyword(stdout, seedname, 'num_bands', found, i_value=i_temp) + if (found .and. library) write (stdout, '(/a)') ' Ignoring in input file' + if (.not. library .and. .not. pw90_effective_model) then + if (found) num_bands = i_temp + if (.not. found) num_bands = num_wann + end if + ! GP: I subtract it here, but only the first time when I pass the total number of bands + ! In later calls, I need to pass instead num_bands already subtracted. + if (library .and. library_w90_wannier90_readwrite_read_first_pass) num_bands = num_bands - num_exclude_bands + if (.not. pw90_effective_model) then + if (found .and. num_bands < num_wann) then + write (stdout, *) 'num_bands', num_bands + write (stdout, *) 'num_wann', num_wann + call io_error('Error: num_bands must be greater than or equal to num_wann', stdout, seedname) + endif + endif + end subroutine w90_readwrite_read_num_bands + + subroutine w90_readwrite_read_devel(devel_flag, stdout, seedname) + implicit none + integer, intent(in) :: stdout + character(len=*), intent(out) :: devel_flag + character(len=50), intent(in) :: seedname + + logical :: found + + devel_flag = ' ' + call w90_readwrite_get_keyword(stdout, seedname, 'devel_flag', found, c_value=devel_flag) + end subroutine w90_readwrite_read_devel + + subroutine w90_readwrite_read_gamma_only(gamma_only, num_kpts, library, stdout, seedname) + use w90_io, only: io_error + implicit none + integer, intent(in) :: stdout + logical, intent(inout) :: gamma_only + integer, intent(in) :: num_kpts + logical, intent(in) :: library + character(len=50), intent(in) :: seedname + + logical :: found, ltmp + + ltmp = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'gamma_only', found, l_value=ltmp) + if (.not. library) then + gamma_only = ltmp + if (gamma_only .and. (num_kpts .ne. 1)) & + call io_error('Error: gamma_only is true, but num_kpts > 1', stdout, seedname) + else + if (found) write (stdout, '(a)') ' Ignoring in input file' + endif + end subroutine w90_readwrite_read_gamma_only + + subroutine w90_readwrite_read_mp_grid(pw90_effective_model, library, mp_grid, num_kpts, stdout, seedname) + use w90_io, only: io_error + implicit none + integer, intent(in) :: stdout + logical, intent(in) :: pw90_effective_model, library + integer, intent(inout) :: mp_grid(3), num_kpts + character(len=50), intent(in) :: seedname + + integer :: iv_temp(3) + logical :: found + + call w90_readwrite_get_keyword_vector(stdout, seedname, 'mp_grid', found, 3, i_value=iv_temp) + if (found .and. library) write (stdout, '(a)') ' Ignoring in input file' + if (.not. library .and. .not. pw90_effective_model) then + if (found) mp_grid = iv_temp + if (.not. found) then + call io_error('Error: You must specify dimensions of the Monkhorst-Pack grid by setting mp_grid', stdout, seedname) + elseif (any(mp_grid < 1)) then + call io_error('Error: mp_grid must be greater than zero', stdout, seedname) + end if + num_kpts = mp_grid(1)*mp_grid(2)*mp_grid(3) + end if + end subroutine w90_readwrite_read_mp_grid + + subroutine w90_readwrite_read_system(library, w90_system, stdout, seedname) + use w90_io, only: io_error + implicit none + integer, intent(in) :: stdout + logical, intent(in) :: library + type(w90_system_type), intent(inout) :: w90_system + character(len=50), intent(in) :: seedname + + logical :: found, ltmp + + ltmp = .false. ! by default our WF are not spinors + call w90_readwrite_get_keyword(stdout, seedname, 'spinors', found, l_value=ltmp) + if (.not. library) then + w90_system%spinors = ltmp + else + if (found) write (stdout, '(a)') ' Ignoring in input file' + endif +! if(spinors .and. (2*(num_wann/2))/=num_wann) & +! call io_error('Error: For spinor WF num_wann must be even') + + ! We need to know if the bands are double degenerate due to spin, e.g. when + ! calculating the DOS + if (w90_system%spinors) then + w90_system%num_elec_per_state = 1 + else + w90_system%num_elec_per_state = 2 + endif + call w90_readwrite_get_keyword(stdout, seedname, 'num_elec_per_state', found, & + i_value=w90_system%num_elec_per_state) + if ((w90_system%num_elec_per_state /= 1) .and. (w90_system%num_elec_per_state /= 2)) & + call io_error('Error: num_elec_per_state can be only 1 or 2', stdout, seedname) + if (w90_system%spinors .and. w90_system%num_elec_per_state /= 1) & + call io_error('Error: when spinors = T num_elec_per_state must be 1', stdout, seedname) + + ! set to a negative default value + w90_system%num_valence_bands = -99 + call w90_readwrite_get_keyword(stdout, seedname, 'num_valence_bands', found, i_value=w90_system%num_valence_bands) + if (found .and. (w90_system%num_valence_bands .le. 0)) & + call io_error('Error: num_valence_bands should be greater than zero', stdout, seedname) + ! there is a check on this parameter later + + end subroutine w90_readwrite_read_system + + subroutine w90_readwrite_read_kpath(library, kpoint_path, ok, bands_plot, stdout, seedname) + use w90_io, only: io_error + implicit none + logical, intent(in) :: library, bands_plot + type(kpoint_path_type), intent(out) :: kpoint_path + integer, intent(in) :: stdout + logical, intent(out) :: ok + character(len=50), intent(in) :: seedname + + integer :: i_temp, ierr, bands_num_spec_points + logical :: found + + bands_num_spec_points = 0 + call w90_readwrite_get_block_length(stdout, seedname, 'kpoint_path', found, i_temp, library) + if (found) then + ok = .true. + bands_num_spec_points = i_temp*2 + if (allocated(kpoint_path%labels)) deallocate (kpoint_path%labels) + allocate (kpoint_path%labels(bands_num_spec_points), stat=ierr) + if (ierr /= 0) call io_error('Error allocating labels in w90_wannier90_readwrite_read', stdout, seedname) + if (allocated(kpoint_path%points)) deallocate (kpoint_path%points) + allocate (kpoint_path%points(3, bands_num_spec_points), stat=ierr) + if (ierr /= 0) call io_error('Error allocating points in w90_wannier90_readwrite_read', stdout, seedname) + call w90_readwrite_get_keyword_kpath(kpoint_path, stdout, seedname) + else + ok = .false. + end if + kpoint_path%num_points_first_segment = 100 + call w90_readwrite_get_keyword(stdout, seedname, 'bands_num_points', found, & + i_value=kpoint_path%num_points_first_segment) + ! checks + if (bands_plot) then + if (kpoint_path%num_points_first_segment < 0) & + call io_error('Error: bands_num_points must be positive', stdout, seedname) + endif + end subroutine w90_readwrite_read_kpath + + subroutine w90_readwrite_read_fermi_energy(found_fermi_energy, fermi_energy_list, stdout, seedname) + use w90_io, only: io_error + implicit none + logical, intent(out) :: found_fermi_energy + real(kind=dp), allocatable, intent(out) :: fermi_energy_list(:) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + + real(kind=dp) :: fermi_energy + logical :: fermi_energy_scan + real(kind=dp) :: fermi_energy_min + real(kind=dp) :: fermi_energy_max + real(kind=dp) :: fermi_energy_step + integer :: i, ierr, n + logical :: found + + n = 0 + found_fermi_energy = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'fermi_energy', found, r_value=fermi_energy) + if (found) then + found_fermi_energy = .true. + n = 1 + endif + + fermi_energy_scan = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'fermi_energy_min', found, r_value=fermi_energy_min) + if (found) then + if (found_fermi_energy) call io_error( & + 'Error: Cannot specify both fermi_energy and fermi_energy_min', stdout, seedname) + fermi_energy_scan = .true. + fermi_energy_max = fermi_energy_min + 1.0_dp + call w90_readwrite_get_keyword(stdout, seedname, 'fermi_energy_max', found, & + r_value=fermi_energy_max) + if (found .and. fermi_energy_max <= fermi_energy_min) call io_error( & + 'Error: fermi_energy_max must be larger than fermi_energy_min', stdout, seedname) + fermi_energy_step = 0.01_dp + call w90_readwrite_get_keyword(stdout, seedname, 'fermi_energy_step', found, & + r_value=fermi_energy_step) + if (found .and. fermi_energy_step <= 0.0_dp) call io_error( & + 'Error: fermi_energy_step must be positive', stdout, seedname) + n = nint(abs((fermi_energy_max - fermi_energy_min)/fermi_energy_step)) + 1 + endif + + if (found_fermi_energy) then + if (allocated(fermi_energy_list)) deallocate (fermi_energy_list) + allocate (fermi_energy_list(1), stat=ierr) + fermi_energy_list(1) = fermi_energy + elseif (fermi_energy_scan) then + if (n .eq. 1) then + fermi_energy_step = 0.0_dp + else + fermi_energy_step = (fermi_energy_max - fermi_energy_min)/real(n - 1, dp) + endif + if (allocated(fermi_energy_list)) deallocate (fermi_energy_list) + allocate (fermi_energy_list(n), stat=ierr) + do i = 1, n + fermi_energy_list(i) = fermi_energy_min + (i - 1)*fermi_energy_step + enddo +!! elseif(nfermi==0) then +!! ! This happens when both found_fermi_energy=.false. and +!! ! fermi_energy_scan=.false. Functionalities that require +!! ! specifying a Fermi level should give an error message +!! allocate(fermi_energy_list(1),stat=ierr) ! helps streamline things +!! +!! AAM_2017-03-27: if nfermi is zero (ie, fermi_energy* parameters are not set in input file) +!! then allocate fermi_energy_list with length 1 and set to zero as default. + else + if (allocated(fermi_energy_list)) deallocate (fermi_energy_list) + allocate (fermi_energy_list(1), stat=ierr) + fermi_energy_list(1) = 0.0_dp + endif + if (ierr /= 0) call io_error( & + 'Error allocating fermi_energy_list in w90_wannier90_readwrite_read', stdout, seedname) + end subroutine w90_readwrite_read_fermi_energy + + subroutine w90_readwrite_read_ws_data(ws_region, stdout, seedname) + use w90_io, only: io_error + implicit none + type(ws_region_type), intent(inout) :: ws_region + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + + integer :: i + logical :: found + + ws_region%use_ws_distance = .true. + call w90_readwrite_get_keyword(stdout, seedname, 'use_ws_distance', found, l_value=ws_region%use_ws_distance) + + ws_region%ws_distance_tol = 1.e-5_dp + call w90_readwrite_get_keyword(stdout, seedname, 'ws_distance_tol', found, r_value=ws_region%ws_distance_tol) + + ws_region%ws_search_size = 2 + + call w90_readwrite_get_vector_length(stdout, seedname, 'ws_search_size', found, length=i) + if (found) then + if (i .eq. 1) then + call w90_readwrite_get_keyword_vector(stdout, seedname, 'ws_search_size', found, 1, & + i_value=ws_region%ws_search_size) + ws_region%ws_search_size(2) = ws_region%ws_search_size(1) + ws_region%ws_search_size(3) = ws_region%ws_search_size(1) + elseif (i .eq. 3) then + call w90_readwrite_get_keyword_vector(stdout, seedname, 'ws_search_size', found, 3, & + i_value=ws_region%ws_search_size) + else + call io_error('Error: ws_search_size must be provided as either one integer or a vector of three integers', & + stdout, seedname) + end if + if (any(ws_region%ws_search_size <= 0)) & + call io_error('Error: ws_search_size elements must be greater than zero', stdout, seedname) + end if + end subroutine w90_readwrite_read_ws_data + + subroutine w90_readwrite_read_eigvals(pw90_effective_model, pw90_boltzwann, pw90_geninterp, w90_plot, & + disentanglement, eig_found, eigval, library, postproc_setup, & + num_bands, num_kpts, stdout, seedname) + + use w90_io, only: io_file_unit, io_error + + implicit none + integer, intent(in) :: num_bands, num_kpts + integer, intent(in) :: stdout + real(kind=dp), allocatable, intent(inout) :: eigval(:, :) + character(len=50), intent(in) :: seedname + logical, intent(in) :: disentanglement, library, postproc_setup + logical, intent(in) :: pw90_effective_model, pw90_boltzwann, pw90_geninterp, w90_plot + logical, intent(out) :: eig_found + integer :: i, j, k, n, eig_unit, ierr + + ! Read the eigenvalues from wannier.eig + eig_found = .false. + if (.not. library .and. .not. pw90_effective_model) then + + if (.not. postproc_setup) then + inquire (file=trim(seedname)//'.eig', exist=eig_found) + if (.not. eig_found) then + if (disentanglement) then + call io_error('No '//trim(seedname)//'.eig file found. Needed for disentanglement', stdout, seedname) + else if ((w90_plot .or. pw90_boltzwann .or. pw90_geninterp)) then + call io_error('No '//trim(seedname)//'.eig file found. Needed for interpolation', stdout, seedname) + end if + else + ! Allocate only here + allocate (eigval(num_bands, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating eigval in w90_wannier90_readwrite_read', stdout, seedname) + + eig_unit = io_file_unit() + open (unit=eig_unit, file=trim(seedname)//'.eig', form='formatted', status='old', err=105) + do k = 1, num_kpts + do n = 1, num_bands + read (eig_unit, *, err=106, end=106) i, j, eigval(n, k) + if ((i .ne. n) .or. (j .ne. k)) then + write (stdout, '(a)') 'Found a mismatch in '//trim(seedname)//'.eig' + write (stdout, '(a,i0,a,i0)') 'Wanted band : ', n, ' found band : ', i + write (stdout, '(a,i0,a,i0)') 'Wanted kpoint: ', k, ' found kpoint: ', j + write (stdout, '(a)') ' ' + write (stdout, '(a)') 'A common cause of this error is using the wrong' + write (stdout, '(a)') 'number of bands. Check your input files.' + write (stdout, '(a)') 'If your pseudopotentials have shallow core states remember' + write (stdout, '(a)') 'to account for these electrons.' + write (stdout, '(a)') ' ' + call io_error('w90_wannier90_readwrite_read: mismatch in '//trim(seedname)//'.eig', stdout, seedname) + end if + enddo + end do + close (eig_unit) + end if + end if + end if + + if (library .and. allocated(eigval)) eig_found = .true. + + return + +105 call io_error('Error: Problem opening eigenvalue file '//trim(seedname)//'.eig', stdout, seedname) +106 call io_error('Error: Problem reading eigenvalue file '//trim(seedname)//'.eig', stdout, seedname) + + end subroutine w90_readwrite_read_eigvals + + subroutine w90_readwrite_read_dis_manifold(eig_found, dis_manifold, stdout, seedname) + use w90_io, only: io_error + implicit none + logical, intent(in) :: eig_found + type(dis_manifold_type), intent(inout) :: dis_manifold + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + logical :: found, found2 + + call w90_readwrite_get_keyword(stdout, seedname, 'dis_win_min', found, r_value=dis_manifold%win_min) + + call w90_readwrite_get_keyword(stdout, seedname, 'dis_win_max', found, r_value=dis_manifold%win_max) + if (eig_found .and. (dis_manifold%win_max .lt. dis_manifold%win_min)) & + call io_error('Error: w90_wannier90_readwrite_read: check disentanglement windows', stdout, seedname) + + dis_manifold%froz_min = -1.0_dp; dis_manifold%froz_max = 0.0_dp + ! no default for dis_froz_max + dis_manifold%frozen_states = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'dis_froz_max', found, r_value=dis_manifold%froz_max) + if (found) then + dis_manifold%frozen_states = .true. + dis_manifold%froz_min = dis_manifold%win_min ! default value for the bottom of frozen window + end if + call w90_readwrite_get_keyword(stdout, seedname, 'dis_froz_min', found2, r_value=dis_manifold%froz_min) + if (eig_found) then + if (dis_manifold%froz_max .lt. dis_manifold%froz_min) & + call io_error('Error: w90_wannier90_readwrite_read: check disentanglement frozen windows', stdout, seedname) + if (found2 .and. .not. found) & + call io_error('Error: w90_wannier90_readwrite_read: found dis_froz_min but not dis_froz_max', stdout, seedname) + endif + ! ndimwin/lwindow are not read + end subroutine w90_readwrite_read_dis_manifold + + subroutine w90_readwrite_read_kmesh_data(kmesh_input, stdout, seedname) + use w90_io, only: io_error + implicit none + type(kmesh_input_type), intent(out) :: kmesh_input + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + integer :: itmp, ierr + logical :: found + + kmesh_input%search_shells = 36 + call w90_readwrite_get_keyword(stdout, seedname, 'search_shells', found, i_value=kmesh_input%search_shells) + if (kmesh_input%search_shells < 0) call io_error('Error: search_shells must be positive', stdout, seedname) + + kmesh_input%tol = 0.000001_dp + call w90_readwrite_get_keyword(stdout, seedname, 'kmesh_tol', found, r_value=kmesh_input%tol) + if (kmesh_input%tol < 0.0_dp) call io_error('Error: kmesh_tol must be positive', stdout, seedname) + + kmesh_input%num_shells = 0 + call w90_readwrite_get_range_vector(stdout, seedname, 'shell_list', found, kmesh_input%num_shells, lcount=.true.) + if (found) then + if (kmesh_input%num_shells < 0 .or. kmesh_input%num_shells > max_shells) & + call io_error('Error: number of shell in shell_list must be between zero and six', stdout, seedname) + if (allocated(kmesh_input%shell_list)) deallocate (kmesh_input%shell_list) + allocate (kmesh_input%shell_list(kmesh_input%num_shells), stat=ierr) + if (ierr /= 0) call io_error('Error allocating shell_list in w90_wannier90_readwrite_read', stdout, seedname) + call w90_readwrite_get_range_vector(stdout, seedname, 'shell_list', found, kmesh_input%num_shells, .false., & + kmesh_input%shell_list) + if (any(kmesh_input%shell_list < 1)) & + call io_error('Error: shell_list must contain positive numbers', stdout, seedname) + else + if (allocated(kmesh_input%shell_list)) deallocate (kmesh_input%shell_list) + allocate (kmesh_input%shell_list(max_shells), stat=ierr) + if (ierr /= 0) call io_error('Error allocating shell_list in w90_wannier90_readwrite_read', stdout, seedname) + end if + + call w90_readwrite_get_keyword(stdout, seedname, 'num_shells', found, i_value=itmp) + if (found .and. (itmp /= kmesh_input%num_shells)) & + call io_error('Error: Found obsolete keyword num_shells. Its value does not agree with shell_list', stdout, seedname) + + ! If .true., does not perform the check of B1 of + ! Marzari, Vanderbild, PRB 56, 12847 (1997) + ! in kmesh.F90 + ! mainly needed for the interaction with Z2PACK + ! By default: .false. (perform the tests) + kmesh_input%skip_B1_tests = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'skip_b1_tests', found, l_value=kmesh_input%skip_B1_tests) + + end subroutine w90_readwrite_read_kmesh_data + + subroutine w90_readwrite_read_kpoints(pw90_effective_model, library, kpt_latt, num_kpts, & + bohr, stdout, seedname) + use w90_io, only: io_error + implicit none + + character(len=50), intent(in) :: seedname + integer, intent(in) :: num_kpts + integer, intent(in) :: stdout + logical, intent(in) :: pw90_effective_model, library + real(kind=dp), allocatable, intent(inout) :: kpt_latt(:, :) + real(kind=dp), allocatable :: kpt_cart(:, :) + real(kind=dp), intent(in) :: bohr + + integer :: ierr + logical :: found + + if (.not. pw90_effective_model) allocate (kpt_cart(3, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating kpt_cart in w90_wannier90_readwrite_read', stdout, seedname) + if (.not. library) then + allocate (kpt_latt(3, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating kpt_latt in w90_wannier90_readwrite_read', stdout, seedname) + end if + + call w90_readwrite_get_keyword_block(stdout, seedname, 'kpoints', found, num_kpts, 3, bohr, & + r_value=kpt_cart) + if (found .and. library) write (stdout, '(a)') ' Ignoring in input file' + if (.not. library .and. .not. pw90_effective_model) then + kpt_latt = kpt_cart + if (.not. found) call io_error('Error: Did not find the kpoint information in the input file', stdout, seedname) + end if + + ! Calculate the kpoints in cartesian coordinates + !if (.not. pw90_effective_model) then + ! do nkp = 1, num_kpts + ! k_points%kpt_cart(:, nkp) = matmul(k_points%kpt_latt(:, nkp), recip_lattice(:, :)) + ! end do + !endif + deallocate (kpt_cart, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating kpt_cart in w90_wannier90_readwrite_read', stdout, seedname) + + end subroutine w90_readwrite_read_kpoints + + subroutine w90_readwrite_read_lattice(library, real_lattice, bohr, stdout, seedname) + use w90_io, only: io_error + implicit none + logical, intent(in) :: library + integer, intent(in) :: stdout + real(kind=dp), intent(out) :: real_lattice(3, 3) + real(kind=dp) :: real_lattice_tmp(3, 3) + real(kind=dp), intent(in) :: bohr + character(len=50), intent(in) :: seedname + + logical :: found + + call w90_readwrite_get_keyword_block(stdout, seedname, 'unit_cell_cart', found, 3, 3, bohr, r_value=real_lattice_tmp) + if (found .and. library) write (stdout, '(a)') ' Ignoring in input file' + if (.not. library) then + real_lattice = transpose(real_lattice_tmp) + if (.not. found) call io_error('Error: Did not find the cell information in the input file', stdout, seedname) + end if + end subroutine w90_readwrite_read_lattice + + subroutine w90_readwrite_read_atoms(library, atom_data, real_lattice, bohr, stdout, seedname) + use w90_io, only: io_error + implicit none + logical, intent(in) :: library + integer, intent(in) :: stdout + type(atom_data_type), intent(inout) :: atom_data + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: bohr + character(len=50), intent(in) :: seedname + + integer :: i_temp, i_temp2 + logical :: found, found2, lunits + + ! Atoms + if (.not. library) atom_data%num_atoms = 0 + call w90_readwrite_get_block_length(stdout, seedname, 'atoms_frac', found, i_temp, library) + if (found .and. library) write (stdout, '(a)') ' Ignoring in input file' + call w90_readwrite_get_block_length(stdout, seedname, 'atoms_cart', found2, i_temp2, library, lunits) + if (found2 .and. library) write (stdout, '(a)') ' Ignoring in input file' + if (.not. library) then + if (found .and. found2) call io_error('Error: Cannot specify both atoms_frac and atoms_cart', stdout, seedname) + if (found .and. i_temp > 0) then + lunits = .false. + atom_data%num_atoms = i_temp + elseif (found2 .and. i_temp2 > 0) then + atom_data%num_atoms = i_temp2 + if (lunits) atom_data%num_atoms = atom_data%num_atoms - 1 + end if + if (atom_data%num_atoms > 0) then + call readwrite_get_atoms(atom_data, library, lunits, real_lattice, bohr, stdout, seedname) + end if + endif + end subroutine w90_readwrite_read_atoms + + subroutine w90_readwrite_clear_keywords(stdout, seedname) + ! wannier90.x and postw90.x now only read their own subset of the valid tokens in the ctrl file + ! checking of the ctrl file is by testing for the presence of any remaining strings in the file + ! after removing all valid keys. + ! + ! this routine hoovers up any remaining keys by scanning the ctrl file for (the union of) all + ! wannier90.x and postw90.x keywords. The w90_readwrite_get_keyword* functions only assign to optional + ! arguments: here we call without any, which has the side effect of clearing the input stream. + ! + ! these lists have been populated using a grep command on the source; it needs to be updated by + ! hand when the code changes. There are a lot of keywords; it's not an ideal solution. + ! + ! (for _vector: just specify zero length) + ! (for _block: small modification to skip checking/failure when rows=0 ) + use w90_io, only: io_error + + implicit none + + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + + logical :: found + + ! keywords for wannier.x + call w90_readwrite_get_keyword_block(stdout, seedname, 'dis_spheres', found, 0, 0, 0.0_dp) + call w90_readwrite_get_keyword_block(stdout, seedname, 'kpoints', found, 0, 0, 0.0_dp) + call w90_readwrite_get_keyword_block(stdout, seedname, 'nnkpts', found, 0, 0, 0.0_dp) + call w90_readwrite_get_keyword_block(stdout, seedname, 'unit_cell_cart', found, 0, 0, 0.0_dp) + call clear_block(stdout, seedname, 'projections') + call clear_block(stdout, seedname, 'kpoint_path') + call w90_readwrite_get_keyword(stdout, seedname, 'auto_projections', found) + call w90_readwrite_get_keyword(stdout, seedname, 'bands_num_points', found) + call w90_readwrite_get_keyword(stdout, seedname, 'bands_plot_dim', found) + call w90_readwrite_get_keyword(stdout, seedname, 'bands_plot_format', found) + call w90_readwrite_get_keyword(stdout, seedname, 'bands_plot', found) + call w90_readwrite_get_keyword(stdout, seedname, 'bands_plot_mode', found) + call w90_readwrite_get_keyword(stdout, seedname, 'calc_only_A', found) + call w90_readwrite_get_keyword(stdout, seedname, 'conv_noise_amp', found) + call w90_readwrite_get_keyword(stdout, seedname, 'conv_noise_num', found) + call w90_readwrite_get_keyword(stdout, seedname, 'conv_tol', found) + call w90_readwrite_get_keyword(stdout, seedname, 'conv_window', found) + call w90_readwrite_get_keyword(stdout, seedname, 'cp_pp', found) + call w90_readwrite_get_keyword(stdout, seedname, 'devel_flag', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dis_conv_tol', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dis_conv_window', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dis_froz_max', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dis_froz_min', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dis_mix_ratio', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dis_num_iter', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dis_spheres_first_wann', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dis_spheres_num', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dist_cutoff', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dist_cutoff_hc', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dist_cutoff_mode', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dis_win_max', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dis_win_min', found) + call w90_readwrite_get_keyword(stdout, seedname, 'energy_unit', found) + call w90_readwrite_get_keyword(stdout, seedname, 'fermi_energy', found) + call w90_readwrite_get_keyword(stdout, seedname, 'fermi_energy_max', found) + call w90_readwrite_get_keyword(stdout, seedname, 'fermi_energy_min', found) + call w90_readwrite_get_keyword(stdout, seedname, 'fermi_energy_step', found) + call w90_readwrite_get_keyword(stdout, seedname, 'fermi_surface_num_points', found) + call w90_readwrite_get_keyword(stdout, seedname, 'fermi_surface_plot_format', found) + call w90_readwrite_get_keyword(stdout, seedname, 'fermi_surface_plot', found) + call w90_readwrite_get_keyword(stdout, seedname, 'fixed_step', found) + call w90_readwrite_get_keyword(stdout, seedname, 'gamma_only', found) + call w90_readwrite_get_keyword(stdout, seedname, 'guiding_centres', found) + call w90_readwrite_get_keyword(stdout, seedname, 'hr_cutoff', found) + call w90_readwrite_get_keyword(stdout, seedname, 'hr_plot', found) + call w90_readwrite_get_keyword(stdout, seedname, 'iprint', found) + call w90_readwrite_get_keyword(stdout, seedname, 'kmesh_spacing', found) + call w90_readwrite_get_keyword(stdout, seedname, 'kmesh_tol', found) + call w90_readwrite_get_keyword(stdout, seedname, 'length_unit', found) + call w90_readwrite_get_keyword(stdout, seedname, 'num_bands', found) + call w90_readwrite_get_keyword(stdout, seedname, 'num_cg_steps', found) + call w90_readwrite_get_keyword(stdout, seedname, 'num_dump_cycles', found) + call w90_readwrite_get_keyword(stdout, seedname, 'num_elec_per_state', found) + call w90_readwrite_get_keyword(stdout, seedname, 'num_guide_cycles', found) + call w90_readwrite_get_keyword(stdout, seedname, 'num_iter', found) + call w90_readwrite_get_keyword(stdout, seedname, 'num_no_guide_iter', found) + call w90_readwrite_get_keyword(stdout, seedname, 'num_print_cycles', found) + call w90_readwrite_get_keyword(stdout, seedname, 'num_shells', found) + call w90_readwrite_get_keyword(stdout, seedname, 'num_valence_bands', found) + call w90_readwrite_get_keyword(stdout, seedname, 'num_wann', found) + call w90_readwrite_get_keyword(stdout, seedname, 'one_dim_axis', found) + call w90_readwrite_get_keyword(stdout, seedname, 'optimisation', found) + call w90_readwrite_get_keyword(stdout, seedname, 'postproc_setup', found) + call w90_readwrite_get_keyword(stdout, seedname, 'precond', found) + call w90_readwrite_get_keyword(stdout, seedname, 'restart', found) + call w90_readwrite_get_keyword(stdout, seedname, 'search_shells', found) + call w90_readwrite_get_keyword(stdout, seedname, 'site_symmetry', found) + call w90_readwrite_get_keyword(stdout, seedname, 'skip_b1_tests', found) + call w90_readwrite_get_keyword(stdout, seedname, 'slwf_constrain', found) + call w90_readwrite_get_keyword(stdout, seedname, 'slwf_lambda', found) + call w90_readwrite_get_keyword(stdout, seedname, 'slwf_num', found) + call w90_readwrite_get_keyword(stdout, seedname, 'spin', found) + call w90_readwrite_get_keyword(stdout, seedname, 'spinors', found) + call w90_readwrite_get_keyword(stdout, seedname, 'symmetrize_eps', found) + call w90_readwrite_get_keyword(stdout, seedname, 'timing_level', found) + call w90_readwrite_get_keyword(stdout, seedname, 'tran_easy_fix', found) + call w90_readwrite_get_keyword(stdout, seedname, 'tran_energy_step', found) + call w90_readwrite_get_keyword(stdout, seedname, 'tran_group_threshold', found) + call w90_readwrite_get_keyword(stdout, seedname, 'tran_num_bandc', found) + call w90_readwrite_get_keyword(stdout, seedname, 'tran_num_bb', found) + call w90_readwrite_get_keyword(stdout, seedname, 'tran_num_cc', found) + call w90_readwrite_get_keyword(stdout, seedname, 'tran_num_cell_ll', found) + call w90_readwrite_get_keyword(stdout, seedname, 'tran_num_cell_rr', found) + call w90_readwrite_get_keyword(stdout, seedname, 'tran_num_cr', found) + call w90_readwrite_get_keyword(stdout, seedname, 'tran_num_lc', found) + call w90_readwrite_get_keyword(stdout, seedname, 'tran_num_ll', found) + call w90_readwrite_get_keyword(stdout, seedname, 'tran_num_rr', found) + call w90_readwrite_get_keyword(stdout, seedname, 'tran_read_ht', found) + call w90_readwrite_get_keyword(stdout, seedname, 'translate_home_cell', found) + call w90_readwrite_get_keyword(stdout, seedname, 'transport', found) + call w90_readwrite_get_keyword(stdout, seedname, 'transport_mode', found) + call w90_readwrite_get_keyword(stdout, seedname, 'tran_use_same_lead', found) + call w90_readwrite_get_keyword(stdout, seedname, 'tran_win_max', found) + call w90_readwrite_get_keyword(stdout, seedname, 'tran_win_min', found) + call w90_readwrite_get_keyword(stdout, seedname, 'tran_write_ht', found) + call w90_readwrite_get_keyword(stdout, seedname, 'trial_step', found) + call w90_readwrite_get_keyword(stdout, seedname, 'use_bloch_phases', found) + call w90_readwrite_get_keyword(stdout, seedname, 'use_ws_distance', found) + call w90_readwrite_get_keyword(stdout, seedname, 'wannier_plot_format', found) + call w90_readwrite_get_keyword(stdout, seedname, 'wannier_plot', found) + call w90_readwrite_get_keyword(stdout, seedname, 'wannier_plot_mode', found) + call w90_readwrite_get_keyword(stdout, seedname, 'wannier_plot_radius', found) + call w90_readwrite_get_keyword(stdout, seedname, 'wannier_plot_scale', found) + call w90_readwrite_get_keyword(stdout, seedname, 'wannier_plot_spinor_mode', found) + call w90_readwrite_get_keyword(stdout, seedname, 'wannier_plot_spinor_phase', found) + call w90_readwrite_get_keyword(stdout, seedname, 'write_bvec', found) + call w90_readwrite_get_keyword(stdout, seedname, 'write_hr_diag', found) + call w90_readwrite_get_keyword(stdout, seedname, 'write_hr', found) + call w90_readwrite_get_keyword(stdout, seedname, 'write_proj', found) + call w90_readwrite_get_keyword(stdout, seedname, 'write_r2mn', found) + call w90_readwrite_get_keyword(stdout, seedname, 'write_rmn', found) + call w90_readwrite_get_keyword(stdout, seedname, 'write_tb', found) + call w90_readwrite_get_keyword(stdout, seedname, 'write_u_matrices', found) + call w90_readwrite_get_keyword(stdout, seedname, 'write_vdw_data', found) + call w90_readwrite_get_keyword(stdout, seedname, 'write_xyz', found) + call w90_readwrite_get_keyword(stdout, seedname, 'ws_distance_tol', found) + call w90_readwrite_get_keyword(stdout, seedname, 'wvfn_formatted', found) + call w90_readwrite_get_keyword_vector(stdout, seedname, 'kmesh', found, 0) ! the absent arrays have zero length ;-) + call w90_readwrite_get_keyword_vector(stdout, seedname, 'mp_grid', found, 0) + call w90_readwrite_get_keyword_vector(stdout, seedname, 'translation_centre_frac', found, 0) + call w90_readwrite_get_keyword_vector(stdout, seedname, 'wannier_plot_supercell', found, 0) + call w90_readwrite_get_keyword_vector(stdout, seedname, 'ws_search_size', found, 0) + ! ends list of wannier.x keywords + + ! keywords for postw90.x + call w90_readwrite_get_keyword(stdout, seedname, 'adpt_smr_fac', found) + call w90_readwrite_get_keyword(stdout, seedname, 'adpt_smr', found) + call w90_readwrite_get_keyword(stdout, seedname, 'adpt_smr_max', found) + call w90_readwrite_get_keyword(stdout, seedname, 'berry_curv_adpt_kmesh', found) + call w90_readwrite_get_keyword(stdout, seedname, 'berry_curv_adpt_kmesh_thresh', found) + call w90_readwrite_get_keyword(stdout, seedname, 'berry_curv_unit', found) + call w90_readwrite_get_keyword(stdout, seedname, 'berry', found) + call w90_readwrite_get_keyword(stdout, seedname, 'berry_kmesh_spacing', found) + call w90_readwrite_get_keyword(stdout, seedname, 'berry_task', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_2d_dir', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_bandshift_energyshift', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_bandshift_firstband', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_bandshift', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_calc_also_dos', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_dos_adpt_smr_fac', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_dos_adpt_smr', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_dos_adpt_smr_max', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_dos_energy_max', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_dos_energy_min', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_dos_energy_step', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_dos_smr_fixed_en_width', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_dos_smr_type', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_kmesh_spacing', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_mu_max', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_mu_min', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_mu_step', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_relax_time', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_tdf_energy_step', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_tdf_smr_fixed_en_width', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_tdf_smr_type', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_temp_max', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_temp_min', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltz_temp_step', found) + call w90_readwrite_get_keyword(stdout, seedname, 'boltzwann', found) + call w90_readwrite_get_keyword(stdout, seedname, 'degen_thr', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dos_adpt_smr_fac', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dos_adpt_smr', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dos_adpt_smr_max', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dos_energy_max', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dos_energy_min', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dos_energy_step', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dos', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dos_kmesh_spacing', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dos_smr_fixed_en_width', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dos_smr_type', found) + call w90_readwrite_get_keyword(stdout, seedname, 'dos_task', found) + call w90_readwrite_get_keyword(stdout, seedname, 'effective_model', found) + call w90_readwrite_get_keyword(stdout, seedname, 'geninterp_alsofirstder', found) + call w90_readwrite_get_keyword(stdout, seedname, 'geninterp', found) + call w90_readwrite_get_keyword(stdout, seedname, 'geninterp_single_file', found) + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic_degen_thresh', found) + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic_eigval_max', found) + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic', found) + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic_freq_max', found) + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic_freq_min', found) + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic_freq_step', found) + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic_kmesh_spacing', found) + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic_smr_fixed_en_width', found) + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic_smr_max_arg', found) + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic_smr_type', found) + call w90_readwrite_get_keyword(stdout, seedname, 'gyrotropic_task', found) + call w90_readwrite_get_keyword(stdout, seedname, 'kpath_bands_colour', found) + call w90_readwrite_get_keyword(stdout, seedname, 'kpath', found) + call w90_readwrite_get_keyword(stdout, seedname, 'kpath_num_points', found) + call w90_readwrite_get_keyword(stdout, seedname, 'kpath_task', found) + call w90_readwrite_get_keyword(stdout, seedname, 'kslice_fermi_lines_colour', found) + call w90_readwrite_get_keyword(stdout, seedname, 'kslice', found) + call w90_readwrite_get_keyword(stdout, seedname, 'kslice_task', found) + call w90_readwrite_get_keyword(stdout, seedname, 'kdotp_num_bands', found) + call w90_readwrite_get_keyword(stdout, seedname, 'kubo_adpt_smr_fac', found) + call w90_readwrite_get_keyword(stdout, seedname, 'kubo_adpt_smr', found) + call w90_readwrite_get_keyword(stdout, seedname, 'kubo_adpt_smr_max', found) + call w90_readwrite_get_keyword(stdout, seedname, 'kubo_eigval_max', found) + call w90_readwrite_get_keyword(stdout, seedname, 'kubo_freq_max', found) + call w90_readwrite_get_keyword(stdout, seedname, 'kubo_freq_min', found) + call w90_readwrite_get_keyword(stdout, seedname, 'kubo_freq_step', found) + call w90_readwrite_get_keyword(stdout, seedname, 'kubo_smr_fixed_en_width', found) + call w90_readwrite_get_keyword(stdout, seedname, 'kubo_smr_type', found) + call w90_readwrite_get_keyword(stdout, seedname, 'sc_eta', found) + call w90_readwrite_get_keyword(stdout, seedname, 'scissors_shift', found) + call w90_readwrite_get_keyword(stdout, seedname, 'sc_phase_conv', found) + call w90_readwrite_get_keyword(stdout, seedname, 'sc_use_eta_corr', found) + call w90_readwrite_get_keyword(stdout, seedname, 'sc_w_thr', found) + call w90_readwrite_get_keyword(stdout, seedname, 'shc_alpha', found) + call w90_readwrite_get_keyword(stdout, seedname, 'shc_bandshift_energyshift', found) + call w90_readwrite_get_keyword(stdout, seedname, 'shc_bandshift_firstband', found) + call w90_readwrite_get_keyword(stdout, seedname, 'shc_bandshift', found) + call w90_readwrite_get_keyword(stdout, seedname, 'shc_beta', found) + call w90_readwrite_get_keyword(stdout, seedname, 'shc_freq_scan', found) + call w90_readwrite_get_keyword(stdout, seedname, 'shc_gamma', found) + call w90_readwrite_get_keyword(stdout, seedname, 'shc_method', found) + call w90_readwrite_get_keyword(stdout, seedname, 'smr_fixed_en_width', found) + call w90_readwrite_get_keyword(stdout, seedname, 'smr_max_arg', found) + call w90_readwrite_get_keyword(stdout, seedname, 'smr_type', found) + call w90_readwrite_get_keyword(stdout, seedname, 'spin_axis_azimuth', found) + call w90_readwrite_get_keyword(stdout, seedname, 'spin_axis_polar', found) + call w90_readwrite_get_keyword(stdout, seedname, 'spin_decomp', found) + call w90_readwrite_get_keyword(stdout, seedname, 'spin_kmesh_spacing', found) + call w90_readwrite_get_keyword(stdout, seedname, 'spin_moment', found) + call w90_readwrite_get_keyword(stdout, seedname, 'spn_formatted', found) + call w90_readwrite_get_keyword(stdout, seedname, 'transl_inv', found) + call w90_readwrite_get_keyword(stdout, seedname, 'uhu_formatted', found) + call w90_readwrite_get_keyword(stdout, seedname, 'use_degen_pert', found) + call w90_readwrite_get_keyword(stdout, seedname, 'wanint_kpoint_file', found) + call w90_readwrite_get_keyword_vector(stdout, seedname, 'berry_kmesh', found, 0) + call w90_readwrite_get_keyword_vector(stdout, seedname, 'boltz_kmesh', found, 0) + call w90_readwrite_get_keyword_vector(stdout, seedname, 'dos_kmesh', found, 0) + call w90_readwrite_get_keyword_vector(stdout, seedname, 'gyrotropic_box_b1', found, 0) + call w90_readwrite_get_keyword_vector(stdout, seedname, 'gyrotropic_box_b2', found, 0) + call w90_readwrite_get_keyword_vector(stdout, seedname, 'gyrotropic_box_b3', found, 0) + call w90_readwrite_get_keyword_vector(stdout, seedname, 'gyrotropic_box_center', found, 0) + call w90_readwrite_get_keyword_vector(stdout, seedname, 'gyrotropic_kmesh', found, 0) + call w90_readwrite_get_keyword_vector(stdout, seedname, 'kdotp_kpoint', found, 0) + call w90_readwrite_get_keyword_vector(stdout, seedname, 'kslice_2dkmesh', found, 0) + call w90_readwrite_get_keyword_vector(stdout, seedname, 'kslice_b1', found, 0) + call w90_readwrite_get_keyword_vector(stdout, seedname, 'kslice_b2', found, 0) + call w90_readwrite_get_keyword_vector(stdout, seedname, 'kslice_corner', found, 0) + call w90_readwrite_get_keyword_vector(stdout, seedname, 'spin_kmesh', found, 0) + ! BGS what about get_range_vectors and gyrotropic_band_list, kdotp_bands etc? + ! ends list of postw90 keywords + + end subroutine w90_readwrite_clear_keywords + + subroutine w90_readwrite_clean_infile(stdout, seedname) + use w90_io, only: io_error + implicit none + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + + integer :: loop, ierr + + ! filter out any remaining accepted keywords from both wannier90.x and postw90.x sets + call w90_readwrite_clear_keywords(stdout, seedname) + + if (any(len_trim(in_data(:)) > 0)) then + write (stdout, '(1x,a)') 'The following section of file '//trim(seedname)//'.win contained unrecognised keywords' + write (stdout, *) + do loop = 1, num_lines + if (len_trim(in_data(loop)) > 0) then + write (stdout, '(1x,a)') trim(in_data(loop)) + end if + end do + write (stdout, *) + call io_error('Unrecognised keyword(s) in input file, see also output file', stdout, seedname) + end if + + deallocate (in_data, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating in_data in w90_wannier90_readwrite_read', stdout, seedname) + + end subroutine w90_readwrite_clean_infile + + subroutine w90_readwrite_read_final_alloc(disentanglement, dis_manifold, wannier_data, & + num_wann, num_bands, num_kpts, stdout, seedname) + !================================================== ! + ! Some checks and initialisations ! + !================================================== ! + use w90_io, only: io_error + implicit none + integer, intent(in) :: stdout + logical, intent(in) :: disentanglement + type(dis_manifold_type), intent(inout) :: dis_manifold + type(wannier_data_type), intent(inout) :: wannier_data + integer, intent(in) :: num_wann, num_bands, num_kpts + character(len=50), intent(in) :: seedname + + integer :: ierr + + if (disentanglement) then + if (allocated(dis_manifold%ndimwin)) deallocate (dis_manifold%ndimwin) + allocate (dis_manifold%ndimwin(num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating ndimwin in w90_wannier90_readwrite_read', stdout, seedname) + if (allocated(dis_manifold%lwindow)) deallocate (dis_manifold%lwindow) + allocate (dis_manifold%lwindow(num_bands, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating lwindow in w90_wannier90_readwrite_read', stdout, seedname) + endif + +! if ( wannier_plot .and. (index(wannier_plot_format,'cub').ne.0) ) then +! cosa(1)=dot_product(real_lattice(1,:),real_lattice(2,:)) +! cosa(2)=dot_product(real_lattice(1,:),real_lattice(3,:)) +! cosa(3)=dot_product(real_lattice(2,:),real_lattice(3,:)) +! cosa = abs(cosa) +! if (any(cosa.gt.eps6)) & +! call io_error('Error: plotting in cube format requires orthogonal lattice vectors') +! endif + + if (allocated(wannier_data%centres)) deallocate (wannier_data%centres) + allocate (wannier_data%centres(3, num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error allocating wannier_centres in w90_wannier90_readwrite_read', stdout, seedname) + wannier_data%centres = 0.0_dp + if (allocated(wannier_data%spreads)) deallocate (wannier_data%spreads) + allocate (wannier_data%spreads(num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating wannier_spreads in w90_wannier90_readwrite_read', stdout, seedname) + wannier_data%spreads = 0.0_dp + end subroutine w90_readwrite_read_final_alloc + + subroutine w90_readwrite_set_kmesh(spacing, reclat, mesh) + !! This routines returns the three integers that define the interpolation k-mesh, satisfying + !! the condition that the spacing between two neighboring points along each of the three + !! k_x, k_y and k_z directions is at smaller than a given spacing. + !! + !! The reclat is defined as: + !! * 'b_1' = (recip_lattice(1,I), i=1,3) + !! * 'b_2' = (recip_lattice(2,I), i=1,3) + !! * 'b_3' = (recip_lattice(3,I), i=1,3) + !! + !! spacing must be > 0 (and in particular different from zero). We don't check this here. + !! + implicit none + real(kind=dp), intent(in) :: spacing + !! Minimum spacing between neighboring points, in angstrom^(-1) + real(kind=dp), intent(in) :: reclat(3, 3) + !! Matrix of the reciprocal lattice vectors in cartesian coordinates, in angstrom^(-1) + integer, intent(out) :: mesh(3) + !! Will contain the three integers defining the interpolation k-mesh + + real(kind=dp) :: blen(3) + integer :: i + + do i = 1, 3 + blen(i) = sqrt(sum(reclat(i, :)**2)) + end do + + do i = 1, 3 + mesh(i) = int(floor(blen(i)/spacing)) + 1 + end do + + end subroutine w90_readwrite_set_kmesh + + function w90_readwrite_get_smearing_type(smearing_index) + !! This function returns a string describing the type of smearing + !! associated to a given smr_index integer value. + integer, intent(in) :: smearing_index + !! The integer index for which we want to get the string + character(len=80) :: w90_readwrite_get_smearing_type + character(len=4) :: orderstr + + if (smearing_index > 0) then + write (orderstr, '(I0)') smearing_index + w90_readwrite_get_smearing_type = "Methfessel-Paxton of order "//trim(orderstr) + else if (smearing_index .eq. 0) then + w90_readwrite_get_smearing_type = "Gaussian" + else if (smearing_index .eq. -1) then + w90_readwrite_get_smearing_type = "Marzari-Vanderbilt cold smearing" + else if (smearing_index .eq. -99) then + w90_readwrite_get_smearing_type = "Fermi-Dirac smearing" + else + w90_readwrite_get_smearing_type = "Unknown type of smearing" + end if + + end function w90_readwrite_get_smearing_type + + function w90_readwrite_get_convention_type(sc_phase_conv) + !! This function returns a string describing the convention + !! associated to a sc_phase_conv integer value. + integer, intent(in) :: sc_phase_conv + !! The integer index for which we want to get the string + character(len=80) :: w90_readwrite_get_convention_type + + !character(len=4) :: orderstr + + if (sc_phase_conv .eq. 1) then + w90_readwrite_get_convention_type = "Tight-binding convention" + else if (sc_phase_conv .eq. 2) then + w90_readwrite_get_convention_type = "Wannier90 convention" + else + w90_readwrite_get_convention_type = "Unknown type of convention" + end if + + end function w90_readwrite_get_convention_type + + function w90_readwrite_get_smearing_index(string, keyword, stdout, seedname) + !! This function parses a string containing the type of + !! smearing and returns the correct index for the smearing_index variable + ! + !! If the string is not valid, an io_error is issued + use w90_io, only: io_error + integer, intent(in) :: stdout + character(len=*), intent(in) :: string + !! The string read from input + character(len=*), intent(in) :: keyword + !! The keyword that was read (e.g., smr_type), so that we can print a more useful error message + character(len=50), intent(in) :: seedname + integer :: w90_readwrite_get_smearing_index + + integer :: pos + + w90_readwrite_get_smearing_index = 0 ! To avoid warnings of unset variables + + if (index(string, 'm-v') > 0) then + w90_readwrite_get_smearing_index = -1 + elseif (index(string, 'm-p') > 0) then + pos = index(string, 'm-p') + if (len(trim(string(pos + 3:))) .eq. 0) then + ! If the string is only 'm-p', we assume that 'm-p1' was intended + w90_readwrite_get_smearing_index = 1 + else + read (string(pos + 3:), *, err=337) w90_readwrite_get_smearing_index + if (w90_readwrite_get_smearing_index < 0) & + call io_error('Wrong m-p smearing order in keyword '//trim(keyword), stdout, seedname) + end if + elseif (index(string, 'f-d') > 0) then + w90_readwrite_get_smearing_index = -99 + ! Some aliases + elseif (index(string, 'cold') > 0) then + w90_readwrite_get_smearing_index = -1 + elseif (index(string, 'gauss') > 0) then + w90_readwrite_get_smearing_index = 0 + ! Unrecognised keyword + else + call io_error('Unrecognised value for keyword '//trim(keyword), stdout, seedname) + end if + + return + +337 call io_error('Wrong m-p smearing order in keyword '//trim(keyword), stdout, seedname) + + end function w90_readwrite_get_smearing_index + +!================================================ + subroutine w90_readwrite_uppercase(atom_data, kpoint_path, length_unit) + !================================================ + !! Convert a few things to uppercase to look nice in the output + ! + !================================================ + + implicit none + + type(atom_data_type), intent(inout) :: atom_data + type(kpoint_path_type), intent(inout) :: kpoint_path + character(len=*), intent(inout) :: length_unit + integer :: nsp, ic, loop, inner_loop + + ! Atom labels (eg, si --> Si) + do nsp = 1, atom_data%num_species + ic = ichar(atom_data%label(nsp) (1:1)) + if ((ic .ge. ichar('a')) .and. (ic .le. ichar('z'))) & + atom_data%label(nsp) (1:1) = char(ic + ichar('Z') - ichar('z')) + enddo + + do nsp = 1, atom_data%num_species + ic = ichar(atom_data%symbol(nsp) (1:1)) + if ((ic .ge. ichar('a')) .and. (ic .le. ichar('z'))) & + atom_data%symbol(nsp) (1:1) = char(ic + ichar('Z') - ichar('z')) + enddo + + ! Bands labels (eg, x --> X) + if (allocated(kpoint_path%labels)) then + do loop = 1, size(kpoint_path%labels) + do inner_loop = 1, len(kpoint_path%labels(loop)) + ic = ichar(kpoint_path%labels(loop) (inner_loop:inner_loop)) + if ((ic .ge. ichar('a')) .and. (ic .le. ichar('z'))) & + kpoint_path%labels(loop) (inner_loop:inner_loop) = char(ic + ichar('Z') - ichar('z')) + enddo + enddo + endif + + ! Length unit (ang --> Ang, bohr --> Bohr) + ic = ichar(length_unit(1:1)) + if ((ic .ge. ichar('a')) .and. (ic .le. ichar('z'))) & + length_unit(1:1) = char(ic + ichar('Z') - ichar('z')) + + return + + end subroutine w90_readwrite_uppercase + + subroutine w90_readwrite_write_header(bohr_version_str, constants_version_str1, constants_version_str2, stdout) + !! Write a suitable header for the calculation - version authors etc + use w90_io, only: io_date, w90_version + + implicit none + + integer, intent(in) :: stdout + character(len=*), intent(in) :: bohr_version_str, constants_version_str1, constants_version_str2 + character(len=9) :: cdate, ctime + + call io_date(cdate, ctime) + + write (stdout, *) + write (stdout, *) ' +---------------------------------------------------+' + write (stdout, *) ' | |' + write (stdout, *) ' | WANNIER90 |' + write (stdout, *) ' | |' + write (stdout, *) ' +---------------------------------------------------+' + write (stdout, *) ' | |' + write (stdout, *) ' | Welcome to the Maximally-Localized |' + write (stdout, *) ' | Generalized Wannier Functions code |' + write (stdout, *) ' | http://www.wannier.org |' + write (stdout, *) ' | |' + write (stdout, *) ' | |' + write (stdout, *) ' | Wannier90 Developer Group: |' + write (stdout, *) ' | Giovanni Pizzi (EPFL) |' + write (stdout, *) ' | Valerio Vitale (Cambridge) |' + write (stdout, *) ' | David Vanderbilt (Rutgers University) |' + write (stdout, *) ' | Nicola Marzari (EPFL) |' + write (stdout, *) ' | Ivo Souza (Universidad del Pais Vasco) |' + write (stdout, *) ' | Arash A. Mostofi (Imperial College London) |' + write (stdout, *) ' | Jonathan R. Yates (University of Oxford) |' + write (stdout, *) ' | |' + write (stdout, *) ' | For the full list of Wannier90 3.x authors, |' + write (stdout, *) ' | please check the code documentation and the |' + write (stdout, *) ' | README on the GitHub page of the code |' + write (stdout, *) ' | |' + write (stdout, *) ' | |' + write (stdout, *) ' | Please cite |' + write (stdout, *) ' | |' + write (stdout, *) ' | [ref] "Wannier90 as a community code: |' + write (stdout, *) ' | new features and applications", |' + write (stdout, *) ' | G. Pizzi et al., J. Phys. Cond. Matt. 32, |' + write (stdout, *) ' | 165902 (2020). |' + write (stdout, *) ' | http://doi.org/10.1088/1361-648X/ab51ff |' + write (stdout, *) ' | |' + write (stdout, *) ' | in any publications arising from the use of |' + write (stdout, *) ' | this code. For the method please cite |' + write (stdout, *) ' | |' + write (stdout, *) ' | [ref] "Maximally Localized Generalised Wannier |' + write (stdout, *) ' | Functions for Composite Energy Bands" |' + write (stdout, *) ' | N. Marzari and D. Vanderbilt |' + write (stdout, *) ' | Phys. Rev. B 56 12847 (1997) |' + write (stdout, *) ' | |' + write (stdout, *) ' | [ref] "Maximally Localized Wannier Functions |' + write (stdout, *) ' | for Entangled Energy Bands" |' + write (stdout, *) ' | I. Souza, N. Marzari and D. Vanderbilt |' + write (stdout, *) ' | Phys. Rev. B 65 035109 (2001) |' + write (stdout, *) ' | |' + write (stdout, *) ' | |' + write (stdout, *) ' | Copyright (c) 1996-2020 |' + write (stdout, *) ' | The Wannier90 Developer Group and |' + write (stdout, *) ' | individual contributors |' + write (stdout, *) ' | |' + write (stdout, *) ' | Release: ', adjustl(w90_version), ' 5th March 2020 |' + write (stdout, *) ' | |' + write (stdout, *) ' | This program is free software; you can |' + write (stdout, *) ' | redistribute it and/or modify it under the terms |' + write (stdout, *) ' | of the GNU General Public License as published by |' + write (stdout, *) ' | the Free Software Foundation; either version 2 of |' + write (stdout, *) ' | the License, or (at your option) any later version|' + write (stdout, *) ' | |' + write (stdout, *) ' | This program is distributed in the hope that it |' + write (stdout, *) ' | will be useful, but WITHOUT ANY WARRANTY; without |' + write (stdout, *) ' | even the implied warranty of MERCHANTABILITY or |' + write (stdout, *) ' | FITNESS FOR A PARTICULAR PURPOSE. See the GNU |' + write (stdout, *) ' | General Public License for more details. |' + write (stdout, *) ' | |' + write (stdout, *) ' | You should have received a copy of the GNU General|' + write (stdout, *) ' | Public License along with this program; if not, |' + write (stdout, *) ' | write to the Free Software Foundation, Inc., |' + write (stdout, *) ' | 675 Mass Ave, Cambridge, MA 02139, USA. |' + write (stdout, *) ' | |' + write (stdout, *) ' +---------------------------------------------------+' + write (stdout, *) ' | Execution started on ', cdate, ' at ', ctime, ' |' + write (stdout, *) ' +---------------------------------------------------+' + write (stdout, *) '' + write (stdout, '(1X,A)') '******************************************************************************' + write (stdout, '(1X,A)') '* '//constants_version_str1//'*' + write (stdout, '(1X,A)') '* '//constants_version_str2//'*' + write (stdout, '(1X,A)') '* '//bohr_version_str//'*' + write (stdout, '(1X,A)') '******************************************************************************' + write (stdout, *) '' + + end subroutine w90_readwrite_write_header + +!================================================! + subroutine w90_readwrite_dealloc(exclude_bands, wannier_data, input_proj, kmesh_input, kpt_latt, & + dis_manifold, atom_data, eigval, kpoint_path, stdout, seedname) + !================================================! + !! release memory from allocated parameters + ! + !================================================ + use w90_io, only: io_error + + implicit none + + type(atom_data_type), intent(inout) :: atom_data + type(dis_manifold_type), intent(inout) :: dis_manifold + type(kmesh_input_type), intent(inout) :: kmesh_input + type(kpoint_path_type), intent(inout) :: kpoint_path + type(proj_input_type), intent(inout) :: input_proj + type(wannier_data_type), intent(inout) :: wannier_data + integer, allocatable, intent(inout) :: exclude_bands(:) + integer, intent(in) :: stdout + real(kind=dp), allocatable, intent(inout) :: eigval(:, :) + real(kind=dp), allocatable, intent(inout) :: kpt_latt(:, :) + character(len=50), intent(in) :: seedname + + integer :: ierr + + if (allocated(dis_manifold%ndimwin)) then + deallocate (dis_manifold%ndimwin, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating ndimwin in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(dis_manifold%lwindow)) then + deallocate (dis_manifold%lwindow, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating lwindow in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(eigval)) then + deallocate (eigval, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating eigval in w90_readwrite_dealloc', stdout, seedname) + endif + if (allocated(kmesh_input%shell_list)) then + deallocate (kmesh_input%shell_list, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating shell_list in w90_readwrite_dealloc', stdout, seedname) + endif + if (allocated(kpt_latt)) then + deallocate (kpt_latt, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating kpt_latt in w90_readwrite_dealloc', stdout, seedname) + endif + if (allocated(kpoint_path%labels)) then + deallocate (kpoint_path%labels, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating labels in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(kpoint_path%points)) then + deallocate (kpoint_path%points, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating points in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(atom_data%label)) then + deallocate (atom_data%label, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating atoms_label in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(atom_data%symbol)) then + deallocate (atom_data%symbol, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating atoms_symbol in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(atom_data%pos_cart)) then + deallocate (atom_data%pos_cart, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating atoms_pos_cart in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(atom_data%species_num)) then + deallocate (atom_data%species_num, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating atoms_species_num in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(input_proj%site)) then + deallocate (input_proj%site, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating input_proj_site in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(input_proj%l)) then + deallocate (input_proj%l, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating input_proj_l in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(input_proj%m)) then + deallocate (input_proj%m, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating input_proj_m in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(input_proj%s)) then + deallocate (input_proj%s, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating input_proj_s in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(input_proj%s_qaxis)) then + deallocate (input_proj%s_qaxis, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating input_proj_s_qaxis in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(input_proj%z)) then + deallocate (input_proj%z, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating input_proj_z in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(input_proj%x)) then + deallocate (input_proj%x, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating input_proj_x in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(input_proj%radial)) then + deallocate (input_proj%radial, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating input_proj_radial in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(input_proj%zona)) then + deallocate (input_proj%zona, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating input_proj_zona in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(exclude_bands)) then + deallocate (exclude_bands, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating exclude_bands in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(wannier_data%centres)) then + deallocate (wannier_data%centres, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating wannier_centres in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(wannier_data%spreads)) then + deallocate (wannier_data%spreads, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating wannier_spreads in w90_readwrite_dealloc', stdout, seedname) + endif + return + + end subroutine w90_readwrite_dealloc + +!~ !================================================! +!~ subroutine w90_wannier90_readwrite_write_um +!~ !================================================! +!~ ! +!~ ! Dump the U and M to *_um.dat ! +!~ ! +!~ !================================================! +!~ +!~ +!~ use w90_io, only : io_file_unit,io_error,seedname,io_date +!~ implicit none +!~ +!~ integer :: i,j,k,l,um_unit +!~ character (len=9) :: cdate, ctime +!~ character(len=33) :: header +!~ +!~ call io_date(cdate, ctime) +!~ header='written on '//cdate//' at '//ctime +!~ +!~ um_unit=io_file_unit() +!~ open(unit=um_unit,file=trim(seedname)//'_um.dat',form='unformatted') +!~ write(um_unit) header +!~ write(um_unit) omega_invariant +!~ write(um_unit) num_wann,num_kpts,num_nnmax +!~ write(um_unit) (((u_matrix(i,j,k),i=1,num_wann),j=1,num_wann),k=1,num_kpts) +!~ write(um_unit) ((((m_matrix(i,j,k,l),i=1,num_wann),j=1,num_wann),k=1,nntot),l=1,num_kpts) +!~ close(um_unit) +!~ +!~ return +!~ +!~ end subroutine w90_wannier90_readwrite_write_um + +!~ !================================================! +!~ subroutine w90_wannier90_readwrite_read_um +!~ !================================================! +!~ ! ! +!~ ! Restore U and M from file ! +!~ ! ! +!~ !================================================! +!~ +!~ use w90_io, only : io_file_unit,io_error,seedname +!~ implicit none +!~ +!~ integer :: tmp_num_wann,tmp_num_kpts,tmp_num_nnmax +!~ integer :: i,j,k,l,um_unit,ierr +!~ character(len=33) :: header +!~ real(kind=dp) :: tmp_omi +!~ +!~ um_unit=io_file_unit() +!~ open(unit=um_unit,file=trim(seedname)//'_um.dat',status="old",form='unformatted',err=105) +!~ read(um_unit) header +!~ write(stdout,'(1x,4(a))') 'Reading U and M from file ',trim(seedname),'_um.dat ', header +!~ read(um_unit) tmp_omi +!~ if ( have_disentangled ) then +!~ if ( abs(tmp_omi-omega_invariant).gt.1.0e-10_dp ) & +!~ call io_error('Error in restart: omega_invariant in .chk and um.dat files do not match') +!~ endif +!~ read(um_unit) tmp_num_wann,tmp_num_kpts,tmp_num_nnmax +!~ if(tmp_num_wann/=num_wann) call io_error('Error in w90_wannier90_readwrite_read_um: num_wann mismatch') +!~ if(tmp_num_kpts/=num_kpts) call io_error('Error in w90_wannier90_readwrite_read_um: num_kpts mismatch') +!~ if(tmp_num_nnmax/=num_nnmax) call io_error('Error in w90_wannier90_readwrite_read_um: num_nnmax mismatch') +!~ if (.not.allocated(u_matrix)) then +!~ allocate(u_matrix(num_wann,num_wann,num_kpts),stat=ierr) +!~ if (ierr/=0) call io_error('Error allocating u_matrix in w90_wannier90_readwrite_read_um') +!~ endif +!~ read(um_unit) (((u_matrix(i,j,k),i=1,num_wann),j=1,num_wann),k=1,num_kpts) +!~ if (.not.allocated(m_matrix)) then +!~ allocate(m_matrix(num_wann,num_wann,nntot,num_kpts),stat=ierr) +!~ if (ierr/=0) call io_error('Error allocating m_matrix in w90_wannier90_readwrite_read_um') +!~ endif +!~ read(um_unit) ((((m_matrix(i,j,k,l),i=1,num_wann),j=1,num_wann),k=1,nntot),l=1,num_kpts) +!~ close(um_unit) +!~ +!~ return +!~ +!~105 call io_error('Error: Problem opening file '//trim(seedname)//'_um.dat in w90_wannier90_readwrite_read_um') +!~ +! $ end subroutine w90_wannier90_readwrite_read_um + +!================================================! + subroutine w90_readwrite_read_chkpt(dis_manifold, exclude_bands, kmesh_info, kpt_latt, wannier_data, m_matrix, & + u_matrix, u_matrix_opt, real_lattice, & + omega_invariant, mp_grid, num_bands, num_exclude_bands, num_kpts, & + num_wann, checkpoint, have_disentangled, ispostw90, seedname, stdout) + !================================================! + !! Read checkpoint file + !! IMPORTANT! If you change the chkpt format, adapt + !! accordingly also the w90chk2chk.x utility! + !! + !! Note on parallelization: this function should be called + !! from the root node only! + !! + !================================================! + + use w90_constants, only: eps6 + use w90_io, only: io_file_unit, io_error + use w90_utility, only: utility_recip_lattice + + implicit none + + integer, allocatable, intent(inout) :: exclude_bands(:) + type(wannier_data_type), intent(inout) :: wannier_data + type(kmesh_info_type), intent(in) :: kmesh_info + real(kind=dp), intent(in) :: kpt_latt(:, :) + type(dis_manifold_type), intent(inout) :: dis_manifold + + integer, intent(in) :: num_kpts + integer, intent(in) :: num_bands + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_exclude_bands + + complex(kind=dp), allocatable, intent(inout) :: u_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: u_matrix_opt(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: m_matrix(:, :, :, :) + + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(inout) :: omega_invariant + + character(len=50), intent(in) :: seedname + character(len=*), intent(inout) :: checkpoint + + logical, intent(in) :: ispostw90 ! Are we running postw90? + logical, intent(out) :: have_disentangled + + ! local variables + real(kind=dp) :: recip_lattice(3, 3), volume + integer :: chk_unit, nkp, i, j, k, l, ntmp, ierr + character(len=33) :: header + real(kind=dp) :: tmp_latt(3, 3), tmp_kpt_latt(3, num_kpts) + integer :: tmp_excl_bands(1:num_exclude_bands), tmp_mp_grid(1:3) + + write (stdout, '(1x,3a)') 'Reading restart information from file ', trim(seedname), '.chk :' + + chk_unit = io_file_unit() + open (unit=chk_unit, file=trim(seedname)//'.chk', status='old', form='unformatted', err=121) + + ! Read comment line + read (chk_unit) header + write (stdout, '(1x,a)', advance='no') trim(header) + + ! Consistency checks + read (chk_unit) ntmp ! Number of bands + if (ntmp .ne. num_bands) call io_error('w90_wannier90_readwrite_read_chk: Mismatch in num_bands', stdout, seedname) + read (chk_unit) ntmp ! Number of excluded bands + if (ntmp .ne. num_exclude_bands) & + call io_error('w90_wannier90_readwrite_read_chk: Mismatch in num_exclude_bands', stdout, seedname) + read (chk_unit) (tmp_excl_bands(i), i=1, num_exclude_bands) ! Excluded bands + do i = 1, num_exclude_bands + if (tmp_excl_bands(i) .ne. exclude_bands(i)) & + call io_error('w90_wannier90_readwrite_read_chk: Mismatch in exclude_bands', stdout, seedname) + enddo + read (chk_unit) ((tmp_latt(i, j), i=1, 3), j=1, 3) ! Real lattice + do j = 1, 3 + do i = 1, 3 + if (abs(tmp_latt(i, j) - real_lattice(i, j)) .gt. eps6) & + call io_error('w90_wannier90_readwrite_read_chk: Mismatch in real_lattice', stdout, seedname) + enddo + enddo + call utility_recip_lattice(real_lattice, recip_lattice, volume, stdout, seedname) + read (chk_unit) ((tmp_latt(i, j), i=1, 3), j=1, 3) ! Reciprocal lattice + do j = 1, 3 + do i = 1, 3 + if (abs(tmp_latt(i, j) - recip_lattice(i, j)) .gt. eps6) & + call io_error('w90_wannier90_readwrite_read_chk: Mismatch in recip_lattice', stdout, seedname) + enddo + enddo + read (chk_unit) ntmp ! K-points + if (ntmp .ne. num_kpts) & + call io_error('w90_wannier90_readwrite_read_chk: Mismatch in num_kpts', stdout, seedname) + read (chk_unit) (tmp_mp_grid(i), i=1, 3) ! M-P grid + do i = 1, 3 + if (tmp_mp_grid(i) .ne. mp_grid(i)) & + call io_error('w90_wannier90_readwrite_read_chk: Mismatch in mp_grid', stdout, seedname) + enddo + read (chk_unit) ((tmp_kpt_latt(i, nkp), i=1, 3), nkp=1, num_kpts) + do nkp = 1, num_kpts + do i = 1, 3 + if (abs(tmp_kpt_latt(i, nkp) - kpt_latt(i, nkp)) .gt. eps6) & + call io_error('w90_wannier90_readwrite_read_chk: Mismatch in kpt_latt', stdout, seedname) + enddo + enddo + read (chk_unit) ntmp ! nntot + if (ntmp .ne. kmesh_info%nntot) & + call io_error('w90_wannier90_readwrite_read_chk: Mismatch in nntot', stdout, seedname) + read (chk_unit) ntmp ! num_wann + if (ntmp .ne. num_wann) & + call io_error('w90_wannier90_readwrite_read_chk: Mismatch in num_wann', stdout, seedname) + ! End of consistency checks + + read (chk_unit) checkpoint ! checkpoint + checkpoint = adjustl(trim(checkpoint)) + + read (chk_unit) have_disentangled ! whether a disentanglement has been performed + + if (have_disentangled) then + + read (chk_unit) omega_invariant ! omega invariant + + ! lwindow + if (.not. allocated(dis_manifold%lwindow)) then + allocate (dis_manifold%lwindow(num_bands, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating lwindow in w90_readwrite_read_chkpt', stdout, seedname) + endif + read (chk_unit, err=122) ((dis_manifold%lwindow(i, nkp), i=1, num_bands), nkp=1, num_kpts) + + ! ndimwin + if (.not. allocated(dis_manifold%ndimwin)) then + allocate (dis_manifold%ndimwin(num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating ndimwin in w90_readwrite_read_chkpt', stdout, seedname) + endif + read (chk_unit, err=123) (dis_manifold%ndimwin(nkp), nkp=1, num_kpts) + + ! U_matrix_opt + if (.not. allocated(u_matrix_opt)) then + allocate (u_matrix_opt(num_bands, num_wann, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating u_matrix_opt in w90_readwrite_read_chkpt', stdout, seedname) + endif + read (chk_unit, err=124) (((u_matrix_opt(i, j, nkp), i=1, num_bands), j=1, num_wann), nkp=1, num_kpts) + + endif + + ! U_matrix + if (.not. allocated(u_matrix)) then + allocate (u_matrix(num_wann, num_wann, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating u_matrix in w90_readwrite_read_chkpt', stdout, seedname) + endif + read (chk_unit, err=125) (((u_matrix(i, j, k), i=1, num_wann), j=1, num_wann), k=1, num_kpts) + + ! M_matrix + if (.not. allocated(m_matrix)) then + allocate (m_matrix(num_wann, num_wann, kmesh_info%nntot, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating m_matrix in w90_readwrite_read_chkpt', stdout, seedname) + endif + read (chk_unit, err=126) ((((m_matrix(i, j, k, l), i=1, num_wann), j=1, num_wann), k=1, kmesh_info%nntot), l=1, num_kpts) + + ! wannier_centres + read (chk_unit, err=127) ((wannier_data%centres(i, j), i=1, 3), j=1, num_wann) + + ! wannier spreads + read (chk_unit, err=128) (wannier_data%spreads(i), i=1, num_wann) + + close (chk_unit) + + write (stdout, '(a/)') ' ... done' + + return + +121 if (ispostw90) then + call io_error('Error opening '//trim(seedname)//'.chk in w90_readwrite_read_chkpt: did you run wannier90.x first?', stdout, & + seedname) + else + call io_error('Error opening '//trim(seedname)//'.chk in w90_readwrite_read_chkpt', stdout, seedname) + end if +122 call io_error('Error reading lwindow from '//trim(seedname)//'.chk in w90_readwrite_read_chkpt', stdout, seedname) +123 call io_error('Error reading ndimwin from '//trim(seedname)//'.chk in w90_readwrite_read_chkpt', stdout, seedname) +124 call io_error('Error reading u_matrix_opt from '//trim(seedname)//'.chk in w90_readwrite_read_chkpt', stdout, seedname) +125 call io_error('Error reading u_matrix from '//trim(seedname)//'.chk in w90_readwrite_read_chkpt', stdout, seedname) +126 call io_error('Error reading m_matrix from '//trim(seedname)//'.chk in w90_readwrite_read_chkpt', stdout, seedname) +127 call io_error('Error reading wannier_centres from '//trim(seedname)//'.chk in w90_readwrite_read_chkpt', stdout, seedname) +128 call io_error('Error reading wannier_spreads from '//trim(seedname)//'.chk in w90_readwrite_read_chkpt', stdout, seedname) + + end subroutine w90_readwrite_read_chkpt + +!================================================! + subroutine w90_readwrite_chkpt_dist(dis_manifold, wannier_data, u_matrix, u_matrix_opt, omega_invariant, & + num_bands, num_kpts, num_wann, checkpoint, have_disentangled, & + seedname, stdout, comm) + !================================================! + ! + !! Distribute the chk files + ! + !================================================! + + use w90_constants, only: dp + use w90_io, only: io_error, io_file_unit, io_date, io_time, io_stopwatch + use w90_comms, only: comms_bcast, w90comm_type, mpirank + + implicit none + + ! arguments + type(wannier_data_type), intent(inout) :: wannier_data + type(dis_manifold_type), intent(inout) :: dis_manifold + type(w90comm_type), intent(in) :: comm + + integer, intent(in) :: stdout + integer, intent(inout) :: num_bands + integer, intent(inout) :: num_wann + integer, intent(inout) :: num_kpts + + complex(kind=dp), allocatable, intent(inout) :: u_matrix(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: u_matrix_opt(:, :, :) + real(kind=dp), intent(inout) :: omega_invariant + + character(len=50), intent(in) :: seedname + character(len=*), intent(inout) :: checkpoint + logical, intent(inout) :: have_disentangled + + ! local variables + integer :: ierr + + logical :: on_root = .false. + + if (mpirank(comm) == 0) on_root = .true. + + call comms_bcast(checkpoint, len(checkpoint), stdout, seedname, comm) + + if (.not. on_root .and. .not. allocated(u_matrix)) then + allocate (u_matrix(num_wann, num_wann, num_kpts), stat=ierr) + if (ierr /= 0) & + call io_error('Error allocating u_matrix in w90_readwrite_chkpt_dist', stdout, seedname) + endif + call comms_bcast(u_matrix(1, 1, 1), num_wann*num_wann*num_kpts, stdout, seedname, comm) + +! if (.not.on_root .and. .not.allocated(m_matrix)) then +! allocate(m_matrix(num_wann,num_wann,nntot,num_kpts),stat=ierr) +! if (ierr/=0)& +! call io_error('Error allocating m_matrix in w90_readwrite_chkpt_dist') +! endif +! call comms_bcast(m_matrix(1,1,1,1),num_wann*num_wann*nntot*num_kpts) + + call comms_bcast(have_disentangled, 1, stdout, seedname, comm) + + if (have_disentangled) then + if (.not. on_root) then + + if (.not. allocated(u_matrix_opt)) then + allocate (u_matrix_opt(num_bands, num_wann, num_kpts), stat=ierr) + if (ierr /= 0) & + call io_error('Error allocating u_matrix_opt in w90_readwrite_chkpt_dist', stdout, seedname) + endif + + if (.not. allocated(dis_manifold%lwindow)) then + allocate (dis_manifold%lwindow(num_bands, num_kpts), stat=ierr) + if (ierr /= 0) & + call io_error('Error allocating lwindow in w90_readwrite_chkpt_dist', stdout, seedname) + endif + + if (.not. allocated(dis_manifold%ndimwin)) then + allocate (dis_manifold%ndimwin(num_kpts), stat=ierr) + if (ierr /= 0) & + call io_error('Error allocating ndimwin in w90_readwrite_chkpt_dist', stdout, seedname) + endif + + end if + + call comms_bcast(u_matrix_opt(1, 1, 1), num_bands*num_wann*num_kpts, stdout, seedname, comm) + call comms_bcast(dis_manifold%lwindow(1, 1), num_bands*num_kpts, stdout, seedname, comm) + call comms_bcast(dis_manifold%ndimwin(1), num_kpts, stdout, seedname, comm) + call comms_bcast(omega_invariant, 1, stdout, seedname, comm) + end if + call comms_bcast(wannier_data%centres(1, 1), 3*num_wann, stdout, seedname, comm) + call comms_bcast(wannier_data%spreads(1), num_wann, stdout, seedname, comm) + + end subroutine w90_readwrite_chkpt_dist + +!================================================! + subroutine w90_readwrite_in_file(seedname, stdout) + !================================================! + !! Load the *.win file into a character + !! array in_file, ignoring comments and + !! blank lines and converting everything + !! to lowercase characters + !================================================! + + use w90_utility, only: utility_lowercase + use w90_io, only: io_file_unit, io_error + + implicit none + + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + + integer :: in_unit, tot_num_lines, ierr, line_counter, loop, in1, in2 + character(len=maxlen) :: dummy + integer :: pos + character, parameter :: TABCHAR = char(9) + + in_unit = io_file_unit() + open (in_unit, file=trim(seedname)//'.win', form='formatted', status='old', err=101) + + num_lines = 0; tot_num_lines = 0 + do + read (in_unit, '(a)', iostat=ierr, err=200, end=210) dummy + ! [GP-begin, Apr13, 2012]: I convert all tabulation characters to spaces + pos = index(dummy, TABCHAR) + do while (pos .ne. 0) + dummy(pos:pos) = ' ' + pos = index(dummy, TABCHAR) + end do + ! [GP-end] + dummy = adjustl(dummy) + tot_num_lines = tot_num_lines + 1 + if (.not. dummy(1:1) == '!' .and. .not. dummy(1:1) == '#') then + if (len(trim(dummy)) > 0) num_lines = num_lines + 1 + endif + + end do + +101 call io_error('Error: Problem opening input file '//trim(seedname)//'.win', stdout, seedname) +200 call io_error('Error: Problem reading input file '//trim(seedname)//'.win', stdout, seedname) +210 continue + rewind (in_unit) + + allocate (in_data(num_lines), stat=ierr) + if (ierr /= 0) call io_error('Error allocating in_data in w90_readwrite_in_file', stdout, seedname) + + line_counter = 0 + do loop = 1, tot_num_lines + read (in_unit, '(a)', iostat=ierr, err=200) dummy + ! [GP-begin, Apr13, 2012]: I convert all tabulation characters to spaces + pos = index(dummy, TABCHAR) + do while (pos .ne. 0) + dummy(pos:pos) = ' ' + pos = index(dummy, TABCHAR) + end do + ! [GP-end] + dummy = utility_lowercase(dummy) + dummy = adjustl(dummy) + if (dummy(1:1) == '!' .or. dummy(1:1) == '#') cycle + if (len(trim(dummy)) == 0) cycle + line_counter = line_counter + 1 + in1 = index(dummy, '!') + in2 = index(dummy, '#') + if (in1 == 0 .and. in2 == 0) in_data(line_counter) = dummy + if (in1 == 0 .and. in2 > 0) in_data(line_counter) = dummy(:in2 - 1) + if (in2 == 0 .and. in1 > 0) in_data(line_counter) = dummy(:in1 - 1) + if (in2 > 0 .and. in1 > 0) in_data(line_counter) = dummy(:min(in1, in2) - 1) + end do + + close (in_unit) + + end subroutine w90_readwrite_in_file + + !================================================! + subroutine w90_readwrite_get_keyword(stdout, seedname, keyword, found, c_value, l_value, i_value, r_value) + !================================================! + ! + !! Finds the value of the required keyword. + ! + !================================================! + + use w90_io, only: io_error + + implicit none + + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + character(*), intent(in) :: keyword + !! Keyword to examine + logical, intent(out) :: found + !! Is keyword present + character(*), optional, intent(inout) :: c_value + !! Keyword value + logical, optional, intent(inout) :: l_value + !! Keyword value + integer, optional, intent(inout) :: i_value + !! Keyword value + real(kind=dp), optional, intent(inout) :: r_value + !! Keyword value + + integer :: kl, in, loop, itmp + character(len=maxlen) :: dummy + + kl = len_trim(keyword) + + found = .false. + + do loop = 1, num_lines + in = index(in_data(loop), trim(keyword)) + if (in == 0 .or. in > 1) cycle + itmp = in + len(trim(keyword)) + if (in_data(loop) (itmp:itmp) /= '=' & + .and. in_data(loop) (itmp:itmp) /= ':' & + .and. in_data(loop) (itmp:itmp) /= ' ') cycle + if (found) then + call io_error('Error: Found keyword '//trim(keyword)//' more than once in input file', stdout, seedname) + endif + found = .true. + dummy = in_data(loop) (kl + 1:) + in_data(loop) (1:maxlen) = ' ' + dummy = adjustl(dummy) + if (dummy(1:1) == '=' .or. dummy(1:1) == ':') then + dummy = dummy(2:) + dummy = adjustl(dummy) + end if + end do + + if (found) then + if (present(c_value)) c_value = dummy + if (present(l_value)) then + if (index(dummy, 't') > 0) then + l_value = .true. + elseif (index(dummy, 'f') > 0) then + l_value = .false. + else + call io_error('Error: Problem reading logical keyword '//trim(keyword), stdout, seedname) + endif + endif + if (present(i_value)) read (dummy, *, err=220, end=220) i_value + if (present(r_value)) read (dummy, *, err=220, end=220) r_value + end if + + return + +220 call io_error('Error: Problem reading keyword '//trim(keyword), stdout, seedname) + + end subroutine w90_readwrite_get_keyword + + !================================================! + subroutine w90_readwrite_get_keyword_vector(stdout, seedname, keyword, found, length, c_value, & + l_value, i_value, r_value) + !================================================! + ! + !! Finds the values of the required keyword vector + ! + !================================================! + + use w90_io, only: io_error + + implicit none + + character(*), intent(in) :: keyword + !! Keyword to examine + logical, intent(out) :: found + !! Is keyword present + integer, intent(in) :: length + !! Length of vecotr to read + character(*), optional, intent(inout) :: c_value(length) + !! Keyword data + logical, optional, intent(inout) :: l_value(length) + !! Keyword data + integer, optional, intent(inout) :: i_value(length) + !! Keyword data + real(kind=dp), optional, intent(inout) :: r_value(length) + !! Keyword data + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + + integer :: kl, in, loop, i + character(len=maxlen) :: dummy + + kl = len_trim(keyword) + + found = .false. + + do loop = 1, num_lines + in = index(in_data(loop), trim(keyword)) + if (in == 0 .or. in > 1) cycle + if (found) then + call io_error('Error: Found keyword '//trim(keyword)//' more than once in input file', stdout, seedname) + endif + found = .true. + dummy = in_data(loop) (kl + 1:) + in_data(loop) (1:maxlen) = ' ' + dummy = adjustl(dummy) + if (dummy(1:1) == '=' .or. dummy(1:1) == ':') then + dummy = dummy(2:) + dummy = adjustl(dummy) + end if + end do + + if (found) then + if (present(c_value)) read (dummy, *, err=230, end=230) (c_value(i), i=1, length) + if (present(l_value)) then + ! I don't think we need this. Maybe read into a dummy charater + ! array and convert each element to logical + call io_error('w90_readwrite_get_keyword_vector unimplemented for logicals', stdout, seedname) + endif + if (present(i_value)) read (dummy, *, err=230, end=230) (i_value(i), i=1, length) + if (present(r_value)) read (dummy, *, err=230, end=230) (r_value(i), i=1, length) + end if + + return + +230 call io_error('Error: Problem reading keyword '//trim(keyword)//' in w90_readwrite_get_keyword_vector', stdout, seedname) + + end subroutine w90_readwrite_get_keyword_vector + +!================================================! + subroutine w90_readwrite_get_vector_length(stdout, seedname, keyword, found, length) + !================================================! + ! + !! Returns the length of a keyword vector + ! + !================================================! + + use w90_io, only: io_error + + implicit none + + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + character(*), intent(in) :: keyword + !! Keyword to examine + logical, intent(out) :: found + !! Is keyword present + integer, intent(out) :: length + !! length of vector + + integer :: kl, in, loop, pos + character(len=maxlen) :: dummy + + kl = len_trim(keyword) + + found = .false. + + do loop = 1, num_lines + in = index(in_data(loop), trim(keyword)) + if (in == 0 .or. in > 1) cycle + if (found) then + call io_error('Error: Found keyword '//trim(keyword)//' more than once in input file', stdout, seedname) + endif + found = .true. + dummy = in_data(loop) (kl + 1:) + dummy = adjustl(dummy) + if (dummy(1:1) == '=' .or. dummy(1:1) == ':') then + dummy = dummy(2:) + dummy = adjustl(dummy) + end if + end do + + length = 0 + if (found) then + if (len_trim(dummy) == 0) call io_error('Error: keyword '//trim(keyword)//' is blank', stdout, seedname) + length = 1 + dummy = adjustl(dummy) + do + pos = index(dummy, ' ') + dummy = dummy(pos + 1:) + dummy = adjustl(dummy) + if (len_trim(dummy) > 0) then + length = length + 1 + else + exit + endif + + end do + + end if + + return + + end subroutine w90_readwrite_get_vector_length + + !================================================! + subroutine w90_readwrite_get_keyword_block(stdout, seedname, keyword, found, rows, columns, & + bohr, c_value, l_value, i_value, r_value) + !================================================! + ! + !! Finds the values of the required data block + ! + !================================================! + + use w90_io, only: io_error + + implicit none + + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + character(*), intent(in) :: keyword + !! Keyword to examine + logical, intent(out) :: found + !! Is keyword present + integer, intent(in) :: rows + !! Number of rows + integer, intent(in) :: columns + !! Number of columns + character(*), optional, intent(inout) :: c_value(columns, rows) + !! keyword block data + logical, optional, intent(inout) :: l_value(columns, rows) + !! keyword block data + integer, optional, intent(inout) :: i_value(columns, rows) + !! keyword block data + real(kind=dp), optional, intent(inout) :: r_value(columns, rows) + !! keyword block data + real(kind=dp), intent(in) :: bohr + + integer :: in, ins, ine, loop, i, line_e, line_s, counter, blen + logical :: found_e, found_s, lconvert + character(len=maxlen) :: dummy, end_st, start_st + + found_s = .false. + found_e = .false. + + start_st = 'begin '//trim(keyword) + end_st = 'end '//trim(keyword) + + do loop = 1, num_lines + ins = index(in_data(loop), trim(keyword)) + if (ins == 0) cycle + in = index(in_data(loop), 'begin') + if (in == 0 .or. in > 1) cycle + line_s = loop + if (found_s) then + call io_error('Error: Found '//trim(start_st)//' more than once in input file', stdout, seedname) + endif + found_s = .true. + end do + + if (.not. found_s) then + found = .false. + return + end if + + do loop = 1, num_lines + ine = index(in_data(loop), trim(keyword)) + if (ine == 0) cycle + in = index(in_data(loop), 'end') + if (in == 0 .or. in > 1) cycle + line_e = loop + if (found_e) then + call io_error('Error: Found '//trim(end_st)//' more than once in input file', stdout, seedname) + endif + found_e = .true. + end do + + if (.not. found_e) then + call io_error('Error: Found '//trim(start_st)//' but no '//trim(end_st)//' in input file', stdout, seedname) + end if + + if (line_e <= line_s) then + call io_error('Error: '//trim(end_st)//' comes before '//trim(start_st)//' in input file', stdout, seedname) + end if + + ! number of lines of data in block + blen = line_e - line_s - 1 + + ! if( blen /= rows) then + ! if ( index(trim(keyword),'unit_cell_cart').ne.0 ) then + ! if ( blen /= rows+1 ) call io_error('Error: Wrong number of lines in block '//trim(keyword)) + ! else + ! call io_error('Error: Wrong number of lines in block '//trim(keyword)) + ! endif + ! endif + + if ((blen .ne. rows) .and. (blen .ne. rows + 1) .and. (rows .gt. 0)) & + call io_error('Error: Wrong number of lines in block '//trim(keyword), stdout, seedname) + + if ((blen .eq. rows + 1) .and. (rows .gt. 0) .and. (index(trim(keyword), 'unit_cell_cart') .eq. 0)) & + call io_error('Error: Wrong number of lines in block '//trim(keyword), stdout, seedname) + + found = .true. + + lconvert = .false. + if (blen == rows + 1) then + dummy = in_data(line_s + 1) + if (index(dummy, 'ang') .ne. 0) then + lconvert = .false. + elseif (index(dummy, 'bohr') .ne. 0) then + lconvert = .true. + else + call io_error('Error: Units in block '//trim(keyword)//' not recognised', stdout, seedname) + endif + in_data(line_s) (1:maxlen) = ' ' + line_s = line_s + 1 + endif + +! r_value=1.0_dp + counter = 0 + do loop = line_s + 1, line_e - 1 + dummy = in_data(loop) + counter = counter + 1 + if (present(c_value)) read (dummy, *, err=240, end=240) (c_value(i, counter), i=1, columns) + if (present(l_value)) then + ! I don't think we need this. Maybe read into a dummy charater + ! array and convert each element to logical + call io_error('w90_readwrite_get_keyword_block unimplemented for logicals', stdout, seedname) + endif + if (present(i_value)) read (dummy, *, err=240, end=240) (i_value(i, counter), i=1, columns) + if (present(r_value)) read (dummy, *, err=240, end=240) (r_value(i, counter), i=1, columns) + end do + + if (lconvert) then + if (present(r_value)) then + r_value = r_value*bohr + endif + endif + + in_data(line_s:line_e) (1:maxlen) = ' ' + + return + +240 call io_error('Error: Problem reading block keyword '//trim(keyword), stdout, seedname) + + end subroutine w90_readwrite_get_keyword_block + + !================================================! + subroutine w90_readwrite_get_block_length(stdout, seedname, keyword, found, rows, library, lunits) + !================================================! + ! + !! Finds the length of the data block + ! + !================================================! + + use w90_io, only: io_error + + implicit none + + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + character(*), intent(in) :: keyword + !! Keyword to examine + logical, intent(out) :: found + !! Is keyword present + integer, intent(out) :: rows + !! Number of rows + logical, intent(in) :: library + logical, optional, intent(out) :: lunits + !! Have we found a unit specification + + integer :: i, in, ins, ine, loop, line_e, line_s + logical :: found_e, found_s + character(len=maxlen) :: end_st, start_st, dummy + character(len=2) :: atsym + real(kind=dp) :: atpos(3) + + rows = 0 + found_s = .false. + found_e = .false. + + start_st = 'begin '//trim(keyword) + end_st = 'end '//trim(keyword) + + do loop = 1, num_lines + ins = index(in_data(loop), trim(keyword)) + if (ins == 0) cycle + in = index(in_data(loop), 'begin') + if (in == 0 .or. in > 1) cycle + line_s = loop + if (found_s) then + call io_error('Error: Found '//trim(start_st)//' more than once in input file', stdout, seedname) + endif + found_s = .true. + end do + + if (.not. found_s) then + found = .false. + return + end if + + do loop = 1, num_lines + ine = index(in_data(loop), trim(keyword)) + if (ine == 0) cycle + in = index(in_data(loop), 'end') + if (in == 0 .or. in > 1) cycle + line_e = loop + if (found_e) then + call io_error('Error: Found '//trim(end_st)//' more than once in input file', stdout, seedname) + endif + found_e = .true. + end do + + if (.not. found_e) then + call io_error('Error: Found '//trim(start_st)//' but no '//trim(end_st)//' in input file', stdout, seedname) + end if + + if (line_e <= line_s) then + call io_error('Error: '//trim(end_st)//' comes before '//trim(start_st)//' in input file', stdout, seedname) + end if + + rows = line_e - line_s - 1 + + found = .true. + + ! Ignore atoms_cart and atoms_frac blocks if running in library mode + if (library) then + if (trim(keyword) .eq. 'atoms_cart' .or. trim(keyword) .eq. 'atoms_frac') then + in_data(line_s:line_e) (1:maxlen) = ' ' + endif + endif + + if (present(lunits)) then + dummy = in_data(line_s + 1) + read (dummy, *, end=555) atsym, (atpos(i), i=1, 3) + lunits = .false. + endif + + if (rows <= 0) then !cope with empty blocks + found = .false. + in_data(line_s:line_e) (1:maxlen) = ' ' + end if + + return + +555 lunits = .true. + + if (rows <= 1) then !cope with empty blocks + found = .false. + in_data(line_s:line_e) (1:maxlen) = ' ' + end if + + return + + end subroutine w90_readwrite_get_block_length + + !================================================! + subroutine readwrite_get_atoms(atom_data, library, lunits, real_lattice, bohr, stdout, seedname) + !================================================! + ! + !! Fills the atom data block + ! + !================================================! + + use w90_utility, only: utility_frac_to_cart, utility_cart_to_frac, utility_inverse_mat + use w90_io, only: io_error + implicit none + + type(atom_data_type), intent(inout) :: atom_data + integer, intent(in) :: stdout + logical, intent(in) :: library + logical, intent(in) :: lunits + !! Do we expect a first line with the units + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: bohr + character(len=50), intent(in) :: seedname + + real(kind=dp) :: inv_lattice(3, 3) + real(kind=dp) :: atoms_pos_frac_tmp(3, atom_data%num_atoms) + real(kind=dp) :: atoms_pos_cart_tmp(3, atom_data%num_atoms) + character(len=20) :: keyword + integer :: in, ins, ine, loop, i, line_e, line_s, counter + integer :: i_temp, loop2, max_sites, ierr, ic + logical :: found_e, found_s, found, frac + character(len=maxlen) :: dummy, end_st, start_st + character(len=maxlen) :: ctemp(atom_data%num_atoms) + character(len=maxlen) :: atoms_label_tmp(atom_data%num_atoms) + logical :: lconvert + + keyword = "atoms_cart" + frac = .false. + call w90_readwrite_get_block_length(stdout, seedname, "atoms_frac", found, i_temp, library) + if (found) then + keyword = "atoms_frac" + frac = .true. + end if + + found_s = .false. + found_e = .false. + + start_st = 'begin '//trim(keyword) + end_st = 'end '//trim(keyword) + + do loop = 1, num_lines + ins = index(in_data(loop), trim(keyword)) + if (ins == 0) cycle + in = index(in_data(loop), 'begin') + if (in == 0 .or. in > 1) cycle + line_s = loop + if (found_s) then + call io_error('Error: Found '//trim(start_st)//' more than once in input file', stdout, seedname) + endif + found_s = .true. + end do + + do loop = 1, num_lines + ine = index(in_data(loop), trim(keyword)) + if (ine == 0) cycle + in = index(in_data(loop), 'end') + if (in == 0 .or. in > 1) cycle + line_e = loop + if (found_e) then + call io_error('Error: Found '//trim(end_st)//' more than once in input file', stdout, seedname) + endif + found_e = .true. + end do + + if (.not. found_e) then + call io_error('Error: Found '//trim(start_st)//' but no '//trim(end_st)//' in input file', stdout, seedname) + end if + + if (line_e <= line_s) then + call io_error('Error: '//trim(end_st)//' comes before '//trim(start_st)//' in input file', stdout, seedname) + end if + + lconvert = .false. + if (lunits) then + dummy = in_data(line_s + 1) + if (index(dummy, 'ang') .ne. 0) then + lconvert = .false. + elseif (index(dummy, 'bohr') .ne. 0) then + lconvert = .true. + else + call io_error('Error: Units in block atoms_cart not recognised in readwrite_get_atoms', stdout, seedname) + endif + in_data(line_s) (1:maxlen) = ' ' + line_s = line_s + 1 + endif + + counter = 0 + do loop = line_s + 1, line_e - 1 + dummy = in_data(loop) + counter = counter + 1 + if (frac) then + read (dummy, *, err=240, end=240) atoms_label_tmp(counter), (atoms_pos_frac_tmp(i, counter), i=1, 3) + else + read (dummy, *, err=240, end=240) atoms_label_tmp(counter), (atoms_pos_cart_tmp(i, counter), i=1, 3) + end if + end do + + if (lconvert) atoms_pos_cart_tmp = atoms_pos_cart_tmp*bohr + + in_data(line_s:line_e) (1:maxlen) = ' ' + + if (frac) then + do loop = 1, atom_data%num_atoms + call utility_frac_to_cart(atoms_pos_frac_tmp(:, loop), atoms_pos_cart_tmp(:, loop), real_lattice) + end do + else + do loop = 1, atom_data%num_atoms + call utility_cart_to_frac(atoms_pos_cart_tmp(:, loop), atoms_pos_frac_tmp(:, loop), inv_lattice) + end do + end if + + ! Now we sort the data into the proper structures + atom_data%num_species = 1 + ctemp(1) = atoms_label_tmp(1) + do loop = 2, atom_data%num_atoms + do loop2 = 1, loop - 1 + if (trim(atoms_label_tmp(loop)) == trim(atoms_label_tmp(loop2))) exit + if (loop2 == loop - 1) then + atom_data%num_species = atom_data%num_species + 1 + ctemp(atom_data%num_species) = atoms_label_tmp(loop) + end if + end do + end do + + allocate (atom_data%species_num(atom_data%num_species), stat=ierr) + if (ierr /= 0) call io_error('Error allocating atoms_species_num in readwrite_get_atoms', stdout, seedname) + allocate (atom_data%label(atom_data%num_species), stat=ierr) + if (ierr /= 0) call io_error('Error allocating atoms_label in readwrite_get_atoms', stdout, seedname) + allocate (atom_data%symbol(atom_data%num_species), stat=ierr) + if (ierr /= 0) call io_error('Error allocating atoms_symbol in readwrite_get_atoms', stdout, seedname) + atom_data%species_num(:) = 0 + + do loop = 1, atom_data%num_species + atom_data%label(loop) = ctemp(loop) + do loop2 = 1, atom_data%num_atoms + if (trim(atom_data%label(loop)) == trim(atoms_label_tmp(loop2))) then + atom_data%species_num(loop) = atom_data%species_num(loop) + 1 + end if + end do + end do + + max_sites = maxval(atom_data%species_num) + allocate (atom_data%pos_cart(3, max_sites, atom_data%num_species), stat=ierr) + if (ierr /= 0) call io_error('Error allocating atoms_pos_cart in readwrite_get_atoms', stdout, seedname) + + do loop = 1, atom_data%num_species + counter = 0 + do loop2 = 1, atom_data%num_atoms + if (trim(atom_data%label(loop)) == trim(atoms_label_tmp(loop2))) then + counter = counter + 1 + !atom_data%pos_frac(:, counter, loop) = atoms_pos_frac_tmp(:, loop2) + atom_data%pos_cart(:, counter, loop) = atoms_pos_cart_tmp(:, loop2) + end if + end do + end do + + ! Strip any numeric characters from atoms_label to get atoms_symbol + do loop = 1, atom_data%num_species + atom_data%symbol(loop) (1:2) = atom_data%label(loop) (1:2) + ic = ichar(atom_data%symbol(loop) (2:2)) + if ((ic .lt. ichar('a')) .or. (ic .gt. ichar('z'))) & + atom_data%symbol(loop) (2:2) = ' ' + end do + + return + +240 call io_error('Error: Problem reading block keyword '//trim(keyword), stdout, seedname) + + end subroutine readwrite_get_atoms + + !================================================! + subroutine w90_readwrite_lib_set_atoms(atom_data, atoms_label_tmp, atoms_pos_cart_tmp, real_lattice, & + stdout, seedname) + !================================================! + ! + !! Fills the atom data block during a library call + ! + !================================================! + + use w90_utility, only: utility_cart_to_frac, utility_inverse_mat, utility_lowercase + use w90_io, only: io_error + + implicit none + + integer, intent(in) :: stdout + type(atom_data_type), intent(inout) :: atom_data + character(len=*), intent(in) :: atoms_label_tmp(atom_data%num_atoms) + !! Atom labels + real(kind=dp), intent(in) :: atoms_pos_cart_tmp(3, atom_data%num_atoms) + !! Atom positions + real(kind=dp), intent(in) :: real_lattice(3, 3) + character(len=50), intent(in) :: seedname + + real(kind=dp) :: inv_lattice(3, 3) + real(kind=dp) :: atoms_pos_frac_tmp(3, atom_data%num_atoms) + integer :: loop2, max_sites, ierr, ic, loop, counter + character(len=maxlen) :: ctemp(atom_data%num_atoms) + character(len=maxlen) :: tmp_string + + call utility_inverse_mat(real_lattice, inv_lattice) + do loop = 1, atom_data%num_atoms + call utility_cart_to_frac(atoms_pos_cart_tmp(:, loop), & + atoms_pos_frac_tmp(:, loop), inv_lattice) + enddo + + ! Now we sort the data into the proper structures + atom_data%num_species = 1 + ctemp(1) = atoms_label_tmp(1) + do loop = 2, atom_data%num_atoms + do loop2 = 1, loop - 1 + if (trim(atoms_label_tmp(loop)) == trim(atoms_label_tmp(loop2))) exit + if (loop2 == loop - 1) then + atom_data%num_species = atom_data%num_species + 1 + ctemp(atom_data%num_species) = atoms_label_tmp(loop) + end if + end do + end do + + allocate (atom_data%species_num(atom_data%num_species), stat=ierr) + if (ierr /= 0) call io_error('Error allocating atoms_species_num in w90_readwrite_lib_set_atoms', stdout, seedname) + allocate (atom_data%label(atom_data%num_species), stat=ierr) + if (ierr /= 0) call io_error('Error allocating atoms_label in w90_readwrite_lib_set_atoms', stdout, seedname) + allocate (atom_data%symbol(atom_data%num_species), stat=ierr) + if (ierr /= 0) call io_error('Error allocating atoms_symbol in w90_readwrite_lib_set_atoms', stdout, seedname) + atom_data%species_num(:) = 0 + + do loop = 1, atom_data%num_species + atom_data%label(loop) = ctemp(loop) + do loop2 = 1, atom_data%num_atoms + if (trim(atom_data%label(loop)) == trim(atoms_label_tmp(loop2))) then + atom_data%species_num(loop) = atom_data%species_num(loop) + 1 + end if + end do + end do + + max_sites = maxval(atom_data%species_num) + allocate (atom_data%pos_cart(3, max_sites, atom_data%num_species), stat=ierr) + if (ierr /= 0) call io_error('Error allocating atoms_pos_cart in w90_readwrite_lib_set_atoms', stdout, seedname) + + do loop = 1, atom_data%num_species + counter = 0 + do loop2 = 1, atom_data%num_atoms + if (trim(atom_data%label(loop)) == trim(atoms_label_tmp(loop2))) then + counter = counter + 1 + !atom_data%pos_frac(:, counter, loop) = atoms_pos_frac_tmp(:, loop2) + atom_data%pos_cart(:, counter, loop) = atoms_pos_cart_tmp(:, loop2) + end if + end do + end do + + ! Strip any numeric characters from atoms_label to get atoms_symbol + do loop = 1, atom_data%num_species + atom_data%symbol(loop) (1:2) = atom_data%label(loop) (1:2) + ic = ichar(atom_data%symbol(loop) (2:2)) + if ((ic .lt. ichar('a')) .or. (ic .gt. ichar('z'))) & + atom_data%symbol(loop) (2:2) = ' ' + tmp_string = trim(adjustl(utility_lowercase(atom_data%symbol(loop)))) + atom_data%symbol(loop) (1:2) = tmp_string(1:2) + tmp_string = trim(adjustl(utility_lowercase(atom_data%label(loop)))) + atom_data%label(loop) (1:2) = tmp_string(1:2) + end do + + return + + end subroutine w90_readwrite_lib_set_atoms + + !================================================! + subroutine w90_readwrite_get_range_vector(stdout, seedname, keyword, found, length, lcount, i_value) + !================================================! + !! Read a range vector eg. 1,2,3,4-10 or 1 3 400:100 + !! if(lcount) we return the number of states in length + !================================================! + use w90_io, only: io_error + + implicit none + + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + character(*), intent(in) :: keyword + !! Keyword to examine + logical, intent(out) :: found + !! Is keyword found + integer, intent(inout) :: length + !! Number of states + logical, intent(in) :: lcount + !! If T only count states + integer, optional, intent(out) :: i_value(length) + !! States specified in range vector + + integer :: kl, in, loop, num1, num2, i_punc + integer :: counter, i_digit, loop_r, range_size + character(len=maxlen) :: dummy + character(len=10), parameter :: c_digit = "0123456789" + character(len=2), parameter :: c_range = "-:" + character(len=3), parameter :: c_sep = " ,;" + character(len=5), parameter :: c_punc = " ,;-:" + character(len=5) :: c_num1, c_num2 + + if (lcount .and. present(i_value)) call io_error('w90_readwrite_get_range_vector: incorrect call', stdout, seedname) + + kl = len_trim(keyword) + + found = .false. + + do loop = 1, num_lines + in = index(in_data(loop), trim(keyword)) + if (in == 0 .or. in > 1) cycle + if (found) then + call io_error('Error: Found keyword '//trim(keyword)//' more than once in input file', stdout, seedname) + endif + found = .true. + dummy = in_data(loop) (kl + 1:) + dummy = adjustl(dummy) + if (.not. lcount) in_data(loop) (1:maxlen) = ' ' + if (dummy(1:1) == '=' .or. dummy(1:1) == ':') then + dummy = dummy(2:) + dummy = adjustl(dummy) + end if + end do + + if (.not. found) return + + counter = 0 + if (len_trim(dummy) == 0) call io_error('Error: keyword '//trim(keyword)//' is blank', stdout, seedname) + dummy = adjustl(dummy) + do + i_punc = scan(dummy, c_punc) + if (i_punc == 0) call io_error('Error parsing keyword '//trim(keyword), stdout, seedname) + c_num1 = dummy(1:i_punc - 1) + read (c_num1, *, err=101, end=101) num1 + dummy = adjustl(dummy(i_punc:)) + !look for range + if (scan(dummy, c_range) == 1) then + i_digit = scan(dummy, c_digit) + dummy = adjustl(dummy(i_digit:)) + i_punc = scan(dummy, c_punc) + c_num2 = dummy(1:i_punc - 1) + read (c_num2, *, err=101, end=101) num2 + dummy = adjustl(dummy(i_punc:)) + range_size = abs(num2 - num1) + 1 + do loop_r = 1, range_size + counter = counter + 1 + if (.not. lcount) i_value(counter) = min(num1, num2) + loop_r - 1 + end do + else + counter = counter + 1 + if (.not. lcount) i_value(counter) = num1 + end if + + if (scan(dummy, c_sep) == 1) dummy = adjustl(dummy(2:)) + if (scan(dummy, c_range) == 1) call io_error('Error parsing keyword '//trim(keyword)//' incorrect range', stdout, seedname) + if (index(dummy, ' ') == 1) exit + end do + + if (lcount) length = counter + if (.not. lcount) then + do loop = 1, counter - 1 + do loop_r = loop + 1, counter + if (i_value(loop) == i_value(loop_r)) & + call io_error('Error parsing keyword '//trim(keyword)//' duplicate values', stdout, seedname) + end do + end do + end if + + return + +101 call io_error('Error parsing keyword '//trim(keyword), stdout, seedname) + + end subroutine w90_readwrite_get_range_vector + + subroutine w90_readwrite_get_centre_constraints(ccentres_frac, ccentres_cart, & + proj_site, num_wann, real_lattice, stdout, seedname) + !================================================! + !! assigns projection centres as default centre constraints and global + !! Lagrange multiplier as individual Lagrange multipliers then reads + !! the centre_constraints block for individual centre constraint parameters + ! + !================================================! + use w90_io, only: io_error + use w90_utility, only: utility_frac_to_cart + integer, intent(in) :: stdout + real(kind=dp), intent(inout) :: ccentres_frac(:, :), ccentres_cart(:, :) + real(kind=dp), intent(in) :: proj_site(:, :) + integer, intent(in) :: num_wann + character(len=50), intent(in) :: seedname + real(kind=dp), intent(in) :: real_lattice(3, 3) + + integer :: loop1, index1, constraint_num, loop2 + integer :: column, start, finish, wann + !logical :: found + character(len=maxlen) :: dummy + + do loop1 = 1, num_wann + do loop2 = 1, 3 + ccentres_frac(loop1, loop2) = proj_site(loop2, loop1) + end do + end do + + constraint_num = 0 + do loop1 = 1, num_lines + dummy = in_data(loop1) + if (constraint_num > 0) then + if (trim(dummy) == '') cycle + index1 = index(dummy, 'begin') + if (index1 > 0) call io_error("slwf_centres block hasn't ended yet", stdout, seedname) + index1 = index(dummy, 'end') + if (index1 > 0) then + index1 = index(dummy, 'slwf_centres') + if (index1 == 0) call io_error('Wrong ending of block (need to end slwf_centres)', stdout, seedname) + in_data(loop1) (1:maxlen) = ' ' + exit + end if + column = 0 + start = 1 + finish = 1 + do loop2 = 1, len_trim(dummy) + if (start == loop2 .and. dummy(loop2:loop2) == ' ') then + start = loop2 + 1 + end if + if (start < loop2) then + if (dummy(loop2:loop2) == ' ') then + finish = loop2 - 1 + call get_centre_constraint_from_column(column, start, finish, & + wann, dummy, ccentres_frac, stdout, seedname) + start = loop2 + 1 + finish = start + end if + end if + if (loop2 == len_trim(dummy) .and. dummy(loop2:loop2) /= ' ') then + finish = loop2 + call get_centre_constraint_from_column(column, start, finish, & + wann, dummy, ccentres_frac, stdout, seedname) + start = loop2 + 1 + finish = start + end if + end do + in_data(loop1) (1:maxlen) = ' ' + constraint_num = constraint_num + 1 + end if + index1 = index(dummy, 'slwf_centres') + if (index1 > 0) then + index1 = index(dummy, 'begin') + if (index1 > 0) then + constraint_num = 1 + in_data(loop1) (1:maxlen) = ' ' + end if + end if + end do + do loop1 = 1, num_wann + call utility_frac_to_cart(ccentres_frac(loop1, :), & + ccentres_cart(loop1, :), real_lattice) + end do + end subroutine w90_readwrite_get_centre_constraints + + !================================================! + subroutine get_centre_constraint_from_column(column, start, finish, & + wann, dummy, ccentres_frac, stdout, seedname) + !================================================! + ! + !! assigns value read to constraint + !! parameters based on column + ! + !================================================! + use w90_io, only: io_error + integer, intent(in) :: stdout + integer, intent(inout):: column, start, finish, wann + character(len=maxlen), intent(inout):: dummy + character(len=50), intent(in) :: seedname + real(kind=dp), intent(inout) :: ccentres_frac(:, :) + + if (column == 0) then + read (dummy(start:finish), '(i3)') wann + end if + if (column > 0) then + if (column > 4) call io_error("Didn't expect anything else after Lagrange multiplier", stdout, seedname) + if (column < 4) read (dummy(start:finish), '(f10.10)') ccentres_frac(wann, column) + end if + column = column + 1 + end subroutine get_centre_constraint_from_column + + !================================================! + subroutine w90_readwrite_get_projections(num_proj, atom_data, num_wann, input_proj, proj, & + inv_lattice, lcount, spinors, bohr, stdout, seedname) + !================================================! + ! + !! Fills the projection data block + ! + !================================================! + + use w90_constants, only: eps6, eps2 + use w90_utility, only: utility_cart_to_frac, utility_string_to_coord, utility_strip + use w90_io, only: io_error + + implicit none + + ! arguments + type(atom_data_type), intent(in) :: atom_data + type(proj_input_type), intent(inout) :: input_proj + type(proj_input_type), intent(inout) :: proj ! intent(out)? + integer, intent(in) :: num_wann + integer, intent(inout) :: num_proj + integer, intent(in) :: stdout + real(kind=dp), intent(in) :: bohr + real(kind=dp), intent(in) :: inv_lattice(3, 3) + character(len=50), intent(in) :: seedname + logical, intent(in) :: lcount + logical, intent(in) :: spinors + + ! local variables + real(kind=dp) :: pos_frac(3) + real(kind=dp) :: pos_cart(3) + character(len=20) :: keyword + integer :: in, ins, ine, loop, line_e, line_s, counter + integer :: sites, species, line, pos1, pos2, pos3, m_tmp, l_tmp, mstate + integer :: loop_l, loop_m, loop_sites, ierr, loop_s, spn_counter + logical :: found_e, found_s + character(len=maxlen) :: dummy, end_st, start_st + character(len=maxlen) :: ctemp, ctemp2, ctemp3, ctemp4, ctemp5, m_string + + integer, parameter :: min_l = -5 + integer, parameter :: max_l = 3 + integer, parameter :: min_m = 1 + integer, parameter :: max_m = 7 + integer :: ang_states(min_m:max_m, min_l:max_l) + ! default values for the optional part of the projection definitions + real(kind=dp), parameter :: proj_z_def(3) = (/0.0_dp, 0.0_dp, 1.0_dp/) + real(kind=dp), parameter :: proj_x_def(3) = (/1.0_dp, 0.0_dp, 0.0_dp/) + real(kind=dp), parameter :: proj_s_qaxis_def(3) = (/0.0_dp, 0.0_dp, 1.0_dp/) + real(kind=dp), parameter :: proj_zona_def = 1.0_dp + integer, parameter :: proj_radial_def = 1 + + real(kind=dp) :: proj_z_tmp(3) + real(kind=dp) :: proj_x_tmp(3) + real(kind=dp) :: proj_s_qaxis_tmp(3) + real(kind=dp) :: proj_zona_tmp + integer :: proj_radial_tmp + logical :: lconvert, lrandom, proj_u_tmp, proj_d_tmp + logical :: lpartrandom + + real(kind=dp) :: xnorm, znorm, cosphi, sinphi, xnorm_new, cosphi_new + + keyword = "projections" + + found_s = .false. + found_e = .false. + + start_st = 'begin '//trim(keyword) + end_st = 'end '//trim(keyword) + +! if(spinors) num_proj=num_wann/2 + + if (.not. lcount) then + allocate (input_proj%site(3, num_proj), stat=ierr) + if (ierr /= 0) call io_error('Error allocating input_proj_site in w90_readwrite_get_projections', stdout, seedname) + allocate (input_proj%l(num_proj), stat=ierr) + if (ierr /= 0) call io_error('Error allocating input_proj_l in w90_readwrite_get_projections', stdout, seedname) + allocate (input_proj%m(num_proj), stat=ierr) + if (ierr /= 0) call io_error('Error allocating input_proj_m in w90_readwrite_get_projections', stdout, seedname) + allocate (input_proj%z(3, num_proj), stat=ierr) + if (ierr /= 0) call io_error('Error allocating input_proj_z in w90_readwrite_get_projections', stdout, seedname) + allocate (input_proj%x(3, num_proj), stat=ierr) + if (ierr /= 0) call io_error('Error allocating input_proj_x in w90_readwrite_get_projections', stdout, seedname) + allocate (input_proj%radial(num_proj), stat=ierr) + if (ierr /= 0) call io_error('Error allocating input_proj_radial in w90_readwrite_get_projections', stdout, seedname) + allocate (input_proj%zona(num_proj), stat=ierr) + if (ierr /= 0) call io_error('Error allocating input_proj_zona in w90_readwrite_get_projections', stdout, seedname) + if (spinors) then + allocate (input_proj%s(num_proj), stat=ierr) + if (ierr /= 0) call io_error('Error allocating input_proj_s in w90_readwrite_get_projections', stdout, seedname) + allocate (input_proj%s_qaxis(3, num_proj), stat=ierr) + if (ierr /= 0) call io_error('Error allocating input_proj_s_qaxis in w90_readwrite_get_projections', stdout, seedname) + endif + + allocate (proj%site(3, num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error allocating proj_site in w90_readwrite_get_projections', stdout, seedname) + allocate (proj%l(num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error allocating proj_l in w90_readwrite_get_projections', stdout, seedname) + allocate (proj%m(num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error allocating proj_m in w90_readwrite_get_projections', stdout, seedname) + allocate (proj%z(3, num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error allocating proj_z in w90_readwrite_get_projections', stdout, seedname) + allocate (proj%x(3, num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error allocating proj_x in w90_readwrite_get_projections', stdout, seedname) + allocate (proj%radial(num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error allocating proj_radial in w90_readwrite_get_projections', stdout, seedname) + allocate (proj%zona(num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error allocating proj_zona in w90_readwrite_get_projections', stdout, seedname) + if (spinors) then + allocate (proj%s(num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error allocating proj_s in w90_readwrite_get_projections', stdout, seedname) + allocate (proj%s_qaxis(3, num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error allocating proj_s_qaxis in w90_readwrite_get_projections', stdout, seedname) + endif + endif + + do loop = 1, num_lines + ins = index(in_data(loop), trim(keyword)) + if (ins == 0) cycle + in = index(in_data(loop), 'begin') + if (in == 0 .or. in > 1) cycle + line_s = loop + if (found_s) then + call io_error('Error: Found '//trim(start_st)//' more than once in input file', stdout, seedname) + endif + found_s = .true. + end do + + do loop = 1, num_lines + ine = index(in_data(loop), trim(keyword)) + if (ine == 0) cycle + in = index(in_data(loop), 'end') + if (in == 0 .or. in > 1) cycle + line_e = loop + if (found_e) then + call io_error('w90_readwrite_get_projections: Found '//trim(end_st)//' more than once in input file', stdout, seedname) + endif + found_e = .true. + end do + + if (.not. found_e) then + call io_error('w90_readwrite_get_projections: Found '//trim(start_st)//' but no '//trim(end_st)//' in input file', stdout, & + seedname) + end if + + if (line_e <= line_s) then + call io_error('w90_readwrite_get_projections: '//trim(end_st)//' comes before '//trim(start_st)//' in input file', stdout, & + seedname) + end if + + dummy = in_data(line_s + 1) + lconvert = .false. + lrandom = .false. + lpartrandom = .false. + if (index(dummy, 'ang') .ne. 0) then + if (.not. lcount) in_data(line_s) (1:maxlen) = ' ' + line_s = line_s + 1 + elseif (index(dummy, 'bohr') .ne. 0) then + if (.not. lcount) in_data(line_s) (1:maxlen) = ' ' + line_s = line_s + 1 + lconvert = .true. + elseif (index(dummy, 'random') .ne. 0) then + if (.not. lcount) in_data(line_s) (1:maxlen) = ' ' + line_s = line_s + 1 + if (index(in_data(line_s + 1), end_st) .ne. 0) then + lrandom = .true. ! all projections random + else + lpartrandom = .true. ! only some projections random + if (index(in_data(line_s + 1), 'ang') .ne. 0) then + if (.not. lcount) in_data(line_s) (1:maxlen) = ' ' + line_s = line_s + 1 + elseif (index(in_data(line_s + 1), 'bohr') .ne. 0) then + if (.not. lcount) in_data(line_s) (1:maxlen) = ' ' + line_s = line_s + 1 + lconvert = .true. + endif + endif + endif + + counter = 0 + if (.not. lrandom) then + do line = line_s + 1, line_e - 1 + ang_states = 0 + !Assume the default values + proj_z_tmp = proj_z_def + proj_x_tmp = proj_x_def + proj_zona_tmp = proj_zona_def + proj_radial_tmp = proj_radial_def + if (spinors) then + proj_s_qaxis_tmp = proj_s_qaxis_def + spn_counter = 2 + proj_u_tmp = .true. + proj_d_tmp = .true. + else + spn_counter = 1 + endif + ! Strip input line of all spaces + dummy = utility_strip(in_data(line)) + dummy = adjustl(dummy) + pos1 = index(dummy, ':') + if (pos1 == 0) & + call io_error('w90_wannier90_readwrite_read_projection: malformed projection definition: '//trim(dummy), stdout, & + seedname) + sites = 0 + ctemp = dummy(:pos1 - 1) + ! Read the atomic site + if (index(ctemp, 'c=') > 0) then + sites = -1 + ctemp = ctemp(3:) + call utility_string_to_coord(ctemp, pos_cart, stdout, seedname) + if (lconvert) pos_cart = pos_cart*bohr + call utility_cart_to_frac(pos_cart(:), pos_frac(:), inv_lattice) + elseif (index(ctemp, 'f=') > 0) then + sites = -1 + ctemp = ctemp(3:) + call utility_string_to_coord(ctemp, pos_frac, stdout, seedname) + else + if (atom_data%num_species == 0) & + call io_error('w90_wannier90_readwrite_read_projection: Atom centred projection requested but no atoms defined', & + stdout, seedname) + do loop = 1, atom_data%num_species + if (trim(ctemp) == atom_data%label(loop)) then + species = loop + sites = atom_data%species_num(loop) + exit + end if + if (loop == atom_data%num_species) then + call io_error('w90_wannier90_readwrite_read_projection: Atom site not recognised '//trim(ctemp), & + stdout, seedname) + endif + end do + end if + + dummy = dummy(pos1 + 1:) + + ! scan for quantisation direction + pos1 = index(dummy, '[') + if (spinors) then + if (pos1 > 0) then + ctemp = (dummy(pos1 + 1:)) + pos2 = index(ctemp, ']') + if (pos2 == 0) call io_error & + ('w90_readwrite_get_projections: no closing square bracket for spin quantisation dir', stdout, seedname) + ctemp = ctemp(:pos2 - 1) + call utility_string_to_coord(ctemp, proj_s_qaxis_tmp, stdout, seedname) + dummy = dummy(:pos1 - 1) ! remove [ ] section + endif + else + if (pos1 > 0) call io_error('w90_readwrite_get_projections: spin qdir is defined but spinors=.false.', stdout, seedname) + endif + + ! scan for up or down + pos1 = index(dummy, '(') + if (spinors) then + if (pos1 > 0) then + proj_u_tmp = .false.; proj_d_tmp = .false. + ctemp = (dummy(pos1 + 1:)) + pos2 = index(ctemp, ')') + if (pos2 == 0) call io_error('w90_readwrite_get_projections: no closing bracket for spin', stdout, seedname) + ctemp = ctemp(:pos2 - 1) + if (index(ctemp, 'u') > 0) proj_u_tmp = .true. + if (index(ctemp, 'd') > 0) proj_d_tmp = .true. + if (proj_u_tmp .and. proj_d_tmp) then + spn_counter = 2 + elseif (.not. proj_u_tmp .and. .not. proj_d_tmp) then + call io_error('w90_readwrite_get_projections: found brackets but neither u or d', stdout, seedname) + else + spn_counter = 1 + endif + dummy = dummy(:pos1 - 1) ! remove ( ) section + endif + else + if (pos1 > 0) call io_error('w90_readwrite_get_projections: spin is defined but spinors=.false.', stdout, seedname) + endif + + !Now we know the sites for this line. Get the angular momentum states + pos1 = index(dummy, ':') + if (pos1 > 0) then + ctemp = dummy(:pos1 - 1) + else + ctemp = dummy + end if + ctemp2 = ctemp + do + pos2 = index(ctemp2, ';') + if (pos2 == 0) then + ctemp3 = ctemp2 + else + ctemp3 = ctemp2(:pos2 - 1) + endif + if (index(ctemp3, 'l=') == 1) then + mstate = index(ctemp3, ',') + if (mstate > 0) then + read (ctemp3(3:mstate - 1), *, err=101, end=101) l_tmp + else + read (ctemp3(3:), *, err=101, end=101) l_tmp + end if + if (l_tmp < -5 .or. l_tmp > 3) call io_error('w90_readwrite_get_projections: Incorrect l state requested', stdout, & + seedname) + if (mstate == 0) then + if (l_tmp >= 0) then + do loop_m = 1, 2*l_tmp + 1 + ang_states(loop_m, l_tmp) = 1 + end do + elseif (l_tmp == -1) then !sp + ang_states(1:2, l_tmp) = 1 + elseif (l_tmp == -2) then !sp2 + ang_states(1:3, l_tmp) = 1 + elseif (l_tmp == -3) then !sp3 + ang_states(1:4, l_tmp) = 1 + elseif (l_tmp == -4) then !sp3d + ang_states(1:5, l_tmp) = 1 + elseif (l_tmp == -5) then !sp3d2 + ang_states(1:6, l_tmp) = 1 + endif + else + if (index(ctemp3, 'mr=') /= mstate + 1) & + call io_error('w90_readwrite_get_projections: Problem reading m state', stdout, seedname) + ctemp4 = ctemp3(mstate + 4:) + do + pos3 = index(ctemp4, ',') + if (pos3 == 0) then + ctemp5 = ctemp4 + else + ctemp5 = ctemp4(:pos3 - 1) + endif + read (ctemp5(1:), *, err=102, end=102) m_tmp + if (l_tmp >= 0) then + if ((m_tmp > 2*l_tmp + 1) .or. (m_tmp <= 0)) call io_error('w90_readwrite_get_projections: m is > l !', & + stdout, seedname) + elseif (l_tmp == -1 .and. (m_tmp > 2 .or. m_tmp <= 0)) then + call io_error('w90_readwrite_get_projections: m has incorrect value (1)', stdout, seedname) + elseif (l_tmp == -2 .and. (m_tmp > 3 .or. m_tmp <= 0)) then + call io_error('w90_readwrite_get_projections: m has incorrect value (2)', stdout, seedname) + elseif (l_tmp == -3 .and. (m_tmp > 4 .or. m_tmp <= 0)) then + call io_error('w90_readwrite_get_projections: m has incorrect value (3)', stdout, seedname) + elseif (l_tmp == -4 .and. (m_tmp > 5 .or. m_tmp <= 0)) then + call io_error('w90_readwrite_get_projections: m has incorrect value (4)', stdout, seedname) + elseif (l_tmp == -5 .and. (m_tmp > 6 .or. m_tmp <= 0)) then + call io_error('w90_readwrite_get_projections: m has incorrect value (5)', stdout, seedname) + endif + ang_states(m_tmp, l_tmp) = 1 + if (pos3 == 0) exit + ctemp4 = ctemp4(pos3 + 1:) + enddo + end if + else + do + pos3 = index(ctemp3, ',') + if (pos3 == 0) then + ctemp4 = ctemp3 + else + ctemp4 = ctemp3(:pos3 - 1) + endif + read (ctemp4(1:), *, err=106, end=106) m_string + select case (trim(adjustl(m_string))) + case ('s') + ang_states(1, 0) = 1 + case ('p') + ang_states(1:3, 1) = 1 + case ('pz') + ang_states(1, 1) = 1 + case ('px') + ang_states(2, 1) = 1 + case ('py') + ang_states(3, 1) = 1 + case ('d') + ang_states(1:5, 2) = 1 + case ('dz2') + ang_states(1, 2) = 1 + case ('dxz') + ang_states(2, 2) = 1 + case ('dyz') + ang_states(3, 2) = 1 + case ('dx2-y2') + ang_states(4, 2) = 1 + case ('dxy') + ang_states(5, 2) = 1 + case ('f') + ang_states(1:7, 3) = 1 + case ('fz3') + ang_states(1, 3) = 1 + case ('fxz2') + ang_states(2, 3) = 1 + case ('fyz2') + ang_states(3, 3) = 1 + case ('fxyz') + ang_states(4, 3) = 1 + case ('fz(x2-y2)') + ang_states(5, 3) = 1 + case ('fx(x2-3y2)') + ang_states(6, 3) = 1 + case ('fy(3x2-y2)') + ang_states(7, 3) = 1 + case ('sp') + ang_states(1:2, -1) = 1 + case ('sp-1') + ang_states(1, -1) = 1 + case ('sp-2') + ang_states(2, -1) = 1 + case ('sp2') + ang_states(1:3, -2) = 1 + case ('sp2-1') + ang_states(1, -2) = 1 + case ('sp2-2') + ang_states(2, -2) = 1 + case ('sp2-3') + ang_states(3, -2) = 1 + case ('sp3') + ang_states(1:4, -3) = 1 + case ('sp3-1') + ang_states(1, -3) = 1 + case ('sp3-2') + ang_states(2, -3) = 1 + case ('sp3-3') + ang_states(3, -3) = 1 + case ('sp3-4') + ang_states(4, -3) = 1 + case ('sp3d') + ang_states(1:5, -4) = 1 + case ('sp3d-1') + ang_states(1, -4) = 1 + case ('sp3d-2') + ang_states(2, -4) = 1 + case ('sp3d-3') + ang_states(3, -4) = 1 + case ('sp3d-4') + ang_states(4, -4) = 1 + case ('sp3d-5') + ang_states(5, -4) = 1 + case ('sp3d2') + ang_states(1:6, -5) = 1 + case ('sp3d2-1') + ang_states(1, -5) = 1 + case ('sp3d2-2') + ang_states(2, -5) = 1 + case ('sp3d2-3') + ang_states(3, -5) = 1 + case ('sp3d2-4') + ang_states(4, -5) = 1 + case ('sp3d2-5') + ang_states(5, -5) = 1 + case ('sp3d2-6') + ang_states(6, -5) = 1 + case default + call io_error('w90_readwrite_get_projections: Problem reading l state '//trim(ctemp3), stdout, seedname) + end select + if (pos3 == 0) exit + ctemp3 = ctemp3(pos3 + 1:) + enddo + endif + if (pos2 == 0) exit + ctemp2 = ctemp2(pos2 + 1:) + enddo + ! check for non-default values + if (pos1 > 0) then + dummy = dummy(pos1 + 1:) + ! z axis + pos1 = index(dummy, 'z=') + if (pos1 > 0) then + ctemp = (dummy(pos1 + 2:)) + pos2 = index(ctemp, ':') + if (pos2 > 0) ctemp = ctemp(:pos2 - 1) + call utility_string_to_coord(ctemp, proj_z_tmp, stdout, seedname) + endif + ! x axis + pos1 = index(dummy, 'x=') + if (pos1 > 0) then + ctemp = (dummy(pos1 + 2:)) + pos2 = index(ctemp, ':') + if (pos2 > 0) ctemp = ctemp(:pos2 - 1) + call utility_string_to_coord(ctemp, proj_x_tmp, stdout, seedname) + endif + ! diffusivity of orbital + pos1 = index(dummy, 'zona=') + if (pos1 > 0) then + ctemp = (dummy(pos1 + 5:)) + pos2 = index(ctemp, ':') + if (pos2 > 0) ctemp = ctemp(:pos2 - 1) + read (ctemp, *, err=104, end=104) proj_zona_tmp + endif + ! nodes for the radial part + pos1 = index(dummy, 'r=') + if (pos1 > 0) then + ctemp = (dummy(pos1 + 2:)) + pos2 = index(ctemp, ':') + if (pos2 > 0) ctemp = ctemp(:pos2 - 1) + read (ctemp, *, err=105, end=105) proj_radial_tmp + endif + end if + ! if (sites == -1) then + ! if (counter + spn_counter*sum(ang_states) > num_proj) & + ! call io_error('w90_readwrite_get_projections: too many projections defined') + ! else + ! if (counter + spn_counter*sites*sum(ang_states) > num_proj) & + ! call io_error('w90_readwrite_get_projections: too many projections defined') + ! end if + + if (sites == -1) then + do loop_l = min_l, max_l + do loop_m = min_m, max_m + if (ang_states(loop_m, loop_l) == 1) then + do loop_s = 1, spn_counter + counter = counter + 1 + if (lcount) cycle + input_proj%site(:, counter) = pos_frac + input_proj%l(counter) = loop_l + input_proj%m(counter) = loop_m + input_proj%z(:, counter) = proj_z_tmp + input_proj%x(:, counter) = proj_x_tmp + input_proj%radial(counter) = proj_radial_tmp + input_proj%zona(counter) = proj_zona_tmp + if (spinors) then + if (spn_counter == 1) then + if (proj_u_tmp) input_proj%s(counter) = 1 + if (proj_d_tmp) input_proj%s(counter) = -1 + else + if (loop_s == 1) input_proj%s(counter) = 1 + if (loop_s == 2) input_proj%s(counter) = -1 + endif + input_proj%s_qaxis(:, counter) = proj_s_qaxis_tmp + endif + end do + endif + end do + end do + else + do loop_sites = 1, sites + do loop_l = min_l, max_l + do loop_m = min_m, max_m + if (ang_states(loop_m, loop_l) == 1) then + do loop_s = 1, spn_counter + counter = counter + 1 + if (lcount) cycle + call utility_cart_to_frac(atom_data%pos_cart(:, loop_sites, species), pos_frac, & + inv_lattice) + input_proj%site(:, counter) = pos_frac(:) + input_proj%l(counter) = loop_l + input_proj%m(counter) = loop_m + input_proj%z(:, counter) = proj_z_tmp + input_proj%x(:, counter) = proj_x_tmp + input_proj%radial(counter) = proj_radial_tmp + input_proj%zona(counter) = proj_zona_tmp + if (spinors) then + if (spn_counter == 1) then + if (proj_u_tmp) input_proj%s(counter) = 1 + if (proj_d_tmp) input_proj%s(counter) = -1 + else + if (loop_s == 1) input_proj%s(counter) = 1 + if (loop_s == 2) input_proj%s(counter) = -1 + endif + input_proj%s_qaxis(:, counter) = proj_s_qaxis_tmp + endif + end do + end if + end do + end do + end do + end if + + end do !end loop over projection block + + ! check there are enough projections and add random projections if required + if (.not. lpartrandom) then + if (counter .lt. num_wann) call io_error( & + 'w90_readwrite_get_projections: too few projection functions defined', stdout, seedname) + end if + end if ! .not. lrandom + + if (lcount) then + if (counter .lt. num_wann) then + num_proj = num_wann + else + num_proj = counter + endif + return + endif + + if (lpartrandom .or. lrandom) then + call random_seed() ! comment out this line for reproducible random positions! + do loop = counter + 1, num_wann + call random_number(input_proj%site(:, loop)) + input_proj%l(loop) = 0 + input_proj%m(loop) = 1 + input_proj%z(:, loop) = proj_z_def + input_proj%x(:, loop) = proj_x_def + input_proj%zona(loop) = proj_zona_def + input_proj%radial(loop) = proj_radial_def + if (spinors) then + if (modulo(loop, 2) == 1) then + input_proj%s(loop) = 1 + else + input_proj%s(loop) = -1 + end if + input_proj%s_qaxis(1, loop) = 0. + input_proj%s_qaxis(2, loop) = 0. + input_proj%s_qaxis(3, loop) = 1. + end if + enddo + endif + + ! I shouldn't get here, but just in case + if (.not. lcount) in_data(line_s:line_e) (1:maxlen) = ' ' + +!~ ! Check +!~ do loop=1,num_wann +!~ if ( abs(sum(proj_z(:,loop)*proj_x(:,loop))).gt.1.0e-6_dp ) then +!~ write(stdout,*) ' Projection:',loop +!~ call io_error(' Error in projections: z and x axes are not orthogonal') +!~ endif +!~ enddo + + ! Normalise z-axis and x-axis and check/fix orthogonality + do loop = 1, num_proj + + znorm = sqrt(sum(input_proj%z(:, loop)*input_proj%z(:, loop))) + xnorm = sqrt(sum(input_proj%x(:, loop)*input_proj%x(:, loop))) + input_proj%z(:, loop) = input_proj%z(:, loop)/znorm ! normalise z + input_proj%x(:, loop) = input_proj%x(:, loop)/xnorm ! normalise x + cosphi = sum(input_proj%z(:, loop)*input_proj%x(:, loop)) + + ! Check whether z-axis and z-axis are orthogonal + if (abs(cosphi) .gt. eps6) then + + ! Special case of circularly symmetric projections (pz, dz2, fz3) + ! just choose an x-axis that is perpendicular to the given z-axis + if ((input_proj%l(loop) .ge. 0) .and. (input_proj%m(loop) .eq. 1)) then + proj_x_tmp(:) = input_proj%x(:, loop) ! copy of original x-axis + call random_seed() + call random_number(proj_z_tmp(:)) ! random vector + ! calculate new x-axis as the cross (vector) product of random vector with z-axis + input_proj%x(1, loop) = proj_z_tmp(2)*input_proj%z(3, loop) & + - proj_z_tmp(3)*input_proj%z(2, loop) + input_proj%x(2, loop) = proj_z_tmp(3)*input_proj%z(1, loop) & + - proj_z_tmp(1)*input_proj%z(3, loop) + input_proj%x(3, loop) = proj_z_tmp(1)*input_proj%z(2, loop) & + - proj_z_tmp(2)*input_proj%z(1, loop) + xnorm_new = sqrt(sum(input_proj%x(:, loop)*input_proj%x(:, loop))) + input_proj%x(:, loop) = input_proj%x(:, loop)/xnorm_new ! normalise + goto 555 + endif + + ! If projection axes non-orthogonal enough, then + ! user may have made a mistake and should check + if (abs(cosphi) .gt. eps2) then + write (stdout, *) ' Projection:', loop + call io_error(' Error in projections: z and x axes are not orthogonal', stdout, seedname) + endif + + ! If projection axes are "reasonably orthogonal", project x-axis + ! onto plane perpendicular to z-axis to make them more so + sinphi = sqrt(1 - cosphi*cosphi) + proj_x_tmp(:) = input_proj%x(:, loop) ! copy of original x-axis + ! calculate new x-axis: + ! x = z \cross (x_tmp \cross z) / sinphi = ( x_tmp - z(z.x_tmp) ) / sinphi + input_proj%x(:, loop) = (proj_x_tmp(:) - cosphi*input_proj%z(:, loop))/sinphi + + ! Final check +555 cosphi_new = sum(input_proj%z(:, loop)*input_proj%x(:, loop)) + if (abs(cosphi_new) .gt. eps6) then + write (stdout, *) ' Projection:', loop + call io_error(' Error: z and x axes are still not orthogonal after projection', stdout, seedname) + endif + + endif + + enddo + + return + +101 call io_error('w90_readwrite_get_projections: Problem reading l state into integer '//trim(ctemp3), stdout, seedname) +102 call io_error('w90_readwrite_get_projections: Problem reading m state into integer '//trim(ctemp3), stdout, seedname) +104 call io_error('w90_readwrite_get_projections: Problem reading zona into real '//trim(ctemp), stdout, seedname) +105 call io_error('w90_readwrite_get_projections: Problem reading radial state into integer '//trim(ctemp), stdout, seedname) +106 call io_error('w90_readwrite_get_projections: Problem reading m state into string '//trim(ctemp3), stdout, seedname) + + end subroutine w90_readwrite_get_projections + + !================================================! + subroutine w90_readwrite_get_keyword_kpath(kpoint_path, stdout, seedname) + !================================================! + ! + !! Fills the kpath data block + ! + !================================================! + use w90_io, only: io_error + + implicit none + + type(kpoint_path_type), intent(inout) :: kpoint_path + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + + character(len=20) :: keyword + integer :: in, ins, ine, loop, i, line_e, line_s, counter + logical :: found_e, found_s + character(len=maxlen) :: dummy, end_st, start_st + + keyword = "kpoint_path" + + found_s = .false. + found_e = .false. + + start_st = 'begin '//trim(keyword) + end_st = 'end '//trim(keyword) + + do loop = 1, num_lines + ins = index(in_data(loop), trim(keyword)) + if (ins == 0) cycle + in = index(in_data(loop), 'begin') + if (in == 0 .or. in > 1) cycle + line_s = loop + if (found_s) then + call io_error('Error: Found '//trim(start_st)//' more than once in input file', stdout, seedname) + endif + found_s = .true. + end do + + do loop = 1, num_lines + ine = index(in_data(loop), trim(keyword)) + if (ine == 0) cycle + in = index(in_data(loop), 'end') + if (in == 0 .or. in > 1) cycle + line_e = loop + if (found_e) then + call io_error('Error: Found '//trim(end_st)//' more than once in input file', stdout, seedname) + endif + found_e = .true. + end do + + if (.not. found_e) then + call io_error('Error: Found '//trim(start_st)//' but no '//trim(end_st)//' in input file', stdout, seedname) + end if + + if (line_e <= line_s) then + call io_error('Error: '//trim(end_st)//' comes before '//trim(start_st)//' in input file', stdout, seedname) + end if + + counter = 0 + do loop = line_s + 1, line_e - 1 + + counter = counter + 2 + dummy = in_data(loop) + read (dummy, *, err=240, end=240) kpoint_path%labels(counter - 1), & + (kpoint_path%points(i, counter - 1), i=1, 3), & + kpoint_path%labels(counter), (kpoint_path%points(i, counter), i=1, 3) + end do + + in_data(line_s:line_e) (1:maxlen) = ' ' + + return + +240 call io_error('w90_readwrite_get_keyword_kpath: Problem reading kpath '//trim(dummy), stdout, seedname) + + end subroutine w90_readwrite_get_keyword_kpath + + !================================================! + subroutine clear_block(stdout, seedname, keyword) + !================================================! + ! a dummy read routine to remove unused but legitimate input block from input stream + ! needed to preserve input file error checking (i.e. input stream should be empty after all + ! legitimate keywords/blocks are read) + !================================================! + use w90_io, only: io_error + + implicit none + + ! arguments + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + character(len=*), intent(in) :: keyword + + ! local variables + integer :: in, ins, ine, loop, line_e, line_s + logical :: found_e, found_s + character(len=maxlen) :: end_st, start_st + + found_s = .false. + found_e = .false. + + start_st = 'begin '//trim(keyword) + end_st = 'end '//trim(keyword) + + do loop = 1, num_lines + ins = index(in_data(loop), trim(keyword)) + if (ins == 0) cycle + in = index(in_data(loop), 'begin') + if (in == 0 .or. in > 1) cycle + line_s = loop + if (found_s) then + call io_error('Error: Found '//trim(start_st)//' more than once in input file', stdout, seedname) + endif + found_s = .true. + end do + + do loop = 1, num_lines + ine = index(in_data(loop), trim(keyword)) + if (ine == 0) cycle + in = index(in_data(loop), 'end') + if (in == 0 .or. in > 1) cycle + line_e = loop + if (found_e) then + call io_error('Error: Found '//trim(end_st)//' more than once in input file', stdout, seedname) + endif + found_e = .true. + end do + + if (found_s .and. (.not. found_e)) then + call io_error('Error: Found '//trim(start_st)//' but no '//trim(end_st)//' in input file', stdout, seedname) + end if + + if (found_e .and. (.not. found_s)) then + call io_error('Error: Found '//trim(end_st)//' but no '//trim(start_st)//' in input file', stdout, seedname) + end if + + if (found_s .and. found_e) then + if (line_e <= line_s) then + call io_error('Error: '//trim(end_st)//' comes before '//trim(start_st)//' in input file', stdout, seedname) + end if + + in_data(line_s:line_e) (1:maxlen) = ' ' ! clear the block from the input stream + end if ! found tags + end subroutine clear_block + +end module w90_readwrite diff --git a/src/sitesym.F90 b/src/sitesym.F90 index 7c86532a3..1653a0060 100644 --- a/src/sitesym.F90 +++ b/src/sitesym.F90 @@ -12,6 +12,7 @@ ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! ! ! +! w90_sitesym: ! ! Reference: ! ! R. Sakuma, Symmetry-adapted Wannier functions ! ! in the maximal localization procedure, ! @@ -20,50 +21,47 @@ !------------------------------------------------------------! module w90_sitesym + !! Routines to impose the site symmetry during minimisation of spread use w90_constants, only: dp, cmplx_1, cmplx_0 - use w90_io, only: io_error, stdout + use w90_io, only: io_error implicit none - private :: symmetrize_ukirr - private :: orthogonalize_u + private - public :: sitesym_slim_d_matrix_band + public :: sitesym_dealloc + public :: sitesym_dis_extract_symmetry + public :: sitesym_read public :: sitesym_replace_d_matrix_band - public :: sitesym_symmetrize_u_matrix + public :: sitesym_slim_d_matrix_band public :: sitesym_symmetrize_gradient public :: sitesym_symmetrize_rotation + public :: sitesym_symmetrize_u_matrix public :: sitesym_symmetrize_zmatrix - public :: sitesym_dis_extract_symmetry - public :: sitesym_read - public :: sitesym_dealloc - - ! Variables and parameters needed by other modules - integer, public, save :: nkptirr = 9999 - integer, public, save :: nsymmetry = 9999 - integer, allocatable, public, save :: kptsym(:, :), ir2ik(:), ik2ir(:) - complex(kind=dp), allocatable, public, save :: d_matrix_band(:, :, :, :) - complex(kind=dp), allocatable, public, save :: d_matrix_wann(:, :, :, :) contains - !==================================================================! - subroutine sitesym_slim_d_matrix_band(lwindow_in) - !==================================================================! - use w90_parameters, only: num_bands, num_kpts + !================================================! + subroutine sitesym_slim_d_matrix_band(num_bands, num_kpts, sitesym, lwindow_in) + !================================================! + ! not called ! + + use w90_wannier90_types, only: sitesym_type implicit none + integer, intent(in) :: num_bands + integer, intent(in) :: num_kpts logical, optional, intent(in) :: lwindow_in(num_bands, num_kpts) + type(sitesym_type), intent(inout) :: sitesym + integer :: ik, i, j, nb, ir integer :: nindx(num_bands) - !write(stdout,"(a)") '-- sitesym_slim_d_matrix_band --' - - do ir = 1, nkptirr - ik = ir2ik(ir) + do ir = 1, sitesym%nkptirr + ik = sitesym%ir2ik(ir) j = 0 do i = 1, num_bands if (lwindow_in(i, ik)) then @@ -74,9 +72,9 @@ subroutine sitesym_slim_d_matrix_band(lwindow_in) nb = j do j = 1, nb i = nindx(j) - d_matrix_band(1:nb, j, :, ir) = d_matrix_band(nindx(1:nb), i, :, ir) + sitesym%d_matrix_band(1:nb, j, :, ir) = sitesym%d_matrix_band(nindx(1:nb), i, :, ir) if (nb .lt. num_bands) then - d_matrix_band(nb + 1:, j, :, ir) = 0 + sitesym%d_matrix_band(nb + 1:, j, :, ir) = 0 endif enddo enddo @@ -84,56 +82,70 @@ subroutine sitesym_slim_d_matrix_band(lwindow_in) return end subroutine sitesym_slim_d_matrix_band - !==================================================================! - subroutine sitesym_replace_d_matrix_band() - !==================================================================! - use w90_parameters, only: num_wann + !================================================! + subroutine sitesym_replace_d_matrix_band(sitesym, num_wann) + !================================================! + + use w90_wannier90_types, only: sitesym_type implicit none - !write(stdout,"(a)") '-- sitesym_replace_d_matrix_band --' - !write(stdout,"(a)") 'd_matrix_band is replaced by d_matrix_wann' - deallocate (d_matrix_band) - allocate (d_matrix_band(num_wann, num_wann, nsymmetry, nkptirr)) - d_matrix_band = d_matrix_wann + integer, intent(in) :: num_wann + type(sitesym_type), intent(inout) :: sitesym + + deallocate (sitesym%d_matrix_band) + allocate (sitesym%d_matrix_band(num_wann, num_wann, sitesym%nsymmetry, sitesym%nkptirr)) + sitesym%d_matrix_band = sitesym%d_matrix_wann return end subroutine sitesym_replace_d_matrix_band - !==========================================================================! - subroutine sitesym_symmetrize_u_matrix(ndim, umat, lwindow_in) - !==========================================================================! - ! ! - ! calculate U(Rk)=d(R,k)*U(k)*D^{\dagger}(R,k) in the following two cases: ! - ! ! - ! 1. "disentanglement" phase (present(lwindow)) ! - ! ndim=num_bands ! - ! ! - ! 2. Minimization of Omega_{D+OD} (.not.present(lwindow)) ! - ! ndim=num_wann, d=d_matrix_band ! - ! ! - !==========================================================================! - use w90_parameters, only: num_wann, num_bands, num_kpts + !================================================! + subroutine sitesym_symmetrize_u_matrix(sitesym, umat, num_bands, ndim, num_kpts, num_wann, & + seedname, stdout, lwindow_in) + !================================================! + ! + ! calculate U(Rk)=d(R,k)*U(k)*D^{\dagger}(R,k) in the following two cases: + ! + ! 1. "disentanglement" phase (present(lwindow)) + ! ndim=num_bands + ! + ! 2. Minimization of Omega_{D+OD} (.not.present(lwindow)) + ! ndim=num_wann, d=sym%d_matrix_band + ! + !================================================! + use w90_wannier90_types, only: sitesym_type implicit none + ! arguments + type(sitesym_type), intent(in) :: sitesym + + integer, intent(in) :: num_bands + integer, intent(in) :: stdout + integer, intent(in) :: num_wann + integer, intent(in) :: num_kpts integer, intent(in) :: ndim + complex(kind=dp), intent(inout) :: umat(ndim, num_wann, num_kpts) + logical, optional, intent(in) :: lwindow_in(num_bands, num_kpts) - ! local + character(len=50), intent(in) :: seedname + + ! local variables integer :: ik, ir, isym, irk, n logical :: ldone(num_kpts) complex(kind=dp) :: cmat(ndim, num_wann) - if (present(lwindow_in) .and. (ndim .ne. num_bands)) call io_error('ndim!=num_bands') + if (present(lwindow_in) .and. (ndim .ne. num_bands)) call io_error('ndim!=num_bands', stdout, seedname) if (.not. present(lwindow_in)) then - if (ndim .ne. num_wann) call io_error('ndim!=num_wann') + if (ndim .ne. num_wann) call io_error('ndim!=num_wann', stdout, seedname) endif ldone = .false. - do ir = 1, nkptirr - ik = ir2ik(ir) + do ir = 1, sitesym%nkptirr + ik = sitesym%ir2ik(ir) ldone(ik) = .true. if (present(lwindow_in)) then n = count(lwindow_in(:, ik)) @@ -141,39 +153,46 @@ subroutine sitesym_symmetrize_u_matrix(ndim, umat, lwindow_in) n = ndim endif if (present(lwindow_in)) then - call symmetrize_ukirr(ir, ndim, umat(:, :, ik), n) + call symmetrize_ukirr(num_wann, num_bands, ir, ndim, umat(:, :, ik), sitesym, stdout, & + seedname, n) else - call symmetrize_ukirr(ir, ndim, umat(:, :, ik)) + call symmetrize_ukirr(num_wann, num_bands, ir, ndim, umat(:, :, ik), sitesym, stdout, & + seedname) endif - do isym = 2, nsymmetry - irk = kptsym(isym, ir) + do isym = 2, sitesym%nsymmetry + irk = sitesym%kptsym(isym, ir) if (ldone(irk)) cycle ldone(irk) = .true. ! cmat = d(R,k) * U(k) call zgemm('N', 'N', n, num_wann, n, cmplx_1, & - d_matrix_band(:, :, isym, ir), ndim, & + sitesym%d_matrix_band(:, :, isym, ir), ndim, & umat(:, :, ik), ndim, cmplx_0, cmat, ndim) ! umat(Rk) = cmat*D^{+}(R,k) = d(R,k) * U(k) * D^{+}(R,k) call zgemm('N', 'C', n, num_wann, num_wann, cmplx_1, cmat, ndim, & - d_matrix_wann(:, :, isym, ir), num_wann, cmplx_0, umat(:, :, irk), ndim) + sitesym%d_matrix_wann(:, :, isym, ir), num_wann, cmplx_0, umat(:, :, irk), ndim) enddo enddo - if (any(.not. ldone)) call io_error('error in sitesym_symmetrize_u_matrix') + if (any(.not. ldone)) call io_error('error in sitesym_symmetrize_u_matrix', stdout, seedname) return end subroutine sitesym_symmetrize_u_matrix - !==================================================================! - subroutine sitesym_symmetrize_gradient(imode, grad) - !==================================================================! - use w90_parameters, only: num_wann, num_kpts + !================================================! + subroutine sitesym_symmetrize_gradient(sitesym, grad, imode, num_kpts, num_wann) + !================================================! + use w90_utility, only: utility_zgemm + use w90_wannier90_types, only: sitesym_type implicit none - integer, intent(in) :: imode + ! arguments + type(sitesym_type), intent(in) :: sitesym + integer, intent(in) :: imode, num_wann, num_kpts complex(kind=dp), intent(inout) :: grad(num_wann, num_wann, num_kpts) + + ! local variables integer :: ik, ir, isym, irk, ngk complex(kind=dp) :: grad_total(num_wann, num_wann) @@ -184,49 +203,49 @@ subroutine sitesym_symmetrize_gradient(imode, grad) if (imode .eq. 1) then lfound = .false. - do ir = 1, nkptirr - ik = ir2ik(ir) + do ir = 1, sitesym%nkptirr + ik = sitesym%ir2ik(ir) grad_total = grad(:, :, ik) lfound(ik) = .true. - do isym = 2, nsymmetry - irk = kptsym(isym, ir) + do isym = 2, sitesym%nsymmetry + irk = sitesym%kptsym(isym, ir) if (lfound(irk)) cycle lfound(irk) = .true. ! ! cmat1 = D(R,k)^{+} G(Rk) D(R,k) ! cmat2 = D(R,k)^{\dagger} G(Rk) ! - call utility_zgemm(cmat2, d_matrix_wann(:, :, isym, ir), 'C', & + call utility_zgemm(cmat2, sitesym%d_matrix_wann(:, :, isym, ir), 'C', & grad(:, :, irk), 'N', num_wann) call utility_zgemm(cmat1, cmat2, 'N', & - d_matrix_wann(:, :, isym, ir), 'N', num_wann) + sitesym%d_matrix_wann(:, :, isym, ir), 'N', num_wann) grad_total = grad_total + cmat1 enddo grad(:, :, ik) = grad_total enddo do ik = 1, num_kpts - if (ir2ik(ik2ir(ik)) .ne. ik) grad(:, :, ik) = 0 + if (sitesym%ir2ik(sitesym%ik2ir(ik)) .ne. ik) grad(:, :, ik) = 0 enddo endif ! if (imode.eq.1) ! ! grad -> 1/N_{R'} \sum_{R'} D^{+}(R',k) grad D(R',k) ! where R' k = k ! - do ir = 1, nkptirr - ik = ir2ik(ir) - ngk = count(kptsym(:, ir) .eq. ik) + do ir = 1, sitesym%nkptirr + ik = sitesym%ir2ik(ir) + ngk = count(sitesym%kptsym(:, ir) .eq. ik) if (ngk .eq. 1) cycle grad_total = grad(:, :, ik) - do isym = 2, nsymmetry - if (kptsym(isym, ir) .ne. ik) cycle + do isym = 2, sitesym%nsymmetry + if (sitesym%kptsym(isym, ir) .ne. ik) cycle ! ! calculate cmat1 = D^{+}(R,k) G(Rk) D(R,k) ! ! step 1: cmat2 = G(Rk) D(R,k) call utility_zgemm(cmat2, grad(:, :, ik), 'N', & - d_matrix_wann(:, :, isym, ir), 'N', num_wann) + sitesym%d_matrix_wann(:, :, isym, ir), 'N', num_wann) ! step 2: cmat1 = D^{+}(R,k) * cmat2 - call utility_zgemm(cmat1, d_matrix_wann(:, :, isym, ir), 'C', & + call utility_zgemm(cmat1, sitesym%d_matrix_wann(:, :, isym, ir), 'C', & cmat2, 'N', num_wann) grad_total = grad_total + cmat1 enddo @@ -236,58 +255,74 @@ subroutine sitesym_symmetrize_gradient(imode, grad) return end subroutine sitesym_symmetrize_gradient - !==================================================================! - subroutine sitesym_symmetrize_rotation(urot) - !==================================================================! - use w90_parameters, only: num_wann, num_kpts, u_matrix + !================================================! + subroutine sitesym_symmetrize_rotation(sitesym, urot, num_kpts, num_wann, seedname, stdout) + !================================================! use w90_utility, only: utility_zgemm + use w90_wannier90_types, only: sitesym_type implicit none - integer :: ik, ir, isym, irk + ! arguments + type(sitesym_type), intent(in) :: sitesym + + integer, intent(in) :: num_wann, num_kpts + integer, intent(in) :: stdout complex(kind=dp), intent(inout) :: urot(num_wann, num_wann, num_kpts) + character(len=50), intent(in) :: seedname + ! local variables + integer :: ik, ir, isym, irk complex(kind=dp) :: cmat1(num_wann, num_wann) complex(kind=dp) :: cmat2(num_wann, num_wann) logical :: ldone(num_kpts) ldone = .false. - do ir = 1, nkptirr - ik = ir2ik(ir) + do ir = 1, sitesym%nkptirr + ik = sitesym%ir2ik(ir) ldone(ik) = .true. - do isym = 2, nsymmetry - irk = kptsym(isym, ir) + do isym = 2, sitesym%nsymmetry + irk = sitesym%kptsym(isym, ir) if (irk .eq. ik) cycle if (ldone(irk)) cycle ldone(irk) = .true. ! cmat2 = UROT(k)*D(R,k)^{\dagger} call utility_zgemm(cmat2, urot(:, :, ik), 'N', & - d_matrix_wann(:, :, isym, ir), 'C', num_wann) + sitesym%d_matrix_wann(:, :, isym, ir), 'C', num_wann) ! cmat1 = D(R,k)*cmat2 - call utility_zgemm(cmat1, d_matrix_wann(:, :, isym, ir), 'N', & + call utility_zgemm(cmat1, sitesym%d_matrix_wann(:, :, isym, ir), 'N', & cmat2, 'N', num_wann) urot(:, :, irk) = cmat1(:, :) enddo enddo - if (any(.not. ldone)) call io_error('error in sitesym_symmetrize_rotation') + if (any(.not. ldone)) call io_error('error in sitesym_symmetrize_rotation', stdout, seedname) return end subroutine sitesym_symmetrize_rotation - !==================================================================! - subroutine sitesym_symmetrize_zmatrix(czmat, lwindow_in) - !==================================================================! - ! ! - ! Z(k) <- \sum_{R} d^{+}(R,k) Z(Rk) d(R,k) ! - ! ! - !==================================================================! - use w90_parameters, only: num_bands, num_kpts + !================================================! + subroutine sitesym_symmetrize_zmatrix(sitesym, czmat, num_bands, num_kpts, lwindow_in) + !================================================! + ! + ! Z(k) <- \sum_{R} d^{+}(R,k) Z(Rk) d(R,k) + ! + !================================================! + use w90_wannier90_types, only: sitesym_type implicit none + ! arguments + type(sitesym_type), intent(in) :: sitesym + + integer, intent(in) :: num_bands + integer, intent(in) :: num_kpts + complex(kind=dp), intent(inout) :: czmat(num_bands, num_bands, num_kpts) + logical, intent(in) :: lwindow_in(num_bands, num_kpts) + + ! local variables logical :: lfound(num_kpts) integer :: ik, ir, isym, irk, nd complex(kind=dp) :: cztmp(num_bands, num_bands) @@ -295,60 +330,65 @@ subroutine sitesym_symmetrize_zmatrix(czmat, lwindow_in) complex(kind=dp) :: cmat2(num_bands, num_bands) lfound = .false. - do ir = 1, nkptirr - ik = ir2ik(ir) + do ir = 1, sitesym%nkptirr + ik = sitesym%ir2ik(ir) nd = count(lwindow_in(:, ik)) lfound(ik) = .true. - do isym = 2, nsymmetry - irk = kptsym(isym, ir) + do isym = 2, sitesym%nsymmetry + irk = sitesym%kptsym(isym, ir) if (lfound(irk)) cycle lfound(irk) = .true. ! cmat1 = Z(R,k)*d(R,k) call zgemm('N', 'N', nd, nd, nd, cmplx_1, czmat(:, :, irk), num_bands, & - d_matrix_band(:, :, isym, ir), num_bands, cmplx_0, cmat1, num_bands) + sitesym%d_matrix_band(:, :, isym, ir), num_bands, cmplx_0, cmat1, num_bands) ! cmat2 = d^{+}(R,k) Z(R,k) d(R,k) = d^{+}(R,k) cmat1 - call zgemm('C', 'N', nd, nd, nd, cmplx_1, d_matrix_band(:, :, isym, ir), num_bands, & - cmat1, num_bands, cmplx_0, cmat2, num_bands) + call zgemm('C', 'N', nd, nd, nd, cmplx_1, sitesym%d_matrix_band(:, :, isym, ir), & + num_bands, cmat1, num_bands, cmplx_0, cmat2, num_bands) czmat(:, :, ik) = czmat(:, :, ik) + cmat2(:, :) enddo cztmp(:, :) = czmat(:, :, ik) - do isym = 2, nsymmetry - irk = kptsym(isym, ir) + do isym = 2, sitesym%nsymmetry + irk = sitesym%kptsym(isym, ir) if (irk .ne. ik) cycle call zgemm('N', 'N', nd, nd, nd, cmplx_1, cztmp, num_bands, & - d_matrix_band(:, :, isym, ir), num_bands, cmplx_0, cmat1, num_bands) + sitesym%d_matrix_band(:, :, isym, ir), num_bands, cmplx_0, cmat1, num_bands) ! cmat2 = d^{+}(R,k) Z(R,k) d(R,k) = d^{+}(R,k) cmat1 - call zgemm('C', 'N', nd, nd, nd, cmplx_1, d_matrix_band(:, :, isym, ir), num_bands, & - cmat1, num_bands, cmplx_0, cmat2, num_bands) + call zgemm('C', 'N', nd, nd, nd, cmplx_1, sitesym%d_matrix_band(:, :, isym, ir), & + num_bands, cmat1, num_bands, cmplx_0, cmat2, num_bands) czmat(:, :, ik) = czmat(:, :, ik) + cmat2(:, :) enddo - czmat(:, :, ik) = czmat(:, :, ik)/count(kptsym(:, ir) .eq. ik) + czmat(:, :, ik) = czmat(:, :, ik)/count(sitesym%kptsym(:, ir) .eq. ik) enddo return end subroutine sitesym_symmetrize_zmatrix - !==================================================================! - subroutine symmetrize_ukirr(ir, ndim, umat, n) - !==================================================================! - ! ! - ! calculate u~(k)=1/N_{R'} \sum_{R'} d^{+}(R',k) u(k) D(R',k) ! - ! where R'k = k ! - ! and orthonormalize it ! - ! ! - !==================================================================! - use w90_parameters, only: num_wann, num_bands, symmetrize_eps + !================================================! + subroutine symmetrize_ukirr(num_wann, num_bands, ir, ndim, umat, & + sitesym, stdout, seedname, n) + !================================================! + ! + ! calculate u~(k)=1/N_{R'} \sum_{R'} d^{+}(R',k) u(k) D(R',k) + ! where R'k = k + ! and orthonormalize it + ! + !================================================! + use w90_wannier90_types, only: sitesym_type implicit none + integer, intent(in) :: num_bands + integer, intent(in) :: stdout + integer, intent(in) :: num_wann + type(sitesym_type), intent(in) :: sitesym integer, intent(in) :: ir, ndim complex(kind=dp), intent(inout) :: umat(ndim, num_wann) integer, optional, intent(in) :: n + character(len=50), intent(in) :: seedname integer :: isym, ngk, i, iter, ntmp integer, parameter :: niter = 100 - real(kind=dp) :: diff complex(kind=dp) :: usum(ndim, num_wann) complex(kind=dp) :: cmat_sub(ndim, num_wann) @@ -357,16 +397,16 @@ subroutine symmetrize_ukirr(ir, ndim, umat, n) !write(stdout,"(a)") '-- symmetrize_ukirr --' if (present(n)) then - if (ndim .ne. num_bands) call io_error('ndim!=num_bands') + if (ndim .ne. num_bands) call io_error('ndim!=num_bands', stdout, seedname) ntmp = n else - if (ndim .ne. num_wann) call io_error('ndim!=num_wann') + if (ndim .ne. num_wann) call io_error('ndim!=num_wann', stdout, seedname) ntmp = ndim endif - ngk = count(kptsym(:, ir) .eq. ir2ik(ir)) + ngk = count(sitesym%kptsym(:, ir) .eq. sitesym%ir2ik(ir)) if (ngk .eq. 1) then - call orthogonalize_u(ndim, num_wann, umat, ntmp) + call orthogonalize_u(ndim, num_wann, umat, ntmp, stdout, seedname) return endif @@ -376,19 +416,19 @@ subroutine symmetrize_ukirr(ir, ndim, umat, n) do i = 1, num_wann cmat2(i, i) = cmat2(i, i) + ngk enddo - do isym = 1, nsymmetry - if (kptsym(isym, ir) .ne. ir2ik(ir)) cycle + do isym = 1, sitesym%nsymmetry + if (sitesym%kptsym(isym, ir) .ne. sitesym%ir2ik(ir)) cycle ! ! cmat = d^{+}(R,k) U(k) D(R,k) ! size of umat: umat(ndim,num_wann) ! ! cmat_sub = U(k) D(R,k) call zgemm('N', 'N', ntmp, num_wann, num_wann, cmplx_1, & - umat, ndim, d_matrix_wann(:, :, isym, ir), num_wann, & + umat, ndim, sitesym%d_matrix_wann(:, :, isym, ir), num_wann, & cmplx_0, cmat_sub, ndim) ! cmat = d^{+}(R,k) * cmat_sub call zgemm('C', 'N', ntmp, num_wann, ntmp, cmplx_1, & - d_matrix_band(:, :, isym, ir), ndim, cmat_sub, ndim, & + sitesym%d_matrix_band(:, :, isym, ir), ndim, cmat_sub, ndim, & cmplx_0, cmat, ndim) usum(:, :) = usum(:, :) + cmat(:, :) ! check @@ -396,31 +436,33 @@ subroutine symmetrize_ukirr(ir, ndim, umat, n) matmul(conjg(transpose(umat(:ntmp, :))), cmat(:ntmp, :)) enddo ! isym diff = sum(abs(cmat2)) - if (diff .lt. symmetrize_eps) exit + if (diff .lt. sitesym%symmetrize_eps) exit if (iter .eq. niter) then write (stdout, "(a)") 'Error in symmetrize_u: not converged' write (stdout, "(a)") 'Either eps is too small or specified irreps is not' write (stdout, "(a)") ' compatible with the bands' - write (stdout, "(a,2e20.10)") 'diff,eps=', diff, symmetrize_eps - call io_error('symmetrize_ukirr: not converged') + write (stdout, "(a,2e20.10)") 'diff,eps=', diff, sitesym%symmetrize_eps + call io_error('symmetrize_ukirr: not converged', stdout, seedname) endif usum = usum/ngk - call orthogonalize_u(ndim, num_wann, usum, ntmp) + call orthogonalize_u(ndim, num_wann, usum, ntmp, stdout, seedname) umat(:, :) = usum enddo ! iter return end subroutine symmetrize_ukirr - !==================================================================! - subroutine orthogonalize_u(ndim, m, u, n) - !==================================================================! + !================================================! + subroutine orthogonalize_u(ndim, m, u, n, stdout, seedname) + !================================================! implicit none integer, intent(in) :: ndim, m complex(kind=dp), intent(inout) :: u(ndim, m) integer, intent(in) :: n + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname complex(kind=dp), allocatable :: smat(:, :), evecl(:, :), evecr(:, :) complex(kind=dp), allocatable :: WORK(:) @@ -428,7 +470,7 @@ subroutine orthogonalize_u(ndim, m, u, n) integer :: INFO, i, j, l integer :: LWORK - if (n .lt. m) call io_error('n !! Density Of States and Quantum Conductance - Version 1.0 !! Marco Buongiorno Nardelli, January 2000. @@ -71,123 +72,274 @@ module w90_transport private - complex(kind=dp), parameter :: eta = (0.0_dp, 0.0005_dp) - !! small complex number - - integer, parameter :: nterx = 50 - !! nterx = # of maximum iteration to calculate transfer matrix - integer :: one_dim_vec - !! cartesian axis to which real_lattice(:,one_dim_vec) is parallel - integer :: nrpts_one_dim - integer :: num_pl - !! number of unit cell in a principal layer - integer, dimension(3) :: coord - !! coord : coord(1) defines the conduction direction according to 1=x,2=y,3=z, - !! coord(2),coord(3) define the other directions during sorting routines - integer, allocatable :: tran_sorted_idx(:) - !! index of sorted WF centres to unsorted - - real(kind=dp), allocatable :: hr_one_dim(:, :, :) - real(kind=dp), allocatable :: hB0(:, :) - real(kind=dp), allocatable :: hB1(:, :) - real(kind=dp), allocatable :: hL0(:, :) - real(kind=dp), allocatable :: hL1(:, :) - real(kind=dp), allocatable :: hR0(:, :) - real(kind=dp), allocatable :: hR1(:, :) - real(kind=dp), allocatable :: hC(:, :) - real(kind=dp), allocatable :: hLC(:, :) - real(kind=dp), allocatable :: hCR(:, :) + complex(kind=dp), parameter :: eta = (0.0_dp, 0.0005_dp) !! small complex number + + integer, parameter :: nterx = 50 !! nterx = # of maximum iteration to calculate transfer matrix public :: tran_main - public :: tran_dealloc contains - !==================================================================! - subroutine tran_main() + + !================================================! + subroutine tran_main(atom_data, dis_manifold, fermi_energy_list, ham_logical, kpt_latt, & + output_file, real_space_ham, transport, print_output, wannier_data, & + ws_region, w90_calculation, ham_k, ham_r, u_matrix, u_matrix_opt, eigval, & + real_lattice, wannier_centres_translated, irvec, mp_grid, ndegen, & + shift_vec, nrpts, num_bands, num_kpts, num_wann, rpt_origin, & + bands_plot_mode, have_disentangled, lsitesymmetry, seedname, stdout) + + !================================================! + ! !! Main transport subroutine - !==================================================================! + ! + !================================================! + + use w90_io, only: io_error, io_stopwatch - use w90_io, only: stdout, io_stopwatch - use w90_parameters, only: transport_mode, tran_read_ht, timing_level, write_hr, & - write_xyz use w90_hamiltonian, only: hamiltonian_get_hr, hamiltonian_write_hr, hamiltonian_setup + use w90_types, only: wannier_data_type, print_output_type, ws_region_type, & + atom_data_type, dis_manifold_type + use w90_wannier90_types, only: w90_calculation_type, transport_type, output_file_type, & + real_space_ham_type, ham_logical_type implicit none - real(kind=dp), allocatable, dimension(:, :) :: signatures - integer :: num_G - logical :: pl_warning + ! arguments + type(transport_type), intent(inout) :: transport + type(real_space_ham_type), intent(inout) :: real_space_ham + type(ws_region_type), intent(inout) :: ws_region + type(print_output_type), intent(in) :: print_output + type(w90_calculation_type), intent(in) :: w90_calculation + type(output_file_type), intent(in) :: output_file + type(wannier_data_type), intent(in) :: wannier_data + type(atom_data_type), intent(in) :: atom_data + type(dis_manifold_type), intent(in) :: dis_manifold + real(kind=dp), intent(in) :: kpt_latt(:, :) + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + type(ham_logical_type), intent(inout) :: ham_logical + + integer, intent(inout) :: rpt_origin + integer, intent(inout) :: nrpts + integer, intent(inout), allocatable :: ndegen(:) + integer, intent(inout), allocatable :: shift_vec(:, :) + integer, intent(inout), allocatable :: irvec(:, :) + integer, intent(in) :: num_wann + integer, intent(in) :: num_bands + integer, intent(in) :: num_kpts + integer, intent(in) :: stdout + integer, intent(in) :: mp_grid(3) + + real(kind=dp), intent(inout), allocatable :: wannier_centres_translated(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: eigval(:, :) + + complex(kind=dp), intent(in) :: u_matrix(:, :, :) + complex(kind=dp), intent(in) :: u_matrix_opt(:, :, :) + complex(kind=dp), allocatable, intent(inout) :: ham_k(:, :, :) + complex(kind=dp), intent(inout), allocatable :: ham_r(:, :, :) + + character(len=*), intent(in) :: bands_plot_mode + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + logical, intent(in) :: lsitesymmetry !YN: + + ! local variables + integer :: one_dim_vec + !! cartesian axis to which real_lattice(:,one_dim_vec) is parallel + integer :: nrpts_one_dim + integer :: num_pl + !! number of unit cell in a principal layer + integer :: coord(3) + !! coord : coord(1) defines the conduction direction according to + !1=x,2=y,3=z + !! coord(2),coord(3) define the other directions during sorting routines + integer, allocatable :: tran_sorted_idx(:) + !! index of sorted WF centres to unsorted + integer :: num_G + integer :: irvec_max ! size of hr_one_dim's last dimension (:, :, -irvec_max:irvec_max) + integer :: ierr + + real(kind=dp), allocatable :: hr_one_dim(:, :, :) + real(kind=dp), allocatable :: signatures(:, :) + real(kind=dp), allocatable :: hB0(:, :) + real(kind=dp), allocatable :: hB1(:, :) + real(kind=dp), allocatable :: hC(:, :) + real(kind=dp), allocatable :: hCR(:, :) + real(kind=dp), allocatable :: hL0(:, :) + real(kind=dp), allocatable :: hL1(:, :) + real(kind=dp), allocatable :: hLC(:, :) + real(kind=dp), allocatable :: hR0(:, :) + real(kind=dp), allocatable :: hR1(:, :) + + logical :: pl_warning - if (timing_level > 0) call io_stopwatch('tran: main', 1) + if (print_output%timing_level > 0) call io_stopwatch('tran: main', 1, stdout, seedname) write (stdout, '(/1x,a)') '*---------------------------------------------------------------------------*' write (stdout, '(1x,a)') '| TRANSPORT |' write (stdout, '(1x,a)') '*---------------------------------------------------------------------------*' write (stdout, *) - if (index(transport_mode, 'bulk') > 0) then + if (index(transport%mode, 'bulk') > 0) then write (stdout, '(/1x,a/)') 'Calculation of Quantum Conductance and DoS: bulk mode' - if (.not. tran_read_ht) then - call hamiltonian_setup() - call hamiltonian_get_hr() - if (write_hr) call hamiltonian_write_hr() - call tran_reduce_hr() - call tran_cut_hr_one_dim() - call tran_get_ht() - if (write_xyz) call tran_write_xyz() + if (.not. transport%read_ht) then + call hamiltonian_setup(ham_logical, print_output, ws_region, w90_calculation, ham_k, & + ham_r, real_lattice, wannier_centres_translated, irvec, mp_grid, & + ndegen, num_kpts, num_wann, nrpts, rpt_origin, bands_plot_mode, & + stdout, seedname, transport%mode) + call hamiltonian_get_hr(atom_data, dis_manifold, ham_logical, real_space_ham, & + print_output, ham_k, ham_r, u_matrix, u_matrix_opt, eigval, & + kpt_latt, real_lattice, wannier_data%centres, & + wannier_centres_translated, irvec, shift_vec, nrpts, num_bands, & + num_kpts, num_wann, have_disentangled, stdout, seedname, & + lsitesymmetry) + if (output_file%write_hr) call hamiltonian_write_hr(ham_logical, ham_r, irvec, ndegen, & + nrpts, num_wann, & + print_output%timing_level, & + seedname, stdout) + call tran_reduce_hr(real_space_ham, ham_r, hr_one_dim, real_lattice, irvec, mp_grid, & + irvec_max, nrpts, nrpts_one_dim, num_wann, one_dim_vec, & + print_output%timing_level, seedname, stdout) + call tran_cut_hr_one_dim(real_space_ham, transport, print_output, hr_one_dim, & + real_lattice, wannier_centres_translated, mp_grid, irvec_max, & + num_pl, num_wann, one_dim_vec, seedname, stdout) + call tran_get_ht(fermi_energy_list, transport, hB0, hB1, hr_one_dim, irvec_max, num_pl, & + num_wann, print_output%timing_level, seedname, stdout) + if (output_file%write_xyz) call tran_write_xyz(atom_data, transport, & + wannier_centres_translated, & + tran_sorted_idx, num_wann, seedname, stdout) end if - call tran_bulk() + call tran_bulk(transport, hB0, hB1, print_output%timing_level, stdout, seedname) end if - if (index(transport_mode, 'lcr') > 0) then + if (index(transport%mode, 'lcr') > 0) then write (stdout, '(/1x,a/)') 'Calculation of Quantum Conductance and DoS: lead-conductor-lead mode' - if (.not. tran_read_ht) then - call hamiltonian_setup() - call hamiltonian_get_hr() - if (write_hr) call hamiltonian_write_hr() - call tran_reduce_hr() - call tran_cut_hr_one_dim() + if (.not. transport%read_ht) then + call hamiltonian_setup(ham_logical, print_output, ws_region, w90_calculation, ham_k, & + ham_r, real_lattice, wannier_centres_translated, irvec, mp_grid, & + ndegen, num_kpts, num_wann, nrpts, rpt_origin, bands_plot_mode, & + stdout, seedname, transport%mode) + call hamiltonian_get_hr(atom_data, dis_manifold, ham_logical, real_space_ham, & + print_output, ham_k, ham_r, u_matrix, u_matrix_opt, eigval, & + kpt_latt, real_lattice, wannier_data%centres, & + wannier_centres_translated, irvec, shift_vec, nrpts, num_bands, & + num_kpts, num_wann, have_disentangled, stdout, seedname, & + lsitesymmetry) + if (output_file%write_hr) call hamiltonian_write_hr(ham_logical, ham_r, irvec, ndegen, & + nrpts, num_wann, & + print_output%timing_level, & + seedname, stdout) + call tran_reduce_hr(real_space_ham, ham_r, hr_one_dim, real_lattice, irvec, mp_grid, & + irvec_max, nrpts, nrpts_one_dim, num_wann, one_dim_vec, & + print_output%timing_level, seedname, stdout) + call tran_cut_hr_one_dim(real_space_ham, transport, print_output, hr_one_dim, & + real_lattice, wannier_centres_translated, mp_grid, irvec_max, & + num_pl, num_wann, one_dim_vec, seedname, stdout) write (stdout, *) '------------------------- 2c2 Calculation Type: ------------------------------' write (stdout, *) ' ' - call tran_find_integral_signatures(signatures, num_G) - call tran_lcr_2c2_sort(signatures, num_G, pl_warning) - if (write_xyz) call tran_write_xyz() - call tran_parity_enforce(signatures) - call tran_lcr_2c2_build_ham(pl_warning) + call tran_find_integral_signatures(signatures, num_G, print_output, real_lattice, & + u_matrix_opt, u_matrix, num_bands, num_wann, & + have_disentangled, wannier_centres_translated, stdout, & + seedname) + call tran_lcr_2c2_sort(signatures, num_G, pl_warning, transport, atom_data, wannier_data, & + real_space_ham, print_output, real_lattice, num_wann, mp_grid, & + ham_r, irvec, nrpts, wannier_centres_translated, one_dim_vec, & + nrpts_one_dim, num_pl, coord, tran_sorted_idx, hr_one_dim, & + irvec_max, output_file%write_xyz, stdout, seedname) + if (output_file%write_xyz) call tran_write_xyz(atom_data, transport, & + wannier_centres_translated, & + tran_sorted_idx, num_wann, seedname, stdout) + + call tran_parity_enforce(signatures, print_output, transport, num_wann, tran_sorted_idx, & + hr_one_dim, irvec_max, stdout, seedname) + call tran_lcr_2c2_build_ham(pl_warning, real_space_ham, fermi_energy_list, kpt_latt, & + num_wann, transport, print_output, real_lattice, mp_grid, & + ham_r, irvec, nrpts, wannier_centres_translated, one_dim_vec, & + nrpts_one_dim, num_pl, coord, tran_sorted_idx, hC, hCR, hL0, & + hL1, hLC, hR0, hR1, hr_one_dim, irvec_max, stdout, seedname) endif - call tran_lcr() + call tran_lcr(transport, hC, hCR, hL0, hL1, hLC, hR0, hR1, print_output%timing_level, & + stdout, seedname) end if - if (timing_level > 0) call io_stopwatch('tran: main', 2) + if (print_output%timing_level > 0) call io_stopwatch('tran: main', 2, stdout, seedname) + + if (allocated(hR1)) then + deallocate (hR1, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating hR1 in tran_main', stdout, seedname) + end if + if (allocated(hR0)) then + deallocate (hR0, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating hR0 in tran_main', stdout, seedname) + end if + if (allocated(hL1)) then + deallocate (hL1, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating hL1 in tran_main', stdout, seedname) + end if + if (allocated(hB1)) then + deallocate (hB1, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating hB1 in tran_main', stdout, seedname) + end if + if (allocated(hB0)) then + deallocate (hB0, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating hB0 in tran_main', stdout, seedname) + end if + if (allocated(hr_one_dim)) then + deallocate (hr_one_dim, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating hr_one_dim in tran_main', stdout, seedname) + end if end subroutine tran_main - !==================================================================! - subroutine tran_reduce_hr() - !==================================================================! + !================================================! + subroutine tran_reduce_hr(real_space_ham, ham_r, hr_one_dim, real_lattice, irvec, mp_grid, & + irvec_max, nrpts, nrpts_one_dim, num_wann, one_dim_vec, timing_level, & + seedname, stdout) + !================================================! ! ! reduce ham_r from 3-d to 1-d ! + !================================================! + use w90_constants, only: dp, eps8 - use w90_io, only: io_error, io_stopwatch, stdout - use w90_parameters, only: one_dim_dir, real_lattice, num_wann, & - mp_grid, timing_level - use w90_hamiltonian, only: irvec, nrpts, ham_r + use w90_io, only: io_error, io_stopwatch + use w90_wannier90_types, only: real_space_ham_type implicit none + ! passed vars + type(real_space_ham_type), intent(in) :: real_space_ham + + integer, intent(in) :: irvec(:, :) + integer, intent(inout) :: irvec_max ! limits of hr_one_dim final dim + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: nrpts + integer, intent(in) :: num_wann + integer, intent(inout) :: nrpts_one_dim + integer, intent(inout) :: one_dim_vec + integer, intent(in) :: timing_level + integer, intent(in) :: stdout + + real(kind=dp), allocatable, intent(inout) :: hr_one_dim(:, :, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + + complex(kind=dp), intent(in) :: ham_r(:, :, :) + + character(len=50), intent(in) :: seedname + + ! local variables integer :: ierr - integer :: irvec_max, irvec_tmp(3), two_dim_vec(2) + integer :: irvec_tmp(3), two_dim_vec(2) integer :: i, j integer :: i1, i2, i3, n1, nrpts_tmp, loop_rpt - if (timing_level > 1) call io_stopwatch('tran: reduce_hr', 1) + if (timing_level > 1) call io_stopwatch('tran: reduce_hr', 1, stdout, seedname) ! Find one_dim_vec which is parallel to one_dim_dir ! two_dim_vec - the other two lattice vectors j = 0 do i = 1, 3 - if (abs(abs(real_lattice(one_dim_dir, i)) & + if (abs(abs(real_lattice(real_space_ham%one_dim_dir, i)) & - sqrt(dot_product(real_lattice(:, i), real_lattice(:, i)))) .lt. eps8) then one_dim_vec = i j = j + 1 @@ -195,7 +347,7 @@ subroutine tran_reduce_hr() end do if (j .ne. 1) then write (stdout, '(i3,a)') j, ' : 1-D LATTICE VECTOR NOT DEFINED' - call io_error('Error: 1-d lattice vector not defined in tran_reduce_hr') + call io_error('Error: 1-d lattice vector not defined in tran_reduce_hr', stdout, seedname) end if j = 0 @@ -216,11 +368,12 @@ subroutine tran_reduce_hr() nrpts_one_dim = 2*irvec_max + 1 allocate (hr_one_dim(num_wann, num_wann, -irvec_max:irvec_max), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hr_one_dim in tran_reduce_hr') + if (ierr /= 0) call io_error('Error in allocating hr_one_dim in tran_reduce_hr', stdout, seedname) hr_one_dim = 0.0_dp ! check imaginary part - write (stdout, '(1x,a,F12.6)') 'Maximum imaginary part of the real-space Hamiltonian: ', maxval(abs(aimag(ham_r))) + write (stdout, '(1x,a,F12.6)') 'Maximum imaginary part of the real-space Hamiltonian: ', & + maxval(abs(aimag(ham_r))) ! select a subset of ham_r, where irvec is 0 along the two other lattice vectors @@ -240,51 +393,69 @@ subroutine tran_reduce_hr() if (nrpts_tmp .ne. nrpts_one_dim) then write (stdout, '(a)') 'FAILED TO EXTRACT 1-D HAMILTONIAN' - call io_error('Error: cannot extract 1d hamiltonian in tran_reduce_hr') + call io_error('Error: cannot extract 1d hamiltonian in tran_reduce_hr', stdout, seedname) end if - if (timing_level > 1) call io_stopwatch('tran: reduce_hr', 2) + if (timing_level > 1) call io_stopwatch('tran: reduce_hr', 2, stdout, seedname) return end subroutine tran_reduce_hr - !==================================================================! - subroutine tran_cut_hr_one_dim() - !==================================================================! - ! + !================================================! + subroutine tran_cut_hr_one_dim(real_space_ham, transport, print_output, hr_one_dim, & + real_lattice, wannier_centres_translated, mp_grid, irvec_max, & + num_pl, num_wann, one_dim_vec, seedname, stdout) + !================================================! + use w90_constants, only: dp - use w90_io, only: io_stopwatch, stdout - use w90_parameters, only: num_wann, mp_grid, timing_level, real_lattice, & - hr_cutoff, dist_cutoff, dist_cutoff_mode, & - one_dim_dir, length_unit, transport_mode, & - tran_num_cell_ll, tran_num_ll, dist_cutoff_hc - use w90_hamiltonian, only: wannier_centres_translated + use w90_io, only: io_stopwatch + use w90_types, only: print_output_type + use w90_wannier90_types, only: transport_type, real_space_ham_type implicit none - ! - integer :: irvec_max + + ! arguments + type(real_space_ham_type), intent(inout) :: real_space_ham + type(print_output_type), intent(in) :: print_output + type(transport_type), intent(inout) :: transport + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: irvec_max + integer, intent(in) :: num_wann + integer, intent(in) :: one_dim_vec + integer, intent(inout) :: num_pl + integer, intent(in) :: stdout + + real(kind=dp), intent(inout) :: hr_one_dim(:, :, -irvec_max:) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: wannier_centres_translated(:, :) + + character(len=50), intent(in) :: seedname + + ! local variables integer :: i, j, n1 real(kind=dp) :: hr_max real(kind=dp) :: dist real(kind=dp) :: dist_vec(3) real(kind=dp) :: dist_ij_vec(3) - real(kind=dp) :: shift_vec(3, -nrpts_one_dim/2:nrpts_one_dim/2) + real(kind=dp) :: shift_vec(3, -irvec_max:irvec_max) real(kind=dp) :: hr_tmp(num_wann, num_wann) - ! - if (timing_level > 1) call io_stopwatch('tran: cut_hr_one_dim', 1) - ! - irvec_max = nrpts_one_dim/2 - ! maximum possible dist_cutoff - dist = real(mp_grid(one_dim_vec), dp)*abs(real_lattice(one_dim_dir, one_dim_vec))/2.0_dp + if (print_output%timing_level > 1) call io_stopwatch('tran: cut_hr_one_dim', 1, stdout, seedname) - if (dist_cutoff .gt. dist) then - write (stdout, '(1x,a,1x,F10.5,1x,a)') 'dist_cutoff', dist_cutoff, trim(length_unit), 'is too large' - dist_cutoff = dist + !irvec_max = nrpts_one_dim/2 ! now passed as arg + ! maximum possible dist_cutoff + dist = real(mp_grid(one_dim_vec), dp)*abs(real_lattice(real_space_ham%one_dim_dir, one_dim_vec)) & + /2.0_dp + if (real_space_ham%dist_cutoff .gt. dist) then + write (stdout, '(1x,a,1x,F10.5,1x,a)') 'dist_cutoff', real_space_ham%dist_cutoff, & + trim(print_output%length_unit), 'is too large' + real_space_ham%dist_cutoff = dist ! aam_2012-04-13 - dist_cutoff_hc = dist - write (stdout, '(4x,a,1x,F10.5,1x,a)') 'reset to', dist_cutoff, trim(length_unit) + real_space_ham%dist_cutoff_hc = dist + write (stdout, '(4x,a,1x,F10.5,1x,a)') 'reset to', real_space_ham%dist_cutoff, & + trim(print_output%length_unit) end if do n1 = -irvec_max, irvec_max @@ -293,31 +464,35 @@ subroutine tran_cut_hr_one_dim() end do ! apply dist_cutoff first - if (index(dist_cutoff_mode, 'one_dim') > 0) then + if (index(real_space_ham%dist_cutoff_mode, 'one_dim') > 0) then do i = 1, num_wann do j = 1, num_wann - dist_ij_vec(one_dim_dir) = wannier_centres_translated(one_dim_dir, i) - wannier_centres_translated(one_dim_dir, j) + dist_ij_vec(real_space_ham%one_dim_dir) = wannier_centres_translated(real_space_ham%one_dim_dir, i) & + - wannier_centres_translated(real_space_ham%one_dim_dir, j) do n1 = -irvec_max, irvec_max - dist_vec(one_dim_dir) = dist_ij_vec(one_dim_dir) + shift_vec(one_dim_dir, n1) - ! + dist_vec(real_space_ham%one_dim_dir) = dist_ij_vec(real_space_ham%one_dim_dir) & + + shift_vec(real_space_ham%one_dim_dir, n1) + !MS: Add special case for lcr: We must not cut the elements that are within ! dist_cutoff under PBC's (single kpt assumed) in order to build ! hamiltonians correctly in tran_2c2_build_hams - ! - if ((index(transport_mode, 'lcr') > 0) .and. & - !~ (tran_num_cell_ll .eq. 1) .and. & - (abs(dist_vec(one_dim_dir)) .gt. dist_cutoff)) then + + if ((index(transport%mode, 'lcr') > 0) .and. & + !~ (transport%num_cell_ll .eq. 1) .and. & + (abs(dist_vec(real_space_ham%one_dim_dir)) .gt. real_space_ham%dist_cutoff)) then ! Move to right - dist_vec(one_dim_dir) = dist_ij_vec(one_dim_dir) + real_lattice(one_dim_dir, one_dim_vec) + dist_vec(real_space_ham%one_dim_dir) = dist_ij_vec(real_space_ham%one_dim_dir) & + + real_lattice(real_space_ham%one_dim_dir, one_dim_vec) ! Move to left - if (abs(dist_vec(one_dim_dir)) .gt. dist_cutoff) & - dist_vec(one_dim_dir) = dist_ij_vec(one_dim_dir) - real_lattice(one_dim_dir, one_dim_vec) + if (abs(dist_vec(real_space_ham%one_dim_dir)) .gt. real_space_ham%dist_cutoff) & + dist_vec(real_space_ham%one_dim_dir) = dist_ij_vec(real_space_ham%one_dim_dir) & + - real_lattice(real_space_ham%one_dim_dir, one_dim_vec) endif - ! + !end MS - ! - dist = abs(dist_vec(one_dim_dir)) - if (dist .gt. dist_cutoff) hr_one_dim(j, i, n1) = 0.0_dp + + dist = abs(dist_vec(real_space_ham%one_dim_dir)) + if (dist .gt. real_space_ham%dist_cutoff) hr_one_dim(j, i, n1) = 0.0_dp end do end do end do @@ -328,25 +503,25 @@ subroutine tran_cut_hr_one_dim() do n1 = -irvec_max, irvec_max dist_vec(:) = dist_ij_vec(:) + shift_vec(:, n1) dist = sqrt(dot_product(dist_vec, dist_vec)) - ! + ! MS: Special case (as above) equivalent for alternate definition of cut off - ! - if ((index(transport_mode, 'lcr') > 0) .and. & - !~ (tran_num_cell_ll .eq. 1) .and. & - (dist .gt. dist_cutoff)) then + + if ((index(transport%mode, 'lcr') > 0) .and. & + !~ (transport%num_cell_ll .eq. 1) .and. & + (dist .gt. real_space_ham%dist_cutoff)) then ! Move to right dist_vec(:) = dist_ij_vec(:) + real_lattice(:, one_dim_vec) dist = sqrt(dot_product(dist_vec, dist_vec)) ! Move to left - if (dist .gt. dist_cutoff) then + if (dist .gt. real_space_ham%dist_cutoff) then dist_vec(:) = dist_ij_vec(:) - real_lattice(:, one_dim_vec) dist = sqrt(dot_product(dist_vec, dist_vec)) endif endif - ! + ! End MS - ! - if (dist .gt. dist_cutoff) hr_one_dim(j, i, n1) = 0.0_dp + + if (dist .gt. real_space_ham%dist_cutoff) hr_one_dim(j, i, n1) = 0.0_dp end do end do end do @@ -363,7 +538,7 @@ subroutine tran_cut_hr_one_dim() do n1 = -irvec_max, irvec_max hr_tmp(:, :) = abs(hr_one_dim(:, :, n1)) hr_max = maxval(hr_tmp) - if (hr_max .gt. hr_cutoff) then + if (hr_max .gt. real_space_ham%hr_cutoff) then if (abs(n1) .gt. num_pl) num_pl = abs(n1) else hr_one_dim(:, :, n1) = 0.0_dp @@ -371,62 +546,85 @@ subroutine tran_cut_hr_one_dim() write (stdout, '(1x,9x,5x,I5,5x,12x,F12.6)') n1, hr_max end do write (stdout, '(1x,8x,a62)') repeat('-', 62) - if (index(transport_mode, 'lcr') > 0) then - write (stdout, '(/1x,a,I6)') 'Number of unit cells inside the principal layer:', tran_num_cell_ll - write (stdout, '(1x,a,I6)') 'Number of Wannier Functions inside the principal layer:', tran_num_ll - elseif (index(transport_mode, 'bulk') > 0) then + if (index(transport%mode, 'lcr') > 0) then + write (stdout, '(/1x,a,I6)') 'Number of unit cells inside the principal layer:', & + transport%num_cell_ll + write (stdout, '(1x,a,I6)') 'Number of Wannier Functions inside the principal layer:', & + transport%num_ll + elseif (index(transport%mode, 'bulk') > 0) then write (stdout, '(/1x,a,I6)') 'Number of unit cells inside the principal layer:', num_pl - write (stdout, '(1x,a,I6)') 'Number of Wannier Functions inside the principal layer:', num_pl*num_wann + write (stdout, '(1x,a,I6)') 'Number of Wannier Functions inside the principal layer:', & + num_pl*num_wann endif ! apply hr_cutoff to each element inside the principal layer do n1 = -num_pl, num_pl do i = 1, num_wann do j = 1, num_wann - if (abs(hr_one_dim(j, i, n1)) .lt. hr_cutoff) hr_one_dim(j, i, n1) = 0.0_dp + if (abs(hr_one_dim(j, i, n1)) .lt. real_space_ham%hr_cutoff) hr_one_dim(j, i, n1) = 0.0_dp end do end do end do - if (timing_level > 1) call io_stopwatch('tran: cut_hr_one_dim', 2) + if (print_output%timing_level > 1) call io_stopwatch('tran: cut_hr_one_dim', 2, stdout, seedname) return end subroutine tran_cut_hr_one_dim - !==================================================================! - subroutine tran_get_ht() - !==================================================================! - ! construct h00 and h01 - !==================================================================! + !================================================! + subroutine tran_get_ht(fermi_energy_list, transport, hB0, hB1, hr_one_dim, irvec_max, num_pl, & + num_wann, timing_level, seedname, stdout) + !================================================! ! - use w90_constants, only: dp - use w90_io, only: io_error, io_stopwatch, seedname, io_date, & - io_file_unit - use w90_parameters, only: num_wann, tran_num_bb, tran_write_ht, & - nfermi, fermi_energy_list, timing_level + !! Construct h00 and h01 ! + !================================================! + + use w90_constants, only: dp + use w90_io, only: io_error, io_stopwatch, io_date, io_file_unit + use w90_wannier90_types, only: transport_type + implicit none - ! + + ! arguments + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + type(transport_type), intent(inout) :: transport + + integer, intent(in) :: num_pl + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + integer, intent(in) :: irvec_max + integer, intent(in) :: timing_level + + real(kind=dp), intent(in) :: hr_one_dim(:, :, -irvec_max:) + real(kind=dp), allocatable, intent(inout) :: hB0(:, :) + real(kind=dp), allocatable, intent(inout) :: hB1(:, :) + + character(len=50), intent(in) :: seedname + + ! local variables integer :: ierr, file_unit integer :: i, j, n1, im, jm - character(len=9) :: cdate, ctime - ! - if (timing_level > 1) call io_stopwatch('tran: get_ht', 1) - ! - if (nfermi > 1) call io_error("Error in tran_get_ht: nfermi>1. " & - //"Set the fermi level using the input parameter 'fermi_evel'") - ! - ! - tran_num_bb = num_pl*num_wann - ! - allocate (hB0(tran_num_bb, tran_num_bb), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hB0 in tran_get_ht') - allocate (hB1(tran_num_bb, tran_num_bb), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hB1 in tran_get_ht') - ! + integer :: fermi_n + character(len=9) :: cdate, ctime + + if (timing_level > 1) call io_stopwatch('tran: get_ht', 1, stdout, seedname) + + fermi_n = 0 + if (allocated(fermi_energy_list)) fermi_n = size(fermi_energy_list) + if (fermi_n > 1) call io_error("Error in tran_get_ht: nfermi>1. " & + //"Set the fermi level using the input parameter 'fermi_evel'", stdout, seedname) + + transport%num_bb = num_pl*num_wann + + allocate (hB0(transport%num_bb, transport%num_bb), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hB0 in tran_get_ht', stdout, seedname) + allocate (hB1(transport%num_bb, transport%num_bb), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hB1 in tran_get_ht', stdout, seedname) + hB0 = 0.0_dp hB1 = 0.0_dp - ! + ! h00 do j = 0, num_pl - 1 do i = 0, num_pl - 1 @@ -448,45 +646,55 @@ subroutine tran_get_ht() end do ! shift by fermi_energy - do i = 1, tran_num_bb + do i = 1, transport%num_bb hB0(i, i) = hB0(i, i) - fermi_energy_list(1) end do - if (tran_write_ht) then + if (transport%write_ht) then file_unit = io_file_unit() - open (file_unit, file=trim(seedname)//'_htB.dat', status='unknown', form='formatted', action='write') + open (file_unit, file=trim(seedname)//'_htB.dat', status='unknown', form='formatted', & + action='write') call io_date(cdate, ctime) write (file_unit, *) 'written on '//cdate//' at '//ctime ! Date and time - write (file_unit, '(I6)') tran_num_bb - write (file_unit, '(6F12.6)') ((hB0(j, i), j=1, tran_num_bb), i=1, tran_num_bb) - write (file_unit, '(I6)') tran_num_bb - write (file_unit, '(6F12.6)') ((hB1(j, i), j=1, tran_num_bb), i=1, tran_num_bb) + write (file_unit, '(I6)') transport%num_bb + write (file_unit, '(6F12.6)') ((hB0(j, i), j=1, transport%num_bb), i=1, transport%num_bb) + write (file_unit, '(I6)') transport%num_bb + write (file_unit, '(6F12.6)') ((hB1(j, i), j=1, transport%num_bb), i=1, transport%num_bb) close (file_unit) end if - if (timing_level > 1) call io_stopwatch('tran: get_ht', 2) + if (timing_level > 1) call io_stopwatch('tran: get_ht', 2, stdout, seedname) return end subroutine tran_get_ht - !==================================================================! - subroutine tran_bulk() - !==================================================================! + !================================================! + subroutine tran_bulk(transport, hB0, hB1, timing_level, stdout, seedname) + !================================================! use w90_constants, only: dp, cmplx_0, cmplx_1, cmplx_i, pi - use w90_io, only: io_error, io_stopwatch, seedname, io_date, & - io_file_unit, stdout - use w90_parameters, only: tran_num_bb, tran_read_ht, & - tran_win_min, tran_win_max, tran_energy_step, & - timing_level + use w90_io, only: io_error, io_stopwatch, io_date, io_file_unit + use w90_wannier90_types, only: transport_type implicit none + ! arguments + integer, intent(in) :: stdout + integer, intent(in) :: timing_level + + real(kind=dp), allocatable :: hB0(:, :) + real(kind=dp), allocatable :: hB1(:, :) + + type(transport_type), intent(in) :: transport + + character(len=50), intent(in) :: seedname + + ! local variables integer :: qc_unit, dos_unit integer :: ierr integer :: n_e, n, i @@ -500,28 +708,28 @@ subroutine tran_bulk() character(len=50) :: filename character(len=9) :: cdate, ctime - if (timing_level > 1) call io_stopwatch('tran: bulk', 1) - - allocate (tot(tran_num_bb, tran_num_bb), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating tot in tran_bulk') - allocate (tott(tran_num_bb, tran_num_bb), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating tott in tran_bulk') - allocate (g_B(tran_num_bb, tran_num_bb), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating g_B in tran_bulk') - allocate (gL(tran_num_bb, tran_num_bb), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating gL in tran_bulk') - allocate (gR(tran_num_bb, tran_num_bb), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating gR in tran_bulk') - allocate (sLr(tran_num_bb, tran_num_bb), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating sLr in tran_bulk') - allocate (sRr(tran_num_bb, tran_num_bb), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating sRr in tran_bulk') - allocate (s1(tran_num_bb, tran_num_bb), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating s1 in tran_bulk') - allocate (s2(tran_num_bb, tran_num_bb), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating s2 in tran_bulk') - allocate (c1(tran_num_bb, tran_num_bb), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating c1 in tran_bulk') + if (timing_level > 1) call io_stopwatch('tran: bulk', 1, stdout, seedname) + + allocate (tot(transport%num_bb, transport%num_bb), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating tot in tran_bulk', stdout, seedname) + allocate (tott(transport%num_bb, transport%num_bb), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating tott in tran_bulk', stdout, seedname) + allocate (g_B(transport%num_bb, transport%num_bb), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating g_B in tran_bulk', stdout, seedname) + allocate (gL(transport%num_bb, transport%num_bb), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating gL in tran_bulk', stdout, seedname) + allocate (gR(transport%num_bb, transport%num_bb), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating gR in tran_bulk', stdout, seedname) + allocate (sLr(transport%num_bb, transport%num_bb), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating sLr in tran_bulk', stdout, seedname) + allocate (sRr(transport%num_bb, transport%num_bb), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating sRr in tran_bulk', stdout, seedname) + allocate (s1(transport%num_bb, transport%num_bb), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating s1 in tran_bulk', stdout, seedname) + allocate (s2(transport%num_bb, transport%num_bb), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating s2 in tran_bulk', stdout, seedname) + allocate (c1(transport%num_bb, transport%num_bb), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating c1 in tran_bulk', stdout, seedname) call io_date(cdate, ctime) @@ -537,24 +745,24 @@ subroutine tran_bulk() ! set up the layer hamiltonians - if (tran_read_ht) then - allocate (hB0(tran_num_bb, tran_num_bb), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hB0 in tran_bulk') - allocate (hB1(tran_num_bb, tran_num_bb), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hB1 in tran_bulk') + if (transport%read_ht) then + allocate (hB0(transport%num_bb, transport%num_bb), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hB0 in tran_bulk', stdout, seedname) + allocate (hB1(transport%num_bb, transport%num_bb), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hB1 in tran_bulk', stdout, seedname) filename = trim(seedname)//'_htB.dat' - call tran_read_htX(tran_num_bb, hB0, hB1, filename) + call tran_read_htX(transport%num_bb, hB0, hB1, filename, stdout, seedname) end if ! loop over the energies - n_e = floor((tran_win_max - tran_win_min)/tran_energy_step) + 1 + n_e = floor((transport%win_max - transport%win_min)/transport%energy_step) + 1 write (stdout, '(/1x,a)', advance='no') 'Calculating quantum& & conductance and density of states...' do n = 1, n_e - e_scan = tran_win_min + real(n - 1, dp)*tran_energy_step + e_scan = transport%win_min + real(n - 1, dp)*transport%energy_step ! if (mod(n,nint(0.1*n_e)).eq.0) write(stdout,'(a)',advance='no') '.' @@ -562,8 +770,8 @@ subroutine tran_bulk() ! retarded Green e_scan_cmp = e_scan + eta - call tran_transfer(tot, tott, hB0, hB1, e_scan_cmp, tran_num_bb) - call tran_green(tot, tott, hB0, hB1, e_scan, g_B, 0, 1, tran_num_bb) + call tran_transfer(tot, tott, hB0, hB1, e_scan_cmp, transport%num_bb, stdout, seedname) + call tran_green(tot, tott, hB0, hB1, e_scan, g_B, 0, 1, transport%num_bb, stdout, seedname) ! compute S_Lr and S_Rr @@ -573,10 +781,10 @@ subroutine tran_bulk() ! Self-energy (Sigma_R^r) : sRr = (hB1) * tot sLr = cmplx_0 sRr = cmplx_0 - call ZGEMM('C', 'N', tran_num_bb, tran_num_bb, tran_num_bb, cmplx_1, c1, & - tran_num_bb, tott, tran_num_bb, cmplx_0, sLr, tran_num_bb) - call ZGEMM('N', 'N', tran_num_bb, tran_num_bb, tran_num_bb, cmplx_1, c1, & - tran_num_bb, tot, tran_num_bb, cmplx_0, sRr, tran_num_bb) + call ZGEMM('C', 'N', transport%num_bb, transport%num_bb, transport%num_bb, cmplx_1, c1, & + transport%num_bb, tott, transport%num_bb, cmplx_0, sLr, transport%num_bb) + call ZGEMM('N', 'N', transport%num_bb, transport%num_bb, transport%num_bb, cmplx_1, c1, & + transport%num_bb, tot, transport%num_bb, cmplx_0, sRr, transport%num_bb) ! Gamma_L = i(Sigma_L^r-Sigma_L^a) gL = cmplx_i*(sLr - conjg(transpose(sLr))) @@ -587,24 +795,23 @@ subroutine tran_bulk() s2 = cmplx_0 c1 = cmplx_0 ! s1 = Gamma_L * g_B^r - call ZGEMM('N', 'N', tran_num_bb, tran_num_bb, tran_num_bb, cmplx_1, gL, & - tran_num_bb, g_B, tran_num_bb, cmplx_0, s1, tran_num_bb) + call ZGEMM('N', 'N', transport%num_bb, transport%num_bb, transport%num_bb, cmplx_1, gL, & + transport%num_bb, g_B, transport%num_bb, cmplx_0, s1, transport%num_bb) ! s2 = Gamma_L * g_B^r * Gamma_R - call ZGEMM('N', 'N', tran_num_bb, tran_num_bb, tran_num_bb, cmplx_1, s1, & - tran_num_bb, gR, tran_num_bb, cmplx_0, s2, tran_num_bb) + call ZGEMM('N', 'N', transport%num_bb, transport%num_bb, transport%num_bb, cmplx_1, s1, & + transport%num_bb, gR, transport%num_bb, cmplx_0, s2, transport%num_bb) ! c1 = Gamma_L * g_B^r * Gamma_R * g_B^a - call ZGEMM('N', 'C', tran_num_bb, tran_num_bb, tran_num_bb, cmplx_1, s2, & - tran_num_bb, g_B, tran_num_bb, cmplx_0, c1, tran_num_bb) + call ZGEMM('N', 'C', transport%num_bb, transport%num_bb, transport%num_bb, cmplx_1, s2, & + transport%num_bb, g_B, transport%num_bb, cmplx_0, c1, transport%num_bb) qc = 0.0_dp - do i = 1, tran_num_bb + do i = 1, transport%num_bb qc = qc + real(c1(i, i), dp) end do -! write(qc_unit,'(f12.6,f15.6)') e_scan, qc write (qc_unit, '(f15.9,f18.9)') e_scan, qc dos = 0.0_dp - do i = 1, tran_num_bb + do i = 1, transport%num_bb dos = dos - aimag(g_B(i, i)) end do dos = dos/pi @@ -618,63 +825,83 @@ subroutine tran_bulk() close (dos_unit) deallocate (c1, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating c1 in tran_bulk') + if (ierr /= 0) call io_error('Error in deallocating c1 in tran_bulk', stdout, seedname) deallocate (s2, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating s2 in tran_bulk') + if (ierr /= 0) call io_error('Error in deallocating s2 in tran_bulk', stdout, seedname) deallocate (s1, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating s1 in tran_bulk') + if (ierr /= 0) call io_error('Error in deallocating s1 in tran_bulk', stdout, seedname) deallocate (sRr, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating sRr in tran_bulk') + if (ierr /= 0) call io_error('Error in deallocating sRr in tran_bulk', stdout, seedname) deallocate (sLr, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating sLr in tran_bulk') + if (ierr /= 0) call io_error('Error in deallocating sLr in tran_bulk', stdout, seedname) deallocate (gR, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating gR in tran_bulk') + if (ierr /= 0) call io_error('Error in deallocating gR in tran_bulk', stdout, seedname) deallocate (gL, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating gL in tran_bulk') + if (ierr /= 0) call io_error('Error in deallocating gL in tran_bulk', stdout, seedname) deallocate (g_B, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating g_B in tran_bulk') + if (ierr /= 0) call io_error('Error in deallocating g_B in tran_bulk', stdout, seedname) deallocate (tott, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating tott in tran_bulk') + if (ierr /= 0) call io_error('Error in deallocating tott in tran_bulk', stdout, seedname) deallocate (tot, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating tot in tran_bulk') + if (ierr /= 0) call io_error('Error in deallocating tot in tran_bulk', stdout, seedname) - if (timing_level > 1) call io_stopwatch('tran: bulk', 2) + if (timing_level > 1) call io_stopwatch('tran: bulk', 2, stdout, seedname) return end subroutine tran_bulk - !==================================================================! - subroutine tran_lcr() - !==================================================================! + !================================================! + subroutine tran_lcr(transport, hC, hCR, hL0, hL1, hLC, hR0, hR1, timing_level, stdout, seedname) + !================================================! use w90_constants, only: dp, cmplx_0, cmplx_1, cmplx_i, pi - use w90_io, only: io_error, io_stopwatch, seedname, io_date, & - stdout, io_file_unit - use w90_parameters, only: tran_num_ll, tran_num_rr, tran_num_cc, tran_num_lc, & - tran_num_cr, tran_num_bandc, & - tran_win_min, tran_win_max, tran_energy_step, & - tran_use_same_lead, timing_level, tran_read_ht + use w90_io, only: io_error, io_stopwatch, io_date, io_file_unit + use w90_wannier90_types, only: transport_type implicit none + ! arguments + integer, intent(in) :: stdout + integer, intent(in) :: timing_level + + real(kind=dp), allocatable, intent(inout) :: hC(:, :) + real(kind=dp), allocatable, intent(inout) :: hCR(:, :) + real(kind=dp), allocatable, intent(inout) :: hL0(:, :) + real(kind=dp), allocatable, intent(inout) :: hL1(:, :) + real(kind=dp), allocatable, intent(inout) :: hLC(:, :) + real(kind=dp), allocatable, intent(inout) :: hR0(:, :) + real(kind=dp), allocatable, intent(inout) :: hR1(:, :) + + type(transport_type), intent(in) :: transport + + character(len=50), intent(in) :: seedname + + ! local variables integer :: qc_unit, dos_unit integer :: ierr integer :: KL, KU, KC integer :: n_e, n, i, j, k, info integer, allocatable :: ipiv(:) + real(kind=dp) :: qc, dos real(kind=dp) :: e_scan - real(kind=dp), allocatable, dimension(:, :) :: hCband + real(kind=dp), allocatable :: hCband(:, :) + complex(kind=dp) :: e_scan_cmp - complex(kind=dp), allocatable, dimension(:, :) :: hLC_cmp, hCR_cmp, & - totL, tottL, totR, tottR, & - g_surf_L, g_surf_R, g_C, g_C_inv, & - gR, gL, sLr, sRr, s1, s2, c1, c2 + complex(kind=dp), allocatable :: hLC_cmp(:, :), hCR_cmp(:, :) + complex(kind=dp), allocatable :: totL(:, :), tottL(:, :), totR(:, :), tottR(:, :) + complex(kind=dp), allocatable :: g_surf_L(:, :), g_surf_R(:, :) + complex(kind=dp), allocatable :: g_C(:, :), g_C_inv(:, :) + complex(kind=dp), allocatable :: gR(:, :), gL(:, :) + complex(kind=dp), allocatable :: sLr(:, :), sRr(:, :) + complex(kind=dp), allocatable :: s1(:, :), s2(:, :) + complex(kind=dp), allocatable :: c1(:, :), c2(:, :) + character(len=50) :: filename - character(len=9) :: cdate, ctime + character(len=9) :: cdate, ctime - if (timing_level > 1) call io_stopwatch('tran: lcr', 1) + if (timing_level > 1) call io_stopwatch('tran: lcr', 1, stdout, seedname) call io_date(cdate, ctime) @@ -688,114 +915,115 @@ subroutine tran_lcr() form='formatted', action='write') write (dos_unit, *) '## written on '//cdate//' at '//ctime ! Date and time - KL = max(tran_num_lc, tran_num_cr, tran_num_bandc) - 1 + KL = max(transport%num_lc, transport%num_cr, transport%num_bandc) - 1 KU = KL - KC = max(tran_num_lc, tran_num_cr) + KC = max(transport%num_lc, transport%num_cr) - allocate (hCband(2*KL + KU + 1, tran_num_cc), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hCband in tran_lcr') - allocate (hLC_cmp(tran_num_ll, tran_num_lc), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hLC_cmp in tran_lcr') - allocate (hCR_cmp(tran_num_cr, tran_num_rr), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hCR_cmp in tran_lcr') + allocate (hCband(2*KL + KU + 1, transport%num_cc), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hCband in tran_lcr', stdout, seedname) + allocate (hLC_cmp(transport%num_ll, transport%num_lc), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hLC_cmp in tran_lcr', stdout, seedname) + allocate (hCR_cmp(transport%num_cr, transport%num_rr), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hCR_cmp in tran_lcr', stdout, seedname) !If construct used only when reading matrices from file - if (tran_read_ht) then - allocate (hL0(tran_num_ll, tran_num_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hL0 in tran_lcr') - allocate (hL1(tran_num_ll, tran_num_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hL1 in tran_lcr') - allocate (hC(tran_num_cc, tran_num_cc), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hC in tran_lcr') - allocate (hLC(tran_num_ll, tran_num_lc), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hLC in tran_lcr') - allocate (hCR(tran_num_cr, tran_num_rr), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hCR in tran_lcr') + if (transport%read_ht) then + allocate (hL0(transport%num_ll, transport%num_ll), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hL0 in tran_lcr', stdout, seedname) + allocate (hL1(transport%num_ll, transport%num_ll), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hL1 in tran_lcr', stdout, seedname) + allocate (hC(transport%num_cc, transport%num_cc), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hC in tran_lcr', stdout, seedname) + allocate (hLC(transport%num_ll, transport%num_lc), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hLC in tran_lcr', stdout, seedname) + allocate (hCR(transport%num_cr, transport%num_rr), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hCR in tran_lcr', stdout, seedname) filename = trim(seedname)//'_htL.dat' - call tran_read_htX(tran_num_ll, hL0, hL1, filename) + call tran_read_htX(transport%num_ll, hL0, hL1, filename, stdout, seedname) - if (.not. tran_use_same_lead) then - allocate (hR0(tran_num_rr, tran_num_rr), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hR0 in tran_lcr') - allocate (hR1(tran_num_rr, tran_num_rr), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hR1 in tran_lcr') + if (.not. transport%use_same_lead) then + allocate (hR0(transport%num_rr, transport%num_rr), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hR0 in tran_lcr', stdout, seedname) + allocate (hR1(transport%num_rr, transport%num_rr), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hR1 in tran_lcr', stdout, seedname) filename = trim(seedname)//'_htR.dat' - call tran_read_htX(tran_num_rr, hR0, hR1, filename) + call tran_read_htX(transport%num_rr, hR0, hR1, filename, stdout, seedname) end if filename = trim(seedname)//'_htC.dat' - call tran_read_htC(tran_num_cc, hC, filename) + call tran_read_htC(transport%num_cc, hC, filename, stdout, seedname) filename = trim(seedname)//'_htLC.dat' - call tran_read_htXY(tran_num_ll, tran_num_lc, hLC, filename) + call tran_read_htXY(transport%num_ll, transport%num_lc, hLC, filename, stdout, seedname) filename = trim(seedname)//'_htCR.dat' - call tran_read_htXY(tran_num_cr, tran_num_rr, hCR, filename) + call tran_read_htXY(transport%num_cr, transport%num_rr, hCR, filename, stdout, seedname) endif ! Banded matrix H_C : save memory ! - do j = 1, tran_num_cc - do i = max(1, j - KU), min(tran_num_cc, j + KL) + do j = 1, transport%num_cc + do i = max(1, j - KU), min(transport%num_cc, j + KL) hCband(KL + KU + 1 + i - j, j) = hC(i, j) end do end do deallocate (hC, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating hC in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating hC in tran_lcr', stdout, seedname) ! H_LC : to a complex matrix hLC_cmp(:, :) = cmplx(hLC(:, :), kind=dp) deallocate (hLC, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating hLC in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating hLC in tran_lcr', stdout, seedname) ! H_CR : to a complex matrix hCR_cmp(:, :) = cmplx(hCR(:, :), kind=dp) deallocate (hCR, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating hCR in tran_lcr') - - allocate (totL(tran_num_ll, tran_num_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating totL in tran_lcr') - allocate (tottL(tran_num_ll, tran_num_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating tottL in tran_lcr') - if (.not. tran_use_same_lead) then - allocate (totR(tran_num_rr, tran_num_rr), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating totR in tran_lcr') - allocate (tottR(tran_num_rr, tran_num_rr), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating tottR in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating hCR in tran_lcr', stdout, seedname) + + allocate (totL(transport%num_ll, transport%num_ll), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating totL in tran_lcr', stdout, seedname) + allocate (tottL(transport%num_ll, transport%num_ll), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating tottL in tran_lcr', stdout, seedname) + if (.not. transport%use_same_lead) then + allocate (totR(transport%num_rr, transport%num_rr), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating totR in tran_lcr', stdout, seedname) + allocate (tottR(transport%num_rr, transport%num_rr), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating tottR in tran_lcr', stdout, seedname) end if - allocate (g_surf_L(tran_num_ll, tran_num_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating g_surf_L in tran_lcr') - allocate (g_surf_R(tran_num_rr, tran_num_rr), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating g_surf_R in tran_lcr') - allocate (g_C_inv(2*KL + KU + 1, tran_num_cc), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating g_C_inv in tran_lcr') - allocate (g_C(tran_num_cc, tran_num_cc), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating g_C in tran_lcr') - allocate (sLr(tran_num_lc, tran_num_lc), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating sLr in tran_lcr') - allocate (sRr(tran_num_cr, tran_num_cr), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating sRr in tran_lcr') - allocate (gL(tran_num_lc, tran_num_lc), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating gL in tran_lcr') - allocate (gR(tran_num_cr, tran_num_cr), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating gR in tran_lcr') - allocate (c1(tran_num_lc, tran_num_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating c1 in tran_lcr') - allocate (c2(tran_num_cr, tran_num_rr), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating c2 in tran_lcr') + allocate (g_surf_L(transport%num_ll, transport%num_ll), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating g_surf_L in tran_lcr', stdout, seedname) + allocate (g_surf_R(transport%num_rr, transport%num_rr), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating g_surf_R in tran_lcr', stdout, seedname) + allocate (g_C_inv(2*KL + KU + 1, transport%num_cc), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating g_C_inv in tran_lcr', stdout, seedname) + allocate (g_C(transport%num_cc, transport%num_cc), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating g_C in tran_lcr', stdout, seedname) + allocate (sLr(transport%num_lc, transport%num_lc), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating sLr in tran_lcr', stdout, seedname) + allocate (sRr(transport%num_cr, transport%num_cr), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating sRr in tran_lcr', stdout, seedname) + allocate (gL(transport%num_lc, transport%num_lc), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating gL in tran_lcr', stdout, seedname) + allocate (gR(transport%num_cr, transport%num_cr), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating gR in tran_lcr', stdout, seedname) + allocate (c1(transport%num_lc, transport%num_ll), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating c1 in tran_lcr', stdout, seedname) + allocate (c2(transport%num_cr, transport%num_rr), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating c2 in tran_lcr', stdout, seedname) allocate (s1(KC, KC), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating s1 in tran_lcr') + if (ierr /= 0) call io_error('Error in allocating s1 in tran_lcr', stdout, seedname) allocate (s2(KC, KC), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating s2 in tran_lcr') - allocate (ipiv(tran_num_cc), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ipiv in tran_lcr') + if (ierr /= 0) call io_error('Error in allocating s2 in tran_lcr', stdout, seedname) + allocate (ipiv(transport%num_cc), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating ipiv in tran_lcr', stdout, seedname) ! Loop over the energies - n_e = floor((tran_win_max - tran_win_min)/tran_energy_step) + 1 + n_e = floor((transport%win_max - transport%win_min)/transport%energy_step) + 1 - write (stdout, '(/1x,a)', advance='no') 'Calculating quantum conductance and density of states...' + write (stdout, '(/1x,a)', advance='no') 'Calculating quantum conductance and & + &density of states...' do n = 1, n_e - e_scan = tran_win_min + real(n - 1, dp)*tran_energy_step + e_scan = transport%win_min + real(n - 1, dp)*transport%energy_step ! compute conductance according to Fisher and Lee ! compute self-energies following Datta @@ -803,67 +1031,69 @@ subroutine tran_lcr() e_scan_cmp = e_scan + eta ! Surface green function for the left lead : g_surf_L - call tran_transfer(totL, tottL, hL0, hL1, e_scan_cmp, tran_num_ll) - call tran_green(totL, tottL, hL0, hL1, e_scan, g_surf_L, -1, 1, tran_num_ll) + call tran_transfer(totL, tottL, hL0, hL1, e_scan_cmp, transport%num_ll, stdout, seedname) + call tran_green(totL, tottL, hL0, hL1, e_scan, g_surf_L, -1, 1, transport%num_ll, stdout, seedname) ! Self-energy (Sigma_L) : sLr = (hLC_cmp)^+ * g_surf_L * hLC_cmp c1 = cmplx_0 sLr = cmplx_0 - call ZGEMM('C', 'N', tran_num_lc, tran_num_ll, tran_num_ll, cmplx_1, & - hLC_cmp, tran_num_ll, g_surf_L, tran_num_ll, cmplx_0, c1, tran_num_lc) - call ZGEMM('N', 'N', tran_num_lc, tran_num_lc, tran_num_ll, cmplx_1, & - c1, tran_num_lc, hLC_cmp, tran_num_ll, cmplx_0, sLr, tran_num_lc) + call ZGEMM('C', 'N', transport%num_lc, transport%num_ll, transport%num_ll, cmplx_1, & + hLC_cmp, transport%num_ll, g_surf_L, transport%num_ll, cmplx_0, c1, transport%num_lc) + call ZGEMM('N', 'N', transport%num_lc, transport%num_lc, transport%num_ll, cmplx_1, & + c1, transport%num_lc, hLC_cmp, transport%num_ll, cmplx_0, sLr, transport%num_lc) ! Surface green function for the right lead : g_surf_R - if (tran_use_same_lead) then - call tran_green(totL, tottL, hL0, hL1, e_scan, g_surf_R, 1, 1, tran_num_rr) + if (transport%use_same_lead) then + call tran_green(totL, tottL, hL0, hL1, e_scan, g_surf_R, 1, 1, transport%num_rr, stdout, seedname) else - call tran_transfer(totR, tottR, hR0, hR1, e_scan_cmp, tran_num_rr) - call tran_green(totR, tottR, hR0, hR1, e_scan, g_surf_R, 1, 1, tran_num_rr) + call tran_transfer(totR, tottR, hR0, hR1, e_scan_cmp, transport%num_rr, stdout, seedname) + call tran_green(totR, tottR, hR0, hR1, e_scan, g_surf_R, 1, 1, transport%num_rr, stdout, seedname) end if ! Self-energy (Sigma_R) : sRr = hCR_cmp * g_surf_R * (hCR_cmp)^+ c2 = cmplx_0 sRr = cmplx_0 - call ZGEMM('N', 'N', tran_num_cr, tran_num_rr, tran_num_rr, cmplx_1, & - hCR_cmp, tran_num_cr, g_surf_R, tran_num_rr, cmplx_0, c2, tran_num_cr) - call ZGEMM('N', 'C', tran_num_cr, tran_num_cr, tran_num_rr, cmplx_1, & - c2, tran_num_cr, hCR_cmp, tran_num_cr, cmplx_0, sRr, tran_num_cr) + call ZGEMM('N', 'N', transport%num_cr, transport%num_rr, transport%num_rr, cmplx_1, & + hCR_cmp, transport%num_cr, g_surf_R, transport%num_rr, cmplx_0, c2, transport%num_cr) + call ZGEMM('N', 'C', transport%num_cr, transport%num_cr, transport%num_rr, cmplx_1, & + c2, transport%num_cr, hCR_cmp, transport%num_cr, cmplx_0, sRr, transport%num_cr) ! g_C^-1 = -H g_C_inv(:, :) = cmplx(-hCband(:, :), kind=dp) ! g_C^-1 = -H - Sigma_L^r - do j = 1, tran_num_lc - do i = max(1, j - KU), min(tran_num_lc, j + KL) + do j = 1, transport%num_lc + do i = max(1, j - KU), min(transport%num_lc, j + KL) g_C_inv(KL + KU + 1 + i - j, j) = g_C_inv(KL + KU + 1 + i - j, j) - sLr(i, j) end do end do ! g_C^-1 = -H - Sigma_L^r - Sigma_R^r - do j = (tran_num_cc - tran_num_cr) + 1, tran_num_cc - do i = max((tran_num_cc - tran_num_cr) + 1, j - (tran_num_cr - 1)), min(tran_num_cc, j + (tran_num_cr - 1)) + do j = (transport%num_cc - transport%num_cr) + 1, transport%num_cc + do i = max((transport%num_cc - transport%num_cr) + 1, j - (transport%num_cr - 1)), & + min(transport%num_cc, j + (transport%num_cr - 1)) g_C_inv(KL + KU + 1 + i - j, j) = & g_C_inv(KL + KU + 1 + i - j, j) - & - sRr(i - (tran_num_cc - tran_num_cr), j - (tran_num_cc - tran_num_cr)) + sRr(i - (transport%num_cc - transport%num_cr), j - (transport%num_cc - transport%num_cr)) end do end do ! g_C^-1 = eI - H - Sigma_L^r - Sigma_R^r - do i = 1, tran_num_cc + do i = 1, transport%num_cc g_C_inv(KL + KU + 1, i) = e_scan + g_C_inv(KL + KU + 1, i) end do ! invert g_C^-1 => g_C g_C = cmplx_0 - do i = 1, tran_num_cc + do i = 1, transport%num_cc g_C(i, i) = cmplx_1 end do - call ZGBSV(tran_num_cc, KL, KU, tran_num_cc, g_C_inv, 2*KL + KU + 1, ipiv, g_C, tran_num_cc, info) + call ZGBSV(transport%num_cc, KL, KU, transport%num_cc, g_C_inv, 2*KL + KU + 1, ipiv, g_C, transport%num_cc, & + info) if (info .ne. 0) then write (stdout, *) 'ERROR: IN ZGBSV IN tran_lcr, INFO=', info - call io_error('tran_lcr: problem in ZGBSV') + call io_error('tran_lcr: problem in ZGBSV', stdout, seedname) end if ! Gamma_L = i(Sigma_L^r-Sigma_L^a) @@ -872,9 +1102,9 @@ subroutine tran_lcr() ! s1 = Gamma_L * g_C^r s1 = cmplx_0 do j = 1, KC - do i = 1, tran_num_lc - do k = 1, tran_num_lc - s1(i, j) = s1(i, j) + gL(i, k)*g_C(k, j + (tran_num_cc - KC)) + do i = 1, transport%num_lc + do k = 1, transport%num_lc + s1(i, j) = s1(i, j) + gL(i, k)*g_C(k, j + (transport%num_cc - KC)) end do end do end do @@ -885,10 +1115,11 @@ subroutine tran_lcr() ! s2 = Gamma_R * g_C^a s2 = cmplx_0 do j = 1, KC - do i = 1, tran_num_cr - do k = 1, tran_num_cr - s2(i + (KC - tran_num_cr), j) = s2(i + (KC - tran_num_cr), j) & - + gR(i, k)*conjg(g_C(j, k + (tran_num_cc - tran_num_cr))) + do i = 1, transport%num_cr + do k = 1, transport%num_cr + s2(i + (KC - transport%num_cr), j) = s2(i + (KC - transport%num_cr), j) & + + gR(i, k)*conjg(g_C(j, k & + + (transport%num_cc - transport%num_cr))) end do end do end do @@ -904,7 +1135,7 @@ subroutine tran_lcr() ! compute density of states for the conductor layer dos = 0.0_dp - do i = 1, tran_num_cc + do i = 1, transport%num_cc dos = dos - aimag(g_C(i, i)) end do dos = dos/pi @@ -918,74 +1149,76 @@ subroutine tran_lcr() close (dos_unit) deallocate (ipiv, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating ipiv in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating ipiv in tran_lcr', stdout, seedname) deallocate (s2, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating s2 in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating s2 in tran_lcr', stdout, seedname) deallocate (s1, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating s1 in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating s1 in tran_lcr', stdout, seedname) deallocate (c2, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating c2 in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating c2 in tran_lcr', stdout, seedname) deallocate (c1, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating c1 in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating c1 in tran_lcr', stdout, seedname) deallocate (gR, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating gR in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating gR in tran_lcr', stdout, seedname) deallocate (gL, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating gL in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating gL in tran_lcr', stdout, seedname) deallocate (sRr, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating sRr in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating sRr in tran_lcr', stdout, seedname) deallocate (sLr, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating sLr in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating sLr in tran_lcr', stdout, seedname) deallocate (g_C, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating g_C in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating g_C in tran_lcr', stdout, seedname) deallocate (g_C_inv, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating g_C_inv in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating g_C_inv in tran_lcr', stdout, seedname) deallocate (g_surf_R, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating g_surf_R in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating g_surf_R in tran_lcr', stdout, seedname) deallocate (g_surf_L, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating g_surf_L in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating g_surf_L in tran_lcr', stdout, seedname) if (allocated(tottR)) deallocate (tottR, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating tottR in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating tottR in tran_lcr', stdout, seedname) if (allocated(totR)) deallocate (totR, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating totR in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating totR in tran_lcr', stdout, seedname) deallocate (tottL, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating tottL in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating tottL in tran_lcr', stdout, seedname) deallocate (totL, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating totL in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating totL in tran_lcr', stdout, seedname) deallocate (hCR_cmp, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating hCR_cmp in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating hCR_cmp in tran_lcr', stdout, seedname) deallocate (hLC_cmp, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating hLC_cmp in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating hLC_cmp in tran_lcr', stdout, seedname) deallocate (hCband, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating hCband in tran_lcr') + if (ierr /= 0) call io_error('Error in deallocating hCband in tran_lcr', stdout, seedname) - if (timing_level > 1) call io_stopwatch('tran: lcr', 2) + if (timing_level > 1) call io_stopwatch('tran: lcr', 2, stdout, seedname) return end subroutine tran_lcr - !==================================================================! - subroutine tran_transfer(tot, tott, h_00, h_01, e_scan_cmp, nxx) - !==================================================================! - ! ! - ! iterative construction of the transfer matrix ! - ! as Lopez-Sancho^2&Rubio, J.Phys.F:Met.Phys., v.14, 1205 (1984) ! - ! and ibid. v.15, 851 (1985) ! - ! ! - !=================================================================== + !================================================! + subroutine tran_transfer(tot, tott, h_00, h_01, e_scan_cmp, nxx, stdout, seedname) + !================================================! + ! + ! iterative construction of the transfer matrix + ! as Lopez-Sancho^2&Rubio, J.Phys.F:Met.Phys., v.14, 1205 (1984) + ! and ibid. v.15, 851 (1985) + ! + !================================================ use w90_constants, only: dp, cmplx_0, cmplx_1, eps7 - use w90_io, only: stdout, io_error + use w90_io, only: io_error implicit none integer, intent(in) :: nxx + integer, intent(in) :: stdout complex(kind=dp), intent(in) :: e_scan_cmp complex(kind=dp), intent(out) :: tot(nxx, nxx) complex(kind=dp), intent(out) :: tott(nxx, nxx) real(kind=dp), intent(in) :: h_00(nxx, nxx) real(kind=dp), intent(in) :: h_01(nxx, nxx) - ! + character(len=50), intent(in) :: seedname + integer :: ierr, info integer :: i, j, n, nxx2 integer, allocatable :: ipiv(:) @@ -996,23 +1229,23 @@ subroutine tran_transfer(tot, tott, h_00, h_01, e_scan_cmp, nxx) complex(kind=dp), allocatable, dimension(:, :, :) :: tau, taut allocate (ipiv(nxx), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ipiv in tran_transfer') + if (ierr /= 0) call io_error('Error in allocating ipiv in tran_transfer', stdout, seedname) allocate (tsum(nxx, nxx), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating tsum in tran_transfer') + if (ierr /= 0) call io_error('Error in allocating tsum in tran_transfer', stdout, seedname) allocate (tsumt(nxx, nxx), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating tsumt in tran_transfer') + if (ierr /= 0) call io_error('Error in allocating tsumt in tran_transfer', stdout, seedname) allocate (t11(nxx, nxx), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating t11 in tran_transfer') + if (ierr /= 0) call io_error('Error in allocating t11 in tran_transfer', stdout, seedname) allocate (t12(nxx, nxx), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating t12 in tran_transfer') + if (ierr /= 0) call io_error('Error in allocating t12 in tran_transfer', stdout, seedname) allocate (s1(nxx, nxx), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating s1 in tran_transfer') + if (ierr /= 0) call io_error('Error in allocating s1 in tran_transfer', stdout, seedname) allocate (s2(nxx, nxx), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating s2 in tran_transfer') + if (ierr /= 0) call io_error('Error in allocating s2 in tran_transfer', stdout, seedname) allocate (tau(nxx, nxx, 2), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating tau in tran_transfer') + if (ierr /= 0) call io_error('Error in allocating tau in tran_transfer', stdout, seedname) allocate (taut(nxx, nxx, 2), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating taut in tran_transfer') + if (ierr /= 0) call io_error('Error in allocating taut in tran_transfer', stdout, seedname) nxx2 = nxx*nxx @@ -1036,7 +1269,7 @@ subroutine tran_transfer(tot, tott, h_00, h_01, e_scan_cmp, nxx) call ZGESV(nxx, nxx, t12, nxx, ipiv, t11, nxx, info) if (info .ne. 0) then write (stdout, *) 'ERROR: IN ZGESV IN tran_transfer, INFO=', info - call io_error('tran_transfer: problem in ZGESV 1') + call io_error('tran_transfer: problem in ZGESV 1', stdout, seedname) end if ! compute intermediate t-matrices (defined as tau(nxx,nxx,niter) @@ -1066,8 +1299,10 @@ subroutine tran_transfer(tot, tott, h_00, h_01, e_scan_cmp, nxx) t11 = cmplx_0 t12 = cmplx_0 - call ZGEMM('N', 'N', nxx, nxx, nxx, cmplx_1, tau(1, 1, 1), nxx, taut(1, 1, 1), nxx, cmplx_0, t11, nxx) - call ZGEMM('N', 'N', nxx, nxx, nxx, cmplx_1, taut(1, 1, 1), nxx, tau(1, 1, 1), nxx, cmplx_0, t12, nxx) + call ZGEMM('N', 'N', nxx, nxx, nxx, cmplx_1, tau(1, 1, 1), nxx, taut(1, 1, 1), nxx, cmplx_0, & + t11, nxx) + call ZGEMM('N', 'N', nxx, nxx, nxx, cmplx_1, taut(1, 1, 1), nxx, tau(1, 1, 1), nxx, cmplx_0, & + t12, nxx) s1(:, :) = -t11(:, :) - t12(:, :) do i = 1, nxx @@ -1082,14 +1317,16 @@ subroutine tran_transfer(tot, tott, h_00, h_01, e_scan_cmp, nxx) call ZGESV(nxx, nxx, s1, nxx, ipiv, s2, nxx, info) if (info .ne. 0) then write (stdout, *) 'ERROR: IN ZGESV IN tran_transfer, INFO=', info - call io_error('tran_transfer: problem in ZGESV 2') + call io_error('tran_transfer: problem in ZGESV 2', stdout, seedname) end if t11 = cmplx_0 t12 = cmplx_0 - call ZGEMM('N', 'N', nxx, nxx, nxx, cmplx_1, tau(1, 1, 1), nxx, tau(1, 1, 1), nxx, cmplx_0, t11, nxx) - call ZGEMM('N', 'N', nxx, nxx, nxx, cmplx_1, taut(1, 1, 1), nxx, taut(1, 1, 1), nxx, cmplx_0, t12, nxx) + call ZGEMM('N', 'N', nxx, nxx, nxx, cmplx_1, tau(1, 1, 1), nxx, tau(1, 1, 1), nxx, cmplx_0, & + t11, nxx) + call ZGEMM('N', 'N', nxx, nxx, nxx, cmplx_1, taut(1, 1, 1), nxx, taut(1, 1, 1), nxx, & + cmplx_0, t12, nxx) call ZGEMM('N', 'N', nxx, nxx, nxx, cmplx_1, s2, nxx, t11, nxx, cmplx_0, tau(1, 1, 2), nxx) call ZGEMM('N', 'N', nxx, nxx, nxx, cmplx_1, s2, nxx, t12, nxx, cmplx_0, taut(1, 1, 2), nxx) @@ -1109,7 +1346,8 @@ subroutine tran_transfer(tot, tott, h_00, h_01, e_scan_cmp, nxx) t11 = cmplx_0 s1 = cmplx_0 - call ZGEMM('N', 'N', nxx, nxx, nxx, cmplx_1, tsumt, nxx, taut(1, 1, 2), nxx, cmplx_0, t11, nxx) + call ZGEMM('N', 'N', nxx, nxx, nxx, cmplx_1, tsumt, nxx, taut(1, 1, 2), nxx, cmplx_0, t11, & + nxx) call ZGEMM('N', 'N', nxx, nxx, nxx, cmplx_1, tsumt, nxx, tau(1, 1, 2), nxx, cmplx_0, s1, nxx) call ZCOPY(nxx2, t11, 1, s2, 1) call ZAXPY(nxx2, cmplx_1, tott, 1, s2, 1) @@ -1136,56 +1374,58 @@ subroutine tran_transfer(tot, tott, h_00, h_01, e_scan_cmp, nxx) end do if (conver .gt. eps7 .or. conver2 .gt. eps7) & - call io_error('Error in converging transfer matrix in tran_transfer') + call io_error('Error in converging transfer matrix in tran_transfer', stdout, seedname) deallocate (taut, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating taut in tran_transfer') + if (ierr /= 0) call io_error('Error in deallocating taut in tran_transfer', stdout, seedname) deallocate (tau, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating tau in tran_transfer') + if (ierr /= 0) call io_error('Error in deallocating tau in tran_transfer', stdout, seedname) deallocate (s2, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating s2 in tran_transfer') + if (ierr /= 0) call io_error('Error in deallocating s2 in tran_transfer', stdout, seedname) deallocate (s1, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating s1 in tran_transfer') + if (ierr /= 0) call io_error('Error in deallocating s1 in tran_transfer', stdout, seedname) deallocate (t12, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating t12 in tran_transfer') + if (ierr /= 0) call io_error('Error in deallocating t12 in tran_transfer', stdout, seedname) deallocate (t11, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating t11 in tran_transfer') + if (ierr /= 0) call io_error('Error in deallocating t11 in tran_transfer', stdout, seedname) deallocate (tsumt, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating tsumt in tran_transfer') + if (ierr /= 0) call io_error('Error in deallocating tsumt in tran_transfer', stdout, seedname) deallocate (tsum, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating tsum in tran_transfer') + if (ierr /= 0) call io_error('Error in deallocating tsum in tran_transfer', stdout, seedname) deallocate (ipiv, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating ipiv in tran_transfer') + if (ierr /= 0) call io_error('Error in deallocating ipiv in tran_transfer', stdout, seedname) return end subroutine tran_transfer - !==================================================================! - subroutine tran_green(tot, tott, h_00, h_01, e_scan, g, igreen, invert, nxx) - !==================================================================! + !================================================! + subroutine tran_green(tot, tott, h_00, h_01, e_scan, g, igreen, invert, nxx, stdout, seedname) + !================================================! ! construct green's functions ! ! igreen = -1 left surface ! igreen = 1 right surface ! igreen = 0 bulk - + ! ! invert = 0 computes g^-1 ! invert = 1 computes g^-1 and g - !==================================================================! + !================================================! use w90_constants, only: dp, cmplx_0, cmplx_1 - use w90_io, only: stdout, io_error + use w90_io, only: io_error implicit none integer, intent(in) :: nxx + integer, intent(in) :: stdout integer, intent(in) :: igreen integer, intent(in) :: invert real(kind=dp), intent(in) :: e_scan real(kind=dp), intent(in) :: h_00(nxx, nxx), h_01(nxx, nxx) complex(kind=dp), intent(in) :: tot(nxx, nxx), tott(nxx, nxx) complex(kind=dp), intent(out) :: g(nxx, nxx) + character(len=50), intent(in) :: seedname integer :: ierr, info integer :: i @@ -1194,17 +1434,17 @@ subroutine tran_green(tot, tott, h_00, h_01, e_scan, g, igreen, invert, nxx) complex(kind=dp), allocatable, dimension(:, :) :: s1, s2, c1 allocate (ipiv(nxx), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ipiv in tran_green') + if (ierr /= 0) call io_error('Error in allocating ipiv in tran_green', stdout, seedname) allocate (g_inv(nxx, nxx)) - if (ierr /= 0) call io_error('Error in allocating g_inv in tran_green') + if (ierr /= 0) call io_error('Error in allocating g_inv in tran_green', stdout, seedname) allocate (eh_00(nxx, nxx)) - if (ierr /= 0) call io_error('Error in allocating eh_00 in tran_green') + if (ierr /= 0) call io_error('Error in allocating eh_00 in tran_green', stdout, seedname) allocate (c1(nxx, nxx)) - if (ierr /= 0) call io_error('Error in allocating c1 in tran_green') + if (ierr /= 0) call io_error('Error in allocating c1 in tran_green', stdout, seedname) allocate (s1(nxx, nxx)) - if (ierr /= 0) call io_error('Error in allocating s1 in tran_green') + if (ierr /= 0) call io_error('Error in allocating s1 in tran_green', stdout, seedname) allocate (s2(nxx, nxx)) - if (ierr /= 0) call io_error('Error in allocating s2 in tran_green') + if (ierr /= 0) call io_error('Error in allocating s2 in tran_green', stdout, seedname) c1(:, :) = cmplx(h_01(:, :), kind=dp) @@ -1237,7 +1477,7 @@ subroutine tran_green(tot, tott, h_00, h_01, e_scan, g, igreen, invert, nxx) call ZGESV(nxx, nxx, eh_00, nxx, ipiv, g, nxx, info) if (info .ne. 0) then write (stdout, *) 'ERROR: IN ZGESV IN tran_green, INFO=', info - call io_error('tran_green: problem in ZGESV 1') + call io_error('tran_green: problem in ZGESV 1', stdout, seedname) end if end if @@ -1268,7 +1508,7 @@ subroutine tran_green(tot, tott, h_00, h_01, e_scan, g, igreen, invert, nxx) call ZGESV(nxx, nxx, eh_00, nxx, ipiv, g, nxx, info) if (info .ne. 0) then write (stdout, *) 'ERROR: IN ZGESV IN tran_green, INFO=', info - call io_error('tran_green: problem in ZGESV 2') + call io_error('tran_green: problem in ZGESV 2', stdout, seedname) end if end if @@ -1301,42 +1541,44 @@ subroutine tran_green(tot, tott, h_00, h_01, e_scan, g, igreen, invert, nxx) call ZGESV(nxx, nxx, eh_00, nxx, ipiv, g, nxx, info) if (info .ne. 0) then write (stdout, *) 'ERROR: IN ZGESV IN tran_green, INFO=', info - call io_error('tran_green: problem in ZGESV 3') + call io_error('tran_green: problem in ZGESV 3', stdout, seedname) end if end if end select deallocate (s2) - if (ierr /= 0) call io_error('Error in deallocating s2 in tran_green') + if (ierr /= 0) call io_error('Error in deallocating s2 in tran_green', stdout, seedname) deallocate (s1) - if (ierr /= 0) call io_error('Error in deallocating s1 in tran_green') + if (ierr /= 0) call io_error('Error in deallocating s1 in tran_green', stdout, seedname) deallocate (c1) - if (ierr /= 0) call io_error('Error in deallocating c1 in tran_green') + if (ierr /= 0) call io_error('Error in deallocating c1 in tran_green', stdout, seedname) deallocate (eh_00) - if (ierr /= 0) call io_error('Error in deallocating eh_00 in tran_green') + if (ierr /= 0) call io_error('Error in deallocating eh_00 in tran_green', stdout, seedname) deallocate (g_inv) - if (ierr /= 0) call io_error('Error in deallocating g_inv in tran_green') + if (ierr /= 0) call io_error('Error in deallocating g_inv in tran_green', stdout, seedname) deallocate (ipiv) - if (ierr /= 0) call io_error('Error in deallocating ipiv in tran_green') + if (ierr /= 0) call io_error('Error in deallocating ipiv in tran_green', stdout, seedname) return end subroutine tran_green - !============================================! - subroutine tran_read_htX(nxx, h_00, h_01, h_file) - !============================================! + !================================================! + subroutine tran_read_htX(nxx, h_00, h_01, h_file, stdout, seedname) + !================================================! use w90_constants, only: dp - use w90_io, only: stdout, io_file_unit, io_error, maxlen + use w90_io, only: io_file_unit, io_error, maxlen implicit none integer, intent(in) :: nxx + integer, intent(in) :: stdout real(kind=dp), intent(out) :: h_00(nxx, nxx), h_01(nxx, nxx) character(len=50), intent(in) :: h_file - ! + character(len=50), intent(in) :: seedname + integer :: i, j, nw, file_unit character(len=maxlen) :: dummy @@ -1351,34 +1593,36 @@ subroutine tran_read_htX(nxx, h_00, h_01, h_file) write (stdout, '(a)') trim(dummy) read (file_unit, *, err=102, end=102) nw - if (nw .ne. nxx) call io_error('wrong matrix size in transport: read_htX') + if (nw .ne. nxx) call io_error('wrong matrix size in transport: read_htX', stdout, seedname) read (file_unit, *) ((h_00(i, j), i=1, nxx), j=1, nxx) read (file_unit, *, err=102, end=102) nw - if (nw .ne. nxx) call io_error('wrong matrix size in transport: read_htX') + if (nw .ne. nxx) call io_error('wrong matrix size in transport: read_htX', stdout, seedname) read (file_unit, *, err=102, end=102) ((h_01(i, j), i=1, nxx), j=1, nxx) close (unit=file_unit) return -101 call io_error('Error: Problem opening input file '//h_file) -102 call io_error('Error: Problem reading input file '//h_file) +101 call io_error('Error: Problem opening input file '//h_file, stdout, seedname) +102 call io_error('Error: Problem reading input file '//h_file, stdout, seedname) end subroutine tran_read_htX - !============================================! - subroutine tran_read_htC(nxx, h_00, h_file) - !============================================! + !================================================! + subroutine tran_read_htC(nxx, h_00, h_file, stdout, seedname) + !================================================! use w90_constants, only: dp - use w90_io, only: stdout, io_file_unit, io_error, maxlen + use w90_io, only: io_file_unit, io_error, maxlen implicit none integer, intent(in) :: nxx + integer, intent(in) :: stdout real(kind=dp), intent(out) :: h_00(nxx, nxx) character(len=50), intent(in) :: h_file - ! + character(len=50), intent(in) :: seedname + integer :: i, j, nw, file_unit character(len=maxlen) :: dummy @@ -1393,31 +1637,33 @@ subroutine tran_read_htC(nxx, h_00, h_file) write (stdout, '(a)') trim(dummy) read (file_unit, *, err=102, end=102) nw - if (nw .ne. nxx) call io_error('wrong matrix size in transport: read_htC') + if (nw .ne. nxx) call io_error('wrong matrix size in transport: read_htC', stdout, seedname) read (file_unit, *, err=102, end=102) ((h_00(i, j), i=1, nxx), j=1, nxx) close (unit=file_unit) return -101 call io_error('Error: Problem opening input file '//h_file) -102 call io_error('Error: Problem reading input file '//h_file) +101 call io_error('Error: Problem opening input file '//h_file, stdout, seedname) +102 call io_error('Error: Problem reading input file '//h_file, stdout, seedname) end subroutine tran_read_htC - !============================================! - subroutine tran_read_htXY(nxx1, nxx2, h_01, h_file) - !============================================! + !================================================! + subroutine tran_read_htXY(nxx1, nxx2, h_01, h_file, stdout, seedname) + !================================================! use w90_constants, only: dp - use w90_io, only: stdout, io_file_unit, io_error, maxlen + use w90_io, only: io_file_unit, io_error, maxlen implicit none integer, intent(in) :: nxx1, nxx2 + integer, intent(in) :: stdout real(kind=dp), intent(out) :: h_01(nxx1, nxx2) character(len=50), intent(in) :: h_file - ! + character(len=50), intent(in) :: seedname + integer :: i, j, nw1, nw2, file_unit character(len=maxlen) :: dummy @@ -1433,7 +1679,7 @@ subroutine tran_read_htXY(nxx1, nxx2, h_01, h_file) read (file_unit, *, err=102, end=102) nw1, nw2 - if (nw1 .ne. nxx1 .or. nw2 .ne. nxx2) call io_error('wrong matrix size in transport: read_htXY') + if (nw1 .ne. nxx1 .or. nw2 .ne. nxx2) call io_error('wrong matrix size in transport: read_htXY', stdout, seedname) read (file_unit, *, err=102, end=102) ((h_01(i, j), i=1, nxx1), j=1, nxx2) @@ -1441,91 +1687,96 @@ subroutine tran_read_htXY(nxx1, nxx2, h_01, h_file) return -101 call io_error('Error: Problem opening input file '//h_file) -102 call io_error('Error: Problem reading input file '//h_file) +101 call io_error('Error: Problem opening input file '//h_file, stdout, seedname) +102 call io_error('Error: Problem reading input file '//h_file, stdout, seedname) end subroutine tran_read_htXY -!======================================== - subroutine tran_find_integral_signatures(signatures, num_G) - !=========================================================================! - ! Reads .unkg file that contains the u_nk(G) and calculate ! - ! Fourier components of each wannier function. Linear combinations of ! - ! these provide integral of different spatial dependence. ! - ! The set of these integrals provide a signature for distinguishing the ! - ! type and 'parity' of each wannier function. ! - !=========================================================================! +!================================================ + subroutine tran_find_integral_signatures(signatures, num_G, print_output, real_lattice, u_matrix_opt, & + u_matrix, num_bands, num_wann, have_disentangled, & + wannier_centres_translated, stdout, seedname) + !================================================! + ! Reads .unkg file that contains the u_nk(G) and calculate + ! Fourier components of each wannier function. Linear combinations of + ! these provide integral of different spatial dependence. + ! The set of these integrals provide a signature for distinguishing the + ! type and 'parity' of each wannier function. + !================================================! use w90_constants, only: dp, cmplx_0, twopi, cmplx_i - use w90_io, only: io_error, stdout, seedname, io_file_unit, io_date, & - io_stopwatch - - use w90_parameters, only: num_wann, have_disentangled, num_bands, u_matrix, u_matrix_opt, & - real_lattice, iprint, timing_level - - use w90_hamiltonian, only: wannier_centres_translated + use w90_io, only: io_error, io_file_unit, io_date, io_stopwatch + use w90_types, only: print_output_type implicit none - integer, intent(out) :: num_G - real(kind=dp), allocatable, dimension(:, :), intent(out) :: signatures - - complex(kind=dp), allocatable :: unkg(:, :), tran_u_matrix(:, :) - complex(kind=dp) :: phase_factor, signature_basis(32) - - real(kind=dp) :: i_unkg, r_unkg, wf_frac(3), det_rl, inv_t_rl(3, 3), & - mag_signature_sq - -!~ character(len=11) :: unkg_file - - logical :: have_file - integer, allocatable, dimension(:, :) :: g_abc - integer :: i, ibnd, file_unit, ierr, p, p_max, n, m, ig, a, b, c, ig_idx(32) + type(print_output_type), intent(in) :: print_output + + integer, intent(in) :: num_bands + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + integer, intent(out) :: num_G + complex(kind=dp), intent(in) :: u_matrix(:, :, :) + complex(kind=dp), intent(in) :: u_matrix_opt(:, :, :) + real(kind=dp), allocatable, intent(out) :: signatures(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: wannier_centres_translated(:, :) + character(len=50), intent(in) :: seedname + logical, intent(in) :: have_disentangled + + integer, allocatable :: g_abc(:, :) + integer :: i, ibnd, file_unit, ierr, p, p_max, n, m, ig, a, b, c, ig_idx(32) + real(kind=dp) :: i_unkg, r_unkg, wf_frac(3), det_rl, inv_t_rl(3, 3), mag_signature_sq + complex(kind=dp), allocatable :: unkg(:, :), tran_u_matrix(:, :) + complex(kind=dp) :: phase_factor, signature_basis(32) + logical :: have_file + + if (print_output%timing_level > 1) call io_stopwatch('tran: find_sigs_unkg_int', 1, stdout, seedname) - if (timing_level > 1) call io_stopwatch('tran: find_sigs_unkg_int', 1) - ! file_unit = io_file_unit() inquire (file=trim(seedname)//'.unkg', exist=have_file) - if (.not. have_file) call io_error('tran_hr_parity_unkg: file '//trim(seedname)//'.unkg not found') + if (.not. have_file) call io_error('tran_hr_parity_unkg: file '//trim(seedname)// & + '.unkg not found', stdout, seedname) open (file_unit, file=trim(seedname)//'.unkg', form='formatted', action='read') - ! - !Read unkg file - ! + write (stdout, '(3a)') ' Reading '//trim(seedname)//'.unkg file' read (file_unit, *) num_G allocate (signatures(20, num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating signatures in tran_find_sigs_unkg_int') + if (ierr /= 0) call io_error('Error in allocating signatures in tran_find_sigs_unkg_int', stdout, seedname) allocate (unkg(num_G, num_bands), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating unkg in tran_find_sigs_unkg_int') + if (ierr /= 0) call io_error('Error in allocating unkg in tran_find_sigs_unkg_int', stdout, seedname) allocate (g_abc(num_G, 3), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating g_abc in tran_find_sigs_unkg_int') + if (ierr /= 0) call io_error('Error in allocating g_abc in tran_find_sigs_unkg_int', stdout, seedname) if (have_disentangled) then allocate (tran_u_matrix(num_bands, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating tran_u_matrix in tran_find_sigs_unkg_int') + if (ierr /= 0) call io_error('Error in allocating tran_u_matrix in tran_find_sigs_unkg_int', stdout, seedname) else allocate (tran_u_matrix(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating tran_u_matrix in tran_find_sigs_unkg_int') + if (ierr /= 0) call io_error('Error in allocating tran_u_matrix in tran_find_sigs_unkg_int', stdout, seedname) endif - ! + unkg = cmplx_0 do m = 1, num_bands do i = 1, num_G read (file_unit, *) ibnd, ig, a, b, c, r_unkg, i_unkg if ((ig .ne. i) .OR. (ibnd .ne. m)) then - call io_error('tran_find_sigs_unkg_int: Incorrect bands or g vectors') + call io_error('tran_find_sigs_unkg_int: Incorrect bands or g vectors', stdout, seedname) endif unkg(i, m) = cmplx(r_unkg, i_unkg, kind=dp) g_abc(i, :) = (/a, b, c/) enddo enddo - ! + close (file_unit) - ! + ! Computing inverse of transpose of real_lattice - ! - det_rl = real_lattice(1, 1)*(real_lattice(2, 2)*real_lattice(3, 3) - real_lattice(2, 3)*real_lattice(3, 2)) & - - real_lattice(2, 2)*(real_lattice(2, 1)*real_lattice(3, 3) - real_lattice(2, 3)*real_lattice(3, 1)) & - + real_lattice(3, 3)*(real_lattice(2, 1)*real_lattice(3, 2) - real_lattice(2, 2)*real_lattice(3, 1)) + + det_rl = real_lattice(1, 1)*(real_lattice(2, 2)*real_lattice(3, 3) & + - real_lattice(2, 3)*real_lattice(3, 2)) & + - real_lattice(2, 2)*(real_lattice(2, 1)*real_lattice(3, 3) & + - real_lattice(2, 3)*real_lattice(3, 1)) & + + real_lattice(3, 3)*(real_lattice(2, 1)*real_lattice(3, 2) & + - real_lattice(2, 2)*real_lattice(3, 1)) inv_t_rl(1, 1) = (real_lattice(2, 2)*real_lattice(3, 3) - real_lattice(3, 2)*real_lattice(2, 3)) inv_t_rl(1, 2) = (real_lattice(2, 1)*real_lattice(3, 3) - real_lattice(3, 1)*real_lattice(2, 3)) @@ -1540,15 +1791,15 @@ subroutine tran_find_integral_signatures(signatures, num_G) inv_t_rl(3, 3) = (real_lattice(1, 1)*real_lattice(2, 2) - real_lattice(2, 1)*real_lattice(1, 2)) inv_t_rl = inv_t_rl/det_rl - ! + !Loop over wannier functions to compute generalised U matrix - ! + signatures = 0.0_dp tran_u_matrix = cmplx_0 do n = 1, num_wann - ! + !Disentanglement step - ! + if (have_disentangled) then do p = 1, num_bands do m = 1, num_wann @@ -1562,20 +1813,21 @@ subroutine tran_find_integral_signatures(signatures, num_G) endif enddo - if (iprint .ge. 5) write (stdout, *) 'Printing integral signatures for each wannier function:' - ! + if (print_output%iprint .ge. 5) write (stdout, *) 'Printing integral signatures for each & + &wannier function:' + ! Loop over all wannier functions - ! + do n = 1, num_wann - ! + ! Find fraction coordinate of wannier function in lattice vector basis ! wf_frac(:)=(transpose(real_lattice))^(-1) * wannier_centres_translated(:,n) - ! + wf_frac = 0.0_dp wf_frac = matmul(inv_t_rl, wannier_centres_translated(:, n)) - ! + ! Loop over all g vectors, find a,b,c's required - ! + do ig = 1, num_G ! 0th Order if ((g_abc(ig, 1) .eq. 0) .and. (g_abc(ig, 2) .eq. 0) .and. (g_abc(ig, 3) .eq. 0)) ig_idx(1) = ig ! 1 @@ -1614,221 +1866,251 @@ subroutine tran_find_integral_signatures(signatures, num_G) if ((g_abc(ig, 1) .eq. 0) .and. (g_abc(ig, 2) .eq. 1) .and. (g_abc(ig, 3) .eq. -2)) ig_idx(31) = ig ! yz^2 if ((g_abc(ig, 1) .eq. 0) .and. (g_abc(ig, 2) .eq. 0) .and. (g_abc(ig, 3) .eq. 3)) ig_idx(32) = ig ! z^3 enddo - ! + ! Loop over the 32 required g-vectors - ! + signature_basis = cmplx_0 do ig = 1, 32 phase_factor = cmplx_0 - ! + ! Compute the phase factor exp(-i*G*x_c) - ! + phase_factor = exp(-twopi*cmplx_i*(g_abc(ig_idx(ig), 1)*wf_frac(1) & + g_abc(ig_idx(ig), 2)*wf_frac(2) & + g_abc(ig_idx(ig), 3)*wf_frac(3))) - ! + ! Compute integrals that form the basis of the spatial integrals that form the signature do p = 1, p_max signature_basis(ig) = signature_basis(ig) + tran_u_matrix(p, n)*conjg(unkg(ig_idx(ig), p)) enddo signature_basis(ig) = signature_basis(ig)*phase_factor enddo - ! + ! Definitions of the signature integrals - ! + ! 0th Order - signatures(1, n) = real(signature_basis(1)) ! 1 + signatures(1, n) = real(signature_basis(1)) ! 1 ! 1st Order - signatures(2, n) = aimag(signature_basis(2)) ! x - signatures(3, n) = aimag(signature_basis(3)) ! y - signatures(4, n) = aimag(signature_basis(4)) ! z + signatures(2, n) = aimag(signature_basis(2)) ! x + signatures(3, n) = aimag(signature_basis(3)) ! y + signatures(4, n) = aimag(signature_basis(4)) ! z ! 2nd Orde r - signatures(5, n) = real(signature_basis(1) - signature_basis(5))/2 ! x^2 - signatures(6, n) = real(signature_basis(7) - signature_basis(6))/2 ! xy - signatures(7, n) = real(signature_basis(9) - signature_basis(8))/2 ! xz - signatures(8, n) = real(signature_basis(1) - signature_basis(10))/2 ! y^2 - signatures(9, n) = real(signature_basis(12) - signature_basis(11))/2 ! yz - signatures(10, n) = real(signature_basis(1) - signature_basis(13))/2 ! z^2 + signatures(5, n) = real(signature_basis(1) - signature_basis(5))/2 ! x^2 + signatures(6, n) = real(signature_basis(7) - signature_basis(6))/2 ! xy + signatures(7, n) = real(signature_basis(9) - signature_basis(8))/2 ! xz + signatures(8, n) = real(signature_basis(1) - signature_basis(10))/2 ! y^2 + signatures(9, n) = real(signature_basis(12) - signature_basis(11))/2 ! yz + signatures(10, n) = real(signature_basis(1) - signature_basis(13))/2 ! z^2 ! 3rd Order - signatures(11, n) = aimag(3*signature_basis(2) - signature_basis(14))/4 ! x^3 - signatures(12, n) = aimag(2*signature_basis(3) + signature_basis(16) - signature_basis(15))/4 ! x^2y - signatures(13, n) = aimag(2*signature_basis(4) + signature_basis(18) - signature_basis(17))/4 ! x^2z - signatures(14, n) = aimag(2*signature_basis(2) - signature_basis(20) - signature_basis(19))/4 ! xy^2 - signatures(15, n) = aimag(signature_basis(23) + signature_basis(22) - signature_basis(21) - signature_basis(24))/4 ! xyz - signatures(16, n) = aimag(2*signature_basis(2) - signature_basis(26) - signature_basis(25))/4 ! xz^2 - signatures(17, n) = aimag(3*signature_basis(3) - signature_basis(27))/4 ! y^3 - signatures(18, n) = aimag(2*signature_basis(4) + signature_basis(29) - signature_basis(28))/4 ! y^2z - signatures(19, n) = aimag(2*signature_basis(3) - signature_basis(31) - signature_basis(30))/4 ! yz^2 - signatures(20, n) = aimag(3*signature_basis(4) - signature_basis(32))/4 ! z^3 - - if (iprint .ge. 5) then + signatures(11, n) = aimag(3*signature_basis(2) - signature_basis(14))/4 ! x^3 + signatures(12, n) = aimag(2*signature_basis(3) + signature_basis(16) - signature_basis(15))/4 ! x^2y + signatures(13, n) = aimag(2*signature_basis(4) + signature_basis(18) - signature_basis(17))/4 ! x^2z + signatures(14, n) = aimag(2*signature_basis(2) - signature_basis(20) - signature_basis(19))/4 ! xy^2 + signatures(15, n) = aimag(signature_basis(23) + signature_basis(22) - signature_basis(21) & + - signature_basis(24))/4 ! xyz + signatures(16, n) = aimag(2*signature_basis(2) - signature_basis(26) - signature_basis(25))/4 ! xz^2 + signatures(17, n) = aimag(3*signature_basis(3) - signature_basis(27))/4 ! y^3 + signatures(18, n) = aimag(2*signature_basis(4) + signature_basis(29) - signature_basis(28))/4 ! y^2z + signatures(19, n) = aimag(2*signature_basis(3) - signature_basis(31) - signature_basis(30))/4 ! yz^2 + signatures(20, n) = aimag(3*signature_basis(4) - signature_basis(32))/4 ! z^3 + + if (print_output%iprint .ge. 5) then write (stdout, *) ' ' write (stdout, *) ' Wannier function: ', n do ig = 1, 20 write (stdout, *) ig - 1, signatures(ig, n) enddo endif - ! + !Normalise signature of each wannier function to a unit vector - ! + mag_signature_sq = 0.0_dp do ig = 1, 20 mag_signature_sq = mag_signature_sq + abs(signatures(ig, n))**2 enddo signatures(:, n) = signatures(:, n)/sqrt(mag_signature_sq) - ! + enddo ! Wannier Function loop - ! ! Set num_G = 20 to ensure later subroutines work correctly - ! + num_G = 20 deallocate (tran_u_matrix, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating tran_u_matrix in tran_find_signatures') + if (ierr /= 0) call io_error('Error deallocating tran_u_matrix in tran_find_signatures', stdout, seedname) deallocate (g_abc, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating g_abc in tran_find_signatures') + if (ierr /= 0) call io_error('Error deallocating g_abc in tran_find_signatures', stdout, seedname) deallocate (unkg, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating unkg in tran_find_signatures') + if (ierr /= 0) call io_error('Error deallocating unkg in tran_find_signatures', stdout, seedname) - if (timing_level > 1) call io_stopwatch('tran: find_sigs_unkg_int', 2) + if (print_output%timing_level > 1) call io_stopwatch('tran: find_sigs_unkg_int', 2, stdout, seedname) return end subroutine tran_find_integral_signatures - !========================================! - subroutine tran_lcr_2c2_sort(signatures, num_G, pl_warning) - !=======================================================! - ! This is the main subroutine controling the sorting ! - ! for the 2c2 geometry. We first sort in the conduction ! - ! direction, group, sort in 2nd direction, group and ! - ! sort in 3rd direction. Rigourous checks are performed ! - ! to ensure group and subgroup structure is consistent ! - ! between principal layers (PLs), and unit cells. Once ! - ! checks are passed we consider the possibility of ! - ! multiple wannier functions are of similar centre, and ! - ! sort those ! - !=======================================================! + !================================================! + subroutine tran_lcr_2c2_sort(signatures, num_G, pl_warning, transport, atom_data, wannier_data, & + real_space_ham, print_output, real_lattice, num_wann, mp_grid, & + ham_r, irvec, nrpts, wannier_centres_translated, one_dim_vec, & + nrpts_one_dim, num_pl, coord, tran_sorted_idx, hr_one_dim, & + irvec_max, write_xyz, stdout, seedname) + !================================================! + ! This is the main subroutine controling the sorting + ! for the 2c2 geometry. We first sort in the conduction + ! direction, group, sort in 2nd direction, group and + ! sort in 3rd direction. Rigourous checks are performed + ! to ensure group and subgroup structure is consistent + ! between principal layers (PLs), and unit cells. Once + ! checks are passed we consider the possibility of + ! multiple wannier functions are of similar centre, and + ! sort those + !================================================! use w90_constants, only: dp - use w90_io, only: io_error, stdout, io_stopwatch - use w90_parameters, only: one_dim_dir, tran_num_ll, num_wann, tran_num_cell_ll, & - real_lattice, tran_group_threshold, iprint, timing_level, lenconfac, & - wannier_spreads, write_xyz, dist_cutoff - use w90_hamiltonian, only: wannier_centres_translated + use w90_io, only: io_error, io_stopwatch + use w90_types, only: wannier_data_type, atom_data_type, print_output_type + use w90_wannier90_types, only: transport_type, real_space_ham_type implicit none - integer, intent(in) :: num_G - real(dp), intent(in), dimension(:, :) :: signatures - logical, intent(out) :: pl_warning - - real(dp), dimension(2, num_wann) :: centres_non_sorted, centres_initial_sorted - real(dp), dimension(2, tran_num_ll) :: PL1, PL2, PL3, PL4, PL - real(dp), dimension(2, num_wann - (4*tran_num_ll)) :: central_region - real(dp) :: reference_position, & - cell_length, distance, PL_max_val, PL_min_val - -!~ integer :: l,max_i,iterator !aam: unused variables - integer :: i, j, k, PL_selector, & - sort_iterator, sort_iterator2, ierr, temp_coord_2, temp_coord_3, n, & - num_wann_cell_ll, num_wf_group1, num_wf_last_group - integer, allocatable, dimension(:) :: PL_groups, & - PL1_groups, PL2_groups, PL3_groups, PL4_groups, central_region_groups - integer, allocatable, dimension(:, :) :: PL_subgroup_info, & - PL1_subgroup_info, PL2_subgroup_info, PL3_subgroup_info, & - PL4_subgroup_info, central_subgroup_info, temp_subgroup - - character(30) :: fmt_1 + ! arguments + integer, intent(in) :: irvec(:, :) + integer, intent(inout) :: irvec_max ! maybe modified + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_G + integer, intent(in) :: num_wann + integer, intent(inout), allocatable :: tran_sorted_idx(:) + integer, intent(inout) :: coord(3) + integer, intent(inout) :: nrpts + integer, intent(inout) :: nrpts_one_dim + integer, intent(inout) :: num_pl + integer, intent(inout) :: one_dim_vec + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: signatures(:, :) + real(kind=dp), allocatable, intent(inout) :: hr_one_dim(:, :, :) + real(kind=dp), intent(inout) :: wannier_centres_translated(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + + complex(kind=dp), intent(in) :: ham_r(:, :, :) + + type(atom_data_type), intent(in) :: atom_data + type(real_space_ham_type), intent(inout) :: real_space_ham + type(print_output_type), intent(in) :: print_output + type(transport_type), intent(inout) :: transport + type(wannier_data_type), intent(in) :: wannier_data + + character(len=50), intent(in) :: seedname + + logical, intent(in) :: write_xyz + logical, intent(out) :: pl_warning + + ! local variables + real(kind=dp), dimension(2, num_wann) :: centres_non_sorted, centres_initial_sorted + real(kind=dp), dimension(2, transport%num_ll) :: PL1, PL2, PL3, PL4, PL + real(kind=dp), dimension(2, num_wann - (4*transport%num_ll)) :: central_region + real(kind=dp) :: reference_position, cell_length, distance, PL_max_val, PL_min_val + + integer :: i, j, k, PL_selector, sort_iterator, sort_iterator2 + integer :: ierr, temp_coord_2, temp_coord_3, n + integer :: num_wann_cell_ll, num_wf_group1, num_wf_last_group + integer, allocatable :: PL_groups(:), PL1_groups(:), PL2_groups(:), PL3_groups(:), & + PL4_groups(:), central_region_groups(:) + integer, allocatable :: PL_subgroup_info(:, :), PL1_subgroup_info(:, :), & + PL2_subgroup_info(:, :), PL3_subgroup_info(:, :), PL4_subgroup_info(:, :), & + central_subgroup_info(:, :), temp_subgroup(:, :) + + character(30) :: fmt_1 allocate (tran_sorted_idx(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating tran_sorted_idx in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error in allocating tran_sorted_idx in tran_lcr_2c2_sort', stdout, seedname) - num_wann_cell_ll = tran_num_ll/tran_num_cell_ll + num_wann_cell_ll = transport%num_ll/transport%num_cell_ll - if (timing_level > 1) call io_stopwatch('tran: lcr_2c2_sort', 1) + if (print_output%timing_level > 1) call io_stopwatch('tran: lcr_2c2_sort', 1, stdout, seedname) sort_iterator = 0 - ! + !Check translated centres have been found - ! + if (size(wannier_centres_translated) .eq. 0) then - call io_error('Translated centres not known : required perform lcr transport, try restart=plot') + call io_error('Translated centres not known : required perform lcr transport, & + &try restart=plot', stdout, seedname) endif !read one_dim_dir and creates an array (coord) that correspond to the !conduction direction (coord(1)) and the two perpendicular directions !(coord(2),coord(3)), such that a right-handed set is formed - ! - if (one_dim_dir .eq. 1) then + + if (real_space_ham%one_dim_dir .eq. 1) then coord(1) = 1 coord(2) = 2 coord(3) = 3 - elseif (one_dim_dir .eq. 2) then + elseif (real_space_ham%one_dim_dir .eq. 2) then coord(1) = 2 coord(2) = 3 coord(3) = 1 - elseif (one_dim_dir .eq. 3) then + elseif (real_space_ham%one_dim_dir .eq. 3) then coord(1) = 3 coord(2) = 1 coord(3) = 2 endif - ! + !Check - ! + if (((real_lattice(coord(1), coord(2)) .ne. 0) .or. (real_lattice(coord(1), coord(3)) .ne. 0)) .or. & ((real_lattice(coord(2), coord(1)) .ne. 0) .or. (real_lattice(coord(3), coord(1)) .ne. 0))) then call io_error( & 'Lattice vector in conduction direction must point along x,y or z & - & direction and be orthogonal to the remaining lattice vectors.') + & direction and be orthogonal to the remaining lattice vectors.', stdout, seedname) endif - ! + !Check - ! - if (num_wann .le. 4*tran_num_ll) then - call io_error('Principle layers are too big.') + + if (num_wann .le. 4*transport%num_ll) then + call io_error('Principle layers are too big.', stdout, seedname) endif 100 continue - ! + !Extract a 2d array of the wannier_indices and their coord(1) from wannier_centers_translated - ! + do i = 1, num_wann centres_non_sorted(1, i) = i centres_non_sorted(2, i) = wannier_centres_translated(coord(1), i) enddo write (stdout, '(/a)') ' Sorting WFs into principal layers' - ! + !Initial sorting according to coord(1). - ! + call sort(centres_non_sorted, centres_initial_sorted) - ! + !Extract principal layers. WARNING: This extraction implies the structure of the supercell is !2 principal layers of lead on the left and on the right of a central conductor. - ! - PL1 = centres_initial_sorted(:, 1:tran_num_ll) - PL2 = centres_initial_sorted(:, tran_num_ll + 1:2*tran_num_ll) - PL3 = centres_initial_sorted(:, num_wann - (2*tran_num_ll - 1):num_wann - (tran_num_ll)) - PL4 = centres_initial_sorted(:, num_wann - (tran_num_ll - 1):) - ! + + PL1 = centres_initial_sorted(:, 1:transport%num_ll) + PL2 = centres_initial_sorted(:, transport%num_ll + 1:2*transport%num_ll) + PL3 = centres_initial_sorted(:, num_wann - (2*transport%num_ll - 1):num_wann - (transport%num_ll)) + PL4 = centres_initial_sorted(:, num_wann - (transport%num_ll - 1):) + if (sort_iterator .eq. 1) then temp_coord_2 = coord(2) temp_coord_3 = coord(3) coord(2) = temp_coord_3 coord(3) = temp_coord_2 endif - ! - if (iprint .ge. 4) then + + if (print_output%iprint .ge. 4) then write (stdout, *) ' Group Breakdown of each principal layer' endif - ! + !Loop over principal layers - ! + do i = 1, 4 - ! + !Creating a variable PL_selector which choose the appropriate PL - ! + PL_selector = i select case (PL_selector) case (1) @@ -1840,96 +2122,98 @@ subroutine tran_lcr_2c2_sort(signatures, num_G, pl_warning) case (4) PL = PL4 endselect - ! + !Grouping wannier functions with similar coord(1) - ! - call group(PL, PL_groups) - if (iprint .ge. 4) then - ! + call group(PL, PL_groups, transport%group_threshold, stdout, seedname) + + if (print_output%iprint .ge. 4) then + !Print group breakdown - ! + write (fmt_1, '(i5)') size(PL_groups) fmt_1 = adjustl(fmt_1) fmt_1 = '(a3,i1,a1,i5,a2,'//trim(fmt_1)//'i4,a1)' - write (stdout, fmt_1) ' PL', i, ' ', size(PL_groups), ' (', (PL_groups(j), j=1, size(PL_groups)), ')' + write (stdout, fmt_1) ' PL', i, ' ', size(PL_groups), ' (', (PL_groups(j), j=1, & + size(PL_groups)), ')' endif - ! + !Returns the sorted PL and informations on this PL - ! + allocate (PL_subgroup_info(size(PL_groups), maxval(PL_groups)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating PL_subgroup_info in tran_lcr_2c2_sort') - call master_sort_and_group(PL, PL_groups, tran_num_ll, PL_subgroup_info) + if (ierr /= 0) call io_error('Error in allocating PL_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) + call master_sort_and_group(PL, PL_groups, transport%num_ll, PL_subgroup_info, & + transport%group_threshold, print_output, wannier_centres_translated, & + coord, stdout, seedname) select case (PL_selector) case (1) allocate (PL1_groups(size(PL_groups)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating PL1_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error in allocating PL1_groups in tran_lcr_2c2_sort', stdout, seedname) allocate (PL1_subgroup_info(size(PL_groups), maxval(PL_groups)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating PL1_subgroup_info in tran_lcr_2c2_sort') - ! + if (ierr /= 0) call io_error('Error in allocating PL1_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) + PL1 = PL PL1_groups = PL_groups PL1_subgroup_info = PL_subgroup_info - ! + deallocate (PL_subgroup_info, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL1_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL1_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) case (2) allocate (PL2_groups(size(PL_groups)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating PL2_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error in allocating PL2_groups in tran_lcr_2c2_sort', stdout, seedname) allocate (PL2_subgroup_info(size(PL_groups), maxval(PL_groups)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating PL2_subgroup_info in tran_lcr_2c2_sort') - ! + if (ierr /= 0) call io_error('Error in allocating PL2_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) + PL2 = PL PL2_groups = PL_groups PL2_subgroup_info = PL_subgroup_info - ! + deallocate (PL_subgroup_info, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL2_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL2_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) case (3) allocate (PL3_groups(size(PL_groups)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating PL3_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error in allocating PL3_groups in tran_lcr_2c2_sort', stdout, seedname) allocate (PL3_subgroup_info(size(PL_groups), maxval(PL_groups)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating PL3_subgroup_info in tran_lcr_2c2_sort') - ! + if (ierr /= 0) call io_error('Error in allocating PL3_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) + PL3 = PL PL3_groups = PL_groups PL3_subgroup_info = PL_subgroup_info - ! + deallocate (PL_subgroup_info, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL3_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL3_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) case (4) allocate (PL4_groups(size(PL_groups)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating PL4_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error in allocating PL4_groups in tran_lcr_2c2_sort', stdout, seedname) allocate (PL4_subgroup_info(size(PL_groups), maxval(PL_groups)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating PL4_subgroup_info in tran_lcr_2c2_sort') - ! + if (ierr /= 0) call io_error('Error in allocating PL4_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) + PL4 = PL PL4_groups = PL_groups PL4_subgroup_info = PL_subgroup_info - ! + deallocate (PL_subgroup_info, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL4_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL4_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) endselect deallocate (PL_groups, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL_groups in tran_lcr_2c2_sort', stdout, seedname) enddo ! Principal layer loop - ! !Grouping and sorting of central conductor region - ! + !Define central region - ! - central_region = centres_initial_sorted(:, 2*tran_num_ll + 1:num_wann - (2*tran_num_ll)) - ! + + central_region = centres_initial_sorted(:, 2*transport%num_ll + 1:num_wann - (2*transport%num_ll)) + !Group central region - ! - call group(central_region, central_region_groups) - ! + + call group(central_region, central_region_groups, transport%group_threshold, stdout, seedname) + !Print central region group breakdown - ! - if (iprint .ge. 4) then + + if (print_output%iprint .ge. 4) then write (stdout, *) ' Group Breakdown of central region' write (fmt_1, '(i5)') size(central_region_groups) fmt_1 = adjustl(fmt_1) @@ -1937,100 +2221,104 @@ subroutine tran_lcr_2c2_sort(signatures, num_G, pl_warning) write (stdout, fmt_1) ' ', size(central_region_groups), ' (', & (central_region_groups(j), j=1, size(central_region_groups)), ')' endif - ! + !Returns sorted central group region - ! + allocate (central_subgroup_info(size(central_region_groups), maxval(central_region_groups)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating central_group_info in tran_lcr_2c2_sort') - call master_sort_and_group(central_region, central_region_groups, num_wann - (4*tran_num_ll), central_subgroup_info) + if (ierr /= 0) call io_error('Error in allocating central_group_info in tran_lcr_2c2_sort', stdout, seedname) + call master_sort_and_group(central_region, central_region_groups, num_wann - (4*transport%num_ll), & + central_subgroup_info, transport%group_threshold, print_output, & + wannier_centres_translated, coord, stdout, seedname) deallocate (central_subgroup_info, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating central_group_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating central_group_info in tran_lcr_2c2_sort', stdout, seedname) write (stdout, *) ' ' - ! + !Build the sorted index array - ! + tran_sorted_idx = nint(centres_initial_sorted(1, :)) - tran_sorted_idx(1:tran_num_ll) = nint(PL1(1, :)) - tran_sorted_idx(tran_num_ll + 1:2*tran_num_ll) = nint(PL2(1, :)) - tran_sorted_idx(2*tran_num_ll + 1:num_wann - (2*tran_num_ll)) = nint(central_region(1, :)) - tran_sorted_idx(num_wann - (2*tran_num_ll - 1):num_wann - (tran_num_ll)) = nint(PL3(1, :)) - tran_sorted_idx(num_wann - (tran_num_ll - 1):) = nint(PL4(1, :)) + tran_sorted_idx(1:transport%num_ll) = nint(PL1(1, :)) + tran_sorted_idx(transport%num_ll + 1:2*transport%num_ll) = nint(PL2(1, :)) + tran_sorted_idx(2*transport%num_ll + 1:num_wann - (2*transport%num_ll)) = nint(central_region(1, :)) + tran_sorted_idx(num_wann - (2*transport%num_ll - 1):num_wann - (transport%num_ll)) = nint(PL3(1, :)) + tran_sorted_idx(num_wann - (transport%num_ll - 1):) = nint(PL4(1, :)) sort_iterator = sort_iterator + 1 - ! + !Checks: - ! + if ((size(PL1_groups) .ne. size(PL2_groups)) .or. & (size(PL2_groups) .ne. size(PL3_groups)) .or. & (size(PL3_groups) .ne. size(PL4_groups))) then if (sort_iterator .ge. 2) then - if (write_xyz) call tran_write_xyz() + if (write_xyz) call tran_write_xyz(atom_data, transport, wannier_centres_translated, & + tran_sorted_idx, num_wann, seedname, stdout) call io_error('Sorting techniques exhausted:& - & Inconsistent number of groups among principal layers') + & Inconsistent number of groups among principal layers', stdout, seedname) endif write (stdout, *) 'Inconsistent number of groups among principal layers: restarting sorting...' deallocate (PL1_groups, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL1_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL1_groups in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL2_groups, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL2_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL2_groups in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL3_groups, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL3_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL3_groups in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL4_groups, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL4_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL4_groups in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL1_subgroup_info) - if (ierr /= 0) call io_error('Error deallocating PL1_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL1_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL2_subgroup_info, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL2_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL2_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL3_subgroup_info, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL3_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL3_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL4_subgroup_info, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL4_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL4_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) goto 100 endif - ! + do i = 1, size(PL1_groups) if ((PL1_groups(i) .ne. PL2_groups(i)) .or. & (PL2_groups(i) .ne. PL3_groups(i)) .or. & (PL3_groups(i) .ne. PL4_groups(i))) then if (sort_iterator .ge. 2) then - if (write_xyz) call tran_write_xyz() + if (write_xyz) call tran_write_xyz(atom_data, transport, wannier_centres_translated, & + tran_sorted_idx, num_wann, seedname, stdout) call io_error & ('Sorting techniques exhausted: Inconsitent number of wannier function among & - & similar groups within principal layers') + & similar groups within principal layers', stdout, seedname) endif write (stdout, *) 'Inconsitent number of wannier function among & &similar groups within& principal layers: restarting sorting...' deallocate (PL1_groups, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL1_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL1_groups in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL2_groups, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL2_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL2_groups in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL3_groups, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL3_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL3_groups in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL4_groups, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL4_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL4_groups in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL1_subgroup_info) - if (ierr /= 0) call io_error('Error deallocating PL1_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL1_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL2_subgroup_info, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL2_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL2_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL3_subgroup_info, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL3_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL3_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL4_subgroup_info, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL4_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL4_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) goto 100 endif enddo - ! + !Now we check that the leftmost group and the rightmost group aren't !supposed to be the same group - ! + reference_position = wannier_centres_translated(coord(1), tran_sorted_idx(1)) cell_length = real_lattice(coord(1), coord(1)) sort_iterator2 = 1 - do i = 1, tran_num_ll + do i = 1, transport%num_ll distance = abs(abs(reference_position - wannier_centres_translated(coord(1), tran_sorted_idx(num_wann - i + 1))) & - cell_length) - if (distance .lt. tran_group_threshold) then + if (distance .lt. transport%group_threshold) then wannier_centres_translated(coord(1), tran_sorted_idx(num_wann - i + 1)) = & wannier_centres_translated(coord(1), tran_sorted_idx(num_wann - i + 1)) - cell_length sort_iterator2 = sort_iterator2 + 1 @@ -2044,37 +2332,41 @@ subroutine tran_lcr_2c2_sort(signatures, num_G, pl_warning) write (stdout, *) ' Rebuilding Hamiltonian...' write (stdout, *) ' ' deallocate (hr_one_dim, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating hr_one_dim in tran_lcr_2c2_sort') - call tran_reduce_hr() - call tran_cut_hr_one_dim() + if (ierr /= 0) call io_error('Error deallocating hr_one_dim in tran_lcr_2c2_sort', stdout, seedname) + call tran_reduce_hr(real_space_ham, ham_r, hr_one_dim, real_lattice, irvec, mp_grid, irvec_max, & + nrpts, nrpts_one_dim, num_wann, one_dim_vec, print_output%timing_level, & + seedname, stdout) + call tran_cut_hr_one_dim(real_space_ham, transport, print_output, hr_one_dim, real_lattice, & + wannier_centres_translated, mp_grid, irvec_max, num_pl, num_wann, & + one_dim_vec, seedname, stdout) write (stdout, *) ' ' write (stdout, *) ' Restarting sorting...' write (stdout, *) ' ' sort_iterator = sort_iterator - 1 deallocate (PL1_groups, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL1_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL1_groups in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL2_groups, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL2_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL2_groups in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL3_groups, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL3_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL3_groups in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL4_groups, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL4_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL4_groups in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL1_subgroup_info) - if (ierr /= 0) call io_error('Error deallocating PL1_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL1_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL2_subgroup_info, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL2_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL2_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL3_subgroup_info, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL3_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL3_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL4_subgroup_info, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL4_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL4_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) goto 100 endif - ! + ! if we reach this point, we don't have any left/right problems anymore. So we now ! check for inconsistencies in subgroups - ! + allocate (temp_subgroup(size(PL1_subgroup_info, 1), size(PL1_subgroup_info, 2)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating tmp_subgroup in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error in allocating tmp_subgroup in tran_lcr_2c2_sort', stdout, seedname) do i = 2, 4 select case (i) case (2) @@ -2088,39 +2380,44 @@ subroutine tran_lcr_2c2_sort(signatures, num_G, pl_warning) do k = 1, size(temp_subgroup, 2) if (temp_subgroup(j, k) .ne. 0) then if (sort_iterator .ge. 2) then - if (write_xyz) call tran_write_xyz() + if (write_xyz) call tran_write_xyz(atom_data, transport, & + wannier_centres_translated, & + tran_sorted_idx, num_wann, seedname, & + stdout) call io_error & - ('Sorting techniques exhausted: Inconsitent subgroup structures among principal layers') + ('Sorting techniques exhausted: Inconsitent subgroup structures among principal layers', stdout, seedname) endif write (stdout, *) 'Inconsitent subgroup structure among principal layers: restarting sorting...' deallocate (temp_subgroup, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating tmp_subgroup in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating tmp_subgroup in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL1_groups, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL1_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL1_groups in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL2_groups, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL2_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL2_groups in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL3_groups, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL3_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL3_groups in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL4_groups, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL4_groups in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL4_groups in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL1_subgroup_info) - if (ierr /= 0) call io_error('Error deallocating PL1_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL1_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL2_subgroup_info, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL2_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL2_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL3_subgroup_info, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL3_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL3_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) deallocate (PL4_subgroup_info, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating PL4_subgroup_info in tran_lcr_2c2_sort') + if (ierr /= 0) call io_error('Error deallocating PL4_subgroup_info in tran_lcr_2c2_sort', stdout, seedname) goto 100 endif enddo enddo enddo - ! + ! At this point, every check has been cleared, and we need to use ! the parity signatures of the WFs for the possibility of equal centres - ! - call check_and_sort_similar_centres(signatures, num_G) + + call check_and_sort_similar_centres(signatures, num_G, atom_data, transport, print_output, & + num_wann, wannier_centres_translated, coord, & + tran_sorted_idx, write_xyz, stdout, seedname) write (stdout, *) ' ' write (stdout, *) '------------------------- Sorted Wannier Centres -----------------------------' @@ -2131,27 +2428,27 @@ subroutine tran_lcr_2c2_sort(signatures, num_G, pl_warning) if (k .eq. 2) write (stdout, *) '==================================PL2=========================================' if (k .eq. 3) then write (stdout, *) '===========================Central Region===================================' - do i = 1, num_wann - 4*tran_num_ll + do i = 1, num_wann - 4*transport%num_ll n = n + 1 write (stdout, FMT='(2x,i6,10x,i6,6x,4F12.6)') n, tran_sorted_idx(n), & wannier_centres_translated(1, tran_sorted_idx(n)), & wannier_centres_translated(2, tran_sorted_idx(n)), & wannier_centres_translated(3, tran_sorted_idx(n)), & - wannier_spreads(tran_sorted_idx(n))*lenconfac**2 + wannier_data%spreads(tran_sorted_idx(n))*print_output%lenconfac**2 enddo write (stdout, *) '==================================PL3=========================================' endif if (k .eq. 4) write (stdout, *) '==================================PL4=========================================' - do i = 1, tran_num_cell_ll + do i = 1, transport%num_cell_ll do j = 1, num_wann_cell_ll n = n + 1 write (stdout, FMT='(2x,i6,10x,i6,6x,4F12.6)') n, tran_sorted_idx(n), & wannier_centres_translated(1, tran_sorted_idx(n)), & wannier_centres_translated(2, tran_sorted_idx(n)), & wannier_centres_translated(3, tran_sorted_idx(n)), & - wannier_spreads(tran_sorted_idx(n))*lenconfac**2 + wannier_data%spreads(tran_sorted_idx(n))*print_output%lenconfac**2 enddo - if (i .ne. tran_num_cell_ll) write (stdout, *) '---------------------& + if (i .ne. transport%num_cell_ll) write (stdout, *) '---------------------& &---------------------------------------------------------' enddo @@ -2160,215 +2457,223 @@ subroutine tran_lcr_2c2_sort(signatures, num_G, pl_warning) write (stdout, *) '==============================================================================' write (stdout, *) ' ' - ! ! MS: Use sorting to assess whether dist_cutoff is suitable for correct PL cut ! by using limits of coord(1) values in 1st and last groups of PL1, & 1st group of PL2 - ! + pl_warning = .false. num_wf_group1 = size(PL1_subgroup_info(1, :)) if (size(PL1_groups) .ge. 1) then num_wf_last_group = size(PL1_subgroup_info(size(PL1_groups), :)) else - ! + !Exception for 1 group in unit cell. - ! num_wf_last_group = num_wann_cell_ll endif - PL_min_val = maxval(wannier_centres_translated(coord(1), tran_sorted_idx(tran_num_ll - num_wf_last_group + 1:tran_num_ll))) & + PL_min_val = maxval(wannier_centres_translated(coord(1), tran_sorted_idx(transport%num_ll & + - num_wf_last_group + 1:transport%num_ll))) & - minval(wannier_centres_translated(coord(1), tran_sorted_idx(1:num_wf_group1))) - PL_max_val = minval(wannier_centres_translated(coord(1), tran_sorted_idx(tran_num_ll + 1:tran_num_ll + num_wf_group1))) & + PL_max_val = minval(wannier_centres_translated(coord(1), tran_sorted_idx(transport%num_ll + & + 1:transport%num_ll + num_wf_group1))) & - minval(wannier_centres_translated(coord(1), tran_sorted_idx(1:num_wf_group1))) - if ((dist_cutoff .lt. PL_min_val) .or. (dist_cutoff .gt. PL_max_val)) then + if ((real_space_ham%dist_cutoff .lt. PL_min_val) .or. (real_space_ham%dist_cutoff .gt. PL_max_val)) then write (stdout, '(a)') ' WARNING: Expected dist_cutoff to be a PL length, I think this' write (stdout, '(2(a,f10.6),a)') ' WARNING: is somewhere between ', PL_min_val, ' and ', PL_max_val, ' Ang' pl_warning = .true. endif - ! ! End MS. - ! - if (timing_level > 1) call io_stopwatch('tran: lcr_2c2_sort', 2) + + if (print_output%timing_level > 1) call io_stopwatch('tran: lcr_2c2_sort', 2, stdout, seedname) return end subroutine tran_lcr_2c2_sort - !========================================! - subroutine master_sort_and_group(Array, Array_groups, Array_size, subgroup_info) - !=============================================================! - ! General sorting and grouping subroutine which takes Array, ! - ! an ordered in conduction direction array of wannier function! - ! indexes and positions, and returns the ordered (and grouped)! - ! indexes and positions after considering the other two ! - ! directions. Sub group info is also return for later checks. ! - !=============================================================! + !================================================! + subroutine master_sort_and_group(Array, Array_groups, Array_size, subgroup_info, & + tran_group_threshold, print_output, wannier_centres_translated, & + coord, stdout, seedname) + !================================================! + ! General sorting and grouping subroutine which takes Array, + ! an ordered in conduction direction array of wannier function + ! indexes and positions, and returns the ordered (and grouped) + ! indexes and positions after considering the other two + ! directions. Sub group info is also return for later checks. + !================================================! use w90_constants, only: dp - use w90_io, only: io_error, stdout, io_stopwatch - use w90_parameters, only: iprint, timing_level - use w90_hamiltonian, only: wannier_centres_translated + use w90_io, only: io_error, io_stopwatch + use w90_types, only: print_output_type implicit none + type(print_output_type), intent(in) :: print_output + + real(kind=dp), intent(in) :: wannier_centres_translated(:, :) + integer, intent(in) :: coord(3) + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: tran_group_threshold + integer, intent(in), dimension(:) :: Array_groups integer, intent(in) :: Array_size integer, intent(out), allocatable, dimension(:, :) :: subgroup_info - real(dp), intent(inout), dimension(2, Array_size) :: Array + real(kind=dp), intent(inout), dimension(2, Array_size) :: Array + character(len=50), intent(in) :: seedname integer :: i, j, k, Array_num_groups, increment, ierr, & subgroup_increment, group_num_subgroups integer, allocatable, dimension(:) :: group_subgroups - real(dp), allocatable, dimension(:, :) :: group_array, sorted_group_array, & - subgroup_array, sorted_subgroup_array + real(kind=dp), allocatable, dimension(:, :) :: group_array, sorted_group_array, & + subgroup_array, sorted_subgroup_array character(30) :: fmt_2 - if (timing_level > 2) call io_stopwatch('tran: lcr_2c2_sort: master_sort', 1) + if (print_output%timing_level > 2) call io_stopwatch('tran: lcr_2c2_sort: master_sort', 1, stdout, seedname) allocate (subgroup_info(size(Array_groups), maxval(Array_groups)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating subgroup_info in master_sort_and_group') + if (ierr /= 0) call io_error('Error in allocating subgroup_info in master_sort_and_group', stdout, seedname) subgroup_info = 0 - ! + !Number of groups inside the principal layer - ! + Array_num_groups = size(Array_groups) - ! !Convenient variable which will be amended later. Used to appropriately extract the group array from the Array - ! + increment = 1 - ! + !Loop over groups inside Array - ! + do j = 1, Array_num_groups allocate (group_array(2, Array_groups(j)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating group_array in master_sort_and_group') + if (ierr /= 0) call io_error('Error in allocating group_array in master_sort_and_group', stdout, seedname) allocate (sorted_group_array(2, Array_groups(j)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating sorted_group_array in master_sort_and_group') - ! + if (ierr /= 0) call io_error('Error in allocating sorted_group_array in master_sort_and_group', stdout, seedname) + !Extract the group from the Array - ! + group_array = Array(:, increment:increment + Array_groups(j) - 1) - ! + !Updating group_array to contain coord(2) - ! + do k = 1, Array_groups(j) group_array(2, k) = wannier_centres_translated(coord(2), int(group_array(1, k))) enddo call sort(group_array, sorted_group_array) - call group(sorted_group_array, group_subgroups) + call group(sorted_group_array, group_subgroups, tran_group_threshold, stdout, seedname) group_num_subgroups = size(group_subgroups) - if (iprint .ge. 4) then - ! + if (print_output%iprint .ge. 4) then + !Printing subgroup breakdown - ! + write (fmt_2, '(i5)') group_num_subgroups fmt_2 = adjustl(fmt_2) fmt_2 = '(a7,i3,a1,i5,a2,'//trim(fmt_2)//'i4,a1)' write (stdout, fmt_2) ' Group ', j, ' ', group_num_subgroups, ' (', (group_subgroups(i), i=1, group_num_subgroups), ')' endif - ! + ! filling up subgroup_info - ! + do k = 1, group_num_subgroups subgroup_info(j, k) = group_subgroups(k) enddo - ! + !Convenient variable which will be amended later. Used to appropriately extract the subgroup array from the group_array - ! + subgroup_increment = 1 - ! + !Loop over subgroups inside group - ! + do k = 1, group_num_subgroups allocate (subgroup_array(2, group_subgroups(k)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating subgroup_array in master_sort_and_group') + if (ierr /= 0) call io_error('Error in allocating subgroup_array in master_sort_and_group', stdout, seedname) allocate (sorted_subgroup_array(2, group_subgroups(k)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating sorted_subgroup_array in master_sort_and_group') - ! + if (ierr /= 0) call io_error('Error in allocating sorted_subgroup_array in master_sort_and_group', stdout, seedname) + !Extract the subgroup from the group - ! + subgroup_array = sorted_group_array(:, subgroup_increment:subgroup_increment + group_subgroups(k) - 1) - ! + !Updating subgroup_array to contain coord(3) - ! + do i = 1, group_subgroups(k) subgroup_array(2, i) = wannier_centres_translated(coord(3), int(subgroup_array(1, i))) enddo call sort(subgroup_array, sorted_subgroup_array) - ! + !Update sorted_group array with the sorted subgroup array - ! + sorted_group_array(:, subgroup_increment:subgroup_increment + group_subgroups(k) - 1) = sorted_subgroup_array - ! + !Update the subgroup_increment - ! + subgroup_increment = subgroup_increment + group_subgroups(k) deallocate (sorted_subgroup_array, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating sorted_subgroup_array in master_sort_and_group') + if (ierr /= 0) call io_error('Error deallocating sorted_subgroup_array in master_sort_and_group', stdout, seedname) deallocate (subgroup_array, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating subgroup_array in master_sort_and_group') + if (ierr /= 0) call io_error('Error deallocating subgroup_array in master_sort_and_group', stdout, seedname) enddo - ! + !Update Array with the sorted group array - ! + Array(:, increment:increment + Array_groups(j) - 1) = sorted_group_array - ! + !Update the group increment - ! + increment = increment + Array_groups(j) deallocate (group_array, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating group_array in master_sort_and_group') + if (ierr /= 0) call io_error('Error deallocating group_array in master_sort_and_group', stdout, seedname) deallocate (sorted_group_array, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating sorted_group_array in master_sort_and_group') + if (ierr /= 0) call io_error('Error deallocating sorted_group_array in master_sort_and_group', stdout, seedname) deallocate (group_subgroups, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating group_subgroups in master_sort_and_group') + if (ierr /= 0) call io_error('Error deallocating group_subgroups in master_sort_and_group', stdout, seedname) enddo - if (timing_level > 2) call io_stopwatch('tran: lcr_2c2_sort: master_sort', 2) + if (print_output%timing_level > 2) call io_stopwatch('tran: lcr_2c2_sort: master_sort', 2, stdout, seedname) return end subroutine master_sort_and_group - !========================================! + !================================================! subroutine sort(non_sorted, sorted) - !========================================! + !================================================! use w90_constants, only: dp implicit none - real(dp), intent(inout), dimension(:, :) :: non_sorted - real(dp), intent(out), dimension(:, :) :: sorted + real(kind=dp), intent(inout) :: non_sorted(:, :) + real(kind=dp), intent(out) :: sorted(:, :) - integer, dimension(1) :: min_loc - integer :: num_col, i + integer, dimension(1) :: min_loc + integer :: num_col, i num_col = size(non_sorted, 2) do i = 1, num_col - ! + !look for the location of the minimum value of the coordinates in non_sorted - ! + min_loc = minloc(non_sorted(2, :)) - ! + !now the index in the first row of sorted is the index non_sorted(1,min_loc) - ! + sorted(1, i) = non_sorted(1, min_loc(1)) - ! + !here is the corresponding coordinate - ! + sorted(2, i) = non_sorted(2, min_loc(1)) - ! + !here one replaces the minimum coordinate with 10**10 such that this value !will not be picked-up again by minloc - ! + non_sorted(2, min_loc(1)) = 10.0**10 enddo @@ -2376,19 +2681,21 @@ subroutine sort(non_sorted, sorted) endsubroutine sort - !========================================! - subroutine group(array, array_groups) - !========================================! + !================================================! + subroutine group(array, array_groups, tran_group_threshold, stdout, seedname) + !================================================! use w90_constants, only: dp use w90_io, only: io_error - use w90_parameters, only: tran_group_threshold - implicit none - real(dp), intent(in), dimension(:, :) :: array + real(kind=dp), intent(in) :: tran_group_threshold + integer, intent(in) :: stdout + + real(kind=dp), intent(in), dimension(:, :) :: array integer, intent(out), allocatable, dimension(:) :: array_groups + character(len=50), intent(in) :: seedname integer, allocatable, dimension(:) :: dummy_array logical, allocatable, dimension(:) :: logic @@ -2397,44 +2704,44 @@ subroutine group(array, array_groups) array_size = size(array, 2) allocate (dummy_array(array_size), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating dummy_array in group') + if (ierr /= 0) call io_error('Error in allocating dummy_array in group', stdout, seedname) allocate (logic(array_size), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating logic in group') - ! + if (ierr /= 0) call io_error('Error in allocating logic in group', stdout, seedname) + !Initialise dummy array - ! + dummy_array = 0 - ! + !Initialise logic to false - ! + logic = .false. - ! + !Define counter of number of groups - ! + array_idx = 1 - ! + !Loop over columns of array (ie array_size) - ! + do i = 1, array_size - ! + !If an element of logic is true then it means the wannier function has already been grouped - ! + if (logic(i) .eqv. .false.) then - ! + !Create a group for the wannier function - ! + logic(i) = .true. - ! + !Initialise the number of wannier functions in this group to be 1 - ! + group_number = 1 - ! + !Loop over the rest of wannier functions in array - ! + do j = min(i + 1, array_size), array_size - ! + !Special termination cases - ! + if ((j .eq. 1) .or. (i .eq. array_size)) then dummy_array(array_idx) = group_number exit @@ -2445,147 +2752,159 @@ subroutine group(array, array_groups) logic(j) = .true. exit endif - ! + !Check distance between wannier function_i and wannier function_j - ! + if (abs(array(2, j) - array(2, i)) .le. tran_group_threshold) then - ! + !Increment number of wannier functions in group - ! + group_number = group_number + 1 - ! + !Assigns wannier function to the group - ! + logic(j) = .true. else - ! + !Group is finished and store number of wanniers in the group to dummy_array - ! + dummy_array(array_idx) = group_number - ! + !Increment number of groups - ! + array_idx = array_idx + 1 exit endif enddo endif enddo - ! + !Copy elements of dummy_array to array_groups - ! + allocate (array_groups(array_idx), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating array_groups in group') + if (ierr /= 0) call io_error('Error in allocating array_groups in group', stdout, seedname) array_groups = dummy_array(:array_idx) deallocate (dummy_array, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating dummy_array in group') + if (ierr /= 0) call io_error('Error deallocating dummy_array in group', stdout, seedname) deallocate (logic, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating logic in group') + if (ierr /= 0) call io_error('Error deallocating logic in group', stdout, seedname) return end subroutine group - !========================================================= - subroutine check_and_sort_similar_centres(signatures, num_G) - !=======================================================! - ! Here, we consider the possiblity of wannier functions ! - ! with similar centres, such as a set of d-orbitals ! - ! centred on an atom. We use tran_group_threshold to ! - ! identify them, if they exist, then use the signatures ! - ! to dishinguish and sort then consistently from unit ! - ! cell to unit cell. ! - ! ! - ! MS: For 2two-shot and beyond, some parameters, ! - ! eg, first_group_element will need changing to consider! - ! the geometry of the new systems. ! - !=======================================================! + !================================================ + subroutine check_and_sort_similar_centres(signatures, num_G, atom_data, transport, print_output, & + num_wann, wannier_centres_translated, & + coord, tran_sorted_idx, write_xyz, stdout, seedname) + !================================================! + ! Here, we consider the possiblity of wannier functions + ! with similar centres, such as a set of d-orbitals + ! centred on an atom. We use tran_group_threshold to + ! identify them, if they exist, then use the signatures + ! to dishinguish and sort then consistently from unit + ! cell to unit cell. + ! + ! MS: For 2two-shot and beyond, some parameters, + ! eg, first_group_element will need changing to consider + ! the geometry of the new systems. + !================================================! use w90_constants, only: dp - use w90_io, only: stdout, io_stopwatch, io_error - use w90_parameters, only: tran_num_ll, num_wann, tran_num_cell_ll, iprint, timing_level, & - tran_group_threshold, write_xyz - use w90_hamiltonian, only: wannier_centres_translated + use w90_io, only: io_stopwatch, io_error + use w90_types, only: atom_data_type, print_output_type + use w90_wannier90_types, only: transport_type implicit none - integer, intent(in) :: num_G - real(dp), intent(in), dimension(:, :) :: signatures - - integer :: i, j, k, l, ierr, group_iterator, coord_iterator, num_wf_iterator, & - num_wann_cell_ll, iterator, max_position(1), p, num_wf_cell_iter - - integer, allocatable, dimension(:) :: idx_similar_wf, group_verifier, sorted_idx, centre_id - real(dp), allocatable, dimension(:) :: dot_p - integer, allocatable, dimension(:, :) :: tmp_wf_verifier, wf_verifier, first_group_element, & - ref_similar_centres, unsorted_similar_centres - integer, allocatable, dimension(:, :, :) :: wf_similar_centres - - logical, allocatable, dimension(:) :: has_similar_centres - - if (timing_level > 2) call io_stopwatch('tran: lcr_2c2_sort: similar_centres', 1) - - num_wann_cell_ll = tran_num_ll/tran_num_cell_ll - - allocate (wf_similar_centres(tran_num_cell_ll*4, num_wann_cell_ll, num_wann_cell_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating wf_similar_centre in check_and_sort_similar_centres') + ! arguments + type(atom_data_type), intent(in) :: atom_data + type(print_output_type), intent(in) :: print_output + type(transport_type), intent(inout) :: transport + integer, intent(in) :: coord(3) + integer, intent(in) :: num_G + integer, intent(in) :: num_wann + integer, intent(inout) :: tran_sorted_idx(:) + integer, intent(in) :: stdout + real(kind=dp), intent(in) :: wannier_centres_translated(:, :) + real(kind=dp), intent(in) :: signatures(:, :) + character(len=50), intent(in) :: seedname + logical, intent(in) :: write_xyz + + ! local variables + integer, allocatable :: idx_similar_wf(:), group_verifier(:), sorted_idx(:), centre_id(:) + integer, allocatable :: tmp_wf_verifier(:, :), wf_verifier(:, :), first_group_element(:, :) + integer, allocatable :: ref_similar_centres(:, :), unsorted_similar_centres(:, :) + integer, allocatable :: wf_similar_centres(:, :, :) + logical, allocatable :: has_similar_centres(:) + integer :: i, j, k, l, ierr, group_iterator, coord_iterator, num_wf_iterator, num_wann_cell_ll + integer :: iterator, max_position(1), p, num_wf_cell_iter + real(kind=dp), allocatable :: dot_p(:) + + if (print_output%timing_level > 2) call io_stopwatch('tran: lcr_2c2_sort: similar_centres', 1, stdout, seedname) + + num_wann_cell_ll = transport%num_ll/transport%num_cell_ll + + allocate (wf_similar_centres(transport%num_cell_ll*4, num_wann_cell_ll, num_wann_cell_ll), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating wf_similar_centre in check_and_sort_similar_centres', stdout, seedname) allocate (idx_similar_wf(num_wann_cell_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating idx_similar_wf in check_and_sort_similar_centres') + if (ierr /= 0) call io_error('Error in allocating idx_similar_wf in check_and_sort_similar_centres', stdout, seedname) allocate (has_similar_centres(num_wann_cell_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating has_similar_centres in check_and_sort_similar_centres') - allocate (tmp_wf_verifier(4*tran_num_cell_ll, num_wann_cell_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating tmp_wf_verifier in check_and_sort_similar_centres') - allocate (group_verifier(4*tran_num_cell_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating group_verifier in check_and_sort_similar_centres') - allocate (first_group_element(4*tran_num_cell_ll, num_wann_cell_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating first_group_element in check_and_sort_similar_centres') + if (ierr /= 0) call io_error('Error in allocating has_similar_centres in check_and_sort_similar_centres', stdout, seedname) + allocate (tmp_wf_verifier(4*transport%num_cell_ll, num_wann_cell_ll), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating tmp_wf_verifier in check_and_sort_similar_centres', stdout, seedname) + allocate (group_verifier(4*transport%num_cell_ll), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating group_verifier in check_and_sort_similar_centres', stdout, seedname) + allocate (first_group_element(4*transport%num_cell_ll, num_wann_cell_ll), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating first_group_element in check_and_sort_similar_centres', stdout, seedname) allocate (centre_id(num_wann_cell_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating centre_id in check_and_sort_similar_centres') + if (ierr /= 0) call io_error('Error in allocating centre_id in check_and_sort_similar_centres', stdout, seedname) - ! ! First find WFs with similar centres: store in wf_similar_centres(cell#,group#,WF#) - ! + group_verifier = 0 tmp_wf_verifier = 0 first_group_element = 0 centre_id = 0 - ! + ! Loop over unit cells in PL1,PL2,PL3 and PL4 - ! - do i = 1, 4*tran_num_cell_ll + + do i = 1, 4*transport%num_cell_ll group_iterator = 0 has_similar_centres = .false. - ! + ! Loops over wannier functions in present unit cell - ! + num_wf_cell_iter = 0 do j = 1, num_wann_cell_ll num_wf_iterator = 0 - ! + ! 2nd Loop over wannier functions in the present unit cell - ! + do k = 1, num_wann_cell_ll if ((.not. has_similar_centres(k)) .and. (j .ne. k)) then coord_iterator = 0 - ! + ! Loop over x,y,z to find similar centres - ! + do l = 1, 3 - if (i .le. 2*tran_num_cell_ll) then + if (i .le. 2*transport%num_cell_ll) then if (abs(wannier_centres_translated(coord(l), tran_sorted_idx(j + (i - 1)*num_wann_cell_ll)) - & wannier_centres_translated(coord(l), tran_sorted_idx(k + (i - 1)*num_wann_cell_ll))) & - .le. tran_group_threshold) then + .le. transport%group_threshold) then coord_iterator = coord_iterator + 1 else exit endif else - if (abs(wannier_centres_translated(coord(l), tran_sorted_idx(num_wann - 2*tran_num_ll + & - j + (i - 2*tran_num_cell_ll - 1)*num_wann_cell_ll)) - & - wannier_centres_translated(coord(l), tran_sorted_idx(num_wann - 2*tran_num_ll + & - k + (i - 2*tran_num_cell_ll - 1)*num_wann_cell_ll))) & - .le. tran_group_threshold) then + if (abs(wannier_centres_translated(coord(l), & + tran_sorted_idx(num_wann - 2*transport%num_ll & + + j + (i - 2*transport%num_cell_ll - 1)*num_wann_cell_ll)) & + - wannier_centres_translated(coord(l), & + tran_sorted_idx(num_wann - 2*transport%num_ll & + + k + (i - 2*transport%num_cell_ll - 1)*num_wann_cell_ll))) & + .le. transport%group_threshold) then coord_iterator = coord_iterator + 1 else exit @@ -2595,17 +2914,17 @@ subroutine check_and_sort_similar_centres(signatures, num_G) if (coord_iterator .eq. 3) then if (.not. has_similar_centres(j)) then num_wf_iterator = num_wf_iterator + 1 - if (i .le. 2*tran_num_cell_ll) then + if (i .le. 2*transport%num_cell_ll) then idx_similar_wf(num_wf_iterator) = tran_sorted_idx(j + (i - 1)*num_wann_cell_ll) else - idx_similar_wf(num_wf_iterator) = tran_sorted_idx(j + num_wann - 2*tran_num_ll + & - (i - 2*tran_num_cell_ll - 1)*num_wann_cell_ll) + idx_similar_wf(num_wf_iterator) = tran_sorted_idx(j + num_wann - 2*transport%num_ll + & + (i - 2*transport%num_cell_ll - 1)*num_wann_cell_ll) endif - if (i .le. 2*tran_num_cell_ll) then + if (i .le. 2*transport%num_cell_ll) then first_group_element(i, j) = j + (i - 1)*num_wann_cell_ll else - first_group_element(i, j) = num_wann - 2*tran_num_ll + & - j + (i - 2*tran_num_cell_ll - 1)*num_wann_cell_ll + first_group_element(i, j) = num_wann - 2*transport%num_ll + & + j + (i - 2*transport%num_cell_ll - 1)*num_wann_cell_ll endif num_wf_cell_iter = num_wf_cell_iter + 1 centre_id(num_wf_cell_iter) = j @@ -2613,11 +2932,11 @@ subroutine check_and_sort_similar_centres(signatures, num_G) has_similar_centres(k) = .true. has_similar_centres(j) = .true. num_wf_iterator = num_wf_iterator + 1 - if (i .le. 2*tran_num_cell_ll) then + if (i .le. 2*transport%num_cell_ll) then idx_similar_wf(num_wf_iterator) = tran_sorted_idx(k + (i - 1)*num_wann_cell_ll) else - idx_similar_wf(num_wf_iterator) = tran_sorted_idx(k + num_wann - 2*tran_num_ll + & - (i - 2*tran_num_cell_ll - 1)*num_wann_cell_ll) + idx_similar_wf(num_wf_iterator) = tran_sorted_idx(k + num_wann - 2*transport%num_ll + & + (i - 2*transport%num_cell_ll - 1)*num_wann_cell_ll) endif endif endif @@ -2625,9 +2944,9 @@ subroutine check_and_sort_similar_centres(signatures, num_G) if (num_wf_iterator .gt. 0) then group_iterator = group_iterator + 1 wf_similar_centres(i, group_iterator, :) = idx_similar_wf(:) - ! + !Save number of WFs in each group - ! + tmp_wf_verifier(i, group_iterator) = num_wf_iterator endif enddo @@ -2638,112 +2957,122 @@ subroutine check_and_sort_similar_centres(signatures, num_G) write (stdout, *) ' Wannier functions found with similar centres: ' write (stdout, *) ' -> using signatures to complete sorting ' endif - ! + !Save number of group of WFs in each unit cell and compare to previous unit cell - ! + group_verifier(i) = group_iterator - if (iprint .ge. 4) write (stdout, '(a11,i4,a13,i4)') ' Unit cell:', i, ' Num groups:', group_verifier(i) + if (print_output%iprint .ge. 4) write (stdout, '(a11,i4,a13,i4)') ' Unit cell:', i, ' Num groups:', group_verifier(i) if (i .ne. 1) then if (group_verifier(i) .ne. group_verifier(i - 1)) then - if (write_xyz) call tran_write_xyz() - call io_error('Inconsitent number of groups of similar centred wannier functions between unit cells') - elseif (i .eq. 4*tran_num_cell_ll) then + if (write_xyz) call tran_write_xyz(atom_data, transport, wannier_centres_translated, & + tran_sorted_idx, num_wann, seedname, stdout) + call io_error('Inconsitent number of groups of similar centred wannier functions between unit cells', stdout, seedname) + elseif (i .eq. 4*transport%num_cell_ll) then write (stdout, *) ' Consistent groups of similar centred wannier functions between ' write (stdout, *) ' unit cells found' write (stdout, *) ' ' endif endif enddo !Loop over all unit cells in PL1,PL2,PL3,PL4 - ! + ! Perform check to ensure consistent number of WFs between equivalent groups in different unit cells - ! + if (any(has_similar_centres)) then - ! - ! - allocate (wf_verifier(4*tran_num_cell_ll, group_verifier(1)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating wf_verifier in check_and_sort_similar_centres') - ! - ! - if (iprint .ge. 4) write (stdout, *) 'Unit cell Group number Num WFs' + + allocate (wf_verifier(4*transport%num_cell_ll, group_verifier(1)), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating wf_verifier in check_and_sort_similar_centres', stdout, seedname) + + if (print_output%iprint .ge. 4) write (stdout, *) 'Unit cell Group number Num WFs' wf_verifier = 0 wf_verifier = tmp_wf_verifier(:, 1:group_verifier(1)) - do i = 1, 4*tran_num_cell_ll + do i = 1, 4*transport%num_cell_ll do j = 1, group_verifier(1) - if (iprint .ge. 4) write (stdout, '(a3,i4,a9,i4,a7,i4)') ' ', i, ' ', j, ' ', wf_verifier(i, j) + if (print_output%iprint .ge. 4) write (stdout, '(a3,i4,a9,i4,a7,i4)') ' ', i, ' ', & + j, ' ', wf_verifier(i, j) if (i .ne. 1) then if (wf_verifier(i, j) .ne. wf_verifier(i - 1, j)) & call io_error('Inconsitent number of wannier & &functions between equivalent groups of similar & - ¢red wannier functions') + ¢red wannier functions', stdout, seedname) endif enddo enddo write (stdout, *) ' Consistent number of wannier functions between equivalent groups of similar' write (stdout, *) ' centred wannier functions' write (stdout, *) ' ' - ! + write (stdout, *) ' Fixing order of similar centred wannier functions using parity signatures' - ! - do i = 2, 4*tran_num_cell_ll + + do i = 2, 4*transport%num_cell_ll do j = 1, group_verifier(1) - ! + ! Make array of WF numbers which act as a reference to sort against ! and an array which need sorting - ! + allocate (ref_similar_centres(group_verifier(1), wf_verifier(1, j)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ref_similar_centres in check_and_sort_similar_centres') + if (ierr /= 0) then + call io_error('Error in allocating ref_similar_centres in check_and_sort_similar_centres', stdout, seedname) + end if allocate (unsorted_similar_centres(group_verifier(1), wf_verifier(1, j)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating unsorted_similar_centres in check_and_sort_similar_centres') + if (ierr /= 0) then + call io_error('Error in allocating unsorted_similar_centres in check_and_sort_similar_centres', stdout, seedname) + end if allocate (sorted_idx(wf_verifier(1, j)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating sorted_idx in check_and_sort_similar_centres') + if (ierr /= 0) then + call io_error('Error in allocating sorted_idx in check_and_sort_similar_centres', stdout, seedname) + end if allocate (dot_p(wf_verifier(1, j)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating dot_p in check_and_sort_similar_centres') - ! + if (ierr /= 0) then + call io_error('Error in allocating dot_p in check_and_sort_similar_centres', stdout, seedname) + end if + do k = 1, wf_verifier(1, j) ref_similar_centres(j, k) = wf_similar_centres(1, j, k) unsorted_similar_centres(j, k) = wf_similar_centres(i, j, k) enddo - ! + sorted_idx = 0 do k = 1, wf_verifier(1, j) dot_p = 0.0_dp - ! + ! building the array of positive dot products of signatures between unsorted_similar_centres(j,k) ! and all the ref_similar_centres(j,:) - ! + do l = 1, wf_verifier(1, j) do p = 1, num_G dot_p(l) = dot_p(l) + abs(signatures(p, unsorted_similar_centres(j, k)))* & abs(signatures(p, ref_similar_centres(j, l))) enddo enddo - ! + max_position = maxloc(dot_p) - ! + sorted_idx(max_position(1)) = unsorted_similar_centres(j, k) enddo - ! + ! we have the properly ordered indexes for group j in unit cell i, now we need ! to overwrite the tran_sorted_idx array at the proper position - ! + tran_sorted_idx(first_group_element(i, centre_id(j)):first_group_element(i, centre_id(j)) +& &wf_verifier(i, j) - 1) = sorted_idx(:) - ! + deallocate (dot_p, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating dot_p in check_and_sort_similar_centres') + if (ierr /= 0) call io_error('Error in deallocating dot_p in check_and_sort_similar_centres', stdout, seedname) deallocate (sorted_idx, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating sorted_idx in check_and_sort_similar_centres') + if (ierr /= 0) call io_error('Error in deallocating sorted_idx in check_and_sort_similar_centres', stdout, seedname) deallocate (unsorted_similar_centres, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating unsorted_similar_centres in check_and_sort_similar_centres') + if (ierr /= 0) call io_error('Error in deallocating unsorted_similar_centres in check_and_sort_similar_centres', & + stdout, seedname) deallocate (ref_similar_centres, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating ref_similar_centres in check_and_sort_similar_centres') + if (ierr /= 0) call io_error('Error in deallocating ref_similar_centres in check_and_sort_similar_centres', & + stdout, seedname) enddo enddo - ! + ! checking that all the indices of WFs in the new tran_sorted_idx are distinct ! Remark: physically, no two WFs with similar centres can have the same type so we should expect ! this check to always pass unless the signatures/wf are very weird !! - ! + do k = 1, num_wann iterator = 0 do l = 1, num_wann @@ -2751,60 +3080,72 @@ subroutine check_and_sort_similar_centres(signatures, num_G) iterator = iterator + 1 endif enddo - ! + if ((iterator .ge. 2) .or. (iterator .eq. 0)) call io_error( & 'A Wannier Function appears either zero times or twice after sorting, this may be due to a & - &poor wannierisation and/or disentanglement') + &poor wannierisation and/or disentanglement', stdout, seedname) !write(stdout,*) ' WF : ',k,' appears ',iterator,' time(s)' enddo deallocate (wf_verifier, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating wf_verifier in check_and_sort_similar_centres') + if (ierr /= 0) call io_error('Error deallocating wf_verifier in check_and_sort_similar_centres', stdout, seedname) endif deallocate (centre_id, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating centre_id in check_and_sort_similar_centres') + if (ierr /= 0) call io_error('Error deallocating centre_id in check_and_sort_similar_centres', stdout, seedname) deallocate (first_group_element, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating first_group_element in check_and_sort_similar_centres') + if (ierr /= 0) call io_error('Error deallocating first_group_element in check_and_sort_similar_centres', stdout, seedname) deallocate (group_verifier, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating group_verifier in check_and_sort_similar_centres') + if (ierr /= 0) call io_error('Error deallocating group_verifier in check_and_sort_similar_centres', stdout, seedname) deallocate (tmp_wf_verifier, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating tmp_wf_verifier in check_and_sort_similar_centres') + if (ierr /= 0) call io_error('Error deallocating tmp_wf_verifier in check_and_sort_similar_centres', stdout, seedname) deallocate (has_similar_centres, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating has_similar_centres in check_and_sort_similar_centres') + if (ierr /= 0) call io_error('Error deallocating has_similar_centres in check_and_sort_similar_centres', stdout, seedname) deallocate (idx_similar_wf, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating idx_similar_wf in check_and_sort_similar_centres') + if (ierr /= 0) call io_error('Error deallocating idx_similar_wf in check_and_sort_similar_centres', stdout, seedname) deallocate (wf_similar_centres, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating wf_similar_centre in check_and_sort_similar_centres') + if (ierr /= 0) call io_error('Error deallocating wf_similar_centre in check_and_sort_similar_centres', stdout, seedname) - if (timing_level > 2) call io_stopwatch('tran: lcr_2c2_sort: similar_centres', 2) + if (print_output%timing_level > 2) call io_stopwatch('tran: lcr_2c2_sort: similar_centres', 2, stdout, seedname) return end subroutine check_and_sort_similar_centres - !=====================================! - subroutine tran_write_xyz() - !=====================================! - ! ! - ! Write xyz file with Wannier centres ! - ! and atomic positions ! - ! ! - !=====================================! - - use w90_io, only: seedname, io_file_unit, io_date, stdout - use w90_parameters, only: num_wann, & - atoms_pos_cart, atoms_symbol, num_species, & - atoms_species_num, num_atoms, transport_mode - use w90_hamiltonian, only: wannier_centres_translated + !================================================! + subroutine tran_write_xyz(atom_data, transport, wannier_centres_translated, tran_sorted_idx, num_wann, & + seedname, stdout) + !================================================! + ! + ! Write xyz file with Wannier centres + ! and atomic positions + ! + !================================================! + + use w90_io, only: io_file_unit, io_date + use w90_types, only: atom_data_type + use w90_wannier90_types, only: transport_type implicit none + ! arguments + type(transport_type), intent(inout) :: transport + type(atom_data_type), intent(in) :: atom_data + + integer, intent(in) :: tran_sorted_idx(:) + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: wannier_centres_translated(:, :) + + character(len=50), intent(in) :: seedname + + ! local variables integer :: iw, ind, xyz_unit, nat, nsp character(len=9) :: cdate, ctime real(kind=dp) :: wc(3, num_wann) - if (index(transport_mode, 'bulk') > 0) wc = wannier_centres_translated - if (index(transport_mode, 'lcr') > 0) then + if (index(transport%mode, 'bulk') > 0) wc = wannier_centres_translated + if (index(transport%mode, 'lcr') > 0) then do iw = 1, num_wann wc(:, iw) = wannier_centres_translated(:, tran_sorted_idx(iw)) enddo @@ -2812,18 +3153,18 @@ subroutine tran_write_xyz() xyz_unit = io_file_unit() open (xyz_unit, file=trim(seedname)//'_centres.xyz', form='formatted') - ! - write (xyz_unit, '(i6)') num_wann + num_atoms - ! + + write (xyz_unit, '(i6)') num_wann + atom_data%num_atoms + call io_date(cdate, ctime) write (xyz_unit, '(a84)') 'Wannier centres and atomic positions, written by Wannier90 on '//cdate//' at '//ctime - ! + do iw = 1, num_wann write (xyz_unit, '("X",6x,3(f14.8,3x))') (wc(ind, iw), ind=1, 3) end do - do nsp = 1, num_species - do nat = 1, atoms_species_num(nsp) - write (xyz_unit, '(a2,5x,3(f14.8,3x))') atoms_symbol(nsp), atoms_pos_cart(:, nat, nsp) + do nsp = 1, atom_data%num_species + do nat = 1, atom_data%species_num(nsp) + write (xyz_unit, '(a2,5x,3(f14.8,3x))') atom_data%symbol(nsp), atom_data%pos_cart(:, nat, nsp) end do end do @@ -2833,36 +3174,49 @@ subroutine tran_write_xyz() end subroutine tran_write_xyz - !==============================================================! - subroutine tran_parity_enforce(signatures) - !==============================================================! - ! Here, the signatures of the each wannier fucntion (stored in ! - ! signatures) is used to determine its relavite parity ! - ! with respect to the first unit cell. The parity pattern of ! - ! first unit cell is then enforced. ! - !==============================================================! + !================================================! + subroutine tran_parity_enforce(signatures, print_output, transport, num_wann, tran_sorted_idx, & + hr_one_dim, irvec_max, stdout, seedname) + !================================================! + ! Here, the signatures of the each wannier fucntion (stored in + ! signatures) is used to determine its relavite parity + ! with respect to the first unit cell. The parity pattern of + ! first unit cell is then enforced. + !================================================! use w90_constants, only: dp - use w90_io, only: stdout, io_stopwatch - use w90_parameters, only: tran_num_cell_ll, num_wann, tran_num_ll, & - timing_level, iprint, tran_easy_fix + use w90_io, only: io_stopwatch + use w90_types, only: print_output_type + use w90_wannier90_types, only: transport_type implicit none - real(dp), intent(inout), dimension(:, :) :: signatures + ! arguments + integer, intent(in) :: irvec_max + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + integer, intent(in) :: tran_sorted_idx(:) - integer :: i, j, k, wf_idx, num_wann_cell_ll - real(dp) :: signature_dot_p + real(kind=dp), intent(inout) :: signatures(:, :) + real(kind=dp), intent(inout) :: hr_one_dim(:, :, -irvec_max:) - if (timing_level > 1) call io_stopwatch('tran: parity_enforce', 1) + type(print_output_type), intent(in) :: print_output + type(transport_type), intent(in) :: transport + + character(len=50), intent(in) :: seedname + + ! local variables + integer :: i, j, k, wf_idx, num_wann_cell_ll + real(kind=dp) :: signature_dot_p + + if (print_output%timing_level > 1) call io_stopwatch('tran: parity_enforce', 1, stdout, seedname) - ! ! NP: special "easy" fix of the parities by switching the sign ! of the Wannier Functions if the first element of the signature ! is found negative. Then updating the signature and the Hamiltonian ! matrix element for the corresponding line and column - ! - if (tran_easy_fix) then + + if (transport%easy_fix) then do i = 1, num_wann if (real(signatures(1, i)) .lt. 0.0_dp) then signatures(:, i) = -signatures(:, i) @@ -2874,31 +3228,31 @@ subroutine tran_parity_enforce(signatures) enddo endif - num_wann_cell_ll = tran_num_ll/tran_num_cell_ll - if (iprint .eq. 5) write (stdout, '(a101)') 'Unit cell Sorted WF index Unsort WF index & + num_wann_cell_ll = transport%num_ll/transport%num_cell_ll + if (print_output%iprint .eq. 5) write (stdout, '(a101)') 'Unit cell Sorted WF index Unsort WF index & &Unsorted WF Equiv Signature Dot Product' - ! + ! Loop over unit cell in principal layers - ! - do i = 2, 4*tran_num_cell_ll - ! + + do i = 2, 4*transport%num_cell_ll + ! Loop over wannier functions in unit cell - ! + do j = 1, num_wann_cell_ll - if (i .le. 2*tran_num_cell_ll) then + if (i .le. 2*transport%num_cell_ll) then wf_idx = j + (i - 1)*num_wann_cell_ll else - wf_idx = num_wann - 2*tran_num_ll + j + (i - 1 - 2*tran_num_cell_ll)*num_wann_cell_ll + wf_idx = num_wann - 2*transport%num_ll + j + (i - 1 - 2*transport%num_cell_ll)*num_wann_cell_ll endif signature_dot_p = dot_product(signatures(:, tran_sorted_idx(j)), signatures(:, tran_sorted_idx(wf_idx))) - if (iprint .eq. 5) then + if (print_output%iprint .eq. 5) then write (stdout, '(2x,i4,3(13x,i5),12x,f20.17)') & i, wf_idx, tran_sorted_idx(wf_idx), tran_sorted_idx(j), signature_dot_p endif if (abs(signature_dot_p) .le. 0.8_dp) then write (stdout, '(a28,i4,a64,i4,a20)') ' WARNING: Wannier function (', tran_sorted_idx(wf_idx), & ') seems to has poor resemblance to equivalent wannier function (', tran_sorted_idx(j), ') in first unit cell' - if (iprint .lt. 5) write (stdout, *) 'Dot product of signatures: ', signature_dot_p + if (print_output%iprint .lt. 5) write (stdout, *) 'Dot product of signatures: ', signature_dot_p endif if (signature_dot_p .lt. 0.0_dp) then do k = 1, num_wann @@ -2909,150 +3263,186 @@ subroutine tran_parity_enforce(signatures) enddo enddo - if (timing_level > 1) call io_stopwatch('tran: parity_enforce', 2) + if (print_output%timing_level > 1) call io_stopwatch('tran: parity_enforce', 2, stdout, seedname) return end subroutine tran_parity_enforce - !========================================! - subroutine tran_lcr_2c2_build_ham(pl_warning) - !==============================================! - ! Builds hamiltonians blocks required for the ! - ! Greens function caclulations of the quantum ! - ! conductance according to the 2c2 geometry. ! - ! Leads are also symmetrised, in that unit cell! - ! sub-blocks are copied to create truely ideal ! - ! leads. ! - !==============================================! + !================================================! + subroutine tran_lcr_2c2_build_ham(pl_warning, real_space_ham, fermi_energy_list, kpt_latt, & + num_wann, transport, print_output, real_lattice, mp_grid, & + ham_r, irvec, nrpts, wannier_centres_translated, one_dim_vec, & + nrpts_one_dim, num_pl, coord, tran_sorted_idx, hC, hCR, hL0, & + hL1, hLC, hR0, hR1, hr_one_dim, irvec_max, stdout, seedname) + !================================================! + ! Builds hamiltonians blocks required for the + ! Greens function caclulations of the quantum + ! conductance according to the 2c2 geometry. + ! Leads are also symmetrised, in that unit cell + ! sub-blocks are copied to create truely ideal + ! leads. + !================================================! use w90_constants, only: dp, eps5 - use w90_io, only: io_error, stdout, seedname, io_file_unit, io_date, io_stopwatch - use w90_parameters, only: tran_num_cell_ll, num_wann, tran_num_ll, kpt_cart, nfermi, fermi_energy_list, & - tran_write_ht, tran_num_rr, tran_num_lc, tran_num_cr, tran_num_cc, & - tran_num_bandc, timing_level, dist_cutoff_mode, dist_cutoff, & - dist_cutoff_hc - use w90_hamiltonian, only: wannier_centres_translated + use w90_io, only: io_error, io_file_unit, io_date, io_stopwatch + use w90_types, only: print_output_type + use w90_wannier90_types, only: transport_type, real_space_ham_type implicit none - logical, intent(in) :: pl_warning - - integer :: i, j, k, num_wann_cell_ll, file_unit, ierr, band_size - - real(dp), allocatable, dimension(:, :) :: sub_block - real(dp) :: PL_length, dist, dist_vec(3) - - character(len=9) :: cdate, ctime - - if (timing_level > 1) call io_stopwatch('tran: lcr_2c2_build_ham', 1) + ! arguments + integer, intent(in) :: coord(3) + integer, intent(in) :: irvec(:, :) + integer, intent(inout) :: irvec_max + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_wann + integer, intent(inout) :: nrpts + integer, intent(inout) :: nrpts_one_dim + integer, intent(inout) :: num_pl + integer, intent(inout) :: one_dim_vec + integer, intent(in) :: stdout + integer, intent(in) :: tran_sorted_idx(:) + + real(kind=dp), allocatable, intent(inout) :: hr_one_dim(:, :, :) ! de/realloc'd below + real(kind=dp), allocatable, intent(inout) :: hC(:, :) + real(kind=dp), allocatable, intent(inout) :: hCR(:, :) + real(kind=dp), allocatable, intent(inout) :: hL0(:, :) + real(kind=dp), allocatable, intent(inout) :: hL1(:, :) + real(kind=dp), allocatable, intent(inout) :: hLC(:, :) + real(kind=dp), allocatable, intent(inout) :: hR0(:, :) + real(kind=dp), allocatable, intent(inout) :: hR1(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: wannier_centres_translated(:, :) + + complex(kind=dp), intent(in) :: ham_r(:, :, :) + + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + real(kind=dp), intent(in) :: kpt_latt(:, :) + type(real_space_ham_type), intent(inout) :: real_space_ham + type(print_output_type), intent(in) :: print_output + type(transport_type), intent(inout) :: transport + + character(len=50), intent(in) :: seedname + + logical, intent(in) :: pl_warning + + ! local variables + integer :: i, j, k, num_wann_cell_ll, file_unit, ierr, band_size + integer :: fermi_n + real(kind=dp), allocatable :: sub_block(:, :) + real(kind=dp) :: PL_length, dist, dist_vec(3) + character(len=9) :: cdate, ctime + + if (print_output%timing_level > 1) call io_stopwatch('tran: lcr_2c2_build_ham', 1, stdout, seedname) + + fermi_n = 0 + if (allocated(fermi_energy_list)) fermi_n = size(fermi_energy_list) + if (fermi_n > 1) call io_error("Error in tran_lcr_2c2_build_ham: nfermi>1. " & + //"Set the fermi level using the input parameter 'fermi_evel'", stdout, seedname) + + allocate (hL0(transport%num_ll, transport%num_ll), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hL0 in tran_lcr_2c2_build_ham', stdout, seedname) + allocate (hL1(transport%num_ll, transport%num_ll), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hL1 in tran_lcr_2c2_build_ham', stdout, seedname) + allocate (hR0(transport%num_ll, transport%num_ll), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hR0 in tran_lcr_2c2_build_ham', stdout, seedname) + allocate (hR1(transport%num_ll, transport%num_ll), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hR1 in tran_lcr_2c2_build_ham', stdout, seedname) + allocate (hLC(transport%num_ll, transport%num_ll), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hLC in tran_lcr_2c2_build_ham', stdout, seedname) + allocate (hCR(transport%num_ll, transport%num_ll), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hCR in tran_lcr_2c2_build_ham', stdout, seedname) + allocate (hC(num_wann - (2*transport%num_ll), num_wann - (2*transport%num_ll)), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating hC in tran_lcr_2c2_build_ham', stdout, seedname) - if (nfermi > 1) call io_error("Error in tran_lcr_2c2_build_ham: nfermi>1. " & - //"Set the fermi level using the input parameter 'fermi_evel'") - - allocate (hL0(tran_num_ll, tran_num_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hL0 in tran_lcr_2c2_build_ham') - allocate (hL1(tran_num_ll, tran_num_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hL1 in tran_lcr_2c2_build_ham') - allocate (hR0(tran_num_ll, tran_num_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hR0 in tran_lcr_2c2_build_ham') - allocate (hR1(tran_num_ll, tran_num_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hR1 in tran_lcr_2c2_build_ham') - allocate (hLC(tran_num_ll, tran_num_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hLC in tran_lcr_2c2_build_ham') - allocate (hCR(tran_num_ll, tran_num_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hCR in tran_lcr_2c2_build_ham') - allocate (hC(num_wann - (2*tran_num_ll), num_wann - (2*tran_num_ll)), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating hC in tran_lcr_2c2_build_ham') - ! !This checks that only the gamma point is used in wannierisation !This is necessary since this calculation only makes sense if we !have periodicity over the supercell. - ! - if ((size(kpt_cart, 2) .ne. 1) .and. (kpt_cart(1, 1) .eq. 0.0_dp) & - .and. (kpt_cart(2, 1) .eq. 0.0_dp) & - .and. (kpt_cart(3, 1) .eq. 0.0_dp)) then - call io_error('Calculation must be performed at gamma only') + !BGS, I think (0, 0, 0) in kpt_latt should work as well as in kpt_cart + if ((size(kpt_latt, 2) .ne. 1) .and. (kpt_latt(1, 1) .eq. 0.0_dp) & + .and. (kpt_latt(2, 1) .eq. 0.0_dp) .and. (kpt_latt(3, 1) .eq. 0.0_dp)) then + call io_error('Calculation must be performed at gamma only', stdout, seedname) endif - num_wann_cell_ll = tran_num_ll/tran_num_cell_ll + num_wann_cell_ll = transport%num_ll/transport%num_cell_ll allocate (sub_block(num_wann_cell_ll, num_wann_cell_ll), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating sub_block in tran_lcr_2c2_build_ham') - ! + if (ierr /= 0) call io_error('Error in allocating sub_block in tran_lcr_2c2_build_ham', stdout, seedname) + !Build hL0 & hL1 - ! + hL0 = 0.0_dp hL1 = 0.0_dp - ! + !Loop over the sub_blocks corresponding to distinct unit cells inside the principal layer - ! - do i = 1, tran_num_cell_ll - ! + + do i = 1, transport%num_cell_ll + !Each sub_block will be duplicated along the corresponding diagonal. This ensures the correct symmetry for the leads. - ! + sub_block = 0.0_dp - ! + !Extract matrix elements from hr_one_dim needed for hL0 (and lower triangular sub_blocks of hL1) - ! + do j = 1, num_wann_cell_ll do k = 1, num_wann_cell_ll sub_block(j, k) = hr_one_dim(tran_sorted_idx(j), tran_sorted_idx((i - 1)*num_wann_cell_ll + k), 0) enddo enddo - ! + !Filling up hL0 sub_block by sub_block - ! - do j = 1, tran_num_cell_ll - i + 1 - ! + + do j = 1, transport%num_cell_ll - i + 1 + !Fill diagonal and upper diagonal sub_blocks - ! + hL0((j - 1)*num_wann_cell_ll + 1:j*num_wann_cell_ll, & (j - 1)*num_wann_cell_ll + 1 + (i - 1)*num_wann_cell_ll:j*num_wann_cell_ll + (i - 1)*num_wann_cell_ll) = sub_block - ! + !Fill lower diagonal sub_blocks - ! + if (i .gt. 1) then hL0((j - 1)*num_wann_cell_ll + 1 + (i - 1)*num_wann_cell_ll:j*num_wann_cell_ll + (i - 1)*num_wann_cell_ll, & (j - 1)*num_wann_cell_ll + 1:j*num_wann_cell_ll) = transpose(sub_block) endif enddo - ! + !Filling up non-diagonal hL1 sub_blocks (nothing need be done for i=1) - ! + if (i .gt. 1) then do j = 1, i - 1 - hL1((tran_num_cell_ll - (i - j))*num_wann_cell_ll + 1:(tran_num_cell_ll - (i - 1 - j))*num_wann_cell_ll, & + hL1((transport%num_cell_ll - (i - j))*num_wann_cell_ll + 1:(transport%num_cell_ll - (i - 1 - j))*num_wann_cell_ll, & (j - 1)*num_wann_cell_ll + 1:j*num_wann_cell_ll) = sub_block enddo endif - ! + ! MS: Get diagonal and upper triangular sublocks for hL1 - use periodic image of PL4 - ! + sub_block = 0.0_dp - ! + if (i == 1) then !Do diagonal only do j = 1, num_wann_cell_ll do k = 1, num_wann_cell_ll sub_block(j, k) = hr_one_dim( & - tran_sorted_idx(num_wann - tran_num_ll + j), & + tran_sorted_idx(num_wann - transport%num_ll + j), & tran_sorted_idx((i - 1)*num_wann_cell_ll + k), 0) enddo enddo - ! + ! MS: Now fill subblocks of hL1 - ! - do j = 1, tran_num_cell_ll - i + 1 + + do j = 1, transport%num_cell_ll - i + 1 hL1((j - 1)*num_wann_cell_ll + 1:j*num_wann_cell_ll, & (j - 1)*num_wann_cell_ll + 1 + (i - 1)*num_wann_cell_ll:j*num_wann_cell_ll + (i - 1)* & num_wann_cell_ll) = sub_block enddo endif enddo - ! + !Special case tran_num_cell_ll=1, the diagonal sub-block of hL1 is hL1, so cannot be left as zero - ! - if (tran_num_cell_ll .eq. 1) then + + if (transport%num_cell_ll .eq. 1) then do j = num_wann - num_wann_cell_ll + 1, num_wann do k = 1, num_wann_cell_ll hL1(j - num_wann + num_wann_cell_ll, k) = hr_one_dim(tran_sorted_idx(j), tran_sorted_idx(k), 0) @@ -3060,79 +3450,78 @@ subroutine tran_lcr_2c2_build_ham(pl_warning) enddo endif - ! !Build hR0 & hR1 - ! + hR0 = 0.0_dp hR1 = 0.0_dp - ! + !Loop over the sub_blocks corresponding to distinct unit cells inside the principal layer - ! - do i = 1, tran_num_cell_ll - ! + + do i = 1, transport%num_cell_ll + !Each sub_block will be duplicated along the corresponding diagonal. This ensures the correct symmetry for the leads. - ! + sub_block = 0.0_dp - ! + !Extract matrix elements from hr_one_dim needed for hR0 (and lower triangular sub_blocks of hR1) - ! + do j = 1, num_wann_cell_ll do k = 1, num_wann_cell_ll sub_block(j, k) = hr_one_dim(tran_sorted_idx(num_wann - i*(num_wann_cell_ll) + j), & tran_sorted_idx(num_wann - num_wann_cell_ll + k), 0) enddo enddo - ! + !Filling up hR0 sub_block by sub_block - ! - do j = 1, tran_num_cell_ll - i + 1 - ! + + do j = 1, transport%num_cell_ll - i + 1 + !Fill diagonal and upper diagonal sub_blocks - ! + hR0((j - 1)*num_wann_cell_ll + 1:j*num_wann_cell_ll, & (j - 1)*num_wann_cell_ll + 1 + (i - 1)*num_wann_cell_ll:j*num_wann_cell_ll + (i - 1)*num_wann_cell_ll) = sub_block - ! + !Fill lower diagonal sub_blocks - ! + if (i .gt. 1) then hR0((j - 1)*num_wann_cell_ll + 1 + (i - 1)*num_wann_cell_ll:j*num_wann_cell_ll + (i - 1)*num_wann_cell_ll, & (j - 1)*num_wann_cell_ll + 1:j*num_wann_cell_ll) = transpose(sub_block) endif enddo - ! + !Filling up non-diagonal hR1 sub_blocks (nothing need be done for i=1) - ! + if (i .gt. 1) then do j = 1, i - 1 - hR1((tran_num_cell_ll - (i - j))*num_wann_cell_ll + 1:(tran_num_cell_ll - (i - 1 - j))*num_wann_cell_ll, & + hR1((transport%num_cell_ll - (i - j))*num_wann_cell_ll + 1:(transport%num_cell_ll - (i - 1 - j))*num_wann_cell_ll, & (j - 1)*num_wann_cell_ll + 1:j*num_wann_cell_ll) = sub_block enddo endif - ! + ! MS: Get diagonal and upper triangular sublocks for hR1 - use periodic image of PL1 - ! + sub_block = 0.0_dp - ! + if (i == 1) then !Do diagonal only do j = 1, num_wann_cell_ll do k = 1, num_wann_cell_ll sub_block(j, k) = hr_one_dim(tran_sorted_idx((i - 1)*num_wann_cell_ll + k), & - tran_sorted_idx(num_wann - tran_num_ll + j), 0) + tran_sorted_idx(num_wann - transport%num_ll + j), 0) enddo enddo - ! + ! MS: Now fill subblocks of hR1 - ! - do j = 1, tran_num_cell_ll - i + 1 + + do j = 1, transport%num_cell_ll - i + 1 hR1((j - 1)*num_wann_cell_ll + 1:j*num_wann_cell_ll, & (j - 1)*num_wann_cell_ll + 1 + (i - 1)*num_wann_cell_ll:j*num_wann_cell_ll + (i - 1)*num_wann_cell_ll) = sub_block enddo endif enddo - ! + !Special case tran_num_cell_ll=1, the diagonal sub-block of hR1 is hR1, so cannot be left as zero - ! - if (tran_num_cell_ll .eq. 1) then + + if (transport%num_cell_ll .eq. 1) then do j = 1, num_wann_cell_ll do k = num_wann - num_wann_cell_ll + 1, num_wann hR1(k - num_wann + num_wann_cell_ll, j) = hr_one_dim(tran_sorted_idx(j), tran_sorted_idx(k), 0) @@ -3140,21 +3529,20 @@ subroutine tran_lcr_2c2_build_ham(pl_warning) enddo endif - ! !Building hLC - ! + hLC = 0.0_dp - do i = 1, tran_num_ll - do j = tran_num_ll + 1, 2*tran_num_ll - hLC(i, j - tran_num_ll) = hr_one_dim(tran_sorted_idx(i), tran_sorted_idx(j), 0) + do i = 1, transport%num_ll + do j = transport%num_ll + 1, 2*transport%num_ll + hLC(i, j - transport%num_ll) = hr_one_dim(tran_sorted_idx(i), tran_sorted_idx(j), 0) enddo enddo !----! ! MS ! Rely on dist_cutoff doing the work here, as it cuts element-wise, not block wise (incorrect) !----! -! if (tran_num_cell_ll .gt. 1) then -! do j=1,tran_num_cell_ll -! do k=1,tran_num_cell_ll +! if (transport%num_cell_ll .gt. 1) then +! do j=1,transport%num_cell_ll +! do k=1,transport%num_cell_ll ! if (k .ge. j) then ! hLC((j-1)*num_wann_cell_ll+1:j*num_wann_cell_ll,(k-1)*num_wann_cell_ll+1:k*num_wann_cell_ll)=0.0_dp ! endif @@ -3165,48 +3553,52 @@ subroutine tran_lcr_2c2_build_ham(pl_warning) !end! !---! - ! !Building hC - ! + hC = 0.0_dp - ! + band_size = 0 - if (dist_cutoff_hc .ne. dist_cutoff) then - dist_cutoff = dist_cutoff_hc + if (real_space_ham%dist_cutoff_hc .ne. real_space_ham%dist_cutoff) then + real_space_ham%dist_cutoff = real_space_ham%dist_cutoff_hc write (stdout, *) 'Applying dist_cutoff_hc to Hamiltonian for construction of hC' deallocate (hr_one_dim, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating hr_one_dim in tran_lcr_2c2_sort') - call tran_reduce_hr() - call tran_cut_hr_one_dim() + if (ierr /= 0) call io_error('Error deallocating hr_one_dim in tran_lcr_2c2_sort', stdout, seedname) + call tran_reduce_hr(real_space_ham, ham_r, hr_one_dim, real_lattice, irvec, mp_grid, irvec_max, & + nrpts, nrpts_one_dim, num_wann, one_dim_vec, print_output%timing_level, & + seedname, stdout) + call tran_cut_hr_one_dim(real_space_ham, transport, print_output, hr_one_dim, real_lattice, & + wannier_centres_translated, mp_grid, irvec_max, num_pl, num_wann, & + one_dim_vec, seedname, stdout) endif - do i = tran_num_ll + 1, num_wann - tran_num_ll - do j = tran_num_ll + 1, num_wann - tran_num_ll - hC(i - tran_num_ll, j - tran_num_ll) = hr_one_dim(tran_sorted_idx(i), tran_sorted_idx(j), 0) - ! + do i = transport%num_ll + 1, num_wann - transport%num_ll + do j = transport%num_ll + 1, num_wann - transport%num_ll + hC(i - transport%num_ll, j - transport%num_ll) = hr_one_dim(tran_sorted_idx(i), tran_sorted_idx(j), 0) + ! Impose a ham_cutoff of 1e-4 eV to reduce tran_num_bandc (and in turn hCband, and speed up transport) - ! - if (abs(hC(i - tran_num_ll, j - tran_num_ll)) .lt. 10.0_dp*eps5) then - hC(i - tran_num_ll, j - tran_num_ll) = 0.0_dp + + if (abs(hC(i - transport%num_ll, j - transport%num_ll)) .lt. 10.0_dp*eps5) then + hC(i - transport%num_ll, j - transport%num_ll) = 0.0_dp band_size = max(band_size, abs(i - j)) endif enddo enddo - ! + !Building hCR - ! + hCR = 0.0_dp - do i = num_wann - 2*tran_num_ll + 1, num_wann - tran_num_ll - do j = num_wann - tran_num_ll + 1, num_wann - hCR(i - (num_wann - 2*tran_num_ll), j - (num_wann - tran_num_ll)) = hr_one_dim(tran_sorted_idx(i), tran_sorted_idx(j), 0) + do i = num_wann - 2*transport%num_ll + 1, num_wann - transport%num_ll + do j = num_wann - transport%num_ll + 1, num_wann + hCR(i - (num_wann - 2*transport%num_ll), j - (num_wann - transport%num_ll)) = & + hr_one_dim(tran_sorted_idx(i), tran_sorted_idx(j), 0) enddo enddo !----! ! MS ! Rely on dist_cutoff doing the work here, as it cuts element-wise, not block wise (incorrect) !----! -! if (tran_num_cell_ll .gt. 1) then -! do j=1,tran_num_cell_ll -! do k=1,tran_num_cell_ll +! if (transport%num_cell_ll .gt. 1) then +! do j=1,transport%num_cell_ll +! do k=1,transport%num_cell_ll ! if (k .ge. j) then ! hCR((j-1)*num_wann_cell_ll+1:j*num_wann_cell_ll,(k-1)*num_wann_cell_ll+1:k*num_wann_cell_ll)=0.0_dp ! endif @@ -3217,56 +3609,53 @@ subroutine tran_lcr_2c2_build_ham(pl_warning) !end! !---! - ! !Subtract the Fermi energy from the diagonal elements of hC,hL0,hR0 - ! - do i = 1, tran_num_ll + + do i = 1, transport%num_ll hL0(i, i) = hL0(i, i) - fermi_energy_list(1) hR0(i, i) = hR0(i, i) - fermi_energy_list(1) enddo - do i = 1, num_wann - (2*tran_num_ll) + do i = 1, num_wann - (2*transport%num_ll) hC(i, i) = hC(i, i) - fermi_energy_list(1) enddo - ! + !Define tran_num_** parameters that are used later in tran_lcr - ! - tran_num_rr = tran_num_ll - tran_num_lc = tran_num_ll - tran_num_cr = tran_num_ll - tran_num_cc = num_wann - (2*tran_num_ll) - ! + transport%num_rr = transport%num_ll + transport%num_lc = transport%num_ll + transport%num_cr = transport%num_ll + transport%num_cc = num_wann - (2*transport%num_ll) + ! Set appropriate tran_num_bandc if has not been set (0.0_dp is default value) - ! - if (tran_num_bandc .eq. 0.0_dp) then - tran_num_bandc = min(band_size + 1, (tran_num_cc + 1)/2 + 1) + + if (transport%num_bandc .eq. 0.0_dp) then + transport%num_bandc = min(band_size + 1, (transport%num_cc + 1)/2 + 1) endif - ! ! MS: Find and print effective PL length - ! + if (.not. pl_warning) then PL_length = 0.0_dp - do i = 1, tran_num_ll - do j = 1, tran_num_ll + do i = 1, transport%num_ll + do j = 1, transport%num_ll if (abs(hL1(i, j)) .gt. 0.0_dp) then - if (index(dist_cutoff_mode, 'one_dim') .gt. 0) then + if (index(real_space_ham%dist_cutoff_mode, 'one_dim') .gt. 0) then dist = abs(wannier_centres_translated(coord(1), tran_sorted_idx(i)) & - - wannier_centres_translated(coord(1), tran_sorted_idx(j + tran_num_ll))) + - wannier_centres_translated(coord(1), tran_sorted_idx(j + transport%num_ll))) else dist_vec(:) = wannier_centres_translated(:, tran_sorted_idx(i)) & - - wannier_centres_translated(:, tran_sorted_idx(j + tran_num_ll)) + - wannier_centres_translated(:, tran_sorted_idx(j + transport%num_ll)) dist = sqrt(dot_product(dist_vec, dist_vec)) endif PL_length = max(PL_length, dist) endif if (abs(hR1(i, j)) .gt. 0.0_dp) then - if (index(dist_cutoff_mode, 'one_dim') .gt. 0) then - dist = abs(wannier_centres_translated(coord(1), tran_sorted_idx(num_wann - 2*tran_num_ll + i)) & - - wannier_centres_translated(coord(1), tran_sorted_idx(num_wann - tran_num_ll + j))) + if (index(real_space_ham%dist_cutoff_mode, 'one_dim') .gt. 0) then + dist = abs(wannier_centres_translated(coord(1), tran_sorted_idx(num_wann - 2*transport%num_ll + i)) & + - wannier_centres_translated(coord(1), tran_sorted_idx(num_wann - transport%num_ll + j))) else - dist_vec(:) = wannier_centres_translated(:, tran_sorted_idx(num_wann - 2*tran_num_ll + i)) & - - wannier_centres_translated(:, tran_sorted_idx(num_wann - tran_num_ll + j)) + dist_vec(:) = wannier_centres_translated(:, tran_sorted_idx(num_wann - 2*transport%num_ll + i)) & + - wannier_centres_translated(:, tran_sorted_idx(num_wann - transport%num_ll + j)) dist = sqrt(dot_product(dist_vec, dist_vec)) endif PL_length = max(PL_length, dist) @@ -3276,75 +3665,74 @@ subroutine tran_lcr_2c2_build_ham(pl_warning) write (stdout, '(1x,a,f12.6,a)') 'Approximate effective principal layer length is: ', PL_length, ' Ang.' endif - ! !Writing to file: - ! - if (tran_write_ht) then + + if (transport%write_ht) then write (stdout, *) '------------------------------- Writing ht files ----------------------------' - ! + file_unit = io_file_unit() open (file_unit, file=trim(seedname)//'_htL.dat', status='unknown', form='formatted', action='write') call io_date(cdate, ctime) write (file_unit, *) 'written on '//cdate//' at '//ctime ! Date and time - write (file_unit, '(I6)') tran_num_ll - write (file_unit, '(6F12.6)') ((hL0(j, i), j=1, tran_num_ll), i=1, tran_num_ll) - write (file_unit, '(I6)') tran_num_ll - write (file_unit, '(6F12.6)') ((hL1(j, i), j=1, tran_num_ll), i=1, tran_num_ll) + write (file_unit, '(I6)') transport%num_ll + write (file_unit, '(6F12.6)') ((hL0(j, i), j=1, transport%num_ll), i=1, transport%num_ll) + write (file_unit, '(I6)') transport%num_ll + write (file_unit, '(6F12.6)') ((hL1(j, i), j=1, transport%num_ll), i=1, transport%num_ll) close (file_unit) write (stdout, *) ' '//trim(seedname)//'_htL.dat written' - ! + !hR - ! + file_unit = io_file_unit() open (file_unit, file=trim(seedname)//'_htR.dat', status='unknown', form='formatted', action='write') call io_date(cdate, ctime) write (file_unit, *) 'written on '//cdate//' at '//ctime ! Date and time - write (file_unit, '(I6)') tran_num_rr - write (file_unit, '(6F12.6)') ((hR0(j, i), j=1, tran_num_rr), i=1, tran_num_rr) - write (file_unit, '(I6)') tran_num_rr - write (file_unit, '(6F12.6)') ((hR1(j, i), j=1, tran_num_rr), i=1, tran_num_rr) + write (file_unit, '(I6)') transport%num_rr + write (file_unit, '(6F12.6)') ((hR0(j, i), j=1, transport%num_rr), i=1, transport%num_rr) + write (file_unit, '(I6)') transport%num_rr + write (file_unit, '(6F12.6)') ((hR1(j, i), j=1, transport%num_rr), i=1, transport%num_rr) close (file_unit) write (stdout, *) ' '//trim(seedname)//'_htR.dat written' - ! + !hLC - ! + file_unit = io_file_unit() open (file_unit, file=trim(seedname)//'_htLC.dat', status='unknown', form='formatted', action='write') call io_date(cdate, ctime) write (file_unit, *) 'written on '//cdate//' at '//ctime ! Date and time - write (file_unit, '(2I6)') tran_num_ll, tran_num_lc - write (file_unit, '(6F12.6)') ((hLC(j, i), j=1, tran_num_lc), i=1, tran_num_lc) + write (file_unit, '(2I6)') transport%num_ll, transport%num_lc + write (file_unit, '(6F12.6)') ((hLC(j, i), j=1, transport%num_lc), i=1, transport%num_lc) close (file_unit) write (stdout, *) ' '//trim(seedname)//'_htLC.dat written' - ! + !hCR - ! + file_unit = io_file_unit() open (file_unit, file=trim(seedname)//'_htCR.dat', status='unknown', form='formatted', action='write') call io_date(cdate, ctime) write (file_unit, *) 'written on '//cdate//' at '//ctime ! Date and time - write (file_unit, '(2I6)') tran_num_cr, tran_num_rr - write (file_unit, '(6F12.6)') ((hCR(j, i), j=1, tran_num_cr), i=1, tran_num_cr) + write (file_unit, '(2I6)') transport%num_cr, transport%num_rr + write (file_unit, '(6F12.6)') ((hCR(j, i), j=1, transport%num_cr), i=1, transport%num_cr) close (file_unit) write (stdout, *) ' '//trim(seedname)//'_htCR.dat written' - ! + !hC - ! + file_unit = io_file_unit() open (file_unit, file=trim(seedname)//'_htC.dat', status='unknown', form='formatted', action='write') call io_date(cdate, ctime) write (file_unit, *) 'written on '//cdate//' at '//ctime ! Date and time - write (file_unit, '(I6)') tran_num_cc - write (file_unit, '(6F12.6)') ((hC(j, i), j=1, tran_num_cc), i=1, tran_num_cc) + write (file_unit, '(I6)') transport%num_cc + write (file_unit, '(6F12.6)') ((hC(j, i), j=1, transport%num_cc), i=1, transport%num_cc) close (file_unit) write (stdout, *) ' '//trim(seedname)//'_htC.dat written' @@ -3353,53 +3741,13 @@ subroutine tran_lcr_2c2_build_ham(pl_warning) end if deallocate (sub_block, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating sub_block in tran_lcr_2c2_build_ham') + if (ierr /= 0) call io_error('Error deallocating sub_block in tran_lcr_2c2_build_ham', stdout, seedname) - if (timing_level > 1) call io_stopwatch('tran: lcr_2c2_build_ham', 2) + if (print_output%timing_level > 1) call io_stopwatch('tran: lcr_2c2_build_ham', 2, stdout, seedname) return end subroutine tran_lcr_2c2_build_ham - !======================================! - subroutine tran_dealloc() - !! Dellocate module data - !====================================! - - use w90_io, only: io_error - - implicit none - - integer :: ierr - - if (allocated(hR1)) then - deallocate (hR1, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating hR1 in tran_dealloc') - end if - if (allocated(hR0)) then - deallocate (hR0, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating hR0 in tran_dealloc') - end if - if (allocated(hL1)) then - deallocate (hL1, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating hL1 in tran_dealloc') - end if - if (allocated(hB1)) then - deallocate (hB1, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating hB1 in tran_dealloc') - end if - if (allocated(hB0)) then - deallocate (hB0, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating hB0 in tran_dealloc') - end if - if (allocated(hr_one_dim)) then - deallocate (hr_one_dim, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating hr_one_dim in tran_dealloc') - end if - - return - - end subroutine tran_dealloc - end module w90_transport diff --git a/src/types.F90 b/src/types.F90 new file mode 100644 index 000000000..db76cf8f0 --- /dev/null +++ b/src/types.F90 @@ -0,0 +1,211 @@ +!-*- mode: F90 -*-! +!------------------------------------------------------------! +! This file is distributed as part of the Wannier90 code and ! +! under the terms of the GNU General Public License. See the ! +! file `LICENSE' in the root directory of the Wannier90 ! +! distribution, or http://www.gnu.org/copyleft/gpl.txt ! +! ! +! The webpage of the Wannier90 code is www.wannier.org ! +! ! +! The Wannier90 code is hosted on GitHub: ! +! ! +! https://github.com/wannier-developers/wannier90 ! +!------------------------------------------------------------! +! ! +! w90_types: derived types encapsulating data required by ! +! both wannier90.x and postw90.x ! +! ! +!------------------------------------------------------------! + +module w90_types + + !! Definition of types encapsulating various quantities, data and parameters. + !! Variables are grouped according to physical meaning and their use in the Wannier90 project. + !! + !! Here are defined types used by both wannier90.x and postw90.x. + !! Types specific to wannier90.x (not used by postw90.x) are defined in wannier90_types.F90. + !! Types specific to postw90.x (not used by wannier90.x) are defined in postw90/postw90_types.F90. + + use w90_constants, only: dp + use w90_io, only: maxlen + + implicit none + + public + + type print_output_type + !!================================================== + !! Contains variables to control output file formatting and verbosity. + !!================================================== + ! verbosity flags - w90_readwrite_read_verbosity + integer :: iprint + ! Controls the verbosity of the output + integer :: timing_level + ! REVIEW_2021-07-22: we agree that we don't need both length_unit and lenconfac; + ! REVIEW_2021-07-22: instead could have a utility function. + character(len=20) :: length_unit ! MAYBE, just have a separate variable? + ! Units for length + real(kind=dp) :: lenconfac !lots of write statements in wannier90 + end type print_output_type + + type w90_system_type + !!================================================== + !! Contains physical information about the material being calculated. + !!================================================== + integer :: num_valence_bands !wannierise, postw90/postw90_common, get_oper and berry + integer :: num_elec_per_state !wannierise and postw90 dos and boltzwann + logical :: spinors !are our WF spinors? !kmesh, plot, wannier_lib, postw90/gyrotropic + end type w90_system_type + + type ws_region_type + logical :: use_ws_distance !ws_distance, plot and postw90_common + real(kind=dp) :: ws_distance_tol !ws_distance, hamiltonian and postw90_common + !! absolute tolerance for the distance to equivalent positions + integer :: ws_search_size(3) ! ws_distance, hamiltonian + !! maximum extension in each direction of the supercell of the BvK cell + !! to search for points inside the Wigner-Seitz cell + end type ws_region_type + + ! used by ws_distance + type ws_distance_type + integer, allocatable :: irdist(:, :, :, :, :)!(3,ndegenx,num_wann,num_wann,nrpts) + !! The integer number of unit cells to shift Wannier function j to put its centre + !! inside the Wigner-Seitz of wannier function i. If several shifts are + !! equivalent (i.e. they take the function on the edge of the WS) they are + !! all listed. First index: xyz, second index: number of degenerate shifts, + !! third and fourth indices: i,j; fifth index: index on the R vector. + real(DP), allocatable :: crdist(:, :, :, :, :)!(3,ndegenx,num_wann,num_wann,nrpts) + !! Cartesian version of irdist_ws, in angstrom + integer, allocatable :: ndeg(:, :, :)!(num_wann,num_wann,nrpts) + !! The number of equivalent vectors for each set of (i,j,R) (that is, loops on + !! the second index of irdist_ws(:,:,i,j,R) go from 1 to wdist_ndeg(i,j,R)) + ! + logical :: done = .false. + !! Global variable to know if the properties were already calculated, and avoid + !! recalculating them when the [[ws_translate_dist]] function is called multiple times + end type ws_distance_type + + ! setup in wannierise, but used by plot, ws_distance etc + type wannier_data_type + !!================================================== + !! Contains the centres and spreads of the MLWFs + !!================================================== + ! Wannier centres and spreads + real(kind=dp), allocatable :: centres(:, :) + real(kind=dp), allocatable :: spreads(:) + ! REVIEW_2021-07-22: Do we want to expose other related variables such as the decomposition + ! REVIEW_2021-07-22: of the spread, matrix elements of r and r^2, etc. (TO FINISH) + end type wannier_data_type + + ! The maximum number of shells we need to satisfy B1 condition in kmesh + integer, parameter :: max_shells = 6 + integer, parameter :: num_nnmax = 12 + + type kmesh_input_type + !!================================================== + !! Contains information that can be provided by the user about determining the kmesh + !!================================================== + integer :: num_shells + !! no longer an input keyword + logical :: skip_B1_tests + !! do not check the B1 condition + integer, allocatable :: shell_list(:) + integer :: search_shells + real(kind=dp) :: tol + end type kmesh_input_type + + !AAM: There are a number of ways one can handle the initial guess. (i) specify explicit + !AAM: projections; (ii) use random (s-orbital) projections; (iii) a combination of (i) and + !AAM: (ii); (iv) use the phases from the Bloch functions directly; (v) SCDM method. (i), (ii) + !AAM: and (iii) require the arrays defined in the "projection_type" below. (iv) and (v) do not. + !AAM: (vi) An external code may also simply supply to w90 an Amn(k) matrix that is has independently + !AAM: generated, in which case projection_type is not needed. + !AAM: It makes sense to keep the projection sites separate from the projection_type data below. + type proj_input_type + !!================================================== + !! Contains information that can be provided by the user about the projections + !!================================================== + ! REVIEW_2021-07-22: site(:,:) has dual usage: for projections and for guiding centres. + ! REVIEW_2021-07-22: Make a new type for guiding centres that only contains sites. + ! REVIEW_2021-07-22: In the future this can be logically distinct from the projection sites. + ! REVIEW_2021-07-22: For now, when defining proj_input_type, also define sites inside the + ! REVIEW_2021-07-22: new guiding centres type. + real(kind=dp), allocatable :: site(:, :) + integer, allocatable :: l(:) + integer, allocatable :: m(:) + integer, allocatable :: s(:) + real(kind=dp), allocatable :: s_qaxis(:, :) + real(kind=dp), allocatable :: z(:, :) + real(kind=dp), allocatable :: x(:, :) + integer, allocatable :: radial(:) + real(kind=dp), allocatable :: zona(:) + ! a u t o m a t i c p r o j e c t i o n s + ! vv: Writes a new block in .nnkp + logical :: auto_projections + end type proj_input_type + + ! kmesh information (set in kmesh) + type kmesh_info_type + !!================================================== + !! Contains derived information about the kmesh + !!================================================== + integer :: nnh ! the number of b-directions (bka) + integer :: nntot ! total number of neighbours for each k-point + integer, allocatable :: nnlist(:, :) ! list of neighbours for each k-point + integer, allocatable :: neigh(:, :) + integer, allocatable :: nncell(:, :, :) ! gives BZ of each neighbour of each k-point + real(kind=dp) :: wbtot + real(kind=dp), allocatable :: wb(:) ! weights associated with neighbours of each k-point + real(kind=dp), allocatable :: bk(:, :, :) ! the b-vectors that go from each k-point to its neighbours + real(kind=dp), allocatable :: bka(:, :) ! the b-directions from 1st k-point to its neighbours + logical :: explicit_nnkpts + !! nnkpts block is in the input file (allowed only for post-proc setup) + end type kmesh_info_type + + ! this contains data which described the disentangled manifold, also used in postw90 + type dis_manifold_type + !!================================================== + !! Contains information about the manifold of states from which the MLWFs are to be disentangled. + !!================================================== + real(kind=dp) :: win_min + !! lower bound of the disentanglement outer window + real(kind=dp) :: win_max + !! upper bound of the disentanglement outer window + real(kind=dp) :: froz_min + !! lower bound of the disentanglement inner (frozen) window + real(kind=dp) :: froz_max + !! upper bound of the disentanglement inner (frozen) window + logical :: frozen_states + ! disentangle parameters + ! Used by plot, hamiltonian, wannierise, postw90_common, get_oper - not read + integer, allocatable :: ndimwin(:) + logical, allocatable :: lwindow(:, :) + end type dis_manifold_type + + ! Atom sites - often used in the write_* routines + ! hamiltonian, wannierise, plot, transport, wannier_lib + type atom_data_type + !!================================================== + !! Contains information about the atoms (and maybe the cell...) of the system being calculated. + !!================================================== + real(kind=dp), allocatable :: pos_cart(:, :, :) + integer, allocatable :: species_num(:) + character(len=maxlen), allocatable :: label(:) + character(len=2), allocatable :: symbol(:) + integer :: num_atoms + integer :: num_species + end type atom_data_type + + ! plot.F90 and postw90/kpath + type kpoint_path_type + !!================================================== + !! Contains information that specifies the k-point path for plotting and other purposes. + !! Note: The length of bands_label and the second index of bands_spec_points is twice the + !! number of segments specified by the user. Each pair of special points defines a segment. + !!================================================== + integer num_points_first_segment + character(len=20), allocatable :: labels(:) + real(kind=dp), allocatable :: points(:, :) + end type kpoint_path_type + +end module w90_types diff --git a/src/utility.F90 b/src/utility.F90 index 87743874d..d82f8fac3 100644 --- a/src/utility.F90 +++ b/src/utility.F90 @@ -11,8 +11,13 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! w90_utility: blas wrappers and other basic routines ! +! ! +!------------------------------------------------------------! module w90_utility + !! Module contains lots of useful general routines use w90_constants, only: dp @@ -21,42 +26,44 @@ module w90_utility private - public :: utility_inv3 - public :: utility_inv2 - public :: utility_det3 - public :: utility_recip_lattice - public :: utility_metric - public :: utility_compar public :: utility_cart_to_frac + public :: utility_commutator_diag + public :: utility_compar + public :: utility_det3 + public :: utility_diagonalize public :: utility_frac_to_cart - public :: utility_string_to_coord + public :: utility_im_tr + public :: utility_im_tr_prod + public :: utility_inv2 + public :: utility_inv3 + public :: utility_inverse_mat public :: utility_lowercase - public :: utility_strip - public :: utility_zgemm - public :: utility_zgemm_new - public :: utility_zgemmm - public :: utility_translate_home - public :: utility_rotate - public :: utility_rotate_new public :: utility_matmul_diag - public :: utility_rotate_diag - public :: utility_commutator_diag + public :: utility_metric + public :: utility_recip_lattice + public :: utility_recip_lattice_base public :: utility_re_tr public :: utility_re_tr_prod - public :: utility_im_tr - public :: utility_im_tr_prod + public :: utility_rotate + public :: utility_rotate_diag + public :: utility_rotate_new + public :: utility_string_to_coord + public :: utility_strip + public :: utility_translate_home public :: utility_w0gauss public :: utility_w0gauss_vec public :: utility_wgauss public :: utility_zdotu - public :: utility_diagonalize + public :: utility_zgemm + public :: utility_zgemmm + public :: utility_zgemm_new contains - !=============================================================! + !================================================! subroutine utility_zgemm(c, a, transa, b, transb, n) - !=============================================================! - ! ! + !================================================! + ! !! Return matrix product of complex n x n matrices a and b: !! !! C = Op(A) Op(B) @@ -66,8 +73,8 @@ subroutine utility_zgemm(c, a, transa, b, transb, n) !! transa = 'C' ==> Op(A) = congj(transpose(A)) !! !! similarly for B - ! ! - !=============================================================! + ! + !================================================! use w90_constants, only: cmplx_0, cmplx_1 @@ -86,13 +93,13 @@ subroutine utility_zgemm(c, a, transa, b, transb, n) end subroutine utility_zgemm - !=================================================================== - function utility_det3(A) ! - !==================================================================! - ! ! - ! Return determinant of a 3x3 matrix A ! - ! ! - !=================================================================== + !================================================ + function utility_det3(A) + !================================================! + ! + ! Return determinant of a 3x3 matrix A + ! + !================================================ real(kind=dp), intent(in) :: a(3, 3) real(kind=dp) :: utility_det3 @@ -102,7 +109,7 @@ function utility_det3(A) ! return end function utility_det3 - !=============================================================! + !================================================! subroutine utility_zgemm_new(a, b, c, transa_opt, transb_opt) !=============================================================! ! ! @@ -156,7 +163,7 @@ subroutine utility_zgemm_new(a, b, c, transa_opt, transb_opt) call zgemm(transa, transb, m, n, k, cmplx_1, a, size(a, 1), b, size(b, 1), cmplx_0, c, m) end subroutine utility_zgemm_new - !=============================================================! + !================================================! function utility_zdotu(a, b) complex(kind=dp), intent(in), dimension(:) :: a, b complex(kind=dp) :: utility_zdotu @@ -164,19 +171,18 @@ function utility_zdotu(a, b) return end function utility_zdotu - !=============================================================! - subroutine utility_zgemmm(a, transa, b, transb, c, transc, & - prod1, eigval, prod2) - !===============================================================! - ! Returns the complex matrix-matrix-matrix product ! - ! --> prod1 = op(a).op(b).op(c), ! - ! where op(a/b/c) are defined according to transa/transb/transc ! - ! (see also documentation of utility_zgemm above) ! - ! ! - ! If eigval and prod2 are present, also ! - ! --> prod2 = op(a).diag(eigval).op(b).op(c) ! - ! is returned. ! - !===============================================================! + !================================================! + subroutine utility_zgemmm(a, transa, b, transb, c, transc, prod1, eigval, prod2) + !================================================! + ! Returns the complex matrix-matrix-matrix product + ! --> prod1 = op(a).op(b).op(c), + ! where op(a/b/c) are defined according to transa/transb/transc + ! (see also documentation of utility_zgemm above) + ! + ! If eigval and prod2 are present, also + ! --> prod2 = op(a).diag(eigval).op(b).op(c) + ! is returned. + !================================================! complex(kind=dp), dimension(:, :), intent(in) :: a, b, c character(len=1), intent(in) :: transa, transb, transc @@ -222,67 +228,48 @@ subroutine utility_zgemmm(a, transa, b, transb, c, transc, & end if end subroutine - !=================================================================== - subroutine utility_inv3(a, b, det) ! - !==================================================================! - ! ! + !================================================ + subroutine utility_inv3(a, b, det) + !================================================! + ! !! Return in b the adjoint of the 3x3 matrix a, and its !! determinant. - !! The inverse is defined as the adjoind divided by the + !! The inverse is defined as the adjoint divided by the !! determinant, so that inverse(a) = b/det - ! ! - !=================================================================== + ! + !================================================ implicit none real(kind=dp), intent(in) :: a(3, 3) real(kind=dp), intent(out) :: b(3, 3) real(kind=dp), intent(out) :: det - real(kind=dp):: work(6, 6) - integer :: i, j, k, l, ll, kk - - do i = 1, 2 - do j = 1, 2 - do k = 1, 3 - do l = 1, 3 - kk = 3*(i - 1) + k - ll = 3*(j - 1) + l - work(kk, ll) = a(k, l) - end do - end do - end do - end do + b(1, 1) = a(2, 2)*a(3, 3) - a(3, 2)*a(2, 3) + b(1, 2) = a(2, 3)*a(3, 1) - a(3, 3)*a(2, 1) + b(1, 3) = a(2, 1)*a(3, 2) - a(3, 1)*a(2, 2) + b(2, 1) = a(3, 2)*a(1, 3) - a(1, 2)*a(3, 3) + b(2, 2) = a(3, 3)*a(1, 1) - a(1, 3)*a(3, 1) + b(2, 3) = a(3, 1)*a(1, 2) - a(1, 1)*a(3, 2) + b(3, 1) = a(1, 2)*a(2, 3) - a(2, 2)*a(1, 3) + b(3, 2) = a(1, 3)*a(2, 1) - a(2, 3)*a(1, 1) + b(3, 3) = a(1, 1)*a(2, 2) - a(2, 1)*a(1, 2) - det = 0.0_dp - do i = 1, 3 - det = det + work(1, i)*work(2, i + 1)*work(3, i + 2) - end do - - do i = 4, 6 - det = det - work(1, i)*work(2, i - 1)*work(3, i - 2) - end do - - do j = 1, 3 - do i = 1, 3 - b(j, i) = (work(i + 1, j + 1)*work(i + 2, j + 2) - work(i + 1, j + 2) & - *work(i + 2, j + 1)) - end do - end do + det = a(1, 1)*b(1, 1) + a(1, 2)*b(1, 2) + a(1, 3)*b(1, 3) return end subroutine utility_inv3 - !=================================================================== - subroutine utility_inv2(a, b, det) ! - !==================================================================! - ! ! + !================================================ + subroutine utility_inv2(a, b, det) + !================================================! + ! !! Return in b the adjoint of the 2x2 matrix !! a, together with the determinant of a. !! The inverse is defined as the adjoind divided by the !! determinant, so that inverse(a) = b/det - ! ! - !=================================================================== + ! + !================================================ implicit none real(kind=dp), intent(in) :: a(2, 2) @@ -300,13 +287,34 @@ subroutine utility_inv2(a, b, det) ! end subroutine utility_inv2 - !=================================================================== - subroutine utility_recip_lattice(real_lat, recip_lat, volume) ! - !==================================================================! - ! ! + !================================================ + subroutine utility_inverse_mat(a, b) + !================================================! + ! + !! Return in b int inverse of a. Uses utility_inv3 + ! + !================================================ + + implicit none + real(kind=dp), intent(in) :: a(3, 3) + real(kind=dp), intent(out) :: b(3, 3) + + real(kind=dp) :: det + + call utility_inv3(a, b, det) + b = b/det + + return + + end subroutine utility_inverse_mat + + !================================================ + subroutine utility_recip_lattice_base(real_lat, recip_lat, volume) + !================================================! + ! !! Calculates the reciprical lattice vectors and the cell volume - ! ! - !=================================================================== + ! + !================================================ use w90_constants, only: dp, twopi, eps5 use w90_io, only: io_error @@ -316,38 +324,53 @@ subroutine utility_recip_lattice(real_lat, recip_lat, volume) ! real(kind=dp), intent(out) :: recip_lat(3, 3) real(kind=dp), intent(out) :: volume - recip_lat(1, 1) = real_lat(2, 2)*real_lat(3, 3) - real_lat(3, 2)*real_lat(2, 3) - recip_lat(1, 2) = real_lat(2, 3)*real_lat(3, 1) - real_lat(3, 3)*real_lat(2, 1) - recip_lat(1, 3) = real_lat(2, 1)*real_lat(3, 2) - real_lat(3, 1)*real_lat(2, 2) - recip_lat(2, 1) = real_lat(3, 2)*real_lat(1, 3) - real_lat(1, 2)*real_lat(3, 3) - recip_lat(2, 2) = real_lat(3, 3)*real_lat(1, 1) - real_lat(1, 3)*real_lat(3, 1) - recip_lat(2, 3) = real_lat(3, 1)*real_lat(1, 2) - real_lat(1, 1)*real_lat(3, 2) - recip_lat(3, 1) = real_lat(1, 2)*real_lat(2, 3) - real_lat(2, 2)*real_lat(1, 3) - recip_lat(3, 2) = real_lat(1, 3)*real_lat(2, 1) - real_lat(2, 3)*real_lat(1, 1) - recip_lat(3, 3) = real_lat(1, 1)*real_lat(2, 2) - real_lat(2, 1)*real_lat(1, 2) + call utility_inv3(real_lat, recip_lat, volume) + + if (abs(volume) > eps5) then + recip_lat = twopi*recip_lat/volume + volume = abs(volume) + endif + + return + + end subroutine utility_recip_lattice_base - volume = real_lat(1, 1)*recip_lat(1, 1) + & - real_lat(1, 2)*recip_lat(1, 2) + & - real_lat(1, 3)*recip_lat(1, 3) + subroutine utility_recip_lattice(real_lat, recip_lat, volume, stdout, seedname) ! + !================================================! + ! + !! Calculates the reciprical lattice vectors and the cell volume + !! Includes a check that the volume isn't almost 0 + !! Use the first time the lattice is read to check its sensible + ! + !================================================ + + use w90_constants, only: dp, twopi, eps5 + use w90_io, only: io_error + + implicit none + real(kind=dp), intent(in) :: real_lat(3, 3) + real(kind=dp), intent(out) :: recip_lat(3, 3) + real(kind=dp), intent(out) :: volume + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + + call utility_recip_lattice_base(real_lat, recip_lat, volume) if (abs(volume) < eps5) then - call io_error(' Found almost zero Volume in utility_recip_lattice') + call io_error(' Found almost zero Volume in utility_recip_lattice', stdout, seedname) end if - recip_lat = twopi*recip_lat/volume - volume = abs(volume) - return end subroutine utility_recip_lattice - !=================================================================== + !================================================ subroutine utility_compar(a, b, ifpos, ifneg) - !==================================================================! - ! ! + !================================================! + ! !! Compares two vectors - ! ! - !=================================================================== + ! + !================================================ use w90_constants, only: eps8 implicit none @@ -369,47 +392,42 @@ subroutine utility_compar(a, b, ifpos, ifneg) end subroutine utility_compar - !=================================================================== - subroutine utility_metric(real_lat, recip_lat, & - real_metric, recip_metric) - !==================================================================! - ! ! - !! Calculate the real and reciprical space metrics - ! ! - !=================================================================== + !================================================ + subroutine utility_metric(lattice, metric) + !================================================! + ! + !! Calculate the metric for a lattice + ! + !================================================ implicit none - real(kind=dp), intent(in) :: real_lat(3, 3) - real(kind=dp), intent(in) :: recip_lat(3, 3) - real(kind=dp), intent(out) :: real_metric(3, 3) - real(kind=dp), intent(out) :: recip_metric(3, 3) + real(kind=dp), intent(in) :: lattice(3, 3) + real(kind=dp), intent(out) :: metric(3, 3) integer :: i, j, l - real_metric = 0.0_dp; recip_metric = 0.0_dp + metric = 0.0_dp do j = 1, 3 do i = 1, j do l = 1, 3 - real_metric(i, j) = real_metric(i, j) + real_lat(i, l)*real_lat(j, l) - recip_metric(i, j) = recip_metric(i, j) + recip_lat(i, l)*recip_lat(j, l) + metric(i, j) = metric(i, j) + lattice(i, l)*lattice(j, l) enddo if (i .lt. j) then - real_metric(j, i) = real_metric(i, j) - recip_metric(j, i) = recip_metric(i, j) + metric(j, i) = metric(i, j) endif enddo enddo end subroutine utility_metric - !=================================================================== + !================================================ subroutine utility_frac_to_cart(frac, cart, real_lat) - !==================================================================! - ! ! + !================================================! + ! !! Convert from fractional to Cartesian coordinates - ! ! - !=================================================================== + ! + !================================================ implicit none real(kind=dp), intent(in) :: real_lat(3, 3) @@ -426,39 +444,39 @@ subroutine utility_frac_to_cart(frac, cart, real_lat) end subroutine utility_frac_to_cart - !=================================================================== - subroutine utility_cart_to_frac(cart, frac, recip_lat) - !==================================================================! - ! ! + !================================================ + subroutine utility_cart_to_frac(cart, frac, inv_lat) + !================================================! + ! !! Convert from Cartesian to fractional coordinates - ! ! - !=================================================================== + ! + !================================================ + use w90_constants, only: twopi + implicit none - real(kind=dp), intent(in) :: recip_lat(3, 3) + real(kind=dp), intent(in) :: inv_lat(3, 3) real(kind=dp), intent(out) :: frac(3) real(kind=dp), intent(in) :: cart(3) integer :: i do i = 1, 3 - frac(i) = recip_lat(i, 1)*cart(1) + recip_lat(i, 2)*cart(2) + recip_lat(i, 3)*cart(3) + frac(i) = inv_lat(i, 1)*cart(1) + inv_lat(i, 2)*cart(2) + inv_lat(i, 3)*cart(3) end do - frac = frac/twopi - return end subroutine utility_cart_to_frac - !=============================! + !================================================! function utility_strip(string)! - !=============================! - ! ! + !================================================! + ! !! Strips string of all blank spaces - ! ! - !=============================! + ! + !================================================! use w90_io, only: maxlen @@ -488,14 +506,14 @@ function utility_strip(string)! end function utility_strip - !=================================! + !================================================! function utility_lowercase(string)! - !=================================! - ! ! + !================================================! + ! !! Takes a string and converts to !! lowercase characters - ! ! - !=================================! + ! + !================================================! use w90_io, only: maxlen @@ -524,20 +542,22 @@ function utility_lowercase(string)! end function utility_lowercase - !====================================================! - subroutine utility_string_to_coord(string_tmp, outvec)! - !====================================================! - ! ! + !================================================! + subroutine utility_string_to_coord(string_tmp, outvec, stdout, seedname)! + !================================================! + ! !! Takes a string in the form 0.0,1.0,0.5 !! and returns an array of the real num - ! ! - !====================================================! + ! + !================================================! use w90_io, only: io_error, maxlen implicit none + integer, intent(in) :: stdout character(len=maxlen), intent(in) :: string_tmp real(kind=dp), intent(out) :: outvec(3) + character(len=50), intent(in) :: seedname integer :: pos character(len=maxlen) :: ctemp @@ -545,7 +565,8 @@ subroutine utility_string_to_coord(string_tmp, outvec)! ctemp = string_tmp pos = index(ctemp, ',') - if (pos <= 0) call io_error('utility_string_to_coord: Problem reading string into real number '//trim(string_tmp)) + if (pos <= 0) & + call io_error('utility_string_to_coord: Problem reading string into real number '//trim(string_tmp), stdout, seedname) ctemp2 = ctemp(1:pos - 1) read (ctemp2, *, err=100, end=100) outvec(1) ctemp = ctemp(pos + 1:) @@ -557,57 +578,25 @@ subroutine utility_string_to_coord(string_tmp, outvec)! return -100 call io_error('utility_string_to_coord: Problem reading string into real number '//trim(string_tmp)) +100 call io_error('utility_string_to_coord: Problem reading string into real number '//trim(string_tmp), stdout, seedname) end subroutine utility_string_to_coord -!~ !===========================================! -!~ function utility_string_to_coord(string_tmp)! -!~ !===========================================! -!~ ! ! -!~ ! Takes a string in the form 0.0,1.0,0.5 ! -!~ ! and returns an array of the real num ! -!~ ! ! -!~ !===========================================! -!~ -!~ implicit none -!~ -!~ character(len=80), intent(in) :: string_tmp -!~ real(kind=dp) :: utility_string_to_coord(3) -!~ -!~ integer :: pos,pos2 -!~ character(len=80) :: ctemp -!~ character(len=80) :: ctemp2 -!~ -!~ -!~ ctemp=string_tmp -!~ pos2=index(ctemp,',') -!~ ctemp2=ctemp(1:pos2-1) -!~ read(ctemp2,*) utility_string_to_coord(1) -!~ ctemp=ctemp(pos2+1:) -!~ pos2=index(ctemp,',') -!~ ctemp2=ctemp(1:pos2-1) -!~ read(ctemp2,*) utility_string_to_coord(2) -!~ ctemp=ctemp(pos2+1:) -!~ read(ctemp,*) utility_string_to_coord(3) -!~ -!~ end function utility_string_to_coord - - !========================================================! - subroutine utility_translate_home(vec, real_lat, recip_lat) - !========================================================! - ! ! + !================================================! + subroutine utility_translate_home(vec, real_lat) + !================================================! + ! !! Translate a vector to the home unit cell - ! ! - !========================================================! + ! + !================================================! implicit none real(kind=dp), intent(inout) :: vec(3) real(kind=dp), intent(in) :: real_lat(3, 3) - real(kind=dp), intent(in) :: recip_lat(3, 3) ! <<>> + real(kind=dp) :: recip_lat(3, 3), volume integer :: ind real(kind=dp) :: r_home(3), r_frac(3) real(kind=dp) :: shift @@ -615,6 +604,7 @@ subroutine utility_translate_home(vec, real_lat, recip_lat) r_home = 0.0_dp; r_frac = 0.0_dp ! Cartesian --> fractional + call utility_recip_lattice_base(real_lat, recip_lat, volume) call utility_cart_to_frac(vec, r_frac, recip_lat) ! Rationalise to interval [0,1] do ind = 1, 3 @@ -635,22 +625,24 @@ subroutine utility_translate_home(vec, real_lat, recip_lat) return end subroutine utility_translate_home - !============================================================! - subroutine utility_diagonalize(mat, dim, eig, rot) - !============================================================! - ! ! + !================================================! + subroutine utility_diagonalize(mat, dim, eig, rot, stdout, seedname) + !================================================! + ! !! Diagonalize the dim x dim hermitian matrix 'mat' and !! return the eigenvalues 'eig' and the unitary rotation 'rot' - ! ! - !============================================================! + ! + !================================================! use w90_constants, only: dp, cmplx_0 - use w90_io, only: io_error, stdout + use w90_io, only: io_error integer, intent(in) :: dim + integer, intent(in) :: stdout complex(kind=dp), intent(in) :: mat(dim, dim) real(kind=dp), intent(out) :: eig(dim) complex(kind=dp), intent(out) :: rot(dim, dim) + character(len=50), intent(in) :: seedname complex(kind=dp) :: mat_pack((dim*(dim + 1))/2), cwork(2*dim) real(kind=dp) :: rwork(7*dim) @@ -667,23 +659,23 @@ subroutine utility_diagonalize(mat, dim, eig, rot) if (info < 0) then write (stdout, '(a,i3,a)') 'THE ', -info, & ' ARGUMENT OF ZHPEVX HAD AN ILLEGAL VALUE' - call io_error('Error in utility_diagonalize') + call io_error('Error in utility_diagonalize', stdout, seedname) endif if (info > 0) then write (stdout, '(i3,a)') info, ' EIGENVECTORS FAILED TO CONVERGE' - call io_error('Error in utility_diagonalize') + call io_error('Error in utility_diagonalize', stdout, seedname) endif end subroutine utility_diagonalize - !===========================================================! + !================================================! function utility_rotate(mat, rot, dim) - !==========================================================! - ! ! + !================================================! + ! !! Rotates the dim x dim matrix 'mat' according to !! (rot)^dagger.mat.rot, where 'rot' is a unitary matrix - ! ! - !===========================================================! + ! + !================================================! use w90_constants, only: dp @@ -696,17 +688,17 @@ function utility_rotate(mat, rot, dim) end function utility_rotate - !===========================================================! + !================================================! subroutine utility_rotate_new(mat, rot, N, reverse) - !==============================================================! - ! ! - ! Rotates the N x N matrix 'mat' according to ! - ! * (rot)^dagger.mat.rot (reverse = .false. or not present) OR ! - ! * rot.mat.(rot)^dagger (reverse = .true.), ! - ! where 'rot' is a unitary matrix. ! - ! The matrix 'mat' is overwritten. ! - ! ! - !==============================================================! + !================================================! + ! + ! Rotates the N x N matrix 'mat' according to + ! * (rot)^dagger.mat.rot (reverse = .false. or not present) OR + ! * rot.mat.(rot)^dagger (reverse = .true.), + ! where 'rot' is a unitary matrix. + ! The matrix 'mat' is overwritten. + ! + !================================================! use w90_constants, only: dp @@ -733,13 +725,13 @@ subroutine utility_rotate_new(mat, rot, N, reverse) end subroutine utility_rotate_new - !===========================================================! + !================================================! function utility_matmul_diag(mat1, mat2, dim) - !===========================================================! - ! ! + !================================================! + ! !! Computes the diagonal elements of the matrix mat1.mat2 - ! ! - !===========================================================! + ! + !================================================! use w90_constants, only: dp, cmplx_0 @@ -759,15 +751,15 @@ function utility_matmul_diag(mat1, mat2, dim) end function utility_matmul_diag - !===========================================================! + !================================================! function utility_rotate_diag(mat, rot, dim) - !===========================================================! - ! ! + !================================================! + ! !! Rotates the dim x dim matrix 'mat' according to !! (rot)^dagger.mat.rot, where 'rot' is a unitary matrix. !! Computes only the diagonal elements of rotated matrix. - ! ! - !===========================================================! + ! + !================================================! use w90_constants, only: dp @@ -782,14 +774,14 @@ function utility_rotate_diag(mat, rot, dim) end function utility_rotate_diag - !===========================================================! + !================================================! function utility_commutator_diag(mat1, mat2, dim) - !===========================================================! - ! ! + !================================================! + ! !! Computes diagonal elements of !! [mat1,mat2]=mat1.mat2-mat2.mat1 - ! ! - !===========================================================! + ! + !================================================! use w90_constants, only: dp @@ -802,13 +794,13 @@ function utility_commutator_diag(mat1, mat2, dim) end function utility_commutator_diag - !===================================================! + !================================================! function utility_re_tr_prod(a, b) !================================================! - ! ! - ! Return Re(tr(a.b)), i.e. the real part of the ! - ! trace of the matrix product of a and b. ! - ! ! + ! + ! Return Re(tr(a.b)), i.e. the real part of the + ! trace of the matrix product of a and b. + ! !================================================! use w90_constants, only: dp, cmplx_0, cmplx_i @@ -829,14 +821,14 @@ function utility_re_tr_prod(a, b) utility_re_tr_prod = s end function - !===================================================! + !================================================! function utility_im_tr_prod(a, b) - !====================================================! - ! ! - ! Return Im(tr(a.b)), i.e. the imaginary part of the ! - ! trace of the matrix product of a and b. ! - ! ! - !====================================================! + !================================================! + ! + ! Return Im(tr(a.b)), i.e. the imaginary part of the + ! trace of the matrix product of a and b. + ! + !================================================! use w90_constants, only: dp, cmplx_0, cmplx_i complex(kind=dp), dimension(:, :), intent(in) :: a, b @@ -857,13 +849,13 @@ function utility_im_tr_prod(a, b) utility_im_tr_prod = s end function - !===================================================! + !================================================! function utility_re_tr(mat) - !========================! - ! ! + !================================================! + ! !! Real part of the trace - ! ! - !========================! + ! + !================================================! use w90_constants, only: dp, cmplx_0, cmplx_i @@ -884,11 +876,11 @@ function utility_re_tr(mat) end function utility_re_tr function utility_im_tr(mat) - !=============================! - ! ! + !================================================! + ! !! Imaginary part of the trace - ! ! - !=============================! + ! + !================================================! use w90_constants, only: dp, cmplx_0 @@ -924,15 +916,15 @@ function utility_wgauss(x, n) use w90_constants, only: dp, pi implicit none + + ! arguments real(kind=dp) :: utility_wgauss, x !! output: the value of the function !! input: the argument of the function integer :: n !! input: the order of the function - ! - ! the local variables - ! + ! local variables real(kind=dp) :: a, hp, arg, hd, xp ! the coefficient a_n ! the hermitean function @@ -942,7 +934,7 @@ function utility_wgauss(x, n) integer :: i, ni ! counter on the n indices ! counter on 2n -! real(kind=dp), external :: gauss_freq, qe_erf + !real(kind=dp), external :: gauss_freq, qe_erf real(kind=dp), parameter :: maxarg = 200.0_dp ! maximum value for the argument of the exponential @@ -986,7 +978,7 @@ function utility_wgauss(x, n) return end function utility_wgauss - function utility_w0gauss(x, n) + function utility_w0gauss(x, n, stdout, seedname) !----------------------------------------------------------------------- ! !! the derivative of utility_wgauss: an approximation to the delta function @@ -1000,16 +992,20 @@ function utility_w0gauss(x, n) ! use w90_constants, only: dp, pi use w90_io, only: io_error + implicit none - real(kind=dp) :: utility_w0gauss, x + + ! arguments + real(kind=dp) :: utility_w0gauss !! output: the value of the function + real(kind=dp), intent(in) :: x !! input: the point where to compute the function - - integer :: n + integer, intent(in) :: n !! input: the order of the smearing function - ! - ! here the local variables - ! + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + + ! local variables real(kind=dp) :: a, arg, hp, hd, sqrtpm1 ! the coefficients a_n ! the argument of the exponential @@ -1043,7 +1039,7 @@ function utility_w0gauss(x, n) endif if (n .gt. 10 .or. n .lt. 0) & - call io_error('utility_w0gauss higher order smearing is untested and unstable') + call io_error('utility_w0gauss higher order smearing is untested and unstable', stdout, seedname) ! Methfessel-Paxton arg = min(200.0_dp, x**2) @@ -1064,7 +1060,7 @@ function utility_w0gauss(x, n) return end function utility_w0gauss - function utility_w0gauss_vec(x, n) result(res) + function utility_w0gauss_vec(x, n, stdout, seedname) result(res) !----------------------------------------------------------------------- ! Stepan Tsirkin: a vectorized version of the outine, gets x as an array. ! @@ -1079,18 +1075,20 @@ function utility_w0gauss_vec(x, n) result(res) ! use w90_constants, only: dp, pi use w90_io, only: io_error + implicit none - real(kind=dp), intent(in) :: x(:) - real(kind=dp), allocatable :: res(:), arg(:) + ! arguments + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + real(kind=dp), intent(in) :: x(:) + real(kind=dp), allocatable :: res(:), arg(:) !! output: the value of the function !! input: the point where to compute the function - integer :: n !! input: the order of the smearing function - ! - ! here the local variables - ! + + ! local variables real(kind=dp) :: sqrtpm1 allocate (res(size(x))) @@ -1098,22 +1096,22 @@ function utility_w0gauss_vec(x, n) result(res) sqrtpm1 = 1.0_dp/sqrt(pi) if (n .eq. -99) then - call io_error('utility_w0gauss_vec not implemented for n == 99') + call io_error('utility_w0gauss_vec not implemented for n == 99', stdout, seedname) endif ! cold smearing (Marzari-Vanderbilt) if (n .eq. -1) then - call io_error('utility_w0gauss_vec not implemented for n == -1') + call io_error('utility_w0gauss_vec not implemented for n == -1', stdout, seedname) endif if (n .gt. 10 .or. n .lt. 0) & - call io_error('utility_w0gauss higher order smearing is untested and unstable') + call io_error('utility_w0gauss higher order smearing is untested and unstable', stdout, seedname) ! Methfessel-Paxton arg = min(200.0_dp, x**2) res = exp(-arg)*sqrtpm1 if (n .eq. 0) return - call io_error('utility_w0gauss_vec not implemented for n >0 ') + call io_error('utility_w0gauss_vec not implemented for n >0 ', stdout, seedname) return end function utility_w0gauss_vec diff --git a/src/w90chk2chk.F90 b/src/w90chk2chk.F90 index cb2af03ea..7c067de4a 100644 --- a/src/w90chk2chk.F90 +++ b/src/w90chk2chk.F90 @@ -11,19 +11,118 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! w90chk2chk: checkpoint file conversion utility ! +! ! +!------------------------------------------------------------! + +module w90chk_parameters + + use w90_types + + implicit none + + public + + type(wannier_data_type), save :: wannier_data + type(kmesh_info_type), save :: kmesh_info + type(dis_manifold_type), save :: dis_manifold + + integer, allocatable, save :: exclude_bands(:) + real(kind=dp), allocatable, save :: kpt_latt(:, :) + logical, save :: have_disentangled + integer, save :: num_exclude_bands + integer, save :: num_kpts + + integer, save :: num_bands + !! Number of bands + + integer, save :: num_wann + !! number of wannier functions + + ! a_matrix and m_matrix_orig can be calculated internally from bloch states + ! or read in from an ab-initio grid + ! a_matrix = projection of trial orbitals on bloch states + ! m_matrix_orig = overlap of bloch states + real(kind=dp), allocatable, save :: eigval(:, :) + + !BGS u_matrix_opt in postw90 only for generation of v_matrix + ! u_matrix_opt gives the num_wann dimension optimal subspace from the + ! original bloch states + complex(kind=dp), allocatable, save :: u_matrix_opt(:, :, :) + + ! u_matrix gives the unitary rotations from the optimal subspace to the + ! optimally smooth states. + ! m_matrix we store here, becuase it is needed for restart of wannierise + complex(kind=dp), allocatable, save :: u_matrix(:, :, :) + + integer, save :: mp_grid(3) + !! Dimensions of the Monkhorst-Pack grid + + integer, save :: num_proj + !BGS used by stuff in driver/kmesh/wannier - keep separate or duplicate? + + real(kind=dp), save :: real_lattice(3, 3) + + !parameters derived from input + real(kind=dp), save :: recip_lattice(3, 3) + + type(kpoint_path_type), save :: spec_points + +end module w90chk_parameters + +module wannchk_data + + use w90_constants, only: dp + use w90_io, only: maxlen + + use w90_wannier90_types + + implicit none + + public + + type(w90_calculation_type), save :: w90_calcs + !type(plot_type), save :: plot + !type(disentangle_type), save :: dis_data + ! RS: symmetry-adapted Wannier functions + logical, save :: lsitesymmetry = .false. + real(kind=dp), save :: symmetrize_eps = 1.d-3 + type(fermi_surface_plot_type), save :: fermi_surface_data + type(transport_type), save :: tran + type(select_projection_type), save :: select_proj + + logical, save :: eig_found + + ! a_matrix, m_matrix in disentangle and overlap + complex(kind=dp), allocatable, save :: a_matrix(:, :, :) + complex(kind=dp), allocatable, save :: m_matrix_orig(:, :, :, :) + complex(kind=dp), allocatable, save :: m_matrix_orig_local(:, :, :, :) + ! disentangle, hamiltonian, overlap and wannierise + complex(kind=dp), allocatable, save :: m_matrix(:, :, :, :) + ! in disentangle and overlap + complex(kind=dp), allocatable, save :: m_matrix_local(:, :, :, :) + + real(kind=dp), save :: omega_invariant + +end module wannchk_data module w90_conv !! Module to convert checkpoint files from formatted to unformmated !! and vice versa - useful for switching between computers use w90_constants, only: dp - use w90_io, only: stdout, io_error, seedname + use w90_io, only: io_error implicit none logical, save :: export_flag character(len=33), save :: header contains - subroutine print_usage() + subroutine print_usage(stdout) + + implicit none + + integer, intent(in) :: stdout !! Writes the usage of the program to stdout write (stdout, '(A)') "Usage:" write (stdout, '(A)') " w90chk2chk.x ACTION [SEEDNAME]" @@ -40,10 +139,13 @@ subroutine print_usage() write (stdout, '(A)') " The seedname.chk.fmt file is read and the seedname.chk file is generated." end subroutine print_usage - subroutine conv_get_seedname + subroutine conv_get_seedname(stdout, seedname) !! Set the seedname from the command line implicit none + integer, intent(in) :: stdout + character(len=50), intent(inout) :: seedname + integer :: num_arg character(len=50) :: ctemp @@ -53,8 +155,8 @@ subroutine conv_get_seedname elseif (num_arg == 2) then call get_command_argument(2, seedname) else - call print_usage - call io_error('Wrong command line arguments, see logfile for usage') + call print_usage(stdout) + call io_error('Wrong command line arguments, see logfile for usage', stdout, seedname) end if ! If on the command line the whole seedname.win was passed, I strip the last ".win" @@ -75,24 +177,29 @@ subroutine conv_get_seedname export_flag = .true. else write (stdout, '(A)') 'Wrong command line action: '//trim(ctemp) - call print_usage - call io_error('Wrong command line arguments, see logfile for usage') + call print_usage(stdout) + call io_error('Wrong command line arguments, see logfile for usage', stdout, seedname) end if end subroutine conv_get_seedname - !=======================================! - subroutine conv_read_chkpt() - !=======================================! + !================================================! + subroutine conv_read_chkpt(checkpoint, stdout, seedname) + !================================================! + ! !! Read formatted checkpoint file - !=======================================! + ! + !================================================! use w90_constants, only: eps6 - use w90_io, only: io_error, io_file_unit, stdout, seedname - use w90_parameters + use w90_io, only: io_error, io_file_unit + use w90chk_parameters + use wannchk_data implicit none - + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + character(len=*), intent(out) :: checkpoint integer :: chk_unit, i, j, k, l, nkp, ierr write (stdout, '(1x,3a)') 'Reading information from file ', trim(seedname), '.chk :' @@ -109,10 +216,10 @@ subroutine conv_read_chkpt() write (stdout, '(a,i0)') "Number of bands: ", num_bands read (chk_unit) num_exclude_bands ! Number of excluded bands if (num_exclude_bands < 0) then - call io_error('Invalid value for num_exclude_bands') + call io_error('Invalid value for num_exclude_bands', stdout, seedname) endif allocate (exclude_bands(num_exclude_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating exclude_bands in conv_read_chkpt') + if (ierr /= 0) call io_error('Error allocating exclude_bands in conv_read_chkpt', stdout, seedname) read (chk_unit) (exclude_bands(i), i=1, num_exclude_bands) ! Excluded bands write (stdout, '(a)', advance='no') "Excluded bands: " if (num_exclude_bands == 0) then @@ -133,12 +240,12 @@ subroutine conv_read_chkpt() write (stdout, '(a)') "mp_grid: read." if (.not. allocated(kpt_latt)) then allocate (kpt_latt(3, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating kpt_latt in conv_read_chkpt') + if (ierr /= 0) call io_error('Error allocating kpt_latt in conv_read_chkpt', stdout, seedname) endif read (chk_unit) ((kpt_latt(i, nkp), i=1, 3), nkp=1, num_kpts) write (stdout, '(a)') "kpt_latt: read." - read (chk_unit) nntot ! nntot - write (stdout, '(a,I0)') "nntot:", nntot + read (chk_unit) kmesh_info%nntot ! nntot + write (stdout, '(a,I0)') "nntot:", kmesh_info%nntot read (chk_unit) num_wann ! num_wann write (stdout, '(a,I0)') "num_wann:", num_wann @@ -155,25 +262,25 @@ subroutine conv_read_chkpt() write (stdout, '(a)') "omega_invariant: read." ! lwindow - if (.not. allocated(lwindow)) then - allocate (lwindow(num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating lwindow in conv_read_chkpt') + if (.not. allocated(dis_manifold%lwindow)) then + allocate (dis_manifold%lwindow(num_bands, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating lwindow in conv_read_chkpt', stdout, seedname) endif - read (chk_unit, err=122) ((lwindow(i, nkp), i=1, num_bands), nkp=1, num_kpts) + read (chk_unit, err=122) ((dis_manifold%lwindow(i, nkp), i=1, num_bands), nkp=1, num_kpts) write (stdout, '(a)') "lwindow: read." ! ndimwin - if (.not. allocated(ndimwin)) then - allocate (ndimwin(num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating ndimwin in conv_read_chkpt') + if (.not. allocated(dis_manifold%ndimwin)) then + allocate (dis_manifold%ndimwin(num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating ndimwin in conv_read_chkpt', stdout, seedname) endif - read (chk_unit, err=123) (ndimwin(nkp), nkp=1, num_kpts) + read (chk_unit, err=123) (dis_manifold%ndimwin(nkp), nkp=1, num_kpts) write (stdout, '(a)') "ndimwin: read." ! U_matrix_opt if (.not. allocated(u_matrix_opt)) then allocate (u_matrix_opt(num_bands, num_wann, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating u_matrix_opt in conv_read_chkpt') + if (ierr /= 0) call io_error('Error allocating u_matrix_opt in conv_read_chkpt', stdout, seedname) endif read (chk_unit, err=124) (((u_matrix_opt(i, j, nkp), i=1, num_bands), j=1, num_wann), nkp=1, num_kpts) write (stdout, '(a)') "U_matrix_opt: read." @@ -185,33 +292,33 @@ subroutine conv_read_chkpt() ! U_matrix if (.not. allocated(u_matrix)) then allocate (u_matrix(num_wann, num_wann, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating u_matrix in conv_read_chkpt') + if (ierr /= 0) call io_error('Error allocating u_matrix in conv_read_chkpt', stdout, seedname) endif read (chk_unit, err=125) (((u_matrix(i, j, k), i=1, num_wann), j=1, num_wann), k=1, num_kpts) write (stdout, '(a)') "U_matrix: read." ! M_matrix if (.not. allocated(m_matrix)) then - allocate (m_matrix(num_wann, num_wann, nntot, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating m_matrix in conv_read_chkpt') + allocate (m_matrix(num_wann, num_wann, kmesh_info%nntot, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating m_matrix in conv_read_chkpt', stdout, seedname) endif - read (chk_unit, err=126) ((((m_matrix(i, j, k, l), i=1, num_wann), j=1, num_wann), k=1, nntot), l=1, num_kpts) + read (chk_unit, err=126) ((((m_matrix(i, j, k, l), i=1, num_wann), j=1, num_wann), k=1, kmesh_info%nntot), l=1, num_kpts) write (stdout, '(a)') "M_matrix: read." ! wannier_centres - if (.not. allocated(wannier_centres)) then - allocate (wannier_centres(3, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating wannier_centres in conv_read_chkpt') + if (.not. allocated(wannier_data%centres)) then + allocate (wannier_data%centres(3, num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error allocating wannier_centres in conv_read_chkpt', stdout, seedname) end if - read (chk_unit, err=127) ((wannier_centres(i, j), i=1, 3), j=1, num_wann) + read (chk_unit, err=127) ((wannier_data%centres(i, j), i=1, 3), j=1, num_wann) write (stdout, '(a)') "wannier_centres: read." ! wannier spreads - if (.not. allocated(wannier_spreads)) then - allocate (wannier_spreads(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating wannier_centres in conv_read_chkpt') + if (.not. allocated(wannier_data%spreads)) then + allocate (wannier_data%spreads(num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error allocating wannier_centres in conv_read_chkpt', stdout, seedname) end if - read (chk_unit, err=128) (wannier_spreads(i), i=1, num_wann) + read (chk_unit, err=128) (wannier_data%spreads(i), i=1, num_wann) write (stdout, '(a)') "wannier_spreads: read." close (chk_unit) @@ -220,28 +327,35 @@ subroutine conv_read_chkpt() return -121 call io_error('Error opening '//trim(seedname)//'.chk in conv_read_chkpt') -122 call io_error('Error reading lwindow from '//trim(seedname)//'.chk in conv_read_chkpt') -123 call io_error('Error reading ndimwin from '//trim(seedname)//'.chk in conv_read_chkpt') -124 call io_error('Error reading u_matrix_opt from '//trim(seedname)//'.chk in conv_read_chkpt') -125 call io_error('Error reading u_matrix from '//trim(seedname)//'.chk in conv_read_chkpt') -126 call io_error('Error reading m_matrix from '//trim(seedname)//'.chk in conv_read_chkpt') -127 call io_error('Error reading wannier_centres from '//trim(seedname)//'.chk in conv_read_chkpt') -128 call io_error('Error reading wannier_spreads from '//trim(seedname)//'.chk in conv_read_chkpt') +121 call io_error('Error opening '//trim(seedname)//'.chk in conv_read_chkpt', stdout, seedname) +122 call io_error('Error reading lwindow from '//trim(seedname)//'.chk in conv_read_chkpt', stdout, seedname) +123 call io_error('Error reading ndimwin from '//trim(seedname)//'.chk in conv_read_chkpt', stdout, seedname) +124 call io_error('Error reading u_matrix_opt from '//trim(seedname)//'.chk in conv_read_chkpt', stdout, seedname) +125 call io_error('Error reading u_matrix from '//trim(seedname)//'.chk in conv_read_chkpt', stdout, seedname) +126 call io_error('Error reading m_matrix from '//trim(seedname)//'.chk in conv_read_chkpt', stdout, seedname) +127 call io_error('Error reading wannier_centres from '//trim(seedname)//'.chk in conv_read_chkpt', stdout, seedname) +128 call io_error('Error reading wannier_spreads from '//trim(seedname)//'.chk in conv_read_chkpt', stdout, seedname) end subroutine conv_read_chkpt - subroutine conv_read_chkpt_fmt() - !=======================================! + subroutine conv_read_chkpt_fmt(checkpoint, stdout, seedname) + !================================================! + ! !! Read formatted checkpoint file - !=======================================! + ! + !================================================! use w90_constants, only: eps6 - use w90_io, only: io_error, io_file_unit, stdout, seedname - use w90_parameters + use w90_io, only: io_error, io_file_unit + use w90chk_parameters + use wannchk_data implicit none + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + character(len=*), intent(out) :: checkpoint + integer :: chk_unit, i, j, k, l, nkp, ierr, idum character(len=30) :: cdum real(kind=dp) :: rreal, rimag @@ -260,10 +374,10 @@ subroutine conv_read_chkpt_fmt() write (stdout, '(a,i0)') "Number of bands: ", num_bands read (chk_unit, *) num_exclude_bands ! Number of excluded bands if (num_exclude_bands < 0) then - call io_error('Invalid value for num_exclude_bands') + call io_error('Invalid value for num_exclude_bands', stdout, seedname) endif allocate (exclude_bands(num_exclude_bands), stat=ierr) - if (ierr /= 0) call io_error('Error allocating exclude_bands in conv_read_chkpt_fmt') + if (ierr /= 0) call io_error('Error allocating exclude_bands in conv_read_chkpt_fmt', stdout, seedname) do i = 1, num_exclude_bands read (chk_unit, *) exclude_bands(i) ! Excluded bands end do @@ -286,14 +400,14 @@ subroutine conv_read_chkpt_fmt() write (stdout, '(a)') "mp_grid: read." if (.not. allocated(kpt_latt)) then allocate (kpt_latt(3, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating kpt_latt in conv_read_chkpt_fmt') + if (ierr /= 0) call io_error('Error allocating kpt_latt in conv_read_chkpt_fmt', stdout, seedname) endif do nkp = 1, num_kpts read (chk_unit, *, err=115) (kpt_latt(i, nkp), i=1, 3) end do write (stdout, '(a)') "kpt_latt: read." - read (chk_unit, *) nntot ! nntot - write (stdout, '(a,I0)') "nntot:", nntot + read (chk_unit, *) kmesh_info%nntot ! nntot + write (stdout, '(a,I0)') "nntot:", kmesh_info%nntot read (chk_unit, *) num_wann ! num_wann write (stdout, '(a,I0)') "num_wann:", num_wann @@ -308,7 +422,7 @@ subroutine conv_read_chkpt_fmt() have_disentangled = .false. else write (cdum, '(I0)') idum - call io_error('Error reading formatted chk: have_distenangled should be 0 or 1, it is instead '//cdum) + call io_error('Error reading formatted chk: have_distenangled should be 0 or 1, it is instead '//cdum, stdout, seedname) end if if (have_disentangled) then @@ -318,39 +432,39 @@ subroutine conv_read_chkpt_fmt() write (stdout, '(a)') "omega_invariant: read." ! lwindow - if (.not. allocated(lwindow)) then - allocate (lwindow(num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating lwindow in conv_read_chkpt_fmt') + if (.not. allocated(dis_manifold%lwindow)) then + allocate (dis_manifold%lwindow(num_bands, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating lwindow in conv_read_chkpt_fmt', stdout, seedname) endif do nkp = 1, num_kpts do i = 1, num_bands read (chk_unit, *) idum if (idum == 1) then - lwindow(i, nkp) = .true. + dis_manifold%lwindow(i, nkp) = .true. elseif (idum == 0) then - lwindow(i, nkp) = .false. + dis_manifold%lwindow(i, nkp) = .false. else write (cdum, '(I0)') idum - call io_error('Error reading formatted chk: lwindow(i,nkp) should be 0 or 1, it is instead '//cdum) + call io_error('Error reading formatted chk: lwindow(i,nkp) should be 0 or 1, it is instead '//cdum, stdout, seedname) end if end do end do write (stdout, '(a)') "lwindow: read." ! ndimwin - if (.not. allocated(ndimwin)) then - allocate (ndimwin(num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating ndimwin in conv_read_chkpt_fmt') + if (.not. allocated(dis_manifold%ndimwin)) then + allocate (dis_manifold%ndimwin(num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating ndimwin in conv_read_chkpt_fmt', stdout, seedname) endif do nkp = 1, num_kpts - read (chk_unit, *, err=123) ndimwin(nkp) + read (chk_unit, *, err=123) dis_manifold%ndimwin(nkp) end do write (stdout, '(a)') "ndimwin: read." ! U_matrix_opt if (.not. allocated(u_matrix_opt)) then allocate (u_matrix_opt(num_bands, num_wann, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating u_matrix_opt in conv_read_chkpt_fmt') + if (ierr /= 0) call io_error('Error allocating u_matrix_opt in conv_read_chkpt_fmt', stdout, seedname) endif do nkp = 1, num_kpts do j = 1, num_wann @@ -369,7 +483,7 @@ subroutine conv_read_chkpt_fmt() ! U_matrix if (.not. allocated(u_matrix)) then allocate (u_matrix(num_wann, num_wann, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating u_matrix in conv_read_chkpt_fmt') + if (ierr /= 0) call io_error('Error allocating u_matrix in conv_read_chkpt_fmt', stdout, seedname) endif do k = 1, num_kpts do j = 1, num_wann @@ -383,11 +497,11 @@ subroutine conv_read_chkpt_fmt() ! M_matrix if (.not. allocated(m_matrix)) then - allocate (m_matrix(num_wann, num_wann, nntot, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating m_matrix in conv_read_chkpt_fmt') + allocate (m_matrix(num_wann, num_wann, kmesh_info%nntot, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating m_matrix in conv_read_chkpt_fmt', stdout, seedname) endif do l = 1, num_kpts - do k = 1, nntot + do k = 1, kmesh_info%nntot do j = 1, num_wann do i = 1, num_wann read (chk_unit, *, err=124) rreal, rimag @@ -399,22 +513,22 @@ subroutine conv_read_chkpt_fmt() write (stdout, '(a)') "M_matrix: read." ! wannier_centres - if (.not. allocated(wannier_centres)) then - allocate (wannier_centres(3, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating wannier_centres in conv_read_chkpt_fmt') + if (.not. allocated(wannier_data%centres)) then + allocate (wannier_data%centres(3, num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error allocating wannier_centres in conv_read_chkpt_fmt', stdout, seedname) end if do j = 1, num_wann - read (chk_unit, *, err=127) (wannier_centres(i, j), i=1, 3) + read (chk_unit, *, err=127) (wannier_data%centres(i, j), i=1, 3) end do write (stdout, '(a)') "wannier_centres: read." ! wannier spreads - if (.not. allocated(wannier_spreads)) then - allocate (wannier_spreads(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating wannier_centres in conv_read_chkpt_fmt') + if (.not. allocated(wannier_data%spreads)) then + allocate (wannier_data%spreads(num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error allocating wannier_centres in conv_read_chkpt_fmt', stdout, seedname) end if do i = 1, num_wann - read (chk_unit, *, err=128) wannier_spreads(i) + read (chk_unit, *, err=128) wannier_data%spreads(i) end do write (stdout, '(a)') "wannier_spreads: read." @@ -424,28 +538,35 @@ subroutine conv_read_chkpt_fmt() return -115 call io_error('Error reading variable from '//trim(seedname)//'.chk.fmt in conv_read_chkpt_fmt') -121 call io_error('Error opening '//trim(seedname)//'.chk.fmt in conv_read_chkpt_fmt') -122 call io_error('Error reading lwindow from '//trim(seedname)//'.chk.fmt in conv_read_chkpt_fmt') -123 call io_error('Error reading ndimwin from '//trim(seedname)//'.chk.fmt in conv_read_chkpt_fmt') -124 call io_error('Error reading u_matrix_opt from '//trim(seedname)//'.chk.fmt in conv_read_chkpt_fmt') -125 call io_error('Error reading u_matrix from '//trim(seedname)//'.chk.fmt in conv_read_chkpt_fmt') -126 call io_error('Error reading m_matrix from '//trim(seedname)//'.chk.fmt in conv_read_chkpt_fmt') -127 call io_error('Error reading wannier_centres from '//trim(seedname)//'.chk.fmt in conv_read_chkpt_fmt') -128 call io_error('Error reading wannier_spreads from '//trim(seedname)//'.chk.fmt in conv_read_chkpt_fmt') +115 call io_error('Error reading variable from '//trim(seedname)//'.chk.fmt in conv_read_chkpt_fmt', stdout, seedname) +121 call io_error('Error opening '//trim(seedname)//'.chk.fmt in conv_read_chkpt_fmt', stdout, seedname) +122 call io_error('Error reading lwindow from '//trim(seedname)//'.chk.fmt in conv_read_chkpt_fmt', stdout, seedname) +123 call io_error('Error reading ndimwin from '//trim(seedname)//'.chk.fmt in conv_read_chkpt_fmt', stdout, seedname) +124 call io_error('Error reading u_matrix_opt from '//trim(seedname)//'.chk.fmt in conv_read_chkpt_fmt', stdout, seedname) +125 call io_error('Error reading u_matrix from '//trim(seedname)//'.chk.fmt in conv_read_chkpt_fmt', stdout, seedname) +126 call io_error('Error reading m_matrix from '//trim(seedname)//'.chk.fmt in conv_read_chkpt_fmt', stdout, seedname) +127 call io_error('Error reading wannier_centres from '//trim(seedname)//'.chk.fmt in conv_read_chkpt_fmt', stdout, seedname) +128 call io_error('Error reading wannier_spreads from '//trim(seedname)//'.chk.fmt in conv_read_chkpt_fmt', stdout, seedname) end subroutine conv_read_chkpt_fmt - subroutine conv_write_chkpt() - !=======================================! + subroutine conv_write_chkpt(checkpoint, stdout, seedname) + !================================================! + ! !! Write formatted checkpoint file - !=======================================! + ! + !================================================! - use w90_io, only: io_file_unit, io_date, seedname - use w90_parameters + use w90_io, only: io_file_unit, io_date + use w90chk_parameters + use wannchk_data implicit none + integer, intent(in) :: stdout + character(len=*), intent(in) :: checkpoint + character(len=50), intent(in) :: seedname + integer :: chk_unit, nkp, i, j, k, l character(len=9) :: cdate, ctime @@ -456,14 +577,14 @@ subroutine conv_write_chkpt() write (chk_unit) header ! Date and time from the read file write (chk_unit) num_bands ! Number of bands - write (chk_unit) num_exclude_bands ! Number of excluded bands + write (chk_unit) num_exclude_bands ! Number of excluded bands write (chk_unit) (exclude_bands(i), i=1, num_exclude_bands) ! Excluded bands write (chk_unit) ((real_lattice(i, j), i=1, 3), j=1, 3) ! Real lattice write (chk_unit) ((recip_lattice(i, j), i=1, 3), j=1, 3) ! Reciprocal lattice write (chk_unit) num_kpts ! Number of k-points write (chk_unit) (mp_grid(i), i=1, 3) ! M-P grid write (chk_unit) ((kpt_latt(i, nkp), i=1, 3), nkp=1, num_kpts) ! K-points - write (chk_unit) nntot ! Number of nearest k-point neighbours + write (chk_unit) kmesh_info%nntot ! Number of nearest k-point neighbours write (chk_unit) num_wann ! Number of wannier functions ! Next is correct: it always print out 20 characters write (chk_unit) checkpoint ! Position of checkpoint @@ -471,30 +592,37 @@ subroutine conv_write_chkpt() if (have_disentangled) then write (chk_unit) omega_invariant ! Omega invariant ! lwindow, ndimwin and U_matrix_opt - write (chk_unit) ((lwindow(i, nkp), i=1, num_bands), nkp=1, num_kpts) - write (chk_unit) (ndimwin(nkp), nkp=1, num_kpts) + write (chk_unit) ((dis_manifold%lwindow(i, nkp), i=1, num_bands), nkp=1, num_kpts) + write (chk_unit) (dis_manifold%ndimwin(nkp), nkp=1, num_kpts) write (chk_unit) (((u_matrix_opt(i, j, nkp), i=1, num_bands), j=1, num_wann), nkp=1, num_kpts) endif write (chk_unit) (((u_matrix(i, j, k), i=1, num_wann), j=1, num_wann), k=1, num_kpts) ! U_matrix - write (chk_unit) ((((m_matrix(i, j, k, l), i=1, num_wann), j=1, num_wann), k=1, nntot), l=1, num_kpts) ! M_matrix - write (chk_unit) ((wannier_centres(i, j), i=1, 3), j=1, num_wann) - write (chk_unit) (wannier_spreads(i), i=1, num_wann) + write (chk_unit) ((((m_matrix(i, j, k, l), i=1, num_wann), j=1, num_wann), k=1, kmesh_info%nntot), l=1, num_kpts) ! M_matrix + write (chk_unit) ((wannier_data%centres(i, j), i=1, 3), j=1, num_wann) + write (chk_unit) (wannier_data%spreads(i), i=1, num_wann) close (chk_unit) write (stdout, '(a/)') ' done' end subroutine conv_write_chkpt - subroutine conv_write_chkpt_fmt() - !=======================================! + subroutine conv_write_chkpt_fmt(checkpoint, stdout, seedname) + !================================================! + ! !! Write formatted checkpoint file - !=======================================! + ! + !================================================! - use w90_io, only: io_file_unit, io_date, seedname - use w90_parameters + use w90_io, only: io_file_unit, io_date + use w90chk_parameters + use wannchk_data implicit none + integer, intent(in) :: stdout + character(len=*), intent(in) :: checkpoint + character(len=50), intent(in) :: seedname + integer :: chk_unit, nkp, i, j, k, l character(len=9) :: cdate, ctime @@ -505,7 +633,7 @@ subroutine conv_write_chkpt_fmt() write (chk_unit, '(A33)') header ! Date and time from the read file write (chk_unit, '(I0)') num_bands ! Number of bands - write (chk_unit, '(I0)') num_exclude_bands ! Number of excluded bands + write (chk_unit, '(I0)') num_exclude_bands ! Number of excluded bands do i = 1, num_exclude_bands write (chk_unit, '(I0)') exclude_bands(i) ! Excluded bands end do @@ -516,7 +644,7 @@ subroutine conv_write_chkpt_fmt() do nkp = 1, num_kpts write (chk_unit, '(3G25.17)') (kpt_latt(i, nkp), i=1, 3) ! K-points end do - write (chk_unit, '(I0)') nntot ! Number of nearest k-point neighbours + write (chk_unit, '(I0)') kmesh_info%nntot ! Number of nearest k-point neighbours write (chk_unit, '(I0)') num_wann ! Number of wannier functions write (chk_unit, '(A20)') checkpoint ! Position of checkpoint if (have_disentangled) then @@ -529,7 +657,7 @@ subroutine conv_write_chkpt_fmt() ! lwindow, ndimwin and U_matrix_opt do nkp = 1, num_kpts do i = 1, num_bands - if (lwindow(i, nkp)) then + if (dis_manifold%lwindow(i, nkp)) then write (chk_unit, '(I1)') 1 else write (chk_unit, '(I1)') 0 @@ -537,7 +665,7 @@ subroutine conv_write_chkpt_fmt() end do end do do nkp = 1, num_kpts - write (chk_unit, '(I0)') ndimwin(nkp) + write (chk_unit, '(I0)') dis_manifold%ndimwin(nkp) end do do nkp = 1, num_kpts do j = 1, num_wann @@ -555,7 +683,7 @@ subroutine conv_write_chkpt_fmt() end do end do do l = 1, num_kpts - do k = 1, nntot + do k = 1, kmesh_info%nntot do j = 1, num_wann do i = 1, num_wann write (chk_unit, '(2G25.17)') m_matrix(i, j, k, l) @@ -564,10 +692,10 @@ subroutine conv_write_chkpt_fmt() end do end do do j = 1, num_wann - write (chk_unit, '(3G25.17)') (wannier_centres(i, j), i=1, 3) + write (chk_unit, '(3G25.17)') (wannier_data%centres(i, j), i=1, 3) end do do i = 1, num_wann - write (chk_unit, '(G25.17)') wannier_spreads(i) + write (chk_unit, '(G25.17)') wannier_data%spreads(i) end do close (chk_unit) @@ -581,37 +709,61 @@ program w90chk2chk !! Program to convert checkpoint files from formatted to unformmated !! and vice versa - useful for switching between computers use w90_constants, only: dp - use w90_io, only: io_file_unit, stdout, io_error, seedname + use w90_io, only: io_file_unit, io_error use w90_conv - use w90_comms, only: num_nodes, comms_setup, comms_end + use w90_comms, only: comms_end, w90comm_type, mpisize + +#ifdef MPI08 + use mpi_f08 ! use f08 interface if possible +#endif +#ifdef MPI90 + use mpi ! next best, use fortran90 interface +#endif + implicit none +#ifdef MPIH + include 'mpif.h' ! worst case, use legacy interface +#endif + ! Export mode: ! TRUE: create formatted .chk.fmt from unformatted .chk ('-export') ! FALSE: create unformatted .chk from formatted .chk.fmt ('-import') + integer :: stdout logical :: file_found integer :: file_unit + character(len=20) :: checkpoint + character(len=50) :: seedname + integer :: num_nodes, ierr + + type(w90comm_type) :: comm - call comms_setup +#ifdef MPI + comm%comm = MPI_COMM_WORLD + call mpi_init(ierr) + if (ierr .ne. 0) call io_error('MPI initialisation error', stdout, seedname) + num_nodes = mpisize(comm) +#else + num_nodes = 1 +#endif stdout = io_file_unit() open (unit=stdout, file='w90chk2chk.log') if (num_nodes /= 1) then - call io_error('w90chk2chk can only be used in serial...') + call io_error('w90chk2chk can only be used in serial...', stdout, seedname) endif - call conv_get_seedname + call conv_get_seedname(stdout, seedname) if (export_flag .eqv. .true.) then - call conv_read_chkpt() - call conv_write_chkpt_fmt() + call conv_read_chkpt(checkpoint, stdout, seedname) + call conv_write_chkpt_fmt(checkpoint, stdout, seedname) else - call conv_read_chkpt_fmt() - call conv_write_chkpt() + call conv_read_chkpt_fmt(checkpoint, stdout, seedname) + call conv_write_chkpt(checkpoint, stdout, seedname) end if -! close(unit=stdout,status='delete') close (unit=stdout) call comms_end diff --git a/src/w90spn2spn.F90 b/src/w90spn2spn.F90 index c711e53a4..98aa431ca 100644 --- a/src/w90spn2spn.F90 +++ b/src/w90spn2spn.F90 @@ -11,12 +11,29 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! w90spn2spn: reformat spn files ! +! ! +!------------------------------------------------------------! + +module w90spn_parameters + + use w90_types + + implicit none + + public + + integer, save :: num_kpts !BGS put in k_point_type? + integer, save :: num_bands !! Number of bands + +end module w90spn_parameters module w90_conv_spn !! Module to convert spn files from formatted to unformmated !! and vice versa - useful for switching between computers use w90_constants, only: dp - use w90_io, only: stdout, io_error, seedname + use w90_io, only: io_error implicit none @@ -27,8 +44,18 @@ module w90_conv_spn contains - subroutine print_usage() + !================================================! + subroutine print_usage(stdout) + !================================================! + ! !! Writes the usage of the program to stdout + ! + !================================================! + + implicit none + + integer, intent(in) :: stdout + write (stdout, '(A)') "Usage:" write (stdout, '(A)') " w90spn2spn.x ACTION [SEEDNAME]" write (stdout, '(A)') "where ACTION can be one of the following:" @@ -44,10 +71,18 @@ subroutine print_usage() write (stdout, '(A)') " The seedname.spn.fmt file is read and the seedname.spn file is generated." end subroutine print_usage - subroutine conv_get_seedname + !================================================! + subroutine conv_get_seedname(stdout, seedname) + !================================================! + ! !! Set the seedname from the command line + ! + !================================================! implicit none + integer, intent(in) :: stdout + character(len=50), intent(inout) :: seedname + integer :: num_arg character(len=50) :: ctemp @@ -57,8 +92,8 @@ subroutine conv_get_seedname elseif (num_arg == 2) then call get_command_argument(2, seedname) else - call print_usage - call io_error('Wrong command line arguments, see logfile for usage') + call print_usage(stdout) + call io_error('Wrong command line arguments, see logfile for usage', stdout, seedname) end if ! If on the command line the whole seedname.win was passed, I strip the last ".win" @@ -79,24 +114,29 @@ subroutine conv_get_seedname export_flag = .true. else write (stdout, '(A)') 'Wrong command line action: '//trim(ctemp) - call print_usage - call io_error('Wrong command line arguments, see logfile for usage') + call print_usage(stdout) + call io_error('Wrong command line arguments, see logfile for usage', stdout, seedname) end if end subroutine conv_get_seedname - !=======================================! - subroutine conv_read_spn() - !=======================================! + !================================================! + subroutine conv_read_spn(stdout, seedname) + !================================================! + ! !! Read unformatted spn file - !=======================================! + ! + !================================================! use w90_constants, only: eps6, dp - use w90_io, only: io_error, io_file_unit, stdout, seedname - use w90_parameters, only: num_bands, num_kpts + use w90_io, only: io_error, io_file_unit + use w90spn_parameters, only: num_bands, num_kpts implicit none + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + integer :: spn_unit, m, n, ik, ierr, s, counter complex(kind=dp), allocatable :: spn_temp(:, :) @@ -116,10 +156,10 @@ subroutine conv_read_spn() write (stdout, '(1x,a,i0)') "Number of k-points: ", num_kpts allocate (spn_o(num_bands, num_bands, num_kpts, 3), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating spm_temp in conv_read_spn') + if (ierr /= 0) call io_error('Error in allocating spm_temp in conv_read_spn', stdout, seedname) allocate (spn_temp(3, (num_bands*(num_bands + 1))/2), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating spm_temp in conv_read_spn') + if (ierr /= 0) call io_error('Error in allocating spm_temp in conv_read_spn', stdout, seedname) do ik = 1, num_kpts read (spn_unit) ((spn_temp(s, m), s=1, 3), m=1, (num_bands*(num_bands + 1))/2) counter = 0 @@ -147,28 +187,34 @@ subroutine conv_read_spn() write (stdout, '(1x,a)') "spn: read." deallocate (spn_temp, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating spm_temp in conv_read_spn') + if (ierr /= 0) call io_error('Error in deallocating spm_temp in conv_read_spn', stdout, seedname) write (stdout, '(1x,a)') 'read done.' return -109 call io_error('Error opening '//trim(seedname)//'.spn.fmt in conv_read_spn') -110 call io_error('Error reading '//trim(seedname)//'.spn.fmt in conv_read_spn') +109 call io_error('Error opening '//trim(seedname)//'.spn.fmt in conv_read_spn', stdout, seedname) +110 call io_error('Error reading '//trim(seedname)//'.spn.fmt in conv_read_spn', stdout, seedname) end subroutine conv_read_spn - subroutine conv_read_spn_fmt() - !=======================================! + !================================================! + subroutine conv_read_spn_fmt(stdout, seedname) + !================================================! + ! !! Read formatted spn file - !=======================================! + ! + !================================================! use w90_constants, only: eps6, dp - use w90_io, only: io_error, io_file_unit, stdout, seedname - use w90_parameters, only: num_bands, num_kpts + use w90_io, only: io_error, io_file_unit + use w90spn_parameters, only: num_bands, num_kpts implicit none + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + integer :: spn_unit, m, n, ik, ierr real(kind=dp) :: s_real, s_img @@ -188,7 +234,7 @@ subroutine conv_read_spn_fmt() write (stdout, '(1x,a,i0)') "Number of k-points: ", num_kpts allocate (spn_o(num_bands, num_bands, num_kpts, 3), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating spn_o in conv_read_spn_fmt') + if (ierr /= 0) call io_error('Error in allocating spn_o in conv_read_spn_fmt', stdout, seedname) do ik = 1, num_kpts do m = 1, num_bands @@ -220,21 +266,27 @@ subroutine conv_read_spn_fmt() return -109 call io_error('Error opening '//trim(seedname)//'.spn.fmt in conv_read_spn_fmt') -110 call io_error('Error reading '//trim(seedname)//'.spn.fmt in conv_read_spn_fmt') +109 call io_error('Error opening '//trim(seedname)//'.spn.fmt in conv_read_spn_fmt', stdout, seedname) +110 call io_error('Error reading '//trim(seedname)//'.spn.fmt in conv_read_spn_fmt', stdout, seedname) end subroutine conv_read_spn_fmt - subroutine conv_write_spn() - !=======================================! + !================================================! + subroutine conv_write_spn(stdout, seedname) + !================================================! + ! !! Write unformatted spn file - !=======================================! + ! + !================================================! - use w90_io, only: io_file_unit, io_date, seedname - use w90_parameters, only: num_bands, num_kpts + use w90_io, only: io_file_unit, io_date + use w90spn_parameters, only: num_bands, num_kpts implicit none + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + integer :: spn_unit, m, n, ik, counter, s, ierr complex(kind=dp), allocatable :: spn_temp(:, :) @@ -244,7 +296,7 @@ subroutine conv_write_spn() open (unit=spn_unit, file=trim(seedname)//'.spn', form='unformatted') allocate (spn_temp(3, (num_bands*(num_bands + 1))/2), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating spm_temp in conv_write_spn') + if (ierr /= 0) call io_error('Error in allocating spm_temp in conv_write_spn', stdout, seedname) write (spn_unit) header write (spn_unit) num_bands, num_kpts @@ -268,16 +320,22 @@ subroutine conv_write_spn() end subroutine conv_write_spn - subroutine conv_write_spn_fmt() - !=======================================! + !================================================! + subroutine conv_write_spn_fmt(stdout, seedname) + !================================================! + ! !! Write formatted spn file - !=======================================! + ! + !================================================! - use w90_io, only: io_file_unit, io_date, seedname - use w90_parameters, only: num_bands, num_kpts + use w90_io, only: io_file_unit, io_date + use w90spn_parameters, only: num_bands, num_kpts implicit none + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + integer :: spn_unit, m, n, ik, s write (stdout, '(3a)') 'Writing information to formatted file ', trim(seedname), '.spn.fmt :' @@ -310,40 +368,61 @@ program w90spn2spn !! Program to convert spn files from formatted to unformmated !! and vice versa - useful for switching between computers use w90_constants, only: dp - use w90_io, only: io_file_unit, stdout, io_error, seedname + use w90_io, only: io_file_unit, io_error use w90_conv_spn - use w90_comms, only: num_nodes, comms_setup, comms_end + use w90_comms, only: comms_end, mpisize, w90comm_type + +#ifdef MPI08 + use mpi_f08 ! use f08 interface if possible +#endif +#ifdef MPI90 + use mpi ! next best, use fortran90 interface +#endif implicit none +#ifdef MPIH + include 'mpif.h' ! worst case, use legacy interface +#endif + ! Export mode: ! TRUE: create formatted .spn.fmt from unformatted .spn ('-export') ! FALSE: create unformatted .spn from formatted .spn.fmt ('-import') + + type(w90comm_type) :: comm logical :: file_found integer :: file_unit - - call comms_setup + integer :: stdout, ierr, num_nodes + character(len=50) :: seedname + +#ifdef MPI + comm%comm = MPI_COMM_WORLD + call mpi_init(ierr) + if (ierr .ne. 0) call io_error('MPI initialisation error', stdout, seedname) + num_nodes = mpisize(comm) +#else + num_nodes = 1 +#endif stdout = io_file_unit() open (unit=stdout, file='w90spn2spn.log') if (num_nodes /= 1) then - call io_error('w90spn2spn can only be used in serial...') + call io_error('w90spn2spn can only be used in serial...', stdout, seedname) endif - call conv_get_seedname + call conv_get_seedname(stdout, seedname) if (export_flag .eqv. .true.) then - call conv_read_spn() + call conv_read_spn(stdout, seedname) write (stdout, '(a)') '' - call conv_write_spn_fmt() + call conv_write_spn_fmt(stdout, seedname) else - call conv_read_spn_fmt() + call conv_read_spn_fmt(stdout, seedname) write (stdout, '(a)') '' - call conv_write_spn() + call conv_write_spn(stdout, seedname) end if -! close(unit=stdout,status='delete') close (unit=stdout) call comms_end diff --git a/src/wannier90_readwrite.F90 b/src/wannier90_readwrite.F90 new file mode 100644 index 000000000..d9924a8ab --- /dev/null +++ b/src/wannier90_readwrite.F90 @@ -0,0 +1,2661 @@ +!-*- mode: F90 -*-! +!------------------------------------------------------------! +! This file is distributed as part of the Wannier90 code and ! +! under the terms of the GNU General Public License. See the ! +! file `LICENSE' in the root directory of the Wannier90 ! +! distribution, or http://www.gnu.org/copyleft/gpl.txt ! +! ! +! The webpage of the Wannier90 code is www.wannier.org ! +! ! +! The Wannier90 code is hosted on GitHub: ! +! ! +! https://github.com/wannier-developers/wannier90 ! +!------------------------------------------------------------! +! ! +! w90_wannier90_readwrite: input/output routines ! +! specific to wannier90.x ! +! ! +!------------------------------------------------------------! + +module w90_wannier90_readwrite + + !! Read/write routines specific to wannier90.x data types + + use w90_constants, only: dp + use w90_types + use w90_readwrite + use w90_wannier90_types + + implicit none + + private + + type w90_extra_io_type + character(len=20) :: one_dim_axis + !! Constrained centres + real(kind=dp), allocatable :: ccentres_frac(:, :) + end type w90_extra_io_type + + public :: w90_extra_io_type + public :: w90_wannier90_readwrite_dist + public :: w90_wannier90_readwrite_memory_estimate + public :: w90_wannier90_readwrite_read + public :: w90_wannier90_readwrite_w90_dealloc + public :: w90_wannier90_readwrite_write + public :: w90_wannier90_readwrite_write_chkpt + +contains + + !================================================! + subroutine w90_wannier90_readwrite_read(atom_data, band_plot, dis_control, dis_spheres, & + dis_manifold, exclude_bands, fermi_energy_list, fermi_surface_data, & + kmesh_input, kmesh_info, kpt_latt, output_file, wvfn_read, wann_control, & + wann_omega, proj, proj_input, real_space_ham, select_proj, kpoint_path, & + w90_system, tran, print_output, wannier_data, wann_plot, w90_extra_io, & + ws_region, w90_calculation, eigval, real_lattice, bohr, symmetrize_eps, & + mp_grid, num_bands, num_kpts, num_proj, num_wann, optimisation, eig_found, & + calc_only_A, cp_pp, gamma_only, lhasproj, library, & + library_w90_wannier90_readwrite_read_first_pass, lsitesymmetry, & + use_bloch_phases, seedname, stdout) + !================================================! + ! + !! Read parameters and calculate derived values + !! + !! Note on parallelization: this function should be called + !! from the root node only! + !! + ! + !================================================ + + use w90_constants, only: w90_physical_constants_type + use w90_utility, only: utility_recip_lattice, utility_inverse_mat + + implicit none + + ! arguments + type(atom_data_type), intent(inout) :: atom_data + type(band_plot_type), intent(inout) :: band_plot + type(dis_control_type), intent(inout) :: dis_control + type(dis_manifold_type), intent(inout) :: dis_manifold + type(dis_spheres_type), intent(inout) :: dis_spheres + type(fermi_surface_plot_type), intent(inout) :: fermi_surface_data + type(kmesh_info_type), intent(inout) :: kmesh_info + type(kmesh_input_type), intent(inout) :: kmesh_input + type(kpoint_path_type), intent(inout) :: kpoint_path + type(output_file_type), intent(inout) :: output_file + type(print_output_type), intent(inout) :: print_output + type(proj_input_type), intent(inout) :: proj + type(proj_input_type), intent(inout) :: proj_input + type(real_space_ham_type), intent(inout) :: real_space_ham + type(select_projection_type), intent(inout) :: select_proj + type(transport_type), intent(inout) :: tran + type(w90_calculation_type), intent(inout) :: w90_calculation + type(w90_extra_io_type), intent(inout) :: w90_extra_io + type(w90_system_type), intent(inout) :: w90_system + type(wann_control_type), intent(inout) :: wann_control + type(wannier_data_type), intent(inout) :: wannier_data + type(wannier_plot_type), intent(inout) :: wann_plot + type(wann_omega_type), intent(inout) :: wann_omega + type(ws_region_type), intent(inout) :: ws_region + type(wvfn_read_type), intent(inout) :: wvfn_read + + integer, allocatable, intent(inout) :: exclude_bands(:) + integer, intent(inout) :: mp_grid(3) + integer, intent(inout) :: num_bands + integer, intent(inout) :: num_kpts + integer, intent(inout) :: num_proj + integer, intent(inout) :: num_wann + integer, intent(inout) :: optimisation + integer, intent(in) :: stdout + + real(kind=dp), allocatable, intent(inout) :: eigval(:, :) + real(kind=dp), allocatable, intent(inout) :: fermi_energy_list(:) + real(kind=dp), allocatable, intent(inout) :: kpt_latt(:, :) + real(kind=dp), intent(in) :: bohr + real(kind=dp), intent(inout) :: real_lattice(3, 3) + real(kind=dp), intent(inout) :: symmetrize_eps + + character(len=50), intent(in) :: seedname + + real(kind=dp) :: recip_lattice(3, 3), volume, inv_lattice(3, 3) + logical, intent(inout) :: eig_found + logical, intent(in) :: library + logical, intent(in) :: library_w90_wannier90_readwrite_read_first_pass + !Projections + logical, intent(out) :: lhasproj + ! RS: symmetry-adapted Wannier functions + logical, intent(inout) :: lsitesymmetry + logical, intent(out) :: use_bloch_phases, cp_pp, calc_only_A + logical, intent(inout) :: gamma_only + + ! local variables + integer :: num_exclude_bands + character(len=20) :: energy_unit + !! Units for energy + logical :: found_fermi_energy + logical :: has_kpath + logical :: disentanglement + + disentanglement = .false. + call w90_readwrite_in_file(seedname, stdout) + call w90_wannier90_readwrite_read_sym(symmetrize_eps, lsitesymmetry, seedname, stdout) + + call w90_readwrite_read_verbosity(print_output, stdout, seedname) + call w90_readwrite_read_algorithm_control(optimisation, stdout, seedname) + call w90_wannier90_readwrite_read_w90_calcs(w90_calculation, stdout, seedname) + call w90_wannier90_readwrite_read_transport(w90_calculation%transport, tran, w90_calculation%restart, stdout, & + seedname) + call w90_wannier90_readwrite_read_dist_cutoff(real_space_ham, stdout, seedname) + if (.not. (w90_calculation%transport .and. tran%read_ht)) then + call w90_readwrite_read_units(print_output%lenconfac, print_output%length_unit, energy_unit, bohr, & + stdout, seedname) + call w90_readwrite_read_num_wann(num_wann, stdout, seedname) + call w90_readwrite_read_exclude_bands(exclude_bands, num_exclude_bands, stdout, seedname) + call w90_readwrite_read_num_bands(.false., library, num_exclude_bands, num_bands, & + num_wann, library_w90_wannier90_readwrite_read_first_pass, stdout, seedname) + disentanglement = (num_bands > num_wann) + call w90_readwrite_read_lattice(library, real_lattice, bohr, stdout, seedname) + call w90_wannier90_readwrite_read_wannierise(wann_control, num_wann, w90_extra_io%ccentres_frac, & + stdout, seedname) + !call w90_readwrite_read_devel(print_output%devel_flag, stdout, seedname) + call w90_readwrite_read_mp_grid(.false., library, mp_grid, num_kpts, stdout, seedname) + call w90_readwrite_read_gamma_only(gamma_only, num_kpts, library, stdout, seedname) + call w90_wannier90_readwrite_read_post_proc(cp_pp, calc_only_A, w90_calculation%postproc_setup, stdout, & + seedname) + call w90_wannier90_readwrite_read_restart(w90_calculation, stdout, seedname) + call w90_readwrite_read_system(library, w90_system, stdout, seedname) + call w90_readwrite_read_kpath(library, kpoint_path, has_kpath, w90_calculation%bands_plot, stdout, & + seedname) + call w90_wannier90_readwrite_read_plot_info(wvfn_read, stdout, seedname) + call w90_wannier90_readwrite_read_band_plot(band_plot, num_wann, has_kpath, w90_calculation%bands_plot, & + stdout, seedname) + call w90_wannier90_readwrite_read_wann_plot(wann_plot, num_wann, w90_calculation%wannier_plot, stdout, seedname) + call w90_wannier90_readwrite_read_fermi_surface(fermi_surface_data, w90_calculation%fermi_surface_plot, & + stdout, seedname) + call w90_readwrite_read_fermi_energy(found_fermi_energy, fermi_energy_list, stdout, seedname) + call w90_wannier90_readwrite_read_outfiles(output_file, num_kpts, w90_system%num_valence_bands, & + disentanglement, gamma_only, stdout, seedname) + endif + ! BGS tran/plot related stuff... + call w90_wannier90_readwrite_read_one_dim(w90_calculation, band_plot, real_space_ham, w90_extra_io%one_dim_axis, & + tran%read_ht, stdout, seedname) + call w90_readwrite_read_ws_data(ws_region, stdout, seedname) !ws_search etc + if (.not. (w90_calculation%transport .and. tran%read_ht)) then + call w90_readwrite_read_eigvals(.false., .false., .false., & + w90_calculation%bands_plot .or. w90_calculation%fermi_surface_plot .or. & + output_file%write_hr, disentanglement, eig_found, & + eigval, library, w90_calculation%postproc_setup, num_bands, num_kpts, & + stdout, seedname) + dis_manifold%win_min = -1.0_dp + dis_manifold%win_max = 0.0_dp + if (eig_found) dis_manifold%win_min = minval(eigval) + if (eig_found) dis_manifold%win_max = maxval(eigval) + call w90_readwrite_read_dis_manifold(eig_found, dis_manifold, stdout, seedname) + call w90_wannier90_readwrite_read_disentangle(dis_control, dis_spheres, num_bands, num_wann, bohr, & + stdout, seedname) + call w90_wannier90_readwrite_read_hamil(real_space_ham, stdout, seedname) + call w90_wannier90_readwrite_read_bloch_phase(use_bloch_phases, disentanglement, stdout, seedname) + call w90_readwrite_read_kmesh_data(kmesh_input, stdout, seedname) + call utility_recip_lattice(real_lattice, recip_lattice, volume, stdout, seedname) + call utility_inverse_mat(real_lattice, inv_lattice) + call w90_readwrite_read_kpoints(.false., library, kpt_latt, num_kpts, bohr, stdout, seedname) + call w90_wannier90_readwrite_read_explicit_kpts(library, w90_calculation, kmesh_info, num_kpts, bohr, stdout, & + seedname) + !call w90_wannier90_readwrite_read_global_kmesh(global_kmesh_set, kmesh_spacing, kmesh, recip_lattice, & + ! stdout, seedname) + call w90_readwrite_read_atoms(library, atom_data, real_lattice, bohr, stdout, seedname) + call w90_wannier90_readwrite_read_projections(proj, use_bloch_phases, lhasproj, & + wann_control%guiding_centres%enable, & + proj_input, select_proj, num_proj, & + atom_data, inv_lattice, num_wann, gamma_only, & + w90_system%spinors, library, bohr, stdout, seedname) + if (allocated(proj%site)) then + if (allocated(wann_control%guiding_centres%centres)) & + deallocate (wann_control%guiding_centres%centres) + allocate (wann_control%guiding_centres%centres(3, num_wann)) + wann_control%guiding_centres%centres(:, :) = proj%site(:, :) + endif + ! projections needs to be allocated before reading constrained centres + if (wann_control%constrain%constrain) then + call w90_wannier90_readwrite_read_constrained_centres(w90_extra_io%ccentres_frac, wann_control, & + real_lattice, num_wann, library, stdout, seedname) + endif + endif + call w90_readwrite_clean_infile(stdout, seedname) + if (.not. (w90_calculation%transport .and. tran%read_ht)) then + ! For aesthetic purposes, convert some things to uppercase + call w90_readwrite_uppercase(atom_data, kpoint_path, print_output%length_unit) + ! Initialise + wann_omega%total = -999.0_dp + wann_omega%tilde = -999.0_dp + wann_omega%invariant = -999.0_dp + call w90_readwrite_read_final_alloc(disentanglement, dis_manifold, wannier_data, num_wann, & + num_bands, num_kpts, stdout, seedname) + endif + end subroutine w90_wannier90_readwrite_read + + !================================================! + subroutine w90_wannier90_readwrite_read_sym(symmetrize_eps, lsitesymmetry, seedname, stdout) + !================================================! + ! Site symmetry + !================================================! + implicit none + logical, intent(inout) :: lsitesymmetry + real(kind=dp), intent(inout) :: symmetrize_eps + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + + logical :: found + + ! default value is lsitesymmetry=.false. + call w90_readwrite_get_keyword(stdout, seedname, 'site_symmetry', found, l_value=lsitesymmetry)!YN: + + ! default value is symmetrize_eps=0.001 + call w90_readwrite_get_keyword(stdout, seedname, 'symmetrize_eps', found, r_value=symmetrize_eps)!YN: + end subroutine w90_wannier90_readwrite_read_sym + + !================================================! + subroutine w90_wannier90_readwrite_read_w90_calcs(w90_calculation, stdout, seedname) + !================================================! + implicit none + integer, intent(in) :: stdout + type(w90_calculation_type), intent(out) :: w90_calculation + character(len=50), intent(in) :: seedname + + logical :: found + + w90_calculation%transport = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'transport', found, & + l_value=w90_calculation%transport) + + w90_calculation%wannier_plot = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'wannier_plot', found, & + l_value=w90_calculation%wannier_plot) + + w90_calculation%bands_plot = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'bands_plot', found, & + l_value=w90_calculation%bands_plot) + + w90_calculation%fermi_surface_plot = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'fermi_surface_plot', found, & + l_value=w90_calculation%fermi_surface_plot) + + end subroutine w90_wannier90_readwrite_read_w90_calcs + + !================================================! + subroutine w90_wannier90_readwrite_read_transport(transport, tran, restart, stdout, seedname) + !================================================! + ! Transport + !================================================! + use w90_io, only: io_error + implicit none + integer, intent(in) :: stdout + logical, intent(in) :: transport + type(transport_type), intent(out) :: tran + character(len=*), intent(inout) :: restart + character(len=50), intent(in) :: seedname + + logical :: found + + tran%read_ht = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'tran_read_ht', found, l_value=tran%read_ht) + + tran%easy_fix = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'tran_easy_fix', found, l_value=tran%easy_fix) + + if (transport .and. tran%read_ht) restart = ' ' + + tran%mode = 'bulk' + call w90_readwrite_get_keyword(stdout, seedname, 'transport_mode', found, c_value=tran%mode) + +! if ( .not.tran_read_ht .and. (index(transport_mode,'lcr').ne.0) ) & +! call io_error('Error: transport_mode.eq.lcr not compatible with tran_read_ht.eq.false') + + tran%win_min = -3.0_dp + call w90_readwrite_get_keyword(stdout, seedname, 'tran_win_min', found, r_value=tran%win_min) + + tran%win_max = 3.0_dp + call w90_readwrite_get_keyword(stdout, seedname, 'tran_win_max', found, r_value=tran%win_max) + + tran%energy_step = 0.01_dp + call w90_readwrite_get_keyword(stdout, seedname, 'tran_energy_step', found, r_value=tran%energy_step) + + tran%num_bb = 0 + call w90_readwrite_get_keyword(stdout, seedname, 'tran_num_bb', found, i_value=tran%num_bb) + + tran%num_ll = 0 + call w90_readwrite_get_keyword(stdout, seedname, 'tran_num_ll', found, i_value=tran%num_ll) + + tran%num_rr = 0 + call w90_readwrite_get_keyword(stdout, seedname, 'tran_num_rr', found, i_value=tran%num_rr) + + tran%num_cc = 0 + call w90_readwrite_get_keyword(stdout, seedname, 'tran_num_cc', found, i_value=tran%num_cc) + + tran%num_lc = 0 + call w90_readwrite_get_keyword(stdout, seedname, 'tran_num_lc', found, i_value=tran%num_lc) + + tran%num_cr = 0 + call w90_readwrite_get_keyword(stdout, seedname, 'tran_num_cr', found, i_value=tran%num_cr) + + tran%num_bandc = 0 + call w90_readwrite_get_keyword(stdout, seedname, 'tran_num_bandc', found, i_value=tran%num_bandc) + + tran%write_ht = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'tran_write_ht', found, l_value=tran%write_ht) + + tran%use_same_lead = .true. + call w90_readwrite_get_keyword(stdout, seedname, 'tran_use_same_lead', found, l_value=tran%use_same_lead) + + tran%num_cell_ll = 0 + call w90_readwrite_get_keyword(stdout, seedname, 'tran_num_cell_ll', found, i_value=tran%num_cell_ll) + + tran%num_cell_rr = 0 + call w90_readwrite_get_keyword(stdout, seedname, 'tran_num_cell_rr', found, i_value=tran%num_cell_rr) + + tran%group_threshold = 0.15_dp + call w90_readwrite_get_keyword(stdout, seedname, 'tran_group_threshold', found, & + r_value=tran%group_threshold) + + ! checks + if (transport) then + if ((index(tran%mode, 'bulk') .eq. 0) .and. (index(tran%mode, 'lcr') .eq. 0)) & + call io_error('Error: transport_mode not recognised', stdout, seedname) + if (tran%num_bb < 0) call io_error('Error: tran_num_bb < 0', stdout, seedname) + if (tran%num_ll < 0) call io_error('Error: tran_num_ll < 0', stdout, seedname) + if (tran%num_rr < 0) call io_error('Error: tran_num_rr < 0', stdout, seedname) + if (tran%num_cc < 0) call io_error('Error: tran_num_cc < 0', stdout, seedname) + if (tran%num_lc < 0) call io_error('Error: tran_num_lc < 0', stdout, seedname) + if (tran%num_cr < 0) call io_error('Error: tran_num_cr < 0', stdout, seedname) + if (tran%num_bandc < 0) call io_error('Error: tran_num_bandc < 0', stdout, seedname) + if (tran%num_cell_ll < 0) call io_error('Error: tran_num_cell_ll < 0', stdout, seedname) + if (tran%num_cell_rr < 0) call io_error('Error: tran_num_cell_rr < 0', stdout, seedname) + if (tran%group_threshold < 0.0_dp) call io_error('Error: tran_group_threshold < 0', stdout, seedname) + endif + + end subroutine w90_wannier90_readwrite_read_transport + + !================================================! + subroutine w90_wannier90_readwrite_read_dist_cutoff(real_space_ham, stdout, seedname) + !================================================! + use w90_io, only: io_error + implicit none + integer, intent(in) :: stdout + type(real_space_ham_type), intent(inout) :: real_space_ham + character(len=50), intent(in) :: seedname + + logical :: found + + real_space_ham%dist_cutoff_mode = 'three_dim' + call w90_readwrite_get_keyword(stdout, seedname, 'dist_cutoff_mode', found, & + c_value=real_space_ham%dist_cutoff_mode) + if ((index(real_space_ham%dist_cutoff_mode, 'three_dim') .eq. 0) & + .and. (index(real_space_ham%dist_cutoff_mode, 'two_dim') .eq. 0) & + .and. (index(real_space_ham%dist_cutoff_mode, 'one_dim') .eq. 0)) & + call io_error('Error: dist_cutoff_mode not recognised', stdout, seedname) + + real_space_ham%dist_cutoff = 1000.0_dp + call w90_readwrite_get_keyword(stdout, seedname, 'dist_cutoff', found, & + r_value=real_space_ham%dist_cutoff) + + real_space_ham%dist_cutoff_hc = real_space_ham%dist_cutoff + call w90_readwrite_get_keyword(stdout, seedname, 'dist_cutoff_hc', found, & + r_value=real_space_ham%dist_cutoff_hc) + + real_space_ham%hr_cutoff = 0.0_dp + call w90_readwrite_get_keyword(stdout, seedname, 'hr_cutoff', found, r_value=real_space_ham%hr_cutoff) + + real_space_ham%system_dim = 3 + call w90_readwrite_get_keyword(stdout, seedname, 'bands_plot_dim', found, & + i_value=real_space_ham%system_dim) + + end subroutine w90_wannier90_readwrite_read_dist_cutoff + + !================================================! + subroutine w90_wannier90_readwrite_read_wannierise(wann_control, num_wann, ccentres_frac, stdout, seedname) + !================================================! + ! Wannierise + !================================================! + use w90_io, only: io_error + implicit none + type(wann_control_type), intent(out) :: wann_control + integer, intent(in) :: num_wann + real(kind=dp), allocatable, intent(inout) :: ccentres_frac(:, :) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + + integer :: ierr + logical :: found + + wann_control%num_dump_cycles = 100 ! frequency to write backups at + call w90_readwrite_get_keyword(stdout, seedname, 'num_dump_cycles', found, & + i_value=wann_control%num_dump_cycles) + if (wann_control%num_dump_cycles < 0) & + call io_error('Error: num_dump_cycles must be positive', stdout, seedname) + + wann_control%num_print_cycles = 1 ! frequency to write at + call w90_readwrite_get_keyword(stdout, seedname, 'num_print_cycles', found, & + i_value=wann_control%num_print_cycles) + if (wann_control%num_print_cycles < 0) & + call io_error('Error: num_print_cycles must be positive', stdout, seedname) + + wann_control%num_iter = 100 + call w90_readwrite_get_keyword(stdout, seedname, 'num_iter', found, & + i_value=wann_control%num_iter) + if (wann_control%num_iter < 0) & + call io_error('Error: num_iter must be positive', stdout, seedname) + + wann_control%num_cg_steps = 5 + call w90_readwrite_get_keyword(stdout, seedname, 'num_cg_steps', found, & + i_value=wann_control%num_cg_steps) + if (wann_control%num_cg_steps < 0) & + call io_error('Error: num_cg_steps must be positive', stdout, seedname) + + wann_control%conv_tol = 1.0e-10_dp + call w90_readwrite_get_keyword(stdout, seedname, 'conv_tol', found, & + r_value=wann_control%conv_tol) + if (wann_control%conv_tol < 0.0_dp) & + call io_error('Error: conv_tol must be positive', stdout, seedname) + + wann_control%conv_noise_amp = -1.0_dp + call w90_readwrite_get_keyword(stdout, seedname, 'conv_noise_amp', found, & + r_value=wann_control%conv_noise_amp) + + ! note that the default here is not to check convergence + wann_control%conv_window = -1 + if (wann_control%conv_noise_amp > 0.0_dp) wann_control%conv_window = 5 + call w90_readwrite_get_keyword(stdout, seedname, 'conv_window', found, & + i_value=wann_control%conv_window) + + wann_control%conv_noise_num = 3 + call w90_readwrite_get_keyword(stdout, seedname, 'conv_noise_num', found, & + i_value=wann_control%conv_noise_num) + if (wann_control%conv_noise_num < 0) & + call io_error('Error: conv_noise_num must be positive', stdout, seedname) + + wann_control%guiding_centres%enable = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'guiding_centres', found, & + l_value=wann_control%guiding_centres%enable) + + wann_control%guiding_centres%num_guide_cycles = 1 + call w90_readwrite_get_keyword(stdout, seedname, 'num_guide_cycles', found, & + i_value=wann_control%guiding_centres%num_guide_cycles) + if (wann_control%guiding_centres%num_guide_cycles < 0) & + call io_error('Error: num_guide_cycles must be >= 0', stdout, seedname) + + wann_control%guiding_centres%num_no_guide_iter = 0 + call w90_readwrite_get_keyword(stdout, seedname, 'num_no_guide_iter', found, & + i_value=wann_control%guiding_centres%num_no_guide_iter) + if (wann_control%guiding_centres%num_no_guide_iter < 0) & + call io_error('Error: num_no_guide_iter must be >= 0', stdout, seedname) + + wann_control%fixed_step = -999.0_dp; + wann_control%lfixstep = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'fixed_step', found, & + r_value=wann_control%fixed_step) + if (found .and. (wann_control%fixed_step < 0.0_dp)) & + call io_error('Error: fixed_step must be > 0', stdout, seedname) + if (wann_control%fixed_step > 0.0_dp) wann_control%lfixstep = .true. + + wann_control%trial_step = 2.0_dp + call w90_readwrite_get_keyword(stdout, seedname, 'trial_step', found, & + r_value=wann_control%trial_step) + if (found .and. wann_control%lfixstep) then + call io_error('Error: cannot specify both fixed_step and trial_step', stdout, seedname) + endif + + wann_control%precond = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'precond', found, & + l_value=wann_control%precond) + + wann_control%constrain%slwf_num = num_wann + wann_control%constrain%selective_loc = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'slwf_num', found, & + i_value=wann_control%constrain%slwf_num) + if (found) then + if (wann_control%constrain%slwf_num .gt. num_wann .or. & + wann_control%constrain%slwf_num .lt. 1) then + call io_error('Error: slwf_num must be an integer between 1 and num_wann', stdout, seedname) + end if + if (wann_control%constrain%slwf_num .lt. num_wann) & + wann_control%constrain%selective_loc = .true. + end if + + wann_control%constrain%constrain = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'slwf_constrain', found, & + l_value=wann_control%constrain%constrain) + if (found .and. wann_control%constrain%constrain) then + if (wann_control%constrain%selective_loc) then + allocate (ccentres_frac(num_wann, 3), stat=ierr) + if (ierr /= 0) & + call io_error('Error allocating ccentres_frac in w90_readwrite_get_centre_constraints', stdout, seedname) + allocate (wann_control%constrain%centres(num_wann, 3), stat=ierr) + if (ierr /= 0) call io_error('Error allocating ccentres_cart in w90_readwrite_get_centre_constraints', stdout, seedname) + else + write (stdout, *) ' No selective localisation requested. Ignoring constraints on centres' + wann_control%constrain%constrain = .false. + end if + end if + + wann_control%constrain%lambda = 1.0_dp + call w90_readwrite_get_keyword(stdout, seedname, 'slwf_lambda', found, & + r_value=wann_control%constrain%lambda) + if (found) then + if (wann_control%constrain%lambda < 0.0_dp) & + call io_error('Error: slwf_lambda must be positive.', stdout, seedname) + endif + end subroutine w90_wannier90_readwrite_read_wannierise + + !================================================! + subroutine w90_wannier90_readwrite_read_disentangle(dis_control, dis_spheres, num_bands, & + num_wann, bohr, stdout, seedname) + !================================================! + use w90_io, only: io_error + implicit none + integer, intent(in) :: stdout + type(dis_control_type), intent(inout) :: dis_control + type(dis_spheres_type), intent(inout) :: dis_spheres + integer, intent(in) :: num_bands, num_wann + real(kind=dp), intent(in) :: bohr + character(len=50), intent(in) :: seedname + + integer :: nkp, ierr + logical :: found + + dis_control%num_iter = 200 + call w90_readwrite_get_keyword(stdout, seedname, 'dis_num_iter', found, i_value=dis_control%num_iter) + if (dis_control%num_iter < 0) call io_error('Error: dis_num_iter must be positive', stdout, seedname) + + dis_control%mix_ratio = 0.5_dp + call w90_readwrite_get_keyword(stdout, seedname, 'dis_mix_ratio', found, r_value=dis_control%mix_ratio) + if (dis_control%mix_ratio <= 0.0_dp .or. dis_control%mix_ratio > 1.0_dp) & + call io_error('Error: dis_mix_ratio must be greater than 0.0 but not greater than 1.0', stdout, seedname) + + dis_control%conv_tol = 1.0e-10_dp + call w90_readwrite_get_keyword(stdout, seedname, 'dis_conv_tol', found, r_value=dis_control%conv_tol) + if (dis_control%conv_tol < 0.0_dp) call io_error('Error: dis_conv_tol must be positive', stdout, seedname) + + dis_control%conv_window = 3 + call w90_readwrite_get_keyword(stdout, seedname, 'dis_conv_window', found, i_value=dis_control%conv_window) + if (dis_control%conv_window < 0) call io_error('Error: dis_conv_window must be positive', stdout, seedname) + + ! GS-start + dis_spheres%first_wann = 1 + call w90_readwrite_get_keyword(stdout, seedname, 'dis_spheres_first_wann', found, i_value=dis_spheres%first_wann) + if (dis_spheres%first_wann < 1) call io_error('Error: dis_spheres_first_wann must be greater than 0', stdout, seedname) + if (dis_spheres%first_wann > num_bands - num_wann + 1) & + call io_error('Error: dis_spheres_first_wann is larger than num_bands-num_wann+1', stdout, seedname) + dis_spheres%num = 0 + call w90_readwrite_get_keyword(stdout, seedname, 'dis_spheres_num', found, i_value=dis_spheres%num) + if (dis_spheres%num < 0) call io_error('Error: dis_spheres_num cannot be negative', stdout, seedname) + if (dis_spheres%num > 0) then + allocate (dis_spheres%spheres(4, dis_spheres%num), stat=ierr) + if (ierr /= 0) call io_error('Error allocating dis_spheres in w90_wannier90_readwrite_read', stdout, seedname) + call w90_readwrite_get_keyword_block(stdout, seedname, 'dis_spheres', found, dis_spheres%num, 4, & + bohr, r_value=dis_spheres%spheres) + if (.not. found) call io_error('Error: Did not find dis_spheres in the input file', stdout, seedname) + do nkp = 1, dis_spheres%num + if (dis_spheres%spheres(4, nkp) < 1.0e-15_dp) & + call io_error('Error: radius for dis_spheres must be > 0', stdout, seedname) + enddo + endif + ! GS-end + end subroutine w90_wannier90_readwrite_read_disentangle + + !================================================! + subroutine w90_wannier90_readwrite_read_post_proc(cp_pp, pp_only_A, postproc_setup, stdout, seedname) + !================================================! + use w90_io, only: post_proc_flag + implicit none + integer, intent(in) :: stdout + logical, intent(out) :: cp_pp, pp_only_A, postproc_setup + character(len=50), intent(in) :: seedname + + logical :: found + + postproc_setup = .false. ! set to true to write .nnkp file and exit + call w90_readwrite_get_keyword(stdout, seedname, 'postproc_setup', found, l_value=postproc_setup) + ! We allow this keyword to be overriden by a command line arg -pp + if (post_proc_flag) postproc_setup = .true. + + cp_pp = .false. ! set to true if doing CP post-processing + call w90_readwrite_get_keyword(stdout, seedname, 'cp_pp', found, l_value=cp_pp) + + pp_only_A = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'calc_only_A', found, l_value=pp_only_A) + end subroutine w90_wannier90_readwrite_read_post_proc + + !================================================! + subroutine w90_wannier90_readwrite_read_restart(w90_calculation, stdout, seedname) + !================================================! + use w90_io, only: io_error + implicit none + integer, intent(in) :: stdout + type(w90_calculation_type), intent(inout) :: w90_calculation + character(len=50), intent(in) :: seedname + + logical :: found, chk_found + + w90_calculation%restart = ' ' + call w90_readwrite_get_keyword(stdout, seedname, 'restart', found, c_value=w90_calculation%restart) + if (found) then + if ((w90_calculation%restart .ne. 'default') .and. (w90_calculation%restart .ne. 'wannierise') & + .and. (w90_calculation%restart .ne. 'plot') .and. (w90_calculation%restart .ne. 'transport')) then + call io_error('Error in input file: value of restart not recognised', stdout, seedname) + else + inquire (file=trim(seedname)//'.chk', exist=chk_found) + if (.not. chk_found) & + call io_error('Error: restart requested but '//trim(seedname)//'.chk file not found', stdout, seedname) + endif + endif + !post processing takes priority (user is not warned of this) + if (w90_calculation%postproc_setup) w90_calculation%restart = ' ' + end subroutine w90_wannier90_readwrite_read_restart + + !================================================! + subroutine w90_wannier90_readwrite_read_outfiles(output_file, num_kpts, num_valence_bands, disentanglement, & + gamma_only, stdout, seedname) + !================================================! + use w90_io, only: io_error + implicit none + type(output_file_type), intent(inout) :: output_file + integer, intent(in) :: stdout + integer, intent(in) :: num_kpts + integer, intent(in) :: num_valence_bands + logical, intent(in) :: disentanglement, gamma_only + character(len=50), intent(in) :: seedname + + logical :: found, hr_plot + + output_file%write_xyz = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'write_xyz', found, l_value=output_file%write_xyz) + + output_file%write_r2mn = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'write_r2mn', found, l_value=output_file%write_r2mn) + + output_file%write_proj = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'write_proj', found, l_value=output_file%write_proj) + + output_file%write_hr_diag = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'write_hr_diag', found, & + l_value=output_file%write_hr_diag) + + hr_plot = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'hr_plot', found, l_value=hr_plot) + if (found) call io_error('Input parameter hr_plot is no longer used. Please use write_hr instead.', stdout, seedname) + output_file%write_hr = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'write_hr', found, l_value=output_file%write_hr) + + output_file%write_rmn = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'write_rmn', found, l_value=output_file%write_rmn) + + output_file%write_tb = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'write_tb', found, l_value=output_file%write_tb) + + !%%%%%%%%%%%%%%%% + ! Other Stuff + !%%%%%%%%%%%%%%%% + + ! aam: vdW + output_file%write_vdw_data = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'write_vdw_data', found, & + l_value=output_file%write_vdw_data) + if (output_file%write_vdw_data) then + if ((.not. gamma_only) .or. (num_kpts .ne. 1)) & + call io_error('Error: write_vdw_data may only be used with a single k-point at Gamma', & + stdout, seedname) + endif + if (output_file%write_vdw_data .and. disentanglement .and. num_valence_bands <= 0) & + call io_error('If writing vdw data and disentangling then num_valence_bands must be defined', stdout, seedname) + + output_file%write_u_matrices = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'write_u_matrices', found, & + l_value=output_file%write_u_matrices) + + output_file%write_bvec = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'write_bvec', found, l_value=output_file%write_bvec) + + end subroutine w90_wannier90_readwrite_read_outfiles + + !================================================! + subroutine w90_wannier90_readwrite_read_plot_info(wvfn_read, stdout, seedname) + !================================================! + ! Plotting + !================================================! + use w90_io, only: io_error + implicit none + type(wvfn_read_type), intent(out) :: wvfn_read + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + + logical :: found + character(len=6) :: spin_str + + wvfn_read%formatted = .false. ! formatted or "binary" file + call w90_readwrite_get_keyword(stdout, seedname, 'wvfn_formatted', found, l_value=wvfn_read%formatted) + + wvfn_read%spin_channel = 1 + call w90_readwrite_get_keyword(stdout, seedname, 'spin', found, c_value=spin_str) + if (found) then + if (index(spin_str, 'up') > 0) then + wvfn_read%spin_channel = 1 + elseif (index(spin_str, 'down') > 0) then + wvfn_read%spin_channel = 2 + else + call io_error('Error: unrecognised value of spin found: '//trim(spin_str), stdout, seedname) + end if + end if + + end subroutine w90_wannier90_readwrite_read_plot_info + + !================================================! + subroutine w90_wannier90_readwrite_read_band_plot(band_plot, num_wann, has_kpath, bands_plot, stdout, seedname) + !================================================! + ! Plotting + !================================================! + use w90_io, only: io_error + implicit none + type(band_plot_type), intent(out) :: band_plot + integer, intent(in) :: stdout + integer, intent(in) :: num_wann + logical, intent(in) :: has_kpath + logical, intent(in) :: bands_plot + character(len=50), intent(in) :: seedname + + integer :: ierr, num_project + logical :: found + + band_plot%format = 'gnuplot' + call w90_readwrite_get_keyword(stdout, seedname, 'bands_plot_format', found, c_value=band_plot%format) + + band_plot%mode = 's-k' + call w90_readwrite_get_keyword(stdout, seedname, 'bands_plot_mode', found, c_value=band_plot%mode) + + num_project = 0 + call w90_readwrite_get_range_vector(stdout, seedname, 'bands_plot_project', found, & + num_project, lcount=.true.) + if (found) then + if (num_project < 1) call io_error('Error: problem reading bands_plot_project', stdout, seedname) + if (allocated(band_plot%project)) deallocate (band_plot%project) + allocate (band_plot%project(num_project), stat=ierr) + if (ierr /= 0) call io_error('Error allocating bands_plot_project in w90_wannier90_readwrite_read', stdout, seedname) + call w90_readwrite_get_range_vector(stdout, seedname, 'bands_plot_project', found, & + num_project, .false., band_plot%project) + if (any(band_plot%project < 1) .or. any(band_plot%project > num_wann)) & + call io_error('Error: bands_plot_project asks for a non-valid wannier function to be projected', stdout, seedname) + endif + + if (.not. has_kpath .and. bands_plot) & + call io_error('A bandstructure plot has been requested but there is no kpoint_path block', stdout, seedname) + + ! checks + if (bands_plot) then + if ((index(band_plot%format, 'gnu') .eq. 0) .and. & + (index(band_plot%format, 'xmgr') .eq. 0)) & + call io_error('Error: bands_plot_format not recognised', stdout, seedname) + if ((index(band_plot%mode, 's-k') .eq. 0) .and. (index(band_plot%mode, 'cut') .eq. 0)) & + call io_error('Error: bands_plot_mode not recognised', stdout, seedname) + endif + + end subroutine w90_wannier90_readwrite_read_band_plot + + !================================================! + subroutine w90_wannier90_readwrite_read_wann_plot(wann_plot, num_wann, wannier_plot, stdout, seedname) + !================================================! + ! Plotting + !================================================! + use w90_io, only: io_error + implicit none + type(wannier_plot_type), intent(out) :: wann_plot + integer, intent(in) :: stdout + integer, intent(in) :: num_wann + logical, intent(in) :: wannier_plot + character(len=50), intent(in) :: seedname + + integer :: i, loop, ierr, wann_plot_num + logical :: found + + wann_plot%supercell = 2 + + call w90_readwrite_get_vector_length(stdout, seedname, 'wannier_plot_supercell', found, length=i) + if (found) then + if (i .eq. 1) then + call w90_readwrite_get_keyword_vector(stdout, seedname, 'wannier_plot_supercell', found, 1, & + i_value=wann_plot%supercell) + wann_plot%supercell(2) = wann_plot%supercell(1) + wann_plot%supercell(3) = wann_plot%supercell(1) + elseif (i .eq. 3) then + call w90_readwrite_get_keyword_vector(stdout, seedname, 'wannier_plot_supercell', found, 3, & + i_value=wann_plot%supercell) + else + call io_error('Error: wannier_plot_supercell must be provided as either one integer or a vector of three integers', & + stdout, seedname) + end if + if (any(wann_plot%supercell <= 0)) & + call io_error('Error: wannier_plot_supercell elements must be greater than zero', stdout, seedname) + end if + + wann_plot%format = 'xcrysden' + call w90_readwrite_get_keyword(stdout, seedname, 'wannier_plot_format', found, c_value=wann_plot%format) + + wann_plot%mode = 'crystal' + call w90_readwrite_get_keyword(stdout, seedname, 'wannier_plot_mode', found, c_value=wann_plot%mode) + + wann_plot%spinor_mode = 'total' + call w90_readwrite_get_keyword(stdout, seedname, 'wannier_plot_spinor_mode', found, & + c_value=wann_plot%spinor_mode) + wann_plot%spinor_phase = .true. + call w90_readwrite_get_keyword(stdout, seedname, 'wannier_plot_spinor_phase', found, & + l_value=wann_plot%spinor_phase) + + wann_plot_num = 0 + call w90_readwrite_get_range_vector(stdout, seedname, 'wannier_plot_list', found, & + wann_plot_num, lcount=.true.) + if (found) then + if (wann_plot_num < 1) call io_error('Error: problem reading wannier_plot_list', & + stdout, seedname) + if (allocated(wann_plot%list)) deallocate (wann_plot%list) + allocate (wann_plot%list(wann_plot_num), stat=ierr) + if (ierr /= 0) call io_error('Error allocating wannier_plot_list in w90_wannier90_readwrite_read', & + stdout, seedname) + call w90_readwrite_get_range_vector(stdout, seedname, 'wannier_plot_list', found, & + wann_plot_num, .false., wann_plot%list) + if (any(wann_plot%list < 1) .or. any(wann_plot%list > num_wann)) & + call io_error('Error: wannier_plot_list asks for a non-valid wannier function to be plotted', stdout, seedname) + else + ! we plot all wannier functions + wann_plot_num = num_wann + if (allocated(wann_plot%list)) deallocate (wann_plot%list) + allocate (wann_plot%list(wann_plot_num), stat=ierr) + if (ierr /= 0) call io_error('Error allocating wannier_plot_list in w90_wannier90_readwrite_read', & + stdout, seedname) + do loop = 1, num_wann + wann_plot%list(loop) = loop + end do + end if + + wann_plot%radius = 3.5_dp + call w90_readwrite_get_keyword(stdout, seedname, 'wannier_plot_radius', found, r_value=wann_plot%radius) + + wann_plot%scale = 1.0_dp + call w90_readwrite_get_keyword(stdout, seedname, 'wannier_plot_scale', found, r_value=wann_plot%scale) + + ! checks + if (wannier_plot) then + if ((index(wann_plot%format, 'xcrys') .eq. 0) .and. (index(wann_plot%format, 'cub') .eq. 0)) & + call io_error('Error: wannier_plot_format not recognised', stdout, seedname) + if ((index(wann_plot%mode, 'crys') .eq. 0) .and. (index(wann_plot%mode, 'mol') .eq. 0)) & + call io_error('Error: wannier_plot_mode not recognised', stdout, seedname) + if ((index(wann_plot%spinor_mode, 'total') .eq. 0) & + .and. (index(wann_plot%spinor_mode, 'up') .eq. 0) & + .and. (index(wann_plot%spinor_mode, 'down') .eq. 0)) & + call io_error('Error: wannier_plot_spinor_mode not recognised', stdout, seedname) + if (wann_plot%radius < 0.0_dp) call io_error('Error: wannier_plot_radius must be positive', stdout, seedname) + if (wann_plot%scale < 0.0_dp) call io_error('Error: wannier_plot_scale must be positive', stdout, seedname) + endif + + end subroutine w90_wannier90_readwrite_read_wann_plot + + !================================================! + subroutine w90_wannier90_readwrite_read_fermi_surface(fermi_surface_data, fermi_surface_plot, stdout, seedname) + !================================================! + use w90_io, only: io_error + implicit none + integer, intent(in) :: stdout + type(fermi_surface_plot_type), intent(out) :: fermi_surface_data + logical, intent(in) :: fermi_surface_plot + character(len=50), intent(in) :: seedname + + logical :: found + + fermi_surface_data%num_points = 50 + call w90_readwrite_get_keyword(stdout, seedname, 'fermi_surface_num_points', found, & + i_value=fermi_surface_data%num_points) + + fermi_surface_data%plot_format = 'xcrysden' + call w90_readwrite_get_keyword(stdout, seedname, 'fermi_surface_plot_format', & + found, c_value=fermi_surface_data%plot_format) + + if (fermi_surface_plot) then + if ((index(fermi_surface_data%plot_format, 'xcrys') .eq. 0)) & + call io_error('Error: fermi_surface_plot_format not recognised', stdout, seedname) + if (fermi_surface_data%num_points < 0) & + call io_error('Error: fermi_surface_num_points must be positive', stdout, seedname) + endif + end subroutine w90_wannier90_readwrite_read_fermi_surface + + !================================================! + subroutine w90_wannier90_readwrite_read_one_dim(w90_calculation, band_plot, real_space_ham, one_dim_axis, & + tran_read_ht, stdout, seedname) + !================================================! + use w90_io, only: io_error + implicit none + integer, intent(in) :: stdout + type(w90_calculation_type), intent(in) :: w90_calculation + type(band_plot_type), intent(in) :: band_plot + type(real_space_ham_type), intent(inout) :: real_space_ham + character(len=*), intent(out) :: one_dim_axis + logical, intent(in) :: tran_read_ht + character(len=50), intent(in) :: seedname + + logical :: found + + one_dim_axis = 'none' + call w90_readwrite_get_keyword(stdout, seedname, 'one_dim_axis', found, c_value=one_dim_axis) + real_space_ham%one_dim_dir = 0 + if (index(one_dim_axis, 'x') > 0) real_space_ham%one_dim_dir = 1 + if (index(one_dim_axis, 'y') > 0) real_space_ham%one_dim_dir = 2 + if (index(one_dim_axis, 'z') > 0) real_space_ham%one_dim_dir = 3 + if (w90_calculation%transport .and. .not. tran_read_ht .and. & + (real_space_ham%one_dim_dir .eq. 0)) call io_error('Error: one_dim_axis not recognised', stdout, seedname) + if (w90_calculation%bands_plot .and. (index(band_plot%mode, 'cut') .ne. 0) .and. & + ((real_space_ham%system_dim .ne. 3) .or. & + (index(real_space_ham%dist_cutoff_mode, 'three_dim') .eq. 0)) .and. & + (real_space_ham%one_dim_dir .eq. 0)) & + call io_error('Error: one_dim_axis not recognised', stdout, seedname) + + end subroutine w90_wannier90_readwrite_read_one_dim + + !================================================! + subroutine w90_wannier90_readwrite_read_hamil(hamiltonian, stdout, seedname) + !================================================! + implicit none + integer, intent(in) :: stdout + type(real_space_ham_type), intent(inout) :: hamiltonian + real(kind=dp) :: rv_temp(3) + character(len=50), intent(in) :: seedname + + logical :: found + + hamiltonian%translate_home_cell = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'translate_home_cell', found, & + l_value=hamiltonian%translate_home_cell) + + hamiltonian%automatic_translation = .true. + hamiltonian%translation_centre_frac = 0.0_dp + call w90_readwrite_get_keyword_vector(stdout, seedname, 'translation_centre_frac', found, 3, & + r_value=rv_temp) + if (found) then + hamiltonian%translation_centre_frac = rv_temp + hamiltonian%automatic_translation = .false. + endif + end subroutine w90_wannier90_readwrite_read_hamil + + !================================================! + subroutine w90_wannier90_readwrite_read_bloch_phase(use_bloch_phases, disentanglement, stdout, seedname) + !================================================! + use w90_io, only: io_error + implicit none + integer, intent(in) :: stdout + logical, intent(out) :: use_bloch_phases + logical, intent(in) :: disentanglement + character(len=50), intent(in) :: seedname + + logical :: found + + use_bloch_phases = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'use_bloch_phases', found, l_value=use_bloch_phases) + if (disentanglement .and. use_bloch_phases) & + call io_error('Error: Cannot use bloch phases for disentanglement', stdout, seedname) + end subroutine w90_wannier90_readwrite_read_bloch_phase + + !================================================! + subroutine w90_wannier90_readwrite_read_explicit_kpts(library, w90_calculation, kmesh_info, num_kpts, bohr, stdout, seedname) + !================================================! + + use w90_io, only: io_error + use w90_utility, only: utility_recip_lattice + + implicit none + + ! arguments + type(kmesh_info_type), intent(inout) :: kmesh_info + type(w90_calculation_type), intent(in) :: w90_calculation + integer, intent(in) :: num_kpts + integer, intent(in) :: stdout + real(kind=dp), intent(in) :: bohr + character(len=50), intent(in) :: seedname + logical, intent(in) :: library + + ! local variables + integer, allocatable :: nnkpts_block(:, :) + integer, allocatable :: nnkpts_idx(:) + integer :: i, k, ierr, rows + logical :: found + + ! get the nnkpts block -- this is allowed only in postproc-setup mode + call w90_readwrite_get_block_length(stdout, seedname, 'nnkpts', kmesh_info%explicit_nnkpts, & + rows, library) + if (kmesh_info%explicit_nnkpts) then + kmesh_info%nntot = rows/num_kpts + if (modulo(rows, num_kpts) /= 0) then + call io_error('The number of rows in nnkpts must be a multiple of num_kpts', stdout, seedname) + end if + if (allocated(nnkpts_block)) deallocate (nnkpts_block) + allocate (nnkpts_block(5, rows), stat=ierr) + if (ierr /= 0) call io_error('Error allocating nnkpts_block in w90_wannier90_readwrite_read', stdout, seedname) + call w90_readwrite_get_keyword_block(stdout, seedname, 'nnkpts', found, rows, 5, bohr, i_value=nnkpts_block) + ! check that postproc_setup is true + if (.not. w90_calculation%postproc_setup) & + call io_error('Input parameter nnkpts_block is allowed only if postproc_setup = .true.', stdout, seedname) + ! assign the values in nnkpts_block to nnlist and nncell + ! this keeps track of how many neighbours have been seen for each k-point + if (allocated(nnkpts_idx)) deallocate (nnkpts_idx) + allocate (nnkpts_idx(num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating nnkpts_idx in w90_wannier90_readwrite_read', stdout, seedname) + nnkpts_idx = 1 + ! allocating "global" nnlist & nncell + ! These are deallocated in kmesh_dealloc + if (allocated(kmesh_info%nnlist)) deallocate (kmesh_info%nnlist) + allocate (kmesh_info%nnlist(num_kpts, kmesh_info%nntot), stat=ierr) + if (ierr /= 0) call io_error('Error allocating nnlist in w90_wannier90_readwrite_read', stdout, seedname) + if (allocated(kmesh_info%nncell)) deallocate (kmesh_info%nncell) + allocate (kmesh_info%nncell(3, num_kpts, kmesh_info%nntot), stat=ierr) + if (ierr /= 0) call io_error('Error allocating nncell in w90_wannier90_readwrite_read', stdout, seedname) + do i = 1, num_kpts*kmesh_info%nntot + k = nnkpts_block(1, i) + kmesh_info%nnlist(k, nnkpts_idx(k)) = nnkpts_block(2, i) + kmesh_info%nncell(:, k, nnkpts_idx(k)) = nnkpts_block(3:, i) + nnkpts_idx(k) = nnkpts_idx(k) + 1 + end do + ! check that all k-points have the same number of neighbours + if (any(nnkpts_idx /= (/(kmesh_info%nntot + 1, i=1, num_kpts)/))) then + call io_error('Inconsistent number of nearest neighbours.', stdout, seedname) + end if + deallocate (nnkpts_idx, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating nnkpts_idx in w90_wannier90_readwrite_read', stdout, seedname) + deallocate (nnkpts_block, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating nnkpts_block in w90_wannier90_readwrite_read', stdout, seedname) + end if + + end subroutine w90_wannier90_readwrite_read_explicit_kpts + + !================================================! + subroutine w90_wannier90_readwrite_read_projections(proj, use_bloch_phases, lhasproj, & + guiding_centres, proj_input, select_proj, & + num_proj, atom_data, recip_lattice, & + num_wann, gamma_only, spinors, library, & + bohr, stdout, seedname) + !================================================! + use w90_io, only: io_error + + implicit none + + type(atom_data_type), intent(in) :: atom_data + type(proj_input_type), intent(inout) :: proj + type(proj_input_type), intent(inout) :: proj_input + type(select_projection_type), intent(inout) :: select_proj + integer, intent(in) :: num_wann + integer, intent(inout) :: num_proj + real(kind=dp), intent(in) :: bohr + real(kind=dp), intent(in) :: recip_lattice(3, 3) + character(len=50), intent(in) :: seedname + logical, intent(in) :: gamma_only + logical, intent(in) :: spinors + logical, intent(in) :: use_bloch_phases, guiding_centres, library + logical, intent(out) :: lhasproj + + integer, intent(in) :: stdout + integer :: i, j, i_temp, loop, ierr + logical :: found + ! projections selection + integer :: num_select_projections + integer, allocatable :: select_projections(:) + + ! Projections + proj_input%auto_projections = .false. + call w90_readwrite_get_keyword(stdout, seedname, 'auto_projections', found, & + l_value=proj_input%auto_projections) + num_proj = 0 + call w90_readwrite_get_block_length(stdout, seedname, 'projections', found, i_temp, library) + ! check to see that there are no unrecognised keywords + if (found) then + if (proj_input%auto_projections) call io_error('Error: Cannot specify both auto_projections and projections block', & + stdout, seedname) + lhasproj = .true. + call w90_readwrite_get_projections(num_proj, atom_data, num_wann, proj_input, & + proj, recip_lattice, .true., spinors, bohr, stdout, seedname) + else + if (guiding_centres .and. .not. (gamma_only .and. use_bloch_phases)) & + call io_error('w90_wannier90_readwrite_read: Guiding centres requested, but no projection block found', stdout, seedname) + lhasproj = .false. + num_proj = num_wann + end if + + select_proj%lselproj = .false. + num_select_projections = 0 + call w90_readwrite_get_range_vector(stdout, seedname, 'select_projections', found, & + num_select_projections, lcount=.true.) + if (found) then + if (num_select_projections < 1) call io_error('Error: problem reading select_projections', stdout, seedname) + if (allocated(select_projections)) deallocate (select_projections) + allocate (select_projections(num_select_projections), stat=ierr) + if (ierr /= 0) call io_error('Error allocating select_projections in w90_wannier90_readwrite_read', stdout, seedname) + call w90_readwrite_get_range_vector(stdout, seedname, 'select_projections', found, & + num_select_projections, .false., select_projections) + if (any(select_projections < 1)) & + call io_error('Error: select_projections must contain positive numbers', stdout, seedname) + if (num_select_projections < num_wann) & + call io_error('Error: too few projections selected', stdout, seedname) + if (num_select_projections > num_wann) & + call io_error('Error: too many projections selected', stdout, seedname) + if (.not. lhasproj) & + call io_error('Error: select_projections cannot be used without defining the projections', stdout, seedname) + if (maxval(select_projections(:)) > num_proj) & + call io_error('Error: select_projections contains a number greater than num_proj', stdout, seedname) + select_proj%lselproj = .true. + end if + + if (allocated(select_proj%proj2wann_map)) deallocate (select_proj%proj2wann_map) + allocate (select_proj%proj2wann_map(num_proj), stat=ierr) + if (ierr /= 0) call io_error('Error allocating proj2wann_map in w90_wannier90_readwrite_read', stdout, seedname) + select_proj%proj2wann_map = -1 + + if (select_proj%lselproj) then + do i = 1, num_proj + do j = 1, num_wann + if (select_projections(j) == i) select_proj%proj2wann_map(i) = j + enddo + enddo + else + do i = 1, num_wann + select_proj%proj2wann_map(i) = i + enddo + endif + + if (lhasproj) then + call w90_readwrite_get_projections(num_proj, atom_data, num_wann, proj_input, & + proj, recip_lattice, .false., spinors, bohr, stdout, seedname) + do loop = 1, num_proj + if (select_proj%proj2wann_map(loop) < 0) cycle + proj%site(:, select_proj%proj2wann_map(loop)) = proj_input%site(:, loop) + proj%l(select_proj%proj2wann_map(loop)) = proj_input%l(loop) + proj%m(select_proj%proj2wann_map(loop)) = proj_input%m(loop) + proj%z(:, select_proj%proj2wann_map(loop)) = proj_input%z(:, loop) + proj%x(:, select_proj%proj2wann_map(loop)) = proj_input%x(:, loop) + proj%radial(select_proj%proj2wann_map(loop)) = proj_input%radial(loop) + proj%zona(select_proj%proj2wann_map(loop)) = proj_input%zona(loop) + enddo + + if (spinors) then + do loop = 1, num_proj + if (select_proj%proj2wann_map(loop) < 0) cycle + proj%s(select_proj%proj2wann_map(loop)) = proj_input%s(loop) + proj%s_qaxis(:, select_proj%proj2wann_map(loop)) = proj_input%s_qaxis(:, loop) + enddo + endif + endif + + end subroutine w90_wannier90_readwrite_read_projections + + !================================================! + subroutine w90_wannier90_readwrite_read_constrained_centres(ccentres_frac, wann_control, real_lattice, & + num_wann, library, stdout, seedname) + !================================================! + use w90_io, only: io_error + implicit none + real(kind=dp), intent(inout) :: ccentres_frac(:, :) + type(wann_control_type), intent(inout) :: wann_control + real(kind=dp), intent(in) :: real_lattice(3, 3) + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + logical, intent(in) :: library + character(len=50), intent(in) :: seedname + + integer :: i_temp + logical :: found + + ! Constrained centres + call w90_readwrite_get_block_length(stdout, seedname, 'slwf_centres', found, i_temp, library) + if (found) then + if (wann_control%constrain%constrain) then + ! Allocate array for constrained centres + call w90_readwrite_get_centre_constraints(ccentres_frac, & + wann_control%constrain%centres, & + wann_control%guiding_centres%centres, & + num_wann, real_lattice, stdout, seedname) + else + write (stdout, '(a)') ' slwf_constrain set to false. Ignoring block ' + end if + ! Check that either projections or constrained centres are specified if slwf_constrain=.true. + elseif (.not. found) then + if (wann_control%constrain%constrain) then + if (.not. allocated(wann_control%guiding_centres%centres)) then + call io_error('Error: slwf_constrain = true, but neither & + & block nor & + & are specified.', stdout, seedname) + else + ! Allocate array for constrained centres + call w90_readwrite_get_centre_constraints(ccentres_frac, & + wann_control%constrain%centres, & + wann_control%guiding_centres%centres, & + num_wann, real_lattice, stdout, seedname) + end if + end if + end if + ! Warning + if (wann_control%constrain%constrain .and. allocated(wann_control%guiding_centres%centres) & + .and. .not. found) & + & write (stdout, '(a)') ' Warning: No block found, but slwf_constrain set to true. & + & Desired centres for SLWF same as projection centres.' + end subroutine w90_wannier90_readwrite_read_constrained_centres + + !================================================! + subroutine w90_wannier90_readwrite_write(atom_data, band_plot, dis_control, dis_spheres, fermi_energy_list, & + fermi_surface_data, kpt_latt, output_file, wvfn_read, wann_control, proj, & + proj_input, real_space_ham, select_proj, kpoint_path, tran, print_output, & + wannier_data, wann_plot, w90_extra_io, w90_calculation, real_lattice, & + symmetrize_eps, mp_grid, num_bands, num_kpts, num_proj, num_wann, & + optimisation, cp_pp, gamma_only, lsitesymmetry, spinors, & + use_bloch_phases, stdout) + !================================================! + ! + !! write wannier90 parameters to stdout + ! + !================================================ + use w90_utility, only: utility_recip_lattice_base, utility_inverse_mat, utility_cart_to_frac, & + utility_frac_to_cart + + implicit none + + !passed vaiables + type(w90_calculation_type), intent(in) :: w90_calculation + type(output_file_type), intent(in) :: output_file + type(real_space_ham_type), intent(in) :: real_space_ham + type(wvfn_read_type), intent(in) :: wvfn_read + type(print_output_type), intent(in) :: print_output + type(band_plot_type), intent(in) :: band_plot + type(wann_control_type), intent(in) :: wann_control + type(wannier_data_type), intent(in) :: wannier_data + type(dis_control_type), intent(in) :: dis_control + type(dis_spheres_type), intent(in) :: dis_spheres + type(fermi_surface_plot_type), intent(in) :: fermi_surface_data + type(transport_type), intent(in) :: tran + type(atom_data_type), intent(in) :: atom_data + type(select_projection_type), intent(in) :: select_proj + type(proj_input_type), intent(in) :: proj_input + type(kpoint_path_type), intent(in) :: kpoint_path + type(w90_extra_io_type), intent(in) :: w90_extra_io + type(wannier_plot_type), intent(in) :: wann_plot + type(proj_input_type), intent(in) :: proj + + integer, intent(in) :: num_bands + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_proj + integer, intent(in) :: num_kpts + integer, intent(in) :: optimisation + + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: symmetrize_eps + real(kind=dp), intent(in) :: kpt_latt(:, :) + real(kind=dp), allocatable, intent(in) :: fermi_energy_list(:) + + ! RS: symmetry-adapted Wannier functions + logical, intent(in) :: lsitesymmetry + logical, intent(in) :: cp_pp, use_bloch_phases + logical, intent(in) :: gamma_only + logical, intent(in) :: spinors + + ! local variables + real(kind=dp) :: recip_lattice(3, 3), inv_lattice(3, 3), pos_frac(3), kpt_cart(3), volume + integer :: i, nkp, loop, nat, nsp, bands_num_spec_points + real(kind=dp) :: cell_volume + logical :: disentanglement + + disentanglement = (num_bands > num_wann) + if (w90_calculation%transport .and. tran%read_ht) goto 401 + + ! System + write (stdout, *) + write (stdout, '(36x,a6)') '------' + write (stdout, '(36x,a6)') 'SYSTEM' + write (stdout, '(36x,a6)') '------' + write (stdout, *) + if (print_output%lenconfac .eq. 1.0_dp) then + write (stdout, '(30x,a21)') 'Lattice Vectors (Ang)' + else + write (stdout, '(28x,a22)') 'Lattice Vectors (Bohr)' + endif + write (stdout, 101) 'a_1', (real_lattice(1, I)*print_output%lenconfac, i=1, 3) + write (stdout, 101) 'a_2', (real_lattice(2, I)*print_output%lenconfac, i=1, 3) + write (stdout, 101) 'a_3', (real_lattice(3, I)*print_output%lenconfac, i=1, 3) + write (stdout, *) + cell_volume = real_lattice(1, 1)*(real_lattice(2, 2)*real_lattice(3, 3) - real_lattice(3, 2)*real_lattice(2, 3)) + & + real_lattice(1, 2)*(real_lattice(2, 3)*real_lattice(3, 1) - real_lattice(3, 3)*real_lattice(2, 1)) + & + real_lattice(1, 3)*(real_lattice(2, 1)*real_lattice(3, 2) - real_lattice(3, 1)*real_lattice(2, 2)) + write (stdout, '(19x,a17,3x,f11.5)', advance='no') & + 'Unit Cell Volume:', cell_volume*print_output%lenconfac**3 + if (print_output%lenconfac .eq. 1.0_dp) then + write (stdout, '(2x,a7)') '(Ang^3)' + else + write (stdout, '(2x,a8)') '(Bohr^3)' + endif + write (stdout, *) + if (print_output%lenconfac .eq. 1.0_dp) then + write (stdout, '(24x,a33)') 'Reciprocal-Space Vectors (Ang^-1)' + else + write (stdout, '(22x,a34)') 'Reciprocal-Space Vectors (Bohr^-1)' + endif + call utility_recip_lattice_base(real_lattice, recip_lattice, volume) + write (stdout, 101) 'b_1', (recip_lattice(1, I)/print_output%lenconfac, i=1, 3) + write (stdout, 101) 'b_2', (recip_lattice(2, I)/print_output%lenconfac, i=1, 3) + write (stdout, 101) 'b_3', (recip_lattice(3, I)/print_output%lenconfac, i=1, 3) + write (stdout, *) ' ' + ! Atoms + if (atom_data%num_atoms > 0) then + write (stdout, '(1x,a)') '*----------------------------------------------------------------------------*' + if (print_output%lenconfac .eq. 1.0_dp) then + write (stdout, '(1x,a)') '| Site Fractional Coordinate Cartesian Coordinate (Ang) |' + else + write (stdout, '(1x,a)') '| Site Fractional Coordinate Cartesian Coordinate (Bohr) |' + endif + write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' + call utility_inverse_mat(real_lattice, inv_lattice) + do nsp = 1, atom_data%num_species + do nat = 1, atom_data%species_num(nsp) + call utility_cart_to_frac(atom_data%pos_cart(:, nat, nsp), pos_frac, inv_lattice) + write (stdout, '(1x,a1,1x,a2,1x,i3,3F10.5,3x,a1,1x,3F10.5,4x,a1)') & + & '|', atom_data%symbol(nsp), nat, pos_frac(:),& + & '|', atom_data%pos_cart(:, nat, nsp)*print_output%lenconfac, '|' + end do + end do + write (stdout, '(1x,a)') '*----------------------------------------------------------------------------*' + else + write (stdout, '(25x,a)') 'No atom positions specified' + end if + ! Constrained centres + if (wann_control%constrain%selective_loc .and. & + wann_control%constrain%constrain) then + write (stdout, *) ' ' + write (stdout, '(1x,a)') '*----------------------------------------------------------------------------*' + write (stdout, '(1x,a)') '| Wannier# Original Centres Constrained centres |' + write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' + do i = 1, wann_control%constrain%slwf_num + write (stdout, '(1x,a1,2x,i3,2x,3F10.5,3x,a1,1x,3F10.5,4x,a1)') & + & '|', i, w90_extra_io%ccentres_frac(i, :), '|', wannier_data%centres(:, i), '|' + end do + write (stdout, '(1x,a)') '*----------------------------------------------------------------------------*' + end if + ! Projections + if (print_output%iprint > 1 .and. allocated(proj_input%site)) then + write (stdout, '(32x,a)') '-----------' + write (stdout, '(32x,a)') 'PROJECTIONS' + write (stdout, '(32x,a)') '-----------' + write (stdout, *) ' ' + write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' + write (stdout, '(1x,a)') '| Frac. Coord. l mr r z-axis x-axis Z/a |' + write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' + do nsp = 1, num_proj + write (stdout, '(1x,a1,3(1x,f5.2),1x,i2,1x,i2,1x,i2,3(1x,f6.3),3(1x,f6.3),2x,f4.1,1x,a1)') & + '|', proj_input%site(1, nsp), proj_input%site(2, nsp), & + proj_input%site(3, nsp), proj_input%l(nsp), & + proj_input%m(nsp), proj_input%radial(nsp), & + proj_input%z(1, nsp), proj_input%z(2, nsp), & + proj_input%z(3, nsp), proj_input%x(1, nsp), & + proj_input%x(2, nsp), proj_input%x(3, nsp), & + proj_input%zona(nsp), '|' + end do + write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' + write (stdout, *) ' ' + end if + + if (print_output%iprint > 1 .and. select_proj%lselproj .and. & + allocated(wann_control%guiding_centres%centres)) then + write (stdout, '(30x,a)') '--------------------' + write (stdout, '(30x,a)') 'SELECTED PROJECTIONS' + write (stdout, '(30x,a)') '--------------------' + write (stdout, *) ' ' + write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' + write (stdout, '(1x,a)') '| Frac. Coord. l mr r z-axis x-axis Z/a |' + write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' + do nsp = 1, num_wann + if (select_proj%proj2wann_map(nsp) < 0) cycle + write (stdout, '(1x,a1,3(1x,f5.2),1x,i2,1x,i2,1x,i2,3(1x,f6.3),3(1x,f6.3),2x,f4.1,1x,a1)')& + & '|', wann_control%guiding_centres%centres(1, nsp), & + wann_control%guiding_centres%centres(2, nsp), & + wann_control%guiding_centres%centres(3, nsp), proj%l(nsp), & + proj%m(nsp), proj%radial(nsp), & + proj%z(1, nsp), proj%z(2, nsp), proj%z(3, nsp), proj%x(1, nsp), & + proj%x(2, nsp), proj%x(3, nsp), proj%zona(nsp), '|' + end do + write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' + write (stdout, *) ' ' + end if + + ! K-points + write (stdout, '(32x,a)') '------------' + write (stdout, '(32x,a)') 'K-POINT GRID' + write (stdout, '(32x,a)') '------------' + write (stdout, *) ' ' + write (stdout, '(13x,a,i3,1x,a1,i3,1x,a1,i3,6x,a,i5)') 'Grid size =', mp_grid(1), 'x', mp_grid(2), 'x', mp_grid(3), & + 'Total points =', num_kpts + write (stdout, *) ' ' + if (print_output%iprint > 1) then + write (stdout, '(1x,a)') '*----------------------------------------------------------------------------*' + if (print_output%lenconfac .eq. 1.0_dp) then + write (stdout, '(1x,a)') '| k-point Fractional Coordinate Cartesian Coordinate (Ang^-1) |' + else + write (stdout, '(1x,a)') '| k-point Fractional Coordinate Cartesian Coordinate (Bohr^-1) |' + endif + write (stdout, '(1x,a)') '+----------------------------------------------------------------------------+' + do nkp = 1, num_kpts + call utility_frac_to_cart(kpt_latt(:, nkp), kpt_cart, recip_lattice) + write (stdout, '(1x,a1,i6,1x,3F10.5,3x,a1,1x,3F10.5,4x,a1)') '|', nkp, kpt_latt(:, nkp), '|', & + kpt_cart(:)/print_output%lenconfac, '|' + end do + write (stdout, '(1x,a)') '*----------------------------------------------------------------------------*' + write (stdout, *) ' ' + end if + ! Main + write (stdout, *) ' ' + write (stdout, '(1x,a78)') '*---------------------------------- MAIN ------------------------------------*' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Number of Wannier Functions :', num_wann, '|' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Number of Objective Wannier Functions :', & + wann_control%constrain%slwf_num, '|' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Number of input Bloch states :', num_bands, '|' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Output verbosity (1=low, 5=high) :', print_output%iprint, '|' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Timing Level (1=low, 5=high) :', print_output%timing_level, '|' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Optimisation (0=memory, 3=speed) :', optimisation, '|' + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Length Unit :', trim(print_output%length_unit), '|' + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Post-processing setup (write *.nnkp) :', & + w90_calculation%postproc_setup, '|' + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Using Gamma-only branch of algorithms :', gamma_only, '|' + !YN: RS: + if (lsitesymmetry) then + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Using symmetry-adapted WF mode :', lsitesymmetry, '|' + write (stdout, '(1x,a46,8x,E10.3,13x,a1)') '| Tolerance for symmetry condition on U :', symmetrize_eps, '|' + endif + + if (cp_pp .or. print_output%iprint > 2) & + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| CP code post-processing :', & + cp_pp, '|' + if (w90_calculation%wannier_plot .or. print_output%iprint > 2) then + if (wvfn_read%formatted) then + write (stdout, '(1x,a46,9x,a9,13x,a1)') '| Wavefunction (UNK) file-type :', 'formatted', '|' + else + write (stdout, '(1x,a46,7x,a11,13x,a1)') '| Wavefunction (UNK) file-type :', 'unformatted', '|' + endif + if (wvfn_read%spin_channel == 1) then + write (stdout, '(1x,a46,16x,a2,13x,a1)') '| Wavefunction spin channel :', 'up', '|' + else + write (stdout, '(1x,a46,14x,a4,13x,a1)') '| Wavefunction spin channel :', 'down', '|' + endif + endif + + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + + ! Wannierise + write (stdout, '(1x,a78)') '*------------------------------- WANNIERISE ---------------------------------*' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Total number of iterations :', & + wann_control%num_iter, '|' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Number of CG steps before reset :', & + wann_control%num_cg_steps, '|' + if (wann_control%lfixstep) then + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Fixed step length for minimisation :', & + wann_control%fixed_step, '|' + else + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Trial step length for line search :', & + wann_control%trial_step, '|' + endif + write (stdout, '(1x,a46,8x,E10.3,13x,a1)') '| Convergence tolerence :', & + wann_control%conv_tol, '|' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Convergence window :', & + wann_control%conv_window, '|' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Iterations between writing output :', & + wann_control%num_print_cycles, '|' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Iterations between backing up to disk :', & + wann_control%num_dump_cycles, '|' + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Write r^2_nm to file :', & + output_file%write_r2mn, '|' + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Write xyz WF centres to file :', & + output_file%write_xyz, '|' + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Write on-site energies <0n|H|0n> to file :', & + output_file%write_hr_diag, '|' + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Use guiding centre to control phases :', & + wann_control%guiding_centres%enable, '|' + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Use phases for initial projections :', & + use_bloch_phases, '|' + if (wann_control%guiding_centres%enable .or. print_output%iprint > 2) then + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Iterations before starting guiding centres:', & + wann_control%guiding_centres%num_no_guide_iter, '|' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Iterations between using guiding centres :', & + wann_control%guiding_centres%num_guide_cycles, '|' + end if + if (wann_control%constrain%selective_loc .or. print_output%iprint > 2) then + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Perform selective localization :', & + wann_control%constrain%selective_loc, '|' + end if + if (wann_control%constrain%constrain .or. print_output%iprint > 2) then + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Use constrains in selective localization :', & + wann_control%constrain%constrain, '|' + write (stdout, '(1x,a46,8x,E10.3,13x,a1)') '| Value of the Lagrange multiplier :',& + &wann_control%constrain%lambda, '|' + end if + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + ! + ! Disentanglement + ! + if (disentanglement .or. print_output%iprint > 2) then + write (stdout, '(1x,a78)') '*------------------------------- DISENTANGLE --------------------------------*' + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Using band disentanglement :', & + disentanglement, '|' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Total number of iterations :', dis_control%num_iter, '|' + write (stdout, '(1x,a46,10x,F8.3,13x,a1)') '| Mixing ratio :', dis_control%mix_ratio, '|' + write (stdout, '(1x,a46,8x,ES10.3,13x,a1)') '| Convergence tolerence :', dis_control%conv_tol, '|' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Convergence window :', dis_control%conv_window, '|' + ! GS-start + if (dis_spheres%num .gt. 0) then + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Number of spheres in k-space :', dis_spheres%num, '|' + do nkp = 1, dis_spheres%num + write (stdout, '(1x,a13,I4,a2,2x,3F8.3,a15,F8.3,9x,a1)') & + '| center n.', nkp, ' :', dis_spheres%spheres(1:3, nkp), ', radius =', dis_spheres%spheres(4, nkp), '|' + enddo + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Index of first Wannier band :', & + dis_spheres%first_wann, '|' + endif + ! GS-end + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + end if + ! + ! Plotting + ! + if (w90_calculation%wannier_plot .or. w90_calculation%bands_plot .or. w90_calculation%fermi_surface_plot & + .or. output_file%write_hr .or. print_output%iprint > 2) then + ! + write (stdout, '(1x,a78)') '*-------------------------------- PLOTTING ----------------------------------*' + ! + if (w90_calculation%wannier_plot .or. print_output%iprint > 2) then + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Plotting Wannier functions :', w90_calculation%wannier_plot, '|' + write (stdout, '(1x,a46,1x,I5,a1,I5,a1,I5,13x,a1)') & + '| Size of supercell for plotting :', & + wann_plot%supercell(1), 'x', wann_plot%supercell(2), 'x', wann_plot%supercell(3), '|' + + if (real_space_ham%translate_home_cell) then + write (stdout, '(1x,a46,10x,L8,13x,a1)') & + '| Translating WFs to home cell :', real_space_ham%translate_home_cell, '|' + end if + + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plotting mode (molecule or crystal) :', & + trim(wann_plot%mode), '|' + if (spinors) then + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plotting mode for spinor WFs :', & + trim(wann_plot%spinor_mode), '|' + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Include phase for spinor WFs :', & + wann_plot%spinor_phase, '|' + end if + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plotting format :', & + trim(wann_plot%format), '|' + if (index(wann_plot%format, 'cub') > 0 .or. print_output%iprint > 2) then + write (stdout, '(1x,a46,10x,F8.3,13x,a1)') '| Plot radius :', & + wann_plot%radius, '|' + write (stdout, '(1x,a46,10x,F8.3,13x,a1)') '| Plot scale :', & + wann_plot%scale, '|' + endif + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + end if + ! + if (w90_calculation%fermi_surface_plot .or. print_output%iprint > 2) then + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Plotting Fermi surface :', & + w90_calculation%fermi_surface_plot, '|' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Number of plotting points (along b_1) :', & + fermi_surface_data%num_points, '|' + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Plotting format :', & + trim(fermi_surface_data%plot_format), '|' + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + end if + ! + if (w90_calculation%bands_plot .or. print_output%iprint > 2) then + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Plotting interpolated bandstructure :', w90_calculation%bands_plot, '|' + bands_num_spec_points = 0 + if (allocated(kpoint_path%labels)) bands_num_spec_points = size(kpoint_path%labels) + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Number of K-path sections :', & + bands_num_spec_points/2, '|' + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Divisions along first K-path section :', & + kpoint_path%num_points_first_segment, '|' + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Output format :', & + trim(band_plot%format), '|' + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Output mode :', & + trim(band_plot%mode), '|' + if (index(band_plot%mode, 'cut') .ne. 0) then + write (stdout, '(1x,a46,10x,I8,13x,a1)') '| Dimension of the system :', & + real_space_ham%system_dim, '|' + if (real_space_ham%system_dim .eq. 1) & + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| System extended in :', & + trim(w90_extra_io%one_dim_axis), '|' + if (real_space_ham%system_dim .eq. 2) & + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| System confined in :', & + trim(w90_extra_io%one_dim_axis), '|' + write (stdout, '(1x,a46,10x,F8.3,13x,a1)') '| Hamiltonian cut-off value :', & + real_space_ham%hr_cutoff, '|' + write (stdout, '(1x,a46,10x,F8.3,13x,a1)') '| Hamiltonian cut-off distance :', & + real_space_ham%dist_cutoff, '|' + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Hamiltonian cut-off distance mode :', & + trim(real_space_ham%dist_cutoff_mode), '|' + endif + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + write (stdout, '(1x,a78)') '| K-space path sections: |' + if (bands_num_spec_points == 0) then + write (stdout, '(1x,a78)') '| None defined |' + else + do loop = 1, bands_num_spec_points, 2 + write (stdout, '(1x,a10,1x,a5,1x,3F7.3,5x,a3,1x,a5,1x,3F7.3,3x,a1)') '| From:', & + kpoint_path%labels(loop), (kpoint_path%points(i, loop), i=1, 3), & + 'To:', kpoint_path%labels(loop + 1), (kpoint_path%points(i, loop + 1), i=1, 3), '|' + end do + end if + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + end if + ! + if (output_file%write_hr .or. print_output%iprint > 2) then + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Plotting Hamiltonian in WF basis :', output_file%write_hr, '|' + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + endif + if (output_file%write_vdw_data .or. print_output%iprint > 2) then + write (stdout, '(1x,a46,10x,L8,13x,a1)') '| Writing data for Van der Waals post-proc :', & + output_file%write_vdw_data, '|' + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + endif + ! + endif + +401 continue + ! + ! Transport + ! + if (w90_calculation%transport .or. print_output%iprint > 2) then + ! + write (stdout, '(1x,a78)') '*------------------------------- TRANSPORT ----------------------------------*' + ! + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Transport mode :', trim(tran%mode), '|' + ! + if (tran%read_ht) then + ! + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Hamiltonian from external files :', 'T', '|' + ! + else + ! + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| Hamiltonian from external files :', 'F', '|' + write (stdout, '(1x,a46,10x,a8,13x,a1)') '| System extended in :', & + trim(w90_extra_io%one_dim_axis), '|' + ! + end if + + write (stdout, '(1x,a78)') '| Centre of the unit cell to which WF are translated (fract. coords): |' + write (stdout, '(1x,a1,35x,F12.6,a1,F12.6,a1,F12.6,3x,a1)') '|', real_space_ham%translation_centre_frac(1), ',', & + real_space_ham%translation_centre_frac(2), ',', & + real_space_ham%translation_centre_frac(3), '|' + + if (size(fermi_energy_list) == 1) then + write (stdout, '(1x,a46,10x,f8.3,13x,a1)') '| Fermi energy (eV) :', fermi_energy_list(1), '|' + else + write (stdout, '(1x,a21,I8,a12,f8.3,a4,f8.3,a3,13x,a1)') '| Fermi energy :', size(fermi_energy_list), & + ' steps from ', fermi_energy_list(1), ' to ', & + fermi_energy_list(size(fermi_energy_list)), ' eV', '|' + end if + ! + write (stdout, '(1x,a78)') '*----------------------------------------------------------------------------*' + ! + endif + +101 format(20x, a3, 2x, 3F11.6) + + end subroutine w90_wannier90_readwrite_write + + !================================================! + subroutine w90_wannier90_readwrite_w90_dealloc(atom_data, band_plot, dis_spheres, dis_manifold, exclude_bands, & + kmesh_input, kpt_latt, wann_control, proj, proj_input, select_proj, & + kpoint_path, wannier_data, wann_plot, w90_extra_io, eigval, & + seedname, stdout) + !================================================! + use w90_io, only: io_error + + implicit none + + ! arguments + type(band_plot_type), intent(inout) :: band_plot + type(wann_control_type), intent(inout) :: wann_control + type(wannier_data_type), intent(inout) :: wannier_data + type(kmesh_input_type), intent(inout) :: kmesh_input + type(dis_spheres_type), intent(inout) :: dis_spheres + type(dis_manifold_type), intent(inout) :: dis_manifold + type(atom_data_type), intent(inout) :: atom_data + type(kpoint_path_type), intent(inout) :: kpoint_path + type(select_projection_type), intent(inout) :: select_proj + type(w90_extra_io_type), intent(inout) :: w90_extra_io + type(wannier_plot_type), intent(inout) :: wann_plot + type(proj_input_type), intent(inout) :: proj + type(proj_input_type), intent(inout) :: proj_input + + integer, intent(in) :: stdout + integer, allocatable, intent(inout) :: exclude_bands(:) + + real(kind=dp), allocatable, intent(inout) :: eigval(:, :) + real(kind=dp), allocatable, intent(inout) :: kpt_latt(:, :) + + character(len=50), intent(in) :: seedname + + ! local variables + integer :: ierr + + call w90_readwrite_dealloc(exclude_bands, wannier_data, proj_input, kmesh_input, kpt_latt, & + dis_manifold, atom_data, eigval, kpoint_path, stdout, seedname) + if (allocated(wann_plot%list)) then + deallocate (wann_plot%list, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating wannier_plot_list in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(band_plot%project)) then + deallocate (band_plot%project, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating bands_plot_project in w90_readwrite_dealloc', stdout, seedname) + endif + if (allocated(w90_extra_io%ccentres_frac)) then + deallocate (w90_extra_io%ccentres_frac, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating ccentres_frac in w90_wannier90_readwrite_w90_dealloc', stdout, seedname) + endif + if (allocated(wann_control%guiding_centres%centres)) then + deallocate (wann_control%guiding_centres%centres, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating wannier proj_site in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(wann_control%constrain%centres)) then + deallocate (wann_control%constrain%centres, stat=ierr) + if (ierr /= 0) call io_error('Error deallocating ccentres_cart in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(proj%l)) then + deallocate (proj%l, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating proj_l in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(proj%site)) then + deallocate (proj%site, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating proj_site in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(proj%m)) then + deallocate (proj%m, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating proj_m in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(proj%s)) then + deallocate (proj%s, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating proj_s in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(proj%s_qaxis)) then + deallocate (proj%s_qaxis, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating proj_s_qaxis in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(proj%z)) then + deallocate (proj%z, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating proj_z in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(proj%x)) then + deallocate (proj%x, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating proj_x in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(proj%radial)) then + deallocate (proj%radial, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating proj_radial in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(proj%zona)) then + deallocate (proj%zona, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating proj_zona in w90_readwrite_dealloc', stdout, seedname) + end if + if (allocated(dis_spheres%spheres)) then + deallocate (dis_spheres%spheres, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating dis_spheres in w90_readwrite_dealloc', stdout, seedname) + endif + if (allocated(select_proj%proj2wann_map)) then + deallocate (select_proj%proj2wann_map, stat=ierr) + if (ierr /= 0) call io_error('Error in deallocating select_projections in w90_readwrite_dealloc', & + stdout, seedname) + endif + end subroutine w90_wannier90_readwrite_w90_dealloc + + !================================================! + subroutine w90_wannier90_readwrite_write_chkpt(chkpt, exclude_bands, wannier_data, kmesh_info, kpt_latt, num_kpts, & + dis_manifold, num_bands, num_wann, u_matrix, u_matrix_opt, m_matrix, & + mp_grid, real_lattice, omega_invariant, & + have_disentangled, stdout, seedname) + !================================================! + !! Write checkpoint file + !! IMPORTANT! If you change the chkpt format, adapt + !! accordingly also the w90chk2chk.x utility! + !! Also, note that this routine writes the u_matrix and the m_matrix - in parallel + !! mode these are however stored in distributed form in, e.g., u_matrix_loc only, so + !! if you are changing the u_matrix, remember to gather it from u_matrix_loc first! + !================================================! + + use w90_io, only: io_file_unit, io_date + use w90_utility, only: utility_recip_lattice_base + + implicit none + + ! arguments + type(wannier_data_type), intent(in) :: wannier_data + type(kmesh_info_type), intent(in) :: kmesh_info + type(dis_manifold_type), intent(in) :: dis_manifold + + complex(kind=dp), intent(in) :: m_matrix(:, :, :, :) + complex(kind=dp), intent(in) :: u_matrix(:, :, :) + complex(kind=dp), intent(in) :: u_matrix_opt(:, :, :) + + real(kind=dp), intent(in) :: kpt_latt(:, :) + real(kind=dp), intent(in) :: omega_invariant + real(kind=dp), intent(in) :: real_lattice(3, 3) + + integer, allocatable, intent(in) :: exclude_bands(:) + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_bands + integer, intent(in) :: num_kpts + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + + character(len=50), intent(in) :: seedname + character(len=*), intent(in) :: chkpt + + logical, intent(in) :: have_disentangled + + ! local variables + integer :: chk_unit, nkp, i, j, k, l, num_exclude_bands + real(kind=dp) :: recip_lattice(3, 3), volume + character(len=9) :: cdate, ctime + character(len=33) :: header + character(len=20) :: chkpt1 + + write (stdout, '(/1x,3a)', advance='no') 'Writing checkpoint file ', trim(seedname), '.chk...' + + call io_date(cdate, ctime) + header = 'written on '//cdate//' at '//ctime + + chk_unit = io_file_unit() + open (unit=chk_unit, file=trim(seedname)//'.chk', form='unformatted') + + write (chk_unit) header ! Date and time + write (chk_unit) num_bands ! Number of bands + if (allocated(exclude_bands)) then + num_exclude_bands = size(exclude_bands) + else + num_exclude_bands = 0 + endif + write (chk_unit) num_exclude_bands ! Number of excluded bands + write (chk_unit) (exclude_bands(i), i=1, num_exclude_bands) ! Excluded bands + write (chk_unit) ((real_lattice(i, j), i=1, 3), j=1, 3) ! Real lattice + call utility_recip_lattice_base(real_lattice, recip_lattice, volume) + write (chk_unit) ((recip_lattice(i, j), i=1, 3), j=1, 3) ! Reciprocal lattice + write (chk_unit) num_kpts ! Number of k-points + write (chk_unit) (mp_grid(i), i=1, 3) ! M-P grid + write (chk_unit) ((kpt_latt(i, nkp), i=1, 3), nkp=1, num_kpts) ! K-points + write (chk_unit) kmesh_info%nntot ! Number of nearest k-point neighbours + write (chk_unit) num_wann ! Number of wannier functions + chkpt1 = adjustl(trim(chkpt)) + write (chk_unit) chkpt1 ! Position of checkpoint + write (chk_unit) have_disentangled ! Whether a disentanglement has been performed + if (have_disentangled) then + write (chk_unit) omega_invariant ! Omega invariant + ! lwindow, ndimwin and U_matrix_opt + write (chk_unit) ((dis_manifold%lwindow(i, nkp), i=1, num_bands), nkp=1, num_kpts) + write (chk_unit) (dis_manifold%ndimwin(nkp), nkp=1, num_kpts) + write (chk_unit) (((u_matrix_opt(i, j, nkp), i=1, num_bands), j=1, num_wann), nkp=1, num_kpts) + endif + write (chk_unit) (((u_matrix(i, j, k), i=1, num_wann), j=1, num_wann), k=1, num_kpts) ! U_matrix + write (chk_unit) ((((m_matrix(i, j, k, l), i=1, num_wann), j=1, num_wann), k=1, kmesh_info%nntot), l=1, num_kpts) ! M_matrix + write (chk_unit) ((wannier_data%centres(i, j), i=1, 3), j=1, num_wann) + write (chk_unit) (wannier_data%spreads(i), i=1, num_wann) + close (chk_unit) + + write (stdout, '(a/)') ' done' + + return + + end subroutine w90_wannier90_readwrite_write_chkpt + + !================================================! + subroutine w90_wannier90_readwrite_memory_estimate(atom_data, kmesh_info, wann_control, proj_input, print_output, & + num_bands, num_kpts, num_proj, num_wann, optimisation, & + gamma_only, stdout) + !================================================! + ! + !! Estimate how much memory we will allocate + ! + !================================================! + + implicit none + + ! arguments + type(print_output_type), intent(in) :: print_output + type(wann_control_type), intent(in) :: wann_control + type(kmesh_info_type), intent(in) :: kmesh_info + type(proj_input_type), intent(in) :: proj_input + type(atom_data_type), intent(in) :: atom_data + + integer, intent(in) :: num_bands + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + integer, intent(in) :: num_proj + integer, intent(in) :: num_kpts + integer, intent(in) :: optimisation + logical, intent(in) :: gamma_only + + ! local variables + real(kind=dp), parameter :: size_log = 1.0_dp + real(kind=dp), parameter :: size_int = 4.0_dp + real(kind=dp), parameter :: size_real = 8.0_dp + real(kind=dp), parameter :: size_cmplx = 16.0_dp + real(kind=dp) :: mem_wan, mem_wan1, mem_param, mem_dis, mem_dis2, mem_dis1 + real(kind=dp) :: mem_bw + logical :: disentanglement + + disentanglement = (num_bands > num_wann) + mem_param = 0 + mem_dis = 0 + mem_dis1 = 0 + mem_dis2 = 0 + mem_wan = 0 + mem_wan1 = 0 + mem_bw = 0 + + ! First the data stored in the parameters module + mem_param = mem_param + num_wann*num_wann*num_kpts*size_cmplx !u_matrix + if (.not. disentanglement) & + mem_param = mem_param + num_wann*num_wann*kmesh_info%nntot*num_kpts*size_cmplx !m_matrix + + if (disentanglement) then + mem_param = mem_param + num_bands*num_wann*num_kpts*size_cmplx ! u_matrix_opt + endif + + if (allocated(atom_data%species_num)) then + mem_param = mem_param + (atom_data%num_species)*size_int !atoms_species_num + mem_param = mem_param + (atom_data%num_species)*size_real !atoms_label + mem_param = mem_param + (atom_data%num_species)*size_real !atoms_symbol + !mem_param = mem_param + (3*maxval(atom_data%species_num)*atom_data%num_species)*size_real !atoms_pos_frac + mem_param = mem_param + (3*maxval(atom_data%species_num)*atom_data%num_species)*size_real !atoms_pos_cart + endif + + if (allocated(proj_input%site)) then + mem_param = mem_param + (3*num_proj)*size_real !input_proj_site + mem_param = mem_param + (num_proj)*size_int !input_proj_l + mem_param = mem_param + (num_proj)*size_int !input_proj_m + mem_param = mem_param + (3*num_proj)*size_real !input_proj_z + mem_param = mem_param + (3*num_proj)*size_real !input_proj_x + mem_param = mem_param + (num_proj)*size_real !input_proj_radial + mem_param = mem_param + (num_proj)*size_real !input_proj_zona + endif + + if (allocated(wann_control%guiding_centres%centres)) then + mem_param = mem_param + (3*num_wann)*size_real !proj_site + mem_param = mem_param + (num_wann)*size_int !proj_l + mem_param = mem_param + (num_wann)*size_int !proj_m + mem_param = mem_param + (3*num_wann)*size_real !proj_z + mem_param = mem_param + (3*num_wann)*size_real !proj_x + mem_param = mem_param + (num_wann)*size_real !proj_radial + mem_param = mem_param + (num_wann)*size_real !proj_zona + endif + + mem_param = mem_param + num_kpts*kmesh_info%nntot*size_int !nnlist + mem_param = mem_param + num_kpts*kmesh_info%nntot/2*size_int !neigh + mem_param = mem_param + 3*num_kpts*kmesh_info%nntot*size_int !nncell + mem_param = mem_param + kmesh_info%nntot*size_real !wb + mem_param = mem_param + 3*kmesh_info%nntot/2*size_real !bka + mem_param = mem_param + 3*kmesh_info%nntot*num_kpts*size_real !bk + + mem_param = mem_param + num_bands*num_kpts*size_real !eigval + !mem_param = mem_param + 3*num_kpts*size_real !kpt_cart + mem_param = mem_param + 3*num_kpts*size_real !kpt_latt + if (disentanglement) then + mem_param = mem_param + num_kpts*size_int !ndimwin + mem_param = mem_param + num_bands*num_kpts*size_log !lwindow + endif + mem_param = mem_param + 3*num_wann*size_real !wannier_centres + mem_param = mem_param + num_wann*size_real !wannier_spreads + + if (disentanglement) then + ! Module vars + mem_dis = mem_dis + num_bands*num_kpts*size_real !eigval_opt + mem_dis = mem_dis + num_kpts*size_int !nfirstwin + mem_dis = mem_dis + num_kpts*size_int !ndimfroz + mem_dis = mem_dis + num_bands*num_kpts*size_int !indxfroz + mem_dis = mem_dis + num_bands*num_kpts*size_int !indxnfroz + mem_dis = mem_dis + num_bands*num_kpts*size_log !lfrozen + + !the memory high-water wiil occur in dis_extract or when we allocate m_matrix + + mem_dis1 = mem_dis1 + num_wann*num_bands*size_cmplx !cwb + mem_dis1 = mem_dis1 + num_wann*num_wann*size_cmplx !cww + mem_dis1 = mem_dis1 + num_bands*num_wann*size_cmplx !cbw + mem_dis1 = mem_dis1 + 5*num_bands*size_int !iwork + mem_dis1 = mem_dis1 + num_bands*size_int !ifail + mem_dis1 = mem_dis1 + num_bands*size_real !w + if (gamma_only) then + mem_dis1 = mem_dis1 + (num_bands*(num_bands + 1))/2*size_real !cap_r + mem_dis1 = mem_dis1 + 8*num_bands*size_real !work + mem_dis1 = mem_dis1 + num_bands*num_bands*size_real !rz + else + mem_dis1 = mem_dis1 + 7*num_bands*size_real !rwork + mem_dis1 = mem_dis1 + (num_bands*(num_bands + 1))/2*size_cmplx !cap + mem_dis1 = mem_dis1 + 2*num_bands*size_cmplx !cwork + mem_dis1 = mem_dis1 + num_bands*num_bands*size_cmplx !cz + end if + mem_dis1 = mem_dis1 + num_kpts*size_real !wkomegai1 + mem_dis1 = mem_dis1 + num_bands*num_bands*num_kpts*size_cmplx !ceamp + mem_dis1 = mem_dis1 + num_bands*num_bands*num_kpts*size_cmplx !cham + mem_dis2 = mem_dis2 + num_wann*num_wann*kmesh_info%nntot*num_kpts*size_cmplx!m_matrix + + if (optimisation <= 0) then + mem_dis = mem_dis + mem_dis1 + else + mem_dis = mem_dis + max(mem_dis1, mem_dis2) + endif + + mem_dis = mem_dis + num_bands*num_bands*kmesh_info%nntot*num_kpts*size_cmplx ! m_matrix_orig + mem_dis = mem_dis + num_bands*num_wann*num_kpts*size_cmplx ! a_matrix + + endif + + !Wannierise + + mem_wan1 = mem_wan1 + (num_wann*num_wann*kmesh_info%nntot*num_kpts)*size_cmplx ! 'm0' + if (optimisation > 0) then + mem_wan = mem_wan + mem_wan1 + endif + mem_wan = mem_wan + (num_wann*num_wann*num_kpts)*size_cmplx ! 'u0' + mem_wan = mem_wan + (num_wann*kmesh_info%nntot*num_kpts)*size_real ! 'rnkb' + mem_wan = mem_wan + (num_wann*kmesh_info%nntot*num_kpts)*size_real ! 'ln_tmp' + mem_wan = mem_wan + (num_wann*kmesh_info%nntot*num_kpts)*size_cmplx ! 'csheet' + mem_wan = mem_wan + (num_wann*kmesh_info%nntot*num_kpts)*size_real ! 'sheet' + mem_wan = mem_wan + (3*num_wann)*size_real ! 'rave' + mem_wan = mem_wan + (num_wann)*size_real ! 'r2ave' + mem_wan = mem_wan + (num_wann)*size_real ! 'rave2' + mem_wan = mem_wan + (3*num_wann)*size_real ! 'rguide' + mem_wan = mem_wan + (num_wann*num_wann)*size_cmplx ! 'cz' + if (gamma_only) then + mem_wan = mem_wan + num_wann*num_wann*kmesh_info%nntot*2*size_cmplx ! m_w + mem_wan = mem_wan + num_wann*num_wann*size_cmplx ! uc_rot + mem_wan = mem_wan + num_wann*num_wann*size_real ! ur_rot + !internal_svd_omega_i + mem_wan = mem_wan + 10*num_wann*size_cmplx ! cw1 + mem_wan = mem_wan + 10*num_wann*size_cmplx ! cw2 + mem_wan = mem_wan + num_wann*num_wann*size_cmplx ! cv1 + mem_wan = mem_wan + num_wann*num_wann*size_cmplx ! cv2 + mem_wan = mem_wan + num_wann*num_wann*size_real ! cpad1 + mem_wan = mem_wan + num_wann*size_cmplx ! singvd + else + mem_wan = mem_wan + (num_wann)*size_cmplx ! 'cwschur1' + mem_wan = mem_wan + (10*num_wann)*size_cmplx ! 'cwschur2' + mem_wan = mem_wan + (num_wann)*size_cmplx ! 'cwschur3' + mem_wan = mem_wan + (num_wann)*size_cmplx ! 'cwschur4' + mem_wan = mem_wan + (num_wann*num_wann*num_kpts)*size_cmplx ! 'cdq' + mem_wan = mem_wan + (num_wann*num_wann)*size_cmplx ! 'cmtmp' + mem_wan = mem_wan + (num_wann*num_wann*num_kpts)*size_cmplx ! 'cdqkeep' + mem_wan = mem_wan + (num_wann*num_wann)*size_cmplx ! 'tmp_cdq' + mem_wan = mem_wan + (num_wann)*size_real ! 'evals' + mem_wan = mem_wan + (4*num_wann)*size_cmplx ! 'cwork' + mem_wan = mem_wan + (3*num_wann - 2)*size_real ! 'rwork' + !d_omega + mem_wan = mem_wan + (num_wann*num_wann)*size_cmplx ! 'cr' + mem_wan = mem_wan + (num_wann*num_wann)*size_cmplx ! 'crt' + end if + + if (disentanglement) & + mem_wan = mem_wan + num_wann*num_wann*kmesh_info%nntot*num_kpts*size_cmplx !m_matrix + + if (print_output%iprint > 0) then + write (stdout, '(1x,a)') '*============================================================================*' + write (stdout, '(1x,a)') '| MEMORY ESTIMATE |' + write (stdout, '(1x,a)') '| Maximum RAM allocated during each phase of the calculation |' + write (stdout, '(1x,a)') '*============================================================================*' + if (disentanglement) & + write (stdout, '(1x,"|",24x,a15,f16.2,a,18x,"|")') 'Disentanglement:', (mem_param + mem_dis)/(1024**2), ' Mb' + write (stdout, '(1x,"|",24x,a15,f16.2,a,18x,"|")') 'Wannierise:', (mem_param + mem_wan)/(1024**2), ' Mb' + if (optimisation > 0 .and. print_output%iprint > 1) then + write (stdout, '(1x,a)') '| |' + write (stdout, '(1x,a)') '| N.B. by setting optimisation=0 memory usage will be reduced to: |' + if (disentanglement) & + write (stdout, '(1x,"|",24x,a15,f16.2,a,18x,"|")') 'Disentanglement:', & + (mem_param + mem_dis - max(mem_dis1, mem_dis2) + mem_dis1)/(1024**2), ' Mb' + if (gamma_only) then + write (stdout, '(1x,"|",24x,a15,f16.2,a,18x,"|")') 'Wannierise:', (mem_param + mem_wan)/(1024**2), ' Mb' + else + write (stdout, '(1x,"|",24x,a15,f16.2,a,18x,"|")') 'Wannierise:', & + (mem_param + mem_wan - mem_wan1)/(1024**2), ' Mb' + end if + write (stdout, '(1x,a)') '| However, this will result in more i/o and slow down the calculation |' + endif + + write (stdout, '(1x,"|",24x,a15,f16.2,a,18x,"|")') 'plot_wannier:', (mem_param + mem_wan)/(1024**2), ' Mb' + write (stdout, '(1x,a)') '*----------------------------------------------------------------------------*' + write (stdout, *) ' ' + endif + +! if(w90_calculation%disentanglement) then +! write(*,'(a12,f12.4,a)') 'Disentangle',(mem_param+mem_dis)/(1024**2),' Mb' +! end if +! write(*,'(a12,f12.4,a)') 'Wannierise ',(mem_wan+mem_param)/(1024**2),' Mb' +! write(*,'(a12,f12.4,a)') 'Module',(mem_param)/(1024**2),' Mb' + + return + end subroutine w90_wannier90_readwrite_memory_estimate + + !================================================! + subroutine w90_wannier90_readwrite_dist(atom_data, band_plot, dis_control, dis_spheres, & + dis_manifold, exclude_bands, fermi_energy_list, & + fermi_surface_data, kmesh_input, kmesh_info, kpt_latt, & + output_file, wvfn_read, wann_control, wann_omega, & + proj_input, real_space_ham, w90_system, tran, & + print_output, wannier_data, wann_plot, ws_region, & + w90_calculation, eigval, real_lattice, symmetrize_eps, & + mp_grid, first_segment, num_bands, num_kpts, num_proj, & + num_wann, optimisation, eig_found, cp_pp, gamma_only, & + have_disentangled, lhasproj, lsitesymmetry, & + use_bloch_phases, seedname, stdout, comm) + !================================================! + ! + !! Distribute the various parameters across processors + ! + !================================================! + + use w90_constants, only: dp + use w90_io, only: io_error, io_file_unit, io_date, io_time + use w90_comms, only: comms_bcast, w90comm_type, mpirank + + implicit none + + ! arguments + type(atom_data_type), intent(inout) :: atom_data + type(band_plot_type), intent(inout) :: band_plot + type(dis_control_type), intent(inout) :: dis_control + type(dis_manifold_type), intent(inout) :: dis_manifold + type(dis_spheres_type), intent(inout) :: dis_spheres + type(fermi_surface_plot_type), intent(inout) :: fermi_surface_data + type(kmesh_info_type), intent(inout) :: kmesh_info + type(kmesh_input_type), intent(inout) :: kmesh_input + type(output_file_type), intent(inout) :: output_file + type(print_output_type), intent(inout) :: print_output + type(proj_input_type), intent(inout) :: proj_input + type(real_space_ham_type), intent(inout) :: real_space_ham + type(transport_type), intent(inout) :: tran + type(w90_calculation_type), intent(inout) :: w90_calculation + type(w90comm_type), intent(in) :: comm + type(w90_system_type), intent(inout) :: w90_system + type(wann_control_type), intent(inout) :: wann_control + type(wannier_data_type), intent(inout) :: wannier_data + type(wannier_plot_type), intent(inout) :: wann_plot + type(wann_omega_type), intent(inout) :: wann_omega + type(ws_region_type), intent(inout) :: ws_region + type(wvfn_read_type), intent(inout) :: wvfn_read + + integer, allocatable, intent(inout) :: exclude_bands(:) + integer, intent(inout) :: first_segment + integer, intent(inout) :: num_bands + integer, intent(inout) :: num_wann + integer, intent(inout) :: stdout + integer, intent(inout) :: mp_grid(3) + integer, intent(inout) :: num_proj + integer, intent(inout) :: num_kpts + integer, intent(inout) :: optimisation + + real(kind=dp), allocatable, intent(inout) :: eigval(:, :) + real(kind=dp), allocatable, intent(inout) :: fermi_energy_list(:) + real(kind=dp), allocatable, intent(inout) :: kpt_latt(:, :) + real(kind=dp), intent(inout) :: real_lattice(3, 3) + real(kind=dp), intent(inout) :: symmetrize_eps + + character(len=50), intent(in) :: seedname + + logical, intent(inout) :: eig_found + logical, intent(inout) :: cp_pp + logical, intent(inout) :: gamma_only + logical, intent(inout) :: have_disentangled + logical, intent(inout) :: lhasproj + logical, intent(inout) :: lsitesymmetry ! RS: symmetry-adapted Wannier functions + logical, intent(inout) :: use_bloch_phases + + ! local variables + logical :: on_root = .false. + integer :: ierr + integer :: iprintroot + integer :: num_project, wann_plot_num, num_exclude_bands, fermi_n + logical :: disentanglement + + if (mpirank(comm) == 0) on_root = .true. + + !call comms_bcast(pw90_common%effective_model, 1) + call comms_bcast(eig_found, 1, stdout, seedname, comm) + call comms_bcast(w90_calculation%postproc_setup, 1, stdout, seedname, comm) + call comms_bcast(cp_pp, 1, stdout, seedname, comm) + !if (.not. pw90_common%effective_model) then + call comms_bcast(mp_grid(1), 3, stdout, seedname, comm) + call comms_bcast(num_kpts, 1, stdout, seedname, comm) + call comms_bcast(num_bands, 1, stdout, seedname, comm) + !endif + call comms_bcast(num_wann, 1, stdout, seedname, comm) + call comms_bcast(print_output%timing_level, 1, stdout, seedname, comm) + + disentanglement = (num_bands > num_wann) + + !______________________________________ + !JJ fixme maybe? not so pretty solution to setting iprint to zero on non-root processes + iprintroot = print_output%iprint + print_output%iprint = 0 + call comms_bcast(print_output%iprint, 1, stdout, seedname, comm) + if (on_root) print_output%iprint = iprintroot + !______________________________________ + + !call comms_bcast(energy_unit, 1, stdout, seedname, comm) + call comms_bcast(print_output%length_unit, 1, stdout, seedname, comm) + call comms_bcast(wvfn_read%formatted, 1, stdout, seedname, comm) + !call comms_bcast(postw90_oper%spn_formatted, 1) + !call comms_bcast(postw90_oper%uHu_formatted, 1) + !call comms_bcast(berry_uHu_formatted, 1) + call comms_bcast(wvfn_read%spin_channel, 1, stdout, seedname, comm) + call comms_bcast(wann_control%num_dump_cycles, 1, stdout, seedname, comm) + call comms_bcast(wann_control%num_print_cycles, 1, stdout, seedname, comm) + call comms_bcast(atom_data%num_atoms, 1, stdout, seedname, comm) ! Ivo: not used in postw90, right? + call comms_bcast(atom_data%num_species, 1, stdout, seedname, comm) ! Ivo: not used in postw90, right? + call comms_bcast(real_lattice(1, 1), 9, stdout, seedname, comm) + !call comms_bcast(recip_lattice(1, 1), 9, stdout, seedname, comm) + !call comms_bcast(real_metric(1, 1), 9) + !call comms_bcast(recip_metric(1, 1), 9) + !call comms_bcast(cell_volume, 1) + !call comms_bcast(dos_data%energy_step, 1) + !call comms_bcast(dos_data%adpt_smr, 1) + !call comms_bcast(dos_data%smr_index, 1) + !call comms_bcast(dos_data%kmesh_spacing, 1) + !call comms_bcast(dos_data%kmesh(1), 3) + !call comms_bcast(dos_data%adpt_smr_max, 1) + !call comms_bcast(dos_data%smr_fixed_en_width, 1) + !call comms_bcast(dos_data%adpt_smr_fac, 1) + !call comms_bcast(dos_data%num_project, 1) + num_exclude_bands = 0 + if (on_root) then + if (allocated(exclude_bands)) num_exclude_bands = size(exclude_bands) + endif + call comms_bcast(num_exclude_bands, 1, stdout, seedname, comm) + if (num_exclude_bands > 0) then + if (.not. on_root) then + allocate (exclude_bands(num_exclude_bands), stat=ierr) + if (ierr /= 0) & + call io_error('Error in allocating exclude_bands in w90_wannier90_readwrite_dist', stdout, seedname) + endif + + call comms_bcast(exclude_bands(1), num_exclude_bands, stdout, seedname, comm) + end if + + call comms_bcast(gamma_only, 1, stdout, seedname, comm) + call comms_bcast(dis_manifold%win_min, 1, stdout, seedname, comm) + call comms_bcast(dis_manifold%win_max, 1, stdout, seedname, comm) + call comms_bcast(dis_manifold%froz_min, 1, stdout, seedname, comm) + call comms_bcast(dis_manifold%froz_max, 1, stdout, seedname, comm) + call comms_bcast(dis_control%num_iter, 1, stdout, seedname, comm) + call comms_bcast(dis_control%mix_ratio, 1, stdout, seedname, comm) + call comms_bcast(dis_control%conv_tol, 1, stdout, seedname, comm) + call comms_bcast(dis_control%conv_window, 1, stdout, seedname, comm) + call comms_bcast(dis_spheres%first_wann, 1, stdout, seedname, comm) + call comms_bcast(dis_spheres%num, 1, stdout, seedname, comm) + if (dis_spheres%num > 0) then + if (.not. on_root) then + allocate (dis_spheres%spheres(4, dis_spheres%num), stat=ierr) + if (ierr /= 0) & + call io_error('Error in allocating dis_spheres in w90_wannier90_readwrite_dist', stdout, seedname) + endif + call comms_bcast(dis_spheres%spheres(1, 1), 4*dis_spheres%num, stdout, seedname, comm) + end if + call comms_bcast(wann_control%num_iter, 1, stdout, seedname, comm) + call comms_bcast(wann_control%num_cg_steps, 1, stdout, seedname, comm) + call comms_bcast(wann_control%conv_tol, 1, stdout, seedname, comm) + call comms_bcast(wann_control%conv_window, 1, stdout, seedname, comm) + call comms_bcast(wann_control%guiding_centres%enable, 1, stdout, seedname, comm) + call comms_bcast(w90_calculation%wannier_plot, 1, stdout, seedname, comm) + wann_plot_num = 0 + if (on_root) then + if (allocated(wann_plot%list)) wann_plot_num = size(wann_plot%list) + endif + call comms_bcast(wann_plot_num, 1, stdout, seedname, comm) + if (wann_plot_num > 0) then + if (.not. on_root) then + allocate (wann_plot%list(wann_plot_num), stat=ierr) + if (ierr /= 0) & + call io_error('Error in allocating wannier_plot_list in w90_wannier90_readwrite_dist', stdout, seedname) + endif + call comms_bcast(wann_plot%list(1), wann_plot_num, stdout, seedname, comm) + end if + call comms_bcast(wann_plot%supercell(1), 3, stdout, seedname, comm) + call comms_bcast(wann_plot%format, len(wann_plot%format), stdout, & + seedname, comm) + call comms_bcast(wann_plot%mode, len(wann_plot%mode), stdout, & + seedname, comm) + call comms_bcast(wann_plot%spinor_mode, len(wann_plot%spinor_mode), & + stdout, seedname, comm) + call comms_bcast(output_file%write_u_matrices, 1, stdout, seedname, comm) + call comms_bcast(w90_calculation%bands_plot, 1, stdout, seedname, comm) + call comms_bcast(output_file%write_bvec, 1, stdout, seedname, comm) + call comms_bcast(first_segment, 1, stdout, seedname, comm) + call comms_bcast(band_plot%format, len(band_plot%format), stdout, & + seedname, comm) + call comms_bcast(band_plot%mode, len(band_plot%mode), stdout, & + seedname, comm) + num_project = 0 + if (on_root) then + if (allocated(band_plot%project)) num_project = size(band_plot%project) + endif + call comms_bcast(num_project, 1, stdout, seedname, comm) + + if (num_project > 0) then + if (.not. on_root) then + allocate (band_plot%project(num_project), stat=ierr) + if (ierr /= 0) & + call io_error('Error in allocating bands_plot_project in w90_wannier90_readwrite_dist', stdout, seedname) + endif + call comms_bcast(band_plot%project(1), num_project, stdout, seedname, comm) + end if + call comms_bcast(real_space_ham%system_dim, 1, stdout, seedname, comm) + call comms_bcast(output_file%write_hr, 1, stdout, seedname, comm) + call comms_bcast(output_file%write_rmn, 1, stdout, seedname, comm) + call comms_bcast(output_file%write_tb, 1, stdout, seedname, comm) + call comms_bcast(real_space_ham%hr_cutoff, 1, stdout, seedname, comm) + call comms_bcast(real_space_ham%dist_cutoff, 1, stdout, seedname, comm) + call comms_bcast(real_space_ham%dist_cutoff_mode, len(real_space_ham%dist_cutoff_mode), & + stdout, seedname, comm) + call comms_bcast(real_space_ham%dist_cutoff_hc, 1, stdout, seedname, comm) + !call comms_bcast(one_dim_axis, len(one_dim_axis), stdout, seedname, comm) + call comms_bcast(ws_region%use_ws_distance, 1, stdout, seedname, comm) + call comms_bcast(ws_region%ws_distance_tol, 1, stdout, seedname, comm) + call comms_bcast(ws_region%ws_search_size(1), 3, stdout, seedname, comm) + call comms_bcast(w90_calculation%fermi_surface_plot, 1, stdout, seedname, comm) + call comms_bcast(fermi_surface_data%num_points, 1, stdout, seedname, comm) + call comms_bcast(fermi_surface_data%plot_format, len(fermi_surface_data%plot_format), stdout, & + seedname, comm) + !call comms_bcast(fermi_energy, 1) !! used? + + !call comms_bcast(pw90_calcs%berry, 1) + !call comms_bcast(berry%task, len(berry%task)) + !call comms_bcast(berry%kmesh_spacing, 1) + !call comms_bcast(berry%kmesh(1), 3) + !call comms_bcast(berry%curv_adpt_kmesh, 1) + !call comms_bcast(berry%curv_adpt_kmesh_thresh, 1) + !call comms_bcast(berry%curv_unit, len(berry%curv_unit)) +! Stepan Tsirkin + !call comms_bcast(pw90_calcs%gyrotropic, 1) + !call comms_bcast(gyrotropic%task, len(gyrotropic%task)) + !call comms_bcast(gyrotropic%kmesh_spacing, 1) + !call comms_bcast(gyrotropic%kmesh(1), 3) + !call comms_bcast(gyrotropic%smr_fixed_en_width, 1) + !call comms_bcast(gyrotropic%smr_index, 1) + !call comms_bcast(gyrotropic%eigval_max, 1) + !call comms_bcast(gyrotropic%nfreq, 1) + !call comms_bcast(gyrotropic%degen_thresh, 1) + !call comms_bcast(gyrotropic%num_bands, 1) + !call comms_bcast(gyrotropic%box(1, 1), 9) + !call comms_bcast(gyrotropic%box_corner(1), 3) + !call comms_bcast(gyrotropic%smr_max_arg, 1) + !call comms_bcast(gyrotropic%smr_fixed_en_width, 1) + !call comms_bcast(gyrotropic%smr_index, 1) + + !call comms_bcast(berry%kubo_adpt_smr, 1) + !call comms_bcast(berry%kubo_adpt_smr_fac, 1) + !call comms_bcast(berry%kubo_adpt_smr_max, 1) + !call comms_bcast(berry%kubo_smr_fixed_en_width, 1) + !call comms_bcast(berry%kubo_smr_index, 1) + !call comms_bcast(berry%kubo_eigval_max, 1) + !call comms_bcast(berry%kubo_nfreq, 1) + fermi_n = 0 + if (on_root) then + if (allocated(fermi_energy_list)) fermi_n = size(fermi_energy_list) + endif + call comms_bcast(fermi_n, 1, stdout, seedname, comm) + !call comms_bcast(dos_data%energy_min, 1) + !call comms_bcast(dos_data%energy_max, 1) + !call comms_bcast(pw90_spin%spin_kmesh_spacing, 1) + !call comms_bcast(pw90_spin%spin_kmesh(1), 3) + !call comms_bcast(berry%wanint_kpoint_file, 1) +! Junfeng Qiao + !call comms_bcast(spin_hall%freq_scan, 1) + !call comms_bcast(spin_hall%alpha, 1) + !call comms_bcast(spin_hall%beta, 1) + !call comms_bcast(spin_hall%gamma, 1) + !call comms_bcast(spin_hall%bandshift, 1) + !call comms_bcast(spin_hall%bandshift_firstband, 1) + !call comms_bcast(spin_hall%bandshift_energyshift, 1) + + !call comms_bcast(print_output%devel_flag, len(print_output%devel_flag), stdout, seedname, comm) + !call comms_bcast(pw90_common%spin_moment, 1) + !call comms_bcast(pw90_spin%spin_axis_polar, 1) + !call comms_bcast(pw90_spin%spin_axis_azimuth, 1) + !call comms_bcast(pw90_common%spin_decomp, 1) + !call comms_bcast(pw90_ham%use_degen_pert, 1) + !call comms_bcast(pw90_ham%degen_thr, 1) + call comms_bcast(w90_system%num_valence_bands, 1, stdout, seedname, comm) + !call comms_bcast(pw90_calcs%dos, 1) + !call comms_bcast(dos_data%task, len(dos_data%task)) + !call comms_bcast(pw90_calcs%kpath, 1) + !call comms_bcast(kpath%task, len(kpath%task)) + !call comms_bcast(kpath%bands_colour, len(kpath%bands_colour)) + !call comms_bcast(pw90_calcs%kslice, 1) + !call comms_bcast(kslice%task, len(kslice%task)) + !call comms_bcast(berry%transl_inv, 1) + call comms_bcast(w90_system%num_elec_per_state, 1, stdout, seedname, comm) + !call comms_bcast(pw90_common%scissors_shift, 1) + +! ---------------------------------------------- + !call comms_bcast(pw90_calcs%geninterp, 1) + !call comms_bcast(geninterp%alsofirstder, 1) + !call comms_bcast(geninterp%single_file, 1) + ! [gp-begin, Apr 12, 2012] + ! BoltzWann variables + !call comms_bcast(pw90_calcs%boltzwann, 1) + !call comms_bcast(boltz%calc_also_dos, 1) + !call comms_bcast(boltz%dir_num_2d, 1) + !call comms_bcast(boltz%dos_energy_step, 1) + !call comms_bcast(boltz%dos_energy_min, 1) + !call comms_bcast(boltz%dos_energy_max, 1) + !call comms_bcast(boltz%dos_adpt_smr, 1) + !call comms_bcast(boltz%dos_smr_fixed_en_width, 1) + !call comms_bcast(boltz%dos_adpt_smr_fac, 1) + !call comms_bcast(boltz%dos_adpt_smr_max, 1) + !call comms_bcast(boltz%mu_min, 1) + !call comms_bcast(boltz%mu_max, 1) + !call comms_bcast(boltz%mu_step, 1) + !call comms_bcast(boltz%temp_min, 1) + !call comms_bcast(boltz%temp_max, 1) + !call comms_bcast(boltz%temp_step, 1) + !call comms_bcast(boltz%kmesh_spacing, 1) + !call comms_bcast(boltz%kmesh(1), 3) + !call comms_bcast(boltz%tdf_energy_step, 1) + !call comms_bcast(boltz%relax_time, 1) + !call comms_bcast(boltz%TDF_smr_fixed_en_width, 1) + !call comms_bcast(boltz%TDF_smr_index, 1) + !call comms_bcast(boltz%dos_smr_index, 1) + !call comms_bcast(boltz%bandshift, 1) + !call comms_bcast(boltz%bandshift_firstband, 1) + !call comms_bcast(boltz%bandshift_energyshift, 1) + ! [gp-end] + + call comms_bcast(ws_region%use_ws_distance, 1, stdout, seedname, comm) + !call comms_bcast(w90_calculation%disentanglement, 1, stdout, seedname, comm) + + call comms_bcast(w90_calculation%transport, 1, stdout, seedname, comm) + call comms_bcast(tran%easy_fix, 1, stdout, seedname, comm) + call comms_bcast(tran%mode, len(tran%mode), stdout, seedname, comm) + call comms_bcast(tran%win_min, 1, stdout, seedname, comm) + call comms_bcast(tran%win_max, 1, stdout, seedname, comm) + call comms_bcast(tran%energy_step, 1, stdout, seedname, comm) + call comms_bcast(tran%num_bb, 1, stdout, seedname, comm) + call comms_bcast(tran%num_ll, 1, stdout, seedname, comm) + call comms_bcast(tran%num_rr, 1, stdout, seedname, comm) + call comms_bcast(tran%num_cc, 1, stdout, seedname, comm) + call comms_bcast(tran%num_lc, 1, stdout, seedname, comm) + call comms_bcast(tran%num_cr, 1, stdout, seedname, comm) + call comms_bcast(tran%num_bandc, 1, stdout, seedname, comm) + call comms_bcast(tran%write_ht, 1, stdout, seedname, comm) + call comms_bcast(tran%read_ht, 1, stdout, seedname, comm) + call comms_bcast(tran%use_same_lead, 1, stdout, seedname, comm) + call comms_bcast(tran%num_cell_ll, 1, stdout, seedname, comm) + call comms_bcast(tran%num_cell_rr, 1, stdout, seedname, comm) + call comms_bcast(tran%group_threshold, 1, stdout, seedname, comm) + call comms_bcast(real_space_ham%translation_centre_frac(1), 3, stdout, seedname, comm) + call comms_bcast(kmesh_input%num_shells, 1, stdout, seedname, comm) + call comms_bcast(kmesh_input%skip_B1_tests, 1, stdout, seedname, comm) + call comms_bcast(kmesh_info%explicit_nnkpts, 1, stdout, seedname, comm) + + !call comms_bcast(calc_only_A, 1, stdout, seedname, comm) ! only used on_root + call comms_bcast(use_bloch_phases, 1, stdout, seedname, comm) + call comms_bcast(w90_calculation%restart, len(w90_calculation%restart), stdout, seedname, comm) + call comms_bcast(output_file%write_r2mn, 1, stdout, seedname, comm) + call comms_bcast(wann_control%guiding_centres%num_guide_cycles, 1, stdout, seedname, comm) + call comms_bcast(wann_control%guiding_centres%num_no_guide_iter, 1, stdout, seedname, comm) + call comms_bcast(wann_control%fixed_step, 1, stdout, seedname, comm) + call comms_bcast(wann_control%trial_step, 1, stdout, seedname, comm) + call comms_bcast(wann_control%precond, 1, stdout, seedname, comm) + call comms_bcast(output_file%write_proj, 1, stdout, seedname, comm) + call comms_bcast(print_output%timing_level, 1, stdout, seedname, comm) + call comms_bcast(w90_system%spinors, 1, stdout, seedname, comm) + call comms_bcast(w90_system%num_elec_per_state, 1, stdout, seedname, comm) + call comms_bcast(real_space_ham%translate_home_cell, 1, stdout, seedname, comm) + call comms_bcast(output_file%write_xyz, 1, stdout, seedname, comm) + call comms_bcast(output_file%write_hr_diag, 1, stdout, seedname, comm) + call comms_bcast(wann_control%conv_noise_amp, 1, stdout, seedname, comm) + call comms_bcast(wann_control%conv_noise_num, 1, stdout, seedname, comm) + call comms_bcast(wann_plot%radius, 1, stdout, seedname, comm) + call comms_bcast(wann_plot%scale, 1, stdout, seedname, comm) + call comms_bcast(kmesh_input%tol, 1, stdout, seedname, comm) + call comms_bcast(optimisation, 1, stdout, seedname, comm) + call comms_bcast(output_file%write_vdw_data, 1, stdout, seedname, comm) + call comms_bcast(print_output%lenconfac, 1, stdout, seedname, comm) + call comms_bcast(wann_control%lfixstep, 1, stdout, seedname, comm) + call comms_bcast(lsitesymmetry, 1, stdout, seedname, comm) + call comms_bcast(dis_manifold%frozen_states, 1, stdout, seedname, comm) + call comms_bcast(symmetrize_eps, 1, stdout, seedname, comm) + + !vv: Constrained centres + call comms_bcast(wann_control%constrain%slwf_num, 1, stdout, seedname, comm) + call comms_bcast(wann_control%constrain%constrain, 1, stdout, seedname, comm) + call comms_bcast(wann_control%constrain%lambda, 1, stdout, seedname, comm) + call comms_bcast(wann_control%constrain%selective_loc, 1, stdout, seedname, comm) + if (wann_control%constrain%selective_loc .and. wann_control%constrain%constrain) then + if (.not. on_root) then + !allocate (ccentres_frac(num_wann, 3), stat=ierr) + if (ierr /= 0) call io_error('Error allocating ccentres_frac in w90_readwrite_get_centre_constraints', stdout, seedname) + allocate (wann_control%constrain%centres(num_wann, 3), stat=ierr) + if (ierr /= 0) call io_error('Error allocating ccentres_cart in w90_readwrite_get_centre_constraints', stdout, seedname) + endif + !call comms_bcast(ccentres_frac(1, 1), 3*num_wann, stdout, seedname, comm) + call comms_bcast(wann_control%constrain%centres(1, 1), 3*num_wann, stdout, seedname, comm) + end if + + ! vv: automatic projections + call comms_bcast(proj_input%auto_projections, 1, stdout, seedname, comm) + + call comms_bcast(num_proj, 1, stdout, seedname, comm) + call comms_bcast(lhasproj, 1, stdout, seedname, comm) + if (lhasproj) then + if (.not. on_root) then + allocate (proj_input%site(3, num_proj), stat=ierr) + if (ierr /= 0) call io_error('Error allocating input_proj_site in w90_wannier90_readwrite_dist', stdout, seedname) + allocate (wann_control%guiding_centres%centres(3, num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error allocating proj_site in w90_wannier90_readwrite_dist', stdout, seedname) + endif + call comms_bcast(proj_input%site(1, 1), 3*num_proj, stdout, seedname, comm) + call comms_bcast(wann_control%guiding_centres%centres(1, 1), 3*num_wann, stdout, seedname, comm) + endif + + ! These variables are different from the ones above in that they are + ! allocatable, and in w90_wannier90_readwrite_read they were allocated on the root node only + ! + if (.not. on_root) then + allocate (fermi_energy_list(fermi_n), stat=ierr) + if (ierr /= 0) call io_error( & + 'Error allocating fermi_energy_read in postw90_w90_wannier90_readwrite_dist', stdout, seedname) + !allocate (berry%kubo_freq_list(berry%kubo_nfreq), stat=ierr) + !if (ierr /= 0) call io_error( & + ! 'Error allocating kubo_freq_list in postw90_w90_wannier90_readwrite_dist') + !allocate (dos_data%project(dos_data%num_project), stat=ierr) + !if (ierr /= 0) & + ! call io_error('Error allocating dos_project in postw90_w90_wannier90_readwrite_dist') + !if (.not. pw90_common%effective_model) then + if (eig_found) then + allocate (eigval(num_bands, num_kpts), stat=ierr) + if (ierr /= 0) & + call io_error('Error allocating eigval in postw90_w90_wannier90_readwrite_dist', stdout, seedname) + end if + allocate (kpt_latt(3, num_kpts), stat=ierr) + if (ierr /= 0) & + call io_error('Error allocating kpt_latt in postw90_w90_wannier90_readwrite_dist', stdout, seedname) + !endif + !allocate (gyrotropic%band_list(gyrotropic%num_bands), stat=ierr) + !if (ierr /= 0) call io_error( & + ! 'Error allocating gyrotropic_num_bands in postw90_w90_wannier90_readwrite_dist') + !allocate (gyrotropic%freq_list(gyrotropic%nfreq), stat=ierr) + !if (ierr /= 0) call io_error( & + ! 'Error allocating gyrotropic_freq_list in postw90_w90_wannier90_readwrite_dist') + end if + + if (fermi_n > 0) call comms_bcast(fermi_energy_list(1), fermi_n, stdout, seedname, comm) + !if (berry%kubo_nfreq > 0) call comms_bcast(berry%kubo_freq_list(1), berry%kubo_nfreq) + !call comms_bcast(gyrotropic%freq_list(1), gyrotropic%nfreq) + !call comms_bcast(gyrotropic%band_list(1), gyrotropic%num_bands) + !if (dos_data%num_project > 0) & + ! call comms_bcast(dos_data%project(1), dos_data%num_project) + !if (.not. pw90_common%effective_model) then + if (eig_found) then + call comms_bcast(eigval(1, 1), num_bands*num_kpts, stdout, seedname, comm) + end if + call comms_bcast(kpt_latt(1, 1), 3*num_kpts, stdout, seedname, comm) + !endif + + !if (.not. pw90_common%effective_model .and. .not. w90_calculation%explicit_nnkpts) then + if (.not. kmesh_info%explicit_nnkpts) then + + call comms_bcast(kmesh_info%nnh, 1, stdout, seedname, comm) + call comms_bcast(kmesh_info%nntot, 1, stdout, seedname, comm) + call comms_bcast(kmesh_info%wbtot, 1, stdout, seedname, comm) + + if (.not. on_root) then + allocate (kmesh_info%nnlist(num_kpts, kmesh_info%nntot), stat=ierr) + if (ierr /= 0) & + call io_error('Error in allocating nnlist in w90_wannier90_readwrite_dist', stdout, seedname) + allocate (kmesh_info%neigh(num_kpts, kmesh_info%nntot/2), stat=ierr) + if (ierr /= 0) & + call io_error('Error in allocating neigh in w90_wannier90_readwrite_dist', stdout, seedname) + allocate (kmesh_info%nncell(3, num_kpts, kmesh_info%nntot), stat=ierr) + if (ierr /= 0) & + call io_error('Error in allocating nncell in w90_wannier90_readwrite_dist', stdout, seedname) + allocate (kmesh_info%wb(kmesh_info%nntot), stat=ierr) + if (ierr /= 0) & + call io_error('Error in allocating wb in w90_wannier90_readwrite_dist', stdout, seedname) + allocate (kmesh_info%bka(3, kmesh_info%nntot/2), stat=ierr) + if (ierr /= 0) & + call io_error('Error in allocating bka in w90_wannier90_readwrite_dist', stdout, seedname) + allocate (kmesh_info%bk(3, kmesh_info%nntot, num_kpts), stat=ierr) + if (ierr /= 0) & + call io_error('Error in allocating bk in w90_wannier90_readwrite_dist', stdout, seedname) + end if + + call comms_bcast(kmesh_info%nnlist(1, 1), num_kpts*kmesh_info%nntot, stdout, seedname, comm) + call comms_bcast(kmesh_info%neigh(1, 1), num_kpts*kmesh_info%nntot/2, stdout, seedname, comm) + call comms_bcast(kmesh_info%nncell(1, 1, 1), 3*num_kpts*kmesh_info%nntot, stdout, seedname, & + comm) + call comms_bcast(kmesh_info%wb(1), kmesh_info%nntot, stdout, seedname, comm) + call comms_bcast(kmesh_info%bka(1, 1), 3*kmesh_info%nntot/2, stdout, seedname, comm) + call comms_bcast(kmesh_info%bk(1, 1, 1), 3*kmesh_info%nntot*num_kpts, stdout, seedname, comm) + + endif + + call comms_bcast(wann_omega%total, 1, stdout, seedname, comm) + call comms_bcast(wann_omega%tilde, 1, stdout, seedname, comm) + call comms_bcast(wann_omega%invariant, 1, stdout, seedname, comm) + call comms_bcast(have_disentangled, 1, stdout, seedname, comm) + + if (.not. on_root) then + allocate (wannier_data%centres(3, num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error allocating wannier_centres in w90_wannier90_readwrite_dist', stdout, seedname) + wannier_data%centres = 0.0_dp + allocate (wannier_data%spreads(num_wann), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating wannier_spreads in w90_wannier90_readwrite_dist', stdout, seedname) + wannier_data%spreads = 0.0_dp + if (disentanglement) then + allocate (dis_manifold%ndimwin(num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating ndimwin in w90_wannier90_readwrite_dist', stdout, seedname) + allocate (dis_manifold%lwindow(num_bands, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error allocating lwindow in w90_wannier90_readwrite_dist', stdout, seedname) + endif + endif + + end subroutine w90_wannier90_readwrite_dist + +end module w90_wannier90_readwrite diff --git a/src/wannier90_types.F90 b/src/wannier90_types.F90 new file mode 100644 index 000000000..62b3668a7 --- /dev/null +++ b/src/wannier90_types.F90 @@ -0,0 +1,279 @@ +!-*- mode: F90 -*-! +!------------------------------------------------------------! +! This file is distributed as part of the Wannier90 code and ! +! under the terms of the GNU General Public License. See the ! +! file `LICENSE' in the root directory of the Wannier90 ! +! distribution, or http://www.gnu.org/copyleft/gpl.txt ! +! ! +! The webpage of the Wannier90 code is www.wannier.org ! +! ! +! The Wannier90 code is hosted on GitHub: ! +! ! +! https://github.com/wannier-developers/wannier90 ! +!------------------------------------------------------------! +! ! +! w90_wannier90_types: data types specific to wannier90.x ! +! ! +!------------------------------------------------------------! + +module w90_wannier90_types + + ! Definition of types encapsulating various quantities, data and parameters. + ! Variables are grouped according to physical meaning and their use in the Wannier90 project. + ! + !! Here are defined types specific to wannier90.x (not used by postw90.x). + !! Types used by both wannier90.x and postw90.x are defined in types.F90. + !! Types specific to postw90.x (not used by wannier90.x) are defined in postw90/postw90_types.F90. + + use w90_constants, only: dp + use w90_io, only: maxlen + + implicit none + + public + + type w90_calculation_type + !!================================================== + !! Contains variables to control the execution path of the program. + !!================================================== + logical :: postproc_setup + character(len=20) :: restart + logical :: bands_plot !hamiltonian (setup only), plot, wannier_lib + logical :: wannier_plot !plot, wannier_lib + logical :: fermi_surface_plot ! plot, wannier_lib! + logical :: transport ! also hamiltonian, wannier_prog, wannier_lib + end type w90_calculation_type + + type output_file_type + logical :: write_hr !plot, transport and wannier_lib + logical :: write_r2mn + logical :: write_proj + logical :: write_hr_diag + logical :: write_vdw_data + ! aam: for WF-based calculation of vdW C6 coefficients + logical :: write_u_matrices + logical :: write_bvec + logical :: write_rmn + logical :: write_tb + logical :: write_xyz !wannierise and transport + end type output_file_type + + type real_space_ham_type + !!================================================== + !! Contains information to control the structure of the real-space Hamiltonian + !! and how it is calculated. + !!================================================== + real(kind=dp) :: hr_cutoff !plot and transport + ! dist_cutoff - only plot and transport + real(kind=dp) :: dist_cutoff !plot and transport + character(len=20) :: dist_cutoff_mode !plot and transport + real(kind=dp) :: dist_cutoff_hc !plot and transport + integer :: one_dim_dir ! transport and plot + ! REVIEW_2021-07-22: system_dim is really providing information about the dimensionality + ! REVIEW_2021-07-22: of the system. Whilst currently it is only used for plotting, its + ! REVIEW_2021-07-22: use may be generalised in the future. Therefore it makes more sense + ! REVIEW_2021-07-22: to put it here. + integer :: system_dim + ! REVIEW_2021-07-22: There's been some discussion in the past about generalising + ! REVIEW_2021-07-22: the use of translate_home_cell to also take into account of + ! REVIEW_2021-07-22: changes in H(R) when WFs are translated. As this is something + ! REVIEW_2021-07-22: we plan to do, translate_home_cell should probably be here + logical :: translate_home_cell ! currently used by wann_write_xyz when write_xyz=.true. + ! REVIEW_2021-08-09: future plan is that these variables (translation_centre_frac and + ! REVIEW_2021-08-09: automatic_translation will also result in the hamiltonian being + ! REVIEW_2021-08-09: modified to be consistent with the translated Wannier centres. + ! REVIEW_2021-08-09: This is related to Issue 39 in the main repo. + real(kind=dp) :: translation_centre_frac(3) + ! For Hamiltonian matrix in WF representation + logical :: automatic_translation + end type real_space_ham_type + + type band_plot_type + !!================================================== + !! Contains information to control how the bandstructure plotting is performed and formatted. + !!================================================== + character(len=20) :: mode !hamiltonian (setup only), plot + character(len=20) :: format + integer, allocatable :: project(:) + end type band_plot_type + + type wannier_plot_type + !!================================================== + !! Contains information for how to plot the wannier functions. + !!================================================== + integer, allocatable :: list(:) + integer :: supercell(3) + real(kind=dp) :: radius + real(kind=dp) :: scale + character(len=20) :: format + character(len=20) :: mode + character(len=20) :: spinor_mode + logical :: spinor_phase + end type wannier_plot_type + + type wvfn_read_type ! only in plot.F90 + !!================================================== + !! Contains information for how to read the wavefunction files + !!================================================== + logical :: formatted + !! Read the wvfn from fortran formatted file + integer :: spin_channel + !! Spin up=1 down=2 + end type wvfn_read_type + + ! parameters used to control the minimisation of the disentanglement process + type dis_control_type + !!================================================== + !! Contains parameters that control the disentanglement minimisation procedure + !!================================================== + integer :: num_iter + !! number of disentanglement iteration steps + real(kind=dp) :: mix_ratio + !! Mixing ratio for the disentanglement routine + real(kind=dp) :: conv_tol + !! Convergence tolerance for the disentanglement + integer :: conv_window + !! Size of the convergence window for disentanglement + end type dis_control_type + + type dis_spheres_type + ! GS-start + integer :: first_wann + integer :: num + real(kind=dp), allocatable :: spheres(:, :) + ! GS-end + end type dis_spheres_type + + type wann_slwf_type + !!================================================== + !! Contains parameters that control the selective localisation and constrained centres algorithm + !!================================================== + integer :: slwf_num + !! Number of objective Wannier functions (others excluded from spread functional) + logical :: selective_loc + !! Selective localization + logical :: constrain + !! Constrained centres in Cartesian coordinates in angstrom. + real(kind=dp), allocatable :: centres(:, :) + real(kind=dp) :: lambda + !! Centre constraints for each Wannier function. Co-ordinates of centre constraint defaults + !! to centre of trial orbital. Individual Lagrange multipliers, lambdas, default to global Lagrange multiplier. + end type wann_slwf_type + + type guiding_centres_type + logical :: enable + integer :: num_guide_cycles + integer :: num_no_guide_iter + real(kind=dp), allocatable :: centres(:, :) + end type guiding_centres_type + + type wann_control_type ! only in wannierise.F90 + !!================================================== + !! Contains parameters that control the wannierisation minimisation procedure + !!================================================== + integer :: num_dump_cycles + !! Number of steps before writing checkpoint + integer :: num_print_cycles + !! Number of steps between writing output + integer :: num_iter + !! Number of wannierisation iterations + integer :: num_cg_steps + !! Number of Conjugate Gradient steps + real(kind=dp) :: conv_tol + integer :: conv_window + type(guiding_centres_type) :: guiding_centres + real(kind=dp) :: fixed_step + real(kind=dp) :: trial_step + logical :: precond + logical :: lfixstep ! derived from input + real(kind=dp) :: conv_noise_amp + integer :: conv_noise_num + type(wann_slwf_type) :: constrain + end type wann_control_type + + type wann_omega_type + !!================================================== + !! Contains the total spread and its decomposition into gauge invariant and gauge dependent parts. + !!================================================== + ! REVIEW_2021-08-04: This type is mainly used for the library mode to be returned back to the external code. + ! REVIEW_2021-08-04: Internally the code mostly uses the localisation_vars type in wannierise.F90. + !================================================== + real(kind=dp) :: invariant !wannierise, disentangle and chk2chk + real(kind=dp) :: total + real(kind=dp) :: tilde + end type wann_omega_type + + ! REVIEW_2021-08-09: We are thinking that this functionality should be probably moved to postw90 at some point. + type fermi_surface_plot_type + !!================================================== + !! Contains variables to control Fermi surface plotting in the main wannier code. + !!================================================== + integer :: num_points + character(len=20) :: plot_format + end type fermi_surface_plot_type + + ! REVIEW_2021-08-09: This functionality should be moved to postw90 at some point. + ! REVIEW_2021-08-09: See Issue 31 in the main repo. + type transport_type ! transport.F90 + !!================================================== + !! Contains variables to control the calculation of quantum (Landauer-Buttiker) transport + !!================================================== + logical :: easy_fix + character(len=20) :: mode ! also hamiltonian + real(kind=dp) :: win_min + real(kind=dp) :: win_max + real(kind=dp) :: energy_step + integer :: num_bb + integer :: num_ll + integer :: num_rr + integer :: num_cc + integer :: num_lc + integer :: num_cr + integer :: num_bandc + logical :: write_ht + logical :: read_ht ! also wannier_prog + logical :: use_same_lead + integer :: num_cell_ll + integer :: num_cell_rr + real(kind=dp) :: group_threshold + end type transport_type + + ! projections selection - overlap.F90 + ! REVIEW_2021-08-09: At first sight it might appear that select_projections should go in + ! REVIEW_2021-08-09: the proj_input_type container; but the way the code is structured + ! REVIEW_2021-08-09: makes this less appealing because there are two proj_input_type variables + ! REVIEW_2021-08-09: proj_input and proj, the latter containing the subset of selected projections. + ! REVIEW_2021-08-09: Perhaps best to keep it as currently coded (for now at least). + type select_projection_type + !!================================================== + !! Contains variables relevant to selecting a subset of the projections for the calculation. + !!================================================== + logical :: lselproj + !integer, save :: num_select_projections + !integer, allocatable, save :: select_projections(:) + integer, allocatable :: proj2wann_map(:) + end type select_projection_type + + ! from sitesym + type sitesym_type + ! Variables and parameters needed by other modules + integer :: nkptirr = 9999 + integer :: nsymmetry = 9999 + integer, allocatable :: kptsym(:, :), ir2ik(:), ik2ir(:) + real(kind=dp) :: symmetrize_eps = 1.d-3 + complex(kind=dp), allocatable :: d_matrix_band(:, :, :, :) + complex(kind=dp), allocatable :: d_matrix_wann(:, :, :, :) + end type sitesym_type + + ! from hamiltonian + type ham_logical_type + logical :: ham_have_setup = .false. + logical :: have_ham_k = .false. + logical :: have_ham_r = .false. + logical :: have_translated = .false. + logical :: hr_written = .false. + logical :: tb_written = .false. + logical :: use_translation = .false. + end type ham_logical_type + +end module w90_wannier90_types diff --git a/src/wannier_lib.F90 b/src/wannier_lib.F90 index 7557431eb..2a48bcd4b 100644 --- a/src/wannier_lib.F90 +++ b/src/wannier_lib.F90 @@ -49,13 +49,121 @@ ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +module w90_libv1_types + ! global type instances (of w90_types) to allow legacy library + + use w90_types + + implicit none + + public + + integer, allocatable, save :: exclude_bands(:) + integer, save :: num_bands !! Number of bands + integer, save :: num_kpts + integer, save :: num_wann !! number of wannier functions + integer, save :: optimisation + + type(atom_data_type), save :: atoms + type(dis_manifold_type), save :: dis_window + type(kmesh_info_type), save :: kmesh_info + type(kmesh_input_type), save :: kmesh_data + type(print_output_type), save :: verbose + type(proj_input_type), save :: input_proj + type(w90_system_type), save :: system + type(wannier_data_type), save :: wann_data + type(ws_region_type) :: ws_region + + real(kind=dp), allocatable, save :: fermi_energy_list(:) + real(kind=dp), allocatable, save :: kpt_latt(:, :) !! kpoints in lattice vecs + + logical, save :: cp_pp, calc_only_A + logical, save :: gamma_only + logical, save :: have_disentangled + logical, save :: use_bloch_phases + + ! a_matrix and m_matrix_orig can be calculated internally from bloch states + ! or read in from an ab-initio grid + ! a_matrix = projection of trial orbitals on bloch states + ! m_matrix_orig = overlap of bloch states + !BGS disentangle, hamiltonian, a wannierise print, and postw90/get_oper + real(kind=dp), allocatable, save :: eigval(:, :) + + !BGS u_matrix_opt in postw90 only for generation of v_matrix + ! u_matrix_opt gives the num_wann dimension optimal subspace from the + ! original bloch states + complex(kind=dp), allocatable, save :: u_matrix_opt(:, :, :) + + ! u_matrix gives the unitary rotations from the optimal subspace to the + ! optimally smooth states. + ! m_matrix we store here, becuase it is needed for restart of wannierise + complex(kind=dp), allocatable, save :: u_matrix(:, :, :) + + integer, save :: mp_grid(3) + !! Dimensions of the Monkhorst-Pack grid + + integer, save :: num_proj + !BGS used by stuff in driver/kmesh/wannier - keep separate or duplicate? + + real(kind=dp), save :: real_lattice(3, 3) + + !parameters derived from input + !real(kind=dp), save :: recip_lattice(3, 3) + + type(kpoint_path_type), save :: spec_points + +end module w90_libv1_types + +module w90_wannier90_libv1_types + ! global type instances (of w90_wannier90_types) to allow legacy library + + use w90_constants, only: dp + use w90_io, only: maxlen + use w90_wannier90_types + + implicit none + + public + + type(w90_calculation_type), save :: w90_calcs + type(output_file_type), save :: out_files + type(real_space_ham_type) :: rs_region + type(wvfn_read_type), save :: plot + type(band_plot_type), save :: band_plot + type(wannier_plot_type), save :: wann_plot + type(dis_control_type), save :: dis_data + type(dis_spheres_type), save :: dis_spheres + type(wann_control_type), save :: wannierise + type(wann_omega_type), save :: wann_omega + ! RS: symmetry-adapted Wannier functions + logical, save :: lsitesymmetry = .false. + real(kind=dp), save :: symmetrize_eps = 1.d-3 + !type(hamiltonian_type), save :: hamiltonian + type(fermi_surface_plot_type), save :: fermi_surface_data + type(transport_type), save :: tran + type(select_projection_type), save :: select_proj + + logical, save :: eig_found + + ! a_matrix, m_matrix in disentangle and overlap + complex(kind=dp), allocatable, save :: a_matrix(:, :, :) + complex(kind=dp), allocatable, save :: m_matrix_orig(:, :, :, :) + complex(kind=dp), allocatable, save :: m_matrix_orig_local(:, :, :, :) + ! disentangle, hamiltonian, overlap and wannierise + complex(kind=dp), allocatable, save :: m_matrix(:, :, :, :) + ! in disentangle and overlap + complex(kind=dp), allocatable, save :: m_matrix_local(:, :, :, :) + +end module w90_wannier90_libv1_types + +!================================================! subroutine wannier_setup(seed__name, mp_grid_loc, num_kpts_loc, & real_lattice_loc, recip_lattice_loc, kpt_latt_loc, num_bands_tot, & num_atoms_loc, atom_symbols_loc, atoms_cart_loc, gamma_only_loc, spinors_loc, & nntot_loc, nnlist_loc, nncell_loc, num_bands_loc, num_wann_loc, & proj_site_loc, proj_l_loc, proj_m_loc, proj_radial_loc, proj_z_loc, & proj_x_loc, proj_zona_loc, exclude_bands_loc, proj_s_loc, proj_s_qaxis_loc) - + !================================================! !! This routine should be called first from a code calling the library !! mode to setup all the variables. !! NOTE! The library mode currently works ONLY in serial (when called from @@ -63,15 +171,39 @@ subroutine wannier_setup(seed__name, mp_grid_loc, num_kpts_loc, & !! !! For more information, check a (minimal) example of how it can be used !! in the folder test-suite/library-mode-test/test_library.F90 + !================================================! - use w90_constants - use w90_parameters + use w90_comms, only: w90comm_type + use w90_constants, only: w90_physical_constants_type, dp use w90_io use w90_kmesh - use w90_comms, only: comms_setup_vars + use w90_libv1_types + use w90_readwrite, only: w90_readwrite_write_header, w90_readwrite_lib_set_atoms + use w90_sitesym + use w90_wannier90_readwrite, only: w90_wannier90_readwrite_read, w90_wannier90_readwrite_write, & + w90_wannier90_readwrite_w90_dealloc, w90_extra_io_type + use w90_wannier90_libv1_types + +#ifdef MPI +# if !(defined(MPI08) || defined(MPI90) || defined(MPIH)) +# error "You need to define which MPI interface you are using" +# endif +#endif + +#ifdef MPI08 + use mpi_f08 ! use f08 interface if possible +#endif +#ifdef MPI90 + use mpi ! next best, use fortran90 interface +#endif implicit none +#ifdef MPIH + include 'mpif.h' ! worst case, use legacy interface +#endif + + type(w90_physical_constants_type) :: physics character(len=*), intent(in) :: seed__name integer, dimension(3), intent(in) :: mp_grid_loc integer, intent(in) :: num_kpts_loc @@ -100,17 +232,32 @@ subroutine wannier_setup(seed__name, mp_grid_loc, num_kpts_loc, & integer, dimension(num_bands_tot), optional, intent(out) :: proj_s_loc real(kind=dp), dimension(3, num_bands_tot), optional, intent(out) :: proj_s_qaxis_loc - real(kind=dp) time0, time1, time2 + type(w90_extra_io_type) :: write_data + ! was in driver, only used by wannier_lib + type(proj_input_type) :: proj + !Projections + logical :: lhasproj + + real(kind=dp) time0, time1 character(len=9) :: stat, pos, cdate, ctime integer :: ierr + integer :: stdout + character(len=50) :: seedname logical :: wout_found + logical :: disentanglement + logical :: mpiinitalready + +#ifdef MPI + ! in wannier_setup, mpi is *exclusively* used by potential calls to io_error + call mpi_initialized(mpiinitalready, ierr) + if (.not. mpiinitalready) then + call io_error('mpi_init must be called before wannier_setup() when libwannier is compiled with MPI support', & + stdout, seedname) + endif +#endif time0 = io_time() - call comms_setup_vars - - library = .true. -! seedname="wannier" seedname = trim(adjustl(seed__name)) inquire (file=trim(seedname)//'.wout', exist=wout_found) if (wout_found) then @@ -123,7 +270,8 @@ subroutine wannier_setup(seed__name, mp_grid_loc, num_kpts_loc, & stdout = io_file_unit() open (unit=stdout, file=trim(seedname)//'.wout', status=trim(stat), position=trim(pos)) - call param_write_header() + call w90_readwrite_write_header(physics%bohr_version_str, physics%constants_version_str1, & + physics%constants_version_str2, stdout) write (stdout, '(/a/)') ' Wannier90 is running in LIBRARY MODE' write (stdout, '(a/)') ' Setting up k-point neighbours...' @@ -132,33 +280,44 @@ subroutine wannier_setup(seed__name, mp_grid_loc, num_kpts_loc, & mp_grid = mp_grid_loc num_kpts = num_kpts_loc real_lattice = real_lattice_loc - recip_lattice = recip_lattice_loc + !recip_lattice = recip_lattice_loc allocate (kpt_latt(3, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating kpt_latt in wannier_setup') + if (ierr /= 0) call io_error('Error allocating kpt_latt in wannier_setup', stdout, seedname) kpt_latt = kpt_latt_loc - num_atoms = num_atoms_loc - call param_lib_set_atoms(atom_symbols_loc, atoms_cart_loc) + atoms%num_atoms = num_atoms_loc + call w90_readwrite_lib_set_atoms(atoms, atom_symbols_loc, atoms_cart_loc, real_lattice, stdout, seedname) gamma_only = gamma_only_loc - spinors = spinors_loc + system%spinors = spinors_loc ! GP: at this point we don't know yet the number of excluded bands... num_bands = num_bands_tot - library_param_read_first_pass = .true. - call param_read() + !library_w90_wannier90_readwrite_read_first_pass = .true. + call w90_wannier90_readwrite_read(atoms, band_plot, dis_data, dis_spheres, dis_window, exclude_bands, fermi_energy_list, & + fermi_surface_data, kmesh_data, kmesh_info, kpt_latt, out_files, & + plot, wannierise, wann_omega, proj, input_proj, rs_region, select_proj, & + spec_points, system, tran, verbose, wann_data, wann_plot, write_data, ws_region, & + w90_calcs, eigval, real_lattice, physics%bohr, symmetrize_eps, mp_grid, & + num_bands, num_kpts, num_proj, num_wann, optimisation, eig_found, calc_only_A, & + cp_pp, gamma_only, lhasproj, .true., .true., lsitesymmetry, use_bloch_phases, & + seedname, stdout) + have_disentangled = .false. + disentanglement = (num_bands > num_wann) ! Following calls will all NOT be first_pass, and I need to pass ! directly num_bands, that is already set internally now to num_bands = num_bands_tot - num_exclude_bands - library_param_read_first_pass = .false. - ! set cell_volume as it is written to output in param_write - cell_volume = real_lattice(1, 1)*(real_lattice(2, 2)*real_lattice(3, 3) - real_lattice(3, 2)*real_lattice(2, 3)) + & - real_lattice(1, 2)*(real_lattice(2, 3)*real_lattice(3, 1) - real_lattice(3, 3)*real_lattice(2, 1)) + & - real_lattice(1, 3)*(real_lattice(2, 1)*real_lattice(3, 2) - real_lattice(3, 1)*real_lattice(2, 2)) - call param_write() - + !library_w90_wannier90_readwrite_read_first_pass = .false. + + call w90_wannier90_readwrite_write(atoms, band_plot, dis_data, dis_spheres, fermi_energy_list, fermi_surface_data, & + kpt_latt, out_files, plot, wannierise, proj, input_proj, rs_region, & + select_proj, spec_points, tran, verbose, wann_data, wann_plot, write_data, & + w90_calcs, real_lattice, symmetrize_eps, mp_grid, num_bands, & + num_kpts, num_proj, num_wann, optimisation, cp_pp, gamma_only, lsitesymmetry, & + system%spinors, use_bloch_phases, stdout) time1 = io_time() write (stdout, '(1x,a25,f11.3,a)') 'Time to read parameters ', time1 - time0, ' (sec)' - if (.not. explicit_nnkpts) call kmesh_get() - + if (.not. kmesh_info%explicit_nnkpts) call kmesh_get(kmesh_data, kmesh_info, verbose, & + kpt_latt, real_lattice, num_kpts, & + gamma_only, seedname, stdout) ! Now we zero all of the local output data, then copy in the data ! from the parameters module @@ -174,36 +333,41 @@ subroutine wannier_setup(seed__name, mp_grid_loc, num_kpts_loc, & proj_zona_loc = 0.0_dp exclude_bands_loc = 0 - nntot_loc = nntot - nnlist_loc(:, 1:nntot) = nnlist(:, 1:nntot) - nncell_loc(:, :, 1:nntot) = nncell(:, :, 1:nntot) + nntot_loc = kmesh_info%nntot + nnlist_loc(:, 1:kmesh_info%nntot) = kmesh_info%nnlist(:, 1:kmesh_info%nntot) + nncell_loc(:, :, 1:kmesh_info%nntot) = kmesh_info%nncell(:, :, 1:kmesh_info%nntot) num_bands_loc = num_bands num_wann_loc = num_wann - if (allocated(proj_site)) then - proj_site_loc(:, 1:num_proj) = proj_site(:, 1:num_proj) - proj_l_loc(1:num_proj) = proj_l(1:num_proj) - proj_m_loc(1:num_proj) = proj_m(1:num_proj) - proj_z_loc(:, 1:num_proj) = proj_z(:, 1:num_proj) - proj_x_loc(:, 1:num_proj) = proj_x(:, 1:num_proj) - proj_radial_loc(1:num_proj) = proj_radial(1:num_proj) - proj_zona_loc(1:num_proj) = proj_zona(1:num_proj) - if (allocated(proj_s) .and. present(proj_s_loc) .and. present(proj_s_qaxis_loc)) then - proj_s_loc(1:num_proj) = proj_s(1:num_proj) - proj_s_qaxis_loc(:, 1:num_proj) = proj_s_qaxis(:, 1:num_proj) + if (allocated(wannierise%guiding_centres%centres)) then + proj_site_loc(:, 1:num_proj) = wannierise%guiding_centres%centres(:, 1:num_proj) + proj_l_loc(1:num_proj) = proj%l(1:num_proj) + proj_m_loc(1:num_proj) = proj%m(1:num_proj) + proj_z_loc(:, 1:num_proj) = proj%z(:, 1:num_proj) + proj_x_loc(:, 1:num_proj) = proj%x(:, 1:num_proj) + proj_radial_loc(1:num_proj) = proj%radial(1:num_proj) + proj_zona_loc(1:num_proj) = proj%zona(1:num_proj) + if (allocated(proj%s) .and. present(proj_s_loc) .and. present(proj_s_qaxis_loc)) then + proj_s_loc(1:num_proj) = proj%s(1:num_proj) + proj_s_qaxis_loc(:, 1:num_proj) = proj%s_qaxis(:, 1:num_proj) end if endif if (allocated(exclude_bands)) then - exclude_bands_loc(1:num_exclude_bands) = exclude_bands(1:num_exclude_bands) + exclude_bands_loc(1:size(exclude_bands)) = exclude_bands(1:size(exclude_bands)) end if - if (postproc_setup) then - call kmesh_write() + if (w90_calcs%postproc_setup) then + call kmesh_write(exclude_bands, kmesh_info, input_proj, verbose, kpt_latt, & + real_lattice, num_kpts, num_proj, calc_only_A, & + system%spinors, seedname, stdout) write (stdout, '(1x,a25,f11.3,a)') 'Time to write kmesh ', io_time(), ' (sec)' write (stdout, '(/a)') ' '//trim(seedname)//'.nnkp written.' endif - call kmesh_dealloc() - call param_dealloc() + call kmesh_dealloc(kmesh_info, stdout, seedname) + + call w90_wannier90_readwrite_w90_dealloc(atoms, band_plot, dis_spheres, dis_window, exclude_bands, kmesh_data, & + kpt_latt, wannierise, proj, input_proj, select_proj, spec_points, & + wann_data, wann_plot, write_data, eigval, seedname, stdout) write (stdout, '(1x,a25,f11.3,a)') 'Time to write kmesh ', io_time(), ' (sec)' write (stdout, '(/a/)') ' Finished setting up k-point neighbours.' @@ -216,13 +380,14 @@ subroutine wannier_setup(seed__name, mp_grid_loc, num_kpts_loc, & end subroutine wannier_setup -subroutine wannier_run(seed__name, mp_grid_loc, num_kpts_loc, & - real_lattice_loc, recip_lattice_loc, kpt_latt_loc, num_bands_loc, & - num_wann_loc, nntot_loc, num_atoms_loc, atom_symbols_loc, & - atoms_cart_loc, gamma_only_loc, M_matrix_loc, A_matrix_loc, eigenvalues_loc, & - U_matrix_loc, U_matrix_opt_loc, lwindow_loc, wann_centres_loc, & - wann_spreads_loc, spread_loc) +!================================================! +subroutine wannier_run(seed__name, mp_grid_loc, num_kpts_loc, real_lattice_loc, recip_lattice_loc, & + kpt_latt_loc, num_bands_loc, num_wann_loc, nntot_loc, num_atoms_loc, & + atom_symbols_loc, atoms_cart_loc, gamma_only_loc, M_matrix_loc, & + A_matrix_loc, eigenvalues_loc, U_matrix_loc, U_matrix_opt_loc, lwindow_loc, & + wann_centres_loc, wann_spreads_loc, spread_loc) + !================================================! !! This routine should be called after wannier_setup from a code calling !! the library mode to actually run the Wannier code. !! @@ -232,9 +397,13 @@ subroutine wannier_run(seed__name, mp_grid_loc, num_kpts_loc, & !! !! For more information, check a (minimal) example of how it can be used !! in the folder test-suite/library-mode-test/test_library.F90 + !================================================! - use w90_constants - use w90_parameters + use w90_constants, only: w90_physical_constants_type, dp + use w90_libv1_types + use w90_wannier90_libv1_types + use w90_wannier90_readwrite, only: w90_wannier90_readwrite_read, w90_wannier90_readwrite_write, & + w90_wannier90_readwrite_write_chkpt, w90_wannier90_readwrite_w90_dealloc, w90_extra_io_type use w90_io use w90_hamiltonian use w90_kmesh @@ -243,11 +412,31 @@ subroutine wannier_run(seed__name, mp_grid_loc, num_kpts_loc, & use w90_wannierise use w90_plot use w90_transport - use w90_comms, only: my_node_id, num_nodes, & - comms_array_split, comms_scatterv + use w90_comms, only: comms_array_split, comms_scatterv, w90comm_type, & + mpisize, mpirank + + use w90_readwrite, only: w90_readwrite_lib_set_atoms + +#ifdef MPI +# if !(defined(MPI08) || defined(MPI90) || defined(MPIH)) +# error "You need to define which MPI interface you are using" +# endif +#endif + +#ifdef MPI08 + use mpi_f08 ! use f08 interface if possible +#endif +#ifdef MPI90 + use mpi ! next best, use fortran90 interface +#endif implicit none +#ifdef MPIH + include 'mpif.h' ! worst case, use legacy interface +#endif + + type(w90_physical_constants_type) :: physics character(len=*), intent(in) :: seed__name integer, dimension(3), intent(in) :: mp_grid_loc integer, intent(in) :: num_kpts_loc @@ -261,11 +450,13 @@ subroutine wannier_run(seed__name, mp_grid_loc, num_kpts_loc, & character(len=*), dimension(num_atoms_loc), intent(in) :: atom_symbols_loc real(kind=dp), dimension(3, num_atoms_loc), intent(in) :: atoms_cart_loc logical, intent(in) :: gamma_only_loc - complex(kind=dp), dimension(num_bands_loc, num_bands_loc, nntot_loc, num_kpts_loc), intent(in) :: M_matrix_loc + complex(kind=dp), dimension(num_bands_loc, num_bands_loc, nntot_loc, num_kpts_loc), & + intent(in) :: M_matrix_loc complex(kind=dp), dimension(num_bands_loc, num_wann_loc, num_kpts_loc), intent(in) :: A_matrix_loc real(kind=dp), dimension(num_bands_loc, num_kpts_loc), intent(in) :: eigenvalues_loc complex(kind=dp), dimension(num_wann_loc, num_wann_loc, num_kpts_loc), intent(out) :: U_matrix_loc - complex(kind=dp), dimension(num_bands_loc, num_wann_loc, num_kpts_loc), optional, intent(out) :: U_matrix_opt_loc + complex(kind=dp), dimension(num_bands_loc, num_wann_loc, num_kpts_loc), optional, & + intent(out) :: U_matrix_opt_loc logical, dimension(num_bands_loc, num_kpts_loc), optional, intent(out) :: lwindow_loc real(kind=dp), dimension(3, num_wann_loc), optional, intent(out) :: wann_centres_loc real(kind=dp), dimension(num_wann_loc), optional, intent(out) :: wann_spreads_loc @@ -274,18 +465,67 @@ subroutine wannier_run(seed__name, mp_grid_loc, num_kpts_loc, & real(kind=dp) time0, time1, time2 character(len=9) :: stat, pos, cdate, ctime integer :: ierr, loop_k, loop_w + integer :: stdout + character(len=50) :: seedname logical :: wout_found - integer :: nkp, nn, n, m - -! Needed to split an array on different nodes - integer, dimension(0:num_nodes - 1) :: counts - integer, dimension(0:num_nodes - 1) :: displs - + complex(kind=dp), allocatable :: ham_r(:, :, :) + integer, allocatable :: irvec(:, :) + integer, allocatable :: shift_vec(:, :) + integer, allocatable :: ndegen(:) + integer :: rpt_origin + real(kind=dp), allocatable :: wannier_centres_translated(:, :) + complex(kind=dp), allocatable :: ham_k(:, :, :) + integer :: nrpts + + type(sitesym_type) :: sym + type(ham_logical_type) :: hmlg + + type(w90_extra_io_type) :: write_data + type(proj_input_type) :: proj + !Projections + logical :: lhasproj + +! Needed to split an array on different nodes (not done here) + integer, allocatable :: counts(:) + integer, allocatable :: displs(:) + integer :: num_nodes, my_node_id + type(w90comm_type) :: comm + logical :: disentanglement + logical :: mpiinitalready + + ! CORRECT ONLY FOR SERIAL CASE!!! + ! THESE LIBRARY ROUTINES ARE OBSOLETE + ! + ! depending on how the rest of the code is compiled (w or w/o MPI) + ! the various functions may or may not require a legitimate + ! MPI communicator + ! because the old "version 1" library interface does not support + ! providing a communicator, we open mpi_comm_world here and pass it + ! + ! it is expected that this library is only invoked with one process + ! even when compiled with MPI + ! use with more than one process is not supported/tested + ! --JJ 13Aug21 + ! +#ifdef MPI + call mpi_initialized(mpiinitalready, ierr) + if (.not. mpiinitalready) then + call io_error('mpi_init must be called before wannier_run() when libwannier is compiled with MPI support', & + stdout, seedname) + endif + comm%comm = MPI_COMM_WORLD + num_nodes = 1 + my_node_id = 0 +#else + num_nodes = 1 + my_node_id = 0 +#endif + + allocate (counts(0:num_nodes - 1)); + allocate (displs(0:num_nodes - 1)); time0 = io_time() - library = .true. -! seedname="wannier" seedname = trim(adjustl(seed__name)) inquire (file=trim(seedname)//'.wout', exist=wout_found) if (wout_found) then @@ -302,40 +542,52 @@ subroutine wannier_run(seed__name, mp_grid_loc, num_kpts_loc, & write (stdout, '(/,2a,/)') ' Resuming Wannier90 at ', ctime -! call param_write_header +! call w90_readwrite_write_header - ! copy local data into module variables num_bands = num_bands_loc mp_grid = mp_grid_loc num_kpts = num_kpts_loc real_lattice = real_lattice_loc - recip_lattice = recip_lattice_loc allocate (kpt_latt(3, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating kpt_latt in wannier_setup') + if (ierr /= 0) call io_error('Error allocating kpt_latt in wannier_setup', stdout, seedname) kpt_latt = kpt_latt_loc allocate (eigval(num_bands, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error allocating eigval in wannier_setup') + if (ierr /= 0) call io_error('Error allocating eigval in wannier_setup', stdout, seedname) eigval = eigenvalues_loc - num_atoms = num_atoms_loc + atoms%num_atoms = num_atoms_loc gamma_only = gamma_only_loc - call param_lib_set_atoms(atom_symbols_loc, atoms_cart_loc) - - call param_read() - - call param_write() - + call w90_readwrite_lib_set_atoms(atoms, atom_symbols_loc, atoms_cart_loc, real_lattice, stdout, seedname) + + call w90_wannier90_readwrite_read(atoms, band_plot, dis_data, dis_spheres, dis_window, exclude_bands, & + fermi_energy_list, fermi_surface_data, kmesh_data, kmesh_info, kpt_latt, & + out_files, plot, wannierise, wann_omega, proj, input_proj, rs_region, & + select_proj, spec_points, system, tran, verbose, wann_data, wann_plot, & + write_data, ws_region, w90_calcs, eigval, real_lattice, physics%bohr, & + symmetrize_eps, mp_grid, num_bands, num_kpts, num_proj, num_wann, optimisation, & + eig_found, calc_only_A, cp_pp, gamma_only, lhasproj, .true., .false., & + lsitesymmetry, use_bloch_phases, seedname, stdout) + have_disentangled = .false. + disentanglement = (num_bands > num_wann) + call w90_wannier90_readwrite_write(atoms, band_plot, dis_data, dis_spheres, fermi_energy_list, fermi_surface_data, & + kpt_latt, out_files, plot, wannierise, proj, input_proj, rs_region, & + select_proj, spec_points, tran, verbose, wann_data, wann_plot, write_data, & + w90_calcs, real_lattice, symmetrize_eps, mp_grid, num_bands, & + num_kpts, num_proj, num_wann, optimisation, cp_pp, gamma_only, lsitesymmetry, & + system%spinors, use_bloch_phases, stdout) time1 = io_time() write (stdout, '(1x,a25,f11.3,a)') 'Time to read parameters ', time1 - time0, ' (sec)' - call kmesh_get() + call kmesh_get(kmesh_data, kmesh_info, verbose, kpt_latt, real_lattice, & + num_kpts, gamma_only, seedname, stdout) time2 = io_time() write (stdout, '(1x,a25,f11.3,a)') 'Time to get kmesh ', time2 - time1, ' (sec)' - call comms_array_split(num_kpts, counts, displs) - call overlap_allocate() - + call comms_array_split(num_kpts, counts, displs, comm) + call overlap_allocate(a_matrix, m_matrix, m_matrix_local, m_matrix_orig, m_matrix_orig_local, & + u_matrix, u_matrix_opt, kmesh_info%nntot, num_bands, num_kpts, num_wann, & + verbose%timing_level, seedname, stdout, comm) if (disentanglement) then m_matrix_orig = m_matrix_loc a_matrix = a_matrix_loc @@ -349,11 +601,14 @@ subroutine wannier_run(seed__name, mp_grid_loc, num_kpts_loc, & ! IMPORTANT NOTE: _loc are variables local to this function, passed in as variables ! Instead, _local are variables local to the MPI process. if (disentanglement) then - call comms_scatterv(m_matrix_orig_local, num_bands*num_bands*nntot*counts(my_node_id), & - m_matrix_orig, num_bands*num_bands*nntot*counts, num_bands*num_bands*nntot*displs) + call comms_scatterv(m_matrix_orig_local, & + num_bands*num_bands*kmesh_info%nntot*counts(my_node_id), m_matrix_orig, & + num_bands*num_bands*kmesh_info%nntot*counts, & + num_bands*num_bands*kmesh_info%nntot*displs, stdout, seedname, comm) else - call comms_scatterv(m_matrix_local, num_wann*num_wann*nntot*counts(my_node_id), & - m_matrix, num_wann*num_wann*nntot*counts, num_wann*num_wann*nntot*displs) + call comms_scatterv(m_matrix_local, num_wann*num_wann*kmesh_info%nntot*counts(my_node_id), & + m_matrix, num_wann*num_wann*kmesh_info%nntot*counts, num_wann*num_wann* & + kmesh_info%nntot*displs, stdout, seedname, comm) endif !~ ! Check Mmn(k,b) is symmetric in m and n for gamma_only case @@ -361,41 +616,77 @@ subroutine wannier_run(seed__name, mp_grid_loc, num_kpts_loc, & if (disentanglement) then have_disentangled = .false. - call dis_main() + + call dis_main(dis_data, dis_spheres, dis_window, kmesh_info, kpt_latt, sym, verbose, a_matrix, & + m_matrix, m_matrix_local, m_matrix_orig, m_matrix_orig_local, u_matrix, & + u_matrix_opt, eigval, real_lattice, wann_omega%invariant, & + num_bands, num_kpts, num_wann, optimisation, gamma_only, lsitesymmetry, & + stdout, seedname, comm) have_disentangled = .true. - call param_write_chkpt('postdis') + call w90_wannier90_readwrite_write_chkpt('postdis', exclude_bands, wann_data, kmesh_info, & + kpt_latt, num_kpts, dis_window, num_bands, num_wann, u_matrix, & + u_matrix_opt, m_matrix, mp_grid, real_lattice, & + wann_omega%invariant, have_disentangled, stdout, seedname) + time1 = io_time() write (stdout, '(1x,a25,f11.3,a)') 'Time to disentangle ', time1 - time2, ' (sec)' else if (gamma_only) then - call overlap_project_gamma() + call overlap_project_gamma(m_matrix, u_matrix, kmesh_info%nntot, num_wann, & + verbose%timing_level, seedname, stdout) else - call overlap_project() + call overlap_project(sym, m_matrix, m_matrix_local, u_matrix, kmesh_info%nnlist, & + kmesh_info%nntot, num_bands, num_kpts, num_wann, & + verbose%timing_level, lsitesymmetry, seedname, stdout, comm) endif time1 = io_time() write (stdout, '(1x,a25,f11.3,a)') 'Time to project overlaps ', time1 - time2, ' (sec)' end if if (gamma_only) then - call wann_main_gamma() + call wann_main_gamma(atoms, dis_window, exclude_bands, kmesh_info, kpt_latt, out_files, & + wannierise, wann_omega, system, verbose, wann_data, m_matrix, & + u_matrix, u_matrix_opt, eigval, real_lattice, mp_grid, & + num_bands, num_kpts, num_wann, have_disentangled, & + rs_region%translate_home_cell, seedname, stdout, comm) else - call wann_main() + call wann_main(atoms, dis_window, exclude_bands, hmlg, kmesh_info, kpt_latt, out_files, & + rs_region, wannierise, wann_omega, sym, system, verbose, wann_data, & + ws_region, w90_calcs, ham_k, ham_r, m_matrix, u_matrix, u_matrix_opt, eigval, & + real_lattice, wannier_centres_translated, irvec, mp_grid, ndegen, shift_vec, & + nrpts, num_bands, num_kpts, num_proj, num_wann, optimisation, rpt_origin, & + band_plot%mode, tran%mode, have_disentangled, lsitesymmetry, & + seedname, stdout, comm) endif - call param_write_chkpt('postwann') + call w90_wannier90_readwrite_write_chkpt('postwann', exclude_bands, wann_data, kmesh_info, kpt_latt, & + num_kpts, dis_window, num_bands, num_wann, u_matrix, u_matrix_opt, & + m_matrix, mp_grid, real_lattice, & + wann_omega%invariant, have_disentangled, stdout, seedname) time2 = io_time() write (stdout, '(1x,a25,f11.3,a)') 'Time for wannierise ', time2 - time1, ' (sec)' - if (wannier_plot .or. bands_plot .or. fermi_surface_plot .or. write_hr .or. write_bvec) then - call plot_main() + if (w90_calcs%wannier_plot .or. w90_calcs%bands_plot .or. w90_calcs%fermi_surface_plot .or. out_files%write_hr) then + call plot_main(atoms, band_plot, dis_window, fermi_energy_list, fermi_surface_data, hmlg, & + kmesh_info, kpt_latt, out_files, plot, rs_region, spec_points, & + verbose, wann_data, wann_plot, ws_region, w90_calcs, ham_k, ham_r, m_matrix, & + u_matrix, u_matrix_opt, eigval, real_lattice, & + wannier_centres_translated, physics%bohr, irvec, mp_grid, ndegen, shift_vec, & + nrpts, num_bands, num_kpts, num_wann, rpt_origin, tran%mode, have_disentangled, & + lsitesymmetry, system%spinors, seedname, stdout, comm) time1 = io_time() write (stdout, '(1x,a25,f11.3,a)') 'Time for plotting ', time1 - time2, ' (sec)' end if time2 = io_time() - if (transport) then - call tran_main() + if (w90_calcs%transport) then + call tran_main(atoms, dis_window, fermi_energy_list, hmlg, kpt_latt, out_files, rs_region, & + tran, verbose, wann_data, ws_region, w90_calcs, ham_k, ham_r, u_matrix, & + u_matrix_opt, eigval, real_lattice, wannier_centres_translated, & + irvec, mp_grid, ndegen, shift_vec, nrpts, num_bands, num_kpts, num_wann, & + rpt_origin, band_plot%mode, have_disentangled, lsitesymmetry, seedname, & + stdout) time1 = io_time() write (stdout, '(1x,a25,f11.3,a)') 'Time for transport ', time1 - time2, ' (sec)' end if @@ -407,7 +698,7 @@ subroutine wannier_run(seed__name, mp_grid_loc, num_kpts_loc, & if (present(u_matrix_opt_loc) .and. present(lwindow_loc)) then if (disentanglement) then u_matrix_opt_loc = u_matrix_opt - lwindow_loc = lwindow + lwindow_loc = dis_window%lwindow else u_matrix_opt_loc = cmplx_0 do loop_k = 1, num_kpts @@ -419,21 +710,25 @@ subroutine wannier_run(seed__name, mp_grid_loc, num_kpts_loc, & end if end if - if (present(wann_centres_loc)) wann_centres_loc = wannier_centres - if (present(wann_spreads_loc)) wann_spreads_loc = wannier_spreads + if (present(wann_centres_loc)) wann_centres_loc = wann_data%centres + if (present(wann_spreads_loc)) wann_spreads_loc = wann_data%spreads if (present(spread_loc)) then - spread_loc(1) = omega_total - spread_loc(2) = omega_invariant - spread_loc(3) = omega_tilde + spread_loc(1) = wann_omega%total + spread_loc(2) = wann_omega%invariant + spread_loc(3) = wann_omega%tilde endif - call hamiltonian_dealloc() - call overlap_dealloc() - call kmesh_dealloc() - call param_dealloc() - + call hamiltonian_dealloc(hmlg, ham_k, ham_r, wannier_centres_translated, irvec, ndegen, & + stdout, seedname) + + call overlap_dealloc(a_matrix, m_matrix, m_matrix_local, m_matrix_orig, m_matrix_orig_local, & + u_matrix, u_matrix_opt, seedname, stdout, comm) + call kmesh_dealloc(kmesh_info, stdout, seedname) + call w90_wannier90_readwrite_w90_dealloc(atoms, band_plot, dis_spheres, dis_window, exclude_bands, kmesh_data, & + kpt_latt, wannierise, proj, input_proj, select_proj, spec_points, & + wann_data, wann_plot, write_data, eigval, seedname, stdout) write (stdout, '(1x,a25,f11.3,a)') 'Total Execution Time ', io_time() - time0, ' (sec)' - if (timing_level > 0) call io_print_timings() + if (verbose%timing_level > 0) call io_print_timings(stdout) write (stdout, *) write (stdout, '(1x,a)') 'All done: wannier90 exiting' diff --git a/src/wannier_prog.F90 b/src/wannier_prog.F90 index 805aae0c5..0c2fa6302 100644 --- a/src/wannier_prog.F90 +++ b/src/wannier_prog.F90 @@ -52,8 +52,8 @@ program wannier !! The main Wannier90 program - use w90_constants - use w90_parameters + use w90_constants, only: w90_physical_constants_type, dp + use w90_types use w90_io use w90_hamiltonian use w90_kmesh @@ -62,31 +62,161 @@ program wannier use w90_wannierise use w90_plot use w90_transport - use w90_comms, only: on_root, num_nodes, comms_setup, comms_end, comms_bcast, my_node_id + use w90_comms use w90_sitesym !YN: + use w90_readwrite, only: w90_readwrite_write_header, w90_readwrite_read_chkpt, & + w90_readwrite_chkpt_dist + use w90_wannier90_types + use w90_wannier90_readwrite, only: w90_wannier90_readwrite_read, & + w90_wannier90_readwrite_w90_dealloc, & + w90_wannier90_readwrite_write, w90_wannier90_readwrite_dist, & + w90_wannier90_readwrite_memory_estimate, & + w90_wannier90_readwrite_write_chkpt, w90_extra_io_type + +#ifdef MPI +# if !(defined(MPI08) || defined(MPI90) || defined(MPIH)) +# error "You need to define which MPI interface you are using" +# endif +#endif + +#ifdef MPI08 + use mpi_f08 ! use f08 interface if possible +#endif +#ifdef MPI90 + use mpi ! next best, use fortran90 interface +#endif + implicit none +#ifdef MPIH + include 'mpif.h' ! worst case, use legacy interface +#endif + + type(atom_data_type) :: atom_data + type(band_plot_type) :: band_plot + type(dis_control_type) :: dis_control + type(dis_manifold_type) :: dis_manifold + type(dis_spheres_type) :: dis_spheres + type(fermi_surface_plot_type) :: fermi_surface_plot + type(ham_logical_type) :: ham_logical + type(kmesh_info_type) :: kmesh_info + type(kmesh_input_type) :: kmesh_input + type(kpoint_path_type) :: kpoint_path + type(output_file_type) :: output_file + type(print_output_type) :: print_output + type(proj_input_type) :: input_proj + type(real_space_ham_type) :: real_space_ham + type(select_projection_type) :: select_projection + type(sitesym_type) :: sitesym + type(transport_type) :: transport + type(w90_calculation_type) :: w90_calculation + type(w90comm_type) :: comm + type(w90_physical_constants_type) :: physics + type(w90_system_type) :: w90_system + type(wann_control_type) :: wann_control + type(wannier_data_type) :: wannier_data + type(wannier_plot_type) :: wannier_plot + type(wann_omega_type) :: omega + type(ws_region_type) :: ws_region + type(wvfn_read_type) :: wvfn_read + + integer, allocatable :: exclude_bands(:) + integer :: mp_grid(3) !! Dimensions of the Monkhorst-Pack grid + integer :: num_bands !! Number of bands + integer :: num_exclude_bands + integer :: num_kpts + integer :: num_proj + integer :: num_wann !! number of wannier functions + integer :: optimisation + + real(kind=dp), allocatable :: kpt_latt(:, :) !! kpoints in lattice vecs + real(kind=dp), allocatable :: eigval(:, :) + real(kind=dp), allocatable :: fermi_energy_list(:) + real(kind=dp) :: real_lattice(3, 3) + real(kind=dp) :: recip_lattice(3, 3) + + ! Are we running postw90? + !logical :: ispostw90 = .false. + + ! a_matrix and m_matrix_orig can be calculated internally from bloch states + ! or read in from an ab-initio grid + ! a_matrix = projection of trial orbitals on bloch states + ! m_matrix_orig = overlap of bloch states + !BGS a_matrix, m_matrix in disentangle and overlap + complex(kind=dp), allocatable :: a_matrix(:, :, :) + complex(kind=dp), allocatable :: m_matrix_orig(:, :, :, :) + complex(kind=dp), allocatable :: m_matrix_orig_local(:, :, :, :) + ! u_matrix_opt gives the num_wann dimension optimal subspace from the + ! original bloch states + complex(kind=dp), allocatable :: u_matrix_opt(:, :, :) + ! u_matrix gives the unitary rotations from the optimal subspace to the + ! optimally smooth states. + ! m_matrix we store here, becuase it is needed for restart of wannierise + complex(kind=dp), allocatable :: u_matrix(:, :, :) + ! disentangle, hamiltonain, overlap and wannierise + complex(kind=dp), allocatable :: m_matrix(:, :, :, :) + complex(kind=dp), allocatable :: m_matrix_local(:, :, :, :) + + integer :: rpt_origin + !! index of R=0 + integer :: nrpts + !! number of Wigner-Seitz grid points + integer, allocatable :: irvec(:, :) + !! The irpt-th Wigner-Seitz grid point has components + !! irvec(1:3,irpt) in the basis of the lattice vectors + integer, allocatable :: shift_vec(:, :) + integer, allocatable :: ndegen(:) + !! Weight of the irpt-th point is 1/ndegen(irpt) + real(kind=dp), allocatable :: wannier_centres_translated(:, :) + complex(kind=dp), allocatable :: ham_r(:, :, :) + !! Hamiltonian matrix in WF representation + complex(kind=dp), allocatable :: ham_k(:, :, :) + + type(proj_input_type) :: proj_input ! Projections + type(w90_extra_io_type) :: w90_extra_io + real(kind=dp) time0, time1, time2 - character(len=9) :: stat, pos, cdate, ctime - logical :: wout_found, dryrun + integer :: len_seedname + integer :: num_nodes, my_node_id, ierr + integer :: stdout + + logical :: eig_found + logical :: gamma_only + logical :: have_disentangled, disentanglement + logical :: lhasproj + logical :: lsitesymmetry = .false. ! RS: symmetry-adapted Wannier functions + logical :: on_root = .false. + logical :: use_bloch_phases, cp_pp, calc_only_A + logical :: wout_found, dryrun + + character(len=20) :: checkpoint character(len=50) :: prog + character(len=50) :: seedname + character(len=9) :: stat, pos, cdate, ctime - call comms_setup +#ifdef MPI + comm%comm = MPI_COMM_WORLD + call mpi_init(ierr) + seedname = "wannier" + if (ierr .ne. 0) call io_error('MPI initialisation error', 0, seedname) ! stdout, seedname not yet known! +#endif - library = .false. + num_nodes = mpisize(comm) + my_node_id = mpirank(comm) + if (my_node_id == 0) on_root = .true. time0 = io_time() if (on_root) then prog = 'wannier90' - call io_commandline(prog, dryrun) + call io_commandline(prog, dryrun, seedname) len_seedname = len(seedname) end if - call comms_bcast(len_seedname, 1) - call comms_bcast(seedname, len_seedname) - call comms_bcast(dryrun, 1) + call comms_bcast(len_seedname, 1, stdout, seedname, comm) + call comms_bcast(seedname, len_seedname, stdout, seedname, comm) + call comms_bcast(dryrun, 1, stdout, seedname, comm) if (on_root) then stdout = io_file_unit() @@ -94,10 +224,19 @@ program wannier call io_date(cdate, ctime) write (stdout, *) 'Wannier90: Execution started on ', cdate, ' at ', ctime - call param_read + call w90_wannier90_readwrite_read(atom_data, band_plot, dis_control, dis_spheres, dis_manifold, exclude_bands, & + fermi_energy_list, fermi_surface_plot, kmesh_input, kmesh_info, kpt_latt, & + output_file, wvfn_read, wann_control, omega, proj_input, input_proj, & + real_space_ham, select_projection, kpoint_path, w90_system, transport, & + print_output, wannier_data, wannier_plot, w90_extra_io, ws_region, & + w90_calculation, eigval, real_lattice, physics%bohr, sitesym%symmetrize_eps, mp_grid, & + num_bands, num_kpts, num_proj, num_wann, optimisation, eig_found, & + calc_only_A, cp_pp, gamma_only, lhasproj, .false., .false., lsitesymmetry, & + use_bloch_phases, seedname, stdout) + have_disentangled = .false. close (stdout, status='delete') - if (restart .eq. ' ') then + if (w90_calculation%restart .eq. ' ') then stat = 'replace' pos = 'rewind' else @@ -112,7 +251,8 @@ program wannier stdout = io_file_unit() open (unit=stdout, file=trim(seedname)//'.wout', status=trim(stat), position=trim(pos)) - call param_write_header() + call w90_readwrite_write_header(physics%bohr_version_str, physics%constants_version_str1, & + physics%constants_version_str2, stdout) if (num_nodes == 1) then #ifdef MPI write (stdout, '(/,1x,a)') 'Running in serial (with parallel executable)' @@ -120,21 +260,28 @@ program wannier write (stdout, '(/,1x,a)') 'Running in serial (with serial executable)' #endif else - write (stdout, '(/,1x,a,i3,a/)') & - 'Running in parallel on ', num_nodes, ' CPUs' + write (stdout, '(/,1x,a,i3,a/)') 'Running in parallel on ', num_nodes, ' CPUs' endif - call param_write() - + call w90_wannier90_readwrite_write(atom_data, band_plot, dis_control, dis_spheres, fermi_energy_list, & + fermi_surface_plot, kpt_latt, output_file, wvfn_read, wann_control, & + proj_input, input_proj, real_space_ham, select_projection, kpoint_path, & + transport, print_output, wannier_data, wannier_plot, w90_extra_io, & + w90_calculation, real_lattice, sitesym%symmetrize_eps, mp_grid, num_bands, num_kpts, & + num_proj, num_wann, optimisation, cp_pp, gamma_only, lsitesymmetry, & + w90_system%spinors, use_bloch_phases, stdout) time1 = io_time() write (stdout, '(1x,a25,f11.3,a)') 'Time to read parameters ', time1 - time0, ' (sec)' - if (.not. explicit_nnkpts) call kmesh_get + if (.not. kmesh_info%explicit_nnkpts) call kmesh_get(kmesh_input, kmesh_info, print_output, & + kpt_latt, real_lattice, & + num_kpts, gamma_only, seedname, stdout) time2 = io_time() - write (stdout, '(1x,a25,f11.3,a)') & - 'Time to get kmesh ', time2 - time1, ' (sec)' + write (stdout, '(1x,a25,f11.3,a)') 'Time to get kmesh ', time2 - time1, ' (sec)' - call param_memory_estimate - end if + call w90_wannier90_readwrite_memory_estimate(atom_data, kmesh_info, wann_control, input_proj, print_output, & + num_bands, num_kpts, num_proj, num_wann, optimisation, gamma_only, & + stdout) + end if !on_root if (dryrun) then if (on_root) then @@ -148,23 +295,42 @@ program wannier endif ! We now distribute the parameters to the other nodes - call param_dist + call w90_wannier90_readwrite_dist(atom_data, band_plot, dis_control, dis_spheres, dis_manifold, exclude_bands, & + fermi_energy_list, fermi_surface_plot, kmesh_input, kmesh_info, kpt_latt, & + output_file, wvfn_read, wann_control, omega, input_proj, real_space_ham, & + w90_system, transport, print_output, wannier_data, wannier_plot, ws_region, & + w90_calculation, eigval, real_lattice, sitesym%symmetrize_eps, mp_grid, & + kpoint_path%num_points_first_segment, num_bands, num_kpts, num_proj, num_wann, & + optimisation, eig_found, cp_pp, gamma_only, have_disentangled, & + lhasproj, lsitesymmetry, use_bloch_phases, seedname, stdout, comm) + disentanglement = (num_bands > num_wann) if (gamma_only .and. num_nodes > 1) & - call io_error('Gamma point branch is serial only at the moment') + call io_error('Gamma point branch is serial only at the moment', stdout, seedname) - if (transport .and. tran_read_ht) goto 3003 + if (w90_calculation%transport .and. transport%read_ht) goto 3003 ! Sort out restarts - if (restart .eq. ' ') then ! start a fresh calculation + if (w90_calculation%restart .eq. ' ') then ! start a fresh calculation if (on_root) write (stdout, '(1x,a/)') 'Starting a new Wannier90 calculation ...' else ! restart a previous calculation - if (on_root) call param_read_chkpt() - call param_chkpt_dist - if (lsitesymmetry) call sitesym_read() ! update this to read on root and bcast - JRY + if (on_root) then + num_exclude_bands = 0 + if (allocated(exclude_bands)) num_exclude_bands = size(exclude_bands) + call w90_readwrite_read_chkpt(dis_manifold, exclude_bands, kmesh_info, kpt_latt, wannier_data, & + m_matrix, u_matrix, u_matrix_opt, real_lattice, & + omega%invariant, mp_grid, num_bands, num_exclude_bands, num_kpts, & + num_wann, checkpoint, have_disentangled, .false., & + seedname, stdout) + endif + call w90_readwrite_chkpt_dist(dis_manifold, wannier_data, u_matrix, u_matrix_opt, & + omega%invariant, num_bands, num_kpts, num_wann, & + checkpoint, have_disentangled, seedname, stdout, comm) + if (lsitesymmetry) call sitesym_read(sitesym, num_bands, num_kpts, num_wann, seedname, stdout) ! update this to read on root and bcast - JRY - select case (restart) + select case (w90_calculation%restart) case ('default') ! continue from where last checkpoint was written - if (on_root) write (stdout, '(/1x,a)', advance='no') 'Resuming a previous Wannier90 calculation ' + if (on_root) write (stdout, '(/1x,a)', advance='no') & + 'Resuming a previous Wannier90 calculation ' if (checkpoint .eq. 'postdis') then if (on_root) write (stdout, '(a/)') 'from wannierisation ...' goto 1001 ! go to wann_main @@ -173,7 +339,7 @@ program wannier goto 2002 ! go to plot_main else if (on_root) write (stdout, '(/a/)') - call io_error('Value of checkpoint not recognised in wann_prog') + call io_error('Value of checkpoint not recognised in wann_prog', stdout, seedname) endif case ('wannierise') ! continue from wann_main irrespective of value of last checkpoint if (on_root) write (stdout, '(1x,a/)') 'Restarting Wannier90 from wannierisation ...' @@ -184,91 +350,149 @@ program wannier case ('transport') ! continue from tran_main irrespective of value of last checkpoint if (on_root) write (stdout, '(1x,a/)') 'Restarting Wannier90 from transport routines ...' goto 3003 - case default ! for completeness... (it is already trapped in param_read) - call io_error('Value of restart not recognised in wann_prog') + case default ! for completeness... (it is already trapped in w90_wannier90_readwrite_read) + call io_error('Value of restart not recognised in wann_prog', stdout, seedname) end select endif - if (postproc_setup) then - if (on_root) call kmesh_write() - call kmesh_dealloc() - call param_dealloc() + if (w90_calculation%postproc_setup) then + if (on_root) call kmesh_write(exclude_bands, kmesh_info, input_proj, print_output, & + kpt_latt, real_lattice, num_kpts, & + num_proj, calc_only_A, w90_system%spinors, seedname, stdout) + call kmesh_dealloc(kmesh_info, stdout, seedname) + call w90_wannier90_readwrite_w90_dealloc(atom_data, band_plot, dis_spheres, dis_manifold, exclude_bands, & + kmesh_input, kpt_latt, wann_control, proj_input, input_proj, & + select_projection, kpoint_path, wannier_data, wannier_plot, & + w90_extra_io, eigval, seedname, stdout) if (on_root) write (stdout, '(1x,a25,f11.3,a)') 'Time to write kmesh ', io_time(), ' (sec)' if (on_root) write (stdout, '(/a)') ' Exiting... '//trim(seedname)//'.nnkp written.' call comms_end stop endif - if (lsitesymmetry) call sitesym_read() ! update this to read on root and bcast - JRY - call overlap_allocate() - call overlap_read() + if (lsitesymmetry) call sitesym_read(sitesym, num_bands, num_kpts, num_wann, seedname, stdout) ! update this to read on root and bcast - JRY + call overlap_allocate(a_matrix, m_matrix, m_matrix_local, m_matrix_orig, m_matrix_orig_local, & + u_matrix, u_matrix_opt, kmesh_info%nntot, num_bands, num_kpts, num_wann, & + print_output%timing_level, seedname, stdout, comm) + call overlap_read(kmesh_info, select_projection, sitesym, a_matrix, m_matrix, m_matrix_local, & + m_matrix_orig, m_matrix_orig_local, u_matrix, u_matrix_opt, num_bands, & + num_kpts, num_proj, num_wann, print_output%timing_level, cp_pp, & + gamma_only, lsitesymmetry, use_bloch_phases, seedname, stdout, comm) time1 = io_time() - if (on_root) write (stdout, '(/1x,a25,f11.3,a)') 'Time to read overlaps ', time1 - time2, ' (sec)' + if (on_root) write (stdout, '(/1x,a25,f11.3,a)') 'Time to read overlaps ', time1 - time2, & + ' (sec)' have_disentangled = .false. if (disentanglement) then - call dis_main() + + call dis_main(dis_control, dis_spheres, dis_manifold, kmesh_info, kpt_latt, sitesym, & + print_output, a_matrix, m_matrix, m_matrix_local, m_matrix_orig, & + m_matrix_orig_local, u_matrix, u_matrix_opt, eigval, real_lattice, & + omega%invariant, num_bands, num_kpts, num_wann, optimisation, gamma_only, & + lsitesymmetry, stdout, seedname, comm) have_disentangled = .true. time2 = io_time() - if (on_root) write (stdout, '(1x,a25,f11.3,a)') 'Time to disentangle bands', time2 - time1, ' (sec)' + if (on_root) write (stdout, '(1x,a25,f11.3,a)') 'Time to disentangle bands', time2 - time1, & + ' (sec)' endif - if (on_root) call param_write_chkpt('postdis') -!~ call param_write_um + if (on_root) then + call w90_wannier90_readwrite_write_chkpt('postdis', exclude_bands, wannier_data, kmesh_info, & + kpt_latt, num_kpts, dis_manifold, num_bands, num_wann, u_matrix, & + u_matrix_opt, m_matrix, mp_grid, real_lattice, & + omega%invariant, have_disentangled, stdout, seedname) + endif +!~ call w90_wannier90_readwrite_write_um 1001 time2 = io_time() + ! JJ workaround mpi_scatterv requirement that all arrays are valid *for all mpi procs* + ! m_matrix* usually alloc'd in overlaps.F90, but not invariably, need to check here + if (.not. allocated(m_matrix)) allocate (m_matrix(1, 1, 1, 1)) + if (.not. gamma_only) then - call wann_main() + call wann_main(atom_data, dis_manifold, exclude_bands, ham_logical, kmesh_info, kpt_latt, & + output_file, real_space_ham, wann_control, omega, sitesym, w90_system, & + print_output, wannier_data, ws_region, w90_calculation, ham_k, ham_r, m_matrix, & + u_matrix, u_matrix_opt, eigval, real_lattice, wannier_centres_translated, & + irvec, mp_grid, ndegen, shift_vec, nrpts, num_bands, num_kpts, num_proj, & + num_wann, optimisation, rpt_origin, band_plot%mode, transport%mode, & + have_disentangled, lsitesymmetry, seedname, stdout, comm) else - call wann_main_gamma() + call wann_main_gamma(atom_data, dis_manifold, exclude_bands, kmesh_info, kpt_latt, & + output_file, wann_control, omega, w90_system, print_output, wannier_data, & + m_matrix, u_matrix, u_matrix_opt, eigval, real_lattice, mp_grid, & + num_bands, num_kpts, num_wann, have_disentangled, & + real_space_ham%translate_home_cell, seedname, stdout, comm) end if time1 = io_time() - if (on_root) write (stdout, '(1x,a25,f11.3,a)') 'Time for wannierise ', time1 - time2, ' (sec)' + if (on_root) write (stdout, '(1x,a25,f11.3,a)') 'Time for wannierise ', time1 - time2, & + ' (sec)' - if (on_root) call param_write_chkpt('postwann') + if (on_root) then + call w90_wannier90_readwrite_write_chkpt('postwann', exclude_bands, wannier_data, kmesh_info, & + kpt_latt, num_kpts, dis_manifold, num_bands, num_wann, u_matrix, & + u_matrix_opt, m_matrix, mp_grid, real_lattice, & + omega%invariant, have_disentangled, stdout, seedname) + endif 2002 continue if (on_root) then - ! I call the routine always; the if statements to decide if/what - ! to plot are inside the function time2 = io_time() - endif - call plot_main() + end if + + ! I call the routine always; the if statements to decide if/what to plot are inside the function + call plot_main(atom_data, band_plot, dis_manifold, fermi_energy_list, fermi_surface_plot, & + ham_logical, kmesh_info, kpt_latt, output_file, wvfn_read, real_space_ham, & + kpoint_path, print_output, wannier_data, wannier_plot, ws_region, & + w90_calculation, ham_k, ham_r, m_matrix, u_matrix, u_matrix_opt, eigval, & + real_lattice, wannier_centres_translated, physics%bohr, irvec, mp_grid, ndegen, & + shift_vec, nrpts, num_bands, num_kpts, num_wann, rpt_origin, transport%mode, & + have_disentangled, lsitesymmetry, w90_system%spinors, seedname, stdout, comm) + if (on_root) then time1 = io_time() - ! Now time is always printed, even if no plotting is done/required, but - ! it shouldn't be a problem. write (stdout, '(1x,a25,f11.3,a)') 'Time for plotting ', time1 - time2, ' (sec)' endif 3003 continue if (on_root) then - time2 = io_time() - if (transport) then - call tran_main() + if (w90_calculation%transport) then + time2 = io_time() + + call tran_main(atom_data, dis_manifold, fermi_energy_list, ham_logical, kpt_latt, output_file, & + real_space_ham, transport, print_output, wannier_data, ws_region, w90_calculation, ham_k, ham_r, & + u_matrix, u_matrix_opt, eigval, real_lattice, & + wannier_centres_translated, irvec, mp_grid, ndegen, shift_vec, nrpts, & + num_bands, num_kpts, num_wann, rpt_origin, band_plot%mode, & + have_disentangled, lsitesymmetry, seedname, stdout) time1 = io_time() + write (stdout, '(1x,a25,f11.3,a)') 'Time for transport ', time1 - time2, ' (sec)' - if (tran_read_ht) goto 4004 + if (transport%read_ht) goto 4004 end if endif - call tran_dealloc() - call hamiltonian_dealloc() - call overlap_dealloc() - call kmesh_dealloc() - call param_dealloc() - if (lsitesymmetry) call sitesym_dealloc() !YN: + call hamiltonian_dealloc(ham_logical, ham_k, ham_r, wannier_centres_translated, irvec, ndegen, & + stdout, seedname) + call overlap_dealloc(a_matrix, m_matrix, m_matrix_local, m_matrix_orig, m_matrix_orig_local, & + u_matrix, u_matrix_opt, seedname, stdout, comm) + call kmesh_dealloc(kmesh_info, stdout, seedname) + call w90_wannier90_readwrite_w90_dealloc(atom_data, band_plot, dis_spheres, dis_manifold, exclude_bands, & + kmesh_input, kpt_latt, wann_control, proj_input, input_proj, & + select_projection, kpoint_path, wannier_data, wannier_plot, & + w90_extra_io, eigval, seedname, stdout) + if (lsitesymmetry) call sitesym_dealloc(sitesym, stdout, seedname) !YN: 4004 continue if (on_root) then write (stdout, '(1x,a25,f11.3,a)') 'Total Execution Time ', io_time(), ' (sec)' - if (timing_level > 0) call io_print_timings() + if (print_output%timing_level > 0) call io_print_timings(stdout) write (stdout, *) write (stdout, '(1x,a)') 'All done: wannier90 exiting' diff --git a/src/wannierise.F90 b/src/wannierise.F90 index c21b2b8b6..1f63be42a 100644 --- a/src/wannierise.F90 +++ b/src/wannierise.F90 @@ -11,107 +11,141 @@ ! ! ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! +! ! +! w90_wannierise: MLFW algorithm ! +! ! +!------------------------------------------------------------! module w90_wannierise + !! Main routines for the minimisation of the spread - use w90_constants - use w90_comms, only: on_root, my_node_id, num_nodes, & - comms_bcast, comms_array_split, & - comms_gatherv, comms_allreduce, & - comms_scatterv + use w90_constants, only: dp implicit none private public :: wann_main - public :: wann_main_gamma ![ysl] - - ! Data to avoid large allocation within iteration loop - real(kind=dp), allocatable :: rnkb(:, :, :) - real(kind=dp), allocatable :: rnkb_loc(:, :, :) - real(kind=dp), allocatable :: ln_tmp(:, :, :) - - real(kind=dp), allocatable :: ln_tmp_loc(:, :, :) - - ! for MPI - complex(kind=dp), allocatable :: u_matrix_loc(:, :, :) - complex(kind=dp), allocatable :: m_matrix_loc(:, :, :, :) - complex(kind=dp), allocatable :: m_matrix_1b(:, :, :) - complex(kind=dp), allocatable :: m_matrix_1b_loc(:, :, :) - complex(kind=dp), allocatable :: cdq_loc(:, :, :) ! the only large array sent - ! from process to process - ! in the main loop - complex(kind=dp), allocatable :: cdodq_loc(:, :, :) - integer, allocatable :: counts(:) - integer, allocatable :: displs(:) - - logical :: first_pass - !! Used to trigger the calculation of the invarient spread - !! we only need to do this on entering wann_main (_gamma) - real(kind=dp) :: lambda_loc - -#ifdef MPI - include 'mpif.h' -#endif - - type localisation_vars + public :: wann_main_gamma + + type localisation_vars_type !! Contributions to the spread - real(kind=dp) :: om_i - !! Gauge Invarient - real(kind=dp) :: om_d - !! Diagonal - real(kind=dp) :: om_od - !! Off-diagonal - real(kind=dp) :: om_tot - !! Total - real(kind=dp) :: om_iod - !! Combined I-OD term for selective localization - real(kind=dp) :: om_nu - !! Lagrange multiplier term due to constrained centres - !! real(kind=dp) :: om_c - !! Total spread functional with constraints -!~ real(kind=dp) :: om_1 -!~ real(kind=dp) :: om_2 -!~ real(kind=dp) :: om_3 - end type localisation_vars + real(kind=dp) :: om_i !! Gauge Invarient + real(kind=dp) :: om_d !! Diagonal + real(kind=dp) :: om_od !! Off-diagonal + real(kind=dp) :: om_tot !! Total + real(kind=dp) :: om_iod !! Combined I-OD term for selective localization + real(kind=dp) :: om_nu !! Lagrange multiplier term due to constrained centres + end type localisation_vars_type contains - !==================================================================! - subroutine wann_main - !==================================================================! - ! ! + !================================================! + subroutine wann_main(atom_data, dis_manifold, exclude_bands, ham_logical, kmesh_info, kpt_latt, & + output_file, real_space_ham, wann_control, omega, sitesym, w90_system, & + print_output, wannier_data, ws_region, w90_calculation, ham_k, ham_r, & + m_matrix, u_matrix, u_matrix_opt, eigval, real_lattice, & + wannier_centres_translated, irvec, mp_grid, ndegen, shift_vec, nrpts, & + num_bands, num_kpts, num_proj, num_wann, optimisation, rpt_origin, & + bands_plot_mode, transport_mode, have_disentangled, lsitesymmetry, & + seedname, stdout, comm) + !================================================! + ! !! Calculate the Unitary Rotations to give Maximally Localised Wannier Functions - ! ! - !=================================================================== - use w90_constants, only: dp, cmplx_1, cmplx_0, eps2, eps5, eps8 - use w90_io, only: stdout, io_error, io_wallclocktime, io_stopwatch & - , io_file_unit - use w90_parameters, only: num_wann, num_cg_steps, num_iter, nnlist, & - nntot, wbtot, u_matrix, m_matrix, num_kpts, iprint, num_print_cycles, & - num_dump_cycles, omega_invariant, param_write_chkpt, length_unit, & - lenconfac, proj_site, real_lattice, write_r2mn, guiding_centres, & - num_guide_cycles, num_no_guide_iter, timing_level, trial_step, precond, spinors, & - fixed_step, lfixstep, write_proj, have_disentangled, conv_tol, num_proj, & - conv_window, conv_noise_amp, conv_noise_num, wannier_centres, write_xyz, & - wannier_spreads, omega_total, omega_tilde, optimisation, write_vdw_data, & - write_hr_diag, kpt_latt, bk, ccentres_cart, slwf_num, selective_loc, & - slwf_constrain, slwf_lambda + ! + !================================================ + use w90_constants, only: dp, cmplx_1, cmplx_0, twopi, cmplx_i + use w90_io, only: io_error, io_wallclocktime, io_stopwatch, io_file_unit + use w90_wannier90_types, only: wann_control_type, output_file_type, & + w90_calculation_type, real_space_ham_type, wann_omega_type, sitesym_type, & + ham_logical_type + use w90_types, only: kmesh_info_type, print_output_type, wannier_data_type, & + atom_data_type, dis_manifold_type, w90_system_type, ws_region_type + use w90_wannier90_readwrite, only: w90_wannier90_readwrite_write_chkpt use w90_utility, only: utility_frac_to_cart, utility_zgemm - use w90_parameters, only: lsitesymmetry !RS: - use w90_sitesym, only: sitesym_symmetrize_gradient !RS: + use w90_sitesym, only: sitesym_symmetrize_gradient + use w90_comms, only: mpisize, mpirank, comms_gatherv, comms_bcast, & + comms_scatterv, comms_array_split, w90comm_type !ivo - use w90_hamiltonian, only: hamiltonian_setup, hamiltonian_get_hr, ham_r, & - rpt_origin, irvec, nrpts, ndegen + use w90_hamiltonian, only: hamiltonian_setup, hamiltonian_get_hr implicit none - type(localisation_vars) :: old_spread - type(localisation_vars) :: wann_spread - type(localisation_vars) :: trial_spread + ! arguments + type(atom_data_type), intent(in) :: atom_data + type(dis_manifold_type), intent(in) :: dis_manifold + type(ham_logical_type), intent(inout) :: ham_logical + type(kmesh_info_type), intent(in) :: kmesh_info + real(kind=dp), intent(in) :: kpt_latt(:, :) + type(w90_system_type), intent(in) :: w90_system + type(ws_region_type), intent(in) :: ws_region + type(print_output_type), intent(in) :: print_output + type(output_file_type), intent(in) :: output_file + type(real_space_ham_type), intent(inout) :: real_space_ham + type(wann_control_type), intent(inout) :: wann_control + type(wann_omega_type), intent(inout) :: omega + type(sitesym_type), intent(in) :: sitesym + type(w90_calculation_type), intent(in) :: w90_calculation + type(w90comm_type), intent(in) :: comm + type(wannier_data_type), intent(inout) :: wannier_data + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: num_bands + integer, intent(in) :: num_kpts + integer, intent(in) :: num_proj + integer, intent(in) :: num_wann + integer, intent(in) :: optimisation + integer, intent(inout), allocatable :: irvec(:, :) + integer, intent(inout), allocatable :: ndegen(:) + integer, intent(inout), allocatable :: shift_vec(:, :) + integer, allocatable, intent(in) :: exclude_bands(:) + integer, intent(inout) :: nrpts + integer, intent(inout) :: rpt_origin + integer, intent(in) :: stdout + + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(inout), allocatable :: wannier_centres_translated(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + + complex(kind=dp), intent(inout), allocatable :: ham_k(:, :, :) + complex(kind=dp), intent(inout), allocatable :: ham_r(:, :, :) + complex(kind=dp), intent(inout) :: m_matrix(:, :, :, :) + complex(kind=dp), intent(inout) :: u_matrix(:, :, :) + complex(kind=dp), intent(in) :: u_matrix_opt(:, :, :) + + logical, intent(in) :: lsitesymmetry + logical, intent(in) :: have_disentangled + + character(len=*), intent(in) :: bands_plot_mode + character(len=*), intent(in) :: transport_mode + character(len=50), intent(in) :: seedname + + ! local variables + type(localisation_vars_type) :: old_spread + type(localisation_vars_type) :: wann_spread + type(localisation_vars_type) :: trial_spread + + ! Data to avoid large allocation within iteration loop + real(kind=dp), allocatable :: rnkb(:, :, :) + real(kind=dp), allocatable :: rnkb_loc(:, :, :) + real(kind=dp), allocatable :: ln_tmp(:, :, :) + real(kind=dp), allocatable :: ln_tmp_loc(:, :, :) + + !real(kind=dp), intent(in) :: recip_lattice(3, 3), volume + ! for MPI + complex(kind=dp), allocatable :: u_matrix_loc(:, :, :) + complex(kind=dp), allocatable :: m_matrix_loc(:, :, :, :) + complex(kind=dp), allocatable :: cdq_loc(:, :, :) ! the only large array sent from process to process in the main loop + complex(kind=dp), allocatable :: cdodq_loc(:, :, :) + integer, allocatable :: counts(:) + integer, allocatable :: displs(:) + + logical :: first_pass + !! Used to trigger the calculation of the invarient spread we only need to do this on entering wann_main (_gamma) + real(kind=dp) :: lambda_loc + ! end of wannierise module data ! guiding centres real(kind=dp), allocatable :: rguide(:, :) @@ -126,7 +160,6 @@ subroutine wann_main complex(kind=dp), allocatable :: cdodq_precond_loc(:, :, :) real(kind=dp), allocatable :: sheet(:, :, :) real(kind=dp), allocatable :: rave(:, :), r2ave(:), rave2(:) - real(kind=dp), dimension(3) :: rvec_cart !local arrays not passed into subroutines complex(kind=dp), allocatable :: cwschur1(:), cwschur2(:) @@ -146,27 +179,35 @@ subroutine wann_main real(kind=dp) :: doda0 real(kind=dp) :: falphamin, alphamin real(kind=dp) :: gcfac, gcnorm1, gcnorm0 - integer :: i, n, iter, ind, ierr, iw, ncg, info, nkp, nkp_loc, nn + integer :: i, n, iter, ind, ierr, iw, ncg, nkp, nkp_loc !, nn logical :: lprint, ldump, lquad real(kind=dp), allocatable :: history(:) real(kind=dp) :: save_spread logical :: lconverged, lrandom, lfirst integer :: conv_count, noise_count, page_unit - complex(kind=dp) :: fac, rdotk - real(kind=dp) :: alpha_precond + complex(kind=dp) :: rdotk !, fac + !real(kind=dp) :: alpha_precond integer :: irpt, loop_kpt - logical :: cconverged - real(kind=dp) :: glpar, cvalue_new + !logical :: cconverged + !real(kind=dp) :: glpar, cvalue_new real(kind=dp), allocatable :: rnr0n2(:) - if (timing_level > 0 .and. on_root) call io_stopwatch('wann: main', 1) + ! pllel setup + logical :: on_root = .false. + integer :: num_nodes, my_node_id + + num_nodes = mpisize(comm) + my_node_id = mpirank(comm) + if (my_node_id == 0) on_root = .true. + + if (print_output%timing_level > 0 .and. print_output%iprint > 0) call io_stopwatch('wann: main', 1, stdout, seedname) first_pass = .true. ! Allocate stuff - allocate (history(conv_window), stat=ierr) - if (ierr /= 0) call io_error('Error allocating history in wann_main') + allocate (history(wann_control%conv_window), stat=ierr) + if (ierr /= 0) call io_error('Error allocating history in wann_main', stdout, seedname) ! module data ! if(optimisation>0) then @@ -175,44 +216,47 @@ subroutine wann_main ! if (ierr/=0) call io_error('Error in allocating m0 in wann_main') ! allocate( u0 (num_wann, num_wann, num_kpts),stat=ierr) ! if (ierr/=0) call io_error('Error in allocating u0 in wann_main') - allocate (rnkb(num_wann, nntot, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating rnkb in wann_main') - allocate (ln_tmp(num_wann, nntot, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ln_tmp in wann_main') - if (selective_loc) then - allocate (rnr0n2(slwf_num), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating rnr0n2 in wann_main') + allocate (rnkb(num_wann, kmesh_info%nntot, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating rnkb in wann_main', stdout, seedname) + allocate (ln_tmp(num_wann, kmesh_info%nntot, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating ln_tmp in wann_main', stdout, seedname) + if (wann_control%constrain%selective_loc) then + allocate (rnr0n2(wann_control%constrain%slwf_num), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating rnr0n2 in wann_main', stdout, seedname) end if rnkb = 0.0_dp ! sub vars passed into other subs - allocate (csheet(num_wann, nntot, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating csheet in wann_main') + allocate (csheet(num_wann, kmesh_info%nntot, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating csheet in wann_main', stdout, seedname) allocate (cdodq(num_wann, num_wann, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cdodq in wann_main') - allocate (sheet(num_wann, nntot, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating sheet in wann_main') + if (ierr /= 0) call io_error('Error in allocating cdodq in wann_main', stdout, seedname) + allocate (sheet(num_wann, kmesh_info%nntot, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating sheet in wann_main', stdout, seedname) allocate (rave(3, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating rave in wann_main') + if (ierr /= 0) call io_error('Error in allocating rave in wann_main', stdout, seedname) allocate (r2ave(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating r2ave in wann_main') + if (ierr /= 0) call io_error('Error in allocating r2ave in wann_main', stdout, seedname) allocate (rave2(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating rave2 in wann_main') + if (ierr /= 0) call io_error('Error in allocating rave2 in wann_main', stdout, seedname) allocate (rguide(3, num_wann)) - if (ierr /= 0) call io_error('Error in allocating rguide in wann_main') + if (ierr /= 0) call io_error('Error in allocating rguide in wann_main', stdout, seedname) - if (precond) then - call hamiltonian_setup() + if (wann_control%precond) then + call hamiltonian_setup(ham_logical, print_output, ws_region, w90_calculation, ham_k, ham_r, & + real_lattice, wannier_centres_translated, irvec, mp_grid, ndegen, & + num_kpts, num_wann, nrpts, rpt_origin, bands_plot_mode, stdout, & + seedname, transport_mode) allocate (cdodq_r(num_wann, num_wann, nrpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cdodq_r in wann_main') + if (ierr /= 0) call io_error('Error in allocating cdodq_r in wann_main', stdout, seedname) allocate (cdodq_precond(num_wann, num_wann, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cdodq_precond in wann_main') + if (ierr /= 0) call io_error('Error in allocating cdodq_precond in wann_main', stdout, seedname) ! this method of computing the preconditioning is much more efficient, but requires more RAM if (optimisation >= 3) then allocate (k_to_r(num_kpts, nrpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating k_to_r in wann_main') + if (ierr /= 0) call io_error('Error in allocating k_to_r in wann_main', stdout, seedname) do irpt = 1, nrpts do loop_kpt = 1, num_kpts @@ -228,40 +272,40 @@ subroutine wann_main ! sub vars not passed into other subs allocate (cwschur1(num_wann), cwschur2(10*num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cwshur1 in wann_main') + if (ierr /= 0) call io_error('Error in allocating cwshur1 in wann_main', stdout, seedname) allocate (cwschur3(num_wann), cwschur4(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cwshur3 in wann_main') + if (ierr /= 0) call io_error('Error in allocating cwshur3 in wann_main', stdout, seedname) allocate (cdq(num_wann, num_wann, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cdq in wann_main') + if (ierr /= 0) call io_error('Error in allocating cdq in wann_main', stdout, seedname) ! for MPI if (allocated(counts)) deallocate (counts) allocate (counts(0:num_nodes - 1), stat=ierr) if (ierr /= 0) then - call io_error('Error in allocating counts in wann_main') + call io_error('Error in allocating counts in wann_main', stdout, seedname) end if if (allocated(displs)) deallocate (displs) allocate (displs(0:num_nodes - 1), stat=ierr) if (ierr /= 0) then - call io_error('Error in allocating displs in wann_main') + call io_error('Error in allocating displs in wann_main', stdout, seedname) end if - call comms_array_split(num_kpts, counts, displs) - allocate (rnkb_loc(num_wann, nntot, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating rnkb_loc in wann_main') - allocate (ln_tmp_loc(num_wann, nntot, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ln_tmp_loc in wann_main') + call comms_array_split(num_kpts, counts, displs, comm) + allocate (rnkb_loc(num_wann, kmesh_info%nntot, max(1, counts(my_node_id))), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating rnkb_loc in wann_main', stdout, seedname) + allocate (ln_tmp_loc(num_wann, kmesh_info%nntot, max(1, counts(my_node_id))), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating ln_tmp_loc in wann_main', stdout, seedname) allocate (u_matrix_loc(num_wann, num_wann, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating u_matrix_loc in wann_main') - allocate (m_matrix_loc(num_wann, num_wann, nntot, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating m_matrix_loc in wann_main') + if (ierr /= 0) call io_error('Error in allocating u_matrix_loc in wann_main', stdout, seedname) + allocate (m_matrix_loc(num_wann, num_wann, kmesh_info%nntot, max(1, counts(my_node_id))), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating m_matrix_loc in wann_main', stdout, seedname) ! allocate( m_matrix_1b (num_wann, num_wann, num_kpts),stat=ierr ) ! if (ierr/=0) call io_error('Error in allocating m_matrix_1b in wann_main') ! allocate( m_matrix_1b_loc (num_wann, num_wann, max(1,counts(my_node_id))),stat=ierr ) ! if (ierr/=0) call io_error('Error in allocating m_matrix_1b_loc in wann_main') - if (precond) then + if (wann_control%precond) then allocate (cdodq_precond_loc(num_wann, num_wann, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cdodq_precond_loc in wann_main') + if (ierr /= 0) call io_error('Error in allocating cdodq_precond_loc in wann_main', stdout, seedname) end if ! initialize local u and m matrices with global ones do nkp_loc = 1, counts(my_node_id) @@ -271,34 +315,35 @@ subroutine wann_main u_matrix_loc(:, :, nkp_loc) = & u_matrix(:, :, nkp) end do - call comms_scatterv(m_matrix_loc, num_wann*num_wann*nntot*counts(my_node_id), & - m_matrix, num_wann*num_wann*nntot*counts, num_wann*num_wann*nntot*displs) + call comms_scatterv(m_matrix_loc, num_wann*num_wann*kmesh_info%nntot*counts(my_node_id), & + m_matrix, num_wann*num_wann*kmesh_info%nntot*counts, & + num_wann*num_wann*kmesh_info%nntot*displs, stdout, seedname, comm) allocate (cdq_loc(num_wann, num_wann, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cdq_loc in wann_main') + if (ierr /= 0) call io_error('Error in allocating cdq_loc in wann_main', stdout, seedname) allocate (cdodq_loc(num_wann, num_wann, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cdodq_loc in wann_main') + if (ierr /= 0) call io_error('Error in allocating cdodq_loc in wann_main', stdout, seedname) allocate (cdqkeep_loc(num_wann, num_wann, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cdqkeep_loc in wann_main') + if (ierr /= 0) call io_error('Error in allocating cdqkeep_loc in wann_main', stdout, seedname) if (optimisation > 0) then - allocate (m0_loc(num_wann, num_wann, nntot, max(1, counts(my_node_id))), stat=ierr) + allocate (m0_loc(num_wann, num_wann, kmesh_info%nntot, max(1, counts(my_node_id))), stat=ierr) end if - if (ierr /= 0) call io_error('Error in allocating m0_loc in wann_main') + if (ierr /= 0) call io_error('Error in allocating m0_loc in wann_main', stdout, seedname) allocate (u0_loc(num_wann, num_wann, max(1, counts(my_node_id))), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating u0_loc in wann_main') + if (ierr /= 0) call io_error('Error in allocating u0_loc in wann_main', stdout, seedname) allocate (cz(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cz in wann_main') + if (ierr /= 0) call io_error('Error in allocating cz in wann_main', stdout, seedname) allocate (cmtmp(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cmtmp in wann_main') + if (ierr /= 0) call io_error('Error in allocating cmtmp in wann_main', stdout, seedname) allocate (tmp_cdq(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating tmp_cdq in wann_main') + if (ierr /= 0) call io_error('Error in allocating tmp_cdq in wann_main', stdout, seedname) allocate (evals(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating evals in wann_main') + if (ierr /= 0) call io_error('Error in allocating evals in wann_main', stdout, seedname) allocate (cwork(4*num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cwork in wann_main') + if (ierr /= 0) call io_error('Error in allocating cwork in wann_main', stdout, seedname) allocate (rwork(3*num_wann - 2), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating rwork in wann_main') + if (ierr /= 0) call io_error('Error in allocating rwork in wann_main', stdout, seedname) cwschur1 = cmplx_0; cwschur2 = cmplx_0; cwschur3 = cmplx_0; cwschur4 = cmplx_0 cdq = cmplx_0; cz = cmplx_0; cmtmp = cmplx_0; cdqkeep_loc = cmplx_0; cdq_loc = cmplx_0; ! buff=cmplx_0; @@ -306,9 +351,10 @@ subroutine wann_main gcnorm1 = 0.0_dp; gcnorm0 = 0.0_dp ! initialise rguide to projection centres (Cartesians in units of Ang) - if (guiding_centres) then + if (wann_control%guiding_centres%enable) then do n = 1, num_proj - call utility_frac_to_cart(proj_site(:, n), rguide(:, n), real_lattice) + call utility_frac_to_cart(wann_control%guiding_centres%centres(:, n), & + rguide(:, n), real_lattice) enddo ! if(spinors) then ! not needed with new changes to spinor proj 2013 JRY ! do n=1,num_proj @@ -317,11 +363,11 @@ subroutine wann_main ! end if end if - if (on_root) then + if (print_output%iprint > 0) then write (stdout, *) write (stdout, '(1x,a)') '*------------------------------- WANNIERISE ---------------------------------*' write (stdout, '(1x,a)') '+--------------------------------------------------------------------+<-- CONV' - if (lenconfac .eq. 1.0_dp) then + if (print_output%lenconfac .eq. 1.0_dp) then write (stdout, '(1x,a)') '| Iter Delta Spread RMS Gradient Spread (Ang^2) Time |<-- CONV' else write (stdout, '(1x,a)') '| Iter Delta Spread RMS Gradient Spread (Bohr^2) Time |<-- CONV' @@ -331,75 +377,85 @@ subroutine wann_main endif irguide = 0 - if (guiding_centres .and. (num_no_guide_iter .le. 0)) then - call wann_phases(csheet, sheet, rguide, irguide) + if (wann_control%guiding_centres%enable .and. (wann_control%guiding_centres%num_no_guide_iter .le. 0)) then + call wann_phases(csheet, sheet, rguide, irguide, num_wann, kmesh_info, num_kpts, m_matrix, & + .false., counts, displs, m_matrix_loc, rnkb, print_output%timing_level, & + stdout, seedname, print_output%iprint, comm) irguide = 1 endif ! constrained centres part lambda_loc = 0.0_dp - if (selective_loc .and. slwf_constrain) then - lambda_loc = slwf_lambda + if (wann_control%constrain%selective_loc .and. wann_control%constrain%constrain) then + lambda_loc = wann_control%constrain%lambda end if ! calculate initial centers and spread - call wann_omega(csheet, sheet, rave, r2ave, rave2, wann_spread) + call wann_omega(csheet, sheet, rave, r2ave, rave2, wann_spread, num_wann, kmesh_info, & + num_kpts, print_output, wann_control%constrain, & + omega%invariant, counts, displs, ln_tmp_loc, m_matrix_loc, & + lambda_loc, first_pass, stdout, seedname, comm) ! public variables - if (.not. selective_loc) then - omega_total = wann_spread%om_tot - omega_invariant = wann_spread%om_i - omega_tilde = wann_spread%om_d + wann_spread%om_od + if (.not. wann_control%constrain%selective_loc) then + omega%total = wann_spread%om_tot + omega%invariant = wann_spread%om_i + omega%tilde = wann_spread%om_d + wann_spread%om_od else - omega_total = wann_spread%om_tot + omega%total = wann_spread%om_tot ! omega_invariant = wann_spread%om_iod ! omega_tilde = wann_spread%om_d + wann_spread%om_nu end if ! public arrays of Wannier centres and spreads - wannier_centres = rave - wannier_spreads = r2ave - rave2 + wannier_data%centres = rave + wannier_data%spreads = r2ave - rave2 - if (lfixstep) lquad = .false. + if (wann_control%lfixstep) lquad = .false. ncg = 0 iter = 0 old_spread%om_tot = 0.0_dp ! print initial state - if (on_root) then + if (print_output%iprint > 0) then write (stdout, '(1x,a78)') repeat('-', 78) write (stdout, '(1x,a)') 'Initial State' do iw = 1, num_wann - write (stdout, 1000) iw, (rave(ind, iw)*lenconfac, ind=1, 3), & - (r2ave(iw) - rave2(iw))*lenconfac**2 + write (stdout, 1000) iw, (rave(ind, iw)*print_output%lenconfac, ind=1, 3), & + (r2ave(iw) - rave2(iw))*print_output%lenconfac**2 end do - write (stdout, 1001) (sum(rave(ind, :))*lenconfac, ind=1, 3), (sum(r2ave) - sum(rave2))*lenconfac**2 + write (stdout, 1001) (sum(rave(ind, :))*print_output%lenconfac, ind=1, 3), & + (sum(r2ave) - sum(rave2))*print_output%lenconfac**2 write (stdout, *) - if (selective_loc .and. slwf_constrain) then - write (stdout, '(1x,i6,2x,E12.3,2x,F15.10,2x,F18.10,3x,F8.2,2x,a)') & - iter, (wann_spread%om_tot - old_spread%om_tot)*lenconfac**2, sqrt(abs(gcnorm1))*lenconfac, & - wann_spread%om_tot*lenconfac**2, io_wallclocktime(), '<-- CONV' + if (wann_control%constrain%selective_loc .and. wann_control%constrain%constrain) then + write (stdout, '(1x,i6,2x,E12.3,2x,F15.10,2x,F18.10,3x,F8.2,2x,a)') iter, & + (wann_spread%om_tot - old_spread%om_tot)*print_output%lenconfac**2, & + sqrt(abs(gcnorm1))*print_output%lenconfac, & + wann_spread%om_tot*print_output%lenconfac**2, io_wallclocktime(), '<-- CONV' write (stdout, '(7x,a,F15.7,a,F15.7,a,F15.7,a,F15.7,a)') & - 'O_D=', wann_spread%om_d*lenconfac**2, & - ' O_IOD=', (wann_spread%om_iod + wann_spread%om_nu)*lenconfac**2, & - ' O_TOT=', wann_spread%om_tot*lenconfac**2, ' <-- SPRD' + 'O_D=', wann_spread%om_d*print_output%lenconfac**2, & + ' O_IOD=', (wann_spread%om_iod + wann_spread%om_nu)*print_output%lenconfac**2, & + ' O_TOT=', wann_spread%om_tot*print_output%lenconfac**2, ' <-- SPRD' write (stdout, '(1x,a78)') repeat('-', 78) - elseif (selective_loc .and. .not. slwf_constrain) then - write (stdout, '(1x,i6,2x,E12.3,2x,F15.10,2x,F18.10,3x,F8.2,2x,a)') & - iter, (wann_spread%om_tot - old_spread%om_tot)*lenconfac**2, sqrt(abs(gcnorm1))*lenconfac, & - wann_spread%om_tot*lenconfac**2, io_wallclocktime(), '<-- CONV' + elseif (wann_control%constrain%selective_loc .and. .not. wann_control%constrain%constrain) then + write (stdout, '(1x,i6,2x,E12.3,2x,F15.10,2x,F18.10,3x,F8.2,2x,a)') iter, & + (wann_spread%om_tot - old_spread%om_tot)*print_output%lenconfac**2, & + sqrt(abs(gcnorm1))*print_output%lenconfac, & + wann_spread%om_tot*print_output%lenconfac**2, io_wallclocktime(), '<-- CONV' write (stdout, '(7x,a,F15.7,a,F15.7,a,F15.7,a)') & - 'O_D=', wann_spread%om_d*lenconfac**2, & - ' O_IOD=', wann_spread%om_iod*lenconfac**2, & - ' O_TOT=', wann_spread%om_tot*lenconfac**2, ' <-- SPRD' + 'O_D=', wann_spread%om_d*print_output%lenconfac**2, & + ' O_IOD=', wann_spread%om_iod*print_output%lenconfac**2, & + ' O_TOT=', wann_spread%om_tot*print_output%lenconfac**2, ' <-- SPRD' write (stdout, '(1x,a78)') repeat('-', 78) else - write (stdout, '(1x,i6,2x,E12.3,2x,F15.10,2x,F18.10,3x,F8.2,2x,a)') & - iter, (wann_spread%om_tot - old_spread%om_tot)*lenconfac**2, sqrt(abs(gcnorm1))*lenconfac, & - wann_spread%om_tot*lenconfac**2, io_wallclocktime(), '<-- CONV' + write (stdout, '(1x,i6,2x,E12.3,2x,F15.10,2x,F18.10,3x,F8.2,2x,a)') iter, & + (wann_spread%om_tot - old_spread%om_tot)*print_output%lenconfac**2, & + sqrt(abs(gcnorm1))*print_output%lenconfac, & + wann_spread%om_tot*print_output%lenconfac**2, io_wallclocktime(), '<-- CONV' write (stdout, '(8x,a,F15.7,a,F15.7,a,F15.7,a)') & - 'O_D=', wann_spread%om_d*lenconfac**2, ' O_OD=', wann_spread%om_od*lenconfac**2, & - ' O_TOT=', wann_spread%om_tot*lenconfac**2, ' <-- SPRD' + 'O_D=', wann_spread%om_d*print_output%lenconfac**2, ' O_OD=', & + wann_spread%om_od*print_output%lenconfac**2, & + ' O_TOT=', wann_spread%om_tot*print_output%lenconfac**2, ' <-- SPRD' write (stdout, '(1x,a78)') repeat('-', 78) end if endif @@ -407,57 +463,76 @@ subroutine wann_main lconverged = .false.; lfirst = .true.; lrandom = .false. conv_count = 0; noise_count = 0 - if (.not. lfixstep .and. optimisation <= 0) then + if (.not. wann_control%lfixstep .and. optimisation <= 0) then page_unit = io_file_unit() open (unit=page_unit, status='scratch', form='unformatted') endif ! main iteration loop - do iter = 1, num_iter + do iter = 1, wann_control%num_iter lprint = .false. - if ((mod(iter, num_print_cycles) .eq. 0) .or. (iter .eq. 1) & - .or. (iter .eq. num_iter)) lprint = .true. + if ((mod(iter, wann_control%num_print_cycles) .eq. 0) .or. (iter .eq. 1) & + .or. (iter .eq. wann_control%num_iter)) lprint = .true. ldump = .false. - if ((num_dump_cycles .gt. 0) .and. (mod(iter, num_dump_cycles) .eq. 0)) ldump = .true. + if ((wann_control%num_dump_cycles .gt. 0) .and. & + (mod(iter, wann_control%num_dump_cycles) .eq. 0)) ldump = .true. - if (lprint .and. on_root) write (stdout, '(1x,a,i6)') 'Cycle: ', iter + if (lprint .and. print_output%iprint > 0) write (stdout, '(1x,a,i6)') 'Cycle: ', iter - if (guiding_centres .and. (iter .gt. num_no_guide_iter) & - .and. (mod(iter, num_guide_cycles) .eq. 0)) then - call wann_phases(csheet, sheet, rguide, irguide) + if (wann_control%guiding_centres%enable .and. & + (iter .gt. wann_control%guiding_centres%num_no_guide_iter) & + .and. (mod(iter, wann_control%guiding_centres%num_guide_cycles) .eq. 0)) then + call wann_phases(csheet, sheet, rguide, irguide, num_wann, kmesh_info, num_kpts, m_matrix, & + .false., counts, displs, m_matrix_loc, rnkb, print_output%timing_level, & + stdout, seedname, print_output%iprint, comm) irguide = 1 endif ! calculate gradient of omega - if (lsitesymmetry .or. precond) then - call wann_domega(csheet, sheet, rave, cdodq) + if (lsitesymmetry .or. wann_control%precond) then + call wann_domega(csheet, sheet, rave, num_wann, kmesh_info, num_kpts, & + wann_control%constrain, lsitesymmetry, counts, displs, ln_tmp_loc, & + m_matrix_loc, rnkb_loc, cdodq_loc, lambda_loc, print_output%timing_level, & + stdout, seedname, sitesym, comm, print_output%iprint, cdodq) else - call wann_domega(csheet, sheet, rave)!,cdodq) fills only cdodq_loc + call wann_domega(csheet, sheet, rave, num_wann, kmesh_info, num_kpts, & + wann_control%constrain, lsitesymmetry, counts, displs, ln_tmp_loc, & + m_matrix_loc, rnkb_loc, cdodq_loc, lambda_loc, print_output%timing_level, & + stdout, seedname, sitesym, comm, print_output%iprint) endif - if (lprint .and. iprint > 2 .and. on_root) & + if (lprint .and. print_output%iprint > 2) & write (stdout, *) ' LINE --> Iteration :', iter ! calculate search direction (cdq) - call internal_search_direction() - if (lsitesymmetry) call sitesym_symmetrize_gradient(2, cdq) !RS: + if (wann_control%precond) then + call precond_search_direction(cdodq, cdodq_r, cdodq_precond, cdodq_precond_loc, & + k_to_r, wann_spread, num_wann, num_kpts, & + kpt_latt, real_lattice, nrpts, irvec, ndegen, & + counts, displs, optimisation, stdout) + endif + call internal_search_direction(cdodq_precond_loc, cdqkeep_loc, iter, lprint, lrandom, & + noise_count, ncg, gcfac, gcnorm0, gcnorm1, doda0, & + wann_control, num_wann, & + kmesh_info%wbtot, cdq_loc, cdodq_loc, counts, stdout) + if (lsitesymmetry) call sitesym_symmetrize_gradient(sitesym, cdq, 2, num_kpts, num_wann) !RS: ! save search direction cdqkeep_loc(:, :, :) = cdq_loc(:, :, :) ! check whether we're doing fixed step lengths - if (lfixstep) then + if (wann_control%lfixstep) then - alphamin = fixed_step + alphamin = wann_control%fixed_step ! or a parabolic line search else ! take trial step - cdq_loc(:, :, :) = cdqkeep_loc(:, :, :)*(trial_step/(4.0_dp*wbtot)) + cdq_loc(:, :, :) = cdqkeep_loc(:, :, :)*(wann_control%trial_step/(4.0_dp*kmesh_info%wbtot)) ! store original U and M before rotating u0_loc = u_matrix_loc @@ -471,43 +546,54 @@ subroutine wann_main endif ! update U and M - call internal_new_u_and_m() + call internal_new_u_and_m(cdq, cmtmp, tmp_cdq, cwork, rwork, evals, cwschur1, cwschur2, & + cwschur3, cwschur4, cz, num_wann, num_kpts, kmesh_info, & + lsitesymmetry, counts, displs, cdq_loc, u_matrix_loc, & + m_matrix_loc, print_output%timing_level, stdout, sitesym, comm) ! calculate spread at trial step - call wann_omega(csheet, sheet, rave, r2ave, rave2, trial_spread) + call wann_omega(csheet, sheet, rave, r2ave, rave2, trial_spread, num_wann, kmesh_info, & + num_kpts, print_output, wann_control%constrain, & + omega%invariant, counts, displs, ln_tmp_loc, & + m_matrix_loc, lambda_loc, first_pass, stdout, seedname, comm) ! Calculate optimal step (alphamin) - call internal_optimal_step() - + call internal_optimal_step(wann_spread, trial_spread, doda0, alphamin, falphamin, lquad, & + lprint, wann_control%trial_step, stdout) endif ! print line search information - if (lprint .and. iprint > 2 .and. on_root) then - write (stdout, *) ' LINE --> Spread at initial point :', wann_spread%om_tot*lenconfac**2 - if (.not. lfixstep) & - write (stdout, *) ' LINE --> Spread at trial step :', trial_spread%om_tot*lenconfac**2 - write (stdout, *) ' LINE --> Slope along search direction :', doda0*lenconfac**2 - write (stdout, *) ' LINE --> ||SD gradient||^2 :', gcnorm1*lenconfac**2 - if (.not. lfixstep) then - write (stdout, *) ' LINE --> Trial step length :', trial_step + if (lprint .and. print_output%iprint > 2) then + write (stdout, *) ' LINE --> Spread at initial point :', & + wann_spread%om_tot*print_output%lenconfac**2 + if (.not. wann_control%lfixstep) & + write (stdout, *) ' LINE --> Spread at trial step :', & + trial_spread%om_tot*print_output%lenconfac**2 + write (stdout, *) ' LINE --> Slope along search direction :', & + doda0*print_output%lenconfac**2 + write (stdout, *) ' LINE --> ||SD gradient||^2 :', & + gcnorm1*print_output%lenconfac**2 + if (.not. wann_control%lfixstep) then + write (stdout, *) ' LINE --> Trial step length :', wann_control%trial_step if (lquad) then write (stdout, *) ' LINE --> Optimal parabolic step length :', alphamin - write (stdout, *) ' LINE --> Spread at predicted minimum :', falphamin*lenconfac**2 + write (stdout, *) ' LINE --> Spread at predicted minimum :', & + falphamin*print_output%lenconfac**2 endif else - write (stdout, *) ' LINE --> Fixed step length :', fixed_step + write (stdout, *) ' LINE --> Fixed step length :', wann_control%fixed_step endif write (stdout, *) ' LINE --> CG coefficient :', gcfac endif ! if taking a fixed step or if parabolic line search was successful - if (lfixstep .or. lquad) then + if (wann_control%lfixstep .or. lquad) then ! take optimal step - cdq_loc(:, :, :) = cdqkeep_loc(:, :, :)*(alphamin/(4.0_dp*wbtot)) + cdq_loc(:, :, :) = cdqkeep_loc(:, :, :)*(alphamin/(4.0_dp*kmesh_info%wbtot)) ! if doing a line search then restore original U and M before rotating - if (.not. lfixstep) then + if (.not. wann_control%lfixstep) then u_matrix_loc = u0_loc if (optimisation <= 0) then ! read(page_unit) m_matrix @@ -519,12 +605,18 @@ subroutine wann_main endif ! update U and M - call internal_new_u_and_m() + call internal_new_u_and_m(cdq, cmtmp, tmp_cdq, cwork, rwork, evals, cwschur1, cwschur2, & + cwschur3, cwschur4, cz, num_wann, num_kpts, kmesh_info, & + lsitesymmetry, counts, displs, cdq_loc, u_matrix_loc, & + m_matrix_loc, print_output%timing_level, stdout, sitesym, comm) call wann_spread_copy(wann_spread, old_spread) ! calculate the new centers and spread - call wann_omega(csheet, sheet, rave, r2ave, rave2, wann_spread) + call wann_omega(csheet, sheet, rave, r2ave, rave2, wann_spread, num_wann, kmesh_info, & + num_kpts, print_output, wann_control%constrain, & + omega%invariant, counts, displs, ln_tmp_loc, & + m_matrix_loc, lambda_loc, first_pass, stdout, seedname, comm) ! parabolic line search was unsuccessful, use trial step already taken else @@ -535,92 +627,103 @@ subroutine wann_main endif ! print the new centers and spreads - if (lprint .and. on_root) then + if (lprint .and. print_output%iprint > 0) then do iw = 1, num_wann - write (stdout, 1000) iw, (rave(ind, iw)*lenconfac, ind=1, 3), & - (r2ave(iw) - rave2(iw))*lenconfac**2 + write (stdout, 1000) iw, (rave(ind, iw)*print_output%lenconfac, ind=1, 3), & + (r2ave(iw) - rave2(iw))*print_output%lenconfac**2 end do - write (stdout, 1001) (sum(rave(ind, :))*lenconfac, ind=1, 3), & - (sum(r2ave) - sum(rave2))*lenconfac**2 + write (stdout, 1001) (sum(rave(ind, :))*print_output%lenconfac, ind=1, 3), & + (sum(r2ave) - sum(rave2))*print_output%lenconfac**2 write (stdout, *) - if (selective_loc .and. slwf_constrain) then + if (wann_control%constrain%selective_loc .and. wann_control%constrain%constrain) then write (stdout, '(1x,i6,2x,E12.3,2x,F15.10,2x,F18.10,3x,F8.2,2x,a)') & - iter, (wann_spread%om_tot - old_spread%om_tot)*lenconfac**2, & - sqrt(abs(gcnorm1))*lenconfac, & - wann_spread%om_tot*lenconfac**2, io_wallclocktime(), '<-- CONV' + iter, (wann_spread%om_tot - old_spread%om_tot)*print_output%lenconfac**2, & + sqrt(abs(gcnorm1))*print_output%lenconfac, & + wann_spread%om_tot*print_output%lenconfac**2, io_wallclocktime(), '<-- CONV' write (stdout, '(7x,a,F15.7,a,F15.7,a,F15.7,a)') & - 'O_IOD=', (wann_spread%om_iod + wann_spread%om_nu)*lenconfac**2, & - ' O_D=', wann_spread%om_d*lenconfac**2, & - ' O_TOT=', wann_spread%om_tot*lenconfac**2, ' <-- SPRD' + 'O_IOD=', (wann_spread%om_iod + wann_spread%om_nu)*print_output%lenconfac**2, & + ' O_D=', wann_spread%om_d*print_output%lenconfac**2, & + ' O_TOT=', wann_spread%om_tot*print_output%lenconfac**2, ' <-- SPRD' write (stdout, '(a,E15.7,a,E15.7,a,E15.7,a)') & 'Delta: O_IOD=', ((wann_spread%om_iod + wann_spread%om_nu) - & - (old_spread%om_iod + wann_spread%om_nu))*lenconfac**2, & - ' O_D=', (wann_spread%om_d - old_spread%om_d)*lenconfac**2, & - ' O_TOT=', (wann_spread%om_tot - old_spread%om_tot)*lenconfac**2, ' <-- DLTA' + (old_spread%om_iod + wann_spread%om_nu))*print_output%lenconfac**2, & + ' O_D=', (wann_spread%om_d - old_spread%om_d)*print_output%lenconfac**2, & + ' O_TOT=', (wann_spread%om_tot - old_spread%om_tot)*print_output%lenconfac**2, ' <-- DLTA' write (stdout, '(1x,a78)') repeat('-', 78) - elseif (selective_loc .and. .not. slwf_constrain) then + elseif (wann_control%constrain%selective_loc .and. .not. wann_control%constrain%constrain) then write (stdout, '(1x,i6,2x,E12.3,2x,F15.10,2x,F18.10,3x,F8.2,2x,a)') & - iter, (wann_spread%om_tot - old_spread%om_tot)*lenconfac**2, & - sqrt(abs(gcnorm1))*lenconfac, & - wann_spread%om_tot*lenconfac**2, io_wallclocktime(), '<-- CONV' + iter, (wann_spread%om_tot - old_spread%om_tot)*print_output%lenconfac**2, & + sqrt(abs(gcnorm1))*print_output%lenconfac, & + wann_spread%om_tot*print_output%lenconfac**2, io_wallclocktime(), '<-- CONV' write (stdout, '(7x,a,F15.7,a,F15.7,a,F15.7,a)') & - 'O_IOD=', wann_spread%om_iod*lenconfac**2, & - ' O_D=', wann_spread%om_d*lenconfac**2, & - ' O_TOT=', wann_spread%om_tot*lenconfac**2, ' <-- SPRD' + 'O_IOD=', wann_spread%om_iod*print_output%lenconfac**2, & + ' O_D=', wann_spread%om_d*print_output%lenconfac**2, & + ' O_TOT=', wann_spread%om_tot*print_output%lenconfac**2, ' <-- SPRD' write (stdout, '(a,E15.7,a,E15.7,a,E15.7,a)') & - 'Delta: O_IOD=', (wann_spread%om_iod - old_spread%om_iod)*lenconfac**2, & - ' O_D=', (wann_spread%om_d - old_spread%om_d)*lenconfac**2, & - ' O_TOT=', (wann_spread%om_tot - old_spread%om_tot)*lenconfac**2, ' <-- DLTA' + 'Delta: O_IOD=', (wann_spread%om_iod - old_spread%om_iod)*print_output%lenconfac**2, & + ' O_D=', (wann_spread%om_d - old_spread%om_d)*print_output%lenconfac**2, & + ' O_TOT=', (wann_spread%om_tot - old_spread%om_tot)*print_output%lenconfac**2, ' <-- DLTA' write (stdout, '(1x,a78)') repeat('-', 78) else write (stdout, '(1x,i6,2x,E12.3,2x,F15.10,2x,F18.10,3x,F8.2,2x,a)') & - iter, (wann_spread%om_tot - old_spread%om_tot)*lenconfac**2, & - sqrt(abs(gcnorm1))*lenconfac, & - wann_spread%om_tot*lenconfac**2, io_wallclocktime(), '<-- CONV' + iter, (wann_spread%om_tot - old_spread%om_tot)*print_output%lenconfac**2, & + sqrt(abs(gcnorm1))*print_output%lenconfac, & + wann_spread%om_tot*print_output%lenconfac**2, io_wallclocktime(), '<-- CONV' write (stdout, '(8x,a,F15.7,a,F15.7,a,F15.7,a)') & - 'O_D=', wann_spread%om_d*lenconfac**2, & - ' O_OD=', wann_spread%om_od*lenconfac**2, & - ' O_TOT=', wann_spread%om_tot*lenconfac**2, ' <-- SPRD' + 'O_D=', wann_spread%om_d*print_output%lenconfac**2, & + ' O_OD=', wann_spread%om_od*print_output%lenconfac**2, & + ' O_TOT=', wann_spread%om_tot*print_output%lenconfac**2, ' <-- SPRD' write (stdout, '(1x,a,E15.7,a,E15.7,a,E15.7,a)') & - 'Delta: O_D=', (wann_spread%om_d - old_spread%om_d)*lenconfac**2, & - ' O_OD=', (wann_spread%om_od - old_spread%om_od)*lenconfac**2, & - ' O_TOT=', (wann_spread%om_tot - old_spread%om_tot)*lenconfac**2, ' <-- DLTA' + 'Delta: O_D=', (wann_spread%om_d - old_spread%om_d)*print_output%lenconfac**2, & + ' O_OD=', (wann_spread%om_od - old_spread%om_od)*print_output%lenconfac**2, & + ' O_TOT=', (wann_spread%om_tot - old_spread%om_tot)*print_output%lenconfac**2, ' <-- DLTA' write (stdout, '(1x,a78)') repeat('-', 78) end if end if ! Public array of Wannier centres and spreads - wannier_centres = rave - wannier_spreads = r2ave - rave2 + wannier_data%centres = rave + wannier_data%spreads = r2ave - rave2 ! Public variables - if (.not. selective_loc) then - omega_total = wann_spread%om_tot - omega_tilde = wann_spread%om_d + wann_spread%om_od + if (.not. wann_control%constrain%selective_loc) then + omega%total = wann_spread%om_tot + omega%tilde = wann_spread%om_d + wann_spread%om_od else - omega_total = wann_spread%om_tot + omega%total = wann_spread%om_tot !omega_tilde = wann_spread%om_d + wann_spread%om_nu end if if (ldump) then - ! Before calling param_write_chkpt, I need to gather on the root node + ! Before calling w90_wannier90_readwrite_write_chkpt, I need to gather on the root node ! the u_matrix from the u_matrix_loc. No need to broadcast it since ! it's printed by the root node only call comms_gatherv(u_matrix_loc, num_wann*num_wann*counts(my_node_id), & - u_matrix, num_wann*num_wann*counts, num_wann*num_wann*displs) + u_matrix, num_wann*num_wann*counts, num_wann*num_wann*displs, stdout, & + seedname, comm) ! I also transfer the M matrix - call comms_gatherv(m_matrix_loc, num_wann*num_wann*nntot*counts(my_node_id), & - m_matrix, num_wann*num_wann*nntot*counts, num_wann*num_wann*nntot*displs) - if (on_root) call param_write_chkpt('postdis') + call comms_gatherv(m_matrix_loc, num_wann*num_wann*kmesh_info%nntot*counts(my_node_id), & + m_matrix, num_wann*num_wann*kmesh_info%nntot*counts, & + num_wann*num_wann*kmesh_info%nntot*displs, stdout, seedname, comm) + if (on_root) call w90_wannier90_readwrite_write_chkpt('postdis', exclude_bands, wannier_data, kmesh_info, & + kpt_latt, num_kpts, dis_manifold, num_bands, num_wann, & + u_matrix, u_matrix_opt, m_matrix, mp_grid, & + real_lattice, omega%invariant, have_disentangled, & + stdout, seedname) endif - if (conv_window .gt. 1) call internal_test_convergence() + if (wann_control%conv_window .gt. 1) then + call internal_test_convergence(old_spread, wann_spread, history, save_spread, iter, & + conv_count, noise_count, lconverged, lrandom, lfirst, & + wann_control, stdout) + endif if (lconverged) then - write (stdout, '(/13x,a,es10.3,a,i2,a)') & - '<<< Delta <', conv_tol, & - ' over ', conv_window, ' iterations >>>' - write (stdout, '(13x,a/)') '<<< Wannierisation convergence criteria satisfied >>>' + if (print_output%iprint > 0) then + write (stdout, '(/13x,a,es10.3,a,i2,a)') '<<< Delta <', wann_control%conv_tol, & + ' over ', wann_control%conv_window, ' iterations >>>' + write (stdout, '(13x,a/)') '<<< Wannierisation convergence criteria satisfied >>>' + endif exit endif @@ -636,74 +739,86 @@ subroutine wann_main ! call comms_bcast(m_matrix_1b(1,1,1),num_wann*num_wann*num_kpts) ! m_matrix(:,:,nn,:)=m_matrix_1b(:,:,:) ! end do!nn - call comms_gatherv(m_matrix_loc, num_wann*num_wann*nntot*counts(my_node_id), & - m_matrix, num_wann*num_wann*nntot*counts, num_wann*num_wann*nntot*displs) + call comms_gatherv(m_matrix_loc, num_wann*num_wann*kmesh_info%nntot*counts(my_node_id), & + m_matrix, num_wann*num_wann*kmesh_info%nntot*counts, & + num_wann*num_wann*kmesh_info%nntot*displs, stdout, seedname, comm) ! send u matrix call comms_gatherv(u_matrix_loc, num_wann*num_wann*counts(my_node_id), & - u_matrix, num_wann*num_wann*counts, num_wann*num_wann*displs) - call comms_bcast(u_matrix(1, 1, 1), num_wann*num_wann*num_kpts) + u_matrix, num_wann*num_wann*counts, num_wann*num_wann*displs, stdout, & + seedname, comm) + call comms_bcast(u_matrix(1, 1, 1), num_wann*num_wann*num_kpts, stdout, seedname, comm) ! Evaluate the penalty functional - if (selective_loc .and. slwf_constrain) then + if (wann_control%constrain%selective_loc .and. wann_control%constrain%constrain) then rnr0n2 = 0.0_dp - do iw = 1, slwf_num - rnr0n2(iw) = (wannier_centres(1, iw) - ccentres_cart(iw, 1))**2 & - + (wannier_centres(2, iw) - ccentres_cart(iw, 2))**2 & - + (wannier_centres(3, iw) - ccentres_cart(iw, 3))**2 + do iw = 1, wann_control%constrain%slwf_num + rnr0n2(iw) = (wannier_data%centres(1, iw) - wann_control%constrain%centres(iw, 1))**2 & + + (wannier_data%centres(2, iw) - wann_control%constrain%centres(iw, 2))**2 & + + (wannier_data%centres(3, iw) - wann_control%constrain%centres(iw, 3))**2 end do end if - if (on_root) then + if (print_output%iprint > 0) then write (stdout, '(1x,a)') 'Final State' do iw = 1, num_wann - write (stdout, 1000) iw, (rave(ind, iw)*lenconfac, ind=1, 3), & - (r2ave(iw) - rave2(iw))*lenconfac**2 + write (stdout, 1000) iw, (rave(ind, iw)*print_output%lenconfac, ind=1, 3), & + (r2ave(iw) - rave2(iw))*print_output%lenconfac**2 end do - write (stdout, 1001) (sum(rave(ind, :))*lenconfac, ind=1, 3), & - (sum(r2ave) - sum(rave2))*lenconfac**2 + write (stdout, 1001) (sum(rave(ind, :))*print_output%lenconfac, ind=1, 3), & + (sum(r2ave) - sum(rave2))*print_output%lenconfac**2 write (stdout, *) - if (selective_loc .and. slwf_constrain) then - write (stdout, '(3x,a21,a,f15.9)') ' Spreads ('//trim(length_unit)//'^2)', & - ' Omega IOD_C = ', (wann_spread%om_iod + wann_spread%om_nu)*lenconfac**2 + if (wann_control%constrain%selective_loc .and. wann_control%constrain%constrain) then + write (stdout, '(3x,a21,a,f15.9)') ' Spreads ('//trim(print_output%length_unit)//'^2)', & + ' Omega IOD_C = ', (wann_spread%om_iod + wann_spread%om_nu)*print_output%lenconfac**2 write (stdout, '(3x,a,f15.9)') ' ================ Omega D = ', & - wann_spread%om_d*lenconfac**2 + wann_spread%om_d*print_output%lenconfac**2 write (stdout, '(3x,a,f15.9)') ' Omega Rest = ', & - (sum(r2ave) - sum(rave2) + wann_spread%om_tot)*lenconfac**2 + (sum(r2ave) - sum(rave2) + wann_spread%om_tot)*print_output%lenconfac**2 write (stdout, '(3x,a,f15.9)') ' Penalty func = ', & sum(rnr0n2(:)) - write (stdout, '(3x,a21,a,f15.9)') 'Final Spread ('//trim(length_unit)//'^2)', & - ' Omega Total_C = ', wann_spread%om_tot*lenconfac**2 + write (stdout, '(3x,a21,a,f15.9)') 'Final Spread ('//trim(print_output%length_unit)//'^2)', & + ' Omega Total_C = ', wann_spread%om_tot*print_output%lenconfac**2 write (stdout, '(1x,a78)') repeat('-', 78) - else if (selective_loc .and. .not. slwf_constrain) then - write (stdout, '(3x,a21,a,f15.9)') ' Spreads ('//trim(length_unit)//'^2)', & - ' Omega IOD = ', wann_spread%om_iod*lenconfac**2 + else if (wann_control%constrain%selective_loc .and. .not. wann_control%constrain%constrain) then + write (stdout, '(3x,a21,a,f15.9)') ' Spreads ('//trim(print_output%length_unit)//'^2)', & + ' Omega IOD = ', wann_spread%om_iod*print_output%lenconfac**2 write (stdout, '(3x,a,f15.9)') ' ================ Omega D = ', & - wann_spread%om_d*lenconfac**2 + wann_spread%om_d*print_output%lenconfac**2 write (stdout, '(3x,a,f15.9)') ' Omega Rest = ', & - (sum(r2ave) - sum(rave2) + wann_spread%om_tot)*lenconfac**2 - write (stdout, '(3x,a21,a,f15.9)') 'Final Spread ('//trim(length_unit)//'^2)', & - ' Omega Total = ', wann_spread%om_tot*lenconfac**2 + (sum(r2ave) - sum(rave2) + wann_spread%om_tot)*print_output%lenconfac**2 + write (stdout, '(3x,a21,a,f15.9)') 'Final Spread ('//trim(print_output%length_unit)//'^2)', & + ' Omega Total = ', wann_spread%om_tot*print_output%lenconfac**2 write (stdout, '(1x,a78)') repeat('-', 78) else - write (stdout, '(3x,a21,a,f15.9)') ' Spreads ('//trim(length_unit)//'^2)', & - ' Omega I = ', wann_spread%om_i*lenconfac**2 + write (stdout, '(3x,a21,a,f15.9)') ' Spreads ('//trim(print_output%length_unit)//'^2)', & + ' Omega I = ', wann_spread%om_i*print_output%lenconfac**2 write (stdout, '(3x,a,f15.9)') ' ================ Omega D = ', & - wann_spread%om_d*lenconfac**2 + wann_spread%om_d*print_output%lenconfac**2 write (stdout, '(3x,a,f15.9)') ' Omega OD = ', & - wann_spread%om_od*lenconfac**2 - write (stdout, '(3x,a21,a,f15.9)') 'Final Spread ('//trim(length_unit)//'^2)', & - ' Omega Total = ', wann_spread%om_tot*lenconfac**2 + wann_spread%om_od*print_output%lenconfac**2 + write (stdout, '(3x,a21,a,f15.9)') 'Final Spread ('//trim(print_output%length_unit)//'^2)', & + ' Omega Total = ', wann_spread%om_tot*print_output%lenconfac**2 write (stdout, '(1x,a78)') repeat('-', 78) end if endif - if (write_xyz .and. on_root) call wann_write_xyz() + if (output_file%write_xyz .and. on_root) then + call wann_write_xyz(real_space_ham%translate_home_cell, num_wann, wannier_data%centres, & + real_lattice, atom_data, print_output, stdout, seedname) + endif - if (write_hr_diag) then - call hamiltonian_setup() - call hamiltonian_get_hr() - if (on_root) then + if (output_file%write_hr_diag) then + call hamiltonian_setup(ham_logical, print_output, ws_region, w90_calculation, ham_k, ham_r, & + real_lattice, wannier_centres_translated, irvec, mp_grid, ndegen, & + num_kpts, num_wann, nrpts, rpt_origin, bands_plot_mode, stdout, & + seedname, transport_mode) + call hamiltonian_get_hr(atom_data, dis_manifold, ham_logical, real_space_ham, print_output, & + ham_k, ham_r, u_matrix, u_matrix_opt, eigval, kpt_latt, & + real_lattice, wannier_data%centres, wannier_centres_translated, & + irvec, shift_vec, nrpts, num_bands, num_kpts, num_wann, & + have_disentangled, stdout, seedname, lsitesymmetry) + if (print_output%iprint > 0) then write (stdout, *) write (stdout, '(1x,a)') 'On-site Hamiltonian matrix elements' write (stdout, '(3x,a)') ' n <0n|H|0n> (eV)' @@ -715,118 +830,132 @@ subroutine wann_main endif endif - if (guiding_centres) call wann_phases(csheet, sheet, rguide, irguide) + if (wann_control%guiding_centres%enable) then + call wann_phases(csheet, sheet, rguide, irguide, num_wann, kmesh_info, num_kpts, m_matrix, & + .false., counts, displs, m_matrix_loc, rnkb, print_output%timing_level, & + stdout, seedname, print_output%iprint, comm) + endif ! unitarity is checked !~ call internal_check_unitarity() - call wann_check_unitarity() + call wann_check_unitarity(num_kpts, num_wann, u_matrix, print_output%timing_level, & + print_output%iprint, stdout, seedname) ! write extra info regarding omega_invariant !~ if (iprint>2) call internal_svd_omega_i() ! if (iprint>2) call wann_svd_omega_i() - if (iprint > 2 .and. on_root) call wann_svd_omega_i() + if (print_output%iprint > 2 .and. on_root) then + call wann_svd_omega_i(num_wann, num_kpts, kmesh_info, m_matrix, print_output, stdout, seedname) + endif ! write matrix elements to file !~ if (write_r2mn) call internal_write_r2mn() ! if (write_r2mn) call wann_write_r2mn() - if (write_r2mn .and. on_root) call wann_write_r2mn() + if (output_file%write_r2mn .and. on_root) call wann_write_r2mn(num_kpts, num_wann, kmesh_info, & + m_matrix, stdout, seedname) ! calculate and write projection of WFs on original bands in outer window - if (have_disentangled .and. write_proj) call wann_calc_projection() + if (have_disentangled .and. output_file%write_proj) & + call wann_calc_projection(num_bands, num_wann, num_kpts, u_matrix_opt, eigval, & + dis_manifold%lwindow, print_output%timing_level, & + print_output%iprint, stdout, seedname) ! aam: write data required for vdW utility - if (write_vdw_data .and. on_root) call wann_write_vdw_data() + if (output_file%write_vdw_data .and. on_root) then + call wann_write_vdw_data(num_wann, wannier_data, real_lattice, u_matrix, & + u_matrix_opt, have_disentangled, w90_system, stdout, seedname) + endif ! deallocate sub vars not passed into other subs deallocate (rwork, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating rwork in wann_main') + if (ierr /= 0) call io_error('Error in deallocating rwork in wann_main', stdout, seedname) deallocate (cwork, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cwork in wann_main') + if (ierr /= 0) call io_error('Error in deallocating cwork in wann_main', stdout, seedname) deallocate (evals, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating evals in wann_main') + if (ierr /= 0) call io_error('Error in deallocating evals in wann_main', stdout, seedname) deallocate (tmp_cdq, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating tmp_cdq in wann_main') + if (ierr /= 0) call io_error('Error in deallocating tmp_cdq in wann_main', stdout, seedname) deallocate (cmtmp, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cmtmp in wann_main') + if (ierr /= 0) call io_error('Error in deallocating cmtmp in wann_main', stdout, seedname) deallocate (cz, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cz in wann_main') + if (ierr /= 0) call io_error('Error in deallocating cz in wann_main', stdout, seedname) deallocate (cdq, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cdq in wann_main') + if (ierr /= 0) call io_error('Error in deallocating cdq in wann_main', stdout, seedname) ! for MPI deallocate (ln_tmp_loc, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating ln_tmp_loc in wann_main') + if (ierr /= 0) call io_error('Error in deallocating ln_tmp_loc in wann_main', stdout, seedname) deallocate (rnkb_loc, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating rnkb_loc in wann_main') + if (ierr /= 0) call io_error('Error in deallocating rnkb_loc in wann_main', stdout, seedname) deallocate (u_matrix_loc, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating u_matrix_loc in wann_main') + if (ierr /= 0) call io_error('Error in deallocating u_matrix_loc in wann_main', stdout, seedname) deallocate (m_matrix_loc, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating m_matrix_loc in wann_main') + if (ierr /= 0) call io_error('Error in deallocating m_matrix_loc in wann_main', stdout, seedname) ! deallocate(m_matrix_1b,stat=ierr) ! if (ierr/=0) call io_error('Error in deallocating m_matrix_1b in wann_main') ! deallocate(m_matrix_1b_loc,stat=ierr) ! if (ierr/=0) call io_error('Error in deallocating m_matrix_1b_loc in wann_main') deallocate (cdq_loc, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cdq_loc in wann_main') + if (ierr /= 0) call io_error('Error in deallocating cdq_loc in wann_main', stdout, seedname) deallocate (cdodq_loc, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cdodq_loc in wann_main') + if (ierr /= 0) call io_error('Error in deallocating cdodq_loc in wann_main', stdout, seedname) deallocate (cdqkeep_loc, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cdqkeep_loc in wann_main') + if (ierr /= 0) call io_error('Error in deallocating cdqkeep_loc in wann_main', stdout, seedname) deallocate (cwschur3, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cwschur3 in wann_main') + if (ierr /= 0) call io_error('Error in deallocating cwschur3 in wann_main', stdout, seedname) deallocate (cwschur1, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cwschur1 in wann_main') - if (precond) then + if (ierr /= 0) call io_error('Error in deallocating cwschur1 in wann_main', stdout, seedname) + if (wann_control%precond) then if (optimisation >= 3) then deallocate (k_to_r, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating k_to_r in wann_main') + if (ierr /= 0) call io_error('Error in deallocating k_to_r in wann_main', stdout, seedname) end if deallocate (cdodq_r, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cdodq_r in wann_main') + if (ierr /= 0) call io_error('Error in deallocating cdodq_r in wann_main', stdout, seedname) deallocate (cdodq_precond, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cdodq_precond in wann_main') + if (ierr /= 0) call io_error('Error in deallocating cdodq_precond in wann_main', stdout, seedname) deallocate (cdodq_precond_loc, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cdodq_precond_loc in wann_main') + if (ierr /= 0) call io_error('Error in deallocating cdodq_precond_loc in wann_main', stdout, seedname) end if ! deallocate sub vars passed into other subs deallocate (rguide, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating rguide in wann_main') + if (ierr /= 0) call io_error('Error in deallocating rguide in wann_main', stdout, seedname) deallocate (rave2, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating rave2 in wann_main') + if (ierr /= 0) call io_error('Error in deallocating rave2 in wann_main', stdout, seedname) deallocate (rave, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating rave in wann_main') + if (ierr /= 0) call io_error('Error in deallocating rave in wann_main', stdout, seedname) deallocate (sheet, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating sheet in wann_main') + if (ierr /= 0) call io_error('Error in deallocating sheet in wann_main', stdout, seedname) deallocate (cdodq, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cdodq in wann_main') + if (ierr /= 0) call io_error('Error in deallocating cdodq in wann_main', stdout, seedname) deallocate (csheet, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating csheet in wann_main') - if (selective_loc) then + if (ierr /= 0) call io_error('Error in deallocating csheet in wann_main', stdout, seedname) + if (wann_control%constrain%selective_loc) then deallocate (rnr0n2, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating rnr0n2 in wann_main') + if (ierr /= 0) call io_error('Error in deallocating rnr0n2 in wann_main', stdout, seedname) end if ! deallocate module data deallocate (ln_tmp, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating ln_tmp in wann_main') + if (ierr /= 0) call io_error('Error in deallocating ln_tmp in wann_main', stdout, seedname) deallocate (rnkb, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating rnkb in wann_main') + if (ierr /= 0) call io_error('Error in deallocating rnkb in wann_main', stdout, seedname) deallocate (u0_loc, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating u0_loc in wann_main') + if (ierr /= 0) call io_error('Error in deallocating u0_loc in wann_main', stdout, seedname) if (optimisation > 0) then deallocate (m0_loc, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating m0_loc in wann_main') + if (ierr /= 0) call io_error('Error in deallocating m0_loc in wann_main', stdout, seedname) end if if (allocated(counts)) deallocate (counts) if (allocated(displs)) deallocate (displs) deallocate (history, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating history in wann_main') + if (ierr /= 0) call io_error('Error deallocating history in wann_main', stdout, seedname) - if (timing_level > 0 .and. on_root) call io_stopwatch('wann: main', 2) + if (print_output%timing_level > 0 .and. print_output%iprint > 0) call io_stopwatch('wann: main', 2, stdout, seedname) return @@ -838,27 +967,48 @@ subroutine wann_main contains - !===============================================! - subroutine internal_test_convergence() - !===============================================! - ! ! + !================================================! + subroutine internal_test_convergence(old_spread, wann_spread, history, save_spread, iter, & + conv_count, noise_count, lconverged, lrandom, lfirst, & + wann_control, stdout) + !================================================! + ! !! Determine whether minimisation of non-gauge !! invariant spread is converged - ! ! - !===============================================! + ! + !================================================! + + use w90_io, only: io_error + use w90_wannier90_types, only: wann_control_type implicit none + type(wann_control_type), intent(in) :: wann_control + + type(localisation_vars_type), intent(in) :: old_spread + type(localisation_vars_type), intent(in) :: wann_spread + real(kind=dp), intent(inout) :: history(:) + real(kind=dp), intent(out) :: save_spread + integer, intent(in) :: iter + integer, intent(inout) :: conv_count + integer, intent(inout) :: noise_count + logical, intent(inout) :: lconverged, lrandom, lfirst +! integer, intent(in) :: conv_window +! real(kind=dp), intent(in) :: conv_tol +! real(kind=dp), intent(in) :: conv_noise_amp +! integer, intent(in) :: conv_noise_num + integer, intent(in) ::stdout + ! local real(kind=dp) :: delta_omega integer :: j, ierr real(kind=dp), allocatable :: temp_hist(:) - allocate (temp_hist(conv_window), stat=ierr) - if (ierr /= 0) call io_error('Error allocating temp_hist in wann_main') + allocate (temp_hist(wann_control%conv_window), stat=ierr) + if (ierr /= 0) call io_error('Error allocating temp_hist in wann_main', stdout, seedname) delta_omega = wann_spread%om_tot - old_spread%om_tot - if (iter .le. conv_window) then + if (iter .le. wann_control%conv_window) then history(iter) = delta_omega else temp_hist = eoshift(history, 1, delta_omega) @@ -867,23 +1017,24 @@ subroutine internal_test_convergence() conv_count = conv_count + 1 - if (conv_count .lt. conv_window) then + if (conv_count .lt. wann_control%conv_window) then return else !~ write(stdout,*) (history(j),j=1,conv_window) - do j = 1, conv_window - if (abs(history(j)) .gt. conv_tol) return + do j = 1, wann_control%conv_window + if (abs(history(j)) .gt. wann_control%conv_tol) return enddo endif - if ((conv_noise_amp .gt. 0.0_dp) .and. (noise_count .lt. conv_noise_num)) then + if ((wann_control%conv_noise_amp .gt. 0.0_dp) .and. & + (noise_count .lt. wann_control%conv_noise_num)) then if (lfirst) then lfirst = .false. save_spread = wann_spread%om_tot lrandom = .true. conv_count = 0 else - if (abs(save_spread - wann_spread%om_tot) .lt. conv_tol) then + if (abs(save_spread - wann_spread%om_tot) .lt. wann_control%conv_tol) then lconverged = .true. return else @@ -899,34 +1050,43 @@ subroutine internal_test_convergence() if (lrandom) noise_count = noise_count + 1 deallocate (temp_hist, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating temp_hist in wann_main') + if (ierr /= 0) call io_error('Error deallocating temp_hist in wann_main', stdout, seedname) return end subroutine internal_test_convergence - !===============================================! - subroutine internal_random_noise() - !===============================================! - ! ! + !================================================! + subroutine internal_random_noise(conv_noise_amp, num_wann, counts, cdq_loc, stdout) + !================================================! + ! !! Add some random noise to the search direction !! to help escape from local minima - ! ! - !===============================================! + ! + !================================================! - implicit none + use w90_constants, only: cmplx_0 + use w90_io, only: io_error + use w90_comms, only: w90comm_type - integer :: ikp, iw, jw + implicit none + real(kind=dp), intent(in) :: conv_noise_amp + integer, intent(in) :: num_wann + complex(kind=dp), intent(inout) :: cdq_loc(:, :, :) + integer, intent(in) :: counts(0:) + integer, intent(in) :: stdout + ! local + integer :: ikp, iw, jw, ierr real(kind=dp), allocatable :: noise_real(:, :), noise_imag(:, :) complex(kind=dp), allocatable :: cnoise(:, :) ! Allocate allocate (noise_real(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating noise_real in wann_main') + if (ierr /= 0) call io_error('Error allocating noise_real in wann_main', stdout, seedname) allocate (noise_imag(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating noise_imag in wann_main') + if (ierr /= 0) call io_error('Error allocating noise_imag in wann_main', stdout, seedname) allocate (cnoise(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error allocating cnoise in wann_main') + if (ierr /= 0) call io_error('Error allocating cnoise in wann_main', stdout, seedname) ! Initialise cnoise = cmplx_0; noise_real = 0.0_dp; noise_imag = 0.0_dp @@ -957,109 +1117,199 @@ subroutine internal_random_noise() ! Deallocate deallocate (cnoise, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating cnoise in wann_main') + if (ierr /= 0) call io_error('Error deallocating cnoise in wann_main', stdout, seedname) deallocate (noise_imag, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating noise_imag in wann_main') + if (ierr /= 0) call io_error('Error deallocating noise_imag in wann_main', stdout, seedname) deallocate (noise_real, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating noise_real in wann_main') + if (ierr /= 0) call io_error('Error deallocating noise_real in wann_main', stdout, seedname) return end subroutine internal_random_noise - !===============================================! - subroutine internal_search_direction() - !===============================================! - ! ! + !================================================! + subroutine precond_search_direction(cdodq, cdodq_r, cdodq_precond, cdodq_precond_loc, & + k_to_r, wann_spread, num_wann, num_kpts, & + kpt_latt, real_lattice, nrpts, irvec, ndegen, & + counts, displs, optimisation, stdout) + !================================================! + ! !! Calculate the conjugate gradients search !! direction using the Fletcher-Reeves formula: !! !! cg_coeff = [g(i).g(i)]/[g(i-1).g(i-1)] - ! ! - !===============================================! + ! + !================================================! - implicit none + use w90_constants, only: cmplx_0, cmplx_1, cmplx_i, twopi + use w90_io, only: io_stopwatch - complex(kind=dp) :: zdotc + implicit none - if (timing_level > 1 .and. on_root) call io_stopwatch('wann: main: search_direction', 1) + complex(kind=dp), intent(in) :: cdodq(:, :, :) + complex(kind=dp), intent(inout) :: cdodq_r(:, :, :) + complex(kind=dp), intent(inout) :: cdodq_precond(:, :, :) + complex(kind=dp), intent(inout) :: cdodq_precond_loc(:, :, :) + !complex(kind=dp), intent(inout) :: cdqkeep_loc(:, :, :) + ! k_to_r depends on optimisation flag + complex(kind=dp), allocatable, intent(in) :: k_to_r(:, :) + type(localisation_vars_type), intent(in) :: wann_spread + !integer, intent(in) :: iter + !logical, intent(in) :: lprint + !logical, intent(inout) :: lrandom + integer, intent(in) :: num_wann, num_kpts + real(kind=dp), intent(in) :: kpt_latt(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + integer, intent(in) :: nrpts + integer, intent(in) :: irvec(:, :) + integer, intent(in) :: ndegen(:) + integer, intent(in) :: counts(0:) + integer, intent(in) :: displs(0:) + integer, intent(in) :: optimisation + integer, intent(in) :: stdout + !type(w90comm_type), intent(in) :: comm + + ! local + complex(kind=dp), external :: zdotc + complex(kind=dp) :: fac, rdotk + real(kind=dp) :: rvec_cart(3) + real(kind=dp) :: alpha_precond + integer :: irpt, loop_kpt + + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('wann: main: search_direction', 1, stdout, seedname) ! gcnorm1 = Tr[gradient . gradient] -- NB gradient is anti-Hermitian ! gcnorm1 = real(zdotc(num_kpts*num_wann*num_wann,cdodq,1,cdodq,1),dp) - if (precond) then - ! compute cdodq_precond + !if (wann_control%precond) then + ! compute cdodq_precond - cdodq_r(:, :, :) = 0 ! intermediary gradient in R space - cdodq_precond(:, :, :) = 0 - cdodq_precond_loc(:, :, :) = 0 + cdodq_r(:, :, :) = 0 ! intermediary gradient in R space + cdodq_precond(:, :, :) = 0 + cdodq_precond_loc(:, :, :) = 0 ! cdodq_precond(:,:,:) = complx_0 - ! convert to real space in cdodq_r - ! Two algorithms: either double loop or GEMM. GEMM is much more efficient but requires more RAM - ! Ideally, we should implement FFT-based filtering here - if (optimisation >= 3) then - call zgemm('N', 'N', num_wann*num_wann, nrpts, num_kpts, cmplx_1, & - & cdodq, num_wann*num_wann, k_to_r, num_kpts, cmplx_0, cdodq_r, num_wann*num_wann) - cdodq_r = cdodq_r/real(num_kpts, dp) - else - do irpt = 1, nrpts - do loop_kpt = 1, num_kpts - rdotk = twopi*dot_product(kpt_latt(:, loop_kpt), real(irvec(:, irpt), dp)) - fac = exp(-cmplx_i*rdotk)/real(num_kpts, dp) - cdodq_r(:, :, irpt) = cdodq_r(:, :, irpt) + fac*cdodq(:, :, loop_kpt) - enddo + ! convert to real space in cdodq_r + ! Two algorithms: either double loop or GEMM. GEMM is much more efficient but requires more RAM + ! Ideally, we should implement FFT-based filtering here + if (optimisation >= 3) then + call zgemm('N', 'N', num_wann*num_wann, nrpts, num_kpts, cmplx_1, cdodq, & + num_wann*num_wann, k_to_r, num_kpts, cmplx_0, cdodq_r, num_wann*num_wann) + cdodq_r = cdodq_r/real(num_kpts, dp) + else + do irpt = 1, nrpts + do loop_kpt = 1, num_kpts + rdotk = twopi*dot_product(kpt_latt(:, loop_kpt), real(irvec(:, irpt), dp)) + fac = exp(-cmplx_i*rdotk)/real(num_kpts, dp) + cdodq_r(:, :, irpt) = cdodq_r(:, :, irpt) + fac*cdodq(:, :, loop_kpt) enddo - end if + enddo + end if + + ! filter cdodq_r in real space by 1/(1+R^2/alpha) + + ! this alpha coefficient is more or less arbitrary, and could + ! be tweaked further: the point is to have something that has + ! the right units, and is not too small (or the filtering is + ! too severe) or too high (or the filtering does nothing). + ! + ! the descent direction produced has a different magnitude + ! than the one without preconditionner, so the values of + ! trial_step are not consistent + alpha_precond = 10*wann_spread%om_tot/num_wann + do irpt = 1, nrpts + rvec_cart = matmul(real_lattice(:, :), real(irvec(:, irpt), dp)) + cdodq_r(:, :, irpt) = cdodq_r(:, :, irpt)*1/(1 + dot_product(rvec_cart, rvec_cart)/ & + alpha_precond) + end do - ! filter cdodq_r in real space by 1/(1+R^2/alpha) - - ! this alpha coefficient is more or less arbitrary, and could - ! be tweaked further: the point is to have something that has - ! the right units, and is not too small (or the filtering is - ! too severe) or too high (or the filtering does nothing). - ! - ! the descent direction produced has a different magnitude - ! than the one without preconditionner, so the values of - ! trial_step are not consistent - alpha_precond = 10*wann_spread%om_tot/num_wann + ! go back to k space + if (optimisation >= 3) then do irpt = 1, nrpts - rvec_cart = matmul(real_lattice(:, :), real(irvec(:, irpt), dp)) - cdodq_r(:, :, irpt) = cdodq_r(:, :, irpt)*1/(1 + dot_product(rvec_cart, rvec_cart)/alpha_precond) + cdodq_r(:, :, irpt) = cdodq_r(:, :, irpt)/real(ndegen(irpt), dp) end do - - ! go back to k space - if (optimisation >= 3) then - do irpt = 1, nrpts - cdodq_r(:, :, irpt) = cdodq_r(:, :, irpt)/real(ndegen(irpt), dp) - end do - call zgemm('N', 'C', num_wann*num_wann, num_kpts, nrpts, cmplx_1, & - & cdodq_r, num_wann*num_wann, k_to_r, num_kpts, cmplx_0, cdodq_precond, num_wann*num_wann) - else - do irpt = 1, nrpts - do loop_kpt = 1, num_kpts - rdotk = twopi*dot_product(kpt_latt(:, loop_kpt), real(irvec(:, irpt), dp)) - fac = exp(cmplx_i*rdotk)/real(ndegen(irpt), dp) - cdodq_precond(:, :, loop_kpt) = cdodq_precond(:, :, loop_kpt) + fac*cdodq_r(:, :, irpt) - enddo + call zgemm('N', 'C', num_wann*num_wann, num_kpts, nrpts, cmplx_1, & + & cdodq_r, num_wann*num_wann, k_to_r, num_kpts, cmplx_0, cdodq_precond, & + num_wann*num_wann) + else + do irpt = 1, nrpts + do loop_kpt = 1, num_kpts + rdotk = twopi*dot_product(kpt_latt(:, loop_kpt), real(irvec(:, irpt), dp)) + fac = exp(cmplx_i*rdotk)/real(ndegen(irpt), dp) + cdodq_precond(:, :, loop_kpt) = cdodq_precond(:, :, loop_kpt) + & + fac*cdodq_r(:, :, irpt) enddo - end if - cdodq_precond_loc(:, :, 1:counts(my_node_id)) = & - cdodq_precond(:, :, 1 + displs(my_node_id):displs(my_node_id) + counts(my_node_id)) - + enddo end if + cdodq_precond_loc(:, :, 1:counts(my_node_id)) = & + cdodq_precond(:, :, 1 + displs(my_node_id):displs(my_node_id) + counts(my_node_id)) + + !end if + + end subroutine precond_search_direction + + !================================================! + subroutine internal_search_direction(cdodq_precond_loc, cdqkeep_loc, iter, lprint, lrandom, & + noise_count, ncg, gcfac, gcnorm0, gcnorm1, & + doda0, wann_control, num_wann, & + wbtot, cdq_loc, cdodq_loc, counts, stdout) + !================================================! + ! + !! Calculate the conjugate gradients search + !! direction using the Fletcher-Reeves formula: + !! + !! cg_coeff = [g(i).g(i)]/[g(i-1).g(i-1)] + ! + !================================================! + + use w90_io, only: io_stopwatch + use w90_comms, only: comms_allreduce, w90comm_type + use w90_wannier90_types, only: wann_control_type + + implicit none + + type(wann_control_type), intent(in) :: wann_control + + complex(kind=dp), allocatable, intent(inout) :: cdodq_precond_loc(:, :, :) + complex(kind=dp), intent(inout) :: cdqkeep_loc(:, :, :) + integer, intent(in) :: iter + logical, intent(in) :: lprint + logical, intent(inout) :: lrandom + integer, intent(in) :: noise_count + integer, intent(inout) :: ncg + real(kind=dp), intent(out) :: gcfac + real(kind=dp), intent(inout) :: gcnorm0, gcnorm1 + real(kind=dp), intent(out) :: doda0 + integer, intent(in) :: num_wann + !real(kind=dp), intent(in) :: kpt_latt(:, :) + !real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: wbtot + !integer, intent(in) :: nrpts + !integer, intent(in) :: irvec(:, :) + !integer, intent(in) :: ndegen(:) + complex(kind=dp), intent(inout) :: cdq_loc(:, :, :) + complex(kind=dp), intent(in) :: cdodq_loc(:, :, :) + integer, intent(in) :: counts(0:) + integer, intent(in) :: stdout + ! local + complex(kind=dp), external :: zdotc + + if ((.not. wann_control%precond) .and. print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('wann: main: search_direction', 1, stdout, seedname) ! gcnorm1 = Tr[gradient . gradient] -- NB gradient is anti-Hermitian - if (precond) then + if (wann_control%precond) then ! gcnorm1 = real(zdotc(num_kpts*num_wann*num_wann,cdodq_precond,1,cdodq,1),dp) - gcnorm1 = real(zdotc(counts(my_node_id)*num_wann*num_wann, cdodq_precond_loc, 1, cdodq_loc, 1), dp) + gcnorm1 = real(zdotc(counts(my_node_id)*num_wann*num_wann, cdodq_precond_loc, 1, & + cdodq_loc, 1), dp) else gcnorm1 = real(zdotc(counts(my_node_id)*num_wann*num_wann, cdodq_loc, 1, cdodq_loc, 1), dp) end if - call comms_allreduce(gcnorm1, 1, 'SUM') + call comms_allreduce(gcnorm1, 1, 'SUM', stdout, seedname, comm) ! calculate cg_coefficient - if ((iter .eq. 1) .or. (ncg .ge. num_cg_steps)) then + if ((iter .eq. 1) .or. (ncg .ge. wann_control%num_cg_steps)) then gcfac = 0.0_dp ! Steepest descents ncg = 0 else @@ -1067,7 +1317,7 @@ subroutine internal_search_direction() gcfac = gcnorm1/gcnorm0 ! Fletcher-Reeves CG coefficient ! prevent CG coefficient from getting too large if (gcfac .gt. 3.0_dp) then - if (lprint .and. iprint > 2 .and. on_root) & + if (lprint .and. print_output%iprint > 2) & write (stdout, *) ' LINE --> CG coeff too large. Resetting :', gcfac gcfac = 0.0_dp ncg = 0 @@ -1085,7 +1335,7 @@ subroutine internal_search_direction() ! calculate search direction - if (precond) then + if (wann_control%precond) then cdq_loc(:, :, :) = cdodq_precond_loc(:, :, :) + cdqkeep_loc(:, :, :)*gcfac !! JRY not MPI else cdq_loc(:, :, :) = cdodq_loc(:, :, :) + cdqkeep_loc(:, :, :)*gcfac @@ -1093,15 +1343,17 @@ subroutine internal_search_direction() ! add some random noise to search direction, if required if (lrandom) then - if (on_root) write (stdout, '(a,i3,a,i3,a)') & - ' [ Adding random noise to search direction. Time ', noise_count, ' / ', conv_noise_num, ' ]' - call internal_random_noise() + if (print_output%iprint > 0) write (stdout, '(a,i3,a,i3,a)') & + ' [ Adding random noise to search direction. Time ', noise_count, ' / ', & + wann_control%conv_noise_num, ' ]' + call internal_random_noise(wann_control%conv_noise_amp, num_wann, counts, cdq_loc, & + stdout) endif ! calculate gradient along search direction - Tr[gradient . search direction] ! NB gradient is anti-hermitian doda0 = -real(zdotc(counts(my_node_id)*num_wann*num_wann, cdodq_loc, 1, cdq_loc, 1), dp) - call comms_allreduce(doda0, 1, 'SUM') + call comms_allreduce(doda0, 1, 'SUM', stdout, seedname, comm) doda0 = doda0/(4.0_dp*wbtot) @@ -1109,28 +1361,29 @@ subroutine internal_search_direction() if (doda0 .gt. 0.0_dp) then ! if doing a CG step then reset CG if (ncg .gt. 0) then - if (lprint .and. iprint > 2 .and. on_root) & + if (lprint .and. print_output%iprint > 2 .and. print_output%iprint > 0) & write (stdout, *) ' LINE --> Search direction uphill: resetting CG' cdq_loc(:, :, :) = cdodq_loc(:, :, :) - if (lrandom) call internal_random_noise() + if (lrandom) call internal_random_noise(wann_control%conv_noise_amp, num_wann, & + counts, cdq_loc, stdout) ncg = 0 gcfac = 0.0_dp ! re-calculate gradient along search direction doda0 = -real(zdotc(counts(my_node_id)*num_wann*num_wann, cdodq_loc, 1, cdq_loc, 1), dp) - call comms_allreduce(doda0, 1, 'SUM') + call comms_allreduce(doda0, 1, 'SUM', stdout, seedname, comm) doda0 = doda0/(4.0_dp*wbtot) ! if search direction still uphill then reverse search direction if (doda0 .gt. 0.0_dp) then - if (lprint .and. iprint > 2 .and. on_root) & + if (lprint .and. print_output%iprint > 2 .and. print_output%iprint > 0) & write (stdout, *) ' LINE --> Search direction still uphill: reversing' cdq_loc(:, :, :) = -cdq_loc(:, :, :) doda0 = -doda0 endif ! if doing a SD step then reverse search direction else - if (lprint .and. iprint > 2 .and. on_root) & + if (lprint .and. print_output%iprint > 2 .and. print_output%iprint > 0) & write (stdout, *) ' LINE --> Search direction uphill: reversing' cdq_loc(:, :, :) = -cdq_loc(:, :, :) doda0 = -doda0 @@ -1140,7 +1393,8 @@ subroutine internal_search_direction() !~ ! calculate search direction !~ cdq(:,:,:) = cdodq(:,:,:) + cdqkeep(:,:,:) * gcfac - if (timing_level > 1 .and. on_root) call io_stopwatch('wann: main: search_direction', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('wann: main: search_direction', 2, stdout, seedname) lrandom = .false. @@ -1148,20 +1402,34 @@ subroutine internal_search_direction() end subroutine internal_search_direction - !===============================================! - subroutine internal_optimal_step() - !===============================================! - ! ! + !================================================! + subroutine internal_optimal_step(wann_spread, trial_spread, doda0, alphamin, falphamin, lquad, & + lprint, trial_step, stdout) + !================================================! + ! !! Calculate the optimal step length based on a !! parabolic line search - ! ! - !===============================================! + ! + !================================================! + use w90_io, only: io_stopwatch + use w90_comms, only: w90comm_type implicit none + type(localisation_vars_type), intent(in) :: trial_spread + type(localisation_vars_type), intent(in) :: wann_spread + integer, intent(in) :: stdout + real(kind=dp), intent(in) :: doda0 + real(kind=dp), intent(in) :: trial_step + real(kind=dp), intent(out) :: alphamin, falphamin + logical, intent(out) :: lquad + logical, intent(in) :: lprint + + ! local variables real(kind=dp) :: fac, shift, eqa, eqb - if (timing_level > 1 .and. on_root) call io_stopwatch('wann: main: optimal_step', 1) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('wann: main: optimal_step', 1, stdout, seedname) fac = trial_spread%om_tot - wann_spread%om_tot if (abs(fac) .gt. tiny(1.0_dp)) then @@ -1179,7 +1447,7 @@ subroutine internal_optimal_step() falphamin = wann_spread%om_tot & - 0.25_dp*eqb*eqb/(fac*eqa)*(trial_step**2) else - if (lprint .and. iprint > 2 .and. on_root) write (stdout, *) & + if (lprint .and. print_output%iprint > 2) write (stdout, *) & ' LINE --> Parabolic line search unstable: using trial step' lquad = .false. alphamin = trial_step @@ -1187,57 +1455,93 @@ subroutine internal_optimal_step() endif if (doda0*alphamin .gt. 0.0_dp) then - if (lprint .and. iprint > 2 .and. on_root) write (stdout, *) & + if (lprint .and. print_output%iprint > 2) write (stdout, *) & ' LINE --> Line search unstable : using trial step' lquad = .false. alphamin = trial_step falphamin = trial_spread%om_tot endif - if (timing_level > 1 .and. on_root) call io_stopwatch('wann: main: optimal_step', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) & + call io_stopwatch('wann: main: optimal_step', 2, stdout, seedname) return end subroutine internal_optimal_step - !===============================================! - subroutine internal_new_u_and_m() - !===============================================! - ! ! + !================================================! + subroutine internal_new_u_and_m(cdq, cmtmp, tmp_cdq, cwork, rwork, evals, cwschur1, cwschur2, & + cwschur3, cwschur4, cz, num_wann, num_kpts, kmesh_info, & + lsitesymmetry, counts, displs, cdq_loc, u_matrix_loc, & + m_matrix_loc, timing_level, stdout, sitesym, comm) + !================================================! + ! !! Update U and M matrices after a trial step - ! ! - !===============================================! - use w90_sitesym, only: sitesym_symmetrize_rotation, & !RS: - ir2ik, ik2ir !YN: RS: + ! + !================================================! + + use w90_constants, only: cmplx_i + use w90_sitesym, only: sitesym_symmetrize_rotation + use w90_wannier90_types, only: sitesym_type + use w90_io, only: io_stopwatch, io_error + use w90_comms, only: comms_bcast, comms_gatherv, w90comm_type + use w90_utility, only: utility_zgemm + use w90_types, only: kmesh_info_type implicit none - integer :: nkp, nn, nkp2, nsdim, nkp_loc + type(kmesh_info_type), intent(in) :: kmesh_info + + type(sitesym_type), intent(in) :: sitesym + complex(kind=dp), intent(inout) :: cdq(:, :, :) + complex(kind=dp), intent(inout) :: cmtmp(:, :), tmp_cdq(:, :) ! really just local? + complex(kind=dp), intent(inout) :: cwork(:) + real(kind=dp), intent(inout) :: evals(:) + real(kind=dp), intent(inout) :: rwork(:) + complex(kind=dp), intent(inout) :: cwschur1(:), cwschur2(:) + complex(kind=dp), intent(inout) :: cwschur3(:), cwschur4(:) + complex(kind=dp), intent(inout) :: cz(:, :) + integer, intent(in) :: num_wann, num_kpts + logical, intent(in) :: lsitesymmetry + integer, intent(in) :: counts(0:) + integer, intent(in) :: displs(0:) + complex(kind=dp), intent(inout) :: cdq_loc(:, :, :) + complex(kind=dp), intent(inout) :: u_matrix_loc(:, :, :) + complex(kind=dp), intent(inout) :: m_matrix_loc(:, :, :, :) + integer, intent(in) :: timing_level + integer, intent(in) :: stdout + type(w90comm_type), intent(in) :: comm + + ! local vars + integer :: i, nkp, nn, nkp2, nsdim, nkp_loc, info logical :: ltmp + integer :: my_node_id - if (timing_level > 1 .and. on_root) call io_stopwatch('wann: main: u_and_m', 1) + my_node_id = mpirank(comm) + + if (timing_level > 1 .and. print_output%iprint > 0) call io_stopwatch('wann: main: u_and_m', 1, stdout, seedname) do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) if (lsitesymmetry) then !YN: RS: - if (ir2ik(ik2ir(nkp)) .ne. nkp) cycle !YN: RS: + if (sitesym%ir2ik(sitesym%ik2ir(nkp)) .ne. nkp) cycle !YN: RS: end if !YN: RS: ! cdq(nkp) is anti-Hermitian; tmp_cdq = i*cdq is Hermitian tmp_cdq(:, :) = cmplx_i*cdq_loc(:, :, nkp_loc) ! Hermitian matrix eigen-solver call zheev('V', 'U', num_wann, tmp_cdq, num_wann, evals, cwork, 4*num_wann, rwork, info) if (info .ne. 0) then - if (on_root) write (stdout, *) & + if (print_output%iprint > 0) write (stdout, *) & 'wann_main: ZHEEV in internal_new_u_and_m failed, info= ', info - if (on_root) write (stdout, *) ' trying Schur decomposition instead' + if (print_output%iprint > 0) write (stdout, *) ' trying Schur decomposition instead' !!$ call io_error('wann_main: problem in ZHEEV in internal_new_u_and_m') tmp_cdq(:, :) = cdq_loc(:, :, nkp_loc) call zgees('V', 'N', ltmp, num_wann, tmp_cdq, num_wann, nsdim, & cwschur1, cz, num_wann, cwschur2, 10*num_wann, cwschur3, & cwschur4, info) if (info .ne. 0) then - if (on_root) write (stdout, *) 'wann_main: SCHUR failed, info= ', info - call io_error('wann_main: problem computing schur form 1') + if (print_output%iprint > 0) write (stdout, *) 'wann_main: SCHUR failed, info= ', info + call io_error('wann_main: problem computing schur form 1', stdout, seedname) endif do i = 1, num_wann tmp_cdq(:, i) = cz(:, i)*exp(cwschur1(i)) @@ -1256,9 +1560,9 @@ subroutine internal_new_u_and_m() ! each process communicates its result to other processes ! it would be enough to copy only next neighbors - call comms_gatherv(cdq_loc, num_wann*num_wann*counts(my_node_id), & - cdq, num_wann*num_wann*counts, num_wann*num_wann*displs) - call comms_bcast(cdq(1, 1, 1), num_wann*num_wann*num_kpts) + call comms_gatherv(cdq_loc, num_wann*num_wann*counts(my_node_id), cdq, & + num_wann*num_wann*counts, num_wann*num_wann*displs, stdout, seedname, comm) + call comms_bcast(cdq(1, 1, 1), num_wann*num_wann*num_kpts, stdout, seedname, comm) !!$ do nkp = 1, num_kpts !!$ tmp_cdq(:,:) = cdq(:,:,nkp) @@ -1278,40 +1582,44 @@ subroutine internal_new_u_and_m() !!$ enddo if (lsitesymmetry) then - call sitesym_symmetrize_rotation(cdq) !RS: calculate cdq(Rk) from k - cdq_loc(:, :, 1:counts(my_node_id)) = cdq(:, :, 1 + displs(my_node_id):displs(my_node_id) + counts(my_node_id)) + call sitesym_symmetrize_rotation(sitesym, cdq, num_kpts, num_wann, seedname, stdout) !RS: calculate cdq(Rk) from k + + cdq_loc(:, :, 1:counts(my_node_id)) = cdq(:, :, 1 + displs(my_node_id):displs(my_node_id) & + + counts(my_node_id)) endif ! the orbitals are rotated do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) ! cmtmp = U(k) . cdq(k) - call utility_zgemm(cmtmp, u_matrix_loc(:, :, nkp_loc), 'N', cdq_loc(:, :, nkp_loc), 'N', num_wann) + call utility_zgemm(cmtmp, u_matrix_loc(:, :, nkp_loc), 'N', cdq_loc(:, :, nkp_loc), 'N', & + num_wann) u_matrix_loc(:, :, nkp_loc) = cmtmp(:, :) enddo ! and the M_ij are updated do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) - do nn = 1, nntot - nkp2 = nnlist(nkp, nn) + do nn = 1, kmesh_info%nntot + nkp2 = kmesh_info%nnlist(nkp, nn) ! tmp_cdq = cdq^{dagger} . M - call utility_zgemm(tmp_cdq, cdq(:, :, nkp), 'C', m_matrix_loc(:, :, nn, nkp_loc), 'N', num_wann) + call utility_zgemm(tmp_cdq, cdq(:, :, nkp), 'C', m_matrix_loc(:, :, nn, nkp_loc), 'N', & + num_wann) ! cmtmp = tmp_cdq . cdq call utility_zgemm(cmtmp, tmp_cdq, 'N', cdq(:, :, nkp2), 'N', num_wann) m_matrix_loc(:, :, nn, nkp_loc) = cmtmp(:, :) enddo enddo - if (timing_level > 1) call io_stopwatch('wann: main: u_and_m', 2) + if (timing_level > 1) call io_stopwatch('wann: main: u_and_m', 2, stdout, seedname) return end subroutine internal_new_u_and_m -!~ !========================================! +!~ !================================================! !~ subroutine internal_check_unitarity() -!~ !========================================! +!~ !================================================! !~ !~ implicit none !~ @@ -1361,13 +1669,13 @@ end subroutine internal_new_u_and_m !~ !~ end subroutine internal_check_unitarity -!~ !========================================! +!~ !================================================! !~ subroutine internal_write_r2mn() -!~ !========================================! -!~ ! ! -!~ ! Write seedname.r2mn file ! -!~ ! ! -!~ !========================================! +!~ !================================================! +!~ ! +!~ ! Write seedname.r2mn file +!~ ! +!~ !================================================! !~ use w90_io, only: seedname,io_file_unit,io_error !~ !~ implicit none @@ -1405,9 +1713,9 @@ end subroutine internal_new_u_and_m !~ !~ end subroutine internal_write_r2mn -!~ !========================================! +!~ !================================================! !~ subroutine internal_svd_omega_i() -!~ !========================================! +!~ !================================================! !~ !~ implicit none !~ @@ -1493,41 +1801,63 @@ end subroutine internal_new_u_and_m end subroutine wann_main - !==================================================================! - subroutine wann_phases(csheet, sheet, rguide, irguide, m_w) - !==================================================================! + !================================================! + + subroutine wann_phases(csheet, sheet, rguide, irguide, num_wann, kmesh_info, num_kpts, m_matrix, & + gamma_only, counts, displs, m_matrix_loc, rnkb, timing_level, stdout, & + seedname, iprint, comm, m_w) + !================================================! !! Uses guiding centres to pick phases which give a !! consistent choice of branch cut for the spread definition - ! ! - !=================================================================== - use w90_constants, only: eps6 - use w90_parameters, only: num_wann, nntot, neigh, & - nnh, bk, bka, num_kpts, timing_level, m_matrix, gamma_only + ! + !================================================ + + use w90_constants, only: eps6, cmplx_0, cmplx_i use w90_io, only: io_stopwatch use w90_utility, only: utility_inv3 + use w90_comms, only: comms_allreduce, w90comm_type, mpirank + use w90_types, only: kmesh_info_type implicit none - complex(kind=dp), intent(out) :: csheet(:, :, :) - !! Choice of phase - real(kind=dp), intent(out) :: sheet(:, :, :) - !! Choice of branch cut - real(kind=dp), intent(inout) :: rguide(:, :) - !! Guiding centres - integer, intent(in) :: irguide - !! Zero if first call to this routine + ! arguments + type(w90comm_type), intent(in) :: comm + type(kmesh_info_type), intent(in) :: kmesh_info + + integer, intent(in) :: timing_level + integer, intent(in) :: stdout + integer, intent(in) :: num_wann + integer, intent(in) :: num_kpts + integer, intent(in) :: irguide !! Zero if first call to this routine + integer, intent(in) :: iprint + integer, intent(in) :: displs(0:) + integer, intent(in) :: counts(0:) + + real(kind=dp), intent(out) :: sheet(:, :, :) !! Choice of branch cut + real(kind=dp), intent(out) :: rnkb(:, :, :) + real(kind=dp), intent(inout) :: rguide(:, :) !! Guiding centres real(kind=dp), intent(in), optional :: m_w(:, :, :) - !! Used in the Gamma point routines as an optimisation + + complex(kind=dp), intent(out) :: csheet(:, :, :) !! Choice of phase + complex(kind=dp), intent(in) :: m_matrix(:, :, :, :) + complex(kind=dp), allocatable, intent(in) :: m_matrix_loc(:, :, :, :) + + character(len=50), intent(in) :: seedname + + logical, intent(in) :: gamma_only !local - complex(kind=dp) :: csum(nnh) - real(kind=dp) :: xx(nnh) + complex(kind=dp) :: csum(kmesh_info%nnh) + real(kind=dp) :: xx(kmesh_info%nnh) real(kind=dp) :: smat(3, 3), svec(3), sinv(3, 3) real(kind=dp) :: xx0, det, brn complex(kind=dp) :: csumt integer :: loop_wann, na, nkp, i, j, nn, ind, m, nkp_loc + integer :: my_node_id + + my_node_id = mpirank(comm) - if (timing_level > 1 .and. on_root) call io_stopwatch('wann: phases', 1) + if (timing_level > 1 .and. iprint > 0) call io_stopwatch('wann: phases', 1, stdout, seedname) csum = cmplx_0; xx = 0.0_dp @@ -1540,20 +1870,20 @@ subroutine wann_phases(csheet, sheet, rguide, irguide, m_w) if (.not. present(m_w)) then ! get average phase for each unique bk direction if (gamma_only) then - do na = 1, nnh + do na = 1, kmesh_info%nnh csum(na) = cmplx_0 do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) - nn = neigh(nkp, na) + nn = kmesh_info%neigh(nkp, na) csum(na) = csum(na) + m_matrix(loop_wann, loop_wann, nn, nkp_loc) enddo enddo else - do na = 1, nnh + do na = 1, kmesh_info%nnh csum(na) = cmplx_0 do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) - nn = neigh(nkp, na) + nn = kmesh_info%neigh(nkp, na) csum(na) = csum(na) + m_matrix_loc(loop_wann, loop_wann, nn, nkp_loc) enddo enddo @@ -1561,11 +1891,11 @@ subroutine wann_phases(csheet, sheet, rguide, irguide, m_w) else - do na = 1, nnh + do na = 1, kmesh_info%nnh csum(na) = cmplx_0 do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) - nn = neigh(nkp, na) + nn = kmesh_info%neigh(nkp, na) csum(na) = csum(na) & + cmplx(m_w(loop_wann, loop_wann, 2*nn - 1), m_w(loop_wann, loop_wann, 2*nn), dp) enddo @@ -1573,7 +1903,7 @@ subroutine wann_phases(csheet, sheet, rguide, irguide, m_w) end if - call comms_allreduce(csum(1), nnh, 'SUM') + call comms_allreduce(csum(1), kmesh_info%nnh, 'SUM', stdout, seedname, comm) ! now analyze that information to get good guess at ! wannier center @@ -1606,7 +1936,7 @@ subroutine wann_phases(csheet, sheet, rguide, irguide, m_w) smat = 0.0_dp svec = 0.0_dp - do nn = 1, nnh + do nn = 1, kmesh_info%nnh if (nn .le. 3) then ! obtain xx with arbitrary branch cut choice xx(nn) = -aimag(log(csum(nn))) @@ -1614,7 +1944,7 @@ subroutine wann_phases(csheet, sheet, rguide, irguide, m_w) ! obtain xx with branch cut choice guided by rguide xx0 = 0.0_dp do j = 1, 3 - xx0 = xx0 + bka(j, nn)*rguide(j, loop_wann) + xx0 = xx0 + kmesh_info%bka(j, nn)*rguide(j, loop_wann) enddo ! xx0 is expected value for xx ! csumt = exp (ci * xx0) @@ -1628,9 +1958,9 @@ subroutine wann_phases(csheet, sheet, rguide, irguide, m_w) ! update smat and svec do j = 1, 3 do i = 1, 3 - smat(j, i) = smat(j, i) + bka(j, nn)*bka(i, nn) + smat(j, i) = smat(j, i) + kmesh_info%bka(j, nn)*kmesh_info%bka(i, nn) enddo - svec(j) = svec(j) + bka(j, nn)*xx(nn) + svec(j) = svec(j) + kmesh_info%bka(j, nn)*xx(nn) enddo if (nn .ge. 3) then @@ -1659,12 +1989,12 @@ subroutine wann_phases(csheet, sheet, rguide, irguide, m_w) ! obtain branch cut choice guided by rguid sheet = 0.0_dp do nkp = 1, num_kpts - do nn = 1, nntot + do nn = 1, kmesh_info%nntot do loop_wann = 1, num_wann ! sheet (loop_wann, nn, nkp) = 0.d0 do j = 1, 3 sheet(loop_wann, nn, nkp) = sheet(loop_wann, nn, nkp) & - + bk(j, nn, nkp)*rguide(j, loop_wann) + + kmesh_info%bk(j, nn, nkp)*rguide(j, loop_wann) enddo ! csheet (loop_wann, nn, nkp) = exp (ci * sheet (loop_wann, nn, nkp) ) enddo @@ -1680,12 +2010,12 @@ subroutine wann_phases(csheet, sheet, rguide, irguide, m_w) rnkb = 0.0_dp do nkp = 1, num_kpts - do nn = 1, nntot + do nn = 1, kmesh_info%nntot do m = 1, num_wann ! rnkb (m, nn, nkp) = 0.0_dp brn = 0.0_dp do ind = 1, 3 - brn = brn + bk(ind, nn, nkp)*rguide(ind, m) + brn = brn + kmesh_info%bk(ind, nn, nkp)*rguide(ind, m) enddo rnkb(m, nn, nkp) = rnkb(m, nn, nkp) + brn enddo @@ -1703,47 +2033,72 @@ subroutine wann_phases(csheet, sheet, rguide, irguide, m_w) ! enddo ! enddo - if (timing_level > 1 .and. on_root) call io_stopwatch('wann: phases', 2) + if (timing_level > 1 .and. iprint > 0) call io_stopwatch('wann: phases', 2, stdout, seedname) return end subroutine wann_phases - !==================================================================! - subroutine wann_omega(csheet, sheet, rave, r2ave, rave2, wann_spread) - !==================================================================! - ! ! - !! Calculate the Wannier Function spread ! - ! ! - ! Modified by Valerio Vitale for the SLWF+C method (PRB 90, 165125)! - ! Jun 2018, based on previous work by Charles T. Johnson and ! + !================================================! + subroutine wann_omega(csheet, sheet, rave, r2ave, rave2, wann_spread, num_wann, kmesh_info, & + num_kpts, print_output, wann_slwf, omega_invariant, counts, displs, & + ln_tmp_loc, m_matrix_loc, lambda_loc, first_pass, stdout, seedname, comm) + !================================================! + ! + !! Calculate the Wannier Function spread + ! + ! Modified by Valerio Vitale for the SLWF+C method (PRB 90, 165125) + ! Jun 2018, based on previous work by Charles T. Johnson and ! Radu Miron at Implerial College London - !=================================================================== - use w90_parameters, only: num_wann, m_matrix, nntot, wb, bk, num_kpts, & - omega_invariant, timing_level, & - selective_loc, slwf_constrain, slwf_num, & - ccentres_cart + !================================================ + use w90_io, only: io_stopwatch + use w90_comms, only: comms_allreduce, w90comm_type, mpirank + use w90_types, only: kmesh_info_type, print_output_type + use w90_wannier90_types, only: wann_slwf_type implicit none + ! arguments + type(kmesh_info_type), intent(in) :: kmesh_info + type(localisation_vars_type), intent(out) :: wann_spread + type(print_output_type), intent(in) :: print_output + type(w90comm_type), intent(in) :: comm + type(wann_slwf_type), intent(in) :: wann_slwf + + integer, intent(in) :: counts(0:), displs(0:) + integer, intent(in) :: num_kpts + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + complex(kind=dp), intent(in) :: csheet(:, :, :) + complex(kind=dp), intent(in) :: m_matrix_loc(:, :, :, :) + + real(kind=dp), intent(in) :: lambda_loc + real(kind=dp), intent(in) :: omega_invariant + real(kind=dp), intent(inout) :: ln_tmp_loc(:, :, :) real(kind=dp), intent(in) :: sheet(:, :, :) - real(kind=dp), intent(out) :: rave(:, :) real(kind=dp), intent(out) :: r2ave(:) + real(kind=dp), intent(out) :: rave(:, :) real(kind=dp), intent(out) :: rave2(:) - type(localisation_vars), intent(out) :: wann_spread - !local variables + logical, intent(inout) :: first_pass + + character(len=50), intent(in) :: seedname + + ! local variables real(kind=dp) :: summ, mnn2 real(kind=dp) :: brn integer :: ind, nkp, nn, m, n, iw, nkp_loc + integer :: my_node_id + + my_node_id = mpirank(comm) - if (timing_level > 1 .and. on_root) call io_stopwatch('wann: omega', 1) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) call io_stopwatch('wann: omega', 1, stdout, seedname) do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) - do nn = 1, nntot + do nn = 1, kmesh_info%nntot do n = 1, num_wann ! Note that this ln_tmp is defined differently wrt the one in wann_domega ln_tmp_loc(n, nn, nkp_loc) = (aimag(log(csheet(n, nn, nkp) & @@ -1757,15 +2112,15 @@ subroutine wann_omega(csheet, sheet, rave, r2ave, rave2, wann_spread) do ind = 1, 3 do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) - do nn = 1, nntot - rave(ind, iw) = rave(ind, iw) + wb(nn)*bk(ind, nn, nkp) & + do nn = 1, kmesh_info%nntot + rave(ind, iw) = rave(ind, iw) + kmesh_info%wb(nn)*kmesh_info%bk(ind, nn, nkp) & *ln_tmp_loc(iw, nn, nkp_loc) enddo enddo enddo enddo - call comms_allreduce(rave(1, 1), num_wann*3, 'SUM') + call comms_allreduce(rave(1, 1), num_wann*3, 'SUM', stdout, seedname, comm) rave = -rave/real(num_kpts, dp) @@ -1786,14 +2141,15 @@ subroutine wann_omega(csheet, sheet, rave, r2ave, rave2, wann_spread) do iw = 1, num_wann do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) - do nn = 1, nntot - mnn2 = real(m_matrix_loc(iw, iw, nn, nkp_loc)*conjg(m_matrix_loc(iw, iw, nn, nkp_loc)), kind=dp) - r2ave(iw) = r2ave(iw) + wb(nn)*(1.0_dp - mnn2 + ln_tmp_loc(iw, nn, nkp_loc)**2) + do nn = 1, kmesh_info%nntot + mnn2 = real(m_matrix_loc(iw, iw, nn, nkp_loc) & + *conjg(m_matrix_loc(iw, iw, nn, nkp_loc)), kind=dp) + r2ave(iw) = r2ave(iw) + kmesh_info%wb(nn)*(1.0_dp - mnn2 + ln_tmp_loc(iw, nn, nkp_loc)**2) enddo enddo enddo - call comms_allreduce(r2ave(1), num_wann, 'SUM') + call comms_allreduce(r2ave(1), num_wann, 'SUM', stdout, seedname, comm) r2ave = r2ave/real(num_kpts, dp) @@ -1849,65 +2205,66 @@ subroutine wann_omega(csheet, sheet, rave, r2ave, rave2, wann_spread) !jry: Either the above (om1,2,3) or the following is redundant ! keep it in the code base for testing - if (selective_loc) then + if (wann_slwf%selective_loc) then wann_spread%om_iod = 0.0_dp do nkp_loc = 1, counts(my_node_id) - do nn = 1, nntot + do nn = 1, kmesh_info%nntot summ = 0.0_dp - do n = 1, slwf_num + do n = 1, wann_slwf%slwf_num summ = summ & + real(m_matrix_loc(n, n, nn, nkp_loc) & *conjg(m_matrix_loc(n, n, nn, nkp_loc)), kind=dp) - if (slwf_constrain) then + if (wann_slwf%constrain) then !! Centre constraint contribution. Zero if slwf_constrain=false summ = summ - lambda_loc*ln_tmp_loc(n, nn, nkp_loc)**2 end if enddo wann_spread%om_iod = wann_spread%om_iod & - + wb(nn)*(real(slwf_num, dp) - summ) + + kmesh_info%wb(nn)*(real(wann_slwf%slwf_num, dp) - summ) enddo enddo - call comms_allreduce(wann_spread%om_iod, 1, 'SUM') + call comms_allreduce(wann_spread%om_iod, 1, 'SUM', stdout, seedname, comm) wann_spread%om_iod = wann_spread%om_iod/real(num_kpts, dp) wann_spread%om_d = 0.0_dp do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) - do nn = 1, nntot - do n = 1, slwf_num - brn = sum(bk(:, nn, nkp)*rave(:, n)) - wann_spread%om_d = wann_spread%om_d + (1.0_dp - lambda_loc)*wb(nn) & + do nn = 1, kmesh_info%nntot + do n = 1, wann_slwf%slwf_num + brn = sum(kmesh_info%bk(:, nn, nkp)*rave(:, n)) + wann_spread%om_d = wann_spread%om_d + (1.0_dp - lambda_loc)*kmesh_info%wb(nn) & *(ln_tmp_loc(n, nn, nkp_loc) + brn)**2 enddo enddo enddo - call comms_allreduce(wann_spread%om_d, 1, 'SUM') + call comms_allreduce(wann_spread%om_d, 1, 'SUM', stdout, seedname, comm) wann_spread%om_d = wann_spread%om_d/real(num_kpts, dp) wann_spread%om_nu = 0.0_dp !! Contribution from constrains on centres - if (slwf_constrain) then + if (wann_slwf%constrain) then do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) - do nn = 1, nntot - do n = 1, slwf_num - wann_spread%om_nu = wann_spread%om_nu + 2.0_dp*wb(nn)* & + do nn = 1, kmesh_info%nntot + do n = 1, wann_slwf%slwf_num + wann_spread%om_nu = wann_spread%om_nu + 2.0_dp*kmesh_info%wb(nn)* & ln_tmp_loc(n, nn, nkp_loc)*lambda_loc* & - sum(bk(:, nn, nkp)*ccentres_cart(n, :)) + sum(kmesh_info%bk(:, nn, nkp)*wann_slwf%centres(n, :)) enddo enddo enddo - call comms_allreduce(wann_spread%om_nu, 1, 'SUM') + call comms_allreduce(wann_spread%om_nu, 1, 'SUM', stdout, seedname, comm) wann_spread%om_nu = wann_spread%om_nu/real(num_kpts, dp) - do n = 1, slwf_num - wann_spread%om_nu = wann_spread%om_nu + lambda_loc*sum(ccentres_cart(n, :)**2) + do n = 1, wann_slwf%slwf_num + wann_spread%om_nu = wann_spread%om_nu & + + lambda_loc*sum(wann_slwf%centres(n, :)**2) end do end if @@ -1919,20 +2276,21 @@ subroutine wann_omega(csheet, sheet, rave, r2ave, rave2, wann_spread) wann_spread%om_i = 0.0_dp nkp = nkp_loc + displs(my_node_id) do nkp_loc = 1, counts(my_node_id) - do nn = 1, nntot + do nn = 1, kmesh_info%nntot summ = 0.0_dp do m = 1, num_wann do n = 1, num_wann summ = summ & - + real(m_matrix_loc(n, m, nn, nkp_loc)*conjg(m_matrix_loc(n, m, nn, nkp_loc)), kind=dp) + + real(m_matrix_loc(n, m, nn, nkp_loc) & + *conjg(m_matrix_loc(n, m, nn, nkp_loc)), kind=dp) enddo enddo wann_spread%om_i = wann_spread%om_i & - + wb(nn)*(real(num_wann, dp) - summ) + + kmesh_info%wb(nn)*(real(num_wann, dp) - summ) enddo enddo - call comms_allreduce(wann_spread%om_i, 1, 'SUM') + call comms_allreduce(wann_spread%om_i, 1, 'SUM', stdout, seedname, comm) wann_spread%om_i = wann_spread%om_i/real(num_kpts, dp) first_pass = .false. @@ -1943,100 +2301,126 @@ subroutine wann_omega(csheet, sheet, rave, r2ave, rave2, wann_spread) wann_spread%om_od = 0.0_dp do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) - do nn = 1, nntot + do nn = 1, kmesh_info%nntot do m = 1, num_wann do n = 1, num_wann if (m .ne. n) wann_spread%om_od = wann_spread%om_od & - + wb(nn)*real(m_matrix_loc(n, m, nn, nkp_loc) & - *conjg(m_matrix_loc(n, m, nn, nkp_loc)), kind=dp) + + kmesh_info%wb(nn)*real(m_matrix_loc(n, m, nn, nkp_loc) & + *conjg(m_matrix_loc(n, m, nn, nkp_loc)), kind=dp) enddo enddo enddo enddo - call comms_allreduce(wann_spread%om_od, 1, 'SUM') + call comms_allreduce(wann_spread%om_od, 1, 'SUM', stdout, seedname, comm) wann_spread%om_od = wann_spread%om_od/real(num_kpts, dp) wann_spread%om_d = 0.0_dp do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) - do nn = 1, nntot + do nn = 1, kmesh_info%nntot do n = 1, num_wann - brn = sum(bk(:, nn, nkp)*rave(:, n)) - wann_spread%om_d = wann_spread%om_d + wb(nn) & + brn = sum(kmesh_info%bk(:, nn, nkp)*rave(:, n)) + wann_spread%om_d = wann_spread%om_d + kmesh_info%wb(nn) & *(ln_tmp_loc(n, nn, nkp_loc) + brn)**2 enddo enddo enddo - call comms_allreduce(wann_spread%om_d, 1, 'SUM') + call comms_allreduce(wann_spread%om_d, 1, 'SUM', stdout, seedname, comm) wann_spread%om_d = wann_spread%om_d/real(num_kpts, dp) wann_spread%om_tot = wann_spread%om_i + wann_spread%om_d + wann_spread%om_od end if - if (timing_level > 1 .and. on_root) call io_stopwatch('wann: omega', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) call io_stopwatch('wann: omega', 2, stdout, seedname) return end subroutine wann_omega - !==================================================================! - subroutine wann_domega(csheet, sheet, rave, cdodq) - !==================================================================! - ! ! - ! Calculate the Gradient of the Wannier Function spread ! - ! ! - ! Modified by Valerio Vitale for the SLWF+C method (PRB 90, 165125)! - ! Jun 2018, based on previous work by Charles T. Johnson and ! - ! Radu Miron at Implerial College London - !=================================================================== - use w90_parameters, only: num_wann, wb, bk, nntot, m_matrix, num_kpts, & - timing_level, selective_loc, & - slwf_constrain, slwf_num, & - ccentres_cart + !================================================! + subroutine wann_domega(csheet, sheet, rave, num_wann, kmesh_info, num_kpts, wann_slwf, & + lsitesymmetry, counts, displs, ln_tmp_loc, m_matrix_loc, rnkb_loc, & + cdodq_loc, lambda_loc, timing_level, stdout, seedname, sitesym, comm, & + iprint, cdodq) + !================================================! + ! + ! Calculate the Gradient of the Wannier Function spread + ! + ! Modified by Valerio Vitale for the SLWF+C method (PRB 90, 165125) + ! Jun 2018, based on previous work by Charles T. Johnson and + ! Radu Miron at Imperial College London + !================================================ + + use w90_constants, only: cmplx_0 use w90_io, only: io_stopwatch, io_error - use w90_parameters, only: lsitesymmetry !RS: use w90_sitesym, only: sitesym_symmetrize_gradient !RS: + use w90_comms, only: comms_gatherv, comms_bcast, comms_allreduce, & + w90comm_type, mpirank + use w90_types, only: kmesh_info_type + use w90_wannier90_types, only: wann_slwf_type, sitesym_type implicit none - complex(kind=dp), intent(in) :: csheet(:, :, :) + type(kmesh_info_type), intent(in) :: kmesh_info + type(wann_slwf_type), intent(inout) :: wann_slwf + type(sitesym_type), intent(in) :: sitesym + type(w90comm_type), intent(in) :: comm + + integer, intent(in) :: num_wann + integer, intent(in) :: num_kpts + integer, intent(in) :: timing_level, iprint + integer, intent(in) :: counts(0:), displs(0:) + integer, intent(in) :: stdout + real(kind=dp), intent(in) :: sheet(:, :, :) real(kind=dp), intent(out) :: rave(:, :) + real(kind=dp), intent(inout) :: ln_tmp_loc(:, :, :) + real(kind=dp), intent(inout) :: rnkb_loc(:, :, :) + real(kind=dp), intent(in) :: lambda_loc + ! as we work on the local cdodq, returning the full cdodq array is now ! made optional complex(kind=dp), intent(out), optional :: cdodq(:, :, :) + complex(kind=dp), intent(in) :: csheet(:, :, :) + complex(kind=dp), intent(in) :: m_matrix_loc(:, :, :, :) + complex(kind=dp), intent(out) :: cdodq_loc(:, :, :) - !local + logical, intent(in) :: lsitesymmetry + + character(len=50), intent(in) :: seedname + + ! local complex(kind=dp), allocatable :: cr(:, :) complex(kind=dp), allocatable :: crt(:, :) real(kind=dp), allocatable :: r0kb(:, :, :) - - ! local integer :: iw, ind, nkp, nn, m, n, ierr, nkp_loc complex(kind=dp) :: mnn + integer :: my_node_id + + my_node_id = mpirank(comm) - if (timing_level > 1 .and. on_root) call io_stopwatch('wann: domega', 1) + if (timing_level > 1 .and. iprint > 0) call io_stopwatch('wann: domega', 1, stdout, seedname) allocate (cr(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cr in wann_domega') + if (ierr /= 0) call io_error('Error in allocating cr in wann_domega', stdout, seedname) allocate (crt(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating crt in wann_domega') - if (selective_loc .and. slwf_constrain) then - allocate (r0kb(num_wann, nntot, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating r0kb in wann_domega') + if (ierr /= 0) call io_error('Error in allocating crt in wann_domega', stdout, seedname) + if (wann_slwf%selective_loc .and. wann_slwf%constrain) then + allocate (r0kb(num_wann, kmesh_info%nntot, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating r0kb in wann_domega', stdout, seedname) end if do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) - do nn = 1, nntot + do nn = 1, kmesh_info%nntot do n = 1, num_wann ! Note that this ln_tmp is defined differently wrt the one in wann_omega - ln_tmp_loc(n, nn, nkp_loc) = wb(nn)*(aimag(log(csheet(n, nn, nkp) & - *m_matrix_loc(n, n, nn, nkp_loc))) - sheet(n, nn, nkp)) + ln_tmp_loc(n, nn, nkp_loc) = kmesh_info%wb(nn)*(aimag(log(csheet(n, nn, nkp) & + *m_matrix_loc(n, n, nn, nkp_loc))) - sheet(n, nn, nkp)) end do end do end do @@ -2047,8 +2431,8 @@ subroutine wann_domega(csheet, sheet, rave, cdodq) do ind = 1, 3 do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) - do nn = 1, nntot - rave(ind, iw) = rave(ind, iw) + bk(ind, nn, nkp) & + do nn = 1, kmesh_info%nntot + rave(ind, iw) = rave(ind, iw) + kmesh_info%bk(ind, nn, nkp) & *ln_tmp_loc(iw, nn, nkp_loc) enddo enddo @@ -2056,16 +2440,17 @@ subroutine wann_domega(csheet, sheet, rave, cdodq) enddo rave = -rave/real(num_kpts, dp) - call comms_allreduce(rave(1, 1), num_wann*3, 'SUM') + call comms_allreduce(rave(1, 1), num_wann*3, 'SUM', stdout, seedname, comm) ! b.r_0n are calculated - if (selective_loc .and. slwf_constrain) then + if (wann_slwf%selective_loc .and. wann_slwf%constrain) then r0kb = 0.0_dp do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) - do nn = 1, nntot + do nn = 1, kmesh_info%nntot do n = 1, num_wann - r0kb(n, nn, nkp_loc) = sum(bk(:, nn, nkp)*ccentres_cart(n, :)) + r0kb(n, nn, nkp_loc) = sum(kmesh_info%bk(:, nn, nkp) & + *wann_slwf%centres(n, :)) enddo enddo enddo @@ -2074,9 +2459,9 @@ subroutine wann_domega(csheet, sheet, rave, cdodq) rnkb_loc = 0.0_dp do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) - do nn = 1, nntot + do nn = 1, kmesh_info%nntot do n = 1, num_wann - rnkb_loc(n, nn, nkp_loc) = sum(bk(:, nn, nkp)*rave(:, n)) + rnkb_loc(n, nn, nkp_loc) = sum(kmesh_info%bk(:, nn, nkp)*rave(:, n)) enddo enddo enddo @@ -2087,34 +2472,35 @@ subroutine wann_domega(csheet, sheet, rave, cdodq) crt = cmplx_0 do nkp_loc = 1, counts(my_node_id) nkp = nkp_loc + displs(my_node_id) - do nn = 1, nntot + do nn = 1, kmesh_info%nntot do n = 1, num_wann ! R^{k,b} and R~^{k,b} have columns of zeroes for the non-objective Wannier functions mnn = m_matrix_loc(n, n, nn, nkp_loc) crt(:, n) = m_matrix_loc(:, n, nn, nkp_loc)/mnn cr(:, n) = m_matrix_loc(:, n, nn, nkp_loc)*conjg(mnn) enddo - if (selective_loc) then + if (wann_slwf%selective_loc) then do n = 1, num_wann do m = 1, num_wann - if (m <= slwf_num) then - if (n <= slwf_num) then + if (m <= wann_slwf%slwf_num) then + if (n <= wann_slwf%slwf_num) then ! A[R^{k,b}]=(R-Rdag)/2 cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) & - + wb(nn)*0.5_dp*(cr(m, n) - conjg(cr(n, m))) + + kmesh_info%wb(nn)*0.5_dp*(cr(m, n) - conjg(cr(n, m))) cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) & - (crt(m, n)*ln_tmp_loc(n, nn, nkp_loc) & + conjg(crt(n, m)*ln_tmp_loc(m, nn, nkp_loc))) & *cmplx(0.0_dp, -0.5_dp, kind=dp) cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) & - - (crt(m, n)*rnkb_loc(n, nn, nkp_loc) + conjg(crt(n, m) & - *rnkb_loc(m, nn, nkp_loc))) & + - (crt(m, n)*rnkb_loc(n, nn, nkp_loc) & + + conjg(crt(n, m)*rnkb_loc(m, nn, nkp_loc))) & *cmplx(0.0_dp, -0.5_dp, kind=dp) - if (slwf_constrain) then + if (wann_slwf%constrain) then cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) + lambda_loc & *(crt(m, n)*ln_tmp_loc(n, nn, nkp_loc) & + conjg(crt(n, m)*ln_tmp_loc(m, nn, nkp_loc))) & *cmplx(0.0_dp, -0.5_dp, kind=dp) - cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) + wb(nn)*lambda_loc & + cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) & + + kmesh_info%wb(nn)*lambda_loc & *(crt(m, n)*rnkb_loc(n, nn, nkp_loc) & + conjg(crt(n, m)*rnkb_loc(m, nn, nkp_loc))) & *cmplx(0.0_dp, -0.5_dp, kind=dp) @@ -2122,40 +2508,47 @@ subroutine wann_domega(csheet, sheet, rave, cdodq) *(crt(m, n)*ln_tmp_loc(n, nn, nkp_loc) & + conjg(crt(n, m))*ln_tmp_loc(m, nn, nkp_loc)) & *cmplx(0.0_dp, -0.5_dp, kind=dp) - cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) - wb(nn)*lambda_loc & + cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) & + - kmesh_info%wb(nn)*lambda_loc & *(r0kb(n, nn, nkp_loc)*crt(m, n) & + r0kb(m, nn, nkp_loc)*conjg(crt(n, m))) & *cmplx(0.0_dp, -0.5_dp, kind=dp) end if else - cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) - wb(nn) & + cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) - kmesh_info%wb(nn) & *0.5_dp*conjg(cr(n, m)) & - conjg(crt(n, m)*(ln_tmp_loc(m, nn, nkp_loc) & - + wb(nn)*rnkb_loc(m, nn, nkp_loc))) & + + kmesh_info%wb(nn)*rnkb_loc(m, nn, nkp_loc))) & *cmplx(0.0_dp, -0.5_dp, kind=dp) - if (slwf_constrain) then + if (wann_slwf%constrain) then cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) + lambda_loc & *conjg(crt(n, m)*(ln_tmp_loc(m, nn, nkp_loc) & - + wb(nn)*rnkb_loc(m, nn, nkp_loc))) & + + kmesh_info%wb(nn)*rnkb_loc(m, nn, nkp_loc))) & *cmplx(0.0_dp, -0.5_dp, kind=dp) & - - lambda_loc*(conjg(crt(n, m))*ln_tmp_loc(m, nn, nkp_loc)) & + - lambda_loc*(conjg(crt(n, m)) & + *ln_tmp_loc(m, nn, nkp_loc)) & *cmplx(0.0_dp, -0.5_dp, kind=dp) - cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) - wb(nn)*lambda_loc & + cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) & + - kmesh_info%wb(nn)*lambda_loc & *r0kb(m, nn, nkp_loc)*conjg(crt(n, m)) & *cmplx(0.0_dp, -0.5_dp, kind=dp) end if end if - else if (n <= slwf_num) then - cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) + wb(nn)*cr(m, n)*0.5_dp & - - crt(m, n)*(ln_tmp_loc(n, nn, nkp_loc) + wb(nn)*rnkb_loc(n, nn, nkp_loc)) & + else if (n <= wann_slwf%slwf_num) then + cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) & + + kmesh_info%wb(nn)*cr(m, n)*0.5_dp & + - crt(m, n)*(ln_tmp_loc(n, nn, nkp_loc) & + + kmesh_info%wb(nn)*rnkb_loc(n, nn, nkp_loc)) & *cmplx(0.0_dp, -0.5_dp, kind=dp) - if (slwf_constrain) then + if (wann_slwf%constrain) then cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) + lambda_loc & - *crt(m, n)*(ln_tmp_loc(n, nn, nkp_loc) + wb(nn)*rnkb_loc(n, nn, nkp_loc)) & + *crt(m, n)*(ln_tmp_loc(n, nn, nkp_loc) & + + kmesh_info%wb(nn)*rnkb_loc(n, nn, nkp_loc)) & *cmplx(0.0_dp, -0.5_dp, kind=dp) & - lambda_loc*crt(m, n)*ln_tmp_loc(n, nn, nkp_loc) & *cmplx(0.0_dp, -0.5_dp, kind=dp) - cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) - wb(nn)*lambda_loc & + cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) - kmesh_info%wb(nn) & + *lambda_loc & *r0kb(n, nn, nkp_loc)*crt(m, n) & *cmplx(0.0_dp, -0.5_dp, kind=dp) end if @@ -2169,14 +2562,14 @@ subroutine wann_domega(csheet, sheet, rave, cdodq) do m = 1, num_wann ! A[R^{k,b}]=(R-Rdag)/2 cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) & - + wb(nn)*0.5_dp & + + kmesh_info%wb(nn)*0.5_dp & *(cr(m, n) - conjg(cr(n, m))) ! -S[T^{k,b}]=-(T+Tdag)/2i ; T_mn = Rt_mn q_n cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) - & (crt(m, n)*ln_tmp_loc(n, nn, nkp_loc) & + conjg(crt(n, m)*ln_tmp_loc(m, nn, nkp_loc))) & *cmplx(0.0_dp, -0.5_dp, kind=dp) - cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) - wb(nn) & + cdodq_loc(m, n, nkp_loc) = cdodq_loc(m, n, nkp_loc) - kmesh_info%wb(nn) & *(crt(m, n)*rnkb_loc(n, nn, nkp_loc) & + conjg(crt(n, m)*rnkb_loc(m, nn, nkp_loc))) & *cmplx(0.0_dp, -0.5_dp, kind=dp) @@ -2190,35 +2583,37 @@ subroutine wann_domega(csheet, sheet, rave, cdodq) if (present(cdodq)) then ! each process communicates its result to other processes call comms_gatherv(cdodq_loc, num_wann*num_wann*counts(my_node_id), & - cdodq, num_wann*num_wann*counts, num_wann*num_wann*displs) - call comms_bcast(cdodq(1, 1, 1), num_wann*num_wann*num_kpts) + cdodq, num_wann*num_wann*counts, num_wann*num_wann*displs, stdout, & + seedname, comm) + call comms_bcast(cdodq(1, 1, 1), num_wann*num_wann*num_kpts, stdout, seedname, comm) if (lsitesymmetry) then - call sitesym_symmetrize_gradient(1, cdodq) !RS: - cdodq_loc(:, :, 1:counts(my_node_id)) = cdodq(:, :, displs(my_node_id) + 1:displs(my_node_id) + counts(my_node_id)) + call sitesym_symmetrize_gradient(sitesym, cdodq, 1, num_kpts, num_wann) !RS: + cdodq_loc(:, :, 1:counts(my_node_id)) = cdodq(:, :, displs(my_node_id) & + + 1:displs(my_node_id) + counts(my_node_id)) endif end if deallocate (cr, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cr in wann_domega') + if (ierr /= 0) call io_error('Error in deallocating cr in wann_domega', stdout, seedname) deallocate (crt, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating crt in wann_domega') + if (ierr /= 0) call io_error('Error in deallocating crt in wann_domega', stdout, seedname) - if (timing_level > 1 .and. on_root) call io_stopwatch('wann: domega', 2) + if (timing_level > 1 .and. iprint > 0) call io_stopwatch('wann: domega', 2, stdout, seedname) return end subroutine wann_domega - !==================================================================! + !================================================! subroutine wann_spread_copy(orig, copy) - !==================================================================! - ! ! - !==================================================================! + !================================================! + ! + !================================================! implicit none - type(localisation_vars), intent(in) :: orig - type(localisation_vars), intent(out) :: copy + type(localisation_vars_type), intent(in) :: orig + type(localisation_vars_type), intent(out) :: copy copy%om_i = orig%om_i copy%om_d = orig%om_d @@ -2235,27 +2630,39 @@ subroutine wann_spread_copy(orig, copy) end subroutine wann_spread_copy - !==================================================================! - subroutine wann_calc_projection() - !==================================================================! - ! ! - ! Calculates and writes the projection of each Wannier function ! - ! on the original bands within the outer window. ! - ! ! - !==================================================================! + !================================================! + subroutine wann_calc_projection(num_bands, num_wann, num_kpts, u_matrix_opt, eigval, lwindow, & + timing_level, iprint, stdout, seedname) + !================================================! + ! + ! Calculates and writes the projection of each Wannier function + ! on the original bands within the outer window. + ! + !================================================! - use w90_parameters, only: num_bands, num_wann, num_kpts, & - u_matrix_opt, eigval, lwindow, timing_level - use w90_io, only: stdout, io_stopwatch + use w90_io, only: io_stopwatch + use w90_comms, only: w90comm_type implicit none + ! These were in the parameter module + integer, intent(in) :: num_bands + integer, intent(in) :: num_wann + integer, intent(in) :: num_kpts + complex(kind=dp), intent(in) :: u_matrix_opt(:, :, :) + real(kind=dp), intent(in) :: eigval(:, :) + logical, intent(in) :: lwindow(:, :) + integer, intent(in) :: timing_level, iprint + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + ! end of vars from parameter module + integer :: nw, nb, nkp, counter real(kind=dp) :: summ - if (timing_level > 1 .and. on_root) call io_stopwatch('wann: calc_projection', 1) + if (timing_level > 1 .and. iprint > 0) call io_stopwatch('wann: calc_projection', 1, stdout, seedname) - if (on_root) then + if (iprint > 0) then write (stdout, '(/1x,a78)') repeat('-', 78) write (stdout, '(1x,9x,a)') & 'Projection of Bands in Outer Window on all Wannier Functions' @@ -2273,36 +2680,44 @@ subroutine wann_calc_projection() do nw = 1, num_wann summ = summ + abs(u_matrix_opt(counter, nw, nkp))**2 enddo - if (on_root) write (stdout, '(1x,16x,i5,1x,i5,1x,f14.6,2x,f14.8)') & + if (iprint > 0) write (stdout, '(1x,16x,i5,1x,i5,1x,f14.6,2x,f14.8)') & nkp, nb, eigval(nb, nkp), summ endif enddo enddo - if (on_root) write (stdout, '(1x,a78/)') repeat('-', 78) + if (iprint > 0) write (stdout, '(1x,a78/)') repeat('-', 78) - if (timing_level > 1 .and. on_root) call io_stopwatch('wann: calc_projection', 2) + if (timing_level > 1 .and. iprint > 0) call io_stopwatch('wann: calc_projection', 2, stdout, seedname) return end subroutine wann_calc_projection - !=====================================! - subroutine wann_write_xyz() - !=====================================! - ! ! - ! Write xyz file with Wannier centres ! - ! ! - !=====================================! - - use w90_io, only: seedname, io_file_unit, io_date, stdout - use w90_parameters, only: translate_home_cell, num_wann, wannier_centres, & - lenconfac, real_lattice, recip_lattice, iprint, & - num_atoms, atoms_symbol, atoms_pos_cart, & - num_species, atoms_species_num + !================================================! + subroutine wann_write_xyz(translate_home_cell, num_wann, wannier_centres, real_lattice, & + atom_data, print_output, stdout, seedname) + !================================================! + ! + ! Write xyz file with Wannier centres + ! + !================================================! + + use w90_io, only: io_file_unit, io_date use w90_utility, only: utility_translate_home + use w90_types, only: atom_data_type, print_output_type implicit none + type(atom_data_type), intent(in) :: atom_data + type(print_output_type), intent(in) :: print_output + + logical, intent(in) :: translate_home_cell + integer, intent(in) :: num_wann + real(kind=dp), intent(in) :: wannier_centres(:, :) + real(kind=dp), intent(in) :: real_lattice(3, 3) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + integer :: iw, ind, xyz_unit, nsp, nat character(len=9) :: cdate, ctime real(kind=dp) :: wc(3, num_wann) @@ -2311,14 +2726,14 @@ subroutine wann_write_xyz() if (translate_home_cell) then do iw = 1, num_wann - call utility_translate_home(wc(:, iw), real_lattice, recip_lattice) + call utility_translate_home(wc(:, iw), real_lattice) enddo endif - if (iprint > 2) then + if (print_output%iprint > 2) then write (stdout, '(1x,a)') 'Final centres (translated to home cell for writing xyz file)' do iw = 1, num_wann - write (stdout, 888) iw, (wc(ind, iw)*lenconfac, ind=1, 3) + write (stdout, 888) iw, (wc(ind, iw)*print_output%lenconfac, ind=1, 3) end do write (stdout, '(1x,a78)') repeat('-', 78) write (stdout, *) @@ -2326,15 +2741,15 @@ subroutine wann_write_xyz() xyz_unit = io_file_unit() open (xyz_unit, file=trim(seedname)//'_centres.xyz', form='formatted') - write (xyz_unit, '(i6)') num_wann + num_atoms + write (xyz_unit, '(i6)') num_wann + atom_data%num_atoms call io_date(cdate, ctime) write (xyz_unit, *) 'Wannier centres, written by Wannier90 on'//cdate//' at '//ctime do iw = 1, num_wann write (xyz_unit, '("X",6x,3(f14.8,3x))') (wc(ind, iw), ind=1, 3) end do - do nsp = 1, num_species - do nat = 1, atoms_species_num(nsp) - write (xyz_unit, '(a2,5x,3(f14.8,3x))') atoms_symbol(nsp), atoms_pos_cart(:, nat, nsp) + do nsp = 1, atom_data%num_species + do nat = 1, atom_data%species_num(nsp) + write (xyz_unit, '(a2,5x,3(f14.8,3x))') atom_data%symbol(nsp), atom_data%pos_cart(:, nat, nsp) end do end do close (xyz_unit) @@ -2347,44 +2762,50 @@ subroutine wann_write_xyz() end subroutine wann_write_xyz - !=================================================================! - subroutine wann_write_vdw_data() - !=================================================================! - ! ! - ! Write a file with Wannier centres, spreads and occupations for ! - ! post-processing computation of vdW C6 coeffients. ! - ! ! - ! Based on code written by Lampros Andrinopoulos. ! - !=================================================================! - - use w90_io, only: seedname, io_file_unit, io_date, stdout, io_error - use w90_parameters, only: translate_home_cell, num_wann, wannier_centres, & - lenconfac, real_lattice, recip_lattice, iprint, & - atoms_symbol, atoms_pos_cart, num_species, & - atoms_species_num, wannier_spreads, u_matrix, & - u_matrix_opt, num_kpts, have_disentangled, & - num_valence_bands, num_elec_per_state, write_vdw_data + !================================================! + subroutine wann_write_vdw_data(num_wann, wannier_data, real_lattice, u_matrix, & + u_matrix_opt, have_disentangled, w90_system, stdout, seedname) + !================================================! + ! + ! Write a file with Wannier centres, spreads and occupations for + ! post-processing computation of vdW C6 coeffients. + ! + ! Based on code written by Lampros Andrinopoulos. + !================================================! + + use w90_io, only: io_file_unit, io_date, io_error use w90_utility, only: utility_translate_home - use w90_constants, only: cmplx_0, eps6 -!~ use w90_disentangle, only : ndimfroz + use w90_constants, only: cmplx_0 + use w90_types, only: wannier_data_type, w90_system_type implicit none + type(wannier_data_type), intent(in) :: wannier_data + type(w90_system_type), intent(in) :: w90_system + + integer, intent(in) :: num_wann + real(kind=dp), intent(in) :: real_lattice(3, 3) + complex(kind=dp), intent(in) :: u_matrix(:, :, :) + complex(kind=dp), intent(in) :: u_matrix_opt(:, :, :) + integer, intent(in) :: stdout + logical, intent(in) :: have_disentangled + character(len=50), intent(in) :: seedname + integer :: iw, vdw_unit, r, s, k, m, ierr, ndim real(kind=dp) :: wc(3, num_wann) real(kind=dp) :: ws(num_wann) complex(kind=dp), allocatable :: f_w(:, :), v_matrix(:, :) !f_w2(:,:) - wc = wannier_centres - ws = wannier_spreads + wc = wannier_data%centres + ws = wannier_data%spreads ! translate Wannier centres to the home unit cell do iw = 1, num_wann - call utility_translate_home(wc(:, iw), real_lattice, recip_lattice) + call utility_translate_home(wc(:, iw), real_lattice) enddo allocate (f_w(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating f_w in wann_write_vdw_data') + if (ierr /= 0) call io_error('Error in allocating f_w in wann_write_vdw_data', stdout, seedname) !~ ! aam: remove f_w2 at end !~ allocate(f_w2(num_wann, num_wann),stat=ierr) @@ -2393,11 +2814,12 @@ subroutine wann_write_vdw_data() if (have_disentangled) then ! dimension of occupied subspace - if (num_valence_bands .le. 0) call io_error('Please set num_valence_bands in seedname.win') - ndim = num_valence_bands + if (w90_system%num_valence_bands .le. 0) & + call io_error('Please set num_valence_bands in seedname.win', stdout, seedname) + ndim = w90_system%num_valence_bands allocate (v_matrix(ndim, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating V_matrix in wann_write_vdw_data') + if (ierr /= 0) call io_error('Error in allocating V_matrix in wann_write_vdw_data', stdout, seedname) ! aam: initialise f_w(:, :) = cmplx_0 @@ -2467,7 +2889,7 @@ subroutine wann_write_vdw_data() write (vdw_unit, '(a)') 'disentangle F' endif write (vdw_unit, '(a)') 'amalgamate F' - write (vdw_unit, '(a,i3)') 'degeneracy', num_elec_per_state + write (vdw_unit, '(a,i3)') 'degeneracy', w90_system%num_elec_per_state write (vdw_unit, '(a)') 'num_frag 2' write (vdw_unit, '(a)') 'num_wann' write (vdw_unit, '(i3,1x,i3)') num_wann/2, num_wann/2 @@ -2487,33 +2909,39 @@ subroutine wann_write_vdw_data() if (have_disentangled) then deallocate (v_matrix, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating v_matrix in wann_write_vdw_data') + if (ierr /= 0) call io_error('Error in deallocating v_matrix in wann_write_vdw_data', stdout, seedname) endif !~ deallocate(f_w2,stat=ierr) !~ if (ierr/=0) call io_error('Error in deallocating f_w2 in wann_write_vdw_data') deallocate (f_w, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating f_w in wann_write_vdw_data') + if (ierr /= 0) call io_error('Error in deallocating f_w in wann_write_vdw_data', stdout, seedname) return end subroutine wann_write_vdw_data - !========================================! - subroutine wann_check_unitarity() - !========================================! + !================================================! + subroutine wann_check_unitarity(num_kpts, num_wann, u_matrix, timing_level, iprint, stdout, & + seedname) + !================================================! use w90_constants, only: dp, cmplx_1, cmplx_0, eps5 - use w90_io, only: io_stopwatch, io_error, stdout - use w90_parameters, only: num_kpts, num_wann, & - u_matrix, timing_level + use w90_io, only: io_stopwatch, io_error + use w90_comms, only: w90comm_type implicit none + ! arguments + integer, intent(in) :: num_kpts, num_wann, timing_level, iprint, stdout + complex(kind=dp), intent(in) :: u_matrix(:, :, :) + character(len=50), intent(in) :: seedname + + ! local variables integer :: nkp, i, j, m complex(kind=dp) :: ctmp1, ctmp2 - if (timing_level > 1 .and. on_root) call io_stopwatch('wann: check_unitarity', 1) + if (timing_level > 1 .and. iprint > 0) call io_stopwatch('wann: check_unitarity', 1, stdout, seedname) do nkp = 1, num_kpts do i = 1, num_wann @@ -2526,51 +2954,57 @@ subroutine wann_check_unitarity() enddo if ((i .eq. j) .and. (abs(ctmp1 - cmplx_1) .gt. eps5)) & then - if (on_root) write (stdout, *) ' ERROR: unitariety of final U', nkp, i, j, & + if (iprint > 0) write (stdout, *) ' ERROR: unitariety of final U', nkp, i, j, & ctmp1 - call io_error('wann_check_unitarity: error 1') + call io_error('wann_check_unitarity: error 1', stdout, seedname) endif if ((i .eq. j) .and. (abs(ctmp2 - cmplx_1) .gt. eps5)) & then - if (on_root) write (stdout, *) ' ERROR: unitariety of final U', nkp, i, j, & + if (iprint > 0) write (stdout, *) ' ERROR: unitariety of final U', nkp, i, j, & ctmp2 - call io_error('wann_check_unitarity: error 2') + call io_error('wann_check_unitarity: error 2', stdout, seedname) endif if ((i .ne. j) .and. (abs(ctmp1) .gt. eps5)) then - if (on_root) write (stdout, *) ' ERROR: unitariety of final U', nkp, i, j, & + if (iprint > 0) write (stdout, *) ' ERROR: unitariety of final U', nkp, i, j, & ctmp1 - call io_error('wann_check_unitarity: error 3') + call io_error('wann_check_unitarity: error 3', stdout, seedname) endif if ((i .ne. j) .and. (abs(ctmp2) .gt. eps5)) then - if (on_root) write (stdout, *) ' ERROR: unitariety of final U', nkp, i, j, & + if (iprint > 0) write (stdout, *) ' ERROR: unitariety of final U', nkp, i, j, & ctmp2 - call io_error('wann_check_unitarity: error 4') + call io_error('wann_check_unitarity: error 4', stdout, seedname) endif enddo enddo enddo - if (timing_level > 1 .and. on_root) call io_stopwatch('wann: check_unitarity', 2) + if (timing_level > 1 .and. iprint > 0) call io_stopwatch('wann: check_unitarity', 2, stdout, seedname) return end subroutine wann_check_unitarity - !========================================! - subroutine wann_write_r2mn() - !========================================! - ! ! - ! Write seedname.r2mn file ! - ! ! - !========================================! + !================================================! + subroutine wann_write_r2mn(num_kpts, num_wann, kmesh_info, m_matrix, stdout, seedname) + !================================================! + ! + ! Write seedname.r2mn file + ! + !================================================! use w90_constants, only: dp - use w90_io, only: seedname, io_file_unit, io_error - use w90_parameters, only: num_kpts, num_wann, nntot, wb, & - m_matrix + use w90_io, only: io_file_unit, io_error + use w90_types, only: kmesh_info_type implicit none + type(kmesh_info_type), intent(in) :: kmesh_info + + integer, intent(in) :: num_kpts, num_wann + complex(kind=dp), intent(in) :: m_matrix(:, :, :, :) + integer, intent(in) :: stdout + character(len=50), intent(in) :: seedname + integer :: r2mnunit, nw1, nw2, nkp, nn real(kind=dp) :: r2ave_mn, delta @@ -2584,8 +3018,8 @@ subroutine wann_write_r2mn() delta = 0.0_dp if (nw1 .eq. nw2) delta = 1.0_dp do nkp = 1, num_kpts - do nn = 1, nntot - r2ave_mn = r2ave_mn + wb(nn)* & + do nn = 1, kmesh_info%nntot + r2ave_mn = r2ave_mn + kmesh_info%wb(nn)* & ! [GP-begin, Apr13, 2012: corrected sign inside "real"] (2.0_dp*delta - real(m_matrix(nw1, nw2, nn, nkp) + & conjg(m_matrix(nw2, nw1, nn, nkp)), kind=dp)) @@ -2600,45 +3034,51 @@ subroutine wann_write_r2mn() return -158 call io_error('Error opening file '//trim(seedname)//'.r2mn in wann_write_r2mn') +158 call io_error('Error opening file '//trim(seedname)//'.r2mn in wann_write_r2mn', stdout, seedname) end subroutine wann_write_r2mn - !========================================! - subroutine wann_svd_omega_i() - !========================================! + !================================================! + subroutine wann_svd_omega_i(num_wann, num_kpts, kmesh_info, m_matrix, print_output, stdout, seedname) + !================================================! + use w90_comms, only: w90comm_type use w90_constants, only: dp, cmplx_0 - use w90_io, only: io_stopwatch, io_error, stdout - use w90_parameters, only: num_wann, num_kpts, nntot, wb, & - m_matrix, lenconfac, length_unit, & - timing_level + use w90_io, only: io_stopwatch, io_error + use w90_types, only: kmesh_info_type, print_output_type implicit none - complex(kind=dp), allocatable :: cv1(:, :), cv2(:, :) - complex(kind=dp), allocatable :: cw1(:), cw2(:) - complex(kind=dp), allocatable :: cpad1(:) - real(kind=dp), allocatable :: singvd(:) + type(print_output_type), intent(in) :: print_output + type(kmesh_info_type), intent(in) :: kmesh_info + integer, intent(in) :: num_wann, num_kpts + integer, intent(in) :: stdout + complex(kind=dp), intent(in) :: m_matrix(:, :, :, :) + character(len=50), intent(in) :: seedname + + complex(kind=dp), allocatable :: cv1(:, :), cv2(:, :) + complex(kind=dp), allocatable :: cw1(:), cw2(:) + complex(kind=dp), allocatable :: cpad1(:) + real(kind=dp), allocatable :: singvd(:) integer :: ierr, info integer :: nkp, nn, nb, na, ind real(kind=dp) :: omt1, omt2, omt3 - if (timing_level > 1 .and. on_root) call io_stopwatch('wann: svd_omega_i', 1) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) call io_stopwatch('wann: svd_omega_i', 1, stdout, seedname) allocate (cw1(10*num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cw1 in wann_svd_omega_i') + if (ierr /= 0) call io_error('Error in allocating cw1 in wann_svd_omega_i', stdout, seedname) allocate (cw2(10*num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cw2 in wann_svd_omega_i') + if (ierr /= 0) call io_error('Error in allocating cw2 in wann_svd_omega_i', stdout, seedname) allocate (cv1(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cv1 in wann_svd_omega_i') + if (ierr /= 0) call io_error('Error in allocating cv1 in wann_svd_omega_i', stdout, seedname) allocate (cv2(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cv2 in wann_svd_omega_i') + if (ierr /= 0) call io_error('Error in allocating cv2 in wann_svd_omega_i', stdout, seedname) allocate (singvd(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating singvd in wann_svd_omega_i') + if (ierr /= 0) call io_error('Error in allocating singvd in wann_svd_omega_i', stdout, seedname) allocate (cpad1(num_wann*num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cpad1 in wann_svd_omega_i') + if (ierr /= 0) call io_error('Error in allocating cpad1 in wann_svd_omega_i', stdout, seedname) cw1 = cmplx_0; cw2 = cmplx_0; cv1 = cmplx_0; cv2 = cmplx_0; cpad1 = cmplx_0 singvd = 0.0_dp @@ -2646,7 +3086,7 @@ subroutine wann_svd_omega_i() ! singular value decomposition omt1 = 0.0_dp; omt2 = 0.0_dp; omt3 = 0.0_dp do nkp = 1, num_kpts - do nn = 1, nntot + do nn = 1, kmesh_info%nntot ind = 1 do nb = 1, num_wann do na = 1, num_wann @@ -2657,73 +3097,114 @@ subroutine wann_svd_omega_i() call zgesvd('A', 'A', num_wann, num_wann, cpad1, num_wann, singvd, cv1, & num_wann, cv2, num_wann, cw1, 10*num_wann, cw2, info) if (info .ne. 0) then - call io_error('ERROR: Singular value decomp. zgesvd failed') + call io_error('ERROR: Singular value decomp. zgesvd failed', stdout, seedname) endif do nb = 1, num_wann - omt1 = omt1 + wb(nn)*(1.0_dp - singvd(nb)**2) - omt2 = omt2 - wb(nn)*(2.0_dp*log(singvd(nb))) - omt3 = omt3 + wb(nn)*(acos(singvd(nb))**2) + omt1 = omt1 + kmesh_info%wb(nn)*(1.0_dp - singvd(nb)**2) + omt2 = omt2 - kmesh_info%wb(nn)*(2.0_dp*log(singvd(nb))) + omt3 = omt3 + kmesh_info%wb(nn)*(acos(singvd(nb))**2) enddo enddo enddo omt1 = omt1/real(num_kpts, dp) omt2 = omt2/real(num_kpts, dp) omt3 = omt3/real(num_kpts, dp) - if (on_root) then + if (print_output%iprint > 0) then write (stdout, *) ' ' write (stdout, '(2x,a,f15.9,1x,a)') 'Omega Invariant: 1-s^2 = ', & - omt1*lenconfac**2, '('//trim(length_unit)//'^2)' + omt1*print_output%lenconfac**2, '('//trim(print_output%length_unit)//'^2)' write (stdout, '(2x,a,f15.9,1x,a)') ' -2log s = ', & - omt2*lenconfac**2, '('//trim(length_unit)//'^2)' + omt2*print_output%lenconfac**2, '('//trim(print_output%length_unit)//'^2)' write (stdout, '(2x,a,f15.9,1x,a)') ' acos^2 = ', & - omt3*lenconfac**2, '('//trim(length_unit)//'^2)' + omt3*print_output%lenconfac**2, '('//trim(print_output%length_unit)//'^2)' endif deallocate (cpad1, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cpad1 in wann_svd_omega_i') + if (ierr /= 0) call io_error('Error in deallocating cpad1 in wann_svd_omega_i', stdout, seedname) deallocate (singvd, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating singvd in wann_svd_omega_i') + if (ierr /= 0) call io_error('Error in deallocating singvd in wann_svd_omega_i', stdout, seedname) deallocate (cv2, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cv2 in wann_svd_omega_i') + if (ierr /= 0) call io_error('Error in deallocating cv2 in wann_svd_omega_i', stdout, seedname) deallocate (cv1, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cv1 in wann_svd_omega_i') + if (ierr /= 0) call io_error('Error in deallocating cv1 in wann_svd_omega_i', stdout, seedname) deallocate (cw2, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cw2 in wann_svd_omega_i') + if (ierr /= 0) call io_error('Error in deallocating cw2 in wann_svd_omega_i', stdout, seedname) deallocate (cw1, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cw1 in wann_svd_omega_i') + if (ierr /= 0) call io_error('Error in deallocating cw1 in wann_svd_omega_i', stdout, seedname) - if (timing_level > 1 .and. on_root) call io_stopwatch('wann: svd_omega_i', 2) + if (print_output%timing_level > 1 .and. print_output%iprint > 0) call io_stopwatch('wann: svd_omega_i', 2, stdout, seedname) return end subroutine wann_svd_omega_i - !==================================================================! - subroutine wann_main_gamma - !==================================================================! - ! ! - ! Calculate the Unitary Rotations to give ! - ! Maximally Localised Wannier Functions ! - ! Gamma version ! - !=================================================================== + !================================================! + subroutine wann_main_gamma(atom_data, dis_manifold, exclude_bands, kmesh_info, kpt_latt, output_file, & + wann_control, omega, w90_system, print_output, wannier_data, m_matrix, & + u_matrix, u_matrix_opt, eigval, real_lattice, mp_grid, & + num_bands, num_kpts, num_wann, have_disentangled, translate_home_cell, & + seedname, stdout, comm) + !================================================! + ! + ! Calculate the Unitary Rotations to give + ! Maximally Localised Wannier Functions + ! Gamma version + !================================================ + use w90_constants, only: dp, cmplx_1, cmplx_0 - use w90_io, only: stdout, io_error, io_time, io_stopwatch - use w90_parameters, only: num_wann, num_iter, wb, & - nntot, u_matrix, m_matrix, num_kpts, iprint, & - num_print_cycles, num_dump_cycles, omega_invariant, & - param_write_chkpt, length_unit, lenconfac, & - proj_site, real_lattice, write_r2mn, guiding_centres, & - num_guide_cycles, num_no_guide_iter, timing_level, & - write_proj, have_disentangled, conv_tol, conv_window, & - wannier_centres, write_xyz, wannier_spreads, omega_total, & - omega_tilde, write_vdw_data + use w90_io, only: io_error, io_time, io_stopwatch + use w90_wannier90_types, only: wann_control_type, output_file_type, wann_omega_type + use w90_types, only: kmesh_info_type, print_output_type, & + wannier_data_type, atom_data_type, dis_manifold_type, w90_system_type + use w90_wannier90_readwrite, only: w90_wannier90_readwrite_write_chkpt use w90_utility, only: utility_frac_to_cart, utility_zgemm + use w90_comms, only: w90comm_type implicit none - type(localisation_vars) :: old_spread - type(localisation_vars) :: wann_spread + !JJ this function has not yet been pllelised + + ! arguments + type(wannier_data_type), intent(inout) :: wannier_data + type(w90comm_type), intent(in) :: comm + type(wann_control_type), intent(inout) :: wann_control + type(wann_omega_type), intent(inout) :: omega + type(w90_system_type), intent(in) :: w90_system + type(print_output_type), intent(in) :: print_output + type(kmesh_info_type), intent(in) :: kmesh_info + type(output_file_type), intent(in) :: output_file + type(dis_manifold_type), intent(in) :: dis_manifold ! needed for write_chkpt + type(atom_data_type), intent(in) :: atom_data + + integer, intent(in) :: stdout + integer, intent(in) :: num_wann + integer, intent(in) :: num_kpts + integer, intent(in) :: num_bands + integer, intent(in) :: mp_grid(3) ! needed for write_chkpt + integer, allocatable, intent(in) :: exclude_bands(:) + + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: eigval(:, :) + real(kind=dp), intent(in) :: kpt_latt(:, :) ! needed for write_chkpt + + complex(kind=dp), intent(in) :: u_matrix_opt(:, :, :) + complex(kind=dp), intent(inout) :: u_matrix(:, :, :) + complex(kind=dp), intent(inout) :: m_matrix(:, :, :, :) + + logical, intent(in) :: have_disentangled, translate_home_cell + character(len=50), intent(in) :: seedname + + ! local variables + type(localisation_vars_type) :: old_spread + type(localisation_vars_type) :: wann_spread + + integer :: counts(0:0) + integer :: displs(0:0) + real(kind=dp), allocatable :: rnkb(:, :, :) + real(kind=dp), allocatable :: ln_tmp(:, :, :) + complex(kind=dp), allocatable :: m_matrix_loc(:, :, :, :) + logical :: first_pass ! guiding centres real(kind=dp), allocatable :: rguide(:, :) @@ -2742,20 +3223,20 @@ subroutine wann_main_gamma complex(kind=dp), allocatable :: cz(:, :) real(kind=dp) :: sqwb - integer :: i, n, nn, iter, ind, ierr, iw - integer :: tnntot - logical :: lprint, ldump + integer :: i, n, nn, iter, ind, ierr, iw + integer :: tnntot + logical :: lprint, ldump real(kind=dp), allocatable :: history(:) - logical :: lconverged + logical :: lconverged - if (timing_level > 0) call io_stopwatch('wann: main_gamma', 1) + if (print_output%timing_level > 0) call io_stopwatch('wann: main_gamma', 1, stdout, seedname) first_pass = .true. ! Allocate stuff - allocate (history(conv_window), stat=ierr) - if (ierr /= 0) call io_error('Error allocating history in wann_main_gamma') + allocate (history(wann_control%conv_window), stat=ierr) + if (ierr /= 0) call io_error('Error allocating history in wann_main_gamma', stdout, seedname) !~ if (.not.allocated(ph_g)) then !~ allocate( ph_g(num_wann),stat=ierr ) @@ -2763,49 +3244,48 @@ subroutine wann_main_gamma !~ ph_g = cmplx_1 !~ endif - ! module data - allocate (rnkb(num_wann, nntot, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating rnkb in wann_main_gamma') - allocate (ln_tmp(num_wann, nntot, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ln_tmp in wann_main_gamma') + allocate (rnkb(num_wann, kmesh_info%nntot, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating rnkb in wann_main_gamma', stdout, seedname) + allocate (ln_tmp(num_wann, kmesh_info%nntot, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating ln_tmp in wann_main_gamma', stdout, seedname) rnkb = 0.0_dp - tnntot = 2*nntot + tnntot = 2*kmesh_info%nntot ! sub vars passed into other subs allocate (m_w(num_wann, num_wann, tnntot), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating m_w in wann_main_gamma') - allocate (csheet(num_wann, nntot, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating csheet in wann_main_gamma') - allocate (sheet(num_wann, nntot, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating sheet in wann_main_gamma') + if (ierr /= 0) call io_error('Error in allocating m_w in wann_main_gamma', stdout, seedname) + allocate (csheet(num_wann, kmesh_info%nntot, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating csheet in wann_main_gamma', stdout, seedname) + allocate (sheet(num_wann, kmesh_info%nntot, num_kpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating sheet in wann_main_gamma', stdout, seedname) allocate (rave(3, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating rave in wann_main_gamma') + if (ierr /= 0) call io_error('Error in allocating rave in wann_main_gamma', stdout, seedname) allocate (r2ave(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating r2ave in wann_main_gamma') + if (ierr /= 0) call io_error('Error in allocating r2ave in wann_main_gamma', stdout, seedname) allocate (rave2(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating rave2 in wann_main_gamma') + if (ierr /= 0) call io_error('Error in allocating rave2 in wann_main_gamma', stdout, seedname) allocate (rguide(3, num_wann)) - if (ierr /= 0) call io_error('Error in allocating rguide in wann_main_gamma') + if (ierr /= 0) call io_error('Error in allocating rguide in wann_main_gamma', stdout, seedname) csheet = cmplx_1 sheet = 0.0_dp; rave = 0.0_dp; r2ave = 0.0_dp; rave2 = 0.0_dp; rguide = 0.0_dp ! sub vars not passed into other subs allocate (u0(num_wann, num_wann, num_kpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating u0 in wann_main_gamma') + if (ierr /= 0) call io_error('Error in allocating u0 in wann_main_gamma', stdout, seedname) allocate (uc_rot(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating uc_rot in wann_main_gamma') + if (ierr /= 0) call io_error('Error in allocating uc_rot in wann_main_gamma', stdout, seedname) allocate (ur_rot(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating ur_rot in wann_main_gamma') + if (ierr /= 0) call io_error('Error in allocating ur_rot in wann_main_gamma', stdout, seedname) allocate (cz(num_wann, num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating cz in wann_main_gamma') + if (ierr /= 0) call io_error('Error in allocating cz in wann_main_gamma', stdout, seedname) cz = cmplx_0 ! Set up the MPI arrays for a serial run. - allocate (counts(0:0), displs(0:0), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating counts and displs in wann_main_gamma') + !allocate (counts(0:0), displs(0:0), stat=ierr) + !if (ierr /= 0) call io_error('Error in allocating counts and displs in wann_main_gamma') counts(0) = 1; displs(0) = 0 ! store original U before rotating @@ -2822,15 +3302,16 @@ subroutine wann_main_gamma !~ lguide = .false. ! guiding centres are not neede for orthorhombic systems - if (nntot .eq. 3) guiding_centres = .false. + if (kmesh_info%nntot .eq. 3) wann_control%guiding_centres%enable = .false. - if (guiding_centres) then + if (wann_control%guiding_centres%enable) then ! initialise rguide to projection centres (Cartesians in units of Ang) !~ if ( use_bloch_phases) then !~ lguide = .true. !~ else do n = 1, num_wann - call utility_frac_to_cart(proj_site(:, n), rguide(:, n), real_lattice) + call utility_frac_to_cart(wann_control%guiding_centres%centres(:, n), rguide(:, n), & + real_lattice) enddo !~ endif endif @@ -2838,7 +3319,7 @@ subroutine wann_main_gamma write (stdout, *) write (stdout, '(1x,a)') '*------------------------------- WANNIERISE ---------------------------------*' write (stdout, '(1x,a)') '+--------------------------------------------------------------------+<-- CONV' - if (lenconfac .eq. 1.0_dp) then + if (print_output%lenconfac .eq. 1.0_dp) then write (stdout, '(1x,a)') '| Iter Delta Spread RMS Gradient Spread (Ang^2) Time |<-- CONV' else write (stdout, '(1x,a)') '| Iter Delta Spread RMS Gradient Spread (Bohr^2) Time |<-- CONV' @@ -2851,30 +3332,35 @@ subroutine wann_main_gamma !~ if (nntot.gt.3) call wann_phases(csheet,sheet,rguide,irguide) !~ irguide=1 !~ endif - if (guiding_centres .and. (num_no_guide_iter .le. 0)) then - call wann_phases(csheet, sheet, rguide, irguide) + if (wann_control%guiding_centres%enable .and. (wann_control%guiding_centres%num_no_guide_iter .le. 0)) then + call wann_phases(csheet, sheet, rguide, irguide, num_wann, kmesh_info, num_kpts, m_matrix, & + .true., counts, displs, m_matrix_loc, rnkb, print_output%timing_level, & + stdout, seedname, print_output%iprint, comm) irguide = 1 endif ! weight m_matrix first to reduce number of operations ! m_w : weighted real matrix - do nn = 1, nntot - sqwb = sqrt(wb(nn)) + do nn = 1, kmesh_info%nntot + sqwb = sqrt(kmesh_info%wb(nn)) m_w(:, :, 2*nn - 1) = sqwb*real(m_matrix(:, :, nn, 1), dp) m_w(:, :, 2*nn) = sqwb*aimag(m_matrix(:, :, nn, 1)) end do ! calculate initial centers and spread - call wann_omega_gamma(m_w, csheet, sheet, rave, r2ave, rave2, wann_spread) + call wann_omega_gamma(m_w, csheet, sheet, rave, r2ave, rave2, wann_spread, num_wann, & + kmesh_info%nntot, kmesh_info%wbtot, kmesh_info%wb, kmesh_info%bk, & + omega%invariant, ln_tmp, first_pass, & + print_output%timing_level, stdout, seedname) ! public variables - omega_total = wann_spread%om_tot - omega_invariant = wann_spread%om_i - omega_tilde = wann_spread%om_d + wann_spread%om_od + omega%total = wann_spread%om_tot + omega%invariant = wann_spread%om_i + omega%tilde = wann_spread%om_d + wann_spread%om_od ! Public array of Wannier centres and spreads - wannier_centres = rave - wannier_spreads = r2ave - rave2 + wannier_data%centres = rave + wannier_data%spreads = r2ave - rave2 iter = 0 old_spread%om_tot = 0.0_dp @@ -2883,17 +3369,17 @@ subroutine wann_main_gamma write (stdout, '(1x,a78)') repeat('-', 78) write (stdout, '(1x,a)') 'Initial State' do iw = 1, num_wann - write (stdout, 1000) iw, (rave(ind, iw)*lenconfac, ind=1, 3), & - (r2ave(iw) - rave2(iw))*lenconfac**2 + write (stdout, 1000) iw, (rave(ind, iw)*print_output%lenconfac, ind=1, 3), & + (r2ave(iw) - rave2(iw))*print_output%lenconfac**2 end do - write (stdout, 1001) (sum(rave(ind, :))*lenconfac, ind=1, 3), (sum(r2ave) - sum(rave2))*lenconfac**2 + write (stdout, 1001) (sum(rave(ind, :))*print_output%lenconfac, ind=1, 3), (sum(r2ave) - sum(rave2))*print_output%lenconfac**2 write (stdout, *) write (stdout, '(1x,i6,2x,E12.3,19x,F18.10,3x,F8.2,2x,a)') & - iter, (wann_spread%om_tot - old_spread%om_tot)*lenconfac**2, & - wann_spread%om_tot*lenconfac**2, io_time(), '<-- CONV' + iter, (wann_spread%om_tot - old_spread%om_tot)*print_output%lenconfac**2, & + wann_spread%om_tot*print_output%lenconfac**2, io_time(), '<-- CONV' write (stdout, '(8x,a,F15.7,a,F15.7,a,F15.7,a)') & - 'O_D=', wann_spread%om_d*lenconfac**2, ' O_OD=', wann_spread%om_od*lenconfac**2, & - ' O_TOT=', wann_spread%om_tot*lenconfac**2, ' <-- SPRD' + 'O_D=', wann_spread%om_d*print_output%lenconfac**2, ' O_OD=', wann_spread%om_od*print_output%lenconfac**2, & + ' O_TOT=', wann_spread%om_tot*print_output%lenconfac**2, ' <-- SPRD' write (stdout, '(1x,a78)') repeat('-', 78) lconverged = .false. @@ -2906,16 +3392,17 @@ subroutine wann_main_gamma ! main iteration loop - do iter = 1, num_iter + do iter = 1, wann_control%num_iter lprint = .false. - if ((mod(iter, num_print_cycles) .eq. 0) .or. (iter .eq. 1) & - .or. (iter .eq. num_iter)) lprint = .true. + if ((mod(iter, wann_control%num_print_cycles) .eq. 0) .or. (iter .eq. 1) & + .or. (iter .eq. wann_control%num_iter)) lprint = .true. ldump = .false. - if ((num_dump_cycles .gt. 0) .and. (mod(iter, num_dump_cycles) .eq. 0)) ldump = .true. + if ((wann_control%num_dump_cycles .gt. 0) .and. & + (mod(iter, wann_control%num_dump_cycles) .eq. 0)) ldump = .true. - if (lprint .and. on_root) write (stdout, '(1x,a,i6)') 'Cycle: ', iter + if (lprint .and. print_output%iprint > 0) write (stdout, '(1x,a,i6)') 'Cycle: ', iter !~ ! initialize rguide as rave for use_bloch_phases !~ if ( (iter.gt.num_no_guide_iter) .and. lguide ) then @@ -2928,62 +3415,76 @@ subroutine wann_main_gamma !~ irguide=1 !~ endif - if (guiding_centres .and. (iter .gt. num_no_guide_iter) & - .and. (mod(iter, num_guide_cycles) .eq. 0)) then - call wann_phases(csheet, sheet, rguide, irguide, m_w) + if (wann_control%guiding_centres%enable .and. & + (iter .gt. wann_control%guiding_centres%num_no_guide_iter) & + .and. (mod(iter, wann_control%guiding_centres%num_guide_cycles) .eq. 0)) then + call wann_phases(csheet, sheet, rguide, irguide, num_wann, kmesh_info, num_kpts, m_matrix, & + .true., counts, displs, m_matrix_loc, rnkb, print_output%timing_level, & + stdout, seedname, print_output%iprint, comm, m_w) irguide = 1 endif - call internal_new_u_and_m_gamma() + call internal_new_u_and_m_gamma(m_w, ur_rot, tnntot, num_wann, print_output%timing_level, & + stdout) call wann_spread_copy(wann_spread, old_spread) ! calculate the new centers and spread - call wann_omega_gamma(m_w, csheet, sheet, rave, r2ave, rave2, wann_spread) + call wann_omega_gamma(m_w, csheet, sheet, rave, r2ave, rave2, wann_spread, num_wann, & + kmesh_info%nntot, kmesh_info%wbtot, kmesh_info%wb, kmesh_info%bk, & + omega%invariant, ln_tmp, first_pass, & + print_output%timing_level, stdout, seedname) ! print the new centers and spreads if (lprint) then do iw = 1, num_wann - write (stdout, 1000) iw, (rave(ind, iw)*lenconfac, ind=1, 3), & - (r2ave(iw) - rave2(iw))*lenconfac**2 + write (stdout, 1000) iw, (rave(ind, iw)*print_output%lenconfac, ind=1, 3), & + (r2ave(iw) - rave2(iw))*print_output%lenconfac**2 end do - write (stdout, 1001) (sum(rave(ind, :))*lenconfac, ind=1, 3), & - (sum(r2ave) - sum(rave2))*lenconfac**2 + write (stdout, 1001) (sum(rave(ind, :))*print_output%lenconfac, ind=1, 3), & + (sum(r2ave) - sum(rave2))*print_output%lenconfac**2 write (stdout, *) write (stdout, '(1x,i6,2x,E12.3,19x,F18.10,3x,F8.2,2x,a)') & - iter, (wann_spread%om_tot - old_spread%om_tot)*lenconfac**2, & - wann_spread%om_tot*lenconfac**2, io_time(), '<-- CONV' + iter, (wann_spread%om_tot - old_spread%om_tot)*print_output%lenconfac**2, & + wann_spread%om_tot*print_output%lenconfac**2, io_time(), '<-- CONV' write (stdout, '(8x,a,F15.7,a,F15.7,a,F15.7,a)') & - 'O_D=', wann_spread%om_d*lenconfac**2, & - ' O_OD=', wann_spread%om_od*lenconfac**2, & - ' O_TOT=', wann_spread%om_tot*lenconfac**2, ' <-- SPRD' + 'O_D=', wann_spread%om_d*print_output%lenconfac**2, & + ' O_OD=', wann_spread%om_od*print_output%lenconfac**2, & + ' O_TOT=', wann_spread%om_tot*print_output%lenconfac**2, ' <-- SPRD' write (stdout, '(1x,a,E15.7,a,E15.7,a,E15.7,a)') & - 'Delta: O_D=', (wann_spread%om_d - old_spread%om_d)*lenconfac**2, & - ' O_OD=', (wann_spread%om_od - old_spread%om_od)*lenconfac**2, & - ' O_TOT=', (wann_spread%om_tot - old_spread%om_tot)*lenconfac**2, ' <-- DLTA' + 'Delta: O_D=', (wann_spread%om_d - old_spread%om_d)*print_output%lenconfac**2, & + ' O_OD=', (wann_spread%om_od - old_spread%om_od)*print_output%lenconfac**2, & + ' O_TOT=', (wann_spread%om_tot - old_spread%om_tot)*print_output%lenconfac**2, ' <-- DLTA' write (stdout, '(1x,a78)') repeat('-', 78) end if ! Public array of Wannier centres and spreads - wannier_centres = rave - wannier_spreads = r2ave - rave2 + wannier_data%centres = rave + wannier_data%spreads = r2ave - rave2 ! Public variables - omega_total = wann_spread%om_tot - omega_tilde = wann_spread%om_d + wann_spread%om_od + omega%total = wann_spread%om_tot + omega%tilde = wann_spread%om_d + wann_spread%om_od if (ldump) then uc_rot(:, :) = cmplx(ur_rot(:, :), 0.0_dp, dp) call utility_zgemm(u_matrix, u0, 'N', uc_rot, 'N', num_wann) - call param_write_chkpt('postdis') + call w90_wannier90_readwrite_write_chkpt('postdis', exclude_bands, wannier_data, kmesh_info, kpt_latt, & + num_kpts, dis_manifold, num_bands, num_wann, u_matrix, u_matrix_opt, & + m_matrix, mp_grid, real_lattice, omega%invariant, & + have_disentangled, stdout, seedname) endif - if (conv_window .gt. 1) call internal_test_convergence_gamma() + if (wann_control%conv_window .gt. 1) then + call internal_test_convergence_gamma(wann_spread, old_spread, history, & + iter, lconverged, wann_control%conv_window, & + wann_control%conv_tol, stdout) + endif if (lconverged) then write (stdout, '(/13x,a,es10.3,a,i2,a)') & - '<<< Delta <', conv_tol, & - ' over ', conv_window, ' iterations >>>' + '<<< Delta <', wann_control%conv_tol, & + ' over ', wann_control%conv_window, ' iterations >>>' write (stdout, '(13x,a/)') '<<< Wannierisation convergence criteria satisfied >>>' exit endif @@ -2992,8 +3493,8 @@ subroutine wann_main_gamma ! end of the minimization loop ! update M - do nn = 1, nntot - sqwb = 1.0_dp/sqrt(wb(nn)) + do nn = 1, kmesh_info%nntot + sqwb = 1.0_dp/sqrt(kmesh_info%wb(nn)) m_matrix(:, :, nn, 1) = sqwb*cmplx(m_w(:, :, 2*nn - 1), m_w(:, :, 2*nn), dp) end do ! update U @@ -3002,78 +3503,95 @@ subroutine wann_main_gamma write (stdout, '(1x,a)') 'Final State' do iw = 1, num_wann - write (stdout, 1000) iw, (rave(ind, iw)*lenconfac, ind=1, 3), & - (r2ave(iw) - rave2(iw))*lenconfac**2 + write (stdout, 1000) iw, (rave(ind, iw)*print_output%lenconfac, ind=1, 3), & + (r2ave(iw) - rave2(iw))*print_output%lenconfac**2 end do - write (stdout, 1001) (sum(rave(ind, :))*lenconfac, ind=1, 3), & - (sum(r2ave) - sum(rave2))*lenconfac**2 + write (stdout, 1001) (sum(rave(ind, :))*print_output%lenconfac, ind=1, 3), & + (sum(r2ave) - sum(rave2))*print_output%lenconfac**2 write (stdout, *) - write (stdout, '(3x,a21,a,f15.9)') ' Spreads ('//trim(length_unit)//'^2)', & - ' Omega I = ', wann_spread%om_i*lenconfac**2 + write (stdout, '(3x,a21,a,f15.9)') ' Spreads ('//trim(print_output%length_unit)//'^2)', & + ' Omega I = ', wann_spread%om_i*print_output%lenconfac**2 write (stdout, '(3x,a,f15.9)') ' ================ Omega D = ', & - wann_spread%om_d*lenconfac**2 + wann_spread%om_d*print_output%lenconfac**2 write (stdout, '(3x,a,f15.9)') ' Omega OD = ', & - wann_spread%om_od*lenconfac**2 - write (stdout, '(3x,a21,a,f15.9)') 'Final Spread ('//trim(length_unit)//'^2)', & - ' Omega Total = ', wann_spread%om_tot*lenconfac**2 + wann_spread%om_od*print_output%lenconfac**2 + write (stdout, '(3x,a21,a,f15.9)') 'Final Spread ('//trim(print_output%length_unit)//'^2)', & + ' Omega Total = ', wann_spread%om_tot*print_output%lenconfac**2 write (stdout, '(1x,a78)') repeat('-', 78) - if (write_xyz .and. on_root) call wann_write_xyz() + if (output_file%write_xyz) then + call wann_write_xyz(translate_home_cell, num_wann, wannier_data%centres, & + real_lattice, atom_data, print_output, stdout, seedname) + endif - if (guiding_centres) call wann_phases(csheet, sheet, rguide, irguide) + if (wann_control%guiding_centres%enable) then + call wann_phases(csheet, sheet, rguide, irguide, num_wann, kmesh_info, num_kpts, m_matrix, & + .true., counts, displs, m_matrix_loc, rnkb, print_output%timing_level, & + stdout, seedname, print_output%iprint, comm) + endif ! unitarity is checked !~ call internal_check_unitarity() - call wann_check_unitarity() + call wann_check_unitarity(num_kpts, num_wann, u_matrix, print_output%timing_level, & + print_output%iprint, stdout, seedname) ! write extra info regarding omega_invariant !~ if (iprint>2) call internal_svd_omega_i() - if (iprint > 2) call wann_svd_omega_i() + if (print_output%iprint > 2) then + call wann_svd_omega_i(num_wann, num_kpts, kmesh_info, m_matrix, print_output, stdout, seedname) + endif ! write matrix elements to file !~ if (write_r2mn) call internal_write_r2mn() - if (write_r2mn) call wann_write_r2mn() + if (output_file%write_r2mn) call wann_write_r2mn(num_kpts, num_wann, kmesh_info, m_matrix, & + stdout, seedname) ! calculate and write projection of WFs on original bands in outer window - if (have_disentangled .and. write_proj) call wann_calc_projection() + if (have_disentangled .and. output_file%write_proj) & + call wann_calc_projection(num_bands, num_wann, num_kpts, u_matrix_opt, eigval, & + dis_manifold%lwindow, print_output%timing_level, print_output%iprint, & + stdout, seedname) ! aam: write data required for vdW utility - if (write_vdw_data) call wann_write_vdw_data() + if (output_file%write_vdw_data) then + call wann_write_vdw_data(num_wann, wannier_data, real_lattice, u_matrix, & + u_matrix_opt, have_disentangled, w90_system, stdout, seedname) + endif ! deallocate sub vars not passed into other subs deallocate (cz, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating cz in wann_main_gamma') + if (ierr /= 0) call io_error('Error in deallocating cz in wann_main_gamma', stdout, seedname) deallocate (ur_rot, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating ur_rot in wann_main_gamma') + if (ierr /= 0) call io_error('Error in deallocating ur_rot in wann_main_gamma', stdout, seedname) deallocate (uc_rot, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating uc_rot in wann_main_gamma') + if (ierr /= 0) call io_error('Error in deallocating uc_rot in wann_main_gamma', stdout, seedname) deallocate (u0, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating u0 in wann_main_gamma') + if (ierr /= 0) call io_error('Error in deallocating u0 in wann_main_gamma', stdout, seedname) ! deallocate sub vars passed into other subs deallocate (rguide, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating rguide in wann_main_gamma') + if (ierr /= 0) call io_error('Error in deallocating rguide in wann_main_gamma', stdout, seedname) deallocate (rave2, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating rave2 in wann_main_gamma') + if (ierr /= 0) call io_error('Error in deallocating rave2 in wann_main_gamma', stdout, seedname) deallocate (rave, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating rave in wann_main_gamma') + if (ierr /= 0) call io_error('Error in deallocating rave in wann_main_gamma', stdout, seedname) deallocate (sheet, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating sheet in wann_main_gamma') + if (ierr /= 0) call io_error('Error in deallocating sheet in wann_main_gamma', stdout, seedname) deallocate (csheet, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating csheet in wann_main_gamma') + if (ierr /= 0) call io_error('Error in deallocating csheet in wann_main_gamma', stdout, seedname) deallocate (m_w, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating m_w in wann_main_gamma') + if (ierr /= 0) call io_error('Error in deallocating m_w in wann_main_gamma', stdout, seedname) ! deallocate module data deallocate (ln_tmp, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating ln_tmp in wann_main_gamma') + if (ierr /= 0) call io_error('Error in deallocating ln_tmp in wann_main_gamma', stdout, seedname) deallocate (rnkb, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating rnkb in wann_main_gamma') + if (ierr /= 0) call io_error('Error in deallocating rnkb in wann_main_gamma', stdout, seedname) deallocate (history, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating history in wann_main_gamma') + if (ierr /= 0) call io_error('Error deallocating history in wann_main_gamma', stdout, seedname) - if (timing_level > 0) call io_stopwatch('wann: main_gamma', 2) + if (print_output%timing_level > 0) call io_stopwatch('wann: main_gamma', 2, stdout, seedname) return @@ -3085,21 +3603,31 @@ subroutine wann_main_gamma contains - !===============================================! - subroutine internal_new_u_and_m_gamma() - !===============================================! + !================================================! + subroutine internal_new_u_and_m_gamma(m_w, ur_rot, tnntot, num_wann, timing_level, stdout) + !================================================! use w90_constants, only: pi, eps10 + use w90_io, only: io_stopwatch implicit none + ! arguments + real(kind=dp), intent(inout) :: m_w(:, :, :) + real(kind=dp), intent(inout) :: ur_rot(:, :) + integer, intent(in) :: tnntot + integer, intent(in) :: num_wann + integer, intent(in) :: timing_level + integer, intent(in) :: stdout + + ! local variables real(kind=dp) :: theta, twotheta real(kind=dp) :: a11, a12, a21, a22 real(kind=dp) :: cc, ss, rtmp1, rtmp2 real(kind=dp), parameter :: pifour = 0.25_dp*pi integer :: nn, nw1, nw2, nw3 - if (timing_level > 1) call io_stopwatch('wann: main_gamma: new_u_and_m_gamma', 1) + if (timing_level > 1) call io_stopwatch('wann: main_gamma: new_u_and_m_gamma', 1, stdout, seedname) loop_nw1: do nw1 = 1, num_wann loop_nw2: do nw2 = nw1 + 1, num_wann @@ -3151,29 +3679,43 @@ subroutine internal_new_u_and_m_gamma() end do loop_nw2 end do loop_nw1 - if (timing_level > 1) call io_stopwatch('wann: main_gamma: new_u_and_m_gamma', 2) + if (timing_level > 1) call io_stopwatch('wann: main_gamma: new_u_and_m_gamma', 2, stdout, seedname) return end subroutine internal_new_u_and_m_gamma - !===============================================! - subroutine internal_test_convergence_gamma() - !===============================================! - ! ! - ! Determine whether minimisation of non-gauge- ! - ! invariant spread is converged ! - ! ! - !===============================================! + !================================================! + subroutine internal_test_convergence_gamma(wann_spread, old_spread, history, iter, lconverged, & + conv_window, conv_tol, stdout) + !================================================! + ! + ! Determine whether minimisation of non-gauge- + ! invariant spread is converged + ! + !================================================! + + use w90_io, only: io_error implicit none + ! arguments + type(localisation_vars_type), intent(in) :: wann_spread + type(localisation_vars_type), intent(in) :: old_spread + integer, intent(in) :: conv_window + integer, intent(in) :: iter + integer, intent(in) :: stdout + real(kind=dp), intent(in) :: conv_tol + real(kind=dp), intent(inout) :: history(:) + logical, intent(out) :: lconverged + + ! local real(kind=dp) :: delta_omega integer :: j, ierr real(kind=dp), allocatable :: temp_hist(:) allocate (temp_hist(conv_window), stat=ierr) - if (ierr /= 0) call io_error('Error allocating temp_hist in wann_main') + if (ierr /= 0) call io_error('Error allocating temp_hist in wann_main', stdout, seedname) delta_omega = wann_spread%om_tot - old_spread%om_tot @@ -3195,15 +3737,15 @@ subroutine internal_test_convergence_gamma() endif deallocate (temp_hist, stat=ierr) - if (ierr /= 0) call io_error('Error deallocating temp_hist in wann_main_gamma') + if (ierr /= 0) call io_error('Error deallocating temp_hist in wann_main_gamma', stdout, seedname) return end subroutine internal_test_convergence_gamma -!~ !========================================! +!~ !================================================! !~ subroutine internal_check_unitarity() -!~ !========================================! +!~ !================================================! !~ !~ implicit none !~ @@ -3253,13 +3795,13 @@ end subroutine internal_test_convergence_gamma !~ !~ end subroutine internal_check_unitarity -!~ !========================================! +!~ !================================================! !~ subroutine internal_write_r2mn() -!~ !========================================! -!~ ! ! -!~ ! Write seedname.r2mn file ! -!~ ! ! -!~ !========================================! +!~ !================================================! +!~ ! +!~ ! Write seedname.r2mn file +!~ ! +!~ !================================================! !~ use w90_io, only: seedname,io_file_unit,io_error !~ !~ implicit none @@ -3296,9 +3838,9 @@ end subroutine internal_test_convergence_gamma !~ !~ end subroutine internal_write_r2mn -!~ !========================================! +!~ !================================================! !~ subroutine internal_svd_omega_i() -!~ !========================================! +!~ !================================================! !~ !~ implicit none !~ @@ -3384,36 +3926,54 @@ end subroutine internal_test_convergence_gamma end subroutine wann_main_gamma - !==================================================================! - subroutine wann_omega_gamma(m_w, csheet, sheet, rave, r2ave, rave2, wann_spread) - !==================================================================! - ! ! - ! Calculate the Wannier Function spread ! - ! ! - !=================================================================== - use w90_parameters, only: num_wann, nntot, wbtot, wb, bk, & - omega_invariant, timing_level + !================================================! + subroutine wann_omega_gamma(m_w, csheet, sheet, rave, r2ave, rave2, wann_spread, num_wann, & + nntot, wbtot, wb, bk, omega_invariant, ln_tmp, first_pass, & + timing_level, stdout, seedname) + !================================================! + ! + ! Calculate the Wannier Function spread + ! + !================================================ + use w90_io, only: io_error, io_stopwatch implicit none - real(kind=dp), intent(in) :: m_w(:, :, :) - complex(kind=dp), intent(in) :: csheet(:, :, :) - real(kind=dp), intent(in) :: sheet(:, :, :) + ! arguments + type(localisation_vars_type), intent(out) :: wann_spread + + integer, intent(in) :: timing_level + integer, intent(in) :: stdout + integer, intent(in) :: num_wann + integer, intent(in) :: nntot + + real(kind=dp), intent(out) :: rave2(:) real(kind=dp), intent(out) :: rave(:, :) real(kind=dp), intent(out) :: r2ave(:) - real(kind=dp), intent(out) :: rave2(:) - type(localisation_vars), intent(out) :: wann_spread + real(kind=dp), intent(out) :: ln_tmp(:, :, :) + real(kind=dp), intent(in) :: wbtot + real(kind=dp), intent(in) :: wb(:) + real(kind=dp), intent(in) :: sheet(:, :, :) + real(kind=dp), intent(in) :: omega_invariant + real(kind=dp), intent(in) :: m_w(:, :, :) + real(kind=dp), intent(in) :: bk(:, :, :) + + complex(kind=dp), intent(in) :: csheet(:, :, :) + + logical, intent(inout) :: first_pass + + character(len=50), intent(in) :: seedname - !local variables + ! local variables real(kind=dp) :: summ, brn real(kind=dp), allocatable :: m_w_nn2(:) integer :: ind, nn, m, n, iw, rn, cn, ierr - if (timing_level > 1) call io_stopwatch('wann: omega_gamma', 1) + if (timing_level > 1) call io_stopwatch('wann: omega_gamma', 1, stdout, seedname) allocate (m_w_nn2(num_wann), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating m_w_nn2 in wann_omega_gamma') + if (ierr /= 0) call io_error('Error in allocating m_w_nn2 in wann_omega_gamma', stdout, seedname) if (nntot .eq. 3) then do nn = 1, nntot @@ -3487,8 +4047,7 @@ subroutine wann_omega_gamma(m_w, csheet, sheet, rave, r2ave, rave2, wann_spread) do nn = 1, nntot do n = 1, num_wann brn = sum(bk(:, nn, 1)*rave(:, n)) - wann_spread%om_d = wann_spread%om_d + wb(nn) & - *(ln_tmp(n, nn, 1) + brn)**2 + wann_spread%om_d = wann_spread%om_d + wb(nn)*(ln_tmp(n, nn, 1) + brn)**2 enddo enddo end if @@ -3496,9 +4055,10 @@ subroutine wann_omega_gamma(m_w, csheet, sheet, rave, r2ave, rave2, wann_spread) wann_spread%om_tot = wann_spread%om_i + wann_spread%om_d + wann_spread%om_od deallocate (m_w_nn2, stat=ierr) - if (ierr /= 0) call io_error('Error in deallocating m_w_nn2 in wann_omega_gamma') + if (ierr /= 0) call io_error('Error in deallocating m_w_nn2 in wann_omega_gamma', & + stdout, seedname) - if (timing_level > 1) call io_stopwatch('wann: omega_gamma', 2) + if (timing_level > 1) call io_stopwatch('wann: omega_gamma', 2, stdout, seedname) return diff --git a/src/ws_distance.F90 b/src/ws_distance.F90 index d987fe89d..46104f86c 100644 --- a/src/ws_distance.F90 +++ b/src/ws_distance.F90 @@ -12,6 +12,7 @@ ! https://github.com/wannier-developers/wannier90 ! !------------------------------------------------------------! ! ! +! ws_distance: ! Original implementation by Lorenzo Paulatto, with later ! ! modifications by Marco Gibertini, Dominik Gresch ! ! and Giovanni Pizzi ! @@ -19,32 +20,30 @@ !------------------------------------------------------------! module w90_ws_distance + !! This module computes the optimal Wigner-Seitz cell around each Wannier !! function to use for interpolation. + + ! Short documentation follows, for a longer explanation see the documentation + ! of the use_ws_distance variable in the user guide. + ! + ! Some comments: + ! 1. This computation is done independently on all processors (when run in + ! parallel). I think this shouldn't do a problem as the math is fairly simple + ! and uses data already broadcasted (integer values, and the + ! wannier_centres), but if there is the risk of having different + ! degeneracies or similar things on different MPI processors, we should + ! probably think to do the math on node 0, and then broadcast results. + use w90_constants, only: dp - use w90_parameters, only: use_ws_distance, ws_distance_tol, ws_search_size implicit none private - ! - public :: ws_translate_dist, clean_ws_translate, ws_write_vec - ! - integer, public, save, allocatable :: irdist_ws(:, :, :, :, :)!(3,ndegenx,num_wann,num_wann,nrpts) - !! The integer number of unit cells to shift Wannier function j to put its centre - !! inside the Wigner-Seitz of wannier function i. If several shifts are - !! equivalent (i.e. they take the function on the edge of the WS) they are - !! all listed. First index: xyz, second index: number of degenerate shifts, - !! third and fourth indices: i,j; fifth index: index on the R vector. - real(DP), public, save, allocatable :: crdist_ws(:, :, :, :, :)!(3,ndegenx,num_wann,num_wann,nrpts) - !! Cartesian version of irdist_ws, in angstrom - integer, public, save, allocatable :: wdist_ndeg(:, :, :)!(num_wann,num_wann,nrpts) - !! The number of equivalent vectors for each set of (i,j,R) (that is, loops on - !! the second index of irdist_ws(:,:,i,j,R) go from 1 to wdist_ndeg(i,j,R)) - ! - logical, public, save :: done_ws_distance = .false. - !! Global variable to know if the properties were already calculated, and avoid - !! recalculating them when the [[ws_translate_dist]] function is called multiple times + + public :: clean_ws_translate + public :: ws_translate_dist + public :: ws_write_vec integer, parameter :: ndegenx = 8 !! max number of unit cells that can touch @@ -52,18 +51,12 @@ module w90_ws_distance contains -! Short documentation follows, for a longer explanation see the documentation -! of the use_ws_distance variable in the user guide. -! -! Some comments: -! 1. This computation is done independently on all processors (when run in -! parallel). I think this shouldn't do a problem as the math is fairly simple -! and uses data already broadcasted (integer values, and the -! wannier_centres), but if there is the risk of having different -! degeneracies or similar things on different MPI processors, we should -! probably think to do the math on node 0, and then broadcast results. - - subroutine ws_translate_dist(nrpts, irvec, force_recompute) + !================================================! + + subroutine ws_translate_dist(ws_distance, stdout, seedname, ws_region, num_wann, & + wannier_centres, real_lattice, mp_grid, nrpts, irvec, & + force_recompute) + !================================================! !! Find the supercell translation (i.e. the translation by a integer number of !! supercell vectors, the supercell being defined by the mp_grid) that !! minimizes the distance between two given Wannier functions, i and j, @@ -72,20 +65,32 @@ subroutine ws_translate_dist(nrpts, irvec, force_recompute) !! We also look for the number of equivalent translation, that happen when w_j,R !! is on the edge of the WS of w_i,0. The results are stored in global !! arrays wdist_ndeg, irdist_ws, crdist_ws. + !================================================! - use w90_parameters, only: num_wann, wannier_centres, real_lattice, & - recip_lattice, iprint - !translation_centre_frac, automatic_translation,lenconfac - use w90_io, only: stdout, io_error - use w90_utility, only: utility_cart_to_frac, utility_frac_to_cart + use w90_io, only: io_error + use w90_utility, only: utility_cart_to_frac, utility_frac_to_cart, utility_inverse_mat + use w90_types, only: ws_region_type, ws_distance_type implicit none + type(ws_distance_type), intent(inout) :: ws_distance + type(ws_region_type), intent(in) :: ws_region + + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + integer, intent(in) :: num_wann integer, intent(in) :: nrpts integer, intent(in) :: irvec(3, nrpts) + + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: wannier_centres(:, :) + logical, optional, intent(in):: force_recompute ! set to true to force recomputing everything + character(len=50), intent(in) :: seedname + ! <<>> + real(kind=dp) :: inv_lattice(3, 3) integer :: iw, jw, ideg, ir, ierr integer :: shifts(3, ndegenx) real(DP) :: irvec_cart(3), tmp(3), tmp_frac(3), R_out(3, ndegenx) @@ -94,28 +99,29 @@ subroutine ws_translate_dist(nrpts, irvec, force_recompute) ! not be the best thing if you invoke it while the WFs are moving if (present(force_recompute)) then if (force_recompute) then - call clean_ws_translate() + call clean_ws_translate(ws_distance) endif endif - if (done_ws_distance) return - done_ws_distance = .true. + if (ws_distance%done) return + ws_distance%done = .true. if (ndegenx*num_wann*nrpts <= 0) then - call io_error("unexpected dimensions in ws_translate_dist") + call io_error("unexpected dimensions in ws_translate_dist", stdout, seedname) end if - allocate (irdist_ws(3, ndegenx, num_wann, num_wann, nrpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating irdist_ws in ws_translate_dist') - allocate (crdist_ws(3, ndegenx, num_wann, num_wann, nrpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating crdist_ws in ws_translate_dist') - allocate (wdist_ndeg(num_wann, num_wann, nrpts), stat=ierr) - if (ierr /= 0) call io_error('Error in allocating wcenter_ndeg in ws_translate_dist') + allocate (ws_distance%irdist(3, ndegenx, num_wann, num_wann, nrpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating irdist_ws in ws_translate_dist', stdout, seedname) + allocate (ws_distance%crdist(3, ndegenx, num_wann, num_wann, nrpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating crdist_ws in ws_translate_dist', stdout, seedname) + allocate (ws_distance%ndeg(num_wann, num_wann, nrpts), stat=ierr) + if (ierr /= 0) call io_error('Error in allocating wcenter_ndeg in ws_translate_dist', stdout, seedname) !translation_centre_frac = 0._dp - wdist_ndeg = 0 - irdist_ws = 0 - crdist_ws = 0 + ws_distance%ndeg = 0 + ws_distance%irdist = 0 + ws_distance%crdist = 0 + call utility_inverse_mat(real_lattice, inv_lattice) do ir = 1, nrpts do jw = 1, num_wann do iw = 1, num_wann @@ -131,34 +137,51 @@ subroutine ws_translate_dist(nrpts, irvec, force_recompute) ! later for interpolation etc. CALL R_wz_sc(-wannier_centres(:, iw) & + (irvec_cart + wannier_centres(:, jw)), (/0._dp, 0._dp, 0._dp/), & - wdist_ndeg(iw, jw, ir), R_out, shifts) - do ideg = 1, wdist_ndeg(iw, jw, ir) - irdist_ws(:, ideg, iw, jw, ir) = irvec(:, ir) + shifts(:, ideg) - tmp_frac = REAL(irdist_ws(:, ideg, iw, jw, ir), kind=dp) + ws_distance%ndeg(iw, jw, ir), R_out, shifts, mp_grid, real_lattice, & + inv_lattice, ws_region%ws_search_size, ws_region%ws_distance_tol, & + stdout, seedname) + do ideg = 1, ws_distance%ndeg(iw, jw, ir) + ws_distance%irdist(:, ideg, iw, jw, ir) = irvec(:, ir) + shifts(:, ideg) + tmp_frac = REAL(ws_distance%irdist(:, ideg, iw, jw, ir), kind=dp) CALL utility_frac_to_cart(tmp_frac, tmp, real_lattice) - crdist_ws(:, ideg, iw, jw, ir) = tmp + ws_distance%crdist(:, ideg, iw, jw, ir) = tmp enddo enddo enddo enddo end subroutine ws_translate_dist - subroutine R_wz_sc(R_in, R0, ndeg, R_out, shifts) + !================================================! + subroutine R_wz_sc(R_in, R0, ndeg, R_out, shifts, mp_grid, real_lattice, inv_lattice, & + ws_search_size, ws_distance_tol, stdout, seedname) + !================================================! !! Put R_in in the Wigner-Seitz cell centered around R0, !! and find all equivalent vectors to this (i.e., with same distance). !! Return their coordinates and the degeneracy, as well as the integer !! shifts needed to get the vector (these are always multiples of !! the mp_grid, i.e. they are supercell displacements in the large supercell) - use w90_parameters, only: real_lattice, recip_lattice, mp_grid + !================================================! + use w90_utility, only: utility_cart_to_frac, utility_frac_to_cart - use w90_io, only: stdout, io_error + use w90_io, only: io_error + implicit none + + ! arguments + integer, intent(in) :: mp_grid(3) + integer, intent(in) :: stdout + integer, intent(in) :: ws_search_size(3) + real(kind=dp), intent(in) :: real_lattice(3, 3) + real(kind=dp), intent(in) :: inv_lattice(3, 3) + real(kind=dp), intent(in) :: ws_distance_tol real(DP), intent(in) :: R_in(3) real(DP), intent(in) :: R0(3) integer, intent(out) :: ndeg real(DP), intent(out) :: R_out(3, ndegenx) integer, intent(out) :: shifts(3, ndegenx) + character(len=50), intent(in) :: seedname + ! local variables real(DP) :: R(3), R_f(3), R_in_f(3), R_bz(3), mod2_R_bz integer :: i, j, k @@ -170,7 +193,7 @@ subroutine R_wz_sc(R_in, R0, ndeg, R_out, shifts) mod2_R_bz = SUM((R_bz - R0)**2) ! ! take R_bz to cryst(frac) coord for translating - call utility_cart_to_frac(R_bz, R_in_f, recip_lattice) + call utility_cart_to_frac(R_bz, R_in_f, inv_lattice) ! In this first loop, I just look for the shortest vector that I obtain ! by trying to displace the second Wannier function by all @@ -223,7 +246,7 @@ subroutine R_wz_sc(R_in, R0, ndeg, R_out, shifts) endif ! ! take R_bz to cryst(frac) coord for translating - call utility_cart_to_frac(R_bz, R_in_f, recip_lattice) + call utility_cart_to_frac(R_bz, R_in_f, inv_lattice) do i = -ws_search_size(1) - 1, ws_search_size(1) + 1 do j = -ws_search_size(2) - 1, ws_search_size(2) + 1 @@ -236,7 +259,7 @@ subroutine R_wz_sc(R_in, R0, ndeg, R_out, shifts) if (ABS(SQRT(SUM((R - R0)**2)) - SQRT(mod2_R_bz)) < ws_distance_tol) then ndeg = ndeg + 1 IF (ndeg > ndegenx) then - call io_error("surprising ndeg, I wouldn't expect a degeneracy larger than 8...") + call io_error("surprising ndeg, I wouldn't expect a degeneracy larger than 8...", stdout, seedname) END IF R_out(:, ndeg) = R ! I return/update also the shifts. Note that I have to sum these @@ -251,23 +274,30 @@ subroutine R_wz_sc(R_in, R0, ndeg, R_out, shifts) enddo enddo enddo - !====================================================! + !================================================! end subroutine R_wz_sc - !====================================================! + !================================================! - !====================================================! - subroutine ws_write_vec(nrpts, irvec) + !================================================! + subroutine ws_write_vec(ws_distance, nrpts, irvec, num_wann, use_ws_distance, stdout, seedname) + !================================================! !! Write to file the lattice vectors of the superlattice !! to be added to R vector in seedname_hr.dat, seedname_rmn.dat, etc. !! in order to have the second Wannier function inside the WS cell !! of the first one. + !================================================! - use w90_io, only: io_error, io_stopwatch, io_file_unit, & - seedname, io_date - use w90_parameters, only: num_wann + use w90_io, only: io_error, io_stopwatch, io_file_unit, io_date + use w90_types, only: ws_distance_type implicit none + type(ws_distance_type), intent(in) :: ws_distance + integer, intent(in) :: num_wann + integer, intent(in) :: stdout + logical, intent(in) :: use_ws_distance + character(len=50), intent(in) :: seedname + integer, intent(in) :: nrpts integer, intent(in) :: irvec(3, nrpts) integer:: irpt, iw, jw, ideg, file_unit @@ -288,9 +318,9 @@ subroutine ws_write_vec(nrpts, irvec) do iw = 1, num_wann do jw = 1, num_wann write (file_unit, '(5I5)') irvec(:, irpt), iw, jw - write (file_unit, '(I5)') wdist_ndeg(iw, jw, irpt) - do ideg = 1, wdist_ndeg(iw, jw, irpt) - write (file_unit, '(5I5,2F12.6,I5)') irdist_ws(:, ideg, iw, jw, irpt) - & + write (file_unit, '(I5)') ws_distance%ndeg(iw, jw, irpt) + do ideg = 1, ws_distance%ndeg(iw, jw, irpt) + write (file_unit, '(5I5,2F12.6,I5)') ws_distance%irdist(:, ideg, iw, jw, irpt) - & irvec(:, irpt) end do end do @@ -315,19 +345,21 @@ subroutine ws_write_vec(nrpts, irvec) close (file_unit) return -101 call io_error('Error: ws_write_vec: problem opening file '//trim(seedname)//'_ws_vec.dat') - !====================================================! +101 call io_error('Error: ws_write_vec: problem opening file '//trim(seedname)//'_ws_vec.dat', stdout, seedname) + !================================================! end subroutine ws_write_vec - !====================================================! - !====================================================! - subroutine clean_ws_translate() - !====================================================! + + !================================================! + subroutine clean_ws_translate(ws_distance) + !================================================! + use w90_types, only: ws_distance_type implicit none - done_ws_distance = .false. - if (allocated(irdist_ws)) deallocate (irdist_ws) - if (allocated(wdist_ndeg)) deallocate (wdist_ndeg) - if (allocated(crdist_ws)) deallocate (crdist_ws) - !====================================================! + type(ws_distance_type), intent(inout) :: ws_distance + ws_distance%done = .false. + if (allocated(ws_distance%irdist)) deallocate (ws_distance%irdist) + if (allocated(ws_distance%ndeg)) deallocate (ws_distance%ndeg) + if (allocated(ws_distance%crdist)) deallocate (ws_distance%crdist) + !================================================! end subroutine clean_ws_translate end module w90_ws_distance diff --git a/test-suite/library-mode-test/Makefile b/test-suite/library-mode-test/Makefile index e478ea0bc..9fc36faa4 100644 --- a/test-suite/library-mode-test/Makefile +++ b/test-suite/library-mode-test/Makefile @@ -12,8 +12,18 @@ endif # Makefile.2 #COMMS = serial -ifeq ($(COMMS),mpi) -TEMP1 = -DMPI +ifeq ($(COMMS),mpi08) +TEMP1 = -DMPI -DMPI08 +TEMP2 = $(MPIF90) +else ifeq ($(COMMS),mpih) +TEMP1 = -DMPI -DMPIH +TEMP2 = $(MPIF90) +else ifeq ($(COMMS),mpi90) +TEMP1 = -DMPI -DMPI90 +TEMP2 = $(MPIF90) +else ifeq ($(COMMS),mpi) +# default to f90 style "use mpi" +TEMP1 = -DMPI -DMPI90 TEMP2 = $(MPIF90) else TEMP1 = diff --git a/test-suite/library-mode-test/test_library.F90 b/test-suite/library-mode-test/test_library.F90 index 54301e77d..66e860540 100644 --- a/test-suite/library-mode-test/test_library.F90 +++ b/test-suite/library-mode-test/test_library.F90 @@ -38,8 +38,28 @@ program test_library !! NOTE! THIS PROGRAM ONLY WORKS IN SERIAL FOR NOW !! (even if there are some stubs that could make you think !! it works in parallel...) + !! MPI initialisation is anyway needed when libwannier.a + !! is compiled in parallel + +#ifdef MPI +# if !(defined(MPI08) || defined(MPI90) || defined(MPIH)) +# error "You need to define which MPI interface you are using" +# endif +#endif + +#ifdef MPI08 + use mpi_f08 ! use f08 interface if possible +#endif +#ifdef MPI90 + use mpi ! next best, use fortran90 interface +#endif + implicit none +#ifdef MPIH + include 'mpif.h' ! worst case, use legacy interface +#endif + integer, parameter :: dp = kind(1.0d0) integer, parameter :: num_nnmax = 12 @@ -104,19 +124,20 @@ program test_library NAMELIST /PARAMS/ seed__name, mp_grid_loc, num_bands_tot, gamma_only_loc, spinors_loc, verbosity #ifdef MPI - include 'mpif.h' - call mpi_init(ierr) if (ierr .ne. 0) then - write (0, '(/a/)') '# MPI initialisation error' + write (*, *) '# MPI initialisation error' stop 1 end if - call mpi_comm_rank(mpi_comm_world, my_node_id, ierr) call mpi_comm_size(mpi_comm_world, num_nodes, ierr) if (my_node_id == 0) then - print *, "# COMPILED IN PARALLEL, RUNNING ON ", num_nodes, " NODES" + write (*, *) "# COMPILED IN PARALLEL, RUNNING ON ", num_nodes, " NODES" end if + if (num_nodes /= 1) then + write (*, *) '# libwannier (version 1) test driver should only be ran with 1 MPI process' + stop 1 + endif #else num_nodes = 1 my_node_id = 0 @@ -395,14 +416,14 @@ program test_library end if ! Broadcast -#ifdef MPI - call MPI_bcast(m_matrix_loc(1, 1, 1, 1), num_bands_loc*num_bands_loc*nntot_loc*num_kpts_loc, & - MPI_double_complex, root_id, mpi_comm_world, ierr) - if (ierr .ne. MPI_success) then - write (stdout, '(/a/)') '# Error in comms_bcast_cmplx' - stop 1 - end if -#endif +!#ifdef MPI +! call MPI_bcast(m_matrix_loc(1, 1, 1, 1), num_bands_loc*num_bands_loc*nntot_loc*num_kpts_loc, & +! MPI_double_complex, root_id, mpi_comm_world, ierr) +! if (ierr .ne. MPI_success) then +! write (stdout, '(/a/)') '# Error in comms_bcast_cmplx' +! stop 1 +! end if +!#endif if (my_node_id == root_id) then ! Read A_matrix from file wannier.amn amn_in = 100 ! Unit number @@ -440,14 +461,14 @@ program test_library close (amn_in) end if -#ifdef MPI - call MPI_bcast(a_matrix_loc(1, 1, 1), num_bands_loc*num_wann_loc*num_kpts_loc, & - MPI_double_complex, root_id, mpi_comm_world, ierr) - if (ierr .ne. MPI_success) then - write (stdout, '(/a/)') '# Error in comms_bcast_cmplx' - stop 1 - end if -#endif +!#ifdef MPI +! call MPI_bcast(a_matrix_loc(1, 1, 1), num_bands_loc*num_wann_loc*num_kpts_loc, & +! MPI_double_complex, root_id, mpi_comm_world, ierr) +! if (ierr .ne. MPI_success) then +! write (stdout, '(/a/)') '# Error in comms_bcast_cmplx' +! stop 1 +! end if +!#endif allocate (eigenvalues_loc(num_bands_loc, num_kpts_loc), stat=ierr) if (ierr /= 0) then diff --git a/utility/w90pov/src/driver.f90 b/utility/w90pov/src/driver.f90 index f444c126d..e720062dc 100644 --- a/utility/w90pov/src/driver.f90 +++ b/utility/w90pov/src/driver.f90 @@ -217,7 +217,7 @@ subroutine read_xsf(wanfun) implicit none integer, intent(in) :: wanfun - integer :: ios, iion, n, i, j, ix, iy, iz + integer :: ios, n, i, j, ix, iy, iz character(len=140) :: line, str(100) integer, parameter :: iu = 81 @@ -292,11 +292,12 @@ subroutine write_unitcell character(len=300) :: line integer :: iion, jion, i, j, ix, iy, iz, natomstmp character :: name(150)*3 - integer :: radius(150), fact + integer :: fact + real(q) :: radius(150) real(q) :: color(3, 150), dist, mid(3), rad, rdir(3) real(q), allocatable :: tmppos(:, :) character, allocatable :: tmpnam(:)*3 - real(q) :: vec1(3), vec2(3), vec3(3) + real(q) :: vec1(3), vec2(3) name(1:56) = [character(len=3) :: & 'H ', 'He', & @@ -732,7 +733,7 @@ subroutine read_infile implicit none character(len=80), parameter :: infile = 'w90pov.inp' character(len=20) :: str - integer :: i, j + integer :: i logical :: found real(q), allocatable :: tmpcol(:)