spinpwpaw/code/0040775004704100470410000000000010365432743013657 5ustar natalienataliespinpwpaw/code/IBMlib.f900100664004704100470410000000041310303710172015253 0ustar natalienatalie! subroutines for SP2 compatibility subroutine flush(unit) Integer, INTENT(IN) :: unit call flush_(unit) end subroutine function etime(tarray) Real*4 , INTENT(INOUT) :: tarray(2) Real*4 :: etime, etime_ etime=etime_(tarray) end function spinpwpaw/code/Makefile0100664004704100470410000002513110371153127015307 0ustar natalienataliePROG = pwpaw SRCS = anderson_mixing.f90 atom_data.f90 bandplot.f90 basis_lib.f90 \ btree.f90 btree_data.f90 btree_support.f90 bz_data.f90 bzint.f90 \ charges.f90 complex_lru.f90 coulomb_matrix.f90 coulomb_pack.f90 \ countbands.f90 cpusec.f90 crystal_data.f90 crystal_symmetry.f90 \ debug.f90 denvhat_pack.f90 doijmatrix.f90 doprint.f90 errorfunc.f90 \ exchange_corr.f90 fftw.f90 fileio.f90 forces.f90 gaussbzi.f90 \ gaussfunc_data.f90 gausslib.f90 genkpoints.f90 gpoints.f90 \ gradenk.f90 grrp.f90 hamfunc.f90 hamiltonian.f90 hamop.f90 hamsym.f90 \ hamvxc.f90 initatomtypes.f90 initspecificatoms.f90 \ initsystem.f90 laplacian.f90 lcao.f90 ldatom_info.f90 ldsupercell.f90 \ local_criteria_lib.f90 lrulib.f90 ltbzi.f90 mathlib.f90 mem_data.f90 \ memmgr.f90 misc.f90 mkname.f90 oinverse.f90 openfile.f90 \ options_data.f90 orbital_matrix.f90 orbital_pack.f90 paw_end.f90 \ paw_init.f90 paw_inout.f90 prepareballandstick.f90 preparepdos.f90 \ preparespindos.f90 projectors.f90 psilib.f90 pwpaw.f90 qtbzi.f90 \ read_input.f90 real_lru.f90 relax.f90 relaxsys.f90 search_sort.f90 \ solver.f90 spherical_harmonic.f90 stopwatch.f90 storedata.f90 \ strings.f90 structfact.f90 timing.f90 units.f90 vhartree_pack.f90 \ word.f90 work_mgr.f90 ylm_fact.f90 group.f rest_inv.f symgen.f \ symm_ident.f OBJS = anderson_mixing.o atom_data.o basis_lib.o btree.o \ btree_data.o btree_support.o bz_data.o bzint.o charges.o \ complex_lru.o coulomb_matrix.o coulomb_pack.o countbands.o cpusec.o \ crystal_data.o crystal_symmetry.o debug.o denvhat_pack.o doijmatrix.o \ doprint.o errorfunc.o exchange_corr.o fftw.o fileio.o forces.o \ gaussbzi.o gaussfunc_data.o gausslib.o gpoints.o \ gradenk.o grrp.o hamfunc.o hamiltonian.o hamop.o hamsym.o hamvxc.o \ initatomtypes.o initspecificatoms.o initsystem.o laplacian.o \ lcao.o ldatom_info.o ldsupercell.o local_criteria_lib.o lrulib.o \ ltbzi.o mathlib.o mem_data.o memmgr.o misc.o mkname.o oinverse.o \ openfile.o options_data.o orbital_matrix.o orbital_pack.o paw_end.o \ paw_init.o paw_inout.o \ projectors.o psilib.o pwpaw.o qtbzi.o read_input.o \ real_lru.o relax.o relaxsys.o search_sort.o solver.o \ spherical_harmonic.o stopwatch.o storedata.o strings.o structfact.o \ timing.o units.o vhartree_pack.o word.o work_mgr.o ylm_fact.o group.o \ rest_inv.o symgen.o symm_ident.o LIBOB = anderson_mixing.o atom_data.o basis_lib.o btree.o \ btree_data.o btree_support.o bz_data.o bzint.o charges.o \ complex_lru.o coulomb_matrix.o coulomb_pack.o countbands.o cpusec.o \ crystal_data.o crystal_symmetry.o debug.o denvhat_pack.o doijmatrix.o \ doprint.o errorfunc.o exchange_corr.o fftw.o fileio.o forces.o \ gaussbzi.o gaussfunc_data.o gausslib.o gpoints.o \ gradenk.o grrp.o hamfunc.o hamiltonian.o hamop.o hamsym.o hamvxc.o \ initatomtypes.o initspecificatoms.o initsystem.o laplacian.o \ lcao.o ldatom_info.o ldsupercell.o local_criteria_lib.o lrulib.o \ ltbzi.o mathlib.o mem_data.o memmgr.o misc.o mkname.o oinverse.o \ openfile.o options_data.o orbital_matrix.o orbital_pack.o paw_end.o \ paw_init.o paw_inout.o \ projectors.o psilib.o pwpaw.o qtbzi.o read_input.o \ real_lru.o relax.o relaxsys.o search_sort.o solver.o \ spherical_harmonic.o stopwatch.o storedata.o strings.o structfact.o \ timing.o units.o vhartree_pack.o word.o work_mgr.o ylm_fact.o group.o \ rest_inv.o symgen.o symm_ident.o include make.inc all: $(PROG) $(PROG): $(OBJS) $(F90) $(LDFLAGS) -o $@ $(OBJS) $(LIBS) preparepdos: preparepdos.o errorfunc.o $(F90) $(LDFLAGS) -o preparepdos preparepdos.o errorfunc.o $(LIBS) preparespindos: preparespindos.o errorfunc.o $(F90) $(LDFLAGS) -o preparespindos preparespindos.o errorfunc.o $(LIBS) prepareballandstick: prepareballandstick.o $(F90) $(LDFLAGS) -o prepareballandstick prepareballandstick.o $(LIBS) genkpoints: genkpoints.o crystal_data.o crystal_symmetry.o mathlib.o \ paw_inout.o strings.o units.o word.o atom_data.o \ bzint.o ltbzi.o qtbzi.o gaussbzi.o bz_data.o \ anderson_mixing.o gaussfunc_data.o errorfunc.o $(F90) $(LDFLAGS) -o genkpoints genkpoints.o crystal_data.o \ crystal_symmetry.o mathlib.o paw_inout.o strings.o units.o \ word.o atom_data.o bzint.o ltbzi.o qtbzi.o gaussbzi.o \ bz_data.o anderson_mixing.o gaussfunc_data.o errorfunc.o \ $(LIBS) bandplot: bandplot.o crystal_data.o mathlib.o errorfunc.o \ paw_inout.o strings.o units.o word.o bzint.o ltbzi.o\ gaussbzi.o bz_data.o qtbzi.o $(F90) $(LDFLAGS) -o bandplot bandplot.o crystal_data.o \ mathlib.o errorfunc.o paw_inout.o strings.o units.o \ word.o bzint.o ltbzi.o gaussbzi.o bz_data.o qtbzi.o \ $(LIBS) libfile: $(LIBOB) ar r libpwpaw.a $(LIBOB) compile: $(F90) $(LDFLAGS) -o $(PROG) $(OBJS) $(LIBS) clean: rm -f $(PROG) $(OBJS) *.mod bandplot genkpoints preparepdos \ preparespindos libpwpaw.a prepareballandstick .SUFFIXES: $(SUFFIXES) .f90 %.o : %.f90 $(F90) $(F90FLAGS) -c $< anderson_mixing.o: paw_inout.o atom_data.o: anderson_mixing.o gaussfunc_data.o strings.o bandplot.o: crystal_data.o mathlib.o paw_inout.o strings.o units.o word.o btree.o: btree_support.o btree_support.o: btree_data.o bzint.o: bz_data.o gaussbzi.o ltbzi.o mathlib.o qtbzi.o charges.o: atom_data.o crystal_data.o doijmatrix.o gpoints.o mathlib.o \ mem_data.o memmgr.o options_data.o paw_inout.o projectors.o \ relaxsys.o strings.o word.o complex_lru.o: fileio.o paw_inout.o coulomb_matrix.o: atom_data.o coulomb_pack.o spherical_harmonic.o \ vhartree_pack.o countbands.o: atom_data.o misc.o options_data.o paw_inout.o word.o crystal_data.o: bzint.o crystal_symmetry.o: atom_data.o crystal_data.o mathlib.o paw_inout.o debug.o: basis_lib.o fileio.o gpoints.o hamop.o mem_data.o memmgr.o \ oinverse.o paw_inout.o psilib.o search_sort.o word.o doijmatrix.o: atom_data.o options_data.o doprint.o: paw_inout.o exchange_corr.o: mathlib.o fftw.o: timing.o fileio.o: atom_data.o mem_data.o misc.o paw_inout.o forces.o: atom_data.o crystal_data.o crystal_symmetry.o gpoints.o hamiltonian.o \ mathlib.o mem_data.o memmgr.o misc.o options_data.o paw_inout.o \ projectors.o psilib.o search_sort.o spherical_harmonic.o word.o gaussbzi.o: bz_data.o options_data.o paw_inout.o gausslib.o: gaussfunc_data.o genkpoints.o: crystal_data.o crystal_symmetry.o mathlib.o paw_inout.o \ strings.o units.o word.o gpoints.o: btree.o bz_data.o crystal_data.o fftw.o mathlib.o misc.o \ options_data.o paw_inout.o word.o gradenk.o: atom_data.o crystal_data.o gpoints.o mathlib.o options_data.o \ paw_inout.o projectors.o spherical_harmonic.o grrp.o: debug.o fileio.o hamop.o mem_data.o memmgr.o paw_inout.o psilib.o \ search_sort.o hamfunc.o: atom_data.o crystal_symmetry.o gausslib.o gpoints.o mathlib.o options_data.o \ paw_inout.o hamiltonian.o: anderson_mixing.o atom_data.o basis_lib.o coulomb_pack.o \ crystal_data.o denvhat_pack.o doijmatrix.o gausslib.o gpoints.o \ hamfunc.o hamsym.o hamvxc.o laplacian.o mathlib.o mem_data.o memmgr.o \ misc.o options_data.o orbital_pack.o paw_inout.o projectors.o \ psilib.o search_sort.o spherical_harmonic.o vhartree_pack.o word.o \ work_mgr.o hamop.o: atom_data.o basis_lib.o crystal_data.o gpoints.o laplacian.o memmgr.o oinverse.o \ options_data.o paw_inout.o projectors.o psilib.o spherical_harmonic.o hamsym.o: atom_data.o basis_lib.o crystal_data.o crystal_symmetry.o gpoints.o \ mathlib.o options_data.o paw_inout.o spherical_harmonic.o hamvxc.o: atom_data.o crystal_data.o exchange_corr.o gpoints.o mathlib.o \ options_data.o paw_inout.o projectors.o spherical_harmonic.o initatomtypes.o: atom_data.o misc.o paw_inout.o initspecificatoms.o: atom_data.o misc.o paw_inout.o strings.o initsystem.o: atom_data.o bz_data.o crystal_data.o crystal_symmetry.o \ exchange_corr.o fileio.o gpoints.o hamop.o ldatom_info.o \ local_criteria_lib.o mathlib.o mem_data.o memmgr.o misc.o oinverse.o \ options_data.o paw_inout.o psilib.o relaxsys.o solver.o \ spherical_harmonic.o structfact.o ylm_fact.o laplacian.o: atom_data.o gpoints.o misc.o search_sort.o lcao.o: atom_data.o bz_data.o crystal_data.o debug.o gpoints.o hamiltonian.o \ mem_data.o memmgr.o misc.o options_data.o paw_inout.o projectors.o \ psilib.o spherical_harmonic.o word.o work_mgr.o ldatom_info.o: atom_data.o crystal_data.o denvhat_pack.o exchange_corr.o \ gausslib.o mathlib.o misc.o options_data.o paw_inout.o projectors.o \ search_sort.o vhartree_pack.o word.o ldsupercell.o: crystal_data.o ldatom_info.o mathlib.o paw_inout.o storedata.o \ strings.o units.o word.o local_criteria_lib.o: atom_data.o crystal_data.o gpoints.o paw_inout.o word.o lrulib.o: complex_lru.o real_lru.o mem_data.o: anderson_mixing.o misc.o paw_inout.o memmgr.o: anderson_mixing.o mem_data.o options_data.o paw_inout.o \ projectors.o psilib.o misc.o: timing.o word.o oinverse.o: atom_data.o crystal_data.o doijmatrix.o gpoints.o lrulib.o \ projectors.o spherical_harmonic.o structfact.o work_mgr.o ylm_fact.o openfile.o: paw_inout.o word.o orbital_matrix.o: atom_data.o denvhat_pack.o orbital_pack.o paw_inout.o \ spherical_harmonic.o word.o paw_end.o: paw_inout.o timing.o word.o paw_init.o: atom_data.o crystal_data.o exchange_corr.o local_criteria_lib.o \ mem_data.o options_data.o paw_inout.o spherical_harmonic.o paw_inout.o: strings.o units.o word.o projectors.o: atom_data.o crystal_data.o gpoints.o lrulib.o \ spherical_harmonic.o structfact.o timing.o work_mgr.o ylm_fact.o psilib.o: fileio.o mem_data.o misc.o paw_inout.o word.o pwpaw.o: mathlib.o paw_inout.o strings.o timing.o word.o read_input.o: atom_data.o charges.o crystal_data.o debug.o forces.o hamop.o \ ldatom_info.o local_criteria_lib.o mem_data.o memmgr.o options_data.o \ paw_inout.o relaxsys.o solver.o storedata.o real_lru.o: fileio.o paw_inout.o relax.o: atom_data.o basis_lib.o debug.o hamfunc.o laplacian.o mem_data.o \ options_data.o projectors.o psilib.o work_mgr.o relaxsys.o: anderson_mixing.o atom_data.o crystal_data.o crystal_symmetry.o \ forces.o gradenk.o hamop.o mem_data.o memmgr.o misc.o options_data.o \ paw_inout.o psilib.o solver.o storedata.o word.o work_mgr.o solver.o: anderson_mixing.o atom_data.o debug.o fileio.o gpoints.o grrp.o \ hamop.o lcao.o mem_data.o memmgr.o options_data.o paw_inout.o \ psilib.o relax.o search_sort.o storedata.o timing.o spherical_harmonic.o: mathlib.o misc.o storedata.o: basis_lib.o crystal_symmetry.o exchange_corr.o fileio.o \ gpoints.o grrp.o hamiltonian.o mem_data.o memmgr.o options_data.o \ paw_inout.o psilib.o search_sort.o strings.o word.o atoms.i \ symmetry.h structfact.o: atom_data.o gpoints.o lrulib.o work_mgr.o timing.o: stopwatch.o units.o: strings.o word.o: strings.o work_mgr.o: mem_data.o misc.o paw_inout.o ylm_fact.o: atom_data.o crystal_data.o gpoints.o lrulib.o \ spherical_harmonic.o work_mgr.o group.o: atoms.i rest_inv.o: atoms.i symmetry.h symgen.o: atoms.i symmetry.h spinpwpaw/code/Makefile.IBM0100664004704100470410000002534210303710172015713 0ustar natalienataliePROG = pwpaw SRCS = anderson_mixing.f90 atom_data.f90 basis_lib.f90 \ btree.f90 btree_data.f90 btree_support.f90 bz_data.f90 bzint.f90 \ charges.f90 complex_lru.f90 coulomb_matrix.f90 coulomb_pack.f90 \ countbands.f90 cpusec.f90 crystal_data.f90 crystal_symmetry.f90 \ debug.f90 denvhat_pack.f90 doijmatrix.f90 doprint.f90 errorfunc.f90 \ exchange_corr.f90 fftw.f90 fileio.f90 forces.f90 gaussbzi.f90 \ gaussfunc_data.f90 gausslib.f90 gpoints.f90 \ gradenk.f90 grrp.f90 hamiltonian.f90 initatomtypes.f90 \ initspecificatoms.f90 initsystem.f90 \ laplacian.f90 lcao.f90 \ ldatom_info.f90 ldsupercell.f90 local_criteria_lib.f90 \ lrulib.f90 ltbzi.f90 mathlib.f90 mem_data.f90 memmgr.f90 metric.f90 \ misc.f90 oinverse.f90 openfile.f90 options_data.f90 \ orbital_matrix.f90 orbital_pack.f90 paw_end.f90 paw_init.f90 \ paw_inout.f90 projectors.f90 \ psilib.f90 pwpaw.f90 qtbzi.f90 read_input.f90 real_lru.f90 relax.f90 \ relaxsys.f90 search_sort.f90 solver.f90 spherical_harmonic.f90 \ stopwatch.f90 storedata.f90 strings.f90 structfact.f90 \ timedependent.f90 timing.f90 units.f90 vhartree_pack.f90 \ word.f90 work_mgr.f90 ylm_fact.f90 group.f rest_inv.f symgen.f \ symm_ident.f IBMlib.f90 OBJS = anderson_mixing.o atom_data.o basis_lib.o btree.o \ btree_data.o btree_support.o bz_data.o bzint.o charges.o \ complex_lru.o coulomb_matrix.o coulomb_pack.o countbands.o cpusec.o \ crystal_data.o crystal_symmetry.o debug.o denvhat_pack.o doijmatrix.o \ doprint.o errorfunc.o exchange_corr.o fftw.o fileio.o forces.o \ gaussbzi.o gaussfunc_data.o gausslib.o gpoints.o \ gradenk.o grrp.o hamiltonian.o initatomtypes.o initspecificatoms.o \ initsystem.o \ laplacian.o lcao.o ldatom_info.o ldsupercell.o \ local_criteria_lib.o lrulib.o ltbzi.o mathlib.o mem_data.o memmgr.o \ metric.o misc.o oinverse.o openfile.o options_data.o orbital_matrix.o \ orbital_pack.o paw_end.o paw_init.o paw_inout.o \ projectors.o psilib.o pwpaw.o qtbzi.o read_input.o \ real_lru.o relax.o relaxsys.o search_sort.o solver.o \ spherical_harmonic.o stopwatch.o storedata.o strings.o structfact.o \ timedependent.o timing.o units.o vhartree_pack.o word.o \ work_mgr.o ylm_fact.o group.o rest_inv.o symgen.o symm_ident.o IBMlib.o LIBOB = anderson_mixing.o atom_data.o basis_lib.o btree.o \ btree_data.o btree_support.o bz_data.o bzint.o charges.o \ complex_lru.o coulomb_matrix.o coulomb_pack.o countbands.o cpusec.o \ crystal_data.o crystal_symmetry.o debug.o denvhat_pack.o doijmatrix.o \ doprint.o errorfunc.o exchange_corr.o fftw.o fileio.o forces.o \ gaussbzi.o gaussfunc_data.o gausslib.o gpoints.o \ gradenk.o grrp.o hamiltonian.o initatomtypes.o initspecificatoms.o \ initsystem.o \ laplacian.o lcao.o ldatom_info.o ldsupercell.o \ local_criteria_lib.o lrulib.o ltbzi.o mathlib.o mem_data.o memmgr.o \ metric.o misc.o oinverse.o openfile.o options_data.o orbital_matrix.o \ orbital_pack.o paw_end.o paw_init.o paw_inout.o \ projectors.o psilib.o qtbzi.o read_input.o \ real_lru.o relax.o relaxsys.o search_sort.o solver.o \ spherical_harmonic.o stopwatch.o storedata.o strings.o structfact.o \ timedependent.o timing.o units.o vhartree_pack.o word.o \ work_mgr.o ylm_fact.o group.o rest_inv.o symgen.o symm_ident.o IBMlib.o LIBS = /pub/share/lib/liblapack.a \ /pub/share/lib/libfftw.a \ /usr/lib/libessl.a CC = xlc CFLAGS = FC = xlf FFLAGS = -O3 -qsuffix=f=f -qarch=pwr3 -qtune=pwr3 -qautodbl=dbl4 -qstrict F90 = xlf90 F90FLAGS = -O3 -qsuffix=f=f90 -qarch=pwr3 -qtune=pwr3 -qautodbl=dbl4 -qstrict F90FLAGSM = -O3 -qsuffix=f=f90 -qarch=pwr3 -qtune=pwr3 -qstrict LDFLAGS = $(F90FLAGS) -bmaxdata:0x80000000 all: $(PROG) $(PROG): $(OBJS) $(F90) $(LDFLAGS) -o $@ $(OBJS) $(LIBS) preparepdos: preparepdos.o errorfunc.o $(F90) $(LDFLAGS) -o preparepdos preparepdos.o errorfunc.o $(LIBS) prepareballandstick: prepareballandstick.o $(F90) $(LDFLAGS) -o prepareballandstick prepareballandstick.o $(LIBS) genkpoints: genkpoints.o crystal_data.o crystal_symmetry.o mathlib.o \ paw_inout.o strings.o units.o word.o atom_data.o \ bzint.o ltbzi.o qtbzi.o gaussbzi.o bz_data.o \ anderson_mixing.o gaussfunc_data.o errorfunc.o IBMlib.o $(F90) $(LDFLAGS) -o genkpoints genkpoints.o crystal_data.o \ crystal_symmetry.o mathlib.o paw_inout.o strings.o units.o \ word.o atom_data.o bzint.o ltbzi.o qtbzi.o gaussbzi.o \ bz_data.o anderson_mixing.o gaussfunc_data.o errorfunc.o \ IBMlib.o $(LIBS) bandplot: bandplot.o crystal_data.o mathlib.o errorfunc.o \ paw_inout.o strings.o units.o word.o bzint.o ltbzi.o\ gaussbzi.o bz_data.o qtbzi.o IBMlib.o $(F90) $(LDFLAGS) -o bandplot bandplot.o crystal_data.o \ mathlib.o errorfunc.o paw_inout.o strings.o units.o \ word.o bzint.o ltbzi.o gaussbzi.o bz_data.o qtbzi.o IBMlib.o \ $(LIBS) libfile: $(LIBOB) ar r libpwpaw.a $(LIBOB) compile: $(F90) $(LDFLAGS) -o $(PROG) $(OBJS) $(LIBS) clean: rm -f $(PROG) *.o *.mod *.a removeX: rm -f bandplot preparepdos genkpoints prepareballandstick .SUFFIXES: $(SUFFIXES) .f90 %.o : %.f90 $(F90) $(F90FLAGS) -c $< %.o : %.f $(FC) $(FFLAGS) -c $< IBMlib.o: IBMlib.f90 $(F90) $(F90FLAGSM) -c IBMlib.f90 cpusec.o: cpusec.f90 $(F90) $(F90FLAGSM) -c cpusec.f90 stopwatch.o: stopwatch.f90 cpusec.o $(F90) $(F90FLAGSM) -c stopwatch.f90 timing.o: timing.f90 $(F90) $(F90FLAGSM) -c timing.f90 word.o: word.f90 $(F90) $(F90FLAGSM) -c word.f90 misc.o: misc.f90 $(F90) $(F90FLAGSM) -c misc.f90 anderson_mixing.o: paw_inout.o atom_data.o: anderson_mixing.o gaussfunc_data.o strings.o bandplot.o: crystal_data.o mathlib.o paw_inout.o strings.o units.o word.o btree.o: btree_support.o btree_support.o: btree_data.o bzint.o: bz_data.o gaussbzi.o ltbzi.o mathlib.o qtbzi.o charges.o: atom_data.o crystal_data.o doijmatrix.o gpoints.o mathlib.o \ mem_data.o memmgr.o paw_inout.o projectors.o relaxsys.o strings.o \ word.o complex_lru.o: fileio.o paw_inout.o coulomb_matrix.o: atom_data.o coulomb_pack.o spherical_harmonic.o \ vhartree_pack.o countbands.o: atom_data.o misc.o paw_inout.o word.o crystal_data.o: bzint.o crystal_symmetry.o: atom_data.o crystal_data.o mathlib.o paw_inout.o debug.o: basis_lib.o fileio.o gpoints.o hamiltonian.o mem_data.o memmgr.o \ oinverse.o paw_inout.o psilib.o search_sort.o word.o doijmatrix.o: atom_data.o doprint.o: paw_inout.o exchange_corr.o: mathlib.o fftw.o: timing.o fileio.o: atom_data.o mem_data.o misc.o paw_inout.o forces.o: atom_data.o crystal_data.o crystal_symmetry.o gpoints.o \ hamiltonian.o mathlib.o mem_data.o memmgr.o misc.o options_data.o \ paw_inout.o projectors.o psilib.o search_sort.o \ spherical_harmonic.o word.o gaussbzi.o: bz_data.o gausslib.o: gaussfunc_data.o genkpoints.o: crystal_data.o crystal_symmetry.o mathlib.o paw_inout.o \ strings.o units.o word.o gpoints.o: btree.o fftw.o mathlib.o misc.o options_data.o paw_inout.o word.o gradenk.o: atom_data.o crystal_data.o gpoints.o mathlib.o options_data.o \ paw_inout.o projectors.o spherical_harmonic.o grrp.o: debug.o fileio.o hamiltonian.o mem_data.o memmgr.o paw_inout.o \ psilib.o search_sort.o hamiltonian.o: anderson_mixing.o atom_data.o basis_lib.o coulomb_pack.o \ crystal_data.o crystal_symmetry.o denvhat_pack.o doijmatrix.o \ exchange_corr.o gausslib.o gpoints.o laplacian.o mathlib.o mem_data.o \ memmgr.o misc.o oinverse.o options_data.o orbital_pack.o paw_inout.o \ projectors.o psilib.o search_sort.o spherical_harmonic.o \ vhartree_pack.o word.o work_mgr.o initatomtypes.o: atom_data.o misc.o paw_inout.o initspecificatoms.o: atom_data.o misc.o paw_inout.o strings.o initsystem.o: atom_data.o bz_data.o crystal_data.o crystal_symmetry.o \ exchange_corr.o fileio.o gpoints.o hamiltonian.o ldatom_info.o \ local_criteria_lib.o mathlib.o mem_data.o memmgr.o misc.o oinverse.o \ options_data.o paw_inout.o psilib.o relaxsys.o solver.o \ spherical_harmonic.o structfact.o ylm_fact.o laplacian.o: atom_data.o gpoints.o misc.o search_sort.o lcao.o: atom_data.o bz_data.o crystal_data.o debug.o gpoints.o hamiltonian.o \ mem_data.o memmgr.o misc.o options_data.o paw_inout.o \ projectors.o psilib.o spherical_harmonic.o word.o work_mgr.o ldatom_info.o: atom_data.o crystal_data.o denvhat_pack.o exchange_corr.o \ gausslib.o mathlib.o misc.o options_data.o paw_inout.o \ projectors.o search_sort.o vhartree_pack.o word.o ldsupercell.o: crystal_data.o ldatom_info.o mathlib.o paw_inout.o storedata.o \ strings.o units.o word.o local_criteria_lib.o: atom_data.o crystal_data.o gpoints.o paw_inout.o word.o lrulib.o: complex_lru.o real_lru.o mem_data.o: anderson_mixing.o misc.o paw_inout.o memmgr.o: anderson_mixing.o mem_data.o options_data.o paw_inout.o \ projectors.o psilib.o metric.o: mathlib.o paw_inout.o misc.o: timing.o word.o oinverse.o: atom_data.o crystal_data.o doijmatrix.o gpoints.o lrulib.o \ projectors.o spherical_harmonic.o structfact.o work_mgr.o \ ylm_fact.o openfile.o: paw_inout.o word.o orbital_matrix.o: atom_data.o denvhat_pack.o orbital_pack.o paw_inout.o \ spherical_harmonic.o word.o paw_end.o: paw_inout.o timing.o word.o paw_init.o: atom_data.o crystal_data.o exchange_corr.o local_criteria_lib.o \ mem_data.o options_data.o paw_inout.o spherical_harmonic.o paw_inout.o: strings.o units.o word.o projectors.o: atom_data.o crystal_data.o gpoints.o lrulib.o \ spherical_harmonic.o structfact.o timing.o work_mgr.o ylm_fact.o psilib.o: fileio.o mem_data.o misc.o paw_inout.o word.o pwpaw.o: mathlib.o paw_inout.o strings.o timing.o word.o read_input.o: atom_data.o charges.o crystal_data.o debug.o forces.o \ hamiltonian.o ldatom_info.o local_criteria_lib.o mem_data.o memmgr.o \ options_data.o paw_inout.o relaxsys.o solver.o storedata.o real_lru.o: fileio.o paw_inout.o relax.o: atom_data.o basis_lib.o debug.o hamiltonian.o laplacian.o mem_data.o \ metric.o options_data.o projectors.o psilib.o work_mgr.o relaxsys.o: anderson_mixing.o atom_data.o crystal_data.o crystal_symmetry.o \ forces.o gradenk.o mem_data.o memmgr.o misc.o options_data.o \ paw_inout.o psilib.o solver.o storedata.o timedependent.o word.o \ work_mgr.o solver.o: anderson_mixing.o atom_data.o debug.o fileio.o gpoints.o grrp.o \ hamiltonian.o lcao.o mem_data.o memmgr.o options_data.o paw_inout.o \ psilib.o relax.o search_sort.o storedata.o timing.o spherical_harmonic.o: mathlib.o misc.o storedata.o: basis_lib.o crystal_symmetry.o exchange_corr.o fileio.o \ gpoints.o grrp.o hamiltonian.o mem_data.o memmgr.o metric.o \ options_data.o paw_inout.o psilib.o search_sort.o strings.o word.o \ atoms.i symmetry.h structfact.o: atom_data.o gpoints.o lrulib.o work_mgr.o timedependent.o: atom_data.o mem_data.o memmgr.o misc.o options_data.o \ paw_inout.o psilib.o solver.o storedata.o word.o work_mgr.o timing.o: stopwatch.o units.o: strings.o word.o: strings.o work_mgr.o: mem_data.o misc.o paw_inout.o ylm_fact.o: atom_data.o crystal_data.o gpoints.o lrulib.o \ spherical_harmonic.o work_mgr.o group.o: atoms.i rest_inv.o: atoms.i symmetry.h symgen.o: atoms.i symmetry.h spinpwpaw/code/Makefile.absoft0100664004704100470410000002625710303710172016570 0ustar natalienataliePROG = pwpaw SRCS = anderson_mixing.f90 atom_data.f90 basis_lib.f90 \ btree.f90 btree_data.f90 btree_support.f90 bz_data.f90 bzint.f90 \ charges.f90 complex_lru.f90 coulomb_matrix.f90 coulomb_pack.f90 \ countbands.f90 cpusec.f90 crystal_data.f90 crystal_symmetry.f90 \ debug.f90 denvhat_pack.f90 doijmatrix.f90 doprint.f90 errorfunc.f90 \ exchange_corr.f90 fftw.f90 fileio.f90 forces.f90 gaussbzi.f90 \ gaussfunc_data.f90 gausslib.f90 gpoints.f90 \ gradenk.f90 grrp.f90 hamiltonian.f90 initatomtypes.f90 \ initspecificatoms.f90 initsystem.f90 \ laplacian.f90 lcao.f90 \ ldatom_info.f90 ldsupercell.f90 local_criteria_lib.f90 \ lrulib.f90 ltbzi.f90 mathlib.f90 mem_data.f90 memmgr.f90 metric.f90 \ misc.f90 oinverse.f90 openfile.f90 options_data.f90 \ orbital_matrix.f90 orbital_pack.f90 paw_end.f90 paw_init.f90 \ paw_inout.f90 projectors.f90 \ psilib.f90 pwpaw.f90 qtbzi.f90 read_input.f90 real_lru.f90 relax.f90 \ relaxsys.f90 search_sort.f90 solver.f90 spherical_harmonic.f90 \ stopwatch.f90 storedata.f90 strings.f90 structfact.f90 \ timedependent.f90 timing.f90 units.f90 vhartree_pack.f90 \ word.f90 work_mgr.f90 ylm_fact.f90 group.f rest_inv.f symgen.f \ symm_ident.f OBJS = anderson_mixing.o atom_data.o basis_lib.o btree.o \ btree_data.o btree_support.o bz_data.o bzint.o charges.o \ complex_lru.o coulomb_matrix.o coulomb_pack.o countbands.o cpusec.o \ crystal_data.o crystal_symmetry.o debug.o denvhat_pack.o doijmatrix.o \ doprint.o errorfunc.o exchange_corr.o fftw.o fileio.o forces.o \ gaussbzi.o gaussfunc_data.o gausslib.o gpoints.o \ gradenk.o grrp.o hamiltonian.o initatomtypes.o initspecificatoms.o \ initsystem.o \ laplacian.o lcao.o ldatom_info.o ldsupercell.o \ local_criteria_lib.o lrulib.o ltbzi.o mathlib.o mem_data.o memmgr.o \ metric.o misc.o oinverse.o openfile.o options_data.o orbital_matrix.o \ orbital_pack.o paw_end.o paw_init.o paw_inout.o \ projectors.o psilib.o pwpaw.o qtbzi.o read_input.o \ real_lru.o relax.o relaxsys.o search_sort.o solver.o \ spherical_harmonic.o stopwatch.o storedata.o strings.o structfact.o \ timedependent.o timing.o units.o vhartree_pack.o word.o \ work_mgr.o ylm_fact.o group.o rest_inv.o symgen.o symm_ident.o LIBOB = anderson_mixing.o atom_data.o basis_lib.o btree.o \ btree_data.o btree_support.o bz_data.o bzint.o charges.o \ complex_lru.o coulomb_matrix.o coulomb_pack.o countbands.o cpusec.o \ crystal_data.o crystal_symmetry.o debug.o denvhat_pack.o doijmatrix.o \ doprint.o errorfunc.o exchange_corr.o fftw.o fileio.o forces.o \ gaussbzi.o gaussfunc_data.o gausslib.o gpoints.o \ gradenk.o grrp.o hamiltonian.o initatomtypes.o initspecificatoms.o \ initsystem.o \ laplacian.o lcao.o ldatom_info.o ldsupercell.o \ local_criteria_lib.o lrulib.o ltbzi.o mathlib.o mem_data.o memmgr.o \ metric.o misc.o oinverse.o openfile.o options_data.o orbital_matrix.o \ orbital_pack.o paw_end.o paw_init.o paw_inout.o \ projectors.o psilib.o qtbzi.o read_input.o \ real_lru.o relax.o relaxsys.o search_sort.o solver.o \ spherical_harmonic.o stopwatch.o storedata.o strings.o structfact.o \ timedependent.o timing.o units.o vhartree_pack.o word.o \ work_mgr.o ylm_fact.o group.o rest_inv.o symgen.o symm_ident.o LIBS = -lm \ /opt/absoft/lib/libU77.a \ -L/home/leia/natalie/LAPACK -llapack_absoft -lblas_absoft \ /usr/local/lib/libfftw.a ######################################################################### # # Note: These absoft flags assume that the fftw library was compiled with # the default flags (the executable names are of the form sub__) and that # the lapack source was compiled with the f77 flags: # -f -O2 -cpu:p7 -B108 ########################################################################## CC = cc CFLAGS = FC = /opt/absoft/bin/f90 #FFLAGS = -g -N113 -YCFRL=1 FFLAGS = -O2 -cpu:p7 -N113 -YCFRL=1 -YEXT_NAMES=LCS -B108 F90 = /opt/absoft/bin/f90 #F90FLAGS = -g -N113 -YCFRL=1 F90FLAGS = -O2 -cpu:p7 -N113 -YCFRL=1 -YEXT_NAMES=LCS -B108 #F90FLAGSM = F90FLAGSM = -O2 -cpu:p7 -YCFRL=1 -YEXT_NAMES=LCS -B108 LDFLAGS = $(F90FLAGS) all: $(PROG) $(PROG): $(OBJS) $(F90) $(LDFLAGS) -o $@ pwpaw.o $(LIBOB) $(LIBS) preparepdos: preparepdos.o errorfunc.o $(F90) $(LDFLAGS) -o preparepdos preparepdos.o errorfunc.o $(LIBS) prepareballandstick: prepareballandstick.o $(F90) $(LDFLAGS) -o prepareballandstick prepareballandstick.o $(LIBS) genkpoints: genkpoints.o crystal_data.o crystal_symmetry.o mathlib.o \ paw_inout.o strings.o units.o word.o atom_data.o \ bzint.o ltbzi.o qtbzi.o gaussbzi.o bz_data.o \ anderson_mixing.o gaussfunc_data.o errorfunc.o $(F90) $(LDFLAGS) -o genkpoints genkpoints.o crystal_data.o \ crystal_symmetry.o mathlib.o paw_inout.o strings.o units.o \ word.o atom_data.o bzint.o ltbzi.o qtbzi.o gaussbzi.o \ bz_data.o anderson_mixing.o gaussfunc_data.o errorfunc.o \ $(LIBS) bandplot: bandplot.o crystal_data.o mathlib.o errorfunc.o\ paw_inout.o strings.o units.o word.o bzint.o ltbzi.o\ gaussbzi.o bz_data.o qtbzi.o $(F90) $(LDFLAGS) -o bandplot bandplot.o crystal_data.o \ mathlib.o errorfunc.o paw_inout.o strings.o units.o \ word.o bzint.o ltbzi.o gaussbzi.o bz_data.o qtbzi.o \ $(LIBS) libfile: $(LIBOB) ar r libpwpaw.a $(LIBOB) compile: $(F90) $(LDFLAGS) -o $(PROG) $(OBJS) $(LIBS) clean: rm -f $(PROG) *.o *.mod *.a removeX: rm -f bandplot preparepdos genkpoints prepareballandstick .SUFFIXES: $(SUFFIXES) .f90 %.o : %.f90 $(F90) $(F90FLAGS) -c $< %.o : %.f $(FC) $(FFLAGS) -c $< cpusec.o: cpusec.f90 $(F90) $(F90FLAGSM) -c cpusec.f90 stopwatch.o: stopwatch.f90 cpusec.o $(F90) $(F90FLAGSM) -c stopwatch.f90 timing.o: timing.f90 $(F90) $(F90FLAGSM) -c timing.f90 word.o: word.f90 $(F90) $(F90FLAGSM) -c word.f90 misc.o: misc.f90 $(F90) $(F90FLAGSM) -c misc.f90 fftw.o: timing.o $(F90) $(F90FLAGS) -YEXT_NAMES=LCS -B108 -c fftw.f90 anderson_mixing.o: paw_inout.o atom_data.o: anderson_mixing.o gaussfunc_data.o strings.o bandplot.o: crystal_data.o mathlib.o paw_inout.o strings.o units.o word.o btree.o: btree_support.o btree_support.o: btree_data.o bzint.o: bz_data.o gaussbzi.o ltbzi.o mathlib.o qtbzi.o charges.o: atom_data.o crystal_data.o doijmatrix.o gpoints.o mathlib.o \ mem_data.o memmgr.o paw_inout.o projectors.o relaxsys.o strings.o \ word.o complex_lru.o: fileio.o paw_inout.o coulomb_matrix.o: atom_data.o coulomb_pack.o spherical_harmonic.o \ vhartree_pack.o countbands.o: atom_data.o misc.o paw_inout.o word.o crystal_data.o: bzint.o crystal_symmetry.o: atom_data.o crystal_data.o mathlib.o paw_inout.o debug.o: basis_lib.o fileio.o gpoints.o hamiltonian.o mem_data.o memmgr.o \ oinverse.o paw_inout.o psilib.o search_sort.o word.o doijmatrix.o: atom_data.o doprint.o: paw_inout.o exchange_corr.o: mathlib.o # fftw.o: timing.o fileio.o: atom_data.o mem_data.o misc.o paw_inout.o forces.o: atom_data.o crystal_data.o crystal_symmetry.o gpoints.o \ hamiltonian.o mathlib.o mem_data.o memmgr.o misc.o options_data.o \ paw_inout.o projectors.o psilib.o search_sort.o \ spherical_harmonic.o word.o gaussbzi.o: bz_data.o gausslib.o: gaussfunc_data.o genkpoints.o: crystal_data.o crystal_symmetry.o mathlib.o paw_inout.o \ strings.o units.o word.o gpoints.o: btree.o fftw.o mathlib.o misc.o options_data.o paw_inout.o word.o gradenk.o: atom_data.o crystal_data.o gpoints.o mathlib.o options_data.o \ paw_inout.o projectors.o spherical_harmonic.o grrp.o: debug.o fileio.o hamiltonian.o mem_data.o memmgr.o paw_inout.o \ psilib.o search_sort.o hamiltonian.o: anderson_mixing.o atom_data.o basis_lib.o coulomb_pack.o \ crystal_data.o crystal_symmetry.o denvhat_pack.o doijmatrix.o \ exchange_corr.o gausslib.o gpoints.o laplacian.o mathlib.o mem_data.o \ memmgr.o misc.o oinverse.o options_data.o orbital_pack.o paw_inout.o \ projectors.o psilib.o search_sort.o spherical_harmonic.o \ vhartree_pack.o word.o work_mgr.o initatomtypes.o: atom_data.o misc.o paw_inout.o initspecificatoms.o: atom_data.o misc.o paw_inout.o strings.o initsystem.o: atom_data.o bz_data.o crystal_data.o crystal_symmetry.o \ exchange_corr.o fileio.o gpoints.o hamiltonian.o ldatom_info.o \ local_criteria_lib.o mathlib.o mem_data.o memmgr.o misc.o oinverse.o \ options_data.o paw_inout.o psilib.o relaxsys.o solver.o \ spherical_harmonic.o structfact.o ylm_fact.o laplacian.o: atom_data.o gpoints.o misc.o search_sort.o lcao.o: atom_data.o bz_data.o crystal_data.o debug.o gpoints.o hamiltonian.o \ mem_data.o memmgr.o misc.o options_data.o paw_inout.o \ projectors.o psilib.o spherical_harmonic.o word.o work_mgr.o ldatom_info.o: atom_data.o crystal_data.o denvhat_pack.o exchange_corr.o \ gausslib.o mathlib.o misc.o options_data.o paw_inout.o \ projectors.o search_sort.o vhartree_pack.o word.o ldsupercell.o: crystal_data.o ldatom_info.o mathlib.o paw_inout.o storedata.o \ strings.o units.o word.o local_criteria_lib.o: atom_data.o crystal_data.o gpoints.o paw_inout.o word.o lrulib.o: complex_lru.o real_lru.o mem_data.o: anderson_mixing.o misc.o paw_inout.o memmgr.o: anderson_mixing.o mem_data.o options_data.o paw_inout.o \ projectors.o psilib.o metric.o: mathlib.o paw_inout.o misc.o: timing.o word.o oinverse.o: atom_data.o crystal_data.o doijmatrix.o gpoints.o lrulib.o \ projectors.o spherical_harmonic.o structfact.o work_mgr.o \ ylm_fact.o openfile.o: paw_inout.o word.o orbital_matrix.o: atom_data.o denvhat_pack.o orbital_pack.o paw_inout.o \ spherical_harmonic.o word.o paw_end.o: paw_inout.o timing.o word.o paw_init.o: atom_data.o crystal_data.o exchange_corr.o local_criteria_lib.o \ mem_data.o options_data.o paw_inout.o spherical_harmonic.o paw_inout.o: strings.o units.o word.o projectors.o: atom_data.o crystal_data.o gpoints.o lrulib.o \ spherical_harmonic.o structfact.o timing.o work_mgr.o ylm_fact.o psilib.o: fileio.o mem_data.o misc.o paw_inout.o word.o pwpaw.o: mathlib.o paw_inout.o strings.o timing.o word.o read_input.o: atom_data.o charges.o crystal_data.o debug.o forces.o \ hamiltonian.o ldatom_info.o local_criteria_lib.o mem_data.o memmgr.o \ options_data.o paw_inout.o relaxsys.o solver.o storedata.o real_lru.o: fileio.o paw_inout.o relax.o: atom_data.o basis_lib.o debug.o hamiltonian.o laplacian.o mem_data.o \ metric.o options_data.o projectors.o psilib.o work_mgr.o relaxsys.o: anderson_mixing.o atom_data.o crystal_data.o crystal_symmetry.o \ forces.o gradenk.o mem_data.o memmgr.o misc.o options_data.o \ paw_inout.o psilib.o solver.o storedata.o timedependent.o word.o \ work_mgr.o solver.o: anderson_mixing.o atom_data.o debug.o fileio.o gpoints.o grrp.o \ hamiltonian.o lcao.o mem_data.o memmgr.o options_data.o paw_inout.o \ psilib.o relax.o search_sort.o storedata.o timing.o spherical_harmonic.o: mathlib.o misc.o storedata.o: basis_lib.o crystal_symmetry.o exchange_corr.o fileio.o \ gpoints.o grrp.o hamiltonian.o mem_data.o memmgr.o metric.o \ options_data.o paw_inout.o psilib.o search_sort.o strings.o word.o \ atoms.i symmetry.h structfact.o: atom_data.o gpoints.o lrulib.o work_mgr.o timedependent.o: atom_data.o mem_data.o memmgr.o misc.o options_data.o \ paw_inout.o psilib.o solver.o storedata.o word.o work_mgr.o timing.o: stopwatch.o units.o: strings.o word.o: strings.o work_mgr.o: mem_data.o misc.o paw_inout.o ylm_fact.o: atom_data.o crystal_data.o gpoints.o lrulib.o \ spherical_harmonic.o work_mgr.o group.o: atoms.i rest_inv.o: atoms.i symmetry.h symgen.o: atoms.i symmetry.h spinpwpaw/code/Makeforlinux0100664004704100470410000002507510303710172016237 0ustar natalienataliePROG = pwpaw SRCS = anderson_mixing.f90 atom_data.f90 bandplot.f90 basis_lib.f90 \ btree.f90 btree_data.f90 btree_support.f90 bz_data.f90 bzint.f90 \ charges.f90 complex_lru.f90 coulomb_matrix.f90 coulomb_pack.f90 \ countbands.f90 cpusec.f90 crystal_data.f90 crystal_symmetry.f90 \ debug.f90 denvhat_pack.f90 doijmatrix.f90 doprint.f90 errorfunc.f90 \ exchange_corr.f90 fftw.f90 fileio.f90 forces.f90 gaussbzi.f90 \ gaussfunc_data.f90 gausslib.f90 genkpoints.f90 gpoints.f90 \ gradenk.f90 grrp.f90 hamfunc.f90 hamiltonian.f90 hamop.f90 hamsym.f90 \ hamvxc.f90 initatomtypes.f90 initspecificatoms.f90 \ initsystem.f90 laplacian.f90 lcao.f90 ldatom_info.f90 ldsupercell.f90 \ local_criteria_lib.f90 lrulib.f90 ltbzi.f90 mathlib.f90 mem_data.f90 \ memmgr.f90 misc.f90 mkname.f90 oinverse.f90 openfile.f90 \ options_data.f90 orbital_matrix.f90 orbital_pack.f90 paw_end.f90 \ paw_init.f90 paw_inout.f90 prepareballandstick.f90 preparepdos.f90 \ preparespindos.f90 projectors.f90 psilib.f90 pwpaw.f90 qtbzi.f90 \ read_input.f90 real_lru.f90 relax.f90 relaxsys.f90 search_sort.f90 \ solver.f90 spherical_harmonic.f90 stopwatch.f90 storedata.f90 \ strings.f90 structfact.f90 timing.f90 units.f90 vhartree_pack.f90 \ word.f90 work_mgr.f90 ylm_fact.f90 group.f rest_inv.f symgen.f \ symm_ident.f OBJS = anderson_mixing.o atom_data.o basis_lib.o btree.o \ btree_data.o btree_support.o bz_data.o bzint.o charges.o \ complex_lru.o coulomb_matrix.o coulomb_pack.o countbands.o cpusec.o \ crystal_data.o crystal_symmetry.o debug.o denvhat_pack.o doijmatrix.o \ doprint.o errorfunc.o exchange_corr.o fftw.o fileio.o forces.o \ gaussbzi.o gaussfunc_data.o gausslib.o gpoints.o \ gradenk.o grrp.o hamfunc.o hamiltonian.o hamop.o hamsym.o hamvxc.o \ initatomtypes.o initspecificatoms.o initsystem.o laplacian.o \ lcao.o ldatom_info.o ldsupercell.o local_criteria_lib.o lrulib.o \ ltbzi.o mathlib.o mem_data.o memmgr.o misc.o mkname.o oinverse.o \ openfile.o options_data.o orbital_matrix.o orbital_pack.o paw_end.o \ paw_init.o paw_inout.o \ projectors.o psilib.o pwpaw.o qtbzi.o read_input.o \ real_lru.o relax.o relaxsys.o search_sort.o solver.o \ spherical_harmonic.o stopwatch.o storedata.o strings.o structfact.o \ timing.o units.o vhartree_pack.o word.o work_mgr.o ylm_fact.o group.o \ rest_inv.o symgen.o symm_ident.o LIBOB = anderson_mixing.o atom_data.o basis_lib.o btree.o \ btree_data.o btree_support.o bz_data.o bzint.o charges.o \ complex_lru.o coulomb_matrix.o coulomb_pack.o countbands.o cpusec.o \ crystal_data.o crystal_symmetry.o debug.o denvhat_pack.o doijmatrix.o \ doprint.o errorfunc.o exchange_corr.o fftw.o fileio.o forces.o \ gaussbzi.o gaussfunc_data.o gausslib.o gpoints.o \ gradenk.o grrp.o hamfunc.o hamiltonian.o hamop.o hamsym.o hamvxc.o \ initatomtypes.o initspecificatoms.o initsystem.o laplacian.o \ lcao.o ldatom_info.o ldsupercell.o local_criteria_lib.o lrulib.o \ ltbzi.o mathlib.o mem_data.o memmgr.o misc.o mkname.o oinverse.o \ openfile.o options_data.o orbital_matrix.o orbital_pack.o paw_end.o \ paw_init.o paw_inout.o \ projectors.o psilib.o pwpaw.o qtbzi.o read_input.o \ real_lru.o relax.o relaxsys.o search_sort.o solver.o \ spherical_harmonic.o stopwatch.o storedata.o strings.o structfact.o \ timing.o units.o vhartree_pack.o word.o work_mgr.o ylm_fact.o group.o \ rest_inv.o symgen.o symm_ident.o include make.inc all: $(PROG) $(PROG): $(OBJS) $(F90) $(LDFLAGS) -o $@ $(OBJS) $(LIBS) preparepdos: preparepdos.o errorfunc.o $(F90) $(LDFLAGS) -o preparepdos preparepdos.o errorfunc.o $(LIBS) preparespindos: preparespindos.o errorfunc.o $(F90) $(LDFLAGS) -o preparespindos preparespindos.o errorfunc.o $(LIBS) prepareballandstick: prepareballandstick.o $(F90) $(LDFLAGS) -o prepareballandstick prepareballandstick.o $(LIBS) genkpoints: genkpoints.o crystal_data.o crystal_symmetry.o mathlib.o \ paw_inout.o strings.o units.o word.o atom_data.o \ bzint.o ltbzi.o qtbzi.o gaussbzi.o bz_data.o \ anderson_mixing.o gaussfunc_data.o errorfunc.o $(F90) $(LDFLAGS) -o genkpoints genkpoints.o crystal_data.o \ crystal_symmetry.o mathlib.o paw_inout.o strings.o units.o \ word.o atom_data.o bzint.o ltbzi.o qtbzi.o gaussbzi.o \ bz_data.o anderson_mixing.o gaussfunc_data.o errorfunc.o \ $(LIBS) bandplot: bandplot.o crystal_data.o mathlib.o errorfunc.o \ paw_inout.o strings.o units.o word.o bzint.o ltbzi.o\ gaussbzi.o bz_data.o qtbzi.o $(F90) $(LDFLAGS) -o bandplot bandplot.o crystal_data.o \ mathlib.o errorfunc.o paw_inout.o strings.o units.o \ word.o bzint.o ltbzi.o gaussbzi.o bz_data.o qtbzi.o \ $(LIBS) libfile: $(LIBOB) ar r libpwpaw.a $(LIBOB) compile: $(F90) $(LDFLAGS) -o $(PROG) $(OBJS) $(LIBS) clean: rm -f $(PROG) $(OBJS) *.mod bandplot genkpoints preparepdos \ preparespindos libpwpaw.a prepareballandstick .SUFFIXES: $(SUFFIXES) .f90 %.o : %.f90 $(F90) $(F90FLAGS) -c $< anderson_mixing.o: paw_inout.o atom_data.o: anderson_mixing.o gaussfunc_data.o strings.o bandplot.o: crystal_data.o mathlib.o paw_inout.o strings.o units.o word.o btree.o: btree_support.o btree_support.o: btree_data.o bzint.o: bz_data.o gaussbzi.o ltbzi.o mathlib.o qtbzi.o charges.o: atom_data.o crystal_data.o doijmatrix.o gpoints.o mathlib.o \ mem_data.o memmgr.o options_data.o paw_inout.o projectors.o \ relaxsys.o strings.o word.o complex_lru.o: fileio.o paw_inout.o coulomb_matrix.o: atom_data.o coulomb_pack.o spherical_harmonic.o \ vhartree_pack.o countbands.o: atom_data.o misc.o options_data.o paw_inout.o word.o crystal_data.o: bzint.o crystal_symmetry.o: atom_data.o crystal_data.o mathlib.o paw_inout.o debug.o: basis_lib.o fileio.o gpoints.o hamop.o mem_data.o memmgr.o \ oinverse.o paw_inout.o psilib.o search_sort.o word.o doijmatrix.o: atom_data.o options_data.o doprint.o: paw_inout.o exchange_corr.o: mathlib.o fftw.o: timing.o fileio.o: atom_data.o mem_data.o misc.o paw_inout.o forces.o: atom_data.o crystal_data.o crystal_symmetry.o gpoints.o hamiltonian.o \ mathlib.o mem_data.o memmgr.o misc.o options_data.o paw_inout.o \ projectors.o psilib.o search_sort.o spherical_harmonic.o word.o gaussbzi.o: bz_data.o options_data.o paw_inout.o gausslib.o: gaussfunc_data.o genkpoints.o: crystal_data.o crystal_symmetry.o mathlib.o paw_inout.o \ strings.o units.o word.o gpoints.o: btree.o fftw.o mathlib.o misc.o options_data.o paw_inout.o word.o gradenk.o: atom_data.o crystal_data.o gpoints.o mathlib.o options_data.o \ paw_inout.o projectors.o spherical_harmonic.o grrp.o: debug.o fileio.o hamop.o mem_data.o memmgr.o paw_inout.o psilib.o \ search_sort.o hamfunc.o: atom_data.o crystal_symmetry.o gausslib.o gpoints.o mathlib.o options_data.o \ paw_inout.o hamiltonian.o: anderson_mixing.o atom_data.o basis_lib.o coulomb_pack.o \ crystal_data.o denvhat_pack.o doijmatrix.o gausslib.o gpoints.o \ hamfunc.o hamsym.o hamvxc.o laplacian.o mathlib.o mem_data.o memmgr.o \ misc.o options_data.o orbital_pack.o paw_inout.o projectors.o \ psilib.o search_sort.o spherical_harmonic.o vhartree_pack.o word.o \ work_mgr.o hamop.o: atom_data.o basis_lib.o crystal_data.o gpoints.o laplacian.o memmgr.o oinverse.o \ options_data.o paw_inout.o projectors.o psilib.o spherical_harmonic.o hamsym.o: atom_data.o basis_lib.o crystal_data.o crystal_symmetry.o gpoints.o \ mathlib.o options_data.o paw_inout.o spherical_harmonic.o hamvxc.o: atom_data.o crystal_data.o exchange_corr.o gpoints.o mathlib.o \ options_data.o paw_inout.o projectors.o spherical_harmonic.o initatomtypes.o: atom_data.o misc.o paw_inout.o initspecificatoms.o: atom_data.o misc.o paw_inout.o strings.o initsystem.o: atom_data.o bz_data.o crystal_data.o crystal_symmetry.o \ exchange_corr.o fileio.o gpoints.o hamop.o ldatom_info.o \ local_criteria_lib.o mathlib.o mem_data.o memmgr.o misc.o oinverse.o \ options_data.o paw_inout.o psilib.o relaxsys.o solver.o \ spherical_harmonic.o structfact.o ylm_fact.o laplacian.o: atom_data.o gpoints.o misc.o search_sort.o lcao.o: atom_data.o bz_data.o crystal_data.o debug.o gpoints.o hamiltonian.o \ mem_data.o memmgr.o misc.o options_data.o paw_inout.o projectors.o \ psilib.o spherical_harmonic.o word.o work_mgr.o ldatom_info.o: atom_data.o crystal_data.o denvhat_pack.o exchange_corr.o \ gausslib.o mathlib.o misc.o options_data.o paw_inout.o projectors.o \ search_sort.o vhartree_pack.o word.o ldsupercell.o: crystal_data.o ldatom_info.o mathlib.o paw_inout.o storedata.o \ strings.o units.o word.o local_criteria_lib.o: atom_data.o crystal_data.o gpoints.o paw_inout.o word.o lrulib.o: complex_lru.o real_lru.o mem_data.o: anderson_mixing.o misc.o paw_inout.o memmgr.o: anderson_mixing.o mem_data.o options_data.o paw_inout.o \ projectors.o psilib.o misc.o: timing.o word.o oinverse.o: atom_data.o crystal_data.o doijmatrix.o gpoints.o lrulib.o \ projectors.o spherical_harmonic.o structfact.o work_mgr.o ylm_fact.o openfile.o: paw_inout.o word.o orbital_matrix.o: atom_data.o denvhat_pack.o orbital_pack.o paw_inout.o \ spherical_harmonic.o word.o paw_end.o: paw_inout.o timing.o word.o paw_init.o: atom_data.o crystal_data.o exchange_corr.o local_criteria_lib.o \ mem_data.o options_data.o paw_inout.o spherical_harmonic.o paw_inout.o: strings.o units.o word.o projectors.o: atom_data.o crystal_data.o gpoints.o lrulib.o \ spherical_harmonic.o structfact.o timing.o work_mgr.o ylm_fact.o psilib.o: fileio.o mem_data.o misc.o paw_inout.o word.o pwpaw.o: mathlib.o paw_inout.o strings.o timing.o word.o read_input.o: atom_data.o charges.o crystal_data.o debug.o forces.o hamop.o \ ldatom_info.o local_criteria_lib.o mem_data.o memmgr.o options_data.o \ paw_inout.o relaxsys.o solver.o storedata.o real_lru.o: fileio.o paw_inout.o relax.o: atom_data.o basis_lib.o debug.o hamfunc.o laplacian.o mem_data.o \ options_data.o projectors.o psilib.o work_mgr.o relaxsys.o: anderson_mixing.o atom_data.o crystal_data.o crystal_symmetry.o \ forces.o gradenk.o hamop.o mem_data.o memmgr.o misc.o options_data.o \ paw_inout.o psilib.o solver.o storedata.o word.o work_mgr.o solver.o: anderson_mixing.o atom_data.o debug.o fileio.o gpoints.o grrp.o \ hamop.o lcao.o mem_data.o memmgr.o options_data.o paw_inout.o \ psilib.o relax.o search_sort.o storedata.o timing.o spherical_harmonic.o: mathlib.o misc.o storedata.o: basis_lib.o crystal_symmetry.o exchange_corr.o fileio.o \ gpoints.o grrp.o hamiltonian.o mem_data.o memmgr.o options_data.o \ paw_inout.o psilib.o search_sort.o strings.o word.o atoms.i \ symmetry.h structfact.o: atom_data.o gpoints.o lrulib.o work_mgr.o timing.o: stopwatch.o units.o: strings.o word.o: strings.o work_mgr.o: mem_data.o misc.o paw_inout.o ylm_fact.o: atom_data.o crystal_data.o gpoints.o lrulib.o \ spherical_harmonic.o work_mgr.o group.o: atoms.i rest_inv.o: atoms.i symmetry.h symgen.o: atoms.i symmetry.h spinpwpaw/code/Makeforlinux.0525050100664004704100470410000002427110303710172016773 0ustar natalienataliePROG = pwpaw SRCS = anderson_mixing.f90 atom_data.f90 bandplot.f90 basis_lib.f90 \ btree.f90 btree_data.f90 btree_support.f90 bz_data.f90 bzint.f90 \ charges.f90 complex_lru.f90 coulomb_matrix.f90 coulomb_pack.f90 \ countbands.f90 cpusec.f90 crystal_data.f90 crystal_symmetry.f90 \ debug.f90 denvhat_pack.f90 doijmatrix.f90 doprint.f90 errorfunc.f90 \ exchange_corr.f90 fftw.f90 fileio.f90 forces.f90 gaussbzi.f90 \ gaussfunc_data.f90 gausslib.f90 genkpoints.f90 gpoints.f90 \ gradenk.f90 grrp.f90 hamiltonian.f90 IBMlib.f90 initatomtypes.f90 \ initspecificatoms.f90 initsystem.f90 laplacian.f90 lcao.f90 \ ldatom_info.f90 ldsupercell.f90 local_criteria_lib.f90 \ lrulib.f90 ltbzi.f90 mathlib.f90 mem_data.f90 memmgr.f90 misc.f90 \ mkname.f90 oinverse.f90 openfile.f90 options_data.f90 \ orbital_matrix.f90 orbital_pack.f90 paw_end.f90 paw_init.f90 \ paw_inout.f90 prepareballandstick.f90 preparepdos.f90 \ preparespindos.f90 projectors.f90 psilib.f90 pwpaw.f90 qtbzi.f90 \ read_input.f90 real_lru.f90 relax.f90 relaxsys.f90 search_sort.f90 \ solver.f90 spherical_harmonic.f90 stopwatch.f90 storedata.f90 \ strings.f90 structfact.f90 timing.f90 units.f90 vhartree_pack.f90 \ word.f90 work_mgr.f90 ylm_fact.f90 group.f rest_inv.f symgen.f \ symm_ident.f OBJS = anderson_mixing.o atom_data.o basis_lib.o btree.o \ btree_data.o btree_support.o bz_data.o bzint.o charges.o \ complex_lru.o coulomb_matrix.o coulomb_pack.o countbands.o cpusec.o \ crystal_data.o crystal_symmetry.o debug.o denvhat_pack.o doijmatrix.o \ doprint.o errorfunc.o exchange_corr.o fftw.o fileio.o forces.o \ gaussbzi.o gaussfunc_data.o gausslib.o gpoints.o \ gradenk.o grrp.o hamiltonian.o initatomtypes.o \ initspecificatoms.o initsystem.o laplacian.o lcao.o ldatom_info.o \ ldsupercell.o local_criteria_lib.o lrulib.o ltbzi.o mathlib.o \ mem_data.o memmgr.o misc.o mkname.o oinverse.o openfile.o \ options_data.o orbital_matrix.o orbital_pack.o paw_end.o paw_init.o \ paw_inout.o \ projectors.o psilib.o pwpaw.o qtbzi.o read_input.o real_lru.o relax.o \ relaxsys.o search_sort.o solver.o spherical_harmonic.o stopwatch.o \ storedata.o strings.o structfact.o timing.o units.o vhartree_pack.o \ word.o work_mgr.o ylm_fact.o group.o rest_inv.o symgen.o symm_ident.o LBOB = anderson_mixing.o atom_data.o bandplot.o basis_lib.o btree.o \ btree_data.o btree_support.o bz_data.o bzint.o charges.o \ complex_lru.o coulomb_matrix.o coulomb_pack.o countbands.o cpusec.o \ crystal_data.o crystal_symmetry.o debug.o denvhat_pack.o doijmatrix.o \ doprint.o errorfunc.o exchange_corr.o fftw.o fileio.o forces.o \ gaussbzi.o gaussfunc_data.o gausslib.o gpoints.o \ gradenk.o grrp.o hamiltonian.o initatomtypes.o \ initspecificatoms.o initsystem.o laplacian.o lcao.o ldatom_info.o \ ldsupercell.o local_criteria_lib.o lrulib.o ltbzi.o mathlib.o \ mem_data.o memmgr.o misc.o mkname.o oinverse.o openfile.o \ options_data.o orbital_matrix.o orbital_pack.o paw_end.o paw_init.o \ paw_inout.o \ projectors.o psilib.o pwpaw.o qtbzi.o read_input.o real_lru.o relax.o \ relaxsys.o search_sort.o solver.o spherical_harmonic.o stopwatch.o \ storedata.o strings.o structfact.o timing.o units.o vhartree_pack.o \ word.o work_mgr.o ylm_fact.o group.o rest_inv.o symgen.o symm_ident.o include make.inc all: $(PROG) $(PROG): $(OBJS) $(F90) $(LDFLAGS) -o $@ $(OBJS) $(LIBS) preparepdos: preparepdos.o errorfunc.o $(F90) $(LDFLAGS) -o preparepdos preparepdos.o errorfunc.o $(LIBS) preparespindos: preparespindos.o errorfunc.o $(F90) $(LDFLAGS) -o preparespindos preparespindos.o errorfunc.o $(LIBS) prepareballandstick: prepareballandstick.o $(F90) $(LDFLAGS) -o prepareballandstick prepareballandstick.o $(LIBS) genkpoints: genkpoints.o crystal_data.o crystal_symmetry.o mathlib.o \ paw_inout.o strings.o units.o word.o atom_data.o \ bzint.o ltbzi.o qtbzi.o gaussbzi.o bz_data.o \ anderson_mixing.o gaussfunc_data.o errorfunc.o $(F90) $(LDFLAGS) -o genkpoints genkpoints.o crystal_data.o \ crystal_symmetry.o mathlib.o paw_inout.o strings.o units.o \ word.o atom_data.o bzint.o ltbzi.o qtbzi.o gaussbzi.o \ bz_data.o anderson_mixing.o gaussfunc_data.o errorfunc.o \ $(LIBS) bandplot: bandplot.o crystal_data.o mathlib.o errorfunc.o \ paw_inout.o strings.o units.o word.o bzint.o ltbzi.o\ gaussbzi.o bz_data.o qtbzi.o $(F90) $(LDFLAGS) -o bandplot bandplot.o crystal_data.o \ mathlib.o errorfunc.o paw_inout.o strings.o units.o \ word.o bzint.o ltbzi.o gaussbzi.o bz_data.o qtbzi.o \ $(LIBS) libfile: $(LIBOB) ar r libpwpaw.a $(LIBOB) compile: $(F90) $(LDFLAGS) -o $(PROG) $(OBJS) $(LIBS) clean: rm -f $(PROG) $(OBJS) *.mod *.o *.std core.* bandplot preparepdos \ preparespindos prepareballandstick genkpoints .SUFFIXES: $(SUFFIXES) .f90 %.o : %.f90 $(F90) $(F90FLAGS) -c $< anderson_mixing.o: paw_inout.o atom_data.o: anderson_mixing.o gaussfunc_data.o strings.o bandplot.o: crystal_data.o mathlib.o paw_inout.o strings.o units.o word.o btree.o: btree_support.o btree_support.o: btree_data.o bzint.o: bz_data.o gaussbzi.o ltbzi.o mathlib.o qtbzi.o charges.o: atom_data.o crystal_data.o doijmatrix.o gpoints.o mathlib.o \ mem_data.o memmgr.o options_data.o paw_inout.o projectors.o \ relaxsys.o strings.o word.o complex_lru.o: fileio.o paw_inout.o coulomb_matrix.o: atom_data.o coulomb_pack.o spherical_harmonic.o \ vhartree_pack.o countbands.o: atom_data.o misc.o options_data.o paw_inout.o word.o crystal_data.o: bzint.o crystal_symmetry.o: atom_data.o crystal_data.o mathlib.o paw_inout.o debug.o: basis_lib.o fileio.o gpoints.o hamiltonian.o mem_data.o memmgr.o \ oinverse.o paw_inout.o psilib.o search_sort.o word.o doijmatrix.o: atom_data.o options_data.o doprint.o: paw_inout.o exchange_corr.o: mathlib.o fftw.o: timing.o fileio.o: atom_data.o mem_data.o misc.o paw_inout.o forces.o: atom_data.o crystal_data.o crystal_symmetry.o gpoints.o \ hamiltonian.o mathlib.o mem_data.o memmgr.o misc.o options_data.o \ paw_inout.o projectors.o psilib.o search_sort.o spherical_harmonic.o \ word.o gaussbzi.o: bz_data.o options_data.o paw_inout.o gausslib.o: gaussfunc_data.o genkpoints.o: crystal_data.o crystal_symmetry.o mathlib.o paw_inout.o \ strings.o units.o word.o gpoints.o: btree.o fftw.o mathlib.o misc.o options_data.o paw_inout.o word.o gradenk.o: atom_data.o crystal_data.o gpoints.o mathlib.o options_data.o \ paw_inout.o projectors.o spherical_harmonic.o grrp.o: debug.o fileio.o hamiltonian.o mem_data.o memmgr.o paw_inout.o \ psilib.o search_sort.o hamiltonian.o: anderson_mixing.o atom_data.o basis_lib.o coulomb_pack.o \ crystal_data.o crystal_symmetry.o denvhat_pack.o doijmatrix.o \ exchange_corr.o gausslib.o gpoints.o laplacian.o mathlib.o mem_data.o \ memmgr.o misc.o oinverse.o options_data.o orbital_pack.o paw_inout.o \ projectors.o psilib.o search_sort.o spherical_harmonic.o \ vhartree_pack.o word.o work_mgr.o initatomtypes.o: atom_data.o misc.o paw_inout.o initspecificatoms.o: atom_data.o misc.o paw_inout.o strings.o initsystem.o: atom_data.o bz_data.o crystal_data.o crystal_symmetry.o \ exchange_corr.o fileio.o gpoints.o hamiltonian.o ldatom_info.o \ local_criteria_lib.o mathlib.o mem_data.o memmgr.o misc.o oinverse.o \ options_data.o paw_inout.o psilib.o relaxsys.o solver.o \ spherical_harmonic.o structfact.o ylm_fact.o laplacian.o: atom_data.o gpoints.o misc.o search_sort.o lcao.o: atom_data.o bz_data.o crystal_data.o debug.o gpoints.o hamiltonian.o \ mem_data.o memmgr.o misc.o options_data.o paw_inout.o projectors.o \ psilib.o spherical_harmonic.o word.o work_mgr.o ldatom_info.o: atom_data.o crystal_data.o denvhat_pack.o exchange_corr.o \ gausslib.o mathlib.o misc.o options_data.o paw_inout.o projectors.o \ search_sort.o vhartree_pack.o word.o ldsupercell.o: crystal_data.o ldatom_info.o mathlib.o paw_inout.o storedata.o \ strings.o units.o word.o local_criteria_lib.o: atom_data.o crystal_data.o gpoints.o paw_inout.o word.o lrulib.o: complex_lru.o real_lru.o mem_data.o: anderson_mixing.o misc.o paw_inout.o memmgr.o: anderson_mixing.o mem_data.o options_data.o paw_inout.o \ projectors.o psilib.o misc.o: timing.o word.o oinverse.o: atom_data.o crystal_data.o doijmatrix.o gpoints.o lrulib.o \ projectors.o spherical_harmonic.o structfact.o work_mgr.o ylm_fact.o openfile.o: paw_inout.o word.o orbital_matrix.o: atom_data.o denvhat_pack.o orbital_pack.o paw_inout.o \ spherical_harmonic.o word.o paw_end.o: paw_inout.o timing.o word.o paw_init.o: atom_data.o crystal_data.o exchange_corr.o local_criteria_lib.o \ mem_data.o options_data.o paw_inout.o spherical_harmonic.o paw_inout.o: strings.o units.o word.o projectors.o: atom_data.o crystal_data.o gpoints.o lrulib.o \ spherical_harmonic.o structfact.o timing.o work_mgr.o ylm_fact.o psilib.o: fileio.o mem_data.o misc.o paw_inout.o word.o pwpaw.o: mathlib.o paw_inout.o strings.o timing.o word.o read_input.o: atom_data.o charges.o crystal_data.o debug.o forces.o \ hamiltonian.o ldatom_info.o local_criteria_lib.o mem_data.o memmgr.o \ options_data.o paw_inout.o relaxsys.o solver.o storedata.o real_lru.o: fileio.o paw_inout.o relax.o: atom_data.o basis_lib.o debug.o hamiltonian.o laplacian.o mem_data.o \ options_data.o projectors.o psilib.o work_mgr.o relaxsys.o: anderson_mixing.o atom_data.o crystal_data.o crystal_symmetry.o \ forces.o gradenk.o hamiltonian.o mem_data.o memmgr.o misc.o \ options_data.o paw_inout.o psilib.o solver.o storedata.o word.o \ work_mgr.o solver.o: anderson_mixing.o atom_data.o debug.o fileio.o gpoints.o grrp.o \ hamiltonian.o lcao.o mem_data.o memmgr.o options_data.o paw_inout.o \ psilib.o relax.o search_sort.o storedata.o timing.o spherical_harmonic.o: mathlib.o misc.o storedata.o: basis_lib.o crystal_symmetry.o exchange_corr.o fileio.o \ gpoints.o grrp.o hamiltonian.o mem_data.o memmgr.o options_data.o \ paw_inout.o psilib.o search_sort.o strings.o word.o atoms.i \ symmetry.h structfact.o: atom_data.o gpoints.o lrulib.o work_mgr.o timing.o: stopwatch.o units.o: strings.o word.o: strings.o work_mgr.o: mem_data.o misc.o paw_inout.o ylm_fact.o: atom_data.o crystal_data.o gpoints.o lrulib.o \ spherical_harmonic.o work_mgr.o group.o: atoms.i rest_inv.o: atoms.i symmetry.h symgen.o: atoms.i symmetry.h spinpwpaw/code/README0100664004704100470410000002427310371153167014541 0ustar natalienatalie Modifications 1-31-00 -- NAWH introduced force anchor parameters; ART changed eigenvalue algorithm and n^ calculation 2-5-00 -- NAWH found new eigenvalue routine unstable -- replaced mg_relax.f90 with old one NAWH made small change to ldsupercell.f90 storedata.f90 3-29 00 -- NAWH removed Wij_NewMix and replaced it with Dij_NewMix also updated partialden and volume and plane plots 6-13-00 -- Various bug fixes -- still lots of diagnostics 6-16-00 -- Fixed diagonalizer , default Overlap_tol=1E-11 7-10-00 -- from cleanpwpaw -- took out lots of diagnostic writes 7-17-00 -- compiled with -O3; changed relax geometry; Yonas's bandplot added 7-22-00 -- corrected problem with bandstructure mode and DOS 8-16-00 -- added grad Enk and surface band; corrected projectors 8-16-00 -- attempted to correct problem with Symmetrize_Pos 11-11-00 -- corrected bug in psilib -- scratch write tested OK 1-23-01 -- added scaling to Atom_List and Plot structure -- added Shell structure to pgm -- still have hysteresis -- in forces 2-01-01 -- corrected allocation hole by removing AllocPreVec -- -- only move along force available in shell mode 2-09-01 -- modified anderson_mixing to use SVD in matrix inversion and introduced condition number 2-10-01 -- modified anderson_mixing slightly using machine accuracy 2-20-01 -- modified RelaxGeometry (still not optimal) 2-27-01 -- replaced MATMUL calls in grrp for speed 2-28-01 -- added STORE_LOWEST_ENERGY option 4-13-01 -- change volplot to output density in elec/volume in Angstroms^3 -- and other changes to charges.f90 4-16-01 -- slight change to volplot for speed 4-30-01 -- removed xlfutility and flush_ from grrp 5-01-01 -- slight changes to solver to help stabilization 5-03-01 -- removed unused modules; no longer need libguptri.a and libjdqz.a -- added Anderson_ConditionNo (default=10000, 1000 may be more stable) 5-16-01 -- corrected volplot pgm so that grid can be 1 in some directions 5-19-01 -- take out symmetrize positions algorithm (in RelaxGeometry) since it currently does more harm 5-20-01 -- fix RelaxGeom in UseShell mode 6-07-01 -- add Center keyword to 3d plot setup (calculates origin of plot as Center - X/2 - Y/2 - Z/2) 8-14-01 -- fix slight bug in storedata.f90 to allow for very long file names 8-25-01 -- changed exchange_corr.f90 and hamiltonian.f90 modules in order to treat LDA (Perdew-Wang form) or GGA (Perdew-Burke-Ernzerhof) forms. The control for the exchange form is now given in the [atom].atomicdata file generated in the atompaw program. The XC_Type keyword is no longer used in the pwpaw input file. Other LDA forms or GGA forms which use the magnitudes of the gradients only can be easily added. 9-21-01 -- found small error LSMove routine in relaxsys.f90 11-10-01 -- added write statement at end of RelaxAtoms to help track relaxation convergence 11-27-01 -- found and corrected small errors in AccumVXC-GGA; note that GGA code has not been completely tested, but suspect that remaining errors may be due to slower convergence wrt to Gcut 12-04-01 -- NAWH fixed (?) problem with random occupancies in bandstructure mode. Program now keeps same Fermi level determined in SCF mode, and calculates band occupancies based on that Fermi level. 4-02-02 -- Alan Wright noticed that the formula in dbeta contained a cot instead of the correct tan. A few test cases do not indicate that this error is significant, but the code in crystal_symmetry was changed to be correct. 5-09-02 -- GGA code was changed slightly after discussion with Ryan Hatcher in order to be more stable when the gradients are close to 0. 5-30-02 -- Slight change to read_input; modify Makefile to make library for pwpaw subroutines libpwpaw.a 6-11-02 -- Slight change to routines to stabilize bandstructure mode 6-13-02 -- Fixed (??) remaining bugs in psilib 7-06-02 -- Fixed error in Volplot concerning atomic contributions 12-21-02 -- Fixed error in Simpson integration routines in mathlib as found by Kevin Conley: IF (j > 3) THEN DO i = 5, n, 2 (5 was incorrectly 4) 1-09-03 -- Ported the code to run with Absoft fortran compiler. Got rid of many of the large local variable arrays such as LUT(2,Mem_MaxSize) which tended to overflow the stack on this system. Statments like Integer :: LUT(2,Mem_MaxSize) were replaced by Integer, allocatable :: LUT(:,:) Allocate(LUT(2,Mem_MaxSize) . DeAllocate(LUT) DeAllocate(LUT) 4-12-03 -- Minor change to forces.f90 after simplifying suggestion by Ryan Hatcher 5-02-03 -- Tim Miller found incompatibility in strings.f90 5-23-03 -- Minor change to mathlib.f90 -- correction to factorial 5-31-03 -- Thanks to HuangYuan, found error in charges.f90 8-05-03 -- Tested code with intel 7.1 compiler, using ATLAS http://math-atlas.sourceforge.net/ library for blas. Compilation with intel or absoft facilitated with script: makescript (intel or absoft) (pwpaw or genkpoints or bandplot or preparepdos or prepareballandstick or clean) Need to edit make.intel or make.absoft files for proper library locations and compiler flags. 4-30-04 -- Minor change in code to allow compatibility with new atompaw treatment of Vloc. 7-13-04 -- Corrected bug concerning compatability with old atompaw files; slight changes wrt to compatability with intel8.0 and absoft 8-13-04 -- Alan W found typo for GGA calculations; adjusted make.absoft for better compatibility 10-17-04 -- Alan W found an error in GGA calculations; changed zero-point extrapolations to 3 points 01-08-05 -- Changed code to include pseudo-core (coretail) contributions compatable with new version of atompaw. If coretail density is 0, there is still a constant energy shift wrt to previous code. In test cases, results with and without coretail contributions are very close. 02-11-05 -- Add some parameter for spin calculation in atom_data.f90 07-06-05 -- Validated code for spin-dependent calculations and implemented Store_Ham_and_Psi and Load_Ham_and_Psi for saving both Hamiltonian and wavefunction files. The later is useful for changing the k-point mesh. 07-19-05 -- Corrected errors in "shell structure" necessary for non-orthogonal direction vectors 09-29-05 -- Store current Dij and Ve_Fourier and output these in Store_Ham_and_Psi (rather than Anderson mix outputs) 11-08-05 -- Corrected small bug and made it optional to store current Dij and Ve_Fourier using STOREUNMIXED key word (defaults to storing Anderson mixed result) 12-12-05 -- Reduced data output by not outputting wfn files by default since these are also output in Store_Ham_and_Psi routines 01-21-06 -- Added option to ldatomtype (in module ldatom_info.f90)o to read VLOCION keyword needed for abinit code but not used in pwpaw 02-02-06 -- After discussion with Alan Wright concerning the poor gcut convergence of pwpaw relative to socorro, attempted to implement strict |k+G|AC%Nmax) AC%Slot = 1 If ((AC%N < 0) .OR. (AC%Nmax == 0)) then !** Simple mixing for 1st time *** AC%Xprev = X X = X + AC%NewMix*F else slot = AC%Slot !Write(AC%Err_Unit,*) 'And_Mix: Slot=',Slot, ' * N=',AC%N AC%DF(:,slot) = F - AC%Fprev !** Make new DF vector AC%DX(:,slot) = X - AC%Xprev !** Make new DX vector currentdim=Min(AC%N+1,AC%Nmax) !Do i=1, Min(AC%N+1,AC%Nmax) !*** Add row/col to matrix Do i=1, currentdim !*** Add row/col to matrix term = DOT_PRODUCT(AC%DF(:,i), AC%DF(:,slot)) AC%Matrix(i,slot) = term if (i /= slot) AC%Matrix(slot,i) = CONJG(term) AC%Gamma(i) = DOT_PRODUCT(AC%DF(:,i), F) End Do AC%DupMatrix = AC%Matrix ! not needed (SVD) AC%DupMatrix(slot,slot) = (1+AC%w0) * AC%DupMatrix(slot,slot) ! Call ZHESV('L', Slot, 1, AC%DupMatrix(1,1), AC%Nmax, & ! AC%IPIV(1), AC%Gamma(1), AC%Nmax, AC%Work(1), AC%LWork, i) ! Call ZGESV(Slot, 1, AC%DupMatrix(1,1), AC%Nmax, AC%IPIV(1), & ! AC%Gamma(1), AC%Nmax, i) ! Call ZGESV(currentdim, 1, AC%DupMatrix(1,1), AC%Nmax, AC%IPIV(1), & ! AC%Gamma(1), AC%Nmax, i) n = AC%Nmax; j= currentdim Call ZGESDD('A',j,j,AC%DupMatrix(1,1),n,AC%S(1), & AC%U(1,1),n,AC%VT(1,1),AC%Nmax,AC%Work(1),AC%Lwork, & AC%RWork(1),AC%IPIV(1),i) If (i /= 0) then Write(AC%Err_Unit,*) 'Anderson_Mix: Error in ZGESDD. Error=',i tmp = 0 tmp = 1.0/tmp STOP end If Write(Log_Unit,*) 'in Anderson_Mix -- completed SVD with values' Write(Log_Unit,'(1p5e15.7)') (AC%S(i),i=1,j) AC%Work(1:j) = AC%Gamma(1:j) AC%Gamma = 0 tmp=ABS(AC%S(1))/AC%ConditionNo If ( tmp > AC%Machaccur) then Do i=1,j If (ABS(AC%S(i)).gt.tmp) then AC%Gamma(1:j)=AC%Gamma(1:j)+& CONJG(AC%VT(i,1:j))*DOT_PRODUCT(AC%U(1:j,i),AC%Work(1:j))/AC%S(i) EndIf Enddo EndIf AC%Xprev = X !*** Now calculate the new vector *** X = X + AC%NewMix*F !Do i=1, Min(AC%N+1,AC%Nmax) !*** Add row/col to matrix Do i=1, currentdim ! updated vector X = X - AC%Gamma(i)*(AC%DX(:,i) + AC%NewMix*AC%DF(:,i)) End Do End If AC%Fprev = F AC%N = AC%N + 1 If (AC%N > AC%Nmax) AC%N = AC%Nmax Return End Subroutine !****************************************************************************** ! Original version ! Anderson_Mix - Performs the actual mixing of the input vector with the ! history and retuns the result. ! ! AC - Anderson context ! X - Current vector on input and new guess on output ! F - F(X) - X. Nonlinear mixing of input vector ! !****************************************************************************** Subroutine Anderson_Mix_old(AC, X, F) Type (Anderson_Context), Intent(INOUT) :: AC Complex, Intent(INOUT) :: X(:) Complex, Intent(IN) :: F(:) Integer :: i, slot, currentdim Complex :: term Real :: tmp !** First determine where to store the new correction vectors *** AC%slot = AC%slot + 1 If (AC%Slot>AC%Nmax) AC%Slot = 1 If ((AC%N < 0) .OR. (AC%Nmax == 0)) then !** Simple mixing for 1st time *** AC%Xprev = X X = X + AC%NewMix*F else slot = AC%Slot !Write(AC%Err_Unit,*) 'And_Mix: Slot=',Slot, ' * N=',AC%N AC%DF(:,slot) = F - AC%Fprev !** Make new DF vector AC%DX(:,slot) = X - AC%Xprev !** Make new DX vector currentdim=Min(AC%N+1,AC%Nmax) !Do i=1, Min(AC%N+1,AC%Nmax) !*** Add row/col to matrix Do i=1, currentdim !*** Add row/col to matrix term = DOT_PRODUCT(AC%DF(:,i), AC%DF(:,slot)) AC%Matrix(i,slot) = term if (i /= slot) AC%Matrix(slot,i) = CONJG(term) AC%Gamma(i) = DOT_PRODUCT(AC%DF(:,i), F) End Do AC%Matrix(slot,slot) = (1+AC%w0) * AC%Matrix(slot,slot) AC%DupMatrix = AC%Matrix ! Call ZHESV('L', Slot, 1, AC%DupMatrix(1,1), AC%Nmax, & ! AC%IPIV(1), AC%Gamma(1), AC%Nmax, AC%Work(1), AC%LWork, i) ! Call ZGESV(Slot, 1, AC%DupMatrix(1,1), AC%Nmax, AC%IPIV(1), & ! AC%Gamma(1), AC%Nmax, i) Call ZGESV(currentdim, 1, AC%DupMatrix(1,1), AC%Nmax, AC%IPIV(1), & AC%Gamma(1), AC%Nmax, i) If (i /= 0) then Write(AC%Err_Unit,*) 'Anderson_Mix: Error in ZHESV. Error=',i tmp = 0 tmp = 1.0/tmp STOP end If AC%Xprev = X !*** Now calculate the new vector *** X = X + AC%NewMix*F !Do i=1, Min(AC%N+1,AC%Nmax) !*** Add row/col to matrix Do i=1, currentdim ! updated vector X = X - AC%Gamma(i)*(AC%DX(:,i) + AC%NewMix*AC%DF(:,i)) End Do End If AC%Fprev = F AC%N = AC%N + 1 If (AC%N > AC%Nmax) AC%N = AC%Nmax Return End Subroutine !****************************************************************************** ! ! Anderson_ResetMix - Resets the mixing history to None ! ! AC - Anderson context to reset ! !****************************************************************************** Subroutine Anderson_ResetMix(AC) Save Type (Anderson_Context), Intent(INOUT) :: AC AC%N = -1 AC%Slot = -1 AC%DF=0; AC%DX=0; AC%Matrix=0 Return End Subroutine !****************************************************************************** ! ! FreeAnderson - Frees all the data associated with the AC data structure ! ! AC -Pointer to the Anderson context to free ! !****************************************************************************** Subroutine FreeAnderson(AC) Save Type (Anderson_Context), Pointer :: AC DeAllocate(AC%Gamma, AC%Fprev, AC%DF, AC%Matrix, AC%DX, AC%Xprev) DeAllocate(AC) Return end Subroutine !****************************************************************************** ! ! InitAnderson - Initializes and Anderson_Context data structure for use ! ! AC - Anderson context created and returned ! Err_Unit - Output error unit ! Nmax - Max number of vectors to keep ! VecSize - Size of each vector ! w0 - Fudge for diagonal to keep linear independece ~1E-4. ! NewMix - Mixing factor ! !****************************************************************************** Subroutine InitAnderson(AC, Err_Unit, Nmax, VecSize, w0, NewMix, CondNo) Save Type (Anderson_Context), Pointer :: AC Integer, Intent(IN) :: Err_Unit Integer, Intent(IN) :: Nmax Integer, Intent(IN) :: VecSize Real, Intent(IN) :: w0 Real, Intent(IN) :: NewMix Real, Intent(IN) :: CondNo Integer :: i Real :: tmp , a1,a2,a3 Allocate(AC) !** Allocate the pointer AC%Nmax = Nmax !*** Store the contants AC%VecSize = VecSize AC%w0 = w0 AC%NewMix = NewMix AC%Err_Unit = Err_Unit AC%N = -1 !** Init the rest of the structure AC%Slot = -1 ! AC%Lwork = 2*Nmax ! Allocate(AC%Gamma(Nmax), AC%Work(AC%Lwork), AC%Fprev(VecSize), & ! AC%DF(VecSize, Nmax), AC%Matrix(Nmax, Nmax), AC%IPIV(Nmax), & ! AC%DX(VecSize, Nmax), AC%Xprev(VecSize), & ! AC%DupMatrix(Nmax, Nmax), STAT=i) Allocate(AC%Xprev(VecSize), AC%Fprev(VecSize) , AC%DX(VecSize,Nmax), & AC%DF(VecSize,Nmax), AC%Matrix(Nmax,Nmax) , AC%Gamma(Nmax), & Stat=i) If (i /= 0) then Write(Err_Unit,*) 'InitAnderson: Allocate Error! Error=',i Write(Err_Unit, *) 'InitAnderson: Nmax=',Nmax, ' * VecSize=',VecSize Call Flush(Err_Unit) tmp = 0 tmp = 1.0/tmp STOP End If AC%Lwork=Nmax*Nmax+3*Nmax AC%LRwork= 5*Nmax*Nmax+7*Nmax AC%ConditionNo= CondNo ! Calculate machine accuracy AC%Machaccur = 0 a1 = 4.0/3.0 do while (AC%Machaccur == 0.0) a2 = a1 - 1.0 a3 = a2 + a2 + a2 AC%Machaccur = ABS(a3 - 1.0) enddo Allocate(AC%DupMatrix(Nmax,Nmax), AC%U(Nmax, Nmax), AC%VT(Nmax,Nmax), & AC%Work(AC%Lwork), AC%RWork(AC%LRWork), AC%IPIV(8*Nmax), & AC%S(Nmax), STAT=i) AC%Matrix = 0; AC%DF=0; AC%DX=0 Return End Subroutine End Module spinpwpaw/code/atom_data.f900100664004704100470410000002766410334664136016143 0ustar natalienatalie!****************************************************************************** ! ! File : atom_data.f90 ! by : Alan Tackett ! on : 7/27/98 ! for : PAW method ! ! This file contains the data structures that are required for loading and ! storing the fixed and variable portions of the atom data. ! ! Modified for spin dependence by Ping Tang ! Last change 5/23/05 ! !****************************************************************************** Module atom_data Use strings Use anderson_mixing Use gaussfunc_data Type atom_info_fixed !** Define the Fixed atom information character*10 :: Atom_Name !** Name of Atom, ie, Ca, C, etc character*10 :: Shape_Type !** Type of shape func used for proj. Integer :: Basis_Size !** Number of Basis functions for atom Integer :: Mesh_Size !** Num mesh points for each basis fn Integer :: Coretail_points !** Num mesh points for CoreTail_Density Integer :: DenVhat_Size !** Size of the Density and V_hat mat's Integer :: Hartree_Size !** Number of V_Hartree terms Integer :: Atomic_Charge !** Atomic Z value Integer :: Overlap_Size !** Overlap, Kinetic, V_ion size Integer :: LCAO_Size !** Size of TPhi_LCAO arrays Integer :: nlm_Size !** Size of nlm_LUT Integer :: Hat_MaxL !** MAx L-value for the n^ Integer, Pointer :: L_Value(:) !** L value for each orbital Integer, Pointer :: nlm_LUT(:,:) !** nilimi Look up table Integer, Pointer :: nl_Base(:) !** nlm_LUT index for start of (NiLi) Real :: Mass !** Mass of atom Real :: LCAO_Step !** LCAO step size ! Real :: V_local !** Local atom potential coefficient Real :: Core_charge !** Core charge of atom Real :: Qeffion !** -Z+Qcore-Qcore~ Real :: Rc !** Basis fn cutoff radius. Real :: Rc_RS_Scale !** Scale factor for RS Proj's Real :: Gcut_Proj !** Projector Gcut Integer :: Gpnt_Size Real :: Rbox !** Local grid enhancement radius Real :: Mesh_Step !** Mesh step size (Bohr) Real :: Atom_Energy !** Total Energy of Atom Real :: CoreTail_SelfEnergy!** CoreTail Self-energy Real :: CoreTail_HatEnergy!** CoreTail-Hat interaction energy Real, pointer :: Hat_SelfEnergy(:) !** Hat self-energy Real, Pointer :: RadR_Vlocal(:) !** Rad Vlocal fn (rad mesh) Real, Pointer :: Rad_Vlocal(:) !** Rad FFT of Vlocal fn Real, Pointer :: Shape_Func(:) !** Shape for Vlocal and Hat (rad mesh) Real, Pointer :: Tphi_LCAO(:,:) !** |phi~> for use in LCAO construction Real, Pointer :: RadG_LCAO(:,:) !** |phi~> Radial G form LCAO Real, Pointer :: Phi(:,:) !** |phi> Real, Pointer :: TPhi(:,:) !** |phi~> Real, Pointer :: TP(:,:) !** |p~> <-- twiddle Projector !Real, Pointer :: TP_deriv(:,:) !** Radial derivative of projector Real, Pointer :: List_Oij(:) !** Overlap matrix (Loading use only) Real, Pointer :: Oij(:,:) !** Overlap or Oij matrix (27) Real, Pointer :: Core_Density(:) !** Core density Real, Pointer :: CoreTail_Density(:)!** Core tail density (coretail_points) Real, Pointer :: FTCoreTail(:) !** FT of radial Core density Real, Pointer :: GradCoreTail(:) !** Gradient of Core Tail density Real, Pointer :: Core_Xchange(:) !** Exchange Correlation Functional Real, Pointer :: Core_dDendr(:) !** Grad core density needed for GGA Real, Pointer :: Kinetic(:) !** Kinetic energy Matrix Real, Pointer :: V_ion(:) !** ??(eq. 38, WN)?? Real, Pointer :: Density(:) !** Density Real, Pointer :: V_hat(:) !** E-S pot. corr. to Gauss. Form Integer, Pointer :: LUT_DenVhat(:) !** LUT for density and V_hat Real, Pointer :: V_Hartree(:) !** Hartree Potential Integer, Pointer :: LUT_V_Hartree(:) !** LUT for V_Hartree Integer :: QVlm_Size !** Size of aQlm and aVlm Real, Pointer :: aQlm(:) !** G^(LM)_limiljmj,lkmkllml * !** V^(aL)_njljnili term in WN46 Real, Pointer :: aVlm(:) !** Contains the coeff - A47 Integer, Pointer :: LUT_Orb(:) !** Encoded indices for aQlm and aVlm Real, Pointer :: Cijkl(:) !** Coeff of W^a_kl in WN48(coulomb) Integer, Pointer :: LUT_Cijkl(:) !** Encoded indices for Cij Integer :: Cijkl_Size !** Size of Cijkl Integer, Pointer :: Rad_Size !** Vxc size Integer, Pointer :: Rad_Skip !** Vxc skip factor Real, Pointer :: R2(:) !** R^2 for Vxc Real, Pointer :: Phi_ij_R2(:,:) !** Phi_i*Phi_J/R^2 for Vxc Real, Pointer :: TPhi_ij_R2(:,:) !** Phi~_i*Phi~_J/R^2 for Vxc Real, Pointer :: dPhi_ijdr(:,:) !** Deriv of Phi_i*Phi_j/R^2 for Vxc Real, Pointer :: dTPhi_ijdr(:,:) !** Deriv of TPhi_i*.Phi_j/R^2 for Vxc Real, Pointer :: Proj_Scale(:) !** P~ scale Real, Pointer :: RadHat(:,:) !** Radial n^ fn's (gmag, n) Integer, Pointer :: Proj_Fn(:) !** P~ Kummer function Complex, Pointer :: Ylm(:,:,:) !** Ylm's for Vxc Complex, Pointer :: dYlmdtheta(:,:,:) !** Deriv of Ylm's for GGA Vxc Complex, Pointer :: dYlmdphi(:,:,:) !** Deriv of Ylm's for GGA Vxc Real, Pointer :: FnRad(:,:), FnRadspin(:,:) !** Work storage for Vxc Real, Pointer :: Cij(:,:), Cijspin(:,:) !** Work Storage for Vxc Real, Pointer :: dCijdtheta(:,:),dCijdthetaspin(:,:) !** Work Storage for Vxc Real, Pointer :: dCijdphi(:,:),dCijdphispin(:,:) !** Work Storage for Vxc Integer :: Orbitals_Size !** Size of Valence orbitals list Integer, POINTER :: Valence_Orbitals(:) !** Valence Orbitals Real, Pointer :: Init_Occ(:), Init_Occspinup(:), Init_Occspindn(:) !** Initial Occupancy !*** These are only used for the norm conserving PP *** Character*10 :: icorr Character*10 :: irel Character*10 :: nicore Real :: Alpha Real, Pointer :: Pot_local(:) !*** These are only used for semi-empirical PP ** Integer :: Poly_Degree !** Degree of G~0 polynomial for V Real, Pointer :: Poly(:) !** Poly for G~0 Real :: Poly_Gcut !** Switch for poly use Real :: Gaussian(2) !** Gaussian Fudge potential Type (GaussFunc) :: V_sepm !** SEPM V in sum of gaussians End Type Type Verlet_Data !*** Contains the Verlet intergration data Real :: Pos(3,3) !** Positions Real :: Velocity(3,3) !** Velocities Real :: Acceleration(3,3) !** Acceleration Real :: CurrForce(3) !** Current Force calculated by CalcForce Integer :: NumMoves !** Number of valid moves Logical :: Predictor_Phase !** Phase of the Verlet algorithm End Type Type Enhance_Type !** Defines grid enhancement around an atom ** Integer :: Level !** Min grid point level of enhancement ** Real :: Radius !** Enhancement radius End Type Type Specific_Atom !** Contains the specifc atom information Character*50 :: Name !** Atom Name Integer :: TypeIndex !** AtomType Index Integer :: Enhance_Size !** Number of enhance data structs Integer :: Orbitals_Size !** Size of Valence orbitals list Integer, POINTER :: Valence_Orbitals(:) !** Valence Orbitals Real :: Frac_Pos(3) !** Position in fractional coordinates Real :: Pos(3) !** Position in Cartesian coordinates Real, Pointer :: Init_Occ(:), Init_Occspinup(:), Init_Occspindn(:) !** Initial Occupancy Real :: Nuclear_Params(7) !** Nulcear charge paramters Type(Verlet_Data) :: Force !**Force information for moving the atom Complex, Pointer :: Wij(:,:),Wijspin(:,:) !** Projected occupation coeff. WN45 Complex, Pointer :: Fij(:,:,:),Fijspin(:,:,:) !** Force Wij coeff Complex, Pointer :: Feij(:,:,:),Feijspin(:,:,:) !** Force Wij Pulay coeff Complex, Pointer :: Dij(:,:),Dijspin(:,:) !** Dij matrix (A8) Complex, Pointer :: cDij(:,:),cDijspin(:,:) !** Dij matrix (A8) -- current ! not subject to Anderson mix Complex, Pointer :: Dij_old(:),Dij_oldspin(:) !** Previous iterations Dij-mapped to 1d Complex, Pointer :: Wij_old(:,:), Wij_oldspin(:,:) !** Previous iterations Wij matrix (A8) Complex, Pointer :: Qlm(:,:) !** Comp. charge Multipole moments. WN46 Complex, Pointer :: dEdQlm(:,:) !** dE/dQlm appears in WN49. Logical :: Freeze !** Determines if an atom is moved Real :: Friction !** Friction coef type (Enhance_Type), Pointer :: Enhance(:) !** Ptr to enhancement structs Type (Anderson_Context), Pointer :: Dij_AC, Dijspin_AC Type (Anderson_Context), Pointer :: Wij_AC, Wijspin_AC End Type Type Shell_Map !** Map atomic positions to parameters Integer :: MapParams !** Total parameters of this atom (<=3) Real :: Origin(3) !** Constant position vector for origin Integer, Pointer :: Map(:) !** Map to parameter indices Real, Pointer :: V(:,:) !** MapParams unit vectors to define pos Real, Pointer :: IV(:,:) !** Inverse unit vectors End Type Type Shell_Structure !** Atom position parametrization Integer :: NPARAMS !** Total number of shell parameters Real, Pointer :: C(:) !** List of parameter values Real, Pointer :: ShellForce(:) !** Generalized forces Type (Shell_Map), Pointer :: AtomMap(:) !Parameters map to atoms End Type Integer :: Atom_Types !** Number of different Atom types Integer :: Max_Atom_Types !** Max number of different types allowed Integer :: Specific_Atoms !** Number of specific Atoms Integer :: Max_Specific_Atoms !** Max number of specific atoms allowed Logical :: UseShells !** Flag for using shell map Type (Atom_Info_Fixed), Pointer ,save :: AtomType_Info(:) !** Array of atom info Type (Specific_Atom), Pointer ,save :: Atom_List(:) !** Array of specific atoms Type (Shell_Structure) :: Shell Integer, Pointer :: AtomType_MAP(:) !** LUT for mapping Type->atom Integer, Pointer :: AtomType_Range(:,:) !** Range of types/atom Type (Anderson_Context), Pointer,save :: Move_AC Type (StringList_Struct) :: AtomType_LUT !** LUT for AtomTypes Type (StringList_Struct) :: Atom_LUT !** LUT for specific Atoms Real, Pointer :: Occupancy(:,:) !** Running Occupancy(band,K-pnt) Integer :: NumBands !** Number of Bands Integer :: NumKpnts !** Number of PSI k-points Real :: TotalElectrons !** Total Number of electrons Real :: NetCharge !** Net charge of system Real :: TotalEnergy !** Total Energy Real :: CohesiveEnergy !** Cohesive energy of the system Real :: BestCohesiveEnergy !** Stored Cohesive energy Real :: AtomicEnergy !** Atomic Energy due to core Real :: NuclearEnergy !** Nuclear Energy due to core approx Real :: Netforce(3) !** Net force on unit cell before drift removal Logical :: Anchor !** True if one atom is held fixed Integer :: AnchorIndex !** "specific atom" index of anchor End Module spinpwpaw/code/atoms.i0100664004704100470410000000021110303710172015126 0ustar natalienatalie!--- ! Atoms.i ! integer ntyp, natp Common /atoms_i/ ntyp, natp save /atoms_i/ !** parameter (ntyp=2,natp=8) !--- spinpwpaw/code/bandplot.f900100664004704100470410000001044110303710172015762 0ustar natalienatalie!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Program Bandplot ! 7/7/00 a program to praper bandstucture plotable ! files from name.band file ! by Yonas and Natalie Program Bandplot Use Crystal_data Use mathlib Use paw_inout Use Word Use Strings Use Units IMPLICIT NONE Character*100 :: Fn, token Logical :: ex LOGICAL :: findA=.false.,findB=.false.,findC=.false. INTEGER :: err, i , j, tlen, ier INTEGER :: ifsym,ii,jj,kk,iftmp,ifcry integer, parameter :: input_unit=5 integer ::np,npanels,iargc REAL ::v(3),cv(3),cdir(3),d1,d2 REAL ::k0(3),kf(3),dir(3),ck0(3),ckf(3) REAL ::kin(3),energy,Ef REAL ::shift=0.,length,calclength,Scale REAL, parameter :: RydtoeV=13.60569172 if (iargc() < 1) then Write(*,*) 'Format: pwpaw input_file' STOP End if Call GetArg(1,Fn) write(*,*) 'Filename=',Fn ! A typical pwpaw input file Token = Fn Call UpperCase(Token) Inquire(file=Trim(fn),exist=ex) if (.not.ex) then Write(*,*) "Can't access file ",Trim(fn) Write(*,*) "Make sure the file exists and has Read permissions." stop endif Call initconstants Write(*,*) 'Scratch_FD=',Scratch_Unit Call DetWordConstants(SCRATCH_UNIT) Call InitWord(PAW_WC, INPUT_BASE_UNIT, trim(Fn), DELIMS, COMMENT, LIT_CHAR, & MAX_INCLUDE, INCLUDE_STR) Call GetNextWord(PAW_WC,Token,tlen) Scale = 1 Do If (W_Error /= W_EOF ) then Call UpperCase(Token) If (Trim(Token) == "A") then Call GetNumbers(PAW_WC,xtal%Basis(1:3,1),3) findA=.true. write(*,*) 'A =',xtal%Basis(1:3,1) Else If (Trim(Token) == "B") then Call GetNumbers(PAW_WC,xtal%Basis(1:3,2),3) findB=.true. write(*,*) 'B =',xtal%Basis(1:3,2) Else If (Trim(Token) == "C") then Call GetNumbers(PAW_WC,xtal%Basis(1:3,3),3) findC=.true. write(*,*) 'C =',xtal%Basis(1:3,3) else if (Trim(token) == "SCALE") then !** Lattice scale factor Call GetNumber(PAW_WC, Scale) write(*,*) 'Scale factor =',Scale EndIf Else Exit EndIf If (findA .AND. findB .AND. findC) Exit Call GetNextWord(PAW_WC,Token,tlen) Enddo If (.not.findA .OR. .not.findB .OR. .not.findC) then write(*,*) 'Error -- Basis functions not found' stop Endif xtal%Basis = xtal%Basis*Scale xtal%Recip = RecipBasis(xtal%Basis) write(*,*) 'GA',xtal%Recip(:,1) write(*,*) 'GB',xtal%Recip(:,2) write(*,*) 'GC',xtal%Recip(:,3) WRITE(*,*) "Input file name" READ(*,*) Token OPEN(UNIT=9, FILE=trim(Token), STATUS='old', ACTION='read', IOSTAT=ier) IF(ier/=0)THEN WRITE(*,*)'ERROR in opening file' STOP END IF OPEN(UNIT=10, FILE=Trim(Token)//'plot', STATUS='REPLACE', ACTION='write', IOSTAT=ier) IF(ier/=0)THEN WRITE(*,*)'ERROR in opening output file' STOP END IF WRITE(*,*) " Note: Band energies are converted to eV " WRITE(*,*) " Note: k vectors should be specified in fractions of G" WRITE(*,*) 'Input Ef in Ry' READ(*,*) Ef WRITE(*,*)" #panels" READ(*,*)npanels panel: DO np=1,npanels WRITE(*,*) "The shift value of",np," is ", shift WRITE(*,*) "input k0 and kf respectively for panel ",np READ(*,*)k0(1:3),kf(1:3) length=calclength(kf-k0) cdir=MAtmul(xtal%Recip,kf-k0)/length write(*,*) 'length = ',length, 'direction = ',cdir DO READ(9,*,IOSTAT=ier)kin(1:3),energy if(ier/=0)EXIT write(*,*)kin(1:3),energy energy=energy-Ef v=kin(1:3)-k0(1:3) cv=Matmul(xtal%Recip,v) d1=calclength(v) d2=Dot_Product(cv,cdir) IF(abs(d1-d2)<0.0001.AND.d1<=length+0.0001)THEN write(10,'(2f12.6)')d1+shift,energy*RydtoeV write(*,'(2f12.6)')d1+shift,energy*RydtoeV END IF END DO shift=shift+length write(*,*) 'rewind',shift REWIND(UNIT=9) END DO panel CLOSE(UNIT=9) CLOSE(UNIT=10) STOP END PROGRAM FUNCTION calclength (V) USE Crystal_data REAL, intent(IN) ::v(3) REAL ::t(3),calclength t=Matmul(xtal%Recip,V) calclength=SQRT(Dot_Product(t,t)) RETURN END spinpwpaw/code/basis_lib.f900100664004704100470410000000175510303710172016116 0ustar natalienatalie!****************************************************************************** ! ! File : basis_lib.f90 ! by : Alan Tackett ! on : 04/29/99 ! for : PWPAW ! ! Module containing basis specific routines ! !****************************************************************************** Module basis_lib IMPLICIT NONE !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! Basis_DotProd - Perfrom a dot product/integration ! ! V1, V2 - Two vectors for dot product/integration ! !****************************************************************************** Complex Function Basis_DotProd( V1, V2, DoOverlap) Complex, Intent(IN) :: V1(:) Complex, Intent(IN) :: V2(:) Logical, Intent(IN) :: DoOverlap Basis_DotProd = DOT_PRODUCT(V1, V2) Return End function End Module spinpwpaw/code/btree.f900100664004704100470410000002143410303710172015264 0ustar natalienatalie!****************************************************************************** ! ! File : btree.f90 ! by : Alan Tackett ! on : 08/06/98 ! for : WAE program ! ! Module for implementing a height balanced binary tree. ! ! The code used here was based on that given in "Introduction to data ! structures and algorithm analysis" by Thomas L. Naps in chapter 7 ! !****************************************************************************** Module btree Use btree_support !** This module contains the data types and !** support routines for the specific application Implicit NONE!!!!!!!!!!!! !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! FreeTree - Frees the tree ! ! Root - Binary tree root ! !****************************************************************************** Recursive Subroutine FreeTree(Root, FreeData) Type (BinaryTreeNode), Pointer :: Root Logical, Intent(IN) :: FreeData If (Associated(Root)) then Call FreeTree(Root%LeftChild, FreeData) Call FreeTree(Root%RightChild, FreeData) If (FreeData) DeAllocate(Root%Info) DeAllocate(Root) EndIf Return End Subroutine !****************************************************************************** ! ! SearchBTree - Searches the b-tree for a given node ! ! Root - Binary tree root ! Item - Data to match ! Result - Pointer to matching node if found ! Success - Determines if item is successfully inserted ! !****************************************************************************** Subroutine SearchBTree(Root, Item, Result, Success) Type (BinaryTreeNode), Pointer :: Root Type (BinaryTreeData), TARGET :: Item Type (BinaryTreeNode), Pointer :: Result Logical, Intent(OUT) :: Success Integer :: CmpResult Success = .FALSE. If (.NOT. Associated(Root)) then Nullify(Result) RETURN End If Result => Root Do While (Associated(Result) .AND. (.NOT. Success)) CmpResult = Compare(Item, Result%Info) Select Case (CmpResult) Case (-1) Result => Result%LeftChild Case (0) Success = .TRUE. Case (1) Result => Result%RightChild End Select End Do Return End Subroutine !****************************************************************************** ! ! LeftOfLeft - AVL rotation case 1 (p351) ! ! Pivot - Pivot point ! !****************************************************************************** Subroutine LeftOfLeft(Pivot) Type (BinaryTreeNode), Pointer :: Pivot Type (BinaryTreeNode), Pointer :: P, Q P => Pivot%LeftChild Q => P%RightChild P%RightChild => Pivot Pivot%LeftChild => Q Pivot => P Pivot%BalanceFactor = 0 Pivot%RightChild%BalanceFactor = 0 Return End Subroutine !****************************************************************************** ! ! RightOfright - AVL rotation case 2 (p353) ! ! Pivot - Pivot point ! !****************************************************************************** Subroutine RightOfRight(Pivot) Type (BinaryTreeNode), Pointer :: Pivot Type (BinaryTreeNode), Pointer :: P, Q P => Pivot%RightChild Q => P%LeftChild P%LeftChild => Pivot Pivot%RightChild => Q Pivot => P Pivot%BalanceFactor = 0 Pivot%LeftChild%BalanceFactor = 0 Return End Subroutine !****************************************************************************** ! ! RightOfLeft - AVL rotation case 3 (p354) ! ! Pivot - Pivot point ! !****************************************************************************** Subroutine RightOfLeft(Pivot) Type (BinaryTreeNode), Pointer :: Pivot Type (BinaryTreeNode), Pointer :: X, Y X => Pivot%LeftChild Y => X%RightChild If (.NOT. Associated(Y)) Write(*,*) 'Y => NULL' Pivot%LeftChild => Y%RightChild X%RightChild => Y%LeftChild Y%LeftChild => X Y%RightChild => Pivot Pivot => Y Select Case (Pivot%BalanceFactor) Case (0) Pivot%LeftChild%BalanceFactor = 0 Pivot%RightChild%BalanceFactor = 0 Case (1) Pivot%BalanceFactor = 0 Pivot%LeftChild%BalanceFactor = 0 Pivot%RightChild%BalanceFactor = -1 Case Default Pivot%BalanceFactor = 0 Pivot%LeftChild%BalanceFactor = 1 Pivot%RightChild%BalanceFactor = 0 End Select Return End Subroutine !****************************************************************************** ! ! LeftOfRight - AVL rotation case 4 (p355) ! ! Pivot - Pivot point ! !****************************************************************************** Subroutine LeftOfRight(Pivot) Type (BinaryTreeNode), Pointer :: Pivot Type (BinaryTreeNode), Pointer :: X, Y X => Pivot%RightChild Y => X%LeftChild Pivot%RightChild => Y%LeftChild X%LeftChild => Y%RightChild Y%RightChild => X Y%LeftChild => Pivot Pivot => Y Select Case (Pivot%BalanceFactor) Case (0) Pivot%LeftChild%BalanceFactor = 0 Pivot%RightChild%BalanceFactor = 0 Case (-1) Pivot%BalanceFactor = 0 Pivot%LeftChild%BalanceFactor = 1 Pivot%RightChild%BalanceFactor = 0 Case Default Pivot%BalanceFactor = 0 Pivot%LeftChild%BalanceFactor = 0 Pivot%RightChild%BalanceFactor = -1 End Select Return End Subroutine !****************************************************************************** ! ! InsertNode - Inserts a node in the b-tree ! ! Root - Binary tree root ! Item - Data to be inserted ! Success - Determines if item is successfully inserted ! !****************************************************************************** Subroutine InsertNode(Root, Item, Success) Type (BinaryTreeNode), Pointer :: Root Type (BinaryTreeData), Pointer :: Item !** Type (BinaryTreeData), TARGET :: Item Logical, Intent(OUT) :: Success Type (BinaryTreeNode), Pointer :: P, Piv, PivParent, InP, InParent, Q Integer :: err Success = .TRUE. Allocate(P, STAT=err) If (err /= 0) then Write(*,*) 'InsertNode: Alloc Error=',err STOP End If P%Info => Item P%BalanceFactor = 0 Nullify(P%LeftChild) Nullify(P%RightChild) If (.NOT. Associated(Root)) then Root => P RETURN End If InP => Root Piv => Root Nullify(InParent) Nullify(PivParent) !*** Search for insertion point and pivot **** Do While (Associated(InP)) If (InP%BalanceFactor /= 0) then Piv => InP PivParent => InParent End If InParent => InP If (Compare(Item, InP%Info) == -1) then InP => InP%LeftChild else InP => InP%RightChild End If End Do !*** Insert the node as a child of InParent *** If (Compare(Item, InParent%Info) == -1) then InParent%LeftChild => P else InParent%RightChild => P End If !*** Now recompute the balance factors between Piv and InParent *** Q => Piv If (Compare(Item, Q%Info) == -1) then Q%BalanceFactor = Q%BalanceFactor + 1 Q => Q%LeftChild else Q%BalanceFactor = Q%BalanceFactor - 1 Q => Q%RightChild End If Do While (.NOT. Associated(Q, P)) If (Compare(Item, Q%Info) == -1) then Q%BalanceFactor = Q%BalanceFactor + 1 Q => Q%LeftChild else Q%BalanceFactor = Q%BalanceFactor - 1 Q => Q%RightChild End If End Do !*** Check to see if an AVL rotation is needed **** If ((Piv%BalanceFactor < -1) .OR. (Piv%BalanceFactor > 1)) then If (Compare(Item, Piv%Info) == -1) then If (Compare(Item, Piv%LeftChild%Info) == -1) then If (Associated(Piv, Root)) then Call LeftOfLeft(Root) else If (Associated(Piv, PivParent%LeftChild)) then Call LeftOfLeft(PivParent%LeftChild) else Call LeftOfLeft(PivParent%RightChild) End If else if (Associated(Piv, Root)) then Call RightOfLeft(Root) else If (Associated(Piv, PivParent%LeftChild)) then Call RightOfLeft(PivParent%LeftChild) else Call RightOfLeft(PivParent%RightChild) End If else If (Compare(Item, Piv%RightChild%Info) /= -1) then If (Associated(Root, Piv)) then Call RightOfRight(Root) else If (Associated(Piv, PivParent%LeftChild)) then Call RightOfRight(PivParent%LeftChild) else Call RightOfRight(PivParent%RightChild) End If else if (Associated(Piv, Root)) then Call LeftOfRight(Root) else if (Associated(Piv, PivParent%LeftChild)) then Call LeftOfRight(PivParent%LeftChild) else Call LeftOfRight(PivParent%RightChild) End If End If Return End Subroutine End Module spinpwpaw/code/btree_data.f900100664004704100470410000000160610303710172016254 0ustar natalienatalie!****************************************************************************** ! ! File : btree_data.f90 ! by : Alan Tackett ! on : 07/16/99 ! for : PAW program ! ! Btree data structures ! !****************************************************************************** Module btree_data Implicit NONE!!!!!!!!!!!!! Type BinaryTreeData !** Define the information stored Type (BinaryTreeData), Pointer :: Level_Next !*Link to next point/level Real :: Gmag !** Mag of G Integer :: Npnt(3) !** Integer version of G End type Type BinaryTreeNode !** Define the btree node Type (BinaryTreeNode), Pointer :: LeftChild !* children Type (BinaryTreeNode), Pointer :: RightChild Type (BinaryTreeData), Pointer :: Info !* pointer to data Integer :: BalanceFactor !* relative branch ht End Type End Module spinpwpaw/code/btree_support.f900100664004704100470410000001143710303710172017062 0ustar natalienatalie!****************************************************************************** ! ! File : btree_support.f90 ! by : Alan Tackett ! on : 08/06/98 ! for : WAE program ! ! Support routines and data structures for the binary tree module ! !****************************************************************************** Module btree_support Use btree_data Implicit none Type (BinaryTreeNode), PRIVATE, Pointer :: Check_Prev Integer, PRIVATE :: Node_Count !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! PrintPoint - Prints the information ! !****************************************************************************** Logical Function PrintPoint(Item) Type (BinaryTreeData), Intent(IN) :: Item Write(*,*) '|G|=',Item%Gmag, ' * N=',Item%Npnt PrintPoint = .TRUE. Return End Function !****************************************************************************** ! ! Compare - Compares two data items and determines their relationship. ! The ordering is determined as |G|,Z,Y,X. ! ! P1, P2 - Data items to compare ! ! Return Values ! -1 -- P1P2 ! !****************************************************************************** Integer Function Compare(pd1, pd2) Type (BinaryTreeData), Intent(IN) :: pd1, pd2 Real, PARAMETER :: TOL = 1E-6 Integer :: Result Integer :: P1(3), P2(3) Real :: diff P1 = PD1%Npnt P2 = PD2%Npnt Result = 0 diff = PD1%Gmag - PD2%Gmag If (diff < -TOL) then Result = -1 else If (diff > TOL) then Result = 1 Else If (P1(3) < P2(3)) then Result = -1 else if (P1(3) > P2(3)) then Result = 1 else If (P1(2) < P2(2)) then Result = -1 else If (P1(2) > P2(2)) then Result = 1 else If (P1(1) < P2(1)) then Result = -1 else If (P1(1) > P2(1)) then Result = 1 else Result = 0 End If End If End If End If Compare = Result Return End Function !****************************************************************************** ! ! InOrderTraversal - Performs an in order traversal of the binary tree ! ! Root - Binary tree root ! FuncCall - Function to call at each grid point. The function returns ! true if you should continue and false otherwise. ! ! !****************************************************************************** Recursive Subroutine InOrderTraversal(Root, FuncCall) Type (BinaryTreeNode), Pointer :: Root Logical, EXTERNAL :: FuncCall Logical :: Ok If (Associated(Root)) then Call InOrderTraversal(Root%LeftChild, FuncCall) Ok = FuncCall(Root%Info) If (Ok) Call InOrderTraversal(Root%RightChild, FuncCall) EndIf Return End Subroutine !****************************************************************************** ! ! CheckOrder - Performs an in order traversal of the binary tree to do ! an integrity check. ! ! Root - Binary tree root ! !****************************************************************************** Recursive Subroutine CheckOrder(Root) Type (BinaryTreeNode), Pointer :: Root Integer :: Result If (Associated(Root)) then Call CheckOrder(Root%LeftChild) Node_Count = Node_Count + 1 If (Associated(Check_Prev)) then Result = Compare(Check_Prev%Info, Root%Info) IF (Result==-1) then Write(*,*) 'CO: P=',Root%Info%Gmag, ' * CMP=',Result, ' * N=',Node_Count else Write(*,*) 'CO: P=',Root%Info%Gmag, ' * CMP=',Result, ' * N=',& Node_Count, ' ERR!!!!!!!!!!!!!!!' End if else Write(*,*) 'CO: P=',Root%Info%Gmag, ' * N=',Node_Count, & ' ******* START ******' End If Check_Prev => Root Call CheckOrder(Root%RightChild) EndIf Return End Subroutine !****************************************************************************** ! ! CheckIntegrity - Performs an in order traversal of the binary tree to do ! an integrity check. ! ! Root - Binary tree root ! !****************************************************************************** Subroutine CheckIntegrity(Root, N) Type (BinaryTreeNode), Pointer :: Root Integer, Intent(IN) :: N Nullify(Check_Prev) node_Count = 0 Call CheckOrder(Root) If (N==Node_Count) then Write(*,*) 'CheckIntegrity: N=Node_Count!' else Write(*,*) 'CheckIntegrity: Error!!!!! N=',N, ' * Node_Count=',Node_Count End If Return End Subroutine End Module spinpwpaw/code/bz_data.f900100664004704100470410000000376010303710172015571 0ustar natalienatalie!***************************************************************************** ! ! File : bz_data.f90 ! by : Alan Tackett ! on : 8/18/95 ! for : DOS and NOS Calculation ! ! This file defines the data structure that contains all the information ! required to calculate the density of states(DOS), number of states(NOS), ! and other integrals involving the Fermi Surface. ! !***************************************************************************** Module bz_data Type bz_struct Integer :: Method !** Integration Method Integer :: Bands !** Total Number of Energy Bands Integer :: TotalKpnts !** Number of Kpnts in grid Integer :: TotalUniq !** Number of Unique K points Integer :: TotalCubes !** Number of cubes Integer :: MaxIter !** Max number of iterations allowed Real :: Fermi !** Fermi Energy Real :: Electrons !** Number of electrons Real :: bz_Low !** Low estimate of Fermi Energy Real :: bz_High !** High estimate of Fermi Energy Real :: accuracy !** Accuracy of Fermi estimate Real :: sigma !** Gaussian smearing width Real :: CubeVol !** Cube Volume in k-space Real :: UnitCellVol !** Unit Cell Volume in k-space Real, Pointer :: Weight(:,:) !** Int. Wts - Weight(Bands,TotalKpnts) Real, Pointer :: WtUniq(:,:) !** Uniq int Wts - WtUniq(Bands,TotalUniq) Real, Pointer :: Kp(:,:) !** List of K-points - Kp(3,TotalKpnts) Real, Pointer :: Ku(:,:) !** Unique K-pnts list - Ku(3,TotalUniq) Real, Pointer :: Ke(:,:) !** K-pnt Energies - Ke(Bands,TotalKpnts) Real, Pointer :: KEu(:,:) !** Unique K-pnt KE's-KUe(Bands,TotalUniq) Integer, Pointer :: Kmap(:) !** Map from Kp->Ku Integer, Pointer :: Cube(:,:) !** Cube list - Cube(TotalCubes,Corners) End Type End Module spinpwpaw/code/bzint.f900100664004704100470410000006256210371153034015323 0ustar natalienatalie!***************************************************************************** ! ! File : bzint.f90 ! by : Alan Tackett ! on : 7/27/95 ! for : PAW Method ! ! bzint - Brillouin Zone Integration ! ! This module contains generic routines to perform BZ integration using ! several different methods. The MEthods currently implemented are : ! ! - Linear Tetrahedron (Analytic) ! - Quadratic Tetrahedron (Numerical, DOS not implemented) ! ! There is also a routine for constructing a 3-D grid of lattice points ! that can then be used for creating the tetrahedrons ! !***************************************************************************** Module bzint Use ltbzi Use qtbzi Use gaussbzi Use mathlib Use bz_data Implicit NONE !*** Define Method Constants *** Integer, Parameter :: bz_NONE = 0 !** No Method defined Integer, Parameter :: bz_LINEAR_TETRA = 1 !** Use linear Tetra w/o corr Integer, Parameter :: bz_LINEAR_TETRA_BASE = 1 !** Use linear Tetra w/o corr Integer, Parameter :: bz_LINEAR_TETRA_CORR = 2 !** Use linear Tetra w/ Corr Integer, Parameter :: bz_QUAD_TETRA = 3 !** USe quadratic tetrahedron Integer, Parameter :: bz_GAUSS = 4 !** Use gaussian smearing Integer, Parameter :: bz_SET_METHOD = 0 !** Set Method Integer, Parameter :: bz_SET_FERMI = 1 !** Set the fermi energy Integer, Parameter :: bz_SET_ElECTRONS = 2 !** # of electrons Integer, Parameter :: bz_SET_LOW = 3 !** Set lower bound for ef Integer, Parameter :: bz_SET_HIGH = 4 !** Set high bound for ef Integer, Parameter :: bz_SET_ACCURACY = 5 !** Set accuracy Integer, Parameter :: bz_SET_MAXITER = 6 !** Set Max iterations Integer, Parameter :: bz_SET_GAUSS = 7 !** Set Gaussian Width Type (bz_struct), PRIVATE :: local_bz !** Private bz for root finding Contains !***************************************************************************** ! ! bz_Init - Initialize the BZ method for use ! ! BZ - BZ Data Structure to hold all the info ! Bands - Number of Bands ! TotalKPnts - Total Number of K-points created ! Kp - K-points of grid - (ALLOCATED) ! Ke - Energy at K points - (ALLOCATED, DIMS=(Kpnt,Band)) ! Wt - List of Weights - (ALLOCATED, DIMS=(Kpnt, Band)) ! TotalCubes - TotalNumber of Cubes created ! Cube - List of Cubes - (ALLOCATED, DIMS=(cube, point)) ! CubeVol - Cube Volume. ! UCellVol - Unit Cell Volume. ! !***************************************************************************** Subroutine bz_Init(bz, Method, Bands, TotalKPnts, Kp, Ke, Wt, TotalCubes, & Cube, CubeVol, UCellVol) Type (bz_struct), Intent(OUT) :: bz Integer, Intent(IN) :: Method Integer, Intent(IN) :: Bands Integer, Intent(IN) :: TotalKpnts Real, Pointer :: Kp(:,:) Real, Pointer :: Ke(:,:) Real, Pointer :: Wt(:,:) Integer, Intent(IN) :: TotalCubes Integer, Pointer :: Cube(:,:) Real, Intent(IN) :: CubeVol Real, Intent(IN) :: UCellVol write(log_unit,*) 'Entered bz_init which no longer works' stop bz%Method = Method bz%Bands = Bands bz%TotalKpnts = TotalKpnts bz%Kp => Kp bz%Ke => Ke bz%Weight => Wt bz%TotalCubes = TotalCubes bz%Cube => Cube bz%CubeVol = CubeVol bz%UnitCellVol = UCellVol bz%TotalUniq = 0 bz%bz_High = 1 bz%bz_Low = 0 write(*,*) 'bz_Init: CV = ', CubeVol, ' UCV=', UCellVol, ' * Bands=',bands, ' * TotalKPnts=',TotalKPnts, ' Cubes=',TotalCubes Select Case (Method) Case (BZ_LINEAR_TETRA_BASE) Call InitLTBZI(Bands, 1, TotalKpnts, Kp, KE, Wt, TotalCubes, 0, & Cube, CubeVol ,UCellVol) Case (BZ_LINEAR_TETRA_CORR) Call InitLTBZI(Bands, 1, TotalKpnts, Kp, KE, Wt, TotalCubes, 0, & Cube, CubeVol ,UCellVol) Call t_DetKUsage Case (BZ_QUAD_TETRA) Call InitQTBZI(Bands, 1, TotalKpnts, Kp, KE, Wt, TotalCubes, & Cube, CubeVol ,UCellVol) Case (BZ_GAUSS) Call InitGaussBZI(bz) End Select Return End Subroutine !***************************************************************************** ! ! bz_Remap - Remaps the energy from the Unique Kpoint list to the full ! list of K points ! !***************************************************************************** Subroutine bz_Remap(bz) Type (bz_struct), Intent(OUT) :: bz Integer :: i If (Size(bz%Ku) <= 0) RETURN Do i=1, Bz%TotalKpnts bz%KE(:, bz%KMap(i)) = bz%KEu(:, i) End Do Return End Subroutine !***************************************************************************** ! ! bz_Sort - Sorts the energy Levels based on the particular method. ! !***************************************************************************** Subroutine bz_Sort(bz) Type (bz_struct), Intent(INOUT) :: bz Select Case (bz%Method) Case (BZ_LINEAR_TETRA_BASE) Call t_Sort Case (BZ_LINEAR_TETRA_CORR) Call t_Sort End Select End Subroutine !***************************************************************************** ! ! bz_PrepEnergy - ReMaps the Uniq Kpoint energy levels to the full set ! of Kpoint energys and also sorts them if required. ! !***************************************************************************** Subroutine bz_PrepEnergy(bz) Type (bz_struct), Intent(OUT) :: bz Call bz_Remap(bz) Call bz_Sort(bz) Return End Subroutine !***************************************************************************** ! ! BZ_MakeGrid - Creates a 3-D grid of lattice points based on the supplied ! Basis. ! ! BZ - Data structure to store all the info ! Basis - Basis to use for lattice points ! Rmin - Array on Min values in units of BASIS vectors ! Rmax - Array of Max values in units of BASIS vectors ! Bands - Number of Bands ! NCubes - Array containing the number of cubes to create along each axis ! NCubeEdge - Array containing the number of points each cube dimension needs ! DoInitMethod - Calls the appropriate init routine based on the ! method selected. Also sets the method. ! You still need to call bz_Set or bz_Set_All to configure ! the remaining parameters.(OPTIONAL) ! UCellVol - Unit Cell Volume required if DoInitMethod is used. ! ! Return Values ! This routine allocates space for various arrays needed for performing ! the BZ integration and returns numerous items all stored in bz. ! The following is a list of the parameters returned in bz: ! ! KPe and Wt - Allocated only, not used. ! Kp, Kuniq, Cube, TotalKpnts, TotalCubes - Allocated and used ! !***************************************************************************** Subroutine BZ_MakeGrid(BZ,Basis, Rmin, Rmax, Bands, NCubes, & NCubeEdge, DoInitMethod, UCellVol) Implicit NONE Type (bz_struct), Intent(OUT) :: bz Real, Intent(IN) :: Basis(3,3) Real, Intent(IN) :: Rmin(3) Real, Intent(IN) :: Rmax(3) Integer, Intent(IN) :: Bands Integer, Intent(IN) :: NCubes(3) Integer, Intent(IN) :: NCubeEdge(3) Integer, OPTIONAL,Intent(IN) :: DoInitMethod Real, OPTIONAL,Intent(IN) :: UCellVol Integer :: i,j,k, n, m, sy, sz, sx0, sy0, sz0, Npnts(3) Integer :: ix, iy, iz, base, offset, bz_method, TotKpnts, TotCubes Integer, Pointer :: Corner(:), Cube(:,:) Real, Pointer :: Kp(:,:), Ke(:,:), Wt(:,:) Real :: x, y, z, delta(3), CVol write(log_unit,*) 'Entered BZ_MakeGrid which no longer works' stop Npnts = nCubes*(nCubeEdge-1) + 1 n = Product(NPnts) Allocate(Kp(3,n), bz%Ku(3,n), STAT=i) If (i/=0) then Write(*,*) 'bz_MakeGrid: Error during Kp,Ku allocate. Size:',n STOP End If Allocate(Ke(Bands, n), BZ%KeU(Bands, n), STAT=i) If (i/=0) then Write(*,*) 'bz_MakeGrid: Error during KE, KEU allocate. Size:',n STOP End If Allocate(Wt(Bands, n), BZ%WtUniq(Bands,n), STAT=i) If (i/=0) then Write(*,*) 'bz_MakeGrid: Error during Wt,WtUniq allocate. Size:',n STOP End If Allocate(Cube(Product(nCubes), Product(nCubeEdge)), STAT=i) If (i/=0) then Write(*,*) 'bz_MakeGrid: Error during Cube allocate. Size:',n STOP End If delta = (Rmax - Rmin)/(Npnts-1) n = 0 !Do z = Rmin(3), Rmax(3), delta(3) !Do y = Rmin(2), Rmax(2), delta(2) !Do x = Rmin(1), Rmax(1), delta(1) Do k=1,Npnts(3) z=Rmin(3)+delta(3)*(k-1) Do j=1,Npnts(2) y=Rmin(2)+delta(2)*(j-1) Do i=1,Npnts(1) x=Rmin(1)+delta(1)*(i-1) n = n + 1 Kp(1:3, n) = MATMUL(Basis, (/ x, y, z /)) End Do End Do End Do TotKPnts = n sy = Npnts(1) sz = sy * Npnts(2) sx0 = nCubeEdge(1)-1 sy0 = sy * (nCubeEdge(1)-1) sz0 = sz * (nCubeEdge(2) - 1) n = 0 Do k=0, nCubes(3)-1 Do j=0, nCubes(2)-1 Do i=0, nCubes(1)-1 n = n + 1 Corner => Cube(n,:) m = 0 base = 1 + sx0*i + sy0*j + sz0*k Do iz=0, nCubeEdge(3)-1 Do iy=0, nCubeEdge(2)-1 Do ix=0, nCubeEdge(1)-1 m = m + 1 Corner(m) = base + ix + sy*iy + sz*iz End Do End Do End Do End Do End Do End Do TotCubes = n if (PRESENT(DoInitMethod) .AND. PRESENT(UCellVol)) then bz_Method = DoInitMethod CVol = Product(Delta) * Product(nCubeEdge-1) !Subroutine bz_Init(bz, Method, Bands, TotalKPnts, Kp, Ke, Wt, TotalCubes, & ! Cube, CubeVol, UCellVol) Call bz_Init(bz,bz_Method,Bands,TotKpnts,KP,KE,Wt, & TotCubes,Cube,CVol,UCellVol) End IF Return End Subroutine !***************************************************************************** ! ! bz_UniqueKpnts - Takes a list of Kpoints and determines which points in ! the list are unique. IF Uniq_Size >= 0 then it is assumed that ! the following arrays have the sizees: BZ%Ku(3, Uniq_Size) and ! BZ%KEu(BZ%TotalBands, Uniq_Size) ! ! BZ - Data structure to store all the info ! Basis - Real Space Cartesian Crystal Lattice Basis ! RotMatrix - List of Rotation Matrices - RotMatrix(3,3,TotRot) ! TotRot - Number of Rotation Matrices ! Uniq_Size - Number of Unique K points. If this value is <= 0 then ! the number of unique K-points are calculated and the ! value is returned. The unique list is NOT created in this case. ! ! ! Algorithm ! The method used to determine if a K point is unique is based on the ! following relation ! ! B . V = 2*Pi*n ! i i ! ! where B(i) = Real space basis vector ! A(i) = Reciprocal space basis vector ! V = n(1)*A(1) + n(2)*A(2) + n(3)*A(3) is an arbirtary vector ! ! If n(1),n(2), and n(3) are integers then V is a reciprocal lattice vector. ! Define V = Rk-k', where R=rotation matrix, k=K point in question, and ! k' is an already defined unique k-point. If V is NOT a reciprocal lattice ! vector for SOME choice of R and k' currently specified then k is a unique ! k-point. ! ! Return Values ! Kmap, Kuniq, and KEuniq, are allocated arrays returned along with TotUniq ! !***************************************************************************** Subroutine bz_UniqueKpnts(bz, Basis, RotMatrix, TotRot, Uniq_Size) Implicit NONE Type (bz_struct), Intent(INOUT) :: bz Real, Intent(IN) :: Basis(3,3) Real, Intent(IN) :: RotMAtrix(:,:,:) Integer, Intent(IN) :: TotRot Integer, Intent(INOUT) :: Uniq_Size Real, PARAMETER :: err = 0.0001 Real :: V(3), n1, n2, n3 Integer :: i,j, k, Num_Uniq Logical :: Used write(log_unit,*) 'Entered bz_UniqueKpnts which no longer works' stop if (Uniq_Size > 0) then bz%Ku(:, 1) = bz%Kp(:,1) bz%KMap(1) = 1 End If Num_Uniq = 1 Do i=2, bz%TotalKpnts Used = .FALSE. j = 1 Do While ((.NOT. Used) .AND. (j <= Num_Uniq)) !** Loop over Uniq pnts k = 1 Do While ((.NOT. Used) .AND. (k <= TotRot)) !** Loop over RotMat V = MATMUL(RotMatrix(1:3,1:3, k), bz%Kp(1:3,i)) - bz%Ku(1:3,j) n1 = DOT_PRODUCT(Basis(1:3,1), V) / (2*PI) n2 = DOT_PRODUCT(Basis(1:3,2), V) / (2*PI) n3 = DOT_PRODUCT(Basis(1:3,3), V) / (2*PI) if (IsInteger(n1,err) .AND. IsInteger(n2,err) & .AND. IsInteger(n3,err) .AND. (Uniq_Size>0)) then Used = .TRUE. bz%KMap(i) = k End If k = k + 1 End Do j = j + 1 End Do if (.NOT. Used) then Num_Uniq = Num_Uniq + 1 if (Uniq_Size > 0) bz%Ku(1:3,Num_Uniq) = bz%Kp(1:3, i) End If End Do i = bz_ReallocUnique(bz, Uniq_Size) If (i /= 0) then Write(*,*) 'bz_UniqueKPnts: Error during bz_ReallocaUnique, Uniq_size=',& Uniq_Size End If Return End Subroutine !***************************************************************************** ! ! bz_AllocUnique - Allocates the space for the unique K-points list ! and associated data structures required ! ! Uniq_Size - Size of the unique K-points list ! ! Return Values ! The allocation error status is returned ! !***************************************************************************** Integer Function bz_ReallocUnique(bz, Uniq_Size) Implicit NONE Type (bz_struct), Intent(INOUT) :: bz Integer, Intent(INOUT) :: Uniq_Size Integer :: ierr ! Real, Target :: A(bz%Bands, Uniq_Size) Real, Target , allocatable :: A(:,:) Allocate(A(bz%Bands, Uniq_Size)) bz%TotalUniq = Uniq_Size If (Uniq_Size > 0) then A = bz%Keu(:,1:Uniq_Size) Deallocate(BZ%Keu) Allocate(bz%Keu(Bz%BAnds, Uniq_Size), STAT=ierr) bz%Keu(:,1:Uniq_Size) = A A = bz%WtUniq(:,1:Uniq_Size) Deallocate(BZ%WtUniq) Allocate(bz%WtUniq(Bz%BAnds, Uniq_Size), STAT=ierr) bz%WtUniq(:,1:Uniq_Size) = A A(1:3, 1:Uniq_Size) = Bz%Ku(1:3, 1:Uniq_Size) DeAllocate(BZ%Ku) Allocate(bz%Ku(3, Uniq_Size), STAT=ierr) Bz%Ku(1:3, 1:Uniq_Size) = A(1:3, 1:Uniq_Size) else DeAllocate(Bz%Ku, Bz%KEu, bz%WtUniq, STAT=ierr) End If bz_ReallocUnique = ierr DeAllocate(A) Return End Function !***************************************************************************** ! ! bz_Set_Weights - Simply sets the pointer to the integration weights ! ! BZ - Data structure to store all the info ! Wt - Array containing integration weights. Same size as Ke ! !***************************************************************************** Subroutine bz_Set_Weights(bz, Wt) Implicit NONE Type (bz_struct), Intent(INOUT) :: bz Real, Pointer :: Wt(:,:) bz%Weight => Wt Return End Subroutine !***************************************************************************** ! ! bz_Set - Sets a BZ integration value ! ! BZ - Data structure to store all the info ! Set - BZ Value to set ! Val - Value to store ! !***************************************************************************** Subroutine bz_Set(bz, Set, Val) Implicit NONE Type (bz_struct), Intent(INOUT) :: bz Integer, Intent(IN) :: Set Real, Intent(IN) :: Val Select Case (Set) Case (bz_SET_METHOD) bz%Method = Val Case (bz_SET_FERMI) bz%Fermi = Val Case (bz_SET_ELECTRONS) bz%Electrons = Val Case (bz_SET_LOW) bz%bz_Low = Val Case (bz_SET_HIGH) bz%bz_High = Val Case (bz_SET_ACCURACY) bz%Accuracy = VAl Case (bz_SET_MAXITER) bz%MaxIter = VAl Case (bz_SET_GAUSS) bz%Sigma = Val End Select Return End Subroutine !***************************************************************************** ! ! bz_Get - Returns a BZ integration value ! ! BZ - Data structure to store all the info ! Get - BZ Value to Get ! !***************************************************************************** Real Function bz_Get(bz, Get) Implicit NONE Type (bz_struct), Intent(INOUT) :: bz Integer, Intent(IN) :: Get Select Case (Get) Case (bz_SET_METHOD) bz_Get = bz%Method Case (bz_SET_FERMI) bz_Get = bz%Fermi Case (bz_SET_ELECTRONS) bz_Get = bz%Electrons Case (bz_SET_LOW) bz_Get = bz%bz_Low Case (bz_SET_HIGH) bz_Get = bz%bz_High Case (bz_SET_ACCURACY) bz_Get = bz%Accuracy Case (bz_SET_MAXITER) bz_Get = bz%MaxIter Case (bz_SET_GAUSS) bz_Get = bz%Sigma End Select Return End Function !***************************************************************************** ! ! bz_Set_All - Sets all BZ integration values ! ! BZ - Data structure to store all the info ! Method - BZ method to use ! Fermi - Fermi Energy ! elec - # of electrons ! ef_Low - Lower bound on Fermi energy ! ef_High - Upper bound on Fermi Energy ! Accuracy - Fermi Energy Accuracy ! MaxIter - Max iteration for fincing ef ! !***************************************************************************** Subroutine bz_Set_All(bz,Method,Fermi,elec, ef_Low, ef_High, Accuracy, & MaxIter, Sigma) Type (bz_struct), Intent(INOUT) :: bz Integer, Intent(IN) :: Method Real, Intent(IN) :: Fermi Real, Intent(IN) :: Elec Real, Intent(IN) :: ef_Low Real, Intent(IN) :: ef_High Real, Intent(IN) :: Accuracy Integer, Intent(IN) :: MaxIter Real, OPTIONAL, Intent(IN) :: Sigma bz%Method = Method bz%Fermi = Fermi bz%Electrons = Elec bz%bz_Low = ef_Low bz%bz_High = ef_High bz%Accuracy = Accuracy bz%MaxIter = MaxIter If (Present(Sigma)) bz%Sigma = Sigma Return End Subroutine !***************************************************************************** ! ! bz_Get_All - Gets all BZ integration values ! ! BZ - Data structure to store all the info ! Method - BZ method ! Fermi - Fermi Energy ! Elec - # of electrons ! ef_Low - Lower bound on Fermi energy ! ef_High - Upper bound on Fermi Energy ! Accuracy - Fermi Energy Accuracy ! !***************************************************************************** Subroutine bz_Get_All(bz,Method, Fermi,Elec, ef_Low,ef_High, Accuracy, & MaxIter, Sigma) Implicit NONE Type (bz_struct), Intent(IN) :: bz Integer, Intent(OUT) :: Method Real, Intent(OUT) :: Fermi Real, Intent(OUT) :: Elec Real, Intent(OUT) :: ef_Low Real, Intent(OUT) :: ef_High Real, Intent(OUT) :: Accuracy Integer, Intent(OUT) :: MaxIter Real, OPTIONAL, Intent(OUT) :: Sigma Method = bz%Method Fermi = bz%Fermi Elec = bz%Electrons ef_Low = bz%bz_Low ef_High = bz%bz_High Accuracy = bz%Accuracy MaxIter = bz%MaxIter If (Present(Sigma)) Sigma = bz%Sigma Return End Subroutine !***************************************************************************** ! ! bz_DOS - Calculates the Density of States ! ! BZ - Data structure to store all the info ! !***************************************************************************** Real Function bz_DOS(bz) Implicit NONE Type (bz_struct), Intent(IN) :: bz Real :: Energy(1), DOS(1) Select Case (bz%Method) Case (BZ_LINEAR_TETRA_BASE) Energy(1) = bz%Fermi Call t_DOS(1, Energy, DOS) Case (BZ_LINEAR_TETRA_CORR) Energy(1) = bz%Fermi Call t_DOS(1, Energy, DOS) Case (BZ_QUAD_TETRA) write(*,*) 'bz_DOS: DOS not currently implemented with BZ_QUAD_TETRA!!' DOS(1) = 0 Case (BZ_GAUSS) write(*,*) 'bz_DOS: DOS not currently implemented with BZ_GAUSS!!' DOS(1) = 0 End Select bz_DOS = DOS(1) Return End Function !***************************************************************************** ! ! bz_NOS - Calculates the Number of States ! ! BZ - Data structure to store all the info ! !***************************************************************************** Real Function bz_NOS(bz) Implicit NONE Type (bz_struct), Intent(INOUT) :: bz Real :: Energy(1), NOS(1) !Write(*,*) 'bz_NOS: Fermi=',bz%Fermi Select Case (bz%Method) Case (BZ_LINEAR_TETRA_BASE) Energy(1) = bz%Fermi Call t_NOS(1, Energy, NOS) Case (BZ_LINEAR_TETRA_CORR) Energy(1) = bz%Fermi Call t_NOS(1, Energy, NOS) Case (BZ_QUAD_TETRA) NOS(1) = qt_NOS(bz%Fermi) !write(*,*) ' bz_NOS: qt_NOS = ',NOS(1) Case (BZ_GAUSS) NOS(1) = Gauss_NOS(bz) End Select bz_NOS = NOS(1) Return End Function !***************************************************************************** ! ! bz_Occupy - Calculates the occupancies of the system ! ! BZ - Data structure containing BZ info ! Occ - Array containing the Unique occupancies ! !***************************************************************************** Subroutine BZ_Occupy(BZ, Occ) Type (bz_struct), Intent(INOUT) :: bz Real, Intent(OUT) :: Occ(:,:) Real :: nos Occ = 0 Select Case (bz%Method) Case (BZ_LINEAR_TETRA_BASE) Write(*,*) 'BZ_Occupy: Not implemented for BZ_LINEAR_TETRA_BASE!' STOP Case (BZ_LINEAR_TETRA_CORR) Write(*,*) 'BZ_Occupy: Not implemented for BZ_LINEAR_TETRA_CORR!' STOP Case (BZ_QUAD_TETRA) Write(*,*) 'BZ_Occupy: Not implemented for BZ_QUAD_TETRA!' STOP Case (BZ_GAUSS) nos = Gauss_NOS(BZ, Occ) End Select Return End Subroutine !***************************************************************************** ! ! bz_Weights - Calculates the Integration Weights ! ! BZ - Data structure to store all the info ! !***************************************************************************** Subroutine bz_Weights(bz) Implicit NONE Type (bz_struct), Intent(INOUT) :: bz Select Case (bz%Method) Case (BZ_LINEAR_TETRA_BASE) Call t_CalcWeights(bz%Fermi, TETRA_BASE_ONLY) Case (BZ_LINEAR_TETRA_CORR) Call t_CalcWeights(bz%Fermi,TETRA_BOTH) Case (BZ_QUAD_TETRA) Call qt_Weights(bz%fermi) Case (BZ_GAUSS) Call Gauss_Weights(bz) End Select Return End Subroutine !***************************************************************************** ! ! bz_FuncDer - Function for calculating the generic NOS and DOS. ! Internal Use Only. ! ! x - Energy ! fn - NOS ! deriv - DOS ! !***************************************************************************** Real Function bz_FuncDer(x, fn, deriv) Implicit NONE Real, Intent(IN) :: x Real, Intent(OUT) :: fn Real, Intent(OUT) :: deriv local_bz%Fermi = x fn = bz_NOS(local_bz) - local_bz%Electrons deriv = bz_DOS(local_bz) bz_FuncDer = fn Return End Function !***************************************************************************** ! ! bz_Func - Function for calculating the generic NOS and DOS. ! Internal Use Only. ! ! x - Fermi Energy ! !***************************************************************************** Real Function bz_Func(x) Implicit NONE Real, Intent(IN) :: x local_bz%Fermi = x bz_Func = bz_NOS(local_bz) - local_bz%Electrons Return End Function !***************************************************************************** ! ! bz_CalcFermi - Calculates the Fermi Energy Surface given the number ! of Electrons. ! ! BZ - Data structure to store all the info ! NumFunc - (OPTIONAL) Returns the number of Function evaluations ! ! Return Values ! Returns the Fermi Energy AND sets the Fermi Energy for subsequent ! calculations ! !***************************************************************************** Real Function bz_CalcFermi(bz, NumFunc) Implicit NONE Type (bz_struct), Intent(INOUT) :: bz Integer, Optional, Intent(OUT) :: NumFunc Integer :: i, j, k local_bz = bz bz%bz_Low = MinVal(Bz%Keu); bz%bz_High = MaxVal(Bz%Keu); i = brak_grow(bz_Func, bz%bz_Low, bz%bz_High, j) if (i==0) then write(*,*) 'bz_CalcFermi: Could not bracket root!' write(*,*) 'bz_CalcFermi: After Brak_Grow----------------------' write(*,*) 'bz_CalcFermi: Range:',bz%bz_Low, ' * ',bz%bz_High, ' * ',bz%Accuracy Write(*,*) 'bz_CalcFermi: MaxITer = ', bz%MaxIter End If Select Case (bz%Method) Case (BZ_LINEAR_TETRA_BASE) bz%Fermi =rt_Brent(bz_Func,bz%bz_Low,bz%bz_High,bz%Accuracy,bz%MaxIter,k) Case (BZ_LINEAR_TETRA_CORR) bz%Fermi =rt_Brent(bz_Func,bz%bz_Low,bz%bz_High,bz%Accuracy,bz%MaxIter,k) Case (BZ_QUAD_TETRA) bz%Fermi =rt_Brent(bz_Func,bz%bz_Low,bz%bz_High,bz%Accuracy,bz%MaxIter,k) Case (BZ_GAUSS) bz%Fermi =rt_Brent(bz_Func,bz%bz_Low,bz%bz_High,bz%Accuracy,bz%MaxIter,k) End Select bz_CalcFermi = bz%Fermi if (PRESENT(NumFunc)) NumFunc = j+k Return End Function !***************************************************************************** ! ! bz_Integrate - Calculates the weighted integral of the function over the ! BZ. Assumes the weights have already been calculated ! ! BZ - Data structure to store all the info ! Fn - Function evaluated at each k pnt and band, must have same dim as Ke. ! !***************************************************************************** Real Function bz_Integrate(bz, Fn) Implicit NONE Type (bz_struct), Intent(IN) :: bz Real, Intent(IN) :: Fn(:,:) bz_Integrate = Sum(Fn*bz%Weight) Return End Function End Module spinpwpaw/code/charges.f900100664004704100470410000013417510303710172015606 0ustar natalienatalie!****************************************************************************** ! ! File : charges.f90 ! by : Natalie Holzwarth ! on : 9/2/99 ! for : PAW program ! ! Module for calculating grids and integrals of charge density ! ! Updated for spin by Ping Tang and N. A. W. Holzwarth ! Last modified on 5/23/05 !****************************************************************************** Module charges Use mathlib Use paw_inout Use atom_data Use crystal_data Use doijmatrix Use gpoints Use options_data Use projectors Use mem_data Use memmgr Use word Use relaxsys Use strings Implicit NONE!!!!!!!!!!!!!! !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! Bandcharge - Calculates charge in spheres for partial density of ! states analysis. If sphere contains an atomic site, radius ! must be at least rc. (Should be checked before calling this ! program.) ! ! Input: ! Nsphere -- number of spheres (0 for DOS output only) ! Iter -- number of iterations for RelaxElectron call ! Tol -- tolerance of error for RelaxElectron call ! For Nsphere > 0, the following variables are read in: ! Asite -- logical array; true if sphere is on atom site ! Map -- integer array; if Asite(i)=.true. then Map(i)=atom index ! Centers -- real array; Center(1:3,i) = sphere center in fractional coord ! Center(4,i) = sphere radius ! Note: If Asite(i)=.true., Center(4,i)>=Rc ! If Asite(i)=.false., only plane wave charge is calculated ! In the input paw file after the CALCULATE PDOS (Nsphere #), the file ! should contain the following Nsphere entries: (Note -- this program ! is not designed to combine charges for more than one center. If ! crystal has more than one equivalent site, one should calculate ! the charge within each and add them together in the analysis pgm.) ! ! For each sphere, list: ! Keyword ! If Keyword=atom, then list: ! Name, radius -- where Name corresponds to Atom_list(i)%Name ! and where radius >= AtomType_Info(k)%Rc ! If Keyword/=atom, then list: ! Fractional position, radius (no checking done) ! ! Input should end with "End" ! ! Output: ! Results written to file ! !****************************************************************************** Subroutine Bandcharge(Nsphere,WC) Integer, Intent(IN) :: Nsphere Type (Word_Context), Intent(INOUT) :: WC ! Integer :: Iter,Map(Nsphere) ! Logical :: Asite(Nsphere) , tmplog, EConverged ! Real :: Center(4,Nsphere),Tol,Etol ! Real :: Charge(Nsphere),wgt ! Real :: G(3), GM, BlochK(3), con,arg ,R(3,Nsphere) ! Integer :: Kpnt, PsiB, PsiK, Psi_toUse(Mem_Mapsize) Integer :: Iter Integer,allocatable :: Map(:) Logical :: tmplog, EConverged Logical,allocatable :: Asite(:) Real :: Tol,Etol,wgt,G(3),GM,BlochK(3),con,arg Real ,allocatable :: Center(:,:),Charge(:),R(:,:) Integer :: Kpnt, PsiB, PsiK Integer,allocatable :: Psi_toUse(:) Integer :: gi, N, j,k, t, tlen ,i , ib Integer :: atom,nili,njlj,li,lj,mi,mj Complex :: zz Type (Mem_handle) , pointer :: psi Complex, pointer :: WK(:),PDOT(:) ,psi1(:) Character*100 :: keyword,token Allocate(Map(Nsphere),Asite(Nsphere),Center(4,Nsphere),R(3,Nsphere)) Allocate(Charge(Nsphere),Psi_ToUse(Mem_Mapsize)) If (Bandstructure_mode) then Write(Error_Unit,*) & 'Error in Bandcharges -- not yet programmed for Band Structure mode' stop Endif Bandstructure_mode=.true. DoLCAO=0 Call GetNumber(WC,Iter) If (Iter.lt.3) Iter=10 Call GetNumber(WC,Tol) If (Tol.lt.1.e-13) Tol=0.001 write(Log_Unit,*) 'Calling RelaxElectrons with iter,tol,minbands=',& Iter, Tol, MinBands write(Log_Unit,*) 'Eigen_MAX =', Eigen_MAX Call RelaxElectrons(Iter, Tol, Etol, EConverged) t = 0 Do Kpnt=1,NumKpnts Do i=1,Mem_MapSize If (Kpnt==PsiInfo(i)%Kpnt.and.PsiInfo(i)%Energy.le.Eigen_Max) t=t+1 Enddo Enddo write(CHARGEOUT_UNIT,*) t ! list total number of bands in output If (Nsphere.gt.0) then Asite=.true.; Center=0; Map=0 ! Input for partial density information i=0 Do Call GetNextWord(WC,keyword,tlen) Call UpperCase(keyword) If (trim(keyword) == "END") exit i=i+1 if (i.gt.Nsphere) then write(Error_Unit,*) 'error in bandcharge -- too many spheres',i,Nsphere stop endif If (trim(keyword) == "ATOM") then Asite(i)=.true. Call GetNextWord(WC,keyword,tlen) if (tlen<=0) then write(Error_Unit,*)& 'error in bandcharge -- next item should be atom label' stop endif do j=1,Specific_Atoms if (trim(keyword)==trim(Atom_list(j)%Name)) then Map(i)=j Center(1:3,i)=Atom_list(j)%Frac_Pos Call GetNumber(WC, con) Center(4,i)=MAX(con,AtomType_Info(Atom_list(j)%TypeIndex)%Rc) write(CHARGEOUT_UNIT,'(i4," atom = ",a5,5x,"radius = ",1pe15.7)') & i, trim(keyword),Center(4,i) write(LOG_UNIT,'(i4," atom = ",a5,5x,"radius = ",1pe15.7)') & i, trim(keyword),Center(4,i) Exit Endif Enddo if (Map(i).eq.0) then write(Error_Unit,*)& 'error in bandcharge -- rc not correct',i,con stop endif else Asite(i)=.false. Call GetNumbers(WC,Center(1:4,i)) write(CHARGEOUT_UNIT,'(i4," interstial site at ",1p3e15.7," radius = ",1pe15.7)') i,Center(1:4,i) Endif Enddo if (i.ne.Nsphere) then write(error_unit,*) 'input error in bandcharge', i, Nsphere stop endif Allocate(WK(FFT_Grid(4,G_HIGH)),stat=j) if (j.ne.0) then write(Error_Unit,*) 'error allocating work array in bandcharge', & FFT_Grid(4,G_HIGH) stop endif Do i=1,Nsphere R(1:3,i)=MATMUL(Xtal%Basis,Center(1:3,i)) !Change to Cartesian Coord. Enddo Endif N=Gpnt_Size(G_HIGH)-1 Do Kpnt=1,NumKpnts BlochK = BZ%Ku(:,Kpnt) wgt=bz%WtUniq(1,Kpnt) Psi_toUse=MH_Skip Where (PsiInfo(:)%Kpnt==Kpnt) Psi_toUse=MH_toProcess Call Phase_Generic(Psi_toUse,Kpnt) Call GetNextPsi(ib,Psi) Do While (ib>0) i=Psi%Index PsiInfo(i)%DoSave=1 PsiInfo(i)%Available=Mem_Used If(PsiInfo(i)%Energy.le.Eigen_Max) then If(.not.spindependence) then write(CHARGEOUT_UNIT,'(1p5e15.7)') BlochK,wgt,PsiInfo(i)%Energy else if(PsiInfo(i)%spinup) & write(CHARGEOUT_UNIT,'(1p5e15.7," up")') BlochK,wgt,PsiInfo(i)%Energy if(.not.PsiInfo(i)%spinup) & write(CHARGEOUT_UNIT,'(1p5e15.7," dn")') BlochK,wgt,PsiInfo(i)%Energy endif If (Nsphere.gt.0) then Psi1=>Psi%Ptr Call FilterValue(Psi1) WK = 0 WK(FFTMap_High(1:Gpnt_Size(G_Low))) = Psi1(1:Gpnt_Size(G_Low)) t = Gpnt_Size(G_Low)+1 j = Gpnt_Size(G_HIGH)+1; k = j + (Gpnt_Size(G_Low)-1) - 1 WK(FFTMap_High(j:k)) = Psi1(t:) Call PerformFFT(FFT_TO_R, G_HIGH, WK) WK = CONJG(WK)*WK Call PerformFFT(FFT_TO_G, G_HIGH, WK) WK = Four_Pi * WK / xtal%volume ! calculate plane wave contributions to charges Do j=1,Nsphere charge(j)=(center(4,j)**3)*WK(FFTMap_High(1))/3 Enddo Do gi=2,Gpnt_Size(G_HIGH) GM=Gpnt(4,gi) G=Gpnt(1:3,gi) do j=1,Nsphere arg=GM*center(4,j) con=(sin(arg)-arg*cos(arg))/(GM**3) arg=Dot_product(G,R(1:3,j)) zz=cmplx(cos(arg),sin(arg)) charge(j)=charge(j) + con*zz*WK(FFTmap_High(gi)) & + con*conjg(zz)*WK(FFTmap_High(N+gi)) Enddo Enddo ! write(CHARGEOUT_UNIT,'(1p5e15.7)') (charge(j),j=1,Nsphere) !remove this ! Correct for charges within atomic spheres PDOT =>PsiInfo(i)%PDOT Call CalcProjProducts(psi1,PDOT) Do j=1,Nsphere If (Asite(j)) then atom = Map(j) do t=1,PLM_MAX if (atom.eq.PLM(1,t)) then nili=PLM(2,t) li =PLM(3,t) mi =PLM(4,t) zz=0 Do k=PLM_AtomRange(1,atom),PLM_AtomRange(2,atom) njlj=PLM(2,k) lj =PLM(3,k) mj =PLM(4,k) zz=zz+OijMatrix(atom,nili,njlj,li,lj,mi,mj)*PDOT(k) Enddo charge(j)=charge(j)+conjg(PDOT(t))*zz Endif Enddo EndIf Enddo write(CHARGEOUT_UNIT,'(1p5e15.7)') (charge(j),j=1,Nsphere) Endif ! Nsphere > 0 Endif ! Energy<=Eigen_Max Call GetNextPsi(ib,Psi) Enddo !ib Enddo !Kpnt Bandstructure_mode = .false. DeAllocate(WK) DeAllocate(Map,Asite,Center,R,Psi_ToUse,charge) Return End Subroutine !***************************************************************************** ! ! Partialden ! ! Input: ! Nranges -- number of energy ranges ! Iter -- number of iterations for RelaxElectron call ! Tol -- tolerance of error for RelaxElectron call ! ! For each range, list: ! OCC ! / filename ebegin eend ! \ ! NOT ! where OCC (or occupied) means program should use stored occupancy ! and NOT (or any other keyword (no spaces) means prgram uses ! BZ weight factor times full occupancy ! ! Input should end with "End" ! ! Output: ! Results written to file -- ! If spindependence, write spinup results then spindown results ! !****************************************************************************** Subroutine Partialden(Nranges,WC) Integer , Intent(IN) :: Nranges Type (Word_Context), Intent(INOUT) :: WC Integer :: Iter Integer :: Kpnt, PsiB, PsiK, Psi_toUse(Mem_Mapsize) Integer :: gi, N, j,k, t, tlen ,i , ib ,irange ,a , Base Real :: Tol,Etol, Ebegin(Nranges),Eend(Nranges) Real :: wgt,charge Real :: G(3), GM, BlochK(3), con,arg Complex :: zz Type (Mem_handle) , pointer :: psi Complex, pointer :: WK(:),DEN(:),PDOT(:) ,psi1(:), Wij(:,:) Complex, pointer :: DENspin(:),Wijspin(:,:) Character*100 :: Filename(Nranges) Character*100 :: token,keyword Logical :: Useocc(Nranges),tmplog, EConverged Call GetNumber(WC,Iter) If (Iter.lt.3) Iter=10 Call GetNumber(WC,Tol) If (Tol.lt.1.e-13) Tol=0.001 write(Log_Unit,*) 'Entering Partialden with Nranges,Iter,tol',Nranges,Iter,tol !Input for partial density ranges i=0 Do Call GetNextWord(WC,keyword,tlen) Call UpperCase(keyword) If (trim(keyword) == "END") exit i=i+1 if (i.gt.Nranges) then write(Error_Unit,*) 'error in partialden -- too many ranges',i,Nranges stop endif Useocc(i)=.false. If (keyword(1:3) == "OCC") Useocc(i)=.true. Call GetNextWord(WC,keyword,tlen) If (tlen.le.0) then write(error_unit,*) 'error in partialden -- no file name' stop Endif Filename(i)=keyword Call GetNumber(WC,Ebegin(i)) Call GetNumber(WC,Eend(i)) write(Log_Unit,'("Range ",i3," file = ",a20," range = ",1p2e15.7)') & i, trim(Filename(i)),Ebegin(i),Eend(i) write(Output_Unit,'("Range ",i3," file = ",a20," range = ",1p2e15.7)') & i, trim(Filename(i)),Ebegin(i),Eend(i) If (Eend(i) < Ebegin(i)) then write(error_unit,*) 'error in partialden -- eend < ebegin' stop Endif If (Eend(i) > Eigen_Max) Eigen_Max=Eend(i) Enddo if (i.ne.Nranges) then write(error_unit,*) 'input error in partialden', i, Nranges stop endif If (Bandstructure_mode) then Write(Error_Unit,*) & 'Error in Bandcharges -- not yet programmed for Band Structure mode' stop Endif Bandstructure_mode=.true. DoLCAO=0 write(Log_Unit,*) 'Calling RelaxElectrons with iter,tol,minbands=',& Iter, Tol, MinBands write(Log_Unit,*) ' Eigen_Max = ',Eigen_Max Call RelaxElectrons(Iter, Tol, Etol, EConverged) Allocate(WK(FFT_Grid(4,G_HIGH)),DEN(FFT_Grid(4,G_HIGH)),stat=j) If (spindependence) Allocate(DENspin(FFT_Grid(4,G_HIGH)),stat=j) if (j.ne.0) then write(Error_Unit,*) 'error allocating work array in partialden', & FFT_Grid(4,G_HIGH) stop endif N=Gpnt_Size(G_HIGH)-1 Do irange=1,Nranges Open(unit=CHARGEOUT_UNIT,file=trim(Filename(irange)),form='unformatted') Write(CHARGEOUT_UNIT) Ebegin(irange),Eend(irange),Useocc(irange) If (spindependence) then Open(unit=SCRATCH_UNIT,file=trim(Filename(irange))//'spindn',form='unformatted') Write(SCRATCH_UNIT) Ebegin(irange),Eend(irange),Useocc(irange) endif DEN=0 if (spindependence) DENspin=0 Do a = 1 ,Specific_Atoms Atom_List(a)%Wij = 0 if (spindependence) Atom_List(a)%Wijspin = 0 Enddo Do Kpnt=1,NumKpnts Psi_toUse=MH_Skip If (Useocc(irange)) then Where ((PsiInfo(:)%Kpnt == Kpnt) .AND. (PsiInfo(:)%Occupancy >1E-10)) Psi_toUse = MH_toProcess End Where Else wgt=bz%WtUniq(1,Kpnt) Where (PsiInfo(:)%Kpnt==Kpnt) Psi_toUse=MH_toProcess Endif Call Phase_Generic(Psi_toUse,Kpnt) Call GetNextPsi(ib,Psi) Do While (ib>0) i=Psi%Index PsiInfo(i)%DoSave=1 PsiInfo(i)%Available=Mem_Used If (Useocc(irange)) wgt=PsiInfo(i)%Occupancy If(PsiInfo(i)%Energy.le.Eend(irange).AND. & PsiInfo(i)%Energy.ge.Ebegin(irange).AND. wgt>1.e-10) then Psi1=>Psi%Ptr Call FilterValue(Psi1) WK = 0 WK(FFTMap_High(1:Gpnt_Size(G_Low))) = Psi1(1:Gpnt_Size(G_Low)) t = Gpnt_Size(G_Low)+1 j = Gpnt_Size(G_HIGH)+1; k = j + (Gpnt_Size(G_Low)-1) - 1 WK(FFTMap_High(j:k)) = Psi1(t:) Call PerformFFT(FFT_TO_R, G_HIGH, WK) If(.not.spindependence.or.(spindependence.and.PsiInfo(i)%spinup)) then DEN = DEN + wgt*CONJG(WK)*WK else DENspin=DENspin + wgt*CONJG(WK)*WK endif PDOT =>PsiInfo(i)%PDOT Call CalcProjProducts(psi1,PDOT) Do a=1, Specific_Atoms If(.not.spindependence.or.(spindependence.and.PsiInfo(i)%spinup)) then Wij => Atom_List(a)%Wij else Wij => Atom_List(a)%Wijspin endif Base = PLM_AtomRange(1,a) - 1 Do t=PLM_AtomRange(1,a), PLM_AtomRange(2,a) Do j=PLM_AtomRange(1,a), PLM_AtomRange(2,a) Wij(t-Base, j-Base) = Wij(t-Base, j-Base) & + CONJG(PDot(t))*PDot(j)*wgt End Do End Do End Do Endif ! Energy range Call GetNextPsi(ib,Psi) Enddo !ib Enddo !Kpnt If (xtal%Rot_Size > 0) Call SymRho( Den, WK) Call PerformFFT(FFT_TO_G, G_HIGH, Den) WK=0 WK(1:Gpnt_Size(G_High))=Den(FFTmap_High(1:Gpnt_Size(G_High))) If (xtal%Rot_Size > 0) Call SymWij write(CHARGEOUT_UNIT) (WK(i),i=1,Gpnt_Size(G_High)) do a=1,Specific_Atoms Wij => Atom_List(a)%Wij t= PLM_AtomRange(2,a) - PLM_AtomRange(1,a) + 1 write(CHARGEOUT_UNIT) ((Wij(i,j),i=1,t),j=1,t) enddo Close(CHARGEOUT_UNIT) if (spindependence) then If (xtal%Rot_Size > 0) Call SymRho( Denspin, WK) Call PerformFFT(FFT_TO_G, G_HIGH, Denspin) WK=0 WK(1:Gpnt_Size(G_High))=Denspin(FFTmap_High(1:Gpnt_Size(G_High))) !If (xtal%Rot_Size > 0) Call SymWij write(SCRATCH_UNIT) (WK(i),i=1,Gpnt_Size(G_High)) do a=1,Specific_Atoms Wij => Atom_List(a)%Wijspin t= PLM_AtomRange(2,a) - PLM_AtomRange(1,a) + 1 write(SCRATCH_UNIT) ((Wij(i,j),i=1,t),j=1,t) enddo endif Close(SCRATCH_UNIT) Enddo !irange Bandstructure_mode = .false. DeAllocate(WK,DEN) If (spindependence) Deallocate(DENspin) End Subroutine !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Subroutine Ld3ddata ! ! Read in axis and grid information for 3-d plots ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Subroutine Ld3ddata(WC) Type (Word_Context), Intent(INOUT) :: WC Character*100 :: token,token2 Integer :: Tlen,icount Real :: Scale,center(3) Logical :: Readcenter Scale = 1 icount=0 Readcenter = .false. Volumeplot%Origin = 0 Loop : Do Call GetNextWord(WC, token, Tlen) Call UpperCase(Token) If (Trim(token)=="SCALE") then Call GetNumbers(WC,Scale) If (Scale<1.e-8) Scale = 1 Else if (token(1:1)=="X") then Call GetNumbers(WC,Volumeplot%X) !x*Scale = Cartesian Bohr Units icount=icount+1 Else If (token(1:1)=="Y") then Call GetNumbers(WC,Volumeplot%Y) !y*Scale = Cartesian Bohr Units icount=icount+1 Else If (token(1:1)=="Z") then Call GetNumbers(WC,Volumeplot%Z) !z*Scale = Cartesian Bohr Units icount=icount+1 Else If (token(1:1)=="O") then Call GetNumbers(WC,Volumeplot%ORIGIN) !o*Scale = Cartesian Bohr Units icount=icount+1 Else If (Trim(token)=="CENTER") then ! specify center of plotting cell Call GetNumbers(WC,center) !center*Scale = Cartesian Bohr Units icount=icount+1 Readcenter=.true. Else If (Trim(token)=="BOND") then Call GetNumbers(WC,Volumeplot%maxbond) !b*Scale = Cartesian Bohr Units icount=icount+1 Else If (Trim(token)=="BONDTOL") then Call GetNumbers(WC,Volumeplot%bondtol) !% bond length for drawing bond Else If (Trim(token)=="GRID") then Call GetNumbers(WC,Volumeplot%grid(1:3)) !Number of grid points icount=icount+10 Else If (Trim(token)=="PLOTNAME") then Call GetNextWord(WC, token2, tlen) If (tlen>0) Plot_Name=Trim(token2) Else If (Trim(token)=="END") then exit loop Else Write(Error_unit,*) 'Error in plot input -- ',Token stop Endif Enddo Loop Volumeplot%query=Max(icount,Volumeplot%query) If (Readcenter) then Volumeplot%Origin=Center-0.5*(Volumeplot%X+Volumeplot%Y+Volumeplot%Z) EndIf Volumeplot%X=Volumeplot%X*Scale Volumeplot%Y=Volumeplot%Y*Scale Volumeplot%Z=Volumeplot%Z*Scale Volumeplot%Origin=Volumeplot%Origin*Scale Volumeplot%maxbond=Volumeplot%maxbond*Scale End subroutine Ld3ddata !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Subroutine Ld2ddata ! ! Read in axis and grid information for 2-d plots ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Subroutine Ld2ddata(WC) Type (Word_Context), Intent(INOUT) :: WC Character*100 :: token,token2 Integer :: Tlen,icount Real :: Scale Scale = 1 icount=0 Loop : Do Call GetNextWord(WC, token, Tlen) Call UpperCase(Token) If (Trim(token)=="SCALE") then Call GetNumbers(WC,Scale) If (Scale<1.e-8) Scale = 1 Else if (token(1:1)=="X") then Call GetNumbers(WC,Planeplot%X) !x*Scale = Cartesian Bohr Units icount=icount+1 Else If (token(1:1)=="Y") then Call GetNumbers(WC,Planeplot%Y) !y*Scale = Cartesian Bohr Units icount=icount+1 Else If (token(1:1)=="O") then Call GetNumbers(WC,Planeplot%ORIGIN) !o*Scale = Cartesian Bohr Units icount=icount+1 Else If (Trim(token)=="GRID") then Call GetNumbers(WC,Planeplot%grid(1:2)) !Number of grid points icount=icount+10 Else If (Trim(token)=="PLOTNAME") then Call GetNextWord(WC, token2, tlen) If (tlen>0) Plot_Name=Trim(token2) Else If (Trim(token)=="END") then exit loop Else Write(Error_unit,*) 'Error in plot input -- ',Token stop Endif Enddo Loop Planeplot%query=Max(icount,Planeplot%query) Planeplot%X=Planeplot%X*Scale Planeplot%Y=Planeplot%Y*Scale Planeplot%Origin=Planeplot%Origin*Scale End subroutine Ld2ddata !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Subroutine Atomplot3d ! ! For given unit cell -- specified by Volumeplot%X,Y,Z,Origin,maxbond ! (input from read_input) ! Calculate atomic positions and bonds for Ball and Stick model ! (Data Explorer output and XCrysden output) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Subroutine Atomplot3d Real, allocatable :: ballpoints(:,:) Real :: resx, resy, resz ,plotmat(3,3),solvmat(3,3),v(3),vin(3),vout(3) Real :: chk,rtol,tx,ty,tz,XA,YA,ZA Real, parameter :: atol=1.e-3 Integer, allocatable :: noballs(:),z(:) Integer :: ncount,ncountmax,many,ierr,npair,i,j,k,n ! file for plotting axes If (volumeplot%query.lt.5) then write(error_unit) 'error in 3d plot -- need to read in data' stop endif rtol=volumeplot%bondtol !Tolerance of including atoms rtol=MAX(atol,rtol) ! Determine length of plotting cell boundaries resx=SQRT(DOT_Product(volumeplot%X,volumeplot%X)) resy=SQRT(DOT_Product(volumeplot%Y,volumeplot%Y)) resz=SQRT(DOT_Product(volumeplot%Z,volumeplot%Z)) XA=resx*0.5291772083 YA=resy*0.5291772083 ZA=resz*0.5291772083 Open(unit=CHARGEOUT_UNIT,& file=Trim(PLOT_Name)//".axes.dx",form="formatted") write(CHARGEOUT_UNIT, & '("object 1 class array type float rank 0 items 8 data follows")') write(CHARGEOUT_UNIT,'(" 1 1 1 1 1 1 1 1")') write(CHARGEOUT_UNIT,'("attribute ""dep"" string ""positions""")') write(CHARGEOUT_UNIT,'("#")') write(CHARGEOUT_UNIT,& '("object 2 class array type float rank 1 shape 3 items 8 data follows")') v=0 write(CHARGEOUT_UNIT,'(1p3e15.7)') v(1:3) write(CHARGEOUT_UNIT,'(1p3e15.7)') XA,v(2),v(3) write(CHARGEOUT_UNIT,'(1p3e15.7)') v(1),YA,v(3) write(CHARGEOUT_UNIT,'(1p3e15.7)') XA,YA,v(3) write(CHARGEOUT_UNIT,'(1p3e15.7)') v(1),v(2),ZA write(CHARGEOUT_UNIT,'(1p3e15.7)') XA,V(2),ZA write(CHARGEOUT_UNIT,'(1p3e15.7)') v(1),YA,ZA write(CHARGEOUT_UNIT,'(1p3e15.7)') XA,YA,ZA write(CHARGEOUT_UNIT,'("attribute ""dep"" string ""positions""")') write(CHARGEOUT_UNIT,'("#")') write(CHARGEOUT_UNIT, & '("object 3 class array type int rank 1 shape 2 items 12 data follows")') write(CHARGEOUT_UNIT, '(" 0 1")') write(CHARGEOUT_UNIT, '(" 0 2")') write(CHARGEOUT_UNIT, '(" 1 3")') write(CHARGEOUT_UNIT, '(" 2 3")') write(CHARGEOUT_UNIT, '(" 4 5")') write(CHARGEOUT_UNIT, '(" 4 6")') write(CHARGEOUT_UNIT, '(" 5 7")') write(CHARGEOUT_UNIT, '(" 6 7")') write(CHARGEOUT_UNIT, '(" 0 4")') write(CHARGEOUT_UNIT, '(" 1 5")') write(CHARGEOUT_UNIT, '(" 2 6")') write(CHARGEOUT_UNIT, '(" 3 7")') write(CHARGEOUT_UNIT,'("attribute ""element type"" string ""lines""")') write(CHARGEOUT_UNIT,'("attribute ""ref"" string ""positions""")') write(CHARGEOUT_UNIT,'("#")') write(CHARGEOUT_UNIT,'("object ""molecule"" class field")') write(CHARGEOUT_UNIT,'("component ""data"" value 1")') write(CHARGEOUT_UNIT,'("component ""positions"" value 2")') write(CHARGEOUT_UNIT,'("component ""connections"" value 3")') write(CHARGEOUT_UNIT,'("attribute ""name"" string ""molecule""")') write(CHARGEOUT_UNIT,'("#")') write(CHARGEOUT_UNIT,'("end")') close (CHARGEOUT_UNIT) ! file for atomic positions Open(unit=CHARGEOUT_UNIT,& file=Trim(PLOT_Name)//".atom.dx",form="formatted") ! Rough estimate of number atoms in plot many=resx*resy*resz/xtal%Volume+1 ncountmax=8*(many**3)*Specific_Atoms Allocate(noballs(ncountmax),ballpoints(3,ncountmax),z(ncountmax)) noballs=0 ballpoints=0 ncount=0 If (volumeplot%maxbond.gt.0.) then tx=rtol*volumeplot%maxbond/resx ty=rtol*volumeplot%maxbond/resy tz=rtol*volumeplot%maxbond/resz Else chk=xtal%volume**(0.33333) tx=rtol*chk/resx ty=rtol*chk/resy tz=rtol*chk/resz EndIf do n=1,Specific_Atoms ! Some assumptions here about shape of cell do i = -many, many do j = -many, many do k = -many, many v = Atom_list(n)%Pos - Volumeplot%origin & + MATMUL(xtal%Basis,(/i,j,k/)) vout(1) = DOT_Product(Volumeplot%X,v)/resx vout(2) = DOT_Product(Volumeplot%Y,v)/resy vout(3) = DOT_Product(Volumeplot%Z,v)/resz vin(1)=vout(1)/resx vin(2)=vout(2)/resy vin(3)=vout(3)/resz ! Check if atom is in plotting cell if (vin(1).gt.-tx.and.vin(1).lt.1+tx & .and.vin(2).gt.-ty.and.vin(2).lt.1+ty & .and.vin(3).gt.-tz.and.vin(3).lt.1+tz) then ncount=ncount+1 noballs(ncount)=Atom_list(n)%TypeIndex z(ncount)=AtomType_Info(noballs(ncount))%Atomic_Charge ballpoints(:,ncount)=vout Endif Enddo Enddo Enddo Enddo ! Change atom positions to Angstrom Units ballpoints(:,1:ncount) = ballpoints(:,1:ncount)*0.5291772083 ! output atomic coordinates for Data Explorer write(CHARGEOUT_UNIT, & '("object 1 class array type float rank 0 items",i4," data follows")') & ncount write(CHARGEOUT_UNIT,*) (noballs(i),i=1,ncount) write(CHARGEOUT_UNIT,'("attribute ""dep"" string ""positions""")') write(CHARGEOUT_UNIT,'("#")') write(CHARGEOUT_UNIT,& '("object 2 class array type float rank 1 shape 3 items",i4," data follows")') & ncount do i=1,ncount write(CHARGEOUT_UNIT,*) ballpoints(1:3,i) enddo write(CHARGEOUT_UNIT,'("attribute ""dep"" string ""positions""")') write(CHARGEOUT_UNIT,'("#")') chk=(Volumeplot%maxbond*0.5291772083)**2 npair=0 do i=1,ncount-1 do j=i+1,ncount v=ballpoints(:,i)-ballpoints(:,j) if(DOT_Product(v,v).le.chk) then npair=npair+1 ! write(CHARGEOUT_UNIT,*) i,j endif enddo enddo write(CHARGEOUT_UNIT, & '("object 3 class array type int rank 1 shape 2 items",i4," data follows")')& npair do i=1,ncount-1 do j=i+1,ncount v=ballpoints(:,i)-ballpoints(:,j) if(DOT_Product(v,v).le.chk) then write(CHARGEOUT_UNIT,*) i-1,j-1 endif enddo enddo write(CHARGEOUT_UNIT,'("attribute ""element type"" string ""lines""")') write(CHARGEOUT_UNIT,'("attribute ""ref"" string ""positions""")') write(CHARGEOUT_UNIT,'("#")') write(CHARGEOUT_UNIT,'("object ""molecule"" class field")') write(CHARGEOUT_UNIT,'("component ""data"" value 1")') write(CHARGEOUT_UNIT,'("component ""positions"" value 2")') write(CHARGEOUT_UNIT,'("component ""connections"" value 3")') write(CHARGEOUT_UNIT,'("attribute ""name"" string ""molecule""")') write(CHARGEOUT_UNIT,'("#")') write(CHARGEOUT_UNIT,'("end")') Close(CHARGEOUT_UNIT) ! XCrysDen output Open(unit=CHARGEOUT_UNIT,& file=Trim(PLOT_Name)//".xsf",form="formatted") Write(CHARGEOUT_UNIT,'(" CONVVEC")') write(CHARGEOUT_UNIT,'(1p3e15.7)') Volumeplot%X(1:3)*0.5291772083 write(CHARGEOUT_UNIT,'(1p3e15.7)') Volumeplot%Y(1:3)*0.5291772083 write(CHARGEOUT_UNIT,'(1p3e15.7)') Volumeplot%Z(1:3)*0.5291772083 Write(CHARGEOUT_UNIT,'(" ATOMS")') do i=1,ncount j=z(i)+0.0001 write(CHARGEOUT_UNIT,'(i8,2x,1p3e15.7)') j, ballpoints(1:3,i) enddo Return End Subroutine !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Subroutine Atomplot2d(ncount) ! ! For given unit cell -- specified by Planeplot%X,Y,Origin ! (input from read_input) ! Calculate atomic positions for Contour plot ! (IDL format) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Subroutine Atomplot2d(ncount) Integer, intent(OUT) :: ncount Real, allocatable :: ballpoints(:,:) Real :: resx, resy,plotmat(2,2),solvmat(2,2),v(3),vin(2),vout(2) Real :: chk,rtol,tx,ty,tz Real, parameter :: atol=1.e-3 Integer, allocatable :: noballs(:) Integer :: ncountmax,many,ierr,npair,i,j,k,n ! file for plotting axes If (planeplot%query.lt.3) then write(error_unit) 'error in 2d plot -- need to read in data' stop endif ! file for atomic positions Open(unit=CHARGEOUT_UNIT,& file=Trim(PLOT_Name)//".atom.idl",form="formatted") ! Determine length of plotting cell boundaries resx=SQRT(DOT_Product(planeplot%X,planeplot%X)) resy=SQRT(DOT_Product(planeplot%Y,planeplot%Y)) ! Rough estimate of number atoms in plot many=resx*resy/xtal%Volume**0.66 +1 many=10*many ncountmax=4*(many**2)*Specific_Atoms Allocate(noballs(ncountmax),ballpoints(2,ncountmax)) noballs=0 ballpoints=0 ! Form plot cell matrix plotmat=0 plotmat(1,1)=DOT_Product(planeplot%X,planeplot%X) plotmat(2,2)=DOT_Product(planeplot%Y,planeplot%Y) plotmat(1,2)=DOT_Product(planeplot%X,planeplot%Y) plotmat(2,1)=plotmat(1,2) chk=plotmat(1,1)*plotmat(2,2)-plotmat(1,2)*plotmat(2,1) solvmat(1,1)=plotmat(2,2)/chk solvmat(2,2)=plotmat(1,1)/chk solvmat(1,2)=-plotmat(1,2)/chk solvmat(2,1)=-plotmat(2,1)/chk tx=atol*resx ty=atol*resy ncount=0 do n=1,Specific_Atoms ! Some assumptions here about shape of cell do i = -many, many do j = -many, many do k = -many, many v = Atom_list(n)%Pos - Planeplot%origin & + MATMUL(xtal%Basis,(/i,j,k/)) vout(1) = DOT_Product(Planeplot%X,v) vout(2) = DOT_Product(Planeplot%Y,v) vin = MATMUL(solvmat,vout) ! Check if atom is in plotting cell if (vin(1).gt.-tx.and.vin(1).lt.1+tx & .and.vin(2).gt.-ty.and.vin(2).lt.1+ty) then ncount=ncount+1 noballs(ncount)=Atom_list(n)%TypeIndex ballpoints(:,ncount)=vin Endif Enddo Enddo Enddo Enddo ! output atomic coordinates for IDL write(CHARGEOUT_UNIT, '(1p5e15.7)') (ballpoints(1,i),i=1,ncount) write(CHARGEOUT_UNIT, '(1p5e15.7)') (ballpoints(2,i),i=1,ncount) Close(CHARGEOUT_UNIT) Return End Subroutine Atomplot2d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Subroutine Planegrid ! ! For given unit cell -- specified by Volumeplot%X,Y,Origin ! (input from read_input) ! Calculate density in 2 dimensional grid for Plot_Name file ! (previously generated by partialden) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Subroutine Planegrid Integer :: nx,ny Integer :: many=10 ! how many possible unit cells to test Real, allocatable :: gridden(:,:) Real :: Ebegin, Eend,xleng,yleng,arg,CRC,dden,Rmag Real :: Xu(3),Yu(3),R(3),D(3),xm,ym,zm Complex, allocatable:: DEN(:),px(:),py(:) Complex :: zzz,zz1 Integer :: i,j,k,a,ix,iy,lx,ly,t,natom Logical :: Useocc If (planeplot%query.lt.13.or.SUM(planeplot%grid(1:2)).lt.2) then write(error_unit,*) 'error in 2d plot -- need data' stop endif nx=planeplot%grid(1) ny=planeplot%grid(2) ! Check coordinates Xleng=sqrt(Dot_Product(planeplot%x,planeplot%x)) Yleng=sqrt(Dot_Product(planeplot%y,planeplot%y)) Write(Log_Unit,'(" Plot origin ",1p3E15.7)')planeplot%Origin Write(Log_Unit,'(" X-axis&length ",1p4E15.7)')planeplot%X,Xleng Write(Log_Unit,'(" Y-axis&length ",1p4E15.7)')planeplot%Y,Yleng Write(Log_Unit,'(" Nx, Ny ",3i10 )')planeplot%grid(1:2) Write(Output_Unit,'(" Plot origin ",1p3E15.7)')planeplot%Origin Write(Output_Unit,'(" X-axis&length ",1p4E15.7)')planeplot%X,Xleng Write(Output_Unit,'(" Y-axis&length ",1p4E15.7)')planeplot%Y,Yleng Write(Output_Unit,'(" Nx, Ny ",3i10 )')planeplot%grid(1:2) If (abs(Dot_Product(planeplot%x,planeplot%y)).gt.1.e-4) then write(Error_Unit,*) 'Error in planeplot- axes are not orthogonal' stop endif many= (Xleng*Yleng)/xtal%volume**0.66 + 3 many= MAX(3,many) Write(Log_Unit,'(" Unit cell repeat factor = ",i10)') many Write(Output_Unit,'(" Unit cell repeat factor = ",i10)') many lx=nx-1 ly=ny-1 Xu=planeplot%X/lx ; xm=SQRT(Dot_Product(Xu,Xu)) Yu=planeplot%Y/ly ; ym=SQRT(Dot_Product(Yu,Yu)) Allocate(DEN(FFT_Grid(4,G_HIGH)),gridden(nx,ny),& px(nx),py(ny),stat=j) if (j.ne.0) then write(Error_Unit,*) 'error allocating work array in Planegrid', & FFT_Grid(4,G_HIGH),nx,ny stop endif Open(unit=CHARGEOUT_UNIT,file=Trim(PLOT_Name),form="unformatted") write(Log_Unit,*) ' Reading from partialden file ',Trim(PLOT_Name) write(Output_Unit,*) ' Reading from partialden file ',Trim(PLOT_Name) read(CHARGEOUT_UNIT) Ebegin,Eend,Useocc write(Log_Unit,*) 'Ebegin,Eend,Useocc= ', Ebegin,Eend,Useocc write(Output_Unit,*) 'Ebegin,Eend,Useocc= ', Ebegin,Eend,Useocc write(6,*) 'gpnt',Gpnt_size(G_HIGH) read(CHARGEOUT_UNIT) (DEN(i),i=1,Gpnt_Size(G_HIGH)) do a=1,Specific_Atoms t= PLM_AtomRange(2,a) - PLM_AtomRange(1,a) + 1 read(CHARGEOUT_UNIT) ((Atom_List(a)%Wij(i,j),i=1,t),j=1,t) enddo Close(CHARGEOUT_UNIT) Call Atomplot2d(natom) Open(unit=CHARGEOUT_UNIT,& file=Trim(PLOT_Name)//".2d.idl",form="formatted") ! DEN ==> DEN*exp(i*G*origin) do i=2,Gpnt_Size(G_HIGH) arg= Dot_Product(Gpnt(1:3,i),planeplot%origin) den(i)=den(i)*CMPLX(cos(arg),sin(arg)) enddo Do iy=1,ny Do ix=1,nx gridden(ix,iy)=den(1) Enddo Enddo do i=2,Gpnt_Size(G_High) arg=Dot_Product(Gpnt(1:3,i),Xu(1:3)) zzz=CMPLX(cos(arg),sin(arg)) px(1)=1 do ix=2,nx px(ix)=px(ix-1)*zzz enddo arg=Dot_Product(Gpnt(1:3,i),Yu(1:3)) zzz=CMPLX(cos(arg),sin(arg)) py(1)=1 do iy=2,ny py(iy)=py(iy-1)*zzz enddo Do iy=1,ny zzz=2*DEN(i)*py(iy) Do ix=1,nx gridden(ix,iy)=gridden(ix,iy) + zzz*px(ix) Enddo Enddo Enddo ! Gpnt ! Plane wave component completed ! ! Correct density inside each atomic sphere Do iy=1,ny Do ix=1,nx R=planeplot%origin + (ix-1)*Xu + (iy-1)*Yu loop: do do a = 1,Specific_Atoms CRC=AtomType_Info(Atom_list(a)%TypeIndex)%Rc do i= -many,many do j= -many,many do k= -many,many D = R - Atom_list(a)%Pos - MATMUL(xtal%Basis,(/i,j,k/)) Rmag=SQRT(Dot_Product(D,D)) If (Rmag.le.CRC) then Call Correctden(a,D,Rmag,dden) gridden(ix,iy)=gridden(ix,iy)+dden*xtal%volume exit loop EndIf Enddo Enddo Enddo Enddo exit loop Enddo loop Enddo !ix Enddo !iy ! output density grid data write(CHARGEOUT_UNIT,'(1p5e15.7)') ((gridden(ix,iy),ix=1,nx), & iy=1,ny) write(Log_Unit,*) 'maximum density=', maxval(gridden(1:nx,1:ny)) write(Log_Unit,*) 'minimum density=', minval(gridden(1:nx,1:ny)) close(CHARGEOUT_UNIT) !Special information files for idl plots open(unit=CHARGEOUT_UNIT,file=Trim(PLOT_Name)//".title",form='formatted') Write(CHARGEOUT_UNIT,*) Trim(PLOT_Name) Write(CHARGEOUT_UNIT,*) nx, ny Write(CHARGEOUT_UNIT,*) 1 !scale factor Write(CHARGEOUT_UNIT,*) Xleng,Yleng Write(CHARGEOUT_UNIT,*) natom close(CHARGEOUT_UNIT) DeAllocate(DEN,gridden,px,py) End Subroutine Planegrid !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Subroutine Volplot ! ! For given unit cell -- specified by Volumeplot%X,Y,Z,Origin,maxbond ! (input from read_input) ! Calculate density in 3 dimensional grid for Plot_Name file ! (previously generated by partialden) ! ! Grid must by >= 1 in all directions ! ! Result given in electrons/volume in A^3 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Subroutine Volplot Integer :: nx,ny,nz Integer :: many=10 ! how many possible unit cells to test Real, allocatable :: gridden(:,:,:) Real :: Ebegin, Eend,xleng,yleng,zleng,arg,CRC,dden,Rmag Real :: Xu(3),Yu(3),Zu(3),R(3),D(3),xm,ym,zm , vol Real :: AA(3),BB(3),CC(3),DI(3),DIJ(3) Complex, allocatable:: DEN(:),px(:),py(:),pz(:) Complex :: zzz,zz1 Integer :: i,j,k,a,ix,iy,iz,lx,ly,lz,t Logical :: Useocc If (volumeplot%query.lt.15.or.SUM(volumeplot%grid(1:3)).lt.3) then write(error_unit,*) 'error in 3d plot -- need data' stop endif nx=volumeplot%grid(1) ny=volumeplot%grid(2) nz=volumeplot%grid(3) ! Check coordinates Xleng=sqrt(Dot_Product(volumeplot%x,volumeplot%x)) Yleng=sqrt(Dot_Product(volumeplot%y,volumeplot%y)) Zleng=sqrt(Dot_Product(volumeplot%z,volumeplot%z)) Write(Log_Unit,'(" Plot origin ",1p3E15.7)')volumeplot%Origin Write(Log_Unit,'(" X-axis&length ",1p4E15.7)')volumeplot%X,Xleng Write(Log_Unit,'(" Y-axis&length ",1p4E15.7)')volumeplot%Y,Yleng Write(Log_Unit,'(" Z-axis&length ",1p4E15.7)')volumeplot%Z,Zleng Write(Log_Unit,'(" Nx, Ny, Nz ",3i10 )')volumeplot%grid(1:3) Write(Output_Unit,'(" Plot origin ",1p3E15.7)')volumeplot%Origin Write(Output_Unit,'(" X-axis&length ",1p4E15.7)')volumeplot%X,Xleng Write(Output_Unit,'(" Y-axis&length ",1p4E15.7)')volumeplot%Y,Yleng Write(Output_Unit,'(" Z-axis&length ",1p4E15.7)')volumeplot%Z,Zleng Write(Output_Unit,'(" Nx, Ny, Nz ",3i10 )')volumeplot%grid(1:3) If (abs(Dot_Product(volumeplot%x,volumeplot%y)).gt.1.e-4 & .or.abs(Dot_Product(volumeplot%x,volumeplot%z)).gt.1.e-4 & .or.abs(Dot_Product(volumeplot%z,volumeplot%y)).gt.1.e-4) then write(Error_Unit,*) 'Error in volplot- axes are not orthogonal' stop endif many= (Xleng*Yleng*Zleng)/xtal%volume + 10 many= MAX(10,many) Write(Log_Unit,'(" Unit cell repeat factor = ",i10)') many Write(Output_Unit,'(" Unit cell repeat factor = ",i10)') many vol=xtal%volume*(0.1481847093) Write(Log_Unit,'(" Unit cell volume in A^3 = ",1pe15.7)') vol Write(Output_Unit,'(" Unit cell volume in A^3 = ",1pe15.7)') vol lx=nx-1 ly=ny-1 lz=nz-1 Xu=0;Yu=0;Zu=0;Xm=0;Ym=0;Zm=0 If (lx.gt.0) Xu=volumeplot%X/lx ; xm=SQRT(Dot_Product(Xu,Xu)) If (ly.gt.0) Yu=volumeplot%Y/ly ; ym=SQRT(Dot_Product(Yu,Yu)) If (lz.gt.0) Zu=volumeplot%Z/lz ; zm=SQRT(Dot_Product(Zu,Zu)) AA=xtal%Basis(1:3,1) BB=xtal%Basis(1:3,2) CC=xtal%Basis(1:3,3) Allocate(DEN(FFT_Grid(4,G_HIGH)),gridden(nx,ny,nz),& px(nx),py(ny),pz(nz),stat=j) if (j.ne.0) then write(Error_Unit,*) 'error allocating work array in Volplot', & FFT_Grid(4,G_HIGH),nx,ny,nz stop endif Open(unit=CHARGEOUT_UNIT,file=Trim(PLOT_Name),form="unformatted") write(Log_Unit,*) ' Reading from partialden file ',Trim(PLOT_Name) write(Output_Unit,*) ' Reading from partialden file ',Trim(PLOT_Name) read(CHARGEOUT_UNIT) Ebegin,Eend,Useocc write(Log_Unit,*) 'Ebegin,Eend,Useocc= ', Ebegin,Eend,Useocc write(Output_Unit,*) 'Ebegin,Eend,Useocc= ', Ebegin,Eend,Useocc write(6,*) 'gpnt',Gpnt_size(G_HIGH) read(CHARGEOUT_UNIT) (DEN(i),i=1,Gpnt_Size(G_HIGH)) do a=1,Specific_Atoms t= PLM_AtomRange(2,a) - PLM_AtomRange(1,a) + 1 write(6,*) 'specific atom = ', a, PLM_AtomRange(2,a), PLM_AtomRange(1,a) read(CHARGEOUT_UNIT) ((Atom_List(a)%Wij(i,j),i=1,t),j=1,t) enddo Close(CHARGEOUT_UNIT) Open(unit=CHARGEOUT_UNIT,& file=Trim(PLOT_Name)//".3d.dx",form="formatted") ! DEN ==> DEN*exp(i*G*origin) do i=2,Gpnt_Size(G_HIGH) arg= Dot_Product(Gpnt(1:3,i),volumeplot%origin) den(i)=den(i)*CMPLX(cos(arg),sin(arg)) enddo Do iz=1,nz Do iy=1,ny Do ix=1,nx gridden(ix,iy,iz)=den(1) Enddo Enddo Enddo do i=2,Gpnt_Size(G_High) arg=Dot_Product(Gpnt(1:3,i),Xu(1:3)) zzz=CMPLX(cos(arg),sin(arg)) px(1)=1 If (ix.gt.1) then do ix=2,nx px(ix)=px(ix-1)*zzz enddo EndIf arg=Dot_Product(Gpnt(1:3,i),Yu(1:3)) zzz=CMPLX(cos(arg),sin(arg)) py(1)=1 If (iy.gt.1) then do iy=2,ny py(iy)=py(iy-1)*zzz enddo EndIf arg=Dot_Product(Gpnt(1:3,i),Zu(1:3)) zzz=CMPLX(cos(arg),sin(arg)) pz(1)=1 If (iz.gt.1) then do iz=2,nz pz(iz)=pz(iz-1)*zzz enddo EndIf Do iz=1,nz zzz=2*DEN(i)*pz(iz) Do iy=1,ny zz1=zzz*py(iy) Do ix=1,nx gridden(ix,iy,iz)=gridden(ix,iy,iz) + zz1*px(ix) Enddo Enddo Enddo Enddo ! Gpnt ! Plane wave component completed ! ! Correct density inside each atomic sphere Do iz=1,nz Do iy=1,ny Do ix=1,nx R=volumeplot%origin + (ix-1)*Xu + (iy-1)*Yu + (iz-1)*Zu loop: do do a = 1,Specific_Atoms CRC=AtomType_Info(Atom_list(a)%TypeIndex)%Rc do i= -many,many DI = R - Atom_list(a)%Pos - AA*i do j= -many,many DIJ = DI - BB*j do k= -many,many !D = R - Atom_list(a)%Pos - MATMUL(xtal%Basis,(/i,j,k/)) D = DIJ - CC*k Rmag=SQRT(Dot_Product(D,D)) If (Rmag.le.CRC) then Call Correctden(a,D,Rmag,dden) gridden(ix,iy,iz)=gridden(ix,iy,iz)+dden*xtal%volume exit loop EndIf Enddo Enddo Enddo Enddo exit loop Enddo loop Enddo !ix Enddo !iy Enddo !iz ! change to electrons/A^3 gridden=gridden/vol ! output density grid data write(CHARGEOUT_UNIT,'(1p5e15.7)') (((gridden(ix,iy,iz),ix=1,nx), & iy=1,ny),iz=1,nz) write(Log_Unit,*) 'maximum density=', maxval(gridden(1:nx,1:ny,1:nz)) write(Log_Unit,*) 'minimum density=', minval(gridden(1:nx,1:ny,1:nz)) close(CHARGEOUT_UNIT) !Special header file Data-Explorer output open(unit=CHARGEOUT_UNIT,file=Trim(PLOT_Name)//".general",form='formatted') Write(CHARGEOUT_UNIT,*) 'file = ',Trim(PLOT_Name)//".3d.dx" Write(CHARGEOUT_UNIT,*) 'grid = ',nx,' x ',ny,' x ',nz Write(CHARGEOUT_UNIT,*) 'format = text' Write(CHARGEOUT_UNIT,*) 'interleaving = record' Write(CHARGEOUT_UNIT,*) 'majority = column' Write(CHARGEOUT_UNIT,*) 'field = density' Write(CHARGEOUT_UNIT,*) 'structure = scalar' Write(CHARGEOUT_UNIT,*) 'type = float' Write(CHARGEOUT_UNIT,*) 'dependency = positions' xm=0.5291772083*xm ! length unit in Anstroms ym=0.5291772083*ym ! length unit in Anstroms zm=0.5291772083*zm ! length unit in Anstroms Write(CHARGEOUT_UNIT,'(" positions = 0.0,",f9.5,", 0.0,",f9.5,", & &0.0,",f9.5)')& xm,ym,zm Write(CHARGEOUT_UNIT,*) 'end' close(CHARGEOUT_UNIT) DeAllocate(DEN,gridden,px,py,pz) End Subroutine Volplot !****************************************************************************** ! ! Subroutine correctden ! Returns density correction within atomic sphere a ! !****************************************************************************** Subroutine Correctden(atom,R,Rmag,dden) Integer, Intent(IN) :: atom ! Specific_atom index Real, Intent(IN) :: R(3),Rmag ! position relative to atom center Real, Intent(OUT) :: dden Real, Parameter :: rtol=1.e-4 Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT Integer :: Basis_Size,Li,Lj,nili,njlj,mi,mj,t,Lmax,indexi,indexj Integer :: ibase,jbase,Nlist Integer, pointer :: L_Value(:), nl_Base(:), nlm_LUT(:,:) Real :: aden,h,phi(20),tphi(20) Real, pointer :: APhi(:,:),ATPhi(:,:) Complex :: Ylm(13,4),Ylmstar(13,4),ylmi,ylmj,zz Complex, pointer :: Wij(:,:) A => Atom_List(atom) AT => AtomType_Info(A%TypeIndex) Basis_size=AT%Basis_Size Lmax=Maxval(AT%L_Value) If (Lmax.gt.3) then write(error_unit,*) 'error in correctden -- lmax > 3',lmax stop endif If (Basis_size.gt.20) then write(error_unit,*) 'error in correctden -- Basis_size > 20',Basis_size stop endif h=AT%Mesh_Step Nlist=AT%Mesh_Size Wij => A%Wij APhi => AT%Phi ATPhi => AT%TPhi L_value => AT%L_Value nl_Base => AT%nl_Base nlm_LUT => AT%nlm_LUT dden=0 Call YlmList(r(1),r(2),r(3),lmax,ylm,error_unit) ylmstar = CONJG(ylm) phi=0 Tphi=0 If (Rmag > rtol ) then do nili=1,Basis_Size call Lininterp(Nlist,h,APhi(1:Nlist,nili),Rmag,phi(nili)) call Lininterp(Nlist,h,ATPhi(1:Nlist,nili),Rmag,Tphi(nili)) enddo phi(1:Basis_Size)=phi(1:Basis_size)/Rmag Tphi(1:Basis_Size)=Tphi(1:Basis_size)/Rmag Else do nili=1,Basis_Size If (L_Value(nili).eq.0) then phi(nili)=Extrapto0(APhi(2,nili)/h,APhi(3,nili)/(2*h)) Tphi(nili)=Extrapto0(ATPhi(2,nili)/h,ATPhi(3,nili)/(2*h)) EndIf EndDo Endif do nili=1,Basis_Size Li=L_Value(nili) ibase=nl_Base(nili); ibase=ibase+nlm_LUT(2,ibase) do njlj=1,Basis_Size Lj=L_Value(njlj) jbase=nl_Base(njlj); jbase=jbase+nlm_LUT(2,jbase) ! aden=0 ! Do mi = -Li, Li ! Ylmi = CONJG(ylm(Li+1+mi,Li+1)) ! Do mj= -Lj, Lj ! Ylmj = ylm(Lj+1+mj,Lj+1) ! aden=aden + A%Wij(ibase+mi,jbase+mj) *Ylmi * Ylmj ! Enddo ! Enddo aden=0 Do mj = -Lj, Lj indexj=jbase+mj zz=0 Do mi = -Li, Li zz = zz + Ylmstar(Li+1+mi,Li+1)*Wij(ibase+mi,indexj) Enddo aden = aden + zz*Ylm(Lj+1+mj,Lj+1) Enddo dden = dden + aden*(phi(nili)*phi(njlj)-Tphi(nili)*Tphi(njlj)) enddo Enddo write(6,*) 'correctden',rmag,dden call flush(6) End Subroutine correctden End Module spinpwpaw/code/complex_lru.f900100664004704100470410000004313110303710172016512 0ustar natalienatalie!****************************************************************************** ! ! File : COMPLEX_lru.inc ! by : Alan Tackett ! on : 04/19/1999 ! for : PW-PAW ! ! This is a generic module implementing a Least Recently Used algorithm for ! I/O management for COMPLEX arrays. ! !****************************************************************************** Module complex_lru Use paw_inout Use fileio Implicit NONE!!!! Integer, PRIVATE, PARAMETER :: COUNT_START = 0 !** Start counter Integer, PRIVATE, PARAMETER :: COUNT_MAX = 2147483640 !** Reset counter val Type COMPLEX_LRUGrid Integer :: Index !** Disk Index Integer :: Count !** Least recently used counter Logical :: DoSave !** Should save before purging COMPLEX, Pointer :: Ptr(:) !** Pointer to Grid End Type Type COMPLEX_LRUData !*** Data Structure for holding the info Type (COMPLEX_LRUGrid), Pointer :: Buffer(:) Integer, Pointer :: DiskMap(:) End Type Type COMPLEX_LRU_Cache !** Cache data structure Integer :: Hits Integer :: Misses Integer :: Total End Type Type COMPLEX_LRU_Context !** Context containing all LRU data structures needed Character*100 :: Id !** User-supplied text Id for debugging Integer :: Count !** LRU count Integer :: NumRecs !** Number of Records loaded Integer :: TotalRecs !** Total number of Records Integer :: MaxMem !** MAx Amount of memory to use for buffers Integer :: MemUsed !** Amount of memory currently used Integer :: MemFree !** Amount of Free memory Integer :: LastIndex !** Last index Integer :: FD_Base !** Base unit Logical :: ReplaceOldest !** Replacement mode Integer, Pointer :: Data_Size !** Record Size Type(COMPLEX_LRU_Cache), Pointer :: Cache Type (COMPLEX_LRUData), Pointer :: LRUstruc !**Data structure of LRU module End Type !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! COMPLEX_LRU_Write - Writes a Record to disk ! ! LRU - LRU context ! Index - K point index ! Ptr - Data to store ! !****************************************************************************** Subroutine COMPLEX_LRU_Write(LRU, Index, Ptr) Type (COMPLEX_LRU_Context), Intent(INOUT) :: LRU Integer, Intent(IN) :: Index COMPLEX, Intent(IN) :: Ptr(:) Integer :: N Character*100 :: Token Write(token,*) 'COMPLEX_WriteLRU: Error Writing Data! :', & ' * Index:',index, ' * ID=',TRIM(LRU%Id) N = LRU%Data_Size Call WriteFile_LOW(LRU%FD_Base, Index, Ptr(1:N), token) Return End Subroutine !****************************************************************************** ! ! COMPLEX_LRU_Read - Reads a record from disk ! ! LRU - LRU context ! Index - K point index ! Ptr - Data to store ! !****************************************************************************** Subroutine COMPLEX_LRU_Read(LRU, Index, Ptr) Type (COMPLEX_LRU_Context), Intent(INOUT) :: LRU Integer, Intent(IN) :: Index COMPLEX, Intent(OUT) :: Ptr(:) Character*100 :: Token Integer :: N Write(token,*) 'COMPLEX_LRU_Read: Error reading data! :', & ' * Index:',index, ' * ID=',TRIM(LRU%Id) N = LRU%Data_Size Call ReadFile_LOW(LRU%FD_Base, Index, Ptr(1:N), token) Return End Subroutine !****************************************************************************** ! ! COMPLEX_LRU_GetRec - Gets the requested record from either memory or disk. ! ! ! LRU - LRU context ! Index - K point index ! Ptr - Data to store ! !****************************************************************************** Subroutine COMPLEX_LRU_GetRec(LRU, Index, Ptr) Type (COMPLEX_LRU_Context), Intent(INOUT) :: LRU Integer, Intent(IN) :: Index COMPLEX, Pointer :: Ptr(:) Integer :: Rec, BufPos, Last, dir, i Type (COMPLEX_LRUGrid), Pointer :: LG(:) Integer, Pointer :: DiskMap(:) LG => LRU%LRUstruc%Buffer DiskMap => LRU%LRUstruc%DiskMap bufPos = diskMap(Index) If (BufPos == 0) then !**** Have to load it from disk ***** LRU%Cache%Misses = LRU%Cache%Misses + 1 If (COMPLEX_LRU_CanAlloc(LRU)) then !*** Can allocate space BufPos = COMPLEX_LRU_Alloc(LRU) !*** Alloc space and get Buf else BufPos = COMPLEX_LRU_MakeSpace(LRU)!**Free other bufs/alloc new End If Call COMPLEX_LRU_Read(LRU, Index, LG(BufPos)%Ptr) LG(BufPos)%Index = Index LG(BufPos)%DoSave = .FALSE. DiskMap(Index) = BufPos else LRU%Cache%Hits = LRU%Cache%Hits + 1 End If Ptr => LG(BufPos)%Ptr LG(BufPos)%Count = LRU%Count LRU%Count = LRU%Count + 1; LRU%LastIndex = BufPos If (LRU%Count >= COUNT_MAX) Call COMPLEX_LRU_ResetCount(LRU) Return End Subroutine !****************************************************************************** ! ! COMPLEX_LRU_PutRec - Puts the requested record to either memory or disk. ! ! ! LRU - LRU context ! Index - K point index ! Ptr - Data to store ! !****************************************************************************** Subroutine COMPLEX_LRU_PutRec(LRU, Index, Ptr) Type (COMPLEX_LRU_Context), Intent(INOUT) :: LRU Integer, Intent(IN) :: Index COMPLEX, Intent(IN) :: Ptr(:) Integer :: Rec, BufPos, Last Integer, Pointer :: DiskMap(:) Type (COMPLEX_LRUGrid), Pointer :: LG(:) LG => LRU%LRUstruc%Buffer DiskMap => LRU%LRUstruc%DiskMap LRU%Cache%Hits = LRU%Cache%Hits + 1 BufPos = DiskMap(Index) If (BufPos == 0) then !**** Not currently loaded ***** If (COMPLEX_LRU_CanAlloc(LRU)) then !*** Can allocate space BufPos = COMPLEX_LRU_Alloc(LRU) !*** Alloc space and get Buf else BufPos = COMPLEX_LRU_MakeSpace(LRU)!**Free other bufs/alloc new End If LG(BufPos)%Index = Index DiskMap(Index) = BufPos End If LG(BufPos)%Ptr = Ptr LG(BufPos)%DoSave = .TRUE. LG(BufPos)%Count = LRU%Count LRU%Count = LRU%Count + 1; If (LRU%Count >= COUNT_MAX) Call COMPLEX_LRU_ResetCount(LRU) Return End Subroutine !****************************************************************************** ! ! COMPLEX_LRU_CanAlloc - Checks to see if free space is available for ! buffer allocation ! ! LRU - LRU context ! !****************************************************************************** Logical Function COMPLEX_LRU_CanAlloc(LRU) Type (COMPLEX_LRU_Context), Intent(INOUT) :: LRU If (LRU%MemFree > LRU%Data_Size) then COMPLEX_LRU_CanAlloc = .TRUE. else COMPLEX_LRU_CanAlloc = .FALSE. End If Return End Function !****************************************************************************** ! ! COMPLEX_LRU_Alloc - Allocates a buffer and returns ! the new buffer position ! ! LRU - LRU context ! !****************************************************************************** Integer Function COMPLEX_LRU_Alloc(LRU) Type (COMPLEX_LRU_Context), Intent(INOUT) :: LRU Type (COMPLEX_LRUGrid), Pointer :: LG(:) Integer :: i, BufPos Character*100 :: msg LG => LRU%LRUstruc%Buffer BufPos = 1 Do While ((LG(BufPos)%Index > 0) .AND. (BufPos < LRU%TotalRecs)) BufPos = BufPos + 1 End Do Allocate(LG(BufPos)%Ptr(LRU%Data_Size), STAT=i) Write(msg,*) 'LRU_Alloc: Could Not allocate Buffer array!', & i, ' * BufPos=',BufPos, ' * ID=',TRIM(LRU%ID) Call Check_Error(i, msg, Error_Unit, .TRUE.,paw_wc, "LRU_Alloc:") LRU%MemUsed = LRU%MemUsed + LRU%Data_Size LRU%MemFree = LRU%MemFree - LRU%Data_Size COMPLEX_LRU_Alloc = BufPos Return End Function !****************************************************************************** ! ! COMPLEX_LRU__FindOldest - Finds the oldest Phase factor and returns ! and buffer position ! ! BufPos - Buffer position ! !****************************************************************************** Subroutine COMPLEX_LRU_FindOldest(LRU, BufPos) Type (COMPLEX_LRU_Context), Intent(INOUT) :: LRU Integer, intent(OUT) :: BufPos Type (COMPLEX_LRUGrid), Pointer :: LG(:) Integer :: i, j, OldCount Logical :: ReplaceOldest ReplaceOldest = LRU%ReplaceOldest If (ReplaceOldest) then OldCount = COUNT_MAX+1 else OldCount = -1 End If LG => LRU%LRUstruc%Buffer If (ReplaceOldest) then Do j=1, LRU%TotalRecs If ((LG(j)%Index > 0) .AND. (OldCount > LG(j)%Count)) then OldCount = LG(j)%Count BufPos = j End If End Do else Do j=1, LRU%TotalRecs If ((LG(j)%Index > 0) .AND. (OldCount < LG(j)%Count)) then OldCount = LG(j)%Count BufPos = j End If End Do End If Return End Subroutine !****************************************************************************** ! ! COMPLEX_LRU_MakeSpace - Deletes the oldest buffers until enough room is made ! to Allocate a buffer and returns ! the new buffer position ! ! LRU - LRU context ! !****************************************************************************** Integer Function COMPLEX_LRU_MakeSpace(LRU) Type (COMPLEX_LRU_Context), Intent(INOUT) :: LRU Integer :: OldPos, temp Logical :: ReUse ReUse = .FALSE. Do While ((LRU%MemFree < LRU%Data_Size) .AND. (.NOT. ReUse)) Call COMPLEX_LRU_FindOldest(LRU, OldPos) !*** check to see if it should be saved first *** If (LRU%LRUstruc%Buffer(OldPos)%DoSave) then Call COMPLEX_LRU_Write(LRU, & LRU%LRUstruc%Buffer(OldPos)%Index, & LRU%LRUstruc%Buffer(OldPos)%Ptr) LRU%LRUstruc%Buffer(OldPos)%DoSave = .FALSE. LRU%Cache%Misses = LRU%Cache%Misses + 1 End If temp = LRU%MemFree + LRU%Data_Size LRU%LRUstruc%DiskMap( & LRU%LRUstruc%Buffer(OldPos)%Index) = 0 If ((temp < LRU%Data_Size) ) then ReUse = .TRUE. else DeAllocate(LRU%LRUstruc%buffer(OldPos)%Ptr) LRU%LRUstruc%buffer(OldPos)%Index = -1 LRU%MemFree = LRU%MemFree + LRU%Data_Size LRU%MemUsed = LRU%MemUsed - LRU%Data_Size End If End Do If (ReUse) then COMPLEX_LRU_MakeSpace = OldPos Else COMPLEX_LRU_MakeSpace = COMPLEX_LRU_Alloc(LRU) End If Return End Function !****************************************************************************** ! ! COMPLEX_LRU_ResetCount - Resets all the counts to COUNT_START ! ! LRU - LRU context ! !****************************************************************************** Subroutine COMPLEX_LRU_ResetCount(LRU) Type (COMPLEX_LRU_Context), Intent(INOUT) :: LRU LRU%LRUstruc%buffer(:)%Count = COUNT_START LRU%Count = COUNT_START Return End Subroutine !****************************************************************************** ! ! COMPLEX_LRU_FreeALL - Frees all the memory associated with the LRU buffers. ! ! LRU - LRU context ! !****************************************************************************** Subroutine COMPLEX_LRU_FreeAll(LRU) Type (COMPLEX_LRU_Context), Intent(INOUT) :: LRU Integer :: i LRU%LRUstruc%DiskMap = 0 Do i=1, LRU%TotalRecs If (LRU%LRUstruc%buffer(i)%Index>0) then DeAllocate(LRU%LRUstruc%Buffer(i)%Ptr) LRU%LRUstruc%Buffer(i)%Index = -1 Nullify(LRU%LRUstruc%Buffer(i)%Ptr) End If End Do LRU%MemUsed = 0 LRU%MemFree = LRU%MaxMem Return End Subroutine !****************************************************************************** ! ! COMPLEX_DisplayBufferInfo - Displays the Buffer Information to ! the specified device ! ! LRU - LRU context ! Output - Output unit ! !****************************************************************************** Subroutine COMPLEX_LRU_DisplayBufferInfo(LRU, Output) Type (COMPLEX_LRU_Context), Intent(INOUT) :: LRU Integer, Intent(IN) :: OutPut Integer :: i, j, LSize, Used Integer :: Mem_Proj, Mem_Psi, Calc_Proj,Calc_Psi Integer :: TotalMem, CacheTotal, CacheHits, CacheMisses Type (COMPLEX_LRUGrid), Pointer :: LG(:) Real :: Hits, miss, total Write(output,*) 'LRU_PRINT: Printing Buffer information*******' Write(output,*) 'ID=',Trim(LRU%ID), ' * Max Record:',LRU%TotalRecs TotalMem = 0 LG => LRU%LRUstruc%Buffer LSize = LRU%Data_Size Used = 0 Do j=1, LRU%TotalRecs If (LG(j)%Index > 0) Used = Used + 1 End Do TotalMem = TotalMem + Used*LSize Write(Output, *) 'Buffer info * Base Size:',LSize Write(Output, *) ' Allocated :',Used, ' * Mem:',Used*LSize CacheTotal = LRU%Cache%Hits + LRU%Cache%Misses Write(Output,*) ' Cache Stats: Total:',CacheTotal, & ' * Hits:',LRU%Cache%Hits, ' * Misses:',LRU%Cache%Misses if (CacheTotal > 0) then total = CacheTotal hits = (1.0*LRU%Cache%Hits)/total miss = (1.0*LRU%Cache%Misses)/total Write(Output,*) ' Cache Stats: %Hits:',Hits, ' * %Misses:',Miss End If Write(Output, *) ' Data : (Buffer, Disk, Size, Count)' Do j=1, LRU%TotalRecs If (LG(j)%Index > 0) then Write(Output,*) j,' *',LG(j)%Index,' *',Size(LG(j)%Ptr), & ' *', LG(j)%Count End If End Do Write(Output,*) 'Total Memory--> Max:', LRU%MaxMem, ' * Free:', LRU%MemFree, ' * Used:', LRU%MemUsed, ' * Calc Used:',TotalMem Write(Output,*) ' Overal Cache Statistics:' CacheHits = (LRU%Cache%Hits) CacheMisses = (LRU%Cache%Misses) CacheTotal = CacheHits + CacheMisses Write(Output,*) ' (Unweighted) Total:',CacheTotal, & ' * Hits:',CacheHits, ' * Misses:',CacheMisses total = CacheTotal If (total>0) then hits = (1.0*CacheHits)/total miss = (1.0*CacheMisses)/total Write(Output,*) ' %Hits:',Hits, ' * %Misses:',Miss End If hits = (LRU%Data_Size) hits = 1 miss = LRU%Data_Size/hits CacheHits = CacheHits + LRU%Cache%Hits * hits CacheMisses = CacheMisses + LRU%Cache%Misses * hits j = j / 8 CacheTotal = CacheHits + CacheMisses Write(Output,*) ' (Weighted) Total:',CacheTotal, & ' * Hits:',CacheHits, ' * Misses:',CacheMisses IF (CacheTotal > 0) then total = CacheTotal hits = (1.0*CacheHits)/total miss = (1.0*CacheMisses)/total Write(Output,*) ' %Hits:',Hits, ' * %Misses:',Miss End If If (LRU%MemFree < 0) then Write(Error_Unit, *) 'LRU_DisplayBufferInfo: Memory Error!!! Memory Free:',LRU%MemFree, ' * ID:',TRim(LRU%Id) End If Write(Output,*) '*********************************************************' Call Flush(OutPut) Return End Subroutine !****************************************************************************** ! ! COMPLEX_LRU_InitAlloc - Allocates the LRU data structures and ! initializes them for use. ! ! LRU - LRU context ! !****************************************************************************** Subroutine COMPLEX_LRU_InitAlloc(LRU) Type (COMPLEX_LRU_Context), Intent(INOUT) :: LRU Integer :: i, j, num Integer :: k, Offset, mem Character*100 :: msg Allocate(LRU%LRUStruc, LRU%Cache, STAT=i) Write(msg, *)'LRU_InitAlloc: Could Not allocate LRUStruc Array!', & TRIM(LRU%Id) Call Check_Error(i, msg, Error_Unit, .TRUE.,paw_wc, "LRU_InitAlloc:") LRU%Cache%Hits = 0 LRU%Cache%Misses = 0 LRU%Cache%Total = 0 k = LRU%TotalRecs Allocate(LRU%LRUstruc%Buffer(k), LRU%LRUstruc%DiskMap(k), STAT=j) Write(msg,*) 'LRI_InitAlloc: Could Not allocate Buffer array!', & ' * ID=',Trim(LRU%Id) Call Check_Error(j, msg, Error_Unit, .TRUE.,paw_wc, "LRU_InitAlloc:") LRU%LRUstruc%DiskMap = 0 Do j=1, k LRU%LRUstruc%buffer(j)%Index = -1 LRU%LRUstruc%Buffer(j)%Count = COUNT_START End Do Return End Subroutine !****************************************************************************** ! ! COMPLEX_LRU_InitContext - Initializes the LRU Context for use ! ! LRU - LRU context to initialize ! Id - Unique text Id for data ! FD_Base - Base Unit ! MaxMem - Max amount of memory to use for buffers ! MaxRec - Max data record ! RecSize - Array containing the number of data elem for each record ! !****************************************************************************** Subroutine COMPLEX_LRU_InitContext(LRU, id, FD_Base, MaxMem, MaxRec, & DataSize, ReplaceOldest) Type (COMPLEX_LRU_Context), Intent(INOUT) :: LRU Character*(*), Intent(IN) :: Id Integer, Intent(IN) :: FD_Base Real, Intent(IN) :: MaxMem Integer, Intent(IN) :: MaxRec Integer, Intent(IN) :: DataSize Logical, Intent(IN) :: ReplaceOldest Integer :: i, err, RecSize Character*100 :: msg LRU%Id = Id LRU%FD_Base = FD_Base i = SizeOf_C LRU%MaxMem = (MaxMem*(2**20))/i LRU%MemUsed = 0 LRU%MemFree = LRU%MaxMem LRU%TotalRecs = MaxRec LRU%ReplaceOldest = ReplaceOldest LRU%LastIndex = 1 Allocate(LRU%Data_Size) LRU%Data_Size = DataSize Nullify(LRU%LRUstruc) RecSize = SizeOf_COMPLEX*LRU%Data_Size Write(Log_Unit, *) 'LRU_InitContext: Unit=',FD_Base, & ' * Size=',LRU%data_size Open(FD_base, Form="UNFORMATTED", status="SCRATCH", & Access="DIRECT", RECL=REcSize, IOSTAT=err) Write(msg,*) ' Error opening file. Rec Size=',RecSize Msg = TRIM(LRU%Id) // ':' // Msg Call Check_Error(err, msg, Error_Unit, .TRUE., PAW_wc, & "COMPLEX_LRU_InitContext:") Call COMPLEX_LRU_InitAlloc(LRU) Return End Subroutine End Module spinpwpaw/code/coulomb_matrix.f900100664004704100470410000001363410303710172017212 0ustar natalienatalie!****************************************************************************** ! ! File : coulomb_matrix.f90 ! by : Alan Tackett ! on : 11/10/95 ! for : PAW Project ! ! Creates the coulomb matrix for a particular atom type. ! used in the atom_data module for the field Cijkl. ! ! ! ! M --- aL L-M LM ! Cijkl(:) = (-1) \ V * G G ! / n l n l n l n l l m l m l m l m ! --- i i j j k k l l i i j j k k l l ! L ! ! ! Where the G's are Gaunt coefficients and V is the fixed atom V_hartree data. ! The various l's amd m's are determined by the atomic orbitals defined ! for the specific atom. Capital L is a value in the range of ! ! L <= L <= L ! min max ! ! ! where L = MAX(| l - l |, | l - l |) and L = MIN( l + l , l + l ) ! min i j k l max i j k l ! ! Based on the symmetry properties of the Gaunt coefficients you know that ! ! LM ! G != 0 if (l + l + L) is EVEN and M = m - m ! l m l m i j j i ! i i j j ! ! ! ******* NOTE: No Error checking is done!!!!!! *************** ! The LUT_Cijkl must use 4 byte integers! ! ************************************************************** ! ! ! Parameters: ! ! Atom - Atom type to use for initializing Cijkl ! Array_Size - Size of Cijkl and LUT_Cijkl. ! if Array_Size = -1 then no data is stored and ! the array size required to store all the non-zero ! coefficients is returned. ! !****************************************************************************** Subroutine Coulomb_Matrix(Atom, Array_Size) Use atom_data Use spherical_harmonic Use coulomb_pack Use vhartree_pack Implicit None Type(Atom_Info_Fixed), Intent(INOUT) :: atom Integer, Intent(INOUT) :: Array_Size Logical :: Ok Integer :: loop Integer :: cnt, V_cnt, Num_Hartree Integer :: Lmin, Lmax, Ltest Integer :: nili, njlj, nklk, nlll Integer :: nili2, njlj2, nklk2, nlll2 Integer :: Li2, Lj2, Lk2, Ll2 Integer :: li, lj, lk, ll, mi, mj, mk, ml, M, L, i, j Integer :: mlmax, mlmin, Cap_L(100) Integer, Pointer :: L_Value(:), LUT(:), LUT_V_HARTREE(:) Real, Pointer :: Vh(:), Cijkl(:) Real :: msign, term Num_Hartree = Atom%Hartree_Size L_Value => Atom%L_Value Vh => Atom%V_Hartree Cijkl => Atom%Cijkl LUT => Atom%LUT_Cijkl LUT_V_HARTREE => Atom%LUT_V_HARTREE cnt = 0 V_cnt = 1 Do While (V_cnt <= Num_Hartree) Call VHartree_Decode(LUT_V_Hartree(V_cnt), nili, njlj, nklk, nlll, L) li = L_Value(nili); lj = L_value(njlj); lk = L_Value(nklk); ll = L_Value(nlll); Ltest = li + lj - lk - ll nili2 = nili; njlj2 = njlj; nklk2 = nklk; nlll2 = nlll; i = 0 Do While ((nili2==nili) .AND. (njlj2==njlj) .AND. & (nklk2==nklk) .AND. (nlll2==nlll) .AND. (V_cnt+i jikl nili = njlj2; Li = lj2; njlj = nili2; Lj = Li2; nklk = nklk2; Lk = Lk2; nlll = nlll2; Ll = Ll2; Else If ((loop==3) .AND. (nklk /= nlll)) then Ok = .TRUE. !** Swap kl -> ijlk nili = nili2; Li = li2; njlj = njlj2; Lj = Lj2; nklk = nlll2; Lk = Ll2; nlll = nklk2; Ll = Lk2; Else If ((loop==4) .AND. (nili /= njlj) .AND. (nklk /= nlll)) then Ok = .TRUE. !** Swap both -> jilk nili = njlj2; Li = lj2; njlj = nili2; Lj = Li2; nklk = nlll2; Lk = Ll2; nlll = nklk2; Ll = Lk2; End If If (Ok) then Do mi = -li, li Do mj = -lj, lj M = mi - mj msign = (-1.0)**M Do mk = -lk, lk Do ml = -ll, ll if (M==(ml-mk)) then term = 0 Do j = 1, i if (abs(M) <= Cap_L(j)) then term = term+Vh(V_cnt+j-1) * & Gaunt(Cap_L(j),-M,li,mi,lj,mj) * & Gaunt(Cap_L(j), M, lk, mk, ll, ml) End IF End Do if (ABS(term)>1E-20) then cnt = cnt + 1 if (Array_Size > 0) then Cijkl(cnt) = term*msign LUT(cnt) = Coulomb_Encode(nili,njlj,nklk, & nlll,mi,mj,mk) End If End If End IF End Do End Do End Do End Do End If End Do V_cnt = V_Cnt + i End Do Array_Size = cnt Return End Subroutine Coulomb_Matrix spinpwpaw/code/coulomb_pack.f900100664004704100470410000001121410303710172016614 0ustar natalienatalie!****************************************************************************** ! ! File : coulomb_pack.f90 ! by : Alan Tackett ! on : 11/10/95 ! for : PAW Method ! ! Contains 2 routines to encode and decode the coulomb matrix indices that are ! used in the atom_data module for the field Cijkl. ! ! M --- aL L-M LM ! Cijkl(:) = (-1) \ V * G G ! / n l n l n l n l l m l m l m l m ! --- i i j j k k l l i i j j k k l l ! L ! ! Where the G's are Gaunt coefficients and V is the fixed atom V_hartree data. ! The various l's amd m's are determined by the atomic orbitals defined ! for the specific atom. Capital L is a value in the range of ! ! L <= L <= L ! min max ! ! ! where L = MAX(| l - l |, | l - l |) and L = MIN( l + l , l + l ) ! min i j k l max i j k l ! ! Based on the symmetry properties of the Gaunt coefficients you know that ! ! LM ! G != 0 if (l + l + L) is EVEN and M = m - m ! l m l m i j j i ! i i j j ! ! ! For this reason the indices that have to be stored are : ! ! (n l ) (n l ) (n l ) (n l ) m m m ! i i j j k k l l i j k ! ! Bits Required: (5) (5) (5) (5) (3) (3) (3) = 29 bits total ! ! The l's can be determined from the (nl)'s and m = m + m - m ! l k i j ! ! Each l value is in the range on 0..3 and the corresponding m is in the ! range of -l <= m <= l for 2*l + 1 possible values. This gives the range ! for L = 0..6. The (nl) indices are stored as pairs which correspond ! to the actual basis function index. Since only 5 bits are used the max ! number of basis functions is 32 for each atom. The l's are not stored ! in order for the encoding to use less than 32 bits. The m's are stored ! by adding an offset of 3 this makes all the m's positive and doesn't ! require the l values. ! ! Also note that since 29 bits are required each integer should ! be 4 byte integer. The 29 LSB's are used all other bits are set to 0. ! ! ******* NOTE: No Error checking is done!!!!!! ******** ! !****************************************************************************** Module coulomb_pack implicit none !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! Coulomb_Encode - Encodes the given nili,njlj, nklk, nlll, mi, mj, ! and mk supplied assuming the above restrictions on ! l's, m's, and L. ! ! ! NOTE : NO error checking is done!!!! ! The return value must be a 4 byte or greater integer!! ! !****************************************************************************** Integer Function Coulomb_Encode(nili, njlj, nklk, nlll, mi, mj, mk) Integer, Intent(IN) :: nili Integer, Intent(IN) :: njlj Integer, Intent(IN) :: nklk Integer, Intent(IN) :: nlll Integer, Intent(IN) :: mi Integer, Intent(IN) :: mj Integer, Intent(IN) :: mk Integer :: N N = nili N = ISHFT(N, 5) + njlj N = ISHFT(N, 5) + nklk N = ISHFT(N, 5) + nlll N = ISHFT(N, 3) + mi+3 N = ISHFT(N, 3) + mj+3 N = ISHFT(N, 3) + mk+3 Coulomb_Encode = N Return End Function !****************************************************************************** ! ! Coulomb_Decode - Decodes the given value(N) into the separate nili, njlj, ! nklk,nlll, mi, mj, and mk assuming the above restrictions ! on (nl)'s, l's, m's, and L. ! ! ! NOTE : NO error checking is done!!!! ! The default integer must be a 4 byte or greater integer!! ! !****************************************************************************** Subroutine Coulomb_Decode(N, nili, njlj, nklk, nlll, mi, mj, mk) Integer, Intent(IN) :: N Integer, Intent(OUT) :: nili Integer, Intent(OUT) :: njlj Integer, Intent(OUT) :: nklk Integer, Intent(OUT) :: nlll Integer, Intent(OUT) :: mi Integer, Intent(OUT) :: mj Integer, Intent(OUT) :: mk nili = ISHFT(IAND(31*(2**24), N), -24) njlj = ISHFT(IAND(31*(2**19), N), -19) nklk = ISHFT(IAND(31*(2**14), N), -14) nlll = ISHFT(IAND(31*(2**9) , N), -9) mi = ISHFT(IAND(7*(2**6), N), -6) - 3 mj = ISHFT(IAND(7*(2**3), N), -3) - 3 mk = IAND(7, N) - 3 Return End Subroutine End Module spinpwpaw/code/countbands.f900100664004704100470410000000500610303710172016320 0ustar natalienatalie!****************************************************************************** ! ! File : countbands.f90 ! by : Alan Tackett ! on : 7/30/98 ! for : PAW project ! ! CountBands - Counts the number of bands per BZ k-Point this is determined ! by the Atom_List(i)%Valence_Orbitals which is actually a ! nili index list determining which basis functions to use ! as initial valence bands. ! ! The number of electrons is also counted. ! !****************************************************************************** Subroutine CountBands Use paw_inout Use misc Use word Use atom_data Use options_data implicit none Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT Integer :: i, j, L, nili, ExtraPsi Integer, Pointer :: L_Values(:), Orbitals(:) Real, Pointer :: Occ(:), Occup(:), Occdn(:) NumBands = 0 TotalElectrons = 0 NetCharge = 0 Do i=1, Specific_Atoms A => Atom_List(i) AT => AtomType_Info(A%TypeIndex) L_Values => AT%L_Value Orbitals => A%Valence_Orbitals If (.not.spindependence)Occ => A%Init_Occ If (spindependence)Occup => A%Init_Occspinup If (spindependence)Occdn => A%Init_Occspindn NetCharge = Netcharge + (AT%Atomic_Charge - AT%Core_Charge) Do j=1, A%Orbitals_Size nili = Orbitals(j) L = L_Values(nili) NumBands = NumBands + 2*L+1 if(.not.spindependence) TotalElectrons = TotalElectrons + Occ(j) if(spindependence) TotalElectrons = TotalElectrons + Occup(j)+Occdn(j) End Do End Do Write(Log_Unit, *) 'CountBands: Total number of valence bands:',NumBands Write(Log_Unit, *) 'CountBands: Total charge from occupancy:', TotalElectrons Write(Log_Unit, *) 'CountBands: Total charge from atoms:', Netcharge NetCharge = NetCharge - TotalElectrons If (ABS(NetCharge)>1E-6) then Write(Log_Unit,*) 'CountBands: Charged SuperCell! Net charge:',NetCharge Write(Log_Unit,*) 'CountBands: Compensting with a uniform charge of :',& -Netcharge Write(Error_Unit,*) 'CountBands: Charged SuperCell! Net charge:',NetCharge Write(Error_Unit,*) 'CountBands: Compensting with a uniform charge of :',& -Netcharge else Write(Log_Unit,*) 'CountBands: Neutral SuperCell. No compensation charge required.' End If NumBands = 2*NumBands !NumBands = 1 !TotalElectrons = 2 Write(Log_Unit, *) 'CountBands: Using valence bands',NumBands Return End Subroutine spinpwpaw/code/cpusec.f900100664004704100470410000000077310303710172015450 0ustar natalienataliesubroutine cpu_second (cpu,user,sys) implicit none real, intent(out) :: cpu,user,sys ! ------------------------------------------------ ! returns elapsed cpu time since start of job (sec) ! ------------------------------------------------ ! etime version; etime is common on many unix systems ! This variant has an underscore, for systems that extend function names real*4, dimension(2) :: tarray real*4 :: etime cpu = etime(tarray) user = tarray(1) sys = tarray(2) return end subroutine cpu_second spinpwpaw/code/crystal_data.f900100664004704100470410000000521010303710172016627 0ustar natalienatalie!**************************************************************************** ! ! File : crystal_data.f90 ! by : Alan Tackett ! on : 9/18/95 ! for : PAW project ! ! Contains the structure pertaining to the crystal. ! !**************************************************************************** Module crystal_data Use bzint Type Crystal_struct !** Crystal Data structure Real :: Basis(3,3) !** Lattice Basis Vectors Real :: Recip(3,3) !** Reciprocal Basis Real :: InverseBasis(3,3) !** Inverse Basis (Recip / 2*Pi) Real, Pointer :: RotMatrix(:,:,:) !** Array containing symmetry rot mat's Real, Pointer :: Trans(:,:) !** Array containing symmetry rot translations Real :: Volume !** Unit cell Volume Real :: RecipVol !** Volume of the reciprocal unit cell Real :: sigma !** Gaussian Smearing width Real, Pointer :: Wt(:) !** Kpoints weight - Temporary Buffer Integer :: Rot_Size !** Number of rotation matrices Integer :: BZ_Method !** BZ Integration Method Integer :: Kpnts_Grid(3) !** K-points Grid Size Logical :: Auto_symmetry !** Automatically calculate the symmetry Integer :: CloneCell(3) !** Cell replication End Type Type (Crystal_Struct) :: xtal !** Crystal data information Logical :: Xtal_Defined !** Determines if I have the Xtal defined Type (BZ_Struct) :: BZ !** BZ data Real, Pointer :: angpoints(:,:) !** Gauss-Legendre integration points Integer :: Num_AngPoints !** number of angular points Integer :: BLOCH_ZERO Type Two_Dim !** Data type for 2-dimensional plot Real :: X(3) ! X-axis in Cartesian coordinates Real :: Y(3) ! Y-axis in Cartesian coordinates Real :: Origin(3) ! Coordinate (in Cartesian coordinates) of plot origin Integer :: Grid(2) ! Number of grid points in 2 dimensions Integer :: Query ! Number to check correct setting of parameters End Type Type Three_Dim !** Data type for 3-dimensional plot Real :: X(3) ! X-axis in Cartesian coordinates Real :: Y(3) ! Y-axis in Cartesian coordinates Real :: Z(3) ! Z-axis in Cartesian coordinates Real :: Origin(3) ! Coordinate (in Cartesian coordinates) of plot origin Real :: maxbond ! Maximum bond length for ball and stick output Real :: bondtol ! Bond length % slack for ball and stick output Integer :: Grid(3) ! Number of grid points in 3 dimensions Integer :: Query ! Number to check correct setting of parameters End Type Type (Two_Dim) :: Planeplot Type (Three_Dim) :: Volumeplot End Module spinpwpaw/code/crystal_symmetry.f900100664004704100470410000003101210303710172017606 0ustar natalienatalie!**************************************************************************** ! ! File : crystal_symmetry.f ! by : N.A.W. Holzwarth ! on : ! for : PAW Project ! ! Module for generating the symmetry matrices for use by SymRho and ! SymWij. ! ! Modified on 2/13/95 by Alan Tackett to use the new data names ! !**************************************************************************** module crystal_symmetry Use crystal_data Use atom_data Use paw_inout Use mathlib implicit none save integer :: nel, nkind, mxatom integer, pointer :: igrot(:,:,:),iatrans(:,:) Real, pointer :: gtrans(:,:),srot(:,:,:) Complex, pointer :: zarot(:,:,:,:) Real, parameter :: tol=1.d-6 ! Real, parameter :: Two_Pi = 2*PI ! constant Two_Pi=two_pi set in mathlib Real :: b1(3),b2(3), b3(3), a1(3),a2(3),a3(3) contains subroutine setsym(lmax) ! input rotation matrices in cartesian coordinates and translation ! vector in lattice coordinates (in units of a1,a2,a3) ! ! uses sign & phase convension of M. E. Rose, Elementary Theory of Angular ! Momentum, John Wiley & Sons,. inc. 1957) ! zalpha = exp(-i*alpha) zgamma = exp (-i*gamma) ! ! assumes each transformation can be expressed in terms of 3 Euler angles ! with or without inversion !*******use lattice_data***** implicit none integer :: lmax, iapkind, iakind Real :: rot(3,3),trans(3),v(3),vp(3), tau(3), T(3) integer :: ier,jer,many,i,j,k,irot,it,is,isn,mxrl,mxrm,nread integer :: iap,index,ia,ikind,il,l,m,mp,l1,l2,l3 Real :: t1,t2,t3,diff,check Real :: cosbeta,sinbeta,cosalp,sinalp,cosgam,singam Complex :: zalpha,zgamma nel = Xtal%Rot_Size !**** The Rotation matrices and srot => Xtal%RotMatrix !**** size are already loaded gtrans => Xtal%Trans !**** mxatom = Specific_Atoms nkind = Atom_Types !** allocate(gtrans(3,nel)) a1 = Xtal%Basis(:,1); a2 = Xtal%Basis(:,2); a3 = Xtal%Basis(:,3) b1 = Xtal%Recip(:,1); b2 = Xtal%Recip(:,2); b3 = Xtal%Recip(:,3) mxrl=lmax+1 mxrm=2*lmax+1 allocate(zarot(mxrm,mxrm,mxrl,nel),igrot(3,3,nel),stat=ier) if (ier.ne.0) then write(6,*) 'error in allocating rotation matrices',mxrm,mxrl,nel stop endif allocate(iatrans(mxatom,nel),stat=ier) if (ier.ne.0) then write(6,*) 'error in allocating translation matrices',nel,mxatom stop endif zarot=0;igrot=0;iatrans=0 write(6,*) write(Log_Unit,*) ' # symmetry elements ',nel,' :' write(Log_Unit,*) write(Log_Unit,*) 'Cartesian coordinates Lattice coordinates' ! read in rotation matrices in cartesian coordinates ! and translations vectors in primitive lattice coordinates do irot=1,nel Rot = SRot(:,:,irot) !**** Changed trans = gtrans(:,irot) ! PW transformations igrot(1,1,irot)=ielement(a1,rot,b1) igrot(2,1,irot)=ielement(a2,rot,b1) igrot(3,1,irot)=ielement(a3,rot,b1) igrot(1,2,irot)=ielement(a1,rot,b2) igrot(2,2,irot)=ielement(a2,rot,b2) igrot(3,2,irot)=ielement(a3,rot,b2) igrot(1,3,irot)=ielement(a1,rot,b3) igrot(2,3,irot)=ielement(a2,rot,b3) igrot(3,3,irot)=ielement(a3,rot,b3) write(Log_Unit,*) write(Log_Unit,*) 'element #',irot do i=1,3 write(Log_Unit,'(3f8.4,10x,3i5)') (rot(i,j),j=1,3),(igrot(i,j,irot),j=1,3) end do write(Log_Unit,'(a3,4x,3f10.4)') 't =', (gtrans(i,irot),i=1,3) ! set up atomic shifts do ia=1, Specific_Atoms iakind = Atom_List(ia)%TypeIndex Tau = Atom_List(ia)%Frac_Pos index=0 bigloop: do iap=1, Specific_Atoms iapkind = Atom_List(iap)%TypeIndex v = Atom_List(iap)%Pos vp = MATMUL(rot, V) !write(Log_Unit,*) 'setsym: Vp=',Vp t1 = DOT_PRODUCT(XTal%Recip(:,1),vp)/Two_Pi + trans(1) t2 = DOT_PRODUCT(XTal%Recip(:,2),vp)/Two_Pi + trans(2) t3 = DOT_PRODUCT(XTal%Recip(:,3),vp)/Two_Pi + trans(3) !write(Log_Unit,*) 'setsym: T=',t1,t2,t3, ' * Tau=',Tau, 'trans=',trans if (iakind == iapkind) then small1: do l1=-7,7,1 small2: do l2=-7,7,1 small3: do l3=-7,7,1 diff=abs(t1-tau(1)+l1)+abs(t2-tau(2)+l2)+abs(t3-tau(3)+l3) if (diff.lt.tol) then index=iap exit bigloop end if enddo small3 enddo small2 enddo small1 End If end do bigloop if (index.lt.1) then write(Log_Unit,*) 'error in symmetry set up ',index,ia,iakind, diff stop end if iatrans(ia,irot)=index write(Log_Unit,"(i3,'-->',i3)") ia,iatrans(ia,irot) enddo ! ia loop ! calculate rotation matrices ! l=0 case zarot(1,1,1,irot)=1 ! l>0 case if (lmax.gt.0) then call makeeuler(rot,cosbeta,zalpha,zgamma,isn) write(Log_Unit,*)'setsym: cosbeta=',cosbeta,' * zalpha=',zalpha, ' * zgamma=',zgamma do l=1,lmax il=(isn)**l do m=-L, L i=m+L+1 do mp=-L, L j=mp+L+1 write(Log_Unit,*) 'setsym: m=',m, ' mp=',mp, ' dbeta=',dbeta(cosbeta,l,mp,m) zarot(j,i,l+1,irot)=il*dbeta(cosbeta,l,mp,m) & *(zalpha**mp)*(zgamma**m) enddo enddo enddo endif ! lmax case if( lmax.gt.0) then write(Log_Unit,*) ' Rotation matrices for l=1' do i=1,3 write(Log_Unit,'(3(2f7.3,2x))') (zarot(i,j,2,irot),j=1,3) enddo if (lmax.gt.1) then write(Log_Unit,*) ' Rotation matrices for l=2' do i=1,5 write(Log_Unit,'(5(2f7.3,2x))') (zarot(i,j,3,irot),j=1,5) enddo endif endif enddo !nel loop return end subroutine setsym subroutine makeeuler(rot,cosbeta,zalpha,zgamma,isn) implicit none Real :: rot(3,3),cosbeta,sinbeta Real :: cosalp,sinalp,cosgam,singam,check Complex :: zalpha,zgamma integer :: ier,isn do isn= -1,1,2 cosbeta=isn*rot(3,3) sinbeta=sqrt(1.d0-cosbeta*cosbeta) if (abs(sinbeta).gt.tol) then zalpha=isn*cmplx(rot(3,1),-rot(3,2))/sinbeta zgamma=isn*cmplx(-rot(1,3),-rot(2,3))/sinbeta else zalpha=isn*cmplx(rot(1,1),-rot(1,2))/cosbeta zgamma=1.d0 endif ! check matrix: ier=0 cosalp=zalpha sinalp=-aimag(zalpha) cosgam=zgamma singam=-aimag(zgamma) check=cosalp*cosbeta*cosgam-sinalp*singam if (abs(check-isn*rot(1,1)).gt.tol) ier=ier+1 check=sinalp*cosbeta*cosgam+cosalp*singam if (abs(check-isn*rot(1,2)).gt.tol) ier=ier+1 check=-sinbeta*cosgam if (abs(check-isn*rot(1,3)).gt.tol) ier=ier+1 check=-cosalp*cosbeta*singam-sinalp*cosgam if (abs(check-isn*rot(2,1)).gt.tol) ier=ier+1 check=-sinalp*cosbeta*singam+cosalp*cosgam if (abs(check-isn*rot(2,2)).gt.tol) ier=ier+1 check=sinbeta*singam if (abs(check-isn*rot(2,3)).gt.tol) ier=ier+1 check=cosalp*sinbeta if (abs(check-isn*rot(3,1)).gt.tol) ier=ier+1 check=sinalp*sinbeta if (abs(check-isn*rot(3,2)).gt.tol) ier=ier+1 if (ier.eq.0) return enddo write(Log_Unit,*) 'error in rot ',ier,rot write(Log_Unit,*) 'alpha=',cosalp,sinalp write(Log_Unit,*) 'beta =',cosbeta,sinbeta write(Log_Unit,*) 'gamma = ',cosgam,singam isn=0 stop end subroutine makeeuler function dbeta(cosbeta,l,mp,m) ! calculate the rotation matrix d^l_{m'm}(beta) using Eq. 4.14 of ! M. E. Rose, Elementary Theory of Angular Momentum, John Wiley & Sons ! New York, 1957 ! Assume l relatively small so that factorials do not cause ! roundoff error implicit none integer , parameter :: mxterms=200 Real :: dbeta,cosbeta integer :: l,mp,m,i Real :: cosbetab2,sinbetab2,pref,sum,t,arg integer :: ina,inb,inc,ml,ms,last dbeta=0 ! special cases if (abs(cosbeta-1.d0).lt.tol) then if (mp.eq.m) dbeta=1 else if (abs(cosbeta+1.d0).lt.tol) then if (mp.eq.-m) dbeta=(-1)**(l+m) else ! general case cosbetab2=sqrt((1+cosbeta)*0.5d0) sinbetab2=sqrt((1-cosbeta)*0.5d0) ml=max(mp,m) ms=min(mp,m) if (ml.ne.mp) sinbetab2=-sinbetab2 ! t=-(cosbetab2/sinbetab2)**2 !possible error found by A. Wright t=-(sinbetab2/cosbetab2)**2 !possible error found by A. Wright pref=sqrt((Factorial(l-ms)*Factorial(l+ml))/ & (Factorial(l+ms)*Factorial(l-ml)))/Factorial(ml-ms) & *(cosbetab2**(2*l+ms-ml))*((-sinbetab2)**(ml-ms)) sum=1 arg=1 ina=ml-l inb=-ms-l inc=ml-ms+1 do i=1,mxterms if (ina.eq.0.or.inb.eq.0) exit arg=(arg*ina*inb*t)/(i*inc) sum=sum+arg ina=ina+1 inb=inb+1 inc=inc+1 enddo dbeta=pref*sum endif return end function dbeta function ielement(tt,rot,gg) implicit none Real :: tt(3),gg(3),rot(3,3),sum,dsign integer :: ielement,i,j sum=0.d0 do j=1,3 do i=1,3 sum=sum+tt(i)*rot(i,j)*gg(j) enddo enddo ielement=sum/Two_Pi+sign(0.00001,sum) return end function ielement !***************************************************************************** ! ! Symmetrize_pos -- inputs nominal atomic positions and outputs ! symmetrized positions in fractional units ! !***************************************************************************** Subroutine Symmetrize_Pos(Inpos,Outpos) Real, intent(IN) :: Inpos(3,Specific_Atoms) Real, intent(OUT) :: Outpos(3,Specific_Atoms) Real,allocatable :: tmppos(:,:),frot(:,:,:) Integer,allocatable :: Iswitch(:,:),shift(:,:) Real :: v(3),vp(3),vpp(3) Integer :: ia,iap,is,i,j Outpos=InPos If (Xtal%Rot_Size.le.1) Return Allocate(tmppos(3,Specific_Atoms),frot(3,3,Xtal%Rot_Size), & shift(3,Specific_Atoms),Iswitch(Specific_atoms,Xtal%Rot_Size)) tmppos = 0 outpos = 0 frot=0 Iswitch=0 Do is=1,Xtal%Rot_Size frot(:,:,is)= MATMUL(Xtal%InverseBasis,& MATMUL(Xtal%RotMatrix(:,:,is),Xtal%Basis)) Do ia=1,Specific_Atoms Iswitch(iatrans(ia,is),is)=ia Enddo Enddo Do ia=1,Specific_Atoms vp=Inpos(:,ia) v(1)=HalfMod(vp(1)); v(2)=HalfMod(vp(2)); v(3)=HalfMod(vp(3)) shift(:,ia)= (Inpos(:,ia) - v)*(1.00001) Do is=1,Xtal%Rot_Size iap=Iswitch(ia,is) vp = MATMUL(frot(:,:,is),v) + Xtal%trans(:,is) vpp(1)=HalfMod(vp(1)); vpp(2)=HalfMod(vp(2)); vpp(3)=HalfMod(vp(3)) tmppos(:,iap)=tmppos(:,iap)+vpp Enddo Enddo write(*,*) 'inpos outpos' Do ia=1,Specific_Atoms v=tmppos(:,ia)/Xtal%Rot_Size Call FilterVec(v,Outpos(:,ia)) Outpos(:,ia)=Outpos(:,ia) + shift(:,ia) write(*,'(i5,1p3e15.7,2x,1p3e15.7)') ia,inpos(:,ia),outpos(:,ia) v=inpos(:,ia)-outpos(:,ia) if (DOT_PRODUCT(v,v).gt.0.1) then Write(Error_Unit,*) 'Warning from Symmetrize_Pos for atom #',ia,& ' inpos = ', inpos(:,ia),' outpos = ',outpos(:,ia) EndIf Enddo Deallocate(tmppos,frot,Iswitch,shift) Return End Subroutine Symmetrize_Pos !****************************************************************************** ! ! Function HalfMod(x) ! ! HalfMod sifts x between -.5 < HalfMod <= .5 ! !****************************************************************************** Function HalfMod(x) Real, intent(IN) :: x Real :: HalfMod HalfMod=x Do If (HalfMod > 0.5000000001d0) then HalfMod=HalfMod - 1 Else Exit EndIf EndDo Do If (HalfMod <= -0.499999999d0) then HalfMod=HalfMod +1 Else Exit EndIf Enddo Return End Function HalfMod !***************************************************************************** ! ! FilterVec(Vin,Vout) ! ! Elements of Vin(3) are zeroed if their value is less than tolerance ! !***************************************************************************** Subroutine FilterVec(Vin,Vout) Real,intent(IN) :: Vin(3) Real,intent(OUT):: Vout(3) Real, parameter :: tol=1.e-10 integer :: i do i=1,3 If (ABS(Vin(i)) < tol) then Vout(i) = 0 Else Vout(i)= Vin(i) EndIf Enddo Return End subroutine FilterVec end module crystal_symmetry spinpwpaw/code/debug.f900100664004704100470410000003005010371153045015250 0ustar natalienatalie!****************************************************************************** ! ! File : debug.f90 ! by : Alan Tackett ! on : 08/11/97 ! for : Testing MGPAW ! ! modified for spin dependence by Ping Tang ! and N. A. W. Holzwarth ! last change: 5/27/05 ! !****************************************************************************** Module debug Use paw_inout Use mem_data Use memmgr Use psilib Use fileio Use paw_inout Use search_sort Use hamop Use word Use basis_lib Use gpoints Use oinverse Implicit NONE!!!!!!!!!!!!! !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! WriteMatrix_Maple - Prints a matrix to disk for inclusion in maple ! ! FileName - FileName ! A - Matrix ! Rows,Cols - Rows and columns of matrix ! !****************************************************************************** Subroutine WriteMatrix_Maple(Filename, A, Rows, Cols) Character*(*), Intent(IN) :: FileName Complex, Intent(IN) :: A(:,:) Integer, Intent(IN) :: Rows Integer, Intent(IN) :: Cols Integer :: i,j,fd Character*100 :: text, t1, t2 fd = 231 Open(fd, FILE=Filename, RECL=1024) Write(fd,*) 'with(linalg);' Write(t1, *) Rows Write(t2, *) Cols ! Write(fd,*) 'A := array(1..',TRIM(ADJUSTL(t1)), & ! ', 1..',TRIM(ADJUSTL(t2)),', [' Write(fd,*) 'A := array(1..',Rows, & ', 1..',Cols,', [' Do i=1, Rows Write(fd,*) ' [' Do j=1, Cols !** Write(t1,*) Real(A(i,j)) !** Write(t2,*) Imag(A(i,j)) IF (j==Cols) then !** Write(fd,*) ' ',TRIM(ADJUSTL(t1)),'+',TRIM(ADJUSTL(t2)), '*I' Write(fd,*) ' ',Real(A(i,j)),'+',Imag(A(i,j)), '*I' else !** Write(fd,*) ' ',TRIM(ADJUSTL(t1)),'+',TRIM(ADJUSTL(t2)), '*I,' Write(fd,*) ' ',Real(A(i,j)),'+',Imag(A(i,j)), '*I,' End If End Do Write(fd,*) ' ]' End Do Write(fd, *) ']);' Close(fd) Return End Subroutine !****************************************************************************** ! ! CheckError_Grid - Calculates the energy and magnitude of the given Grid ! ! Psi - Wave vector to multiplies band ! !****************************************************************************** Subroutine CheckError_Grid(Grid, Kpnt,BandEnergy,Band, OutPut, Err) Complex, Intent(IN) :: Grid(:) Integer, Intent(IN) :: Kpnt Real, Intent(IN) :: bandEnergy Integer, Intent(IN) :: Band Integer, OPTIONAL, Intent(IN) :: Output Real, OPTIONAL, Intent(OUT) :: Err Complex :: energy, MAg, Error, oi_err, hoih_err, Pdot2(PLM_Max) Complex, Pointer :: Psi(:), Hx(:), KE(:), PDOT(:), Oi(:), HOiHx(:) Complex, Pointer :: Ve(:) Integer :: LSize, Out, i Integer :: Vec_toProcess(Mem_MapSize) Logical :: PDOT_Stored Real :: Eo, Ew If (Present(Output)) then out = Output else out = 6 End If if(.NOT.spindependence .OR. PsiInfo(Band)%spinup) THEN Ve=>SCFValues%Ve else Ve=>SCFValues%Vespin end if !Write(*,*) 'CheckError: Start!!!!!!!!!' Call Getbuffer( Psi) Call GetBuffer( Hx) Call GetBuffer( KE) Psi = Grid Vec_toProcess = MH_Skip !Write(*,*) 'CheckError: Before Phase_Generic' Call Phase_Generic( Vec_toPRocess, Kpnt) !Write(*,*) 'CheckError: Before CalcProjProducts' PDOT => Psiinfo(Band)%PDOT Call CalcHxandOx( Psi, Hx, KE, Ve, PDOT, & Kpnt, PsiInfo(Band)%PDOT_Stored) Eo = 1; Ew = 1; hoih_err = -1 If (Eigen_Mode == EIGEN_ENERGY) then Call GetBuffer( HOiHx) Call Calc_HOiHx_Hx_Ox( Psi, HOiHx, Hx, KE, Ve, PDOT, & Kpnt, PsiInfo(Band)%PDOT_Stored, Eo, Ew) hoih_err = Basis_DotProd(Psi, HOiHx, .FALSE.) energy = Basis_DotProd( Psi,Hx, .FALSE.) HOiHx = HoiHx - hoih_err*KE oi_err = Basis_DotProd( HOiHx, HoiHx, .FALSE.) Call FreeBuffer(HOiHx) end if mag = Basis_DotProd( Psi, KE, .FALSE.) Ke = Hx - BandEnergy*Ke Error = Basis_DotProd( KE, KE, .FALSE.) Call FreeBuffer(KE) Energy = Basis_DotProd( Psi, Hx, .FALSE.) Call FreeBuffer(Hx) Call FreeBuffer(Psi) Write(out,*) 'CheckError: Calculated Energy: ', Real(Energy), & ' * Band Energy: ', BandEnergy, ' * Mag(Psi)=',Real(mag) if (abs(real(mag)) > 1D-100) Write(out,*)' Normalized Energy =', Real(Energy/mag) Write(out,*) 'CheckError: Error in Hx-eX =', Real(Error), ' * Kpnt=',Kpnt, ' * Band=', Band If (Eigen_Mode == EIGEN_ENERGY) then energy = (Energy - Eo)/Ew Write(out,*) 'CheckError: Error in Oinv =',oi_err Write(out,*) 'CheckError: Error in HOiH =',hoih_err, ' shift energy=',Energy**2 End If If (Present(Err)) Err = Error Return End Subroutine !****************************************************************************** ! ! CheckError - Calculates the energy and magnitude of the given band ! ! PsiBand - Wave vector to multiplies band ! !****************************************************************************** Subroutine CheckError(PsiBand, OutPut, Error) Integer, Intent(IN) :: PsiBand Integer, OPTIONAL, Intent(IN) :: Output Real, OPTIONAL, Intent(OUT) :: Error Real :: Err Integer :: Out Complex, Pointer :: Psi(:) If (Present(Output)) then out = Output else out = 6 End If Call Getbuffer( Psi) Call GetPsi_fromBuffer( PsiBand, Psi) Call CheckError_GRID( Psi, PsiInfo(PsiBand)%Kpnt, & PsiInfo(PsiBand)%Energy, PsiBand, out, Err) Call FreeBuffer(Psi) If (Present(Error)) Error = Err PsiInfo(PSiBand)%Error = Err Return End Subroutine !****************************************************************************** ! ! CheckClusterError - Checks the cluster error ! ! Output - Output Unit ! Cluster - Cluster to check ! !****************************************************************************** Subroutine CheckClusterError(Output, Cluster, DoStoreError) Integer, Intent(IN) :: Output Integer, Intent(IN) :: Cluster Logical, Intent(IN) :: DoStoreError Integer :: i, LSize Real :: Error LSize = PsiArraySize Do i=1, Mem_MapSize If (ClusterMap(i) == CLuster) then Write(Output, *) 'CheckCLusterError: Disk Index=', i, & ' * CLuster=', CLuster Call CheckError( i, Output, Error) If (DoStoreError) PsiInfo(i)%Error = Error End If End Do Return End Subroutine !****************************************************************************** ! ! DisplayClusterEnergy - Printe the Cluster Energy to the specified device ! ! Output - Output device ! Cluster - Cluster Info to Display ! !****************************************************************************** Subroutine DisplayClusterEnergy(Output, Cluster,Countup,Countdn) Integer, Intent(IN) :: Output Integer, Intent(IN) :: Cluster Real, INTENT(INOUT) :: Countup Real, INTENT(INOUT), OPTIONAL :: Countdn Integer :: i Character*50 :: tmpstr, Kpnt_String Write(Output,*)'Energies for cluster',cluster, & ' (DiskRec, Energy, Occ, Kpnt)', ' * Size:',ClusterSize(cluster) Do i=1, Mem_MapSize If (CLusterMap(i) == Cluster) then Write(Kpnt_String, *) PsiInfo(i)%Kpnt,PsiInfo(i)%spinup Write(OutPut, *) i, ' *', PsiInfo(i)%Energy, & ' *',PsiInfo(i)%Occupancy, ' * ', TRIM(AdjustL(Kpnt_String)) If (PsiInfo(i)%spinup) Countup=Countup+PsiInfo(i)%Occupancy If (present(Countdn).and..not.PsiInfo(i)%spinup)& Countdn=Countdn+PsiInfo(i)%Occupancy End if End Do Return End Subroutine !****************************************************************************** ! ! DisplayEnergy - Prints the Energy levels to the specified device ! ! Output - Output device ! !****************************************************************************** Subroutine DisplayEnergy(Output,Countup,Countdn) Integer, Intent(IN) :: Output Real, INTENT(OUT) ::Countup Real, INTENT(OUT),optional ::Countdn Integer :: i Countup=0 If (present(Countdn)) Countdn=0 Do i=1, LastCluster If(present(Countdn)) then Call DisplayCLusterEnergy(Output, i,Countup,Countdn) Else Call DisplayCLusterEnergy(Output, i,Countup) Endif End Do Return End Subroutine !****************************************************************************** ! ! CheckPotErrorl - Checks the error in the potential ! ! V - Potential ! Rho - Density ! Output - Output unit ! ! !****************************************************************************** Subroutine CheckPotError( Output, Err) Integer, Intent(IN) :: Output Real, OPTIONAL, Intent(OUT) :: Err If (Present(Err)) Err = 0 Return End Subroutine !****************************************************************************** ! ! WriteSlice ! !****************************************************************************** Subroutine WriteSLice(PM_Slice,Dir,fn1, fn2, V) Integer, Intent(IN) :: PM_SLice(:) Integer, Intent(IN) :: Dir Character*(*), intent(IN) :: Fn1, Fn2 Complex, Intent(IN) :: V(:) Complex, Pointer :: Vr(:) Character*1, PARAMETER :: XYZ(3) = (/'X', 'Y', 'Z'/) Integer :: P(3), Pf(3), i, fd, offset Complex :: Value Real :: mag, R(3) write(Log_unit,*) 'Entered subroutine WriteSlice which no longer works' stop Vr =>SCFvalues%Work Vr = 0 Vr(FFTmap_Low) = V Call PerformFFT(FFT_TO_R, G_LOW, Vr) fd = 98 Open(fd, FILE=Fn1, RECL=10000) Write(fd,*) 'PM, R, Fn(Re), Fn(Im), Fn(mag**2) Fn(mag) (Dir=', & XYZ(Dir),')' P = PM_Slice Do i=1, FFT_Grid(Dir, G_Low) !Write(*,*) 'WriteSLice: i=',i P(dir) = i offset = CalcLinearIndex(FFT_Grid(:,G_LOW), P) + 1 Value = Vr(offset) !Call CalcRealSpace( Pf, R) mag = CONJG(Value)*Value Write(fd, *) i, R(dir), Real(Value), AImag(Value), mag, sqrt(mag) End Do Close(fd) Return End Subroutine !****************************************************************************** ! ! WritePsiSlice ! !****************************************************************************** Subroutine WritePSiSlice( PM_SLice, Dir, ext) Integer, Intent(IN) :: PM_SLice(:) Integer, Intent(IN) :: Dir Character*(*), intent(IN) :: Ext Integer :: i Character*100 :: Fname1, fname2 Complex, Pointer :: Psi(:), Vout(:), KE(:), Ve(:) Complex, TARGET :: PDot(PLM_Max) Integer :: Vec_toProcess(Mem_MapSize) write(Log_unit,*) 'Entered WritePSiSlice which no longer works' stop Call GetBuffer( Psi) Call GetBuffer( Vout) Call GetBuffer( KE) Fname1 = 'pot' // TRIM(EXT) Fname2 = 'pot_used' // TRIM(EXT) SCFvalues%Work = SCFvalues%Ve Call PerformFFT(FFT_TO_G, G_LOW, SCFvalues%Work) Psi = SCFvalues%Work(FFTmap_LOW) Call WriteSLice( PM_SLice, Dir, Fname1, Fname2, & SCFvalues%Work) Vec_toProcess = MH_SKip Do i=1, Mem_MapSize - 1 If (ClusterMap(i)>0) then Call GetPsi_fromBuffer( i, Psi) Write(Fname2, *) i Fname1 = 'psi' // TRIM(ADJUSTL(Fname2)) // TRIM(EXT) Fname2 = 'psi_used' // TRIM(ADJUSTL(Fname2)) // TRIM(EXT) Call WriteSLice(PM_SLice,Dir,Fname1,Fname2, Psi) Vout = 0 Call Phase_Generic( Vec_toProcess, & PsiInfo(i)%Kpnt) if(.NOT.spindependence .OR. PsiInfo(i)%spinup) then Ve=>SCFValues%Ve else Ve=>SCFValues%Vespin endif Call HPsi( Psi, & Vout, Ve, PsiInfo(i)%PDot, PsiInfo(i)%Kpnt, PsiInfo(i)%PDOT_Stored) Call Opsi( Psi, KE, & PsiInfo(i)%PDot, PsiInfo(i)%Kpnt, PsiInfo(i)%PDOT_Stored) Vout = Vout - PsiInfo(i)%Energy*KE Write(Log_Unit,*) 'WPS: i=',i Fname2 = ' ' Write(Fname2, *) i Write(Log_Unit,*) 'AFter Fname2 Store =!',TRIM(Fname2),'!' Fname1 = 'psierr' // TRIM(ADJUSTL(Fname2)) // TRIM(EXT) Fname2 = 'psierr_used' // TRIM(ADJUSTL(Fname2)) // TRIM(EXT) Call WriteSLice(PM_SLice,Dir,Fname1,Fname2, Vout) End If End Do Call FreeBuffer(Psi) Call FreeBuffer(Vout) Call FreeBuffer(KE) Return End Subroutine End Module spinpwpaw/code/denvhat_pack.f900100664004704100470410000000537610303710172016621 0ustar natalienatalie!****************************************************************************** ! ! File : denvhat_pack.f90 ! by : Alan Tackett ! on : 11/15/95 ! for : PAW Method ! ! Contains 2 routines to encode and decode the density matrix indices that are ! used in the atom_data module for the fields DENSITY and V_Hat. ! ! aL ^aL ! Density(:) = N V_Hat(:) = v ! n l n l n l n l ! i i j j i i j j ! ! ! The indices have to be stored are : ! ! (n l ) (n l ) L ! i i j j ! ! Bits Required: (5) (5) (3) = 13 bits total ! ! Each l value is in the range on 0..3 and the corresponding m is in the ! range of -l <= m <= l for 2*l + 1 possible values. This gives the range ! for L = 0..6. The (nl) indices are stored as pairs which correspond ! to the actual basis function index. Since only 5 bits are used the max ! number of basis functions is 32 for each atom. The l's can be determined ! from the (nl)'s and hence are not stored. ! ! The 13 LSB's are used all other bits are set to 0. ! ! ******* NOTE: No Error checking is done!!!!!! ******** ! !****************************************************************************** Module denvhat_pack implicit none !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! DenVhat_Encode - Encodes the given nili, njlj, and L supplied ! assuming the above restrictions on indices. ! ! ! NOTE : NO error checking is done!!!! ! !****************************************************************************** Integer Function DenVhat_Encode(nili, njlj, L) Integer, Intent(IN) :: nili Integer, Intent(IN) :: njlj Integer, Intent(IN) :: L Integer :: N N = nili N = ISHFT(N, 5) + njlj N = ISHFT(N, 3) + L DenVhat_Encode = N Return End Function !****************************************************************************** ! ! DenVhat_Decode - Decodes the given value(N) into the separate nili, njlj, ! L assuming the above restrictions on (nl)'s, l's, ! m's, and L. ! ! ! NOTE : NO error checking is done!!!! ! !****************************************************************************** Subroutine DenVhat_Decode(N, nili, njlj, L) Integer, Intent(IN) :: N Integer, Intent(OUT) :: nili Integer, Intent(OUT) :: njlj Integer, Intent(OUT) :: L nili = ISHFT(IAND(31*(2**8), N), -8) njlj = ISHFT(IAND(31*(2**3), N), -3) L = IAND(7, N) Return End Subroutine End Module spinpwpaw/code/doijmatrix.f900100664004704100470410000000610210303710172016330 0ustar natalienatalie!****************************************************************************** ! ! File : doijmatrix.f90 ! by : Alan Tackett ! on : 02/12/97 ! for : PAW Project ! ! Contains 2 routines for assisting in the calculation of H*Psi and ! O*Psi. These routines are passed to AccumProj(projector module) ! from HPsi and OPsi in the hamiltonian module. ! ! ~ ---- ~ a ~ a ! HPsi = H*Psi + \ |P > D

! / i ij j ! ---- ! a,i,j ! ! There is a similiar definition for OPsi but H~ is replaced with 1 and ! Dij is replaced with Oij - which is very spase. ! ! These routines are designed to return either Oij or Dij to AccumProj ! so that it can determine the weighting factor for each projector in doing ! the projector sum. ! ! modified for spin by Ping Tang and N. A. W. Holzwarth ! last modification 5/23/05 !****************************************************************************** Module doijmatrix Use atom_data Use options_data Implicit NONE!!!!!!!!!!!! !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! OijMatrix - Returns the Oij elements for AccumProj ! ! AtomIndex - The Number of the atom ! nili, njlj, - Projector basis indices ! Li, Lj - Corresponding L values ! mi, mj - M values ! !****************************************************************************** Complex Function OijMatrix(AtomIndex, nili, njlj, li, lj, mi, mj) Integer, Intent(IN) :: AtomIndex Integer, Intent(IN) :: nili, njlj Integer, Intent(IN) :: li, lj Integer, Intent(IN) :: mi, mj Integer, Pointer :: nlm_base(:) Integer :: AT_Index AT_index = Atom_List(AtomIndex)%TypeIndex nlm_Base => AtomType_Info(AT_Index)%nl_Base OijMatrix = AtomType_Info(AT_Index)%Oij(nlm_base(nili)+Li+mi, & nlm_base(njlj)+Lj+mj) !OijMatrix = 0 !QWERT Return End Function !****************************************************************************** ! ! DijMatrix - Returns the Dij elements for AccumProj ! ! AtomIndex - The Number of the atom ! nili, njlj, - Projector basis indices ! Li, Lj - Corresponding L values ! mi, mj - M values ! !****************************************************************************** Complex Function DijMatrix(AtomIndex, nili, njlj, li, lj, mi, mj) Integer, Intent(IN) :: AtomIndex Integer, Intent(IN) :: nili, njlj integer, Intent(IN) :: li, lj Integer, Intent(IN) :: mi, mj Integer, Pointer :: nlm_base(:) nlm_Base => AtomType_Info(Atom_List(AtomIndex)%TypeIndex)%nl_Base If(Global_spinup) then !spin up or no spin DijMatrix = Atom_List(AtomIndex)%Dij(nlm_base(nili)+Li+mi, & nlm_base(njlj)+Lj+mj) Else !spin down DijMatrix = Atom_List(AtomIndex)%Dijspin(nlm_base(nili)+Li+mi, & nlm_base(njlj)+Lj+mj) Endif !DijMatrix = 1 !QWERT Return End Function End Module spinpwpaw/code/doprint.f900100664004704100470410000000455610303710172015650 0ustar natalienatalie!****************************************************************************** ! ! File : doprint.f90 ! by : Alan Tackett ! on : 9/25/95 ! for : PAW Project ! ! DoPrint - Formats and generates output for the PAW program. ! Below is the Format for the statement. The function ! is line oriented. So all input on the entire line is processed! ! ! Input_WC - Input Context to take input from ! ! Print OUTPUT_DEVICE LITERAL_STRING_1, LITERAL_STRING_2, .. ! ! Where OUTPUT_DEVICE is one of the following: ! LOG - Print to Log File (Default) ! OUTPUT - Rpints to the output file ! ERROR - Prints to the Error File ! ALL - Prints to ALL the above ! ! ! LITERAL_STRING - A Literal string containing text to be printed. ! Multiple Strings may be listed ! !****************************************************************************** Subroutine DoPrint(input_wc) Use paw_inout implicit none !* Use word Type (Word_Context), Intent(INOUT) :: Input_WC Integer, PARAMETER :: LOG_OUT = 1 Integer, PARAMETER :: OUT_OUT = 2 Integer, PARAMETER :: ERR_OUT = 3 Integer, PARAMETER :: ALL_OUT = 4 Logical :: NewTok Integer :: Out_Dev, tlen Character*200 :: token, Token2 Call GetNextWord(Input_WC, Token2, tlen) Token = Token2 Call UpperCase(Token2) NewTok = .TRUE. if (Trim(Token2) == "LOG") then Out_Dev = LOG_OUT else if (Trim(Token2) == "OUTPUT") then Out_Dev = OUT_OUT else if (Trim(Token2) == "ERROR") then Out_Dev = ERR_OUT else if (Trim(Token2) == "ALL") then Out_Dev = ALL_OUT else NewTok = .FALSE. !** Flag NOT to get another token Out_Dev = LOG_OUT End If if (NewTok) Call GetWord(Input_WC, Token, tlen) NewTok = .TRUE. Do While (NewTok) Select Case (Out_Dev) Case (LOG_OUT) Write(Log_Unit, *) Token(1:Tlen) Case (OUT_OUT) Write(Output_Unit, *) token(1:TLen) Case (ERR_OUT) Write(Error_Unit, *) token(1:TLen) Case (ALL_OUT) Write(Log_Unit, *) Token(1:Tlen) Write(Output_Unit, *) token(1:TLen) Write(Error_Unit, *) token(1:TLen) End Select If (W_Error == W_OK) then Call GetWord(Input_WC, Token, Tlen) else NewTok = .FALSE. End IF End Do Return End Subroutine spinpwpaw/code/errorfunc.f900100664004704100470410000003341510303710172016172 0ustar natalienatalie SUBROUTINE CALERF(ARG,RESULT,JINT) ! ------------------------------------------------------------------ ! ! This packet evaluates erf(x), erfc(x), and exp(x*x)*erfc(x) ! for a real argument x. It contains three FUNCTION type ! subprograms: ERF, ERFC, and ERFCX (or DERF, DERFC, and DERFCX), ! and one SUBROUTINE type subprogram, CALERF. The calling ! statements for the primary entries are: ! ! Y=ERF(X) (or Y=DERF(X)), ! ! Y=ERFC(X) (or Y=DERFC(X)), ! and ! Y=ERFCX(X) (or Y=DERFCX(X)). ! ! The routine CALERF is intended for internal packet use only, ! all computations within the packet being concentrated in this ! routine. The function subprograms invoke CALERF with the ! statement ! ! CALL CALERF(ARG,RESULT,JINT) ! ! where the parameter usage is as follows ! ! Function Parameters for CALERF ! call ARG Result JINT ! ! ERF(ARG) ANY REAL ARGUMENT ERF(ARG) 0 ! ERFC(ARG) ABS(ARG) .LT. XBIG ERFC(ARG) 1 ! ERFCX(ARG) XNEG .LT. ARG .LT. XMAX ERFCX(ARG) 2 ! ! The main computation evaluates near-minimax approximations ! from "Rational Chebyshev approximations for the error function" ! by W. J. Cody, Math. Comp., 1969, PP. 631-638. This ! transportable program uses rational functions that theoretically ! approximate erf(x) and erfc(x) to at least 18 significant ! decimal digits. The accuracy achieved depends on the arithmetic ! system, the compiler, the intrinsic functions, and proper ! selection of the machine-dependent constants. ! !******************************************************************* !******************************************************************* ! ! Explanation of machine-dependent constants ! ! XMIN = the smallest positive floating-point number. ! XINF = the largest positive finite floating-point number. ! XNEG = the largest negative argument acceptable to ERFCX; ! the negative of the solution to the equation ! 2*exp(x*x) = XINF. ! XSMALL = argument below which erf(x) may be represented by ! 2*x/sqrt(pi) and above which x*x will not underflow. ! A conservative value is the largest machine number X ! such that 1.0 + X = 1.0 to machine precision. ! XBIG = largest argument acceptable to ERFC; solution to ! the equation: W(x) * (1-0.5/x**2) = XMIN, where ! W(x) = exp(-x*x)/[x*sqrt(pi)]. ! XHUGE = argument above which 1.0 - 1/(2*x*x) = 1.0 to ! machine precision. A conservative value is ! 1/[2*sqrt(XSMALL)] ! XMAX = largest acceptable argument to ERFCX; the minimum ! of XINF and 1/[sqrt(pi)*XMIN]. ! ! Approximate values for some important machines are: ! ! XMIN XINF XNEG XSMALL ! ! CDC 7600 (S.P.) 3.13E-294 1.26E+322 -27.220 7.11E-15 ! CRAY-1 (S.P.) 4.58E-2467 5.45E+2465 -75.345 7.11E-15 ! IEEE (IBM/XT, ! SUN, etc.) (S.P.) 1.18E-38 3.40E+38 -9.382 5.96E-8 ! IEEE (IBM/XT, ! SUN, etc.) (D.P.) 2.23D-308 1.79D+308 -26.628 1.11D-16 ! IBM 195 (D.P.) 5.40D-79 7.23E+75 -13.190 1.39D-17 ! UNIVAC 1108 (D.P.) 2.78D-309 8.98D+307 -26.615 1.73D-18 ! VAX D-Format (D.P.) 2.94D-39 1.70D+38 -9.345 1.39D-17 ! VAX G-Format (D.P.) 5.56D-309 8.98D+307 -26.615 1.11D-16 ! ! ! XBIG XHUGE XMAX ! ! CDC 7600 (S.P.) 25.922 8.39E+6 1.80X+293 ! CRAY-1 (S.P.) 75.326 8.39E+6 5.45E+2465 ! IEEE (IBM/XT, ! SUN, etc.) (S.P.) 9.194 2.90E+3 4.79E+37 ! IEEE (IBM/XT, ! SUN, etc.) (D.P.) 26.543 6.71D+7 2.53D+307 ! IBM 195 (D.P.) 13.306 1.90D+8 7.23E+75 ! UNIVAC 1108 (D.P.) 26.582 5.37D+8 8.98D+307 ! VAX D-Format (D.P.) 9.269 1.90D+8 1.70D+38 ! VAX G-Format (D.P.) 26.569 6.71D+7 8.98D+307 ! !******************************************************************* !******************************************************************* ! ! Error returns ! ! The program returns ERFC = 0 for ARG .GE. XBIG; ! ! ERFCX = XINF for ARG .LT. XNEG; ! and ! ERFCX = 0 for ARG .GE. XMAX. ! ! ! Intrinsic functions required are: ! ! ABS, AINT, EXP ! ! ! Author: W. J. Cody ! Mathematics and Computer Science Division ! Argonne National Laboratory ! Argonne, IL 60439 ! ! Latest modification: March 19, 1990 ! !------------------------------------------------------------------ implicit none INTEGER I,JINT !S REAL DOUBLE PRECISION :: & A,ARG,B,C,D,DEL,FOUR,HALF,P,ONE,Q,RESULT,SIXTEN,SQRPI, & TWO,THRESH,X,XBIG,XDEN,XHUGE,XINF,XMAX,XNEG,XNUM,XSMALL,& Y,YSQ,ZERO DIMENSION A(5),B(4),C(9),D(8),P(6),Q(5) Logical :: goto300 !------------------------------------------------------------------ ! Mathematical constants !------------------------------------------------------------------ !S DATA FOUR,ONE,HALF,TWO,ZERO/4.0E0,1.0E0,0.5E0,2.0E0,0.0E0/, !S 1 SQRPI/5.6418958354775628695E-1/,THRESH/0.46875E0/, !S 2 SIXTEN/16.0E0/ DATA FOUR,ONE,HALF,TWO,ZERO/4.0D0,1.0D0,0.5D0,2.0D0,0.0D0/, & SQRPI/5.6418958354775628695D-1/,THRESH/0.46875D0/, & SIXTEN/16.0D0/ !------------------------------------------------------------------ ! Machine-dependent constants !------------------------------------------------------------------ !S DATA XINF,XNEG,XSMALL/3.40E+38,-9.382E0,5.96E-8/, !S 1 XBIG,XHUGE,XMAX/9.194E0,2.90E3,4.79E37/ DATA XINF,XNEG,XSMALL/1.79D308,-26.628D0,1.11D-16/, & XBIG,XHUGE,XMAX/26.543D0,6.71D7,2.53D307/ !------------------------------------------------------------------ ! Coefficients for approximation to erf in first interval !------------------------------------------------------------------ !S DATA A/3.16112374387056560E00,1.13864154151050156E02, !S 1 3.77485237685302021E02,3.20937758913846947E03, !S 2 1.85777706184603153E-1/ !S DATA B/2.36012909523441209E01,2.44024637934444173E02, !S 1 1.28261652607737228E03,2.84423683343917062E03/ DATA A/3.16112374387056560D00,1.13864154151050156D02, & 3.77485237685302021D02,3.20937758913846947D03, & 1.85777706184603153D-1/ DATA B/2.36012909523441209D01,2.44024637934444173D02, & 1.28261652607737228D03,2.84423683343917062D03/ !------------------------------------------------------------------ ! Coefficients for approximation to erfc in second interval !------------------------------------------------------------------ !S DATA C/5.64188496988670089E-1,8.88314979438837594E0, !S 1 6.61191906371416295E01,2.98635138197400131E02, !S 2 8.81952221241769090E02,1.71204761263407058E03, !S 3 2.05107837782607147E03,1.23033935479799725E03, !S 4 2.15311535474403846E-8/ !S DATA D/1.57449261107098347E01,1.17693950891312499E02, !S 1 5.37181101862009858E02,1.62138957456669019E03, !S 2 3.29079923573345963E03,4.36261909014324716E03, !S 3 3.43936767414372164E03,1.23033935480374942E03/ DATA C/5.64188496988670089D-1,8.88314979438837594D0, & 6.61191906371416295D01,2.98635138197400131D02, & 8.81952221241769090D02,1.71204761263407058D03, & 2.05107837782607147D03,1.23033935479799725D03, & 2.15311535474403846D-8/ DATA D/1.57449261107098347D01,1.17693950891312499D02, & 5.37181101862009858D02,1.62138957456669019D03, & 3.29079923573345963D03,4.36261909014324716D03, & 3.43936767414372164D03,1.23033935480374942D03/ !------------------------------------------------------------------ ! Coefficients for approximation to erfc in third interval !------------------------------------------------------------------ !S DATA P/3.05326634961232344E-1,3.60344899949804439E-1, !S 1 1.25781726111229246E-1,1.60837851487422766E-2, !S 2 6.58749161529837803E-4,1.63153871373020978E-2/ !S DATA Q/2.56852019228982242E00,1.87295284992346047E00, !S 1 5.27905102951428412E-1,6.05183413124413191E-2, !S 2 2.33520497626869185E-3/ DATA P/3.05326634961232344D-1,3.60344899949804439D-1, & 1.25781726111229246D-1,1.60837851487422766D-2, & 6.58749161529837803D-4,1.63153871373020978D-2/ DATA Q/2.56852019228982242D00,1.87295284992346047D00, & 5.27905102951428412D-1,6.05183413124413191D-2, & 2.33520497626869185D-3/ !------------------------------------------------------------------ Goto300 = .FALSE. X = ARG Y = ABS(X) IF (Y .LE. THRESH) THEN !------------------------------------------------------------------ ! Evaluate erf for |X| <= 0.46875 !------------------------------------------------------------------ YSQ = ZERO IF (Y .GT. XSMALL) YSQ = Y * Y XNUM = A(5)*YSQ XDEN = YSQ DO I = 1, 3 XNUM = (XNUM + A(I)) * YSQ XDEN = (XDEN + B(I)) * YSQ End Do RESULT = X * (XNUM + A(4)) / (XDEN + B(4)) IF (JINT .NE. 0) RESULT = ONE - RESULT IF (JINT .EQ. 2) RESULT = EXP(YSQ) * RESULT RETURN !*** goto 800 !------------------------------------------------------------------ ! Evaluate erfc for 0.46875 <= |X| <= 4.0 !------------------------------------------------------------------ ELSE IF (Y .LE. FOUR) THEN XNUM = C(9)*Y XDEN = Y DO I = 1, 7 XNUM = (XNUM + C(I)) * Y XDEN = (XDEN + D(I)) * Y End DO RESULT = (XNUM + C(8)) / (XDEN + D(8)) IF (JINT .NE. 2) THEN YSQ = AINT(Y*SIXTEN)/SIXTEN DEL = (Y-YSQ)*(Y+YSQ) RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT END IF !------------------------------------------------------------------ ! Evaluate erfc for |X| > 4.0 !------------------------------------------------------------------ ELSE Goto300 = .FALSE. RESULT = ZERO IF (Y .GE. XBIG) THEN IF ((JINT .NE. 2) .OR. (Y .GE. XMAX)) GOTO300 = .TRUE. IF ((Y .GE. XHUGE) .AND. (.NOT. Goto300)) THEN RESULT = SQRPI / Y GOTO300 = .TRUE. END IF END IF If (.NOT. Goto300) then YSQ = ONE / (Y * Y) XNUM = P(6)*YSQ XDEN = YSQ DO I = 1, 4 XNUM = (XNUM + P(I)) * YSQ XDEN = (XDEN + Q(I)) * YSQ End Do RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5)) RESULT = (SQRPI - RESULT) / Y IF (JINT .NE. 2) THEN YSQ = AINT(Y*SIXTEN)/SIXTEN DEL = (Y-YSQ)*(Y+YSQ) RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT END IF End If END IF !------------------------------------------------------------------ ! Fix up for negative argument, erf, etc. !------------------------------------------------------------------ IF (JINT .EQ. 0) THEN !*** Goto300 *** RESULT = (HALF - RESULT) + HALF IF (X .LT. ZERO) RESULT = -RESULT ELSE IF (JINT .EQ. 1) THEN IF (X .LT. ZERO) RESULT = TWO - RESULT ELSE IF (X .LT. ZERO) THEN IF (X .LT. XNEG) THEN RESULT = XINF ELSE YSQ = AINT(X*SIXTEN)/SIXTEN DEL = (X-YSQ)*(X+YSQ) Y = EXP(YSQ*YSQ) * EXP(DEL) RESULT = (Y+Y) - RESULT END IF END IF END IF RETURN !*** 800 !---------- Last card of CALERF ---------- END Subroutine !S REAL FUNCTION ERF(X) DOUBLE PRECISION FUNCTION DERF(X) !-------------------------------------------------------------------- ! ! This subprogram computes approximate values for erf(x). ! (see comments heading CALERF). ! ! Author/date: W. J. Cody, January 8, 1985 ! !-------------------------------------------------------------------- INTEGER JINT !S REAL X, RESULT DOUBLE PRECISION :: X, RESULT !------------------------------------------------------------------ JINT = 0 CALL CALERF(X,RESULT,JINT) !S ERF = RESULT DERF = RESULT RETURN !---------- Last card of DERF ---------- END Function !S REAL FUNCTION ERFC(X) DOUBLE PRECISION FUNCTION DERFC(X) !-------------------------------------------------------------------- ! ! This subprogram computes approximate values for erfc(x). ! (see comments heading CALERF). ! ! Author/date: W. J. Cody, January 8, 1985 ! !-------------------------------------------------------------------- INTEGER JINT !S REAL X, RESULT DOUBLE PRECISION :: X, RESULT !------------------------------------------------------------------ JINT = 1 CALL CALERF(X,RESULT,JINT) !S ERFC = RESULT DERFC = RESULT RETURN !---------- Last card of DERFC ---------- END Function !S REAL FUNCTION ERFCX(X) DOUBLE PRECISION FUNCTION DERFCX(X) !------------------------------------------------------------------ ! ! This subprogram computes approximate values for exp(x*x) * erfc(x). ! (see comments heading CALERF). ! ! Author/date: W. J. Cody, March 30, 1987 ! !------------------------------------------------------------------ INTEGER JINT !S REAL X, RESULT DOUBLE PRECISION :: X, RESULT !------------------------------------------------------------------ JINT = 2 CALL CALERF(X,RESULT,JINT) !S ERFCX = RESULT DERFCX = RESULT RETURN !---------- Last card of DERFCX ---------- END Function spinpwpaw/code/exchange_corr.f900100664004704100470410000004544310303710172017000 0ustar natalienatalie!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Modified by Ping Tang and N. A. W. Holzwarth ! to include spin (LSDA, SGGA) ! Last change 5/23/05 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MODULE exchange_corr USE mathlib IMPLICIT NONE ! INTEGER :: XC_TYPE Logical :: XC_TYPE_SET INTEGER, PARAMETER :: XC_LDA_PW=1 INTEGER, PARAMETER :: XC_GGA_PBE=2 INTEGER, PARAMETER :: XC_LSDA_PW=3 INTEGER, PARAMETER :: XC_SGGA_PBE=4 ! Parameters for the Perdew-Wang (PRB 45,13244 (1992)) LDA correlation REAL, PRIVATE, PARAMETER :: AA=0.0310907d0 REAL, PRIVATE, PARAMETER :: a1=0.21370d0 REAL, PRIVATE, PARAMETER :: b1=7.59570d0 REAL, PRIVATE, PARAMETER :: b2=3.58760d0 REAL, PRIVATE, PARAMETER :: b3=1.63820d0 REAL, PRIVATE, PARAMETER :: b4=0.49294d0 ! Parameters for the Perdew-Wang (PRB 45,13244 (1992)) LDA correlation zeta=0 Real, private, parameter :: AAec0=0.0310907d0 Real, private, parameter :: a1ec0=0.21370d0 Real, private, parameter :: b1ec0=7.59570d0 Real, private, parameter :: b2ec0=3.58760d0 Real, private, parameter :: b3ec0=1.63820d0 Real, private, parameter :: b4ec0=0.49294d0 ! Parameters for the Perdew-Wang (PRB 45,13244 (1992)) LDA correlation zeta=1 Real, private, parameter :: AAec1=0.015545d0 Real, private, parameter :: a1ec1=0.20548d0 Real, private, parameter :: b1ec1=14.1189d0 Real, private, parameter :: b2ec1=6.19770d0 Real, private, parameter :: b3ec1=3.36620d0 Real, private, parameter :: b4ec1=0.62517d0 ! Parameters for the Perdew-Wang (PRB 45,13244 (1992)) LDA correlation Real, private, parameter :: AAalp=0.016887d0 Real, private, parameter :: a1alp=0.11125d0 Real, private, parameter :: b1alp=10.3570d0 Real, private, parameter :: b2alp=3.62310d0 Real, private, parameter :: b3alp=0.88026d0 Real, private, parameter :: b4alp=0.49671d0 ! Parameters for the PBE (PRL 77, 3865 (1996)) GGA-PBE REAL, PRIVATE, PARAMETER :: kappa= 0.804d0 REAL, PRIVATE, PARAMETER :: mu = 0.2195149727645171d0 REAL, PRIVATE, PARAMETER :: beta = 0.06672455060314922d0 REAL, PRIVATE, PARAMETER :: gamm = 0.03109069086965489503494086371273d0 REAL, PRIVATE, PARAMETER :: betabygamm=beta/gamm CONTAINS !********************************************************** ! Subroutine to calculate the LDA exchange correlation functionals ! using the form of Perdew and Wang (PRB 45, 13244 (1992) ! assuming no spin polarization ! Inside this routine, energies are in Hartree units SUBROUTINE pwldafunc(den,exc,vxc) REAL(8), INTENT(IN) :: den !density REAL(8), INTENT(OUT) :: exc,vxc ! Variables depending on den REAL(8) :: n,g,kf,rs,ks REAL(8) :: ex,ec,pprs,decdrs REAL(8) :: term n=den IF (n < machine_zero) THEN exc=0.d0; vxc=0.d0 RETURN ENDIF kf=(3.d0*(pi**2)*n)**0.3333333333333333333333333333d0 rs=(3.d0/(4.d0*pi*n))**0.3333333333333333333333333333d0 ks=SQRT(4.d0*kf/pi) ex=-3.d0*kf/(4.d0*pi) pprs=SQRT(rs)*(b1+b3*rs)+rs*(b2+b4*rs) !ec=-2.d0*AA*(1.d0+a1*rs)*ddlog(1.d0+1.d0/(2.d0*AA*pprs)) term=Logofterm(1.d0/(2.d0*AA*pprs)) ec=-2.d0*AA*(1.d0+a1*rs)*term exc=ex+ec !decdrs=-(2.d0*AA*a1)*ddlog(1.d0+1.d0/(2*AA*pprs)) & decdrs=-(2.d0*AA*a1)*term & +((1.d0+a1*rs)*((b1+3*b3*rs)/(2.d0*SQRT(rs))+& b2+2*b4*rs))/(pprs*(pprs+1.d0/(2.d0*AA))) vxc = (4.d0/3.d0)*ex+ec-(decdrs*rs)/3.d0 IF ((ABS(exc).GT.1.d65).OR.(ABS(vxc).GT.1.d65)) THEN WRITE(6,*) 'Problem in PW',n,rs,ec ENDIF exc=2*exc; vxc=2*vxc ! change to Rydberg units RETURN END SUBROUTINE pwldafunc !********************************************************** ! Subroutine to calculate the exchange correlation functionals ! using the form of Perdew, Burke, and Ernzerhof (PRL 77, 3865 (1996)) ! assuming no spin polarization ! Inside this routine, energies are in Hartree units SUBROUTINE pbefunc(den,grad,fxc,dfxcdn,dfxcdgbg) REAL(8), INTENT(IN) :: den,grad !density, magnitude of grad(density) REAL(8), INTENT(OUT) :: fxc,dfxcdn,dfxcdgbg ! Variables depending on den & grad REAL(8) :: n,g,kf,rs,ks,s,t REAL(8) :: ex,ec,Fx,H,A,pprs,ppt,At2,dFds,dHdt,decdrs,dHdrs,dHdA,dAdrs REAL(8) :: term,dHdtbg,dFdsbg n=den IF (n < machine_zero) THEN fxc=0.d0; dfxcdn=0.d0; dfxcdgbg=0.d0 RETURN ENDIF g=grad IF (g < machine_zero) g=machine_zero kf=(3.d0*(pi**2)*n)**0.3333333333333333333333333333d0 rs=(3.d0/(4.d0*pi*n))**0.3333333333333333333333333333d0 ks=SQRT(4.d0*kf/pi) s=g/(2.d0*kf*n) t=g/(2.d0*ks*n) ex=-3.d0*kf/(4.d0*pi) pprs=SQRT(rs)*(b1+b3*rs)+rs*(b2+b4*rs) !ec=-2.d0*AA*(1.d0+a1*rs)*ddlog(1.d0+1.d0/(2.d0*AA*pprs)) term=Logofterm(1.d0/(2.d0*AA*pprs)) ec=-2.d0*AA*(1.d0+a1*rs)*term Fx=1.d0+kappa -kappa/(1.d0+(mu/kappa)*s*s) A=Aofec(ec) At2=A*t*t ppt=(1.d0+At2*(1.d0+At2)) !H=gamm*ddlog(1.d0+(betabygamm)*(t*t)*((1.d0+At2)/ppt)) H=gamm*Logofterm((betabygamm)*(t*t)*((1.d0+At2)/ppt)) fxc=n*(ex*Fx+ec+H) dFds = (2.d0*mu*s)/(1.d0+(mu/kappa)*(s**2))**2 dFdsbg = ((2.d0*mu)/(1.d0+(mu/kappa)*(s**2))**2)/(2.d0*kf*n) dHdt = (2.d0*t*beta*gamm*(1.d0+2.d0*At2))/& ((gamm*ppt+beta*t*t*(1.d0+At2))*ppt) dHdtbg = ((2.d0*beta*gamm*(1.d0+ & 2.d0*At2))/((gamm*ppt+beta*t*t*(1.d0+At2))*ppt))/(2.d0*ks*n) !decdrs=-(2.d0*AA*a1)*ddlog(1.d0+1.d0/(2*AA*pprs)) & decdrs=-(2.d0*AA*a1)*term & +((1.d0+a1*rs)*((b1+3*b3*rs)/(2.d0*SQRT(rs))+& b2+2*b4*rs))/(pprs*(pprs+1.d0/(2.d0*AA))) dHdA=-((2.d0+At2)*(At2*t*t*t*t*beta*gamm))/& ((gamm*ppt+beta*t*t*(1.d0+At2))*ppt) dAdrs=ddexp(-ec/gamm)*A*A*decdrs/beta dHdrs=dHdA*dAdrs dfxcdn = (4.d0/3.d0)*ex*(Fx-dFds*s)+ec-(decdrs*rs)/3.d0+& H-(dHdrs*rs)/3.d0 & - (7.d0/6.d0)*dHdt*t dfxcdgbg = ex*dFdsbg/(2.d0*kf) + dHdtbg/(2.d0*ks) !write(400,'(1p5e15.7)') fxc,dfxcdn,dfxcdgbg,dHdA,dAdrs !write(401,'(1p8e15.7)') ex,ec,dFdsbg,dHdtbg,kf,ks,n,dHdt IF ((ABS(fxc).GT.1.d65).OR.(ABS(dfxcdn).GT.1.d65)& .OR.(ABS(dfxcdgbg).GT.1.d65)) THEN WRITE(6,*) 'Problem in PBE',n,g,rs,s,t,ec,A,H stop ENDIF fxc=2*fxc; dfxcdn=2*dfxcdn; dfxcdgbg=2*dfxcdgbg ! change to Rydberg units RETURN END SUBROUTINE pbefunc !********************************************************** ! Subroutine to calculate the exchange correlation functionals ! using the form of Perdew, Burke, and Ernzerhof (PRL 77, 3865 (1996)) ! assuming the spin polarization ! gradient inputs are gradup==|grad denup| ! graddn==|grad dendn| ! grad ==|grad (denup+dendn)| ! Inside this routine, energies are in Hartree units ! We use relationship of Vxceven=(vxcup+vxcdn)/2 ! Vxcodd=(vxcup-vxcdn)/2 ! Gradient exchange terms: dFxdgbgup,dFxdgbgdn ! Gradient correlation term: dcdgbg SUBROUTINE Sggapbefunc(denup,gradup,dendn,graddn,grad, & fxc, dfxcdneven,dfxcdnodd, dfxdgbgup,dfxdgbgdn,dcdgbg) REAL(8), INTENT(IN) :: denup,gradup,dendn,graddn,grad !density, magnitude of grad(density) REAL(8), INTENT(OUT) :: fxc,dfxcdneven,dfxcdnodd,dfxdgbgup,dfxdgbgdn,dcdgbg ! Variables depending on den & grad REAL(8) :: nup,ndn,n,g,gup,gdn,kf,kfup,kfdn,rs,& ks,s,sup,sdn,t,dtdnup,dtdndn,zeta REAL(8) :: c1,c2,c3,c4,c5,c6,c7,c8,phi,dphidzeta,& fzeta,dfdzeta,dzetadnup,dzetadndn REAL(8) :: pprsec0, pprsec1,pprsalp,termec0,termec1,& termalp,ec0,ec1,alpc,drsdnup,drsdndn,drsdn REAL(8) :: dpdrsec0,dpdrsec1,dpdrsalp,dec0drs,dec1drs,& dalpdrs,decdrs,decdzeta REAL(8) :: ex,exup,exdn,ec,Fx,Fxup,Fxdn,H,A,ppt,At2,& dFds,dFdsup,dFdsdn,dHdt,dHdrs,dHdA,dAdrs REAL(8) :: dHdphi,dAdphi,dHdnup,dHdndn,dfxdnup,dfxdndn,& decdnup,decdndn,dAdzeta,dHdzeta REAL(8) :: dHdtbg,dFdsbg,ddfxc,dFdsbgup,dFdsbgdn,dfxcdgbg !,dfxdgbgup,dfxdgbgdn,dcdgbg ndn=dendn nup=denup IF (ndn < machine_zero) ndn=machine_zero IF (nup < machine_zero) nup=machine_zero n=nup+ndn !write(6,*) 'inside pbefunc,denup and dendn=',denup,dendn !IF (ndn < machine_zero.OR.nup < machine_zero) THEN ! fxc=0.d0; dfxcdneven=0.d0; dfxcdnodd=0.d0; ! dfxdgbgup=0.d0;dfxdgbgdn=0.d0;dcdgbg=0.d0; ! dfxcdgbgup=0;dfxcdgbgdn=0; ! RETURN !ENDIF gdn=graddn !(already abs)ABS(graddn) gup=gradup !(already abs)ABS(gradup) g=grad IF (g < machine_zero) g=machine_zero IF (gup < machine_zero) gup=machine_zero IF (gdn < machine_zero) gdn=machine_zero !write(6,*) 'next step' kf=(3.d0*(pi**2)*n)**0.3333333333333333333333333333d0 kfup=(6.d0*(pi**2)*nup)**0.333333333333333333333333333d0 kfdn=(6.d0*(pi**2)*ndn)**0.333333333333333333333333333d0 rs=(3.d0/(4.d0*pi*n))**0.3333333333333333333333333333d0 ks=SQRT(4.d0*kf/pi) s=g/(2.d0*kf*n) sup=gup/(2.d0*kfup*nup) sdn=gdn/(2.d0*kfdn*ndn) drsdn=-rs/(3.d0*n) drsdnup=-rs/(3.d0*n) drsdndn=-rs/(3.d0*n) zeta=(nup-ndn)/n dzetadnup=2.d0*ndn/(n**2.d0) dzetadndn=-2.d0*nup/(n**2.d0) c1=(1+zeta)**1.33333333333333333333333333333d0 c2=(1-zeta)**1.33333333333333333333333333333d0 c3=(1+zeta)**0.66666666666666666666666666667d0 c4=(1-zeta)**0.66666666666666666666666666667d0 c5=(1/((1+zeta)**2+machine_zero))**0.1666666666666666666666666667d0 c6=(1/((1-zeta)**2+machine_zero))**0.1666666666666666666666666667d0 c7=(1+zeta)**0.33333333333333333333333333333d0 c8=(1-zeta)**0.33333333333333333333333333333d0 phi=(c3+c4)/2.d0 t=g/(2.d0*ks*phi*n) dtdnup=-7.d0*t/(6.d0*n)-t*(c5-c6)*dzetadnup/(3.d0*phi) dtdndn=-7.d0*t/(6.d0*n)-t*(c5-c6)*dzetadndn/(3.d0*phi) dphidzeta=(c5-c6)/3.d0 fzeta=(c1+c2-2.d0)/(2.d0**1.3333333333333333333333333333d0-2.d0) dfdzeta=4.d0*(c7-c8)/(3.d0*(2.d0**1.3333333333333333333333333333d0-2.d0)) ex=-3.d0*kf/(4.d0*pi) exup=-3.d0*kfup/(4.d0*pi) exdn=-3.d0*kfdn/(4.d0*pi) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! first derivative of ec !!! pprsec0=SQRT(rs)*(b1ec0+b3ec0*rs)+rs*(b2ec0+b4ec0*rs) pprsec1=SQRT(rs)*(b1ec1+b3ec1*rs)+rs*(b2ec1+b4ec1*rs) pprsalp=SQRT(rs)*(b1alp+b3alp*rs)+rs*(b2alp+b4alp*rs) !ec=-2.d0*AA*(1.d0+a1*rs)*ddlog(1.d0+1.d0/(2.d0*AA*pprs)) termec0=Logofterm(1.d0/(2.d0*AAec0*pprsec0)) termec1=Logofterm(1.d0/(2.d0*AAec1*pprsec1)) termalp=Logofterm(1.d0/(2.d0*AAalp*pprsalp)) ec0=-2.d0*AAec0*(1.d0+a1ec0*rs)*termec0 ec1=-2.d0*AAec1*(1.d0+a1ec1*rs)*termec1 alpc=2.d0*AAalp*(1.d0+a1alp*rs)*termalp ec=ec0+alpc*fzeta*(1-zeta**4.d0)/1.709921d0+(ec1-ec0)*fzeta*zeta**4.d0 dpdrsec0=(b1ec0+3.d0*b3ec0*rs)/(2.d0*sqrt(rs))+b2ec0+b4ec0*rs*2.d0 dpdrsec1=(b1ec1+3.d0*b3ec1*rs)/(2.d0*sqrt(rs))+b2ec1+b4ec1*rs*2.d0 dpdrsalp=(b1alp+3.d0*b3alp*rs)/(2.d0*sqrt(rs))+b2alp+b4alp*rs*2.d0 dec0drs=-(2.d0*AAec0*a1ec0)*termec0+& 2.d0*AAec0*(1.d0+a1ec0*rs)*dpdrsec0/(pprsec0*(1.d0+2.d0*AAec0*pprsec0)) dec1drs=-(2.d0*AAec1*a1ec1)*termec1+& 2.d0*AAec1*(1.d0+a1ec1*rs)*dpdrsec1/(pprsec1*(1.d0+2.d0*AAec1*pprsec1)) dalpdrs=2.d0*AAalp*a1alp*termalp-& 2.d0*AAalp*(1.d0+a1alp*rs)*dpdrsalp/(pprsalp*(1.d0+2.d0*AAalp*pprsalp)) decdrs=dec0drs+dalpdrs*fzeta*(1-zeta**4.d0)/1.709921d0+& (dec1drs-dec0drs)*fzeta*zeta**4.d0 decdzeta=alpc*(dfdzeta*(1-zeta**4.d0)-4.d0*fzeta*zeta**3.d0)/1.709921d0+& (ec1-ec0)*(dfdzeta*zeta**4.d0+4.d0*fzeta*zeta**3.d0) decdnup=decdrs*drsdnup+decdzeta*dzetadnup decdndn=decdrs*drsdndn+decdzeta*dzetadndn !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! calculat fxc here Fx=1.d0+kappa -kappa/(1.d0+(mu/kappa)*s*s) Fxup=1.d0+ kappa -kappa/(1.d0+(mu/kappa)*sup*sup) Fxdn=1.d0+ kappa -kappa/(1.d0+(mu/kappa)*sdn*sdn) A=Aofec(ec/phi**3) At2=A*t*t ppt=(1.d0+At2*(1.d0+At2)) !H=gamm*ddlog(1.d0+(betabygamm)*(t*t)*((1.d0+At2)/ppt)) H=gamm*(phi**3)*Logofterm((betabygamm)*(t*t)*((1.d0+At2)/ppt)) !fxc=n*(ex*Fx+ec+H) fxc=nup*exup*Fxup+ndn*exdn*Fxdn+n*(ec+H) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! calculate dfxup/dnup dFds = (2.d0*mu*s)/(1.d0+(mu/kappa)*(s**2))**2 dFdsup= (2.d0*mu*sup)/(1.d0+(mu/kappa)*(sup**2))**2 dFdsdn= (2.d0*mu*sdn)/(1.d0+(mu/kappa)*(sdn**2))**2 dfxdnup=-kfup*(Fxup-dFdsup*sup)/pi dfxdndn=-kfdn*(Fxdn-dFdsdn*sdn)/pi dFdsbg = ((2.d0*mu)/(1.d0+(mu/kappa)*(s**2))**2)/(2.d0*kf*n) dFdsbgup = ((2.d0*mu)/(1.d0+(mu/kappa)*(sup**2))**2)/(2.d0*kfup*nup) dFdsbgdn = ((2.d0*mu)/(1.d0+(mu/kappa)*(sdn**2))**2)/(2.d0*kfdn*ndn) dHdt = (2.d0*t*beta*(phi**3.d0)*gamm*(1.d0+2.d0*At2))/& ((gamm*ppt+beta*t*t*(1.d0+At2))*ppt) dHdtbg = ((2.d0*beta*(phi**2.d0)*gamm*(1.d0+ & 2.d0*At2))/((gamm*ppt+beta*t*t*(1.d0+At2))*ppt))/(2.d0*ks*n) dHdA=-((2.d0+At2)*(At2*t*t*t*t*beta*gamm*phi**3.d0))/& ((gamm*ppt+beta*t*t*(1.d0+At2))*ppt) dAdrs=ddexp(-ec/(gamm*(phi**3.d0)))*A*A*decdrs/(beta*phi**3.d0) dAdzeta=ddexp(-ec/(gamm*(phi**3.d0)))*A*A*decdzeta/(beta*phi**3.d0) dHdrs=dHdA*dAdrs dHdzeta=dHdA*dAdzeta dHdphi=3.d0*gamm*(phi**2)*Logofterm((betabygamm)*(t*t)*((1.d0+At2)/ppt)) dAdphi=-3.d0*A*A*ec*exp(-ec/(gamm*(phi**3)))/(beta*(phi**4)) dHdnup=dHdrs*drsdnup+dHdzeta*dzetadnup+dHdphi*dphidzeta*dzetadnup+& dHdA*dAdphi*dphidzeta*dzetadnup+dHdt*dtdnup dHdndn=dHdrs*drsdndn+dHdzeta*dzetadndn+dHdphi*dphidzeta*dzetadndn+& dHdA*dAdphi*dphidzeta*dzetadndn+dHdt*dtdndn dfxcdneven=(dfxdnup+dfxdndn)/2.d0+ec+H+n*(decdnup+dHdnup+decdndn+& dHdndn)/2.d0 !dfxceven=(dfxcup+dfxcdn)/2 dfxcdnodd=(dfxdnup-dfxdndn)/2.d0+n*(decdnup+dHdnup-decdndn-dHdndn)/2.d0 !dfxcodd=(dfxup-dfxcdn)/2 dfxdgbgup = exup*dFdsbgup/(2.d0*kfup) !there are upspin and dnspin gradient parts for dfxdgbgdn = exdn*dFdsbgdn/(2.d0*kfdn) !dfxdgbg*grad(n) dcdgbg = dHdtbg/(2.d0*ks*phi) !one gradient part for dHdtbg*grad(n) IF ((ABS(fxc).GT.1.d65).OR.(ABS(dfxcdneven).GT.1.d65).OR.& (ABS(dfxcdnodd).GT.1.d65).OR.(ABS(dfxdgbgup).GT.1.d65).OR.& (ABS(dfxdgbgdn).GT.1.d65).OR.ABS(dcdgbg).GT.1.d65) THEN WRITE(6,*) 'Problem in PBE',n,g,rs,s,t,ec,A,H ENDIF ! Change to Rydberg units fxc=2*fxc; dfxcdneven=2*dfxcdneven; dfxcdnodd=2*dfxcdnodd dfxdgbgup=2*dfxdgbgup; dfxdgbgdn=2*dfxdgbgdn; dcdgbg=2*dcdgbg RETURN END SUBROUTINE Sggapbefunc !******************************************************************* ! ! Function Logofterm -- needed to take care of behavior for small term ! Evaluates log(1+term) FUNCTION Logofterm(term) REAL(8) :: term, Logofterm IF (ABS(term)>machine_precision) THEN Logofterm=ddlog(1.d0+term) ELSE Logofterm=term ENDIF RETURN END FUNCTION Logofterm !******************************************************************* ! ! Function Aofec -- needed to take care of behavior for small ec FUNCTION Aofec(ec) REAL(8) :: ec, Aofec IF (ABS(ec)>machine_precision) THEN Aofec=betabygamm/(ddexp(-ec/gamm)-1.d0) ELSEIF (ABS(ec)>machine_zero) THEN Aofec=beta/(-ec) ELSE Aofec=-beta*DSIGN(machine_infinity,ec) ENDIF RETURN END FUNCTION Aofec !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Exchange-correlational functions for LSDA according to ! Perdew and Wang ! Program written by Ping Tang and NAWH ! Last modified 5/25/02 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !********************************************************** ! Subroutine to calculate the LSDA exchange correlation functionals ! using the form of Perdew and Wang (PRB 45, 13244 (1992) ! assuming spin polarization ! Inside this routine, energies are in Hartree units ! Input den=denup+dendown, mu=denup-dendown ! Output Exc,Vexc(even), Vexc(odd) ! Where Vxceven=(vxcup+vxcdn)/2 ! Vxcodd=(vxcup-vxcdn)/2 Subroutine pwlsdafunc(den,mu,Exc,vxceven,vxcodd) Real(8), intent(IN) :: den,mu !density Real(8), intent(OUT) :: Exc,vxceven,vxcodd ! Variables depending on den Real(8) :: n,g,kf,rs,zeta,nup,ndown Real(8) :: ex,ec,pprsec0,decdrs,dexdrs,dexdzeta,decdzeta,ec0,ec1,alpc Real(8) :: fzeta,pprsec1,pprsalp,dpdrsec0,dpdrsec1,dpdrsalp Real(8) :: dec0drs,dec1drs,dalpdrs,c1,c2,c3,c4,drsdn,dzetadnup,dzetadndn Real(8) :: dfdzeta,coef,termec0,termec1,termalp n=den If (n < machine_zero .or. & abs(mu) > n) then Exc=0.d0; vxceven=0.d0 vxcodd=0.d0 return EndIf kf=(3.d0*(pi**2)*n)**0.3333333333333333333333333333d0 rs=(3.d0/(4.d0*pi*n))**0.3333333333333333333333333333d0 drsdn=-rs/(3*n) zeta=mu/n c1=(1.d0+zeta)**1.33333333333333333333333d0 c2=(1.d0-zeta)**1.33333333333333333333333d0 c3=(1.d0+zeta)**0.33333333333333333333333d0 c4=(1.d0-zeta)**0.33333333333333333333333d0 coef=3.d0/(8.d0*pi)*(9.d0*pi/4.d0)**0.3333333333333333333d0/rs ex=-coef*(c1+c2) dexdrs=-ex/rs dexdzeta=-4.d0*coef*(c3-c4)/3.d0 fzeta=(c1+c2-2.d0)/(2.d0**1.33333333333333333333d0-2.d0) dfdzeta=4*(c3-c4)/(3.d0*(2.d0**1.333333333333333333333333d0-2.d0)) pprsec0=sqrt(rs)*(b1ec0+b3ec0*rs)+rs*(b2ec0+b4ec0*rs) pprsec1=sqrt(rs)*(b1ec1+b3ec1*rs)+rs*(b2ec1+b4ec1*rs) pprsalp=sqrt(rs)*(b1alp+b3alp*rs)+rs*(b2alp+b4alp*rs) !ec=-2.d0*AA*(1.d0+a1*rs)*ddlog(1.d0+1.d0/(2.d0*AAec0*pprs)) termec0=Logofterm(1.d0/(2.d0*AAec0*pprsec0)) termec1=Logofterm(1.d0/(2.d0*AAec1*pprsec1)) termalp=Logofterm(1.d0/(2.d0*AAalp*pprsalp)) ec0=-2.d0*AAec0*(1.d0+a1ec0*rs)*termec0 ec1=-2.d0*AAec1*(1.d0+a1ec1*rs)*termec1 alpc=2.d0*AAalp*(1.d0+a1alp*rs)*termalp ec=ec0+alpc*fzeta*(1-zeta**4.d0)/1.709921d0+(ec1-ec0)*fzeta*zeta**4.d0 dpdrsec0=(b1ec0+3.d0*b3ec0*rs)/(2.d0*sqrt(rs))+b2ec0+b4ec0*rs*2.d0 dpdrsec1=(b1ec1+3.d0*b3ec1*rs)/(2.d0*sqrt(rs))+b2ec1+b4ec1*rs*2.d0 dpdrsalp=(b1alp+3.d0*b3alp*rs)/(2.d0*sqrt(rs))+b2alp+b4alp*rs*2.d0 dec0drs=-(2.d0*AAec0*a1ec0)*termec0+& 2.d0*AAec0*(1.d0+a1ec0*rs)*dpdrsec0/(pprsec0*(1.d0+2.d0*AAec0*pprsec0)) dec1drs=-2.d0*AAec1*a1ec1*termec1+& 2.d0*AAec1*(1.d0+a1ec1*rs)*dpdrsec1/(pprsec1*(1.d0+2.d0*AAec0*pprsec1)) dalpdrs=2.d0*AAalp*a1alp*termalp-& 2.d0*AAalp*(1.d0+a1alp*rs)*dpdrsalp/(pprsalp*(1.d0+2.d0*AAalp*pprsalp)) decdrs=dec0drs+dalpdrs*fzeta*(1-zeta**4.d0)/1.709921d0+& (dec1drs-dec0drs)*fzeta*zeta**4.d0 decdzeta=alpc*(dfdzeta*(1-zeta**4.d0)-4.d0*fzeta*zeta**3.d0)/1.709921d0+& (ec1-ec0)*(dfdzeta*zeta**4.d0+4.d0*fzeta*zeta**3.d0) Exc=ex+ec vxceven=ex+ec-(decdrs+dexdrs)*rs/3-(decdzeta+dexdzeta)*zeta vxcodd =(decdzeta+dexdzeta) if ((abs(Exc).gt.1.d65).or.(abs(vxceven).gt.1.d65).or.(abs(vxcodd).gt.1.d65)) then write(6,*) 'Problem in PW',n,rs,ec endif Exc=2*Exc; vxceven=2*vxceven ! change to Rydberg units vxcodd=2*vxcodd !do i=1,n ! write(155, '(1p3e15.7)') r(i),vxceven(i), vxcodd(i) !enddo !stop return end subroutine end Module spinpwpaw/code/fftw.f900100664004704100470410000001506310303710172015132 0ustar natalienatalie!****************************************************************************** ! ! File : fftw.f90 ! by : Natalie Holzwarth ! on : 07/08/99 ! for : PWPAW ! ! Module containing the fft routines needed for pwpaw ! Obtained from fttp:/theory.lcs.mit.edu/~fftw ! ! Copyright (c) 1997-1999 Massachusetts Institute of Technology ! ! This program is free software; you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 2 of the License, or ! (at your option) any later version. ! ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this program; if not, write to the Free Software ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! Module fftw Use timing implicit none ! include "fftw_f77.i" ! This file contains PARAMETER statements for various constants ! that can be passed to FFTW routines. You should include ! this file in any FORTRAN program that calls the fftw_f77 ! routines (either directly or with an #include statement ! if you use the C preprocessor). ! ! integer FFTW_FORWARD,FFTW_BACKWARD ! parameter (FFTW_FORWARD=-1,FFTW_BACKWARD=1) Integer, parameter :: FFTW_FORWARD=-1,FFTW_BACKWARD=1 ! ! integer FFTW_REAL_TO_COMPLEX,FFTW_COMPLEX_TO_REAL ! parameter (FFTW_REAL_TO_COMPLEX=-1,FFTW_COMPLEX_TO_REAL=1) Integer, parameter :: FFTW_REAL_TO_COMPLEX=-1,FFTW_COMPLEX_TO_REAL=1 ! ! integer FFTW_ESTIMATE,FFTW_MEASURE ! parameter (FFTW_ESTIMATE=0,FFTW_MEASURE=1) Integer, parameter :: FFTW_ESTIMATE=0,FFTW_MEASURE=1 ! ! integer FFTW_OUT_OF_PLACE,FFTW_IN_PLACE,FFTW_USE_WISDOM ! parameter (FFTW_OUT_OF_PLACE=0) ! parameter (FFTW_IN_PLACE=8,FFTW_USE_WISDOM=16) Integer, parameter :: FFTW_OUT_OF_PLACE=0,FFTW_IN_PLACE=8,FFTW_USE_WISDOM=16 ! ! integer FFTW_THREADSAFE ! parameter (FFTW_THREADSAFE=128) integer, parameter :: FFTW_THREADSAFE=128 ! Character, PARAMETER :: FFT_TO_G = 'F' !*** Perform FFT(r->g) Character, PARAMETER :: FFT_TO_R = 'B' !*** Perform FFT(g->r) Type FFT_Plan Integer*8 :: to_R Integer*8 :: to_G Integer :: Grid(4) End Type Type(FFT_Plan), Pointer, PRIVATE :: Plan_List(:) Integer, PRIVATE :: Plan_Size !*************************************************************************** contains !*************************************************************************** !*************************************************************************** !do3dfftw -- driver program for fftw Subroutine do3dfftw(Dir,plan,Inout) Character, Intent(IN) :: Dir Type(FFT_Plan), Intent(IN) :: plan Complex, Intent(INOUT) :: Inout(:) !** write(6,*) 'entering do3dfftw with',dir,grid If (Dir == 'F') then call fftwnd_f77_one(plan%to_G,Inout(1),0) else if (Dir == 'B') then call fftwnd_f77_one(plan%to_R,Inout(1),0) Inout=Inout/Plan%Grid(4) else write(6,*) 'Error in fftw -- Dir = ', Dir stop endif return end subroutine do3dfftw !****************************************************************************** ! ! PerformFFT - Performs the 3d FFT -- version for fftw ! ! Dir - Direction(FFT_TO_G or FFT_TO_R) ! Grid - Grid Dimensions ! InOut - In and Output array ! ! !****************************************************************************** Subroutine PerformFFT(Dir, Plan, InOut) Character, Intent(IN) :: Dir Integer, Intent(IN) :: Plan Complex, Intent(INOUT) :: InOut(:) ! Include "DXMLDEF.inc" ! Integer :: err, Grid(3) ! Integer, EXTERNAL :: zfft_3d ! Grid = plan_list(plan)%Grid(1:3) ! err = zfft_3d('C','C', Dir, InOut, InOut, grid(1),grid(2),grid(3), & ! grid(1), grid(2), 1,1,1) Call Start_Timer(Timer(FFT_Timer)) call do3dfftw(Dir,plan_List(plan),InOut) If (Dir==FFT_TO_G) InOut=InOut/plan_list(plan)%Grid(4) If (Dir==FFT_TO_R) InOut=InOut*plan_list(plan)%Grid(4) Call Stop_Timer(Timer(FFT_Timer)) Return End Subroutine !****************************************************************************** ! ! TestFFT - Test the fft routine ! !****************************************************************************** Subroutine TestFFT(plan, InOut) Integer, Intent(IN) :: plan Complex, Intent(INOUT) :: InOut(:) Complex :: csum Inout = 1 csum = DOT_PRODUCT(InOut,inout) Write(*,*) 'TestFFT: Grid=',plan_list(plan)%Grid, ' * SUM=',csum Call PerformFFT(FFT_TO_R, plan, InOut) csum = DOT_PRODUCT(InOut,inout) Write(*,*) 'TestFFT: FFT_TO_R Result=',csum Call PerformFFT(FFT_TO_G, plan, InOut) csum = DOT_PRODUCT(InOut,inout) Write(*,*) 'TestFFT: FFT_TO_G Result=',csum Return End Subroutine !****************************************************************************** ! ! FFT_CreatePlan - Creates a plan for use ! ! slot - Slot to store the plan ! grid - Size of FFT grid ! !****************************************************************************** Subroutine FFT_CreatePlan(slot, grid) Integer, Intent(IN) :: slot Integer, Intent(IN) :: grid(:) Plan_list(slot)%Grid(1:3) = Grid(1:3) Plan_list(slot)%Grid(4) = PRODUCT(Grid(1:3)) call fftwnd_f77_create_plan(plan_list(slot)%to_g, 3, & Plan_List(slot)%grid(1), FFTW_FORWARD, FFTW_ESTIMATE+FFTW_IN_PLACE) call fftwnd_f77_create_plan(plan_list(slot)%to_R, 3, & Plan_List(slot)%grid(1), FFTW_BACKWARD, FFTW_ESTIMATE+FFTW_IN_PLACE) Return end Subroutine !****************************************************************************** ! ! FFT_DestroyPlan - Destroys a plan ! ! slot - Slot to destroy ! !****************************************************************************** Subroutine FFT_DestroyPlan(slot) Integer, Intent(IN) :: slot call fftwnd_f77_destroy_plan(plan_list(slot)%to_g) call fftwnd_f77_destroy_plan(plan_list(slot)%to_R) Return end Subroutine !****************************************************************************** ! ! InitFFTW - Initializes the FFTW routines for use ! ! MaxPlans - Max number of different FFT grids to construct plans for ! !****************************************************************************** Subroutine InitFFTW(MaxPlans) Integer, Intent(IN) :: MaxPlans Plan_Size = MaxPlans Allocate(Plan_List(Plan_size)) Return End Subroutine end module fftw spinpwpaw/code/fileio.f900100664004704100470410000002075210303710172015434 0ustar natalienatalie!****************************************************************************** ! ! File : fileio.f90 ! by : Alan Tackett ! on : 04/29/97 ! for : MG-PAW ! ! Module contains definitions for allocating the File Units and Names ! !****************************************************************************** Module fileio Use atom_data Use paw_inout Use mem_data Use misc Implicit NONE!!!! Integer :: FD_Psi !** Base unit for Psi Integer :: FD_RadProj !** Base unit for the Radial Projectors Integer :: FD_BlochK !** Base unit for Atom Phase factors Integer :: FD_Ylm !** Base unit for Ylm structure factors Integer :: FD_Proj !** Base unit for the complete projetors(G) Integer :: FD_RS_Proj !** Base unit for the complete projetors(RS) Integer :: FD_Oinv !** Base unit for the Oinv Integer, PRIVATE :: MaxAtom Interface WriteFile_LOW !** Interface for WriteFile_LOW Module Procedure CMPLX_WriteFile_LOW Module Procedure REAL_WriteFile_LOW End Interface Interface ReadFile_LOW !** Interface for ReadFile_LOW Module Procedure CMPLX_ReadFile_LOW Module Procedure REAL_ReadFile_LOW End Interface Type (Word_Context), PRIVATE, Pointer :: WC !** Optional Context for IO errors Integer, PRIVATE :: Error_Out !** Optional error unit for error messages !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! AssignBaseFileUnits - Assigns the Base file units to all the devices ! ! BaseFile - Base File unit to use ! !****************************************************************************** Subroutine AssignBaseFileUnits(BaseUnit) Integer, Intent(IN) :: BaseUnit FD_Psi = BaseUnit FD_Oinv = FD_Psi + 1 FD_BlochK = FD_Oinv + 1 FD_Ylm = FD_BlochK + 1 FD_RadProj = FD_Ylm + 1 FD_Proj = FD_RadProj + Atom_Types FD_RS_Proj = FD_PRoj + Specific_Atoms Write(Log_Unit,*) 'ABFU: FD_Psi=', FD_Psi Write(Log_Unit,*) 'ABFU: FD_Oinv=', FD_Oinv Write(Log_Unit,*) 'ABFU: FD_BlochK=', FD_BlochK Write(Log_Unit,*) 'ABFU: FD_Ylm=',FD_Ylm Write(Log_Unit,*) 'ABFU: FD_RadProj=',FD_RadProj Write(Log_Unit,*) 'ABFU: FD_Proj=',FD_Proj Write(Log_Unit,*) 'ABFU: FD_RS_Proj=',FD_RS_Proj Return End Subroutine !****************************************************************************** ! ! Init_FileIO - Initializes the file IO module for use ! !****************************************************************************** Subroutine Init_FileIO Call Init_FileIO_Low(paw_WC, Error_Unit) Return End Subroutine !****************************************************************************** ! ! CMPLX_OpenBuffer - Opens the set of buffer files. ! ! FD_Base - Base Unit ! IDText - Text string containing where OpenBuffer is called from ! !****************************************************************************** Subroutine CMPLX_OpenBuffer(FD_base, IDText) Integer, Intent(IN) :: FD_Base Character*(*) :: IDText Integer :: i, err, last Integer :: RecSize Character*100 :: msg Complex :: c RecSize = SizeOf_C*PsiArraySize Write(Log_Unit, *) 'OpenBuffer: Unit=',FD_Base, & ' * Level=',i, ' * Size=',PsiArraySize Open(FD_base, Form="UNFORMATTED", status="SCRATCH", & Access="DIRECT", RECL=REcSize, IOSTAT=err) Write(msg,*) ' Error opening file. Rec Size=',recSize Msg = TRIM(IDText) // Msg Call Check_Error(err, msg, Error_Out, .TRUE., PAW_wc, IDText) Return End Subroutine !****************************************************************************** ! ! REAL_OpenBuffer - Opens the set of buffer files. ! ! FD_Base - Base Unit ! IDText - Text string containing where OpenBuffer is called from ! !****************************************************************************** Subroutine REAL_OpenBuffer(FD_base, IDText) Integer, Intent(IN) :: FD_Base Character*(*) :: IDText Integer :: i, err, last Integer :: RecSize Character*100 :: msg RecSize = SizeOf_Real*PsiArraySize Write(Log_Unit, *) 'OpenBuffer: Unit=',FD_Base, & ' * Size=',PsiArraySize Open(FD_base+i, Form="UNFORMATTED", status="SCRATCH", & Access="DIRECT", RECL=REcSize, IOSTAT=err) Write(msg,*) ' Error opening file. Rec Size=',recSize Msg = TRIM(IDText) // Msg Call Check_Error(err, msg, Error_Out, .TRUE., PAW_wc, IDText) Return End Subroutine !****************************************************************************** ! ! Init_FileIO_Low - Initializes the module routines for use ! ! WordC - Optional Word context ! Err_Unit - Error unit number ! !****************************************************************************** Subroutine Init_FileIO_Low(WordC, Err_Unit) Type (Word_Context), OPTIONAL, TARGET :: WordC Integer, Intent(IN) :: Err_Unit Error_Out = Err_Unit Nullify(WC) If (Present(WordC)) WC => WordC Return End Subroutine !****************************************************************************** ! ! CMPLX_WriteFile_LOW - Performs a low level WRITE of a file from disk ! ! FD_Unit - File unit ! Rec - Record Number ! Ptr - Ptr for data ! Msg - Error Text ! !****************************************************************************** Subroutine CMPLX_WriteFile_LOW(FD_Unit, Rec, Ptr, Msg) Integer, Intent(IN) :: FD_Unit Integer, Intent(IN) :: Rec Complex, Intent(IN) :: Ptr(:) Character*(*), Intent(IN) :: Msg Integer :: err, i, N !! write(Log_Unit,*) 'COMPLXwrite', FD_Unit,rec N = Size(Ptr) Write(FD_Unit, IOSTAT=err, REC=Rec) (Ptr(i), i=1, N) If (err /= 0) then Call Check_Error(err, msg, Error_Out, .TRUE., wc, "CMPLX_WriteFile_Low:") STOP End If Return End Subroutine !****************************************************************************** ! ! CMPLX_ReadFile_LOW - Performs a low level read of a file from disk ! ! FD_Unit - File unit ! Rec - Record Number ! Ptr - Ptr for storing data ! Msg - Error Text ! !****************************************************************************** Subroutine CMPLX_ReadFile_LOW(FD_Unit, Rec, Ptr, Msg) Integer, Intent(IN) :: FD_Unit Integer, Intent(IN) :: Rec Complex, Intent(OUT) :: Ptr(:) Character*(*), Intent(IN) :: Msg Integer :: err, i, N Real :: tmp !! write(Log_Unit,*) 'COMPLXread', FD_Unit,rec N = Size(Ptr) Read(FD_Unit, IOSTAT=err, REC=rec) (Ptr(i), i=1, N) If (err /= 0) then Call Check_Error(err, msg, Error_Out, .TRUE., wc, "CMPLXReadFile_LOW:") tmp = 0.0 tmp = 1.0/tmp STOP End If Return End Subroutine !****************************************************************************** ! ! REAL_WriteFile_LOW - Performs a low level WRITE of a file from disk ! ! FD_Unit - File unit ! Rec - Record Number ! Ptr - Ptr for data ! Msg - Error Text ! !****************************************************************************** Subroutine REAL_WriteFile_LOW(FD_Unit, Rec, Ptr, Msg) Integer, Intent(IN) :: FD_Unit Integer, Intent(IN) :: Rec Real, Intent(IN) :: Ptr(:) Character*(*), Intent(IN) :: Msg Integer :: err, i, N N = Size(Ptr) Write(FD_Unit, IOSTAT=err, REC=Rec) (Ptr(i), i=1, N) If (err /= 0) then Call Check_Error(err, msg, Error_Out, .TRUE., wc, "REAL_WriteFile_Low:") STOP End If Return End Subroutine !****************************************************************************** ! ! REAL_ReadFile_LOW - Performs a low level read of a file from disk ! ! FD_Unit - File unit ! Rec - Record Number ! Ptr - Ptr for storing data ! Msg - Error Text ! !****************************************************************************** Subroutine REAL_ReadFile_LOW(FD_Unit, Rec, Ptr, Msg) Integer, Intent(IN) :: FD_Unit Integer, Intent(IN) :: Rec Real, Intent(OUT) :: Ptr(:) Character*(*), Intent(IN) :: Msg Integer :: err, i, N Real :: tmp N = Size(Ptr) Read(FD_Unit, IOSTAT=err, REC=rec) (Ptr(i), i=1, N) If (err /= 0) then Call Check_Error(err, msg, Error_Out, .TRUE., wc, "REAL_ReadFile_LOW:") tmp = 0.0 tmp = 1.0/tmp STOP End If Return End Subroutine End Module spinpwpaw/code/fixspinband.f900100664004704100470410000000164110365432743016503 0ustar natalienatalie!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Program fixfile for plotting spin-dependent bandstructures ! input xx.band file generated in pwpaw with ! Calculate Band_Structure [filename] [iter] [tol] ! keywords ! forms separate spin up and spin down band files program fixfile Real(8) :: x1,x2,x3,x4 Logical :: spin integer :: i character(132) :: filename write(6,*) 'input file name (without band suffix)' read(5,*) filename open(7,file=Trim(filename)//'.band', form='formatted') open(300,file=Trim(filename)//'up.band', form='formatted') open(301,file=Trim(filename)//'dn.band', form='formatted') do read(7,*,iostat=i) x1,x2,x3,x4,spin if (i /= 0) exit if (spin) & write(300,'(1p3e16.7,2x,1pe16.7,l2)') x1,x2,x3,x4,spin if (.not.spin) & write(301,'(1p3e16.7,2x,1pe16.7,l2)') x1,x2,x3,x4,spin enddo end program spinpwpaw/code/forces.f900100664004704100470410000004726110303710172015452 0ustar natalienatalie!****************************************************************************** ! ! File : forces.f90 ! by : Alan Tackett ! on : 8/1/98 ! for : PAW program ! ! Module for calculating the forces on the atoms ! ! Updatedate for spin by Ping Tang and N. A. W. Holzwarth ! Last modification 5/23/05 !****************************************************************************** Module forces Use word Use paw_inout Use atom_data Use crystal_data Use crystal_symmetry Use spherical_harmonic Use misc Use gpoints Use projectors Use psilib Use options_data Use mathlib Use mem_data Use memmgr Use search_sort Use hamiltonian Implicit NONE!!!!!!!!!!!!!! Integer, PARAMETER :: FORCE_WIJ = 0 !** Which Fij coeff to calculate Integer, PARAMETER :: FORCE_UIJ = 1 !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! CalcForces - Calculates the Forces on the atoms ! !****************************************************************************** Subroutine CalcForces Real :: Cohesivee, F(3) Integer :: Copy_Vnewmix, Copy_Dijnewmix, i Logical :: DoCalcHam ! Initialize force array Call Start_Timer(Timer(Force_Timer)) write(log_unit,*) 'inCalcForces' call flush(log_unit) DoCalcHam = Forces_Always_Calc_H Do i=1, Specific_Atoms !write(log_unit,*) 'Calcforces', i !call flush(log_unit) Atom_List(i)%Force%CurrForce = 0 Atom_List(i)%Fij = 0 Atom_List(i)%Feij = 0 !write(log_unit,*) size(Atom_List(i)%Fij),size(Atom_List(i)%Feij) !call flush(log_unit) if (spindependence) then Atom_List(i)%Fijspin = 0 Atom_List(i)%Feijspin = 0 !write(log_unit,*) size(Atom_List(i)%Fijspin),size(Atom_List(i)%Feijspin) !call flush(log_unit) endif End Do ! recalculate Dij and Qlm matrix for current solution If (DoCalcHam) then Copy_Vnewmix=V_newMix Copy_Dijnewmix=Dij_NewMix V_newMix=1 Dij_NewMix=1 Call CalcHam(Cohesivee) CohesiveEnergy =Cohesivee V_newMix=Copy_Vnewmix Dij_NewMix=Copy_Dijnewmix !Call CalcEigenValues -- Taken out 1-24-01 NAWH write(Log_unit,*) 'from CalcForces - Cohesiveenergy = ', Cohesiveenergy End If ! DenHat and Vlocal terms Call CalcFij If (xtal%Rot_Size > 1) then Call SymFij(2) Call SymFij(3) End If Call AccumForce1 Do i=1,Specific_atoms write(Log_unit,*) 'Plane wave contribution to force for i',i write(Log_unit,*) Atom_list(i)%force%CurrForce Enddo Call AccumForce_PROJ Do i=1,Specific_atoms write(Log_unit,*) 'Term #2 contribution to force for i',i write(Log_unit,*) Atom_list(i)%force%CurrForce Enddo ! Call AccumForce3 ! Do i=1,Specific_atoms ! write(Log_unit,*) 'Term #3 contribution to force for i',i ! write(Log_unit,*) Atom_list(i)%force%CurrForce ! Enddo ! temp write statements Do i=1,Specific_atoms write(Log_unit,*) 'Before sym force for i',i write(Log_unit,*) Atom_list(i)%force%CurrForce Enddo If (xtal%Rot_size > 1) Call SymForce Do i=1,Specific_atoms write(Log_unit,*) 'After sym force for i',i write(Log_unit,*) Atom_list(i)%force%CurrForce Enddo F = 0 Do i=1, Specific_Atoms F = F + atom_list(i)%force%currforce Enddo NetForce = F Write(Log_Unit,'("CalcForces: Net Force :", 1p3e15.7)') F !** Remove drift in forces ** Removed by NAWH 01/31/00 !!!F = F/Specific_Atoms !!!Do i=1, Specific_Atoms !!! atom_list(i)%Force%CurrForce = atom_list(i)%Force%CurrForce - F !!!end Do !!!!!!! Take out the Anchor shift in this subroutine !!! !** Apply Anchor constraint of Anchor=.true. !!! If (Anchor) then !!! F=-atom_list(AnchorIndex)%force%currforce !!! Write(Log_Unit,'("CalcForces: Anchor Force:",1p3e15.7)') F !!! Do i=1, Specific_Atoms !!! atom_list(i)%Force%CurrForce = atom_list(i)%Force%CurrForce + F !!! end Do !!! Do i=1,Specific_atoms !!! write(Log_unit,*) 'After sym force for i',i !!! write(Log_unit,*) Atom_list(i)%force%CurrForce !!! Enddo !!! EndIf Call Stop_Timer(Timer(Force_Timer)) Return End Subroutine !****************************************************************************** ! ! CHeckForces - Checks the Forces on the atoms ! ! ForceTol - magnitude to togle convergence check ! Converged - true if forceForceTol) Converged = .FALSE. End Do return End Subroutine !****************************************************************************** ! ! AccumForce1 - Accumulates the DenHat and Vlocal contribution ! ! !****************************************************************************** Subroutine AccumForce1 Real :: con Integer :: L,m,lut,gi,atom,HatIndex,Offset_Q,i,atype Real :: theta, Gmag, RadG, G(3) Complex, parameter :: ai = (0,1) Complex :: accum(3),Phase,Ylm(13),Ylm_neg(13),DenT,tmp,tmpp,smoothden Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT ! DenHat and Vlocal terms con=2*Four_Pi/xtal%volume HatIndex = 1 Do gi=2, Gpnt_Size(G_HIGH) G = Gpnt(1:3,gi) Gmag = Gpnt(4,gi) if (spindependence) then smoothden=SCFvalues%RhoSmooth(gi)+SCFvalues%RhoSmoothspin(gi) else smoothden=SCFvalues%RhoSmooth(gi) endif DenT = con * Conjg((smoothden & + SCFvalues%RhoHat(gi)+SCFvalues%CoreTail(gi)))/(Gmag**2) !*** If needed inc the HatIndex *** If (G_NewMag(gi)) HatIndex = HatIndex + 1 !*** structure factors *** Do atom = 1 , Specific_atoms A => Atom_List(atom) AT => AtomType_Info(A%TypeIndex) Offset_Q = AT%Hat_MaxL + 1 theta = DOT_PRODUCT(G, A%Pos) Phase = CMPLX(cos(theta), -sin(theta)) !*** Sum over Qlm factors accum=0 Do L=0, AT%Hat_MaxL Ylm = Spharm(G(1), G(2), G(3), L, .TRUE.) RadG = AT%RadHat(HatIndex, L+1) tmp=0 Do m=-L, L tmp=tmp+A%Qlm(L+1,Offset_Q+m)*Ylm(L+m+1) Enddo tmp=tmp*(ai**(-L)) ! tmpp=tmp*((-1)**L) ! accum=accum + (RadG*G)*ai*(tmp*Phase*DenT-tmpp*Conjg(Phase*DenT)) accum=accum - 2*(RadG*G)*Imag(tmp*Phase*DenT) Enddo !*** Add coretail term accum=accum - 2*G*AT%FTCoreTail(HatIndex)*Imag(Phase*DenT) !*** Vlocal Contributions tmp=Phase*Conjg(smoothden) ! accum = accum + ai*G*AT%Rad_Vlocal(HatIndex)*(tmp-Conjg(tmp)) accum = accum - 2*G*AT%Rad_Vlocal(HatIndex)*Imag(tmp) !*** VXC term accum=accum - 2*G*AT%FTCoreTail(HatIndex)* & Imag(Phase*Conjg(SCFValues%VXC(gi))) A%force%CurrForce = A%force%CurrForce + accum Enddo Enddo Return End Subroutine !****************************************************************************** ! ! AccumForce_PROJ - Accumulates the Fij contributions ! ! !****************************************************************************** Subroutine AccumForce_PROJ Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT Integer :: i,j, atom, Total_Basis Complex :: accum(3) Do atom = 1 , Specific_atoms A => Atom_List(atom) AT => AtomType_Info(A%TypeIndex) Total_Basis = AT%nlm_Size accum = 0 do i=1,Total_Basis do j=1,Total_Basis accum = accum - A%Fij(:,i,j)*A%Dij(i,j)& + A%Feij(:,i,j)*AT%Oij(i,j) Enddo Enddo If (spindependence) then do i=1,Total_Basis do j=1,Total_Basis accum = accum - A%Fijspin(:,i,j)*A%Dijspin(i,j)& + A%Feij(:,i,j)*AT%Oij(i,j) Enddo Enddo endif A%force%Currforce = A%force%Currforce + accum Enddo Return End Subroutine !****************************************************************************** ! ! SymFij - Symmetrizes the Fij and Feij coefficients ! ! index = 2 for Fij or index = 3 for Feij ! !****************************************************************************** Subroutine SymFij(Index) Integer, INTENT(IN) :: Index type Fij_Atom Complex, Pointer :: Fij(:,:,:) End Type Integer :: i,j,k, nili, njlj, Li, Lj,mi1, mj1, mi2, mj2, Basis_Size Integer :: ibase, jbase,spin,s Real :: c Complex :: zsum(3),zrotated(3) Complex, Pointer :: Fij(:,:,:), Fij_Copy(:,:,:) Type (Fij_Atom) :: Fij_List(Specific_Atoms) Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT Character*100 :: Msg If (index.ne.2.and.index.ne.3) then write(Msg,*) "SymFIJ: Error in index",index Call Check_Error(1, Msg, Error_Unit, .TRUE., IDTEXT="SymFij:") Stop Endif spin=1 if (spindependence) spin=2 c = 1.0/XTal%Rot_Size Do i=1, Specific_Atoms !**** Make a temp copy of Fij **** A => Atom_List(i) AT => AtomType_Info(A%TypeIndex) j=AT%nlm_Size Allocate(Fij_List(i)%Fij(3, j, j), STAT=k) Write(MSg,*) "SymFij: Error Allocating Temp array for atom:",i Call Check_Error(k, Msg, Error_Unit, .TRUE., IDTEXT="SymFij:") End Do Do s=1,spin Do i=1, Specific_Atoms A => Atom_List(i) If (index.eq.2.and.s==1) Fij_List(i)%Fij = A%Fij If (index.eq.2.and.s==2) Fij_List(i)%Fij = A%Fijspin If (index.eq.3.and.s==1) Fij_List(i)%Fij = A%Feij If (index.eq.3.and.s==2) Fij_List(i)%Fij = A%Feijspin End Do Do i=1, Specific_Atoms !*** Symmetrize Fij A => Atom_List(i) AT => AtomType_Info(A%TypeIndex) Basis_Size = AT%Basis_Size If (index.eq.2.and.s==1) Fij => A%Fij If (index.eq.2.and.s==2) Fij => A%Fijspin If (index.eq.3.and.s==1) Fij => A%Feij If (index.eq.3.and.s==2) Fij => A%Feijspin Do nili=1, Basis_Size Li = AT%L_Value(nili) ibase = AT%nl_Base(nili)+Li Do mi1=-Li, Li Do njlj=1, Basis_Size Lj = AT%L_Value(njlj) jbase = AT%nl_Base(njlj)+Lj Do mj1=-Lj, Lj zrotated = 0 Do j=1, XTal%Rot_Size zsum = 0 Fij_Copy => Fij_List(iatrans(i,j))%Fij Do mi2=-Li, Li Do mj2=-Lj, Lj zsum= zsum + & (zarot(mi2+Li+1,mi1+Li+1,Li+1,j)) & *CONJG(zarot(mj2+Lj+1,mj1+Lj+1,Lj+1,j)) & *Fij_copy(:,ibase+mi2, jbase+mj2) End Do End Do Do k=1,3 zrotated = zrotated + XTal%RotMatrix(:,k,j)*zsum(k) Enddo End Do Fij(:,ibase+mi1, jbase+mj1) = zrotated*c End Do End Do !**njlj End Do End Do !**nili End Do End Do ! spin Do i=1, Specific_Atoms !*** Free Fij Copy DeAllocate(Fij_List(i)%Fij) End Do Return End Subroutine !****************************************************************************** ! ! SymForce - Symmetrizes the Forces ! ! !****************************************************************************** Subroutine SymForce Integer :: i,j,k Real :: c Complex :: zsum(3),zrotated(3),ztmp(3) Complex :: Ftmp(3,Specific_Atoms) Type (Specific_Atom), Pointer :: A c = 1.0/XTal%Rot_Size Do i=1, Specific_Atoms !**** Make a temp copy of Forces *** A => Atom_List(i) Ftmp(1:3,i)=A%Force%CurrForce(1:3) End Do Do i=1, Specific_Atoms !*** Symmetrize Forces A => Atom_List(i) zsum = 0 Do j=1, XTal%Rot_Size ztmp = Ftmp(1:3,iatrans(i,j)) zrotated = MATMUL((XTal%RotMatrix(:,:,j)),ztmp) zsum = zsum + zrotated End Do A%Force%CurrForce(1:3) = zsum*c End Do Return End Subroutine !****************************************************************************** ! ! CalcFij - Calculates d SUM_nk f_nk ! --- ! dR^a ! and stores results in Fij and also calculates Feij ! !****************************************************************************** Subroutine CalcFij Integer :: Prange(2),Base, G_Half, G_Size, atype Integer :: i,j, k,Base_DI, atom, L, m, am, N, RadP, PLM_Index ! Integer :: Psi_toUse(Mem_MapSize), Flag, PsiBand, PsiK,PsiIn Integer :: Flag, PsiBand, PsiK,PsiIn Integer ,pointer:: Psi_toUse(:) Complex, Pointer :: Ylm(:), Phase(:) Complex, Pointer :: Work(:), Glist(:,:), PDOT(:), DPDOT(:,:) Real, Pointer :: Proj(:) Real :: c1, occ, energy, BlochK(3) Complex :: c3, cL,tmp(3), c_p, c_dp, term Complex, parameter :: ai = (0,1) Complex, Pointer :: Fij(:,:,:), Feij(:,:,:), WF(:) Type (Specific_Atom), Pointer :: A Type (Mem_handle), Pointer :: Psi Allocate(Psi_toUse(Mem_MapSize)) !write(log_unit,*) 'In CalcFij' !call flush(log_unit) Do atom=1,Specific_Atoms Atom_List(atom)%Fij=0 ! zero Fij array Atom_List(atom)%Feij=0 ! zero Fije array if (spindependence) then Atom_List(atom)%Fijspin=0 ! zero Fij array Atom_List(atom)%Feijspin=0 ! zero Fije array endif Enddo N=Gpnt_Size(G_LOW)-1 c1 = 4*Pi / sqrt(xtal%Volume) Allocate(Glist(3,Gall_Size(G_Low)),DPDOT(3,Plm_Max)) Call GetBuffer(Work) Glist(:,1:Gpnt_Size(G_LOW)) = Gpnt(1:3,1:Gpnt_Size(G_LOW)) Glist(:,Gpnt_Size(G_LOW)+1:Gall_Size(G_Low)) = -Gpnt(1:3,2:Gpnt_Size(G_LOW)) Do k=1, NumKpnts BlochK = BZ%Ku(:,k) Psi_toUse = MH_Skip Where ((PsiInfo(:)%Kpnt == k) .AND. (PsiInfo(:)%Occupancy >1E-10)) Psi_toUse = MH_toProcess End Where Call Phase_Generic( Psi_toUse, k) Call GetNextPsi(Flag, Psi) Do While (Flag > 0) WF => Psi%Ptr PsiIn=Psi%Index PsiInfo(PsiIn)%DoSave=1 PsiInfo(PsiIn)%Available=Mem_Used occ = PsiInfo(PsiIn)%Occupancy energy = PsiInfo(PsiIn)%Energy PDOT => PsiInfo(PsiIn)%PDOT DPDOT = 0 PDOT_Dir = -PDOT_Dir Call SetStartEnd(Prange) Do atom=1, Specific_Atoms atype = Atom_List(atom)%typeIndex If (Proj_Mode /= MIN_TIME) then Call GetStructFactor( atom, Phase) Base_DI = Atomtype_Info(atype)%Basis_Size*(k-1) !** Calc starting DI for Kpnt Else Base_DI = RS_PLMMax(atom)*(k-1) End If ! G_Half = Atomtype_Info(atype)%Gpnt_size ! G_Size = 2*G_Half - 1 G_Half = Gpnt_Size(G_LOW) G_Size = Gall_Size(G_LOW) Do j=1, RS_PLMMax(atom) RadP = RS_PLM(atom,1,j) L = RS_PLM(atom,2,j) m = RS_PLM(atom,3,j) am = ABS(m) PLM_Index = RS_PLM(atom,4,j) If (Run_Mode == Min_MEMORY) then Call GetYlm( k, L, am, Ylm) Call LRU_GetRec(LRU_RadProj(atype), Base_DI+radP, Proj) cL = ai**L !-------- If (m>=0) then i = 1 term = CONJG(Ylm(i))*Proj(i)*Phase(i)*WF(i) Pdot(PLM_Index) = term DPDOT(:,PLM_Index) = Term*Glist(:,i) Do i=2, G_Half term = CONJG(Ylm(i))*Proj(i)*Phase(i)*WF(i) PDOT(PLM_Index) = PDOT(PLM_Index) + term DPDOT(:,PLM_Index) = DPDOT(:,PLM_Index) + Term*Glist(:,i) term = CONJG(Ylm(i+n)) * Proj(i+G_Half-1) * & Phase(i+n) * WF(i+n) PDOT(PLM_INDEX) = PDOT(PLM_Index) + term DPDOT(:,PLM_Index) = DPDOT(:,PLM_Index) + & Term*GList(:,i+n) end Do PDOT(PLM_Index) = c1*cL*PDOT(PLM_Index) DPDOT(:,PLM_Index) = ai*CL*C1*DPDOT(:,Plm_Index) Else i = 1 term = Ylm(i)*Proj(i)*Phase(i)*WF(i) PDOT(PLM_Index) = term DPDOT(:,PLM_Index) = term*GList(:,i) Do i=2, G_Half term = Ylm(i)*Proj(i)*Phase(i)*WF(i) PDOT(PLM_Index) = PDOT(PLM_Index) + term DPDOT(:,PLM_Index) = DPDOT(:,PLM_Index) + term*Glist(:,i) term = Ylm(i+n) * Proj(i+G_Half-1) * & Phase(i+n) * WF(i+n) PDOT(PLM_Index) = PDOT(PLM_Index) + term DPDOT(:,Plm_Index) = DPDOT(:,PLM_Index) + & term*Glist(:,i+n) end Do c3 = (-1)**am PDOT(PLM_Index) = c1*cL*c3*PDOT(PLM_Index) DPDOT(:,PLM_Index) = ai*c1*cL*c3*DPDOT(:,PLM_Index) End If else Call LRU_GetRec(LRU_Proj(atom), Base_DI+j, Phase) i = 1 term = Phase(i)*WF(i) Pdot(PLM_Index) = term DPDOT(:,PLM_Index) = Term*Glist(:,i) Do i=2, G_Half term = Phase(i)*WF(i) PDOT(PLM_Index) = PDOT(PLM_Index) + term DPDOT(:,PLM_Index) = DPDOT(:,PLM_Index) + Term*Glist(:,i) term = Phase(i+G_Half-1) * WF(i+n) PDOT(PLM_INDEX) = PDOT(PLM_Index) + term DPDOT(:,PLM_Index) = DPDOT(:,PLM_Index) + & Term*GList(:,i+n) end Do DPDOT(:,PLM_Index) = ai*DPDOT(:,Plm_Index) End If End Do !** j End Do If(spindependence.and.(.not.PsiInfo(PsiIn)%spinup)) then Do atom=1,Specific_Atoms ! Accumulate Fij Fij => Atom_List(atom)%Fijspin Feij => Atom_List(atom)%Feijspin Base = PLM_AtomRange(1,atom)-1 !write(log_unit,*) 'CalcFij spindown', atom,Base !call flush(log_unit) Do i=PLM_AtomRange(1,atom),PLM_AtomRange(2,atom) Do j=PLM_AtomRange(1,atom),PLM_AtomRange(2,atom) tmp = occ*(CONJG(PDOT(i))*DPDOT(:,j) + & CONJG(DPDOT(:,i))*PDOT(j)) Fij(:,i-Base,j-Base) = Fij(:,i-Base,j-Base) + tmp Feij(:,i-Base,j-Base) = Feij(:,i-Base,j-Base) + tmp*energy EndDo Enddo Enddo else Do atom=1,Specific_Atoms ! Accumulate Fij Fij => Atom_List(atom)%Fij Feij => Atom_List(atom)%Feij Base = PLM_AtomRange(1,atom)-1 !write(log_unit,*) 'CalcFij spinup', atom,Base !call flush(log_unit) Do i=PLM_AtomRange(1,atom),PLM_AtomRange(2,atom) Do j=PLM_AtomRange(1,atom),PLM_AtomRange(2,atom) tmp = occ*(CONJG(PDOT(i))*DPDOT(:,j) + & CONJG(DPDOT(:,i))*PDOT(j)) Fij(:,i-Base,j-Base) = Fij(:,i-Base,j-Base) + tmp Feij(:,i-Base,j-Base) = Feij(:,i-Base,j-Base) + tmp*energy EndDo Enddo Enddo Endif Call GetNextPsi(Flag, Psi) End do End do Call FreeBuffer(Work) Deallocate(Glist,DPDOT) DeAllocate(Psi_toUse) Return End Subroutine End Module spinpwpaw/code/gaussbzi.f900100664004704100470410000001066310303710172016014 0ustar natalienatalie!*************************************************************************** ! ! File : gaussbzi.f90 ! by : Alan Tackett ! on : 2/3/97 ! for : PAW Method ! ! ! gaussbzi - Gaussian Smearing Brillouin Zone Integration ! ! This file contains routines to perform BZ integration using a ! Gaussian smearing Method which is outlined in the articles below: ! ! Fu, C.-L., Ho, K.-M., PRB 28, 5480 (1983). ! Holzwarth, N.A.W., Zeng, Y., PRB 49, 2351 (1994). ! ! ! NOTE: DOS is not implemented only NOS ! ! Modified for spin dependence by Ping Tang and N. A. W. Holzwarth ! last modification 5/23/05 !************************************************************************** Module gaussbzi Use bz_data Use options_data Use paw_inout implicit none Contains !**************************************************************************** ! ! InitGaussBZI - Initialize the Gaussian routines for use. ! ! This routine is assumed to be called from bz_Init(...) contained in the ! BZINT module. Check there to see what is set in bz. ! !**************************************************************************** Subroutine InitGaussBZI(bz) Type (bz_Struct), Intent(INOUT) :: Bz Return End Subroutine !**************************************************************************** ! ! Gauss_FreeUnused - Frees the unused arrays and makes them point to the ! unique versions. Should not be called ! until after GAUSS_WEIGHTS has been called! ! ! The Following Arrays are deallocated in the BZ data structure: ! ! Weight, Kp, Ke, Kmap, and Cube ! ! !**************************************************************************** Subroutine Gauss_FreeUnused(BZ) Type (BZ_Struct), Intent(INOUT) :: bz DeAllocate(BZ%Weight, BZ%Kp, BZ%Ke, BZ%KMap, BZ%Cube) BZ%Weight => BZ%WtUniq BZ%Kp => BZ%Ku BZ%Ke => BZ%KEu BZ%TotalCubes = 0 BZ%TotalKPnts = BZ%TotalUniq Return End Subroutine !**************************************************************************** ! ! Gauss_NOS - Calculates the NOS for all bands ! ! bz - BZ data structure, uses Fermi energy contained ! ! The NOS contribution for a particular (band,K-point) is defined as ! ! ! ( ( E - E ) ) ! NOS = d ( 1 + erf( f n,k ) ) where SUM(d ) = 1 ! n,k k ( ( --------- ) ) k ! ( ( sigma ) ) ! ! ! The d 's are contained in BZ%WtUniq array ! k ! ! Return Values ! Returns the NOS and optionally the NOS for each n,k. ! ! Note: Only uses the Unique K-points, KE's, and Weights!! ! !**************************************************************************** Real Function gauss_NOS(BZ, Occ) type (BZ_Struct), Intent(INOUT) :: bz Real, OPTIONAL, Intent(OUT) :: Occ(:,:) Integer :: i, j ,n,s Real :: NOS, fn, c, Fermi, DERF Real, Pointer :: KEu(:,:), Wtu(:,:) KEu => BZ%KEu Wtu => BZ%WtUniq c = 1.0/BZ%Sigma Fermi = BZ%Fermi NOS = 0 s=1 if (spindependence) s=2 n=BZ%Bands*s !BZ%Bands == Numbands !write(log_unit,*) 'gauss_NOS: begin', n,s !call flush(log_unit) !Write(*,*) 'Gauss_NOS: Fermi=',Fermi !Write(Log_unit,*) 'Gauss_NOS: Fermi=',Fermi !call flush(log_unit) Do i=1, BZ%TotalUniq !Do j = 1, BZ%Bands Do j = 1, n fn = (1 + DERF((Fermi - KEu(j,i))*c))/s !Write(*,*) 'Gauss_NOS: Kpnt=',i, ' * Band=',j, ' * KE=',KEu(j,i), ' * Occ=',Wtu(j,i)*Fn !Write(log_unit,*) 'Gauss_NOS: Kpnt=',i, ' * Band=',j, ' * KE=',KEu(j,i), ' * Occ=',Wtu(j,i)*Fn !call flush(log_unit) NOS = NOS + Wtu(j,i)*fn IF (Present(Occ)) Occ(j,i) = Wtu(j,i)*fn End Do End Do Gauss_NOS = NOS !write(log_unit,*) 'Gaussbzi: NOS',NOS !call flush(log_unit) Return End Function !**************************************************************************** ! ! Gauss_Weights - Calculates the Weights for all bands ! ! Return Values ! Stores all the UNIQUE weights ! !**************************************************************************** Subroutine Gauss_Weights(bz) type (BZ_Struct), Intent(INOUT) :: bz Integer :: i Real, Pointer :: Wtu(:,:) Integer, Pointer :: KMap(:) Wtu => Bz%WtUniq KMap => BZ%KMap Wtu = 0 Do i = 1, Bz%TotalKpnts Wtu(1,KMap(i)) = Wtu(1,KMap(i)) + 1 End Do Wtu(1,:) = Wtu(1,:) / Bz%TotalKpnts Do i=2, Bz%Bands Wtu(i,:) = wtu(1,:) End Do Return End Subroutine End Module spinpwpaw/code/gaussfunc_data.f900100664004704100470410000000126110303710172017146 0ustar natalienatalie!****************************************************************************** ! ! File : gaussfunc_data.f90 ! by : Alan Tackett ! on : 04/25/00 ! for : ! ! Data structure to define the gaussian functions ! ! N - Number of gaussians ! Coeff(1,:) - Shift ! Coeff(2,:) - width or sigma ! Coeff(3,:) - Scale factor ! !****************************************************************************** Module gaussfunc_data Implicit None!!!!!!!!! Integer, PARAMETER :: GAUSS_SHIFT = 1 Integer, PARAMETER :: GAUSS_SIGMA = 2 Integer, PARAMETER :: GAUSS_SCALE = 3 Type GaussFunc Integer :: N Real, Pointer :: Coeff(:,:) End Type End Module spinpwpaw/code/gausslib.f900100664004704100470410000000546310303710172016000 0ustar natalienatalie!****************************************************************************** ! ! File : gausslib.f90 ! by : Alan Tackett ! on : 04/25/00 ! for : Convert_SEPM ! ! Searches and manipulates a table of gaussian functions ! !****************************************************************************** Module gausslib Use gaussfunc_data Implicit None !!!! !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! Combine_Gauss - Combines two gaussian lists ! ! A, B - Lists to combine ! C - Result, C = alpha*A +beta*B ! alpha, beta - Scale factors for A and B ! !****************************************************************************** Subroutine Combine_Gauss(A,B,C, alpha, beta) Type (Gaussfunc), Intent(IN) :: A Type (Gaussfunc), Intent(IN) :: B Type (Gaussfunc), Intent(OUT):: C Real, Intent(IN) :: alpha Real, Intent(IN) :: beta Real, PARAMETER :: tol = 1E-8 Integer :: i,j,k, n Type (Gaussfunc) :: AB Real :: err, Diff(2) !** Make temp result ** i = A%N+B%N AB%N = A%N Allocate(AB%Coeff(3,i)) !** Copy initial gauss func ** AB%Coeff(:,1:A%N) = A%Coeff AB%Coeff(GAUSS_SCALE, 1:A%N) = alpha*AB%Coeff(GAUSS_SCALE,1:A%N) n = A%N !** Now try to merge with the B function ** Do i=1, B%N j = 0 err = 2*tol Do While ((j tol)) j = j + 1 diff = A%Coeff(1:2,j) - B%Coeff(1:2,i) err = SQRT(DOT_PRODUCT(diff,diff)) End do if (err < tol) then AB%Coeff(GAUSS_SCALE,j) = AB%Coeff(GAUSS_SCALE,j) + & beta*B%Coeff(GAUSS_SCALE,i) else AB%N = AB%N + 1 n = AB%N AB%Coeff(:,n) = B%Coeff(:,i) AB%Coeff(GAUSS_SCALE,n) = beta*B%Coeff(GAUSS_SCALE, i) End if End do !** Now reallocate the final 'C' ** C%N = AB%N Allocate(C%Coeff(3,C%N)) C%Coeff = AB%Coeff(:,1:C%N) !** finally clean up by dealloc'ing AB ** DeAllocate(AB%Coeff) Return End Subroutine !****************************************************************************** ! ! EvalGauss - Evaluates a gaussian function at the specified point ! ! Func - Function ! R - Position ! !****************************************************************************** Real Function EvalGauss(Func, R) Type (GaussFunc), Intent(IN) :: Func Real, Intent(IN) :: R Integer :: i Real :: gsum, pow gsum = 0 Do i=1, Func%N pow = (R - Func%Coeff(GAUSS_SHIFT, i))/Func%Coeff(GAUSS_SIGMA,i) pow = -pow*pow if (pow > -40) gsum = gsum + Func%Coeff(GAUSS_SCALE, i)*exp(pow) End do EvalGauss = gsum Return End function end Module spinpwpaw/code/genkpoints.f900100664004704100470410000001752510303710172016352 0ustar natalienatalie!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Program genkpoints ! 5/16/00 translation of pawbz pgm into Alan Tackett's form ! program pawbz ! -- to construct grid for Brillouin Zone integral ! ! Calling sequence: genkpoints [input paw file name] !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Program Genkpoints Use Crystal_data Use Crystal_symmetry Use mathlib Use paw_inout Use Word Use Strings Use Units implicit none Character*100 :: Fn, token Logical :: ex LOGICAL :: findA=.false.,findB=.false.,findC=.false. Integer :: err, i , j, tlen,nrot integer :: ifsym,ii,jj,kk,iftmp,ifcry,iargc integer, parameter :: input_unit=5 if (iargc() < 1) then Write(*,*) 'Format: pwpaw input_file' STOP End if Call GetArg(1,Fn) write(*,*) 'Filename=',Fn ! A typical pwpaw input file Token = Fn Call UpperCase(Token) Inquire(file=Trim(fn),exist=ex) if (.not.ex) then Write(*,*) "Can't access file ",Trim(fn) Write(*,*) "Make sure the file exists and has Read permissions." stop endif Allocate(xtal%trans(3,48),xtal%rotmatrix(3,3,48)) Call initconstants Write(*,*) 'Scratch_FD=',Scratch_Unit Call DetWordConstants(SCRATCH_UNIT) Call InitWord(PAW_WC, INPUT_BASE_UNIT, trim(Fn), DELIMS, COMMENT, LIT_CHAR, & MAX_INCLUDE, INCLUDE_STR) Call GetNextWord(PAW_WC,Token,tlen) nrot=0; xtal%Rot_Size=100 Do If (W_Error /= W_EOF ) then Call UpperCase(Token) If (Trim(Token) == "A") then Call GetNumbers(PAW_WC,xtal%Basis(1:3,1),3) findA=.true. write(*,*) 'A =',xtal%Basis(1:3,1) Else If (Trim(Token) == "B") then Call GetNumbers(PAW_WC,xtal%Basis(1:3,2),3) findB=.true. write(*,*) 'B =',xtal%Basis(1:3,2) Else If (Trim(Token) == "C") then Call GetNumbers(PAW_WC,xtal%Basis(1:3,3),3) findC=.true. write(*,*) 'C =',xtal%Basis(1:3,3) Else If (Trim(Token) == "ROT_SIZE") then Call GetNumber(PAW_WC,xtal%Rot_Size) write(*,*) 'Rot_Size =',xtal%Rot_Size Else if (Trim(token) == "MATRIX") then Call GetNumber(PAW_WC, j) Call GetNumbers(PAW_WC, xtal%RotMatrix(1,:, j), 3) Call GetNumbers(PAW_WC, xtal%RotMatrix(2,:, j), 3) Call GetNumbers(PAW_WC, xtal%RotMatrix(3,:, j), 3) Call GetNextWord(PAW_WC, Token, tlen) !** Get the end statement write(*,*) 'Loaded matrix #',j Else if (Trim(token) == "TRANSLATION") then Call GetNumber(PAW_WC, j) Call GetNumbers(PAW_WC, xtal%Trans(:,j), 3) nrot=nrot+1 EndIf Else Exit EndIf If (findA .AND. findB .AND. findC .AND. nrot==xtal%Rot_Size) Exit Call GetNextWord(PAW_WC,Token,tlen) Enddo If (.not.findA .OR. .not.findB .OR. .not.findC & .OR. nrot /= xtal%Rot_Size) then write(*,*) 'Error -- Basis functions and/or rotations not found' stop Endif xtal%Recip = RecipBasis(xtal%Basis) If (Xtal%Rot_Size.le.0) then xtal%Rot_Size=1 xtal%RotMatrix=0 xtal%Trans=0 xtal%RotMatrix(1,1,1)=1 xtal%RotMatrix(2,2,1)=1 xtal%RotMatrix(3,3,1)=1 Endif Call setsym(0) do write(*,*) 'input Agrid, Bgrid, Cgrid' read(*,*) ii,jj,kk call kgrid(ii,jj,kk,input_unit,SCRATCH_UNIT) enddo stop end subroutine kgrid(ii,jj,kk,input_unit,iftmp) ! subroutine to generate k-space grid for Gaussian smoothing ! method of dos calculation ! uses point group rotations and first positive translations use crystal_symmetry use crystal_data use paw_inout implicit none real*8 :: v(3),w(3),u(3) real*8, allocatable :: rk(:,:),wgt(:) real*8, parameter :: eps=1.d-6 real*8 :: xkk,xjj,xii,dfloat,ww,dabs,wate,xx1,xx2,xx3 integer :: nkpts,nkpts0,icount,m1,m2,m3,it,n1,n2,n3,ier,iftmp integer :: ii,jj,kk,i,j,k,inc,np,nq,mt,nx,l,krep,iq integer :: input_unit character *100 :: answer, filename nkpts=ii*jj*kk if (nkpts.lt.1) then write(*,*) ' kpoints < 1 -- program exiting ' stop endif allocate(rk(3,nkpts),wgt(nkpts),stat=ier) if (ier.ne.0) then write(*,*) 'error in allocating rk',nkpts,ier stop endif nkpts0=nkpts xkk=1.d0/kk xjj=1.d0/jj xii=1.d0/ii icount=0 do k=1,kk do j=1,jj do i=1,ii icount=icount+1 wgt(icount)=1.d0 rk(1,icount)=(dfloat(i)-0.5d0)*xii rk(2,icount)=(dfloat(j)-0.5d0)*xjj rk(3,icount)=(dfloat(k)-0.5d0)*xkk enddo enddo enddo inc=3 ! generate all equivalent points np=1 mainloop: do np=np+1 if (np.gt.nkpts) exit mainloop innerloop: do nq=np-1 do m1=1,3 do m2=1,3 do m3=1,3 do it=1,3 v(it)=rk(it,np) enddo v(1)=v(1)+(m1-2) v(2)=v(2)+(m2-2) v(3)=v(3)+(m3-2) do mt=1,Xtal%Rot_Size do it=1,3 w(it)=igrot(it,1,mt)*v(1)+igrot(it,2,mt)*v(2)+igrot(it,3,mt)*v(3) enddo do iq=1,nq xx1=dmod(dabs(w(1)-rk(1,iq)),1.d0) xx2=dmod(dabs(w(2)-rk(2,iq)),1.d0) xx3=dmod(dabs(w(3)-rk(3,iq)),1.d0) if(xx1+xx2+xx3.le.eps) then ! w already in list wgt(iq)=wgt(iq)+1.d0 ! np not needed nx=np+1 if (nx.le.nkpts) then do l=nx,nkpts do it=1,3 rk(it,l-1)=rk(it,l) enddo enddo endif nkpts=nkpts-1 np=np-1 exit innerloop endif enddo !iq enddo !mt enddo !m3 enddo !m2 enddo !m1 exit innerloop enddo innerloop enddo mainloop ! completed list of k kvectors write(*, & "('kgrid -- ',i3,' x',i3,' x',i3,i5,' pts reduced to',i5)") & ii,jj,kk,nkpts0,nkpts write(*,*) 'Input two character strings --' write(*,*) 'save filename OR try again OR quit now' read(*,*) answer,filename Call Uppercase(answer) If (trim(answer)=="SAVE") then Open(unit=SCRATCH_UNIT,file=trim(filename),form='formatted') write(SCRATCH_UNIT,'("K-POINTS_LIST",i10)') nkpts do it=1,nkpts do l=1,3 if (rk(l,it).gt.0.5d0) rk(l,it)=rk(l,it)-1.d0 enddo wate=wgt(it) write (SCRATCH_UNIT,'(3f20.16,2x,f10.5)')(rk(j,it),j=1,3),wate enddo write(SCRATCH_UNIT,'("END")') close(SCRATCH_UNIT) stop else if (trim(answer)=="QUIT") then stop endif return end spinpwpaw/code/gpoints.f900100664004704100470410000005250310371153057015657 0ustar natalienatalie!****************************************************************************** ! ! File : gpoints.f90 ! by : Alan Tackett ! on : 04/14/99 ! for : PAW ! ! Module containing the G-points used for evaluation of the Wave functions ! and potentials. ! ! The arrays Gpnt(:,:) and Npnt(:,:) contain only the unique reciprocal ! lattice vectors, i.e. k and -k are not stored. The vectors are sorted ! in ascending order with k=(0,0,0) in slot 1. ! ! Gpnt(:,:) => Gpnt(1:3, i) : Kx,Ky,Kz for the ith k-vector ! Gpnt(4,i) : |k|, magnitude of the K-vector ! ! NPnt(:,:) => NPnt(1:3,i) : Nx,Ny,Nz(integers) for the ith K-vector ! ! FFTMap_Low(:) - FFT mapping for Psi functions(Gcut_Psi) ! FFTMap_High(:) - FFT mapping for functions with the larger Gcut_Den ! ! modified 2/2/06 to filter wfn's so that |k + G| < Gcut_LOW ! !****************************************************************************** Module gpoints Use mathlib Use word Use misc Use paw_inout Use options_data Use fftw Use btree Use crystal_data Use bz_data Implicit NONE!!!!! Integer, PARAMETER :: G_LOW = 1 !** Low PW cutoff index Integer, PARAMETER :: G_HIGH = 2 !** High PW cutoff index Integer, PARAMETER :: G_PROJ = 3 !** PW cutoff index for RS proj Real, Pointer :: Gpnt(:,:) !** G-vector list Integer, Pointer :: NPnt(:,:) !** Coresponding integer G-vector Logical, Pointer :: G_NewMag(:) !** TRUE if Gpnt(4,i-1)/=Gpnt(4,i) Integer :: NewMag_Size(3) !** Size of Non-redundant G-mags Integer :: Gpnt_Size(3) !** Number of G-points for Low/High cutoffs <= 0 Integer :: Gall_Size(3) !** Number of G-points for Low/High cutoffs (all) Integer, Pointer :: FFTmap_Low(:) Integer, Pointer :: FFTmap_High(:) Integer, Pointer :: FFTmap_PROJ(:) Integer :: FFT_Grid(4,3) !** Grid Dimensions - (:,1)=Low Real, PARAMETER :: Filter_Min = 1E-30 !** for FilterValue pgm Integer, PRIVATE :: Count !** Used for converting the btree to 1d array Real, PRIVATE :: G_Recip(3,3) ! data structure needed for filtering Type Gcutfilter_struct Integer :: nzeros Integer, pointer :: zeromap(:) End type Type (Gcutfilter_struct), allocatable :: Gcutfilter(:) !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! ConvertGpoints - Converts the G-points list to the 1-D array ! !****************************************************************************** Logical Function ConvertGpoints(Node) Type (BinaryTreeData) :: Node Count = Count + 1 !Write(Log_Unit,*) 'ConvertGpoints: Count=',count !Write(Log_Unit,*) 'ConvertGpoints: Gmag=',Node%Gmag, ' * N=',Node%Npnt !write(Log_Unit,*) 'ConvertGpoints : Recip=',G_recip Gpnt(1:3, Count) = MATMUL(G_Recip, Node%Npnt) Gpnt(4, Count) = Node%Gmag Npnt(:, Count) = Node%Npnt ConvertGpoints = .TRUE. Return End Function !****************************************************************************** ! ! GenGPoints - Generates the list of G-points ! ! Recip - Reciprocal Lattice Vectors ! Gcut - Curvilinear Plane wave cutoff ! GSize - Number of curvilinear Plane Waves generated ! Gpnt - List of Gpnts ! ! NOTE: If Gsize <= 0 then Gpnts is not used but GSize contains the number ! of planewaves needed. !****************************************************************************** Subroutine GenGpoints(Recip, Gcut, Gsize,WC) Real, Intent(IN) :: Recip(:,:) Real, Intent(IN) :: Gcut Integer, Intent(OUT) :: Gsize Type (Word_Context), Intent(INOUT) :: WC Integer :: i,j,k, NMax, t, Used ,m(3) Real :: g, g2, gv(3) Character*100 :: Token Logical :: Ok, Unique Type (BinaryTreeNode), Pointer :: Root, Match Type (BinaryTreeData), Pointer :: Item, Test Nullify(Root) !*** Estimate the Max indices for Gcut **** do i=1,3 g=DOT_PRODUCT(Recip(:,i),Recip(:,i)) j=i+1-((i)/3)*3 k=i+2-((i+1)/3)*3 g=MIN(g,DOT_PRODUCT((Recip(:,i)-Recip(:,j)),(Recip(:,i)-Recip(:,j)))) g=MIN(g,DOT_PRODUCT((Recip(:,i)+Recip(:,j)),(Recip(:,i)+Recip(:,j)))) g=MIN(g,DOT_PRODUCT((Recip(:,i)-Recip(:,k)),(Recip(:,i)-Recip(:,k)))) g=MIN(g,DOT_PRODUCT((Recip(:,i)+Recip(:,k)),(Recip(:,i)+Recip(:,k)))) m(i)=1.5*gcut/SQRT(g) enddo Used = 0 !** First do the X=0, plane - Need to check for dups **** Allocate(Test) i = 0 Do j=-m(2), m(2) Do k=-m(3), m(3) gv = MATMUL(Recip, (/i,j,k/)) g = SQRT(DOT_PRODUCT(gv,gv)) if (g < Gcut) then Test%Gmag = g Test%Npnt = - (/i,j,k/) Call SearchBTree(Root, Test, Match, Ok) If (.NOT. Ok) then Used = Used + 1 Allocate(Item) Item%Gmag = Test%Gmag Item%Npnt = -Test%Npnt Call InsertNode(Root, Item, Ok) End If End If End Do End Do !*** Now add the rest. Don't have to check for dups **** Do i=1, m(1) Do j=-m(2), m(2) Do k=-m(3), m(3) gv = MATMUL(Recip, (/i,j,k/)) g = SQRT(DOT_PRODUCT(gv,gv)) if (g < Gcut) then Used = Used + 1 Allocate(Item) Item%Gmag = g Item%Npnt = (/i,j,k/) Call InsertNode(Root, Item, Ok) End If End Do End Do End Do GSize = Used Allocate(Gpnt(4,GSize), Npnt(3,GSize),STAT=i) Write(Token,*) 'InitGpoints: Error allocating Recip array. Size=',GSize Call Check_Error(i, Token, Error_Unit, .TRUE., WC, 'GenGpoints:') Gpnt=0 Npnt=0 !*** Now store the list in the 1D array *** G_Recip = Recip Count = 0 Call InOrderTraversal(Root, ConvertGpoints) Call FreeTree(Root, .TRUE.) Return End Subroutine !****************************************************************************** ! ! GenGPoints - Generates the list of G-points ! ! Recip - Reciprocal Lattice Vectors ! Gcut - Curvilinear Plane wave cutoff ! GSize - Number of curvilinear Plane Waves generated ! Gpnt - List of Gpnts ! ! NOTE: If Gsize <= 0 then Gpnts is not used but GSize contains the number ! of planewaves needed. !***OLD*** !****************************************************************************** Subroutine GenGpoints_OLD(Recip, Gcut, Gsize,WC) Real, Intent(IN) :: Recip(:,:) Real, Intent(IN) :: Gcut Integer, Intent(OUT) :: Gsize Type (Word_Context), Intent(INOUT) :: WC Integer :: i,j,k, NMax, t, Used ,m(3) Real :: g, g2, gv(3) Character*100 :: Token Integer, Pointer :: LUT(:,:) Logical :: Ok, Unique Unique = .TRUE. !*** Estimate the Max indices for Gcut **** do i=1,3 g=DOT_PRODUCT(Recip(:,i),Recip(:,i)) j=i+1-((i)/3)*3 k=i+2-((i+1)/3)*3 g=MIN(g,DOT_PRODUCT((Recip(:,i)-Recip(:,j)),(Recip(:,i)-Recip(:,j)))) g=MIN(g,DOT_PRODUCT((Recip(:,i)+Recip(:,j)),(Recip(:,i)+Recip(:,j)))) g=MIN(g,DOT_PRODUCT((Recip(:,i)-Recip(:,k)),(Recip(:,i)-Recip(:,k)))) g=MIN(g,DOT_PRODUCT((Recip(:,i)+Recip(:,k)),(Recip(:,i)+Recip(:,k)))) m(i)=1.5*gcut/SQRT(g) enddo t = (m(1)+1)*(m(2)+1)*(m(3)+1) Allocate(LUT(3,t)) Used = 1 LUT(:,Used) = 0 !*** Store DC G-point Do i=-m(1), m(1) Do j=-m(2), m(2) Do k=-m(3), m(3) gv = MATMUL(Recip, (/i,j,k/)) g = SQRT(DOT_PRODUCT(gv,gv)) if ((g /= 0) .AND. (g < Gcut)) then Ok = .TRUE. If (Unique) then t = 1 Do While ((t<=Used) .AND. Ok) If ((i==-LUT(1,t)).AND.(j==-LUT(2,t)).AND.(k==-LUT(3,t))) then Ok = .FALSE. End If t = t + 1 End Do End If If (Ok) then Used = Used + 1 LUT(:,Used) = (/i,j,k/) End IF End If End Do End Do End Do GSize = Used Allocate(Gpnt(4,GSize), Npnt(3,GSize),STAT=i) Write(Token,*) 'InitGpoints: Error allocating Recip array. Size=',GSize Call Check_Error(i, Token, Error_Unit, .TRUE., WC, 'GenGpoints:') Gpnt=0 Npnt=0 do i=1,GSize gv = MATMUL(Recip, LUT(:,i)) g = SQRT(DOT_PRODUCT(gv,gv)) Gpnt(1:3,i)=gv Gpnt(4,i)=g Npnt(:,i)=LUT(:,i) enddo DeAllocate(LUT) Return End Subroutine !****************************************************************************** ! ! FindGcut - Finds the Gcut cutoff index ! ! Gcut - Plane wave cutoff ! Gpnt - List of Gpoints. Gpnt(1:3,i)=INTEGER indices, Gpnt(4,i)=Actual G mag ! GSize - Size of Kpoints list ! !****************************************************************************** Integer Function FindGcut(Gcut, Gpnt, GSize) Real, Intent(IN) :: Gcut Real, Intent(INOUT) :: Gpnt(:,:) Integer, Intent(IN) :: GSize Integer :: i i=1 Do While ((i 1E-9) then G_NewMag(i) = .TRUE. j = j + 1 If (i<=Gpnt_Size(G_Low)) NewMag_Size(G_Low) = j else G_NewMag(i) = .FALSE. End if End Do NewMag_Size(G_High) = j Do n=1, 3 Do i=1, 3 !** Determine min LOW/High grid dimensions j = 2*MaxVal(ABS(Npnt(i,1:Gpnt_Size(n)))) + 1 FFT_Grid(i,n) = NearestIntWithFactors(j,(/2,3,5/), 3, +1) End Do FFT_Grid(4,n) = PRODUCT(FFT_Grid(1:3,n)) End Do Write(Log_Unit,*) 'InitGpoints: FFT_Grid(LOW):',FFT_Grid(:,G_LOW) Write(Log_Unit,*) 'InitGpoints: FFT_Grid(HIGH):',FFT_Grid(:,G_HIGH) Write(Log_Unit,*) 'InitGpoints: FFT_Grid(PROJ):',FFT_Grid(:,G_PROJ) Gall_Size = 2*Gpnt_Size - 1 Allocate(FFTmap_Low(2*Gpnt_Size(G_LOW)-1),& FFTmap_High(2*Gpnt_Size(G_HIGH)-1), & FFTmap_PROJ(2*Gpnt_Size(G_PROJ)-1),stat=ioerr) Write(token,*)'InitGpoints: Error allocating FFTmap, Size =',& Gpnt_Size(G_HIGH) Call Check_Error(ioerr,token,Error_Unit, .TRUE.,WC,"InitKPOINTS:") ! !*** Check to make sure grid is large enough *** ! j=MaxVal(ABS(NPnt(1:3,1:Gpnt_Size(G_HIGH)))) ! k = MaxVal(FFT_Grid(1:3,G_HIGH))/2 + 1 ! if (j>k) then ! Write(Error_Unit,*) 'InitKpoints: Npnt to large when adding Gn!' ! Write(Error_Unit,*) 'InitKPoints: Max K=',k ! STOP ! End If !do i=1,30 !write(Log_Unit,'(i4,3i3,1pe15.7)') i,Npnt(1:3,i),Gpnt(4,i) ! enddo !*** Lastly calculate the FFT mappings *** Do i=1, 3 If (i==G_LOW) then FFTMap => FFTmap_Low else if (i==G_HIGH) then FFTMap => FFTmap_High else if (i==G_PROJ) then FFTMap => FFTmap_PROJ End If j = 1 !** G=0 vector Gn = Npnt(:,j) + 1 Where (Gn <= 0) Gn = Gn + FFT_Grid(1:3,i) FFTMap(j) = CalcLinearIndex(FFT_Grid(1:3,i), Gn) + 1 Do j=2, Gpnt_Size(i) Gn = Npnt(:,j) + 1 !** +G vector Where (Gn <= 0) Gn = Gn + FFT_Grid(1:3,i) FFTMap(j) = CalcLinearIndex(FFT_Grid(1:3,i), Gn) + 1 If (FFTMap(j)>FFT_Grid(4,i)) then Write(Log_Unit,*) 'InitGPoints: FFTMap+Error!! j=',j, & ' * NPnt=',Npnt(:,j), ' * Gn=',Gn, ' * FFTMap(j)=',FFTMAp(j) STOP End If Gn = -Npnt(:,j) + 1 !** -G vector Where (Gn <= 0) Gn = Gn + FFT_Grid(1:3,i) FFTMap(j+Gpnt_Size(i)-1) = CalcLinearIndex(FFT_Grid(1:3,i), Gn) + 1 If (FFTMap(j)>FFT_Grid(4,i)) then Write(Log_Unit,*) 'InitGPoints: FFTMap-Error!! j=',j, & ' * NPnt=',Npnt(:,j), ' * Gn=',Gn, ' * FFTMap(j)=',FFTMAp(j) STOP End If End Do End Do Grid = FFT_Grid(1:3,G_LOW) !** Now create the FFT plans *** Call InitFFTW(3) Call FFT_CreatePlan(G_LOW, FFT_Grid(:,G_Low)) Call FFT_CreatePlan(G_HIGH, FFT_Grid(:,G_High)) Call FFT_CreatePlan(G_PROJ, FFT_Grid(:,G_PROJ)) Return End Subroutine !****************************************************************************** ! ! FilterValue - Filter's a complex array by zeroing the small values ! !****************************************************************************** Subroutine FilterValue(Grid, MinReal) Complex, Intent(INOUT) :: Grid(:) Real, OPTIONAL, Intent(IN) :: MinReal Real :: TooSmall TooSmall = Filter_Min If (Present(MinReal)) TooSmall = MinReal Where (ABS(Real(Grid)) < TooSmall) Grid = CMPLX(0.0, AImag(Grid)) Where (ABS(AImag(Grid)) < TooSmall) Grid = CMPLX(Real(Grid), 0.0) Return End Subroutine !****************************************************************************** ! ! CalcLinearIndex - Calculates the Linear Index of 3-d array ! ! GridDim - Grid Dimensions ! PM - 3-d Mesh point index ! ! ***** NOTE: Should only be used on unifrom grids!!!!! ****** ! !****************************************************************************** Function CalcLinearIndex(GridDim, PM) Integer :: CalcLinearIndex Integer, Intent(IN) :: gridDim(:) Integer, Intent(IN) :: PM(:) CalcLinearIndex = GridDim(1)*GridDim(2)*(PM(3)-1) + & GridDim(1)*(PM(2)-1) + PM(1)-1 Return End Function !************************************************************************* ! ! V_G_to_r ! Takes V(G) (input) to V(r) (output) where ! G defined on Gpnt_Size(INPUTGRID) ! r defined on FFTmap(OUTPUTGRID) ! ! Vr initialized to 0 ! !************************************************************************* Subroutine V_G_to_r(VG,INPUTGRID,Vr,OUTPUTGRID) Complex, intent(IN) :: VG(:) Complex, intent(OUT) :: Vr(:) Integer, intent(IN) :: INPUTGRID,OUTPUTGRID Integer :: i,j,k,l Integer, pointer :: FFTMap(:) If (OUTPUTGRID == G_LOW) then FFTMap => FFTMap_LOW Else if (OUTPUTGRID == G_PROJ) then FFTMap => FFTMap_PROJ Else if (OUTPUTGRID == G_HIGH) then FFTMap => FFTMap_HIGH Else Write(Error_Unit,*) " Error in V_G_to_r", INPUTGRID,OUTPUTGRID stop EndIf If (Gall_Size(OUTPUTGRID) FFTMap_LOW Else if (INPUTGRID == G_PROJ) then FFTMap => FFTMap_PROJ Else if (INPUTGRID == G_HIGH) then FFTMap => FFTMap_HIGH Else Write(Error_Unit,*) " Error in V_r_to_G", INPUTGRID,OUTPUTGRID stop EndIf If (Gall_Size(OUTPUTGRID)>Gall_Size(INPUTGRID)) then write(Error_Unit,*) " Error in V_r_to_G", INPUTGRID,OUTPUTGRID Endif Call PerformFFT(FFT_TO_G, INPUTGRID, Vr) i=Gpnt_Size(OUTPUTGRID)+1;j=Gpnt_Size(INPUTGRID)+1;k=j+Gpnt_Size(OUTPUTGRID)-2 VG(1:Gpnt_Size(OUTPUTGRID))=VG(1:Gpnt_Size(OUTPUTGRID)) + & Vr(FFTMap(1:Gpnt_Size(OUTPUTGRID))) VG(i:Gall_Size(OUTPUTGRID))=VG(i:Gall_Size(OUTPUTGRID)) + & Vr(FFTMap(j:k)) Return End Subroutine !***************************************************************************** ! ! Subroutine LdPlaneWave ! !****************************************************************************** Subroutine LdPlaneWave(WC) Type (Word_Context), Intent(INOUT) :: WC Integer :: i, tlen Character*80 :: Token PW_Gcut = 0 Call GetNextWord(WC, Token, tlen) Call UpperCase(token) Do While (Trim(token) /= "END") if (Trim(Token) == "GCUT_LOW") then !** Set Psi PW Cutoff Call GetNumbers(WC, PW_Gcut(G_LOW)) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) " Gcut_Low = ", PW_Gcut(G_LOW) End IF else if (Trim(Token) == "GCUT_HIGH") then !** Set density PW Cutoff Call GetNumbers(WC, PW_Gcut(G_HIGH)) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) " Gcut_High = ", PW_Gcut(G_HIGH) End IF else if (Trim(Token) == "GCUT_PROJ") then !** Set projector PW Cutoff Call GetNumbers(WC, PW_Gcut(G_PROJ)) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) " Gcut_PROJ = ", PW_Gcut(G_PROJ) End IF else Write(Error_Unit, *) "ldPlaneWave: Unknown Command : ", Trim(Token) End If Call GetNextWord(WC, Token, tlen) if (W_ERROR /= W_OK) Call EOF_Error(WC, "ldPlaneWave:(next word): ") Call UpperCase(token) End Do If (PW_Gcut(G_PROJ) == 0) PW_Gcut(G_PROJ) = PW_GCut(G_LOW) Return End Subroutine Subroutine InitkplusGfilter(NoKpnts) Integer, INTENT(IN) :: NoKpnts Integer :: i,j,k Real :: Kvec(3),gmag2,ecut,v(3) If(allocated(Gcutfilter)) then k=size(Gcutfilter) do i=1,k Deallocate(Gcutfilter(i)%zeromap) enddo Deallocate(Gcutfilter) endif write(Log_unit,*) 'InitkplusGfilter (re)starting with kpts = ', NoKpnts allocate(Gcutfilter(NoKpnts),stat=i) if (i /= 0) then write(error_unit,*) 'Error in InitkplusGfilter ', NoKpnts,i stop endif ecut=PW_Gcut(G_LOW)**2 j=0 do k=1,NoKpnts Kvec=BZ%Ku(:,k) do i=1,Gall_Size(G_LOW) if (i <= Gpnt_Size(G_LOW)) then v=Kvec+Gpnt(:,i) gmag2=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) if (gmag2>ecut) j=j+1 else v=Kvec-Gpnt(:,i-Gpnt_Size(G_LOW)+1) gmag2=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) if (gmag2>ecut) j=j+1 endif enddo write(Log_unit,*) 'In InitkplusGvilter -- kpnt, nzeros = ', k,j Gcutfilter(k)%nzeros=j if (j>0) then allocate(Gcutfilter(k)%zeromap(j), stat=i) if (i /= 0) then write(error_unit,*) 'Error in InitkplusGfilter ', k,j stop endif else write(6,*) 'WARNING!!!!! no padding for kvec =', Kvec endif j=0 do i=1,Gall_Size(G_LOW) if (i <= Gpnt_Size(G_LOW)) then v=Kvec+Gpnt(:,i) gmag2=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) if (gmag2>ecut) then j=j+1 Gcutfilter(k)%zeromap(j)=i endif else v=Kvec-Gpnt(:,i-Gpnt_Size(G_LOW)+1) gmag2=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) if (gmag2>ecut) then j=j+1 Gcutfilter(k)%zeromap(j)=i endif endif enddo enddo End Subroutine InitkplusGfilter Subroutine kplusGfilter(WF,kindex) COMPLEX, INTENT(INOUT) :: WF(:) INTEGER, INTENT(IN) :: kindex INTEGER :: many,i many=Gcutfilter(kindex)%nzeros if (many>0) then do i=1,many WF(Gcutfilter(kindex)%zeromap(i))=0 enddo endif End subroutine kplusGfilter End Module spinpwpaw/code/gradenk.f900100664004704100470410000003160710303710172015601 0ustar natalienatalie!****************************************************************************** ! ! File : gradEnk.f90 ! by : N. A. W. Holzwarth and Yonas Abraham ! on : 7/24/00 ! for : PAW program ! ! Module for calculating k gradient for Enk ! ! modified for spin by Ping Tang and N. A. W. Holzwarth ! Last change 5/23/05 !****************************************************************************** Module GradEnk Use paw_inout Use atom_data Use crystal_data Use spherical_harmonic Use gpoints Use projectors Use options_data Use mathlib Implicit NONE!!!!!!!!!!!!!! Type Temp_Grad Complex, pointer :: Gij(:,:,:) End Type Type Temp_GP Real, pointer :: Gpnl(:,:) Real, pointer :: pnl(:,:) End Type Type (Temp_Grad) ,private ,pointer :: Temp_atom(:) Type (Temp_GP) ,private ,pointer :: Temp_type(:) Complex, pointer ,private :: Ylm(:,:),Gylm(:,:,:) Complex, pointer, private :: GRADPDOT(:,:),WF(:),WW(:) Complex, pointer , private :: W1(:),W2(:),W3(:) Real, pointer ,private :: Glist(:,:) Real, private :: YlmCon Integer, private :: MaxMaxL !***************************************************************************** Contains !****************************************************************************** !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! InitGradEnk ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Subroutine InitGradEnk Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT Integer :: i,j,k,many,ier,n,L,atype,lut,atom,m,am,Base YlmCon=4*Pi/SQRT(xtal%Volume) Allocate (Temp_atom(Specific_atoms),Temp_Type(Atom_Types),stat=ier) If (ier /= 0) then write(Error_Unit,*) 'Error allocating Temp in InitGradEnk' stop EndIf Do i=1,Specific_Atoms A=> Atom_List(i) AT=> AtomType_Info(A%TypeIndex) many=AT%nlm_Size Allocate(Temp_Atom(i)%Gij(3,many,many),stat=ier) If (ier /= 0) then write(Error_Unit,*) 'Errror allocating Gij in InitGradEnk',i,many stop EndIf Enddo MaxMaxL=0 Do i=1,Atom_Types many=AtomType_Info(i)%Basis_Size MaxMaxL=Max(MaxMaxL,MaxVal(AtomType_Info(i)%L_Value(1:many))) Allocate(Temp_Type(i)%Gpnl(Gall_Size(G_LOW),many), & Temp_Type(i)%pnl(Gall_Size(G_LOW),many),stat=ier) If (ier /= 0) then write(Error_Unit,*) 'Error allocating Gpnl in InitGradEnk',i,many stop EndIf Enddo Write(Log_Unit,*) 'InitGradEnk: MaxMaxL = ',MaxMaxL Call Flush(Log_Unit) If (MaxMaxL.gt.6) then Write(Error_Unit,*) 'InitGradEnk: MaxMaxL > 6 ', MaxMaxL stop EndIf Allocate(GRADPDOT(Plm_Max,3),Glist(Gall_Size(G_LOW),4),stat=ier) If (ier /= 0) then write(Error_Unit,*) 'Error allocating GRADPDOT in CalcGradEnk',Plm_Max stop EndIf Write(Log_Unit,*) 'CalcEnk: MaxMaxl = ', MaxMaxL many=((MaxMaxL+2)*(MaxMaxL+1))/2 Allocate(Ylm(Gall_Size(G_LOW),many),GYlm(Gall_Size(G_Low),3,many),stat=ier) If (ier /= 0) then write(Error_Unit,*) 'Errror allocating Ylm in CalcGradEnk',many stop EndIf !! Finished allocation Return End Subroutine !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Subroutine FinishGradEnk ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Subroutine FinishGradEnk Integer :: i Do i=1,Specific_Atoms Deallocate(Temp_Atom(i)%Gij) Enddo Deallocate(GRADPDOT,Glist,Ylm,GYlm) Return End Subroutine !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! NewKforGradEnk ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Subroutine NewKforGradEnk(Kval) Real, intent(IN) :: Kval(3) Real , parameter :: tol=1.e-11 Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT Real :: tmp,tmp1,Gmag Complex :: Ylmtmp(13,7),GYlmtmp(3,13,7) Integer :: i,j,k,many,ier,n,L,atype,lut,atom,m do i=1,Gpnt_Size(G_LOW) Glist(i,1:3)=Kval + Gpnt(1:3,i) Enddo do i=Gpnt_Size(G_LOW)+1,Gall_Size(G_LOW) Glist(i,1:3)=Kval - Gpnt(1:3,i+1-Gpnt_Size(G_LOW)) Enddo Do i=1,Gall_Size(G_LOW) Glist(i,4)=SQRT(DOT_PRODUCT(Glist(i,1:3),Glist(i,1:3))) If (Glist(i,4) AtomType_Info(i) !! Calculate and store Fourier Transforms of radial term Do n=1,AT%Basis_Size L=AT%L_Value(n) Do j=1,Gall_Size(G_LOW) tmp = RadFourierDeriv(L, Glist(j,4), AT%Mesh_Step, & AT%Mesh_Size, AT%TP(:,n)) tmp1 = RadialFourier(L, Glist(j,4), AT%Mesh_Step, & AT%Mesh_Size, AT%TP(:,n)) Temp_type(i)%Gpnl(j,n)= tmp Temp_type(i)%pnl(j,n)= tmp1 Enddo Enddo Enddo !! Calculate and store Fourier transform of spherical harmonics Do j=1,Gall_Size(G_LOW) Call Ylmlist(Glist(j,1),Glist(j,2),Glist(j,3),MaxMaxL,Ylmtmp,Error_Unit) Call GradYlmlist(Glist(j,1),Glist(j,2),Glist(j,3),MaxMaxL,GYlmtmp) many=0 Do L=0,MaxMaxL do m=0,L many=many+1 Ylm(j,many)=YlmTmp(L+1+m,L+1) GYlm(j,:,many)=GYlmTmp(:,L+1+m,L+1) Enddo Enddo Enddo Return End Subroutine !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! CalcGradEnk ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Subroutine CalcGradEnk(Enk, WF, PDOT, GradEnk) Real, intent(IN) :: Enk Complex, intent(IN) :: WF(:) Complex, intent(INOUT) :: PDOT(:) Real, intent(OUT) :: GradEnk(3) Real , parameter :: tol=1.e-11 Complex , parameter :: ai=(0,1) Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT Complex, pointer :: Phase(:),Dij(:,:) Real :: tmp,tmp1,Gmag Complex :: il,ctmp(3) Complex :: tempdot(PLM_Max) Integer :: i,j,k,many,ier,n,L,atype,lut,atom,m,am,Base Integer :: Index,PlmIndex tempdot=PDOT Call GetBuffer(WW) Call GetBuffer(W1) Call GetBuffer(W2) Call GetBuffer(W3) PDOT=0 GRADPDOT=0 Do atom=1,Specific_Atoms Temp_atom(atom)%Gij=0 Enddo !! Prepare projector and gradprojector coefficients i=0 Do atype = 1, Atom_Types AT => AtomType_Info(atype) Do n=1,AT%Basis_Size L = AT%L_Value(n) il= YlmCon*(ai**L) Do m=-L,L am=ABS(m) Index=((L*(L+1))/2) + 1 + am If (m < 0) then il=il*((-1)**am) WW=WF*Temp_type(atype)%pnl(:,n)*Ylm(:,Index) W1=WF*(Temp_type(atype)%pnl(:,n)*GYlm(:,1,Index) & +Temp_type(atype)%Gpnl(:,n)*Ylm(:,Index)*Glist(:,1)) W2=WF*(Temp_type(atype)%pnl(:,n)*GYlm(:,2,Index) & +Temp_type(atype)%Gpnl(:,n)*Ylm(:,Index)*Glist(:,2)) W3=WF*(Temp_type(atype)%pnl(:,n)*GYlm(:,3,Index) & +Temp_type(atype)%Gpnl(:,n)*Ylm(:,Index)*Glist(:,3)) Else WW=WF*Temp_type(atype)%pnl(:,n)*CONJG(Ylm(:,Index)) W1=WF*(Temp_type(atype)%pnl(:,n)*CONJG(GYlm(:,1,Index)) & +Temp_type(atype)%Gpnl(:,n)*CONJG(Ylm(:,Index))*Glist(:,1)) W2=WF*(Temp_type(atype)%pnl(:,n)*CONJG(GYlm(:,2,Index)) & +Temp_type(atype)%Gpnl(:,n)*CONJG(Ylm(:,Index))*Glist(:,2)) W3=WF*(Temp_type(atype)%pnl(:,n)*CONJG(GYlm(:,3,Index)) & +Temp_type(atype)%Gpnl(:,n)*CONJG(Ylm(:,Index))*Glist(:,3)) EndIf Do lut=AtomType_Range(1,atype),AtomType_Range(2,atype) atom=AtomType_Map(lut) Call GetStructFactor(atom,Phase) i=i+1 PlmIndex=PDOT_Map(5,i) PDOT(PlmIndex)=il*SUM(WW(:)*Phase(:)) GRADPDOT(PlmIndex,1)=il*SUM(W1(:)*Phase(:)) GRADPDOT(PlmIndex,2)=il*SUM(W2(:)*Phase(:)) GRADPDOT(PlmIndex,3)=il*SUM(W3(:)*Phase(:)) EndDo EndDo !m Enddo !n Enddo !atype ! Do i=1,PLM_Max ! write(Log_UNit,*) 'Compare pdot --',i,ABS(pdot(i)-tempdot(i)) ! Enddo Do atom=1,Specific_Atoms Base=PLM_AtomRange(1,atom)-1 Do i=PLM_AtomRange(1,atom),PLM_AtomRange(2,atom) Do j=PLM_AtomRange(1,atom),PLM_AtomRange(2,atom) Temp_atom(atom)%Gij(1,i-Base,j-Base)=CONJG(GRADPDOT(i,1))*PDOT(j) & + CONJG(PDOT(i))*GRADPDOT(j,1) Temp_atom(atom)%Gij(2,i-Base,j-Base)=CONJG(GRADPDOT(i,2))*PDOT(j) & + CONJG(PDOT(i))*GRADPDOT(j,2) Temp_atom(atom)%Gij(3,i-Base,j-Base)=CONJG(GRADPDOT(i,3))*PDOT(j) & + CONJG(PDOT(i))*GRADPDOT(j,3) Enddo Enddo Enddo GradEnk(1)=2*DOT_PRODUCT(Glist(:,1)*WF(:),Glist(:,4)*WF(:)) GradEnk(2)=2*DOT_PRODUCT(Glist(:,2)*WF(:),Glist(:,4)*WF(:)) GradEnk(3)=2*DOT_PRODUCT(Glist(:,3)*WF(:),Glist(:,4)*WF(:)) Do Atom = 1,Specific_Atoms A => Atom_List(atom) AT => AtomType_Info(A%TypeIndex) Base=AT%nlm_Size if(spindependence.and.(.not.Global_spinup)) then Dij=>A%Dijspin else Dij=>A%Dij endif ctmp=0 Do i=1,Base Do j=1,Base ctmp=ctmp+(Dij(i,j)-Enk*AT%Oij(i,j))*Temp_atom(atom)%Gij(:,i,j) Enddo Enddo GradEnk(:)=GradEnk(:)+ctmp(:) Enddo write(Log_Unit,*) 'CalcGradEnk: Enk, GradEnk = ',Enk,GradEnk Call Flush(Log_Unit) Call FreeBuffer(WW) Call FreeBuffer(W1) Call FreeBuffer(W2) Call FreeBuffer(W3) Return End Subroutine !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! RadFourierDeriv - calculates the radial integral necessary to evaluate the ! derivative of the Fourier transform of f(r)/r*Ylm ! ! L - L value of Ylm ! k - Spherical Bessel argument scale factor(see below) ! h - Radial spacing between grid points ! N - Number of grid points ! F - tabulated Function ! ! input : l, k, h, n, f(:) , where f(r) is tabulated at n points ! in intervals of h; f(1)==f(r=0)=0 ! ! The radial integral is returned: ! gftf == int(r*f(r)*d j_l(k*r),r=0..(n-1)*h) ! _________ ! d k ! ! !****************************************************************************** Real Function RadFourierDeriv(l,k,h,n,f) Integer, Intent(IN) :: L Real, Intent(IN) :: k Real, Intent(IN) :: h Integer, Intent(IN) :: n Real, Intent(IN) :: f(n) Integer :: i Real, pointer :: x(:) Real, parameter :: tol=1.e-11 Allocate(x(n)) If (k < tol ) then Write(Error_Unit,*) ' Error in radFourierDeriv -- k too small ', k stop EndIf Do i=1,n x(i) = k*(i-1)*h End Do Call DerivSphereBessel(L,n,x) Do i=1,n x(i)=x(i)*f(i)*(((i-1)*h)**2) End Do RadFourierDeriv = IntSimpson(n,h,x) DeAllocate(x) return End Function !****************************************************************************** ! ! gradylmlist: Returns gradient spherical harmonic functions for l in the order ! m=-l,...0,...l in Condon-Shortley convention and for ! l=0,.. lmax ! ! IN : x, y, z- These are the x, y, and z cartesian coordinates ! lmax ! error_unit ! ! OUT: GradYlm(3,13,lmax+1) -array containing the spherical harmonic ! values. ! !****************************************************************************** Subroutine GradYlmlist(x, y, z, lmax, Gradylm) implicit none Real, intent(IN) :: x, y, z integer, intent(IN):: lmax Complex, INTENT(OUT) :: Gradylm(:,:,:) ! Local declarations Real :: Ylm_Norm, r, costheta, sintheta, cosphi, sinphi , tmp Real :: vtheta(3) Complex :: vphi(3) Real, parameter :: tol = 1.e-11 Integer :: m,im ,L Complex :: phase Gradylm = 0 if (lmax.lt.0.or.lmax.gt.6) then write(error_unit,*) 'error in GradYlmlist',lmax,x,y,z stop endif r=sqrt(x*x+y*y+z*z) If (r.lt.tol.or.lmax.eq.0) return costheta=z/r cosphi=1 sinphi=0 sintheta=sqrt((1-costheta)*(1+costheta)) if (sintheta.gt.tol) then cosphi=x/(r*sintheta) sinphi=y/(r*sintheta) else sintheta=0 end if vtheta(1)=costheta*cosphi/r;vtheta(2)=costheta*sinphi/r;vtheta(3)=-sintheta/r vphi(1)=CMPLX(0,-sinphi/r);vphi(2)=CMPLX(0,cosphi/r);vphi(3)=0 phase=CMPLX(cosphi,sinphi) do L=1,lmax Ylm_Norm= sqrt((2*L+1)/Four_Pi) Gradylm(:,L+1,l+1)=Ylm_Norm*Der_Theta_P(l,0,costheta)*vtheta tmp=1.0/(L*(L+1)) Do m=1,L Gradylm(:,L+1+m,l+1)=Ylm_Norm*sqrt(tmp)*(phase**m)* & (Der_Theta_P(l,m,costheta)*vtheta + Der_Phi_P(l,m,costheta)*vphi) Gradylm(:,L+1-m,l+1)=((-1)**m)*CONJG(Gradylm(:,L+1+m,l+1)) if (m.lt.L) tmp=tmp/((L+m+1)*(L-m)) End do Enddo end subroutine Gradylmlist End Module GradEnk spinpwpaw/code/group.f0100664004704100470410000003635310303710172015154 0ustar natalienataliec c $Id: group.f,v 1.1.1.1 2005/08/26 21:58:18 natalie Exp $ c c $Log: group.f,v $ c Revision 1.1.1.1 2005/08/26 21:58:18 natalie c Version of pwpaw with option for spin dependence. c c Revision 1.1.1.1 2003/08/06 02:45:29 natalie c PWPAW source code implemented on Osiris c c Revision 1.1 1992/04/21 00:43:59 alberto c New parameter scheme c c Revision 1.1 1991/12/16 00:16:03 alberto c Initial revision c subroutine atftmt(nfd,a,ai,x,r,tnp,trans,ity,na,ib,ihg,ipm,li,nc, & invers_no) c c subroutine atftmt determines the point group of the crystal, the c atom transformation table,f0, the fractional translations,tnp, c associated with each rotation and finally the multiplication table c mt, for the point group of the crystal. ib now contains c operations in the p.g. of the crystal and ntrans is the order of c this group. c include 'atoms.i' c C .. Scalar Arguments .. integer ihg, ipm, li, na, nc, invers_no, nfd C .. C .. Array Arguments .. Real a(3,3), ai(3,3), r(49,3,3), tnp(48,3), 1 trans(48,3,3), x(3,ntyp*natp) integer ib(48), ity(ntyp*natp) C .. C .. Local Scalars .. Real da, dif, eps, ts, vs integer i, il, is, isy, iu, j, k, k1, k2, k3, k4, ks, l, m, n, n1, 1 n2, n3, nca, ni C .. C .. Local Arrays .. Real rx(3,ntyp*natp), v(3,48), vr(3), vt(3), xb(3) integer ia(48), ic(48), if0(48,ntyp*natp), mt(48,48) character cst(7)*12 C .. C .. External Subroutines .. external rlv C .. C .. Intrinsic Functions .. intrinsic abs, mod C .. C .. Data statements .. c data cst/'triclinic ', 'monoclinic ', 'orthorhombic', 1 'tetragonal ', 'cubic ', 'trigonal ', 2 'hexagonal '/ C .. invers_no = 0 c c eps should be slightly larger than computer precision c eps = 1.0d-8 nca = 0 ni = 13 if (ihg .lt. 6) ni = 25 li = 0 do 130 n = 1, nc l = ib(n) ic(n) = ib(n) do 30 k = 1, na do 20 i = 1, 3 rx(i,k) = 0.0d0 do 10 j = 1, 3 rx(i,k) = rx(i,k) + r(l,i,j)*x(j,k) 10 continue 20 continue 30 continue do 100 k1 = 1, na do 90 k2 = 1, na if (ity(k1) .eq. ity(k2)) then do 40 i = 1, 3 xb(i) = rx(i,k1) - x(i,k2) 40 continue il = 0 call rlv(ai,xb,vr,il) c subroutine rlv removes a direct lattice vector from c leaving the remainder in vr. if a nonzero lattice vector was c removed, il is made nonzero. vr stands for v-reference. ks = 0 do 80 k3 = 1, na do 70 k4 = 1, na if (ity(k3) .eq. ity(k4)) then do 50 i = 1, 3 xb(i) = rx(i,k3) - x(i,k4) 50 continue call rlv(ai,xb,vt,il) c vt stands for v-test. dif = 0.0d0 do 60 i = 1, 3 da = abs(vr(i)-vt(i)) + eps dif = dif + mod(da,1.e0) 60 continue if (dif .le. 10.0D0*eps) then if0(l,k3) = k4 c if0 is the function defined in maradudin and vosko by c eq.(2.35). it defines the atom transformation table ks = ks + k4 if (ks .eq. na*(na+1)/2) go to 110 c go to 80 c end if end if 70 continue c go to 90 c 80 continue end if 90 continue 100 continue c go to 130 c 110 continue nca = nca + 1 do 120 i = 1, 3 v(i,l) = vr(i) 120 continue c c v(i,l) is the i-th cartesian component of the fractional c translation associated with the rotation r(l). c ib(nca) = l if (l .eq. ni) then li = l invers_no = nca endif 130 continue if (ihg .eq. 7 .and. nca .eq. 24) go to 140 if (ihg .eq. 5 .and. nca .eq. 48) go to 140 write(nfd,9000) cst(ihg), (ic(i),i=1,nc) 9000 format(/' The crystal system is ',a12,' with operations: ',/5x, 1 24i3,/5x,24i3,/) c go to 150 c 140 continue write(nfd,9010) cst(ihg) 9010 format(/' The point group of the crystal is the full ',a12, 1 'group') 150 continue vs = 0.0d0 nc = nca do 170 n = 1, nc l = ib(n) do 160 i = 1, 3 vs = vs + abs(v(i,l)) 160 continue 170 continue if (vs .gt. eps) go to 180 write(nfd,9020) 9020 format(/' the space group of the crystal is symmorphic',/) isy = 1 is = 1 c go to 190 c 180 continue write(nfd,9030) 9030 format(/, 1 ' The space group is non-symmorphic',/,' (Or a non standard', 2 ' origin of coordinates is used)',/) c ipm=1 isy = 0 is = 0 c c construct the multiplication table c 190 continue do 270 n1 = 1, nc do 260 n2 = 1, nc l = ib(n1) m = ib(n2) do 220 i = 1, 3 do 210 j = 1, 3 r(49,i,j) = 0.0d0 do 200 k = 1, 3 r(49,i,j) = r(49,i,j) + r(l,i,k)*r(m,k,j) 200 continue 210 continue 220 continue do 250 n3 = 1, nc n = ib(n3) ts = 0.0d0 do 240 i = 1, 3 do 230 j = 1, 3 ts = ts + abs(r(49,i,j)-r(n,i,j)) 230 continue 240 continue if (ts .gt. 100.0D0*eps) go to 250 mt(l,m) = n c go to 260 c 250 continue 260 continue 270 continue c il = 1 iu = nc if (iu .gt. 24) iu = 24 280 continue write(nfd,9040) (ib(i),i=il,iu) 9040 format(' Operation number ',24i3) do 300 i = 1, na do 290 j = 1, nc l = ib(j) ia(j) = if0(l,i) 290 continue 300 continue if (nc-iu) 320, 320, 310 310 continue write(nfd,9050) 9050 format(//) il = 25 iu = nc c go to 280 c c Print multiplication table and fractional translations. c 320 continue if (ipm .eq. 0) go to 410 il = 1 iu = nc if (nc .gt. 24) iu = 24 if (is) 330, 330, 340 330 continue write(nfd,9060) 9060 format('0',57x,'Multiplication table',30x, 1 'Fractional translations') write(nfd,9070) (ib(i),i=il,iu) 9070 format('0',4x,24i4) write(nfd,9080) 9080 format('+',107x,'v(1) v(2) v(3)') c go to 360 c 340 continue write(nfd,9090) 9090 format('0',57x,'Multiplication table') 350 continue write(nfd,9100) (ib(i),i=il,iu) 9100 format('0',4x,24i4) 360 continue do 400 j = 1, nc l = ib(j) do 370 i = il, iu n = ib(i) ia(i) = mt(l,n) 370 continue if (is) 380, 380, 390 380 continue write(nfd,9120) ib(j), (ia(i),i=il,iu) write(nfd,9110) (v(i,l),i=1,3) 9110 format('+',102x,3f10.4) c go to 400 c 390 continue write(nfd,9120) ib(j), (ia(i),i=il,iu) 400 continue 9120 format(i5,24i4) if (iu .eq. nc) go to 410 il = 25 iu = nc is = 1 c go to 350 c 410 continue c do 440 i = 1, nc l = ib(i) do 430 j = 1, 3 tnp(i,j) = -v(j,l) do 420 k = 1, 3 trans(i,j,k) = r(l,j,k) 420 continue 430 continue 440 continue c return c end c subroutine pgl(a,b,r,nc,ib,ihg) c C .. Scalar Arguments .. integer ihg, nc C .. C .. Array Arguments .. double precision a(3,3), b(3,3), r(49,3,3) integer ib(48) C .. C .. Local Scalars .. double precision eps, tr integer i, ihc, j, k, lx, n, nr C .. C .. Local Arrays .. double precision vr(3), xa(3) C .. C .. External Subroutines .. external rlv, rot C .. C .. Intrinsic Functions .. intrinsic abs C .. c c eps should be slightly larger than computer precision c eps = 1.0d-8 ihc = 0 c c ihc is 0 for hexagonal groups and 1 for cubic groups. c nr = 24 10 continue nc = 0 call rot(r,nr) do 60 n = 1, nr ib(n) = 0 tr = 0.0d0 do 50 k = 1, 3 do 30 i = 1, 3 xa(i) = 0.0d0 do 20 j = 1, 3 xa(i) = xa(i) + r(n,i,j)*a(j,k) 20 continue 30 continue call rlv(b,xa,vr,lx) do 40 i = 1, 3 tr = tr + abs(vr(i)) 40 continue 50 continue if (tr .le. 10.0D0*eps) then nc = nc + 1 ib(nc) = n end if 60 continue if (ihc .eq. 0) then if (nc .eq. 12) then ihg = 6 c return c end if if (nc .gt. 12) then ihg = 7 c return c end if if (nc .lt. 12) then nr = 48 ihc = 1 c go to 10 c end if else if (nc .eq. 16) then ihg = 4 c return c end if if (nc .gt. 16) then ihg = 5 c return c end if if (nc .lt. 16) then if (nc .eq. 4) then ihg = 2 c return c end if if (nc .gt. 4) then ihg = 3 c return c end if if (nc .lt. 4) then ihg = 1 c return c end if end if end if c c ihg stands for holohedral group number. c end c subroutine rot(r,nr) c C .. Scalar Arguments .. integer nr C .. C .. Array Arguments .. double precision r(49,3,3) C .. C .. Local Scalars .. double precision f integer i, j, k, n, nv C .. C .. Intrinsic Functions .. intrinsic sqrt C .. do 30 n = 1, nr do 20 i = 1, 3 do 10 j = 1, 3 r(n,i,j) = 0.0d0 10 continue 20 continue 30 continue c if (nr .le. 24) then c c define the generators for the rotation matrices c --hexagonal group c f = sqrt(3.0d0)/2.0d0 r(2,1,1) = 0.5d0 r(2,1,2) = -f r(2,2,1) = f r(2,2,2) = 0.5d0 r(7,1,1) = -0.5d0 r(7,1,2) = -f r(7,2,1) = -f r(7,2,2) = 0.5d0 do 40 n = 1, 6 r(n,3,3) = 1.0d0 r(n+18,3,3) = 1.0d0 r(n+6,3,3) = -1.0d0 r(n+12,3,3) = -1.0d0 40 continue c c generate the rest of the rotation matrices c do 70 i = 1, 2 r(1,i,i) = 1.0d0 do 60 j = 1, 2 r(6,i,j) = r(2,j,i) do 50 k = 1, 2 r(3,i,j) = r(3,i,j) + r(2,i,k)*r(2,k,j) r(8,i,j) = r(8,i,j) + r(2,i,k)*r(7,k,j) r(12,i,j) = r(12,i,j) + r(7,i,k)*r(2,k,j) 50 continue 60 continue 70 continue do 100 i = 1, 2 do 90 j = 1, 2 r(5,i,j) = r(3,j,i) do 80 k = 1, 2 r(4,i,j) = r(4,i,j) + r(2,i,k)*r(3,k,j) r(9,i,j) = r(9,i,j) + r(2,i,k)*r(8,k,j) r(10,i,j) = r(10,i,j) + r(12,i,k)*r(3,k,j) r(11,i,j) = r(11,i,j) + r(12,i,k)*r(2,k,j) 80 continue 90 continue 100 continue c do 130 n = 1, 12 nv = n + 12 do 120 i = 1, 2 do 110 j = 1, 2 r(nv,i,j) = -r(n,i,j) 110 continue 120 continue 130 continue else c c define the generators for the rotation matrices c --cubic group c r(9,1,3) = 1.0d0 r(9,2,1) = 1.0d0 r(9,3,2) = 1.0d0 r(19,1,1) = 1.0d0 r(19,2,3) = -1.0d0 r(19,3,2) = 1.0d0 do 160 i = 1, 3 r(1,i,i) = 1.0d0 do 150 j = 1, 3 r(20,i,j) = r(19,j,i) r(5,i,j) = r(9,j,i) do 140 k = 1, 3 r(2,i,j) = r(2,i,j) + r(19,i,k)*r(19,k,j) r(16,i,j) = r(16,i,j) + r(9,i,k)*r(19,k,j) r(23,i,j) = r(23,i,j) + r(19,i,k)*r(9,k,j) 140 continue 150 continue 160 continue do 190 i = 1, 3 do 180 j = 1, 3 do 170 k = 1, 3 r(6,i,j) = r(6,i,j) + r(2,i,k)*r(5,k,j) r(7,i,j) = r(7,i,j) + r(16,i,k)*r(23,k,j) r(8,i,j) = r(8,i,j) + r(5,i,k)*r(2,k,j) r(10,i,j) = r(10,i,j) + r(2,i,k)*r(9,k,j) r(11,i,j) = r(11,i,j) + r(9,i,k)*r(2,k,j) r(12,i,j) = r(12,i,j) + r(23,i,k)*r(16,k,j) r(14,i,j) = r(14,i,j) + r(16,i,k)*r(2,k,j) r(15,i,j) = r(15,i,j) + r(2,i,k)*r(16,k,j) r(22,i,j) = r(22,i,j) + r(23,i,k)*r(2,k,j) r(24,i,j) = r(24,i,j) + r(2,i,k)*r(23,k,j) 170 continue 180 continue 190 continue do 220 i = 1, 3 do 210 j = 1, 3 do 200 k = 1, 3 r(3,i,j) = r(3,i,j) + r(5,i,k)*r(12,k,j) r(4,i,j) = r(4,i,j) + r(5,i,k)*r(10,k,j) r(13,i,j) = r(13,i,j) + r(23,i,k)*r(11,k,j) r(17,i,j) = r(17,i,j) + r(16,i,k)*r(12,k,j) r(18,i,j) = r(18,i,j) + r(16,i,k)*r(10,k,j) r(21,i,j) = r(21,i,j) + r(12,i,k)*r(15,k,j) 200 continue 210 continue 220 continue do 250 n = 1, 24 nv = n + 24 do 240 i = 1, 3 do 230 j = 1, 3 r(nv,i,j) = -r(n,i,j) 230 continue 240 continue 250 continue end if c end c subroutine rlv(p,g,y,l) c C .. Scalar Arguments .. integer l C .. C .. Array Arguments .. double precision g(3), p(3,3), y(3) C .. C .. Local Scalars .. double precision eps, ts integer i, j C .. C .. Local Arrays .. double precision del(3) C .. C .. Intrinsic Functions .. intrinsic abs, nint C .. c c eps should be slightly larger than computer precision c eps = 1.0d-8 l = 0 ts = 0.0d0 do 10 i = 1, 3 del(i) = 0.0d0 y(i) = 0.0d0 ts = ts + abs(g(i)) 10 continue c if (ts.le.eps) go to 40 do 30 i = 1, 3 do 20 j = 1, 3 y(i) = y(i) + p(i,j)*g(j) 20 continue c if (y(i).gt.0.9) del(i)=eps c if (y(i).lt.-0.9) del(i)=-eps c del is added to eliminate roundoff errors in the function amod. c y(i)=y(i)+del(i) l = l + nint(abs(y(i))) y(i) = y(i) - 1.0d0*nint(y(i)) c 30 y(i)=y(i)+del(i) 30 continue c c 40 continue c return c end c spinpwpaw/code/grrp.f900100664004704100470410000004116110371153065015143 0ustar natalienatalie!****************************************************************************** ! ! File : grrp.f90 ! by : Alan Tackett ! on : 11/02/97 ! for : PAW ! ! This file containsthe routines needed to perform the Generalized Rayleigh ! Ritz projections for determining the new Psi's and eigenvalues. Also ! routines are included to perform the Back-Rotations. ! !****************************************************************************** Module grrp Use paw_inout Use mem_data Use memmgr Use psilib Use fileio Use paw_inout Use search_sort Use hamiltonian Use debug !USe xlfutility Implicit NONE!!!!!!!!!!!!! !****************************************************************************** Contains !****************************************************************************** ! ! Diagonalizer - Diagonalizes Hbase & OBase matrices ! ! VecSize - Number of basis vectors used to construct Hbase, OBase ! ArraySize - Dimension of Hbase, OBase ! NewSize - Number of EigenValues and EigenVectors returned ! Eigen - List of EigenValues ! Vec - MAtrix containing the new eigenvectors ! DoOrthog - If true, assume Obase is identity matrix ! Hbase, Obase - Assumed to be Hermitian ! !****************************************************************************** Subroutine Diagonalizer(DoOrthog, VecSize, ArraySize, NewSize, Hbase, Obase, & Eigen, Vec) Logical, Intent(IN) :: DoOrthog Integer, Intent(IN) :: VecSize Integer, Intent(IN) :: ArraySize Integer, Intent(OUT) :: NewSize Complex, Intent(INOUT) :: Hbase(:,:) Complex, Intent(INOUT) :: Obase(:,:) Real, Intent(OUT) :: Eigen(:) Complex, Intent(OUT) :: Vec(:,:) Integer :: Kindex, i, j, k, LWork, LSize Integer :: Info ! Complex :: Omat(ArraySize,ArraySize) ! Complex :: Hmat(ArraySize, ArraySize), VecR(ArraySize, ArraySize) ! Complex :: Work(4*ArraySize), JUNK(ArraySize,ArraySize) Complex, allocatable :: Omat(:,:),Hmat(:,:),VecR(:,:),Work(:),JUNK(:,:) ! Real :: RWork(8*ArraySize), val, Lambda(ArraySize) Real ,allocatable :: RWork(:), Lambda(:) Real :: tol,val Allocate(Hmat(ArraySize, ArraySize), VecR(ArraySize, ArraySize), & Omat(ArraySize, ArraySize), Work(4*ArraySize), & JUNK(ArraySize,ArraySize), RWork(8*ArraySize), Lambda(ArraySize)) tol=Overlap_tol Call PrintDate(Log_Unit,'Diagonalizer: START') !Call flush(Log_Unit) LWork = 4*ArraySize NewSize=VecSize ! val = MAXVAL(ABS(CONJG(Hbase)*Hbase)) ! val = SQRT(ABS(val)) !Write(Log_Unit,*) 'GRRP: MAXVAL(Hmat) check=',val !Call flush(Log_Unit) !!Write(*,*) 'GRRP: MAXVAL(Hmat) check=',val ! val = MAXVAL(ABS(CONJG(Obase)*Obase)) ! val = SQRT(ABS(val)) !Write(Log_Unit,*) 'GRRP: MAXVAL(Omat) check=',val !Call flush(Log_Unit) !!Write(*,*) 'GRRP: MAXVAL(Omat) check=',val !val = SUM(ABS(AImag(Hbase))) !Call flush(Log_Unit) !Write(Log_Unit,*) 'GRRP: IMAG Hmat check=',val !val = SUM(ABS(AImag(Obase))) !Write(Log_Unit,*) 'GRRP: IMAG Omat check=',val !Call flush(Log_Unit) !write(LOg_Unit,*) 'in diag',vecsize,arraysize !Call flush(Log_Unit) Work = 0; Rwork = 0; Hmat = Hbase; Omat = Obase; VecR = 0 Hmat = Hbase; Omat = Obase Info =13; NewSize=VecSize If (DoOrthog) then ! Omat is not diagonal If (.not.Calc_O_Eigenvalues) then Call ZHEGV(1, 'V', 'U', VecSize, Hmat(1,1), ArraySize, & Omat(1,1), ArraySize, Eigen, Work, Lwork, Rwork, Info) write(Log_Unit,*) ' completed zhegv with Info=',Info !Call flush(Log_Unit) If (Info.ne.0) then Hmat=Hbase; Omat=Obase EndIf EndIf If (Info.ne.0) then Call ZHEEV('V', 'U', VecSize, Omat(1,1), ArraySize, Lambda, & Work, LWork, Rwork, Info) write(Log_Unit,*) ' completed Omat diagonalization with Info=',Info j=0 ; VecR=0 Do i=1,VecSize write(Log_Unit,*) 'i lambda',i,Lambda(i) If (Lambda(i) > tol) then j=j+1 VecR(1:VecSize,j)=Omat(1:VecSize,i)/SQRT(Lambda(i)) EndIf Enddo If (j > 0) then NewSize=j Else Write(Log_Unit,*) 'GRRP - O matrix is singular', Lambda Stop Endif Write(Log_Unit,*) 'GRRP - NewSize = ',NewSize ! Omat=0 ! Omat=MATMUL(Hmat(1:VecSize,1:VecSize),VecR(1:VecSize,1:NewSize)) !!!!!Following code replaces fortran MATMUL which is too slow Omat=0 do k=1,NewSize do i=1,VecSize ! Omat(i,k)=0 do j=1,VecSize Omat(i,k)=Omat(i,k)+CONJG(Hmat(j,i))*VecR(j,k) Enddo Enddo Enddo !End Replace MATMUL ! JUNK=0 ! JUNK=TRANSPOSE(CONJG(VecR(1:VecSize,1:NewSize))) ! Hmat=0 ! Hmat=MATMUL(JUNK(1:NewSize,1:VecSize),Omat(1:VecSize,1:newSize)) !!!!!Following code replaces fortran MATMUL which is too slow Hmat=0 do k=1,NewSize do i=1,NewSize ! Hmat(i,k)=0 Do j=1,VecSize Hmat(i,k)=Hmat(i,k)+CONJG(VecR(j,i))*Omat(j,k) Enddo Enddo Enddo !End Replace MATMUL Call ZHEEV('V', 'U', NewSize, Hmat(1,1), ArraySize, Eigen, & Work, LWork, Rwork, Info) write(Log_Unit,*) ' completed Hmat diagonalization with Info=',Info Omat=Hmat ! Hmat=0 ! Hmat=MATMUL(VecR(1:VecSize,1:NewSize),Omat(1:NewSize,1:NewSize)) !!!!!Following code replaces fortran MATMUL which is too slow Hmat=0 JUNK(1:NewSize,1:VecSize)=TRANSPOSE(VecR(1:VecSize,1:NewSize)) do k=1,NewSize do i=1,VecSize ! Hmat(i,k)=0 Do j=1,NewSize Hmat(i,k)=Hmat(i,k)+JUNK(j,i)*Omat(j,k) Enddo Enddo Enddo !End Replace MATMUL EndIf else Call ZHEEV('V', 'U', VecSize, Hmat(1,1), ArraySize, Eigen, & Work, LWork, Rwork, Info) write(Log_Unit,*) ' completed Hmat diagonalization with Info=',Info End If ! Write(Log_Unit,*) 'GRRP - Eigen',Eigen(1:NewSize) Vec = Hmat Call PrintDate(Log_Unit,'Diagonalizer: END') !Call flush(Log_Unit) DeAllocate(Hmat,Omat,VecR,Work,JUNK,RWork,Lambda) Return End Subroutine !****************************************************************************** ! ! MakeNewPsi - Creates the New Psi's from the Old Psi's after a GRRP-BR ! ! BasisSize - Number of Basis Vectors ! KpntBands - Number of Bands for the K-point ! Vec - MAtrix containing the new eigenvectors ! Eigen - List of EigenValues ! LUT - LUT matching Disk Index to Vec, Eigen position ! ! 05/23/05 NAWH: updated for spin !****************************************************************************** Subroutine MakeNewPsi(BasisSize, KpntBands, Vec, Eigen, LUT,Kpnt) Integer, Intent(IN) :: BasisSize Integer, Intent(IN) :: KpntBands Complex, Intent(IN) :: Vec(:,:) Real, Intent(IN) :: Eigen(:) Integer, Intent(IN) :: LUT(:,:) Integer, Intent(IN) :: Kpnt Complex :: dot Integer :: i, LSize, ioerr, Kindex, CurrentSet(Mem_MapSize), j, LastGMRES, k ! Integer :: VecMap(Mem_MapSize), SU1, SU2, KpntIndex Integer :: SU1, SU2, KpntIndex Integer ,allocatable:: VecMap(:) Real :: Mag Character*100 :: msg ! Complex :: c, PDot(PLM_Max) Complex :: c Complex ,allocatable :: PDot(:) Complex, Pointer :: NewPSi(:), Ox(:), Work(:) Type(MEm_Handle), Pointer :: Psi, FAS, MH(:) Logical :: PDOT_Stored Allocate(VecMap(Mem_MapSize),PDot(PLM_Max)) Call Start_Timer(Timer(MakeNewPsi_Timer)) Call GetBuffer( NewPsi) Call GetBuffer( Ox) KpntIndex = 0 j = 0 Do i=1, KpntBands !**** Create NEw Psi's VecMap = MH_Skip !**** Make MAp of Psi's to use in construction VecMap(LUT(1,1:BasisSize)) = MH_toProcess Call Phase_Generic(VecMap, Kpnt) NewPsi = 0 Call GetNextPsi(KIndex, Psi) Do While (KIndex /= 0) NewPsi = NewPsi + Vec(LUT(2,Psi%index),i)*Psi%Ptr Call GetNExtPsi(Kindex, Psi) End Do Call GetNextFreeIndex(KpntIndex) PsiInfo(KpntIndex)%Kpnt=Kpnt PsiInfo(KpntIndex)%spinup=Global_spinup PsiInfo(KpntIndex)%DoSave=1 PsiInfo(KpntIndex)%Available=Mem_Used PsiInfo(KpntIndex)%Energy=Eigen(i) PsiInfo(KpntIndex)%PDOT_Stored=.false. PsiInfo(KpntIndex)%KE_Stored=.false. PDOT_Stored = .FALSE. call kplusGfilter(NewPsi,Kpnt) Call Opsi( NewPsi, Ox, PDot, Kpnt, PDOT_Stored) Mag = Basis_DotProd( Ox, NewPsi, .FALSE.) mag = SQRT(mag) Write(Log_Unit,*) 'MakeNewPsi: Mag=',Mag, ' * DI=',KpntIndex,' E=',Eigen(i) NewPsi = NewPsi/mag Call SavePsi_toBuffer(KpntIndex,NewPsi) End Do ! No longer need BasisSize entries PsiInfo(LUT(1,1:BasisSize))%Kpnt=0 PsiInfo(LUT(1,1:BasisSize))%spinup=.true. PsiInfo(LUT(1,1:BasisSize))%DoSave=0 PsiInfo(LUT(1,1:BasisSize))%Available=Mem_Available PsiInfo(LUT(1,1:BasisSize))%PDOT_Stored=.FALSE. PsiInfo(LUT(1,1:BasisSize))%KE_Stored=.FALSE. Do i = 1 , BasisSize j = PsiInfo(LUT(1,i))%MemBufIndex If (j > 0) then GlobalMap%Psi_Handle(j)%Index = 0 PsiInfo(LUT(1,i))%MemBufIndex=0 EndIf !write(log_unit,*) 'MakeNewPsi: released indices',i,LUT(1,i),j Enddo Call FreeBuffer(NewPsi) Call FreeBuffer(Ox) Call Stop_Timer(Timer(MakeNewPsi_Timer)) DeAllocate(VecMap,PDot) !write(Log_unit,*) 'complete MakeNewPsi' Return End Subroutine !****************************************************************************** ! ! PerfromGRRP_ALL - Performs a generalized Rayleigh-Ritz operation for current ! set of wave functions for the given kpoint ! ! LSize - LEvel Dimensions ! BlochK - Bloch Phase ! Vec_toProcess- List of Psi's to process ! VecSize - Number of Bands beign processed ! Eigen - List of EigenValues ! LUT - LUT matching Disk Index to Vec, Eigen position ! Vec - MAtrix containing the new eigenvectors ! ! !****************************************************************************** Subroutine PerformGRRP_All( Vec_toProcess, VecSize, & Vec, Eigen, LUT, NewSize, Kpnt) Integer, Intent(IN) :: VecSize Integer, Intent(IN) :: Vec_toProcess(:) Complex, Intent(OUT) :: Vec(:,:) Real, Intent(OUT) :: Eigen(:) Integer, Intent(OUT) :: LUT(:,:) Integer, Intent(OUT) :: NewSize Integer, Intent(IN) :: Kpnt Integer :: Kindex, i, j, k, LWork, PsiIndex, LUTIndex, LSize !Integer :: VecProcessed(Mem_MapSize), Info, ArraySize Integer :: Info, ArraySize Integer ,allocatable :: VecProcessed(:) Complex, Pointer :: Hx(:), KE(:), Ox(:) Complex, Pointer :: PsiWork(:),Ve(:) !Complex :: Hbase(VecSize,VecSize), Obase(VecSize, VecSize) Complex ,allocatable :: Hbase(:,:), Obase(:, :),PDot(:) !Complex :: Term, PDot(PLM_Max), E3 Complex :: Term, E3 Real :: val Type(Mem_Handle), Pointer :: Psi2 Allocate(VecProcessed(Mem_MapSize),Hbase(VecSize,VecSize), & Obase(VecSize, VecSize), PDot(PLM_Max)) Call PrintDate(Log_Unit,'PerformGRRP_ALL: START') ArraySize = VecSize !Write(Log_unit,*) 'GRRP: VecSize= ',VecSize, 'Kpnt=',Kpnt,' * Vec_toProcess=',Vec_toProcess !call flush(Log_unit) Call GetBuffer( PsiWork) Call GetBuffer( Hx) Call GetBuffer( Ox) LUT = 0 Hbase = 0 Obase = 0 if(Global_spinup) Ve =>SCFValues%Ve if(.not.Global_spinup) Ve =>SCFValues%Vespin Psi_toProcess = Vec_toProcess j = 0 !**** Make the LUT ***** Do i=1, Mem_MapSize If (Psi_toProcess(i) == MH_toProcess) then j = j + 1 LUT(1,j) = i LUT(2,i) = j write(log_unit,*)'PerformGRRP_ALL: LUT ',i,j call flush(log_unit) End If End Do !*** Initialize the Proj config and K-point to use *** !Write(Log_Unit,*) 'PerformGRRP_All: Kpnt=',Kpnt, ' * VTP=', Vec_toProcess Call Phase_Generic( Vec_toProcess, Kpnt) VecProcessed = Vec_toProcess Do i=1, VecSize Call GetNextPsi_UnProcessed(KIndex, VecProcessed, & PsiIndex, PsiWork) Call SavePsi_toBuffer(PsiIndex , PsiWork) Call CalcHxandOx( PsiWork, Hx, Ox, Ve, & PSiInfo(PsiIndex)%PDOT, Kpnt, PSiInfo(PsiIndex)%PDOT_Stored) PsiIndex = LUT(2,PsiIndex) !** Get the LUT index Hbase(PsiIndex, PsiIndex) = Basis_DotProd( Hx, PsiWork, .FALSE.) Obase(PsiIndex, PsiIndex) = Basis_DotProd( Ox, PsiWork, .FALSE.) Do j=1, i-1 Call GetNextPsi(Kindex, Psi2) k = LUT(2, Psi2%Index) !** Get the LUT index Term = Basis_DotProd( Hx, Psi2%Ptr, .FALSE.) Hbase(PsiIndex, k) = Term Hbase(K, PsiIndex) = CONJG(Term) Term = Basis_DotProd( Ox, Psi2%Ptr, .FALSE.) Obase(PsiIndex, k) = Term Obase(K, PsiIndex) = CONJG(Term) End Do End Do val = MAXVAL(ABS(CONJG(Hbase)*Hbase)) val = SQRT(ABS(val)) Write(Log_Unit,*) 'GRRP: MAXVAL(Hmat) check=',val !Write(*,*) 'GRRP: MAXVAL(Hmat) check=',val val = MAXVAL(ABS(CONJG(Obase)*Obase)) val = SQRT(ABS(val)) Write(Log_Unit,*) 'GRRP: MAXVAL(Omat) check=',val !val = SUM(ABS(AImag(Hbase))) !Write(Log_Unit,*) 'GRRP: IMAG Hmat check=',val !val = SUM(ABS(AImag(Obase))) !Write(Log_Unit,*) 'GRRP: IMAG Omat check=',val !Write(Log_Unit,*) 'GRRP: VecSize=',VecSize, ' * Vec_toProcess=',Vec_toProcess !Write(Log_Unit,*) 'GRRP: LUT(1,:)=',LUT(1,1:VecSize) !Write(Log_Unit,*) 'GRRP: Printing Hmat-----------------------------------' !Do i=1, VecSize ! Write(Log_Unit,*) 'GRRP: Row=',i ! Write(Log_Unit,*) 'GRRP: H(i,:)=',Hbase(i,:) !End Do !Write(Log_Unit,*) 'GRRP: Printing Omat-----------------------------------' !Do i=1, VecSize ! Write(Log_Unit,*) 'GRRP: Row=',i ! Write(Log_Unit,*) 'GRRP: O(i,:)=',Obase(i,:) !End Do Call Diagonalizer(.true. , VecSize, VecSize, NewSize, Hbase, Obase, & Eigen, Vec) Call FreeBuffer(PsiWork) Call FreeBuffer(Hx) Call FreeBuffer(Ox) Call PrintDate(Log_Unit,'PerformGRRP_ALL: End') DeAllocate(VecProcessed,Hbase,Obase,PDot) Return End Subroutine !****************************************************************************** ! ! UpdateKpnt - Updates the Wave functions for a given Kpnt ! ! Kpnt - Kpnt index ! VecSize - Number of Psi's for the kpoint ! Basis_toProcess - List of Psi's to process ! !****************************************************************************** Subroutine UpdateKpnt( Kpnt, VecSize, Basis_toProcess) Integer, Intent(IN) :: Kpnt Integer, Intent(IN) :: VecSize Integer, Intent(IN) :: Basis_toProcess(:) ! Complex :: Vec(VecSize, VecSize) Complex ,allocatable :: Vec(:,:) !Real :: Eigen(VecSize) Real ,allocatable :: Eigen(:) !Integer :: LUT(2,Mem_MapSize), KpntBands, i, NewSize Integer :: KpntBands, i, NewSize Integer ,allocatable :: LUT(:,:) Allocate(Vec(VecSize, VecSize),Eigen(VecSize),LUT(2,Mem_MapSize)) KpntBands = 0 Do i=1, Mem_MapSize If ((PsiInfo(i)%Kpnt == Kpnt) .AND. (CLusterMap(i) > 0) & .and.(PsiInfo(i)%spinup.eqv.Global_spinup)) then KpntBands = KpntBands + 1 End If End Do Call PerformGRRP_ALL( Basis_toProcess, KpntBands, & Vec, Eigen, LUT, NewSize, Kpnt) Call MakeNewPsi( KpntBands, NewSize, Vec, Eigen, LUT, Kpnt) DeAllocate(Vec,Eigen,LUT) write(Log_Unit,*) 'completed updatekpnt' Return End Subroutine !****************************************************************************** ! ! MiniDiag -- Recalculate basis for given k and spin ! ! Kpnt - Kpnt index ! VecSize - Number of Psi's for the kpoint ! Basis_toProcess - List of Psi's to process ! !****************************************************************************** Subroutine MiniDiag( Kpnt, VecSize, Basis_toProcess) Integer, Intent(IN) :: Kpnt Integer, Intent(IN) :: VecSize Integer, Intent(IN) :: Basis_toProcess(:) ! Complex :: Vec(VecSize, VecSize) Complex ,allocatable :: Vec(:,:) !Real :: Eigen(VecSize) Real ,allocatable :: Eigen(:) !Integer :: LUT(2,Mem_MapSize), KpntBands, i, NewSize Integer :: KpntBands, i, NewSize Integer ,allocatable :: LUT(:,:) Allocate(Vec(VecSize, VecSize),Eigen(VecSize),LUT(2,Mem_MapSize)) KpntBands = 0 Do i=1, Mem_MapSize If ((PsiInfo(i)%Kpnt == Kpnt) & .and.(PsiInfo(i)%spinup.eqv.Global_spinup)) then KpntBands = KpntBands + 1 End If End Do If (KpntBands > VecSize ) then Write(Error_unit,*) 'MiniDiag: error in MiniDiag', Kpnt,KpntBands,VecSize stop Endif Call PerformGRRP_ALL( Basis_toProcess, KpntBands, & Vec, Eigen, LUT, NewSize, Kpnt) Call MakeNewPsi( KpntBands, NewSize, Vec, Eigen, LUT, Kpnt) DeAllocate(Vec,Eigen,LUT) write(Log_Unit,*) 'completed updatekpnt' Return End Subroutine End Module spinpwpaw/code/hamfunc.f900100664004704100470410000003121110303710172015576 0ustar natalienatalie!****************************************************************************** ! ! File : hamfunc.f90 ! originally from hamiltonian.f90 ! by : Alan Tackett ! on : 02/07/97 ! for : PAW ! ! Module for calculating the Hamiltonian and Cohesive Energy of the PAW ! system. Also contains routines to do H*Psi and O*Psi. ! ! Contains relatively simple functions in construction of Hamiltonian ! terms ! ! Updated for spin by Ping Tang and N. A. W. Holzwarth ! Last change 5/25/05 !****************************************************************************** Module hamfunc Use atom_data Use crystal_symmetry Use gausslib Use gpoints Use mathlib Use options_data Use paw_inout Implicit NONE!!!! !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! RestrictPot - Restricts the potential from the High planewave grid to the ! low cutoff grid in FFT space. ! ! Vin - High PW grid in FFT space(Input) ! Vout - Low PW grid in FFT space(Returned) ! !****************************************************************************** Subroutine RestrictPot( Vin, Vout) Complex, Intent(IN) :: Vin(:) Complex, Intent(OUT) :: Vout(:) Integer :: i, N_low, N_high real :: weight, Ec Ec = PW_Gcut(G_PROJ)*(1-V_Smooth_width) N_low = Gpnt_Size(G_PROJ) - 1 N_High = Gpnt_Size(G_HIGH) - 1 Vout = 0 Write(Log_Unit,*) 'RestrictPot: PW_Gcut=',PW_Gcut, ' * V_Smooth_Width=',V_Smooth_Width Vout(FFTmap_PROJ(1)) = Vin(FFTmap_High(1)) Do i=2, Gpnt_size(G_PROJ) ! If (V_Smooth_Width > 0.0) then ! weight = abs(Gpnt(4,i)-PW_Gcut(G_PROJ))/(PW_Gcut(G_Proj)*V_Smooth_Width) ! weight = 2.0/(exp(-weight) + 1.0) - 1 ! else ! Weight = 1 ! End if Weight = 1 If (Gpnt(4,i) > Ec) then Weight = Pi*(PW_Gcut(G_PROJ) - Gpnt(4,i)) / & (2*V_Smooth_Width*PW_Gcut(G_PROJ)) Weight = sin(weight)**2 End if !Write(Log_Unit,*) 'RestrictPot: i=',i, ' * |G|=',Gpnt(4,i), ' * Wt=',weight !weight = 1 Vout(FFTmap_HIGH(i)) = Vin(FFTmap_High(i)) * Weight Vout(FFTmap_HIGH(i+N_HIGH)) = Vin(FFTmap_High(i+N_High)) * Weight End Do Return End Subroutine !****************************************************************************** ! ! CalcVlocal - Calculates Vlocal ! !****************************************************************************** Subroutine CalcVlocal(V) Complex, Intent(INOUT) :: V(:) Real :: theta, Gmag, RadG, G(3), Esum Complex :: Phase, Vsum Integer :: atom, atype, lut, gindex, RadIndex, fi Type (Atom_Info_Fixed), Pointer :: AT V = 0 RadIndex = 0 Do gindex=1, Gpnt_Size(G_HIGH) G = Gpnt(1:3,gindex) Gmag = Gpnt(4,gindex) !*** If needed inc the RadIndex *** If (G_NewMag(gindex)) RadIndex = RadIndex + 1 Vsum = 0 Do atype=1, Atom_Types AT => AtomType_Info(atype) RadG = AT%Rad_VLocal(RadIndex) !*** Create the structure factors and accumulate vlocal*** Do lut = AtomType_Range(1,atype), AtomType_range(2,atype) atom = Atomtype_map(lut) theta = DOT_PRODUCT(G, Atom_List(atom)%Pos) Phase = CMPLX(cos(theta), -sin(theta)) !Phase = CONJG(Phase) Vsum = Vsum + Phase*RadG End Do End do V(gindex) = V(gindex) + Vsum End Do Return End Subroutine !****************************************************************************** ! ! function spheresymFT ! !****************************************************************************** Function spheresymFT(ngrid,radialfn,Gmag,dr) Real :: spheresymFT Integer, INTENT(IN) :: ngrid Real, INTENT(IN) :: radialfn(:),Gmag,dr Real, allocatable :: fn(:) Integer :: i Real :: r, con,x con = Four_Pi Allocate(fn(ngrid)) do i=1,ngrid r=dr*(i-1) x=r if (Gmag > machine_precision) x=SIN(Gmag*r)/Gmag fn(i) = con*r*radialfn(i)*x End do spheresymFT=IntSimpson(ngrid,dr,fn) deallocate(fn) End Function spheresymFT Subroutine CalcCoreTail(V) Complex, INTENT(OUT) :: V(:) Real :: theta, Gmag, RadG, G(3), Esum,dr Complex :: Phase, Vsum Integer :: atom, atype, lut, gindex, RadIndex, fi,ngrid,i,j Type (Atom_Info_Fixed), Pointer :: AT Write(Log_unit,*) 'In CalcCoreTail',size(V) Do atype=1, Atom_Types AT => AtomType_Info(atype) Allocate(AT%FTCoreTail(NewMag_Size(G_High)), STAT=j) if (j /= 0) then write(Error_unit,*) 'Error CalcCoreTail: allocation ', & NewMag_Size(G_High),atype,j stop endif AT%FTCoreTail=0 dr= AT%Mesh_Step ngrid=AT%CoreTail_Points Radindex=0 Do gindex=1, Gpnt_Size(G_HIGH) If (G_NewMag(gindex)) then Gmag = Gpnt(4,gindex) RadG = spheresymFT(ngrid,AT%CoreTail_Density,Gmag,dr) RadIndex=RadIndex+1 AT%FTCoreTail(RadIndex)=RadG Endif Enddo Enddo V=0; Radindex=0 Do gindex=1, Gpnt_Size(G_HIGH) G = Gpnt(1:3,gindex) If (G_NewMag(gindex)) Radindex=Radindex+1 Vsum = 0 Do atype=1, Atom_Types AT => AtomType_Info(atype) !*** Create the structure factors and accumulate vlocal*** Do lut = AtomType_Range(1,atype), AtomType_range(2,atype) atom = Atomtype_map(lut) theta = DOT_PRODUCT(G, Atom_List(atom)%Pos) Phase = CMPLX(cos(theta), -sin(theta)) Vsum = Vsum + Phase*AT%FTCoreTail(RadIndex) End Do End do V(gindex)=Vsum End Do End Subroutine Subroutine UpdateCoreTail(V) Complex, INTENT(OUT) :: V(:) Real :: theta, Gmag, RadG, G(3), Esum,dr Complex :: Phase, Vsum Integer :: atom, atype, lut, gindex, RadIndex, fi,ngrid,i,j Type (Atom_Info_Fixed), Pointer :: AT Write(Log_unit,*) 'In UpdateCoreTail',size(V) V=0; Radindex=0 Do gindex=1, Gpnt_Size(G_HIGH) G = Gpnt(1:3,gindex) If (G_NewMag(gindex)) Radindex=Radindex+1 Vsum = 0 Do atype=1, Atom_Types AT => AtomType_Info(atype) !*** Create the structure factors and accumulate coretail*** Do lut = AtomType_Range(1,atype), AtomType_range(2,atype) atom = Atomtype_map(lut) theta = DOT_PRODUCT(G, Atom_List(atom)%Pos) Phase = CMPLX(cos(theta), -sin(theta)) Vsum = Vsum + Phase*AT%FTCoreTail(RadIndex) End Do End do V(gindex)=Vsum End Do End subroutine !****************************************************************************** ! ! CalcRadial_Vlocal - Calculates the radial Vlocal grids ! !****************************************************************************** Subroutine CalcRadial_Vlocal Integer :: i,j, k, G, Gmag, n, L,ngrid Character*200 :: Token Real, Pointer :: RadV(:),fn(:) Real :: dr, r, norm,xmax,gmax,con Type (Atom_Info_Fixed), Pointer :: AT con = Four_Pi/Xtal%volume L=0 ! L=0 for Vlocal ngrid=MAXVAL(AtomType_Info(:)%Mesh_Size) Allocate(fn(ngrid)) Do i=1, Atom_Types AT => AtomType_Info(i) Allocate(AT%Rad_Vlocal(NewMag_Size(G_High)), STAT=j) Write(Token,*) 'CalcRadial_Vlocal: Error allocating array. Size=',& NewMag_Size(G_HIGH), ' * TypeIndex=',i Call Check_Error(j, Token, Error_Unit, .TRUE., PAW_WC,'CalcRadial_Vlocal:') RadV => AT%Rad_Vlocal RadV = 0 If (Atomic_Mode == SIM_SEPM) then k = 0 con = 1.0 /xtal%volume Do j=1, Gpnt_Size(G_HIGH) If (G_NewMag(j)) then k = k + 1 RadV(k) = EvalGauss(AT%V_sepm, Gpnt(4,j)) * con End If End Do else ! norm = con*AT%V_Local norm = con if (ABS(norm).gt.1.d-9) then DR=AT%Mesh_Step write(6,*) 'CalcRadial_Vlocal: DR',DR !*** Tabulate the vlocal function *** Do j=1, AT%Mesh_Size r = DR*(j-1) !Fn(j) = norm*r*AT%Shape_Func(j) Fn(j) = norm*r*AT%RadR_Vlocal(j) End do k = 0 Do j=1, Gpnt_Size(G_HIGH) If (G_NewMag(j)) then k = k + 1 !RadV(k) = RadialFourier(L, Gpnt(4,j), DR, AT%Mesh_Size, fn) RadV(k) = spheresymFT(AT%Mesh_Size,& AT%RadR_Vlocal,Gpnt(4,j),dr)/xtal%volume End If End Do Endif End If End Do Deallocate(fn) Return End Subroutine !****************************************************************************** ! ! CalcRadialHat - Calculates the radial n^ grids ! !****************************************************************************** Subroutine CalcRadialHat Integer :: i,j, k, G, Gmag, n, L, ngrid Character*200 :: Token Real, Pointer :: RadHat(:),fn(:) Real :: dr, r, norm,xmax,gmax Type (Atom_Info_Fixed), Pointer :: AT ngrid=MAXVAL(AtomType_Info(:)%Mesh_Size) Allocate(fn(ngrid)) Do i=1, Atom_Types AT => AtomType_Info(i) AT%Hat_MaxL = 2*MaxVal(AT%L_Value) Allocate(AT%RadHat(NewMag_Size(G_High), AT%Hat_MaxL+1), STAT=j) Write(Token,*) 'CalcRadialHat: Error allocating array. Size=',& NewMag_Size(G_HIGH), ' * ', AT%Basis_Size, ' * TypeIndex=',i Call Check_Error(j, Token, Error_Unit, .TRUE., PAW_WC, 'CalcRadialHat:') DR=AT%Mesh_Step !write(6,*) 'CalcRadHat: DR',DR Do L=0, AT%Hat_MaxL RadHat => AT%RadHat(:,L+1) n=AT%Mesh_Size do j=1,n fn(j)=((dr*(j-1))**(2*L+2))*AT%Shape_Func(j) enddo norm = sqrt(Four_Pi)/IntSimpson(n, DR, fn) !*** Tabulate the hat function *** Do j=1, n r = DR*(j-1) Fn(j) = norm * AT%Shape_Func(j) * r**(L+1) End do k = 0 Do j=1, Gpnt_Size(G_HIGH) If (G_NewMag(j)) then k = k + 1 RadHat(k) = RadialFourier(L, Gpnt(4,j), DR, n, fn) !write(6,'("radhat",2i4,1p2e15.7)') k,L,Gpnt(4,j),radHat(k) End If End Do End Do End Do Deallocate(fn) Return End Subroutine !****************************************************************************** ! ! CalcKineticEnergy - Calculates the KE for the given Psi nad K-pnt ! ! BlochK - K-Point ! Psi - Wave function ! !****************************************************************************** Real Function CalcKineticEnergy(BlochK, Psi) Real, Intent(IN) :: BlochK(:) Complex, Intent(IN) :: Psi(:) Integer :: gi, N Real :: G(3), G2 Complex :: KE N = Gpnt_Size(G_LOW) - 1 KE = 0 Do gi=1, Gpnt_Size(G_LOW) G = BlochK + Gpnt(1:3,gi) G2 = DOT_PRODUCT(G,G) KE = KE + CONJG(Psi(gi))*Psi(gi) * G2 End Do Do gi=2, Gpnt_Size(G_LOW) G = BlochK - Gpnt(1:3,gi) G2 = DOT_PRODUCT(G,G) KE = KE + CONJG(Psi(gi+N))*Psi(gi+N) * G2 End Do CalcKineticEnergy = KE Return End function End Module spinpwpaw/code/hamiltonian.f900100664004704100470410000022262010371153074016475 0ustar natalienatalie!****************************************************************************** ! ! File : hamiltonian.f90 ! by : Alan Tackett ! on : 02/07/97 ! for : PAW ! ! Module for calculating the Hamiltonian and Cohesive Energy of the PAW ! system. Also contains routines to do H*Psi and O*Psi. ! ! Contains CalcHam and supporting routines ! ! Updated for spin by Ping Tang and N. A. W. Holzwarth ! Last change 5/23/05 !****************************************************************************** Module hamiltonian Use anderson_mixing Use atom_data Use basis_lib Use coulomb_pack Use crystal_data Use denvhat_pack Use doijmatrix Use gausslib Use gpoints Use hamfunc Use hamsym Use hamvxc Use laplacian Use mathlib Use mem_data Use memmgr Use misc Use options_data Use orbital_pack Use paw_inout Use projectors Use spherical_harmonic Use psilib Use search_sort Use vhartree_pack Use word Use work_mgr !**Use atom_charge Implicit NONE!!!! Integer, Pointer :: BandMap(:,:) Real :: Diag_Energy !** K+V_ion energy Real :: hat_Energy !** V^ + E^ energy Real :: Hartree_Energy !** Hartree energy Real :: OneExc_Energy !** Exchange-correlation energy in AccumVxc Real :: TildeKE_Energy !** KE energy for smooth hamiltonian Real :: TildePot_Energy !** Pot energy for smooth hamiltonian Real :: TildeXC_Energy !** XC energy for smooth hamiltonian Real :: Hat_Hat_Energy !** Coulomb interaction for Hat-Hat Real :: Prev_CohesiveEnergy(2) Complex, Pointer :: Work_Dij(:), Work_Dijspin(:) !** Work array for mixing Dij's !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! CalcWij - Calculates the Wij coefficients ! ! PDot - Projector times Psi products. The indices of PDot are as follows: ! ! PDOT(atom, +/-M, ProjIndex, Band, Kpnt) ! ! Where 1=+M and 2=-M ! ! !****************************************************************************** Subroutine CalcWij(PDot) Complex, Intent(IN) :: PDot(:,:,:) complex :: sum1,sum2 ! test Integer :: Base, i, j, a ,N,NN Complex, Pointer :: Wij(:,:) sum1=0 !test Do a=1, Specific_Atoms Wij => Atom_List(a)%Wij Wij = 0 !write(Log_unit,*)'CalcWij: a = ',a,PLM_AtomRange(1,a),PLM_AtomRange(2,a) !call flush(log_unit) Base = PLM_AtomRange(1,a) - 1 Do i=PLM_AtomRange(1,a), PLM_AtomRange(2,a) Do j=PLM_AtomRange(1,a), PLM_AtomRange(2,a) Wij(i-Base, j-Base) = & SUM(CONJG(PDot(i,1:Numbands,:))*PDot(j,1:Numbands,:)& *Occupancy(1:Numbands,:)) !write(log_unit,*) 'CalcWij', i,j,Wij(i-Base,j-Base) !call flush(log_unit) End Do End Do ! i=AtomType_Info(Atom_List(a)%TypeIndex)%nlm_Size !!testing ! sum2=SUM(Wij(1:i,1:i)*AtomType_Info(Atom_List(a)%TypeIndex)%Oij(1:i,1:i)) ! write(Log_Unit,*) 'test Wij for atom',a,sum2 !!testing ! sum1=sum1+sum2 !!testing End Do write(log_unit,*) 'CalcWij: finished s=1' call flush(log_unit) if(spindependence ) then N=Numbands+1;NN=2*Numbands write(log_unit,*) 'CalcWij: N,NN ', N,NN Do a=1, Specific_Atoms Wij => Atom_List(a)%Wijspin Wij = 0 write(Log_unit,*)'CalcWij: a = ',a,PLM_AtomRange(1,a),PLM_AtomRange(2,a) call flush(log_unit) Base = PLM_AtomRange(1,a) - 1 Do i=PLM_AtomRange(1,a), PLM_AtomRange(2,a) Do j=PLM_AtomRange(1,a), PLM_AtomRange(2,a) Wij(i-Base, j-Base) = SUM(CONJG(PDot(i,N:NN,:))*PDot(j,N:NN,:)& *Occupancy(N:NN,:)) write(log_unit,*) 'CalcWij', i,j,Wij(i-Base,j-Base) call flush(log_unit) End Do End Do End Do end if ! write(Log_Unit,*) 'total wij*Oij test', sum1 !! testing Return End Subroutine !****************************************************************************** ! a ! CalcQlm - Calculates the Q coefficients according to eq. A22 and ! LM ! ! also accumulates the Qlm term in eq. A28 to dEdQlm ! !****************************************************************************** Subroutine CalcQlm(energy) Real, Intent(INOUT) :: Energy Integer :: i, j, k, Qlm_Size, Offset_Q Integer :: nili, njlj, mi, mj, M, L, Li, Lj, ibase, jbase Integer, Pointer :: LUT_Orb(:), nl_Base(:), nlm_LUT(:,:) Real, Pointer :: aQlm(:), Hat(:) Complex, Pointer :: Qlm(:,:), Wij(:,:), dEdQlm(:,:), Wijspin(:,:) Real :: fn,tt Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT write(log_unit,*) 'CalcQlm: Begin' call flush(log_unit) tt=0 !!!!!! Do i=1, Specific_Atoms A => Atom_List(i) AT => AtomType_Info(A%TypeIndex) nl_base => AT%nl_Base nlm_LUT => AT%nlm_LUT aQlm => AT%aQlm LUT_Orb => AT%LUT_Orb Qlm_Size = AT%QVlm_Size Qlm => A%Qlm dEdQlm => A%dEdQlm Wij => A%Wij if(spindependence) Wijspin => A%Wijspin Offset_Q = 2*MaxVal(AT%L_Value) + 1 !Qlm(1, Offset_Q) = Qlm(1,Offset_Q) + AT%Core_Charge - At%Atomic_Charge Qlm(1, Offset_Q) = Qlm(1,Offset_Q) + AT%Qeffion Hat => AT%Hat_SelfEnergy Do j=1, Qlm_Size Call Orbital_Decode(LUT_Orb(j), nili, njlj, mi, mj, L) M = mj - mi ibase = nl_base(nili); ibase = ibase + nlm_LUT(2, ibase) jbase = nl_base(njlj); jbase = jbase + nlm_LUT(2, jbase) Qlm(L+1, M+Offset_Q) = Qlm(L+1, M+Offset_Q) + & Wij(ibase+mi, jbase+mj) * aQlm(j) if(spindependence) then Qlm(L+1, M+Offset_Q) = Qlm(L+1, M+Offset_Q) + & Wijspin(ibase+mi, jbase+mj) * aQlm(j) end if !write(log_unit,*) 'CalcQLM: L M QLM ', L, M, QLM(L+1,M+Offset_Q) !call flush(Log_unit) End Do !***** Now accum dEdQlm and the Energy ***** Do L=0, Offset_Q - 1 fn = Hat(L) Do M=-L, L dEdQlm(L+1, Offset_Q+M) = dEdQlm(L+1, Offset_Q+M) - & 2*fn * CONJG(Qlm(L+1,Offset_Q + M)) Energy= Energy - & fn*CONJG(Qlm(L+1,Offset_Q+M))*Qlm(L+1,Offset_Q+M) End Do End Do tt=tt+Qlm(1,Offset_Q) !!!!!! ! add coretail effects Energy=Energy-AT%CoreTail_SelfEnergy-Qlm(1,Offset_Q)*AT%CoreTail_HatEnergy dEdQlm(1,Offset_Q)=dEdQlm(1,Offset_Q)-AT%CoreTail_HatEnergy End Do write(Log_Unit,*) ' check Q00 ', tt !!!!! call flush(log_unit) ! Write(6,*) ' dEdQlm with self term' ! call WriteQlm(2,6) Return End Subroutine !****************************************************************************** ! ! AccumVhartree - Accumulates the Vhartree terms in Dij based on eq A26 ! !****************************************************************************** Subroutine AccumVhartree(Energy) Real, Intent(INOUT) :: Energy Integer :: i, j, k, Qlm_Size, Offset_Q, Cijkl_Size Integer :: nili, njlj, nlll,nklk, mi, mj, mk, ml Integer :: ibase,jbase,lbase,kbase Integer, Pointer :: LUT_Cijkl(:), nl_base(:), nlm_LUT(:,:) Real, Pointer :: Cijkl(:) Complex, Pointer :: Dij(:,:), Wij(:,:), Dijspin(:,:), Wijspin(:,:) Complex :: fn Real :: Venergy Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT write(log_unit,*) 'AccumVhartree: Begin' call flush(log_unit) Venergy = 0 Do i=1, Specific_Atoms A => Atom_List(i) AT => AtomType_Info(A%TypeIndex) Offset_Q = 2*MaxVal(AT%L_Value) + 1 Cijkl => AT%Cijkl LUT_Cijkl => AT%LUT_Cijkl Cijkl_Size = AT%Cijkl_Size nl_base => AT%nl_base nlm_LUT => AT%nlm_LUT Wij => A%Wij Dij => A%Dij if(spindependence) then Wijspin => A%Wijspin Dijspin => A%Dijspin end if Do j=1, Cijkl_Size Call Coulomb_Decode(LUT_Cijkl(j), nili, njlj, nklk, nlll, mi, mj, mk) ml = mi - mj + mk ibase = nl_Base(nili); ibase = ibase + nlm_lut(2,ibase) + mi; jbase = nl_Base(njlj); jbase = jbase + nlm_lut(2,jbase) + mj; kbase = nl_Base(nklk); kbase = kbase + nlm_lut(2,kbase) + mk; lbase = nl_Base(nlll); lbase = lbase + nlm_lut(2,lbase) + ml; if(.NOT.spindependence) then fn = Wij(kbase, lbase) * Cijkl(j) Dij(ibase,jbase) = Dij(ibase,jbase) + fn Venergy = Venergy + Wij(ibase,jbase) * fn else fn = (Wij(kbase, lbase)+Wijspin(kbase, lbase)) * Cijkl(j) Dij(ibase,jbase) = Dij(ibase,jbase) + fn Dijspin(ibase,jbase) = Dijspin(ibase,jbase) + fn Venergy = Venergy + (Wij(ibase,jbase)+Wijspin(ibase, jbase)) * fn end if End Do End Do Energy = Energy + 0.5*Venergy write(log_unit,*) 'AccumVhartree: End' call flush(log_unit) Return End Subroutine !****************************************************************************** ! ! AccumVhatdEdQlm - Accumulates the Vhat terms in Dij based on eq A23 ! and also accumulates the contributions to dEdQlm ! !****************************************************************************** Subroutine AccumVhatdEdQlm(Energy) Real, Intent(INOUT) :: Energy Integer :: i, j, k, Vlm_Size, Offset_Q, ibase,jbase Integer :: nili, njlj, mi, mj, M, L Integer, Pointer :: LUT_Orb(:), nl_base(:), nlm_LUT(:,:) Real, Pointer :: aVlm(:) Complex, Pointer :: dEdQlm(:,:), Qlm(:,:), Wij(:,:), Dij(:,:) Complex, Pointer :: Wijspin(:,:), Dijspin(:,:) Complex :: fn Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT write(log_unit,*) 'AccumVhatDEdQlm: Begin' call flush(log_unit) Do i=1, Specific_Atoms A => Atom_List(i) AT => AtomType_Info(A%TypeIndex) Offset_Q = AT%Hat_MaxL + 1 aVlm => AT%aVlm LUT_Orb => AT%LUT_Orb Vlm_Size = AT%QVlm_Size Qlm => A%Qlm dEdQlm => A%dEdQlm nl_base => AT%nl_base nlm_LUT => AT%nlm_LUT Wij => A%Wij Dij => A%Dij if(spindependence) then Wijspin => A%Wijspin Dijspin => A%Dijspin end if Do j=1, Vlm_Size Call Orbital_Decode(LUT_Orb(j), nili, njlj, mi, mj, L) M = -(mj - mi) !** Change sign for aVlm ibase = nl_Base(nili); ibase = ibase + nlm_lut(2,ibase) + mi; jbase = nl_Base(njlj); jbase = jbase + nlm_lut(2,jbase) + mj; fn = aVlm(j) * Qlm(L+1, M+Offset_Q) !** Reverse M-sign for Qlm Dij(ibase, jbase) = Dij(ibase,jbase) - fn Energy = Energy - Real(Wij(ibase,jbase) * fn) !** Reverse M-sign for dEdQlm dEdQlm(L+1, Offset_Q + M) = dEdQlm(L+1, Offset_Q + M) - & Wij(ibase,jbase) * aVlm(j) if(spindependence) then Dijspin(ibase, jbase) = Dijspin(ibase,jbase) - fn Energy = Energy - Real(Wijspin(ibase,jbase) * fn) dEdQlm(L+1, Offset_Q + M) = dEdQlm(L+1, Offset_Q + M) - & Wijspin(ibase,jbase) * aVlm(j) end if End Do End Do ! Write(6,*) ' dEdQlm with vhat term' ! call WriteQlm(2,6) write(log_unit,*) 'AccumVhatDEdQlm: complete' call flush(log_unit) Return End Subroutine !****************************************************************************** ! ! AccumVlocal - Accumulates the Vlocal ! !****************************************************************************** Subroutine AccumVlocal(Energy, Den, Denspin) Complex, Intent(IN) :: Den(:) Complex, Intent(IN), OPTIONAL :: Denspin(:) Real, Intent(INOUT) :: Energy !Accumulate Pot. Energy Complex, Pointer :: V(:),Vspin(:) Real :: theta, Gmag, RadG, G(3), Esum Complex :: Phase, Vsum Integer :: atom, atype, lut, gindex, RadIndex, fi Type (Atom_Info_Fixed), Pointer :: AT write(log_unit,*) 'AccumVlocal: begin' call flush(log_unit) V => SCFvalues%Ve if(spindependence) Vspin => SCFvalues%Vespin Esum = 0 Do gindex=1, Gpnt_Size(G_HIGH) Vsum = SCFvalues%V_local(gindex) fi = FFTmap_High(gindex) V(fi) = V(fi) + Vsum !write(log_unit,*) 'AccumVlocal ', gindex,fi,Vsum !call flush(log_unit) Esum = Esum + Vsum*Conjg(Den(fi)) if(spindependence) then Vspin(fi) = Vspin(fi) +Vsum Esum = Esum + Vsum*Conjg(Denspin(fi)) endif If (gindex>1) then fi = FFTmap_High(Gindex + Gpnt_Size(G_HIGH)-1) V(fi) = V(fi) + CONJG(Vsum) !write(log_unit,*) 'AccumVlocal ', gindex,fi,CONJG(Vsum) !call flush(log_unit) Esum = Esum + Conjg(Vsum*Den(fi)) if(spindependence) then Vspin(fi) = Vspin(fi) +CONJG(Vsum) Esum = Esum + Conjg(Vsum*Denspin(fi)) endif End if End Do Energy = Energy + Esum write(log_unit,*) 'AccumVlocal: end' call flush(log_unit) Return End Subroutine !****************************************************************************** ! ! CalcDenhat - Accumulates the n^ density ! !****************************************************************************** Subroutine CalcDenHat( DenHat) Complex, Intent(INOUT) :: DenHat(:) ! input density is augmented with n^ Real :: theta, Gmag, RadG, MinQlm, G(3) Complex :: Phase(Specific_Atoms), Ylm(13), Ylm_neg(13), den,tmp Complex, parameter :: ai=(0,-1) Integer :: atom, atype, L, m, lut, gindex, Offset_Q, HatIndex, fi, Gi(3) Logical :: WhichL(20, Atom_Types) Type (Atom_Info_Fixed), Pointer :: AT Type (Specific_Atom), Pointer :: A Call Start_Timer(Timer(DenHat_Timer)) !** First create L filter using the Qlm ** WhichL = .FALSE. !MinQlm = 1.E-30 Do atom=1, Specific_Atoms A => Atom_List(atom) AT => AtomType_Info(A%TypeIndex) MinQlm = 1E-20*MAXVAL(REAL(CONJG(A%Qlm)*A%Qlm)) Offset_Q = AT%Hat_MaxL + 1 Do L=0, AT%Hat_MaxL Do m=-L, L theta = CONJG(A%Qlm(L+1, Offset_Q+m))*A%Qlm(L+1, Offset_Q+m) If (theta > MinQlm) WhichL(L+1, A%TypeIndex) = .TRUE. End Do End Do End Do !*** Now calculate the Hat density in G-space *** HatIndex = 0 Do gindex=1, Gpnt_Size(G_HIGH) fi = FFTmap_High(gindex) G = Gpnt(1:3,gindex) Gmag = Gpnt(4,gindex) !*** If needed inc the HatIndex *** If (G_NewMag(gindex)) HatIndex = HatIndex + 1 den = 0 Do atype=1, Atom_Types AT => AtomType_Info(atype) Offset_Q = AT%Hat_MaxL + 1 !*** Create and store the structure factors *** Do lut = AtomType_Range(1,atype), AtomType_range(2,atype) atom = Atomtype_map(lut) theta = DOT_PRODUCT(G, Atom_List(atom)%Pos) Phase(atom) = CMPLX(cos(theta), -sin(theta)) End Do Do L=0, AT%Hat_MaxL If (WhichL(L+1, atype)) then Ylm = Spharm(G(1), G(2), G(3), L, .TRUE.) RadG = AT%RadHat(HatIndex, L+1) Do lut = AtomType_Range(1,atype), AtomType_range(2,atype) atom = Atomtype_map(lut) !If (gindex==1) then ! Write(Log_Unit,*) 'CalcDenHat: atype=',atype, ' * L=', L, ' * RadG=',RadG, ' * Phase=',Phase(atom) !end If tmp=0 Do m=-L, L tmp=tmp+Atom_List(Atom)%Qlm(L+1, Offset_Q+m)*Ylm(L+m+1) !If (gindex==1) then ! Write(Log_Unit,*) 'CalcDenHat: atype=',atype, ' * atom=',atom, ' * L=',L, ' * m=',m, ' * Qlm=',Atom_List(Atom)%Qlm(L+1, Offset_Q+m), ' * Term=',Atom_List(Atom)%Qlm(L+1, Offset_Q+m) * Phase(atom)*RadG*Ylm(L+m+1) !end If Enddo tmp=tmp*(ai**L) den = den + tmp*Phase(atom)*RadG !If (gindex==1) then ! Write(Log_Unit,*) 'CalcDenHat: atom=',atom, ' * L=',L, ' * SumDenHat=',den !End If End Do End if End Do End Do !If (gindex == 1) Write(Log_Unit,*) 'CalcDenHat: Qhat=',Den, ' * Den(1)=',DenHat(1) DenHat(fi) = DenHat(fi) + den ! Store RhoHat SCFvalues%RhoHat(gindex)=den !write(6,*) 'CalcDen',fi,gmag,den If (gindex>1) then fi = FFTmap_High(gindex+Gpnt_size(G_HIGH)-1) DenHat(fi) = DenHat(fi) + CONJG(den) End If End Do Call Stop_Timer(Timer(DenHat_Timer)) !write(6,*) 'in denhat -', denHat(1),denHat(7),denHat(97),denHat(200) Return End Subroutine !****************************************************************************** ! ! CalcDen_dEdQlm - Accumulates the n~+n^ density term to dE/dQlm. ! !****************************************************************************** Subroutine CalcDen_dEdQlm( Den) Complex, Intent(IN) :: Den(:) !This must be n~ + n^(G) Real :: theta, Gmag, RadG, MinQlm, c1, G(3) Complex :: Phase(Specific_Atoms), Ylm(13), Ylm_neg(13), DenG, tmp Complex , parameter :: ai=(0,-1) Integer :: atom, atype, L, m, lut, gindex, Offset_Q, HatIndex,Gi(3) Logical :: WhichL(20, Atom_Types) Type (Atom_Info_Fixed), Pointer :: AT Type (Specific_Atom), Pointer :: A c1 = 2*Four_Pi/xtal%Volume HatIndex = 1 Do gindex=2, Gpnt_Size(G_HIGH) G = Gpnt(1:3,gindex) Gmag = Gpnt(4,gindex) DenG = CONJG(Den(FFTmap_High(gindex))+SCFValues%CoreTail(gindex))/(Gmag*Gmag) !*** If needed inc the HatIndex *** If (G_NewMag(gindex)) HatIndex = HatIndex + 1 Do atype=1, Atom_Types AT => AtomType_Info(atype) Offset_Q = AT%Hat_MaxL + 1 !*** Create and store the structure factors *** Do lut = AtomType_Range(1,atype), AtomType_range(2,atype) atom = Atomtype_map(lut) theta = DOT_PRODUCT(G, Atom_List(atom)%Pos) Phase(atom) = CMPLX(cos(theta), -sin(theta)) End Do Do L=0, AT%Hat_MaxL Ylm = Spharm(G(1), G(2), G(3), L, .TRUE.) !Ylm_neg = Spharm(-G(1), -G(2), -G(3), L, .TRUE.) Ylm_neg = Ylm; if (L>0) Ylm_neg=Ylm_neg*((-1)**L) RadG = AT%RadHat(HatIndex, L+1) tmp = ai**L Do lut = AtomType_Range(1,atype), AtomType_range(2,atype) atom = Atomtype_map(lut) Do m=-L, L Atom_List(atom)%dEdQlm(L+1, Offset_Q+m) = & Atom_List(atom)%dEdQlm(L+1, Offset_Q+m) + & c1 * tmp * (DenG * Ylm(L+m+1)*Phase(atom) + & Ylm_neg(L+m+1)*CONJG(DenG * Phase(atom)))*RadG End Do End Do End Do End Do End Do ! Write(6,*) ' dEdQlm with den term' ! call WriteQlm(2,6) Return End Subroutine !****************************************************************************** ! ! CalcDenhat_dEdQlm - Accumulates the n^ density in Den to n~ and ! also accumulates the term in dEdQlm containing n^+n~. ! !****************************************************************************** Subroutine CalcDenHat_dEdQlm( Den) Complex, Intent(INOUT) :: Den(:) Call CalcDenHat( Den) Call CalcDen_dEdQlm( Den) Return End Subroutine !****************************************************************************** ! ! AccumPotential - Accumulates the potential energy due to n~+n^+ncore~. ! !****************************************************************************** Subroutine AccumPotential( Energy, Rho) Real, Intent(INOUT) :: Energy Complex, Intent(INOUT) :: Rho(:) Complex, Pointer :: V(:), Vspin(:) Real :: c1, c2 , Esum Complex :: Vpnt, Den Integer :: gi, N c1 = Four_Pi/xtal%Volume c2 = 2*c1 !write(6,*) 'in AccumPotential',c1,c2 N = Gpnt_Size(G_HIGH) - 1 V => SCFValues%Ve if(spindependence) Vspin => SCFValues%Vespin Esum = 0 Do gi=2, Gpnt_Size(G_High) Den = Rho(FFTmap_High(gi)) +SCFValues%CoreTail(Gi) Vpnt = c2*(Den)/ Gpnt(4,gi)**2 Esum = Esum + REAL(Vpnt*CONJG(den)) Hat_Hat_Energy=Hat_Hat_Energy+ & c2*CONJG(SCFvalues%RhoHat(gi))*SCFvalues%RhoHat(gi)/Gpnt(4,gi)**2 !write(6,*) 'ACCPOT',gi,ESUM !V(FFTmap_High(gi)) = V(FFTmap_High(gi)) + FFT_Grid(4,G_High)*Vpnt !V(FFTmap_High(gi+N)) = V(FFTmap_High(gi+N)) + FFT_Grid(4,G_High)*CONJG(Vpnt) ! If (V_MixType /= MIX_V) then V(FFTmap_High(gi)) = V(FFTmap_High(gi)) + Vpnt !** Orig V(FFTmap_High(gi+N)) = V(FFTmap_High(gi+N)) + CONJG(Vpnt) if(spindependence) then Vspin(FFTmap_High(gi)) = Vspin(FFTmap_High(gi)) + Vpnt !** Orig Vspin(FFTmap_High(gi+N)) = Vspin(FFTmap_High(gi+N)) + CONJG(Vpnt) end if ! else ! Rho(FFTmap_High(gi)) = Vpnt ! Rho(FFTmap_High(gi+N)) = CONJG(Vpnt) ! End if End Do Energy = Energy + Esum Return End Subroutine !****************************************************************************** ! ! AccumShift - Accumulates the coulomb shift term eq A27 ! !****************************************************************************** Subroutine AccumShift Integer :: i, j, k, Qlm_Size, Offset_Q, ibase,jbase Integer :: nili, njlj, mi, mj, M, L Integer, Pointer :: LUT_Orb(:), nlm_LUT(:,:), nl_Base(:) Real, Pointer :: aQlm(:) Complex, Pointer :: dEdQlm(:,:), Dij(:,:), Dijspin(:,:) Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT Do i=1, Specific_Atoms A => Atom_List(i) AT => AtomType_Info(A%TypeIndex) Offset_Q = AT%Hat_MaxL + 1 aQlm => AT%aQlm LUT_Orb => AT%LUT_Orb Qlm_Size = AT%QVlm_Size dEdQlm => A%dEdQlm nl_base => AT%nl_Base nlm_LUT => AT%nlm_LUT Dij => A%Dij if(spindependence) Dijspin => A%Dijspin Do j=1, Qlm_Size Call Orbital_Decode(LUT_Orb(j), nili, njlj, mi, mj, L) M = mj - mi ibase = nl_Base(nili); ibase = ibase + nlm_lut(2,ibase) + mi; jbase = nl_Base(njlj); jbase = jbase + nlm_lut(2,jbase) + mj; Dij(ibase,jbase) = Dij(ibase,jbase) + aQlm(j) * dEdQlm(L+1, M+Offset_Q) if(spindependence) Dijspin(ibase, jbase) = Dijspin(ibase, jbase) + & aQlm(j) * dEdQlm(L+1, M+Offset_Q) End Do End Do Return End Subroutine !****************************************************************************** ! ! AddDiagElements - Adds the Diagonal Elements to the Dij for each atom ! eq A10, A11 ! !****************************************************************************** Subroutine AddDiagElements(Energy) Real, Intent(INOUT) :: Energy Integer :: i, j, k, t, Basis_Size, Overlap_Size Integer :: nili, njlj, m, mmin, mmax, Li, Lj, ibase,jbase Complex, Pointer :: Dij(:,:), Wij(:,:),Dijspin(:,:), Wijspin(:,:) Real, Pointer :: Vion(:), KE(:) Integer, Pointer :: L_Values(:), nlm_LUT(:,:),nl_base(:) Complex :: fn Integer, Pointer :: LUT(:) Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT Do i=1, Specific_Atoms A => Atom_List(i) AT => AtomType_Info(A%TypeIndex) Dij => A%Dij Wij => A%Wij if(spindependence) then Dijspin => A%Dijspin Wijspin => A%Wijspin end if Vion => AT%V_ion KE => AT%Kinetic Basis_Size = AT%Basis_Size L_Values => AT%L_Value nl_base => AT%nl_Base nlm_LUT => AT%nlm_LUT t = 0 Do nili=1, Basis_Size Li = L_Values(nili) ibase = nl_Base(nili); ibase = ibase + nlm_lut(2,ibase); Do njlj=1, nili Lj = L_Values(njlj) If (Li == Lj) then t = t + 1 jbase = nl_Base(njlj); jbase = jbase + nlm_lut(2,jbase); fn = KE(t) + Vion(t) Do m=-Li, Li Dij(ibase+m,jbase+m) = Dij(ibase+m,jbase+m) + Fn Energy = Energy+Wij(ibase+m,jbase+m)*Fn if(spindependence) then Dijspin(ibase+m,jbase+m) = Dijspin(ibase+m,jbase+m) + Fn Energy = Energy+Wijspin(ibase+m,jbase+m)*Fn end if if (nili /= njlj) then Dij(jbase+m,ibase+m) = Dij(jbase+m,ibase+m) + Fn Energy = Energy+Wij(jbase+m,ibase+m)*Fn if(spindependence) then Dijspin(jbase+m,ibase+m) = Dijspin(jbase+m,ibase+m) + Fn Energy = Energy+Wijspin(jbase+m,ibase+m)*Fn end if End If End Do End If End Do End Do End Do Return End Subroutine !****************************************************************************** ! LoadWij - Temp for comparison !****************************************************************************** ! It is not updated for spin dependence Subroutine LoadWij Integer :: i,j,k, nili,njlj,mi,mj,li,lj, ikind, ia, basis_size Complex :: c Integer, pointer :: nl_base(:), nlm_lut(:,:) Complex, Pointer :: Dij(:,:), Wij(:,:) Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT Open(50, file="wij.out", recl=1000) write(*,*) 'LoadWij:!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' Do i=1, Specific_Atoms A => Atom_List(i) AT => AtomType_Info(A%TypeIndex) nl_base => AT%nl_Base nlm_LUT => AT%nlm_LUT Wij => A%Wij Dij => A%Dij Basis_Size = AT%Basis_Size Do j=1, AT%nlm_Size Do k=1, AT%nlm_Size Read(50,*) ikind,ia,nili,Li,mi,njlj,Lj,mj,c Wij(nl_base(nili)+mi+Li,nl_base(njlj)+mj+Lj) = c End Do End Do End Do Close(50) Return End Subroutine !****************************************************************************** ! WriteWij - Temp for comparison !****************************************************************************** !It is not updated for spin dependence Subroutine WriteWij(fd) Integer, Intent(IN) :: fd Integer :: i,j,k, nili,njlj,mi,mj,li,lj, ikind, ia, Basis_size Complex :: c Integer, pointer :: nl_base(:), nlm_lut(:,:) Complex, Pointer :: Dij(:,:), Wij(:,:) Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT ! Open(50, file="wij.out", recl=1000) Write(fd,*) 'Printing Wij (nili,Li,mi, njlj,Lj,mj, Wij)********************' Do i=1, Specific_Atoms Write(fd,*) 'ATOM:',i, '------------------------------------------------' A => Atom_List(i) AT => AtomType_Info(A%TypeIndex) nl_base => AT%nl_Base nlm_LUT => AT%nlm_LUT Wij => A%Wij Dij => A%Dij Basis_Size = AT%Basis_Size Do j=1, AT%nlm_Size nili = nlm_LUT(1,j) Li = nlm_LUT(2,j) mi = nlm_LUT(3,j) Do k=1, AT%nlm_Size njlj = nlm_LUT(1,k) Lj = nlm_LUT(2,k) mj = nlm_LUT(3,k) c = Wij(nl_base(nili)+mi+Li, nl_base(njlj)+Mj+Lj) !** c = c/(4*PI/Xtal%Volume) If (ABS(c*COnjg(c))>1E-20) then Write(fd,'(6i3)', ADVANCE="NO") nili,Li,mi,njlj,Lj,mj Write(fd,*) '(i,j)',nl_base(nili)+mi+Li, nl_base(njlj)+mj+Lj Write(fd,*) c End If End Do End Do End Do Write(fd,*) '******************************************************' !** Close(50) Return End Subroutine !****************************************************************************** ! WriteDij - Temp for comparison !****************************************************************************** Subroutine WriteDij(fd) Integer, Intent(IN) :: fd Integer :: i,j,k, nili,njlj,mi,mj,li,lj, ikind, ia, Basis_size Complex :: c Integer, pointer :: nl_base(:), nlm_lut(:,:) Complex, Pointer :: Dij(:,:), Wij(:,:) Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT ! Open(50, file="wij.out", recl=1000) Write(fd,*) 'Printing Dij atom (nili,Li,mi, njlj,Lj,mj, Dij)****************' Do i=1, Specific_Atoms Write(fd,*) 'ATOM:',i, '------------------------------------------------' A => Atom_List(i) AT => AtomType_Info(A%TypeIndex) nl_base => AT%nl_Base nlm_LUT => AT%nlm_LUT Wij => A%Wij Dij => A%Dij Basis_Size = AT%Basis_Size Do j=1, AT%nlm_Size nili = nlm_LUT(1,j) Li = nlm_LUT(2,j) mi = nlm_LUT(3,j) Do k=1, AT%nlm_Size njlj = nlm_LUT(1,k) Lj = nlm_LUT(2,k) mj = nlm_LUT(3,k) c = Dij(nl_base(nili)+mi+Li, nl_base(njlj)+Mj+Lj) !** c = c/(4*PI/Xtal%Volume) If (ABS(c*COnjg(c))>1E-20) then Write(fd,*) 'Dij=',c Write(fd,*) '(i,j)',nl_base(nili)+mi+Li, nl_base(njlj)+mj+Lj Write(fd,*) ' ',nili,Li,mi,njlj,Lj,mj End If End Do End Do End Do Write(fd,*) '******************************************************' !** Close(50) Return End Subroutine !****************************************************************************** ! WriteQlm - Temp for comparison !****************************************************************************** Subroutine WriteQlm(Which, fd) Integer, Intent(IN) :: Which Integer, Intent(IN) :: fd Integer :: i,j,k, M,l, ikind, ia, Offset_Q Complex :: c, QlmSum, totalQlm Complex, Pointer :: Qlm(:,:) Integer, pointer :: nl_base(:), nlm_lut(:,:) Complex, Pointer :: Dij(:,:), Wij(:,:) Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT ! Open(50, file="wij.out", recl=1000) totalQlm = 0 If (Which==1) then Write(fd,*) 'Printing Qlm (atom, L, M, Qlm)********************' Else Write(fd,*) 'Printing dEdQlm (atom, L, M, Qlm)********************' End If Do i=1, Specific_Atoms Write(fd,*) 'ATOM:',i, '------------------------------------------------' A => Atom_List(i) AT => AtomType_Info(A%TypeIndex) nl_base => AT%nl_Base nlm_LUT => AT%nlm_LUT If (Which==1) then Qlm => A%Qlm else Qlm => A%dEdQlm End If Offset_Q = 2*MaxVal(AT%L_Value) + 1 QlmSum = 0 Do L=0, Offset_Q-1 Do m=-L, L c = Qlm(L+1, Offset_Q + m) Qlmsum = QlmSum + c If (ABS(c*COnjg(c))>1E-5) then Write(fd,*) L,M,c End If End Do End Do Write(fd,*) ' SUM(Qlm)=',QlmSum TotalQlm = TotalQlm + QlmSum End Do Write(fd,*) '******************************************************' Write(fd,*) ' Total SUM(Qlm)=',TotalQlm Write(fd,*) '******************************************************' !** Close(50) Return End Subroutine !****************************************************************************** ! ! MakeBandMap - Creates the mapping from diskindex to (Band,Kpnt) ! !****************************************************************************** Subroutine MakeBandMap !Integer :: BandsPerKpnt(NumKpnts), i, j, k !Integer :: LUT(Mem_MapSize), ListSize, SortLUT(Mem_MapSize) !Real :: Eigen(Mem_MapSize) Integer :: i, j, k , ListSize Integer ,allocatable :: LUT(:), SortLUT(:), BandsPerKpnt(:) Real ,allocatable:: Eigen(:) !write(log_unit,*) 'MakeBandMap: start', NumKpnts,Numbands !call flush(log_unit) Allocate(BandsPerKpnt(NumKpnts),LUT(Mem_MapSize),SortLUT(Mem_MapSize), & Eigen(Mem_MapSize)) BandMap = 0 if(.NOT.spindependence) then !write(log_unit,*) 'MakeBandMap: NOT spin dependent' !call flush(log_unit) BandsPerKpnt = 0;LUT=0;SortLUT=0;Eigen=1.e30 ListSize = 0 !*** Create LUT and Eigenvalue list Do i=1, Mem_MapSize If (PsiInfo(i)%Kpnt > 0) then ListSize = ListSize + 1 LUT(ListSize) = i Eigen(ListSize) = PsiInfo(i)%Energy End if End Do !** Sort the eigenvalues *** Call Insertion_Sort(Eigen(1:ListSize), SortLUT(1:ListSize), .TRUE.) Do i=1, ListSize j = LUT(SortLUT(i)) If (PsiInfo(j)%Kpnt > 0) then k = PsiInfo(j)%Kpnt If (BandsPerKpnt(k) < NumBands) then BandsPerKpnt(k) = BandsPerKpnt(k) + 1 BandMap(1,j) = BandsPerKpnt(k) BandMap(2,j) = k !write(Log_unit,*) 'MakeBandMap', j,BandMap(1,j),BandMap(2,j) !call flush(log_unit) End If End If End Do else !write(log_unit,*) 'MakeBandMap: spin dependent' !call flush(log_unit) BandsPerKpnt = 0;LUT=0;SortLUT=0;Eigen=1.e30 ListSize = 0 !*** Create LUT and Eigenvalue list Do i=1, Mem_MapSize If (PsiInfo(i)%Kpnt > 0 .and. PsiInfo(i)%spinup) then ListSize = ListSize + 1 LUT(ListSize) = i Eigen(ListSize) = PsiInfo(i)%Energy End if End Do !** Sort the eigenvalues *** Call Insertion_Sort(Eigen(1:ListSize), SortLUT(1:ListSize), .TRUE.) Do i=1, ListSize j = LUT(SortLUT(i)) If (PsiInfo(j)%Kpnt > 0 .and. PsiInfo(j)%spinup) then k = PsiInfo(j)%Kpnt If (BandsPerKpnt(k) < NumBands) then BandsPerKpnt(k) = BandsPerKpnt(k) + 1 BandMap(1,j) = BandsPerKpnt(k) BandMap(2,j) = k !write(Log_unit,*) 'MakeBandMap', j,BandMap(1,j),BandMap(2,j) !call flush(log_unit) End If End If End Do BandsPerKpnt = 0;LUT=0;SortLUT=0;Eigen=1.e30 ListSize = 0 !*** Create LUT and Eigenvalue list Do i=1, Mem_MapSize If (PsiInfo(i)%Kpnt > 0 .and. .NOT.PsiInfo(i)%spinup) then ListSize = ListSize + 1 LUT(ListSize) = i Eigen(ListSize) = PsiInfo(i)%Energy End if End Do !** Sort the eigenvalues *** Call Insertion_Sort(Eigen(1:ListSize), SortLUT(1:ListSize), .TRUE.) Do i=1, ListSize j = LUT(SortLUT(i)) If (PsiInfo(j)%Kpnt > 0 .and. .NOT.PsiInfo(j)%spinup) then k = PsiInfo(j)%Kpnt If (BandsPerKpnt(k) < NumBands) then BandsPerKpnt(k) = BandsPerKpnt(k) + 1 BandMap(1,j) = BandsPerKpnt(k)+NumBands BandMap(2,j) = k !write(Log_unit,*) 'MakeBandMap', j,BandMap(1,j),BandMap(2,j) !call flush(log_unit) End If End If End Do end if DeAllocate(BandsPerKpnt,LUT,SortLUT,Eigen) Return End Subroutine !****************************************************************************** ! ! CalcNewOccAndFermi - Calculates the New occupancies and Fermi Energy ! for the system. ! ! *** NOTE: This routine assumes the MakeBandMap has been called! *** ! ! Also update virtual memory list !****************************************************************************** Subroutine CalcNewOccAndFermi Real :: OldFermi, NewFermi, NewWgt,x Integer :: i, band, Kpnt, temp,ind(1),s If (Atomic_Mode == SIM_SEPM) RETURN s=1 if(spindependence) s=2 !write(log_unit,*) 'CalcNewOccAndFermi: start', 10*MaxVal(PsiInfo(:)%Energy) !call flush(log_unit) BZ%KEu(:,:) = 10*MaxVal(PsiInfo(:)%Energy) + 150 Do i=1, Mem_MapSize Band = BandMap(1,i) Kpnt = BandMap(2,i) If ((Kpnt /= 0) .AND. (Band <= s*NumBands)) then BZ%KEu(Band, Kpnt) = PsiInfo(i)%Energy write(log_unit,*) 'CalcNewOccAndFermi: loading', Band,Kpnt,BZ%KEu(Band, Kpnt) call flush(log_unit) PsiInfo(i)%DoSave=1 PsiInfo(i)%Available=Mem_Used Else PsiInfo(i)%Kpnt=0 PsiInfo(i)%spinup=.true. PsiInfo(i)%DoSave=0 PsiInfo(i)%Available=Mem_Available temp=PsiInfo(i)%MemBufIndex if (temp>0) then Globalmap%Psi_Handle(temp)%Index=0 PsiInfo(i)%MemBufIndex=0 EndIf End If End Do If (.not.bandstructure_mode) then !Keep Fermi level if bandstructure calc OldFermi = BZ%Fermi NewFermi = BZ_CalcFermi(BZ) !*** Calculate the new fermi energy Write(Log_Unit,*) & 'CalcNewOccAndFermi: NewFermi = ',NewFermi,' OldFermi = ',OldFermi call flush(log_unit) EndIf If (bandstructure_mode) & Write(Log_Unit,*) 'CalcHewOccAndFermi: Keeping OldFermi = ',BZ%Fermi If (ReCalculate_Occupancies) then !Recalculate occupancies Call BZ_Occupy(BZ, Occupancy) !*** Occupy the bands NewWgt = 1.0 x=0 Do i=1, Mem_MapSize !*** Now Map the new occupations back *** If (PsiInfo(i)%Available==Mem_Used) then Band = BandMap(1,i) Kpnt = BandMap(2,i) PsiInfo(i)%Occupancy = (1.0-NewWgt)*PsiInfo(i)%Occupancy + & NewWgt*Occupancy(Band, Kpnt) write(log_unit,*) 'CalcNewOccAndFermi:',Band,Kpnt,PsiInfo(i)%Energy,PsiInfo(i)%Occupancy x=x+PsiInfo(i)%Occupancy else PsiInfo(i)%Occupancy = 0 End If End Do EndIf write(log_unit,*) 'CalcNewOccAndFermi: ', x call flush(log_unit) Return End Subroutine !****************************************************************************** ! ! CalcSmoothH - Calculates the smooth density and stores it in V%FAS ! and also accumulates the energy for the smooth psi to H. ! ! The KE and Exc for psi~ are ONLY calculated. The terms involving ! n^ can't be calculated yet since no Wij's and Qlm's are known. ! ! ! Both Den and WK1 are LARGE arrays(G_HIGH) ! !****************************************************************************** Subroutine CalcSmoothH( ProjDotPsi, Den, WK1, Denspin) Complex, Intent(OUT) :: ProjDotPsi(:,:,:) Complex, Intent(OUT), OPTIONAL ::Denspin(:) Complex, Intent(OUT) :: Den(:) Complex, Intent(OUT) :: WK1(:) Real :: G(3), G2, BlochK(3), KE, TotOcc, norm1,norm2 Type (Mem_handle), Pointer :: Psi !Integer :: Psi_toUse(Mem_MapSize), Kpnt, PsiBand, PsiK, i Integer :: Kpnt, PsiBand, PsiK, i Integer ,allocatable :: Psi_toUse(:) Integer :: gi, N, j,k, t,Flag Complex, Pointer :: Comp(:), Ocomp(:), Work(:), Ox(:) !Complex :: C_PDOT(PLM_MAx) Complex ,allocatable :: C_PDOT(:) Logical :: Stored write(log_unit,*) 'CalcSmoothH: begin' call flush(log_unit) Call Start_Timer(Timer(CalcSmoothH_Timer)) Allocate(Psi_toUse(Mem_MapSize),C_PDOT(PLM_MAx)) N = Gpnt_Size(G_LOW) - 1 Flag=1 ProjDotPSi = 0.0 den = 0 if(spindependence .and. .NOT.present(Denspin)) then write(error_unit,*) 'Denspin is not correctly input' stop endif if(present(Denspin)) Denspin=0 !Write(Log_Unit,*) 'CalcSmoothH: * Occ=',PsiInfo(:)%Occupancy !call flush(log_unit) ! PsiInfo(:)%PDOT_Stored = .FALSE. !** Clear PDOT Info !--- This part taken out by NAWH 6-24-00 !-- !*** Add neutralizing charge if needed *** !-- If (ABS(NetCharge)>1E-6) then !-- Stored = .FALSE. !-- Call GetBuffer( Comp) !-- Call GetBuffer( OComp) !-- Comp = 0 !-- Comp(1) = 1 !-- Call OPsi( Comp, Ocomp, C_PDOT, 1, Stored) !-- ke = DOT_PRODUCT(Comp,Ocomp) !--Write(Error_Unit, *) 'CalcSmoothH: C_DOT=',ke !-- Comp = Comp / SQRT(ke) !-- WK1 = 0 !-- !-- WK1(FFTMap_High(1:Gpnt_Size(G_Low))) = Comp(1:Gpnt_Size(G_Low)) !-- t = Gpnt_Size(G_Low)+1 !-- j = Gpnt_Size(G_HIGH)+1; k = j + (Gpnt_Size(G_Low)-1) - 1 !-- WK1(FFTMap_High(j:k)) = Comp(t:) !-- !--WK1 = 0 !--WK1(FFTMap_High(1)) = NetCharge !-- Call PerformFFT(FFT_TO_R, G_HIGH, WK1) !-- !-- Den = Den + NetCharge*CONJG(WK1)*WK1 !-- !-- Call FreeBuffer(Comp) !-- Call FreeBuffer(Ocomp) !-- End If TotOcc = 0 Do i=1, NumKpnts BlochK = BZ%Ku(:,i) !write(log_unit,*) 'CalcSmoothH: BlochK = ',i,BlochK Psi_toUse = MH_Skip Where ((PsiInfo(:)%Kpnt == i) .AND. (PsiInfo(:)%Occupancy >1E-10)) Psi_toUse = MH_toProcess End Where !write(log_unit,*) 'CalcSmoothH: i',i ! do j=1,Mem_mapsize ! if (Psi_toUse(j) /= 0) then ! write(log_unit,*) 'wfn ',j,PsiInfo(j)%Energy ,PsiInfo(j)%Occupancy ! endif ! enddo Call Phase_Generic( Psi_toUse, i) Call GetNextPsi(Flag, Psi) Do While (Flag > 0) !Write(Log_Unit,*) 'CalcSmoothH: Flag=',Flag, ' * DI=',Psi%Index, ' * Occ=', PsiInfo(Psi%Index)%Occupancy !call flush(log_unit) TotOcc = TotOcc + PsiInfo(Psi%Index)%Occupancy !write(log_unit,*) 'Occ ', TotOcc !call flush(log_unit) Call FilterValue(Psi%Ptr) call kplusGfilter(Psi%Ptr,i) !*** Calculate the KE for this Psi *** KE = CalcKineticEnergy(BlochK, Psi%Ptr) PsiInfo(Psi%Index)%KE = KE PsiInfo(Psi%Index)%KE_Stored = .TRUE. If (Atomic_Mode == SIM_TIME) then Call GetBuffer( Work) Call CalcDEL2_TIME( BlochK, Psi%Ptr, Work) KE = DOT_PRODUCT(Psi%Ptr,Work) Call FreeBuffer(Work) End if TildeKE_Energy = TildeKE_Energy + PsiInfo(Psi%Index)%Occupancy*KE WK1=0 !*** Now accumulate the density *** Call V_G_to_r(Psi%Ptr,G_LOW,WK1,G_HIGH) !write(log_unit,*) 'SmoothH: wfn = ', Psi%Index,PsiInfo(Psi%Index)%spinup,PsiInfo(Psi%Index)%Occupancy !call flush(log_unit) if(spindependence .and. .NOT.PsiInfo(Psi%Index)%spinup) then Denspin = Denspin + PsiInfo(Psi%Index)%Occupancy * CONJG(WK1)*WK1 else Den = Den + PsiInfo(Psi%Index)%Occupancy * CONJG(WK1)*WK1 endif !write(Log_Unit,*)'CalcSmoothH',PsiInfo(Psi%Index)%Occupancy !write(Log_Unit,*) 'den',den(1),den(2),den(3) !call flush(log_unit) !write(Log_Unit,*) 'CalcSmoothH: sum(den) = ',sum(den)*xtal%Volume/PRODUCT(FFT_Grid(1:3,G_HIGH)) !*** Finally calculate the PDOTS for Wij *** PsiBand = BandMap(1, Psi%Index) PsiK = BandMap(2,Psi%Index) !Write(Log_Unit,*) 'PsiBand, PsiK=',PsiBand, PsiK, ' * NumBands=',NumBands !call flush(Log_unit) If (.NOT. PsiInfo(Psi%Index)%PDOT_Stored) then If (Proj_Mode == PROJ_RS) then WK1 = 0 Call RS_toR(Psi%Ptr, WK1) Call CalcProjProducts(WK1, & PsiInfo(Psi%Index)%PDOT) else Call CalcProjProducts(Psi%Ptr, PsiInfo(Psi%Index)%PDOT) End If PsiInfo(Psi%Index)%PDOT_Stored = .TRUE. End If ProjDotPsi(:,PsiBand, PsiK) = PsiInfo(Psi%Index)%PDOT !write(log_unit,*) 'CalcSmoothH: PDOT index = ', PsiBand,PsiK !call flush(log_unit) !Write(Log_Unit,*) 'CalcSmoothH: PDOT=',ProjDotPsi(:,PsiBand, PsiK) !call flush(log_unit) Call GetNextPsi(Flag, Psi) End Do End Do Write(Log_Unit,*) 'CalcSmoothH: SUM(Occ)=',TotOcc call flush(log_unit) !Den = Den * FFT_Grid(4,G_HIGH) ! correct for FFT normalization DeAllocate(Psi_toUse,C_PDOT) Call Stop_Timer(Timer(CalcSmoothH_Timer)) !STOP Return End Subroutine !****************************************************************************** ! ! CalcHam - Calculates the Hamiltonian ! !****************************************************************************** Subroutine CalcHam( Energy) Real, Intent(OUT) :: Energy Integer :: i,j,k, PsiBand, PsiK, n, t Integer :: den_handle, psi_R_Handle, Psi_G_Handle, KE_Handle Complex, Pointer :: BlochK(:), Wk1(:), Wk2(:) Real :: P(3), rmag, Offset(3), energytemp, toosmall Real :: Qt, Qh, c1, c2, gmag Complex, Pointer :: OldDen(:), Work1(:), Work2(:), Fn(:), DenTemp(:) Complex, Allocatable :: ProjDotPsi(:,:,:) Type (Mem_handle), Pointer :: Psi, FAS !Integer :: Psi_toUse(Mem_MapSize), Kpnt, atom, LL, LG, Pin(3) Integer :: Kpnt, atom, LL, LG, Pin(3) Integer ,allocatable :: Psi_toUse(:) Complex, Pointer :: Den(:), Vwork(:), Denspin(:) Real :: Vxc, Exc, ExcSum Logical :: Ok, DoZero, DoPrint, DoLoadWij Character*100 :: msg write(log_unit,*) 'CalcHam: begin' call flush(log_unit) Allocate(Psi_toUse(Mem_MapSize)) energytemp = 0 If (Prev_cohesiveEnergy(1) < 1E20) then energytemp = Prev_CohesiveEnergy(2) - Prev_CohesiveEnergy(1) gmag = 0.5*(abs(Prev_CohesiveEnergy(2)) + abs(Prev_CohesiveEnergy(1))) energyTemp = abs(energytemp / gmag) ! energyTemp = abs(energytemp / Prev_CohesiveEnergy(2)) If (energytemp > Mix_DampRelative) then Write(Log_Unit,*) 'DAMP' SCFvalues%AC%NewMix = V_DampNewMix If(spindependence)SCFvalues%ACspin%NewMix = V_DampNewMix Do i=1, Specific_Atoms Atom_List(i)%Dij_AC%NewMix = Dij_DampNewMix If(spindependence)Atom_List(i)%Dijspin_AC%NewMix = Dij_DampNewMix End Do else Write(Log_Unit,*) 'RESTORE' SCFvalues%AC%NewMix = V_NewMix If(spindependence)SCFvalues%ACspin%NewMix = V_NewMix Do i=1, Specific_Atoms Atom_list(i)%Dij_AC%NewMix = Dij_NewMix If(spindependence)Atom_list(i)%Dijspin_AC%NewMix = Dij_NewMix End do End if End If Write(Log_unit,*) 'CalcHam: Echange=',energytemp Write(Log_unit,*) 'CalcHam: V_NewMix=',SCFvalues%AC%NewMix Write(Log_unit,*) 'CalcHam: Dij_NewMix=',Atom_list(1)%Dij_AC%NewMix, ' *',Dij_NewMix call flush(Log_unit) Call Start_Timer(Timer(CalcHam_Timer)) Call PrintDate(Log_Unit, 'CalcHam: Start of Routine!') !Energy = 0 !Do i=1, Specific_Atoms ! Energy = Energy +0.5*SUM(Atom_List(i)%Pos**2) !End Do !RETURN DoPrint = .FALSE. DoLoadWij = .FALSE. DoZero = .FALSE. Diag_Energy = 0 Hat_Energy = 0 OneExc_Energy = 0 Hartree_Energy = 0 TildeKE_Energy = 0 TildePot_Energy = 0 TildeXC_Energy = 0 Hat_Hat_Energy = 0 Energy = 0 !*** Allocate the Large FFT and ProjDotPsi arrays *** i = FFT_Grid(4,G_HIGH) if(.NOT.spindependence) then Allocate(Den(i), ProjDotPsi(PLM_MAX, NumBands,NumKpnts), STAT=j) msg = 'CalcHam: Could Not allocate LARGE buffers!' Call Check_Error(j, msg, Error_Unit, .TRUE.,paw_wc, "CalcHam:") else Allocate(Den(i),Denspin(i), ProjDotPsi(PLM_MAX, 2*NumBands,NumKpnts), STAT=j) msg = 'CalcHam: Could Not allocate LARGE buffers!' Call Check_Error(j, msg, Error_Unit, .TRUE.,paw_wc, "CalcHam:") endif !**************** Vwork =>SCFvalues%Work If (DoPrint) Write(*,*) 'CalcHam: Start of routine !!!!!!!!!!!!!!!!!!!!!!!!!!' if(.NOT.spindependence) Call CalcSmoothH( ProjDotPsi, Den, Vwork) if(spindependence) Call CalcSmoothH( ProjDotPsi, Den, Vwork, Denspin) write(Log_Unit,*) 'totaldensity after calcsmooth',sum(den) call flush(log_unit) If (xtal%Rot_Size > 0) Call SymRho( Den, Vwork) If (xtal%Rot_Size > 0 .and. spindependence) Call SymRho( Denspin, Vwork) write(Log_Unit,*) 'totaldensity after symrho ',sum(den) call flush(log_unit) If (Atomic_Mode /= SIM_AE) then If (DoPrint) Write(*,*) 'CalcHam: Before Wij!!!!!!!!!!!!!!!!!!!' Do i=1, Specific_Atoms Atom_List(i)%Wij_Old = Atom_List(i)%Wij Atom_List(i)%Dij = 0 !** Init Dij matrix Atom_List(i)%Qlm = 0 Atom_List(i)%dEdQlm = 0 End Do if(spindependence) then Do i=1, Specific_Atoms Atom_List(i)%Wij_Oldspin = Atom_List(i)%Wijspin Atom_List(i)%Dijspin = 0 !** Init Dij matrix End Do end if Call CalcWij(ProjDotPsi) !** Calculate and the Wij's (eq A19) !Call WriteWij(Log_Unit) If (DoPrint) then call writewij(6) End If If (DoLoadWij) Call LoadWij !STOP If (DoPrint) then Write(Log_Unit,*) 'CalcHam: Before SymWij.......................' Call WriteWij(Log_Unit) End If If (xtal%Rot_Size > 0) Call SymWij !** Symmetrize the Wij's write(log_unit,*) 'CalcHam: After SymWij' call flush(log_unit) If (DoPrint) then Write(*,*) 'CAlcHam: Before WriteSymWij!!!!!!!!!!!!!!!!!!!!!!!!!!' call writewij(6) Write(*,*) 'CalcHam: After Wij!!!!!!!!!!!!!!!!!!!' !STOP End If energytemp = hat_energy Call CalcQlm(Hat_Energy) !** Calculate the Qlm's (eq A22) energytemp = hat_energy - energytemp If (DoPrint) then Write(*,*) 'CalcHam: E^ energy =',energytemp Write(*,*) 'CalcHam: After CalcQLM' Call writeQlm(1,6) Call WriteQlm(2,6) !RETURN End If !Call writeQlm(1,Log_Unit) !Call WriteQlm(2,Log_Unit) !Do i=1, Specific_atoms ! If (DoZero) Atom_List(i)%Dij = CMPLX(0,0) !** TESTING !End Do !If (DoPrint) Write(*,*) 'CalcHam: Before AddDiag!!!' Call AddDiagElements(Diag_Energy) !** Adds the Diagonal Elements to Dij !If (DoPrint) then ! Call WriteDij(6) ! Do i=1, Specific_atoms ! If (DoZero) Atom_List(i)%Dij = CMPLX(0,0) !** TESTING ! End Do !End If !** Accum Vhat terms in Dij and dEdQlm(eq A23) ** energytemp = hat_energy Call AccumVhatdEdQlm(Hat_Energy) If (DoPrint) then energytemp = hat_energy - energytemp Write(*,*) 'CalcHam: V^ energy =',energytemp Write(*,*) 'CalcHam: Hat energy =',Hat_energy Write(*,*) 'CalcHam: After AccumVhatdEdQlm - dEdQlm' Call WriteQlm(2,6) Write(*,*) 'CalcHam: After AccumVhatdEdQlm - Dij' Call WriteDij(6) ! Do i=1, Specific_atoms ! if (DoZero) Atom_List(i)%Dij = 0 !** TESTING ! End Do End If !** Accumulate Vhartree terms in Dij (eq A26) Call AccumVhartree(Hartree_Energy) If (DoPrint) then Write(*,*) 'CalcHam: After AccumVhartree' Call WriteDij(6) Write(*,*) 'CalcHam: Before AccumVxc!!!' !Do i=1, Specific_atoms ! If (DoZero) Atom_List(i)%Dij = 0 !** TESTING !End Do End If If (XC_TYPE == XC_LDA_PW) Call AccumVxc_LDA( OneExc_Energy) If (XC_TYPE == XC_LSDA_PW) Call AccumVxc_LSDA( OneExc_Energy) If (XC_TYPE == XC_GGA_PBE) Call AccumVxc_GGA( OneExc_Energy) If (XC_TYPE == XC_SGGA_PBE) Call AccumVxc_SGGA( OneExc_Energy) If (DoPRint) then Write(*,*) 'CalcHam: After AccumVxc!!!!!' Call WriteDij(6) End If Vwork = 0 If (XC_Type == XC_LDA_PW) then Call CalcVxc_LDA( Den,TildeXC_Energy) !** Calculate Vxc and Exc !** Convert Density to FFT space *** Call PerformFFT(FFT_TO_G, G_HIGH, Den) !*** Store the Smooth density *** -- average over n(G)+Conjg(n(-G)) !SCFvalues%RhoSmooth = Den(FFTmap_High(1:Gpnt_Size(G_High))) SCFvalues%RhoSmooth(1) = Den(FFTmap_High(1)) SCFvalues%RhoSmooth(2:Gpnt_Size(G_High)) = & (Den(FFTmap_High(2:Gpnt_Size(G_High))) + & Conjg(Den(FFTmap_High(Gpnt_Size(G_High)+1:Gall_Size(G_High)))))/2 Else if (XC_Type == XC_LSDA_PW) then Call CalcVxc_LSDA( Den, Denspin,TildeXC_Energy) !** Calculate Vxc and Exc !** Convert Density to FFT space *** Call PerformFFT(FFT_TO_G, G_HIGH, Den) Call PerformFFT(FFT_TO_G, G_HIGH, Denspin) !*** Store the Smooth density *** -- average over n(G)+Conjg(n(-G)) !SCFvalues%RhoSmooth = Den(FFTmap_High(1:Gpnt_Size(G_High))) SCFvalues%RhoSmooth(1) = Den(FFTmap_High(1)) SCFvalues%RhoSmoothspin(1) = Denspin(FFTmap_High(1)) SCFvalues%RhoSmooth(2:Gpnt_Size(G_High)) = & (Den(FFTmap_High(2:Gpnt_Size(G_High))) + & Conjg(Den(FFTmap_High(Gpnt_Size(G_High)+1:Gall_Size(G_High)))))/2 SCFvalues%RhoSmoothspin(2:Gpnt_Size(G_High)) = & (Denspin(FFTmap_High(2:Gpnt_Size(G_High))) + & Conjg(Denspin(FFTmap_High(Gpnt_Size(G_High)+1:Gall_Size(G_High)))))/2 Else if (XC_Type == XC_GGA_PBE) then !** Convert Density to FFT space *** Call PerformFFT(FFT_TO_G, G_HIGH, Den) !*** Store the Smooth density *** -- average over n(G)+Conjg(n(-G)) SCFvalues%RhoSmooth(1) = Den(FFTmap_High(1)) SCFvalues%RhoSmooth(2:Gpnt_Size(G_High)) = & (Den(FFTmap_High(2:Gpnt_Size(G_High))) + & Conjg(Den(FFTmap_High(Gpnt_Size(G_High)+1:Gall_Size(G_High)))))/2 Call CalcVxc_GGA(Den,TildeXC_Energy) Else if (XC_Type == XC_SGGA_PBE) then !** Convert Density to FFT space *** Call PerformFFT(FFT_TO_G, G_HIGH, Den) Call PerformFFT(FFT_TO_G, G_HIGH, Denspin) !*** Store the Smooth density *** -- average over n(G)+Conjg(n(-G)) SCFvalues%RhoSmooth(1) = Den(FFTmap_High(1)) SCFvalues%RhoSmooth(2:Gpnt_Size(G_High)) = & (Den(FFTmap_High(2:Gpnt_Size(G_High))) + & Conjg(Den(FFTmap_High(Gpnt_Size(G_High)+1:Gall_Size(G_High)))))/2 SCFvalues%RhoSmoothspin(1) = Denspin(FFTmap_High(1)) SCFvalues%RhoSmoothspin(2:Gpnt_Size(G_High)) = & (Denspin(FFTmap_High(2:Gpnt_Size(G_High))) + & Conjg(Denspin(FFTmap_High(Gpnt_Size(G_High)+1:Gall_Size(G_High)))))/2 Call CalcVxc_SGGA(Den, Denspin,TildeXC_Energy) Else Write(Error_Unit,*) 'CalcHam: Error in XC_Type ', XC_Type stop EndIf ! write(6,*) 'after FFT -- den(1)',den(1) !** Accumulates the Vlocal term to Vwork if(spindependence) then Call AccumVlocal(TildePot_Energy, Den, Denspin) !Den = Den + Denspin write(Log_unit,*) 'CalcHam: Den,Denspin', Size(Den),Size(Denspin) call flush(log_unit) Do i=1, FFT_Grid(4,G_HIGH) Den(i)=Den(i)+Denspin(i) enddo write(Log_unit,*) 'CalcHam: Den,Denspin after:', FFT_Grid(4,G_HIGH) call flush(log_unit) else Call AccumVlocal(TildePot_Energy, Den) end if Qt = Den(1) write(log_unit,*) 'Qt = ', Qt call flush(log_unit) Call CalcDenHat_dEdQlm( Den) !** Calc N^ !!!!!!!!! ! write(Log_Unit,*)'test \hat{n}', SCFvalues%rhohat(1) !--------------------- ! If (V_MixType == MIX_DENSITY) then ! If (V_NewMix < 0.9999) then ! Allocate(DenTemp(Gpnt_Size(G_HIGH))) !DenTemp = Den(FFTmap_High(1:Gpnt_Size(G_HIGH))) ! average over n(G) and n(-G)* ! DenTemp(1)=Den(FFTmap_High(1)) ! DenTemp(2:Gpnt_Size(G_High)) = & ! (Den(FFTmap_High(2:Gpnt_Size(G_High))) + & ! Conjg(Den(FFTmap_High(Gpnt_Size(G_High)+1:Gall_Size(G_High)))))/2 ! DenTemp = DenTemp - & ! SCFvalues%Ve_Fourier(1:Gpnt_Size(G_HIGH)) ! ! Call Anderson_Mix(SCFvalues%AC, & ! SCFvalues%Ve_Fourier(1:Gpnt_Size(G_HIGH)), & ! DenTemp) ! ! Den = 0 ! Den(FFTmap_High(1:Gpnt_Size(G_HIGH))) = & ! SCFvalues%Ve_Fourier(1:Gpnt_Size(G_High)) ! Den(FFTmap_High(Gpnt_Size(G_High)+1:)) = & ! CONJG(SCFvalues%Ve_Fourier(2:Gpnt_Size(G_high))) ! ! DeAllocate(DenTemp) ! else ! SCFvalues%Ve_Fourier(1) = Den(FFTmap_High(1)) ! SCFvalues%Ve_Fourier(2:Gpnt_Size(G_HIGH)) = & ! (Den(FFTmap_HIGH(2:Gpnt_Size(G_HIGH))) + & ! Conjg(Den(FFTmap_High(Gpnt_Size(G_High)+1:Gall_Size(G_High)))))/2 ! End If ! End If if (DoPrint) Call WriteQlm(2,6) End IF Qh = Den(1) +SCFValues%CoreTail(1) - Qt Call AccumShift Call AccumPotential( TildePot_Energy, Den) !*** New Mix V w/o Vxc and Vlocal ! If (V_MixType == MIX_V) then ! If (V_NewMix < 0.9999) then ! Allocate(DenTemp(Gpnt_Size(G_HIGH))) ! DenTemp(1) = Den(FFTmap_HIGH(1)) ! DenTemp(2:Gpnt_Size(G_HIGH)) = & ! (Den(FFTmap_HIGH(2:Gpnt_Size(G_HIGH))) + & ! Conjg(Den(FFTmap_High(Gpnt_Size(G_High)+1:Gall_Size(G_High)))))/2 ! DenTemp(1:Gpnt_Size(G_HIGH)) = DenTemp(1:Gpnt_Size(G_HIGH)) - & ! SCFvalues%Ve_Fourier(1:Gpnt_Size(G_HIGH)) ! ! Call Anderson_Mix(SCFvalues%AC, & ! SCFvalues%Ve_Fourier(1:Gpnt_Size(G_HIGH)), DenTemp) ! ! Den = 0 ! Den(FFTmap_HIGH(1:Gpnt_Size(G_HIGH))) = & ! SCFvalues%Ve_Fourier(1:Gpnt_Size(G_HIGH)) ! n = Gpnt_Size(G_High)+Gpnt_size(G_HIGH)-1 ! Den(FFTmap_HIGH(Gpnt_Size(G_HIGH)+1:n)) = & ! CONJG(SCFvalues%Ve_Fourier(2:Gpnt_Size(G_HIGH))) ! Vwork = Vwork + Den ! DeAllocate(DenTemp) ! else ! SCFvalues%Ve_Fourier(1) = Den(FFTmap_High(1)) ! SCFvalues%Ve_Fourier(2:Gpnt_Size(G_HIGH)) = & ! (Den(FFTmap_HIGH(2:Gpnt_Size(G_HIGH))) + & ! Conjg(Den(FFTmap_High(Gpnt_Size(G_High)+1:Gall_Size(G_High)))))/2 ! ! Vwork(FFTmap_HIGH(1:Gpnt_Size(G_HIGH))) = & ! Vwork(FFTmap_HIGH(1:Gpnt_Size(G_HIGH))) + & ! SCFvalues%Ve_Fourier(1:Gpnt_Size(G_HIGH)) ! n = Gpnt_Size(G_High)+Gpnt_size(G_HIGH)-1 ! Vwork(FFTmap_HIGH(Gpnt_Size(G_HIGH)+1:n)) = & ! Vwork(FFTmap_HIGH(Gpnt_Size(G_HIGH)+1:n)) + & ! CONJG(SCFvalues%Ve_Fourier(2:Gpnt_Size(G_HIGH))) ! End If ! ! End If !! Store currect Dij coefficients Do i=1,Specific_atoms Do j=1, AtomType_Info(Atom_list(i)%TypeIndex)%nlm_Size Do k=1, j Atom_List(i)%cDij(j,k)=(Atom_List(i)%Dij(j,k) + & CONJG(Atom_List(i)%Dij(k,j)))/2 Atom_List(i)%cDij(k,j)=Atom_List(i)%cDij(j,k) Enddo Enddo Enddo If (spindependence) then Do i=1,Specific_atoms Do j=1, AtomType_Info(Atom_list(i)%TypeIndex)%nlm_Size Do k=1, j Atom_List(i)%cDijspin(j,k)=(Atom_List(i)%Dijspin(j,k) + & CONJG(Atom_List(i)%Dijspin(k,j)))/2 Atom_List(i)%cDijspin(k,j)=Atom_List(i)%cDijspin(j,k) Enddo Enddo Enddo Endif If (Dij_NewMix < 0.9999) then Do i=1, Specific_Atoms !** Mix each atom's Dij separately j = AtomType_Info(Atom_list(i)%TypeIndex)%nlm_Size n = (j*(j+1))/2 !** Determine unique Dij's t = 0 !** Copy new Dij's to 1-D mixing array *** Do j=1, AtomType_Info(Atom_list(i)%TypeIndex)%nlm_Size Do k=1, j t = t + 1 Work_Dij(t) = (Atom_List(i)%Dij(j,k) + & !** Work_Dij = F(X) CONJG(Atom_List(i)%Dij(k,j)))/2 End Do End Do !** Remember that Anderson mixing wants X and F(X)-X ** !** X = Atom_list(i)%Dij_Old and F(X)-X = Work_Dij Work_Dij(1:n) = Work_Dij(1:n) - Atom_list(i)%Dij_old !** Form F(X)-X write(Log_Unit,*)'Mix DeltaDij = ',i,Dot_Product(Work_Dij,Work_Dij) !*** Perform the mixing *** Call Anderson_Mix(Atom_List(i)%Dij_AC, Atom_list(i)%Dij_Old, & Work_Dij(1:n)) !*** Now store the results back in the Dij arrays *** !*** Upon exiting Anderson_Mix Atom_List(i)%Dij_old contains the !*** mixed or new Dij's to use t = 0 Do j=1, AtomType_Info(Atom_list(i)%TypeIndex)%nlm_Size Do k=1, j t = t + 1 Atom_List(i)%Dij(j,k) = Atom_list(i)%Dij_old(t) If (j/=k) Atom_List(i)%Dij(k,j) = CONJG(Atom_list(i)%Dij_old(t)) End Do End Do if(spindependence) then t = 0 !** Copy new Dij's to 1-D mixing array *** Do j=1, AtomType_Info(Atom_list(i)%TypeIndex)%nlm_Size Do k=1, j t = t + 1 Work_Dijspin(t) = (Atom_List(i)%Dijspin(j,k) + & !** Work_Dij = F(X) CONJG(Atom_List(i)%Dijspin(k,j)))/2 End Do End Do !** Remember that Anderson mixing wants X and F(X)-X ** !** X = Atom_list(i)%Dij_Old and F(X)-X = Work_Dij Work_Dijspin(1:n) = Work_Dijspin(1:n) - Atom_list(i)%Dij_oldspin !** Form F(X)-X write(Log_Unit,*)'Mix DeltaDij = ',i,Dot_Product(Work_Dijspin,Work_Dijspin) !*** Perform the mixing *** Call Anderson_Mix(Atom_List(i)%Dijspin_AC, Atom_list(i)%Dij_Oldspin, & Work_Dijspin(1:n)) !*** Now store the results back in the Dij arrays *** !*** Upon exiting Anderson_Mix Atom_List(i)%Dij_old contains the !*** mixed or new Dij's to use t = 0 Do j=1, AtomType_Info(Atom_list(i)%TypeIndex)%nlm_Size Do k=1, j t = t + 1 Atom_List(i)%Dijspin(j,k) = Atom_list(i)%Dij_oldspin(t) If (j/=k) Atom_List(i)%Dijspin(k,j) = CONJG(Atom_list(i)%Dij_oldspin(t)) End Do End Do endif End Do else Do i=1, Specific_Atoms !** Mix each atom's Dij separately t = 0 !** Copy new Dij's to 1-D mixing array *** Do j=1, AtomType_Info(Atom_list(i)%TypeIndex)%nlm_Size Do k=1, j t = t + 1 Atom_list(i)%Dij_old(t) = (Atom_List(i)%Dij(j,k) + & CONJG(Atom_List(i)%Dij(k,j)))/2 if(spindependence) then Atom_list(i)%Dij_oldspin(t) = (Atom_List(i)%Dijspin(j,k) + & CONJG(Atom_List(i)%Dijspin(k,j)))/2 endif End Do End Do EndDo End If !********* If (DoPrint) then Call WriteWij(Log_Unit) Call WriteDij(Log_Unit) Call WriteQlm(1,Log_Unit) Call WriteQlm(2,Log_Unit) End If If (Atomic_Mode == SIM_AE) then Energy = AtomicEnergy - NuclearEnergy - TildePot_Energy & - TildeKE_Energy - TildeXC_Energy Write(Log_Unit,*) 'CalcHam: Cohesive Energy = ',Energy Write(Log_Unit,*) 'CalcHam: CalcHam = ',Energy-AtomicEnergy Write(Log_Unit,*) 'CalcHam: Atomic Energy = ',AtomicEnergy Write(Log_Unit,*) 'CalcHam: Nuclear Energy = ',NuclearEnergy Write(Log_Unit,*) 'CalcHam: KE = ',TildeKE_Energy Write(Log_Unit,*) 'CalcHam: Pot(uncor) = ',TildePot_Energy Write(Log_Unit,*) 'CalcHam: Pot + En = ',TildePot_Energy & + NuclearEnergy Write(Log_Unit,*) 'CalcHam: XC = ',TildeXC_Energy Write(Log_Unit,*) 'CalcHam: Hat - Hat = ',Hat_Hat_Energy else Energy = TildePot_Energy + TildeKE_Energy + TildeXC_Energy & + OneExc_Energy + Hartree_Energy + Diag_Energy + Hat_Energy Write(Log_Unit,*) 'CalcHam: ' Write(Log_Unit,*) 'CalcHam: Cohesive Energy = ',AtomicEnergy-Energy Write(Log_Unit,*) 'CalcHam: CalcHam = ',Energy Write(Log_Unit,*) 'CalcHam: Atomic = ',AtomicEnergy Write(Log_Unit,*) 'CalcHam: Diag = ',Diag_Energy Write(Log_Unit,*) 'CalcHam: Hartree = ',Hartree_Energy Write(Log_Unit,*) 'CalcHam: Hat = ',Hat_Energy If (XC_Type == XC_LDA_PW) & Write(Log_Unit,*) 'CalcHam: OneExc = ',OneExc_Energy,' (LDA-PW)' If (XC_Type == XC_LSDA_PW) & Write(Log_Unit,*) 'CalcHam: OneExc = ',OneExc_Energy,' (LSDA-PW)' If (XC_Type == XC_GGA_PBE) & Write(Log_Unit,*) 'CalcHam: OneExc = ',OneExc_Energy,' (GGA-PBE)' If (XC_Type == XC_SGGA_PBE) & Write(Log_Unit,*) 'CalcHam: OneExc = ',OneExc_Energy,' (SGGA-PBE)' Write(Log_Unit,*) 'CalcHam: KE~ = ',TildeKE_Energy Write(Log_Unit,*) 'CalcHam: Pot~ = ',TildePot_Energy If (XC_Type == XC_LDA_PW) & Write(Log_Unit,*) 'CalcHam: XC~ = ',TildeXC_Energy,' (LDA-PW)' If (XC_Type == XC_LSDA_PW) & Write(Log_Unit,*) 'CalcHam: XC~ = ',TildeXC_Energy,' (LSDA-PW)' If (XC_Type == XC_GGA_PBE) & Write(Log_Unit,*) 'CalcHam: XC~ = ',TildeXC_Energy,' (GGA-PBE)' If (XC_Type == XC_SGGA_PBE) & Write(Log_Unit,*) 'CalcHam: XC~ = ',TildeXC_Energy,' (SGGA-PBE)' Write(Log_Unit,*) 'CalcHam: Hat - Hat = ',Hat_Hat_Energy Energy = AtomicEnergy - Energy End If Write(Log_Unit,*) 'CalcHam: Smooth Charge = ',Qt If (Atomic_Mode /= SIM_AE) then Write(Log_Unit,*) 'CalcHam: Q^ = ',Qh rmag = Qt+Qh Write(Log_Unit,*) 'CalcHam: Q~+Q^ =',rmag If (ABS(Rmag)>1E-3) then Write(Log_Unit,*) 'CalcHam: ERROR!!! Qt+Qh=',rmag Write(Error_Unit,*) 'CalcHam: ERROR!!! Qt+Qh=',rmag End If End If ! !*** Restrict the potential *** ! If (Filter_potential) then ! Call RestrictPot( Vwork, Den) ! Else ! Den=Vwork ! EndIf !! store current Veff SCFValues%cVe_F(1) = SCFValues%Ve(FFTmap_HIGH(1)) SCFValues%cVe_F(2:Gpnt_Size(G_HIGH)) = & (SCFValues%Ve(FFTmap_HIGH(2:Gpnt_Size(G_HIGH))) + & CONJG(SCFValues%Ve(FFTmap_HIGH(Gpnt_Size(G_HIGH)+1:Gall_Size(G_HIGH)))))/2 If (spindependence) then SCFValues%cVe_Fspin(1) = SCFValues%Vespin(FFTmap_HIGH(1)) SCFValues%cVe_Fspin(2:Gpnt_Size(G_HIGH)) = & (SCFValues%Vespin(FFTmap_HIGH(2:Gpnt_Size(G_HIGH))) + & CONJG(SCFValues%Vespin(FFTmap_HIGH(Gpnt_Size(G_HIGH)+1:Gall_Size(G_HIGH)))))/2 Endif !*** Old V_Mix w/ Vxc and Vlocal *** If (V_MixType == MIX_VEFF) then If (V_NewMix < 0.9999) then Vwork(1) = SCFValues%Ve(FFTmap_HIGH(1)) Vwork(2:Gpnt_Size(G_HIGH)) = & (SCFValues%Ve(FFTmap_HIGH(2:Gpnt_Size(G_HIGH))) + & CONJG(SCFValues%Ve(FFTmap_HIGH(Gpnt_Size(G_HIGH)+1:Gall_Size(G_HIGH)))))/2 Den(1:Gpnt_Size(G_HIGH)) = Vwork(1:Gpnt_Size(G_HIGH)) - & SCFvalues%Ve_Fourier(1:Gpnt_Size(G_HIGH)) Write(Log_Unit,*)'Mix DeltaVeff',Dot_Product(Den(1:Gpnt_Size(G_HIGH)),& Den(1:Gpnt_Size(G_HIGH))) Call Anderson_Mix(SCFvalues%AC, & SCFvalues%Ve_Fourier(1:Gpnt_Size(G_HIGH)), & Den(1:Gpnt_Size(G_HIGH))) SCFValues%Ve = 0 SCFValues%Ve(FFTmap_HIGH(1:Gpnt_Size(G_HIGH))) = & SCFvalues%Ve_Fourier(1:Gpnt_Size(G_HIGH)) SCFValues%Ve(FFTmap_HIGH(Gpnt_Size(G_HIGH)+1:)) = & CONJG(SCFvalues%Ve_Fourier(2:Gpnt_Size(G_HIGH))) else SCFvalues%Ve_Fourier(1:) = SCFValues%Ve(FFTmap_HIGH(1)) SCFvalues%Ve_Fourier(2:Gpnt_Size(G_HIGH)) = & (SCFValues%Ve(FFTmap_HIGH(2:Gpnt_Size(G_HIGH))) + & CONJG(SCFValues%Ve(FFTmap_HIGH(Gpnt_Size(G_HIGH)+1:Gall_Size(G_HIGH)))))/2 End If End If !*** Calc the change in the old and new potentials *** Call PerformFFT(FFT_TO_R, G_HIGH, SCFValues%Ve) !** write(6,*) 'potential sum' , sum(den) if(spindependence) then !*** Old V_Mix w/ Vxc and Vlocal *** If (V_MixType == MIX_VEFF) then If (V_NewMix < 0.9999) then Vwork(1) = SCFValues%Vespin(FFTmap_HIGH(1)) Vwork(2:Gpnt_Size(G_HIGH)) = & (SCFValues%Vespin(FFTmap_HIGH(2:Gpnt_Size(G_HIGH))) + & CONJG(SCFValues%Vespin(FFTmap_HIGH(Gpnt_Size(G_HIGH)+1:Gall_Size(G_HIGH)))))/2 Den(1:Gpnt_Size(G_HIGH)) = Vwork(1:Gpnt_Size(G_HIGH)) - & SCFvalues%Ve_Fourierspin(1:Gpnt_Size(G_HIGH)) Write(Log_Unit,*)'Mix DeltaVeff',Dot_Product(Den(1:Gpnt_Size(G_HIGH)),& Den(1:Gpnt_Size(G_HIGH))) Call Anderson_Mix(SCFvalues%ACspin, & SCFvalues%Ve_Fourierspin(1:Gpnt_Size(G_HIGH)), & Den(1:Gpnt_Size(G_HIGH))) SCFValues%Vespin = 0 SCFValues%Vespin(FFTmap_HIGH(1:Gpnt_Size(G_HIGH))) = & SCFvalues%Ve_Fourierspin(1:Gpnt_Size(G_HIGH)) SCFValues%Vespin(FFTmap_HIGH(Gpnt_Size(G_HIGH)+1:)) = & CONJG(SCFvalues%Ve_Fourierspin(2:Gpnt_Size(G_HIGH))) else SCFvalues%Ve_Fourierspin(1:) = SCFValues%Vespin(FFTmap_HIGH(1)) SCFvalues%Ve_Fourierspin(2:Gpnt_Size(G_HIGH)) = & (SCFValues%Vespin(FFTmap_HIGH(2:Gpnt_Size(G_HIGH))) + & CONJG(SCFValues%Vespin(FFTmap_HIGH(Gpnt_Size(G_HIGH)+1:Gall_Size(G_HIGH)))))/2 End If End If !*** Calc the change in the old and new potentials *** Call PerformFFT(FFT_TO_R, G_HIGH, SCFValues%Vespin) !** write(6,*) 'potential sum' , sum(den) endif Write(Log_Unit,*) ' ' Write(Log_Unit,*) 'CalcHam: Change in Wij (atom, change):' Qt = 0 Do i=1, Specific_Atoms Atom_List(i)%Wij_Old = Atom_List(i)%Wij - Atom_List(i)%Wij_Old gmag = SUM(CONJG(Atom_List(i)%Wij_Old) * Atom_List(i)%Wij_Old) Qt = Qt + gmag Write(Log_Unit,*) 'CalcHam:CWij ',i, gmag End Do if(spindependence) then Do i=1, Specific_Atoms Atom_List(i)%Wij_Oldspin = Atom_List(i)%Wijspin - Atom_List(i)%Wij_Oldspin gmag = SUM(CONJG(Atom_List(i)%Wij_Oldspin) * Atom_List(i)%Wij_Oldspin) Qt = Qt + gmag Write(Log_Unit,*) 'CalcHam:CWijdn ',i, gmag End Do endif Write(Log_Unit,*) 'CalcHam:CWij Total Change in Wij:', Qt DeAllocate(Den,ProjDotPsi) !*** Free the big arrays *** if(spindependence) DeAllocate(Denspin) Call PrintDate(Log_Unit, 'CalcHam: Finished Routine!') Call Stop_Timer(Timer(CalcHam_Timer)) Prev_CohesiveEnergy(1) = Prev_CohesiveEnergy(2) Prev_CohesiveEnergy(2) = energy HamLoaded=.true. DeAllocate(Psi_toUse) Return End Subroutine !****************************************************************************** ! ! CalcBandMerit - Calculates the band structure merit function. ! !****************************************************************************** Subroutine CalcBandMerit( Energy) Real, Intent(OUT) :: Energy Integer :: i, Kpnt Call Start_Timer(Timer(CalcHam_Timer)) !!!! Call CalcEigenValues -- eigenvalues already determined Energy = 0 Do Kpnt=1, NumKpnts Do i=1, Mem_MapSize If (PsiInfo(i)%Kpnt == Kpnt) then If (PsiInfo(i)%Energy <= Eigen_Max) then Energy = Energy + ABS(PSiInfo(i)%Energy) End If End If End Do end Do Call Stop_Timer(Timer(CalcHam_Timer)) Return End Subroutine !****************************************************************************** ! ! CalcMeritFunction - Calculates the Merit function ! Normally CalcHam is called unless BandStructure_Mode = .TRUE. then ! H is assumed to be fixed and the Band structure merit function is called ! !****************************************************************************** Subroutine CalcMeritFunction( Energy) Real, Intent(OUT) :: Energy If (BandStructure_Mode) then Call CalcBandMerit(Energy) else Call CalcHam( Energy) End If Return End Subroutine !****************************************************************************** ! ! InitHam - Initializes the HAmiltonian module ! !****************************************************************************** Subroutine InitHam Integer :: i,j, Rad_Size Type (atom_info_fixed), Pointer :: AT Complex, Pointer :: Work(:), Work2(:) Prev_CohesiveEnergy = 1E30 write(Log_unit,*) 'Entering InitHam' call flush(Log_Unit) Allocate(BandMap(2,Mem_MapSize),stat=i) If (i /= 0) then Write(Error_Unit,*) 'InitHam: Failed to allocate BandMap',i Call Flush(Error_Unit) stop EndIf If (Atomic_Mode == SIM_AE) RETURN !** Ignore the rest if an AE calc !RETURN !**REMOVE** Debug Only !** Calculate the radial hat functions If (Atomic_Mode /= SIM_SEPM) Call CalcRadialHat Call CalcRadial_Vlocal !** Calculate the radial V_local functions Call CalcVlocal(SCFvalues%V_local) Call CalcCoreTail(SCFvalues%CoreTail) write(Log_unit,*) 'InitHam: SCFvalues%CoreTail', SCFvalues%CoreTail(1) call flush(Log_Unit) If (Atomic_Mode == SIM_SEPM) then Call GetBuffer( Work2) Work => SCFvalues%V_Local Work2(1:Gpnt_Size(G_LOW)) = Work(1:Gpnt_Size(G_Low)) SCFvalues%Ve_Fourier = Work(1:Gpnt_Size(G_LOW)) Work2(Gpnt_Size(G_LOW)+1:) = & Work(Gpnt_Size(G_high)+1:Gpnt_Size(G_High)+Gpnt_size(G_low)-1) Work => SCFvalues%Work Work = 0 Call RS_toR(Work2, Work) SCFvalues%Ve = Work !SCFvalues%Ve = 0 Call FreeBuffer(Work2) RETURN !*** EXIT EARLY *** End IF Do i=1, Atom_Types AT => AtomType_Info(i) Allocate(AT%Rad_Size, AT%Rad_Skip) !AT%Mesh_Size = At%Mesh_Size - 2 !*** DEBUG ONLY **** !AT%Mesh_Size = At%Mesh_Size-1 !*** DEBUG ONLY * for li Rad_Size = 0 Do j=1, AT%Mesh_Size, AtomicVxc_Step Rad_Size = Rad_Size + 1 End Do AT%Rad_Size = Rad_Size AT%Rad_Skip = AtomicVxc_Step !note this is always 1 unless ! we fix the Core_Density part!!! Write(Log_Unit,*) 'InitHam: ',' * Atom=',i, & ' * SIZE=',AT%Rad_Size, & ' * SKIP=',AT%Rad_Skip call flush(Log_unit) End Do !**** Prepare the Vxc data structures ***** !************ Generate the Angular Integration points *************** !Call InitSpharm Num_AngPoints = Angular_Points**2 AngPoints => AngInit(Angular_Points,Angular_Points,Xtal%Volume,Error_Unit) Do i=1, Atom_Types AT => AtomType_Info(i) Call PrepareVxc(AT) End Do !*** Allocate space for Dij mixing *** i = MaxVal(AtomType_Info(:)%nlm_size) i = i*(i+1)/2 Allocate(Work_Dij(i),stat=j) if(spindependence) Allocate(Work_Dijspin(i), stat=j) If (j /= 0) then Write(Error_Unit,*) 'InitHam: Failed to allocate BandMap',j Call Flush(Error_Unit) stop EndIf !*** Init the Dij Mixing *** Do i=1, Specific_Atoms j = AtomType_Info(Atom_List(i)%TypeIndex)%nlm_Size j = j*(j+1)/2 Call InitAnderson(Atom_List(i)%Dij_AC, Error_Unit, Mix_Size, & j, 1E-5, Dij_NewMix, AndersonConditionNo) if(spindependence) then Call InitAnderson(Atom_List(i)%Dijspin_AC, Error_Unit, Mix_Size, & j, 1E-5, Dij_NewMix, AndersonConditionNo) endif End Do Return End Subroutine End Module spinpwpaw/code/hamop.f900100664004704100470410000003137010303710172015267 0ustar natalienatalie!****************************************************************************** ! ! File : hamop.f90 ! originally in hamiltonian.f90 ! by : Alan Tackett ! on : 02/07/97 ! for : PAW ! ! Module for calculating the Hamiltonian and Cohesive Energy of the PAW ! system. Also contains routines to do H*Psi and O*Psi. ! ! Contains routines of the type H*Psi ! ! Updated for spin by Ping Tang and N. A. W. Holzwarth ! Last change 5/25/05 !****************************************************************************** Module hamop Use atom_data Use basis_lib Use crystal_data Use gpoints Use laplacian Use memmgr Use oinverse Use options_data Use paw_inout Use psilib Use projectors Use spherical_harmonic Implicit NONE!!!! !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! Hpsi - Multiplies the Hamiltonian times the Given Wave vector ! and returns the result ! ! Psi - Wave vector to multiply. NO Bloch K and DetJ!!!! ! Hx - Output result. Hx is initialized to 0! ! Kpnt - K-point array index ! ! KE - Work Array ! !****************************************************************************** Subroutine Hpsi( Psi, Hx, Ve, ProjDotPsi, Kpnt, PDOT_Stored) Complex, Intent(IN) :: Psi(:) Complex, Intent(IN) :: Ve(:) Complex, Intent(INOUT) :: Hx(:) Complex, Intent(INOUT) :: ProjDotPsi(:) Integer, Intent(IN) :: Kpnt Logical, Intent(INOUT) :: PDOT_Stored Complex, Pointer :: Work(:) Integer :: i,j,k Call Start_Timer(Timer(HPsi_Timer)) If (Atomic_Mode == SIM_TIME) then Call CalcDEL2_TIME( BZ%Ku(:,Kpnt), Psi, Hx) else Call CalcDEL2_Phase( BZ%Ku(:,Kpnt), Psi, Hx) Hx = -Hx End If Work => SCFvalues%Work If (Atomic_Mode == SIM_SEPM) then Call RS_toR(Psi, Work) Work = V_Weight*Ve*Work Call RS_toG(Work, Hx) else if (Proj_Mode == PROJ_RS) then Call RS_toR(Psi, Work) If (.NOT. PDOT_Stored) then Call CalcProjProducts(Work, ProjDotPsi) PDOT_Stored = .TRUE. End If Work = V_Weight*Ve*Work Call AccumProj(Work, ProjDotPsi, DijMatrix) Call RS_toG(Work, Hx) else Call V_G_to_r(Psi,G_LOW,Work,G_HIGH) Work = V_Weight*Ve*Work Call V_r_to_G(Work,G_HIGH,Hx,G_LOW) If (.NOT. PDOT_Stored) then Call CalcProjProducts(Psi, ProjDotPsi) PDOT_Stored = .TRUE. End If Call AccumProj(Hx, ProjDotPsi, DijMatrix) End If Call Stop_Timer(Timer(HPsi_Timer)) Return End Subroutine !****************************************************************************** ! ! Opsi - Multiplies the Overlap matrix times the Given Wave vector ! and returns the result ! ! Psi - Wave vector to multiply. ! Ox - Output result. Ox is initialized to 0! ! ProjDotPsi - Array containing the projector psi dot products ! Kpnt - Kpnt array index ! !****************************************************************************** Subroutine Opsi( Psi, Ox, ProjDotPsi, Kpnt, PDOT_Stored) Complex, Intent(IN) :: Psi(:) Complex, Intent(OUT) :: Ox(:) Complex, Intent(INOUT) :: ProjDotPsi(:) Integer, Intent(IN) :: Kpnt Logical, Intent(INOUT) :: PDOT_Stored Complex, Pointer :: Work(:) COmplex :: xOx Real :: temp !Ox = Psi !RETURN !***REMOVE** Debug Call Start_Timer(Timer(OPsi_Timer)) Ox = Psi If (Atomic_Mode == SIM_SEPM) then !** Don't do anything ** else If (Proj_Mode == PROJ_RS) then Work => SCFvalues%Work If (.NOT. PDOT_Stored) then Call RS_toR(Psi, Work) Call CalcProjProducts(Work, ProjDotPsi) PDOT_Stored = .TRUE. End If Work = 0 Call AccumProj(Work, ProjDotPsi, OijMatrix) Call RS_toG(Work, Ox) else If (.NOT. PDOT_Stored) then Call CalcProjProducts(Psi, ProjDotPsi) PDOT_Stored = .TRUE. End If Call AccumProj(Ox, ProjDotPsi, OijMatrix) End If Call Stop_Timer(Timer(OPsi_Timer)) Return End Subroutine !****************************************************************************** ! ! CalcHxandOx - Calculates H and O times the given Psi ! ! Psi - Wave vector to multiply. NO Bloch K and DetJ!!!! ! Hx - Output result. Hx is initialized to 0! ! Ox - Output result. Ox is initialized to 0! ! Kpnt - K-point array index ! !****************************************************************************** Subroutine CalcHxandOx( Psi, Hx, Ox, Ve, PDOT, Kpnt, PDOT_Stored) Complex, Intent(IN) :: Psi(:) Complex, Intent(IN) :: Ve(:) Complex, Intent(OUT) :: Hx(:) Complex, Intent(OUT) :: Ox(:) Complex, Intent(INOUT) :: PDOT(:) Integer, Intent(IN) :: Kpnt Logical, Intent(INOUT) :: PDOT_Stored !* Complex :: PDOT(PLM_Max) Complex, Pointer :: KE(:), Work(:) Integer :: i,j !----- Call Start_Timer(Timer(HandOPsi_Timer)) Call CalcDEL2_Phase( BZ%Ku(:,Kpnt), Psi, Hx) Hx = -Hx Work => SCFvalues%Work If (Atomic_Mode == SIM_SEPM) then Call RS_toR(Psi, Work) Work = V_Weight*Ve*Work Call RS_toG(Work, Hx) Ox = Psi else If (Proj_Mode == PROJ_RS) then Call RS_toR(Psi, Work) Ox = Psi If (.NOT. PDOT_Stored) then Call CalcProjProducts(Work, PDot) PDOT_Stored = .TRUE. End If RS_Work1 = V_Weight*Ve*Work Work = 0 Call AccumBothProj(RS_Work1, Work, PDot, DijMatrix, OijMatrix) Call RS_toG(RS_Work1, Hx) Call RS_toG(Work, Ox) else Call V_G_to_r(Psi,G_LOW,Work,G_HIGH) Work = V_Weight*Ve*Work Call V_r_to_G(Work,G_HIGH,Hx,G_LOW) If (.NOT. PDOT_Stored) then Call CalcProjProducts(Psi, PDot) PDOT_Stored = .TRUE. End If Ox = Psi Call AccumBothProj(Hx, Ox, PDot, DijMatrix, OijMatrix) End If Call Stop_Timer(Timer(HandOPsi_Timer)) Return End subroutine !****************************************************************************** ! ! Calc_HOiH_Hx_Ox - Calculates HOiH, H and O times the given Psi ! ! Psi - Wave vector to multiply. NO Bloch K and DetJ!!!! ! HOiHx - Output result. Initialized to 0! ! Hx - Output result. Hx is initialized to 0! ! Ox - Output result. Ox is initialized to 0! ! Kpnt - K-point array index ! !****************************************************************************** Subroutine Calc_HOiHx_Hx_Ox( Psi, HOiHx, Hx, Ox, Ve, PDOT, Kpnt, PDOT_Stored, Eo, Ewidth) Complex, Intent(IN) :: Psi(:) Complex, Intent(IN) :: Ve(:) Complex, Intent(OUT) :: HOiHx(:) Complex, Intent(OUT) :: Hx(:) Complex, Intent(OUT) :: Ox(:) Complex, Intent(INOUT) :: PDOT(:) Integer, Intent(IN) :: Kpnt Logical, Intent(INOUT) :: PDOT_Stored Real, Intent(IN) :: Eo Real, Intent(IN) :: Ewidth !Complex :: PDOT_OiHx(PLM_Max) Complex ,allocatable:: PDOT_OiHx(:) Complex, Pointer :: KE(:), Work(:), W2(:), W3(:) Integer :: i,j Allocate(PDOT_OiHx(PLM_Max)) Call CalcDEL2_Phase( BZ%Ku(:,Kpnt), Psi, Hx) Hx = -Hx Work => SCFvalues%Work If (Proj_Mode == PROJ_RS) then Call RS_toR(Psi, Work) If (.NOT. PDOT_Stored) then Call CalcProjProducts(Work, PDot) PDOT_Stored = .TRUE. End If RS_Work1 = V_Weight*Ve*Work Call AccumBothProj(RS_Work1, Work, PDot, DijMatrix, OijMatrix) RS_Work2 = Work !** Copy Ox into a temp space Ox = 0 Call RS_toG(Work, Ox) Work = 0 Call RS_toR(Hx, Work) !** Make sure we add the KE in RS Work = Work + RS_Work1 - Eo*RS_Work2 !** Start the shift Call RS_toG(RS_Work1, Hx) !HOiHx = 0 !Call RS_toG(Work, HOiHx) !RETURN !*** Now calculate HOiHx *** Call CalcOinverse(Work, kpnt) !** Work = OiHx after call RS_Work1 = Work !** Need OiHx in both RS and GS Call Getbuffer( W2) W2 = 0 Call RS_toG(Work, W2) Call CalcDEL2_Phase( BZ%Ku(:,Kpnt), W2, HOiHx) HOiHx = -HOiHx Call Freebuffer(W2) Call CalcProjProducts(RS_Work1, PDot_OiHx) RS_Work1 = V_Weight*Ve*RS_Work1 - Eo*RS_Work1 Work = 0 Call AccumBothProj(RS_Work1, Work, PDot_OiHx, DijMatrix, OijMatrix) RS_Work1 = RS_Work1 - Eo*Work Call RS_toG(RS_Work1, HOiHx) HOiHx = HOiHx/Ewidth**2 !** Re-scale the answer else Call V_G_to_r(Psi,G_LOW,Work,G_HIGH) Work = V_Weight*Ve*Work Call V_r_to_G(Work,G_HIGH,Hx,G_LOW) If (.NOT. PDOT_Stored) then Call CalcProjProducts(Psi, PDot) PDOT_Stored = .TRUE. End If Ox = Psi Call AccumBothProj(Hx, Ox, PDot, DijMatrix, OijMatrix) !*** Now calculate HOiHx *** HOiHx = Hx - Eo*Ox !** Shift the spectrum Call CalcOinverse(HOiHx, kpnt) ! Call GetBuffer( W3) ! W3 = HOiHx Call CalcProjProducts(HOiHx, PDot_OiHx) Call GetBuffer( W2) Call CalcDEL2_Phase( BZ%Ku(:,Kpnt), HOiHx, W2) Call V_G_to_r(HOiHx,G_LOW,Work,G_HIGH) Work = V_Weight*Ve*Work HOiHx = -W2 - Eo*HOiHx Call V_r_to_G(Work,G_HIGH,HOiHx,G_LOW) Call PerformFFT(FFT_TO_G, G_HIGH, Work) W2 = 0 Call AccumBothProj(HOiHx, W2, PDot_OiHx, DijMatrix, OijMatrix) HOiHx = HOiHx - Eo*W2 HOiHx = HOiHx/Ewidth**2 !** Re-scale the answer Call FreeBuffer(W2) End If DeAllocate(PDOT_OiHx) Return End subroutine !****************************************************************************** ! ! CalcMagAndEnergy - Calculates the energy and magnitude of the given band ! ! PsiBand - Wave vector to multiplies band ! Energy - Wave function energy ! Mag - Magnitude of the wave function ! !****************************************************************************** ! This routine is not compatable with spin !Subroutine CalcMagAndEnergy( PsiBand, Energy, Mag) ! Integer, Intent(IN) :: PsiBand ! Real, Intent(OUT) :: Energy ! Real, Intent(OUT) :: Mag ! Complex, Pointer :: Hx(:), Psi(:), KE(:), Ox(:) !Complex, TARGET :: PDot(PLM_Max) ! Complex, TARGET , allocatable :: PDot(:) ! Integer :: Kpnt ! Allocate(PDot(PLM_Max)) ! Call GetBuffer( Hx) ! Call GetBuffer( Psi) ! Call GetBuffer( Ox) ! Kpnt = PsiInfo(PsiBand)%Kpnt ! Call GetPsi_fromBuffer( PsiBand, Psi) ! Call CalcHxandOx( Psi, Hx, Ox, & ! PsiInfo(PsiBand)%PDOT, Kpnt, PSiInfo(PsiBand)%PDOT_Stored) ! Energy = Basis_DotProd( Psi,Hx, .FALSE.) ! Mag = Basis_DotProd( Psi,Ox, .FALSE.) ! Call Freebuffer(Psi) ! Call FreeBuffer(Hx) ! Call FreeBuffer(Ox) ! DeAllocate(PDot) ! Return !End Subroutine !****************************************************************************** ! ! CalcEigenValues - Calculates the Energy eigenvalues for each ! wave function ! !****************************************************************************** Subroutine CalcEigenValues !Integer :: Psi_toUse(Mem_MapSize), i, Flag, Kpnt Integer :: i, Flag, Kpnt Integer ,allocatable:: Psi_toUse(:) Complex, Pointer :: Hx(:) Complex, Pointer :: Ve(:) Real :: DV Type(Mem_Handle), Pointer :: Psi !Complex :: PDot(PLM_Max) Complex ,allocatable :: PDot(:) Allocate(Psi_toUse(Mem_MapSize),PDot(PLM_Max)) Call Getbuffer( Hx) if(.NOT.spindependence) then Do Kpnt=1, NumKpnts Psi_toUse = MH_Skip Where (PsiInfo(:)%Kpnt == Kpnt) Psi_toUse = MH_toProcess Call Phase_Generic( Psi_toUse, Kpnt) Call GetNextPsi(Flag, Psi) Do While (Flag > 0) i = Psi%Index PsiInfo(i)%DoSave=1 PsiInfo(i)%Available=Mem_Used Call Hpsi( Psi%Ptr, Hx, SCFValues%Ve, PsiInfo(i)%PDot, Kpnt, & PsiInfo(i)%PDOT_Stored) PsiInfo(Psi%Index)%Energy = Basis_DotProd(Psi%Ptr, Hx, .FALSE.) !write(Log_Unit,*) 'CalcEigenValues: DI=',Psi%Index, ' * New=',PsiInfo(Psi%Index)%Energy Call GetNextPsi(Flag, Psi) End Do End do else Do Kpnt=1, NumKpnts Psi_toUse = MH_Skip Where (PsiInfo(:)%Kpnt == Kpnt ) Psi_toUse = MH_toProcess Call Phase_Generic( Psi_toUse, Kpnt) Call GetNextPsi(Flag, Psi) Do While (Flag > 0) i = Psi%Index PsiInfo(i)%DoSave=1 PsiInfo(i)%Available=Mem_Used If(PsiInfo(i)%spinup) then Ve=>SCFvalues%Ve else Ve=>SCFvalues%Vespin endif Call Hpsi( Psi%Ptr, Hx, Ve, PsiInfo(i)%PDot, Kpnt, & PsiInfo(i)%PDOT_Stored) PsiInfo(Psi%Index)%Energy = Basis_DotProd(Psi%Ptr, Hx, .FALSE.) !write(Log_Unit,*) 'CalcEigenValues: DI=',Psi%Index, ' * New=',PsiInfo(Psi%Index)%Energy Call GetNextPsi(Flag, Psi) End Do End do endif Call FreeBuffer(Hx) DeAllocate(Psi_toUse,PDot) Return End Subroutine End Module spinpwpaw/code/hamsym.f900100664004704100470410000001552510303710172015465 0ustar natalienatalie!****************************************************************************** ! ! File : hamsym.f90 ! originally from hamiltonian.f90 ! by : Alan Tackett ! on : 02/07/97 ! for : PAW ! ! Module for calculating the Hamiltonian and Cohesive Energy of the PAW ! system. Also contains routines to do H*Psi and O*Psi. ! ! contains symmetry related functions ! ! Updated for spin by Ping Tang and N. A. W. Holzwarth ! Last change 5/25/05 !****************************************************************************** Module hamsym Use atom_data Use basis_lib Use crystal_data Use crystal_symmetry Use gpoints Use mathlib Use options_data Use paw_inout Use spherical_harmonic Implicit NONE!!!! !****************************************************************************** Contains !****************************************************************************** ! ! SymRho - Symmetrizes the density based on the crystal symmetry operations ! ! Rho - The Density to symmetrize ! ! ** Uses plane waves ** !****************************************************************************** Subroutine SymRho( Den, Work) Complex , Intent(INOUT) :: Den(:) Complex , Intent(INOUT) :: Work(:) Integer :: i,j,k1,s Real :: R(3), Rp(3), gcut, mag, arg Complex :: zsum, zterm Integer :: Nx, Ny, Nz, Gi(3), N(3), M1(3), M2(3) Call Start_Timer(Timer(SymRho_Timer)) write(log_unit,*) 'SymRho: Begin' call flush(log_unit) Nx = FFT_Grid(1,G_HIGH) Ny = FFT_Grid(2,G_HIGH) Nz = FFT_Grid(3,G_HIGH) !Work = 0 !Call PerformFFT(FFT_TO_G, G_HIGH, Den, Work) !write(6,*) 'after PerformFFT', Work(1) Work = Den Call PerformFFT(FFT_TO_G, G_HIGH, Work) write(Log_Unit,*) 'SymRho: Start Q=', Work(1) call flush(log_unit) Den = 0 Den(1) = Work(1) Do i=2, Gpnt_Size(G_HIGH) Gi = Npnt(:,i) Zsum = 0 Do j=1, Xtal%Rot_Size N = MatMul(Igrot(:,:,j),Gi) arg = DOT_PRODUCT(N, xtal%Trans(:,j)) If (ABS(Arg) > 1E-8) then arg = Two_PI*arg zterm = CMPLX(cos(arg),sin(arg)) else zterm = CMPLX(1,0) End If M1 = N + 1 Where (M1<=0) M1 = M1 + FFT_Grid(1:3,G_High) IF ((M1(1)<=Nx) .AND. (M1(1)>0) .AND. & (M1(2)<=Ny) .AND. (M1(2)>0) .AND. & (M1(3)<=Nz) .AND. (M1(3)>0)) then k1 = CalcLinearIndex(FFT_Grid(:,G_HIGH), M1)+1 zsum = zsum + Work(k1)*zterm !write(6,'("SymRho",12i4)') i,j,Gi,N,M1,k1 else write(error_unit,*) 'Symrho: bad rotation',j,Gi,N STOP End If End Do zsum = zsum/xtal%Rot_Size Den(FFTmap_High(i)) = zsum !write(6,*) 'sum',FFTmap_High(i),zsum Den(FFTmap_High(i+Gpnt_Size(G_High)-1)) = CONJG(zsum) !write(6,*) 'sum*',FFTmap_High(i+Gpnt_Size(G_HIGH)-1),CONJG(zsum) End Do write(Log_Unit,*) 'SymRho: After SymRho Q=', Den(1) Call PerformFFT(FFT_TO_R, G_HIGH, Den) ! write(6,*) 'in SymRho sum', sum(den) write(log_unit,*) 'in SymRho sum', sum(den) call flush(log_unit) Call Stop_Timer(Timer(SymRho_Timer)) Return End Subroutine !****************************************************************************** ! ! SymWij - Symmetrizes the Wij coefficients ! !****************************************************************************** Subroutine SymWij type Wij_Atom Complex, Pointer :: Wij(:,:) End Type Integer :: i,j,k, nili, njlj, Li, Lj,mi1, mj1, mi2, mj2, Basis_Size Integer :: ibase, jbase Real :: c Complex :: zsum Complex, Pointer :: Wij(:,:), Wij_Copy(:,:) Type (Wij_Atom) :: Wij_List(Specific_Atoms) Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT Character*100 :: Msg write(log_unit,*) 'SymWij: Begin' call flush(log_unit) c = 1.0/XTal%Rot_Size Do i=1, Specific_Atoms !**** Make a temp copy of Wij **** A => Atom_List(i) AT => AtomType_Info(A%TypeIndex) j=AT%nlm_Size Allocate(Wij_List(i)%Wij(j, j), STAT=k) Write(MSg,*) "SymWij: Error Allocating Temp array for atom:",i Call Check_Error(k, Msg, Error_Unit, .TRUE., IDTEXT="SymWij:") Wij_List(i)%Wij = A%Wij End Do Do i=1, Specific_Atoms !*** Symmetrize Wij A => Atom_List(i) AT => AtomType_Info(A%TypeIndex) Basis_Size = AT%Basis_Size Wij => A%Wij Do nili=1, Basis_Size Li = AT%L_Value(nili) ibase = AT%nl_Base(nili)+Li Do mi1=-Li, Li Do njlj=1, Basis_Size Lj = AT%L_Value(njlj) jbase = AT%nl_Base(njlj)+Lj Do mj1=-Lj, Lj zsum = 0 Do j=1, XTal%Rot_Size Wij_Copy => Wij_List(iatrans(i,j))%Wij Do mi2=-Li, Li Do mj2=-Lj, Lj zsum= zsum + (zarot(mi2+Li+1,mi1+Li+1,Li+1,j)) & *CONJG(zarot(mj2+Lj+1,mj1+Lj+1,Lj+1,j)) & *Wij_copy(ibase+mi2, jbase+mj2) End Do End Do End Do Wij(ibase+mi1, jbase+mj1) = zsum*c End Do End Do !**njlj End Do End Do !**nili End Do write(Log_unit,*) 'SymWij: Finish non spin part' call flush(log_unit) write(Log_unit,*) 'spindependence', spindependence call flush(log_unit) if(spindependence) then Do i=1, Specific_Atoms !**** Make a temp copy of Wij **** A => Atom_List(i) Wij_List(i)%Wij = A%Wijspin End Do Do i=1, Specific_Atoms !*** Symmetrize Wij A => Atom_List(i) AT => AtomType_Info(A%TypeIndex) Basis_Size = AT%Basis_Size Wij => A%Wijspin Do nili=1, Basis_Size Li = AT%L_Value(nili) ibase = AT%nl_Base(nili)+Li Do mi1=-Li, Li Do njlj=1, Basis_Size Lj = AT%L_Value(njlj) jbase = AT%nl_Base(njlj)+Lj Do mj1=-Lj, Lj zsum = 0 Do j=1, XTal%Rot_Size Wij_Copy => Wij_List(iatrans(i,j))%Wij Do mi2=-Li, Li Do mj2=-Lj, Lj zsum= zsum + (zarot(mi2+Li+1,mi1+Li+1,Li+1,j)) & *CONJG(zarot(mj2+Lj+1,mj1+Lj+1,Lj+1,j)) & *Wij_copy(ibase+mi2, jbase+mj2) End Do End Do End Do Wij(ibase+mi1, jbase+mj1) = zsum*c End Do End Do !**njlj End Do End Do !**nili End Do write(Log_unit,*) 'SymWij: Finish spin part' call flush(log_unit) End if Do i=1, Specific_Atoms !*** Free Wij Copy DeAllocate(Wij_List(i)%Wij) End Do Return End Subroutine End module spinpwpaw/code/hamvxc.f900100664004704100470410000017241010303710172015452 0ustar natalienatalie!****************************************************************************** ! ! File : hamvxc.f90 ! originally in hamiltonian.f90 ! by : Alan Tackett ! on : 02/07/97 ! for : PAW ! ! Module for calculating the Hamiltonian and Cohesive Energy of the PAW ! system. Also contains routines to do H*Psi and O*Psi. ! ! Constains terms pertaining to vxc ! ! Updated for spin by Ping Tang and N. A. W. Holzwarth ! Last change 5/25/05 !****************************************************************************** Module hamvxc Use atom_data Use crystal_data Use exchange_corr Use gpoints Use mathlib Use options_data Use paw_inout Use projectors Use spherical_harmonic Implicit NONE!!!! !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ~a a ! AccumVxc_LDA - Accumulates the Exchange correlation pot for N + N to Dij ! for LDA in Perdew_Wang form only ! ! R=0 is included!!!!!!!!!! ! !****************************************************************************** Subroutine AccumVxc_LDA( Energy) Real, Intent(INOUT) :: Energy Integer :: i,j,k, nili, njlj, mi, mj, Li, Lj, Rk, RS, count Integer ::nklk, nlll, mk, ml, Lk, Ll, alpha, Basis_Size, Rad_Size Integer :: ibase,jbase,kbase,lbase, Skip_Size, Rad_Index, Mesh_Size Integer, pointer :: nl_base(:), nlm_lut(:,:) Complex, Pointer :: Dij(:,:), Wij(:,:), Ylm(:,:,:) Real, Pointer :: R2(:), Phi_ij_R2(:), TPhi_ij_R2(:) Real, Pointer :: CoreXC(:), CoreDen(:),FnRad(:,:) Complex :: Ylm_l(13), Ylm_k(13), ylm1, ylm2 Complex, Pointer :: Ylm_i(:), Ylm_j(:) Real :: Vxc1, Exc1, Vxc2, Exc2, fnint, Esum, PhiRk, TPhiRk Complex :: den_phi, den_Tphi, den Real :: Efn,fn,Fnsum Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT Real :: DR Real, Pointer :: Cij(:,:) Character*100 :: Msg if(spindependence) then write(error_unit, *) 'AccumVxc_LDA: error -- spindependence should be false' stop endif Call Start_Timer(Timer(AtomVxc_Timer)) ! Write(msg,*) 'AccumVxc: Error allocating Cij. Size=',Basis_Size ! Call Check_Error(j, msg, Error_Unit, .TRUE.,paw_wc, "AccumVxc:") write(log_unit,*) 'AccumVxc_LDA: start' call flush(log_unit) Do i=1, Specific_Atoms A => Atom_List(i) AT => AtomType_Info(A%TypeIndex) nl_base => AT%nl_Base nlm_LUT => AT%nlm_LUT Wij => A%Wij Dij => A%Dij CoreDen => AT%Core_Density CoreXC => AT%Core_Xchange R2 => AT%R2 Ylm => AT%Ylm Cij => AT%Cij FnRad => AT%FnRad Mesh_size = AT%Rad_Size DR = AT%Mesh_Step*AT%Rad_Skip Basis_Size = AT%Basis_Size FnSum = 0; ESum = 0 Do alpha = 1, Num_AngPoints Cij = 0 Do nili=1, Basis_Size !*** Calulate Cij for n^a and n~^a Li = AT%L_Value(nili) Ylm_i => Ylm(:, Li+1, alpha) ibase = nl_Base(nili); ibase = ibase + nlm_lut(2,ibase); Do njlj=1, Basis_Size Lj = AT%L_Value(njlj) Ylm_j => Ylm(:, Lj+1, alpha) jbase = nl_Base(njlj); jbase = jbase + nlm_lut(2,jbase); den = 0 Do mi = -Li, Li ylm1 = CONJG(Ylm_i(mi+Li+1)) Do mj=-Lj, Lj ylm2 = Ylm_j(mj+Lj+1) den = den + Wij(ibase+mi,jbase+mj) * Ylm1 * Ylm2 End Do End Do Cij(nili, njlj) = Den End do End Do !**** Calculate the Radial Densities and store them ***** FnRad = 0 Count = 0 Do nili=1, Basis_Size Do njlj=1, Basis_Size count = count + 1 Phi_ij_R2 => AT%Phi_ij_R2(:,count) TPhi_ij_R2 => AT%TPhi_ij_R2(:,count) FnRad(1:Mesh_Size,1)=FnRad(1:Mesh_Size,1) & + Cij(nili,njlj)*Phi_ij_R2(1:Mesh_Size) FnRad(1:Mesh_Size,2)=FnRad(1:Mesh_Size,2) & + Cij(nili,njlj)*TPhi_ij_R2(1:Mesh_Size) End Do End Do !*** Add CoreDen *** FnRad(1:Mesh_Size,1) = FnRad(1:Mesh_Size,1) + & CoreDen(1:Mesh_Size) FnRad(1:Mesh_Size,2) = FnRad(1:Mesh_Size,2) + & AT%CoreTail_Density(1:Mesh_Size) !**** Calculate Vxc and Exc for Ra***** Do Rk=1, Mesh_Size Call pwldafunc((FnRad(Rk,1)),Exc1,Vxc1) Call pwldafunc((FnRad(Rk,2)),Exc2,Vxc2) FnRad(Rk, 3:6) = (/Vxc1, Vxc2, Exc1, Exc2/) ! write(6,'(i5,1p7e15.7)') Rk,Vxc1,Vxc2,Exc1,Exc2 End Do FnRad(1:Mesh_Size,7) = R2(1:Mesh_Size) * & (FnRad(1:Mesh_Size,5)*FnRad(1:Mesh_Size,1) & - FnRad(1:Mesh_Size,6)*FnRad(1:Mesh_Size,2)) !FnRad(1:Mesh_Size,7) = FnRad(1:Mesh_Size,7) - & ! R2(1:Mesh_Size) * & ! CoreXC(1:Mesh_Size) * CoreDen(1:Mesh_Size) Efn= IntSimpson(Mesh_Size, DR, FnRad(1:Mesh_Size,7)) * & AngPoints(4,alpha)*4*Pi Energy = Energy + Efn !write(6,*) 'alpha efn energy',alpha,efn,energy Count = 0 Do nili=1, Basis_Size Li = AT%L_Value(nili) Ylm_i => Ylm(:, Li+1, Alpha) ibase = nl_Base(nili); ibase = ibase + nlm_lut(2,ibase); Do njlj=1, Basis_Size Lj = AT%L_Value(njlj) Ylm_j => Ylm(:, Lj+1, Alpha) jbase = nl_Base(njlj); jbase = jbase + nlm_lut(2,jbase); count = count + 1 Phi_ij_R2 => AT%Phi_ij_R2(:,count) TPhi_ij_R2 => AT%TPhi_ij_R2(:,count) !**** Radial Integral Portion ****** FnRad(1:Mesh_Size, 7) = & (FnRad(1:Mesh_Size,3) * Phi_ij_R2(1:Mesh_Size) - & FnRad(1:Mesh_Size,4) * TPhi_ij_R2(1:Mesh_Size)) * & R2(1:Mesh_Size) FnRad(1,7) = 0 FnRad(Mesh_Size,7) = 0 fn = IntSimpson(Mesh_Size, DR, FnRad(1:Mesh_Size,7)) * & AngPoints(4,alpha)*Four_Pi Do mi=-Li, Li Do mj=-Lj, Lj Dij(ibase+mi,jbase+mj) = Dij(ibase+mi,jbase+mj) + & fn * CONJG(Ylm_i(Li+Mi+1))*Ylm_j(Lj+mj+1) End Do End Do end Do !njlj End do !nili End Do End Do Call Stop_Timer(Timer(AtomVxc_Timer)) write(log_unit,*) 'AccumVxc_LDA: finish' call flush(log_unit) Return End Subroutine Subroutine AccumVxc_LSDA( Energy) Real, Intent(INOUT) :: Energy Integer :: i,j,k, nili, njlj, mi, mj, Li, Lj, Rk, RS, count Integer ::nklk, nlll, mk, ml, Lk, Ll, alpha, Basis_Size, Rad_Size Integer :: ibase,jbase,kbase,lbase, Skip_Size, Rad_Index, Mesh_Size Integer, pointer :: nl_base(:), nlm_lut(:,:) Complex, Pointer :: Dijup(:,:),Dijdn(:,:), Wijup(:,:), Wijdn(:,:), Ylm(:,:,:) Real, Pointer :: R2(:), Phi_ij_R2(:), TPhi_ij_R2(:) Real, Pointer :: CoreXC(:), CoreDen(:),FnRadup(:,:),FnRaddn(:,:) Complex :: Ylm_l(13), Ylm_k(13), ylm1, ylm2 Complex, Pointer :: Ylm_i(:), Ylm_j(:) Real :: Vxc1even,Vxc1odd, Exc1, Vxc2even,Vxc2odd, Exc2, fnint, Esum, PhiRk, TPhiRk Complex :: den_phi, den_Tphi, denup, dendn Real :: Efn,fnup,fndn,Fnsum Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT Real :: DR Real, Pointer :: Cijup(:,:), Cijdn(:,:) Character*100 :: Msg if(.NOT.spindependence) then write(error_unit, *) 'AccumVxc_LSDA---error: spindependence should be true' stop end if Call Start_Timer(Timer(AtomVxc_Timer)) ! Write(msg,*) 'AccumVxc: Error allocating Cij. Size=',Basis_Size ! Call Check_Error(j, msg, Error_Unit, .TRUE.,paw_wc, "AccumVxc:") write(log_unit,*) 'AccumVxc_LSDA: start' call flush(log_unit) Do i=1, Specific_Atoms A => Atom_List(i) AT => AtomType_Info(A%TypeIndex) nl_base => AT%nl_Base nlm_LUT => AT%nlm_LUT Wijup => A%Wij Wijdn => A%Wijspin Dijup => A%Dij Dijdn => A%Dijspin CoreDen => AT%Core_Density CoreXC => AT%Core_Xchange R2 => AT%R2 Ylm => AT%Ylm Cijup => AT%Cij Cijdn => AT%Cijspin FnRadup => AT%FnRad FnRaddn => AT%FnRadspin Mesh_size = AT%Rad_Size DR = AT%Mesh_Step*AT%Rad_Skip Basis_Size = AT%Basis_Size FnSum = 0; ESum = 0 Do alpha = 1, Num_AngPoints Cijup = 0; Cijdn = 0 Do nili=1, Basis_Size !*** Calulate Cij for n^a and n~^a Li = AT%L_Value(nili) Ylm_i => Ylm(:, Li+1, alpha) ibase = nl_Base(nili); ibase = ibase + nlm_lut(2,ibase); Do njlj=1, Basis_Size Lj = AT%L_Value(njlj) Ylm_j => Ylm(:, Lj+1, alpha) jbase = nl_Base(njlj); jbase = jbase + nlm_lut(2,jbase); denup = 0; dendn = 0 Do mi = -Li, Li ylm1 = CONJG(Ylm_i(mi+Li+1)) Do mj=-Lj, Lj ylm2 = Ylm_j(mj+Lj+1) denup = denup + Wijup(ibase+mi,jbase+mj) * Ylm1 * Ylm2 dendn = dendn + Wijdn(ibase+mi,jbase+mj) * Ylm1 * Ylm2 End Do End Do Cijup(nili, njlj) = denup Cijdn(nili, njlj) = dendn End do End Do !**** Calculate the Radial Densities and store them ***** FnRadup = 0; FnRaddn = 0 Count = 0 Do nili=1, Basis_Size Do njlj=1, Basis_Size count = count + 1 Phi_ij_R2 => AT%Phi_ij_R2(:,count) TPhi_ij_R2 => AT%TPhi_ij_R2(:,count) FnRadup(1:Mesh_Size,1)=FnRadup(1:Mesh_Size,1) & + Cijup(nili,njlj)*Phi_ij_R2(1:Mesh_Size) FnRaddn(1:Mesh_Size,1)=FnRaddn(1:Mesh_Size,1) & + Cijdn(nili,njlj)*Phi_ij_R2(1:Mesh_Size) FnRadup(1:Mesh_Size,2)=FnRadup(1:Mesh_Size,2) & + Cijup(nili,njlj)*TPhi_ij_R2(1:Mesh_Size) FnRaddn(1:Mesh_Size,2)=FnRaddn(1:Mesh_Size,2) & + Cijdn(nili,njlj)*TPhi_ij_R2(1:Mesh_Size) End Do End Do !*** Add CoreDen *** FnRadup(1:Mesh_Size,1) = FnRadup(1:Mesh_Size,1) + & CoreDen(1:Mesh_Size)/2 FnRaddn(1:Mesh_Size,1) = FnRaddn(1:Mesh_Size,1) + & CoreDen(1:Mesh_Size)/2 FnRadup(1:Mesh_Size,2) = FnRadup(1:Mesh_Size,2) + & AT%CoreTail_Density(1:Mesh_Size)/2 FnRaddn(1:Mesh_Size,2) = FnRaddn(1:Mesh_Size,2) + & AT%CoreTail_Density(1:Mesh_Size)/2 !**** Calculate Vxc and Exc for Ra***** Do Rk=1, Mesh_Size Call pwlsdafunc((FnRadup(Rk,1)+FnRaddn(Rk,1)),(FnRadup(Rk,1)-FnRaddn(Rk,1)),Exc1,Vxc1even, Vxc1odd) Call pwlsdafunc((FnRadup(Rk,2)+FnRaddn(Rk,2)),(FnRadup(Rk,2)-FnRaddn(Rk,2)),Exc2,Vxc2even, Vxc2odd) FnRadup(Rk, 3:6) = (/Vxc1even, Vxc2even, Exc1, Exc2/) FnRaddn(Rk, 3:6) = (/Vxc1odd, Vxc2odd, Exc1, Exc2/) ! write(6,'(i5,1p7e15.7)') Rk,Vxc1,Vxc2,Exc1,Exc2 End Do FnRadup(1:Mesh_Size,7) = R2(1:Mesh_Size) * & (FnRadup(1:Mesh_Size,5)*(FnRadup(1:Mesh_Size,1)+FnRaddn(1:Mesh_Size,1)) & - FnRadup(1:Mesh_Size,6)*(FnRadup(1:Mesh_Size,2)+FnRaddn(1:Mesh_Size,2))) !FnRad(1:Mesh_Size,7) = FnRad(1:Mesh_Size,7) - & ! R2(1:Mesh_Size) * & ! CoreXC(1:Mesh_Size) * CoreDen(1:Mesh_Size) Efn= IntSimpson(Mesh_Size, DR, FnRadup(1:Mesh_Size,7)) * & AngPoints(4,alpha)*4*Pi Energy = Energy + Efn !write(6,*) 'alpha efn energy',alpha,efn,energy Count = 0 Do nili=1, Basis_Size Li = AT%L_Value(nili) Ylm_i => Ylm(:, Li+1, Alpha) ibase = nl_Base(nili); ibase = ibase + nlm_lut(2,ibase); Do njlj=1, Basis_Size Lj = AT%L_Value(njlj) Ylm_j => Ylm(:, Lj+1, Alpha) jbase = nl_Base(njlj); jbase = jbase + nlm_lut(2,jbase); count = count + 1 Phi_ij_R2 => AT%Phi_ij_R2(:,count) TPhi_ij_R2 => AT%TPhi_ij_R2(:,count) !**** Radial Integral Portion ****** FnRadup(1:Mesh_Size, 7) = & ((FnRadup(1:Mesh_Size,3)+FnRaddn(1:Mesh_Size,3)) * Phi_ij_R2(1:Mesh_Size) - & (FnRadup(1:Mesh_Size,4)+FnRaddn(1:Mesh_Size,4)) * TPhi_ij_R2(1:Mesh_Size)) * & R2(1:Mesh_Size) FnRaddn(1:Mesh_Size, 7) = & ((FnRadup(1:Mesh_Size,3)-FnRaddn(1:Mesh_Size,3)) * Phi_ij_R2(1:Mesh_Size) - & (FnRadup(1:Mesh_Size,4)-FnRaddn(1:Mesh_Size,4)) * TPhi_ij_R2(1:Mesh_Size)) * & R2(1:Mesh_Size) FnRadup(1,7) = 0; FnRaddn(1,7) = 0 FnRadup(Mesh_Size,7) = 0; FnRaddn(Mesh_Size,7) = 0 fnup = IntSimpson(Mesh_Size, DR, FnRadup(1:Mesh_Size,7)) * & AngPoints(4,alpha)*Four_Pi fndn = IntSimpson(Mesh_Size, DR, FnRaddn(1:Mesh_Size,7)) * & AngPoints(4,alpha)*Four_Pi Do mi=-Li, Li Do mj=-Lj, Lj Dijup(ibase+mi,jbase+mj) = Dijup(ibase+mi,jbase+mj) + & fnup * CONJG(Ylm_i(Li+Mi+1))*Ylm_j(Lj+mj+1) Dijdn(ibase+mi,jbase+mj) = Dijdn(ibase+mi,jbase+mj) + & fndn * CONJG(Ylm_i(Li+Mi+1))*Ylm_j(Lj+mj+1) End Do End Do end Do !njlj End do !nili End Do End Do Call Stop_Timer(Timer(AtomVxc_Timer)) write(log_unit,*) 'AccumVxc_LSDA: finish' call flush(log_unit) Return End Subroutine !****************************************************************************** ! ~a a ! AccumVxc_GGA - Accumulates the Exchange correlation pot for N + N to Dij ! for GGA in Perdew-Burke-Ezerholf form only ! !****************************************************************************** Subroutine AccumVxc_GGA( Energy) Real, Intent(INOUT) :: Energy Integer :: i,j,k, nili, njlj, mi, mj, Li, Lj, Rk, RS, count Integer ::nklk, nlll, mk, ml, Lk, Ll, alpha, Basis_Size, Rad_Size Integer :: ibase,jbase,kbase,lbase, Skip_Size, Rad_Index, Mesh_Size Integer, pointer :: nl_base(:), nlm_lut(:,:) Complex, Pointer :: Dij(:,:), Wij(:,:), Ylm(:,:,:) Complex, Pointer :: dYlmdtheta(:,:,:), dYlmdphi(:,:,:) Real, Pointer :: R2(:), Phi_ij_R2(:), TPhi_ij_R2(:) Real, Pointer :: dPhijdr(:),dTPhijdr(:) Real, Pointer :: CoreXC(:), CoreDen(:),FnRad(:,:),CoreGrad(:) Complex :: ylm1, ylm2,ylm1t,ylm1p,ylm2t,ylm2p Complex, Pointer :: Ylm_i(:), Ylm_j(:) Complex, Pointer :: dYlmdt_i(:), dYlmdt_j(:) Complex, Pointer :: dYlmdp_i(:), dYlmdp_j(:) Real :: Vxc1, Exc1, Vxc2, Exc2, fnint, Esum, PhiRk, TPhiRk Real :: fxc,gxc,dfxcdn,dfxcdg Complex :: den_phi, den_Tphi, den, dent, denp Real :: Efn,fn,fnt,fnp,Fnsum Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT Real :: DR,RR,grad Real, Pointer :: Cij(:,:),dCijdtheta(:,:),dCijdphi(:,:) Character*100 :: Msg if(spindependence) then write(error_unit, *) 'AccumVxc_GGA: error -- spindependence should be false' stop endif Call Start_Timer(Timer(AtomVxc_Timer)) ! Write(msg,*) 'AccumVxc: Error allocating Cij. Size=',Basis_Size ! Call Check_Error(j, msg, Error_Unit, .TRUE.,paw_wc, "AccumVxc:") write(log_unit,*) 'AccumVxc_GGA: start' call flush(log_unit) Do i=1, Specific_Atoms A => Atom_List(i) AT => AtomType_Info(A%TypeIndex) nl_base => AT%nl_Base nlm_LUT => AT%nlm_LUT Wij => A%Wij Dij => A%Dij CoreDen => AT%Core_Density CoreGrad => AT%Core_dDendr CoreXC => AT%Core_Xchange R2 => AT%R2 DR = AT%Mesh_Step ! assume that no steps are skipped! Ylm => AT%Ylm dYlmdtheta => AT%dYlmdtheta dYlmdphi => AT%dYlmdphi Cij => AT%Cij dCijdtheta => AT%dCijdtheta dCijdphi => AT%dCijdphi FnRad => AT%FnRad Mesh_size = AT%Rad_Size DR = AT%Mesh_Step*AT%Rad_Skip Basis_Size = AT%Basis_Size FnSum = 0; ESum = 0 Do alpha = 1, Num_AngPoints Cij = 0 dCijdtheta=0 ; dCijdphi=0 Do nili=1, Basis_Size !*** Calulate Cij for n^a and n~^a Li = AT%L_Value(nili) Ylm_i => Ylm(:, Li+1, alpha) dYlmdt_i => dYlmdtheta(:, Li+1, alpha) dYlmdp_i => dYlmdphi(:, Li+1, alpha) ibase = nl_Base(nili); ibase = ibase + nlm_lut(2,ibase); Do njlj=1, Basis_Size Lj = AT%L_Value(njlj) Ylm_j => Ylm(:, Lj+1, alpha) dYlmdt_j => dYlmdtheta(:, Lj+1, alpha) dYlmdp_j => dYlmdphi(:, Lj+1, alpha) jbase = nl_Base(njlj); jbase = jbase + nlm_lut(2,jbase); den = 0 ; dent = 0 ; denp = 0 Do mi = -Li, Li ylm1 = CONJG(Ylm_i(mi+Li+1)) ylm1t = CONJG(dYlmdt_i(mi+Li+1)) ylm1p = CONJG(dYlmdp_i(mi+Li+1)) Do mj=-Lj, Lj ylm2 = Ylm_j(mj+Lj+1) ylm2t = dYlmdt_j(mj+Lj+1) ylm2p = dYlmdp_j(mj+Lj+1) den = den + Wij(ibase+mi,jbase+mj) * Ylm1 * Ylm2 dent = dent + Wij(ibase+mi,jbase+mj) * & (ylm1t * Ylm2 + ylm1 * ylm2t) denp = denp + Wij(ibase+mi,jbase+mj) * & (ylm1p * Ylm2 + ylm1 * ylm2p) End Do End Do Cij(nili, njlj) = Den dCijdtheta(nili, njlj) = Dent dCijdphi(nili, njlj) = Denp End Do End Do !**** Calculate the Radial Densities and store them ***** FnRad = 0 Count = 0 Do nili=1, Basis_Size Do njlj=1, Basis_Size count = count + 1 Phi_ij_R2 => AT%Phi_ij_R2(:,count) TPhi_ij_R2 => AT%TPhi_ij_R2(:,count) dPhijdr => AT%dPhi_ijdr(:,count) dTPhijdr => AT%dTPhi_ijdr(:,count) FnRad(1:Mesh_Size,1)=FnRad(1:Mesh_Size,1) & !n + Cij(nili,njlj)*Phi_ij_R2(1:Mesh_Size) FnRad(1:Mesh_Size,2)=FnRad(1:Mesh_Size,2) & !~n + Cij(nili,njlj)*TPhi_ij_R2(1:Mesh_Size) FnRad(1:Mesh_Size,3)=FnRad(1:Mesh_Size,3) & !dndr + Cij(nili,njlj)*dPhijdr(1:Mesh_Size) FnRad(1:Mesh_Size,4)=FnRad(1:Mesh_Size,4) & !d~ndr + Cij(nili,njlj)*dTPhijdr(1:Mesh_Size) FnRad(1:Mesh_Size,5)=FnRad(1:Mesh_Size,5) & !dndtheta + dCijdtheta(nili,njlj)*Phi_ij_R2(1:Mesh_Size) FnRad(1:Mesh_Size,6)=FnRad(1:Mesh_Size,6) & !d~ndtheta + dCijdtheta(nili,njlj)*TPhi_ij_R2(1:Mesh_Size) FnRad(1:Mesh_Size,7)=FnRad(1:Mesh_Size,7) & !dndphi + dCijdphi(nili,njlj)*Phi_ij_R2(1:Mesh_Size) FnRad(1:Mesh_Size,8)=FnRad(1:Mesh_Size,8) & !d~ndphi + dCijdphi(nili,njlj)*TPhi_ij_R2(1:Mesh_Size) End Do End Do !*** Add CoreDen *** FnRad(1:Mesh_Size,1) = FnRad(1:Mesh_Size,1) + & CoreDen(1:Mesh_Size) FnRad(1:Mesh_Size,3) = FnRad(1:Mesh_Size,3) + & CoreGrad(1:Mesh_Size) FnRad(1:Mesh_Size,2) = FnRad(1:Mesh_Size,2) + & AT%CoreTail_Density(1:Mesh_Size) FnRad(1:Mesh_Size,4) = FnRad(1:Mesh_Size,4) + & AT%GradCoreTail(1:Mesh_Size) !**** Calculate Vxc, Gxc, and Fxc ***** Do Rk=2, Mesh_Size RR=DR*(Rk-1) grad=SQRT(FnRad(Rk,3)**2+(FnRad(Rk,5)/RR)**2+(FnRad(Rk,7)/RR)**2) Call pbefunc((FnRad(Rk,1)),grad,FnRad(Rk,9),& FnRad(Rk,11),FnRad(Rk,13)) !!!If (grad>machine_zero) then ! no longer term has /grad !!! FnRad(Rk,13)=FnRad(Rk,13)/grad !!!Else !!! FnRad(Rk,13)=0.d0 !!!EndIf grad=SQRT(FnRad(Rk,4)**2+(FnRad(Rk,6)/RR)**2+(FnRad(Rk,8)/RR)**2) Call pbefunc((FnRad(Rk,2)),grad,FnRad(Rk,10),& FnRad(Rk,12),FnRad(Rk,14)) !!!If (grad>machine_zero) then !!! FnRad(Rk,14)=FnRad(Rk,14)/grad !!!Else !!! FnRad(Rk,14)=0.d0 !!!EndIf End Do !FnRad(2:Mesh_Size,15) = R2(2:Mesh_Size) * & ! (FnRad(2:Mesh_Size,9) - CoreXC(2:Mesh_Size) & ! - FnRad(2:Mesh_Size,10)) FnRad(2:Mesh_Size,15) = R2(2:Mesh_Size) * & (FnRad(2:Mesh_Size,9) - FnRad(2:Mesh_Size,10)) FnRad(1,15)=0.d0 Efn= IntSimpson(Mesh_Size, DR, FnRad(1:Mesh_Size,15)) * & AngPoints(4,alpha)*4*Pi Energy = Energy + Efn Count = 0 Do nili=1, Basis_Size Li = AT%L_Value(nili) Ylm_i => Ylm(:, Li+1, Alpha) dYlmdt_i => dYlmdtheta(:, Li+1, alpha) dYlmdp_i => dYlmdphi(:, Li+1, alpha) ibase = nl_Base(nili); ibase = ibase + nlm_lut(2,ibase); Do njlj=1, Basis_Size Lj = AT%L_Value(njlj) Ylm_j => Ylm(:, Lj+1, Alpha) dYlmdt_j => dYlmdtheta(:, Lj+1, alpha) dYlmdp_j => dYlmdphi(:, Lj+1, alpha) jbase = nl_Base(njlj); jbase = jbase + nlm_lut(2,jbase); count = count + 1 Phi_ij_R2 => AT%Phi_ij_R2(:,count) TPhi_ij_R2 => AT%TPhi_ij_R2(:,count) dPhijdr => AT%dPhi_ijdr(:,count) dTPhijdr => AT%dTPhi_ijdr(:,count) !**** Radial Integral Portion ****** FnRad(1,1) = 0; FnRad(Mesh_Size,1) = 0 FnRad(1,2) = 0; FnRad(Mesh_Size,2) = 0 FnRad(1,15) = 0; FnRad(Mesh_Size,15) = 0 Rk=Mesh_Size-1 FnRad(2:Rk,15) = R2(2:Rk)* & (FnRad(2:Rk,11) * Phi_ij_R2(2:Rk) - & FnRad(2:Rk,12) * TPhi_ij_R2(2:Rk) + & FnRad(2:Rk,13) * FnRad(2:Rk,3) * dPhijdr(2:Rk) - & FnRad(2:Rk,14) * FnRad(2:Rk,4) * dTphijdr(2:Rk)) FnRad(2:Rk,1) = & (FnRad(2:Rk,13) * FnRad(2:Rk,5) * Phi_ij_R2(2:Rk) - & FnRad(2:Rk,14) * FnRad(2:Rk,6) * Tphi_ij_R2(2:Rk)) FnRad(2:Rk,2) = & (FnRad(2:Rk,13) * FnRad(2:Rk,7) * Phi_ij_R2(2:Rk) - & FnRad(2:Rk,14) * FnRad(2:Rk,8) * Tphi_ij_R2(2:Rk)) fn = IntSimpson(Mesh_Size, DR, FnRad(1:Mesh_Size,15)) * & AngPoints(4,alpha)*Four_Pi fnt= IntSimpson(Mesh_Size, DR, FnRad(1:Mesh_Size,1)) * & AngPoints(4,alpha)*Four_Pi fnp = IntSimpson(Mesh_Size, DR, FnRad(1:Mesh_Size,2)) * & AngPoints(4,alpha)*Four_Pi Do mi=-Li, Li Do mj=-Lj, Lj Dij(ibase+mi,jbase+mj) = Dij(ibase+mi,jbase+mj) + & fn * CONJG(Ylm_i(Li+Mi+1))*Ylm_j(Lj+mj+1) + & fnt*(CONJG(dYlmdt_i(Li+mi+1))*Ylm_j(Lj+mj+1) + & CONJG(Ylm_i(Li+mi+1))*dYlmdt_j(Lj+mj+1)) + & fnp*(CONJG(dYlmdp_i(Li+mi+1))*Ylm_j(Lj+mj+1) + & CONJG(Ylm_i(Li+mi+1))*dYlmdp_j(Lj+mj+1)) End Do End Do end Do !njlj End do !nili End Do End Do Call Stop_Timer(Timer(AtomVxc_Timer)) write(log_unit,*) 'AccumVxc_GGA: finish' call flush(log_unit) Return End Subroutine Subroutine AccumVxc_SGGA( Energy) Real, Intent(INOUT) :: Energy Integer :: i,j,k, nili, njlj, mi, mj, Li, Lj, Rk, RS, count Integer ::nklk, nlll, mk, ml, Lk, Ll, alpha, Basis_Size, Rad_Size Integer :: ibase,jbase,kbase,lbase, Skip_Size, Rad_Index, Mesh_Size Integer, pointer :: nl_base(:), nlm_lut(:,:) Complex, Pointer :: Dijup(:,:), Dijdn(:,:), Wijup(:,:), Wijdn(:,:), Ylm(:,:,:) Complex, Pointer :: dYlmdtheta(:,:,:), dYlmdphi(:,:,:) Real, Pointer :: R2(:), Phi_ij_R2(:), TPhi_ij_R2(:) Real, Pointer :: dPhijdr(:),dTPhijdr(:) Real, Pointer :: CoreXC(:), CoreDen(:),FnRadup(:,:),FnRaddn(:,:),CoreGrad(:) Complex :: ylm1, ylm2,ylm1t,ylm1p,ylm2t,ylm2p Complex, Pointer :: Ylm_i(:), Ylm_j(:) Complex, Pointer :: dYlmdt_i(:), dYlmdt_j(:) Complex, Pointer :: dYlmdp_i(:), dYlmdp_j(:) Real :: Vxc1even,Vxc1odd, Exc1, Vxc2even,Vxc2odd, & Exc2, fnint, Esum, PhiRk, TPhiRk Real :: fxc,gxc,dfxcdn,dfxcdg Complex :: den_phi, den_Tphi, denup, dendn, & dentup, dentdn, denpup, denpdn Real :: Efn,fnup,fndn,fntup,fntdn,fnpup,fnpdn,Fnsum Type (Specific_Atom), Pointer :: A Type (Atom_Info_Fixed), Pointer :: AT Real :: DR,RR,gradup,graddn,grad Real, Pointer :: Cijup(:,:),Cijdn(:,:),dCijdthetaup(:,:),dCijdthetadn(:,:),dCijdphiup(:,:),dCijdphidn(:,:) Character*100 :: Msg Call Start_Timer(Timer(AtomVxc_Timer)) ! Write(msg,*) 'AccumVxc: Error allocating Cij. Size=',Basis_Size ! Call Check_Error(j, msg, Error_Unit, .TRUE.,paw_wc, "AccumVxc:") if(.not.spindependence) then write(error_unit, *) 'AccumVxc_SGGA: error -- spindependence should be true' stop endif write(log_unit,*) 'AccumVxc_SGGA: start' call flush(log_unit) Do i=1, Specific_Atoms A => Atom_List(i) AT => AtomType_Info(A%TypeIndex) nl_base => AT%nl_Base nlm_LUT => AT%nlm_LUT Wijup => A%Wij Wijdn => A%Wijspin Dijup => A%Dij Dijdn => A%Dijspin CoreDen => AT%Core_Density CoreGrad => AT%Core_dDendr CoreXC => AT%Core_Xchange R2 => AT%R2 DR = AT%Mesh_Step ! assume that no steps are skipped! Ylm => AT%Ylm dYlmdtheta => AT%dYlmdtheta dYlmdphi => AT%dYlmdphi Cijup => AT%Cij Cijdn => AT%Cijspin dCijdthetaup => AT%dCijdtheta dCijdthetadn => AT%dCijdthetaspin dCijdphiup => AT%dCijdphi dCijdphidn => AT%dCijdphispin FnRadup => AT%FnRad FnRaddn => AT%FnRadspin Mesh_size = AT%Rad_Size DR = AT%Mesh_Step*AT%Rad_Skip Basis_Size = AT%Basis_Size FnSum = 0; ESum = 0 Do alpha = 1, Num_AngPoints Cijup = 0; Cijdn = 0 dCijdthetaup=0 ; dCijdthetadn=0; dCijdphiup=0; dCijdphidn=0 Do nili=1, Basis_Size !*** Calulate Cij for n^a and n~^a Li = AT%L_Value(nili) Ylm_i => Ylm(:, Li+1, alpha) dYlmdt_i => dYlmdtheta(:, Li+1, alpha) dYlmdp_i => dYlmdphi(:, Li+1, alpha) ibase = nl_Base(nili); ibase = ibase + nlm_lut(2,ibase); Do njlj=1, Basis_Size Lj = AT%L_Value(njlj) Ylm_j => Ylm(:, Lj+1, alpha) dYlmdt_j => dYlmdtheta(:, Lj+1, alpha) dYlmdp_j => dYlmdphi(:, Lj+1, alpha) jbase = nl_Base(njlj); jbase = jbase + nlm_lut(2,jbase); denup = 0 ; dendn = 0; dentup = 0 ; dentdn = 0; denpup = 0; denpdn = 0 Do mi = -Li, Li ylm1 = CONJG(Ylm_i(mi+Li+1)) ylm1t = CONJG(dYlmdt_i(mi+Li+1)) ylm1p = CONJG(dYlmdp_i(mi+Li+1)) Do mj=-Lj, Lj ylm2 = Ylm_j(mj+Lj+1) ylm2t = dYlmdt_j(mj+Lj+1) ylm2p = dYlmdp_j(mj+Lj+1) denup = denup + Wijup(ibase+mi,jbase+mj) * Ylm1 * Ylm2 dendn = dendn + Wijdn(ibase+mi,jbase+mj) * Ylm1 * Ylm2 dentup = dentup + Wijup(ibase+mi,jbase+mj) * & (ylm1t * Ylm2 + ylm1 * ylm2t) dentdn = dentdn + Wijdn(ibase+mi,jbase+mj) * & (ylm1t * Ylm2 + ylm1 * ylm2t) denpup = denpup + Wijup(ibase+mi,jbase+mj) * & (ylm1p * Ylm2 + ylm1 * ylm2p) denpdn = denpdn + Wijdn(ibase+mi,jbase+mj) * & (ylm1p * Ylm2 + ylm1 * ylm2p) End Do End Do Cijup(nili, njlj) = Denup Cijdn(nili, njlj) = Dendn dCijdthetaup(nili, njlj) = Dentup dCijdthetadn(nili, njlj) = Dentdn dCijdphiup(nili, njlj) = Denpup dCijdphidn(nili, njlj) = Denpdn End Do End Do !**** Calculate the Radial Densities and store them ***** FnRadup = 0; FnRaddn = 0 Count = 0 Do nili=1, Basis_Size Do njlj=1, Basis_Size count = count + 1 Phi_ij_R2 => AT%Phi_ij_R2(:,count) TPhi_ij_R2 => AT%TPhi_ij_R2(:,count) dPhijdr => AT%dPhi_ijdr(:,count) dTPhijdr => AT%dTPhi_ijdr(:,count) FnRadup(1:Mesh_Size,1)=FnRadup(1:Mesh_Size,1) & !n + Cijup(nili,njlj)*Phi_ij_R2(1:Mesh_Size) FnRaddn(1:Mesh_Size,1)=FnRaddn(1:Mesh_Size,1) & !n + Cijdn(nili,njlj)*Phi_ij_R2(1:Mesh_Size) FnRadup(1:Mesh_Size,2)=FnRadup(1:Mesh_Size,2) & !~n + Cijup(nili,njlj)*TPhi_ij_R2(1:Mesh_Size) FnRaddn(1:Mesh_Size,2)=FnRaddn(1:Mesh_Size,2) & !~n + Cijdn(nili,njlj)*TPhi_ij_R2(1:Mesh_Size) FnRadup(1:Mesh_Size,3)=FnRadup(1:Mesh_Size,3) & !dndr + Cijup(nili,njlj)*dPhijdr(1:Mesh_Size) FnRaddn(1:Mesh_Size,3)=FnRaddn(1:Mesh_Size,3) & !dndr + Cijdn(nili,njlj)*dPhijdr(1:Mesh_Size) FnRadup(1:Mesh_Size,4)=FnRadup(1:Mesh_Size,4) & !d~ndr + Cijup(nili,njlj)*dTPhijdr(1:Mesh_Size) FnRaddn(1:Mesh_Size,4)=FnRaddn(1:Mesh_Size,4) & !d~ndr + Cijdn(nili,njlj)*dTPhijdr(1:Mesh_Size) FnRadup(1:Mesh_Size,5)=FnRadup(1:Mesh_Size,5) & !dndtheta + dCijdthetaup(nili,njlj)*Phi_ij_R2(1:Mesh_Size) FnRaddn(1:Mesh_Size,5)=FnRaddn(1:Mesh_Size,5) & !dndtheta + dCijdthetadn(nili,njlj)*Phi_ij_R2(1:Mesh_Size) FnRadup(1:Mesh_Size,6)=FnRadup(1:Mesh_Size,6) & !d~ndtheta + dCijdthetaup(nili,njlj)*TPhi_ij_R2(1:Mesh_Size) FnRaddn(1:Mesh_Size,6)=FnRaddn(1:Mesh_Size,6) & !d~ndtheta + dCijdthetadn(nili,njlj)*TPhi_ij_R2(1:Mesh_Size) FnRadup(1:Mesh_Size,7)=FnRadup(1:Mesh_Size,7) & !dndphi + dCijdphiup(nili,njlj)*Phi_ij_R2(1:Mesh_Size) FnRaddn(1:Mesh_Size,7)=FnRaddn(1:Mesh_Size,7) & !dndphi + dCijdphidn(nili,njlj)*Phi_ij_R2(1:Mesh_Size) FnRadup(1:Mesh_Size,8)=FnRadup(1:Mesh_Size,8) & !d~ndphi + dCijdphiup(nili,njlj)*TPhi_ij_R2(1:Mesh_Size) FnRaddn(1:Mesh_Size,8)=FnRaddn(1:Mesh_Size,8) & !d~ndphi + dCijdphidn(nili,njlj)*TPhi_ij_R2(1:Mesh_Size) End Do End Do !*** Add CoreDen *** FnRadup(1:Mesh_Size,1) = FnRadup(1:Mesh_Size,1) + & CoreDen(1:Mesh_Size)/2 FnRaddn(1:Mesh_Size,1) = FnRaddn(1:Mesh_Size,1) + & CoreDen(1:Mesh_Size)/2 FnRadup(1:Mesh_Size,3) = FnRadup(1:Mesh_Size,3) + & CoreGrad(1:Mesh_Size)/2 FnRaddn(1:Mesh_Size,3) = FnRaddn(1:Mesh_Size,3) + & CoreGrad(1:Mesh_Size)/2 FnRadup(1:Mesh_Size,2) = FnRadup(1:Mesh_Size,2) + & AT%CoreTail_Density(1:Mesh_Size)/2 FnRaddn(1:Mesh_Size,2) = FnRaddn(1:Mesh_Size,2) + & AT%CoreTail_Density(1:Mesh_Size)/2 FnRadup(1:Mesh_Size,4) = FnRadup(1:Mesh_Size,4) + & AT%GradCoreTail(1:Mesh_Size)/2 FnRaddn(1:Mesh_Size,4) = FnRaddn(1:Mesh_Size,4) + & AT%GradCoreTail(1:Mesh_Size)/2 !**** Calculate Vxc, Gxc, and Fxc ***** Do Rk=2, Mesh_Size RR=DR*(Rk-1) gradup=SQRT(FnRadup(Rk,3)**2+(FnRadup(Rk,5)/RR)**2+& (FnRadup(Rk,7)/RR)**2) graddn=SQRT(FnRaddn(Rk,3)**2+(FnRaddn(Rk,5)/RR)**2+& (FnRaddn(Rk,7)/RR)**2) grad=SQRT((FnRadup(Rk,3)+FnRaddn(Rk,3))**2& +((FnRadup(Rk,5)+FnRaddn(Rk,5))/RR)**2& +((FnRadup(Rk,7)+FnRaddn(Rk,7))/RR)**2) !!!FnRadup(Rk,11) stores dfxcdneven, FnRaddn(Rk,11) stores dfxcdnodd !!!FnRadup(Rk,16) stores dcdgbg, other are corresponding to upspin and dnspin Call Sggapbefunc(FnRadup(Rk,1),gradup,FnRaddn(Rk,1),graddn,& grad,FnRadup(Rk,9),FnRadup(Rk,11),FnRaddn(Rk,11),& FnRadup(Rk,13),FnRaddn(Rk,13),FnRadup(Rk,16)) !!!If (grad>machine_zero) then ! no longer term has /grad !!! FnRad(Rk,13)=FnRad(Rk,13)/grad !!!Else !!! FnRad(Rk,13)=0.d0 !!!EndIf gradup=SQRT(FnRadup(Rk,4)**2+(FnRadup(Rk,6)/RR)**2+& (FnRadup(Rk,8)/RR)**2) graddn=SQRT(FnRaddn(Rk,4)**2+(FnRaddn(Rk,6)/RR)**2+& (FnRaddn(Rk,8)/RR)**2) grad=SQRT((FnRadup(Rk,4)+FnRaddn(Rk,4))**2& +((FnRadup(Rk,6)+FnRaddn(Rk,6))/RR)**2& +((FnRadup(Rk,8)+FnRaddn(Rk,8))/RR)**2) !!!FnRadup(Rk,12) stores dfxcdneven, FnRaddn(Rk,12) stores dfxcdnodd !!!FnRaddn(Rk,16) stores dcdgbg, other are correspondent to upspin and dnspin Call Sggapbefunc(FnRadup(Rk,2),gradup,FnRaddn(Rk,2),graddn,& grad,FnRadup(Rk,10),FnRadup(Rk,12),FnRaddn(Rk,12),& FnRadup(Rk,14),FnRaddn(Rk,14),FnRaddn(Rk,16)) !!!If (grad>machine_zero) then !!! FnRad(Rk,14)=FnRad(Rk,14)/grad !!!Else !!! FnRad(Rk,14)=0.d0 !!!EndIf End Do !FnRad(2:Mesh_Size,15) = R2(2:Mesh_Size) * & ! (FnRad(2:Mesh_Size,9) - CoreXC(2:Mesh_Size) & ! - FnRad(2:Mesh_Size,10)) FnRadup(2:Mesh_Size,15) = R2(2:Mesh_Size) * & (FnRadup(2:Mesh_Size,9) - FnRadup(2:Mesh_Size,10)) FnRadup(1,15)=0.d0; FnRaddn(1,15)=0.d0 Efn= IntSimpson(Mesh_Size, DR, FnRadup(1:Mesh_Size,15)) * & AngPoints(4,alpha)*4*Pi Energy = Energy + Efn Count = 0 Do nili=1, Basis_Size Li = AT%L_Value(nili) Ylm_i => Ylm(:, Li+1, Alpha) dYlmdt_i => dYlmdtheta(:, Li+1, alpha) dYlmdp_i => dYlmdphi(:, Li+1, alpha) ibase = nl_Base(nili); ibase = ibase + nlm_lut(2,ibase); Do njlj=1, Basis_Size Lj = AT%L_Value(njlj) Ylm_j => Ylm(:, Lj+1, Alpha) dYlmdt_j => dYlmdtheta(:, Lj+1, alpha) dYlmdp_j => dYlmdphi(:, Lj+1, alpha) jbase = nl_Base(njlj); jbase = jbase + nlm_lut(2,jbase); count = count + 1 Phi_ij_R2 => AT%Phi_ij_R2(:,count) TPhi_ij_R2 => AT%TPhi_ij_R2(:,count) dPhijdr => AT%dPhi_ijdr(:,count) dTPhijdr => AT%dTPhi_ijdr(:,count) !**** Radial Integral Portion ****** FnRadup(1,1) = 0; FnRadup(Mesh_Size,1) = 0 FnRadup(1,2) = 0; FnRadup(Mesh_Size,2) = 0 FnRadup(1,15) = 0; FnRadup(Mesh_Size,15) = 0 FnRaddn(1,1) = 0; FnRaddn(Mesh_Size,1) = 0 FnRaddn(1,2) = 0; FnRaddn(Mesh_Size,2) = 0 FnRaddn(1,15) = 0; FnRaddn(Mesh_Size,15) = 0 Rk=Mesh_Size-1 ! vxcup=(vxceven+vxcodd)/2-(dgxdrup+dgcdr/2) ! vxcdn=(vxceven-vxcodd)/2-(dgxdrup+dgcdr/2) ! so next FnRadup(2:Rk,15) actually stores vxceven ! and FnRaddn(2:Rk,15) stores vxcodd ! FnRadup(2:Rk,15) = R2(2:Rk)* & ! ((FnRadup(2:Rk,11)+FnRaddn(2:Rk,11)) * Phi_ij_R2(2:Rk) - & ! (FnRadup(2:Rk,12)+FnRaddn(2:Rk,12)) * TPhi_ij_R2(2:Rk) + & ! (FnRadup(2:Rk,13) * FnRadup(2:Rk,3) + & ! FnRadup(2:Rk,16)*(FnRadup(2:Rk,3)+FnRaddn(2:Rk,3))/2)* dPhijdr(2:Rk) - & ! (FnRadup(2:Rk,14) * FnRadup(2:Rk,4) + & ! FnRaddn(2:Rk,16)*(FnRadup(2:Rk,4)+FnRaddn(2:Rk,4))/2)* dTphijdr(2:Rk)) FnRadup(2:Rk,15) = R2(2:Rk)* & ((FnRadup(2:Rk,11)+FnRaddn(2:Rk,11)) * Phi_ij_R2(2:Rk) - & (FnRadup(2:Rk,12)+FnRaddn(2:Rk,12)) * TPhi_ij_R2(2:Rk) + & (FnRadup(2:Rk,13) * FnRadup(2:Rk,3) + & FnRadup(2:Rk,16)*(FnRadup(2:Rk,3)+FnRaddn(2:Rk,3)))* dPhijdr(2:Rk) - & (FnRadup(2:Rk,14) * FnRadup(2:Rk,4) + & FnRaddn(2:Rk,16)*(FnRadup(2:Rk,4)+FnRaddn(2:Rk,4)))* dTphijdr(2:Rk)) ! FnRaddn(2:Rk,15) = R2(2:Rk)* & ! ((FnRadup(2:Rk,11)-FnRaddn(2:Rk,11)) * Phi_ij_R2(2:Rk) - & ! (FnRadup(2:Rk,12)-FnRaddn(2:Rk,12)) * TPhi_ij_R2(2:Rk) + & ! (FnRaddn(2:Rk,13) * FnRaddn(2:Rk,3) + & ! FnRadup(2:Rk,16)*(FnRadup(2:Rk,3)+FnRaddn(2:Rk,3))/2) * dPhijdr(2:Rk) - & ! (FnRaddn(2:Rk,14) * FnRaddn(2:Rk,4) + & ! FnRaddn(2:Rk,16)*(FnRadup(2:Rk,4)+FnRaddn(2:Rk,4))/2) * dTphijdr(2:Rk)) FnRaddn(2:Rk,15) = R2(2:Rk)* & ((FnRadup(2:Rk,11)-FnRaddn(2:Rk,11)) * Phi_ij_R2(2:Rk) - & (FnRadup(2:Rk,12)-FnRaddn(2:Rk,12)) * TPhi_ij_R2(2:Rk) + & (FnRaddn(2:Rk,13) * FnRaddn(2:Rk,3) + & FnRadup(2:Rk,16)*(FnRadup(2:Rk,3)+FnRaddn(2:Rk,3))) * dPhijdr(2:Rk) - & (FnRaddn(2:Rk,14) * FnRaddn(2:Rk,4) + & FnRaddn(2:Rk,16)*(FnRadup(2:Rk,4)+FnRaddn(2:Rk,4))) * dTphijdr(2:Rk)) ! FnRadup(2:Rk,1) = & ! (FnRadup(2:Rk,13) * FnRadup(2:Rk,5) + & ! FnRadup(2:Rk,16) * (FnRadup(2:Rk,5)+FnRaddn(2:Rk,5))/2) * Phi_ij_R2(2:Rk) - & ! (FnRadup(2:Rk,14) * FnRadup(2:Rk,6) + & ! FnRaddn(2:Rk,16) * (FnRadup(2:Rk,6)+FnRaddn(2:Rk,6))/2) * Tphi_ij_R2(2:Rk) FnRadup(2:Rk,1) = & (FnRadup(2:Rk,13) * FnRadup(2:Rk,5) + & FnRadup(2:Rk,16) * (FnRadup(2:Rk,5)+FnRaddn(2:Rk,5))) * Phi_ij_R2(2:Rk) - & (FnRadup(2:Rk,14) * FnRadup(2:Rk,6) + & FnRaddn(2:Rk,16) * (FnRadup(2:Rk,6)+FnRaddn(2:Rk,6))) * Tphi_ij_R2(2:Rk) ! FnRaddn(2:Rk,1) = & ! (FnRaddn(2:Rk,13) * FnRaddn(2:Rk,5) + & ! FnRadup(2:Rk,16) * (FnRadup(2:Rk,5)+FnRaddn(2:Rk,5))/2) * Phi_ij_R2(2:Rk) - & ! (FnRaddn(2:Rk,14) * FnRaddn(2:Rk,6) + & ! FnRaddn(2:Rk,16) * (FnRadup(2:Rk,6)+FnRaddn(2:Rk,6))/2) * Tphi_ij_R2(2:Rk) FnRaddn(2:Rk,1) = & (FnRaddn(2:Rk,13) * FnRaddn(2:Rk,5) + & FnRadup(2:Rk,16) * (FnRadup(2:Rk,5)+FnRaddn(2:Rk,5))) * Phi_ij_R2(2:Rk) - & (FnRaddn(2:Rk,14) * FnRaddn(2:Rk,6) + & FnRaddn(2:Rk,16) * (FnRadup(2:Rk,6)+FnRaddn(2:Rk,6))) * Tphi_ij_R2(2:Rk) ! FnRadup(2:Rk,2) = & ! (FnRadup(2:Rk,13) * FnRadup(2:Rk,7) + & ! FnRadup(2:Rk,16) * (FnRadup(2:Rk,7)+FnRaddn(2:Rk,7))/2) * Phi_ij_R2(2:Rk) - & ! (FnRadup(2:Rk,14) * FnRadup(2:Rk,8) + & ! FnRaddn(2:Rk,16) * (FnRadup(2:Rk,7)+FnRaddn(2:Rk,7))/2) * Tphi_ij_R2(2:Rk) FnRadup(2:Rk,2) = & (FnRadup(2:Rk,13) * FnRadup(2:Rk,7) + & FnRadup(2:Rk,16) * (FnRadup(2:Rk,7)+FnRaddn(2:Rk,7))) * Phi_ij_R2(2:Rk) - & (FnRadup(2:Rk,14) * FnRadup(2:Rk,8) + & FnRaddn(2:Rk,16) * (FnRadup(2:Rk,8)+FnRaddn(2:Rk,8))) * Tphi_ij_R2(2:Rk) ! FnRaddn(2:Rk,2) = & ! (FnRaddn(2:Rk,13) * FnRaddn(2:Rk,7) + & ! FnRadup(2:Rk,16) * (FnRadup(2:Rk,7)+FnRaddn(2:Rk,7))/2) * Phi_ij_R2(2:Rk) - & ! (FnRaddn(2:Rk,14) * FnRaddn(2:Rk,8) + & ! FnRaddn(2:Rk,16) * (FnRadup(2:Rk,7)+FnRaddn(2:Rk,7))/2) * Tphi_ij_R2(2:Rk) FnRaddn(2:Rk,2) = & (FnRaddn(2:Rk,13) * FnRaddn(2:Rk,7) + & FnRadup(2:Rk,16) * (FnRadup(2:Rk,7)+FnRaddn(2:Rk,7))) * Phi_ij_R2(2:Rk) - & (FnRaddn(2:Rk,14) * FnRaddn(2:Rk,8) + & FnRaddn(2:Rk,16) * (FnRadup(2:Rk,8)+FnRaddn(2:Rk,8))) * Tphi_ij_R2(2:Rk) fnup = IntSimpson(Mesh_Size, DR, FnRadup(1:Mesh_Size,15)) * & AngPoints(4,alpha)*Four_Pi fndn = IntSimpson(Mesh_Size, DR, FnRaddn(1:Mesh_Size,15)) * & AngPoints(4,alpha)*Four_Pi fntup= IntSimpson(Mesh_Size, DR, FnRadup(1:Mesh_Size,1)) * & AngPoints(4,alpha)*Four_Pi fntdn= IntSimpson(Mesh_Size, DR, FnRaddn(1:Mesh_Size,1)) * & AngPoints(4,alpha)*Four_Pi fnpup = IntSimpson(Mesh_Size, DR, FnRadup(1:Mesh_Size,2)) * & AngPoints(4,alpha)*Four_Pi fnpdn = IntSimpson(Mesh_Size, DR, FnRaddn(1:Mesh_Size,2)) * & AngPoints(4,alpha)*Four_Pi Do mi=-Li, Li Do mj=-Lj, Lj Dijup(ibase+mi,jbase+mj) = Dijup(ibase+mi,jbase+mj) + & fnup * CONJG(Ylm_i(Li+Mi+1))*Ylm_j(Lj+mj+1) + & fntup*(CONJG(dYlmdt_i(Li+mi+1))*Ylm_j(Lj+mj+1) + & CONJG(Ylm_i(Li+mi+1))*dYlmdt_j(Lj+mj+1)) + & fnpup*(CONJG(dYlmdp_i(Li+mi+1))*Ylm_j(Lj+mj+1) + & CONJG(Ylm_i(Li+mi+1))*dYlmdp_j(Lj+mj+1)) Dijdn(ibase+mi,jbase+mj) = Dijdn(ibase+mi,jbase+mj) + & fndn * CONJG(Ylm_i(Li+Mi+1))*Ylm_j(Lj+mj+1) + & fntdn*(CONJG(dYlmdt_i(Li+mi+1))*Ylm_j(Lj+mj+1) + & CONJG(Ylm_i(Li+mi+1))*dYlmdt_j(Lj+mj+1)) + & fnpdn*(CONJG(dYlmdp_i(Li+mi+1))*Ylm_j(Lj+mj+1) + & CONJG(Ylm_i(Li+mi+1))*dYlmdp_j(Lj+mj+1)) End Do End Do end Do !njlj End do !nili End Do End Do Call Stop_Timer(Timer(AtomVxc_Timer)) write(log_unit,*) 'AccumVxc_SGGA: finish' call flush(log_unit) Return End Subroutine !****************************************************************************** ! ! CalcVxc_LDA - Tabulates the Vxc potential and also accumulates the Exc ! energy ! ! Version for Perdew-Wang LDA form only ! ! Den - Density in real space ! Vxc - Returned tabulated Vxc in FFT space ! ! NOTE: Both Den and Vxc use the large grid(G_HIGH) ! !****************************************************************************** Subroutine CalcVxc_LDA( Den, SmoothExc) Complex, Intent(IN) :: Den(:) Complex, Pointer :: Vxc(:) Real, INTENT(INOUT) :: SmoothExc Complex, Pointer :: Fn(:) Real :: ExcSum, Potxc, Exc, rho, DV Integer :: i, N write(log_unit,*) 'CalcVxc_LDA: start' call flush(log_unit) ExcSum = 0 !! construct core tail contribution Vxc => SCFvalues%Ve Vxc = 0 Vxc(FFTMap_High(1:Gpnt_Size(G_High)))=SCFvalues%CoreTail(1:Gpnt_Size(G_High)) Vxc(FFTMap_High(Gpnt_Size(G_High)+1:Gall_Size(G_High))) = & Conjg(SCFvalues%CoreTail(2:Gpnt_Size(G_High))) Call PerformFFT(FFT_TO_R, G_HIGH, Vxc) Do i=1, FFT_Grid(4,G_HIGH) rho = Real(Den(i)+Vxc(i))/xtal%volume !!!! -- old form -- Call ExchangeCorr(rho, Potxc, Exc, .FALSE. ,XC_Type) Call pwldafunc(rho,Exc,Potxc) ExcSum = ExcSum + rho*Exc Vxc(i) = Potxc End Do !TildeXC_Energy = TildeXC_Energy + ExcSum*xtal%volume/FFT_Grid(4,G_HIGH) SmoothExc = SmoothExc + ExcSum*xtal%volume/FFT_Grid(4,G_HIGH) Write(Log_Unit,*) 'CalcVxc: Vxc_energy=',SmoothExc call flush(log_unit) !*** Now convert Vxc to FFT space *** write(log_unit,*) 'mag of vxc**2-R',dot_product(vxc,vxc) Call PerformFFT(FFT_TO_G, G_HIGH, Vxc) write(log_unit,*) 'mag of vxc**2-G',dot_product(vxc,vxc) call flush(log_unit) SCFValues%VXC(1)=Vxc(FFTMap_High(1)) SCFValues%VXC(2:Gpnt_Size(G_High))=& (Vxc(FFTMap_High(2:Gpnt_Size(G_High)))+& Conjg(Vxc(FFTMap_High(Gpnt_Size(G_High)+1:Gall_Size(G_High)))))/2 write(log_unit,*) 'CalcVxc_LDA: finish' call flush(log_unit) Return End Subroutine Subroutine CalcVxc_LSDA( Den, Denspin,SmoothExc) Complex, Intent(IN) :: Den(:), Denspin(:) Complex, Pointer :: Vxcup(:), Vxcdn(:) Real, INTENT(INOUT) :: SmoothExc Complex, Pointer :: Fn(:) Real :: ExcSum, Potxceven,Potxcodd, Exc, rho, rhomu, DV Integer :: i, N ExcSum = 0 !! construct core tail contribution Vxcup => SCFvalues%Ve Vxcdn => SCFvalues%Vespin Vxcup = 0 Vxcup(FFTMap_High(1:Gpnt_Size(G_High)))=SCFvalues%CoreTail(1:Gpnt_Size(G_High)) Vxcup(FFTMap_High(Gpnt_Size(G_High)+1:Gall_Size(G_High))) = & Conjg(SCFvalues%CoreTail(2:Gpnt_Size(G_High))) Call PerformFFT(FFT_TO_R, G_HIGH, Vxcup) Do i=1, FFT_Grid(4,G_HIGH) rho = Real(Den(i)+Denspin(i)+Vxcup(i))/xtal%volume rhomu = Real(Den(i)-Denspin(i))/xtal%volume !!!! -- old form -- Call ExchangeCorr(rho, Potxc, Exc, .FALSE. ,XC_Type) Call pwlsdafunc(rho,rhomu,Exc,Potxceven, Potxcodd) ExcSum = ExcSum + rho*Exc Vxcup(i) = Potxceven+Potxcodd Vxcdn(i) = Potxceven-Potxcodd End Do !TildeXC_Energy = TildeXC_Energy + ExcSum*xtal%volume/FFT_Grid(4,G_HIGH) SmoothExc = SmoothExc + ExcSum*xtal%volume/FFT_Grid(4,G_HIGH) Write(Log_Unit,*) 'CalcVxc: Vxc_energy=',SmoothExc !*** Now convert Vxc to FFT space *** write(log_unit,*) 'mag of vxcup**2-R',dot_product(vxcup,vxcup) write(log_unit,*) 'mag of vxcdn**2-R',dot_product(vxcdn,vxcdn) Call PerformFFT(FFT_TO_G, G_HIGH, Vxcup) Call PerformFFT(FFT_TO_G, G_HIGH, Vxcdn) write(log_unit,*) 'mag of vxceven**2-G',dot_product(vxcup,vxcup) write(log_unit,*) 'mag of vxceven**2-G',dot_product(vxcdn,vxcdn) SCFValues%VXC(1)=Vxcup(FFTMap_High(1)) SCFValues%VXC(2:Gpnt_Size(G_High))=& (Vxcup(FFTMap_High(2:Gpnt_Size(G_High)))+& Conjg(Vxcup(FFTMap_High(Gpnt_Size(G_High)+1:Gall_Size(G_High)))))/2 SCFValues%VXCSPIN(1)=Vxcdn(FFTMap_High(1)) SCFValues%VXCSPIN(2:Gpnt_Size(G_High))=& (Vxcdn(FFTMap_High(2:Gpnt_Size(G_High)))+& Conjg(Vxcdn(FFTMap_High(Gpnt_Size(G_High)+1:Gall_Size(G_High)))))/2 Return End Subroutine !****************************************************************************** ! ! CalcVxc_GGA - Tabulates the Vxc potential and also accumulates the Exc ! energy ! ! Version for PBE GGA form only ! ! DG - Density in G space -- tabulated 1..Gpnt_Size(G_High) ! W1 - on input: Density in real space, on output: Vxc in FFT space ! W2 - Work array ! ! NOTE: Both W1 and W2 use the large grid(G_HIGH) ! !****************************************************************************** Subroutine CalcVxc_GGA( W1, SmoothExc) Complex, Intent(INOUT) :: W1(:) Real, INTENT(INOUT) :: SmoothExc Complex, Pointer :: W2(:) Complex, Allocatable :: W3(:),DG(:) Real :: ExcSum, Potxc, Exc, rho, DV, grad,fxc,dfxcdn, dfxcdgbg Integer :: i, j, N, ier Allocate(W3(FFT_Grid(4,G_HIGH)),DG(Gpnt_Size(G_HIGH)),stat=ier) If (ier /= 0) then write(Error_Unit,*) 'CalcVxc_GGA: Cannot allocate work array ', FFT_Grid(4,G_HIGH) stop EndIf DG = SCFValues%RhoSmooth + SCFValues%CoreTail ExcSum = 0 W2 => SCFvalues%Ve W2 = 0 N = Gpnt_Size(G_HIGH)-1 Do i=1,3 W3=0 Do j=2,Gpnt_Size(G_HIGH) W3(FFTMap_High(j))=Gpnt(i,j)*DG(j) W3(FFTMap_High(N+j))=-Gpnt(i,j)*CONJG(DG(j)) Enddo Call PerformFFT(FFT_TO_R, G_HIGH, W3) W2 = W2 + W3*CONJG(W3) EndDo W1 = 0 W1(FFTMap_High(1))=DG(1) Do j=2,Gpnt_Size(G_HIGH) W1(FFTMap_High(j))=DG(j) W1(FFTMap_High(N+j))=CONJG(DG(j)) Enddo Call PerformFFT(FFT_TO_R, G_HIGH, W1) Do i=1, FFT_Grid(4,G_HIGH) rho = W1(i)/xtal%volume grad = SQRT(REAL(W2(i)))/xtal%volume call pbefunc(rho,grad,fxc,dfxcdn,dfxcdgbg) ExcSum = ExcSum + fxc W1(i) = CMPLX(dfxcdn,0) W2(i) = CMPLX(dfxcdgbg,0) End Do W2=W2/xtal%volume !TildeXC_Energy = TildeXC_Energy + ExcSum*xtal%volume/FFT_Grid(4,G_HIGH) SmoothExc = SmoothExc + ExcSum*xtal%volume/FFT_Grid(4,G_HIGH) Write(Log_Unit,*) 'CalcVxc: Vxc_energy=',SmoothExc Call PerformFFT(FFT_TO_G, G_HIGH, W1) W3=0 W3(1)=W1(FFTMap_High(1)) Do j=2,Gpnt_Size(G_HIGH) W3(j) = ( W1(FFTMap_High(j)) + CONJG(W1(FFTMap_High(N+j))))/2 !write(log_unit,'("V1: ",i5,1p4e15.7)')j,w3(j) Enddo Do i=1,3 W1=0 Do j=2,Gpnt_Size(G_HIGH) W1(FFTMap_High(j))=Gpnt(i,j)*DG(j) W1(FFTMap_High(N+j))=-Gpnt(i,j)*CONJG(DG(j)) Enddo Call PerformFFT(FFT_TO_R, G_HIGH, W1) W1 = W1*W2 Call PerformFFT(FFT_TO_G, G_HIGH, W1) Do j=2,Gpnt_Size(G_HIGH) W3(j)=W3(j)+Gpnt(i,j)*(W1(FFTMap_High(j)) - & CONJG(W1(FFTMap_High(N+j))))/2 !write(log_unit,'("V1: ",i5,1p4e15.7)')j,w3(j) EndDo EndDo ! Load resultant W3 into FFT grid as W1 W1=0; W2 =0 W2(FFTmap_High(1:Gpnt_Size(G_HIGH))) = W3(1:Gpnt_Size(G_High)) W2(FFTmap_High(N+2:Gall_Size(G_HIGH))) = CONJG(W3(2:Gpnt_Size(G_High))) W1(FFTmap_High(1:Gpnt_Size(G_HIGH))) = & SCFValues%RhoSmooth( 1:Gpnt_Size(G_High)) W1(FFTmap_High(N+2:Gall_Size(G_HIGH))) = & CONJG(SCFValues%RhoSmooth(2:Gpnt_Size(G_High))) write(log_unit,*) 'mag of vxc**2-G',dot_product(W1,W1) SCFValues%VXC = W3(1:Gpnt_Size(G_High)) DeAllocate(W3,DG) Return End Subroutine Subroutine CalcVxc_SGGA( W1up, W1dn,SmoothExc) Complex, Intent(INOUT) :: W1up(:), W1dn(:) Real, INTENT(INOUT) :: SmoothExc Complex, Pointer :: W2up(:), W2dn(:) Complex, Allocatable :: W3up(:),W3dn(:),DGup(:),DGdn(:),W(:) Real :: ExcSum, Potxceven,Potxcodd, Exc, rhoup,rhodn, DV, grad,& gradup,graddn,fxc,dfxcdneven,dfxcdnodd, dfxdgbgup, dfxdgbgdn, dfcdgbg COMPLEX :: term Integer :: i, j, N, ier Allocate(W3up(FFT_Grid(4,G_HIGH)),W3dn(FFT_Grid(4,G_HIGH)),& W(FFT_Grid(4,G_HIGH)),& DGup(Gpnt_Size(G_HIGH)),DGdn(Gpnt_Size(G_HIGH)),stat=ier) If (ier /= 0) then write(Error_Unit,*) 'CalcVxc_GGA: Cannot allocate work array ', FFT_Grid(4,G_HIGH) stop EndIf DGup = SCFValues%RhoSmooth + SCFValues%CoreTail/2 DGdn = SCFValues%RhoSmoothspin + SCFValues%CoreTail/2 ExcSum = 0 W2up => SCFvalues%Ve W2dn => SCFvalues%Vespin W2up = 0 W2dn = 0 W = 0 N = Gpnt_Size(G_HIGH)-1 Do i=1,3 W3up=0 W3dn=0 Do j=2,Gpnt_Size(G_HIGH) W3up(FFTMap_High(j))=Gpnt(i,j)*DGup(j) W3up(FFTMap_High(N+j))=-Gpnt(i,j)*CONJG(DGup(j)) W3dn(FFTMap_High(j))=Gpnt(i,j)*DGdn(j) W3dn(FFTMap_High(N+j))=-Gpnt(i,j)*CONJG(DGdn(j)) Enddo Call PerformFFT(FFT_TO_R, G_HIGH, W3up) Call PerformFFT(FFT_TO_R, G_HIGH, W3dn) W2up = W2up + W3up*CONJG(W3up) W2dn = W2dn + W3dn*CONJG(W3dn) W = W + (W3up+W3dn)*CONJG(W3up+W3dn) EndDo W1up = 0 W1dn = 0 w1up(FFTMap_High(1))=DGup(1) W1dn(FFTMap_High(1))=DGdn(1) Do j=2, Gpnt_Size(G_HIGH) W1up(FFTMap_High(j))=DGup(j) W1up(FFTMap_High(N+j))=CONJG(DGup(j)) W1dn(FFTMap_High(j))=DGdn(j) W1dn(FFTMap_High(N+j))=CONJG(DGdn(j)) Enddo Call PerformFFT(FFT_TO_R, G_HIGH, W1up) Call PerformFFT(FFT_TO_R, G_HIGH, W1dn) Do i=1, FFT_Grid(4,G_HIGH) rhoup = W1up(i)/xtal%volume !!/2 rhodn = W1dn(i)/xtal%volume !!/2 gradup = SQRT(REAL(W2up(i)))/xtal%volume graddn = SQRT(REAL(W2dn(i)))/xtal%volume grad = SQRT(REAL(W(i)))/xtal%volume call Sggapbefunc(rhoup,gradup,rhodn,graddn, grad, & fxc,dfxcdneven,dfxcdnodd,dfxdgbgup, dfxdgbgdn, dfcdgbg) ExcSum = ExcSum + fxc W1up(i) = CMPLX((dfxcdneven+dfxcdnodd),0) W1dn(i) = CMPLX((dfxcdneven-dfxcdnodd),0) W2up(i) = CMPLX(dfxdgbgup,0) W2dn(i) = CMPLX(dfxdgbgdn,0) W(i) = CMPLX(dfcdgbg,0) End Do W2up=W2up/xtal%volume W2dn=W2dn/xtal%volume W = W/xtal%volume !TildeXC_Energy = TildeXC_Energy + ExcSum*xtal%volume/FFT_Grid(4,G_HIGH) SmoothExc = SmoothExc + ExcSum*xtal%volume/FFT_Grid(4,G_HIGH) Write(Log_Unit,*) 'CalcVxc: Vxc_energy=',SmoothExc Call PerformFFT(FFT_TO_G, G_HIGH, W1up) Call PerformFFT(FFT_TO_G, G_HIGH, W1dn) W3up=0 W3dn=0 W3up(1)=W1up(FFTMap_High(1)) W3dn(1)=W1dn(FFTMap_High(1)) Do j=2,Gpnt_Size(G_HIGH) W3up(j) = ( W1up(FFTMap_High(j)) + CONJG(W1up(FFTMap_High(N+j))))/2 W3dn(j) = ( W1dn(FFTMap_High(j)) + CONJG(W1dn(FFTMap_High(N+j))))/2 !write(log_unit,'("V1: ",i5,1p4e15.7)')j,w3up(j),w3dn(j) Enddo Do i=1,3 W1up=0 W1dn=0 Do j=2,Gpnt_Size(G_HIGH) W1up(FFTMap_High(j))=Gpnt(i,j)*DGup(j) W1up(FFTMap_High(N+j))=-Gpnt(i,j)*CONJG(DGup(j)) W1dn(FFTMap_High(j))=Gpnt(i,j)*DGdn(j) W1dn(FFTMap_High(N+j))=-Gpnt(i,j)*CONJG(DGdn(j)) Enddo Call PerformFFT(FFT_TO_R, G_HIGH, W1up) Call PerformFFT(FFT_TO_R, G_HIGH, W1dn) Do j=1, FFT_Grid(4,G_HIGH) gradup=-AIMAG(W1up(j)) graddn=-AIMAG(W1dn(j)) grad=gradup+graddn W1up(j)=gradup*W2up(j)+grad*W(j) !!/2 W1dn(j)=graddn*W2dn(j)+grad*W(j) !!/2 Enddo Call PerformFFT(FFT_TO_G, G_HIGH, W1up) Call PerformFFT(FFT_TO_G, G_HIGH, W1dn) Do j=2,Gpnt_Size(G_HIGH) term=CMPLX(0,Gpnt(i,j)) W3up(j)=W3up(j)-term*(W1up(FFTMap_High(j)) + & CONJG(W1up(FFTMap_High(N+j))))/2 W3dn(j)=W3dn(j)-term*(W1dn(FFTMap_High(j)) + & CONJG(W1dn(FFTMap_High(N+j))))/2 !write(log_unit,'("V1: ",i5,1p4e15.7)')j,w3up(j),w3dn(j) EndDo EndDo ! Load resultant W3 into FFT grid as W1 W1up=0; W2up=0 W1dn=0; W2dn=0 W2up(FFTmap_High(1:Gpnt_Size(G_HIGH))) = W3up(1:Gpnt_Size(G_High)) W2up(FFTmap_High(N+2:Gall_Size(G_HIGH))) = CONJG(W3up(2:Gpnt_Size(G_High))) W2dn(FFTmap_High(1:Gpnt_Size(G_HIGH))) = W3dn(1:Gpnt_Size(G_High)) W2dn(FFTmap_High(N+2:Gall_Size(G_HIGH))) = CONJG(W3dn(2:Gpnt_Size(G_High))) W1up(FFTmap_High(1:Gpnt_Size(G_HIGH))) = SCFValues%RhoSmooth(1:Gpnt_Size(G_High)) W1up(FFTmap_High(N+2:Gall_Size(G_HIGH))) = CONJG(SCFValues%RhoSmooth(2:Gpnt_Size(G_High))) W1dn(FFTmap_High(1:Gpnt_Size(G_HIGH))) = SCFValues%RhoSmoothspin(1:Gpnt_Size(G_High)) W1dn(FFTmap_High(N+2:Gall_Size(G_HIGH))) = CONJG(SCFValues%RhoSmoothspin(2:Gpnt_Size(G_High))) write(log_unit,*) 'mag of vxc**2-G',dot_product((W2up+W2dn),(W2up+W2dn)) SCFValues%VXC = W3up(1:Gpnt_Size(G_High)) SCFValues%VXCSPIN = W3dn(1:Gpnt_Size(G_High)) DeAllocate(W3up,W,DGup) DeAllocate(W3dn,DGdn) Return End Subroutine !****************************************************************************** ! ! PrepareVxc - Prepares the data structures for the caclulation of Vxc ! ! AT - Pointer to the Atom_Info_Fixed structure ! !****************************************************************************** Subroutine PrepareVxc(AT) Type (Atom_Info_Fixed), Intent(INOUT) :: AT Real, Pointer :: R2(:), Phi_ij_R2(:,:), TPhi_ij_R2(:,:) Real, Pointer :: dPhi_ijdr(:,:),dTPhi_ijdr(:,:) Real, Pointer :: Phi_I(:), Phi_j(:), TPhi_i(:), TPhi_j(:) Complex, Pointer :: Ylm(:,:,:),dYlmdtheta(:,:,:),dYlmdphi(:,:,:) Complex :: Ylm_i(13), dYlmdt(13),dYlmdp(13) Real :: DR, Ra(3),den,Exc,Vxc,grad,dfxcdn,dfxcdg Integer :: RadSize, Rk, alpha, count, nili, njlj, mi, mj, Li, Lj, Stride RadSize = AT%Rad_Size !******* First determine how many ij indices there are ******* count = 0 Do nili=1, AT%Basis_Size Li = AT%L_Value(nili) Do njlj=1, AT%Basis_Size Lj = AT%L_Value(njlj) count = count + 1 End Do End Do Stride = AT%Rad_Skip Li = MAXVal(AT%L_Value) mi = 2*Li+1 Allocate(AT%R2(RadSize), & AT%Ylm(mi, Li+1, Num_AngPoints), AT%Phi_ij_R2(RadSize, Count), & AT%TPhi_ij_R2(RadSize, Count), AT%Cij(AT%Basis_Size, AT%Basis_Size), & STAT=Rk) if(spindependence) Allocate(AT%Cijspin(AT%Basis_Size, AT%Basis_Size), STAT=Rk) If (XC_Type == XC_LDA_PW) Allocate(AT%FnRad(RadSize,7)) If (XC_Type == XC_LSDA_PW) Allocate(AT%FnRad(RadSize,7), AT%FnRadspin(RadSize,7),STAT=Rk) If (XC_Type == XC_GGA_PBE) then Allocate(AT%FnRad(RadSize,15),AT%dYlmdtheta(mi, Li+1, Num_AngPoints),& AT%dYlmdphi(mi, Li+1, Num_AngPoints), & AT%dCijdtheta(AT%Basis_Size, AT%Basis_Size),& AT%dCijdphi(AT%Basis_Size, AT%Basis_Size),& AT%dPhi_ijdr(RadSize, Count),& AT%dTPhi_ijdr(RadSize, Count),& AT%Core_dDendr(RadSize),AT%GradCoreTail(RadSize),STAT=Rk) EndIf If (XC_Type == XC_SGGA_PBE) then Allocate(AT%FnRad(RadSize,16),AT%FnRadspin(RadSize,16),& AT%dYlmdtheta(mi, Li+1, Num_AngPoints),& AT%dYlmdphi(mi, Li+1, Num_AngPoints), & AT%dCijdtheta(AT%Basis_Size, AT%Basis_Size),AT%dCijdthetaspin(AT%Basis_Size, AT%Basis_Size),& AT%dCijdphi(AT%Basis_Size, AT%Basis_Size),AT%dCijdphispin(AT%Basis_Size, AT%Basis_Size),& AT%dPhi_ijdr(RadSize, Count),& AT%dTPhi_ijdr(RadSize, Count),& AT%Core_dDendr(RadSize),AT%GradCoreTail(RadSize),STAT=Rk) EndIf !**** fix core part -- this was previously in InitSystem If (XC_Type == XC_LDA_PW .OR. XC_Type == XC_LSDA_PW) then ! Do Rk=2, AT%Mesh_Size ! den = AT%Core_Density(Rk) ! If (XC_Type == XC_LDA_PW) Call pwldafunc(den,Exc,Vxc) ! AT%Core_Xchange(Rk) = Exc ! End Do ! !AT%Core_Xchange(1) = 2*AT%Core_Xchange(2)-AT%Core_Xchange(3) ! AT%Core_Xchange(1) = 3*(AT%Core_Xchange(2)-AT%Core_Xchange(3))& ! + AT%Core_Xchange(4) Else If (XC_Type == XC_GGA_PBE .OR. XC_Type == XC_SGGA_PBE) then RadSize=AT%Mesh_Size Call nderiv(AT%Mesh_Step,AT%Core_Density(:),& AT%Core_dDendr(:),RadSize) Call nderiv(AT%Mesh_Step,AT%CoreTail_Density(:),& AT%GradCoreTail(:),RadSize) ! Do Rk=1,RadSize ! grad=ABS(AT%Core_dDendr(Rk)) ! stores gradient ! Call pbefunc(AT%Core_Density(Rk),grad,AT%Core_Xchange(Rk),dfxcdn,dfxcdg) ! !! Remember: for GGA Core_Xchange is fxc ! Enddo Else Write(Error_Unit, * ) 'Initsystem: Error in XC_Type', XC_Type Stop EndIf !**** end core part R2 => AT%R2 Ylm => AT%Ylm If (XC_Type == XC_GGA_PBE .OR. XC_Type == XC_SGGA_PBE) then dYlmdtheta => AT%dYlmdtheta dYlmdphi => AT%dYlmdphi dPhi_ijdr => AT%dPhi_ijdr dTPhi_ijdr => AT%dTPhi_ijdr endif !********** Make R^2 ************ DR = AT%Mesh_Step*Stride !** Calc Radial weighting and R Do Rk=1, RadSize R2(Rk) = (DR*(Rk-1))**2 End Do count = 0 Do nili=1, AT%Basis_Size Li = AT%L_Value(nili) Phi_i =>AT%Phi(1:AT%Mesh_Size:Stride,nili) TPhi_i =>AT%TPhi(1:AT%Mesh_Size:Stride,nili) Do Rk=1, Num_AngPoints !** Calculate the Ylm's ** Ra = AngPoints(1:3, Rk) Ylm_i = Spharm(Ra(1), Ra(2), Ra(3), Li, .TRUE.) Ylm(1:2*Li+1, Li+1, Rk) = Ylm_i(1:2*Li+1) If (XC_Type == XC_GGA_PBE .OR. XC_Type == XC_SGGA_PBE) then Call GradYlm(Ra(1),Ra(2),Ra(3),Li,dYlmdt,dYlmdp) dYlmdtheta(1:2*Li+1, Li+1, Rk) = dYlmdt(1:2*Li+1) dYlmdphi(1:2*Li+1, Li+1, Rk) = dYlmdp(1:2*Li+1) EndIf End Do Do njlj=1, AT%Basis_Size count = count + 1 Phi_j =>AT%Phi(1:AT%Mesh_Size:Stride,njlj) TPhi_j =>AT%TPhi(1:AT%Mesh_Size:Stride,njlj) Phi_ij_R2 => AT%Phi_ij_R2 TPhi_ij_R2 => AT%TPhi_ij_R2 Phi_ij_R2(2:RadSize,count) = & Phi_i(2:RadSize)*Phi_j(2:RadSize)/R2(2:RadSize) !Phi_ij_R2(1,count)=2*Phi_ij_R2(2,count)-Phi_ij_R2(3,count) Phi_ij_R2(1,count)=3*(Phi_ij_R2(2,count)-Phi_ij_R2(3,count)) & + Phi_ij_R2(4,count) TPhi_ij_R2(2:RadSize,count) = & TPhi_i(2:RadSize)*TPhi_j(2:RadSize)/R2(2:RadSize) !TPhi_ij_R2(1,count)=2*TPhi_ij_R2(2,count)-TPhi_ij_R2(3,count) TPhi_ij_R2(1,count)=3*(TPhi_ij_R2(2,count)-TPhi_ij_R2(3,count)) & + TPhi_ij_R2(4,count) If (XC_Type == XC_GGA_PBE .or. XC_Type == XC_SGGA_PBE) then call nderiv(DR,Phi_ij_R2(:,count),dPhi_ijdr(:,count),RadSize) call nderiv(DR,TPhi_ij_R2(:,count),dTPhi_ijdr(:,count),RadSize) EndIf End Do End Do Return End Subroutine End Module spinpwpaw/code/initatomtypes.f900100664004704100470410000000353210303710172017073 0ustar natalienatalie!***************************************************************************** ! ! File : initatomtypes.f90 ! by : Alan Tackett ! on : 9/21/95 ! for : PAW Project ! ! InitAtomTypes - Allocates the space for the different Atom type structures ! !***************************************************************************** Subroutine InitAtomTypes(WC) Use paw_inout Use atom_data Use misc Implicit NONE!!!!! Type (Word_context), Intent(INOUT) :: WC Integer :: i,j Character*25, Pointer :: Type_Strings(:) Call GetNumber(WC, j) if (Max_Atom_Types > 0) then !** Ignore Already allocated ** Write(Error_Unit, *) "InitAtomTypes: Attempt to Reallocate AtomTypes list!" Write(Error_Unit, *) "InitAtomTypes: Requested Size :",j Write(Error_Unit, *) "InitAtomTypes: Current Size :",Max_Atom_Types Write(Error_Unit, *) "InitAtomTypes: Request IGNORED!" else if (j <= 0) then !** Bad Value ** Write(Error_Unit, *) "InitAtomTypes: Bad Size for AtomTypes :",j Write(Error_unit, *)"InitAtomTypes: IGNORING request!" else !** Good Value if (Print_Level <= PRINT_COMMANDS) then Write(Log_Unit, *) ">Max_AtomTypes ",j End If Max_Atom_Types = j Allocate(AtomType_Info(j), STAT=i) if (i /= 0) then !*** Error with Allocation *** Write(Error_Unit, *) "InitAtomTypes: Error with Allocation! Error = ",i Write(Error_Unit, *) "InitAtomTypes: Requested Size : ", j Call Word_GetAndPrint(WC, Error_Unit, "InitAtomTypes:") STOP End If Allocate(Type_Strings(Max_Atom_types), STAT=i) Call Check_Error(i, "InitAtomTypes: Error with String LUT allocation!", & Error_Unit, .TRUE., WC, "InitAtomTypes:") Call InitStringList(AtomType_LUT, Type_Strings, j, 0, STR_IGNORE, STR_UPPER) End If Return End Subroutine spinpwpaw/code/initspecificatoms.f900100664004704100470410000000401310303710172017672 0ustar natalienatalie!***************************************************************************** ! ! File : initspecificatoms.f90 ! by : Alan Tackett ! on : 7/30/98 ! for : PAW Project ! ! InitSpecificAtoms - Allocates the space for the different ! specific Atom structures ! !***************************************************************************** Subroutine InitSpecificAtoms(WC) Use paw_inout Use atom_data Use misc Use strings implicit none Type (Word_context), Intent(INOUT) :: WC Integer :: i,j Character*25, Pointer :: Type_Strings(:) Call GetNumber(WC, j) if (Max_Specific_Atoms > 0) then !** Ignore Already allocated ** Write(Error_Unit, *) "InitSpecificAtoms: Attempt to Reallocate ", & "Specific Atoms list!" Write(Error_Unit, *) "InitSpecificAtoms: Requested Size :",j Write(Error_Unit, *) "InitSpecificAtoms: Current Size :", & Max_Specific_Atoms Write(Error_Unit, *) "InitSpecficiAtoms: Request IGNORED!" else if (j <= 0) then !** Bad Value ** Write(Error_Unit, *) "InitSpecificAtoms: Bad Size for Specfic Atoms :",j Write(Error_unit, *)"InitSpecificAtoms: IGNORING request!" else !** Good Value if (Print_Level <= PRINT_COMMANDS) then Write(Log_Unit, *) ">Max_Specific_Atoms ",j End If Max_Specific_Atoms = j Allocate(Atom_List(j), STAT=i) if (i /= 0) then !*** Error with Allocation *** Write(Error_Unit,*) "InitSpecificAtoms: Error with Allocation! Error=",i Write(Error_Unit,*) "InitSpecificAtoms: Requested Size : ", j Call Word_GetAndPrint(WC, Error_Unit, "InitSpecificAtomss:") STOP End If Allocate(Type_Strings(Max_Specific_Atoms), STAT=i) Call Check_Error(i,"InitSpecificAtoms: Error with String LUT allocation!",& Error_Unit, .TRUE., WC, "InitSpecificAtoms:") Call InitStringList(Atom_LUT, Type_Strings, j, 0, STR_IGNORE, STR_UPPER) End If Return End Subroutine spinpwpaw/code/initsystem.f900100664004704100470410000003174510371153104016402 0ustar natalienatalie!****************************************************************************** ! ! File : initsystem.f90 ! by : Alan Tackett ! on : 7/30/98 ! for : PAW Project ! ! InitSystem - Performs the One time initialization for the PAW system ! ! Modified for spin by Ping Tang and N. A. W. Holzwarth ! Last change 5/23/05 !****************************************************************************** Subroutine InitSystem Use paw_inout Use misc Use bz_data Use psilib Use options_data Use crystal_data Use atom_data Use spherical_harmonic Use mathlib Use hamiltonian Use crystal_symmetry Use mem_data Use memmgr Use solver Use relaxsys Use gpoints Use fileio Use structfact USe ylm_fact Use oinverse Use ldatom_info Use local_criteria_lib Use exchange_corr Implicit NONE!!!!!!! Character*100 :: Msg Integer :: KGrid(3), FinalGrid(3), i, aerr, Lmax, j,Npts,a,many Real :: t , s Real :: PC(3), R(3), G(3), theta, error, t1, Exc, Vxc, den,grad Logical :: Ok Integer :: k,n, Oldk,bufloaded, m, u,v, x,y,z,PM(3), mindex, h1,h2,h3,p Type (Atom_Info_Fixed), Pointer :: AT Call Start_Timer(Timer(Setup_timer)) Call PrintDate(Log_Unit, 'InitSystem: Paw Start!') Call Init_FIleIO !*** Initialize IO routines *** Vxc_MinSize = 40 PAW_FirstTime = .TRUE. if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) 'InitSystem: Starting System Initialization.***************' End If If (Atomic_Mode == SIM_SEPM) V_MixType = MIX_VEFF !** Generate all the atoms and their positions ** Call Clone_Cell(xtal%CloneCell) If (UseShells) then Write(Log_Unit,*) 'Initializing Shell Parmameters' Do p = 1,Shell%NPARAMS n=0 t = 0 !Shell%C(p) = 0 Do i=1,Specific_Atoms If (Shell%AtomMap(i)%MapParams>0) then Do j=1,Shell%AtomMap(i)%MapParams If (Shell%AtomMap(i)%Map(j)==p) then n=n+1 t=t+Dot_Product(Shell%AtomMap(i)%IV(:,j), & (Atom_List(i)%Pos-Shell%AtomMap(i)%Origin)) EndIf Enddo EndIf Enddo If (n < 1) then Write(Error_Unit,*) 'Error in InitSystem -- Shell parameter',& p Stop EndIf Shell%C(p) = t/n Write(Log_Unit,'(" Shell param ", i5," = ", 1pe15.7)')p,Shell%C(p) EndDo ! check positions Do a=1,Specific_Atoms many = Shell%AtomMap(a)%MapParams If (many > 0) then R = Shell%AtomMap(a)%Origin Do i=1,many p=Shell%AtomMap(a)%Map(i) R = R + Shell%C(p)*Shell%AtomMap(a)%V(:,i) Enddo G=R-Atom_List(a)%Pos s=Dot_Product(G,G) if (s>1.e-8) then write(Error_unit,*) 'Error in Shell for atom', a write(Error_unit,*) 'Correct position:', Atom_List(a)%Pos write(Error_unit,*) 'Fract position:', Atom_List(a)%Frac_Pos write(Error_unit,*) 'Shell position:', R stop endif EndIf Write(Log_Unit,*) 'Shell parameters check for atom ', a Enddo EndIf Call CheckAtomOverlap !*** Next make the AtomType_LUT and AtomType_Range arrays *** Allocate(AtomType_MAP(Max_Specific_Atoms), AtomType_Range(2,Max_Atom_Types)) k = 0 Do i=1, Atom_Types AtomType_Range(1,i) = k + 1 Do j=1, Specific_Atoms If (Atom_List(j)%TypeIndex == i) then k = k + 1 AtomType_MAP(k) = j End If End Do AtomType_Range(2,i) = k End Do Call CountBands !*** Count the Bands If (NumBands < (User_MinPsi+1)) then write(LOG_Unit, *) 'InitSystem: NumBands < MinBands! Changing ', & ' NumBands form', NumBands, ' to ', User_MinPsi+1 NumBands = User_MinPsi+1 end If if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) 'InitSystem: Total Number of Bands :', NumBands write(LOG_Unit, *) 'InitSystem: Total Number of Electrons :', TotalElectrons End If !************* BZ Setup **************** If (.NOT. Xtal_Defined) then Write(Error_Unit, *) 'InitSystem: Crystal not Defined! Exiting!' Call Word_GetAndPrint(PAW_WC, Error_Unit, 'InitSystem:') !Call SendQuit STOP End If if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) 'InitSystem: Generating the BZ K-point grid.' End If BZ%Bands = NumBands Call bz_Set_All(bz,Xtal%BZ_Method,0.5,TotalElectrons, 0.0, 1.0, 1E-10, & 200, Xtal%Sigma) If (Associated(BZ%Ku)) then !** Ignoring Kpnts grid using the user !** supplied list if(.not.spindependence) then Allocate(BZ%Keu(NumBands,BZ%TotalUniq), & BZ%WtUniq(NumBands,BZ%TotalUniq), & STAT=aerr) else Allocate(BZ%Keu(2*NumBands,BZ%TotalUniq), & BZ%WtUniq(2*NumBands,BZ%TotalUniq), & STAT=aerr) end if if (aerr /= 0) then Write(Error_Unit, *) "InitSystem: Error Allocating BZ info! Error = ", aerr Call Word_GetAndPrint(PAW_wc, Error_Unit, 'InitSystem(BZ): ') !Call SendQuit STOP End If t = SUM(XTal%Wt) !** Make sure the weights are normalized xtal%Wt = Xtal%wt/ t Do i=1, NumBands BZ%WtUniq(i,:) = Xtal%Wt If (spindependence) BZ%WtUniq(i+NumBands,:) = Xtal%Wt End Do DeAllocate(Xtal%Wt) !*** Free the Temporary Wt buffer NumKpnts = BZ%TotalKpnts else !*** Generate the List of BZ K-Points write(Log_unit,*)' K-point generation not working' stop BZ%Weight => BZ%WtUniq; Kgrid = Xtal%Kpnts_Grid - 1 Call BZ_MakeGrid(BZ,Xtal%Recip,(/0.0,0.0,0.0/),(/1.0,1.0,1.0/),NumBands, & KGrid, (/2,2,2/), 1, Xtal%Volume) Call BZ_Set(BZ, BZ_SET_ELECTRONS, TotalElectrons) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) 'InitSystem: Determining Unique BZ K-points.' End If i = 0 !** Must call Twice first time det uniq size and second stores them Call BZ_UniqueKpnts(BZ, Xtal%Basis, Xtal%RotMatrix, Xtal%Rot_Size, i) Call BZ_UniqueKpnts(BZ, Xtal%Basis, Xtal%RotMatrix, Xtal%Rot_Size, i) NumKpnts = i End If if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit,*) 'InitSystem: Number of Unique BZ K-points:',NumKpnts Write(LOG_Unit,*)'InitSustem: Generating the Angular integration points' End If if(.not.spindependence) Allocate(Occupancy(NumBands, NumKpnts), STAT=i) if(spindependence) Allocate(Occupancy(2*NumBands, NumKpnts), STAT=i) Write(Msg,*) "InitSystem: Can't alloc space Occupancies!" Call Check_Error(i, MSg, Error_Unit, .TRUE., PAW_WC, "InitSystem:") ! Check for spindependence and if necessary, reset exchange-correlation ! parameters if (.not.XC_TYPE_SET) then write(Error_Unit,*) 'InitSystem: Warning XC_Type not set -- default used' XC_TYPE_SET=.true. XC_TYPE=XC_LDA_PW endif if (Spindependence) then If (XC_TYPE == XC_LDA_PW) then XC_TYPE = XC_LSDA_PW write(Log_Unit,*) 'InitSystem: Spin restricted calculation' write(Log_Unit,*) 'InitSystem: XC_TYPE = LSDA_PW' Endif If (XC_TYPE == XC_GGA_PBE) then XC_TYPE = XC_SGGA_PBE write(Log_Unit,*) 'InitSystem: Spin restricted calculation' write(Log_Unit,*) 'InitSystem: XC_TYPE = SGGA_PBE' Endif endif ! If (Atomic_Mode /= SIM_SEPM) then - this part moved to PrepareVxc-- ******** ! !**** Create the Core XC-- this part moved to PrepareVxc-- ******** ! If (XC_Type == XC_LDA_PW) then ! Do i=1, Atom_Types ! AT => AtomType_Info(i) ! Do j=2, AT%Mesh_Size ! den = AT%Core_Density(j) ! !!Call ExchangeCorr(den, Vxc, Exc, .FALSE., XC_Type) ! If (XC_Type == XC_LDA_PW) Call pwldafunc(den,Exc,Vxc) ! AT%Core_Xchange(j) = Exc ! End Do ! AT%Core_Xchange(1) = 2*AT%Core_Xchange(2)-AT%Core_Xchange(3) ! End Do ! Else If (XC_Type == XC_GGA_PBE) then ! Do i=1,Atom_Types ! AT => AtomType_Info(i) ! Npts=AT%Mesh_Size ! write(6,*) 'in initsystem',Npts,SIZE(AT%Core_Density),SIZE(AT%Core_dDendr) ! call flush(6) ! Call nderiv(AT%Mesh_Step,AT%Core_Density(:),AT%Core_dDendr(:),Npts) ! Do j=1,Npts ! grad=ABS(AT%Core_dDendr(j)) ! stores gradient ! Call pbefunc(AT%Core_Density(j),grad,AT%Core_Xchange(j),s,t) ! !! Remember: for GGA Core_Xchange is fxc ! Enddo ! Enddo ! Else ! Write(Error_Unit, * ) 'Initsystem: Error in XC_Type', XC_Type ! Stop ! EndIf ! ! ! !************ Generate the Angular Integration points *************** ! !Call InitSpharm ! Num_AngPoints = Angular_Points**2 ! AngPoints => AngInit(Angular_Points,Angular_Points,Xtal%Volume,Error_Unit) ! End If !******* Initialize the Crystal_Symmetry routines ********** Lmax = -1 Do i=1, Atom_Types j = MaxVal(AtomType_Info(i)%L_Value) Lmax = MAX(Lmax, j) End Do If (Print_Level <= PRINT_NORMAL) then Write(Log_Unit,*) 'InitSystem: Calling SetSym with Lmax=',Lmax End If If (xtal%Auto_Symmetry) Call StoreSymmetry(Sym_Name) If (xtal%Rot_Size > 0) Call SetSym(Lmax) !** Adjust the projector Gcut based on the mode *** ! PW_Gcut(G_PROJ) = PW_Gcut(G_LOW) If (Proj_Mode == 0) then Proj_Mode = Run_Mode PW_Gcut(G_PROJ) = PW_Gcut(G_LOW) End If !*** Initialize the G-points **** Call InitGpoints(Grid, xtal%Recip, PW_Gcut(G_HIGH), PW_Gcut(G_LOW), & PW_Gcut(G_PROJ), paw_WC) call InitkplusGfilter(Numkpnts) PsiArraySize=Gall_Size(G_LOW) Call AssignBaseFileUnits(FD_Base) !***** Initialize the Memory Management routines ****** Call InitWorkArrays(10) Call ReAllocate_Work(Gall_Size(G_LOW)) !***** Initialize the Memory Management routines ****** Call InitMemMgr(Psi_Memory) !*** Initialize the Local selection criteria map *** Call InitLocalCriteria !**** Initialize the solver routines ******* Call InitSolver !***** Initialize the Structure factor routines ****** Call InitStructFactors(FD_BlochK, Bloch_Memory) If (Atomic_Mode /= SIM_SEPM) then !***** Initialize the Ylm factor routines ****** j = MAXVal(AtomType_Info(1)%L_Value) Do i=2, Atom_Types j = Max(j,MAXVal(AtomType_Info(i)%L_Value)) End Do Call InitYlmFact(FD_Ylm, Ylm_Memory, j) !**** Initialize the Radial projectors ***** If (Proj_Mode == 0) Proj_mode = Run_Mode Call InitProjectors(FD_RadProj, FD_Proj, Proj_Memory) If (Eigen_Mode == EIGEN_ENERGY) Call InitOinverse(FD_Oinv, 50.0) !Call InitOinverse(FD_Oinv, 50.0) end If !********* Setup Wave Function Buffers ********* if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) 'InitSystem: Initializing the PSI routines.' End If write(Log_unit,*) 'InitSysem: Before InitPsiLib' call flush(Log_Unit) Call InitPsiLib write(Log_unit,*) 'InitSysem: After InitPsiLib' call flush(Log_Unit) If (Atomic_Mode /= SIM_SEPM) then !********** Calculate the Base Energy ********** CohesiveEnergy = 0 TotalEnergy = 0 AtomicEnergy = 0 Do i=1, Specific_Atoms AtomicEnergy = AtomicEnergy + & AtomType_Info(Atom_List(i)%TypeIndex)%Atom_Energy End Do if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) 'InitSystem: Total Atomic Energy :', AtomicEnergy End If End If !******* Initialize the Hamiltonian Routines ********** If (Print_Level <= PRINT_NORMAL) then Write(Log_Unit,*) 'InitSystem: Initializing Hamiltonian Module.' call flush(Log_Unit) End If Call InitHam write(log_unit,*) 'InitSytem: Finished InitHam -- start alloc PDOT' call flush(log_unit) !!!Call Init_relax !** Initialize relax routines ** If (Atomic_Mode == SIM_SEPM) PLM_Max = 0 !*** Allocate Space for The PDOT's for each Psi *** write(Log_unit,*) 'PLM_Max = ', PLM_Max call flush(log_unit) Do i=1, Mem_MapSize PsiInfo(i)%PDot_Stored = .FALSE. Allocate(PsiInfo(i)%PDOT(PLM_Max)) End Do PAW_FirstTime = .FALSE. ! Do i=1, Atom_types !*** DEBUG ONLY *** ! ATomType_Info(i)%Oij = 0 ! End Do ! if (Print_Level == PRINT_VERBOSE) then ! write(LOG_Unit, *) 'InitSystem: Transferring data to nodes' ! End If Matrix_Range = RANGE_DO !***** Initialize ploting data**** volumeplot%query=0 volumeplot%bondtol=0 planeplot%query=0 !** Tell everybody else it's ok to continue ** !** Call MPI_BCAST(CMD_NEXT, 1, DATA_INTEGER, Root_Rank, PAW_COMM, i) !** Call InitSystem_MPI if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) 'InitSystem: Finished System Initializiation!***************' End If write(LOG_Unit, *) 'InitSystem: Finished System Initializiation!***************' call flush(Log_unit) Call Stop_Timer(Timer(Setup_timer)) Return End Subroutine spinpwpaw/code/laplacian.f900100664004704100470410000000721510303710172016110 0ustar natalienatalie!****************************************************************************** ! ! File : laplacian.f90 ! by : Alan Tackett ! on : 08/19/98 ! for : PAW Proagram ! ! ! !****************************************************************************** Module laplacian Use atom_data Use search_sort Use misc Use gpoints Implicit NONE!!!!!!!!!!!!!! !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! CalcDEL2 - Calculates the Laplacian of the given grid ! ! Vin - Input Vector 2 ! Vout - Output vector containing Vout=DEL Vin ! ! NOTE: the Vout array is ZEROED!!!! ! !****************************************************************************** Subroutine CalcDEL2( Vin, Vout) Complex, Intent(IN) :: Vin(:) Complex, TARGET, Intent(OUT) :: Vout(:) Real :: c1 Integer :: gi, N !Write(*,*) 'CalcDEL2: Start!!!!!!!!!!' Vout = 0 c1 = -1 N = Gpnt_Size(G_LOW) - 1 Do gi=1, Gpnt_Size(G_LOW) Vout(gi) = c1*Vin(gi)*Gpnt(4,gi)**2 End Do Do gi=2, Gpnt_Size(G_LOW) Vout(gi+N) = c1*Vin(gi+N)*Gpnt(4,gi)**2 End Do !Write(*,*) 'CalcDEL2: End!!!!!!!!!!' Return End Subroutine !****************************************************************************** ! ! CalcDEL2_PHASE - Calculates the Laplacian of the given grid ! ! Kvec - Kpoint Vector ! BLochK - Corresponding BLock Phase ! Vin - Input Vector 2 ! Vout - Output vector containing Vout= DEL (Vin ) in Fourier space ! ! NOTE: the Vout array is ZEROED!!!! ! !****************************************************************************** Subroutine CalcDEL2_PHASE( Kvec, Vin, Vout) Real, Intent(IN) :: Kvec(:) Complex, Intent(IN) :: Vin(:) Complex, TARGET, Intent(OUT) :: Vout(:) Real :: c1, G(3), G2 Integer :: gi, N c1 = DOT_PRODUCT(Kvec,Kvec) If (c1<1E-20) then Call CalcDEL2( Vin, Vout) else c1 = -1 N = Gpnt_Size(G_LOW)-1 Do gi=1, Gpnt_Size(G_LOW) G = Kvec + Gpnt(1:3,gi) G2 = DOT_PRODUCT(G,G) Vout(gi) = c1*Vin(gi)*G2 End Do Do gi=2, Gpnt_Size(G_LOW) G = Kvec - Gpnt(1:3,gi) G2 = DOT_PRODUCT(G,G) Vout(gi+N) = c1*Vin(gi+N)*G2 End Do End If Return End Subroutine !****************************************************************************** ! ! CalcDEL2_TIME - Applies the KE and vector potential operator ! to the given vector. ! ! Kvec - Kpoint Vector ! BLochK - Corresponding BLock Phase ! Vin - Input Vector ikr 2 -ikr ! Vout - Output vector containing Vout= e (-i*DEL-A) (Vin * e ) ! ! NOTE: The Vout array is ZEROED!!!! ! Also notice the (+) sign on the entire expression. This ! is the OPPOSITE than the way the KE is calc'ed above so Hpsi must ! be changed accordingly. ! !****************************************************************************** Subroutine CalcDEL2_TIME( Kvec, Vin, Vout) Real, Intent(IN) :: Kvec(:) Complex, Intent(IN) :: Vin(:) Complex, TARGET, Intent(OUT) :: Vout(:) Real :: c1, G(3), G2, KA(3) Integer :: gi, N KA = Kvec - Vector_Pot N = Gpnt_Size(G_LOW)-1 Do gi=1, Gpnt_Size(G_LOW) G = KA + Gpnt(1:3,gi) G2 = DOT_PRODUCT(G,G) Vout(gi) = Vin(gi)*G2 End Do Do gi=2, Gpnt_Size(G_LOW) G = KA - Gpnt(1:3,gi) G2 = DOT_PRODUCT(G,G) Vout(gi+N) = Vin(gi+N)*G2 End Do Return End Subroutine End Module spinpwpaw/code/lcao.f900100664004704100470410000002124010303710172015074 0ustar natalienatalie!****************************************************************************** ! ! File : lcao.f90 ! by : Alan Tackett ! on : 02/18/97 ! for : PAW project ! ! This module contains routines to generate the initial wave function for ! use in the PAW program. The wave function is constructed from a linear ! combination of atomic orbitals and Bloch wave vectors. The inital ! occupancies are also calculated. ! !****************************************************************************** Module lcao Use paw_inout Use word Use atom_data Use misc Use crystal_data Use bz_data Use psilib Use options_data Use spherical_harmonic Use mem_data USe memmgr Use projectors Use debug Use hamiltonian Use work_mgr Use gpoints Implicit NONE!!!!! !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! LCAO_Interpolate - Interpolates the Radial LCAO function with a third ! order polynomial around the requested point and ! returns the iterpolated value ! ! TPhi - Radial Basis function ! Mesh_Size - Number of radial grid points ! Mesh_Step - Real space distance between mesh points ! R - R-value to interpolate ! !****************************************************************************** Real Function LCAO_Interpolate(Tphi, Mesh_size, Mesh_Step, R) Real, Intent(IN) :: tphi(:) Integer, Intent(IN) :: Mesh_Size Real, Intent(IN) :: Mesh_Step Real, Intent(IN) :: R Real :: fn, a,b,c,d, h1,h2,h3, y0,y1,y2,y3, x Integer :: i,j,k i = R/Mesh_Step + 1 - 1 !*** We want 2 pnts to the left and right of R If (i>=Mesh_Size) then !*** If too far away then return 0 fn = 0 else IF (i<=0) then !*** Make sure Index is good i = 1 else if (i>Mesh_Size-3) then i = Mesh_Size - 3 End If h1=Mesh_Step; h2=h1*h1; h3=h1*h2; y0 = TPhi(i); y1=TPhi(i+1); y2=TPhi(i+2); y3=TPhi(i+3); d = y0 c = (18*y1 - 9*y2 + 2*y3 - 11*y0)/(6*h1) b = (-y3 + 2*y0 - 5*y1 + 4*y2)/(2*h2) a = (-3*y2 + y3 - y0 + 3*y1)/(6*h3) x = R - (i-1)*Mesh_Step Fn = d + x*(c + x*(b + a*x)) End If LCAO_Interpolate = fn Return End Function !****************************************************************************** ! ! CalcLCAO - Generates an LCAO wave function given the radial basis function ! and associated spherical harmonic ! ! psi - Wave function calculated(Returned) ! tphi - Radial Basis function ! Mesh_Size - Number of radial grid points ! Mesh_Step - Real space distance between mesh points ! L,M - Spherical harmonic L and M values ! Kvec - Bloch K point ! Ra - Atom position ! Cells - Array determining which cells to sum over ! G_Size - Max G index to use ! !*OLD* !****************************************************************************** Subroutine CalcLCAO_OLD(psi,tphi, mesh_size, mesh_step,L, M, Kvec, Ra, & Cells, G_Size) Complex, Intent(OUT) :: psi(:) Real, Intent(IN) :: tphi(:) Integer, Intent(IN) :: Mesh_Size Real, Intent(IN) :: Mesh_Step Integer, Intent(IN) :: L Integer, Intent(IN) :: M Real, Intent(IN) :: Kvec(:) Real, Intent(IN) :: Ra(:) Integer, Intent(IN) :: Cells(:) Integer, Intent(IN) :: G_Size Integer :: cx, cy, cz, px, py, pz, t, i, j, N Real :: G(3), RadG, theta, Gmag Complex :: Phase Complex :: Ylm(13) !! write(Log_Unit,*) 'CalcLCAO: Kvec=',Kvec, ' Ra=',Ra Psi = CMPLX(0,0) N = Gpnt_Size(G_LOW) - 1 Do i=1, G_Size G = Kvec+Gpnt(1:3,i) Gmag = SQRT(DOT_PRODUCT(G,G)) theta = DOT_PRODUCT(Gpnt(1:3,i), Ra) Phase = CMPLX(cos(theta), -sin(theta)) Ylm = Spharm(G(1),G(2),G(3), L, .TRUE.) RadG = RadialFourier(L, Gmag, Mesh_Step, Mesh_Size, TPhi) Psi(i) = RadG*Ylm(L+m+1)*Phase If (i>1) then G = Kvec-Gpnt(1:3,i) Gmag = SQRT(DOT_PRODUCT(G,G)) Ylm = Spharm(G(1),G(2),G(3), L, .TRUE.) RadG = RadialFourier(L, Gmag, Mesh_Step, Mesh_Size, TPhi) Psi(i+N) = RadG*Ylm(L+m+1)*Conjg(Phase) Endif End Do Return End Subroutine !****************************************************************************** ! ! CalcLCAO - Generates an LCAO wave function given the radial basis function ! and associated spherical harmonic ! ! psi - Wave function calculated(Returned) ! tphi - Radial Basis function in Rad-G ! Mesh_Size - Number of radial grid points ! Mesh_Step - Real space distance between mesh points ! L,M - Spherical harmonic L and M values ! Kvec - Bloch K point ! Ra - Atom position ! Cells - Array determining which cells to sum over ! G_Size - Max G index to use !*NEW* !****************************************************************************** Subroutine CalcLCAO(psi,tphi, mesh_size, mesh_step,L, M, Kvec, Ra, & Cells, Glist, G_Size) Complex, Intent(OUT) :: psi(:) Real, Intent(IN) :: tphi(:) Integer, Intent(IN) :: Mesh_Size Real, Intent(IN) :: Mesh_Step Integer, Intent(IN) :: L Integer, Intent(IN) :: M Real, Intent(IN) :: Kvec(:) Real, Intent(IN) :: Ra(:) Integer, Intent(IN) :: Cells(:) Real, Intent(IN) :: GList(:,:) Integer, Intent(IN) :: G_Size Integer :: cx, cy, cz, px, py, pz, t, i, j, N, Ng Real :: G(3), RadG, theta, Gmag Complex :: Phase Complex :: Ylm(13) !! write(Log_Unit,*) 'CalcLCAO: Kvec=',Kvec, ' Ra=',Ra Psi = CMPLX(0,0) N = Gpnt_Size(G_LOW) - 1 Ng = G_Size - 1 Do i=1, G_Size G = Glist(1:3,i) Gmag = Glist(4,i) theta = DOT_PRODUCT(Gpnt(1:3,i), Ra) Phase = CMPLX(cos(theta), -sin(theta)) Ylm = Spharm(G(1),G(2),G(3), L, .TRUE.) RadG = TPhi(i) Psi(i) = RadG*Ylm(L+m+1)*Phase If (i>1) then G = Glist(1:3,i+Ng) Gmag = Glist(4,i+Ng) Ylm = Spharm(G(1),G(2),G(3), L, .TRUE.) RadG = TPhi(i+Ng) Psi(i+N) = RadG*Ylm(L+m+1)*Conjg(Phase) Endif End Do Return End Subroutine !****************************************************************************** ! ! CalcRadG_LCAO - Calculates the radial FFT forms of the LCAO fns ! ! G_Size - Max +G ! Kvec - K-Point ! !****************************************************************************** Subroutine CalcRadG_LCAO(G_Size, Kvec, Glist) Integer, Intent(IN) :: G_Size Real, Intent(IN) :: Kvec(:) Real, Intent(OUT) :: Glist(:,:) Integer :: a, i, nl, j, L, Mesh_size, N Real, Pointer :: RadG(:), TPhi(:) Real :: G(3), Gmag, Mesh_Step Type (Atom_Info_Fixed), Pointer :: AT N = G_Size - 1 Do a=1, Atom_Types AT => AtomType_Info(a) Mesh_Step = AT%LCAO_Step Mesh_Size = AT%LCAO_Size Do nl=1, AT%Basis_Size RadG => AT%RadG_LCAO(:,nl) TPhi => AT%TPhi_LCAO(:,nl) L = AT%L_Value(nl) Do i=1, G_Size G = Kvec+Gpnt(1:3,i) Gmag = SQRT(DOT_PRODUCT(G,G)) Glist(1:3,i) = G Glist(4,i) = Gmag RadG(i) = RadialFourier(L, Gmag, Mesh_Step, Mesh_Size, TPhi) If (i>1) then G = Kvec-Gpnt(1:3,i) Gmag = SQRT(DOT_PRODUCT(G,G)) Glist(1:3,i+N) = G Glist(4,i+N) = Gmag RadG(i+N) = RadialFourier(L, Gmag, Mesh_Step, Mesh_Size, TPhi) Endif End Do End Do End Do Return end Subroutine !****************************************************************************** ! ! FreeLCAO - Frees the RadG LCAO storage ! !****************************************************************************** Subroutine FreeLCAO Integer :: i Do i=1, Atom_Types DeAllocate(AtomType_Info(i)%RadG_LCAO) End Do Return End Subroutine !****************************************************************************** ! ! AllocLCAO - Allocates the RadG LCAO storage ! ! Array_Size - Size of the array ! !****************************************************************************** Subroutine AllocLCAO(Array_Size) Integer, Intent(IN) :: Array_Size Integer :: i !** Allocate space for the RadG versions of each LCAO type ** Do i=1, Atom_Types Allocate(AtomType_Info(i)%RadG_LCAO(Array_Size, & AtomType_Info(i)%basis_Size)) End Do Return End Subroutine !****************************************************************************** ! ! InitLCAO - Initializes the LCAO routines for use ! !****************************************************************************** Subroutine InitLCAO Return End Subroutine End Module spinpwpaw/code/ldatom_info.f900100664004704100470410000022543610365432772016505 0ustar natalienatalie!***************************************************************************** ! ! File : ldatom_info.f90 ! by : Alan Tackett ! on : 8/30/95 ! for : PAW Method ! ! Contains routine to load the atomic species tpye and also a specific atom ! ! Updated for spin by Ping Tang and N. A. W. Holzwarth ! Last change 6/08/05 !***************************************************************************** Module ldatom_info Use atom_data Use exchange_corr Use paw_inout Use word Use misc Use projectors Use options_data Use denvhat_pack Use search_sort Use vhartree_pack Use crystal_data Use mathlib Use projectors Use gausslib Implicit NONE!!! !***************************************************************************** Contains !***************************************************************************** !*************************************** ! ! AtomAlloc - Allocates the MULTI-D arrays ! !*************************************** Subroutine AtomAlloc(WC, A) Type (Atom_Info_Fixed), Pointer :: A Type (Word_Context), Intent(INOUT) :: WC Integer :: aerr If (Atomic_Mode == SIM_AE) then If ((A%Basis_Size == -1) .OR. (A%LCAO_Size == -1)) then Write(Error_Unit, *) "atomalloc: Can't Allocate arrays! Dim's not set!" Write(Error_Unit, *) "atomalloc: Atom Name : ", Trim(A%Atom_Name) Write(Error_Unit, *) "atomalloc: Basis_Size = ", A%Basis_Size Write(Error_Unit, *) "atomalloc: LCAO_Size = ", A%LCAO_Size Call Word_GetAndPrint(WC, Error_Unit, 'atomalloc: ') STOP End If else If ((A%Basis_Size == -1) .OR. (A%Mesh_Size == -1) .OR. & (A%LCAO_Size == -1)) then Write(Error_Unit, *) "atomalloc: Can't Allocate arrays! Dim's not set!" Write(Error_Unit, *) "atomalloc: Atom Name : ", Trim(A%Atom_Name) Write(Error_Unit, *) "atomalloc: Basis_Size = ", A%Basis_Size Write(Error_Unit, *) "atomalloc: Mesh_Size = ", A%Mesh_Size Write(Error_Unit, *) "atomalloc: LCAO_Size = ", A%LCAO_Size Call Word_GetAndPrint(WC, Error_Unit, 'atomalloc: ') STOP End If End If if (Print_Level == PRINT_VERBOSE) then write(Log_Unit, *) "#atomalloc : Allocating arrays for phi, tphi, tp" End If Allocate(A%Phi(A%Mesh_Size, A%Basis_Size), STAT=aerr) Call Check_Error(aerr, 'atomalloc: Error Allocating PHI!', Error_Unit, & .TRUE., WC, 'atomalloc: ') Allocate(A%TPhi(A%Mesh_Size, A%Basis_Size), & A%TPhi_LCAO(A%LCAO_Size, A%Basis_Size), STAT=aerr) Call Check_Error(aerr, 'atomalloc: Error Allocating TPHI!', Error_Unit, & .TRUE., WC, 'atomalloc: ') !Allocate(A%TP(A%Mesh_Size, A%Basis_Size), & ! A%TP_Deriv(A%Mesh_Size, A%Basis_Size), STAT=aerr) Allocate(A%TP(A%Mesh_Size, A%Basis_Size), STAT=aerr) Call Check_Error(aerr, 'atomalloc: Error Allocating TP!', Error_Unit, & .TRUE., WC, 'atomalloc: ') Return End Subroutine !********************************************************************** ! ! FillArray - Loads a 1-D array of data ! !********************************************************************** Subroutine FillArray(WC, A, A_Size, IDText) Type (Word_Context), Intent(INOUT) :: WC Real, Intent(OUT) :: A(:) Integer, Intent(IN) :: A_Size character*(*) :: IDText Character(132) :: str, token Integer :: ierr, tlen str = "FillArray(" // Trim(IDText) !***write(*,*) trim(str), 'STart---------------- N=',a_Size Call GetNumbers(WC, A, A_Size) if (W_ERROR /= W_OK) Then Write(Error_Unit, *) trim(str)," data): Array_Size=",A_Size Call EOF_Error(WC, trim(str) // " data):"); End If Call GetNextWord(WC, token, tlen) if (W_ERROR /= W_OK) Call EOF_Error(WC, trim(str) // " END)"); Call UpperCase(token) if (token /= "END") then Write(Error_Unit,*)"ldatom: END Not found while loading basis " Write(Error_Unit,*) "ldatom: Ignoring ALL text until END is found!" Call Word_GetAndPrint(WC, Error_Unit, "LdAtomType: ") Do While (token /= "END") Call GetNextWord(WC, token, tlen) if (W_ERROR /= W_OK) Call EOF_Error(WC, trim(str) // " scan)"); Call UpperCase(token) End Do End IF Return End Subroutine !********************************************************************** ! ! LoadArray - Allocates and Loads a 1-D array of data ! !********************************************************************** Subroutine LoadArray(WC, A, A_Size, IDText) Type (Word_Context), Intent(INOUT) :: WC Real, Pointer :: A(:) Integer, Intent(IN) :: A_Size character*(*) :: IDText Character(132) :: str, token Integer :: ierr, tlen str = "LoadArray(" // Trim(IDText) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) Trim(Str), ') : Loading with size =',A_Size End IF if (A_Size <= 0) then str = trim(str) // " alloc):" Write(Error_Unit,*) trim(str), "Can't load matrix no Size!" Call Word_GetAndPrint(WC, Error_Unit, trim(str)) STOP End If Allocate(A(A_Size), STAT=ierr) Call Check_Error(ierr, trim(str) // ' Error during allocation!', & Error_Unit, .TRUE., WC, trim(str)) Call FillArray(WC, A, A_Size, IDText) Return End Subroutine !********************************************************************** ! ! LoadDenVhat - Loads the Density and V_hat arrays ! !********************************************************************** Subroutine LoadDenVhat(WC, A, LUT, A_Size, IDtext) Type (Word_Context), Intent(INOUT) :: WC Real, Pointer :: A(:) Integer, Pointer :: LUT(:) Integer, Intent(IN) :: A_Size Character*(*) :: IDText Logical :: FirstTime, Exact Character*100 :: str, token Integer :: i, j, k, ierr, tlen Integer :: N, Ind(3) Real :: v FirstTime = .FALSE. str = "LoadDenVhat(" // Trim(IDtext) If (A_Size <= 0) then str = Trim(str) // " alloc):" Write(Error_Unit,*) trim(str), "Can't load matrix no Size!" Call Word_GetAndPrint(WC, Error_Unit, trim(str)) STOP End If !Write(Log_Unit, *) 'lddenvhat: A_Size=',A_size, ' * Associated(A)=',Associated(A) if (.NOT. Associated(A)) then Allocate(A(A_Size), STAT=ierr) Call Check_Error(ierr, trim(str) // ' Error during allocation!', & Error_Unit, .TRUE., WC, trim(str) // " alloc):") if (.NOT. Associated(LUT)) then FirstTime = .TRUE. Allocate(LUT(A_Size), STAT=ierr) Call Check_Error(ierr,trim(str)//' Error during LUT_DenVhat alloc!', & Error_Unit, .TRUE., WC, trim(str) // ": LUT_denvhat Alloc):") End If End If Do i = 1, A_Size !Write(Log_Unit,*) 'lddenvhat: i=',i Call GetNumbers(WC, Ind) !** Get the indices Call GetNumbers(WC, V) !** and the corresponding value j = DenVhat_Encode(Ind(1), Ind(2), Ind(3)) if (FirstTime) then !** First time then store values only A(i) = V LUT(i) = j else !** Check for index match in a previous run k = Linear_Search(LUT, j, Exact) !Write(Log_Unit,*) 'lddenvhat: Match = ',k, ' * Decode=',j if (Exact) then !** Got an Exact Match with a preceeding call A(k) = V !** So store the value in the right spot else !** Error!! Write(Error_Unit, *) 'LoadDenVhat: No match was found!' Write(Error_Unit, *) 'LoadDenVhat: (n1l1, n2l2, L) : ', Ind Call Word_GetAndPrint(WC, Error_Unit, 'LoadDenVhat:') STOP End If End If End Do Call GetNextWord(WC, token, tlen) !** Should Be and END Statement if (token /= "END") then Write(Error_Unit,*)"ldatom: END Not found while loading basis " Write(Error_Unit,*) "ldatom: Ignoring ALL text until END is found!" Call Word_GetAndPrint(WC, Error_Unit, "ldatom: ") Do While (token /= "END") Call GetNextWord(WC, token, tlen) if (W_ERROR /= W_OK) Call EOF_Error(WC, trim(str) // " scan)"); Call UpperCase(token) End Do End IF Return End Subroutine !********************************************************************** ! ! LoadVHartree - Loads the VHartree array ! !********************************************************************** Subroutine LoadVhartree(WC, A, LUT, A_Size) Type (Word_Context), Intent(INOUT) :: WC Real, Pointer :: A(:) Integer, Pointer :: LUT(:) Integer, Intent(IN) :: A_Size Character*100 :: str, token Integer :: i, j, k, ierr, tlen Integer :: N, Ind(5) Real :: v str = "LoadVHartree :" if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Loading VHartree" End IF If (A_Size <= 0) then str = Trim(str) // " alloc):" Write(Error_Unit,*) trim(str), "Can't load matrix no Size!" Call Word_GetAndPrint(WC, Error_Unit, trim(str)) STOP End If Allocate(A(A_Size), STAT=ierr) Call Check_Error(ierr, trim(str) // ' Error during allocation!', & Error_Unit, .TRUE., WC, trim(str) // " alloc):") if (.NOT. Associated(LUT)) then Allocate(LUT(A_Size), STAT=ierr) Call Check_Error(ierr,trim(str)//' Error during LUT_VHartree alloc!', & Error_Unit, .TRUE., WC, trim(str) // ": LUT_VHartreee Alloc):") End If Do i = 1, A_Size Call GetNumbers(WC, Ind) !** Get the indices Call GetNumbers(WC, V) !** and the corresponding value LUT(i) = VHartree_Encode(Ind(1), Ind(2), Ind(3), Ind(4), Ind(5)) A(i) = V End Do Call GetNextWord(WC, token, tlen) !** Should Be and END Statement if (token /= "END") then Write(Error_Unit,*)"ldatom: END Not found while loading basis " Write(Error_Unit,*) "ldatom: Ignoring ALL text until END is found!" Call Word_GetAndPrint(WC, Error_Unit, "ldatom: ") Do While (token /= "END") Call GetNextWord(WC, token, tlen) if (W_ERROR /= W_OK) Call EOF_Error(WC, trim(str) // " scan)"); Call UpperCase(token) End Do End IF Return End Subroutine !********************************************************************** ! ! Check_Atom - Does a quick test to make sure I got all the data ! !********************************************************************** Subroutine Check_Atom(WC, A) Type (Word_Context), Intent(INOUT) :: WC Type(Atom_Info_Fixed), Pointer :: A Logical :: Ok Ok = .TRUE. if (A%Basis_Size < 1) then Write(Error_Unit, *) 'ldatomType: Error Basis_Size =',A%Basis_size Ok = .FALSE. End If if (A%LCAO_Size < 1) then Write(Error_Unit, *) 'ldatomType: Error LCAO_Size =',A%LCAO_size Ok = .FALSE. End If if (A%LCAO_Step <= 0) then Write(Error_Unit, *) 'ldatomType: Error LCAO_Step =',A%LCAO_Step Ok = .FALSE. End If If (Atomic_Mode == SIM_PAW) then if (A%Mesh_Size < 1) then Write(Error_Unit, *) 'ldatomType: Error Mesh_Size = ', A%Mesh_size Ok = .FALSE. End If if (A%Overlap_Size < 1) then Write(Error_Unit,*) 'ldatomType: Error Overlap_Size = ', A%Overlap_size Ok = .FALSE. End If if (A%Hartree_Size < 1) then Write(Error_Unit,*) 'ldatomType: Error Hartree_Size = ', A%Hartree_Size Ok = .FALSE. End If if (A%DenVhat_Size < 1) then Write(Error_Unit,*) 'ldatomType: Error DenVhat_Size = ', A%DenVhat_Size Ok = .FALSE. End If if (A%Hartree_Size < 1) then Write(Error_Unit,*) 'ldatomType: Error Hartree_Size = ', A%Hartree_Size Ok = .FALSE. End If if (A%Mesh_Step <= 0) then Write(Error_Unit, *) 'ldatomType: Error Mesh_step = ', A%Mesh_Step Ok = .FALSE. End If if (A%Rc <= 0) then Write(Error_Unit, *) 'ldatomType: Error Rc = ', A%Rc Ok = .FALSE. End If if (A%Rbox <= 0) then Write(Error_Unit, *) 'ldatomType: Error Rbox = ', A%Rbox Ok = .FALSE. End If End If If (.NOT. Ok) then Call Word_GetAndPrint(WC, Error_Unit, 'Check_Atom:') STOP End IF Return End Subroutine !**************************************************************************** ! ! ldatomtype - Procedure to load all the atom specific information that ! is help fixed throughout the calculation. ! ! NOTE : This file also contains a support routine for allocation ! ! Format of AtomType in input file is shown below. All keywords are shown ! in uppercase. Curly braces denote an optional parameter. ! ! NOTE : NO checking is done to ensure that ALL data is loaded!!! ! ! MAX_ATOMTYPES MaxAtomType # Previously defined ! ! ATOMTYPE AtomName(string) ! ATOMXCTYPE character ! BASIS_SIZE integer ! MESH_SIZE integer ! DENVHAT_SIZE integer ! HARTREE_SIZE integer ! ATOMIC_CHARGE real ! CORE_CHARGE real ! SHAPE_TYPE character ! RC real {unit} # Cutoff Radius ! MESH_STEP real {unit} ! ENERGY real {unit} ! LCAO_SIZE integer # Size of tphi_LCAO functions ! LCAO_STEP real {unit} # Radial Step size of tphi_LCAO functions ! ! ENHANCE_Rc real {unit} # Local Enhancement radius > Rc ! ! TPHI_LCAO Basis_Index(integer) # One for each TPhi basis function ! Data listed in ascending order ! END ! ! ORBITALS ! Orbital_1(integer) ! ... ! Orbital_BASIS_SIZE(integer) ! END ! ! PHI Basis_Index(Integer) # One for each Basis function ! Data Listed in ascending order ! END ! ! TPHI Basis_Index(Integer) # One for each |phi~> ! Data Listed in ascending order ! END ! ! TPROJECTOR Basis_Index(Integer) # one for each |p~> ! Data listed in ascending order ! END ! ! CORE_DENSITY ! Data Listed in ascending order ! END ! ! OVERLAP_MATRIX # Size not needed because of definition ! Data Listed in ascending order ! END ! ! KINETIC_ENERGY_MATRIX ! Data Listed in ascending order ! END ! ! V_ION_MATRIX ! Data Listed in ascending order ! END ! ! DENSITY ! n1l1 n2l2 L value ! .. .. .. ... ! END ! ! V_HAT ! n1l1 n2l2 L value ! .. .. .. ... ! END ! ! V_HARTREE ! n1l1 n2l2 n3l3 n4l4 L value ! .. .. .. .. . ... ! END ! END # End of Atom Definition ! !********************************************************************** Subroutine LdAtomType(WC) Type (Word_Context), Intent(INOUT) :: WC Character*100 :: Token,Token2 Logical :: NewToken, Ok Integer :: i, j, k, L, m, tlen, intnum, base_i, base_j Real :: realnum, scale, den, Vxc, Exc, gmag ,V_local Integer, Pointer :: LUT(:) Integer, Pointer :: IntTemp(:) Real, Pointer :: RealTemp(:,:), Rtmp(:) Logical :: AllocatedBigArrays Type(Atom_Info_Fixed), Pointer :: A If (Atomic_Mode /= SIM_PAW) then Write(Log_Unit,*) 'LdAtomtype: Attempting to load a PAW', & ' pseudopotential when NOT in PAW mode!!!!!' Call Word_GetAndPrint(WC, Error_Unit, 'ldAtomType: ') STOP End If if (Atom_types >= Max_Atom_Types) then write(Error_Unit, *) 'ldatom: Error Loading atom type!' write(Error_Unit, *) 'ldatom: Not Enough space allocated!' write(Error_Unit, *) 'ldatom: Max_Atom_Types = ', Max_Atom_Types Call Word_GetAndPrint(WC, Error_Unit, 'ldatomtype: ') STOP End If AllocatedBigArrays = .FALSE. Atom_types = Atom_Types + 1 A => AtomType_Info(Atom_types) Write(Log_Unit,*) 'LdAtomType: TypeIndex = ', Atom_Types !***** Initialize Constants to -1 or 0 for error checking ***** A%Mesh_Size = -1; A%Basis_Size = -1 A%CoreTail_Points = -1 A%Overlap_Size = -1; A%Mass = 1 A%Hartree_Size = -1; A%Atomic_Charge = 0 A%Core_Charge = 0; A%Orbitals_Size = 0 A%Mesh_Step = -1; A%Rc_RS_Scale = 1.5 A%Atom_Energy = 0; A%DenVhat_Size = -1 A%Rc = -1; A%Rbox = 1 !** Rbox Not used anymore A%LCAO_Step = -1; A%LCAO_Size = -1 A%Gcut_Proj = 0 A%CoreTail_SelfEnergy = 0;A%CoreTail_HatEnergy = 0 !A%V_local = 0; A%Gcut_Proj = 0 V_local=1.e20 Nullify(A%Density); Nullify(A%LUT_DenVhat) Nullify(A%V_Hartree); Nullify(A%LUT_V_Hartree) Nullify(A%Valence_Orbitals); Nullify(A%Init_Occ) Nullify(A%Init_Occspinup); Nullify(A%Init_Occspindn) Nullify(A%L_Value); Nullify(A%V_ion); Nullify(A%V_hat); Call GetNextWord(WC, A%Atom_Name, Tlen) If (Print_Level <= PRINT_COMMANDS) then Write(Log_Unit, *) ">AtomType ", Trim(A%Atom_Name) End IF i = SearchAddList(A%Atom_Name, AtomType_LUT, NewToken) if (.NOT. NewToken) then !** Name previously used Write(Error_Unit, *) "LdAtomType: Name previously used! Name =", & Trim(A%Atom_Name), " * Index =", i Call Word_GetAndPrint(WC, Error_Unit, 'LdAtomType:') STOP End If Call GetNextWord(WC, token, Tlen) Call UpperCase(Token) !*** write(*,*) 'ldatomtype: Start loop tlen=',tlen, ' * Token=',Trim(Token) Do While (Trim(token) /= "END") NewToken = .TRUE. if (Trim(token) == "BASIS_SIZE") then Call GetNumbers(WC, A%Basis_Size) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Basis_Size = ", A%Basis_Size End IF else if (Trim(token) == "MESH_SIZE") then Call GetNumbers(WC, A%Mesh_Size) if(A%CoreTail_Points<1) A%CoreTail_Points=A%Mesh_Size if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Mesh_Size = ", A%Mesh_Size End IF else if (Trim(token) == "CORETAIL_POINTS") then Call GetNumbers(WC, A%CoreTail_Points) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: CoreTail_Points = ", A%CoreTail_Points End IF else if (Trim(token) == "DENVHAT_SIZE") then Call GetNumbers(WC, A%DenVHat_Size) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: DenVHat_Size = ", A%DenVHat_Size End IF else if (Trim(token) == "OVERLAP_SIZE") then Call GetNumbers(WC, A%Overlap_Size) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Overlap_Size = ", A%Overlap_Size End IF else if (Trim(token) == "LCAO_SIZE") then Call GetNumbers(WC, A%LCAO_Size) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: LCAO_Size = ", A%LCAO_Size End IF else if (Trim(token) == "LCAO_STEP") then NewToken = .NOT. GetRealsWithUnit(WC, A%LCAO_Step, Length_Unit, Token) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: LCAO_Step = ", A%LCAO_Step End IF else if (Trim(token) == "HARTREE_SIZE") then Call GetNumbers(WC, A%HARTREE_Size) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Hartree_Size = ", A%Hartree_Size End IF else if (Trim(token) == "ATOMIC_CHARGE") then Call GetNumbers(WC, A%Atomic_Charge) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Atomic_Charge = ", A%Atomic_Charge End IF else if (Trim(token) == "ATOMXCTYPE") then Call GetNextWord(WC, token2, Tlen) Call UpperCase(Token2) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: XC_TYPE = ", Token2 End IF i=0 If (TRIM(Token2) == 'LDA-PW') i=XC_LDA_PW If (TRIM(Token2) == 'GGA-PBE') i=XC_GGA_PBE If (XC_TYPE_SET) then ! Check that this atomdata file is compatible ! with previously set XC type If (i /= XC_TYPE) then Write(Error_Unit,*) 'Error in XC_Type --', Token2,& 'Is not compatible with previously set XC_Type ',XC_TYPE Write(Log_Unit,*) 'Error in XC_Type --', Token2,& 'Is not compatible with previously set XC_Type ',XC_TYPE Stop EndIf Else XC_TYPE_SET=.true. XC_TYPE=i EndIf else if (Trim(token) == "VLOC") then Call GetNumbers(WC, V_Local) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: V_Local = ", V_Local End IF Else if (Trim(token) == "CORE_CHARGE") then CAll GetNumbers(WC, A%Core_Charge) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Core_Charge = ", A%Core_Charge End IF else if (Trim(token) == "SHAPE_TYPE") then Call GetNextWord(WC, A%Shape_type, Tlen) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Shape_type = ", A%Shape_type End IF else if (Trim(token) == "RC") then NewToken = .NOT. GetRealsWithUnit(WC, A%Rc, Length_Unit, Token) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Rc = ", A%Rc End IF else if (Trim(token) == "ENHANCE_RC") then NewToken = .NOT. GetRealsWithUnit(WC, A%Rbox, Length_Unit, Token) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Rbox = ", A%Rbox End IF else if (Trim(token) == "MESH_STEP") then NewToken = .NOT. GetRealsWithUnit(WC, A%Mesh_Step, Length_Unit, Token) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Mesh_Step = ", A%Mesh_Step End IF else if (Trim(token) == "ENERGY") then NewToken = .NOT. GetRealsWithUnit(WC,A%Atom_Energy,Energy_Unit, Token) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Energy = ", A%Atom_energy End IF else if (Trim(token) == "ORBITALS") then Allocate(A%L_Value(A%Basis_Size), STAT=j) Call Check_Error(j, 'ldatom(orbitals data) Error during allocation!', & Error_Unit, .TRUE., WC, "ldatom(orbitals data): "); Call LoadArray(WC, RTmp, A%Basis_Size, "orbitals") if (W_ERROR /= W_OK) Call EOF_Error(WC, "ldatom(orbitals data): "); A%L_Value = RTmp DeAllocate(Rtmp) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Orbitals = ", A%L_Value End IF else if (Trim(token) == "INITOCC") then ! not currently used Call LoadArray(WC, RTmp, A%Basis_Size, "initocc") if (W_ERROR /= W_OK) Call EOF_Error(WC, "ldatom(initocc data): "); if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Init occ = ", Rtmp(1:A%Basis_Size) End IF DeAllocate(Rtmp) else if (Trim(token) == "PHI") then Call GetNumbers(WC, j) if (W_ERROR /= W_OK) Call EOF_Error(WC, "ldatom(phi index): "); if (.NOT. AllocatedBigArrays) Call AtomAlloc(WC, A) AllocatedBigArrays = .TRUE. if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Loading Phi = ", j End IF Call FillArray(WC, A%Phi(:,j), A%Mesh_Size, "phi") else if (Trim(token) == "TPHI") then Call GetNumbers(WC, j) if (W_ERROR /= W_OK) Call EOF_Error(WC, "ldatom(tphi index): "); if (.NOT. AllocatedBigArrays) Call AtomAlloc(WC, A) AllocatedBigArrays = .TRUE. if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Loading TPhi = ", j End IF Call FillArray(WC, A%TPhi(:,j), A%Mesh_Size, "tphi") else if (Trim(token) == "TPHI_LCAO") then Call GetNumbers(WC, j) if (W_ERROR /= W_OK) Call EOF_Error(WC, "ldatom(tphi_LCAO index): ") if (.NOT. AllocatedBigArrays) Call AtomAlloc(WC, A) AllocatedBigArrays = .TRUE. if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Loading TPhi_LCAO = ", j End IF Call FillArray(WC, A%TPhi_LCAO(:,j), A%LCAO_Size, "tphi_LCAO") else if (Trim(token) == "TPROJECTOR") then Call GetNumbers(WC, j) if (W_ERROR /= W_OK) Call EOF_Error(WC, "ldatom(tproj index): "); if (.NOT. AllocatedBigArrays) Call AtomAlloc(WC, A) AllocatedBigArrays = .TRUE. if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Loading TP = ", j End IF Call FillArray(WC, A%TP(:,j), A%Mesh_Size, "tproj") ! TP_Deriv no longer used !else if (Trim(token) == "DERIVTPROJECTOR") then ! Call GetNumbers(WC, j) ! if (W_ERROR /= W_OK) Call EOF_Error(WC, "ldatom(tproj_deriv index): "); ! if (.NOT. AllocatedBigArrays) Call AtomAlloc(WC, A) ! AllocatedBigArrays = .TRUE. ! if (Print_Level == PRINT_VERBOSE) then ! Write(Log_Unit, *) "ldatomtype: Loading TP_Deriv = ", j ! End IF ! Call FillArray(WC, A%TP_Deriv(:,j), A%Mesh_Size, "tproj_deriv") else if (Trim(token) == "SHAPE_FUNC") then Call LoadArray(WC, A%Shape_Func, A%Mesh_Size, "shape_func") else if (Trim(token) == "VLOCFUN") then Call LoadArray(WC, A%RadR_Vlocal, A%Mesh_Size, "vloc_fun") else if (Trim(token) == "VLOCION") then Call GetNumber(WC, j) Call LoadArray(WC, Rtmp, j, "vloc_for_abinit") deallocate(Rtmp) else if (Trim(token) == "CORE_DENSITY") then Call LoadArray(WC, A%Core_Density, A%Mesh_Size, "core_density") else if (Trim(token) == "CORETAIL_DENSITY") then Call LoadArray(WC, A%CoreTail_Density, A%CoreTail_Points, "coretail_density") else if (Trim(token) == "OVERLAP_MATRIX") then Call LoadArray(WC, A%List_Oij, A%overlap_size, "overlap") else if (Trim(token) == "KINETIC_ENERGY_MATRIX") then Call LoadArray(WC, A%Kinetic, A%overlap_size, "kinetic_energy") else if (Trim(token) == "V_ION_MATRIX") then Call LoadArray(WC, A%V_ion, A%overlap_size, "v_ion") else if (Trim(token) == "DENSITY") then if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Loading Density" End IF Call LoadDenVhat(WC,A%Density, A%LUT_DenVhat, A%DenVhat_Size, "Density") else if (Trim(token) == "V_HAT") then if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Loading V_Hat" End IF Call LoadDenVhat(WC, A%V_hat, A%LUT_DenVhat, A%DenVhat_Size, "V_Hat") else if (Trim(token) == "V_HARTREE") then Call LoadVHartree(WC, A%V_Hartree, A%LUT_V_Hartree, A%Hartree_Size) else if (Trim(token) == "CORETAILSELFENERGY") then Call GetNumber(WC, A%CoreTail_Selfenergy) Write(Log_Unit,*) 'ldatomtype: CoreTail Self-Energy:',A%CoreTail_Selfenergy Call GetNextWord(WC, token, Tlen) else if (Trim(token) == "CORETAILHATENERGY") then Call GetNumber(WC, A%CoreTail_Hatenergy) Write(Log_Unit,*) 'ldatomtype: CoreTail Hat-Energy:',A%CoreTail_Hatenergy Call GetNextWord(WC, token, Tlen) else if (Trim(token) == "HAT_SELF-ENERGY") then Call GetNumber(WC, i) Allocate(A%Hat_SelfEnergy(0:i)) Do j=0, i Call GetNumber(WC, L) Call GetNumber(WC, A%Hat_SelfEnergy(L)) End Do Call GetNextWord(WC, token, Tlen) Write(Log_Unit,*) 'ldatomtype: Hat Self-Energy:',A%Hat_SelfEnergy else if (Trim(Token) == "MASS") then Call GetNumber(WC, A%Mass) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldatomtype: Mass = ", A%Mass End IF else Write(Error_Unit, *) "ldAtomType: Unknown Option: ", Trim(Token) End If If (NewToken) then Call GetNextWord(WC, token, tlen) Call UpperCase(Token) !*** write(*,*) 'ldatomtype: tlen=',tlen, ' * Token=',Trim(Token) if (W_ERROR /= W_OK) Call EOF_Error(WC, "ldatom(next word): ") End If End Do If (ABS(V_local)<1.e10) then If (.not.Associated(A%RadR_Vlocal)) then Allocate(A%RadR_Vlocal(A%Mesh_Size), stat=i) if (i/=0) then Call Check_Error(i, 'ldatomtype: Error Allocating A%RadR_Vlocal', & Error_Unit, .TRUE., WC, 'LdAtomType: ') stop endif Endif A%RadR_Vlocal=V_local*A%Shape_Func Endif Call Check_Atom(WC, A) !** Do a cursory check of the atom ** !**** Create nlm LUT and nl base arrays if needed **** IF (Atomic_Mode == SIM_PAW) then k = 0 Do i=1, A%Basis_Size k = k + 2*A%L_Value(i) + 1 End Do A%nlm_Size = K Allocate(A%nl_Base(A%Basis_Size), A%nlm_LUT(3,A%nlm_Size), & A%Oij(k, k), A%Core_Xchange(A%MEsh_Size), STAT=i) Call Check_Error(i, 'ldatomtype: Error Allocating nlm_base and nlm_LUT!',& Error_Unit, .TRUE., WC, 'LdAtomType: ') k = 0 Do i=1, A%Basis_Size L = A%L_Value(i) A%nl_base(i) = k + 1 Do M = -L, L k = k + 1 A%nlm_LUT(:,k) = (/i,L,M/) End Do End Do A%Oij = 0 k = 0 Do i=1, A%Basis_Size Do j=1, i If (A%L_Value(i) == A%L_Value(j)) then k = k + 1 L = A%L_Value(i) base_i = A%nl_base(i)+L base_j = A%nl_base(j)+L Do M=-L, L A%Oij(base_i+M, Base_j+M) = A%List_Oij(k) A%Oij(base_j+M, Base_i+M) = A%List_Oij(k) End Do End If End Do End Do !*** Make the Coulomb Matrix aQlm, and aVlm **** !*** First sort the V_hartree LUT in ascending order *** Allocate(LUT(A%Hartree_Size),RTmp(A%Hartree_Size), & IntTEmp(A%Hartree_Size), STAT=i) Call Check_Error(i, 'ldatomtype: Error Allocating Temp LUT!',& Error_Unit, .TRUE., WC, 'LdAtomType: ') CAll Insertion_Sort(A%LUT_V_Hartree, LUT, .TRUE.) IntTemp = A%LUT_V_Hartree(LUT) RTmp = A%V_Hartree(LUT) A%LUT_V_Hartree = IntTemp A%V_Hartree = RTmp A%Cijkl_Size = -1; A%QVlm_Size = -1 Call Coulomb_Matrix(A, A%Cijkl_Size) !** First determine the size Call Orbital_Matrix(A, A%QVlm_Size) Allocate(A%LUT_Cijkl(A%Cijkl_Size), A%Cijkl(A%Cijkl_Size), & A%aQlm(A%QVlm_Size), A%aVlm(A%QVlm_Size), A%LUT_Orb(A%QVlm_Size), & STAT=i) Call Check_Error(i, 'ldatomtype: Error Allocating Coulomb and orbital matrices',& Error_Unit, .TRUE., WC, 'LdAtomType: ') !Write(LOG_Unit,*) 'ldatomtype: Cijkl_Size=',A%Cijkl_Size !Write(LOG_Unit,*) 'ldatomtype: QVLM_Size=',A%QVLM_Size Call Coulomb_Matrix(A, A%Cijkl_Size) !** Actually Store the matrices Call Orbital_Matrix(A, A%QVlm_Size) !write(Log_Unit,*) 'LdAtomType: aQlm=',A%aQlm !OPEN(29,FILE="proj.out", RECL=10000) !Do i=1, A%Mesh_Size ! Write(29,*) i, (i-1)*A%Mesh_Step, A%TP(i,:) !End DO !CLOSE(29) !****** Scale the Core Density to that in the paper ****** Do i=2, A%Mesh_Size A%Core_Density(i) = A%Core_Density(i)/(Four_PI*(A%Mesh_Step*(i-1))**2) End Do !A%Core_Density(1)= 2*A%Core_Density(2)-A%Core_Density(3) A%Core_Density(1)= 3*(A%Core_Density(2)-A%Core_Density(3)) & +A%Core_Density(4) if (.NOT.Associated(A%CoreTail_Density)) then Allocate(A%CoreTail_Density(A%CoreTail_Points),stat=i) if (i /= 0) then write(Error_unit,*) 'ldatomtype: Error in Coretail', A%CoreTail_Points,i stop endif A%CoreTail_Density=0 A%Qeffion=-A%Atomic_Charge+A%Core_charge else Do i=2, A%CoreTail_Points A%CoreTail_Density(i) = A%CoreTail_Density(i)/(Four_PI*(A%Mesh_Step*(i-1))**2) End Do A%CoreTail_Density(1)= 3*(A%CoreTail_Density(2)-A%CoreTail_Density(3)) & +A%CoreTail_Density(4) Allocate(Rtmp(A%Mesh_Size),stat=i) if (i /= 0) then write(Error_unit,*) 'ldatomtype: Error in Rtmp', A%Mesh_Size,i stop endif Do i=1,A%Mesh_Size Rtmp(i)=(A%Core_Density(i)- & A%CoreTail_Density(i))*(Four_PI*(A%Mesh_Step*(i-1))**2) enddo A%Qeffion=-A%Atomic_Charge+IntSimpson(A%Mesh_Size,A%Mesh_Step,Rtmp) Deallocate(Rtmp) Endif write(Log_Unit,*) 'ldatomtype: Qeffion = ', A%Qeffion ! This part has been changed -- all functions f(r) are assumed to be used ! as f(r)/r*Ylm !! !******Input projectors are divided by r**L -- multiply by r**l !! (note -- this will give A%TP=p(r)/r, where p(r) is function defined in PRB) !! Need to check this for TP_Deriv ! write(6,*) 'Abasis',A%Basis_Size,A%L_value ! do j=1,A%Basis_Size ! If (A%L_value(j)>0) then ! Do i=2, A%Mesh_Size ! A%TP(i,j) = A%TP(i,j)*(A%Mesh_Step*(i-1))**(A%L_Value(j) ) ! A%TP_Deriv(i,j)=A%TP_Deriv(i,j)*(A%Mesh_Step*(i-1))**(A%L_Value(j)) ! End Do ! A%TP(1,j) = 0 ! A%TP_Deriv(1,j) = 0 ! Endif ! End Do ! !*** Remove the r factor from TPhi_LCAO *** ! A%TPhi_LCAO(1,:) = 0 ! A%TP_Deriv(1,:) = 0 ! Do i=2, A%LCAO_Size ! A%TPhi_LCAO(i,:) = A%TPhi_LCAO(i,:)/(A%Mesh_Step*(i-1)) ! End Do !! !***** print the Projectors out to a file ******** !! Do i=1, A%Basis_Size !! Write(token, *) i !! token = TRIM(A%Atom_Name) // trim(ADJUSTL(token)) // '.txt' !! Open(SCRATCH_UNIT, FILE=token, RECL=10000) !! !! Write(SCRATCH_UNIT, *) '1.Index 2.R 3.Phi 4.Phi~ 5.P~', & !!' 6.CoreDen/r^2 7.P~/r 8.Phi/r 9.Phi~/r ' !!!! ! Write(SCRATCH_UNIT, *) ' 0 0 0 0 0' !! Do j=2, A%Mesh_Size-1 !! den = (j-1)*A%Mesh_Step !! Write(SCRATCH_UNIT, *) j, den, A%Phi(j,i), A%TPhi(j,i), A%TP(j,i), & !! A%Core_Density(j), A%TP(j,i)/den, A%Phi(j,i)/den, & !! A%TPhi(j,i)/den !! End Do !! den = den + A%Mesh_Step ! Write(SCRATCH_UNIT, *) A%Mesh_Size+1, den, ' 0 0 0' !! CLose(SCRATCH_UNIT) !! Write(token, *) i !! token = TRIM(A%Atom_Name) // trim(ADJUSTL(token)) // '.radg' !! Open(SCRATCH_UNIT, FILE=token, RECL=10000) !! !! Write(SCRATCH_UNIT, *) '1.Index 2.|G| 3.P(|G|)' !! L = A%L_Value(i) !! Do j=1, 40 !! gmag = 0.25*(j-1) !! den = RadialFourier(L, Gmag, A%Mesh_Step, A%Mesh_Size, A%TP(:,i)) !! !! Write(SCRATCH_UNIT, *) j, gmag, den !! End Do !! Close(SCRATCH_UNIT) !! End Do End If !**NOPROJ** !*A%Basis_Size = 0 Return End Subroutine !********************************************************************** ! ! LdAtomtype_NORM - Loads an species definition for a norm conserving ! pseuodpotential definition. ! ! NOTE : The program must be in SIM_NORM mode! ! !********************************************************************** Subroutine LdAtomType_NORM(WC) Type (Word_Context), Intent(INOUT) :: WC Character*100 :: Token Integer :: tlen, i, j Logical :: NewToken Real, pointer :: rtmp(:) Type(Atom_Info_Fixed), Pointer :: A !** Make sure we are in the correct mode *** If (Atomic_Mode == SIM_PAW) then Write(Log_Unit,*) 'LdAtomtype_NORM: Attempting to load a norm', & ' conserving pseudopotential when in PAW mode!!!!!' Call Word_GetAndPrint(WC, Error_Unit, 'ldAtomType_NORM: ') STOP End If if (Atom_types >= Max_Atom_Types) then write(Error_Unit, *) 'ldatomtype_norm: Error Loading atom type!' write(Error_Unit, *) 'ldatomtype_norm: Not Enough space allocated!' write(Error_Unit, *) 'ldatomtype_norm: Max_Atom_Types = ', Max_Atom_Types Call Word_GetAndPrint(WC, Error_Unit, 'ldatomtype: ') STOP End If !** Find position to store the PP ** Atom_types = Atom_Types + 1 A => AtomType_Info(Atom_types) Write(Log_Unit,*) 'LdAtomType_NORM: TypeIndex = ', Atom_Types !*** Now load the data ** Call GetNextWord(WC, A%Atom_Name, Tlen) If (Print_Level <= PRINT_COMMANDS) then Write(Log_Unit, *) ">AtomType ", Trim(A%Atom_Name) End IF i = SearchAddList(A%Atom_Name, AtomType_LUT, NewToken) if (.NOT. NewToken) then !** Name previously used Write(Error_Unit, *) "LdAtomType: Name previously used! Name =", & Trim(A%Atom_Name), " * Index =", i Call Word_GetAndPrint(WC, Error_Unit, 'LdAtomType:') STOP End If Call GetNextWord(WC, token, Tlen) Call UpperCase(Token) Do While (Trim(token) /= "END") NewToken = .TRUE. if (Trim(token) == "BASIS_SIZE") then Call GetNumbers(WC, A%Basis_Size) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype_norm: Basis_Size = ", A%Basis_Size End IF else if (Trim(token) == "MESH_SIZE") then Call GetNumbers(WC, A%Mesh_Size) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype_norm: Mesh_Size = ", A%Mesh_Size End IF else if (Trim(token) == "MESH_STEP") then Call GetNumbers(WC, A%Mesh_Step) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype_norm: Mesh_Step = ", A%Mesh_Step End IF else if (Trim(token) == "ICORR") then Call GetNextWord(WC, A%icorr, tlen) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype_norm: ICORR = ", TRIM(A%ICORR) End IF else if (Trim(token) == "IREL") then Call GetNextWord(WC, A%irel, tlen) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype_norm: IREL = ", TRIM(A%IREL) End IF else if (Trim(token) == "NICORE") then Call GetNextWord(WC, A%nicore, tlen) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype_norm: NICORR = ", TRIM(A%NICORE) End IF else if (Trim(token) == "ATOMIC_CHARGE") then Call GetNumbers(WC, A%Atomic_Charge) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype_norm: Atomic_Charge = ", & A%Atomic_Charge End IF else if (Trim(token) == "ALPHA") then Call GetNumbers(WC, A%Alpha) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype_norm: Alpha = ", A%Alpha End IF else if (Trim(token) == "BASIS_SIZE") then Call GetNumbers(WC, A%Basis_Size) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype_norm: Basis_Size = ", A%Basis_Size End IF !** Allocate arrays also. Assumes A%Mesh_Size has been declared! ** i = A%Basis_Size; j = A%Mesh_Size Allocate(A%TP(j+1,i), A%pot_local(j), A%Core_Density(j), & A%Density(j)) else if (Trim(token) == "VALENCE_DENSITY") then if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype_norm: Loading Density" End IF Call LoadArray(WC, A%Density, A%Mesh_Size, 'ldatomtype_norm: (Valence)') else if (Trim(token) == "VALENCE_DENSITY") then if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype_norm: Loading Density" End IF Call FillArray(WC, A%Density, A%Mesh_Size, 'ldatomtype_norm: (Valence)') else if (Trim(token) == "CORE_DENSITY") then if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype_norm: Loading Core Density" End IF Call FillArray(WC, A%Core_Density, A%Mesh_Size, & 'ldatomtype_norm: (core)') else if (Trim(token) == "V_LOCAL") then if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype_norm: Loading V_Local" End IF Call FillArray(WC, A%Pot_local, A%Mesh_Size, & 'ldatomtype_norm: (core)') else if (Trim(token) == "PROJECTOR") then Call GetNumber(WC, i) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype_norm: Loading Projector", i End IF Call FillArray(WC, A%TP(:,i), A%Mesh_Size+1, 'ldatomtype_norm: (proj)') else if (Trim(token) == "ORBITALS") then Allocate(A%L_Value(A%Basis_Size), STAT=j) Call Check_Error(j, 'ldatomtype_norm(orbitals data) Error during allocation!', & Error_Unit, .TRUE., WC, "ldatomtype_norm(orbitals data): ") Call LoadArray(WC, RTmp, A%Basis_Size, "orbitals") if (W_ERROR /= W_OK) Call EOF_Error(WC, "ldatomtyep_norm(orbitals data): "); A%L_Value = RTmp DeAllocate(Rtmp) if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldatomtype: Orbitals = ", A%L_Value End IF else Write(Error_Unit, *) "ldAtomType_NORM: Unknown Option: ", Trim(Token) End If If (NewToken) then Call GetNextWord(WC, token, tlen) Call UpperCase(Token) if (W_ERROR /= W_OK) Call EOF_Error(WC, "ldatomtype_norm(next word): ") End If End Do Return End Subroutine !********************************************************************** ! ! LdAtomtype_SEPM - Loads a species definition for a semi-empirical ! pseuodpotential definition. ! ! NOTE : The program must be in SIM_SEPM mode! ! !********************************************************************** Subroutine LdAtomType_SEPM(WC) Type (Word_Context), Intent(INOUT) :: WC Character*100 :: token, token2 Character*100 :: atomname(2) Real :: Gaussian(2,2), Poly_Gcut, alpha, beta, x, dx, fn, tmp Type (GaussFunc) :: VIn(2), VOut(2) !* Real :: PolyIn(5,2), PolyOut(5,2) Integer :: i, tlen, Poly_Size(2), index, sign, n, fd Logical :: Newtoken Type(Atom_Info_Fixed), Pointer :: A !** Make sure we are in the correct mode *** If (Atomic_Mode /= SIM_SEPM) then Write(Log_Unit,*) 'LdAtomtype_SEPM: Attempting to load a semi', & '-empirical pseudopotential when not in SEPM mode!!!!!' Call Word_GetAndPrint(WC, Error_Unit, 'ldAtomType_SEPM: ') STOP End If if (Atom_types >= Max_Atom_Types) then write(Error_Unit, *) 'ldatomtype_SEPM: Error Loading atom type!' write(Error_Unit, *) 'ldatomtype_SEPM: Not Enough space allocated!' write(Error_Unit, *) 'ldatomtype_SEPM: Max_Atom_Types = ', Max_Atom_Types Call Word_GetAndPrint(WC, Error_Unit, 'ldatomtype_SEPM: ') STOP End If !** Find position to store the PP ** Atom_types = Atom_Types + 1 A => AtomType_Info(Atom_types) Write(Log_Unit,*) 'LdAtomType_NORM: TypeIndex = ', Atom_Types !*** Now load the data ** Call GetNextWord(WC, A%Atom_Name, Tlen) If (Print_Level <= PRINT_COMMANDS) then Write(Log_Unit, *) ">AtomType ", Trim(A%Atom_Name) End IF i = SearchAddList(A%Atom_Name, AtomType_LUT, NewToken) if (.NOT. NewToken) then !** Name previously used Write(Error_Unit, *) "LdAtomType_SEPM: Name previously used! Name =", & Trim(A%Atom_Name), " * Index =", i Call Word_GetAndPrint(WC, Error_Unit, 'LdAtomType_SEPM:') STOP End If Call GetNextWord(WC, token, tlen) Call UpperCase(token) Do While ((W_Error /= W_EOF) .AND. (Trim(Token) /= 'END')) Write(*,*) 'Read_Input : Token: !',trim(token),'!' If (Trim(Token) == "GAUSSIAN") then Call GetNumbers(WC, A%Gaussian) else if (Trim(Token) == "POTENTIAL") then Call GetNumbers(WC, i) A%V_sepm%N = i Allocate(A%V_sepm%Coeff(3,i)) Do i=1, A%V_sepm%N Call GetNumbers(WC, A%V_sepm%Coeff(:,i)) End do Call GetNExtword(WC, token, tlen) else if (Trim(Token) == "POLY_GCUT") then Call GetNumbers(WC, Poly_Gcut) else if (Trim(Token) == "POLY") then Call GetNumbers(WC, i) A%Poly_Degree = i Allocate(A%Poly(i+1)) Call GetNumbers(WC, A%Poly) Call GetNExtword(WC, token, tlen) else Write(*, *) "ldatomtype_SEPM: Unknown Command : ", Trim(Token) Call Word_GetAndPrint(WC, Error_Unit, 'ldatomtype_SEPM:') End If Call GetNextWord(WC, Token, tlen) Call UpperCase(token) end do fd = SCRATCH_UNIT token = trim(A%Atom_Name) // '.txt' Open(fd, FILE=trim(token), RECL=10024) Write(fd,*) '1.x 2.V_sepm' n = 200 dx = 10.0/n Poly_Gcut = A%Poly_Gcut Poly_Gcut = -1 do i=0, n x = i*dx If (x >= Poly_Gcut) then fn = EvalGauss(A%V_sepm, x) else fn = EvalPoly(A%Poly_Degree, A%Poly, x) End If Write(fd,*) x, fn End Do Close(fd) Return End Subroutine !****************************************************************************** ! ! Clone_Cell - Clones the current supercell definition and modifies the ! lattice to reflect the larger cell. ! ! Cell - Clone size for each principal axis = 0 0 0 if no cloning ! !****************************************************************************** Subroutine Clone_Cell(Cell) Integer, Intent(IN) :: Cell(:) Type (Specific_Atom), Pointer :: A, BA Integer :: i,j,k, Base_Atoms, index, ctmp(3),s,t,MaxL,err Real :: Offset(3), OldBasis(3,3), OldInversebasis(3,3),tol,rs,rt character*20 :: Name_Ext, strtmp logical :: IsNew tol = 1E-8 OldBasis=Xtal%Basis OldInversebasis=Xtal%Inversebasis !** First Adjust the lattice ** Do i=1, 3 xtal%Basis(:,i) = OldBasis(:,i)*(Cell(i)+1) End do xtal%Volume = ABS(DOT_PRODUCT(xtal%Basis(:,1), & CrossProduct(xtal%Basis(:,2), xtal%Basis(:,3)))) xtal%Recip = RecipBasis(xtal%Basis) xtal%InverseBasis = TRANSPOSE(Xtal%Recip) / (2*Pi) xtal%RecipVol = ABS(DOT_PRODUCT(xtal%Recip(:,1), & CrossProduct(xtal%Recip(:,2), xtal%Recip(:,3)))) If (Print_Level <= PRINT_NORMAL) then Write(Log_Unit,*) 'Clone_Cell: New Xtal information. Cell=',Cell Write(Log_Unit, *) 'Clone_Cell: Xtal Volume : ', Xtal%Volume, & ' * Recip Volume :',Xtal%RecipVol Write(Log_Unit, *) 'Clone_Cell: Scaled Lattice Vectors:' Write(Log_Unit, *) 'Clone_Cell: A :',Xtal%Basis(:,1) Write(Log_Unit, *) 'Clone_Cell: B :',Xtal%Basis(:,2) Write(Log_Unit, *) 'Clone_Cell: C :',Xtal%basis(:,3) Write(Log_Unit,*) ' ' Write(OutPut_Unit, *) ' Xtal Volume : ', Xtal%Volume Write(OutPut_Unit, *) 'Lattice Vectors:' Write(OutPut_Unit, *) ' A :',Xtal%Basis(:,1) Write(OutPut_Unit, *) ' B :',Xtal%Basis(:,2) Write(OutPut_Unit, *) ' C :',Xtal%basis(:,3) Write(OutPut_Unit,*) ' ' Write(Log_Unit, *) 'Clone_Cell: Recip(:,1) :',Xtal%Recip(:,1) Write(Log_Unit, *) 'Clone_Cell: Recip(:,2) :',Xtal%Recip(:,2) Write(Log_Unit, *) 'Clone_Cell: Recip(:,3) :',Xtal%Recip(:,3) end If !********* Scale the BASE atom positions and init them *************** Do i=1, Specific_Atoms rt = sum(abs(Atom_List(i)%Frac_Pos)) rs = sum(abs(Atom_List(i)%Pos)) !Write(Log_Unit,*) 'Clone_Cell: i=',i, ' * t,s=',rt,rs !Write(Log_Unit,*) 'Clone_Cell: Frac=',Atom_List(i)%Frac_Pos !Write(Log_Unit,*) 'Clone_Cell: Pos=',Atom_List(i)%Pos if ((rs<=tol).and.(rt>tol)) then Atom_List(i)%Pos = MATMUL(OldBasis, Atom_List(i)%Frac_Pos) else if ((rt<=tol).and.(rs>tol)) then Atom_List(i)%Frac_Pos = & MATMUL(OldInversebasis, Atom_List(i)%Pos) else if ((rt>tol).and.(rs>tol)) then write(Log_Unit,*)'Warning -- both fractional and Cartesian ', & 'positions specified in atom file' Atom_List(i)%Pos = MATMUL(OldBasis, Atom_List(i)%Frac_Pos) else Atom_List(i)%Pos = 0 ; Atom_List(i)%Frac_Pos = 0 endif Write(Log_Unit,*) 'Clone_Cell: atom=',i, ' * ',& Trim(Atom_List(i)%Name) Write(Log_Unit,*) 'Clone_Cell: Pos=',Atom_List(i)%Pos Write(Log_Unit,*) 'Clone_Cell: Frac_Pos=',Atom_List(i)%Frac_Pos End Do Base_Atoms = Specific_Atoms Specific_Atoms=0 Do i=0, Cell(1) Do j=0, Cell(2) Do k=0, Cell(3) ctmp = (/i,j,k/) Offset = MATMUL(OldBasis, (/i,j,k/)) !** Now loop over all the base atoms ** Do index=1, Base_Atoms Specific_Atoms = Specific_Atoms + 1 if (Specific_Atoms > Max_Specific_Atoms) then write(Error_Unit, *) & 'Clone_Cell: Error Loading a specific atom!' write(Error_Unit, *) & 'Clone_Cell: Not Enough space allocated!' write(Error_Unit, *) & 'Clone_Cell: Max_Specific_Atoms = ', Max_Specific_Atoms STOP End If A => Atom_list(Specific_Atoms) BA => Atom_List(Index) If (i+j+k > 0) then !** Construct the name and add it to the LUT ** Name_Ext = '_' Do t=1, 3 Write(strtmp, *) ctmp(t) Name_Ext = TRIM(Name_Ext) // TRIM(ADJUSTL(strtmp)) end Do A%Name = Trim(BA%Name) // TRIM(Name_Ext) s = SearchAddList(A%Name, Atom_LUT, IsNew) if (.NOT. IsNew) then !** Name previously used Write(Error_Unit, *) & "LdAtomList: Name previously used! Name =", & Trim(A%Name), " * Index =", i Call Word_GetAndPrint(paw_WC, Error_Unit,'Clone_Cell:') STOP End If !** Copy the Base data *** s = BA%Orbitals_Size A%Orbitals_Size = BA%Orbitals_Size Allocate(A%Valence_Orbitals(s), A%Init_Occ(s), A%Init_Occspinup(s), A%Init_Occspindn(s)) A%Valence_Orbitals = BA%Valence_Orbitals A%Init_Occ = BA%Init_Occ A%Init_Occspinup = BA%Init_Occspinup A%Init_Occspindn = BA%Init_Occspindn A%Freeze = BA%Freeze A%Friction = BA%Friction A%Enhance_Size = BA%Enhance_Size A%TypeIndex = BA%TypeIndex If (Atomic_Mode == SIM_PAW) then MaxL = MaxVal(AtomType_Info(A%TypeIndex)%L_Value) s = AtomType_Info(A%TypeIndex)%nlm_Size t = s*(s+1)/2 !** Determine unique Dij's Allocate(A%Qlm(2*MaxL+1, 2*(2*MaxL)+1), & A%dEdQlm(2*MaxL+1,2*(2*MaxL)+1), A%Dij(s,s), & A%Dij_old(t), A%Wij(s,s), A%Wij_old(s,s), & A%Fij(3,s,s), A%Feij(3,s,s), A%cDij(s,s), STAT=err) A%Qlm = 0; A%dEdQlm = 0; A%Dij = 0; A%cDij = 0; A%Wij = 0; A%Wij_old = 0; A%Dij_old = 0; A%Fij = 0; A%Feij = 0 if(spindependence) then Allocate(A%Dijspin(s,s),A%cDijspin(s,s),A%Dij_oldspin(t),A%Wijspin(s,s), & A%Wij_oldspin(s,s),A%Fijspin(3,s,s),A%Feijspin(3,s,s),STAT=err) A%Dijspin =0; A%cDijspin=0;A%Dij_oldspin =0 ; A%Wijspin=0 A%Wij_oldspin =0; A%Fijspin=0; A%Feijspin=0 write(log_unit,*) 'ldAtom: Wijspin allocated', s,t write(log_unit,*) 'ldAtom: Fijspin', size(A%Fijspin),size(A%Feijspin) call flush(log_unit) end if Call Check_Error(err, & "Clone_Cell: Error allocating Qlm, ... ", & Error_Unit, .TRUE., paw_wc, "ldatom:") EndIf EndIf A%Pos = BA%Pos + Offset !** Update the position A%Frac_Pos = MATMUL(Xtal%Inversebasis, A%Pos) !** Init the rest of the structure A%Force%Pos(:,1) = A%Pos A%Force%Velocity = 0 A%Force%Acceleration = 0 A%Force%NumMoves = 1 A%Force%Predictor_Phase = .TRUE. Write(Log_Unit,*) 'Clone_Cell: atom=',Specific_Atoms, ' * ',& Trim(A%Name) Write(Log_Unit,*) 'Clone_Cell: Pos=',A%Pos Write(Log_Unit,*) 'Clone_Cell: Frac_Pos=', & A%Frac_Pos end do End Do End Do End do return end subroutine !****************************************************************************** ! ! ldAtom - Loads a single atom from the input file. ! The input format is specified below: ! ! MAXATOM Max_Specific_Atom # Previously defined ! ! ATOM AtomName ! TYPE AtomType # Type of atom corresponds to an ATOMTYPE ! FRAC_POSITION (fa,fb,fc) # Initial Position of atom ! / (in fractions of A, B, and C) ! or ! \ ! CART_POSITION (fa,fb,fc) # Initial Position of atom ! (in Cartesian coordinates -- bohr units) ! ORBITALS_SIZE n # Number of valence orbitals for LCAO ! VALENCE_ORBITALS i1 i2 .. in # List of (nl)'s for use as valence fn's ! VALENCE_OCCUPANCY q1 q2 .. qn # Initial charge distribution in electrons. ! FRICTION fc # Friction coeff (OPTIONAL) ! ! Enhance N # Number of enhance definitions ! Level_1 Radius_1 # Radius is in Bohr ! Level_2 Radius_2 ! ... ... ! Level_N Radius_N ! End ! END ! !****************************************************************************** Subroutine ldAtom(WC) Type (Word_Context), Intent(INOUT) :: WC Type (Specific_Atom), Pointer :: A Integer :: tlen, i, j, k, n, err, MaxL character*100 :: token Logical :: IsNew if (Specific_Atoms >= Max_Specific_Atoms) then write(Error_Unit, *) 'ldatom: Error Loading a specific atom!' write(Error_Unit, *) 'ldatom: Not Enough space allocated!' write(Error_Unit, *) 'ldatom: Max_Specific_Atoms = ', Max_Specific_Atoms Call Word_GetAndPrint(WC, Error_Unit, 'ldatom: ') STOP End If Specific_Atoms = Specific_Atoms + 1 A => Atom_list(Specific_Atoms) A%Frac_Pos = 0; A%Pos = 0; A%TypeIndex = -1; A%Orbitals_Size = -1; A%Freeze = .FALSE.; A%Friction = 0; A%Enhance_Size = -1 Call GetNextWord(WC, A%Name, tlen) If (Print_Level <= PRINT_COMMANDS) then Write(Log_Unit, *) ">Atom ", Trim(A%Name)," * Array index=",Specific_Atoms End IF i = SearchAddList(A%Name, Atom_LUT, IsNew) if (.NOT. IsNew) then !** Name previously used Write(Error_Unit, *) "LdAtom: Name previously used! Name =", & Trim(A%Name), " * Index =", i Call Word_GetAndPrint(WC, Error_Unit, 'LdAtom:') STOP End If Call GetNextWord(WC, token, Tlen) Call UpperCase(Token) Do While (Trim(token) /= "END") if (Trim(token) == "TYPE") then Call GetNextWord(WC, token, tlen) i = SearchList(token, AtomType_LUT) if (i <= 0) then !** No MAtch Found! Write(Error_Unit,*) 'LdAtom: Unknown Atom Type! Type = ', Trim(token) Write(Error_Unit,*) 'LdAtom: Current Atom Types defined: Used=', & AtomType_LUT%Used Write(Error_Unit, *) 'LdAtom: Names = ', & (Trim(AtomType_LUT%StrList(i)), ' * ', i=1, Atomtype_LUT%USed) Call Word_GetAndPRint(WC, Error_Unit, "LdAtom:") STOP else A%TypeIndex = i If (Print_Level <= PRINT_COMMANDS) then Write(Log_Unit, *) "ldatom: AtomType =", & TRim(AtomType_Info(i)%Atom_Name) End IF End IF else if (Trim(Token) == "FRAC_POSITION") then Call GetNumbers(WC, A%Frac_Pos, 3) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldatom: Fractional Position = ", A%Frac_Pos End IF else if (Trim(Token) == "CART_POSITION") then Call GetNumbers(WC, A%Pos, 3) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldatom: Cartesian Position = ", A%Pos End IF else if (Trim(token) == "ORBITALS_SIZE") then Call GetNumber(WC, i) A%Orbitals_Size = i Allocate(A%Valence_Orbitals(i), STAT=j) Write(token,*) "ldatom: Can't alloc space for Valence Orbitals! Size=",i Call Check_Error(j, token, Error_Unit, .TRUE., WC, "ldatom:") Allocate(A%Init_Occ(i), A%Init_Occspinup(i), & A%Init_Occspindn(i), STAT=j) Write(token,*)"ldatom: Can't alloc space for Valence Occupancy! Size=",i Call Check_Error(j, token, Error_Unit, .TRUE., WC, "ldatom:") else if (Trim(token) == "VALENCE_ORBITALS") then If (A%Orbitals_Size <= 0) then Write(Error_Unit, *) 'ldatom: Orbital_Size not defined!!' Call Word_GetAndPrint(WC, Error_Unit, "ldatom: ") STOP End If Call GetNumbers(WC, A%Valence_Orbitals) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldatom: Valence_Orbitals = ", A%Valence_Orbitals End IF else if (TRim(token) == "VALENCE_OCCUPANCY") then If (A%Orbitals_Size <= 0) then Write(Error_Unit, *) 'ldatom: Orbital_Size not defined!!' Call Word_GetAndPrint(WC, Error_Unit, "ldatom: ") STOP End If Call GetNumbers(WC, A%Init_Occ) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldatom: Valence_Occupancy = ", A%Init_Occ End IF else if (TRim(token) == "SPINUP_VALENCE_OCCUPANCY") then If (A%Orbitals_Size <= 0) then Write(Error_Unit, *) 'ldatom: Orbital_Size not defined!!' Call Word_GetAndPrint(WC, Error_Unit, "ldatom: ") STOP End If Call GetNumbers(WC, A%Init_Occspinup) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldatom: Valence_Occspinup = ", A%Init_Occspinup End IF else if (TRim(token) == "SPINDN_VALENCE_OCCUPANCY") then If (A%Orbitals_Size <= 0) then Write(Error_Unit, *) 'ldatom: Orbital_Size not defined!!' Call Word_GetAndPrint(WC, Error_Unit, "ldatom: ") STOP End If Call GetNumbers(WC, A%Init_Occspindn) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldatom: Valence_Occspindn = ", A%Init_Occspindn End IF else if (Trim(Token) == "FRICTION") then Call GetNumber(WC, A%Friction) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldatom: Friction = ", A%Friction End IF else if (Trim(token) == "ENHANCE") then Call GetNumber(WC, A%Enhance_Size) i = A%Enhance_Size Allocate(A%enhance(i), STAT=j) Write(token,*) "ldatom: Can't alloc space for enhancements! Size=",i Call Check_Error(j, token, Error_Unit, .TRUE., WC, "ldatom:") if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldatom: Enhance_Size = ", A%Enhance_Size End IF Do i=1, A%Enhance_Size Call GetNumber(WC, A%Enhance(i)%Level) Call GetNumber(WC, A%Enhance(i)%Radius) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldatom: Enhance(L,R):", & A%Enhance(i)%Level, A%Enhance(i)%Radius End IF End Do Call GetNextWord(WC, token, tlen) else Write(Error_Unit, *) "ldAtom: Unknown Option: ", Trim(Token) End If Call GetNextWord(WC, token, tlen) if (W_ERROR /= W_OK) Call EOF_Error(WC, "ldatom(next word): ") Call UpperCase(Token) End Do A%Nuclear_Params = 0 A%Force%NumMoves = 0; A%Force%Predictor_Phase = .FALSE. If (Atomic_Mode == SIM_PAW) then MaxL = MaxVal(AtomType_Info(A%TypeIndex)%L_Value) i = AtomType_Info(A%TypeIndex)%nlm_Size n = i*(i+1)/2 !** Determine unique Dij's Allocate(A%Qlm(2*MaxL+1, 2*(2*MaxL)+1), A%dEdQlm(2*MaxL+1,2*(2*MaxL)+1), & A%Dij(i,i),A%cdij(i,i), A%Dij_old(n), A%Wij(i,i), A%Wij_old(i,i), & A%Fij(3,i,i), A%Feij(3,i,i), STAT=err) A%Qlm = 0; A%dEdQlm = 0; A%Dij = 0; A%Wij = 0; A%Wij_old = 0 A%Fij = 0; A%Feij = 0; A%Dij_old = 0; A%cDij=0 if(spindependence) then Allocate(A%Dijspin(i,i),A%cDijspin(i,i),A%Dij_oldspin(n),A%Wijspin(i,i), & A%Wij_oldspin(i,i),A%Fijspin(3,i,i),A%Feijspin(3,i,i),STAT=err) A%Dijspin =0; A%cDijspin=0;A%Dij_oldspin =0 ; A%Wijspin=0 A%Wij_oldspin =0; A%Fijspin=0; A%Feijspin=0 write(log_unit,*) 'ldAtom: Wijspin allocated', i,n write(log_unit,*) 'ldAtom: Fijspin', size(A%Fijspin),size(A%Feijspin) call flush(log_unit) end if End If Call Check_Error(err, "LdAtom: Error allocating Qlm, ...", & Error_Unit, .TRUE., WC, "ldatom:") Return End Subroutine !****************************************************************************** ! ! ldAtomList - Loads a list of atoms from the input file. ! The input format is specified below: ! ! MAXATOM Max_Specific_Atom # Previously defined ! ! ATOM_LIST [CART_POSITION | FRAC_POSITION] ! Name1 Type1 (x1,y1,z1) ! Name2 Type2 (x2,y2,z2) ! .. .. .. ! NameN TypeN (xN,yN,zN) ! END ! ! !****************************************************************************** Subroutine ldAtomList(WC) Type (Word_Context), Intent(INOUT) :: WC Character*100 :: token, token2 Integer :: i, n, tlen, Mode, MaxL, err Real :: pos(3),scale logical :: IsNew Type(Atom_Info_Fixed), Pointer :: AT Type (Specific_Atom), Pointer :: A !*** Determine coordinate format *** Call GetNextWord(WC, token, Tlen) Call UpperCase(Token) If (TRIM(token) == "FRAC_POSITION") then mode = 1 else if (TRIM(token) == "CART_POSITION") then mode = 2 else Write(Error_Unit, *) 'ldAtomList: Unknown Mode:',trim(token) Write(Error_Unit, *) 'ldAtomList: Assuming FRAC_POSITION mode.' End If Write(Log_Unit,*) 'LdAtomList: Mode=',TRIM(Token) Scale = 1 Call GetNextWord(WC, token, Tlen) token2 = token Call UpperCase(Token2) If(Token2=="SCALE") then Call GetNumber(WC,Scale) If (Scale<1.e-8) Scale = 1 Call GetNextWord(WC, token, Tlen) token2 = token Call UpperCase(Token2) EndIf Do While (TRIM(Token2) /= "END") !**** Inc slot for new atom *** Specific_Atoms = Specific_Atoms + 1 A => Atom_list(Specific_Atoms) A%Name = token A%Frac_Pos = 0; A%Pos = 0; A%TypeIndex = -1; A%Orbitals_Size = -1; A%Freeze = .FALSE.; A%Friction = 0; A%Enhance_Size = -1 i = SearchAddList(A%Name, Atom_LUT, IsNew) if (.NOT. IsNew) then !** Name previously used Write(Error_Unit, *) "LdAtomList: Name previously used! Name =", & Trim(A%Name), " * Index =", i Call Word_GetAndPrint(WC, Error_Unit, 'LdAtomList:') STOP End If !** Determine the type index *** Call GetNextWord(WC, token, Tlen) i = SearchList(token, Atomtype_LUT) If (i<0) then !** type not found so ABORT Write(Error_Unit, *) "LdAtomList: type Not Found! Type =", Trim(Token) Call Word_GetAndPrint(WC, Error_Unit, 'LdAtomList:') End if A%TypeIndex = i AT => AtomType_Info(i) A%Orbitals_size = AT%Orbitals_Size i = A%Orbitals_size Allocate(A%Valence_Orbitals(i), A%Init_Occ(i), & A%Init_Occspinup(i), A%Init_Occspindn(i)) A%Valence_orbitals = AT%Valence_Orbitals A%Init_Occ = AT%Init_Occ A%Init_Occspinup = AT%Init_Occspinup A%Init_Occspindn = AT%Init_Occspindn !*** Now get the position and store it in the appropriate slot *** Call GetNumbers(WC, Pos, 3) If (Mode == 1) then A%Frac_Pos = Pos*Scale else A%Pos = Pos*Scale End If !*** Write a synopsis line *** Write(Log_Unit,*) TRIM(A%Name), ' ', Trim(AT%Atom_Name), Pos !*** Finally init the rest of the data structure *** A%Nuclear_Params = 0 A%Force%NumMoves = 0; A%Force%Predictor_Phase = .FALSE. If (Atomic_Mode == SIM_PAW) then MaxL = MaxVal(AtomType_Info(A%TypeIndex)%L_Value) i = AtomType_Info(A%TypeIndex)%nlm_Size n = i*(i+1)/2 !** Determine unique Dij's Allocate(A%Qlm(2*MaxL+1, 2*(2*MaxL)+1), & A%dEdQlm(2*MaxL+1,2*(2*MaxL)+1), A%Dij(i,i), A%cDij(i,i),& A%Dij_old(n), A%Wij(i,i), A%Wij_old(i,i), & A%Fij(3,i,i), A%Feij(3,i,i), STAT=err) A%Qlm = 0; A%dEdQlm = 0; A%Dij = 0; A%Wij = 0; A%Wij_old = 0 A%Dij_old = 0; A%Fij = 0; A%Feij = 0; A%cDij=0 if(spindependence) then Allocate(A%Dijspin(i,i),A%cDijspin(i,i),A%Dij_oldspin(n),A%Wijspin(i,i), & A%Wij_oldspin(i,i),A%Fijspin(3,i,i),A%Feijspin(3,i,i),STAT=err) A%Dijspin =0; A%cDijspin=0;A%Dij_oldspin =0 ; A%Wijspin=0 A%Wij_oldspin =0; A%Fijspin=0; A%Feijspin=0 write(log_unit,*) 'ldAtom: Wijspin allocated', i,n write(log_unit,*) 'ldAtom: Fijspin', size(A%Fijspin),size(A%Feijspin) call flush(log_unit) end if Call Check_Error(err, "LdAtomList: Error allocating Qlm, ...", & Error_Unit, .TRUE., WC, "ldatom:") End If !*** check for another line *** Call GetNextWord(WC, token, Tlen) token2 = token Call UpperCase(Token2) End Do Return End Subroutine !****************************************************************************** ! ldShellInfo -- Sets up Shell parameters and translation to atomic positions ! !****************************************************************************** Subroutine ldShellInfo(WC,WithOrigin) Type (Word_Context), Intent(INOUT) :: WC Logical, Intent(IN) :: WithOrigin Character*100 :: token, token2, token3 Integer :: tlen, i,a, j, k, l,index, ier Real :: vec(3),scale,x Real, allocatable :: MM(:,:),IM(:,:) If (Specific_Atoms<1) then Write(Error_Unit,*) 'Error in ldShellInfo - Specific_Atoms<1',Specific_Atoms Write(Error_Unit,*) 'Must read in atomic positions first' stop EndIf Call GetNumber(WC,i) If (i>0) then Shell%NPARAMS=i Write(Log_Unit,*)'ldShellInfo: Shell%NPARAMS',i Else Write(Error_Unit,*) 'Error in ldShellInfo -- NPARAMS = ',i Stop EndIf Allocate(Shell%C(i),Shell%ShellForce(i),stat=ier) If (ier > 0 ) then Write(Error_Unit,*) 'Error in ldShellInfo allocation',ier stop EndIf Nullify(Shell%AtomMap) Allocate(Shell%AtomMap(Specific_Atoms),stat=ier) If (ier > 0 ) then Write(Error_Unit,*) 'Error in ldShellInfo allocation',ier stop EndIf Do i=1,Specific_Atoms Shell%AtomMap(i)%Origin = 0 Enddo Call GetNextWord(WC, token, Tlen) token2 = token Call UpperCase(Token2) ! List of atoms mapped to parameters Do While (TRIM(Token2) /= "END") a=0 loop: do i = 1,Specific_Atoms If(TRIM(token)==TRIM(Atom_List(i)%Name)) then a=i exit loop EndIf enddo loop If (a<1) then Write(Error_Unit,*) 'Error in ldShellInfo -- atom name', token stop EndIf Call GetNumber(WC,i) Shell%AtomMap(a)%MapParams=i !**Can be zero if atom constrained Write(Log_Unit,*)'ldShellInfo: a, MapParams',a,i If (i > 0 ) then If (i > 3) then Write(Error_Unit,*) 'Error in ldShellInfo -- MapParams>3',& token,a,i stop EndIf Nullify(Shell%AtomMap(a)%Map); Nullify(Shell%AtomMap(a)%V) Nullify(Shell%AtomMap(a)%IV) Allocate(Shell%AtomMap(a)%Map(i),Shell%AtomMap(a)%V(3,i),& Shell%AtomMap(a)%IV(3,i),stat=ier) If (ier > 0 ) then Write(Error_Unit,*) 'Error in ldShellInfo allocation',ier stop EndIf If (WithOrigin) then Call GetNextWord(WC, token3, Tlen) Call UpperCase(token3) If (TRIM(token3)=="O_CART") then Call GetNumbers(WC,vec,3) Write(Log_Unit,*)'ldShellInfo: origin',vec Shell%AtomMap(a)%Origin = vec Elseif (TRIM(token3)=="O_SCALE") then Call GetNumber(WC,scale) Call GetNumbers(WC,vec,3) Write(Log_Unit,*)'ldShellInfo: scaled origin',scale,vec Shell%AtomMap(a)%Origin = vec*scale Elseif (TRIM(token3)=="O_FRAC") then Call GetNumbers(WC,vec,3) Write(Log_Unit,*)'ldShellInfo: origin',vec Shell%AtomMap(a)%Origin = MATMUL(xtal%Basis,vec) Else Write(Log_unit,*) 'ldShellInfo error in origin', token3 stop EndIf EndIf Do j=1,i Call GetNumber(WC,k) If ((k < 1) .OR. (k > Shell%NPARAMS)) then Write(Error_Unit,*) 'Error in ldShellInfo -- Map',a,j,k Stop EndIf Shell%AtomMap(a)%Map(j) = k Write(Log_Unit,*)'ldShellInfo: j,Map',j,k Call GetNumbers(WC,vec,3) Write(Log_Unit,*)'ldShellInfo: vec',vec scale=Dot_Product(vec,vec) If (scale > 1.e-15) then Shell%AtomMap(a)%V(:,j)=vec/SQRT(scale) !Normalize to unity Else Write(Error_Unit,*) & 'Error in ldShell -- vector',a,j,scale Stop EndIf Enddo If (ALLOCATED(MM)) Deallocate(MM) If (ALLOCATED(IM)) Deallocate(IM) Allocate(MM(i,i),IM(i,i)) do j=1,i do k=1,i MM(j,k)=Dot_Product(Shell%AtomMap(a)%V(:,j),Shell%AtomMap(a)%V(:,k)) enddo enddo call MatrixInverse123(MM,IM) write(log_unit,*) 'Checking matrix inverse' do j=1,i do k=1,i x=0 do l=1,i x=x+MM(j,l)*IM(l,k) enddo if (j==k.and.ABS(x-1)>1.e-8) then write(Error_unit,*) 'Error in matrix inverse',MM,IM stop endif if (j/=k.and.ABS(x)>1.e-8) then write(Error_unit,*) 'Error in matrix inverse',MM,IM stop endif enddo enddo do j=1,i Shell%AtomMap(a)%IV(:,j)=0 do k=1,i Shell%AtomMap(a)%IV(:,j)=Shell%AtomMap(a)%IV(:,j) + & Shell%AtomMap(a)%V(:,k)*IM(k,j) enddo enddo deallocate(MM,IM) write(Log_unit,*) 'Summary for atom', a Do j=1,i write(log_unit,'(1p3e12.4,2x,1p3e12.4)') & (Shell%AtomMap(a)%V(k,j),k=1,3),(Shell%AtomMap(a)%IV(k,j),k=1,3) Enddo EndIf !*** check for another line *** Call GetNextWord(WC, token, Tlen) token2 = token Call UpperCase(Token2) EndDo Return End Subroutine !****************************************************************************** ! ! ldAtomTypeOcc - Loads the default occupany for the species. ! The input format is specified below: ! ! ATOMTYPE_OCCUPANCY Species_Name ! ORBITALS_SIZE n # Number of valence orbitals for LCAO ! VALENCE_ORBITALS i1 i2 .. in # List of (nl)'s for use as valence fn's ! VALENCE_OCCUPANCY q1 q2 .. qn # Initial charge distribution in electrons. ! END ! !****************************************************************************** Subroutine ldAtomTypeOcc(WC) Type (Word_Context), Intent(INOUT) :: WC Character*100 :: token Integer :: i, j, tlen Type(Atom_Info_Fixed), Pointer :: A !*** Get the species name and find its TypeIndex *** Call GetNextWord(WC, token, tlen) i = SearchList(token, AtomType_LUT) if (i==-1) then !** Name not found Write(Error_Unit, *) "LdAtomTypeOcc: type not found! Name =", TRIM(token) Call Word_GetAndPrint(WC, Error_Unit, 'LdAtomTypeOcc:') STOP End If A => AtomType_Info(i) If (A%Orbitals_Size > 0) then !** Free old defaults if needed A%Orbitals_Size = -1 DeAllocate(A%Valence_orbitals, A%Init_Occ, & A%Init_Occspinup, A%Init_Occspindn) End if Write(Log_Unit,*) 'ldAtomTypeOcc: Atom type:',TRIM(token), ' * Index=',i Call GetNextWord(WC, token, Tlen) Call UpperCase(Token) Do While (Trim(token) /= "END") if (Trim(token) == "ORBITALS_SIZE") then Call GetNumber(WC, i) A%Orbitals_Size = i Allocate(A%Valence_Orbitals(i), STAT=j) Write(token,*) "ldatomTypeOcc: Can't alloc space for Valence Orbitals! Size=",i Call Check_Error(j, token, Error_Unit, .TRUE., WC, "ldAtomTypeOcc:") Allocate(A%Init_Occ(i), A%Init_Occspinup(i), & A%Init_Occspindn(i), STAT=j) Write(token,*)"ldAtomTypeOcc: Can't alloc space for Valence Occupancy! Size=",i Call Check_Error(j, token, Error_Unit, .TRUE., WC, "ldAtomTypeOcc:") else if (Trim(token) == "VALENCE_ORBITALS") then If (A%Orbitals_Size <= 0) then Write(Error_Unit, *) 'ldAtomTypeOcc: Orbital_Size not defined!!' Call Word_GetAndPrint(WC, Error_Unit, "ldAtomTypeOcc: ") STOP End If Call GetNumbers(WC, A%Valence_Orbitals) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldAtomTypeOcc: Valence_Orbitals = ", A%Valence_Orbitals End IF else if (TRim(token) == "VALENCE_OCCUPANCY") then If (A%Orbitals_Size <= 0) then Write(Error_Unit, *) 'ldAtomTypeOcc: Orbital_Size not defined!!' Call Word_GetAndPrint(WC, Error_Unit, "ldatom: ") STOP End If Call GetNumbers(WC, A%Init_Occ) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldAtomTypeOcc: Valence_Occupancy = ", A%Init_Occ End IF else if (TRim(token) == "SPINUP_VALENCE_OCCUPANCY") then If (A%Orbitals_Size <= 0) then Write(Error_Unit, *) 'ldAtomTypeOcc: Orbital_Size not defined!!' Call Word_GetAndPrint(WC, Error_Unit, "ldatom: ") STOP End If Call GetNumbers(WC, A%Init_Occspinup) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldAtomTypeOcc: Spinup_Occupancy = ", A%Init_Occspinup End IF else if (TRim(token) == "SPINDN_VALENCE_OCCUPANCY") then If (A%Orbitals_Size <= 0) then Write(Error_Unit, *) 'ldAtomTypeOcc: Orbital_Size not defined!!' Call Word_GetAndPrint(WC, Error_Unit, "ldatom: ") STOP End If Call GetNumbers(WC, A%Init_Occspindn) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldAtomTypeOcc: Spindn_Occupancy = ", A%Init_Occspindn End IF else if (TRim(token) == "RS_SCALE") then Call GetNumbers(WC, A%Rc_RS_Scale) Write(Log_Unit,*) "ldAtomTypeOcc: RS_Scale = ",A%Rc_Rs_Scale else if (TRim(token) == "GCUT") then Call GetNumbers(WC, A%Gcut_Proj) Write(Log_Unit,*) "ldAtomTypeOcc: Gcut = ",A%Gcut_PROJ else Write(Error_Unit, *) "ldAtomTypeOcc: Unknown Option: ", Trim(Token) End If Call GetNextWord(WC, token, tlen) if (W_ERROR /= W_OK) Call EOF_Error(WC, "ldAtomTypeOcc(next word): ") Call UpperCase(Token) End Do Return End Subroutine End Module spinpwpaw/code/ldsupercell.f900100664004704100470410000002350510371153116016506 0ustar natalienatalie!****************************************************************************** ! ! File : ldsupercell.f90 ! by : Alan Tackett ! on : 7/27/98 ! for : PAW Project ! ! LdSuperCell - Loads the super cell information. ! ! Definition Format : ! ! SuperCell ! SCALE scale_factor # Optional Scale factor for A,B,C ! A (Xa,Ya,Za) UNIT # Unit cell vectors in xyz coords ! B (Xb,Yb,Zb) UNIT ! C (Xc,Yc,Zc) UNIT ! ! ! K-POINTS_GRID (nA, nB, nC) # Defines the K-points grid ! # where nA, nB, and nC are the recip lattice ! # subdivisions along each recip vector ! ! K-POINTS_LIST List_Size # Or you can specifty the list yourself ! (Kx1, Ky1, Kz1) Weight1 # where each line is a kpoint followed ! . . . . . . . . . . # by a weight ! END ! ! BZ_METHOD method # BZ integration method. Current options are: ! # LINEAR_TETRA - Linear tetrahedron method ! # QUAD_TETRA - Quadratic tetrahedron ! # GAUSS - Gaussian Smearing ! ! GAUSS_WIDTH sigma # Gaussian Smearing Sigma. Only used if ! # BZ_Method is GAUSS. Ignored otherwise ! ! AUTO_SYMMETRY # Automatically determine the symmetry ! ! # OR ! ! ROT_SIZE RotMatSize # Number of rotation matrices ! ! TRANSLATION index (x,y,z) # Rotation Matrix symmetry Translation ! ! MATRIX index # Load the 'index'th matrix ! (X1i,Y1i, Z1i) ! (X2i,Y2i, Z2i) ! (X3i,Y3i, Z3i) ! End ! . ! . ! . ! End ! ! !****************************************************************************** Subroutine LDSuperCell(WC) Use crystal_data Use paw_inout Use mathlib Use word Use units Use strings Use storedata Use ldatom_info Implicit NONE!!!!! Type (Word_Context), Intent(INOUT) :: WC Real, Pointer :: Ku(:,:), Wt(:) Character(132) :: token Integer :: i, aerr, tlen, j Logical :: NewToken, ListLoaded Real :: Scale scale = 1 xtal%CloneCell = 0 xtal%Basis = -100 xtal%Rot_Size = -1 xtal%BZ_Method = -1 xtal%Kpnts_grid = -1 xtal%Sigma = 0.1 xtal%Auto_symmetry = .FALSE. Allocate(xtal%Trans(3,48), xtal%RotMatrix(3,3,48)) ListLoaded = .FALSE. If (Print_Level <= PRINT_COMMANDS) then Write(Log_Unit, *) ">SuperCell" End IF Call GetNextWord(WC, token, Tlen) Call UpperCase(Token) Do While (token /= "END") NewToken = .TRUE. !***write(*,*) 'ldsupercell: Token=',trim(Token) if (Trim(token) == "A") then NewToken= .NOT. GetRealsWithUnit(WC,xtal%Basis(:,1),Length_Unit,token,3) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldSuperCell: A = ", xtal%Basis(:,1) End IF else if (Trim(token) == "B") then NewToken =.NOT. GetRealsWithUnit(WC,xtal%Basis(:,2),Length_Unit,token,3) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldSuperCell: B = ", xtal%Basis(:,2) End IF else if (Trim(token) == "C") then NewToken= .NOT. GetRealsWithUnit(WC,xtal%Basis(:,3),Length_Unit,token,3) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldSuperCell: C = ", xtal%Basis(:,3) End IF else if (Trim(token) == "SCALE") then !** Lattice scale factor Call GetNumber(WC, Scale) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldSuperCell: Scale = ", Scale End IF else if (Trim(token) == "AUTO_SYMMETRY") then xtal%Auto_Symmetry = .TRUE. else if (Trim(token) == "SYM_OUTFILE") then Call GetNextWord(WC, token, Tlen) If (Tlen > 0) Sym_Name=Trim(token) else if (Trim(token) == "ROT_SIZE") then Call GetNumber(WC, xtal%Rot_Size) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldSuperCell: Rot_Size = ", xtal%Rot_Size End IF else if (Trim(token) == "MATRIX") then Call GetNumber(WC, j) Call GetNumbers(WC, xtal%RotMatrix(1,:, j), 3) Call GetNumbers(WC, xtal%RotMatrix(2,:, j), 3) Call GetNumbers(WC, xtal%RotMatrix(3,:, j), 3) Call GetNextWord(WC, Token, tlen) !** Get the end statement if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldSuperCell: Ld RotMatrix = ", j End IF else if (Trim(token) == "TRANSLATION") then Call GetNumber(WC, j) Call GetNumbers(WC, xtal%Trans(:,j), 3) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldSuperCell: Ld Translation = ", j End IF else if (Trim(token) == "K-POINTS_GRID") then Call GetNumbers(WC, Xtal%Kpnts_Grid) if (Print_Level == PRINT_VERBOSE) then write(LOG_UNIT, *) "ldSuperCell: K-Points Grid = ",Xtal%Kpnts_grid End If else if (Trim(token) == "GAUSS_WIDTH") then Call GetNumber(WC, xtal%Sigma) if (Print_Level == PRINT_VERBOSE) then write(LOG_Unit, *) "ldSuperCell: GAUSS_Width = ", xtal%Sigma End IF else if (Trim(token) == "BZ_METHOD") then Call GetNextWord(WC, token, tlen) if (W_ERROR /= W_OK) Call EOF_Error(WC, "ldsupercell(bz_method):") Call UpperCase(token) if (trim(token) == "LINEAR_TETRA") then Xtal%BZ_Method = BZ_LINEAR_TETRA if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldSuperCell: BZ_Method = BZ_LINEAR_TETRA" End If else if (Trim(token) == "QUAD_TETRA") then Xtal%BZ_Method = BZ_QUAD_TETRA if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldSuperCell: BZ_Method = BZ_QUAD_TETRA" End If else if (Trim(token) == "GAUSS") then Xtal%BZ_Method = BZ_GAUSS if (Print_Level == PRINT_VERBOSE) then Write(Log_Unit, *) "ldSuperCell: BZ_Method = BZ_GAUSS" End If else Write(Error_Unit, *) "ldSuperCell: Unknown BZ_Method: ",Trim(token) End If else if (Trim(token) == "K-POINTS_LIST") then Call GetNumber(WC,BZ%TotalUniq) if (W_ERROR /= W_OK) Call EOF_Error(WC, "ldatom(K-Points_List):") BZ%TotalKpnts = BZ%TotalUniq Allocate(BZ%Ku(3,BZ%TotalUniq), xtal%Wt(BZ%TotalUniq), & User_Kpoints(3,BZ%TotalUniq), STAT=aerr) if (aerr /= 0) then Write(Error_Unit, *) "ldSuperCell: Error Allocating K-Points List! Error = ", aerr Call Word_GetAndPrint(WC, Error_Unit, 'ldSuperCell: ') STOP End If If (Print_LEvel == PRINT_VERBOSE) then Write(Log_Unit, *) 'LdSuperCell: K-Points_List Size = ',BZ%TotalUniq End If ListLoaded = .TRUE. BZ%Kp => BZ%Ku; i = 1 Do While ((i<=BZ%TotalUniq) .AND. (W_Error == W_OK)) Call GetNumbers(WC, BZ%Ku(:,i)) Call GetNumber(WC,xtal%Wt(i)) i = i + 1 End Do If (i-1 /= BZ%TotalUniq) then write(Error_unit,*) 'Error in K-point list',i-1,BZ%TotalUniq stop Endif User_Kpoints = BZ%Ku Call GetNExtWord(WC,Token,TLen) IF (W_Error/=W_Ok) Call EOF_Error(WC, "ldatom(K-Points_List-LOADING):") else if (Trim(token) == "CLONE_CELL") then Call GetNumbers(WC, xtal%CloneCell) Write(Log_Unit,*) 'LdSuperCell: Cloning Cell:',xtal%CloneCell else Write(Error_Unit, *) "ldSuperCell: Unknown Option: ", Trim(Token) End If Xtal%Kpnts_Grid = 0 !** Set to 0 If (NewToken) then Call GetNextWord(WC, token, tlen) if (W_ERROR /= W_OK) Call EOF_Error(WC, "ldatom(next word): ") End If Call Uppercase(token) End Do ! ! Calculate SuperCell Volume and Reciprocal lattice vectors ! xtal%Basis = Scale * xtal%Basis xtal%Volume = ABS(DOT_PRODUCT(xtal%Basis(:,1), & CrossProduct(xtal%Basis(:,2), xtal%Basis(:,3)))) xtal%Recip = RecipBasis(xtal%Basis) xtal%InverseBasis = TRANSPOSE(Xtal%Recip) / (2*Pi) xtal%RecipVol = ABS(DOT_PRODUCT(xtal%Recip(:,1), & CrossProduct(xtal%Recip(:,2), xtal%Recip(:,3)))) If (Print_Level <= PRINT_NORMAL) then Write(Log_Unit, *) 'ldSuperCell: Xtal Volume : ', Xtal%Volume, & ' * Recip Volume :',Xtal%RecipVol Write(Log_Unit, *) 'ldSuperCell: Scaled Lattice Vectors:' Write(Log_Unit, *) 'ldSuperCell: A :',Xtal%Basis(:,1) Write(Log_Unit, *) 'ldSuperCell: B :',Xtal%Basis(:,2) Write(Log_Unit, *) 'ldSuperCell: C :',Xtal%basis(:,3) Write(Log_Unit,*) ' ' Write(Log_Unit, *) 'ldSuperCell: Recip(:,1) :',Xtal%Recip(:,1) Write(Log_Unit, *) 'ldSuperCell: Recip(:,2) :',Xtal%Recip(:,2) Write(Log_Unit, *) 'ldSuperCell: Recip(:,3) :',Xtal%Recip(:,3) end If !*** If (Auto_Symmetry) Call StoreSymmetry('RUNTIME') ! ! Do a quck check on the BZ info to make sure its valid ! If (Product(Xtal%Kpnts_Grid) < 0) then Write(Error_Unit, *) "ldSuperCell: Invalid K-Points_Grid size: ", & Xtal%KPnts_Grid Write(Error_Unit, *) "ldSuperCell: Program Halted!" Call Word_GetAndPrint(WC, Error_unit, "ldSuperCell:") STOP End If If (xtal%BZ_Method == -1) then Write(Error_Unit, *) "ldSuperCell: Invalid BZ_Method! Program Halted!" Call Word_GetAndPrint(WC, Error_Unit, "ldSuperCell:") STOP End If bloch_zero = 1 !** Quick Fix should be removed if possible if (ListLoaded) then !** Scale the Kpoints list loaded Do i=1, BZ%TotalUniq call fixhalfrange(BZ%Ku(1,i)) call fixhalfrange(BZ%Ku(2,i)) call fixhalfrange(BZ%Ku(3,i)) BZ%Ku(:,i) = MATMUL(xtal%Recip, BZ%Ku(:,i)) End Do End If xtal_Defined = .TRUE. Return End Subroutine spinpwpaw/code/local_criteria_lib.f900100664004704100470410000001215510303710172017765 0ustar natalienatalie!****************************************************************************** ! ! File : local_criteria_lib.f90 ! by : Alan Tackett ! on : 05/04/00 ! for : PWPAW ! ! Module for defining, loading, and using the local selection criteria ! for targeting wave functions in a particular region in space. ! !****************************************************************************** Module local_criteria_lib Use atom_data Use crystal_data Use paw_inout Use word Use gpoints Implicit NONE!!!!!!! Integer, PARAMETER :: CRIT_ATOM = 1 !** Atom-centered selection !** Data structure containing the spatial or localized selection criteria Type Local_Criteria_Type Integer :: Criteria_Type Integer :: index Real :: Width(3) End Type Type (Local_Criteria_Type), Pointer :: Local_Criteria(:) Integer Local_Criteria_Size Real, Pointer :: Local_Criteria_Map(:) !****************************************************************************** Contains !****************************************************************************** !********************************************************************** ! ! AddLocalCrit_Sphere - Adds a sphere shaped selection to the criteria map ! ! Map - Map to add to ! Center - Sphere center ! Radius - Sphere radius ! R_xtal - Different Lattice Offsets for periodic images ! !********************************************************************** Subroutine AddLocalCrit_Sphere(Map, Center, Radius, R_xtal) Real, Intent(INOUT) :: Map(:) Real, Intent(IN) :: Center(:) Real, Intent(IN) :: Radius Real, Intent(IN) :: R_xtal(:,:) Integer :: x,y,z,t, PM(3), offset_xtal Real :: R(3), DR(3), mag, Rc2 Logical :: Ok Rc2 = Radius*Radius Do z=1, FFT_Grid(3, G_PROJ) Do y=1, FFT_Grid(2, G_PROJ) Do x=1, FFT_Grid(1, G_PROJ) t = t + 1 PM = (/x,y,z/) R = MATMUL(xtal%Basis, (PM-1.0)/(FFT_grid(1:3,G_PROJ))) offset_xtal = 0 Ok = .FALSE. Do While ((.NOT. Ok) .AND. (offset_xtal<27)) Offset_xtal = offset_xtal + 1 DR = R - R_xtal(:,offset_xtal) - Center mag = DOT_PRODUCT(DR,DR) If (mag <= Rc2) Ok = .TRUE. end Do If (Ok) then Map(t) = 1 End If End Do !*x End Do !*y End Do !*z Return end subroutine !****************************************************************************** ! ! CreateLocalCriteriaMap - Creates the local criteria map ! !****************************************************************************** Subroutine CreateLocalCriteriaMap Integer :: i,x,y,z Real :: R(3), R_xtal(3,27), Radius Type (Local_Criteria_Type), Pointer :: LC i = 0 Do z=-1, 1 Do y= -1, 1 Do x=-1, 1 i = i + 1 R_xtal(:,i) = MatMul(xtal%Basis, (/x,y,z/)) End Do End Do End Do R_xtal(:,14) = R_xtal(:,1); R_xtal(:,1) = 0 !** Move R=0 to front for speed Local_Criteria_Map = 0 Do i=1, Local_Criteria_Size LC => Local_Criteria(i) R = Atom_List(LC%index)%Pos Call AddLocalCrit_Sphere(Local_Criteria_Map, R, LC%Width(1), R_xtal) End Do Return end subroutine !****************************************************************************** ! ! ldLocalCriteria - Loads the local criteria ! !****************************************************************************** Subroutine LdLocalCriteria(WC) Type (Word_Context), Intent(INOUT) :: WC Integer :: i, index, tlen Character*100 :: token, token2 Type (Local_Criteria_Type), Pointer :: LC Call GetNumber(WC, i) Write(Log_Unit,*) 'LdLocalCriteria: Size=',i Local_Criteria_Size = i Allocate(Local_Criteria(i)) Call GetNextWord(WC, Token, tlen) !Write(*,*) 'Read_Input : Token: !',trim(token),'! * Error=',error Call UpperCase(token) index = 0 Do While ((W_Error /= W_EOF) .AND. (TRIM(token) /= 'END')) index = index + 1 LC => Local_Criteria(index) If (TRIM(token) == 'ATOM') then !** Atom-centered sphere Call GetNextWord(WC, token, tlen) Call GetNumber(WC, LC%Width(1)) i = SearchList(Token, Atom_LUT) LC%Index = i if (i<=0) then !** Name not used Write(Error_Unit,*) "LdLocalCriteria: Can't find atom! Name =",& Trim(Token) Call Word_GetAndPrint(WC, Error_Unit, 'LdLocalCriteria:') STOP End If else index = index - 1 Write(Error_Unit, *) "LdLocalCriteria: Unknown Command : ", Trim(Token) End If Call GetNextWord(WC, Token, tlen) Call UpperCase(token) End Do Local_Criteria_Size = index Return End Subroutine !****************************************************************************** ! ! InitLocalCriteria - Initializes the local selection criteria ! !****************************************************************************** Subroutine InitLocalCriteria Allocate(Local_Criteria_Map(FFT_Grid(4,G_PROJ))) Local_Criteria_Map = 1 !** Defaults to all space ** Call CreateLocalCriteriaMap Return End Subroutine End Module spinpwpaw/code/lrulib.f900100664004704100470410000000177510303710172015462 0ustar natalienatalie!****************************************************************************** ! ! File : lrulib.f90 ! by : Alan Tackett ! on : 04/19/1999 ! for : PW-PAW ! ! This is a generic module implementing a Least Recently Used algorithm for ! I/O management. ! !****************************************************************************** Module lrulib Use real_lru Use complex_lru implicit none Interface LRU_GetRec Module Procedure REAL_LRU_GetRec Module Procedure Complex_LRU_GetRec End Interface Interface LRU_PutRec Module Procedure REAL_LRU_PutRec Module Procedure Complex_LRU_PutRec End Interface Interface LRU_DisplayBufferInfo Module Procedure REAL_LRU_DisplayBufferInfo Module Procedure COMPLEX_LRU_DisplayBufferInfo End Interface Interface LRU_FreeAll Module Procedure REAL_LRU_FreeAll Module Procedure COMPLEX_LRU_FreeAll End Interface Interface LRU_InitContext Module Procedure REAL_LRU_InitContext Module Procedure COMPLEX_LRU_InitContext End Interface End Module spinpwpaw/code/ltbzi.f900100664004704100470410000005173310303710172015314 0ustar natalienatalie!***************************************************************************** ! ! File : ltbzi.f90 ! on : 5/8/95 ! by : Alan Tackett ! for : DOS calculation using tetrahedron method ! !***************************************************************************** Module ltbzi Implicit NONE!!!! !********* Global Constants ************ Integer, PARAMETER :: TETRA_BASE_ONLY = 0 Integer, PARAMETER :: TETRA_CORR_ONLY = 1 Integer, PARAMETER :: TETRA_BOTH = 2 Type KUsageInfo Integer :: NumCubes ! Number of Cubes containing this Kpnt Integer :: CubeList(2,8) ! List of Cube/Corner pairs End Type Type TetraVertices Integer :: Corners(4) !** Tetrahedron Corners End Type Type Corner2TetraRec !** Corner to Tetrahedron Record Type Integer :: NumTetra ! Number of Tetra point is in Integer :: Tetra(6) ! List of Tetra point is in End Type Type (TetraVertices), Private, Target :: TetraCorners(6) Type (Corner2TetraRec), Private,Target :: Corner2Tetra(8) Integer, Private :: CornerMap(256) Integer, Private :: NextMap(256) Integer, Private :: Power2(8) Integer, Private, Allocatable, TARGET :: CornerOrder(:,:,:) !**Corner order Integer, Private, Allocatable, TARGET :: InvOrder(:,:,:) !**Inv Crnr order Integer, Private, Allocatable, TARGET :: TetraOrder(:,:,:) !**Tetra order Real, Private, Pointer :: Klist(:,:) !** K points list Type (KUsageInfo), Private, Allocatable, Target :: Kusage(:) !** K points list Real, Private, Pointer :: Kenergy(:,:) Integer, Private :: TotalKpnts !** Num K points Integer, Private, Pointer :: Cube(:,:) !** Cube list Integer, Private :: TotalCubes !** Num Cubes Integer, Private :: EdgeCubes !** Num Edge Cubes Integer, Private :: TotalBands !** Num Energy Bands Integer, Private :: TotalElectrons !** # electrons Real, Private :: TetraVolume !** Tetrahedron Volume Real, Private :: FermiEnergy !** Fermi Energy Level Real, Private :: TetraConst !** Volume Const Real, Private, Pointer :: Weight(:,:) !** Integration Weights Contains !****************************************************************************** ! ! InitDOSTetra - Initializes the Tetrahedron DOS calculation routines. ! Must be called before ANY other dostetra functions! ! ! Num_Bands- # of Energy Bands ! Num_Electrons - # of electrons ! KSize - # of K points ! KPnts - Pointer to K Points table ! KE - Pointer to Energy Table for K points ! Wt - Pointer to the Integration Weights Table ! Cubesize - # of Cubes ! CubeEdge - # of Edge cubes(1st portion on Cubelist) ! CubeList - Pointer to Cube info ! CubeVol - Volume of a cube in reciprocal space ! UnitCellVol - Volume of a Unit Cell ! !****************************************************************************** Subroutine InitLTBZI(Num_Bands, Num_Electrons, KSize, KPnts, Ke, Wt, & CubeSize, CubeEdge, CubeList, CubeVol, UnitCellVol) Integer, Intent(IN) :: Num_Bands Integer, Intent(IN) :: Num_Electrons Integer, Intent(IN) :: KSize Real, TARGET, Intent(IN) :: KPnts(:,:) Real, TARGET, Intent(IN) :: Ke(:,:) Real, TARGET, Intent(IN) :: Wt(:,:) Integer, Intent(IN) :: CubeSize Integer, Intent(IN) :: CubeEdge Integer, TARGET, Intent(IN) :: CubeList(:, :) Real, Intent(IN) :: CubeVol Real, Intent(IN) :: UnitCellVol Integer :: i, j, k, n, Sum Integer, Pointer :: Corner(:) !******** Initialize Tetrahedron Corner LUT *********** TetraCorners(1)%Corners = (/ 1, 2, 3, 6 /) TetraCorners(2)%Corners = (/ 1, 3, 5, 6 /) TetraCorners(3)%Corners = (/ 2, 3, 4, 6 /) TetraCorners(4)%Corners = (/ 3, 5, 6, 7 /) TetraCorners(5)%Corners = (/ 3, 4, 6, 8 /) TetraCorners(6)%Corners = (/ 3, 6, 7, 8 /) !******** Initialize Corner to Tetra LUT ************ Corner2Tetra(1)%NumTetra = 2 Corner2Tetra(1)%Tetra = (/ 1, 2, 0, 0, 0, 0 /) Corner2Tetra(2)%NumTetra = 2 Corner2Tetra(2)%Tetra = (/ 1, 3, 0, 0, 0, 0 /) Corner2Tetra(3)%NumTetra = 6 Corner2Tetra(3)%Tetra = (/ 1, 2, 3, 4, 5, 6 /) Corner2Tetra(4)%NumTetra = 2 Corner2Tetra(4)%Tetra = (/ 3, 5, 0, 0, 0, 0 /) Corner2Tetra(5)%NumTetra = 2 Corner2Tetra(5)%Tetra = (/ 2, 4, 0, 0, 0, 0 /) Corner2Tetra(6)%NumTetra = 6 Corner2Tetra(6)%Tetra = (/ 1, 2, 3, 4, 5, 6 /) Corner2Tetra(7)%NumTetra = 2 Corner2Tetra(7)%Tetra = (/ 4, 6, 0, 0, 0, 0 /) Corner2Tetra(8)%NumTetra = 2 Corner2Tetra(8)%Tetra = (/ 5, 6, 0, 0, 0, 0 /) !*********** Initialize CornerMap LUT ************** k = 1 n = 1 do i=1, 8 Power2(i) = n do j = n, 2*n-1 CornerMap(j) = i NextMap(j) = n End Do k = n + 1 n = 2 * n End Do !*********** Initialize the tables *********** TotalKpnts = KSize Klist => Kpnts KEnergy => Ke Weight => Wt TotalCubes = CubeSize EdgeCubes = CubeEdge Cube => CubeList TotalBands = Num_Bands TetraConst = CubeVol / UnitCellVol / 6.0 TotalElectrons = Num_Electrons Allocate(CornerOrder(8, TotalBands, TotalCubes)) Allocate(InvOrder(8, TotalBands, TotalCubes)) Allocate(TetraOrder(6, TotalBands, Totalcubes)) Allocate(Kusage(TotalKpnts)) Do i=1, TotalCubes !** Init Corner and Tetra Orders Do j=1, TotalBands Do k=1, 8 !** Init CornerOrder CornerOrder(k,j,i) = k InvOrder(k,j,i) = k End Do Do k=1, 6 Corner => TetraCorners(k)%Corners Sum = 0 Do n=1, 4 Sum = Sum + Power2(CornerOrder(Corner(n), j, i)) End Do TetraOrder(k,j,i) = Sum End Do End Do End Do Return End Subroutine !**************************************************************************** ! ! t_DetKUsage - Determines how the K points are used in the various ! Cubes and Tetrahedra ! !**************************************************************************** Subroutine t_DetKUsage Integer :: i, j, k Integer, Pointer :: Corner(:) Type (KUsageInfo), Pointer :: KU KUsage%NumCubes = 0 Do i = 1, TotalCubes Corner => Cube(i,:) Do j = 1, 8 KU => KUsage(Corner(j)) KU%NumCubes = KU%NumCubes + 1 KU%CubeList(1,KU%NumCubes) = i KU%CubeList(2,KU%NumCubes) = j End Do End Do Return End Subroutine !**************************************************************************** ! ! t_Sort - Sorts the Cube energy levels in INCREASING energy ! !**************************************************************************** Subroutine t_Sort Real, Pointer :: KE(:) Integer :: i, j, k, n, a, b, t Integer, Pointer :: Corner(:), COrder(:), TOrder(:), TC(:), IOrder(:) Logical :: Changed Do i=1, TotalCubes Corner => Cube(i,:) Do j = 1, TotalBands KE => KEnergy(j, :) COrder => CornerOrder(:,j, i) IOrder => InvOrder(:,j, i) TOrder => TetraOrder(:, j, i) Changed = .FALSE. Do k=2, 8 !*** Sort Energies **** n = k Do While (n>1) if (KE(Corner(COrder(n-1)))>KE(Corner(COrder(n)))) then Changed = .TRUE. a = COrder(n) b = COrder(n-1) COrder(n) = b COrder(n-1) = a IOrder(b) = n IOrder(a) = n-1 n = n - 1 else n = 1 End If End Do End Do if (Changed) then !*** If needed Encode new Sort order **** Do k=1, 6 TC => TetraCorners(k)%Corners t = 0 Do n = 1, 4 t = t + Power2(IOrder(TC(n))) End Do TOrder(k) = t End Do End If End Do End Do Return End Subroutine !**************************************************************************** ! ! t_BandNOS - Calculates the Number of states for a given Band ! ! ****** NOTE : Does NOT init NOS to 0! ****** ! ! NumPoints - Number of points to calculate ! Band - Energy Band ! Energy - Energy Levels to calculate NOS ! NOS - Tabulated NOS ! !**************************************************************************** Subroutine t_BandNOS(NumPoints, Band, Energy, NOS) Integer, Intent(IN) :: NumPoints Integer, Intent(IN) :: Band Real, Intent(IN) :: Energy(:) Real, Intent(INOUT) :: NOS(:) Integer :: i, j, k, Map, n Real :: CurrE Real :: e1, e2, e3, e4, tc Real :: t1, t2, t3, t4, denom Real, Pointer :: KE(:) Integer, Pointer :: CC(:), TOrder(:), COrder(:) tc = TetraConst Do i=1, TotalCubes CC => Cube(i,:) TOrder => TetraOrder(:, Band, i) COrder => CornerOrder(:, Band, i) KE => Kenergy(Band, :) Do k = 1, 6 Map = TOrder(k) e4 = KE(CC(COrder(CornerMap(Map)))) Map = Map - NextMap(Map) e3 = KE(CC(COrder(CornerMap(Map)))) Map = Map - NextMap(Map) e2 = KE(CC(COrder(CornerMap(Map)))) Map = Map - NextMap(Map) e1 = KE(CC(COrder(CornerMap(Map)))) Do n=1, NumPoints CurrE = Energy(n) if (CurrE>e4) then !** E>e4 NOS(n) = NOS(n) + tc else if (CurrE>e3) then !** e4>E>e3 t1 = e4 - CurrE NOS(n) = NOS(n) + tc - tc*t1*t1*t1 / ((e4-e1)*(e4-e2)*(e4-e3)) else if (CurrE>e2) then !** e3>E>e2 t1 = CurrE- e2 t2 = e2 - e1 t3 = e3 - e1 t4 = e4 - e2 t1 = t2*t2 + t1 * (3*t2 + t1*(3 - t1*(t3+t4)/(t4*(e3-e2)))) NOS(n) = NOS(n) + tc*t1/(t3*(e4-e1)) else if (CurrE>e1) then !** e2>e>e1 t1 = CurrE - e1 NOS(n) = NOS(n) + tc*t1*t1*t1/((e2-e1)*(e3-e1)*(e4-e1)) End If End Do End Do End Do End Subroutine !**************************************************************************** ! ! t_NOS - Calculates the Number of states ! Does init NOS to 0! ! ! ! NumPoints - Number of points to calculate ! Energy - Energy Levels to calculate NOS ! NOS - Tabulated NOS ! !**************************************************************************** Subroutine t_NOS(NumPoints, Energy, NOS) Integer, Intent(IN) :: NumPoints Real, Intent(IN) :: Energy(:) Real, Intent(INOUT) :: NOS(:) Integer :: i NOS = 0 Do i = 1, TotalBands Call t_BandNOS(NumPoints, i, Energy, NOS) End Do End Subroutine !**************************************************************************** ! ! t_TetraDOS - Calculates the Density of states for a SINGLE TetraHedra ! ! Ef - Fermi Energy ! e1,e2,e3,e4 - Corner Energies in ascending order ! tc - Scale Constant ! ! Return Values ! Returns the DOS for the given Tetrahedra ! !**************************************************************************** Real Function t_TetraDOS(Ef, e1,e2,e3,e4, tc) Real, Intent(IN) :: Ef Real, Intent(IN) :: e1,e2,e3,e4 Real, Intent(IN) :: tc Real :: t1,t2,t3,t4 Real :: DOS if ((Ef>=e4) .OR. (Ef<=e1)) then !** E>e4 or Ee3) then !** e4>E>e3 t1 = e4 - Ef DOS = 3*tc*t1*t1 / ((e4-e1)*(e4-e2)*(e4-e3)) else if (Ef>e2) then !** e3>E>e2 t1 = Ef- e2 t2 = e2 - e1 t3 = e3 - e1 t4 = e4 - e2 t1 = t2 + t1 * (2 - t1*(t3+t4)/(t4*(e3-e2))) DOS = 3*tc*t1/(t3*(e4-e1)) else !** e2>e>e1 t1 = Ef - e1 DOS = 3*tc*t1*t1/((e2-e1)*(e3-e1)*(e4-e1)) End If t_TetraDOS = DOS Return End Function !**************************************************************************** ! ! t_BandDOS - Calculates the density of states for a single Band ! ! ***** NOTE : Does NOT init DOS to 0! ***** ! ! NumPoints - Number of points to calculate ! Band - Energy Band ! Energy - Energy Levels to calculate DOS ! DOS - Tabulated DOS ! !**************************************************************************** Subroutine t_BandDOS(NumPoints, Band, Energy, DOS) Integer, Intent(IN) :: NumPoints Integer, Intent(IN) :: Band Real, Intent(IN) :: Energy(:) Real, Intent(INOUT) :: DOS(:) Integer :: i, j, k, Map, n Real :: CurrE Real :: e1, e2, e3, e4 Real, Pointer :: KE(:) Integer, Pointer :: CC(:), TOrder(:), COrder(:) Do i=1, TotalCubes CC => Cube(i,:) TOrder => TetraOrder(:, Band, i) COrder => CornerOrder(:, Band, i) KE => KEnergy(Band, :) Do k = 1, 6 Map = TOrder(k) e4 = KE(CC(COrder(CornerMap(Map)))) Map = Map - NextMap(Map) e3 = KE(CC(COrder(CornerMap(Map)))) Map = Map - NextMap(Map) e2 = KE(CC(COrder(CornerMap(Map)))) Map = Map - NextMap(Map) e1 = KE(CC(COrder(CornerMap(Map)))) Do n=1, NumPoints DOS(n) = DOS(n) + t_TetraDOS(Energy(n), e1,e2,e3,e4, TetraConst) End Do End Do End Do End Subroutine !**************************************************************************** ! ! t_DOS - Calculates the density of states ! Does init DOS to 0! ! ! ! NumPoints - Number of points to calculate ! Energy - Energy Levels to calculate DOS ! DOS - Tabulated DOS ! !**************************************************************************** Subroutine t_DOS(NumPoints, Energy, DOS) Integer, Intent(IN) :: NumPoints Real, Intent(IN) :: Energy(:) Real, Intent(INOUT) :: DOS(:) Integer :: i DOS = 0 Do i = 1, TotalBands Call t_BandDOS(NumPoints, i, Energy, DOS) End Do End Subroutine !**************************************************************************** ! ! t_CalcBaseWeights - Calculates the BASE Weight Factors. ! These are the UNCORRECTED weights ! ! NOTE : Does NOT init WEIGHTS to 0! ! ! Ef - Fermi Energy Level ! !**************************************************************************** Subroutine t_CalcBaseWeights(Ef) Real :: Ef Integer :: i, j, k, Map Integer :: k1, k2, k3, k4 Real :: CurrE Real :: e1, e2, e3, e4 Real :: t1, t2, t3, t4, t5, c1, c2, c3, c4, tc, denom Real :: a1, a2, a3, a4 Real, Pointer :: KE(:), Wt(:) Integer, Pointer :: CC(:), TOrder(:), COrder(:) Tc = TetraConst / 4.0 Do i=1, TotalCubes CC => Cube(i,:) Do j = 1, TotalBands TOrder => TetraOrder(:, j, i) COrder => CornerOrder(:, j, i) KE => Kenergy(j, :) Wt => Weight(j, :) Do k = 1, 6 Map = TOrder(k) k4 = CC(COrder(CornerMap(Map))) Map = Map - NextMap(Map) k3 = CC(COrder(CornerMap(Map))) Map = Map - NextMap(Map) k2 = CC(COrder(CornerMap(Map))) Map = Map - NextMap(Map) k1 = CC(COrder(CornerMap(Map))) e4 = KE(k4) e3 = KE(k3) e2 = KE(k2) e1 = KE(k1) if (Efe4 Wt(k1) = Wt(k1) + tc Wt(k2) = Wt(k2) + tc Wt(k3) = Wt(k3) + tc Wt(k4) = Wt(k4) + tc end IF End Do End Do End Do End Subroutine !**************************************************************************** ! ! t_CalcCorrectedWeights - Calculates the CORRECTION to the Weight Factors. ! Does not calculate the Base weight factors! ! ! NOTE : Does not init Weights to 0! ! ! Ef - Fermi Energy Level ! !**************************************************************************** Subroutine t_CalcCorrectedWeights(Ef) Real, Intent(IN) :: Ef Type (KUsageInfo), Pointer :: Kpnt Type (Corner2TetraRec), Pointer :: C2T Integer :: i,j,k, c Real :: DOS(TotalBands), de Real :: e1, e2, e3, e4, CurrE Real, Pointer :: KE(:), Wt(:) Integer, Pointer :: CC(:), TOrder(:), COrder(:) Integer :: k1,k2,k3,k4, t, map Do i=1, TotalKpnts KPnt => KUsage(i) Do j=1, KPnt%NumCubes c = KPnt%CubeList(1,j) C2T => Corner2Tetra(KPnt%CubeList(2,j)) CC => Cube(c,:) Do k=1, TotalBands CurrE = KEnergy(k, i) COrder => CornerOrder(:,k,c) Do t=1, C2T%NumTetra Map = TetraOrder(C2T%Tetra(t), k, c) e4 = Kenergy(k, CC(COrder(CornerMap(Map)))) Map = Map - NextMap(Map) e3 = Kenergy(k, CC(COrder(CornerMap(Map)))) Map = Map - NextMap(Map) e2 = Kenergy(k, CC(COrder(CornerMap(Map)))) Map = Map - NextMap(Map) e1 = Kenergy(k, CC(COrder(CornerMap(Map)))) de = e1+e2+e3+e4 - 4*CurrE Weight(k,i) = Weight(k,i) + & 0.025*t_TetraDOS(Ef,e1,e2,e3,e4,TetraConst)* de End Do End Do End Do End Do Return End Subroutine !**************************************************************************** ! ! t_CalcWeights - Calculates the the Weight Factors. ! ! Ef - Fermi Energy Level ! Mode - Type of NOS to calculate ! TETRA_BASE_ONLY - Calc using BASE weight factors only ! TETRA_CORR_ONLY - " " Correction weight factors only ! TETRA_BOTH - " " both base and correction weights ! ! !**************************************************************************** Subroutine t_CalcWeights(Ef, Mode) Real, Intent(IN) :: Ef Integer, Intent(IN) :: Mode Weight = 0 Select Case (Mode) Case (TETRA_BASE_ONLY) Call t_CalcBaseWeights(Ef) Case (TETRA_CORR_ONLY) Call t_CalcCorrectedWeights(Ef) Case (TETRA_BOTH) Call t_CalcBaseWeights(Ef) Call t_CalcCorrectedWeights(Ef) End Select Return End Subroutine !**************************************************************************** ! ! t_CorrectedNOS - Calculates the number of states with the ! corrected integration Weights ! ! NOTE : Assumes the Kpnts Energies are SORTED! ! ! NumPoints - Number of points to calculate ! Energy - Energy Levels to calculate DOS ! DOS - Tabulated DOS ! Mode - Type of NOS to calculate ! TETRA_BASE_ONLY - Calc using BASE weight factors only ! TETRA_CORR_ONLY - " " Correction weight factors only ! TETRA_BOTH - " " both base and correction weights ! !**************************************************************************** Subroutine t_CorrectedNOS(NumPoints, Energy, NOS, Mode) Integer, Intent(IN) :: NumPoints Real, Intent(IN) :: Energy(:) Real, Intent(INOUT) :: NOS(:) Integer, Intent(IN) :: Mode Integer :: i integer ::j Real :: s NOS = 0 Weight = 0 Do i=1, NumPoints Call t_CalcWeights(Energy(i), Mode) NOS(i) = Sum(Weight) End Do Return End Subroutine !**************************************************************************** ! ! t_Integral - Calculates the integral of a function. Assumes that the ! integration weights have already been calculated. ! ! Fn - Function evaluated at each k pnt and band, must have same dim as KE ! !**************************************************************************** Real Function t_Integral(Fn) Real, Intent(IN) :: Fn(:,:) t_Integral = Sum(Fn(1:TotalBands,1:TotalKPnts)*Weight(1:totalBands,1:totalKpnts)) Return end Function End Module spinpwpaw/code/make.ELabsoft0100664004704100470410000000113310303710172016173 0ustar natalienatalie# lapack and blas libraries LIBS = -L/usr/lib -lm -L/opt/absoft/lib -lU77 \ /opt/absoft90-libs/lapack-3.0.3/lib/liblapack.a \ /opt/absoft90-libs/lapack-3.0.3/lib/libblas.a \ /home/natalie/EL/publiccode/fftw-2.1.5/lib/libfftw.a # Compilers and flags CC = cc CFLAGS = FC = /opt/absoft/bin/f90 FFLAGS = -O2 -cpu:p7 -N113 -YEXT_NAMES=LCS -YEXT_SFX="_" F90 = /opt/absoft/bin/f90 #F90FLAGS = -g -N113 -YCFRL=1 F90FLAGS = -O2 -cpu:p7 -N113 -YEXT_NAMES=LCS -YEXT_SFX="_" FFTFLAGS = $(F90FLAGS) F90FLAGSM = -O2 -cpu:p7 -YEXT_NAMES=LCS -YEXT_SFX="_" LDFLAGS = $(F90FLAGS) spinpwpaw/code/make.ELabsoft.debug0100664004704100470410000000113010303710172017255 0ustar natalienatalie# lapack and blas libraries LIBS = -L/usr/lib -lm -L/opt/absoft/lib -lU77 \ /opt/absoft90-libs/lapack-3.0.3/lib/liblapack.a \ /opt/absoft90-libs/lapack-3.0.3/lib/libblas.a \ /home/natalie/EL/publiccode/fftw-2.1.5/lib/libfftw.a # Compilers and flags CC = cc CFLAGS = FC = /opt/absoft/bin/f90 FFLAGS = -g -Rb -Rs -N113 -YEXT_NAMES=LCS -YEXT_SFX="_" F90 = /opt/absoft/bin/f90 #F90FLAGS = -g -N113 -YCFRL=1 F90FLAGS = -g -Rb -Rs -N113 -YEXT_NAMES=LCS -YEXT_SFX="_" FFTFLAGS = $(F90FLAGS) F90FLAGSM = -g -Rb -Rs -YEXT_NAMES=LCS -YEXT_SFX="_" LDFLAGS = $(F90FLAGS) spinpwpaw/code/make.absoft0100664004704100470410000000112110303710172015747 0ustar natalienatalie# lapack and blas libraries LIBS = -L/usr/lib -lm -L/opt/absoft/lib -lU77 \ /opt/absoft-libs/lapack-3.0/lib/liblapack.a \ /opt/absoft-libs/lapack-3.0/lib/libblas.a \ /opt/absoft-libs/ethernet/fftw-2.1.5/lib/libfftw.a # Compilers and flags CC = cc CFLAGS = FC = /opt/absoft/bin/f90 FFLAGS = -O2 -cpu:p7 -N113 -YEXT_NAMES=LCS -YEXT_SFX="_" F90 = /opt/absoft/bin/f90 #F90FLAGS = -g -N113 -YCFRL=1 F90FLAGS = -O2 -cpu:p7 -N113 -YEXT_NAMES=LCS -YEXT_SFX="_" FFTFLAGS = $(F90FLAGS) F90FLAGSM = -O2 -cpu:p7 -YEXT_NAMES=LCS -YEXT_SFX="_" LDFLAGS = $(F90FLAGS) spinpwpaw/code/make.absoft.debug0100664004704100470410000000104510303710172017041 0ustar natalienatalie# lapack and blas libraries LIBS = -L/usr/lib -lm -L/opt/absoft/lib -lU77 \ -L/opt/absoft-libs/lapack-3.0/lib/ -llapack -lblas \ /opt/gnu-libs/ethernet/fftw-2.1.5/lib/libfftw.a # Compilers and flags CC = cc CFLAGS = FC = /opt/absoft/bin/f90 FFLAGS = -g -Rb -Rs -N113 -YEXT_NAMES=LCS -YEXT_SFX="_" F90 = /opt/absoft/bin/f90 #F90FLAGS = -g -N113 -YCFRL=1 F90FLAGS = -g -Rb -Rs -N113 -YEXT_NAMES=LCS -YEXT_SFX="_" FFTFLAGS = $(F90FLAGS) F90FLAGSM = -g -Rb -Rs -YEXT_NAMES=LCS -YEXT_SFX="_" LDFLAGS = $(F90FLAGS) spinpwpaw/code/make.inc0100664004704100470410000000113310303710172015245 0ustar natalienatalie# lapack and blas libraries LIBS = -L/usr/lib -lm -L/opt/absoft/lib -lU77 \ /opt/absoft90-libs/lapack-3.0.3/lib/liblapack.a \ /opt/absoft90-libs/lapack-3.0.3/lib/libblas.a \ /home/natalie/EL/publiccode/fftw-2.1.5/lib/libfftw.a # Compilers and flags CC = cc CFLAGS = FC = /opt/absoft/bin/f90 FFLAGS = -O2 -cpu:p7 -N113 -YEXT_NAMES=LCS -YEXT_SFX="_" F90 = /opt/absoft/bin/f90 #F90FLAGS = -g -N113 -YCFRL=1 F90FLAGS = -O2 -cpu:p7 -N113 -YEXT_NAMES=LCS -YEXT_SFX="_" FFTFLAGS = $(F90FLAGS) F90FLAGSM = -O2 -cpu:p7 -YEXT_NAMES=LCS -YEXT_SFX="_" LDFLAGS = $(F90FLAGS) spinpwpaw/code/make.intel0100664004704100470410000000104210303710172015606 0ustar natalienatalie# lapack and blas libraries LIBS = -L/home/natalie/publiccode/ATLAS/ \ -llapack_atlasintel -lcblas -lf77blas -latlas \ -L/opt/intel/compiler70/ia32/lib \ -lPEPCF90 \ /opt/intel-libs/ethernet/fftw-2.1.5/lib/libfftw.a # Compilers and flags CC = cc CFLAGS = FC = /opt/intel/compiler70/ia32/bin/ifc FFLAGS = -r8 -O2 -tpp7 -xW -mp F90 = /opt/intel/compiler70/ia32/bin/ifc F90FLAGS = -r8 -O2 -tpp7 -xW -mp FFTFLAGS = $(F90FLAGS) F90FLAGSM = -O2 -tpp7 -xW -mp LDFLAGS = $(F90FLAGS) # Note: -O3 gives INCORRECT results!!!!!! spinpwpaw/code/make.intel800100664004704100470410000000105510303710172015762 0ustar natalienatalie# lapack and blas libraries LIBS = /opt/intel8-libs/lapack-3.0/lib/liblapack.a \ /opt/intel8-libs/lapack-3.0/lib/libblas.a \ -L/opt/intel/compiler80/ifort/lib \ /opt/intel8-libs/ethernet/fftw-2.1.5/lib/libfftw.a # Compilers and flags CC = cc CFLAGS = FC = /opt/intel/compiler80/ifort/bin/ifort FFLAGS = -r8 -O2 -tpp7 -xW -mp -f77rtl -static F90 = /opt/intel/compiler80/ifort/bin/ifort F90FLAGS = -r8 -O2 -tpp7 -xW -mp -static FFTFLAGS = $(F90FLAGS) F90FLAGSM = -O2 -tpp7 -xW -mp -static LDFLAGS = $(F90FLAGS) # Note: -O3 gives INCORRECT results!!!!!! spinpwpaw/code/make.intel80.debug0100664004704100470410000000104510303710172017046 0ustar natalienatalie# lapack and blas libraries LIBS = /home/natalie/developcode/LAPACK/lapack_intel80.a \ /home/natalie/developcode/LAPACK/blas_intel80.a \ -L/opt/intel/compiler80/ifort/lib \ /opt/intel-libs/ethernet/fftw-2.1.5/lib/libfftw.a # Compilers and flags CC = cc CFLAGS = FC = /opt/intel/compiler80/ifort/bin/ifort FFLAGS = -r8 -mp -f77rtl -static -g F90 = /opt/intel/compiler80/ifort/bin/ifort F90FLAGS = -r8 -mp -static -g FFTFLAGS = $(F90FLAGS) F90FLAGSM = -mp -static -g LDFLAGS = $(F90FLAGS) # Note: -O3 gives INCORRECT results!!!!!! spinpwpaw/code/make.intel8010100664004704100470410000000106610303710172016045 0ustar natalienatalie# lapack and blas libraries LIBS = /opt/intel8-libs/lapack-3.0/lib/liblapack.a \ /opt/intel8-libs/lapack-3.0/lib/libblas.a \ -L/opt/intel/compiler80/ifort/lib \ /opt/intel8-libs/ethernet/fftw-2.1.5/lib/libfftw.a # Compilers and flags CC = cc CFLAGS = FC = /opt/intel/compiler80/ifort/bin/ifort FFLAGS = -r8 -O2 -tpp7 -xW -mp -f77rtl -static -g F90 = /opt/intel/compiler80/ifort/bin/ifort F90FLAGS = -r8 -O2 -tpp7 -xW -mp -static -g FFTFLAGS = $(F90FLAGS) F90FLAGSM = -O2 -tpp7 -xW -mp -static -g LDFLAGS = $(F90FLAGS) # Note: -O3 gives INCORRECT results!!!!!! spinpwpaw/code/make.intelMKL0100664004704100470410000000127310303710172016160 0ustar natalienatalie# lapack and blas libraries LIBS = /opt/intel-libs/lapack-3.0/lib/liblapack.a \ /opt/intel/mkl/lib/32/libmkl_p4.a \ /opt/intel/mkl/lib/32/libguide.a \ -L/opt/intel/compiler70/ia32/lib \ -lpthread -lPEPCF90 \ /opt/intel-libs/ethernet/fftw-2.1.3/lib/libfftw.a # Compilers and flags CC = cc CFLAGS = FC = /opt/intel/compiler70/ia32/bin/ifc FFLAGS = -r8 -O2 -tpp7 -xW -mp F90 = /opt/intel/compiler70/ia32/bin/ifc F90FLAGS = -r8 -O2 -tpp7 -xW -mp FFTFLAGS = $(F90FLAGS) F90FLAGSM = -O2 -tpp7 -xW -mp LDFLAGS = $(F90FLAGS) # Note: -O3 gives INCORRECT results!!!!!! spinpwpaw/code/make.pgi0100664004704100470410000000115110303710172015253 0ustar natalienatalie# lapack and blas libraries LIBS = /home/natalie/developcode/LAPACK/lapack_pgi.a \ /home/natalie/developcode/LAPACK/blas_pgi.a \ -L/opt/pgi-4.0/linux86/lib \ /opt/pgi-libs/ethernet/fftw-2.1.5/lib/libfftw.a # Compilers and flags CC = cc CFLAGS = FC = /opt/pgi-4.0/linux86/bin/pgf77 #FFLAGS = -r8 -O2 -tp p7 FFLAGS = -r8 -g F90 = /opt/pgi-4.0/linux86/bin/pgf90 #F90FLAGS = -r8 -O2 -tp p7 F90FLAGS = -r8 -g FFTFLAGS = $(F90FLAGS) #F90FLAGSM = -O -tp p7 F90FLAGSM = -g LDFLAGS = $(F90FLAGS) spinpwpaw/code/makescript0100775004704100470410000000041510303710172015727 0ustar natalienatalie#!/bin/tcsh echo 'syntax : makescript (intel or absoft) (pwpaw genkpoints ...' echo ' libfile plotbands prepareballandstick preparepdos...)' echo 'compiling ' $2 ' using ' $1 'rm' -f .compiler echo $1 >.compiler 'cp' -f make.$1 make.inc make -f Makeforlinux $2 spinpwpaw/code/mathlib.f900100664004704100470410000014015710371153136015615 0ustar natalienatalie!****************************************************************************** ! ! File : mathlib.f90 ! by : Alan Tackett ! on : 7/27/95 ! for : PAW Method ! ! Initializes values of global constants such as pi, machine_precision, etc. ! Contains various math routines for creating a crystal cartesian basis from ! spherical basis, calculating reciprocal lattice vectors, etc... ! The following is a list of the routines currently implemented: ! ! Calc3x3Inverse - Calculates the 3x3 inverse of a 3x3 symmetric matrix ! CrossProduct - Calculates the Cross Product of 2 vectors T ! Outer_Product - Calculates the outer product of 2 vectors-> AB ! XtalBasis - Converts the Length and Angle information into a XYZ basis ! hkl2xyz - Converts xtal coordinates (h,k,l) to cart. coords (x,y,z) ! hkl2xyz - Converts cart. coords (x,y,z) to xtal coordinates (h,k,l) ! RecipBasis - Calculates the Reciprocal Basis from the xtal basis ! NearestIntWithFactors - Calculates the nearest integer that has a ! given set of factors. ! IsInteger - Determines if a number is an integer within a given epsilon ! Factorial - Calculates n! ! DoulbeFac - Calculates n!! ! Permutations - Calculates N!/(N-k)! ! GaussLeg - Calculates the Gauss-Legendre weight factors and points ! IntSimpsons - Integrates a 1-D function using Simpsons Rule(Real/Complex) ! IsOdd - Detemines if an integer is odd ! IsEven - Detemines if an integer is even ! itotheL - returns i**L ! SphereBessel - returns spherical Bessel function ! DerivSphereBessel - Calculates the Derivative of Spherical Bessel function ! RadialFourier - calculates the radial integral for Fourier transform ! AssosP - returns associated Legendre function ! Der_Theta_P - returns theta derivative of AssosP ! Der_Phi_P - returns phi derivative of spherical harmonic function ! Lininterp - performs linear interpolation of a numeric function ! Extrapto0 - performs a 2-point extrapolation to zero ! EvalPoly - Evaluates a polynomial ! Checkbounds - Checks to make sure the xmin and xmax values bound a root ! brak_grow - Expands an inital interval until a root is bracketed or ! brak_shrink - Subdivides an inital interval and searches the new list ! rt_Brent - Finds the root of a function using Brent's method given ! rt_Newton - Newton-Raphson with Bisection. Returns the fn root . ! xyztosphericalpolar -- converts from cartesian to spherical polar coords. ! nderiv - evaluates numerical derivative of a function on a regular grid ! !****************************************************************************** Module mathlib Implicit NONE!!! !Real, Parameter :: PI = 3.1415926535897932D0 !Real, Parameter :: R2D = 180.0/PI !Conversion for radians to degrees Real :: Pi, Two_Pi, Four_Pi Real :: R2D Real :: machine_precision , machine_zero , machine_infinity Real*8, private :: minlog,maxlog,minexp,maxexp Real*8, private :: minlogarg,maxlogarg,minexparg,maxexparg Interface IntSimpson Module Procedure Complex_Simpson Module Procedure Real_Simpson End Interface Interface nderiv Module Procedure Complex_nderiv Module Procedure Real_nderiv End Interface !****************************************************************************** Contains !****************************************************************************** !***************************************************************************** ! ! Subroutine initconstants -- calculates Pi and related constants !***************************************************************************** subroutine initconstants implicit none Integer :: i Real :: tmp , a1,a2,a3 pi=acos(-1.d0) two_pi=2*Pi four_pi=4*Pi r2d=pi/180 ! Calculate machine accuracy machine_precision = 0 a1 = 4.0/3.0 do while (machine_precision == 0.0) a2 = a1 - 1.0 a3 = a2 + a2 + a2 machine_precision = ABS(a3 - 1.0) enddo machine_zero= machine_precision**4 machine_infinity = 1.d0/machine_zero minlogarg=machine_precision; minlog=log(minlogarg) maxlogarg=1.d0/machine_precision; maxlog=log(maxlogarg) minexparg=log(machine_precision); minexp=0.d0 maxexparg=-log(machine_precision); maxexp=exp(maxexparg) return end subroutine initconstants !**************************************************** Function ddlog(arg) Real*8 :: arg,ddlog If (arg>maxlogarg) then ddlog=maxlog Else if (argmaxexparg) then ddexp=maxexp Else if (arg 3) THEN DO i = 5, n, 2 COMPLEX_Simpson = COMPLEX_Simpson + fn(i-2) + 4*fn(i-1) + fn(i) END DO END IF COMPLEX_Simpson = fac * COMPLEX_Simpson !** trapezoidal rule for end if N is odd ** IF (n > j) COMPLEX_simpson = COMPLEX_simpson + h * (fn(n-1)+fn(n)) / 2 End If RETURN END FUNCTION !****************************************************************************** ! ! File : real_simpson.f90 ! by : Alan Tackett ! on : 04/21/99 ! for : Mathlib ! ! Generic real for performing 1-D Simpson's rule. This code is based on ! that given to me by N.A.W. Holzwarth. The number of points does not ! have to be even. ! !****************************************************************************** !****************************************************************************** ! ! REAL_simpson - Returns integral over tabulated function f, with ! n tabulated integrands at interval h. ! ! N - Number of points(Doesn't have to be even) ! H - Spacing between points ! fn - Tabulated function values ! !****************************************************************************** REAL FUNCTION REAL_Simpson(n, h, fn) Integer, Intent(IN) :: n Real, Intent(IN) :: h Real, Intent(IN) :: fn(n) Real :: fac Integer :: i, j REAL_Simpson = 0.d0 j = 2*((n-1)/2) + 1 If (n == 0) then Write(*,*) 'REAL_Simpson: N=0!!!!!!!!!' else If (n == 1) then REAL_Simpson = h*fn(1) else If (n == 2) THEN !** use trapazoidal rule REAL_simpson = h * (fn(1)+fn(2)) / 2 else !** Use Simpson's rule ** fac = h / 3 REAL_Simpson = fn(1) + 4*fn(2) + fn(3) IF (j > 3) THEN DO i = 5, n, 2 REAL_Simpson = REAL_Simpson + fn(i-2) + 4*fn(i-1) + fn(i) END DO END IF REAL_Simpson = fac * REAL_Simpson !** trapezoidal rule for end if N is odd ** IF (n > j) REAL_simpson = REAL_simpson + h * (fn(n-1)+fn(n)) / 2 End If RETURN END FUNCTION !****************************************************************************** ! ! Calc3x3Inverse -- Calculates the 3x3 inverse of a 3x3 symmetric matrix ! ! Input matrix M ! Returns matrix IM , ierr=0 if successful inverse ! ierr=1 if M is not symmetric ! ierr=-1 if M has zero determinant !****************************************************************************** Subroutine Calc3x3Inverse(M,IM,ierr) Real, Intent(IN) :: M(3,3) Real, Intent(OUT) :: IM(3,3) Integer, Intent(OUT) :: ierr Real :: det ierr=0 IM = 0 if (ABS(M(1,2)-M(2,1))+ABS(M(2,3)-M(3,2))+ABS(M(1,3)-M(3,1)).gt.1.d-10) then ierr=1 return endif det= M(1,1)*M(2,2)*M(3,3)-M(1,1)*(M(2,3)**2) & -M(2,2)*(M(1,3)**2) & -M(3,3)*(M(1,2)**2) & +2*M(1,2)*M(1,3)*M(2,3) if (ABS(det).lt.1.d-10) then ierr=-1 return endif IM(1,1)=(M(2,2)*M(3,3)-M(2,3)**2)/det IM(1,2)=(M(1,3)*M(2,3)-M(1,2)*M(3,3))/det IM(2,1)=IM(1,2) IM(1,3)=(M(1,2)*M(2,3)-M(1,3)*M(2,2))/det IM(3,1)=IM(1,3) IM(2,2)=(M(1,1)*M(3,3)-M(1,3)**2)/det IM(2,3)=(M(1,2)*M(1,3)-M(1,1)*M(2,3))/det IM(3,2)=IM(2,3) IM(3,3)=(M(1,1)*M(2,2)-M(1,2)**2)/det Return End Subroutine !****************************************************************************** ! ! CrossProduct - Calculates the Cross Product of 2 vectors ! ! A,B - Vectors ! ! Return Values ! The cross product of AxB is returned ! !****************************************************************************** Function CrossProduct(A,B) Real :: CrossProduct(3) Real, Intent(IN) :: A(3) Real, Intent(IN) :: B(3) Real :: C(3) C(1) = A(2)*B(3) - A(3)*B(2) C(2) = A(3)*B(1) - A(1)*B(3) C(3) = A(1)*B(2) - A(2)*B(1) CrossProduct = C Return End Function !****************************************************************************** ! T ! Outer_Product - Calculates the Outer Product of 2 vectors, AB ! ! A,B - Vectors ! n - Length of Vectors ! ! Return Values T ! The outer product of AB is returned ! !****************************************************************************** Function Outer_Product(A,B, n) Integer, Intent(IN) :: n Real, Intent(IN) :: A(n) Real, Intent(IN) :: B(n) Real :: Outer_Product(n,n) Integer :: i, j Do i=1, n Outer_Product(:,i) = A*B(i) End Do Return End Function !****************************************************************************** ! ! XtalBasis - Converts the length and Angle information into a cartesian ! basis. The A-axis lies along the X-Axis and the B-axis lies ! in the XY plane. ! ! basis - Contains the the resulting 3x3 matrix of the 3 cartesian vectors ! lengths - Crystal unit cell lengths ! angles - Crystal unit cell angles in DEGREES ! ! Return Values ! Upon return BASIS contains the xyz basis vectors for the unit cell. ! Each COLUMN of Basis is a basis vector. ! !****************************************************************************** Function XtalBasis(basis, lengths, angles) Real :: XtalBasis(3,3) Real, Intent(IN) :: Lengths(3) Real, Intent(IN) :: Angles(3) Real :: Basis(3,3) !*** Calculate unit basis vectors *** Basis(1,1) = 1 Basis(2,1) = 0 Basis(3,1) = 0 Basis(1,2) = cos(angles(3)*R2D) Basis(2,2) = sin(angles(3)*R2D) Basis(3,2) = 0 Basis(1,3) = cos(angles(2)*R2D) Basis(2,3) = (cos(angles(1)*R2D)-cos(angles(2)*R2D)*cos(angles(3)*R2D)) & / sin(angles(3)*R2D) Basis(3,3) = sqrt(1 - Basis(1,3)*Basis(1,3) - Basis(2,3)*Basis(2,3)) !*** Scale basis *** Basis(1:3,1) = Basis(1:3,1)*lengths(1) Basis(1:3,2) = Basis(1:3,2)*lengths(2) Basis(1:3,3) = Basis(1:3,3)*lengths(3) XtalBasis = Basis Return End Function !****************************************************************************** ! ! hkl2xyz - Converts crystallographic coordinates(h,k,l) to ! cartesian coordinates(x,y,z) based on the given crstal basis. ! ! Basis - Crystal Basis, 3x3 Matrix ! hkl - Crystal Coordinates ! ! Return Values ! The Cartesian coordinates are returned in PNT ! !****************************************************************************** Function hkl2xyz(Basis, hkl) Real :: hkl2xyz(3) Real, Intent(IN) :: Basis(3,3) Real, Intent(IN) :: hkl(3) hkl2xyz = MATMUL(Basis, hkl) Return End Function !****************************************************************************** ! ! xyz2hkl - Converts cartesian coordinates(x,y,z) to crystallographic ! coordinates(h,k,l) to based on the given crstal basis. ! ! Basis - Crystal Basis, 3x3 Matrix ! xyz - Crystal Coordinates ! ! Return Values ! The crystallographic coordinates are returned in PNT ! !****************************************************************************** Function xyz2hkl(Basis, xyz) Real :: xyz2hkl(3) Real, Intent(IN) :: Basis(3,3) Real, Intent(IN) :: xyz(3) xyz2hkl = MATMUL(TRANSPOSE(RecipBasis(Basis))/(2*PI), xyz) Return End Function !****************************************************************************** ! ! RecipBasis - Calculates the reciprocal lattice vectors given the ! cartesian basis calculated in XtalBasis ! ! Basis - Crystal Basis (3x3 matrix) ! Recip - Reciprocal Crystal Basis of above (3x3 matrix) ! ! Return Values ! RECIP contains the reciprocal basis with each COLUMN being a ! reciprocal lattice vector. ! !****************************************************************************** Function RecipBasis(Basis) Real :: RecipBasis(3,3) Real, Intent(IN) :: Basis(3,3) Real :: Recip(3,3) Real :: t, C(3) C = CrossProduct(basis(1:3,2),basis(1:3,3)) t = DOT_PRODUCT(Basis(1:3,1), C) Recip(1:3,1) = 2*PI * C / t C = CrossProduct(basis(1:3,3),basis(1:3,1)) t = DOT_PRODUCT(Basis(1:3,2), C) Recip(1:3,2) = 2*PI * C / t C = CrossProduct(basis(1:3,1),basis(1:3,2)) t = DOT_PRODUCT(Basis(1:3,3), C) Recip(1:3,3) = 2*PI * C / t !Do i=1,3 ! Write(*,*) i,'REC=',Recip(:,i) !End Do RecipBasis = Recip Return End Function !****************************************************************************** ! ! NearestIntWithFactors - Calculates the nearest integer from the specified N ! in either direction that is composed of the specified Factors. ! ! N - Starting Number ! Factor - List of Factors ! NumFact - Number of factors ! Direction - Direction to search: +1=up, -1=down ! NOTE: This is actually the INCREMENT between successive guesses ! ! Return Values ! Returns the number or 0 if Direction=0. ! ! Examples ! N = NearestIntWithFactors(79, (/2,3,5/), 3, +1) ! 4 ! Returns N=80 since 80 = 2 * 5 ! !****************************************************************************** Integer Function NearestIntWithFactors(N, Factor, NumFact, Direction) Integer, Intent(IN) :: N Integer, Intent(IN) :: Factor(:) Integer, Intent(IN) :: NumFact Integer, Intent(IN) :: Direction Integer :: M, Num, i If (Direction == 0) then Num = 1 M = 0 else Num = 0 M = N - Direction End If Do While (Num /= 1) M = M + Direction i = 1 Num = M Do While ((Num > 1) .AND. (i<= NumFact)) Do While (MOD(Num, Factor(i)) == 0) Num = Num / Factor(i) End Do i = i + 1 End Do End Do NearestIntWithFactors = M Return End Function !****************************************************************************** ! ! IsInteger - Determines if a number is an integer within a given epsilon ! ! Num - Number to check ! epsilon - Precision ! ! Return Values ! Returns .TRUE. if INT(num)-epsilon < num < INT(num)+epsilon ! and .FALSE. otherwise. ! !****************************************************************************** Logical Function IsInteger(Num, epsilon) Real, Intent(IN) :: Num Real, Intent(IN) :: epsilon Logical :: Answer If (((Int(num)-epsilon) < num) .AND. (num < (Int(num)+epsilon))) then Answer = .TRUE. else Answer = .FALSE. End If IsInteger = Answer Return End Function !****************************************************************************** ! ! Factorial - Calculates N! ! ! N - Number to use ! ! Return Value ! Returns N! ! !****************************************************************************** Real Function Factorial(N) Integer, Intent(IN) :: N Integer :: i Factorial = 1 If (N<2) return Do i = 2, N Factorial = Factorial * i End Do Return End Function !****************************************************************************** ! ! DoubleFac - Calculates N!! ! ! N - Number to use ! ! Return Value ! Returns N!! ! !****************************************************************************** Real Function DoubleFac(N) Integer, Intent(IN) :: N Integer :: i DoubleFac = 1 Do i = N, 1, -2 DoubleFac = DoubleFac * i End Do Return End Function !****************************************************************************** ! ! Permutations - Calculates N!/(N-k)! ! ! N, K - Numbers to use ! ! Return Value ! Returns N!/(N-k)! if N>=0 and N-k>0 otherwise 0 is returned ! !****************************************************************************** Real Function Permutations(N, K) Integer, Intent(IN) :: N Integer, Intent(IN) :: k Integer :: i if ((N>=0) .AND. ((N-k)>=0)) then Permutations = 1 Do i = N-K+1, N Permutations = Permutations * i End Do Else Permutations = 0 End If Return End Function !****************************************************************************** ! ! GaussLeg - Calculates the Gauss-Legendre integration weights and points ! on the interval (-1, 1) ! ! n - Number of G-L points and weights to calculate ! X - G-L Points ! W - G-L weights ! ! NOTE: This routine is based on the routine from Numerical Recipes in Fortran ! !****************************************************************************** SUBROUTINE GaussLeg(x1,x2,n,x,w) Real, Intent(IN) :: x1,x2 Integer, Intent(IN) :: n Real, Intent(OUT) :: X(:) Real, Intent(OUT) :: W(:) Real, PARAMETER :: EPS=3.d-14 !** EPS is the relative precision. Real :: p1,p2,p3,pp,xl,xm,z,z1,pi Integer :: i,j,m pi=acos(-1.d0) !** High precision is a good idea for this routine. m=(n+1)/2 !** The roots are symmetric in the interval, so we xl=0.5*(x2-x1) !** only have to nd half of them. xm=0.5d0*(x2+x1) do i=1,m !** Loop over the desired roots. z=cos(pi*(i-.25d0)/(n+.5d0)) !** Starting with the above approximation to the ith root, !** we enter the main loop of refinement by Newton's method. z1 = z+10*EPS !** Cheat to enter loop Do While (ABS(z-z1) > EPS) p1=1.0d0 p2=0.0d0 do j=1,n !** Loop up the recurrence relation to get the Legendre p3=p2 !** polynomial evaluated at z. p2=p1 p1=((2.0*j-1.d0)*z*p2-(j-1.0)*p3)/j end do !** p1 is now the desired Legendre polynomial. We next compute pp, !** its derivative, by a standard relation involving also p2, !** the polynomial of one lower order. pp=n*(z*p1-p2)/(z*z-1.d0) z1=z z=z1-p1/pp !**Newton's method. End Do x(i)=xm-xl*z !** Scale the root to the desired interval, x(n+1-i)=xm+xl*z !** and put in its symmetric counterpart. w(i)=2.0*xl/((1.0-z*z)*pp*pp) !** Compute the weight w(n+1-i)=w(i) !**and its symmetric counterpart. end do return End Subroutine !****************************************************************************** ! ! RadialFourier - calculates the radial integral necessary to evaluate the ! Fourier transform of f(r)/r*Ylm ! ! L - L value of Ylm ! k - Spherical Bessel argument scale factor(see below) ! h - Radial spacing between grid points ! N - Number of grid points ! F - tabulated Function ! ! input : l, k, h, n, f(:) , where f(r) is tabulated at n points ! in intervals of h; f(1)==f(r=0)=0 ! ! The radial integral is returned: ! ftf == int(r*f(r)*j_l(k*r),r=0..(n-1)*h) ! ! NOTE: This code was taken from N.A.W. Holzwarth ! !****************************************************************************** Real Function RadialFourier(l,k,h,n,f) Integer, Intent(IN) :: L Real, Intent(IN) :: k Real, Intent(IN) :: h Integer, Intent(IN) :: n Real, Intent(IN) :: f(n) Integer :: i Real, pointer :: x(:) Allocate(x(n)) Do i=1,n x(i) = k*(i-1)*h End Do Call SphereBessel(l,n,x) Do i=1,n x(i)=x(i)*f(i)*(((i-1)*h)) End Do RadialFourier = IntSimpson(n,h,x) DeAllocate(x) return End Function !****************************************************************************** ! ! SphereBessel - Calculates the Sphereical Bessel function of order Lval, ! jl(x), at the given x(i) positions ! ! Ndim - Number of grid points ! X - On input this contains the positions where to calculate jl(x) ! On output x contains the tabulated jl ! !****************************************************************************** Subroutine SphereBessel(lval,ndim,x) Integer, Intent(IN) :: lval Integer, Intent(IN) :: ndim Real, Intent(INOUT) :: x(ndim) Integer :: it,lll,l,n,il Real :: z,bs,bs0,bs1,xx,z2,arg,sum Real, parameter :: tol=1.e-11 do it=1,ndim z=x(it) if(z.le.0.5) then ! series expansion for small arguments if (z.le.tol) then ! - special treatment if z = 0 bs=0.d0 if(lval.eq.0) bs=1.d0 else lll=2*lval+1 xx=1.d0 do l=1,lll,2 xx=xx*l end do z2=0.5d0*z*z lll=lll+2 arg=-z2/lll sum=1.d0+arg do n=2,500 lll=lll+2 arg=-arg*z2/(n*lll) sum=sum+arg if (abs(arg).le.tol) exit end do bs=(z**lval)*sum/xx end if else ! -- trigometric form bs=sin(z)/z if (lval.gt.0) then bs0=bs bs=(bs0-cos(z))/z if (lval.gt.1) then bs1=bs do il=2,lval bs=(2*il-1)*bs1/z-bs0 bs0=bs1 bs1=bs end do end if end if end if if (ABS(bs)<1D-50) bs = 0 x(it)=bs end do Return End Subroutine !****************************************************************************** ! ! DerivSphereBessel - Calculates the Derivative of Spherical Bessel ! function of order Lval, d jl(x), at the given x(i) positions ! ------- ! dx ! ! Ndim - Number of grid points ! X - On input this contains the positions where to calculate d jl(x)/dx ! On output x contains the tabulated d jl/dx ! ! !****************************************************************************** Subroutine DerivSphereBessel(lval,ndim,x) Integer, Intent(IN) :: lval Integer, Intent(IN) :: ndim Real, Intent(INOUT) :: x(ndim) Integer :: it,lll,l,n,il Real :: z,bs,bs0,bs1,xx,z2,arg,sum,db,bsm Real, parameter :: tol=1.e-11 do it=1,ndim z=x(it) if(z.le.0.5) then ! series expansion for small arguments if (z.le.tol) then ! - special treatment if z = 0 db=0.d0 if(lval.eq.0) db=1.d0/3 else lll=2*lval+1 xx=1.d0 do l=1,lll,2 xx=xx*l end do If (lval == 0) then sum=0 Else sum=lval*(z**(lval-1))/xx endIf lll=lll+2 xx=xx*lll arg=-(z**(lval+1))/(2*xx) sum=sum+(lval+2)*arg z2=z*z do n=2,500 lll=lll+2 arg=-arg*z2/(2*n*lll) sum=sum+(lval+2*n)*arg if ((lval+2*n)*abs(arg).le.tol) exit end do db=sum end if else ! -- trigometric form bs=sin(z)/z bsm=cos(z)/z if (lval.gt.0) then bsm=bs bs=(bsm-cos(z))/z if (lval.gt.1) then bs0=bsm bsm=bs do il=2,lval bs=(2*il-1)*bsm/z-bs0 bs0=bsm bsm=bs end do bsm=bs0 end if end if db=bsm-(lval+1)*bs/z end if if (ABS(db) 0) THEN fact=1 do i=1,m pmm=-pmm*fact*somx2 dpmm=-dpmm*fact fact=fact+2 ENDDO IF(m>1)THEN DO i=2,m dosomx2=dosomx2*somx2 END DO END IF dpmm= dpmm*m*x*dosomx2 ENDIF IF(l==m) THEN Der_Theta_P=dpmm ELSE pmmp1=x*(2*m+1)*pmm dpmmp1=-(2*m+1)*somx2*pmm+x*(2*m+1)*dpmm IF(L==m+1) THEN Der_Theta_P=dpmmp1 ELSE do ll=m+2,L pll=(x*(2*ll-1)*pmmp1-(ll+m-1)*pmm)/(ll-m) dpll=(-somx2*(2*ll-1)*pmmp1+(x*(2*ll-1)*dpmmp1-(ll+m-1)*dpmm))/(ll-m) pmm=pmmp1 pmmp1=pll dpmm=dpmmp1 dpmmp1=dpll ENDDO Der_Theta_P=dpll ENDIF ENDIF END function Der_Theta_P !****************************************************************************** ! Function Der_Phi_P(L,m,x) ! From Numerical Recipes, 2nd. Edition, pg. 247 ! Implimented by Yonas Abraham ! m ! This function is modified to return m*P_l(x)/sqrt((1-x^2)) !***************************************************************************** REAL Function Der_Phi_P(L,m,x,Error_Unit) IMPLICIT None INTEGER, Intent(IN) :: L,m Real, Intent(IN) :: x INTEGER, Optional, Intent(IN) :: Error_Unit REAL :: fact,pll,pmm,pmmp1,somx2,dosomx2 INTEGER :: i, ll IF (m.lt.0.or.m.gt.L.or.abs(x).gt.1.0) THEN If (Present(Error_Unit)) then WRITE(Error_Unit,*) 'error in Der_Phi_P',m,x Else WRITE(*,*) 'error in Der_Phi_P',m,x EndIf STOP ENDIF Der_Phi_P=0 If (m==0) return pmm=1 dosomx2=1 IF (m > 0) then somx2=sqrt((1-x)*(1+x)) fact=1 DO i=1,m pmm=-pmm*fact fact=fact+2 ENDDO If (m > 1) then DO i=2,m dosomx2=somx2*dosomx2 END DO EndIf pmm=pmm*dosomx2 !due to one more term (-1^M) ENDIF IF(L==m) THEN Der_Phi_P=pmm*m ELSE pmmp1=x*(2*m+1)*pmm IF(L==m+1) THEN Der_Phi_P=pmmp1*m ELSE DO ll=m+2,L pll=(x*(2*ll-1)*pmmp1-(ll+m-1)*pmm)/(ll-m) pmm=pmmp1 pmmp1=pll ENDDO Der_Phi_P=pll*m ENDIF ENDIF END function Der_Phi_P !****************************************************************************** ! ! subroutine Lininterp -- performs linear interpolation of numerical ! function on uniform grid ! ! fgrid(i) is tabulated at n points corresponding to argument i*h ! It is assumed that fgrid(1)==fgrid(0) and fofx is returned as 0 for x>n*h ! !****************************************************************************** Subroutine Lininterp(n,h,fgrid,x,fofx) Integer, intent(IN) :: n Real, intent(IN) :: h,fgrid(n),x Real, intent(OUT) :: fofx Real :: x1 Integer :: i x1=x/h i=x1+1 if (i.lt.1) then fofx=fgrid(1) else if (i.gt.n-1) then fofx=0.d0 else fofx=(x1+1-i)*fgrid(i+1)+(i-x1)*fgrid(i) endif End Subroutine Lininterp !****************************************************************************** ! Extrapto0 - performs a 2-point extrapolation to zero !****************************************************************************** Real Function Extrapto0(f1,f2) Real, Intent(IN) :: f1,f2 !! f(h), f(2h) Extrapto0 = 2*f1 - f2 End Function Extrapto0 !****************************************************************************** ! ! EvalPoly - Evaluates a polynomial at the given position ! ! N - Degree of polynomial ! Poly - List of coefficients. Poly(1) = constant, Poly(2)=c1*x, etc ! x - Position ! !****************************************************************************** Real Function EvalPoly(n, poly, x) Integer, Intent(IN) :: n Real, Intent(IN) :: Poly(:) Real, Intent(IN) :: x Integer :: i Real :: fn, term fn = poly(n+1) Do i=n, 1, -1 fn = fn*x + poly(i) End Do EvalPoly = Fn Return End Function !****************************************************************************** ! ! File : roots.f90 ! on : 7/31/95 ! by : Alan Tackett ! for : Misc. Math routines ! ! ! This module contains several routines for finding and bracketing a root of ! of a 1-D function. The two main methods are: ! ! rt_Brent - Which doesn't use derivatives and combines ! Secant and Bisection methods so give ~quad convergence ! rt_newton - Does use derivatives and combines Newton-Raphson and ! Bisection. ! ! Two routines exist for bracketing a root : ! ! brak_grow - Takes an initial interval and expands it until an ! interval containing a root is located ! brak_Shrink - Takes an initial interval and subdivides it into ! smaller intervals and checks them for roots. ! !****************************************************************************** !****************************************************************************** ! ! Checkbounds - Checks to make sure the xmin and xmax values bound a root ! ! FitFunc - External, user-supplied routine that calculates the value ! of the function and its 1st derivative at a point. It ! has the following form ! Double Precision FitFunc(x, fn, deriv) ! where all arguments are double precision. The Return value ! is ignored. ! xmin, xmax - Root bounds. Automatically swaps xmin and xmax if ! f(xmin)>f(xmax) ! ! Return Values ! Returns .TRUE. if a root is bounded and .FALSE. otherwise. ! !****************************************************************************** Logical Function CheckBounds(FitFunc, xmin, xmax) Real, External :: FitFunc Real, Intent(INOUT) :: xmin Real, Intent(INOUT) :: xmax Logical :: ok Real :: junk Real :: f1, f2 Real :: df1, df2 junk = FitFunc(xmin, f1, df1) junk = FitFunc(xmax, f2, df2) if ((f1<0) .AND. (f2>0)) then ok = .TRUE. else if ((f1>0) .AND. (f2<0)) then ok = .TRUE. junk = xmin xmin = xmax xmax = junk else ok = .FALSE. end if CheckBounds = ok Return End Function !****************************************************************************** ! ! brak_grow - Expands an inital interval until a root is bracketed or ! the range becomes unacceptably large. ! ! Func - Function for finding the root. Has the form ! Double Precision Func(Double Precision x) ! x1, x2 - Initial interval, Root Brackets(RETURNED) ! NumEval - (OPTIONAL) Returns the number of function evaluations ! ! Return Values ! brak_grow returns 1 if a root was successfully found and 0 otherwise ! ! !****************************************************************************** Integer Function Brak_Grow(Func, x1, x2, NumEval) Real, External :: Func Real, Intent(INOUT) :: x1 Real, Intent(INOUT) :: x2 Integer, Optional, Intent(OUT) :: NumEval Integer, PARAMETER :: NTRY = 50 Real, PARAMETER :: FACTOR = 1.6 integer :: j, NE Real :: f1, f2 f1 = Func(x1) f2 = Func(x2) NE = 2 j = 1 Do While ((f1*f2>=0) .AND. (j0) then write(*,*) 'Root Not Bracketed in [',a,b, ']' write(*,*) ' with function values [',fa,fb,']' rt_Brent = x1 Return End If fc = fb Finished = .FALSE. i = 0 Do While ((.NOT. Finished) .AND. (i<=MaxIter)) i = i + 1 if (fb*fc>0) then !*** Rename a,b,c and adjust c = a !*** Bounding interval d fc = fa e = b - a; d = e; End If if (ABS(fc) < ABS(fb)) then a=b; b=c; c=a; fa=fb; fb=fc; fc=fa; End If tol1 = 2*eps + 0.5 * tol xm = 0.5 * (c-b) if ((ABS(xm) <= tol1) .OR. fb == 0.0) then !*** Check Convergence *** Finished = .TRUE. rt = b End If if ((ABS(e) >= tol1) .AND. (ABS(fa)>ABS(fb))) then !*** Try inv quad interp s = fb / fa if (a == c) then p = 2 * xm * s q = 1 - s else q = fa/fc r = fb/fc p = s * (2*xm*q*(q-r) - (b-a)*(r-1)) q = (q-1) * (r-1) * (s-1) End If if (p>0) q = -q !*** Check whether in bounds p = abs(p) min1 = 3*xm*q - ABS(tol1*q) min2 = ABS(e*q) if (2*p < MIN(min1, min2)) then e = d !*** Accept Step d = p/q else d = xm !** Step failed, use bisection e = d End If else !** Bounds decreasing slowly, use bisection d=xm e=d End If a=b; fa=fb; !** Move last guess to a if (ABS(d)>tol1) then !** Evaluate new trial root b = b + d else b = b + SIGN(tol1, xm) End If fb = Func(b) NE = NE + 1 End Do rt_Brent = rt if (PRESENT(NumEval)) NumEval = NE Return End Function !****************************************************************************** ! rt_Newton - Newton-Raphson with Bisection. Returns the fn root . ! ! FitFunc - External, user-supplied routine that calculates the value ! of the function and its 1st derivative at a point. It ! has the following form ! Double Precision FitFunc(x, fn, deriv) ! where all arguments are double precision. The Return value is ! ignored. ! ! xmim, ! xman - Min and Max values of x that bracket the root. Automatically ! swapped if F(xmin)>F(xmax) ! xacc - Accuracy of root requested ! MAXITER - Max number of iterations to perform ! NumEval - (OPTIONAL) Returns the number of function evaluations ! !****************************************************************************** Real Function rt_Newton(FitFunc, xmin, xmax, xacc, MaxIter, NumEval) Real, External :: FitFunc Real, Intent(INOUT) :: xmin Real, Intent(INOUT) :: xmax Real, Intent(IN) :: xacc Integer, Intent(IN) :: MaxIter Integer, Optional, Intent(OUT):: NumEval Logical :: Finished Integer :: j, k, NE Real :: df, dx, dxold, f, fhigh, flow Real :: temp, xhigh, xlow, rts Finished = CheckBounds(FitFunc, Xmin, Xmax) if (.NOT. Finished) then write(*,*) 'Root Not Bracketed in [',Xmin, Xmax, ']' rt_Newton = Xmin Return End If xlow = xmin xhigh = xmax rts = 0.5 * (xlow+xhigh) dxold = ABS(xhigh-xlow) k = FitFunc(rts, f, df) NE = 1 j = 0 Finished = .FALSE. Do While ((j=0) .OR. & (abs(2.0*f)>abs(dxold*df))) then !** Bisect if out of range dxold = dx dx = 0.5 * (xhigh-xlow) rts = xlow + dx if (xlow == rts) Finished = .TRUE. else !** Do a Newton step ** dxold = dx dx = f / df temp = rts rts = rts - dx if (temp == rts) Finished = .TRUE. End If if (abs(dx) < xacc) Finished = .TRUE. k = FitFunc(rts, f, df) NE = NE + 1 if (f < 0) then !** Maintain Root bracket xlow = rts else xhigh = rts End If End Do rt_Newton = rts if (PRESENT(NumEval)) NumEval = NE Return End Function !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Subroutine xyztosphericalpolar(x,y,z,r,theta,phi) ! ! subroutine to transform between cartesian and spherical polar coordinates ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Subroutine xyztosphericalpolar(x,y,z,r,theta,phi) Real , intent(IN) :: x,y,z Real , intent(OUT) :: r,theta,phi Real, parameter :: tol=1.e-13 Real :: Pi Pi=acos(-1.0) r=0 theta=0 phi=0 r=sqrt(x*x+y*y+z*z) If (r < tol) return theta=ACOS(z/r) If (ABS(x) < tol .AND. ABS(y) < tol) then Phi = 0 ElseIf (ABS(x)< tol .AND. ABS(y) >= tol) then If ( y >= 0 ) Phi=Pi/2 If ( y < 0 ) Phi=3*Pi/2 ElseIf (ABS(y)< tol .AND. ABS(x) >= tol) then If (x >=0 ) Phi=0 If (x < 0 ) Phi=Pi Else Phi=ATAN(y/x) If (Phi < 0 ) Phi=Phi+Pi If (y < 0 ) Phi=Phi+Pi EndIf Return End subroutine !*********************************************************************************************** ! subroutine ddet5(h,y,z,ndim) ! ssp routine modified by nawh 6/8/76 !!!! implicit real*8 (a-h,o-z) !*********************************************************************************************** subroutine Real_nderiv(h,y,z,ndim) integer, intent(IN) :: ndim real, intent(IN) :: h,y(ndim) real, intent(OUT) :: z(ndim) real :: hh,yy,a,b,c integer :: i,ier ! prepare differentiation loop hh=.08333333333333333d0/h yy=y(ndim-4) b=hh*(-25.d0*y(1)+48.d0*y(2)-36.d0*y(3)+16.d0*y(4)-3.d0*y(5)) c=hh*(-3.d0*y(1)-10.d0*y(2)+18.d0*y(3)-6.d0*y(4)+y(5)) ! ! start differentiation loop do i=5,ndim a=b b=c c=hh*(y(i-4)-y(i)+8.d0*(y(i-1)-y(i-3))) z(i-4)=a enddo ! end of differentiation loop ! ! normal exit ier=0 a=hh*(-yy+6.d0*y(ndim-3)-18.d0*y(ndim-2)+10.d0*y(ndim-1) & +3.d0*y(ndim)) z(ndim)=hh*(3.d0*yy-16.d0*y(ndim-3)+36.d0*y(ndim-2) & -48.d0*y(ndim-1)+25.d0*y(ndim)) z(ndim-1)=a z(ndim-2)=c z(ndim-3)=b ! end subroutine !*********************************************************************************************** ! subroutine ddet5(h,y,z,ndim) ! ssp routine modified by nawh 6/8/76 !!!! implicit real*8 (a-h,o-z) !*********************************************************************************************** subroutine Complex_nderiv(h,y,z,ndim) integer, INTENT(IN) :: ndim real, INTENT(IN) :: h complex, INTENT(IN) :: y(ndim) complex, INTENT(OUT) :: z(ndim) complex :: yy,a,b,c real :: hh integer :: i,ier ! prepare differentiation loop hh=.08333333333333333d0/h yy=y(ndim-4) b=hh*(-25.d0*y(1)+48.d0*y(2)-36.d0*y(3)+16.d0*y(4)-3.d0*y(5)) c=hh*(-3.d0*y(1)-10.d0*y(2)+18.d0*y(3)-6.d0*y(4)+y(5)) ! ! start differentiation loop do i=5,ndim a=b b=c c=hh*(y(i-4)-y(i)+8.d0*(y(i-1)-y(i-3))) z(i-4)=a enddo ! end of differentiation loop ! ! normal exit ier=0 a=hh*(-yy+6.d0*y(ndim-3)-18.d0*y(ndim-2)+10.d0*y(ndim-1) & +3.d0*y(ndim)) z(ndim)=hh*(3.d0*yy-16.d0*y(ndim-3)+36.d0*y(ndim-2) & -48.d0*y(ndim-1)+25.d0*y(ndim)) z(ndim-1)=a z(ndim-2)=c z(ndim-3)=b ! end subroutine !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Subroutine MatrixInverse123(MM,IM) Real, INTENT(IN) :: MM(:,:) REAL, INTENT(OUT) :: IM(:,:) Integer :: i,j,k Real :: det i=SIZE(MM,1) j=SIZE(MM,2) if (i /= j) then write(*,*) '123MatrixInverse: Error -- matrix not square',& i,j stop endif If (i == 1) then IM(1,1)=1.0/MM(1,1) else if (i==2) then det=MM(1,1)*MM(2,2)-MM(1,2)*MM(2,1) IM(1,1)=MM(2,2)/det IM(2,2)=MM(1,1)/det IM(1,2)=-MM(1,2)/det IM(2,1)=-MM(2,1)/det else if (i==3) then det=MM(1,1)*(MM(2,2)*MM(3,3)-MM(2,3)*MM(3,2))+& MM(1,2)*(MM(2,3)*MM(3,1)-MM(2,1)*MM(3,3))+& MM(1,3)*(MM(2,1)*MM(3,2)-MM(2,2)*MM(3,1)) IM(1,1)=(MM(2,2)*MM(3,3)-MM(2,3)*MM(3,2))/det IM(1,2)=(MM(1,3)*MM(3,2)-MM(1,2)*MM(3,3))/det IM(1,3)=(MM(1,2)*MM(2,3)-MM(1,3)*MM(2,2))/det IM(2,1)=(MM(2,3)*MM(3,1)-MM(2,1)*MM(3,3))/det IM(2,2)=(MM(1,1)*MM(3,3)-MM(1,3)*MM(3,1))/det IM(2,3)=(MM(1,3)*MM(2,1)-MM(1,1)*MM(2,3))/det IM(3,1)=(MM(2,1)*MM(3,2)-MM(2,2)*MM(3,1))/det IM(3,2)=(MM(1,2)*MM(3,1)-MM(1,1)*MM(3,2))/det IM(3,3)=(MM(1,1)*MM(2,2)-MM(1,2)*MM(2,1))/det else Write(*,*) 'MatrixInverse123: Error -- matrix too large', i stop endif End Subroutine MatrixInverse123 ! subroutine to input number f and output shifted value such that ! -1/2 < f <= 1/2 subroutine fixhalfrange(f) real(8), INTENT(INOUT) :: f do if ( f < -0.5d0) then f=f+1.d0 else exit endif enddo do if ( f >= 0.5d0) then f=f-1.d0 else exit endif enddo end subroutine fixhalfrange End Module spinpwpaw/code/mem_data.f900100664004704100470410000002011210334664227015737 0ustar natalienatalie!****************************************************************************** ! ! File : mem_data.f90 ! by : Alan Tackett ! on : 04/27/97 ! for : PAW Project ! ! Contains the Data structures and constants for use by the MemMgr, Projector, ! and Psi modules ! ! Updated for spin by Ping Tang and N. A. W. Holzwarth ! Last change 5/23/05 !****************************************************************************** Module mem_data Use misc Use paw_inout Use anderson_mixing Implicit NONE!!!!!!!!!!!!!!!!!!! Integer, PARAMETER :: SIZEOF_C = 16 Integer, PARAMETER :: SIZEOF_COMPLEX = 16 Integer, PARAMETER :: SIZEOF_REAL = 8 Integer, PARAMETER :: BG_KPNT = -3 !** Special processing index !*Mem_Handle constants for *_toProcess, *_Processsed, *_UnProcessed variables * Integer, PARAMETER :: MH_PROCESSED = 0 !** Vec processed Integer, PARAMETER :: MH_toPROCESS = 1 !** To be Processed Integer, PARAMETER :: MH_SKIP = 0 !** Ignore or skip vec Integer, PARAMETER :: MH_UnProcessed = 1 !** Vec currently not processed Integer, PARAMETER :: Mem_Available = 1 !** Memory slot available Integer, PARAMETER :: Mem_Used = 0 !** Memory slot used Real :: MemSize !** Amount of buffer size in Mbytes Integer :: MemWords !** Size of buf in Complex*16 units Integer :: MemFree !** Amount of free space Integer :: BaseFree !** Size of buffer w/o V Type Cache_Handle !** Cache data structure Integer :: Hits Integer :: Misses Integer :: Total End Type Type Mem_Cache !** Cache Data structure Type (Cache_handle) :: Psi_Read Type (Cache_handle) :: Psi_Write End Type Type(Mem_Cache), Pointer :: MemCache Type Mem_handle !*** Memory Allocation Handle *** Integer :: Index !** Data Index, PsiInfo number Complex, Pointer :: Ptr(:) !** Pointer to data End Type Type global_handle !*** Memory Allocation for set of data *** Integer :: NumPsi !** Number of Psi's alloc Integer :: PsiLoaded !** Number of Psi's loaded Type (Mem_Handle), Pointer :: PSI_handle(:) !** PSI memory handles End Type Type (global_Handle), Pointer :: Globalmap Integer, Pointer :: Psi_Processed(:) !**LUT denoting which psi have been used Integer, Pointer :: Psi_toProcess(:) !** LUT of Psi's to process(=0) Integer, Pointer :: PsiBand_toProcess(:) Integer, Pointer :: ClusterMap(:) !** LUT determining eigenvalue clusters Integer, Pointer :: ClusterSize(:) !** Size of each cluster Integer :: LastCLuster !** Last cluster used Integer :: Mem_Kpnt Type Potential_handle !** Potential Handle ** Complex, Pointer :: Ve(:),Vespin(:) !** Veff in real space Complex, Pointer :: Work(:) !** Work array Complex, Pointer :: V_local(:) !** Local Potential Complex, Pointer :: Ve_Fourier(:),Ve_Fourierspin(:) !** Veff in Fourier Space Complex, Pointer ::cVe_F(:),cVe_Fspin(:) !** current Veff in Fourier Space ! not from Anderson mix Complex, Pointer :: RhoSmooth(:),RhoSmoothspin(:) !** Smooth, n~, charge density Complex, Pointer :: RhoHat(:) !** n^ charge density Complex, Pointer :: CoreTail(:) !** Coretail density Complex, Pointer :: VXC(:),VXCSPIN(:) !** VXC in Fourier Space Type (Anderson_Context), Pointer :: AC, ACspin End Type Type (Potential_handle), Pointer,save :: SCFvalues !** Potential ptr's Type BufferPtr !*** Temp Buffer Ptr Complex, Pointer :: Ptr(:) End Type Type (BufferPtr), Pointer :: WorkPtr(:) Type PsiEigen_Handle !** Contains info about how the eigen maps to the BZ data Integer :: Kpnt !** Kpnt the Psi maps to Logical :: Spinup !** used for spin polarized calculation Integer :: DoSave !** 1 if wavefunction should be saved to disk Integer :: Available !** Tracks availability of virtual memory slot Integer :: CorrIndex !** Correction index Integer :: OxIndex !** Ox disk index Integer :: MemBufIndex !** Memory buffer index Real :: Occupancy !** Original occupancy REal :: Energy !** Energy eigen value of the Psi Real :: KE !** Kinetic energy for band Real :: Error !** Error in Hx-eOx Logical :: PDOT_Stored Logical :: KE_Stored Complex, Pointer :: PDOT(:) End Type Type (PsiEigen_Handle), Pointer :: PsiInfo(:) !** LUT for psi info Integer :: TotalPsi !** Total Number of Psi's (Psi_bands*Psi_Kpnts) Integer :: Mem_MaxPsi !** Max number of Psi's per K-pnt. Integer :: ExtraPsi !** Min number of extra Psi's Integer :: MinBands !** Min Num of bands to have(NumBands+ExtraPsi) Integer :: Mem_MapSize !** LUT, and Map allocated size Integer :: PsiArraySize !** Array size for each Psi(G) !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! GetNextIndex_toProcess - Returns the next index to be processed. ! ! Index - The value of Index on entry determines the first index ! for looking for a valid index to process. On exit INDEX ! contains the next index to process or 0 if no ! more Indices were found. ! toProcess - Array containing 1's for Indices to process and 0's for ! indices to skip. NOTE: This array is not modified in any way!! ! !****************************************************************************** Subroutine GetNextIndex_toProcess(Index, toProcess) Integer, Intent(INOUT) :: Index Integer, Intent(INOUT) :: toProcess(:) Index=1 Do While ((toProcess(Index) /= MH_toProcess) .AND. (Index <= Mem_MapSize)) index = Index + 1 End Do If (Index > Mem_MapSize) Index=0 Return End Subroutine !****************************************************************************** ! ! Swap_Mem_Handle - Swaps two memory handles ! ! MH1, MH2 - The 2 handles to swap ! !****************************************************************************** Subroutine Swap_Mem_Handles(MH1, MH2) Type (Mem_Handle), Intent(INOUT) :: MH1 Type (Mem_Handle), Intent(INOUT) :: MH2 Type (Mem_Handle) :: Temp Temp%Index = MH1%Index; Temp%Ptr => MH1%Ptr MH1%Index = MH2%Index; MH1%Ptr => MH2%Ptr MH2%Index = Temp%Index; MH2%Ptr => Temp%Ptr Return End Subroutine !****************************************************************************** ! ! CanAlloc - checks to see if it is possible to allocate the extra space ! for a Psi ! ! LSize - Ptr size ! !****************************************************************************** Logical Function CanAlloc( LSize) Integer, Intent(IN) :: LSize Logical :: Ok Ok = .FALSE. If (((MemFree - LSize) > 0) .AND. & (Globalmap%Numpsi Globalmap LH%NumPsi = LH%NumPsi+1; MH1 => LH%Psi_handle(LH%NumPsi) Allocate(MH1%Ptr(LSize), STAT=k) Write(msg,*) 'AllocMemHandle: Could Not allocate Psi buffer!', & ' * Size:',LSize Call Check_Error(k, msg, Error_Unit, .TRUE.,paw_wc, "AllocMemHandle:") MH1%Index = 0 MemFree = MemFree - LSize slot = LH%NumPsi Return End Subroutine End Module spinpwpaw/code/memmgr.f900100664004704100470410000005236010334664237015467 0ustar natalienatalie!****************************************************************************** ! ! File : memmgr.f90 ! by : Alan Tackett ! on : 04/26/97 ! for : PAW project ! ! This module contains routines for controlling the memory allocation and ! distribution between the projectors, psi's, and FAS vectors ! ! Updated for spin by Ping Tang and N. A. W. Holzwarth ! Last change 5/23/05 !****************************************************************************** Module memmgr Use mem_data Use paw_inout Use projectors Use psilib Use options_data Use anderson_mixing Implicit NONE!!!!!!!!!!!!! !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! GetNextFreeIndex - Returns the next free Psi index ! ! Index - Free record returned ! !****************************************************************************** Subroutine GetNextFreeIndex(Index) Integer, Intent(OUT) :: Index Real :: mag Index = 1 Do While ((Index <= Mem_MapSize) .AND. & (PsiInfo(Index)%Available==Mem_Used)) Index = Index + 1 End Do If (Index > Mem_MapSize) then Write(Error_Unit,*) 'GetNextFreeIndex: Mem_MapSize=',Mem_MapSize, & ' * New Index=',Index Write(Log_Unit,*) 'GetNextFreeIndex: Mem_MapSize=', & Mem_MapSize, ' * New Index=',Index Call Flush(Error_Unit) Call Flush(Log_Unit) stop mag = 0 mag = 1.0/mag End If Return End Subroutine !****************************************************************************** ! ! MemUsed - Calculates the amount of memory ! ! TotalUsed - Total Memory Used ,ie, ProjUsed+PsiUsed ! ProjUsed - Projector memory used ! PsiUsed - Psi memory used ! !****************************************************************************** Subroutine MemUsed( TotalUsed) Integer, intent(OUT) :: TotalUsed Integer :: LSize Type (Global_handle), Pointer :: LH LSize = PsiArraySize LH => Globalmap TotalUsed = LH%NumPsi*LSize Return End Subroutine !****************************************************************************** ! ! DisplayBufferInfo - Displays the Buffer Information to the specified device ! ! Output - Output unit ! !****************************************************************************** Subroutine DisplayBufferInfo(Output) Integer, Intent(IN) :: OutPut Integer :: i, j, LSize Integer :: Mem_Proj, Mem_Psi, Calc_Proj,Calc_Psi Integer :: TotalMem Type (Global_handle), Pointer :: LH Type (Mem_handle), Pointer :: MH(:), MH2(:) Integer :: CacheTotal, CacheHits, CacheMisses Real :: Hits, miss, total Write(output, *) 'BUFFER_INFO: Printing Psi buffer info ********************' Write(output, *) 'Max Records :', Mem_MapSize TotalMem = 0 LH => Globalmap LSize = PsiArraySize Write(Output, *) 'Buffer info * Base Size:',LSize Write(Output, *) ' Allocated Psi:',LH%NumPsi Write(Output, *) ' Loaded Psi:',LH%PsiLoaded Call MemUsed(TotalMem) Write(Output, *) ' Memory Total:',TotalMem Write(Output,*) ' Cache Statistics: ' CacheTotal = MemCache%Psi_Read%Hits + MemCache%Psi_Read%Misses Write(Output,*) ' *Psi Read* Total:',CacheTotal, & ' * Hits:',MemCache%Psi_Read%Hits, & ' * Misses:',MemCache%Psi_Read%Misses CacheTotal = MemCache%Psi_Write%Hits + MemCache%Psi_Write%Misses Write(Output,*) ' *Psi Write* Total:',CacheTotal, & ' * Hits:',MemCache%Psi_Write%Hits, & ' * Misses:',MemCache%Psi_Write%Misses CacheTotal = MemCache%Psi_Read%Hits + MemCache%Psi_Read%Misses & + MemCache%Psi_Write%Hits + MemCache%Psi_Write%Misses CacheHits = MemCache%Psi_Read%Hits + MemCache%Psi_Write%Hits CacheMisses = MemCache%Psi_Read%Misses + MemCache%Psi_Write%Misses Write(Output,*) ' *Psi Both* Total:',CacheTotal, & ' * Hits:',CacheHits, ' * Misses:',CacheMisses Total = MemCache%Psi_Read%Hits + MemCache%Psi_Read%Misses if (Total > 0) then hits = (1.0*MemCache%Psi_Read%Hits)/total miss = (1.0*MemCache%Psi_Read%Misses)/total Write(Output,*) ' *Psi Read* %Hits:',Hits, ' * %Misses:',Miss End If Total = MemCache%Psi_Write%Hits + MemCache%Psi_Write%Misses if (Total > 0) then hits = (1.0*MemCache%Psi_Write%Hits)/total miss = (1.0*MemCache%Psi_Write%Misses)/total Write(Output,*) ' *Psi Write* %Hits:',Hits, ' * %Misses:',Miss End If Total = MemCache%Psi_Read%Hits + MemCache%Psi_Read%Misses & + MemCache%Psi_Write%Hits + MemCache%Psi_Write%Misses if (Total > 0) then Hits = MemCache%Psi_Read%Hits + MemCache%Psi_Write%Hits Miss = MemCache%Psi_Read%Misses+ MemCache%Psi_Write%Misses hits = Hits/total miss = Miss/total Write(Output,*) ' *Psi Both* %Hits:',Hits, ' * %Misses:',Miss End If Write(Output, *) ' Psi Data : Buffer, Disk, Store' MH => LH%Psi_handle !! Do j=1, LH%NumPsi !! If (j<=LH%PsiLoaded) then !! Write(Output, *) ' PSI:', j, ' * ',MH(j)%Index,' * ', Size(MH(j)%Ptr) !! else !! Write(Output, *) ' # PSI:', j, ' * ',MH(j)%Index,' * ', Size(MH(j)%Ptr) !! End If !! !!!** Write(Output, *) ' Psi=',MH(j)%Ptr !! End Do Write(Output,*) 'Total Memory--> Max:', MemWords, ' * BaseFree:',BaseFree, ' * Used:', TotalMem, ' * Free:', MemFree Write(Output,*) ' Overall Cache Statistics (Unweighted): ' CacheHits = MemCache%Psi_Read%Hits CacheMisses = MemCache%Psi_Read%Misses CacheTotal = CacheHits + CacheMisses Write(Output,*) ' *Psi Read* Total:',CacheTotal, & ' * Hits:',CacheHits, & ' * Misses:',CacheMisses CacheHits = MemCache%Psi_Write%Hits CacheMisses = MemCache%Psi_Write%Misses CacheTotal = CacheHits + CacheMisses Write(Output,*) ' *Psi Write* Total:',CacheTotal, & ' * Hits:',CacheHits, & ' * Misses:',CacheMisses CacheHits = MemCache%Psi_Write%Hits + MemCache%Psi_Read%Hits CacheMisses = MemCache%Psi_Write%Misses+ MemCache%Psi_Read%Misses CacheTotal = CacheHits + CacheMisses Write(Output,*) ' *Psi Both* Total:',CacheTotal, & ' * Hits:',CacheHits, & ' * Misses:',CacheMisses !**** %Psi hits/miss ***** Hits = MemCache%Psi_Read%Hits Miss = MemCache%Psi_Read%Misses Total = Hits + Miss If (Total > 0) then Hits = Hits/Total Miss = Miss/Total Write(Output,*) ' *Psi Read* %Hits:',Hits, ' * %Misses:',Miss End IF Hits = MemCache%Psi_Write%Hits Miss = MemCache%Psi_Write%Misses Total = Hits + Miss if (Total > 0) then Hits = Hits/Total Miss = Miss/Total Write(Output,*) ' *Psi Write* %Hits:',Hits, ' * %Misses:',Miss End If Hits = MemCache%Psi_Read%Hits + MemCache%Psi_Write%Hits Miss = MemCache%Psi_Read%Misses + MemCache%Psi_Write%Misses Total = Hits + Miss if (Total > 0) then Hits = Hits/Total Miss = Miss/Total Write(Output,*) ' *Psi Both* %Hits:',Hits, ' * %Misses:',Miss End If !----------------------------------------- Write(Output,*) ' Overall Cache Statistics (Weighted): ' CacheHits = MemCache%Psi_Read%Hits CacheMisses = MemCache%Psi_Read%Misses CacheTotal = CacheHits + CacheMisses Write(Output,*) ' *Psi Read* Total:',CacheTotal, & ' * Hits:',CacheHits, & ' * Misses:',CacheMisses CacheHits = MemCache%Psi_Write%Hits CacheMisses = MemCache%Psi_Write%Misses CacheTotal = CacheHits + CacheMisses Write(Output,*) ' *Psi Write* Total:',CacheTotal, & ' * Hits:',CacheHits, & ' * Misses:',CacheMisses CacheHits = (MemCache%Psi_Write%Hits + MemCache%Psi_Read%Hits ) CacheMisses = (MemCache%Psi_Write%Misses+MemCache%Psi_Read%Misses) CacheTotal = CacheHits + CacheMisses Write(Output,*) ' *Psi Both* Total:',CacheTotal, & ' * Hits:',CacheHits, & ' * Misses:',CacheMisses !**** %Psi hits/miss ***** Hits = MemCache%Psi_Read%Hits Miss = MemCache%Psi_Read%Misses Total = Hits + Miss if (Total > 0) then Hits = Hits/Total Miss = Miss/Total Write(Output,*) ' *Psi Read* %Hits:',Hits, ' * %Misses:',Miss End If Hits = MemCache%Psi_Write%Hits Miss = MemCache%Psi_Write%Misses Total = Hits + Miss if (Total > 0) then Hits = Hits/Total Miss = Miss/Total Write(Output,*) ' *Psi Write* %Hits:',Hits, ' * %Misses:',Miss End If Hits = (MemCache%Psi_Read%Hits + MemCache%Psi_Write%Hits) Miss = (MemCache%Psi_Read%Misses + MemCache%Psi_Write%Misses) Total = Hits + Miss if (Total > 0) then Hits = Hits/Total Miss = Miss/Total Write(Output,*) ' *Psi Both* %Hits:',Hits, ' * %Misses:',Miss End IF If (MemFree < 0) then Write(Error_Unit, *) 'DisplayBufferInfo: Memory Error!!! Memory Free:',MemFree End If Write(Output,*) '*********************************************************' Call Flush(OutPut) Return End Subroutine !****************************************************************************** ! ! Mem_AllocBuffers - Ensures that the required ! number of buffers are available. ! ! MH - Mem_handle array ! CurrSize - Current number of buffers allocated(RETURNED) ! NewSize - Number of buffers wanted ! !****************************************************************************** Subroutine Mem_AllocBuffers( MH, CurrSize, NewSize) Type (Mem_Handle), Pointer :: MH(:) Integer, Intent(INOUT) :: CurrSize Integer, intent(IN) :: NewSize Integer :: i, k Integer :: LSize Character*100 :: msg LSize = PsiArraySize !write(*,*) 'mem_allocbuffer: Size(MH) = ',size(MH), ' * CurrSize=',CurrSize, ' * NewSize=',NewSize Do i = CurrSize+1, NewSize Allocate(MH(i)%Ptr(LSize), STAT=k) Write(msg,*) 'Mem_AllocBuffers: Could Not allocate buffer!', & ' * Size:',LSize Call Check_Error(k, msg, Error_Unit, .TRUE.,paw_wc, "Mem_AllocBuffers:") MH(i)%Index = 0 MemFree = MemFree - LSize End Do If (NewSize > CurrSize) CurrSize = NewSize Return End Subroutine !****************************************************************************** ! ! CalcBestMemConfig - Calculates the best memory configuration for the given ! Case ! ! Proj_Size - Size of each projector ! Psi_Size - Size of each Wave function ! ! Proj_toLoad - Number of projectors to load ! Psi_toLoad - Number of Psi' buffers to have ! !****************************************************************************** Subroutine CalcBestMemConfig(MaxProj, MaxPsi,Proj_Size, Psi_Size,Proj_toLoad,Psi_toLoad, ProjMem, PsiMem) Integer, Intent(IN) :: MaxProj Integer, Intent(IN) :: MaxPsi Integer, Intent(IN) :: Proj_size Integer, Intent(IN) :: Psi_Size Integer, Intent(OUT) :: Proj_toLoad Integer, Intent(OUT) :: Psi_toLoad Integer, Intent(OUT) :: ProjMem Integer, Intent(OUT) :: PsiMem Integer :: i,j,k Write(Log_Unit,*) 'CalcBestMemConfig: BaseFree=',BaseFree Proj_toLoad = (BaseFree - Psi_Size)/Proj_Size Proj_ToLoad = Min(Proj_toLoad, MaxProj) ProjMem = Proj_toLoad*Proj_Size Psi_toLoad = (BaseFree - ProjMem)/Psi_Size Write(Log_Unit,*) 'CalcBestMemConfig: Psi_toLoad=',Psi_toLoad, ' * MaxPsi=',MaxPsi, ' * PRojMem=',ProjMem, ' * Psi_Size=',Psi_Size Psi_toLoad = Min(Psi_toLoad, MaxPsi) PsiMem = Psi_toLoad*Psi_Size Return End Subroutine !****************************************************************************** ! ! Phase_Generic - Configures the system to contain only the current ! Psi's and projectors. ! ! Psi_toUse - List of Psi's to use. 1=Use ! Kpnt - Kpnt index for projectors ! !****************************************************************************** Subroutine Phase_Generic( Psi_toUse, Kpnt) Integer, Intent(IN) :: Psi_toUse(:) Integer, Intent(IN) :: Kpnt Integer :: i, j, NumPsi, NumProj, MaxPsi, CSize, NumAtoms !Integer :: Sets_toLoad(Mem_MapSize) Integer :: LSize, PSize, ProjMem, PsiMem, MemWanted, mem Type (Global_handle), Pointer :: LH, PH Character*100 :: msg PsiBand_toProcess = Psi_toUse Mem_Kpnt = Kpnt Psi_toProcess = MH_Skip Where (PsiBand_toProcess == MH_toProcess) Psi_toProcess = MH_toProcess Call PreparePsi( Psi_toProcess) Return End Subroutine !***************************************************************************** ! ! Phase_Cluster ! !***************************************************************************** Subroutine Phase_Cluster( ClusterIndex) Integer, Intent(IN) :: CLusterIndex Integer :: i Psi_toProcess = MH_SKIP Where (ClusterMap == CLusterIndex) Psi_ToProcess = MH_toProcess i=1 Do While ((ClusterMap(i)/=ClusterIndex) .AND. (i<=Mem_MapSize)) i = i + 1 End Do If (i>Mem_MapSize) then write(Error_Unit,*) "Phase_Cluster: Error in index",ClusterIndex,& clustermap,i call flush(Error_Unit) stop ENdif Call Phase_Generic( Psi_toProcess, PsiInfo(i)%Kpnt) Return End Subroutine !****************************************************************************** ! ! AllocBestMemConfig - Allocs the data structures for the memory management ! !****************************************************************************** Subroutine AllocBestMemConfig Integer :: i, j, NumPsi, NumPRoj Integer :: LSize, ProjMem, PsiMem Type (Global_handle), Pointer :: LH Real :: ProjMem_MEG LSize = PsiArraySize ; LH => Globalmap Proj_Max = 0 Write(*,*) 'AllocBestMemConfig: Proj_Max=',Proj_Max, ' * TotalPsi=',TotalPsi Call CalcBestMemConfig(Proj_Max, TotalPsi, 1, LSize, & NumProj, NumPSi, ProjMem, PsiMem) BaseFree = MemFree Write(Log_Unit,*) 'AllocBestMemConfig: NumProj=',NumProj, ' * NumPsi=',NumPsi Call Mem_AllocBuffers( LH%Psi_Handle, LH%NumPsi, NumPsi) Return End Subroutine !****************************************************************************** ! ! AllocatePotential - Allocate the memory for V ! ! NewSize - Number of grid points ! !****************************************************************************** Subroutine AllocatePotential( NewSize, SmallSize, Ve_F_size) Integer, Intent(IN) :: NewSize Integer, Intent(IN) :: SmallSize Integer, Intent(IN) :: Ve_F_Size Integer :: Used Integer :: i, j, atom Character*200 :: msg Used = NewSize Allocate(SCFvalues%Ve(Used), SCFvalues%Work(Used), & SCFvalues%V_local(SmallSize), & SCFvalues%RhoSmooth(SmallSize), & SCFvalues%CoreTail(SmallSize), & SCFvalues%VXC(SmallSize), & SCFvalues%RhoHat(SmallSize), & SCFvalues%Ve_Fourier(Ve_F_Size), & SCFvalues%cVe_F(Ve_F_Size), & STAT=j) if(spindependence) THEN Allocate(SCFvalues%Vespin(Used),& SCFvalues%RhoSmoothspin(SmallSize), & SCFvalues%VXCSPIN(SmallSize), & SCFvalues%Ve_Fourierspin(Ve_F_Size), & SCFvalues%cVe_Fspin(Ve_F_Size), & STAT=j) endif Write(msg,*) 'AllocatePotential: Could Not allocate buffer!', & ' * Size:',Used Call Check_Error(j, msg, Error_Unit, .TRUE.,paw_wc, "AllocatePotential:") SCFvalues%Ve = 0 SCFvalues%V_Local = 0 SCFvalues%RhoSmooth = 0 SCFvalues%RhoHat = 0 SCFvalues%Ve_Fourier = 0 SCFvalues%cVe_F = 0 SCFvalues%VXC = 0 SCFvalues%CoreTail = 0 if(spindependence) then SCFvalues%Vespin = 0 SCFvalues%RhoSmoothspin = 0 SCFvalues%Ve_Fourierspin = 0 SCFvalues%cVe_Fspin = 0 SCFvalues%VXCSPIN = 0 endif MemFree = MemFree - 2*Used - 3*SmallSize - Ve_F_Size Call InitAnderson(SCFvalues%AC, Error_Unit, Mix_Size, & Ve_F_Size, 1E-5, V_NewMix, AndersonConditionNo) if(spindependence) then Call InitAnderson(SCFvalues%ACspin, Error_Unit, Mix_Size, & Ve_F_Size, 1E-5, V_NewMix, AndersonConditionNo) endif Return End Subroutine !****************************************************************************** ! ! AllocateGlobal - Allocates the memory management data structures and ! initializes them for use. ! !****************************************************************************** Subroutine AllocateGlobal Integer :: i, j, PSize, LSize Character*100 :: msg Allocate(Globalmap,STAT=i) msg = 'AllocateGlogal: Could Not allocate Globalmap!' Call Check_Error(i, msg, Error_Unit, .TRUE.,paw_wc, "Allocatemap:") Write(*,*) 'AllocateGlobal: Proj_Max=',Proj_max, ' * Mem_MapSize=',Mem_MapSize Psize = Proj_Max LSize = Mem_MapSize Allocate(Globalmap%Psi_handle(LSize), STAT=j) Write(msg,*) 'AllocateGlobal: Could Not allocate Globalmap BUFFER!' Call Check_Error(j, msg, Error_Unit, .TRUE.,paw_wc, "AllocateGlobal:") Globalmap%NumPSI = 0 Globalmap%PsiLoaded = 0 Globalmap%Psi_Handle(:)%Index = 0 Return End Subroutine !****************************************************************************** ! ! InitMemMgr - Initializes the memory manager routines ! ! Mem_Size - The amount of memory to use in Mbytes ! ! ! Note : This routine should be called AFTER the projectors have ! been initialized. ! !****************************************************************************** Subroutine InitMemMgr(Mem_Size) Real, Intent(IN) :: Mem_Size Complex :: C Integer :: i,j,k, CalcMinBands Real :: t1 Character*100 :: msg MinBands = TotalElectrons ExtraPsi = 0.25*MinBands + 1 Write(Log_Unit, *) 'InitMemMgr: Extra Bands=',ExtraPsi, ' * Min Bands=',MinBands MinBands = MinBands + ExtraPsi CalcMinbands = 2*MinBands TotalPsi = 2*MinBands !** * NumKpnts TotalPsi = MAX(TotalPsi, NumBands) If (User_MaxTotalPsi > 0) then Write(Log_Unit,*) 'InitMemMgr: Overiding Total Psi! Calculated =', & TotalPsi, ' * User Specified =',User_MaxTotalPsi TotalPsi = User_MaxTotalPsi End If If (User_MinPsi > 0) then Write(Log_Unit,*) 'InitMemMgr: Overiding Min Psi! Calculated =', & MinBands, ' * User Specified =',User_MinPsi MinBands = User_MinPsi End If MemSize = Mem_Size write(Log_Unit,*) 'InitMemMgr: TotalPsi=',TotalPsi, ' NumBands=',NumBands, ' MinBands=',MinBands, ' * NumKpnts=',NumKpnts MemWords = Mem_Size*1024*1024 / SizeOf_C !** 1 Word = 1 Complex(Double) MemFree = MemWords !** Check to make sure we have the min. memory required ** i = 4*Gpnt_Size(G_High) + 2*FFT_Grid(4,G_HIGH) + 1*Gall_Size(G_LOW) If (i>MemWords) then t1 = i*SizeOf_Complex/(1024.0*1024.0) Write(Error_Unit,*) 'InitMemMgr: Not enough memory requested!' Write(Error_Unit,*) 'InitMemMgr: Memory Requested :', MemSize Write(Error_Unit,*) 'InitMemMgr: Memory Needed :', t1 Write(Error_Unit,*) 'InitMemMgr: Total Elements :', i Write(Error_Unit,*) 'InitMemMgr: Element BreakDown : ' Write(Error_Unit,*) 'InitMemMgr: 3x', Gpnt_Size(G_High) Write(Error_Unit,*) 'InitMemMgr: 2x', FFT_Grid(4,G_Low) Write(Error_Unit,*) 'InitMemMgr: 1x', Gall_Size(G_Low) STOP End IF Mem_MaxPsi = 2*MinBands Mem_MapSize = 4*MAX(CalcMinBands,TotalPsi)*NumKpnts + 1 + 1 + 1 + 1 + 1 !**** Allocate the Kpoint LUT ****** Allocate(PsiInfo(Mem_MapSize), STAT=i) msg = 'InitMemMgr: Could Not allocate WhichKpnt!' Call Check_Error(i, msg, Error_Unit, .TRUE.,paw_wc, "InitMemMgr:") PsiInfo(:)%Kpnt = 0 PsiInfo(:)%spinup = .true. PsiInfo(:)%DoSave = 0 PsiInfo(:)%Available = Mem_Available PsiInfo(:)%CorrIndex = 0 PsiInfo(:)%OxIndex = 0 PsiInfo(:)%MemBufIndex = 0 PsiInfo(:)%Energy = 0 PsiInfo(:)%KE = 0 PsiInfo(:)%Occupancy = 0 PsiInfo(:)%Error = -1 PsiInfo(:)%PDOT_Stored = .FALSE. PsiInfo(:)%KE_Stored = .FALSE. Call AllocateGlobal !** Allocate Data structure's Allocate(SCFvalues, STAT=i) msg = 'InitMemMgr: Could Not allocate SCFvalues!' Call Check_Error(i, msg, Error_Unit, .TRUE.,paw_wc, "InitMemMgr:") ! If ((V_MixType == MIX_V) .OR. (V_MixType == MIX_VEFF)) then ! Call AllocatePotential(FFT_Grid(4,G_PROJ), Gpnt_Size(G_HIGH), & ! Gpnt_Size(G_PROJ)) ! else ! Call AllocatePotential(FFT_Grid(4,G_PROJ), Gpnt_Size(G_HIGH), & ! Gpnt_Size(G_High)) ! End If Call AllocatePotential(FFT_Grid(4,G_HIGH), Gpnt_Size(G_HIGH), & Gpnt_Size(G_HIGH)) Allocate(MemCache, STAT=i) msg = 'InitMemMgr: Could Not allocate Work Buffers!' Call Check_Error(i, msg, Error_Unit, .TRUE.,paw_wc, "InitMemMgr:") MemCache%Psi_Read%Hits = 0 MemCache%Psi_Read%Misses = 0 MemCache%Psi_Write%Hits = 0 MemCache%Psi_Write%Misses = 0 !*** Allocate Cluster Buffers **** Allocate(ClusterMap(Mem_MapSize), ClusterSize(Mem_MapSize), & Psi_toProcess(Mem_MapSize), Psi_Processed(Mem_MapSize), & PsiBand_toProcess(Mem_MapSize), STAT=i) msg = 'InitMemMgr: Could Not allocate Cluster Buffers!' Call Check_Error(i, msg, Error_Unit, .TRUE.,paw_wc, "InitMemMgr:") ClusterMap = 0 ClusterSize = 0 LastCluster = 0 BaseFree = MemFree Psi_Restart = .TRUE. Write(Log_Unit, *) 'InitMemMgr: Mem_MapSize = ', Mem_MapSize Write(Log_Unit, *) 'InitMemMgr: MemWords = ', MemWords, & ' * FreeWords=', MemFree Call AllocBestMemConfig Write(Log_Unit, *) 'InitMemMgr: MemWords = ', MemWords, & ' * FreeWords=', MemFree Return End Subroutine End Module spinpwpaw/code/misc.f900100664004704100470410000001314410303710172015115 0ustar natalienatalie!****************************************************************************** ! ! File : misc.f90 ! by : Alan Tackett ! on : 10/17/95 ! for : Misc general purpose functions ! ! This module contains misc. general purpose routines that don't fit ! in another library. Below is a list of routines contained : ! ! ! Check_Error(Alloc_error, Error_String, Unit, Die, WC, IDText) ! Routine for processing an error message return from an intrinsic ! function, ie, ALLOCATE, OPEN, READ, WRITE, etc. A descriptive ! message is printed if one occured and dies(default, can be changed). ! ! ! Swap(a, b) ! Swaps the values A and B ! ! PrintDate(Unit, Text) ! Prints the date and time to the specified unit along with the TEXT ! !***************************************************************************** Module misc Use word Use timing Implicit NONE!!!! Interface Swap Module Procedure R4_Swap Module Procedure R8_Swap Module Procedure C8_Swap Module Procedure C16_Swap Module Procedure I4_Swap Module Procedure I8_Swap End Interface Contains !**************************************************************************** ! ! Check_Error ! Routine for processing an error message return from an intrinsic ! function, ie, ALLOCATE, OPEN, READ, WRITE, etc. A descriptive ! message is printed if one occured and dies(default, can be changed). ! ! Error_Number - Error value returned from intrinsic ! Error_String - Text string to print if an error occurs(OPTIONAL) ! Unit - Output Unit(OPTIONAL) ! Die - If true then the progam aborts if an error occurs ! otherwise only the error message is printed and ! control is returned to the calling program. ! If this parameter is not present then the default ! is to die if an error occurs.(OPTIONAL) ! WC - Word Context(OPTIONAL) ! IDText - If present then Calls Word_GetAndPrint(OPTIONAL) ! !**************************************************************************** Subroutine Check_Error(Error_Number, Error_String, Unit, Die, WC, IDText) Integer, Intent(IN) :: Error_Number character*(*), Optional, Intent(IN) :: Error_String Integer, Optional, Intent(IN) :: Unit Logical, Optional, Intent(IN) :: Die Type (Word_Context), OPTIONAL, Intent(INOUT) :: WC Character*(*), Optional, Intent(IN) :: IDText Integer :: u Real :: tmp Character*100 :: errmsg, token If (Error_Number /= 0) then If (Present(Unit)) then u = Unit else u = 6 End If If (Present(Error_String)) Write(u, *) Error_String Write(u,*) TRim(IDText) // ' Error Value : ', Error_Number Call Flush(u) Write(token,*) Error_Number !!Call GError(errmsg) !** Not available on the SP2 or CRAY!!!! Write(u,*) TRim(IDText),'(',TRIM(Token),') ', Trim(errmsg) !** Write(u,*) TRim(IDText),'(',TRIM(Token),') ' !** USe this line if cray if (Present(IDText) .AND. Present(WC)) Call Word_GetAndPrint(WC, u, IDText) if (Present(Die)) then if (Die) then tmp = 0 tmp = 1.0/tmp !** Generate a core dump End If tmp = 0 tmp = 1.0/tmp !** Generate a core dump else tmp = 0 tmp = 1.0/tmp !** Generate a core dump End IF tmp=0 tmp=1.0/tmp write(u,*) 'Hello!!!!!!!!' End If Return End Subroutine !**************************************************************************** ! ! Swap - Swaps two elements ! ! A, B - Elements to swap ! !**************************************************************************** !************************** R4_Swap ******************************************* Subroutine R4_Swap(A, B) Real*4, Intent(INOUT) :: A, B Real*4 :: T T = A A = B B = T Return End Subroutine !************************** R8_Swap ******************************************* Subroutine R8_Swap(A, B) Real*8, Intent(INOUT) :: A, B Real*8 :: T T = A A = B B = T Return End Subroutine !************************** C8_Swap ***************************************** Subroutine C8_Swap(A, B) Complex*8, Intent(INOUT) :: A, B Complex*8 :: T T = A A = B B = T Return End Subroutine !************************** C16_Swap ***************************************** Subroutine C16_Swap(A, B) Complex*16, Intent(INOUT) :: A, B Complex*16 :: T T = A A = B B = T Return End Subroutine !************************** I4_Swap ***************************************** Subroutine I4_Swap(A, B) Integer*4, Intent(INOUT) :: A, B Integer*4 :: T T = A A = B B = T Return End Subroutine !************************** C8_Swap ***************************************** Subroutine I8_Swap(A, B) Integer*8, Intent(INOUT) :: A, B Integer*8 :: T T = A A = B B = T Return End Subroutine !****************************************************************************** ! ! PrintDate - Prints the date to the specified unit with TEXT prepended. ! ! Unit - Output unit ! Text - Text for prepending. All trailing blanks are removed. ! !****************************************************************************** Subroutine PrintDate(Unit, Text) Integer, Intent(IN) :: Unit Character*(*), Intent(IN) :: Text Character*10 :: DateStr, TimeStr Character*50 :: FmtStr Call Date_And_Time(DateStr, TimeStr) FmtStr=' ' // DateStr(5:6) // '/' // DateStr(7:8) // '/' // DateStr(1:4) // & ', ' // TimeStr(1:2) // ':' // TimeStr(3:4) // ':' // & TimeStr(5:10) Write(Unit, '(a,a)') Trim(Text), Trim(FmtStr) Return End Subroutine End Module spinpwpaw/code/mkname.f900100664004704100470410000000137110303710172015431 0ustar natalienatalie! subroutine to take an integer (.le. 4 digits) and return it ! in the form of a character string subroutine mkname(i,stuff) implicit none character*4 ::stuff integer*4 :: i integer*4 :: i1000,i100,i10,i1 stuff='?' if (i.gt.10000) i=mod(i,10000) i1000=i/1000 i100=(i-1000*i1000)/100 i10=(i-1000*i1000-100*i100)/10 i1=(i-1000*i1000-100*i100-10*i10) if (i.ge.1000) then stuff=char(i1000+48)//char(i100+48)//char(i10+48)//char(i1+48) return endif if (i.ge.100) then stuff=char(i100+48)//char(i10+48)//char(i1+48) return endif if (i.ge.10) then stuff=char(i10+48)//char(i1+48) return endif if (i.ge.0) stuff=char(i1+48) return end spinpwpaw/code/oinverse.f900100664004704100470410000006046610371153146016034 0ustar natalienatalie!****************************************************************************** ! ! File : oinverse.f90 ! by : Alan Tackett ! on : 09/20/99 ! for : PWPAW ! ! Routines for calculating O^(-1), ie the inverse of the overlap matrix ! !****************************************************************************** Module oinverse Use lrulib Use gpoints Use work_mgr Use atom_data Use crystal_data Use spherical_harmonic Use structfact Use ylm_fact Use projectors Use doijmatrix Implicit NONE!!!!! Type RLE_Oi_type Integer :: N Integer, Pointer :: RLE(:,:) Complex, Pointer :: Oinv(:) End Type Type (RLE_Oi_Type), Pointer :: RS_Oinv(:,:) Type (COMPLEX_LRU_Context) :: LRU_GS_Oinv Type (COMPLEX_LRU_Context) :: LRU_RS_Oinv Complex, Pointer :: GS_Oinv_Scale(:,:) Complex, Pointer :: RS_Oinv_Scale(:,:) Complex, PRIVATE, Pointer :: Oi_Work1(:) Complex, PRIVATE, Pointer :: Oi_Work2(:) Integer, Pointer, PRIVATE :: Group(:) Integer, Pointer, PRIVATE :: Group_Nmax(:) Integer, PRIVATE :: NumGroups Integer, PRIVATE :: NumRecsPerKpnt !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! RS_Oinverse - Calculates O**(-1) times V in R-space ! !****************************************************************************** Subroutine RS_Oinverse(V, kpnt, MaxAtom, MaxN) Complex, Intent(INOUT) :: V(:) Integer, Intent(IN) :: Kpnt Integer, OPTIONAL, Intent(IN) :: MaxAtom Integer, OPTIONAL, Intent(IN) :: MaxN Integer :: i,j,k,dn, Base_DI, atom, n, N_rle, DI Integer :: LastAtom, LastN Complex, Pointer :: Proj_R(:), Oi(:) Complex :: dot, dot2, dot3 Real :: DV Integer, Pointer :: RLE(:,:) !*V=V/(FFT_Grid(4,G_PROJ))**2 !*V=0 !RETURN !* DV = Xtal%Volume/(1.0*FFT_Grid(4,G_PROJ)) !DV = 1.0/(1.0*FFT_Grid(4,G_PROJ)) DV = 1 DI = PLM_Max*(Kpnt-1) !Write(Log_Unit,*) 'RS_Oinv: DI=',DI, ' * Kpnt=',Kpnt LastAtom = Specific_Atoms If (Present(MaxAtom)) LastAtom = MaxAtom Do atom=1, LastAtom Base_DI = RS_PLMMax(atom)*(Kpnt-1) LastN = RS_PLMMax(atom) If (atom==LastAtom) then If (Present(MaxAtom)) LastN = MaxN End If Do n=1, LastN dot = 0 Call LRU_GetRec(LRU_RS_Proj(atom), Base_DI + n, Proj_R) i = 0; j = 0; Do k=1, RS_RLE(atom)%N j = RS_RLE(atom)%RLE(1,k)-1 dn = RS_RLE(atom)%RLE(2,k) dot = dot + DOT_PRODUCT(Proj_R(i+1:i+dn), V(j+1:j+dn)) i = i + dn End Do DI = DI + 1 N_rle = RS_Oinv(RS_PLM(atom,4,n),kpnt)%N RLE => RS_Oinv(RS_PLM(atom,4,n),kpnt)%RLE Oi => RS_Oinv(RS_PLM(atom,4,n),kpnt)%Oinv dot = RS_Oinv_Scale(RS_PLM(atom,4,n),Kpnt)*dot i = 0; j = 0; !Write(Log_Unit,*) 'RS_Oinv: DOT=',dot, ' Oi=',Oi, ' * Size(Oi)=',size(Oi) Do k=1, N_rle j = RLE(1,k)-1 dn = RLE(2,k) !write(Log_unit,*) 'k=',k, ' ij=',i,j,' dn=',dn, ' * V=',V(j+1:j+dn), ' * Oi=',Oi(i+1:i+dn) V(j+1:j+dn) = V(j+1:j+dn) - dot*Oi(i+1:i+dn) i = i + dn End Do !** V = V - RS_Oinv_Scale(RS_PLM(atom,4,n),Kpnt)*dot*Oi End Do !**n End Do !** atom Return End Subroutine !****************************************************************************** ! ! GS_Oinverse_TIME - Applies the inverse of the overlap matrix in G-space to ! the given vector ! ! V - On Input the vector to multiply by. On output V=O**-1 * V ! MaxN - Optional Max inverse vector to apply. Used during construction of ! the inverse vectors. ! !*TIME* !****************************************************************************** Subroutine GS_Oinverse_TIME(V, Kpnt, MaxAtom, MaxN) Complex, Intent(INOUT) :: V(:) Integer, Intent(IN) :: Kpnt Integer, OPTIONAL, Intent(IN) :: MaxAtom Integer, OPTIONAL, Intent(IN) :: MaxN Integer :: i,j,k,level, m,am, L, n, t, G_Size, G_Half, atom Integer :: Base_DI, DI, RadP, PLM_Index Integer :: NG, atype, LastN, LastAtom Complex :: dot Complex, Pointer :: Oinv(:), Proj(:) LastAtom = Specific_Atoms If (Present(MaxAtom)) LastAtom = MaxAtom NG = Gpnt_Size(G_Low) - 1 DI = PLM_Max*(Kpnt-1) Do atom=1, LastAtom atype = Atom_List(atom)%typeIndex !G_Half = Atomtype_Info(Atom_List(atom)%typeIndex)%Gpnt_size !G_Size = 2*G_Half - 1 G_Half = Gpnt_Size(G_LOW) G_Size = Gall_Size(G_LOW) Base_DI = RS_PLMMax(atom) * (Kpnt-1) !** Calc starting DI for Kpnt LastN = RS_PLMMax(atom) If (atom==LastAtom) then If (Present(MaxAtom)) LastN = MaxN End If Do n=1, LastN RadP = RS_PLM(atom,1,n) L = RS_PLM(atom,2,n) m = RS_PLM(atom,3,n) am = ABS(m) PLM_Index = RS_PLM(atom,4,n) Call LRU_GetRec(LRU_Proj(atom), Base_DI + n, Proj) i = 1 dot = Proj(i)*V(i) Do i=2, G_Half dot = dot + Proj(i)*V(i) dot = dot + Proj(i+G_Half-1) * V(i+ng) end Do DI = DI + 1 Call LRU_GetRec(LRU_GS_Oinv, DI, Oinv) !Write(Log_Unit,*) 'GS_Oinverse: atom=',atom, ' * n=',n, ' * DOT=',dot, ' * Gscale=',GS_Oinv_Scale(PLM_Index), ' * Both=',dot*GS_Oinv_Scale(PLM_Index) V = V - dot*Oinv*GS_Oinv_Scale(PLM_Index, Kpnt) End Do End Do !*atom !Write(Log_Unit,*) 'GS_Oinverse_TIME:...........' Return End subroutine !****************************************************************************** ! ! GS_Oinverse_MEM - Applies the inverse of the overlap matrix in G-space to ! the given vector ! ! V - On Input the vector to multiply by. On output V=O**-1 * V ! MaxN - Optional Max inverse vector to apply. Used during construction of ! the inverse vectors. ! !*MEMORY* !****************************************************************************** Subroutine GS_Oinverse_MEM(V, Kpnt, MaxAtom, MaxN) Complex, Intent(INOUT) :: V(:) Integer, Intent(IN) :: Kpnt Integer, OPTIONAL, Intent(IN) :: MaxAtom Integer, OPTIONAL, Intent(IN) :: MaxN Integer :: i,j,k,level, m,am, L, n, t, G_Size, G_Half, atom Integer :: Base_RAD, Base_DI, G_Index, DI, RadP, PLM_Index Integer :: Basis_size, NG, atype, LastN, LastAtom Complex :: c1,c2,c3, Cij, dot Complex, Pointer :: Oinv(:), Phase(:), Ylm(:) Real, Pointer :: Proj(:) LastAtom = Specific_Atoms If (Present(MaxAtom)) LastAtom = MaxAtom NG = Gpnt_Size(G_Low) - 1 c1 = 4*Pi / sqrt(xtal%Volume) DI = PLM_Max*(Kpnt-1) Do atom=1, LastAtom atype = Atom_List(atom)%typeIndex Basis_Size = AtomType_Info(atype)%Basis_Size !G_Half = Atomtype_Info(Atom_List(atom)%typeIndex)%Gpnt_size !G_Size = 2*G_Half - 1 G_Half = Gpnt_Size(G_LOW) G_Size = Gall_Size(G_LOW) Call GetStructFactor( atom, Phase) Base_DI = Basis_Size * (Kpnt-1) !** Calc starting DI for Kpnt LastN = RS_PLMMax(atom) If (atom==LastAtom) then If (Present(MaxAtom)) LastN = MaxN End If Do n=1, LastN RadP = RS_PLM(atom,1,n) L = RS_PLM(atom,2,n) m = RS_PLM(atom,3,n) am = ABS(m) PLM_Index = RS_PLM(atom,4,n) Call LRU_GetRec(LRU_RadProj(atype), Base_DI + radP, Proj) Call GetYlm( Kpnt, L, am, Ylm) c2 = CMPLX(0,1)**L dot = 0 If (m>=0) then i = 1 dot = CONJG(Ylm(i))*Proj(i)*Phase(i)*V(i) Do i=2, G_Half dot = dot + CONJG(Ylm(i))*Proj(i)*Phase(i)*V(i) dot = dot + CONJG(Ylm(i+ng)) * Proj(i+G_Half-1) * & Phase(i+ng)*V(i+ng) end Do dot = c1*c2*dot Else i = 1 dot = Ylm(i)*Proj(i)*Phase(i)*V(i) Do i=2, G_Half dot = dot + Ylm(i)*Proj(i)*Phase(i)*V(i) dot = dot + Ylm(i+ng) * Proj(i+G_Half-1) * & Phase(i+ng)*V(i+ng) end Do c3 = (-1)**am dot = c1*c2*c3*dot End If DI = DI + 1 Call LRU_GetRec(LRU_GS_Oinv, DI, Oinv) !Write(Log_Unit,*) 'GS_Oinverse: atom=',atom, ' * n=',n, ' * DOT=',dot, ' * Gscale=',GS_Oinv_Scale(PLM_Index), ' * Both=',dot*GS_Oinv_Scale(PLM_Index) V = V - dot*Oinv*GS_Oinv_Scale(PLM_Index, Kpnt) End Do End Do !*atom Return End subroutine !****************************************************************************** ! ! Oinverse - Applies the inverse of the overlap matrix in G-space to ! the given vector ! ! V - On Input the vector to multiply by. On output V=O**-1 * V ! MaxN - Optional Max inverse vector to apply. Used during construction of ! the inverse vectors. ! !*DRIVER* !****************************************************************************** Subroutine CalcOinverse(V, Kpnt) Complex, Intent(INOUT) :: V(:) Integer, Intent(IN) :: Kpnt !RETURN Select Case (Proj_Mode) Case (MIN_TIME) Call GS_Oinverse_TIME(V, Kpnt) Case (MIN_MEMORY) Call GS_Oinverse_MEM(V, Kpnt) Case (PROJ_RS) ! RS_Work1 = 0 ! Call RS_toR(V, RS_Work1) ! RS_Work1 = RS_Work1/(1.0*FFT_Grid(4,G_PROJ)) ! Call RS_Oinverse(RS_Work1, Kpnt) Call RS_Oinverse(V, Kpnt) ! V = 0 ! Call RS_toG(RS_Work1, V) ! V = V * (1.0*FFT_Grid(4,G_PROJ)) End Select Return End Subroutine !****************************************************************************** ! ! RS_Psum - Sums the projectors for the given group ! !****************************************************************************** Subroutine RS_Psum(V, Kpnt, atom, njlj, Lj, mj) Complex, Intent(OUT) :: V(:) Integer, Intent(IN) :: Kpnt Integer, Intent(IN) :: atom Integer, Intent(IN) :: njlj Integer, Intent(IN) :: Lj Integer, Intent(IN) :: mj Integer :: i,j,k,dn, Base_DI, n, DI Integer :: nili, Li, mi Complex, Pointer :: Proj_R(:) Complex :: dot, Oij Real :: DV !* DV = Xtal%Volume/(1.0*FFT_Grid(4,G_PROJ)) DV = 1.0*(1.0*FFT_Grid(4,G_PROJ)) !DV = 1 Base_DI = RS_PLMMax(atom)*(Kpnt-1) V = 0 Do n=1, RS_PLMMax(atom) nili = RS_PLM(atom, 1, n) Li = RS_PLM(atom,2,n) mi = RS_PLM(atom,3,n) Oij = OijMatrix(Atom, nili, njlj, Li, lj, mi, mj) Call LRU_GetRec(LRU_RS_Proj(atom), Base_DI + n, Proj_R) i = 0; j = 0; Do k=1, RS_RLE(atom)%N j = RS_RLE(atom)%RLE(1,k)-1 dn = RS_RLE(atom)%RLE(2,k) V(j+1:j+dn) = V(j+1:j+dn) + Proj_R(i+1:i+dn)*Oij i = i + dn End Do End Do !**n Write(Log_Unit, *) 'RS_Psum: atom=',atom, ' n=', n, ' * Kpnt=',kpnt, ' * DOT=',DOT_PRODUCT(V,V) Return End Subroutine !****************************************************************************** ! ! GS_Psum - Sums the projectors for the given atom ! ! PSum - Output vector ! Kpnt - K-point ! atom - atom for sum ! njlj, Lj, mj - Indices of "other" vector for Oij factor in sum ! !****************************************************************************** Subroutine GS_Psum(Psum_G, Kpnt, atom, njlj, Lj, mj) Complex, Intent(OUT) :: Psum_G(:) Integer, Intent(IN) :: Kpnt Integer, Intent(IN) :: atom Integer, Intent(IN) :: njlj Integer, Intent(IN) :: Lj Integer, Intent(IN) :: mj Integer :: i,j,k,level, m,am, L, n, t, G_Size, G_Half Integer :: Base_RAD, Base_DI, G_Index, DI, RadP Integer :: Basis_size, NG, atype Complex :: c1,c2,c3, Oij Complex, Pointer :: Proj_G(:), Ylm(:), Phase(:) Real, Pointer :: Proj(:) c1 = 4*Pi / sqrt(xtal%Volume) Call Getbuffer( Proj_G) NG = Gpnt_size(G_LOW) - 1 Psum_G = 0 atype = Atom_List(atom)%typeIndex Basis_Size = AtomType_Info(atype)%Basis_Size !G_Half = Atomtype_Info(Atom_List(atom)%typeIndex)%Gpnt_size !G_Size = 2*G_Half - 1 G_Half = Gpnt_Size(G_LOW) G_Size = Gall_Size(G_LOW) Call GetStructFactor( atom, Phase) Base_DI = Basis_Size * (Kpnt-1) !** Calc starting DI for Kpnt Do n=1, RS_PLMMax(atom) RadP = RS_PLM(atom,1,n) L = RS_PLM(atom,2,n) m = RS_PLM(atom,3,n) am = ABS(m) Call LRU_GetRec(LRU_RadProj(atype), Base_DI + radP, Proj) Call GetYlm( Kpnt, L, am, Ylm) c2 = CMPLX(0,1)**L Proj_G = 0 If (m>=0) then i = 1 Proj_G(i) = CONJG(Ylm(i))*Proj(i)*Phase(i) Do i=2, G_Half Proj_G(i) = CONJG(Ylm(i))*Proj(i)*Phase(i) Proj_G(i+ng) = CONJG(Ylm(i+ng)) * Proj(i+G_Half-1) * & Phase(i+ng) end Do Proj_G = c1*c2*Proj_G Else i = 1 Proj_G(i) = Ylm(i)*Proj(i)*Phase(i) Do i=2, G_Half Proj_G(i) = Ylm(i)*Proj(i)*Phase(i) Proj_G(i+ng) = Ylm(i+ng) * Proj(i+G_Half-1) * & Phase(i+ng) end Do c3 = (-1)**am Proj_G = c1*c2*c3*Proj_G End If Write(Log_Unit, *) 'GS_Psum: atom=',atom, ' n=', n, ' * Kpnt=',kpnt, ' * DOT=',DOT_PRODUCT(Proj_G, Proj_G) Oij = OijMatrix(Atom, radP, njlj, L, lj, m, mj) Psum_G = Psum_G + CONJG(Proj_G)*Oij End Do Call Freebuffer(Proj_G) Return End Subroutine !********************************************************************** ! ! RS_RLE_Vector - Stores the vector in compressed form ! !********************************************************************** subroutine RS_RLE_Vector(DoStore, rle_size, data_size, RLE, Proj_RAW, Proj_RLE) Logical, Intent(IN) :: DoStore Integer, Intent(OUT) :: rle_size Integer, Intent(OUT) :: data_size Integer, Intent(OUT) :: RLE(:,:) Complex, Intent(IN) :: Proj_RAW(:) Complex, Intent(OUT) :: Proj_RLE(:) Integer :: t, i,j,k Integer :: npnts, run_Start Logical :: Ok, InRun Real :: num If (DoStore) RLE = 0 rle_size = 0 data_size = 0 npnts = 0 t = 0 Inrun = .FALSE. Do t=1, FFT_Grid(4,G_PROJ) num = SQRT(ABS(REAL(CONJG(Proj_Raw(t))*Proj_raw(t)))) If (num > 1E-20) then If (.NOT. InRun) then Run_Start = t InRun = .TRUE. End If npnts = npnts + 1 !Write(Log_Unit,*) 'RS_RLE: t=',t, ' * n=',npnts, ' * RLE=',rle_size If (DoStore) Proj_RLE(npnts) = Proj_RAW(t) else If (Inrun) then rle_size = rle_size + 1 data_size = data_size + t-Run_Start If (DoStore) RLE(:,rle_size) = (/Run_start, (t-Run_Start) /) InRun = .FALSE. !Write(Log_Unit,*) 'RS_RLE: Start=',run_Start, ' * n=',npnts, ' * RLE=',rle_size, ' * data_size=',data_size End If End Do If (InRun) then t = FFT_Grid(4,G_Proj) rle_size = rle_size + 1 data_size = data_size + t-Run_Start+1 If (DoStore) RLE(:,rle_size) = (/Run_start, (t-Run_Start+1) /) !Write(Log_Unit,*) 'RS_RLE: Start=',run_Start, ' * n=',data_size, ' * RLE=',rle_size end If If (DoStore) Write(Log_Unit,*) 'RS_RLE: Total points:',npnts, & ' RLE Size:',rle_size, ' * Data_size=',data_size data_size = npnts Return end Subroutine !****************************************************************************** ! ! RS_CreateOinverse - Creates the Oinverse vectors in R-space ! !****************************************************************************** Subroutine RS_CreateOinverse Integer :: i,j,k,dn, Base_DI, atom, n, Kpnt, grp, DI Complex, Pointer :: Proj_R(:), Work1(:), Work2(:) Complex :: dot Real :: DV, r !* DV = Xtal%Volume/(1.0*FFT_Grid(4,G_PROJ)) DV = 1.0/(1.0*FFT_Grid(4,G_PROJ)) !DV = 1 Allocate(Work1(FFT_Grid(4,G_PROJ)), Work2(FFT_Grid(4,G_PROJ))) !Write(Log_Unit,*) 'CPP_RS: Base_DI=',Base_DI, ' * Kpnt=',Mem_Kpnt DI = 0 Do Kpnt=1, Size(BZ%Ku(1,:)) Do atom=1, Specific_Atoms Base_DI = RS_PLMMax(atom)*(Kpnt-1) Do n=1, RS_PLMMax(atom) Work1 = 0 Call LRU_GetRec(LRU_RS_Proj(atom), Base_DI + n, Proj_R) i = 0; j = 0; Do k=1, RS_RLE(atom)%N j = RS_RLE(atom)%RLE(1,k)-1 dn = RS_RLE(atom)%RLE(2,k) Work1(j+1:j+dn) = Proj_R(i+1:i+dn) i = i + dn End Do DI = DI + 1 Call RS_Psum(Work2, Kpnt, atom, RS_PLM(atom,1,n), & RS_PLM(atom,2,n), RS_PLM(atom,3,n)) Work2 = Work2 * DV Call RS_Oinverse(Work2, kpnt, atom, n-1) dot = DOT_PRODUCT(Work1, Work2) !* DV !?????? RS_Oinv_Scale(RS_PLM(atom,4,n), Kpnt) = 1.0/(1.0+dot) Write(Log_Unit, *) 'RS_CreateOinv: atom=',atom, ' n=', n, ' * Kpnt=',kpnt, ' * WORK1 DOT=',DOT_PRODUCT(Work1, Work1) Write(Log_Unit,*) ' dot=',dot,' * scale=',RS_Oinv_Scale(RS_PLM(atom,4,n),kpnt), ' * DI=',DI j=0 Do i=1, FFT_Grid(4,G_PROJ) r = CONJG(Work2(i))*Work2(i) r = SQRT(ABS(r)) If (ABS(r)>1E-20) j = j + 1 end Do Write(log_Unit,*) 'RS_CreateOinv: DI=',DI, ' * NonZero=',j k = RS_PLM(atom,4,n) If (RS_Oinv(k,kpnt)%N>0) then DeAllocate(RS_Oinv(k,kpnt)%RLE, RS_Oinv(k,kpnt)%Oinv) End If Call RS_RLE_Vector(.FALSE., i, j, RS_Oinv(k,kpnt)%RLE, Work2, Work1) RS_Oinv(k,kpnt)%N = i Allocate(RS_Oinv(k, Kpnt)%RLE(2,i), RS_Oinv(k,kpnt)%Oinv(j)) Call RS_RLE_Vector(.TRUE., i, j, RS_Oinv(k,kpnt)%RLE, & Work2, RS_Oinv(k,kpnt)%Oinv) End do End Do !** atom End Do DeAllocate(Work1, Work2) Return End Subroutine !****************************************************************************** ! ! GS_CreateOinverse - Creates the Oinverse vectors in G-space ! !****************************************************************************** Subroutine GS_CreateOinverse Integer :: i,j,k,atom, level, m,am, L, n, kpnt, t, G_Size, G_Half Integer :: Base_RAD, Base_DI, G_Index, MaxRec, RS_Size(0:0), DI, RadP Integer :: Basis_size, NG, atype Integer, Pointer :: Map(:) Real, Pointer :: Proj(:), Wt(:) Complex, Pointer :: Work(:), Ylm(:), Phase(:), Proj_G(:), Proj_R(:) Complex, Pointer :: Buffer(:), Psum_G(:) Complex :: c1,c2,c3, c4, dot Real :: DV, R(3), R_xtal(3,27) Integer :: x,y,z,xo,yo,zo, rle_size, data_size Real :: r1,r2 DV = Xtal%Volume/(1.0*FFT_Grid(4,G_PROJ)) Call Getbuffer( Proj_G) Call Getbuffer( Psum_G) Call GetBuffer( Work) c1 = 4*Pi / sqrt(xtal%Volume) NG = Gpnt_size(G_LOW) - 1 DI = 0 Do Kpnt = 1, Size(BZ%Ku(1,:)) Do atom=1, Specific_Atoms atype = Atom_List(atom)%typeIndex Basis_Size = AtomType_Info(atype)%Basis_Size !G_Half = Atomtype_Info(Atom_List(atom)%typeIndex)%Gpnt_size !G_Size = 2*G_Half - 1 G_Half = Gpnt_Size(G_LOW) G_Size = Gall_Size(G_LOW) Call GetStructFactor( atom, Phase) Base_DI = Basis_Size * (Kpnt-1) !** Calc starting DI for Kpnt Do n=1, RS_PLMMax(atom) RadP = RS_PLM(atom,1,n) L = RS_PLM(atom,2,n) m = RS_PLM(atom,3,n) am = ABS(m) Call LRU_GetRec(LRU_RadProj(atype), Base_DI + radP, Proj) Call GetYlm( Kpnt, L, am, Ylm) c2 = CMPLX(0,1)**L Proj_G = 0 If (m>=0) then i = 1 Proj_G(i) = CONJG(Ylm(i))*Proj(i)*Phase(i) Do i=2, G_Half Proj_G(i) = CONJG(Ylm(i))*Proj(i)*Phase(i) Proj_G(i+ng) = CONJG(Ylm(i+ng)) * Proj(i+G_Half-1) * & Phase(i+ng) end Do Proj_G = c1*c2*Proj_G Else i = 1 Proj_G(i) = Ylm(i)*Proj(i)*Phase(i) Do i=2, G_Half Proj_G(i) = Ylm(i)*Proj(i)*Phase(i) Proj_G(i+ng) = Ylm(i+ng) * Proj(i+G_Half-1) * & Phase(i+ng) end Do c3 = (-1)**am Proj_G = c1*c2*c3*Proj_G End If !Proj_G = CONJG(Proj_G) Write(Log_Unit, *) 'GS_CreateOinv: atom=',atom, ' n=', n, ' * Kpnt=',kpnt, ' * DOT=',DOT_PRODUCT(Proj_G, Proj_G) Call GS_Psum(Psum_G, Kpnt, atom, radp, L, m) !Psum_G = CONJG(PSum_G) Work = PSum_G Call GS_Oinverse_MEM(Work, kpnt, atom, n-1) dot = SUM(Proj_G*Work) GS_Oinv_Scale(RS_PLM(atom,4,n),Kpnt) = 1.0/(1.0+dot) DI = DI + 1 Write(Log_Unit, *) 'GS_CreateOinv: atom=',atom, ' n=', n, ' * Kpnt=',kpnt, ' * WORK DOT=',DOT_PRODUCT(Work, Work) Write(Log_Unit,*) ' dot=',dot,' * scale=',GS_Oinv_Scale(RS_PLM(atom,4,n),Kpnt), ' * DI=',DI Call LRU_PutRec(LRU_GS_Oinv, DI, Work) End Do End Do !*atom End do !* kpnt Call FreeBuffer(Proj_G) Call FreeBuffer(Psum_G) Call freeBuffer(Work) Return End Subroutine !****************************************************************************** ! ! GS_Test_Oinverse - Tests the Oinverse code in G-space ! !****************************************************************************** Subroutine GS_Test_Oinverse Complex, Pointer :: O(:), Oinv(:), V(:) !Complex :: dot, dot2, PDOT(PLM_Max) Complex :: dot, dot2 Complex ,allocatable :: PDOT(:) Integer :: i,j, Kpnt, N Real :: r, dv Complex, Pointer :: Omat(:,:), Oinvmat(:,:) Write(Log_Unit,*) 'GS_Test_Oinverse: Start!!!!!!!!!!!!!!!!!!! PLM_Max=',PLM_Max write(Log_unit,*) 'GS_Test_Oinvers which no longer works' stop Allocate(PDOT(PLM_Max)) N = FFT_Grid(4,G_PROJ) ! N = Gall_Size(G_LOW) Allocate(O(N), Oinv(N), V(N)) Mem_Kpnt = 1 dv = 1.0/FFT_Grid(4,G_PROJ) !Omat = 0 !Do i=1,n ! Omat(i,i) = Omat(i,i) + 1 ! Do j=1, n ! Omat(i,j) = Omat(i,j) + V(i)*CONJG(V(j)) ! End Do !end Do !Call RS_Oinverse(V, 1) Do Kpnt=1, NumKpnts Write(Log_Unit,*) 'GS_Test_Oinverse: checking Kpnt=',kpnt Mem_Kpnt = Kpnt Do i=1, N V = 0 V(i) = 1 PDOT = 0 Call CalcProjProducts(V, PDOT) O = V Call AccumProj(O, PDOT, OijMatrix) !Write(Log_Unit,*) 'i=',i, ' * DOT=',DOT_PRODUCT(O,O) !Do j=1, N ! dot = O(j) - Omat(j,i) ! r = CONJG(dot)*dot ! if (ABS(r) > 1E-9) then ! Write(Log_Unit,*) 'Omat: ij=',i,j, ' * Oj=',O(j), ' * Oji=',Omat(j,i), ' * ERR=',r ! End if !End Do Do j=1, i Oinv = 0 Oinv(j) = 1 Call CalcOinverse(Oinv, Kpnt) dot = DOT_PRODUCT(O, Oinv) r = CONJG(dot)*dot r = SQRT(r) If (i==j) then if (ABS(r-1) > 1E-9) then write(Log_Unit,*) 'ij=',i,j,' * dot=',dot end If else if (ABS(r) > 1E-9) then write(Log_Unit,*) 'ij=',i,j,' * dot=',dot end If End If End Do End Do End do Write(Log_Unit,*) 'GS_Test: Completed!' DeAllocate(O,Oinv,V) DeAllocate(PDOT) ! Call FreeBuffer(O) ! Call FreeBuffer(Oinv) ! Call FreeBuffer(V) Return End Subroutine !****************************************************************************** ! ! Update_Oinverse - Updates the Oinverse vectors when the atoms move ! !****************************************************************************** Subroutine Update_Oinverse(FD_Base, Mem) Integer, Intent(IN) :: FD_Base Real, Intent(IN) :: Mem Integer :: MaxRec, Lsize MaxRec = Size(BZ%Ku(1,:)) * PLM_Max If (Proj_Mode == PROJ_RS) then !* Call DetGroups Call RS_CreateOinverse else LSize = Gall_size(G_LOW) Call LRU_InitContext(LRU_GS_Oinv, 'GS_Oinv:', FD_Base, Mem, & MaxRec, LSize, .FALSE.) Call GS_CreateOinverse End if Return End Subroutine !****************************************************************************** ! ! InitOinverse - Initializes the Oinverse routines ! !****************************************************************************** Subroutine InitOinverse(FD_Base, Mem) Integer, Intent(IN) :: FD_Base Real, Intent(IN) :: Mem Integer :: i,j,MaxRec, LSize(0:0) !RETURN If (Proj_Mode == PROJ_RS) then Allocate(RS_Oinv_Scale(PLM_Max, Size(BZ%Ku(1,:)))) Allocate(RS_Oinv(PLM_Max, Size(BZ%Ku(1,:)))) Allocate(Group(Specific_Atoms), Oi_Work1(FFT_Grid(4,G_PROJ))) RS_Oinv(:,:)%N = 0 !** Dummy allocs to get things started *** !* Allocate(group_nmax(1), RS_Oinv_Scale(1)) else Allocate(GS_Oinv_Scale(PLM_Max, Size(BZ%Ku(1,:)))) End if Call Update_Oinverse(FD_Base, Mem) ! Call GS_Test_Oinverse !STOP Return end Subroutine End Module spinpwpaw/code/openfile.f900100664004704100470410000000554610303710172015772 0ustar natalienatalie!****************************************************************************** ! ! File : openfile.f90 ! by : Alan Tackett ! on : 10/31/95 ! for : PAW Project ! ! Routine to open an output file for subsequent writing. If a file is ! already open then it is closed before the new one is opened. ! ! Below is the Format for the command: ! ! OPEN type filname ! ! Where: type - is one of the following - LOG, ERROR, or OUTPUT. ! This determines which file is affected. ! filename - The name of the file to open. If the name is ! SCREEN then ouput is redirected to the screen. ! !****************************************************************************** Subroutine OpenIt(OldUnit, OldName, NewUnit, NewName) Use Word Use paw_inout implicit none Integer, Intent(IN) :: OldUnit Character*(*), Intent(IN) :: OldName Integer, Intent(INOUT) :: NewUnit Character*(*), Intent(INOUT) :: NewName Character*200 :: Token Token = NewName CAll UpperCase(Token) If (OldUnit /= 6) Close(OldUnit) if (Trim(Token) == "SCREEN") then NewUnit = 6 else Open(NewUnit, FILE=NewName, RECL=100000) End If Write(NewUnit, *) ' ' Return End Subroutine Subroutine OpenFile(Input_WC) Use paw_inout Use word Interface Subroutine OpenIt(OldUnit, OldName, NewUnit, NewName) Use Word Use paw_inout Integer, Intent(IN) :: OldUnit Character*(*), Intent(IN) :: OldName Integer, Intent(INOUT) :: NewUnit Character*(*), Intent(INOUT) :: NewName End Subroutine OpenIt End Interface Type (Word_context) :: Input_WC Character*200 :: token, filename, oldfile Integer :: ierr, tlen, oldfd Call GetNextWord(Input_WC, Token, tlen) if (W_Error == W_EOF) Call EOF_Error(Input_WC, 'OpenFile:') Call GetNextWord(Input_WC, Filename, tlen) if (W_Error == W_EOF) Call EOF_Error(Input_WC, 'OpenFile:') Call UpperCase(token) If (Trim(token) == "LOG") then oldfd = Log_Unit; oldFile = Log_Name; Log_Unit = LOG_BASE_UNIT; Log_Name = filename; Call OpenIt(oldfd, oldfile, Log_Unit, Log_Name) else If (Trim(token) == "OUTPUT") then oldfd = Output_Unit; oldFile = Output_Name; Output_Unit = OUTPUT_BASE_UNIT; Output_Name = filename; Call OpenIt(oldfd, oldfile, Output_Unit, Output_Name) else If (Trim(token) == "ERROR") then oldfd = Error_Unit; oldFile = Error_Name; Error_Unit = ERROR_BASE_UNIT; Error_Name = filename; Call OpenIt(oldfd, oldfile, Error_Unit, Error_Name) else Call Word_GetAndPrint(Input_WC, Error_Unit, "OpenFile:") Write(Error_Unit, *) 'OpenFile: Unknown Filetype :',Trim(Token) Write(Error_Unit, *) 'OpenFile: Command Ignored.' End If Return End Subroutine spinpwpaw/code/options_data.f900100664004704100470410000001744010365433010016652 0ustar natalienatalie!****************************************************************************** ! ! File : options_data.f90 ! by : Alan Tackett ! on : 12/07/95 ! for : PAW Project ! ! This file contains the data structures holding run-time options for the PAW ! program. ! ! Updated for spin by Ping Tang and N. A. W. Holzwarth ! Last changed 5/23/05 !****************************************************************************** Module options_data Integer, PARAMETER :: SIM_AE = 0 !** All-electron calculation Integer, PARAMETER :: SIM_PAW = 1 !** PAW calculation Integer, PARAMETER :: SIM_SEPM = 2 !** Semi-empirical PP calculation Integer, PARAMETER :: SIM_TIME = 3 !** Time-dependent calculation !*** Type of potential mixing to perform ** Integer, PARAMETER :: MIX_V = 1 !** Mix V(n~+n^) Integer, PARAMETER :: MIX_VEFF = 2 !** Mix Veff=V(n~+n^)+Vxc+Vlocal Integer, PARAMETER :: MIX_DENSITY = 3 !** Mix the smooth density Integer, PARAMETER :: MIN_MEMORY = 1 !** Conserve memory Integer, PARAMETER :: MIN_TIME = 2 !** Minimize time (default) Integer, PARAMETER :: PROJ_RS = 3 !** Minimize time (default) Integer, PARAMETER :: MD_PREVIOUS = 1 !** Use previous initial guess for MD Integer, PARAMETER :: MD_LCAO = 2 !** Use LCAO for MD initial guess Integer, PARAMETER :: GUESS_LCAO = 1 Integer, PARAMETER :: GUESS_RANDOM = 2 Integer, PARAMETER :: GEOMETRY_BROYDEN = 1 Integer, PARAMETER :: GEOMETRY_LINEAR = 2 Integer, PARAMETER :: EIGEN_DAVIDSON = 1 !** Jacobi-Davidson eigenvalue solver Integer, PARAMETER :: EIGEN_ENERGY = 2 !** Energy partition scheme Integer, PARAMETER :: EIGEN_JDQZ = 3 !** JDQZ scheme Integer, PARAMETER :: EIGEN_BLOCK_DAVIDSON = 4 !** Block-Davidson solver Real :: Vector_Pot(3) !** Current vector potential value Integer :: TIME_MaxN !** Max applications of Hpsi to be used Real :: TIME_tol !** Correction vector tolerance controlling accuracy !****************Spin parameter*********************** Logical :: Spindependence Logical :: Global_Spinup !**************************************************** logical :: Nodiagwithload Integer :: Initial_guess Integer :: Proj_mode Integer :: Run_Mode !** Run mode Integer :: Eigen_Mode Integer :: Angular_Points Integer :: Grid(3) !** Curvilinear grid dimensions Integer :: LCAO_Cells(3) !** LCAO summation cells Integer :: DoLCAO !** Gen LCAO wfns=1 Real :: LCAO_Gcut !** Gcut for LCAO guess Logical :: SCF_DoGramSchmidt !** Do explicit GS orthog in SCF Integer :: AtomicVxc_Step !** Step size for Atomic Vxc calc Integer :: MD_guess !** MD initial guess type Logical :: forces_Always_Calc_H Real :: Force_Zero !** force min non-0 value Real :: Eigen_Max !** Used for Band Structure mode Real :: AndersonConditionNo !** Anderson Mix SVD parameter Logical :: Calc_O_Eigenvalues !** Controls eigenvalue solver Logical :: Filter_Potential !** Controls truncation of V Real :: Overlap_Tol !** Min overlap eigenvalue kept ! for generalized eigenvalues Logical :: HamLoaded !** True if CalcHam or LoadHam called Real :: ClusterTol !** Tolerance for eigenvalue clusters Integer :: Geometry_Move !** type of move for geometry update Integer :: Mix_Size !** # of vects to mix for V/den Logical :: SaveUnmixed !** Option for storedata output Character*100 :: SolnFilename !** File to read initial guess from Integer :: Vxc_MinSize !** Min # of points for Vxc calc Real :: Psi_Memory !** Mem for Psi's Real :: Proj_Memory !** MEmory to use in Mbytes for Radial Projs Real :: Bloch_Memory !** MEmory to use in Mbytes for Phase Real :: Ylm_Memory !** Mem for Ylm's Integer :: User_MaxTotalPsi !** Max Psi's set by the user(optional) Integer :: User_MinPsi !** Min Psi's set by the user(optional) Integer :: GMRES_Size !** Number of basis vectors for GMRES Real :: TimeStep !** Time step for MD runs Real :: Geometry_NewMix !** Mixing factor for Gemotry relaxations Real :: V_Weight !** Scale factor for V Real :: V_NewMix !** Mixing factor for V Real :: V_DampNewMix Real :: Dij_NewMix !** Mixing factor for Dij's Real :: Dij_DampNewMix Real :: Mix_DampRelative Integer :: V_MixType !** Type of potential mixing(V or Rho) Real :: V_Smooth_Width !** Smoothing of V in H*Psi to control conv. Integer :: V_CorrIter(3) !** V control(1=Loops,2=DoGMRES,3=JacIter) Integer :: Psi_CorrIter(3) !** Psi control Real :: Debug_Fraction_Slice(3) Integer, Pointer :: Debug_Slice(:,:) Integer :: Debug_Dir Integer :: Debug_Grid_Dir Integer :: Atomic_Mode !** Type of calculation AE or PAW Real :: PW_Gcut(3) !** PW G-cut Real, Pointer :: User_Kpoints(:,:) !** List of k-points from the user !** in fractions of recip lattice !******** Boundary condition data ******* Integer, PARAMETER :: BC_PLANE = 0 !** Plane boundary condition Integer, PARAMETER :: BC_VALUE = 0 !** Fill condition with value Type Boundary_Data Integer :: Condition_Type !** Type of condition Integer :: Plane_Dir !** Which Plane ->x,y,z Integer :: Fill_type !** Fill type Integer :: Plane_Start !** Start Plane index Integer :: Plane_End !** End plane index Complex :: Value !** Fill Value End Type Type (Boundary_Data), Pointer :: Boundary_List(:) Integer :: Boundary_Size Integer, PARAMETER :: BC_PER = 0 !** Periodic boundary conditions Integer, PARAMETER :: BC_NONPER = 1 !** Non-periodic boundary cond Integer :: BC_Mode(3) Type Electric_Field_Type !** Define the electric field data structure Integer :: Etype Real :: E0(3) Real :: T0 Real :: Phase Real :: Frequency End Type Type (Electric_Field_type) :: E_field Integer, PARAMETER :: E_SINE = 0 !** Sine wave E-field !*** Timing variables ** Real :: Parallel_Time !** Parallel time Real :: Serial_Time !** Serial or setup time Real :: Global_Start_Time !** Starting time AFTER init for SCF solve Real :: Start_Time !** Local start time for accumulating Par/Serial total !*** Load Balancing variables *** Real :: Scale_MaxJobPerCPU Real :: Scale_MinJobPerCPU Integer :: Matrix_Range(5) Integer, PARAMETER :: RANGE_DO = 1 Integer, PARAMETER :: RANGE_SKIP = 2 Logical :: BandStructure_Mode !** Do band struct calcs with fixed Ham Logical :: ReCalculate_Occupancies !** false for band structure plotting Integer :: Dummy_Integer !** Dummy variables for intermediate testing Real :: Dummy_Real Integer, PARAMETER :: JDQZ_PRECOND_ONCE = 0 !** Make 1 prec/iter Integer, PARAMETER :: JDQZ_PRECOND_CLUSTER = 1 !** Prec each cluster/iter Real :: JDQZ_Energy !** Shift energy for JDQZ method Integer :: JDQZ_MaxMV !** Max number of matrix-vector prod's for JDQZ Integer :: JDQZ_WaitIter !** Wait iterations before JDQZ method is used Integer :: JDQZ_Precond_Mode !** Preconditioner mode Integer :: JDQZ_Qmax Integer :: JDQZ_Qmin Integer :: JDQZ_Jmax Integer :: JDQZ_Jmin Integer :: JDQZ_MaxPerBand Real :: JDQZ_eps Real :: JDQZ_TargetShift Logical :: JDQZ_Spatial_Selection End Module spinpwpaw/code/orbital_matrix.f900100664004704100470410000001165210303710172017204 0ustar natalienatalie!****************************************************************************** ! ! File : orbital_matrix.f90 ! by : Alan Tackett ! on : 11/09/95 ! for : PAW project ! ! Orbital_Matrix - Initializes the aqlm, avlm, and anlm arrays for the given ! fixed atom data. ! ! atom - Fixed atom data structure to use ! ArraySize - If this variable is set to -1 then no data is stored ! and the number of nonzero elements are determined and ! returned in ArraySize ! ! ! The form of the aqlm and avlm cooeficients are defined below. ! ! LM aL ! aqlm(:) = G N (see WN46) ! l m l m n l n l ! i i j j i i j j ! ! M L-M ^ aL ! avlm(:) = (-1) G v (see WN47) ! l m l m n l n l ! i i j j i i j j ! ! Where the G's are Gaunt coefficients and N is the fixed atom density. ! The various l's amd m's are determined by the atomic orbitals defined ! for the specific atom. Capital L is a value in the range of ! ! |l - l | <= L <= (l + l ) ! i j i j ! ! Based on the symmetry properties of the Gaunt coefficients you know that ! ! LM ! G != 0 if (l + l + L) is EVEN and M = m - m and |M| <= L ! l m l m i j j i ! i i j j ! ! ! For this reason the indices that have to be stored are : ! ! (n l ) (n l ) m m L ! i i j j i j ! ! For avlm the m's need to be negated in order to get the proper indices,ie, ! ! if m = 1 and m = 2 then m = -1 and m = -2 for avlm ! i j i j ! ! This helps minimive storage space. ! ! Based on the symmetry of the Gaunt coefficients, n's and v's only ! half of the values need to be stored, li < lj, to get the flipped value ! you just multiply by (-1)^M (I think?? Ask Natalie) ! ! ! NOTE : This routine assumes that the V_Hat and Density variables contained ! in the atom data structure are encoded based on the above idea and ! that the orbitals are stored in increasing order. ! ! The LUT must use 4 byte or greater integers for the index encoding! ! !****************************************************************************** Subroutine Orbital_Matrix(atom, Array_Size) Use atom_data Use spherical_harmonic Use paw_inout Use word Use orbital_pack Use denvhat_pack Implicit None Type(Atom_Info_Fixed), Intent(INOUT) :: atom Integer, Intent(INOUT) :: Array_Size Integer :: cnt, Num_Orbitals, denvhat_cnt Integer :: Lmin, Lmax, i, j Integer :: li, lj, mi, mj, L, m Integer :: nili, njlj Integer, Pointer :: L_Value(:), LUT_orb(:), LUT_denvhat(:) Real, Pointer :: Vhat(:), den(:), aqlm(:), avlm(:) Real :: g !OPEN(29,file='orb.out') !write(29,*) 'Ni Nj Li Lj Mi Mj L M' Vhat => atom%V_Hat Den => atom%Density L_Value => Atom%L_Value aqlm => Atom%aqlm avlm => Atom%avlm LUT_orb => Atom%LUT_orb LUT_denvhat => Atom%LUT_denvhat Num_Orbitals = Atom%Basis_Size cnt = 0 Do denvhat_cnt = 1, Atom%DenVhat_Size Call DenVhat_Decode(LUT_denvhat(denvhat_cnt), nili, njlj, L) li = L_value(nili); lj = L_Value(njlj); If (nili == njlj) then j = 1 !** No mirror image Else j = 2 !** Indices are different so do it twice End If !write(Log_Unit,*) 'Orbital_Matrix: DenVHat_Cnt=',denvhat_cnt, ' * J=',j, ' nili=',nili, ' * njlj=', njlj Do i=1, j !** Possibly do it twice If (i==2) then !** If 2nd time through then swap nili, njlj !write(Log_Unit,*) 'Orbital_MAtrix: Swapping nili and njlj' m = nili; nili=njlj; njlj = m; m = Li; Li = Lj; Lj = m; End If !write(Log_Unit,*) 'Orbital_Matrix: nili,njlj=',nili,njlj Do mi = -li, li Do mj = -lj, lj M = mj - mi !write(Log_Unit,*) 'Orbital_Matrix: mi,mj,L,M=',mi,mj,l,m if (abs(M) <= L) then cnt = cnt + 1 if (Array_Size > 0) then !** Check to see if we store it LUT_Orb(cnt) = Orbital_Encode(nili, njlj, mi, mj, L) aqlm(cnt) = Den(denvhat_cnt) * Gaunt(L, M, li, mi, lj, mj) avlm(cnt) = Vhat(denvhat_cnt) * Gaunt(L,M,li, mi, lj, mj) if (Mod(ABS(M),2) == 1) avlm(cnt) = -avlm(cnt) !write(29, '(8i3,2f)') nili,njlj,li,lj,mi,mj,L,M, avlm(cnt), Gaunt(L,M,li,mi,lj,mj) !write(Log_Unit,*) 'orbital_Matrix: cnt=',cnt, '* den=',den(denvhat_cnt) !write(Log_Unit,*) 'orbital_Matrix: nili,njlj,mi,mj,L=',nili,njlj,mi,mj,l !Write(Log_Unit,*) 'Orbital_Matrix: avlm=',avlm(cnt), ' * aqlm=',aqlm(cnt) End If End If End Do End Do End Do End Do close(29) Array_Size = cnt Return End Subroutine spinpwpaw/code/orbital_pack.f900100664004704100470410000001021310303710172016606 0ustar natalienatalie!****************************************************************************** ! ! File : orbital_pack.f90 ! by : Alan Tackett ! on : 11/08/95 ! for : PAW Method ! ! Contains 2 routines to encode and decode the orbital matrix indices that are ! used in the atom_data module for the fields aqlm, and avlm. ! ! LM aL ! aqlm(:) = G N (see WN46) ! l m l m n l n l ! i i j j i i j j ! ! M L-M ^ aL ! avlm(:) = (-1) G v (see WN47) ! l m l m n l n l ! i i j j i i j j ! ! ! Where the G's are Gaunt coefficients and N is the fixed atom density. ! The various l's amd m's are determined by the atomic orbitals defined ! for the specific atom. Capital L is a value in the range of ! ! |l - l | <= L <= (l + l ) ! i j i j ! ! Based on the symmetry properties of the Gaunt coefficients you know that ! ! LM ! G != 0 if (l + l + L) is EVEN and M = m - m ! l m l m i j j i ! i i j j ! ! ! For this reason the indices that have to be stored are : ! ! (n l ) (n l ) m m L ! i i j j i j ! ! Bits Required: (5) (5) (3) (3) (3) = 19 bits total ! ! Each l value is in the range on 0..3 and the corresponding m is in the ! range of -l <= m <= l for 2*l + 1 possible values. This gives the range ! for L = 0..6. The (nl) indices are stored as pairs which correspond ! to the actual basis function index. Since only 5 bits are used the max ! number of basis functions is 32 for each atom. The l's can be determined ! from the (nl)'s and hence are not stored. ! ! For avlm the m's need to be negated in order to get the proper indices,ie, ! ! if m = 1 and m = 2 then m = -1 and m = -2 for avlm ! i j i j ! ! This helps minimive storage space. ! ! Also note that since 19 bits are required each integer should ! be 4 byte integer. The 19 LSB's are used all other bits are set to 0. ! ! ******* NOTE: No Error checking is done!!!!!! ******** ! !****************************************************************************** Module orbital_pack implicit none !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! Orbital_Encode - Encodes the given nili,njlj, li, lj, mi, mj, and L supplied ! assuming the above restrictions on l's, m's, and L. ! ! ! NOTE : NO error checking is done!!!! ! The return value must be a 4 byte or greater integer!! ! !****************************************************************************** Integer Function Orbital_Encode(nili, njlj, mi, mj, L) Integer, Intent(IN) :: nili Integer, Intent(IN) :: njlj Integer, Intent(IN) :: mi Integer, Intent(IN) :: mj Integer, Intent(IN) :: L Integer :: N N = nili N = ISHFT(N, 5) + njlj N = ISHFT(N, 3) + mi+3 N = ISHFT(N, 3) + mj+3 N = ISHFT(N, 3) + L Orbital_Encode = N Return End Function !****************************************************************************** ! ! Orbital_Decode - Decodes the given value(N) into the separate nili, njlj, ! li, lj, mi, mj, and L assuming the above restrictions on ! (nl)'s, l's, m's, and L. ! ! ! NOTE : NO error checking is done!!!! ! The default integer must be a 4 byte or greater integer!! ! !****************************************************************************** Subroutine Orbital_Decode(N, nili, njlj, mi, mj, L) Integer, Intent(IN) :: N Integer, Intent(OUT) :: nili Integer, Intent(OUT) :: njlj Integer, Intent(OUT) :: mi Integer, Intent(OUT) :: mj Integer, Intent(OUT) :: L nili = ISHFT(IAND(31*(2**14), N), -14) njlj = ISHFT(IAND(31*(2**9), N), -9) mi = ISHFT(IAND(7*(2**6), N), -6) - 3 mj = ISHFT(IAND(7*(2**3), N), -3) - 3 L = IAND(7, N) Return End Subroutine End Module spinpwpaw/code/paw_end.f900100664004704100470410000000112710303710172015575 0ustar natalienatalie!*************************************************************************** ! ! File : paw_end.f90 ! by : Alan Tackett ! on : 7/26/98 ! for : PAW Project ! ! ! PAW_End - Performs an orderly close of the PAW program ! !*************************************************************************** Subroutine paw_End Use paw_inout Use word Use timing Implicit NONE!!!! character*100 :: msg Call Print_Timers(Log_Unit) msg = 'Exiting PAW program' Write(Output_Unit, *) msg Write(Error_Unit, *) msg Write(Log_Unit, *) msg !Call SendQuit STOP Return End Subroutine spinpwpaw/code/paw_init.f900100664004704100470410000001144010365433031015775 0ustar natalienatalie!*************************************************************************** ! ! File : paw_init.f90 ! by : Alan Tackett ! on : 7/27/98 ! for : PAW Project ! ! ! PAW_Init - Performs Initialization for the PAW program ! !*************************************************************************** Subroutine PAW_Init Use crystal_data Use paw_inout Use exchange_corr Use atom_data Use options_data Use spherical_harmonic Use mem_data Use local_criteria_lib Implicit NONE!!!!! Print_Level = PRINT_NORMAL !** Output Level *** !*** Adjoint_PARALLEL = .TRUE. !** Default adjoint mode to parallel Log_Name = "SCREEN" !** Init output filenames Output_Name = "SCREEN" Error_Name = "SCREEN" Band_Name = "paw.bands" Charge_Name = "paw.charges" Force_Name = "paw.forces" DOS_Name = "paw.dos" PLOT_Name = "plot" Sym_Name = 'RUNTIME' Pos_Name = "paw.pos" Best_Name = "" Log_Unit = 6 !*** Setup Output Units **** Output_Unit = 6 Error_Unit = 6 Length_Output_Unit = LENGTH_UNIT !*** Define Output Units *** Energy_Output_Unit = ENERGY_UNIT XC_Type = XC_LDA_PW !*** Set default Exchange Correlation type *** XC_Type_Set = .false. !*** Exchange-correlation type not yet explicitly set Spindependence = .false. !*** Default spin unrestricted calculation Global_spinup = .true. !*** Default to Dij, etc. !*** false uses Dijspin, etc. Nodiagwithload = .false. !** used in LoadHamandPsi ! .true. used to by-pass diagonalization ! of Hamiltonian Angular_Points = 12 !** Set angular integration mesh Run_Mode = MIN_TIME !** Minimize execution time Proj_mode = 0 SCF_DoGramSchmidt = .FALSE. !** Don't do explicit GS orthog Eigen_Mode = EIGEN_DAVIDSON Calc_O_Eigenvalues = .true. !Diagonalize O matrix for gen. eigen. problem Filter_potential = .false. !Do not truncate potential at G_PROJ Overlap_Tol = 1E-11 ! minimum overlap eigenvalue for generalized eigenvalues HamLoaded = .FALSE. ! set to true with CalcHam or LoadHam SaveUnmixed = .FALSE. ! Storedata output from Anderson mix Atom_Types = 0 !*** Init different Atom Types Max_Atom_types = 0 UseShells = .false. !** Default is not to use shell parameterization Specific_Atoms = 0 !** Initialize atom count Atomic_Mode = SIM_PAW !** Default to PAW simulation Vector_Pot = 0 !** Zero vector potential TIME_MaxN = 20 Time_Tol = 1E-15 Xtal_Defined = .FALSE. !*** No Xtal is defined *** !** BZ_Defined = .FALSE. !*** No BZ currently set *** BC_Mode = BC_PER LCAO_Cells = 1 !** Sum over nn for initial LCAO psi's DoLCAO = 1 !** Use LCAO initial wave functions Initial_guess = DoLCAO ClusterTol = 0.07 Psi_Memory = 40 Proj_Memory = 40 Bloch_Memory = 5 Ylm_Memory = 5 PAW_FirstTime = .TRUE. !CAll InitSpharm User_MaxTotalPsi = -1 !** By default disable this option User_MinPsi = -1 !** By default disable this option Boundary_Size = -1 !** Default is no special boundary conditions BC_Mode = BC_PER TimeStep = 1 !** Default DT for MD run V_Weight = 1.0 V_NewMix = 0.5 V_DampNewMix = 0.25 Dij_NewMix = 1.0 Dij_DampNewMix = 1.0 V_MixType = MIX_VEFF Geometry_NewMix = 0.5 Mix_DampRelative = 0.2 LCAO_Gcut = 10000 !** Init LCAO Gcut to use ALL Psi G's MD_Guess = MD_PREVIOUS Forces_Always_Calc_H = .FALSE. Force_Zero = 1E-10 Eigen_Max = 1 !** Init max eigenvalue for CalcBandMerit AndersonConditionNo = 10000 !** Initial value for Anderson SVD AtomicVxc_Step = 1 !** Don't skip any is the default V_CorrIter = (/10, 1, 10/) !** GMRES solver Loops, DoGMRES, JacobiIter Psi_CorrIter = (/10, 1, 10/) Debug_Fraction_SLice = 0.0 Debug_Dir = 1 NuclearEnergy = 0 BandStructure_Mode = .FALSE. ReCalculate_Occupancies = .TRUE. Scale_MaxJobPerCPU = 0.5 Scale_MinJobPerCPU = 0.1 !** Currently not used Geometry_Move = GEOMETRY_BROYDEN Dummy_Integer = 0 Dummy_Real = 0 Anchor = .false. AnchorIndex = 1 Mix_Size = 5 !** Default V/density mixing size NULLIFY(Move_AC) JDQZ_Energy = -5 JDQZ_MaxMV = 5 ! JDQZ_WaitIter = 5 JDQZ_WaitIter = 500 !** Never turn it on JDQZ_Precond_Mode = JDQZ_PRECOND_ONCE JDQZ_Qmax = 10 JDQZ_Qmin = 5 JDQZ_Jmax = 2*JDQZ_Qmax JDQZ_Jmin = JDQZ_Qmax JDQZ_MaxPerBand = 2 JDQZ_eps = 1E-10 JDQZ_TargetShift = -0.1 JDQZ_Spatial_Selection = .FALSE. V_Smooth_Width = 0 !** Default to no High G smoothing of the potential Return End Subroutine spinpwpaw/code/paw_inout.f900100664004704100470410000001710410303710172016167 0ustar natalienatalie!***************************************************************************** ! ! File : paw_inout.f90 ! by : Alan Tackett ! on : 8/29/95 ! for : PAW method ! ! Contains input/output constants and definitions needed for the MAE method ! along with several routines for handling user I/O. ! !***************************************************************************** Module paw_inout Use strings Use Units Use Word implicit none !*** Define Constants that control output level **** Integer, PARAMETER :: PRINT_TERSE = 4 !** Print only results Integer, PARAMETER :: PRINT_COMMANDS = 3 !** Print Commands and results only Integer, PARAMETER :: PRINT_NORMAL = 2 !** Normal output Integer, PARAMETER :: PRINT_VERBOSE = 1 !** Everything output(usually debug) Integer :: Print_Level !** Variable that controls output info !*** Define Reserved output unit numbers *** Integer, PARAMETER:: LOG_BASE_UNIT = 10 !* Reserved log Unit if NOT screen Integer, PARAMETER:: OUTPUT_BASE_UNIT= 11 !* Reserved output unit if NOT screen Integer, PARAMETER:: ERROR_BASE_UNIT = 12 !* Reserved error Unit if NOT screen Integer, PARAMETER:: BAND_IN = 13 !** Reserved for Band Struct Kpnts Integer, PARAMETER:: BAND_OUT = 14 !** Reserved for Band Struct Output Integer, PARAMETER:: SCRATCH_UNIT = 15 !* Reserved unit for scratch work Integer, PARAMETER:: BANDOUT_UNIT = 16 ! Output for band results Integer, PARAMETER:: CHARGEOUT_UNIT = 17 ! Output for charge results Integer, PARAMETER:: FORCE_UNIT = 18 ! Output for force results Integer, PARAMETER:: TOTALCURRENT_UNIT = 19 ! Total current unit Integer, PARAMETER:: E_UNIT = 20 ! Electric field unit Integer, PARAMETER:: POSITIONS_UNIT = 21 ! Atomic positions and forces unit !**** Define Output Units and their filenames **** Integer :: Log_Unit !** Log file unit Integer :: Output_Unit !** Output file unit for results Integer :: Error_Unit !** Unit for error output Character*200 :: Log_Name !** Log Filename Character*200 :: Output_Name !** Output Filename Character*200 :: Error_Name !** Error Filename Character*200 :: Band_Name ! Filename for band output Character*200 :: Charge_Name ! Filename for charge output Character*200 :: Sym_Name ! Filename for symmetry output Character*200 :: Force_Name ! Filename for force output Character*200 :: DOS_Name ! Filename for DOS output Character*200 :: PLOT_Name ! Filename for 2d or 3d output data Character*200 :: TotalCurrent_Name! Filename for Total current output Character*200 :: E_Name ! Filename for electric field Character*200 :: Pos_Name ! Filename atom positions and forces Character*200 :: Best_Name ! Filename for storing lowest energy results !**** Define Input configuration **** Integer, PARAMETER :: INPUT_BASE_UNIT = 40 !** Base input unit Integer, PARAMETER :: MAX_INCLUDE = 10 !** Max Level of Include file Character*7, PARAMETER :: INCLUDE_STR = "INCLUDE"!** Include String Character*8, PARAMETER :: DELIMS = " ()[]{}," !** System Delimiters Character*1, PARAMETER :: COMMENT = "#" !** Comment Character Character*1, PARAMETER :: LIT_CHAR = "'" !** Literal Character Integer, PARAMETER :: MAX_FILE_UNIT = 200 Type(Word_context), TARGET :: paw_WC !** Main input context !**** Define system Units **** Integer, PARAMETER :: Length_Unit = U_BOHR Integer, PARAMETER :: Energy_Unit = U_EV !**** Define Variables for Output Units ***** Integer :: Length_Output_Unit Integer :: Energy_Output_Unit !*** Define File units for the different modules ***** Integer, PARAMETER :: FD_BASE = 110 Character*(*), PARAMETER :: FILENAME_PSI = "psi.wfn" !** PSi file !!!Integer :: XC_Type !*** Exchange Correlation Type - NOT USED Logical :: PAW_FirstTime Interface GetRealsWithUnit Module Procedure SNGLE_GetRealsWithUnit Module Procedure ARRAY_GetRealsWithUnit End Interface Contains !***************************************************************************** ! ! SNGLE_GetRealswithUnit - Gets a real number from the input with an optional ! unit and converts it to the requested unit. ! If the next token is not a unit then the token is returned. ! ! Number - Where to store the number ! Output_Unit - Output unit ! token - Token or next word in the input if not a unit ! ! Return Values ! If the next 2 tokens comprise a number, unit pair then FALSE is ! returned otherwise TRUE is returned along with the token. ! !***************************************************************************** Logical Function SNGLE_GetRealsWithUnit(wc, Number, Output_Unit, Token, InUnit) Type (Word_Context), Intent(INOUT) :: WC Real, Intent(OUT) :: Number Integer, Intent(IN) :: Output_Unit Character*(*), Intent(OUT) :: Token Integer, Optional, Intent(OUT) :: InUnit Integer :: j, tlen Logical :: ExtraToken Call GetNumber(WC, Number) Call GetNextWord(WC, token, tlen) Call UpperCase(token) j = Str2Unit(token) if (j /= -1) then if (Present(INUnit)) InUnit = j ExtraToken = .FALSE. Number = Number * ConvertFactor(j, OUTPUT_Unit) else ExtraToken = .TRUE. End If SNGLE_GetRealsWithUnit = ExtraToken Return End Function !***************************************************************************** ! ! ARRAY_GetRealswithUnit - Gets a real vector from the input with an optional ! unit and converts it to the requested unit. ! If the next token is not a unit then the token is returned. ! ! Number - Where to store the number ! Output_Unit - Output unit ! token - Token or next word in the input if not a unit ! VecLen - Vector Length ! ! Return Values ! If the next 2 tokens comprise a number, unit pair then FALSE is ! returned otherwise TRUE is returned along with the token. ! !***************************************************************************** Logical Function ARRAY_GetRealsWithUnit(WC, Number, Output_Unit, Token, VecLen) Type (Word_Context), Intent(INOUT) :: WC Real, Intent(OUT) :: Number(:) Integer, Intent(IN) :: Output_Unit Character*(*), Intent(OUT) :: Token Integer, Optional, Intent(IN) :: VecLen Integer :: j, tlen, k Logical :: ExtraToken if (PRESENT(VecLen)) then k = VecLen else k = Size(Number) End If if (k > 1) Call GetNumbers(WC, Number, k-1) ExtraToken = SNGLE_GetRealsWithUnit(wc, Number(k), Output_Unit, token, j) if ((.NOT. ExtraToken) .AND. (k>1)) then Number(1:k-1) = Number(1:k-1) * ConvertFactor(j, OUTPUT_Unit) End If ARRAY_GetRealsWithUnit = ExtraToken Return End Function !***************************************************************************** ! ! EOF_Error - Prints a message telling the user an unexpected EOF occured ! ! IDText - Identification string telling where in the program the error ! occured. ! !***************************************************************************** Subroutine EOF_Error(WC, IDText) Use word Type (Word_Context), Intent(INOUT) :: WC Character*(*) :: IDText Character*100 :: msg Write(Error_Unit, *) Trim(IDText), " Unexpected Error encountered!" !Call GError(msg) !not available on the SP2 Write(Error_Unit, *) Trim(IDText), ' ', Trim(msg) Call Word_GetAndPrint(WC, Error_Unit, IDText) STOP Return End Subroutine End Module spinpwpaw/code/prepareballandstick.f900100664004704100470410000001605510303710172020200 0ustar natalienatalie!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Program prepareballandstick ! ! Stand-alone program to determine atomic positions and bonds ! Calculate atomic positions and bonds for Ball and Stick model ! (Data Explorer output and XCrysden output) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Implicit None Real*8, allocatable :: ballpoints(:,:) Real*8 :: resx, resy, resz ,plotmat(3,3),solvmat(3,3),v(3),vin(3),vout(3) Real*8 :: chk,rtol,tx,ty,tz,XA,YA,ZA,A(3),B(3),C(3) Real*8, parameter :: atol=1.e-3 Real*8 :: maxbond Integer, allocatable :: noballs(:),z(:) Integer :: ncount,ncountmax,many,ierr,npair,i,j,k,n,ier,specific_atoms Integer :: CHARGEOUT_UNIT=9 Character*80 :: Plot_Name, Positions_Name, Readline write(*,*) 'Enter filename for plotting output' read(*,*) Plot_Name write(*,*) 'Enter lattice vectors A,B,C in Cartesian coordinates' read(*,*) A(1),A(2),A(3) read(*,*) B(1),B(2),B(3) read(*,*) C(1),C(2),C(3) ! file for plotting axes Open(unit=CHARGEOUT_UNIT,& file=Trim(PLOT_Name)//".cell.dx",form="formatted") write(CHARGEOUT_UNIT,& '("object 2 class array type float rank 1 shape 3 items 3 data follows")') write(CHARGEOUT_UNIT,'(1p3e15.7)') A(1),A(2),A(3) write(CHARGEOUT_UNIT,'(1p3e15.7)') B(1),B(2),B(3) write(CHARGEOUT_UNIT,'(1p3e15.7)') C(1),C(2),C(3) write(CHARGEOUT_UNIT,'("attribute ""dep"" string ""positions""")') write(CHARGEOUT_UNIT,'("#")') write(CHARGEOUT_UNIT,'("end")') close (CHARGEOUT_UNIT) Open(unit=CHARGEOUT_UNIT,& file=Trim(PLOT_Name)//".axes.dx",form="formatted") write(CHARGEOUT_UNIT, & '("object 1 class array type float rank 0 items 8 data follows")') write(CHARGEOUT_UNIT,'(" 1 1 1 1 1 1 1 1")') write(CHARGEOUT_UNIT,'("attribute ""dep"" string ""positions""")') write(CHARGEOUT_UNIT,'("#")') write(CHARGEOUT_UNIT,& '("object 2 class array type float rank 1 shape 3 items 8 data follows")') v=0 write(CHARGEOUT_UNIT,'(1p3e15.7)') v(1:3) write(CHARGEOUT_UNIT,'(1p3e15.7)') A(1),A(2),A(3) write(CHARGEOUT_UNIT,'(1p3e15.7)') A(1)+B(1),A(2)+B(2),A(3)+B(3) write(CHARGEOUT_UNIT,'(1p3e15.7)') B(1),B(2),B(3) write(CHARGEOUT_UNIT,'(1p3e15.7)') C(1),C(2),C(3) write(CHARGEOUT_UNIT,'(1p3e15.7)') A(1)+C(1),A(2)+C(2),A(3)+C(3) write(CHARGEOUT_UNIT,'(1p3e15.7)') A(1)+B(1)+C(1),A(2)+B(2)+C(2),& A(3)+B(3)+C(3) write(CHARGEOUT_UNIT,'(1p3e15.7)') B(1)+C(1),B(2)+C(2),B(3)+C(3) write(CHARGEOUT_UNIT,'("attribute ""dep"" string ""positions""")') write(CHARGEOUT_UNIT,'("#")') write(CHARGEOUT_UNIT, & '("object 3 class array type int rank 1 shape 2 items 12 data follows")') write(CHARGEOUT_UNIT, '(" 0 1")') write(CHARGEOUT_UNIT, '(" 1 2")') write(CHARGEOUT_UNIT, '(" 2 3")') write(CHARGEOUT_UNIT, '(" 3 0")') write(CHARGEOUT_UNIT, '(" 4 5")') write(CHARGEOUT_UNIT, '(" 5 6")') write(CHARGEOUT_UNIT, '(" 6 7")') write(CHARGEOUT_UNIT, '(" 7 4")') write(CHARGEOUT_UNIT, '(" 0 4")') write(CHARGEOUT_UNIT, '(" 1 5")') write(CHARGEOUT_UNIT, '(" 2 6")') write(CHARGEOUT_UNIT, '(" 3 7")') write(CHARGEOUT_UNIT,'("attribute ""element type"" string ""lines""")') write(CHARGEOUT_UNIT,'("attribute ""ref"" string ""positions""")') write(CHARGEOUT_UNIT,'("#")') write(CHARGEOUT_UNIT,'("object ""molecule"" class field")') write(CHARGEOUT_UNIT,'("component ""data"" value 1")') write(CHARGEOUT_UNIT,'("component ""positions"" value 2")') write(CHARGEOUT_UNIT,'("component ""connections"" value 3")') write(CHARGEOUT_UNIT,'("attribute ""name"" string ""molecule""")') write(CHARGEOUT_UNIT,'("#")') write(CHARGEOUT_UNIT,'("end")') close (CHARGEOUT_UNIT) ! file for atomic positions Open(unit=CHARGEOUT_UNIT,& file=Trim(PLOT_Name)//".atom.dx",form="formatted") ! Rough estimate of number atoms in plot write(*,*) 'datafile name containing atom positions' read(*,*) Positions_Name write(*,*) 'input maximum bond length' read(*,*) maxbond open(7,file=TRIM(Positions_Name),form="formatted") specific_atoms=0 do read(7,*,iostat=ier) i if (ier==0) then specific_atoms=specific_atoms+1 else exit endif enddo rewind(7) ncountmax=Specific_Atoms Allocate(noballs(ncountmax),ballpoints(3,ncountmax),z(ncountmax)) noballs=0 ballpoints=0 ncount=0 do n=1,Specific_Atoms ! Some assumptions here about shape of cell ncount=ncount+1 read(7,*) noballs(ncount),z(ncount),vout(:) ballpoints(:,ncount)=A(:)*(vout(1)+0.5d0)+B(:)*(vout(2)+0.5d0) & + C(:)*(vout(3)+0.5d0) Enddo ! output atomic coordinates for Data Explorer write(CHARGEOUT_UNIT, & '("object 1 class array type float rank 0 items",i4," data follows")') & ncount write(CHARGEOUT_UNIT,*) (noballs(i),i=1,ncount) write(CHARGEOUT_UNIT,'("attribute ""dep"" string ""positions""")') write(CHARGEOUT_UNIT,'("#")') write(CHARGEOUT_UNIT,& '("object 2 class array type float rank 1 shape 3 items",i4," data follows")') & ncount do i=1,ncount write(CHARGEOUT_UNIT,*) ballpoints(1:3,i) enddo write(CHARGEOUT_UNIT,'("attribute ""dep"" string ""positions""")') write(CHARGEOUT_UNIT,'("#")') chk=maxbond**2 npair=0 do i=1,ncount-1 do j=i+1,ncount v=ballpoints(:,i)-ballpoints(:,j) if(DOT_Product(v,v).le.chk) then npair=npair+1 ! write(CHARGEOUT_UNIT,*) i,j endif enddo enddo write(CHARGEOUT_UNIT, & '("object 3 class array type int rank 1 shape 2 items",i4," data follows")')& npair do i=1,ncount-1 do j=i+1,ncount v=ballpoints(:,i)-ballpoints(:,j) if(DOT_Product(v,v).le.chk) then write(CHARGEOUT_UNIT,*) i-1,j-1 endif enddo enddo write(CHARGEOUT_UNIT,'("attribute ""element type"" string ""lines""")') write(CHARGEOUT_UNIT,'("attribute ""ref"" string ""positions""")') write(CHARGEOUT_UNIT,'("#")') write(CHARGEOUT_UNIT,'("object ""molecule"" class field")') write(CHARGEOUT_UNIT,'("component ""data"" value 1")') write(CHARGEOUT_UNIT,'("component ""positions"" value 2")') write(CHARGEOUT_UNIT,'("component ""connections"" value 3")') write(CHARGEOUT_UNIT,'("attribute ""name"" string ""molecule""")') write(CHARGEOUT_UNIT,'("#")') write(CHARGEOUT_UNIT,'("end")') Close(CHARGEOUT_UNIT) ! XCrysDen output Open(unit=CHARGEOUT_UNIT,& file=Trim(PLOT_Name)//".xsf",form="formatted") Write(CHARGEOUT_UNIT,'(" CONVVEC")') write(CHARGEOUT_UNIT,'(1p3e15.7)') A(1:3) write(CHARGEOUT_UNIT,'(1p3e15.7)') B(1:3) write(CHARGEOUT_UNIT,'(1p3e15.7)') C(1:3) Write(CHARGEOUT_UNIT,'(" ATOMS")') do i=1,ncount j=z(i)+0.0001 write(CHARGEOUT_UNIT,'(i8,2x,1p3e15.7)') j, ballpoints(1:3,i) enddo End Program spinpwpaw/code/preparepdos.f900100664004704100470410000001043610303710172016507 0ustar natalienatalie!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Program preparepdos ! 9/4/99 Natalie Holzwarth ! ! Program to read dos or pdos output from pwpaw pgm and generate ! plotting output ! ! calling argument : filename for pwpaw output ! ! For pdos output, the result is averaged over the specified spheres ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! implicit none Real*8 :: derf Real, parameter :: eunit=13.6056981 ! Rydberg to eV conversion Real, allocatable :: charges(:),e(:),dos(:),pdos(:,:),tdos(:) Integer, allocatable :: NMap(:),Map(:,:) Real :: Pi,sigma,e0,de,x,enk,fnk,term,fac,shift Character*2 :: eval Character*80 :: filenm,description Integer :: Nsphere,Ntot Integer :: ne,npdos,nk,ierr,i,j,k,ie,iunit External GetArg Call GetArg(1,filenm) iunit=7 open(unit=iunit, file=trim(filenm), form='formatted') open(unit=iunit+1, file=trim(filenm)//'.dosout', form='formatted') write(iunit+1,*) 'HEADER LINE -- dos results for ',trim(filenm) read(iunit,*) Nsphere !# of pdos spheres read(iunit,*) Ntot !# of k and eigenvalue entries If (Nsphere.gt.0) then Write(6,*) 'PDOS information available for',Nsphere,' sites' Do i=1,Nsphere read(iunit,'(a80)') description write(6,'(a80)') description End Do Allocate(charges(Nsphere)) Write(6,*) 'enter # of pdos results to calculate' read(5,*) npdos If (npdos.gt.0) then Allocate(NMap(npdos),Map(npdos,Nsphere)) open(unit=iunit+2, file=trim(filenm)//'.pdosout', form='formatted') write(iunit+2,*) 'HEADER LINE -- pdos results for ',trim(filenm) Do i=1,npdos write(6,*) 'For pdos #',i,' enter no. of spheres and list them' read(5,*) j,(Map(i,k),k=1,j) NMap(i)=j End Do Endif !npdos >0 Endif !Nsphere >0 Write(6,*) 'Enter # energies for dos and pdos arrays' Read(5,*) ne Write(6,*) 'Enter e0, de in eV for dos and pdos arrays' Read(5,*) e0,de Write(6,*) 'Enter energy shift in Ry for energy 0' Read(5,*) shift Write(6,*) 'Enter sigma for gaussian smearing' Read(5,*) sigma Pi=ACOS(-1.0) fac=2.0/(SQRT(Pi)*sigma) Allocate(e(ne),dos(ne),tdos(ne)) If (npdos.gt.0) Allocate(pdos(ne,npdos)) dos=0; tdos=0 do i=1,ne e(i)=e0+de*(i-1) enddo if (npdos.gt.0) pdos=0 do k=1,Ntot read(iunit,*) x,x,x,fnk,enk If (Nsphere.gt.0) read(iunit,*) (charges(i),i=1,Nsphere) enk=(enk-shift)*eunit ! shift 0 of energy and change to eV units do ie=1,ne term=fac*fnk*EXP(-((e(ie)-enk)/sigma)**2) dos(ie)=dos(ie)+term tdos(ie)=tdos(ie)+fnk*(1+derf((e(ie)-enk)/sigma)) If (npdos.gt.0) then Do j=1,npdos x=0 Do i=1,NMap(j) x=x+charges(Map(j,i)) End Do pdos(ie,j)=pdos(ie,j)+x*term End Do EndIf Enddo ! ie (ne) Enddo ! k (Ntot) If (npdos.gt.0) then do j=1,npdos pdos(:,j)=pdos(:,j)/NMap(j) Enddo EndIf write(iunit+1,*) 'HEADER LINE -- ',ne,shift,sigma,' ! ne shift sigma' if (npdos.gt.0) then write(iunit+2,*) 'HEADER LINE -- ',ne,shift,sigma,npdos,' ! ne shift sigma npdos' Do j=1,npdos write(iunit+2,'("Map for #",i5,25i3)')j,(Map(j,i),i=1,NMap(j)) Enddo EndIf Call Filter(dos,ne) Call Filter(tdos,ne) If (npdos.gt.0) Call Filter(pdos,ne*npdos) DO ie=1,ne write(iunit+1,'(1p4e15.7)') e(ie),dos(ie),tdos(ie),e(ie)/eunit+shift If (npdos.gt.0) then write(iunit+2,'(1p25e15.7)') e(ie),(pdos(ie,j),j=1,npdos) Endif EndDo Stop End !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! subroutine filter ! ! zeros elements of an array with values smaller then tol ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine filter(x,n) Real, Intent(INOUT):: x(n) Integer , Intent(IN) :: n Real , parameter :: tol=1.e-13 Integer :: i do i=1,n if (ABS(x(i)).lt.tol) x(i)=0 Enddo Return End spinpwpaw/code/preparespindos.f900100664004704100470410000001234610303710172017223 0ustar natalienatalie!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Program preparespindos ! 9/4/99 Natalie Holzwarth ! ! Program to read dos or pdos output from pwpaw pgm and generate ! plotting output ! ! calling argument : filename for pwpaw output ! ! For pdos output, the result is averaged over the specified spheres ! ! Modified 5/23/05 for spin density plots !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! implicit none Real*8 :: derf Real, parameter :: eunit=13.6056981 ! Rydberg to eV conversion Real, allocatable :: charges(:),e(:),dos(:),pdos(:,:),tdos(:) Real, allocatable :: dosdn(:),pdosdn(:,:),mu(:),tmu(:),tdosdn(:) Integer, allocatable :: NMap(:),Map(:,:) Real :: Pi,sigma,e0,de,x,enk,fnk,term,fac,shift Character*2 :: eval Character*80 :: filenm,description Character*4 :: spin Integer :: Nsphere,Ntot Integer :: ne,npdos,nk,ierr,i,j,k,ie,iunit External GetArg Call GetArg(1,filenm) iunit=7 open(unit=iunit, file=trim(filenm), form='formatted') open(unit=iunit+1, file=trim(filenm)//'.dosout', form='formatted') write(iunit+1,*) 'HEADER LINE -- dos results for ',trim(filenm) read(iunit,*) Nsphere !# of pdos spheres read(iunit,*) Ntot !# of k and eigenvalue entries If (Nsphere.gt.0) then Write(6,*) 'PDOS information available for',Nsphere,' sites' Do i=1,Nsphere read(iunit,'(a80)') description write(6,'(a80)') description End Do Allocate(charges(Nsphere)) Write(6,*) 'enter # of pdos results to calculate' read(5,*) npdos If (npdos.gt.0) then Allocate(NMap(npdos),Map(npdos,Nsphere)) open(unit=iunit+2, file=trim(filenm)//'.pdosout', form='formatted') write(iunit+2,*) 'HEADER LINE -- pdos results for ',trim(filenm) Do i=1,npdos write(6,*) 'For pdos #',i,' enter no. of spheres and list them' read(5,*) j,(Map(i,k),k=1,j) NMap(i)=j End Do Endif !npdos >0 Endif !Nsphere >0 Write(6,*) 'Enter # energies for dos and pdos arrays' Read(5,*) ne Write(6,*) 'Enter e0, de in eV for dos and pdos arrays' Read(5,*) e0,de Write(6,*) 'Enter energy shift in Ry for energy 0' Read(5,*) shift Write(6,*) 'Enter sigma for gaussian smearing' Read(5,*) sigma Pi=ACOS(-1.0) fac=1.0/(SQRT(Pi)*sigma) !Each spin has weight 1 Allocate(e(ne),dos(ne),tdos(ne),dosdn(ne),tdosdn(ne),mu(ne),tmu(ne)) If (npdos.gt.0) Allocate(pdos(ne,npdos),pdosdn(ne,npdos)) dos=0; tdos=0 ; tmu=0; mu=0; tdosdn=0 do i=1,ne e(i)=e0+de*(i-1) enddo if (npdos.gt.0) pdos=0 if (npdos.gt.0) pdosdn=0 do k=1,Ntot read(iunit,'(1p5e15.7,a4)') x,x,x,fnk,enk,spin If (Nsphere.gt.0) read(iunit,*) (charges(i),i=1,Nsphere) enk=(enk-shift)*eunit ! shift 0 of energy and change to eV units do ie=1,ne term=fac*fnk*EXP(-((e(ie)-enk)/sigma)**2) if (spin==' up') then dos(ie)=dos(ie)+term tdos(ie)=tdos(ie)+fnk*(1+derf((e(ie)-enk)/sigma))/2 else if (spin==' dn') then dosdn(ie)=dosdn(ie)+term tdosdn(ie)=tdosdn(ie)+fnk*(1+derf((e(ie)-enk)/sigma))/2 else write(6,*) 'Error in file -- spin = ',spin stop endif If (npdos.gt.0) then Do j=1,npdos x=0 Do i=1,NMap(j) x=x+charges(Map(j,i)) End Do if (spin==' up') then pdos(ie,j)=pdos(ie,j)+x*term else if (spin==' dn') then pdosdn(ie,j)=pdosdn(ie,j)+x*term endif End Do EndIf Enddo ! ie (ne) Enddo ! k (Ntot) If (npdos.gt.0) then do j=1,npdos pdos(:,j)=pdos(:,j)/NMap(j) pdosdn(:,j)=pdosdn(:,j)/NMap(j) Enddo EndIf write(iunit+1,*) 'HEADER LINE -- ',ne,shift,' ! ne shift' if (npdos.gt.0) then write(iunit+2,*) 'HEADER LINE -- ',ne,shift,npdos,' ! ne shift npdos' Do j=1,npdos write(iunit+2,'("Map for #",i5,25i3)')j,(Map(j,i),i=1,NMap(j)) Enddo EndIf Call Filter(dos,ne) Call Filter(dosdn,ne) Call Filter(tdos,ne) Call Filter(tdosdn,ne) If (npdos.gt.0) Call Filter(pdos,ne*npdos) If (npdos.gt.0) Call Filter(pdosdn,ne*npdos) mu=dos-dosdn tmu=tdos-tdosdn tdos=tdos+tdosdn DO ie=1,ne write(iunit+1,'(1p7e15.7)') e(ie),dos(ie),dosdn(ie),mu(ie),& tmu(ie),tdos(ie),e(ie)/eunit+shift If (npdos.gt.0) then write(iunit+2,'(1p25e15.7)') e(ie),(pdos(ie,j),j=1,npdos),& (pdosdn(ie,j),j=1,npdos) Endif EndDo Stop End !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! subroutine filter ! ! zeros elements of an array with values smaller then tol ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine filter(x,n) Real, Intent(INOUT):: x(n) Integer , Intent(IN) :: n Real , parameter :: tol=1.e-13 Integer :: i do i=1,n if (ABS(x(i)).lt.tol) x(i)=0 Enddo Return End spinpwpaw/code/projectors.f900100664004704100470410000020124710303710172016357 0ustar natalienatalie!****************************************************************************** ! ! File : projectors.f90 ! by : Alan Tackett ! on : 04/20/1999 ! for : PW-PAW ! ! Contains the routines for creating and storing the radial projectors ! and also routines for perfomring the calculations ! !****************************************************************************** Module projectors Use lrulib Use gpoints Use work_mgr Use atom_data Use crystal_data Use spherical_harmonic Use structfact Use ylm_fact Use timing Implicit NONE!!!!! Type (REAL_LRU_Context), Pointer :: LRU_RadProj(:) Type (COMPLEX_LRU_Context), Pointer :: LRU_Proj(:) Integer :: PLM_Max, Proj_Max Integer :: PDOT_Max Integer :: RadProj_Max Integer, Pointer :: PLM(:,:) Integer, POINTER :: PLM_AtomRange(:,:) Integer, Pointer :: PDOT_Map(:,:) Integer :: PDOT_Dir !** Previous direction when processing PDOTS Integer, PRIVATE :: Count !** Counter for g-points list Integer, PRIVATE :: Glist_Half Real, Pointer, PRIVATE :: GList(:,:) Integer, Pointer, Private :: GMap(:) Real, PRIVATE :: Kvec(3) !-------------------------------- !Integer, PARAMETER :: G_PROJ = G_HIGH Type RLE_type Integer :: N Integer, Pointer :: RLE(:,:) end Type Type (RLE_Type), Pointer :: RS_RLE(:) Integer, Pointer :: RS_PLMMax(:) Integer, Pointer :: RS_ProjMap(:) Integer, Pointer :: RS_PLM(:,:,:) !Integer, Pointer :: FFTMap_Proj(:) Type (COMPLEX_LRU_Context), ALLOCATABLE :: LRU_RS_Proj(:) Type (COMPLEX_LRU_Context) :: LRU_RS_dummy Complex, Pointer :: RS_Work1(:), RS_Work2(:) Real, Pointer :: RS_Wt(:) Type RLE_RUN_Type Integer :: N Integer, Pointer :: Table(:,:) Complex, Pointer :: RLE_Data(:) End Type Type (RLE_Run_Type), Pointer :: RLE_Run(:) !-------------------------------- !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! FindNext_RLE - Finds the next set of RLE's to process ! ! pos - Position in Wave function space ! Table - Merge table ! next_atom - Next atom to process ! next - info about the next merge operation ! !****************************************************************************** Subroutine FindNext_RLE(pos, Table, Next_Atom, next) Integer, Intent(OUT) :: pos Integer, Intent(INOUT) :: Table(:,:) Integer, Intent(OUT) :: Next_atom Integer, Intent(OUT) :: NExt(:) Integer :: atom, n, k, next_plm Write(Error_Unit,*) 'Entered FindNext_RLE which is not debugged' stop Pos = FFT_Grid(4,G_PROJ)+1 next_atom = -1 Do atom=1, Specific_Atoms If (pos > Table(2,atom)) then pos = Table(2,atom) next_atom = atom End IF End Do If (next_atom > 0) then next = Table(:,next_atom) k = Table(1,next_atom) Table(1,next_atom) = Table(1,next_atom) + 1 If (k >= RS_RLE(next_atom)%N) then Table(2,next_atom) = FFT_Grid(4,G_PROJ) + 2 else Table(2,next_atom) = RS_RLE(next_atom)%RLE(1,k+1) Table(3,next_atom) = Table(3,next_atom) + RS_RLE(next_atom)%RLE(2,k) End If !Write(*,*) 'FindNExt_RLE: Update Table=',Table(:,next_atom) End if Return End Subroutine !****************************************************************************** ! ! Merge_Proj_RLE - Merges the separate projector's for a given k-point ! If RunSize<=0 then the data is NOT stored and the size of the ! table and rle_data arrays are calculated and returned ! ! RLE_Run - Data structure where to store the merged RLE data ! Kpnt - K-point index ! RunSize - Number of RLE runs ! DataSize- Size of data array ! !****************************************************************************** Subroutine Merge_Proj_RLE(RLE_Run, Kpnt, RunSize, DataSize) Type (RLE_RUN_Type), Intent(OUT) :: RLE_Run Integer, Intent(IN) :: Kpnt Integer, Intent(INOUT) :: RunSize Integer, Intent(INOUT) :: DataSize Complex, Pointer :: Proj_R(:) !Integer :: Table(3, Specific_Atoms), atom, Base_DI, next(3), pos Integer :: atom, Base_DI, next(3), pos Integer ,allocatable :: Table(:,:) Integer :: PLM_Index, dn, i,j Logical :: DoStore Allocate(Table(3,Specific_Atoms)) Write(Error_Unit,*) 'Entered Merge_Proj_RLE which is not debugged' stop DoStore = .TRUE. If (RunSize <= 0) DoStore = .FALSE. pos = 0 RunSize = 1 DataSize = 0 Table = 0 Do atom=1, Specific_Atoms Table(1,atom) = 1 Table(2,atom) = RS_RLE(atom)%RLE(1,1) Table(3,atom) = 0 End Do Call FindNext_RLE(pos, Table, atom, next) Do While (atom > 0) !Write(Log_Unit,*) 'Merge_Proj_RLE: Atom=',atom, ' * next=',next, ' * Pos=',pos, ' *RLE%N=',RS_RLE(atom)%N Base_DI = RS_PLMMax(atom)*(Kpnt-1) Do i=1, RS_PLMMax(atom) Call LRU_GetRec(LRU_RS_Proj(atom), Base_DI + i, Proj_R) PLM_Index = RS_PLM(atom,4,i) dn = RS_RLE(atom)%RLE(2,Next(1)) If (DoStore) then RLE_Run%Table(:,RunSize) = (/PLM_Index, Next(2), dn/) j = Next(3) RLE_Run%RLE_Data(DataSize+1:DataSize+dn) = Proj_R(j+1:j+dn) End If DataSize = DataSize + dn RunSize = RunSize + 1 End Do Call FindNext_RLE(pos, Table, atom, next) End Do RunSize = RunSize - 1 DeAllocate(Table) Return End Subroutine !****************************************************************************** ! ! RS_MakeGlobal_RLE - Makes the global RLE data structure ! !****************************************************************************** Subroutine RS_MakeGlobal_RLE Integer :: kpnt, RunSize, DataSize Write(Error_Unit,*) 'Entered RS_MakeGlobal_RLE which is not debugged' stop Do Kpnt=1, NumKpnts RunSize = -1 Call Merge_Proj_RLE(RLE_Run(kpnt), Kpnt, RunSize, DataSize) If (RLE_Run(Kpnt)%N > 0) then DeAllocate(RLE_Run(kpnt)%Table, RLE_Run(kpnt)%RLE_Data) End if Write(Log_Unit,*) 'RS_MakeGlobal: Kpnt=',Kpnt, ' * RunSize=',RunSize, & ' * DataSize=',DataSize RLE_Run(kpnt)%N = RunSize Allocate(RLE_Run(kpnt)%Table(3,Runsize), RLE_Run(kpnt)%RLE_Data(DataSize)) Call Merge_Proj_RLE(RLE_Run(kpnt), Kpnt, RunSize, DataSize) End Do Return End Subroutine !****************************************************************************** ! ! MakeIntWts - Makes the integration weights using Bodes ! 5-point rule. ! !****************************************************************************** Subroutine MakeIntWts_Bode(Wt) Real, Intent(OUT) :: Wt(:) Integer :: x,y,z,k, xw,yw,zw Integer :: BodeWt(5) Write(Error_Unit,*) 'Entered MakeIntWts_Bode which is not debugged' stop BodeWt = (/28, 64, 24, 64, 28/) k = 0 Do z=1, FFT_Grid(3,G_PROJ) zw = BodeWt(Mod(z-1,4)+1) Do y=1, FFT_Grid(2,G_PROJ) yw = BodeWt(Mod(y-1,4)+1) Do x=1, FFT_Grid(1,G_PROJ) xw = BodeWt(Mod(x-1,4)+1) k = k + 1 Wt(k) = xw*yw*zw End Do End Do End Do Wt = Wt/(45.0)**3 !* Wt = 1.0 Return End Subroutine !****************************************************************************** ! ! MakeIntWts_Simpson - Makes the integration weights ! using Simpson's 3-pnt rule ! !****************************************************************************** Subroutine MakeIntWts_Simpson(Wt) Real, Intent(OUT) :: Wt(:) Integer :: x,y,z,k, xw,yw,zw Write(Error_Unit,*) 'Entered MakeIntWts_Simpson which is not debugged' stop k = 0 Do z=1, FFT_Grid(3,G_PROJ) If (Mod(z,2)==1) then zw = 2 else zw = 4 End If Do y=1, FFT_Grid(2,G_PROJ) If (Mod(y,2)==1) then yw = 2 else yw = 4 End If Do x=1, FFT_Grid(1,G_PROJ) k = k + 1 If (Mod(x,2)==1) then xw = 2 else xw = 4 End If Wt(k) = xw*yw*zw End Do End Do End Do Wt = Wt/27.0 !* Wt = 1.0 Return End Subroutine !****************************************************************************** ! ! MakeIntWeights - Makes the integration weights ! !****************************************************************************** Subroutine MakeIntWeights(Wt) Real, Intent(OUT) :: Wt(:) Integer :: i,j,k Logical :: DoBode Write(Error_Unit,*) 'Entered MakeIntWts which is not debugged' stop DoBode = .TRUE. i = FFT_Grid(1,G_PROJ) j = FFT_Grid(2,G_PROJ) k = FFT_Grid(3,G_PROJ) If ((Mod(i,4)==0) .AND. (Mod(j,4)==0) .AND. (Mod(k,4)==0) .AND. DoBode) then Write(Log_Unit,*) 'MakeIntWeights: BODE' Call MakeIntWts_BODE(Wt) else Write(Log_Unit,*) 'MakeIntWeights: SIMPSON' Call MakeIntWts_Simpson(Wt) End If Return End Subroutine !********************************************************************** ! ! RS_CreateProjMap - Creates the Projector Maps ! !********************************************************************** subroutine RS_CreateProjMap(atom, Map, R_xtal, rle_size, data_size) Integer, Intent(IN) :: atom Integer, Intent(OUT) :: Map(:) Real, Intent(IN) :: R_xtal(:,:) Integer, Intent(OUT) :: rle_size Integer, Intent(OUT) :: data_size !Rick Matthews, 2/9/97 !Create the projector map ! !(See module declarations for explanations of these.) integer :: ix,iy,iz !Integer coordinates on curvilinear grid. !Range from 1 to Grid(1), Grid(2),Grid(3) integer :: PM(3) !Vector with elements ix, iy, iz real :: PC(3) !Actual curvilinear coords corresponding to PM real :: R(3) !Real space equivalent of PM, PC. real :: Offset(3) Integer :: t, x,y,z Real :: Rc2 ! Rc^2 Integer :: Offset_xtal integer :: i !Index of specific atoms integer :: k !=1,2,3 for curv coord x,y,z integer :: L,m !Local l and m of projector. Type(Atom_Info_Fixed),Pointer :: At_info !Structure on atom type info Type(Specific_Atom), Pointer :: AT !Structure on specific atom info Real :: DR(3), mag, rsmall Character*100 :: msg Integer :: npnts, Run_Start Logical :: Ok, InRun Write(Error_Unit,*) 'Entered RS_CreateProjMap which is not debugged' stop Map = 0 At=>Atom_List(atom) !This specific atom in atom list AT_Info=>AtomType_Info(At%TypeIndex)!AtomTypeInfo for the atom type Rc2 = (AT_Info%Rc_RS_scale*AT_Info%Rc)**2 rle_size = 0 data_size = 0 npnts = 0 t = 0 Inrun = .FALSE. Do z=1, FFT_Grid(3, G_PROJ) Do y=1, FFT_Grid(2, G_PROJ) Do x=1, FFT_Grid(1, G_PROJ) t = t + 1 PM = (/x,y,z/) R = MATMUL(xtal%Basis, (PM-1.0)/(FFT_grid(1:3,G_PROJ))) !Write(Log_Unit,*) ' xyz=',x,y,z !Write(Log_Unit,*) ' R=',R offset_xtal = 0 Ok = .FALSE. Do While ((.NOT. Ok) .AND. (offset_xtal<27)) Offset_xtal = offset_xtal + 1 DR = R - R_xtal(:,offset_xtal) - AT%Pos mag = DOT_PRODUCT(DR,DR) If (mag <= Rc2) Ok = .TRUE. end Do If (Ok) then If (.NOT. InRun) then Run_Start = t InRun = .TRUE. End If Map(t) = offset_xtal npnts = npnts + 1 !Write(Log_Unit,*) 'RS_CPM: t=',t, ' * n=',npnts, ' * RLE=',rle_size else If (Inrun) then data_size = data_size + t-Run_Start rle_size = rle_size + 1 InRun = .FALSE. !Write(Log_Unit,*) 'RS_CPM: Start=',run_Start, ' * n=',data_size, ' * RLE=',rle_size End If End Do !*x End Do !*y End Do !*z If (InRun) then data_size = data_size + t-Run_Start + 1 rle_size = rle_size + 1 InRun = .FALSE. !Write(Log_Unit,*) 'RS_CPM: Start=',run_Start, ' * n=',data_size, ' * RLE=',rle_size end If Write(Log_Unit,*) 'RS_CreateProjMap: Total points:',npnts, ' RLE Size:',rle_size Return end subroutine !**************************************************************** ! ! RS_Find_PLMMAX - Calculates the RS_PLMMax constant ! !**************************************************************** Subroutine RS_Find_PLMMax !Rick Matthews, 2/9/97 !Find Proj_Max,the maximum number of projector functions of any atom !and L_Max, the max L_Value of any atom !There are Basis_Size radial projector functions. !For each radial projector, the L_value(projector number) tells the ! corresponding quantum number L. !For each L, their are 2L+1 projectors (one for each quantum number m). integer :: atom,atype !Which atom type integer :: projector !which radial projector integer :: sum !Count of proj functions for each atom Type(Atom_Info_fixed),pointer:: AT !Shortcut or alias to AtomType_Info(atom) do atom=1, Specific_Atoms atype = Atom_List(atom)%TypeIndex AT=>AtomType_Info(atype) sum=0 do projector=1,AT%Basis_Size sum= sum+2*AT%L_Value(projector)+1 end do RS_PLMMax(atom) = sum end do atom = MAXVAL(RS_PLMMax) Allocate(RS_PLM(Specific_Atoms, 5, atom)) Write(Log_Unit,*) 'RS_Find_PLMmax: RS_PLMMax = ', RS_PLMMax Return end subroutine !****************************************************************************** ! ! RS_FindPLM - Creates the RS PLM array. ! !****************************************************************************** Subroutine RS_FindPLM !Rick Matthews,created 2/11/97 !Finds PLM(atom type, quantum number, grid index) integer :: atom !atom index integer :: rad_proj !index of radial projector integer :: L !quantum number L integer :: m !quantum number m integer :: i !projector grid index Integer :: j, err, V(4), DV(4), RadP Type (Atom_Info_Fixed), Pointer :: AT_Info RS_PLM = 0 do atom=1,Specific_Atoms i=0 j = Atom_List(atom)%TypeIndex AT_Info => AtomType_Info(j) do rad_proj=1, AT_Info%Basis_Size L=AT_Info%L_Value(rad_proj) do m= -L,L i = i + 1 RS_PLM(atom,1,i) = Rad_Proj RS_PLM(atom,2,i) = L RS_PLM(atom,3,i) = m V = (/atom,Rad_Proj,L,m/) j=1 DV = V - PLM(:,j) err = DOT_PRODUCT(DV,DV) Do while (err>0.5) j = j + 1 DV = V - PLM(:,j) err = DOT_PRODUCT(DV,DV) End Do RS_PLM(atom,4,i) = j !** PLM Index RS_PLM(atom,5,i) = 1 !atom is present in this grid end do end do !** Proj_AtomMax(atom) = i end do ! Write(Log_Unit, *) 'RS_FindPLM: Proj_Max=', RS_PLMMax ! Do atom=1, Specific_Atoms ! Do i=1, rS_PLMMax(atom) ! Write(Log_Unit, *) 'RS_FindPLM: Atom=',Atom, & ! ' * NLM=',RS_PLM(atom,1:3,i) ! End Do ! End Do End Subroutine !********************************************************************** ! ! RS_StoreProj - Stores the Projector for the atom ! !********************************************************************** subroutine RS_StoreProj(atom, Map, R_xtal, RLE, Proj_G, Proj_R) Integer, Intent(IN) :: atom Integer, Intent(IN) :: Map(:) Real, Intent(IN) :: R_xtal(:,:) Integer, Intent(OUT) :: RLE(:,:) Complex, Intent(IN) :: Proj_G(:) Complex, Intent(OUT) :: Proj_R(:) !Rick Matthews, 2/9/97 !Create the projector map ! !(See module declarations for explanations of these.) integer :: ix,iy,iz !Integer coordinates on curvilinear grid. !Range from 1 to Grid(1), Grid(2),Grid(3) Integer :: t, x,y,z integer :: i !Index of specific atoms integer :: k !=1,2,3 for curv coord x,y,z integer :: L,m !Local l and m of projector. Type(Atom_Info_Fixed),Pointer :: At_info !Structure on atom type info Type(Specific_Atom), Pointer :: AT !Structure on specific atom info Integer :: npnts, run_Start Logical :: Ok, InRun Integer :: data_size, rle_size Write(Error_Unit,*) 'Entered RS_StoreProj which is not debugged' stop At=>Atom_List(atom) !This specific atom in atom list AT_Info=>AtomType_Info(At%TypeIndex)!AtomTypeInfo for the atom type rle_size = 0 RLE = 0 data_size = 0 npnts = 0 t = 0 Inrun = .FALSE. Do z=1, FFT_Grid(3, G_PROJ) Do y=1, FFT_Grid(2, G_PROJ) Do x=1, FFT_Grid(1, G_PROJ) t = t + 1 If (Map(t) > 0) then If (.NOT. InRun) then Run_Start = t InRun = .TRUE. End If npnts = npnts + 1 !Write(Log_Unit,*) 'RS_SPM: t=',t, ' * n=',npnts, ' * RLE=',rle_size Proj_R(npnts) = Proj_G(t) else If (Inrun) then rle_size = rle_size + 1 RLE(:,rle_size) = (/Run_start, (t-Run_Start) /) InRun = .FALSE. !Write(Log_Unit,*) 'RS_SPM: Start=',run_Start, ' * n=',npnts, ' * RLE=',rle_size End If End Do !*x End Do !*y End Do !*z If (InRun) then rle_size = rle_size + 1 RLE(:,rle_size) = (/Run_start, (t-Run_Start+1) /) !Write(Log_Unit,*) 'RS_SPM: Start=',run_Start, ' * n=',data_size, ' * RLE=',rle_size end If Write(Log_Unit,*) 'RS_CreateProjMap: Total points:',npnts, ' RLE Size:',rle_size Return end Subroutine !****************************************************************************** ! ! RS_CreateProj - Creates the Real-space projectors ! !****************************************************************************** Subroutine RS_CreateProj Integer :: i,j,k,atom, m,am, L, n, kpnt, t, G_Size, G_Half Integer :: Base_RAD, Base_DI, G_Index, MaxRec, RS_Size, DI, RadP Integer :: Basis_size, NG, atype Integer, Pointer :: Map(:) Real, Pointer :: Proj(:), Wt(:) Complex, Pointer :: P(:), Work(:), Ylm(:), Phase(:), Proj_G(:), Proj_R(:) Complex, Pointer :: Buffer(:) Complex :: c1,c2,c3, c4 Real :: DV, R(3), R_xtal(3,27) Integer :: x,y,z,xo,yo,zo, rle_size, data_size Real :: r1,r2 Write(Error_Unit,*) 'Entered RS_CreateProj which is not debugged' stop DV = Xtal%Volume/(1.0*FFT_Grid(4,G_PROJ)) Allocate(P(FFT_Grid(4,G_PROJ)), buffer(FFT_Grid(4,G_PROJ)), & Map(FFT_Grid(4,G_PROJ))) Call Getbuffer( Proj_G) c1 = 4*Pi / sqrt(xtal%Volume) !** FD_Proj = 60 i = 0 Do z=-1, 1 Do y= -1, 1 Do x=-1, 1 i = i + 1 R_xtal(:,i) = MatMul(xtal%Basis, (/x,y,z/)) !Write(Log_Unit,*) 'RS_CreateProjMap: i=',i, '* DR=',R_xtal(:,i) End Do End Do End Do R_xtal(:,14) = R_xtal(:,1); R_xtal(:,1) = 0 !** Move R=0 to front for speed NG = Gpnt_size(G_LOW) - 1 Do atom=1, Specific_Atoms atype = Atom_List(atom)%typeIndex Basis_Size = AtomType_Info(atype)%Basis_Size Call RS_CreateProjMap(atom, Map, R_xtal, rle_size, data_size) G_Half = Atomtype_Info(Atom_List(atom)%typeIndex)%Gpnt_size G_Size = 2*G_Half - 1 Call GetStructFactor( atom, Phase) Write(Log_Unit,*) 'RS_CreateProj: atom=',atom, ' * RLE%N=',rle_size, ' * Data=',Data_Size RS_RLE(atom)%N = RLE_Size Allocate(Proj_R(data_size), RS_RLE(atom)%RLE(2,RLE_Size), & Work(G_Size)) MaxRec = Size(BZ%Ku(1,:)) * RS_PLMMax(atom) RS_Size = Data_Size i = FD_RS_Proj+atom-1; R(1) = 50 Call LRU_InitContext(LRU_RS_Proj(atom), 'RS_Proj:', i, 50.0, & MaxRec, RS_Size, .TRUE.) !----- DI = 0 Do Kpnt = 1, Size(BZ%Ku(1,:)) Base_DI = Basis_Size * (Kpnt-1) !** Calc starting DI for Kpnt Do n=1, RS_PLMMax(atom) RadP = RS_PLM(atom,1,n) L = RS_PLM(atom,2,n) m = RS_PLM(atom,3,n) am = ABS(m) Call LRU_GetRec(LRU_RadProj(atype), Base_DI + radP, Proj) Call GetYlm( Kpnt, L, am, Ylm) c2 = CMPLX(0,1)**L Proj_G = 0 If (m>=0) then i = 1 Proj_G(i) = CONJG(Ylm(i))*Proj(i)*Phase(i) Do i=2, G_Half Proj_G(i) = CONJG(Ylm(i))*Proj(i)*Phase(i) Proj_G(i+ng) = CONJG(Ylm(i+ng)) * Proj(i+G_Half-1) * & Phase(i+ng) end Do Proj_G = c1*c2*Proj_G Else i = 1 Proj_G(i) = Ylm(i)*Proj(i)*Phase(i) Do i=2, G_Half Proj_G(i) = Ylm(i)*Proj(i)*Phase(i) Proj_G(i+ng) = Ylm(i+ng) * Proj(i+G_Half-1) * & Phase(i+ng) end Do c3 = (-1)**am Proj_G = c1*c2*c3*Proj_G End If Proj_G = CONJG(Proj_G) !Write(Log_Unit,*) 'RS_CreateProj: nlm=',n,l,m,' * a=',atom, ' DOT=',DOT_PRODUCT(Proj_G, Proj_G) Call RS_toR(Proj_G, Buffer) Proj_R = 0 Call RS_StoreProj(atom, Map, R_xtal, RS_RLE(atom)%RLE, & Buffer, Proj_R) DI = DI + 1 Call LRU_PutRec(LRU_RS_Proj(atom), DI, Proj_R) P = 0 Where (Map > 0) P = Buffer c4=DOT_PRODUCT(Buffer, buffer) !c4 = SQRT(REAL(c4)) Where (Map > 0) Buffer = 0 c3=DOT_PRODUCT(Buffer, buffer) !c3 = SQRT(REAL(c3)) Buffer = 0 where(Map > 0) Buffer = P c2=DOT_PRODUCT(Buffer, Buffer) !c2 = SQRT(REAL(c2)) c3=SQRT(REAL(c3/c4)) c2 = SQRT(REAL(c2/c4)) Write(Log_Unit,*) 'RS_CreateProj:2 nlm=',n,l,m,' * a=',atom Write(Log_Unit,*) ' INSIDE==',REAL(C2), ' * OUTSIDE=',REAL(C3) Write(LOG_Unit,*) ' DOT=',DOT_PRODUCT(Proj_R, Proj_R) End Do End Do DeAllocate(Work, Proj_R) End do !*atom DeAllocate(P, Buffer, Map) Call FreeBuffer(Proj_G) Return End Subroutine !****************************************************************************** ! ! RS_toR - transforms the function to RS ! ! Fg - function in G-space ! Fr - Function in real space ! !****************************************************************************** Subroutine RS_toR(Fg, Fr) Complex, Intent(IN) :: Fg(:) Complex, Intent(OUT) :: Fr(:) Integer :: j,k,t Write(Error_Unit,*) 'Entered RS_toR which is not debugged' stop Fr = 0 Fr(FFTMap_PROJ(1:Gpnt_Size(G_Low))) = Fr(FFTMap_PROJ(1:Gpnt_Size(G_Low))) + & Fg(1:Gpnt_Size(G_Low)) t = Gpnt_Size(G_Low)+1 j = Gpnt_Size(G_PROJ)+1; k = j + (Gpnt_Size(G_Low)-1) - 1 Fr(FFTMap_Proj(j:k)) = Fr(FFTMap_Proj(j:k)) + Fg(t:) Call PerformFFT(FFT_TO_R, G_PROJ, Fr) Return end Subroutine !****************************************************************************** ! ! RS_toG - transforms the function from RS to 1-d G-space ! ! Fr - Function in real space ! Fg - function in G-space - accumulated! ! !****************************************************************************** Subroutine RS_toG(Fr, Fg) Complex, Intent(INOUT) :: Fr(:) Complex, Intent(OUT) :: Fg(:) Integer :: j,k,t Write(Error_Unit,*) 'Entered RS_toG which is not debugged' stop Call PerformFFT(FFT_TO_G, G_PROJ, Fr) Fg(1:Gpnt_Size(G_Low)) = Fg(1:Gpnt_Size(G_Low)) + & Fr(FFTMap_PROJ(1:Gpnt_Size(G_Low))) t = Gpnt_Size(G_Low)+1 j = Gpnt_Size(G_PROJ)+1; k = j + (Gpnt_Size(G_Low)-1) - 1 Fg(t:) = Fg(t:) + Fr(FFTMap_Proj(j:k)) Return end Subroutine !****************************************************************************** ! ! CalcProjProducts_RS - Calcuylates the PDOT's in real space ! ! Psi - Wave function in R-SPACE ! PDOT - Output array containing the products ! !*RS* !****************************************************************************** Subroutine CalcProjProducts_RS(psi, PDOT) Complex, Intent(IN) :: Psi(:) Complex, Intent(OUT) :: PDot(:) Integer :: i,j,k,dn, n, PLM_Index Integer, Pointer :: Table(:,:) Complex, Pointer :: Proj_R(:) Real :: DV Write(Error_Unit,*) 'Entered CalcProjProducts_RS which is not debugged' stop DV = 1.0/(1.0*FFT_Grid(4,G_PROJ)) Proj_R => RLE_Run(Mem_Kpnt)%RLE_Data Table => RLE_Run(Mem_Kpnt)%Table PDOT = 0 i = 0 Do n=1, RLE_Run(Mem_Kpnt)%N PLM_Index = Table(1,n) j = Table(2,n) - 1 dn = Table(3,n) Pdot(PLM_Index) = PDOT(PLM_Index) + & SUM(CONJG(Proj_R(i+1:i+dn)) * Psi(j+1:j+dn)) i = i + dn End do PDOT = PDOT * DV !Do i=1, PLM_Max ! Write(Log_Unit,*) ' CPP_RS: i=',i, ' * PDOT=',PDOT(i) !End Do Return end Subroutine !****************************************************************************** ! ! CalcProjProducts_RS - Calcuylates the PDOT's in real space ! ! Psi - Wave function in R-SPACE ! PDOT - Output array containing the products ! !*RS*OLD !****************************************************************************** Subroutine CalcProjProducts_RS_OLD(psi, PDOT) Complex, Intent(IN) :: Psi(:) Complex, Intent(OUT) :: PDot(:) Integer :: i,j,k,dn, Base_DI, atom, n Complex, Pointer :: Proj_R(:) Complex :: dot Real :: DV Real, Pointer :: Wt(:) Write(Error_Unit,*) 'Entered CalcProjProducts_RS_OLD which is not debugged' stop !* DV = Xtal%Volume/(1.0*FFT_Grid(4,G_PROJ)) DV = 1.0/(1.0*FFT_Grid(4,G_PROJ)) !DV = 1 !* Allocate(Wt(FFT_Grid(4,G_PROJ))) !* Call MakeIntWeights(Wt) !*Wt = 1 !Write(Log_Unit,*) 'CPP_RS: Base_DI=',Base_DI, ' * Kpnt=',Mem_Kpnt !**FIXME !DV=1 !RS_Work1 = Psi !**** Do atom=1, Specific_Atoms Base_DI = RS_PLMMax(atom)*(Mem_Kpnt-1) !** Calc starting DI for Kpnt Do n=1, RS_PLMMax(atom) Call LRU_GetRec(LRU_RS_Proj(atom), Base_DI + n, Proj_R) i = 0; j = 0; dot = 0 Do k=1, RS_RLE(atom)%N j = RS_RLE(atom)%RLE(1,k)-1 dn = RS_RLE(atom)%RLE(2,k) !write(*,*) 'atom=',atom, ' * i,j,dn=',i,j,dn, ' * dot=',dot !Write(*,*) ' Proj=',Proj_R(i+1:i+dn) !Write(*,*) ' Psi =',RS_Work1(j+1:j+dn) !Write(*,*) ' Wt =',RS_Wt(j+1:j+dn) dot = dot + SUM(CONJG(Proj_R(i+1:i+dn)) * Psi(j+1:j+dn)) i = i + dn End Do PDOT(RS_PLM(atom,4,n)) = dot*DV End Do End Do !Do i=1, PLM_Max ! Write(Log_Unit,*) ' CPP_RS: i=',i, ' * PDOT=',PDOT(i) !End Do Return end Subroutine !****************************************************************************** ! ! AccumBothProj_RS - Accumulates the summed |pi>Dij and ! and |pi>Oij to the given vectors ! using a real space representation ! ! Hx - Output vector for Dij sum. NOTE: The vector is not initialized to 0! ! Ox - Output vector for Oij sum. NOTE: The vector is not initialized to 0! ! PDOT - List of products ! Dij - External function for calculaint matrix elements ! Oij - External function for calculaint matrix elements !*RS* !****************************************************************************** Subroutine AccumBothProj_RS(Hx, Ox, PDot, Dij, Oij) Complex, Intent(INOUT) :: Hx(:) Complex, Intent(INOUT) :: Ox(:) Complex, Intent(IN) :: PDOT(:) Complex, EXTERNAL :: Dij Complex, EXTERNAL :: Oij !Complex :: Ch(PLM_Max), Co(PLM_Max) Complex ,allocatable :: Ch(:), Co(:) Integer :: atom,i, j, k, dn, Base_DI, PLM_Index, n Integer, Pointer :: Table(:,:) Complex, Pointer :: Proj_R(:) Complex :: c1, c2 Allocate(Ch(PLM_Max), Co(PLM_Max)) Write(Error_Unit,*) 'Entered AccumBothProj_RS which is not debugged' stop Call CalcAccumVector(Ch, PDOT, Dij) Call CalcAccumVector(Co, PDOT, Oij) Proj_R => RLE_Run(Mem_Kpnt)%RLE_Data Table => RLE_Run(Mem_Kpnt)%Table i = 0 Do n=1, RLE_Run(Mem_Kpnt)%N PLM_Index = Table(1,n) j = Table(2,n) - 1 dn = Table(3,n) Hx(j+1:j+dn) = Hx(j+1:j+dn) + Proj_R(i+1:i+dn)*Ch(PLM_Index) Ox(j+1:j+dn) = Ox(j+1:j+dn) + Proj_R(i+1:i+dn)*Co(PLM_Index) i = i + dn End do DeAllocate(Ch, Co) Return End Subroutine !****************************************************************************** ! ! AccumBothProj_RS - Accumulates the summed |pi>Dij and ! and |pi>Oij to the given vectors ! using a real space representation ! ! Hx - Output vector for Dij sum. NOTE: The vector is not initialized to 0! ! Ox - Output vector for Oij sum. NOTE: The vector is not initialized to 0! ! PDOT - List of products ! Dij - External function for calculaint matrix elements ! Oij - External function for calculaint matrix elements !*RS*OLD !****************************************************************************** Subroutine AccumBothProj_RS_OLD(Hx, Ox, PDot, Dij, Oij) Complex, Intent(INOUT) :: Hx(:) Complex, Intent(INOUT) :: Ox(:) Complex, Intent(IN) :: PDOT(:) Complex, EXTERNAL :: Dij Complex, EXTERNAL :: Oij !Complex :: Ch(PLM_Max), Co(PLM_Max) Complex ,allocatable :: Ch(:), Co(:) Integer :: atom,i, j, k, dn, Base_DI, PLM_Index, n Complex, Pointer :: Proj(:) Complex :: c1, c2 Allocate( Ch(PLM_Max), Co(PLM_Max)) Write(Error_Unit,*) 'Entered AccumBothProj_RS_OLD which is not debugged' stop Call CalcAccumVector(Ch, PDOT, Dij) Call CalcAccumVector(Co, PDOT, Oij) Do atom=1, Specific_Atoms Base_DI = RS_PLMMax(atom)*(Mem_Kpnt-1) !** Calc starting DI for Kpnt Do n=1, RS_PLMMax(atom) Call LRU_GetRec(LRU_RS_Proj(atom), Base_DI + n, Proj) PLM_Index = RS_PLM(atom,4,n) i = 0; j = 0; Do k=1, RS_RLE(atom)%N j = RS_RLE(atom)%RLE(1,k)-1 dn = RS_RLE(atom)%RLE(2,k) Hx(j+1:j+dn) = Hx(j+1:j+dn) + Proj(i+1:i+dn)*Ch(PLM_Index) Ox(j+1:j+dn) = Ox(j+1:j+dn) + Proj(i+1:i+dn)*Co(PLM_Index) i = i + dn End Do End Do End Do DeAllocate( Ch, Co) Return End Subroutine !****************************************************************************** ! ! AccumProj_RS - Accumulates the summed |pi>Dij and ! and |pi>Oij to the given vectors ! using a real space representation ! ! Hx - Output vector for Dij sum. NOTE: The vector is not initialized to 0! ! PDOT - List of products ! Dij - External function for calculaint matrix elements !*RS* !****************************************************************************** Subroutine AccumProj_RS(Hx, PDot, Dij) Complex, Intent(INOUT) :: Hx(:) Complex, Intent(IN) :: PDOT(:) Complex, EXTERNAL :: Dij !Complex :: Ch(PLM_Max) Complex ,allocatable:: Ch(:) Integer :: i, j, k, Base_DI, atom, PLM_Index, n, dn Complex, Pointer :: Proj_R(:) Integer, Pointer :: Table(:,:) Complex :: c1, c2 Allocate( Ch(PLM_Max)) Write(Error_Unit,*) 'Entered AccumProj_RS which is not debugged' stop !RETURN Call CalcAccumVector(Ch, PDOT, Dij) Proj_R => RLE_Run(Mem_Kpnt)%RLE_Data Table => RLE_Run(Mem_Kpnt)%Table i = 0 Do n=1, RLE_Run(Mem_Kpnt)%N PLM_Index = Table(1,n) j = Table(2,n) - 1 dn = Table(3,n) Hx(j+1:j+dn) = Hx(j+1:j+dn) + Proj_R(i+1:i+dn)*Ch(PLM_Index) i = i + dn End do DeAllocate( Ch) Return End Subroutine !****************************************************************************** ! ! AccumProj_RS - Accumulates the summed |pi>Dij and ! and |pi>Oij to the given vectors ! using a real space representation ! ! Hx - Output vector for Dij sum. NOTE: The vector is not initialized to 0! ! PDOT - List of products ! Dij - External function for calculaint matrix elements !*RS*OLD !****************************************************************************** Subroutine AccumProj_RS_OLD(Hx, PDot, Dij) Complex, Intent(INOUT) :: Hx(:) Complex, Intent(IN) :: PDOT(:) Complex, EXTERNAL :: Dij !Complex :: Ch(PLM_Max) Complex ,allocatable:: Ch(:) Integer :: i, j, k, Base_DI, atom, PLM_Index, n, dn Complex, Pointer :: Proj(:) Complex :: c1, c2 Allocate(Ch(PLM_Max)) Write(Error_Unit,*) 'Entered AccumProj_RS_OLD which is not debugged' stop !RETURN Call CalcAccumVector(Ch, PDOT, Dij) Do atom=1, Specific_Atoms Base_DI = RS_PLMMax(atom)*(Mem_Kpnt-1) !** Calc starting DI for Kpnt Do n=1, RS_PLMMax(atom) Call LRU_GetRec(LRU_RS_Proj(atom), Base_DI + n, Proj) PLM_Index = RS_PLM(atom,4,n) i = 0; j = 0; Do k=1, RS_RLE(atom)%N j = RS_RLE(atom)%RLE(1,k)-1 dn = RS_RLE(atom)%RLE(2,k) Hx(j+1:j+dn) = Hx(j+1:j+dn) + Proj(i+1:i+dn)*Ch(PLM_Index) i = i + dn End Do End Do End Do DeAllocate(Ch) Return End Subroutine !------------------------------------------------------------------------- !------------------------------------------------------------------------- !****************************************************************************** ! ! Create_PLM - Creates the PLM map ! ! DoStore - Determines if info is stored in PLM or just calculate PLM_Max ! !****************************************************************************** Subroutine Create_PLM(DoStore) Logical, Intent(IN) :: DoStore Integer :: atype, atom , n, l, m, lut Type (Atom_Info_Fixed), Pointer :: AT PLM_Max = 0 Do atype = 1, Atom_types AT => AtomType_Info(atype) Do lut = AtomType_Range(1,atype), AtomType_Range(2,atype) atom = AtomType_MAP(lut) If (DoStore) PLM_AtomRange(1,atom) = PLM_Max + 1 Do n=1, AT%Basis_Size L = AT%L_Value(n) Do m=-L, L PLM_Max = PLM_Max + 1 If (DoStore) PLM(:,PLM_Max) = (/atom, n, L, m/) End Do End Do If (DoStore) PLM_AtomRange(2,atom) = PLM_Max End Do End Do Return End Subroutine !****************************************************************************** ! ! Create_PDOT_Map - Creates the Process Map for doing PDOT's ! ! DoStore - Determines if the array is filled or just it's size is calculated ! !****************************************************************************** Subroutine Create_PDOT_Map(DoStore) Logical, Intent(IN) :: DoStore Integer :: atype, atom , n, l, m, i, j, RadP, err, Diff(4), lut Type (Atom_Info_Fixed), Pointer :: AT i = 0 Do atype = 1, Atom_types AT => AtomType_Info(atype) Do n=1, AT%Basis_Size L = AT%L_Value(n) Do m=-L, L Do lut = AtomType_Range(1,atype), AtomType_Range(2,atype) atom = AtomType_MAP(lut) i = i + 1 If (DoStore) then !** Now find the PLM index j = 1 Diff = PLM(:,j) - (/atom, n, l, m/) err = DOT_PRODUCT(Diff,Diff) Do While (err /= 0) j = j + 1 Diff = PLM(:,j) - (/atom, n, l, m/) err = DOT_PRODUCT(Diff,Diff) End Do !*** Finally store the result *** PDOT_Map(:,i) = (/n, L, m, atom, j/) End If End Do End Do End Do End Do PDOT_Max = i Return End Subroutine !****************************************************************************** ! ! ConvertGpoints - Converts the G-points list to the 1-D array ! !****************************************************************************** Logical Function ConvertProjGpoints(Node) Type (BinaryTreeData) :: Node Integer :: n, ng Write(Error_Unit,*) 'Entered ConvertGpoints which is not debugged' stop Count = Count + 1 !Write(Log_Unit,*) 'ConvertGpoints: Count=',count, ' * Size(Glist)=',Size(Glist(1,:)) !Write(Log_Unit,*) 'ConvertGpoints: Gmag=',Node%Gmag, ' * N=',Node%Npnt(1) !write(Log_Unit,*) 'ConvertGpoints : Recip=',G_recip n = Node%Npnt(1) ng = Glist_Half - 1 ! ng = Gpnt_Size(G_LOW) - 1 If (n<=Glist_Half) then ! If (n<=Gpnt_Size(G_LOW)) then Glist(1:3, Count) = Kvec + Gpnt(1:3,n) else Glist(1:3, Count) = Kvec - Gpnt(1:3,n-ng) End if Glist(4, Count) = Node%Gmag GMap(count) = n ConvertProjGpoints = .TRUE. Return End Function !****************************************************************************** ! ! CreateProjGlist - create the projector g-points list ! ! Kvec - K-point ! Glist - Returned list of g-points ! !****************************************************************************** Subroutine CreateProjGlist(Kvec, Gmax) Real, Intent(IN) :: Kvec(:) Integer, Intent(IN) :: Gmax Integer :: i, j, Ng Real :: G(3), Gmag Type (BinaryTreeNode), Pointer :: Root, Match Type (BinaryTreeData), Pointer :: Item, Test Logical :: Ok Write(Error_Unit,*) 'Entered CreateProjGlist which is not debugged' stop Nullify(Root) Ng = Gmax - 1 !*** Generate the list **** Allocate(Item) Gmag = DOT_PRODUCT(Kvec, Kvec) Item%Gmag = Gmag Item%Npnt = 1 Call InsertNode(Root, Item, Ok) Do j=2, Gmax G = Kvec + Gpnt(1:3,j) Gmag = SQRT(DOT_PRODUCT(G,G)) Allocate(Item) Item%Gmag = Gmag Item%Npnt = j Call InsertNode(Root, Item, Ok) G = Kvec - Gpnt(1:3,j) Gmag = SQRT(DOT_PRODUCT(G,G)) Allocate(Item) Item%Gmag = Gmag Item%Npnt = Ng + j Call InsertNode(Root, Item, Ok) End Do !*** Now make the 1-d sorted list *** Count = 0 Glist_Half = Gmax Call InOrderTraversal(Root, ConvertProjGpoints) Call FreeTree(Root, .TRUE.) Return End Subroutine !****************************************************************************** ! ! StoreRadProj - Stores the Radial projector grids to disk ! !****************************************************************************** Subroutine StoreRadProj Integer :: atype, n, L, m, j, Kpnt, DI, Ng, G_Index Integer :: G_Size, G_Half, dummy Real :: G(3), Kvec(3), Gmag , Gmag1, diff, RF Real, Pointer :: RP(:) Character*200 :: token Type (Atom_Info_Fixed), Pointer :: AT Write(Log_Unit,*) 'StoreRadProj: Start!!!!!!!!!!!!!!!!' Call Flush(Log_Unit) !RETURN !**REMOVE** Ng = Gpnt_Size(G_LOW) - 1 G_half = Gpnt_Size(G_LOW) G_Size=Gall_Size(G_LOW) Allocate(RP(G_Size)) Do atype = 1, Atom_types AT => AtomType_Info(atype) n = AT%Basis_Size*Size(BZ%KU(1,:)) dummy = G_Size Call LRU_InitContext(LRU_RadProj(atype), 'RS_RadProj:', & FD_RadProj + atype - 1, 50.0, n, dummy, .TRUE.) DI = 0 Do kpnt=1, Size(BZ%Ku(1,:)) Kvec = BZ%Ku(:,kpnt) Do n = 1, AT%Basis_Size L=AT%L_value(n) RP = 0 count = 1 G = Kvec Gmag1 = SQRT(DOT_PRODUCT(G,G)) RF = RadialFourier(L, Gmag1, AT%Mesh_Step, & AT%Mesh_Size, AT%TP(:,n)) RP(1) = RF Do j=2, G_Half G=Kvec+Gpnt(1:3,j) Gmag1 = SQRT(DOT_PRODUCT(G,G)) count = count + 1 RF = RadialFourier(L, Gmag1, AT%Mesh_Step, & AT%Mesh_Size, AT%TP(:,n)) RP(j) = RF G=Kvec-Gpnt(1:3,j) Gmag1 = SQRT(DOT_PRODUCT(G,G)) count = count + 1 RF = RadialFourier(L, Gmag1, AT%Mesh_Step, & AT%Mesh_Size, AT%TP(:,n)) RP(j+ng) = RF End Do DI = DI + 1 !Write(Log_Unit,*) 'StoreRadProj: Writing DI=',DI, ' * Atype=',atype, ' * n=',n, ' * Kpnt=',Kpnt, ' * DOT=',DOT_PRODUCT(RP,RP) Where (ABS(RP)=0) then !i = 1 !Work(i) = CONJG(Ylm(i))*Proj(i)*Phase(i) !Do i=2, G_Half ! work(i) = CONJG(Ylm(i))*Proj(i)*Phase(i) ! work(i+G_Half-1) = CONJG(Ylm(i+ng)) * Proj(i+G_Half-1) * & ! Phase(i+ng) !end Do Work(:) = CONJG(Ylm(:))*Proj(:)*Phase(:) work = c1*c2*work Else !i = 1 !work(i) = Ylm(i)*Proj(i)*Phase(i) !Do i=2, G_Half ! work(i) = Ylm(i)*Proj(i)*Phase(i) ! work(i+g_Half-1) = Ylm(i+ng) * Proj(i+G_Half-1) * & ! Phase(i+ng) !end Do Work(:) = Ylm(:)*Proj(:)*Phase(:) c3 = (-1)**am Work = c1*c2*c3*Work End If DI = DI + 1 Call FilterValue(Work) Call LRU_PutRec(LRU_Proj(atom), DI, Work) !Write(Log_Unit, *) 'StoreRawProj: atom=',atom, ' n=', n, ' * Kpnt=',kpnt, ' * DOT=',DOT_PRODUCT(Work,Work) End Do End Do DeAllocate(Work) End do Return End Subroutine !****************************************************************************** ! ! SetStartEnd - Sets the starting and ending points for processing the ! PDOTS ! ! P - Projector Start/end range ! !****************************************************************************** Subroutine SetStartEnd(P) Integer, Intent(OUT) :: P(:) If (PDOT_Dir > 0) then P(1) = 1; P(2) = PLM_Max else P(1) = PLM_Max; P(2) = 1 End If Return End Subroutine !****************************************************************************** ! ! CalcProjProducts_TIME-Calculates ALL the products and stores them in ! the PDOT array. ! ! Kpnt - Bloch Phase factor ! Psi - Wave function ! PDOT - Output array containing the products !*TIME* !****************************************************************************** Subroutine CalcProjProducts_TIME(psi, PDOT) Complex, Intent(IN) :: Psi(:) Complex, Intent(OUT) :: PDot(:) Integer :: Kpnt, gmax, ng, G_half, G_size Integer :: Prange(2) Integer :: i,j, Base_DI, atom, L, m, am, n, RadP, PLM_Index Complex, Pointer :: Proj(:) Real :: c1, c3 Complex :: Pos_M, Neg_M, c2, dot Complex, EXTERNAL :: ZDOTC !Complex :: PD(PLM_Max) !PDOT = 0 !RETURN !**REMOVE** Debug Only!!! Kpnt = Mem_Kpnt gmax = Gall_Size(G_LOW) PDOT_Dir = -PDOT_Dir Call SetStartEnd(Prange) Base_DI = PLM_Max*(Kpnt-1) !** Calc starting disk index for Kpnt !------ ng = Gpnt_Size(G_LOW) - 1 G_Half=Gpnt_Size(G_LOW) G_Size=Gall_Size(G_LOW) Do atom=1, Specific_Atoms Base_DI = RS_PLMMax(atom)*(Mem_Kpnt-1) Do n=1, RS_PLMMax(atom) RadP = RS_PLM(atom,1,n) L = RS_PLM(atom,2,n) m = RS_PLM(atom,3,n) am = ABS(m) Call LRU_GetRec(LRU_Proj(atom), Base_DI + n, Proj) !i = 1 !dot = Proj(i)*Psi(i) !Do i=2, G_Half ! dot = dot + Proj(i)*Psi(i) ! dot = dot + Proj(i+G_Half-1) * Psi(i+ng) !end Do dot=SUM(Proj(:)*Psi(:)) PDOT(RS_PLM(atom,4,n)) = dot End Do End Do !Do i=1, PLM_Max ! Write(Log_Unit,*) ' CPP_TIME: i=',i, ' * PDOT=',PDOT(i) !End Do Return End Subroutine !****************************************************************************** ! ! CalcProjProducts_MEM -Calculates ALL the products and stores them in ! the PDOT array. ! ! Kpnt - Bloch Phase factor ! Psi - Wave function ! PDOT - Output array containing the products !*MEMORY* !****************************************************************************** Subroutine CalcProjProducts_MEM(psi, PDOT) Complex, Intent(IN) :: Psi(:) Complex, Intent(OUT) :: PDot(:) Integer :: Kpnt, G_half, G_size, ng, atype Integer :: Prange(2) Integer :: i,j, Base_DI, atom, L, m, am, n, RadP, PLM_Index Complex, Pointer :: Ylm(:), Phase(:) Complex, Pointer :: Work(:) Real, Pointer :: Proj(:) Complex :: dot, c1, c2, c3 !PDOT = 0 !RETURN !**REMOVE** Debug Only!!! Kpnt = Mem_Kpnt c1 = 4*Pi / sqrt(xtal%Volume) PDOT_Dir = -PDOT_Dir Call SetStartEnd(Prange) ng = Gpnt_Size(G_LOW) - 1 G_Half=Gpnt_Size(G_LOW) G_Size=Gall_Size(G_LOW) !---- Do atom=1, Specific_Atoms Call GetStructFactor( atom, Phase) atype = Atom_List(atom)%typeIndex Base_DI = Atomtype_Info(atype)%Basis_Size * & (Mem_Kpnt-1) !** Calc starting DI for Kpnt Do n=1, RS_PLMMax(atom) RadP = RS_PLM(atom,1,n) L = RS_PLM(atom,2,n) m = RS_PLM(atom,3,n) am = ABS(m) Call LRU_GetRec(LRU_RadProj(atype), Base_DI + radP, Proj) Call GetYlm( Mem_Kpnt, L, am, Ylm) c2 = CMPLX(0,1)**L If (m>=0) then !i = 1 !dot = CONJG(Ylm(i))*Proj(i)*Phase(i)*Psi(i) !Do i=2, G_Half ! dot = dot + CONJG(Ylm(i))*Proj(i)*Phase(i)*Psi(i) ! dot = dot + CONJG(Ylm(i+ng)) * Proj(i+G_Half-1) * & ! Phase(i+ng) * Psi(i+ng) !end Do dot=SUM(CONJG(Ylm(:))*Proj(:)*Phase(:)*Psi(:)) dot = c1*c2*dot Else !i = 1 !dot = Ylm(i)*Proj(i)*Phase(i)*Psi(i) !Do i=2, G_Half ! dot = dot + Ylm(i)*Proj(i)*Phase(i)*Psi(i) ! dot = dot + Ylm(i+ng) * Proj(i+G_Half-1) * & ! Phase(i+ng) * Psi(i+ng) !end Do dot=SUM(Ylm(:)*Proj(:)*Phase(:)*Psi(:)) c3 = (-1)**am dot = c1*c2*c3*dot End If PDOT(RS_PLM(atom,4,n)) = dot End Do End Do !----- !Write(Log_Unit,*) 'CalcProjProducts: PDOT=',PDOT/sqrt(4*Pi/xtal%Volume) !Write(*,*) 'CalcProjProducts: PDOT=',PDOT/sqrt(4*Pi/xtal%Volume) !Write(Log_Unit,*) 'CPP_MEM: PDOT=',PDOT !Do i=1, PLM_Max ! Write(Log_Unit,*) 'CPP_MEM: i=',i, ' * PDOT=',PDOT(i) !end Do Return End Subroutine !****************************************************************************** ! ! CalcProjProducts - Calculates ALL the products and stores them in ! the PDOT array. ! ! Kpnt - Bloch Phase factor ! Psi - Wave function ! PDOT - Output array containing the products ! !****************************************************************************** Subroutine CalcProjProducts(psi, PDOT) Complex, Intent(IN) :: Psi(:) Complex, Intent(OUT) :: PDot(:) Call Start_Timer(Timer(CalcProjProd_Timer)) Select Case (Proj_Mode) Case (MIN_TIME) Call CalcProjProducts_TIME(Psi, PDot) Case (MIN_MEMORY) Call CalcProjProducts_MEM(Psi, PDot) Case (PROJ_RS) Call CalcProjProducts_RS(Psi, PDot) !** Call CalcProjProducts_TIME(Psi, PDot) End Select Call Stop_Timer(Timer(CalcProjProd_Timer)) Return End Subroutine !****************************************************************************** ! ! CalcAccumVector - Calculates the AccumProj vector ! ! ---- ! a \ a a ! C = / D

! i ---- ij j ! j ! ! Ci - Returned array contining the above sum ! PDOT - Array containsing the products ! Dij - External function to calculate the Dij matrix elements ! ! !****************************************************************************** Subroutine CalcAccumVector(Ci, PDOT, Dij) Complex, Intent(OUT) :: Ci(:) Complex, Intent(IN) :: PDOT(:) Complex, EXTERNAL :: Dij Integer :: atom, nili, njlj, Li, Lj, mi, mj, n, RadP, PLM_Index, i, j Complex :: ans Do i=1, PLM_Max atom = PLM(1,i) nili = PLM(2,i) Li = PLM(3,i) mi = PLM(4,i) ans = 0 Do j=PLM_AtomRange(1,atom), PLM_AtomRange(2,Atom) njlj = PLM(2,j) Lj = PLM(3,j) mj = PLM(4,j) Ans = Ans + Dij(atom,nili,njlj,li,lj,mi,mj)*PDOT(j) End Do Ci(i) = ans End Do Return End Subroutine !****************************************************************************** ! ! AccumBothProj_TIME - Accumulates the summed |pi>Dij and ! and |pi>Oij to the given vectors ! ! Hx - Output vector for Dij sum. NOTE: The vector is not initialized to 0! ! Ox - Output vector for Oij sum. NOTE: The vector is not initialized to 0! ! PDOT - List of products ! Dij - External function for calculaint matrix elements ! Oij - External function for calculaint matrix elements !*TIME* !****************************************************************************** Subroutine AccumBothProj_TIME(Hx, Ox, PDot, Dij, Oij) Complex, Intent(INOUT) :: Hx(:) Complex, Intent(INOUT) :: Ox(:) Complex, Intent(IN) :: PDOT(:) Complex, EXTERNAL :: Dij Complex, EXTERNAL :: Oij !Complex :: Ch(PLM_Max), Co(PLM_Max) Complex ,allocatable :: Ch(:), Co(:) Integer :: gmax, ng, G_Half, G_Size Integer :: Prange(2) Integer :: i, Base_DI, atom, L, m, n, am, RadP, PLM_Index Complex, Pointer :: Ylm(:), Phase(:) Complex, Pointer :: Work(:), Proj(:) Real :: c1 Complex :: c2, c3 Allocate( Ch(PLM_Max), Co(PLM_Max)) !V=0 !RETURN !**REMOVE** Debug Only !Call AccumBothProj_MEM(Hx, Ox, PDot, Dij, Oij) !RETURN Call CalcAccumVector(Ch, PDOT, Dij) Call CalcAccumVector(Co, PDOT, Oij) !------ ng = Gpnt_Size(G_LOW) - 1 G_Half=Gpnt_Size(G_LOW) G_Size=Gall_Size(G_LOW) Do atom=1, Specific_Atoms Base_DI = RS_PLMMax(atom)*(Mem_Kpnt-1) Do n=1, RS_PLMMax(atom) RadP = RS_PLM(atom,1,n) L = RS_PLM(atom,2,n) m = RS_PLM(atom,3,n) am = ABS(m) Call LRU_GetRec(LRU_Proj(atom), Base_DI + n, Proj) c2 = Ch(RS_PLM(atom,4,n)) c3 = Co(RS_PLM(atom,4,n)) !i = 1 !Hx(i) = Hx(i) + CONJG(Proj(i))*c2 !Ox(i) = Ox(i) + CONJG(Proj(i))*c3 !Do i=2, G_Half ! Hx(i) = Hx(i) + CONJG(Proj(i))*c2 ! Hx(i+ng) = Hx(i+ng) + CONJG(Proj(i+G_Half-1)) * c2 ! Ox(i) = Ox(i) + CONJG(Proj(i))*c3 ! Ox(i+ng) = Ox(i+ng) + CONJG(Proj(i+G_Half-1)) * c3 !end Do Hx(:)=Hx(:)+CONJG(Proj(:))*c2 Ox(:)=Ox(:)+CONJG(Proj(:))*c3 End Do End Do DeAllocate( Ch, Co) !------ Return End Subroutine !****************************************************************************** ! ! AccumBothProj_MEM - Accumulates the summed |pi>Dij and ! and |pi>Oij to the given vectors ! ! Hx - Output vector for Dij sum. NOTE: The vector is not initialized to 0! ! Ox - Output vector for Oij sum. NOTE: The vector is not initialized to 0! ! PDOT - List of products ! Dij - External function for calculaint matrix elements ! Oij - External function for calculaint matrix elements ! !*MEMORY* !****************************************************************************** Subroutine AccumBothProj_MEM(Hx, Ox, PDot, Dij, Oij) Complex, Intent(INOUT) :: Hx(:) Complex, Intent(INOUT) :: Ox(:) Complex, Intent(IN) :: PDOT(:) Complex, EXTERNAL :: Dij Complex, EXTERNAL :: Oij !Complex :: Ch(PLM_Max), Co(PLM_Max), Hc, Oc Complex :: Hc, Oc Complex ,allocatable :: Ch(:), Co(:) Integer :: Kpnt, G_Half, G_Size, NG Integer :: Prange(2), atype Integer :: i, Base_DI, atom, L, m, n, am, RadP, PLM_Index Complex, Pointer :: Ylm(:), Phase(:) Complex, Pointer :: Work(:) Real, Pointer :: Proj(:) Real :: c1 Complex :: Pos_M, Neg_M, c2, c3 Allocate(Ch(PLM_Max), Co(PLM_Max)) Call CalcAccumVector(Ch, PDOT, Dij) Call CalcAccumVector(Co, PDOT, Oij) Kpnt = Mem_Kpnt c1 = 4*Pi / sqrt(xtal%Volume) ng = Gpnt_Size(G_LOW) - 1 G_Half = Gpnt_Size(G_LOW) G_Size = Gall_Size(G_LOW) Do atom=1, Specific_Atoms Call GetStructFactor( atom, Phase) atype = Atom_List(atom)%typeIndex Base_DI = Atomtype_Info(atype)%Basis_Size * & (Mem_Kpnt-1) !** Calc starting DI for Kpnt Do n=1, RS_PLMMax(atom) RadP = RS_PLM(atom,1,n) L = RS_PLM(atom,2,n) m = RS_PLM(atom,3,n) PLM_Index = RS_PLM(atom,4,n) am = ABS(m) Call LRU_GetRec(LRU_RadProj(atype), Base_DI + radP, Proj) Call GetYlm( Mem_Kpnt, L, am, Ylm) c2 = CMPLX(0,-1)**L If (m>=0) then Hc = c1*c2*Ch(PLM_Index) Oc = c1*c2*Co(PLM_Index) !i = 1 !Hx(i) = Hx(i) + Hc*Ylm(i)*Proj(i)*CONJG(Phase(i)) !Ox(i) = Ox(i) + Oc*Ylm(i)*Proj(i)*CONJG(Phase(i)) !Do i=2, G_Half ! Hx(i) = Hx(i) + Hc*Ylm(i)*Proj(i)*CONJG(Phase(i)) ! Hx(i+ng) = Hx(i+ng) + Hc*Ylm(i+ng)*Proj(i+G_half-1) * & ! CONJG(Phase(i+ng)) ! Ox(i) = Ox(i) + Oc*Ylm(i)*Proj(i)*CONJG(Phase(i)) ! Ox(i+ng) = Ox(i+ng) + Oc*Ylm(i+ng)*Proj(i+G_half-1) * & ! CONJG(Phase(i+ng)) !end Do Hx(:)=Hx(:)+Hc*Ylm(:)*Proj(:)*CONJG(Phase(:)) Ox(:)=Ox(:)+Oc*Ylm(:)*Proj(:)*CONJG(Phase(:)) Else Hc = c1*c2*Ch(PLM_Index)*(-1)**am Oc = c1*c2*Co(PLM_Index)*(-1)**am !i = 1 !Hx(i) = Hx(i) + Hc*Proj(i)*CONJG(Ylm(i)*Phase(i)) !Ox(i) = Ox(i) + Oc*Proj(i)*CONJG(Ylm(i)*Phase(i)) !Do i=2, G_Half ! Hx(i) = Hx(i) + Hc*Proj(i)*CONJG(Ylm(i)*Phase(i)) ! Hx(i+ng) = Hx(i+ng) + Hc*Proj(i+G_half-1)*CONJG(Ylm(i+ng) * & ! Phase(i+ng)) ! Ox(i) = Ox(i) + Oc*Proj(i)*CONJG(Ylm(i)*Phase(i)) ! Ox(i+ng) = Ox(i+ng) + Oc*Proj(i+G_half-1)*CONJG(Ylm(i+ng) * & ! Phase(i+ng)) !end Do Hx(:)=Hx(:)+Hc*Proj(:)*CONJG(Ylm(:)*Phase(:)) Ox(:)=Ox(:)+Oc*Proj(:)*CONJG(Ylm(:)*Phase(:)) End If End Do End Do DeAllocate(Ch, Co) Return End Subroutine !****************************************************************************** ! ! AccumBothProj - Accumulates the summed |pi>Dij and ! and |pi>Oij to the given vectors ! ! Hx - Output vector for Dij sum. NOTE: The vector is not initialized to 0! ! Ox - Output vector for Oij sum. NOTE: The vector is not initialized to 0! ! PDOT - List of products ! Dij - External function for calculaint matrix elements ! Oij - External function for calculaint matrix elements ! !****************************************************************************** Subroutine AccumBothProj(Hx, Ox, PDot, Dij, Oij) Complex, Intent(INOUT) :: Hx(:) Complex, Intent(INOUT) :: Ox(:) Complex, Intent(IN) :: PDOT(:) Complex, EXTERNAL :: Dij Complex, EXTERNAL :: Oij Call Start_Timer(Timer(AccumProj_Timer)) Select Case (Proj_Mode) Case (MIN_TIME) Call AccumBothProj_TIME(Hx, Ox, PDot, Dij, Oij) Case (MIN_MEMORY) Call AccumBothProj_MEM(Hx, Ox, PDot, Dij, Oij) Case (PROJ_RS) Call AccumBothProj_RS(Hx, Ox, PDot, Dij, Oij) !** Call AccumBothProj_MEM(Hx, Ox, PDot, Dij, Oij) End Select Call Stop_Timer(Timer(AccumProj_Timer)) Return End Subroutine !****************************************************************************** ! ! AccumProj_TIME - Accumulates the summed |pi>Dij to the given vector ! ! V - Output vector. NOTE: The vector is not initialized to 0! ! PDOT - List of products ! Dij - External function for calculaint matrix elements !*TIME* !****************************************************************************** Subroutine AccumProj_TIME(V, PDot, Dij) Complex, Intent(INOUT) :: V(:) Complex, Intent(IN) :: PDOT(:) Complex, EXTERNAL :: Dij !Complex :: Ci(PLM_Max) Complex ,allocatable :: Ci(:) Integer :: Kpnt, gmax, ng, G_half, G_Size Integer :: Prange(2) Integer :: i, Base_DI, atom, L, m, n, am, RadP, PLM_Index Complex, Pointer :: Ylm(:), Phase(:) Complex, Pointer :: Work(:), Proj(:) Real :: c1 Complex :: c3 Allocate( Ci(PLM_Max)) !V=0 !RETURN !**REMOVE** Debug Only Call CalcAccumVector(Ci, PDOT, Dij) !------ ng = Gpnt_Size(G_LOW) - 1 G_Half = Gpnt_Size(G_LOW) G_Size = Gall_Size(G_LOW) Do atom=1, Specific_Atoms Call GetStructFactor( atom, Phase) Base_DI = RS_PLMMax(atom)*(Mem_Kpnt-1) Do n=1, RS_PLMMax(atom) RadP = RS_PLM(atom,1,n) L = RS_PLM(atom,2,n) m = RS_PLM(atom,3,n) am = ABS(m) Call LRU_GetRec(LRU_Proj(atom), Base_DI + n, Proj) c3 = Ci(RS_PLM(atom,4,n)) !i = 1 !V(i) = V(i) + CONJG(Proj(i))*c3 !Do i=2, G_Half ! V(i) = V(i) + CONJG(Proj(i))*c3 ! V(i+ng) = V(i+ng) + CONJG(Proj(i+G_Half-1)) * c3 !end Do V(:)=V(:) + CONJG(Proj(:))*c3 End Do End Do DeAllocate( Ci) !------ Return End Subroutine !****************************************************************************** ! ! AccumProj_MEM - Accumulates the summed |pi>Dij to the given vector ! ! V - Output vector. NOTE: The vector is not initialized to 0! ! PDOT - List of products ! Dij - External function for calculaint matrix elements !*MEMORY* !****************************************************************************** Subroutine AccumProj_MEM(V, PDot, Dij) Complex, Intent(INOUT) :: V(:) Complex, Intent(IN) :: PDOT(:) Complex, EXTERNAL :: Dij !Complex :: Ci(PLM_Max) Complex ,allocatable :: Ci(:) Integer :: Kpnt, G_Half, G_Size, ng Integer :: Prange(2), atype Integer :: i, Base_DI, atom, L, m, n, am, RadP, PLM_Index Complex, Pointer :: Ylm(:), Phase(:) Complex, Pointer :: Work(:) Real, Pointer :: Proj(:) Real :: c1 Complex :: Pos_M, Neg_M, c2, c3 Allocate( Ci(PLM_Max)) !V=0 !RETURN !**REMOVE** Debug Only Call CalcAccumVector(Ci, PDOT, Dij) Kpnt = Mem_Kpnt c1 = 4*Pi / sqrt(xtal%Volume) ng = Gpnt_Size(G_LOW) - 1 G_Half = Gpnt_Size(G_LOW) G_Size = Gall_Size(G_LOW) Do atom=1, Specific_Atoms Call GetStructFactor( atom, Phase) atype = Atom_List(atom)%typeIndex Base_DI = Atomtype_Info(atype)%Basis_Size * & (Mem_Kpnt-1) !** Calc starting DI for Kpnt Do n=1, RS_PLMMax(atom) RadP = RS_PLM(atom,1,n) L = RS_PLM(atom,2,n) m = RS_PLM(atom,3,n) PLM_Index = RS_PLM(atom,4,n) am = ABS(m) Call LRU_GetRec(LRU_RadProj(atype), Base_DI + radP, Proj) Call GetYlm( Mem_Kpnt, L, am, Ylm) c2 = CMPLX(0,-1)**L If (m>=0) then c3 = c1*c2*Ci(PLM_Index) !i = 1 !V(i) = V(i) + c3*Ylm(i)*Proj(i)*CONJG(Phase(i)) !Do i=2, G_Half ! V(i) = V(i) + c3*Ylm(i)*Proj(i)*CONJG(Phase(i)) ! V(i+ng) = V(i+ng) + c3*Ylm(i+ng)*Proj(i+G_half-1) * & ! CONJG(Phase(i+ng)) !end Do V(:)=V(:) +c3*Ylm(:)*Proj(:)*CONJG(Phase(:)) Else c3 = c1*c2*Ci(PLM_Index)*(-1)**am !i = 1 !V(i) = V(i) + c3 * Proj(i)*CONJG(Ylm(i)*Phase(i)) !Do i=2, G_Half ! V(i) = V(i) + c3 * Proj(i)*CONJG(Ylm(i)*Phase(i)) ! V(i+ng) = V(i+ng) + c3*Proj(i+G_half-1)*CONJG(Ylm(i+ng) * & ! Phase(i+ng)) !end Do V(:)=V(:)+c3*Proj(:)*CONJG(Ylm(:)*Phase(:)) End If End Do End Do DeAllocate( Ci) Return End Subroutine !****************************************************************************** ! ! AccumProj - Accumulates the summed |pi>Dij to the given vector ! ! V - Output vector. NOTE: The vector is not initialized to 0! ! PDOT - List of products ! Dij - External function for calculaint matrix elements ! !****************************************************************************** Subroutine AccumProj(V, PDot, Dij) Complex, Intent(INOUT) :: V(:) Complex, Intent(IN) :: PDOT(:) Complex, EXTERNAL :: Dij Call Start_Timer(Timer(AccumProj_Timer)) Select Case (Proj_Mode) Case (MIN_TIME) Call AccumProj_TIME(V, PDot, Dij) Case (MIN_MEMORY) Call AccumProj_MEM(V, PDot, Dij) Case (PROJ_RS) Call AccumProj_RS(V, PDot, Dij) !** Call AccumProj_TIME(V, PDot, Dij) End Select Call Stop_Timer(Timer(AccumProj_Timer)) Return End Subroutine !****************************************************************************** ! ! RS_Update - Frees all the RS proj data and updates the data to the new ! atom positions ! !****************************************************************************** Subroutine RS_Update Integer :: atom Do atom=1, Specific_Atoms Call LRU_FreeAll(LRU_RS_Proj(atom)) Close(LRU_RS_Proj(atom)%FD_Base) DeAllocate(RS_RLE(atom)%RLE) End do Call RS_CreateProj Return End Subroutine !****************************************************************************** ! ! InitProjectors - Initializes the Projector routines ! ! FD_RadProj - Base File unit for the radial projectors ! FD_Proj - Base File unit for the complete projectors ! MaxMem - Max amout of memory to use for structure factors(Mbytes) ! !****************************************************************************** Subroutine InitProjectors(FD_RadProj, FD_Proj, MaxMem) Integer, Intent(IN) :: FD_RadProj Integer, Intent(IN) :: FD_Proj Real, Intent(IN) :: MaxMem Integer :: L, m, MaxRec, RS_Size(0:0), i PDOT_Dir = -1 !** Init previous direction of processing the pdots !RETURN !**REMOVE** Allocate(LRU_RadProj(Atom_Types), LRU_Proj(Specific_Atoms)) Do i=1, Atom_types If (run_mode == Proj_RS) then If (Atomtype_Info(i)%Gcut_Proj > PW_Gcut(G_HIGH)) then AtomType_Info(i)%Gcut_Proj = PW_Gcut(G_High) else If (Atomtype_Info(i)%Gcut_Proj <= 0) then AtomType_Info(i)%Gcut_Proj = PW_Gcut(G_LOW) End If else AtomType_Info(i)%Gcut_Proj = PW_Gcut(G_LOW) End If Atomtype_Info(i)%Gpnt_Size = FindGcut(Atomtype_Info(i)%Gcut_Proj, & Gpnt,Gpnt_Size(G_HIGH)) End Do !**REMOVE** Uncomment the next 2 lines !** Call Create_RadProjMap !** Create the radial projector map !** Proj_Max = Size(BZ%Ku(1,:)) * RadProj_Max Call Create_PLM(.FALSE.) !** Determine the PLM and PDOT array sizes Call Create_PDOT_Map(.FALSE.) Allocate(LRU_RS_Proj(Specific_Atoms), RS_PLMMax(Specific_Atoms), & RS_RLE(Specific_Atoms)) Proj_Max = PLM_Max !*** Allocate the space *** Allocate(PLM(4,PLM_Max), PLM_AtomRange(2,Specific_Atoms), & PDOT_Map(5,PDOT_Max)) Call Create_PLM(.TRUE.) !** Now fill the arrays Call Create_PDOT_Map(.TRUE.) Call RS_Find_PLMMax Call RS_FindPLM !RS_PLMMax = 1 !RS_PLM(:,2,1) = 1 !RS_PLM(:,3,1) = -1 !RS_PLM(:,2,2) = 1 !RS_PLM(:,3,2) = -1 !RETURN !**REMOVE** MaxRec = Size(BZ%Ku(1,:)) * RadProj_Max Write(Log_Unit,*) 'InitProjectors: Size(BZ%Ku))=',Size(BZ%Ku(1,:)), & ' * RadProj_Max=',RadProj_Max, ' * MaxRec=',MaxRec, & ' * PLM_Max=',PLM_Max, ' * PDOT_Max=',PDOT_Max Call Flush(Log_Unit) Call StoreRadProj !** Store the radial projectors on disk If (Run_Mode == MIN_TIME) Call StoreRawProj Write(log_unit,*) 'Proj_mode = ',Proj_mode Call Flush(Log_Unit) !Call StoreRawProj If (Proj_Mode == Proj_RS) then Allocate(RS_wt(FFT_Grid(4,G_PROJ))) Call MakeIntWeights(RS_Wt) RS_Wt = 1 !** Call RS_CreateProjMap Allocate(RS_Work1(FFT_Grid(4,G_PROJ)), RS_Work2(FFT_Grid(4,G_PROJ))) Call RS_CreateProj Allocate(RLE_Run(NumKpnts)) Do i=1, NumKpnts RLE_Run(i)%N = 0 End do Call RS_MakeGlobal_RLE End If Write(Log_Unit,*) ' Completed InitProjectors ' Call Flush(Log_Unit) Return End Subroutine End Module spinpwpaw/code/psilib.f900100664004704100470410000003503510303710172015447 0ustar natalienatalie!****************************************************************************** ! ! File : psilib.f90 ! by : Alan Tackett ! on : 7/29/98 ! for : PAW ! ! Module containing routines for moving the wave functions to and from ! memory. ! !****************************************************************************** Module psilib Use mem_data Use word Use paw_inout Use misc Use fileio Implicit NONE!!!! Logical :: Psi_Restart Integer :: Psi_Pos !** Current Psi buffer position !Integer, PRIVATE :: PSI_Loaded !** How many psi's are loaded in the buffer !****************************************************************************** Contains !****************************************************************************** !****************************************************************************** ! ! ReadPSI - Loads a particular PSI record from disk ! ! Rec - Record to load ! Psi - Psi Handle ! !****************************************************************************** Subroutine ReadPSI( Rec, Psi) Integer, Intent(IN) :: Rec Type (Mem_Handle), Intent(INOUT) :: Psi Type (Mem_Handle) , Pointer :: MH1 Character*100 :: token Integer :: i If (Rec == 0) RETURN !**** Exit if dummy record requested ***** If ((Psi%Index>0)) then If(PsiInfo(Psi%Index)%DoSave==1) then ! need to save psi If (CanAlloc(PsiArraySize)) then Call AllocMemHandle(PsiArraySize, i, MH1) Call Swap_Mem_Handles(MH1,Psi) PsiInfo(MH1%Index)%MemBufIndex=i Else Call WritePsi_NOW( Psi) EndIf End If End If Write(token,*) 'ReadPsi: Error reading Wave functions! :', & ' * Rec : ',Rec Call ReadFile_LOW(FD_Psi, Rec, Psi%Ptr, token) Psi%Index = Rec; MemCache%Psi_Read%Misses=MemCache%Psi_Read%Misses + 1 Return End Subroutine !****************************************************************************** ! ! WritePSI_NOW - Writes a particular PSI to disk ! ! Psi - Psi Handle ! !****************************************************************************** Subroutine WritePSI_NOW( Psi) Type (Mem_Handle), Intent(INOUT) :: Psi Character*100 :: token IF ( (Psi%Index /= 0)) then Write(token,*) 'Error Writing Wave functions! :', & ' * Rec : ',Psi%Index Call WriteFile_LOW(FD_Psi, Psi%Index, Psi%Ptr, token) PsiInfo(Psi%Index)%MemBufIndex = 0 Psi%Index = 0 MemCache%Psi_Write%Misses=MemCache%Psi_Write%Misses+1 End If Return End Subroutine !****************************************************************************** ! ! SavePsi_toBuffer - Saves the Psi Buffer if possible ! otherwise PSi is saved ta disk ! ! PsiIndex - Psi's disk Index ! ! Psi - Psi to save ! !****************************************************************************** Subroutine SavePsi_toBuffer( PsiIndex, Psi) Integer, Intent(IN) :: PsiIndex Complex, Intent(IN) :: Psi(:) Type(Mem_handle), Pointer :: Psi1(:) Type(Mem_handle), Pointer :: MH1 Integer :: i, NumPsi, j Character*100 :: msg If (PsiIndex <= 0 ) then write(Error_Unit,*) 'Entered SavePsi_toBuffer with PsiIndex=',PsiIndex return EndIf ! Assume this vector is to be kept PsiInfo(PsiIndex)%DoSave=1 PsiInfo(PsiIndex)%Available=Mem_Used NumPsi = Globalmap%NumPsi Psi1 => Globalmap%Psi_Handle !** Check for buffer match ** i = PsiInfo(PsiIndex)%MemBufIndex If (i > 0) then Psi1(i)%Ptr = Psi; Psi1(i)%Index=PsiIndex MemCache%Psi_Write%Hits = MemCache%Psi_Write%Hits + 1 else !*** Not in buffer, so save to blank buffer or disk *** i = 1 Do While ((Psi1(i)%Index /= 0) .AND. (i < NumPsi)) i = i + 1 End Do !*** Check if there's free memory for a buffer or a blank buffer *** If (Psi1(i)%Index == 0) then !** Blank Buffer Psi1(i)%Ptr = Psi MemCache%Psi_Write%Hits = MemCache%Psi_Write%Hits + 1 Psi1(i)%Index = PsiIndex; PsiInfo(PsiIndex)%MemBufIndex = i else if (CanAlloc( PsiArraySize)) then CAll AllocMEmHandle( PsiArraySize, i, MH1) MH1%Ptr = Psi MemCache%Psi_Write%Hits = MemCache%Psi_Write%Hits + 1 MH1%Index = PsiIndex; PsiInfo(PsiIndex)%MemBufIndex = i else !**** Must store it to disk ****** Write(msg, *) 'SavePsi_toBuffer: Error writing Psi index:',& PsiIndex, ' * RecSize=',Size(Psi) Call WriteFile_LOW(FD_Psi, PsiIndex, Psi, Msg) MemCache%Psi_Write%Misses=MemCache%Psi_Write%Misses+1 PsiInfo(PsiIndex)%MemBufIndex = 0 End If End If Return End Subroutine !****************************************************************************** ! ! GetPsi_fromBuffer - Gets the Psi from the ! current Buffer if possible otherwise the PSi is read from ! disk ! ! PsiIndex - Psi's disk Index ! Psi - Psi to read ! !****************************************************************************** Subroutine GetPsi_fromBuffer( PsiIndex, Psi) Integer, Intent(IN) :: PsiIndex Complex, Intent(OUT) :: Psi(:) Type(Mem_handle), Pointer :: Psi1(:) Type(Mem_handle), Pointer :: MH1 Integer :: i, NumPsi Character*100 :: msg If(PsiIndex<=0) then write(Error_Unit,*) 'Error in GetPsi_FromBuffer - PsiIndex=',PsiIndex call flush(Error_Unit) Stop EndIf NumPsi = GlobalMap%NumPsi Psi1 => GlobalMap%Psi_Handle !** Check for buffer match ** If (PsiInfo(PsiIndex)%MemBufIndex > 0) then i = PsiInfo(PsiIndex)%MemBufIndex Psi = Psi1(i)%Ptr MemCache%Psi_Read%Hits = MemCache%Psi_Read%Hits + 1 else !*** Not in buffer, so load from disk *** Write(msg, *) 'GetPsi_fromBuffer: Error reading Psi index:',PsiIndex !write(Log_Unit,*) 'in getpsi reading index',psiindex,psiinfo(psiindex)%membufindex Call ReadFile_LOW(FD_Psi, PsiIndex, Psi, Msg) MemCache%Psi_Read%Misses = MemCache%Psi_Read%Misses + 1 !*** Check if there's free memory for a buffer If (CanAlloc( PsiArraySize)) then Call AllocMEmHandle( PsiArraySize, i, MH1) MH1%Ptr = Psi MH1%Index = PsiIndex; PsiInfo(PsiIndex)%MemBufIndex = i !write(Log_Unit,*) 'ingetpsi -- saving to allocated slot', psiindex,i End If End If Return End Subroutine !****************************************************************************** ! ! PreparePsi - Loads the Psi's into the data buffer and ! initializes Psi_Processed ! ! Process_List - List of Psi's for loading. A Psi will be marked for ! loading if its Process_List index == MH_toProcess. ! Otherwise it will be ignored. ! ! !****************************************************************************** Subroutine PreparePsi( Process_List) Integer, Intent(IN) :: Process_List(:) Integer :: i, j, k, PsiNeeded, PsiLoaded, Used,Psi1Index,Psi2Index Integer :: LSize Type (Global_handle), Pointer :: LH Type (Mem_handle), Pointer :: MH(:) Type (Mem_handle), Pointer :: MH1 Character*100 :: msg Complex, Pointer :: Ptr(:) Psi_Processed = Process_List LSize = PsiArraySize LH => Globalmap MH => LH%PSi_handle Used = 0 !write(Log_Unit,*) 'inpreparepsi',SUM(Psi_Processed) PsiNeeded = SUM(Psi_Processed) If ((LH%NumPsi>0).AND.(PsiNeeded>0)) Then Do i=1, LH%NumPsi !** Move the Good Psi's to the front Psi1Index=MH(i)%Index If(Psi1Index > 0) then IF (PSi_Processed(Psi1Index) == MH_toProcess) then Used = Used + 1 If (i /= Used) then Psi2Index=MH(Used)%Index If (Psi2Index > 0) then Call Swap_Mem_Handles(MH(i), MH(Used)) PsiInfo(Psi1Index)%MemBufIndex = used PsiInfo(Psi2Index)%MemBufIndex = i Else Call Swap_Mem_Handles(MH(i),MH(Used)) PsiInfo(Psi1Index)%MemBufIndex = used EndIf ! Psi2Index>0 EndIf !i/= Used Psi_Processed(MH(Used)%Index) = MH_Processed !** Skip in next phase End If !PsiProcessed EndIf ! PsiIndex > 0 End Do EndIf PsiNeeded = PsiNeeded - Used PsiLoaded = Used i=Used !write(Log_Unit,*) 'inpreparepsi -- used loaded needed' , Used,Psiloaded,Psineeded If (PsiNeeded > 0) then Do i=i+1 If ((SUM(Psi_Processed)<=0).OR.(i>LH%NumPsi)) Exit j = 1 Call GetNextIndex_toProcess(j, Psi_Processed) If (j <= 0 ) then write(Error_Unit,*) 'Error in PreparePsi -- j=',j Stop EndIf Psi1Index=MH(i)%Index !write(Log_Unit,*) 'inpreparepsi -- i,j',i,j,Psi1Index If (Psi1Index > 0) then ! need to save psi1Index Call ReadPsi( j, MH(i)) PsiInfo(j)%MemBufIndex=i Psi_Processed(j)=MH_Processed !write(Log_Unit,*) 'inpreparepsi -- Called ReadPsi' Else Used=PsiInfo(j)%MemBufIndex !write(Log_Unit,*) 'inpreparepsi -- Did not call readpsi', used,i,j If (Used > 0 ) then Call Swap_Mem_Handles(MH(Used),MH(i)) PsiInfo(j)%MemBufIndex=i !write(Log_Unit,*) 'preparepsi--strange happenings',Used,i,j,MH(i)%Index Else write(msg,*)'Error in PreparePsi - j = ',j Call ReadFile_LOW(FD_Psi, j ,MH(i)%Ptr,msg) PsiInfo(j)%MemBufIndex = i MH(i)%Index=j !write(Log_Unit,*) 'preparepsi--Called ReadFile',i,j,MH(i)%Index EndIf Psi_Processed(j)=MH_Processed EndIf PsiLoaded = PsiLoaded + 1 End Do EndIf Psi_Restart = .TRUE. Psi_Processed = Process_List LH%PsiLoaded = PsiLoaded Return End Subroutine !****************************************************************************** ! ! GetNextPSI - Returns the Next Psi or Set of Psi's ! ! Flag - Index=0 if no more Psi's, >0 otherwise ! Psi1 - Current Psi ! ! NOTE: No error checking is done. ! !****************************************************************************** Subroutine GetNextPsi(Flag, Psi1) Integer, Intent(OUT) :: Flag Type (Mem_Handle), Pointer :: Psi1 Integer :: i, j, Left, Psi_Loaded, List(Mem_MapSize), A(1) Flag = 0 PSI_Loaded = Globalmap%PsiLoaded If (PSI_Restart) then !** Restart Psi_Pos = 1 Psi_restart = .FALSE. Psi_Processed = Psi_toProcess End IF If (Psi_Pos > Psi_Loaded) then !** Try to load the next set PSI_Loaded = Globalmap%NumPsi Left=SUM(Psi_Processed) If (Left <= 0) then !** No Psi's left to process so restart Psi_Restart = .TRUE. Psi_Processed = Psi_toProcess End If List=Psi_Processed Call PreparePsi( List) if (Left > 0) Psi_Restart = .FALSE. Psi_Pos = 1 End If If (.NOT. Psi_Restart) then Psi1 => Globalmap%PSI_Handle(Psi_Pos) MemCache%Psi_Read%Hits = & MemCache%Psi_Read%Hits + 1 Flag = Psi1%Index If(Flag>0) then Psi_Processed(Flag) = MH_PROCESSED !** Mark as processed Flag=PsiInfo(Flag)%Kpnt Else write(Error_Unit,*) ' Error in GetNextPsi -- flag=',& flag,globalmap%Psiloaded EndIf Psi_Pos = PSi_Pos + 1 else !** Finished Processing !Write(*,*) 'GetNExtPsi: BZ_Index=0!!!!!!!!!!!!!!!!!!!!' Flag = 0 ! Nullify(Psi1) End If Return End Subroutine !***************************************************************************** ! ! GetNextPsi_UnProcessed - Gets the next UNPROCESSED Psi ! and also initialize sequential processing ! ! Flag - Flag=0 if no more Psi's need to be processed, ! >0 otherwise ! VecProcessed - Array determining which vectors have been processed. ! A processed Psi contains a 0 in the appropriate array slot. ! PsiIndex - Psi and FAS disk Index returned ! PsiPtr - Pointer to the next Psi ! !**************************************************************** Subroutine GetNextPsi_UnProcessed(Flag,VecProcessed,PsiIndex,PsiPtr) Integer, Intent(OUT) :: Flag Integer, Intent(INOUT) :: VecProcessed(:) Integer, Intent(OUT) :: PsiIndex Complex, Intent(OUT) :: PsiPtr(:) !Integer :: i, j, Used, Psiinbuffer,Left, Psi_list(Mem_MapSize) Integer :: i, j, Used, Psiinbuffer,Left Integer ,allocatable :: Psi_list(:) Type(Mem_handle), Pointer :: MH1(:) Type(Mem_handle) :: temp Complex, Pointer :: Ptr(:) Character*100 :: msg Allocate(Psi_list(Mem_MapSize)) Flag = 0 If (SUM(VecProcessed) <= 0) return ! no more vectors left MH1 => Globalmap%Psi_Handle i=1 Do While ((i 0) then PsiIndex = i Flag = PsiInfo(PsiIndex)%Kpnt PsiPtr = MH1(j)%Ptr MemCache%Psi_Read%Hits = & MemCache%Psi_Read%Hits + 1 Else Call GetPsi_fromBuffer( i , PsiPtr) PsiIndex = i Flag = PsiInfo(PsiIndex)%Kpnt End if !*** Now we need to move all the unprocessed Psi's to the front of *** !*** the buffer and fill the remaining slots with unprocessed Psi's *** Psi_List = MH_Skip Where ((Psi_toProcess == MH_toProcess) .AND. & (VecProcessed == MH_Processed)) Psi_List = MH_toProcess VecProcessed(PsiIndex) = MH_Processed !** Mark returned psi as processed Psi_List(PsiIndex)=MH_Processed Call PreparePsi( PSi_List) Psi_Restart = .FALSE. !*** Don't want GetNextPsi using Psi_toPRocess Psi_Pos = 1 DeAllocate(Psi_list) Return End Subroutine !****************************************************************************** ! ! InitPsiLib - Initializes the PSIlib routines for use. ! Currently it only opens the Psi data files. ! !****************************************************************************** Subroutine InitPsiLib implicit none Integer :: RecSize, err Character*100 :: msg Psi_Restart = .TRUE. RecSize = SizeOf_Complex * PsiArraySize Write(Log_Unit,*) 'InitPsiLib: Rec Size=',RecSize call flush(Log_unit) Open(FD_Psi, Form="UNFORMATTED", status="SCRATCH", & Access="DIRECT", RECL=REcSize, IOSTAT=err) Write(msg,*) ' Error opening file. Rec Size=',RecSize Call Check_Error(err, msg, Error_Unit, .TRUE., PAW_wc, & "InitPsiLib:") Return End Subroutine End Module spinpwpaw/code/pwpaw.f900100664004704100470410000000273510303710172015324 0ustar natalienatalie!*************************************************************************** ! ! File : pwpaw.f90 ! by : Alan Tackett ! on : 4/14/98 ! for : PlaneWave PAW Project ! ! This is the Driver program for the PWPAW project. ! !*************************************************************************** Program PWPAW Use mathlib Use paw_inout Use Word Use Strings Use timing implicit none Type (WatchType) :: w Character(132) :: Fn, token Logical :: ex Integer :: err, i,iargc if (iargc() < 1) then Write(*,*) 'Format: pwpaw input_file' STOP End if Call GetArg(1,Fn) write(*,*) 'Filename=',Fn Token = Fn Call UpperCase(Token) Inquire(file=Trim(fn),exist=ex) if (Trim(token) == KBD_INPUT) then Fn = Token ! else if (Access(trim(fn), "r") /= 0) then else if (.not.ex) then Write(*,*) "Can't access file ",Trim(fn) Write(*,*) "Make sure the file exists and has Read permissions." ! ! !DEC$ If Defined (_WIN32) !! Call PError("PWPAW:") ! !DEC$ else ! Call PError !! !DEC$ End If STOP End If Call InitTimers !** Initialize the timers Call Start_Timer(Timer(Total_Timer)) Call initconstants Call PAW_Init Print_Level = PRINT_VERBOSE Write(*,*) 'Scratch_FD=',Scratch_Unit Call DetWordConstants(SCRATCH_UNIT) Call InitWord(PAW_WC, INPUT_BASE_UNIT, trim(Fn), DELIMS, COMMENT, LIT_CHAR, & MAX_INCLUDE, INCLUDE_STR) Call Read_Input(PAW_WC) Call PAW_End End spinpwpaw/code/qtbzi.f900100664004704100470410000002454710303710172015324 0ustar natalienatalie!*************************************************************************** ! ! File : qtbzi.f90 ! by : Alan Tackett ! on : 7/26/95 ! for : PAW Method ! ! ! qtbzi - Quadratic Tetrahedron Brillouin Zone Integration ! ! This file contains routines to perform BZ integration using a ! Quadratic Tetrahedron Method. Currently all integration is done ! numberically. Hopefully it can be replaced at a later date with an ! analytic version. ! !************************************************************************** Module qtbzi implicit none Type TetraVertices Integer :: Corners(10) !** Tetrahedron Corners End Type Type (TetraVertices), Private, Target :: TetraCorners(6) Real, Private, Pointer :: Klist(:,:) !** K points list Real, Private, Pointer :: Kenergy(:,:) Integer, Private :: TotalKpnts !** Num K points Integer, Private, Pointer :: TetraList(:,:) !** Tetrahedron list Integer, Private, Pointer :: Cube(:,:) !** Cubelist Integer, Private :: TotalTetra !** Num Tetrahedra Integer, Private :: TotalCubes !** Num Cubes Integer, Private :: TotalBands !** Num Energy Bands Integer, Private :: TotalElectrons !** # electrons Real, Private :: TetraVolume !** Tetrahedron Volume Real, Private :: FermiEnergy !** Fermi Energy Level Real, Private :: TetraConst !** Volume Const Real, Private, Pointer :: Weights(:,:)!** Integration Weights Integer, Public :: qtbzi_INTERVALS !**Num Int. intervals Contains !**************************************************************************** ! ! InitQTBZI - Initialize the QTBZI routines for use. ! ! Num_Bands- # of Energy Bands ! Num_Electrons - # of electrons ! KSize - # of K points ! KPnts - Pointer to K Points table ! KE - Pointer to Energy Table for K points ! Wt - Pointer to the Integration Weights Table ! CubeNum - # of Cubes ! CubeList - Pointer to Cube info ! CubeVol - Volume of a cube in reciprocal space ! UnitCellVol - Volume of a Unit Cell ! !**************************************************************************** Subroutine InitQTBZI(Num_Bands, Num_Electrons, KSize, KPnts, Ke, Wt, & CubeNum, CubeList, CubeVol, UnitCellVol) Integer, Intent(IN) :: Num_Bands Integer, Intent(IN) :: Num_Electrons Integer, Intent(IN) :: KSize Real, Pointer :: KPnts(:,:) Real, Pointer :: Ke(:,:) Real, Pointer :: Wt(:,:) Integer, Intent(IN) :: CubeNum Integer, Pointer :: CubeList(:,:) Real, Intent(IN) :: CubeVol Real, Intent(IN) :: UnitCellVol Integer :: i, j, k, n, Sum Integer, Pointer :: Corner(:) !*********** Initialize the Cube to Tetra LUT*********** TetraCorners(1)%Corners = (/ 3, 5, 7, 2, 1, 12, 21, 14, 11, 4/) TetraCorners(2)%Corners = (/19, 20, 21, 10, 1, 13, 7, 14, 4, 11/) TetraCorners(3)%Corners = (/ 3, 6, 9, 5, 7, 12, 21, 15, 14, 8/) TetraCorners(4)%Corners = (/19, 22, 25, 20, 21, 13, 7, 16, 14, 23/) TetraCorners(5)%Corners = (/ 9, 15, 21, 18, 27, 8, 7, 14, 17, 24/) TetraCorners(6)%corners = (/25, 26, 27, 23, 21, 16, 7, 17, 14, 24/) !*********** Initialize the tables *********** TotalKpnts = KSize Klist => Kpnts KEnergy => Ke Weights => Wt TotalCubes = CubeNum Cube => CubeList TotalBands = Num_Bands TetraConst = CubeVol / UnitCellVol TotalElectrons = Num_Electrons qtbzi_INTERVALS = 15 TotalTetra = 6*TotalCubes Allocate(TetraList(TotalTetra, 10)) n = 0 Do i=1, Totalcubes Do j=1, 6 n = n + 1 TetraList(n,1:10) = Cube(i,TetraCorners(j)%Corners(1:10)) End Do End Do Return End Subroutine !**************************************************************************** ! ! qt_TetraNOS - Integrates over the tetrahedron the NOS function up to ! the Fermi surface. ! ! NOS - Upon Return contains the NOS for the Tetrahedron ! N - Number of intervals for subdivision. ! ef - Fermi Energy ! e1,..,e10 - Tetrahedron Energy Values ! ! Return Values ! Returns the integral of the function below the Fermi Surface in NOS ! !**************************************************************************** Real Function qt_TetraNOS(N,ef,e1,e2,e3,e4,e5,e6,e7,e8,e9,e10) Integer, Intent(IN) :: N Real, Intent(IN) :: ef,e1,e2,e3,e4,e5,e6,e7,e8, e9, e10 Real :: delta, dv, t, ans, x, y, z, energy Real :: w1,w2,w3,w4,w5,w6,w7,w8,w9,w10 Integer :: i, j, k delta = 1.0/N dv = delta*delta*delta ans = 0 do i=1, N x = delta * (i-0.5) Do j=1, N-i+1 y = delta * (j-0.5) Do k=1, N-i-j+1 z = delta * (k-0.5) t = x + y + z - 1 w1 = 2 * (t + 0.5) * t w2 = -4*x*t w3 = x * (2*x-1) w4 = -4*y*t w5 = y * (2*y-1) w6 = -4*z*t w7 = z*(2*z-1) w8 = 4*x*z w9 = 4*y*z w10 = 4*x*y energy = w1*e1+w2*e2+w3*e3+w4*e4+w5*e5+ & w6*e6+w7*e7+w8*e8+w9*e9+w10*e10 if (energy<=ef) ans = ans + dv End Do End Do End Do qt_TetraNOS = ans * TetraConst Return End Function !**************************************************************