GWW/0000755000077300007730000000000012341332543012012 5ustar giannozzgiannozzGWW/doc/0000755000077300007730000000000012341332543012557 5ustar giannozzgiannozzGWW/doc/make.sys_SCALAPACK0000644000077300007730000001166612341332532015606 0ustar giannozzgiannozz# make.sys. Generated from make.sys.in by configure. # compilation rules .SUFFIXES : .SUFFIXES : .o .c .f .f90 # most fortran compilers can directly preprocess c-like directives: use # $(MPIF90) $(F90FLAGS) -c $< # if explicit preprocessing by the C preprocessor is needed, use: # $(CPP) $(CPPFLAGS) $< -o $*.F90 # $(MPIF90) $(F90FLAGS) -c $*.F90 -o $*.o # remember the tabulator in the first column !!! .f90.o: $(MPIF90) $(F90FLAGS) -c $< # .f.o and .c.o: do not modify .f.o: $(F77) $(FFLAGS) -c $< .c.o: $(CC) $(CFLAGS) -c $< # DFLAGS = precompilation options (possible arguments to -D and -U) # used by the C compiler and preprocessor # FDFLAGS = as DFLAGS, for the f90 compiler # See include/defs.h.README for a list of options and their meaning # With the exception of IBM xlf, FDFLAGS = $(DFLAGS) # For IBM xlf, FDFLAGS is the same as DFLAGS with separating commas DFLAGS = -D__INTEL -D__FFTW -D__USE_INTERNAL_FFTW -D__MPI -D__PARA FDFLAGS = $(DFLAGS) # IFLAGS = how to locate directories where files to be included are # In most cases, IFLAGS = -I../include # If loading an external FFTW library, add the location of FFTW include files IFLAGS = -I../include # MODFLAGS = flag used by f90 compiler to locate modules # You need to search for modules in ./, in ../iotk/src, in ../Modules # Some applications also need modules in ../PW and ../PH MODFLAGS = -I./ -I../Modules -I../iotk/src \ -I../PW -I../PH -I../GWW/pw4gww # Compilers: fortran-90, fortran-77, C # If a parallel compilation is desired, MPIF90 should be a fortran-90 # compiler that produces executables for parallel execution using MPI # (such as for instance mpif90, mpf90, mpxlf90,...); # otherwise, an ordinary fortran-90 compiler (f90, g95, xlf90, ifort,...) # If you have a parallel machine but no suitable candidate for MPIF90, # try to specify the directory containing "mpif.h" in IFLAGS # and to specify the location of MPI libraries in MPI_LIBS MPIF90 = mpif90 #F90 = ifort CC = icc F77 = ifort # C preprocessor and preprocessing flags - for explicit preprocessing, # if needed (see the compilation rules above) # preprocessing flags must include DFLAGS and IFLAGS CPP = cpp CPPFLAGS = -P -traditional $(DFLAGS) $(IFLAGS) # compiler flags: C, F90, F77 # C flags must include DFLAGS and IFLAGS # F90 flags must include MODFLAGS, IFLAGS, and FDFLAGS with appropriate syntax CFLAGS = -O3 $(DFLAGS) $(IFLAGS) F90FLAGS = $(FFLAGS) -nomodule -fpp $(FDFLAGS) $(IFLAGS) $(MODFLAGS) ###FFLAGS = -O2 -assume byterecl FFLAGS = -O2 -assume byterecl -heap-arrays 100000 # compiler flags without optimization for fortran-77 # the latter is NEEDED to properly compile dlamch.f, used by lapack FFLAGS_NOOPT = -O0 -assume byterecl # Linker, linker-specific flags (if any) # Typically LD coincides with F90 or MPIF90, LD_LIBS is empty LD = mpif90 LDFLAGS = -i-static -openmp LD_LIBS = # External Libraries (if any) : blas, lapack, fft, MPI # If you have nothing better, use the local copy : ../flib/blas.a ####BLAS_LIBS = -L/opt/intel/mkl/10.0.5.025/lib/em64t -lmkl_em64t BLAS_LIBS = /opt/intel/mkl/10.0.5.025/lib/em64t/libmkl_blacs_openmpi_lp64.a -L/opt/intel/mkl/10.0.5.025/lib/em64t/ -lmkl_em64t -lguide -lpthread # The following lapack libraries will be available in flib/ : # ../flib/lapack.a : contains all needed routines # ../flib/lapack_atlas.a: only routines not present in the Atlas library # For IBM machines with essl (-D__ESSL): load essl BEFORE lapack ! # remember that LAPACK_LIBS precedes BLAS_LIBS in loading order ###LAPACK_LIBS = -L/opt/intel/mkl/10.0.5.025/lib/em64t -lmkl_em64t LAPACK_LIBS = /opt/intel/mkl/10.0.5.025/lib/em64t/libmkl_lapack.a /opt/intel/mkl/10.0.5.025/lib/em64t/libmkl_scalapack.a # nothing needed here if the the internal copy of FFTW is compiled # (needs -D__FFTW -D__USE_INTERNAL_FFTW in DFLAGS) FFT_LIBS = # For parallel execution, the correct path to MPI libraries must # be specified in MPI_LIBS (except for IBM if you use mpxlf) MPI_LIBS = # IBM-specific: MASS libraries, if available and if -D__MASS is defined in FDFLAGS MASS_LIBS = # pgplot libraries (used by some post-processing tools) PGPLOT_LIBS = # ar command and flags - for most architectures: AR = ar, ARFLAGS = ruv # ARFLAGS_DYNAMIC is used in iotk to produce a dynamical library, # for Mac OS-X with PowerPC and xlf compiler. In all other cases # ARFLAGS_DYNAMIC = $(ARFLAGS) AR = ar ARFLAGS = ruv ARFLAGS_DYNAMIC= ruv # ranlib command. If ranlib is not needed (it isn't in most cases) use # RANLIB = echo RANLIB = ranlib # all internal and external libraries - do not modify LIBOBJS = ../flib/ptools.a ../flib/flib.a ../clib/clib.a ../iotk/src/libiotk.a LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FFT_LIBS) $(MPI_LIBS) $(MASS_LIBS) $(PGPLOT_LIBS) $(LD_LIBS) GWW/doc/README0000644000077300007730000000043112341332532013433 0ustar giannozzgiannozzFor detailed informations on input flags go to http://gww.qe-forge.org/ A tutorial is also available. ############################################## To compile with scalapack see as an example make.sys_SCALAPACK ############################################# Joe, 02/07/2009 GWW/minpack/0000755000077300007730000000000012341332543013434 5ustar giannozzgiannozzGWW/minpack/mlegzo.f0000644000077300007730000000301012341332532015070 0ustar giannozzgiannozz SUBROUTINE LEGZO(N,X,W) C C ========================================================= C Purpose : Compute the zeros of Legendre polynomial Pn(x) C in the interval [-1,1], and the corresponding C weighting coefficients for Gauss-Legendre C integration C Input : n --- Order of the Legendre polynomial C Output: X(n) --- Zeros of the Legendre polynomial C W(n) --- Corresponding weighting coefficients C ========================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION X(N),W(N) N0=(N+1)/2 DO 45 NR=1,N0 Z=DCOS(3.1415926D0*(NR-0.25D0)/N) 10 Z0=Z P=1.0D0 DO 15 I=1,NR-1 15 P=P*(Z-X(I)) F0=1.0D0 IF (NR.EQ.N0.AND.N.NE.2*INT(N/2)) Z=0.0D0 F1=Z DO 20 K=2,N PF=(2.0D0-1.0D0/K)*Z*F1-(1.0D0-1.0D0/K)*F0 PD=K*(F1-Z*PF)/(1.0D0-Z*Z) F0=F1 20 F1=PF IF (Z.EQ.0.0) GO TO 40 FD=PF/P Q=0.0D0 DO 35 I=1,NR WP=1.0D0 DO 30 J=1,NR IF (J.NE.I) WP=WP*(Z-X(J)) 30 CONTINUE 35 Q=Q+WP GD=(PD-Q*FD)/P Z=Z-FD/GD IF (DABS(Z-Z0).GT.DABS(Z)*1.0D-15) GO TO 10 40 X(NR)=Z X(N+1-NR)=-Z W(NR)=2.0D0/((1.0D0-Z*Z)*PD*PD) 45 W(N+1-NR)=W(NR) RETURN END GWW/minpack/dpmpar.f0000644000077300007730000001323612341332532015071 0ustar giannozzgiannozz double precision function dpmpar(i) integer i c ********** c c Function dpmpar c c This function provides double precision machine parameters c when the appropriate set of data statements is activated (by c removing the c from column 1) and all other data statements are c rendered inactive. Most of the parameter values were obtained c from the corresponding Bell Laboratories Port Library function. c c The function statement is c c double precision function dpmpar(i) c c where c c i is an integer input variable set to 1, 2, or 3 which c selects the desired machine parameter. If the machine has c t base b digits and its smallest and largest exponents are c emin and emax, respectively, then these parameters are c c dpmpar(1) = b**(1 - t), the machine precision, c c dpmpar(2) = b**(emin - 1), the smallest magnitude, c c dpmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude. c c Argonne National Laboratory. MINPACK Project. November 1996. c Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More' c c ********** integer mcheps(4) integer minmag(4) integer maxmag(4) double precision dmach(3) equivalence (dmach(1),mcheps(1)) equivalence (dmach(2),minmag(1)) equivalence (dmach(3),maxmag(1)) c c Machine constants for the IBM 360/370 series, c the Amdahl 470/V6, the ICL 2900, the Itel AS/6, c the Xerox Sigma 5/7/9 and the Sel systems 85/86. c c data mcheps(1),mcheps(2) / z34100000, z00000000 / c data minmag(1),minmag(2) / z00100000, z00000000 / c data maxmag(1),maxmag(2) / z7fffffff, zffffffff / c c Machine constants for the Honeywell 600/6000 series. c c data mcheps(1),mcheps(2) / o606400000000, o000000000000 / c data minmag(1),minmag(2) / o402400000000, o000000000000 / c data maxmag(1),maxmag(2) / o376777777777, o777777777777 / c c Machine constants for the CDC 6000/7000 series. c c data mcheps(1) / 15614000000000000000b / c data mcheps(2) / 15010000000000000000b / c c data minmag(1) / 00604000000000000000b / c data minmag(2) / 00000000000000000000b / c c data maxmag(1) / 37767777777777777777b / c data maxmag(2) / 37167777777777777777b / c c Machine constants for the PDP-10 (KA processor). c c data mcheps(1),mcheps(2) / "114400000000, "000000000000 / c data minmag(1),minmag(2) / "033400000000, "000000000000 / c data maxmag(1),maxmag(2) / "377777777777, "344777777777 / c c Machine constants for the PDP-10 (KI processor). c c data mcheps(1),mcheps(2) / "104400000000, "000000000000 / c data minmag(1),minmag(2) / "000400000000, "000000000000 / c data maxmag(1),maxmag(2) / "377777777777, "377777777777 / c c Machine constants for the PDP-11. c c data mcheps(1),mcheps(2) / 9472, 0 / c data mcheps(3),mcheps(4) / 0, 0 / c c data minmag(1),minmag(2) / 128, 0 / c data minmag(3),minmag(4) / 0, 0 / c c data maxmag(1),maxmag(2) / 32767, -1 / c data maxmag(3),maxmag(4) / -1, -1 / c c Machine constants for the Burroughs 6700/7700 systems. c c data mcheps(1) / o1451000000000000 / c data mcheps(2) / o0000000000000000 / c c data minmag(1) / o1771000000000000 / c data minmag(2) / o7770000000000000 / c c data maxmag(1) / o0777777777777777 / c data maxmag(2) / o7777777777777777 / c c Machine constants for the Burroughs 5700 system. c c data mcheps(1) / o1451000000000000 / c data mcheps(2) / o0000000000000000 / c c data minmag(1) / o1771000000000000 / c data minmag(2) / o0000000000000000 / c c data maxmag(1) / o0777777777777777 / c data maxmag(2) / o0007777777777777 / c c Machine constants for the Burroughs 1700 system. c c data mcheps(1) / zcc6800000 / c data mcheps(2) / z000000000 / c c data minmag(1) / zc00800000 / c data minmag(2) / z000000000 / c c data maxmag(1) / zdffffffff / c data maxmag(2) / zfffffffff / c c Machine constants for the Univac 1100 series. c c data mcheps(1),mcheps(2) / o170640000000, o000000000000 / c data minmag(1),minmag(2) / o000040000000, o000000000000 / c data maxmag(1),maxmag(2) / o377777777777, o777777777777 / c c Machine constants for the Data General Eclipse S/200. c c Note - it may be appropriate to include the following card - c static dmach(3) c c data minmag/20k,3*0/,maxmag/77777k,3*177777k/ c data mcheps/32020k,3*0/ c c Machine constants for the Harris 220. c c data mcheps(1),mcheps(2) / '20000000, '00000334 / c data minmag(1),minmag(2) / '20000000, '00000201 / c data maxmag(1),maxmag(2) / '37777777, '37777577 / c c Machine constants for the Cray-1. c c data mcheps(1) / 0376424000000000000000b / c data mcheps(2) / 0000000000000000000000b / c c data minmag(1) / 0200034000000000000000b / c data minmag(2) / 0000000000000000000000b / c c data maxmag(1) / 0577777777777777777777b / c data maxmag(2) / 0000007777777777777776b / c c Machine constants for the Prime 400. c c data mcheps(1),mcheps(2) / :10000000000, :00000000123 / c data minmag(1),minmag(2) / :10000000000, :00000100000 / c data maxmag(1),maxmag(2) / :17777777777, :37777677776 / c c Machine constants for the VAX-11. c c data mcheps(1),mcheps(2) / 9472, 0 / c data minmag(1),minmag(2) / 128, 0 / c data maxmag(1),maxmag(2) / -32769, -1 / c c Machine constants for IEEE machines. c data dmach(1) /2.22044604926d-16/ data dmach(2) /2.22507385852d-308/ data dmach(3) /1.79769313485d+308/ c dpmpar = dmach(i) return c c Last card of function dpmpar. c end GWW/minpack/lmdif1.f0000644000077300007730000001077412341332532014766 0ustar giannozzgiannozz subroutine lmdif1(fcn,m,n,n_max_iter,x,fvec,tol,info,iwa,wa,lwa) integer m,n,info,lwa integer iwa(n) double precision tol double precision x(n),fvec(m),wa(lwa) external fcn c ********** c c subroutine lmdif1 c c the purpose of lmdif1 is to minimize the sum of the squares of c m nonlinear functions in n variables by a modification of the c levenberg-marquardt algorithm. this is done by using the more c general least-squares solver lmdif. the user must provide a c subroutine which calculates the functions. the jacobian is c then calculated by a forward-difference approximation. c c the subroutine statement is c c subroutine lmdif1(fcn,m,n,x,fvec,tol,info,iwa,wa,lwa) c c where c c fcn is the name of the user-supplied subroutine which c calculates the functions. fcn must be declared c in an external statement in the user calling c program, and should be written as follows. c c subroutine fcn(m,n,x,fvec,iflag) c integer m,n,iflag c double precision x(n),fvec(m) c ---------- c calculate the functions at x and c return this vector in fvec. c ---------- c return c end c c the value of iflag should not be changed by fcn unless c the user wants to terminate execution of lmdif1. c in this case set iflag to a negative integer. c c m is a positive integer input variable set to the number c of functions. c c n is a positive integer input variable set to the number c of variables. n must not exceed m. c c x is an array of length n. on input x must contain c an initial estimate of the solution vector. on output x c contains the final estimate of the solution vector. c c fvec is an output array of length m which contains c the functions evaluated at the output x. c c tol is a nonnegative input variable. termination occurs c when the algorithm estimates either that the relative c error in the sum of squares is at most tol or that c the relative error between x and the solution is at c most tol. c c info is an integer output variable. if the user has c terminated execution, info is set to the (negative) c value of iflag. see description of fcn. otherwise, c info is set as follows. c c info = 0 improper input parameters. c c info = 1 algorithm estimates that the relative error c in the sum of squares is at most tol. c c info = 2 algorithm estimates that the relative error c between x and the solution is at most tol. c c info = 3 conditions for info = 1 and info = 2 both hold. c c info = 4 fvec is orthogonal to the columns of the c jacobian to machine precision. c c info = 5 number of calls to fcn has reached or c exceeded 200*(n+1). c c info = 6 tol is too small. no further reduction in c the sum of squares is possible. c c info = 7 tol is too small. no further improvement in c the approximate solution x is possible. c c iwa is an integer work array of length n. c c wa is a work array of length lwa. c c lwa is a positive integer input variable not less than c m*n+5*n+m. c c subprograms called c c user-supplied ...... fcn c c minpack-supplied ... lmdif c c argonne national laboratory. minpack project. march 1980. c burton s. garbow, kenneth e. hillstrom, jorge j. more c c ********** integer maxfev,mode,mp5n,nfev,nprint,n_max_iter double precision epsfcn,factor,ftol,gtol,xtol,zero info = 0 c c check the input parameters for errors. c if (n .le. 0 .or. m .lt. n .or. tol .lt. zero * .or. lwa .lt. m*n + 5*n + m) go to 10 c c call lmdif. c factor = 1.0d3 zero = 0.0d0 maxfev = n_max_iter*(n + 1) ftol = tol xtol = tol gtol = zero epsfcn = zero epsfcn = 1.d-9 mode = 1 nprint = 0 mp5n = m + 5*n c ATTENZIONE call fcn(m,n,x,fvec,iflga) c write(*,*) 'fvec',fvec(1:10) call lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,wa(1), * mode,factor,nprint,info,nfev,wa(mp5n+1),m,iwa, * wa(n+1),wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) if (info .eq. 8) info = 4 10 continue return c c last card of subroutine lmdif1. c end GWW/minpack/qrsolv.f0000644000077300007730000001404212341332532015130 0ustar giannozzgiannozz subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa) integer n,ldr integer ipvt(n) double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa(n) c ********** c c subroutine qrsolv c c given an m by n matrix a, an n by n diagonal matrix d, c and an m-vector b, the problem is to determine an x which c solves the system c c a*x = b , d*x = 0 , c c in the least squares sense. c c this subroutine completes the solution of the problem c if it is provided with the necessary information from the c qr factorization, with column pivoting, of a. that is, if c a*p = q*r, where p is a permutation matrix, q has orthogonal c columns, and r is an upper triangular matrix with diagonal c elements of nonincreasing magnitude, then qrsolv expects c the full upper triangle of r, the permutation matrix p, c and the first n components of (q transpose)*b. the system c a*x = b, d*x = 0, is then equivalent to c c t t c r*z = q *b , p *d*p*z = 0 , c c where x = p*z. if this system does not have full rank, c then a least squares solution is obtained. on output qrsolv c also provides an upper triangular matrix s such that c c t t t c p *(a *a + d*d)*p = s *s . c c s is computed within qrsolv and may be of separate interest. c c the subroutine statement is c c subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa) c c where c c n is a positive integer input variable set to the order of r. c c r is an n by n array. on input the full upper triangle c must contain the full upper triangle of the matrix r. c on output the full upper triangle is unaltered, and the c strict lower triangle contains the strict upper triangle c (transposed) of the upper triangular matrix s. c c ldr is a positive integer input variable not less than n c which specifies the leading dimension of the array r. c c ipvt is an integer input array of length n which defines the c permutation matrix p such that a*p = q*r. column j of p c is column ipvt(j) of the identity matrix. c c diag is an input array of length n which must contain the c diagonal elements of the matrix d. c c qtb is an input array of length n which must contain the first c n elements of the vector (q transpose)*b. c c x is an output array of length n which contains the least c squares solution of the system a*x = b, d*x = 0. c c sdiag is an output array of length n which contains the c diagonal elements of the upper triangular matrix s. c c wa is a work array of length n. c c subprograms called c c fortran-supplied ... dabs,dsqrt c c argonne national laboratory. minpack project. march 1980. c burton s. garbow, kenneth e. hillstrom, jorge j. more c c ********** integer i,j,jp1,k,kp1,l,nsing double precision cos,cotan,p5,p25,qtbpj,sin,sum,tan,temp,zero data p5,p25,zero /5.0d-1,2.5d-1,0.0d0/ c c copy r and (q transpose)*b to preserve input and initialize s. c in particular, save the diagonal elements of r in x. c do 20 j = 1, n do 10 i = j, n r(i,j) = r(j,i) 10 continue x(j) = r(j,j) wa(j) = qtb(j) 20 continue c c eliminate the diagonal matrix d using a givens rotation. c do 100 j = 1, n c c prepare the row of d to be eliminated, locating the c diagonal element using p from the qr factorization. c l = ipvt(j) if (diag(l) .eq. zero) go to 90 do 30 k = j, n sdiag(k) = zero 30 continue sdiag(j) = diag(l) c c the transformations to eliminate the row of d c modify only a single element of (q transpose)*b c beyond the first n, which is initially zero. c qtbpj = zero do 80 k = j, n c c determine a givens rotation which eliminates the c appropriate element in the current row of d. c if (sdiag(k) .eq. zero) go to 70 if (dabs(r(k,k)) .ge. dabs(sdiag(k))) go to 40 cotan = r(k,k)/sdiag(k) sin = p5/dsqrt(p25+p25*cotan**2) cos = sin*cotan go to 50 40 continue tan = sdiag(k)/r(k,k) cos = p5/dsqrt(p25+p25*tan**2) sin = cos*tan 50 continue c c compute the modified diagonal element of r and c the modified element of ((q transpose)*b,0). c r(k,k) = cos*r(k,k) + sin*sdiag(k) temp = cos*wa(k) + sin*qtbpj qtbpj = -sin*wa(k) + cos*qtbpj wa(k) = temp c c accumulate the tranformation in the row of s. c kp1 = k + 1 if (n .lt. kp1) go to 70 do 60 i = kp1, n temp = cos*r(i,k) + sin*sdiag(i) sdiag(i) = -sin*r(i,k) + cos*sdiag(i) r(i,k) = temp 60 continue 70 continue 80 continue 90 continue c c store the diagonal element of s and restore c the corresponding diagonal element of r. c sdiag(j) = r(j,j) r(j,j) = x(j) 100 continue c c solve the triangular system for z. if the system is c singular, then obtain a least squares solution. c nsing = n do 110 j = 1, n if (sdiag(j) .eq. zero .and. nsing .eq. n) nsing = j - 1 if (nsing .lt. n) wa(j) = zero 110 continue if (nsing .lt. 1) go to 150 do 140 k = 1, nsing j = nsing - k + 1 sum = zero jp1 = j + 1 if (nsing .lt. jp1) go to 130 do 120 i = jp1, nsing sum = sum + r(i,j)*wa(i) 120 continue 130 continue wa(j) = (wa(j) - sum)/sdiag(j) 140 continue 150 continue c c permute the components of z back to components of x. c do 160 j = 1, n l = ipvt(j) x(l) = wa(j) 160 continue return c c last card of subroutine qrsolv. c end GWW/minpack/fdjac2.f0000644000077300007730000000647412341332532014745 0ustar giannozzgiannozz subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa) integer m,n,ldfjac,iflag double precision epsfcn double precision x(n),fvec(m),fjac(ldfjac,n),wa(m) c ********** c c subroutine fdjac2 c c this subroutine computes a forward-difference approximation c to the m by n jacobian matrix associated with a specified c problem of m functions in n variables. c c the subroutine statement is c c subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa) c c where c c fcn is the name of the user-supplied subroutine which c calculates the functions. fcn must be declared c in an external statement in the user calling c program, and should be written as follows. c c subroutine fcn(m,n,x,fvec,iflag) c integer m,n,iflag c double precision x(n),fvec(m) c ---------- c calculate the functions at x and c return this vector in fvec. c ---------- c return c end c c the value of iflag should not be changed by fcn unless c the user wants to terminate execution of fdjac2. c in this case set iflag to a negative integer. c c m is a positive integer input variable set to the number c of functions. c c n is a positive integer input variable set to the number c of variables. n must not exceed m. c c x is an input array of length n. c c fvec is an input array of length m which must contain the c functions evaluated at x. c c fjac is an output m by n array which contains the c approximation to the jacobian matrix evaluated at x. c c ldfjac is a positive integer input variable not less than m c which specifies the leading dimension of the array fjac. c c iflag is an integer variable which can be used to terminate c the execution of fdjac2. see description of fcn. c c epsfcn is an input variable used in determining a suitable c step length for the forward-difference approximation. this c approximation assumes that the relative errors in the c functions are of the order of epsfcn. if epsfcn is less c than the machine precision, it is assumed that the relative c errors in the functions are of the order of the machine c precision. c c wa is a work array of length m. c c subprograms called c c user-supplied ...... fcn c c minpack-supplied ... dpmpar c c fortran-supplied ... dabs,dmax1,dsqrt c c argonne national laboratory. minpack project. march 1980. c burton s. garbow, kenneth e. hillstrom, jorge j. more c c ********** integer i,j double precision eps,epsmch,h,temp,zero double precision dpmpar data zero /0.0d0/ c c epsmch is the machine precision. c epsmch = dpmpar(1) c eps = dsqrt(dmax1(epsfcn,epsmch)) do 20 j = 1, n temp = x(j) h = eps*dabs(temp) if (h .eq. zero) h = eps x(j) = temp + h ! write(*,*) 'ACCA', h,eps,temp, epsfcn call fcn(m,n,x,wa,iflag) if (iflag .lt. 0) go to 30 x(j) = temp do 10 i = 1, m fjac(i,j) = (wa(i) - fvec(i))/h 10 continue 20 continue 30 continue return c c last card of subroutine fdjac2. c end GWW/minpack/Makefile0000644000077300007730000000054412341332532015075 0ustar giannozzgiannozz# Makefile for Minpack include ../../make.sys MINOBJS = \ dpmpar.o \ fdjac2.o \ lmder1.o \ lmdif1.o \ mlagzo.o \ qrfac.o \ test.o \ enorm.o \ lmder.o \ lmdif.o \ lmpar.o \ mlegzo.o \ qrsolv.o all : minpacklib.a minpacklib.a : $(MINOBJS) $(AR) $(ARFLAGS) $@ $(MINOBJS) clean : - /bin/rm -fv minpacklib.a *.o include make.depend # DO NOT DELETE GWW/minpack/qrfac.f0000644000077300007730000001245112341332532014700 0ustar giannozzgiannozz subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) integer m,n,lda,lipvt integer ipvt(lipvt) logical pivot double precision a(lda,n),rdiag(n),acnorm(n),wa(n) c ********** c c subroutine qrfac c c this subroutine uses householder transformations with column c pivoting (optional) to compute a qr factorization of the c m by n matrix a. that is, qrfac determines an orthogonal c matrix q, a permutation matrix p, and an upper trapezoidal c matrix r with diagonal elements of nonincreasing magnitude, c such that a*p = q*r. the householder transformation for c column k, k = 1,2,...,min(m,n), is of the form c c t c i - (1/u(k))*u*u c c where u has zeros in the first k-1 positions. the form of c this transformation and the method of pivoting first c appeared in the corresponding linpack subroutine. c c the subroutine statement is c c subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) c c where c c m is a positive integer input variable set to the number c of rows of a. c c n is a positive integer input variable set to the number c of columns of a. c c a is an m by n array. on input a contains the matrix for c which the qr factorization is to be computed. on output c the strict upper trapezoidal part of a contains the strict c upper trapezoidal part of r, and the lower trapezoidal c part of a contains a factored form of q (the non-trivial c elements of the u vectors described above). c c lda is a positive integer input variable not less than m c which specifies the leading dimension of the array a. c c pivot is a logical input variable. if pivot is set true, c then column pivoting is enforced. if pivot is set false, c then no column pivoting is done. c c ipvt is an integer output array of length lipvt. ipvt c defines the permutation matrix p such that a*p = q*r. c column j of p is column ipvt(j) of the identity matrix. c if pivot is false, ipvt is not referenced. c c lipvt is a positive integer input variable. if pivot is false, c then lipvt may be as small as 1. if pivot is true, then c lipvt must be at least n. c c rdiag is an output array of length n which contains the c diagonal elements of r. c c acnorm is an output array of length n which contains the c norms of the corresponding columns of the input matrix a. c if this information is not needed, then acnorm can coincide c with rdiag. c c wa is a work array of length n. if pivot is false, then wa c can coincide with rdiag. c c subprograms called c c minpack-supplied ... dpmpar,enorm c c fortran-supplied ... dmax1,dsqrt,min0 c c argonne national laboratory. minpack project. march 1980. c burton s. garbow, kenneth e. hillstrom, jorge j. more c c ********** integer i,j,jp1,k,kmax,minmn double precision ajnorm,epsmch,one,p05,sum,temp,zero double precision dpmpar,enorm data one,p05,zero /1.0d0,5.0d-2,0.0d0/ c c epsmch is the machine precision. c epsmch = dpmpar(1) c c compute the initial column norms and initialize several arrays. c do 10 j = 1, n acnorm(j) = enorm(m,a(1,j)) rdiag(j) = acnorm(j) wa(j) = rdiag(j) if (pivot) ipvt(j) = j 10 continue c c reduce a to r with householder transformations. c minmn = min0(m,n) do 110 j = 1, minmn if (.not.pivot) go to 40 c c bring the column of largest norm into the pivot position. c kmax = j do 20 k = j, n if (rdiag(k) .gt. rdiag(kmax)) kmax = k 20 continue if (kmax .eq. j) go to 40 do 30 i = 1, m temp = a(i,j) a(i,j) = a(i,kmax) a(i,kmax) = temp 30 continue rdiag(kmax) = rdiag(j) wa(kmax) = wa(j) k = ipvt(j) ipvt(j) = ipvt(kmax) ipvt(kmax) = k 40 continue c c compute the householder transformation to reduce the c j-th column of a to a multiple of the j-th unit vector. c ajnorm = enorm(m-j+1,a(j,j)) if (ajnorm .eq. zero) go to 100 if (a(j,j) .lt. zero) ajnorm = -ajnorm do 50 i = j, m a(i,j) = a(i,j)/ajnorm 50 continue a(j,j) = a(j,j) + one c c apply the transformation to the remaining columns c and update the norms. c jp1 = j + 1 if (n .lt. jp1) go to 100 do 90 k = jp1, n sum = zero do 60 i = j, m sum = sum + a(i,j)*a(i,k) 60 continue temp = sum/a(j,j) do 70 i = j, m a(i,k) = a(i,k) - temp*a(i,j) 70 continue if (.not.pivot .or. rdiag(k) .eq. zero) go to 80 temp = a(j,k)/rdiag(k) rdiag(k) = rdiag(k)*dsqrt(dmax1(zero,one-temp**2)) if (p05*(rdiag(k)/wa(k))**2 .gt. epsmch) go to 80 rdiag(k) = enorm(m-j,a(jp1,k)) wa(k) = rdiag(k) 80 continue 90 continue 100 continue rdiag(j) = -ajnorm 110 continue return c c last card of subroutine qrfac. c end GWW/minpack/enorm.f0000644000077300007730000000607712341332532014733 0ustar giannozzgiannozz double precision function enorm(n,x) integer n double precision x(n) c ********** c c function enorm c c given an n-vector x, this function calculates the c euclidean norm of x. c c the euclidean norm is computed by accumulating the sum of c squares in three different sums. the sums of squares for the c small and large components are scaled so that no overflows c occur. non-destructive underflows are permitted. underflows c and overflows do not occur in the computation of the unscaled c sum of squares for the intermediate components. c the definitions of small, intermediate and large components c depend on two constants, rdwarf and rgiant. the main c restrictions on these constants are that rdwarf**2 not c underflow and rgiant**2 not overflow. the constants c given here are suitable for every known computer. c c the function statement is c c double precision function enorm(n,x) c c where c c n is a positive integer input variable. c c x is an input array of length n. c c subprograms called c c fortran-supplied ... dabs,dsqrt c c argonne national laboratory. minpack project. march 1980. c burton s. garbow, kenneth e. hillstrom, jorge j. more c c ********** integer i double precision agiant,floatn,one,rdwarf,rgiant,s1,s2,s3,xabs, * x1max,x3max,zero data one,zero,rdwarf,rgiant /1.0d0,0.0d0,3.834d-20,1.304d19/ s1 = zero s2 = zero s3 = zero x1max = zero x3max = zero floatn = n agiant = rgiant/floatn do 90 i = 1, n xabs = dabs(x(i)) if (xabs .gt. rdwarf .and. xabs .lt. agiant) go to 70 if (xabs .le. rdwarf) go to 30 c c sum for large components. c if (xabs .le. x1max) go to 10 s1 = one + s1*(x1max/xabs)**2 x1max = xabs go to 20 10 continue s1 = s1 + (xabs/x1max)**2 20 continue go to 60 30 continue c c sum for small components. c if (xabs .le. x3max) go to 40 s3 = one + s3*(x3max/xabs)**2 x3max = xabs go to 50 40 continue if (xabs .ne. zero) s3 = s3 + (xabs/x3max)**2 50 continue 60 continue go to 80 70 continue c c sum for intermediate components. c s2 = s2 + xabs**2 80 continue 90 continue c c calculation of norm. c if (s1 .eq. zero) go to 100 enorm = x1max*dsqrt(s1+(s2/x1max)/x1max) go to 130 100 continue if (s2 .eq. zero) go to 110 if (s2 .ge. x3max) * enorm = dsqrt(s2*(one+(x3max/s2)*(x3max*s3))) if (s2 .lt. x3max) * enorm = dsqrt(x3max*((s2/x3max)+(x3max*s3))) go to 120 110 continue enorm = x3max*dsqrt(s3) 120 continue 130 continue return c c last card of function enorm. c end GWW/minpack/mlagzo.f0000644000077300007730000000277012341332532015100 0ustar giannozzgiannozz SUBROUTINE LAGZO(N,X,W) C C ========================================================= C Purpose : Compute the zeros of Laguerre polynomial Ln(x) C in the interval [0,�], and the corresponding C weighting coefficients for Gauss-Laguerre C integration C Input : n --- Order of the Laguerre polynomial C X(n) --- Zeros of the Laguerre polynomial C W(n) --- Corresponding weighting coefficients C ========================================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION X(N),W(N) HN=1.0D0/N DO 35 NR=1,N IF (NR.EQ.1) Z=HN IF (NR.GT.1) Z=X(NR-1)+HN*NR**1.27 IT=0 10 IT=IT+1 Z0=Z P=1.0D0 DO 15 I=1,NR-1 15 P=P*(Z-X(I)) F0=1.0D0 F1=1.0D0-Z DO 20 K=2,N PF=((2.0D0*K-1.0D0-Z)*F1-(K-1.0D0)*F0)/K PD=K/Z*(PF-F1) F0=F1 20 F1=PF FD=PF/P Q=0.0D0 DO 30 I=1,NR-1 WP=1.0D0 DO 25 J=1,NR-1 IF (J.EQ.I) GO TO 25 WP=WP*(Z-X(J)) 25 CONTINUE Q=Q+WP 30 CONTINUE GD=(PD-Q*FD)/P Z=Z-FD/GD IF (IT.LE.40.AND.DABS((Z-Z0)/Z).GT.1.0D-15) GO TO 10 X(NR)=Z W(NR)=1.0D0/(Z*PD*PD) 35 CONTINUE RETURN END GWW/minpack/lmder1.f0000644000077300007730000001311112341332532014762 0ustar giannozzgiannozz subroutine lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,ipvt,wa, * lwa, n_max_iter) integer m,n,ldfjac,info,lwa, n_max_iter integer ipvt(n) double precision tol double precision x(n),fvec(m),fjac(ldfjac,n),wa(lwa) external fcn c ********** c c subroutine lmder1 c c the purpose of lmder1 is to minimize the sum of the squares of c m nonlinear functions in n variables by a modification of the c levenberg-marquardt algorithm. this is done by using the more c general least-squares solver lmder. the user must provide a c subroutine which calculates the functions and the jacobian. c c the subroutine statement is c c subroutine lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info, c ipvt,wa,lwa) c c where c c fcn is the name of the user-supplied subroutine which c calculates the functions and the jacobian. fcn must c be declared in an external statement in the user c calling program, and should be written as follows. c c subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) c integer m,n,ldfjac,iflag c double precision x(n),fvec(m),fjac(ldfjac,n) c ---------- c if iflag = 1 calculate the functions at x and c return this vector in fvec. do not alter fjac. c if iflag = 2 calculate the jacobian at x and c return this matrix in fjac. do not alter fvec. c ---------- c return c end c c the value of iflag should not be changed by fcn unless c the user wants to terminate execution of lmder1. c in this case set iflag to a negative integer. c c m is a positive integer input variable set to the number c of functions. c c n is a positive integer input variable set to the number c of variables. n must not exceed m. c c x is an array of length n. on input x must contain c an initial estimate of the solution vector. on output x c contains the final estimate of the solution vector. c c fvec is an output array of length m which contains c the functions evaluated at the output x. c c fjac is an output m by n array. the upper n by n submatrix c of fjac contains an upper triangular matrix r with c diagonal elements of nonincreasing magnitude such that c c t t t c p *(jac *jac)*p = r *r, c c where p is a permutation matrix and jac is the final c calculated jacobian. column j of p is column ipvt(j) c (see below) of the identity matrix. the lower trapezoidal c part of fjac contains information generated during c the computation of r. c c ldfjac is a positive integer input variable not less than m c which specifies the leading dimension of the array fjac. c c tol is a nonnegative input variable. termination occurs c when the algorithm estimates either that the relative c error in the sum of squares is at most tol or that c the relative error between x and the solution is at c most tol. c c info is an integer output variable. if the user has c terminated execution, info is set to the (negative) c value of iflag. see description of fcn. otherwise, c info is set as follows. c c info = 0 improper input parameters. c c info = 1 algorithm estimates that the relative error c in the sum of squares is at most tol. c c info = 2 algorithm estimates that the relative error c between x and the solution is at most tol. c c info = 3 conditions for info = 1 and info = 2 both hold. c c info = 4 fvec is orthogonal to the columns of the c jacobian to machine precision. c c info = 5 number of calls to fcn with iflag = 1 has c reached 100*(n+1). c c info = 6 tol is too small. no further reduction in c the sum of squares is possible. c c info = 7 tol is too small. no further improvement in c the approximate solution x is possible. c c ipvt is an integer output array of length n. ipvt c defines a permutation matrix p such that jac*p = q*r, c where jac is the final calculated jacobian, q is c orthogonal (not stored), and r is upper triangular c with diagonal elements of nonincreasing magnitude. c column j of p is column ipvt(j) of the identity matrix. c c wa is a work array of length lwa. c c lwa is a positive integer input variable not less than 5*n+m. c c subprograms called c c user-supplied ...... fcn c c minpack-supplied ... lmder c c argonne national laboratory. minpack project. march 1980. c burton s. garbow, kenneth e. hillstrom, jorge j. more c c ********** integer maxfev,mode,nfev,njev,nprint double precision factor,ftol,gtol,xtol,zero data factor,zero /1.0d2,0.0d0/ info = 0 c c check the input parameters for errors. c if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m .or. tol .lt. zero * .or. lwa .lt. 5*n + m) go to 10 c c call lmder. c maxfev = n_max_iter*(n + 1) ftol = tol xtol = tol gtol = zero mode = 1 nprint = 0 call lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol,maxfev, * wa(1),mode,factor,nprint,info,nfev,njev,ipvt,wa(n+1), * wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) if (info .eq. 8) info = 4 10 continue return c c last card of subroutine lmder1. c end GWW/minpack/lmder.f0000644000077300007730000003612312341332532014711 0ustar giannozzgiannozz subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, * maxfev,diag,mode,factor,nprint,info,nfev,njev, * ipvt,qtf,wa1,wa2,wa3,wa4) integer m,n,ldfjac,maxfev,mode,nprint,info,nfev,njev integer ipvt(n) double precision ftol,xtol,gtol,factor double precision x(n),fvec(m),fjac(ldfjac,n),diag(n),qtf(n), * wa1(n),wa2(n),wa3(n),wa4(m) c ********** c c subroutine lmder c c the purpose of lmder is to minimize the sum of the squares of c m nonlinear functions in n variables by a modification of c the levenberg-marquardt algorithm. the user must provide a c subroutine which calculates the functions and the jacobian. c c the subroutine statement is c c subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, c maxfev,diag,mode,factor,nprint,info,nfev, c njev,ipvt,qtf,wa1,wa2,wa3,wa4) c c where c c fcn is the name of the user-supplied subroutine which c calculates the functions and the jacobian. fcn must c be declared in an external statement in the user c calling program, and should be written as follows. c c subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) c integer m,n,ldfjac,iflag c double precision x(n),fvec(m),fjac(ldfjac,n) c ---------- c if iflag = 1 calculate the functions at x and c return this vector in fvec. do not alter fjac. c if iflag = 2 calculate the jacobian at x and c return this matrix in fjac. do not alter fvec. c ---------- c return c end c c the value of iflag should not be changed by fcn unless c the user wants to terminate execution of lmder. c in this case set iflag to a negative integer. c c m is a positive integer input variable set to the number c of functions. c c n is a positive integer input variable set to the number c of variables. n must not exceed m. c c x is an array of length n. on input x must contain c an initial estimate of the solution vector. on output x c contains the final estimate of the solution vector. c c fvec is an output array of length m which contains c the functions evaluated at the output x. c c fjac is an output m by n array. the upper n by n submatrix c of fjac contains an upper triangular matrix r with c diagonal elements of nonincreasing magnitude such that c c t t t c p *(jac *jac)*p = r *r, c c where p is a permutation matrix and jac is the final c calculated jacobian. column j of p is column ipvt(j) c (see below) of the identity matrix. the lower trapezoidal c part of fjac contains information generated during c the computation of r. c c ldfjac is a positive integer input variable not less than m c which specifies the leading dimension of the array fjac. c c ftol is a nonnegative input variable. termination c occurs when both the actual and predicted relative c reductions in the sum of squares are at most ftol. c therefore, ftol measures the relative error desired c in the sum of squares. c c xtol is a nonnegative input variable. termination c occurs when the relative error between two consecutive c iterates is at most xtol. therefore, xtol measures the c relative error desired in the approximate solution. c c gtol is a nonnegative input variable. termination c occurs when the cosine of the angle between fvec and c any column of the jacobian is at most gtol in absolute c value. therefore, gtol measures the orthogonality c desired between the function vector and the columns c of the jacobian. c c maxfev is a positive integer input variable. termination c occurs when the number of calls to fcn with iflag = 1 c has reached maxfev. c c diag is an array of length n. if mode = 1 (see c below), diag is internally set. if mode = 2, diag c must contain positive entries that serve as c multiplicative scale factors for the variables. c c mode is an integer input variable. if mode = 1, the c variables will be scaled internally. if mode = 2, c the scaling is specified by the input diag. other c values of mode are equivalent to mode = 1. c c factor is a positive input variable used in determining the c initial step bound. this bound is set to the product of c factor and the euclidean norm of diag*x if nonzero, or else c to factor itself. in most cases factor should lie in the c interval (.1,100.).100. is a generally recommended value. c c nprint is an integer input variable that enables controlled c printing of iterates if it is positive. in this case, c fcn is called with iflag = 0 at the beginning of the first c iteration and every nprint iterations thereafter and c immediately prior to return, with x, fvec, and fjac c available for printing. fvec and fjac should not be c altered. if nprint is not positive, no special calls c of fcn with iflag = 0 are made. c c info is an integer output variable. if the user has c terminated execution, info is set to the (negative) c value of iflag. see description of fcn. otherwise, c info is set as follows. c c info = 0 improper input parameters. c c info = 1 both actual and predicted relative reductions c in the sum of squares are at most ftol. c c info = 2 relative error between two consecutive iterates c is at most xtol. c c info = 3 conditions for info = 1 and info = 2 both hold. c c info = 4 the cosine of the angle between fvec and any c column of the jacobian is at most gtol in c absolute value. c c info = 5 number of calls to fcn with iflag = 1 has c reached maxfev. c c info = 6 ftol is too small. no further reduction in c the sum of squares is possible. c c info = 7 xtol is too small. no further improvement in c the approximate solution x is possible. c c info = 8 gtol is too small. fvec is orthogonal to the c columns of the jacobian to machine precision. c c nfev is an integer output variable set to the number of c calls to fcn with iflag = 1. c c njev is an integer output variable set to the number of c calls to fcn with iflag = 2. c c ipvt is an integer output array of length n. ipvt c defines a permutation matrix p such that jac*p = q*r, c where jac is the final calculated jacobian, q is c orthogonal (not stored), and r is upper triangular c with diagonal elements of nonincreasing magnitude. c column j of p is column ipvt(j) of the identity matrix. c c qtf is an output array of length n which contains c the first n elements of the vector (q transpose)*fvec. c c wa1, wa2, and wa3 are work arrays of length n. c c wa4 is a work array of length m. c c subprograms called c c user-supplied ...... fcn c c minpack-supplied ... dpmpar,enorm,lmpar,qrfac c c fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod c c argonne national laboratory. minpack project. march 1980. c burton s. garbow, kenneth e. hillstrom, jorge j. more c c ********** integer i,iflag,iter,j,l double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm, * one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio, * sum,temp,temp1,temp2,xnorm,zero double precision dpmpar,enorm data one,p1,p5,p25,p75,p0001,zero * /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/ c c epsmch is the machine precision. c epsmch = dpmpar(1) c info = 0 iflag = 0 nfev = 0 njev = 0 c c check the input parameters for errors. c if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m * .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero * .or. maxfev .le. 0 .or. factor .le. zero) go to 300 if (mode .ne. 2) go to 20 do 10 j = 1, n if (diag(j) .le. zero) go to 300 10 continue 20 continue c c evaluate the function at the starting point c and calculate its norm. c iflag = 1 call fcn(m,n,x,fvec,fjac,ldfjac,iflag) nfev = 1 if (iflag .lt. 0) go to 300 fnorm = enorm(m,fvec) c c initialize levenberg-marquardt parameter and iteration counter. c par = zero iter = 1 c c beginning of the outer loop. c 30 continue c c calculate the jacobian matrix. c iflag = 2 call fcn(m,n,x,fvec,fjac,ldfjac,iflag) njev = njev + 1 if (iflag .lt. 0) go to 300 c c if requested, call fcn to enable printing of iterates. c if (nprint .le. 0) go to 40 iflag = 0 if (mod(iter-1,nprint) .eq. 0) * call fcn(m,n,x,fvec,fjac,ldfjac,iflag) if (iflag .lt. 0) go to 300 40 continue c c compute the qr factorization of the jacobian. c call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3) c c on the first iteration and if mode is 1, scale according c to the norms of the columns of the initial jacobian. c if (iter .ne. 1) go to 80 if (mode .eq. 2) go to 60 do 50 j = 1, n diag(j) = wa2(j) if (wa2(j) .eq. zero) diag(j) = one 50 continue 60 continue c c on the first iteration, calculate the norm of the scaled x c and initialize the step bound delta. c do 70 j = 1, n wa3(j) = diag(j)*x(j) 70 continue xnorm = enorm(n,wa3) delta = factor*xnorm if (delta .eq. zero) delta = factor 80 continue c c form (q transpose)*fvec and store the first n components in c qtf. c do 90 i = 1, m wa4(i) = fvec(i) 90 continue do 130 j = 1, n if (fjac(j,j) .eq. zero) go to 120 sum = zero do 100 i = j, m sum = sum + fjac(i,j)*wa4(i) 100 continue temp = -sum/fjac(j,j) do 110 i = j, m wa4(i) = wa4(i) + fjac(i,j)*temp 110 continue 120 continue fjac(j,j) = wa1(j) qtf(j) = wa4(j) 130 continue c c compute the norm of the scaled gradient. c gnorm = zero if (fnorm .eq. zero) go to 170 do 160 j = 1, n l = ipvt(j) if (wa2(l) .eq. zero) go to 150 sum = zero do 140 i = 1, j sum = sum + fjac(i,j)*(qtf(i)/fnorm) 140 continue gnorm = dmax1(gnorm,dabs(sum/wa2(l))) 150 continue 160 continue 170 continue c c test for convergence of the gradient norm. c if (gnorm .le. gtol) info = 4 if (info .ne. 0) go to 300 c c rescale if necessary. c if (mode .eq. 2) go to 190 do 180 j = 1, n diag(j) = dmax1(diag(j),wa2(j)) 180 continue 190 continue c c beginning of the inner loop. c 200 continue c c determine the levenberg-marquardt parameter. c call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2, * wa3,wa4) c c store the direction p and x + p. calculate the norm of p. c do 210 j = 1, n wa1(j) = -wa1(j) wa2(j) = x(j) + wa1(j) wa3(j) = diag(j)*wa1(j) 210 continue pnorm = enorm(n,wa3) c c on the first iteration, adjust the initial step bound. c if (iter .eq. 1) delta = dmin1(delta,pnorm) c c evaluate the function at x + p and calculate its norm. c iflag = 1 call fcn(m,n,wa2,wa4,fjac,ldfjac,iflag) nfev = nfev + 1 if (iflag .lt. 0) go to 300 fnorm1 = enorm(m,wa4) c c compute the scaled actual reduction. c actred = -one if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 c c compute the scaled predicted reduction and c the scaled directional derivative. c do 230 j = 1, n wa3(j) = zero l = ipvt(j) temp = wa1(l) do 220 i = 1, j wa3(i) = wa3(i) + fjac(i,j)*temp 220 continue 230 continue temp1 = enorm(n,wa3)/fnorm temp2 = (dsqrt(par)*pnorm)/fnorm prered = temp1**2 + temp2**2/p5 dirder = -(temp1**2 + temp2**2) c c compute the ratio of the actual to the predicted c reduction. c ratio = zero if (prered .ne. zero) ratio = actred/prered c c update the step bound. c if (ratio .gt. p25) go to 240 if (actred .ge. zero) temp = p5 if (actred .lt. zero) * temp = p5*dirder/(dirder + p5*actred) if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1 delta = temp*dmin1(delta,pnorm/p1) par = par/temp go to 260 240 continue if (par .ne. zero .and. ratio .lt. p75) go to 250 delta = pnorm/p5 par = p5*par 250 continue 260 continue c c test for successful iteration. c if (ratio .lt. p0001) go to 290 c c successful iteration. update x, fvec, and their norms. c do 270 j = 1, n x(j) = wa2(j) wa2(j) = diag(j)*x(j) 270 continue do 280 i = 1, m fvec(i) = wa4(i) 280 continue xnorm = enorm(n,wa2) fnorm = fnorm1 iter = iter + 1 290 continue c c tests for convergence. c if (dabs(actred) .le. ftol .and. prered .le. ftol * .and. p5*ratio .le. one) info = 1 if (delta .le. xtol*xnorm) info = 2 if (dabs(actred) .le. ftol .and. prered .le. ftol * .and. p5*ratio .le. one .and. info .eq. 2) info = 3 if (info .ne. 0) go to 300 c c tests for termination and stringent tolerances. c if (nfev .ge. maxfev) info = 5 if (dabs(actred) .le. epsmch .and. prered .le. epsmch * .and. p5*ratio .le. one) info = 6 if (delta .le. epsmch*xnorm) info = 7 if (gnorm .le. epsmch) info = 8 if (info .ne. 0) go to 300 c c end of the inner loop. repeat if iteration unsuccessful. c if (ratio .lt. p0001) go to 200 c c end of the outer loop. c go to 30 300 continue c c termination, either normal or user imposed. c if (iflag .lt. 0) info = iflag iflag = 0 if (nprint .gt. 0) call fcn(m,n,x,fvec,fjac,ldfjac,iflag) return c c last card of subroutine lmder. c end GWW/minpack/lmpar.f0000644000077300007730000002006312341332532014715 0ustar giannozzgiannozz subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,wa1, * wa2) integer n,ldr integer ipvt(n) double precision delta,par double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa1(n), * wa2(n) c ********** c c subroutine lmpar c c given an m by n matrix a, an n by n nonsingular diagonal c matrix d, an m-vector b, and a positive number delta, c the problem is to determine a value for the parameter c par such that if x solves the system c c a*x = b , sqrt(par)*d*x = 0 , c c in the least squares sense, and dxnorm is the euclidean c norm of d*x, then either par is zero and c c (dxnorm-delta) .le. 0.1*delta , c c or par is positive and c c abs(dxnorm-delta) .le. 0.1*delta . c c this subroutine completes the solution of the problem c if it is provided with the necessary information from the c qr factorization, with column pivoting, of a. that is, if c a*p = q*r, where p is a permutation matrix, q has orthogonal c columns, and r is an upper triangular matrix with diagonal c elements of nonincreasing magnitude, then lmpar expects c the full upper triangle of r, the permutation matrix p, c and the first n components of (q transpose)*b. on output c lmpar also provides an upper triangular matrix s such that c c t t t c p *(a *a + par*d*d)*p = s *s . c c s is employed within lmpar and may be of separate interest. c c only a few iterations are generally needed for convergence c of the algorithm. if, however, the limit of 10 iterations c is reached, then the output par will contain the best c value obtained so far. c c the subroutine statement is c c subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag, c wa1,wa2) c c where c c n is a positive integer input variable set to the order of r. c c r is an n by n array. on input the full upper triangle c must contain the full upper triangle of the matrix r. c on output the full upper triangle is unaltered, and the c strict lower triangle contains the strict upper triangle c (transposed) of the upper triangular matrix s. c c ldr is a positive integer input variable not less than n c which specifies the leading dimension of the array r. c c ipvt is an integer input array of length n which defines the c permutation matrix p such that a*p = q*r. column j of p c is column ipvt(j) of the identity matrix. c c diag is an input array of length n which must contain the c diagonal elements of the matrix d. c c qtb is an input array of length n which must contain the first c n elements of the vector (q transpose)*b. c c delta is a positive input variable which specifies an upper c bound on the euclidean norm of d*x. c c par is a nonnegative variable. on input par contains an c initial estimate of the levenberg-marquardt parameter. c on output par contains the final estimate. c c x is an output array of length n which contains the least c squares solution of the system a*x = b, sqrt(par)*d*x = 0, c for the output par. c c sdiag is an output array of length n which contains the c diagonal elements of the upper triangular matrix s. c c wa1 and wa2 are work arrays of length n. c c subprograms called c c minpack-supplied ... dpmpar,enorm,qrsolv c c fortran-supplied ... dabs,dmax1,dmin1,dsqrt c c argonne national laboratory. minpack project. march 1980. c burton s. garbow, kenneth e. hillstrom, jorge j. more c c ********** integer i,iter,j,jm1,jp1,k,l,nsing double precision dxnorm,dwarf,fp,gnorm,parc,parl,paru,p1,p001, * sum,temp,zero double precision dpmpar,enorm data p1,p001,zero /1.0d-1,1.0d-3,0.0d0/ c c dwarf is the smallest positive magnitude. c dwarf = dpmpar(2) c c compute and store in x the gauss-newton direction. if the c jacobian is rank-deficient, obtain a least squares solution. c nsing = n do 10 j = 1, n wa1(j) = qtb(j) if (r(j,j) .eq. zero .and. nsing .eq. n) nsing = j - 1 if (nsing .lt. n) wa1(j) = zero 10 continue if (nsing .lt. 1) go to 50 do 40 k = 1, nsing j = nsing - k + 1 wa1(j) = wa1(j)/r(j,j) temp = wa1(j) jm1 = j - 1 if (jm1 .lt. 1) go to 30 do 20 i = 1, jm1 wa1(i) = wa1(i) - r(i,j)*temp 20 continue 30 continue 40 continue 50 continue do 60 j = 1, n l = ipvt(j) x(l) = wa1(j) 60 continue c c initialize the iteration counter. c evaluate the function at the origin, and test c for acceptance of the gauss-newton direction. c iter = 0 do 70 j = 1, n wa2(j) = diag(j)*x(j) 70 continue dxnorm = enorm(n,wa2) fp = dxnorm - delta if (fp .le. p1*delta) go to 220 c c if the jacobian is not rank deficient, the newton c step provides a lower bound, parl, for the zero of c the function. otherwise set this bound to zero. c parl = zero if (nsing .lt. n) go to 120 do 80 j = 1, n l = ipvt(j) wa1(j) = diag(l)*(wa2(l)/dxnorm) 80 continue do 110 j = 1, n sum = zero jm1 = j - 1 if (jm1 .lt. 1) go to 100 do 90 i = 1, jm1 sum = sum + r(i,j)*wa1(i) 90 continue 100 continue wa1(j) = (wa1(j) - sum)/r(j,j) 110 continue temp = enorm(n,wa1) parl = ((fp/delta)/temp)/temp 120 continue c c calculate an upper bound, paru, for the zero of the function. c do 140 j = 1, n sum = zero do 130 i = 1, j sum = sum + r(i,j)*qtb(i) 130 continue l = ipvt(j) wa1(j) = sum/diag(l) 140 continue gnorm = enorm(n,wa1) paru = gnorm/delta if (paru .eq. zero) paru = dwarf/dmin1(delta,p1) c c if the input par lies outside of the interval (parl,paru), c set par to the closer endpoint. c par = dmax1(par,parl) par = dmin1(par,paru) if (par .eq. zero) par = gnorm/dxnorm c c beginning of an iteration. c 150 continue iter = iter + 1 c c evaluate the function at the current value of par. c if (par .eq. zero) par = dmax1(dwarf,p001*paru) temp = dsqrt(par) do 160 j = 1, n wa1(j) = temp*diag(j) 160 continue call qrsolv(n,r,ldr,ipvt,wa1,qtb,x,sdiag,wa2) do 170 j = 1, n wa2(j) = diag(j)*x(j) 170 continue dxnorm = enorm(n,wa2) temp = fp fp = dxnorm - delta c c if the function is small enough, accept the current value c of par. also test for the exceptional cases where parl c is zero or the number of iterations has reached 10. c if (dabs(fp) .le. p1*delta * .or. parl .eq. zero .and. fp .le. temp * .and. temp .lt. zero .or. iter .eq. 10) go to 220 c c compute the newton correction. c do 180 j = 1, n l = ipvt(j) wa1(j) = diag(l)*(wa2(l)/dxnorm) 180 continue do 210 j = 1, n wa1(j) = wa1(j)/sdiag(j) temp = wa1(j) jp1 = j + 1 if (n .lt. jp1) go to 200 do 190 i = jp1, n wa1(i) = wa1(i) - r(i,j)*temp 190 continue 200 continue 210 continue temp = enorm(n,wa1) parc = ((fp/delta)/temp)/temp c c depending on the sign of the function, update parl or paru. c if (fp .gt. zero) parl = dmax1(parl,par) if (fp .lt. zero) paru = dmin1(paru,par) c c compute an improved estimate for par. c par = dmax1(parl,par+parc) c c end of an iteration. c go to 150 220 continue c c termination. c if (iter .eq. 0) par = zero return c c last card of subroutine lmpar. c end GWW/minpack/test.f0000644000077300007730000004517212341332532014571 0ustar giannozzgiannozzC ********** C C THIS PROGRAM TESTS CODES FOR THE LEAST-SQUARES SOLUTION OF C M NONLINEAR EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER C AND AN INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, C CALLS THE NONLINEAR LEAST-SQUARES SOLVER, AND FINALLY PRINTS C OUT INFORMATION ON THE PERFORMANCE OF THE SOLVER. THIS IS C ONLY A SAMPLE DRIVER, MANY OTHER DRIVERS ARE POSSIBLE. THE C INTERFACE SUBROUTINE FCN IS NECESSARY TO TAKE INTO ACCOUNT THE C FORMS OF CALLING SEQUENCES USED BY THE FUNCTION AND JACOBIAN C SUBROUTINES IN THE VARIOUS NONLINEAR LEAST-SQUARES SOLVERS. C C SUBPROGRAMS CALLED C C USER-SUPPLIED ...... FCN C C MINPACK-SUPPLIED ... DPMPAR,ENORM,INITPT,LMDIF1,SSQFCN C C FORTRAN-SUPPLIED ... DSQRT C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER I,IC,INFO,K,LWA,M,N,NFEV,NJEV,NPROB,NREAD,NTRIES,NWRITE INTEGER IWA(40),MA(60),NA(60),NF(60),NJ(60),NP(60),NX(60) DOUBLE PRECISION FACTOR,FNORM1,FNORM2,ONE,TEN,TOL DOUBLE PRECISION FNM(60),FVEC(65),WA(2865),X(40) DOUBLE PRECISION DPMPAR,ENORM EXTERNAL FCN COMMON /REFNUM/ NPROB,NFEV,NJEV C C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. C DATA NREAD,NWRITE /5,6/ C DATA ONE,TEN /1.0D0,1.0D1/ TOL = DSQRT(DPMPAR(1)) LWA = 2865 IC = 0 10 CONTINUE READ (NREAD,50) NPROB,N,M,NTRIES IF (NPROB .LE. 0) GO TO 30 FACTOR = ONE DO 20 K = 1, NTRIES IC = IC + 1 CALL INITPT(N,X,NPROB,FACTOR) CALL SSQFCN(M,N,X,FVEC,NPROB) FNORM1 = ENORM(M,FVEC) WRITE (NWRITE,60) NPROB,N,M NFEV = 0 NJEV = 0 CALL LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) CALL SSQFCN(M,N,X,FVEC,NPROB) FNORM2 = ENORM(M,FVEC) NP(IC) = NPROB NA(IC) = N MA(IC) = M NF(IC) = NFEV NJEV = NJEV/N NJ(IC) = NJEV NX(IC) = INFO FNM(IC) = FNORM2 WRITE (NWRITE,70) * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N) FACTOR = TEN*FACTOR 20 CONTINUE GO TO 10 30 CONTINUE WRITE (NWRITE,80) IC WRITE (NWRITE,90) DO 40 I = 1, IC WRITE (NWRITE,100) NP(I),NA(I),MA(I),NF(I),NJ(I),NX(I),FNM(I) 40 CONTINUE STOP 50 FORMAT (4I5) 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 11H DIMENSIONS, 2I5, 5X // * ) 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, D15.7 // 5X, * 33H FINAL L2 NORM OF THE RESIDUALS , D15.7 // 5X, * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X, * 15H EXIT PARAMETER, 18X, I10 // 5X, * 27H FINAL APPROXIMATE SOLUTION // (5X, 5D15.7)) 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO LMDIF1 /) 90 FORMAT (49H NPROB N M NFEV NJEV INFO FINAL L2 NORM /) 100 FORMAT (3I5, 3I6, 1X, D15.7) C C LAST CARD OF DRIVER. C END SUBROUTINE FCN(M,N,X,FVEC,IFLAG) INTEGER M,N,IFLAG DOUBLE PRECISION X(N),FVEC(M) C ********** C C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR C LEAST-SQUARES SOLVER. FCN SHOULD ONLY CALL THE TESTING C FUNCTION SUBROUTINE SSQFCN WITH THE APPROPRIATE VALUE OF C PROBLEM NUMBER (NPROB). C C SUBPROGRAMS CALLED C C MINPACK-SUPPLIED ... SSQFCN C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER NPROB,NFEV,NJEV COMMON /REFNUM/ NPROB,NFEV,NJEV CALL SSQFCN(M,N,X,FVEC,NPROB) IF (IFLAG .EQ. 1) NFEV = NFEV + 1 IF (IFLAG .EQ. 2) NJEV = NJEV + 1 RETURN C C LAST CARD OF INTERFACE SUBROUTINE FCN. C END SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) INTEGER M,N,NPROB DOUBLE PRECISION X(N),FVEC(M) C ********** C C SUBROUTINE SSQFCN C C THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR C LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR C FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N. C FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE C (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY. C FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9. C HOWEVER, ANY N, N = 2,...,31, IS PERMITTED. C FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT C ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20. C FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N. C FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N. C FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE C (33,5) AND (65,11), RESPECTIVELY. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) C C WHERE C C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT C EXCEED M. C C X IS AN INPUT ARRAY OF LENGTH N. C C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS THE NPROB C FUNCTION EVALUATED AT X. C C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. C C SUBPROGRAMS CALLED C C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIN,DSQRT,DSIGN C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER I,IEV,IVAR,J,NM1 DOUBLE PRECISION C13,C14,C29,C45,DIV,DX,EIGHT,FIVE,ONE,PROD,SUM, * S1,S2,TEMP,TEN,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO, * ZERO,ZP25,ZP5 DOUBLE PRECISION V(11),Y1(15),Y2(11),Y3(16),Y4(33),Y5(65) DOUBLE PRECISION DFLOAT DATA ZERO,ZP25,ZP5,ONE,TWO,FIVE,EIGHT,TEN,C13,C14,C29,C45 * /0.0D0,2.5D-1,5.0D-1,1.0D0,2.0D0,5.0D0,8.0D0,1.0D1,1.3D1, * 1.4D1,2.9D1,4.5D1/ DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) * /4.0D0,2.0D0,1.0D0,5.0D-1,2.5D-1,1.67D-1,1.25D-1,1.0D-1, * 8.33D-2,7.14D-2,6.25D-2/ DATA Y1(1),Y1(2),Y1(3),Y1(4),Y1(5),Y1(6),Y1(7),Y1(8),Y1(9), * Y1(10),Y1(11),Y1(12),Y1(13),Y1(14),Y1(15) * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ DATA Y2(1),Y2(2),Y2(3),Y2(4),Y2(5),Y2(6),Y2(7),Y2(8),Y2(9), * Y2(10),Y2(11) * /1.957D-1,1.947D-1,1.735D-1,1.6D-1,8.44D-2,6.27D-2,4.56D-2, * 3.42D-2,3.23D-2,2.35D-2,2.46D-2/ DATA Y3(1),Y3(2),Y3(3),Y3(4),Y3(5),Y3(6),Y3(7),Y3(8),Y3(9), * Y3(10),Y3(11),Y3(12),Y3(13),Y3(14),Y3(15),Y3(16) * /3.478D4,2.861D4,2.365D4,1.963D4,1.637D4,1.372D4,1.154D4, * 9.744D3,8.261D3,7.03D3,6.005D3,5.147D3,4.427D3,3.82D3, * 3.307D3,2.872D3/ DATA Y4(1),Y4(2),Y4(3),Y4(4),Y4(5),Y4(6),Y4(7),Y4(8),Y4(9), * Y4(10),Y4(11),Y4(12),Y4(13),Y4(14),Y4(15),Y4(16),Y4(17), * Y4(18),Y4(19),Y4(20),Y4(21),Y4(22),Y4(23),Y4(24),Y4(25), * Y4(26),Y4(27),Y4(28),Y4(29),Y4(30),Y4(31),Y4(32),Y4(33) * /8.44D-1,9.08D-1,9.32D-1,9.36D-1,9.25D-1,9.08D-1,8.81D-1, * 8.5D-1,8.18D-1,7.84D-1,7.51D-1,7.18D-1,6.85D-1,6.58D-1, * 6.28D-1,6.03D-1,5.8D-1,5.58D-1,5.38D-1,5.22D-1,5.06D-1, * 4.9D-1,4.78D-1,4.67D-1,4.57D-1,4.48D-1,4.38D-1,4.31D-1, * 4.24D-1,4.2D-1,4.14D-1,4.11D-1,4.06D-1/ DATA Y5(1),Y5(2),Y5(3),Y5(4),Y5(5),Y5(6),Y5(7),Y5(8),Y5(9), * Y5(10),Y5(11),Y5(12),Y5(13),Y5(14),Y5(15),Y5(16),Y5(17), * Y5(18),Y5(19),Y5(20),Y5(21),Y5(22),Y5(23),Y5(24),Y5(25), * Y5(26),Y5(27),Y5(28),Y5(29),Y5(30),Y5(31),Y5(32),Y5(33), * Y5(34),Y5(35),Y5(36),Y5(37),Y5(38),Y5(39),Y5(40),Y5(41), * Y5(42),Y5(43),Y5(44),Y5(45),Y5(46),Y5(47),Y5(48),Y5(49), * Y5(50),Y5(51),Y5(52),Y5(53),Y5(54),Y5(55),Y5(56),Y5(57), * Y5(58),Y5(59),Y5(60),Y5(61),Y5(62),Y5(63),Y5(64),Y5(65) * /1.366D0,1.191D0,1.112D0,1.013D0,9.91D-1,8.85D-1,8.31D-1, * 8.47D-1,7.86D-1,7.25D-1,7.46D-1,6.79D-1,6.08D-1,6.55D-1, * 6.16D-1,6.06D-1,6.02D-1,6.26D-1,6.51D-1,7.24D-1,6.49D-1, * 6.49D-1,6.94D-1,6.44D-1,6.24D-1,6.61D-1,6.12D-1,5.58D-1, * 5.33D-1,4.95D-1,5.0D-1,4.23D-1,3.95D-1,3.75D-1,3.72D-1, * 3.91D-1,3.96D-1,4.05D-1,4.28D-1,4.29D-1,5.23D-1,5.62D-1, * 6.07D-1,6.53D-1,6.72D-1,7.08D-1,6.33D-1,6.68D-1,6.45D-1, * 6.32D-1,5.91D-1,5.59D-1,5.97D-1,6.25D-1,7.39D-1,7.1D-1, * 7.29D-1,7.2D-1,6.36D-1,5.81D-1,4.28D-1,2.92D-1,1.62D-1, * 9.8D-2,5.4D-2/ DFLOAT(IVAR) = IVAR C C FUNCTION ROUTINE SELECTOR. C GO TO (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310, * 360,390,410), NPROB C C LINEAR FUNCTION - FULL RANK. C 10 CONTINUE SUM = ZERO DO 20 J = 1, N SUM = SUM + X(J) 20 CONTINUE TEMP = TWO*SUM/DFLOAT(M) + ONE DO 30 I = 1, M FVEC(I) = -TEMP IF (I .LE. N) FVEC(I) = FVEC(I) + X(I) 30 CONTINUE GO TO 430 C C LINEAR FUNCTION - RANK 1. C 40 CONTINUE SUM = ZERO DO 50 J = 1, N SUM = SUM + DFLOAT(J)*X(J) 50 CONTINUE DO 60 I = 1, M FVEC(I) = DFLOAT(I)*SUM - ONE 60 CONTINUE GO TO 430 C C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. C 70 CONTINUE SUM = ZERO NM1 = N - 1 IF (NM1 .LT. 2) GO TO 90 DO 80 J = 2, NM1 SUM = SUM + DFLOAT(J)*X(J) 80 CONTINUE 90 CONTINUE DO 100 I = 1, M FVEC(I) = DFLOAT(I-1)*SUM - ONE 100 CONTINUE FVEC(M) = -ONE GO TO 430 C C ROSENBROCK FUNCTION. C 110 CONTINUE FVEC(1) = TEN*(X(2) - X(1)**2) FVEC(2) = ONE - X(1) GO TO 430 C C HELICAL VALLEY FUNCTION. C 120 CONTINUE TPI = EIGHT*DATAN(ONE) TMP1 = DSIGN(ZP25,X(2)) IF (X(1) .GT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI IF (X(1) .LT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI + ZP5 TMP2 = DSQRT(X(1)**2+X(2)**2) FVEC(1) = TEN*(X(3) - TEN*TMP1) FVEC(2) = TEN*(TMP2 - ONE) FVEC(3) = X(3) GO TO 430 C C POWELL SINGULAR FUNCTION. C 130 CONTINUE FVEC(1) = X(1) + TEN*X(2) FVEC(2) = DSQRT(FIVE)*(X(3) - X(4)) FVEC(3) = (X(2) - TWO*X(3))**2 FVEC(4) = DSQRT(TEN)*(X(1) - X(4))**2 GO TO 430 C C FREUDENSTEIN AND ROTH FUNCTION. C 140 CONTINUE FVEC(1) = -C13 + X(1) + ((FIVE - X(2))*X(2) - TWO)*X(2) FVEC(2) = -C29 + X(1) + ((ONE + X(2))*X(2) - C14)*X(2) GO TO 430 C C BARD FUNCTION. C 150 CONTINUE DO 160 I = 1, 15 TMP1 = DFLOAT(I) TMP2 = DFLOAT(16-I) TMP3 = TMP1 IF (I .GT. 8) TMP3 = TMP2 FVEC(I) = Y1(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) 160 CONTINUE GO TO 430 C C KOWALIK AND OSBORNE FUNCTION. C 170 CONTINUE DO 180 I = 1, 11 TMP1 = V(I)*(V(I) + X(2)) TMP2 = V(I)*(V(I) + X(3)) + X(4) FVEC(I) = Y2(I) - X(1)*TMP1/TMP2 180 CONTINUE GO TO 430 C C MEYER FUNCTION. C 190 CONTINUE DO 200 I = 1, 16 TEMP = FIVE*DFLOAT(I) + C45 + X(3) TMP1 = X(2)/TEMP TMP2 = DEXP(TMP1) FVEC(I) = X(1)*TMP2 - Y3(I) 200 CONTINUE GO TO 430 C C WATSON FUNCTION. C 210 CONTINUE DO 240 I = 1, 29 DIV = DFLOAT(I)/C29 S1 = ZERO DX = ONE DO 220 J = 2, N S1 = S1 + DFLOAT(J-1)*DX*X(J) DX = DIV*DX 220 CONTINUE S2 = ZERO DX = ONE DO 230 J = 1, N S2 = S2 + DX*X(J) DX = DIV*DX 230 CONTINUE FVEC(I) = S1 - S2**2 - ONE 240 CONTINUE FVEC(30) = X(1) FVEC(31) = X(2) - X(1)**2 - ONE GO TO 430 C C BOX 3-DIMENSIONAL FUNCTION. C 250 CONTINUE DO 260 I = 1, M TEMP = DFLOAT(I) TMP1 = TEMP/TEN FVEC(I) = DEXP(-TMP1*X(1)) - DEXP(-TMP1*X(2)) * + (DEXP(-TEMP) - DEXP(-TMP1))*X(3) 260 CONTINUE GO TO 430 C C JENNRICH AND SAMPSON FUNCTION. C 270 CONTINUE DO 280 I = 1, M TEMP = DFLOAT(I) FVEC(I) = TWO + TWO*TEMP - DEXP(TEMP*X(1)) - DEXP(TEMP*X(2)) 280 CONTINUE GO TO 430 C C BROWN AND DENNIS FUNCTION. C 290 CONTINUE DO 300 I = 1, M TEMP = DFLOAT(I)/FIVE TMP1 = X(1) + TEMP*X(2) - DEXP(TEMP) TMP2 = X(3) + DSIN(TEMP)*X(4) - DCOS(TEMP) FVEC(I) = TMP1**2 + TMP2**2 300 CONTINUE GO TO 430 C C CHEBYQUAD FUNCTION. C 310 CONTINUE DO 320 I = 1, M FVEC(I) = ZERO 320 CONTINUE DO 340 J = 1, N TMP1 = ONE TMP2 = TWO*X(J) - ONE TEMP = TWO*TMP2 DO 330 I = 1, M FVEC(I) = FVEC(I) + TMP2 TI = TEMP*TMP2 - TMP1 TMP1 = TMP2 TMP2 = TI 330 CONTINUE 340 CONTINUE DX = ONE/DFLOAT(N) IEV = -1 DO 350 I = 1, M FVEC(I) = DX*FVEC(I) IF (IEV .GT. 0) FVEC(I) = FVEC(I) + ONE/(DFLOAT(I)**2 - ONE) IEV = -IEV 350 CONTINUE GO TO 430 C C BROWN ALMOST-LINEAR FUNCTION. C 360 CONTINUE SUM = -DFLOAT(N+1) PROD = ONE DO 370 J = 1, N SUM = SUM + X(J) PROD = X(J)*PROD 370 CONTINUE DO 380 I = 1, N FVEC(I) = X(I) + SUM 380 CONTINUE FVEC(N) = PROD - ONE GO TO 430 C C OSBORNE 1 FUNCTION. C 390 CONTINUE DO 400 I = 1, 33 TEMP = TEN*DFLOAT(I-1) TMP1 = DEXP(-X(4)*TEMP) TMP2 = DEXP(-X(5)*TEMP) FVEC(I) = Y4(I) - (X(1) + X(2)*TMP1 + X(3)*TMP2) 400 CONTINUE GO TO 430 C C OSBORNE 2 FUNCTION. C 410 CONTINUE DO 420 I = 1, 65 TEMP = DFLOAT(I-1)/TEN TMP1 = DEXP(-X(5)*TEMP) TMP2 = DEXP(-X(6)*(TEMP-X(9))**2) TMP3 = DEXP(-X(7)*(TEMP-X(10))**2) TMP4 = DEXP(-X(8)*(TEMP-X(11))**2) FVEC(I) = Y5(I) * - (X(1)*TMP1 + X(2)*TMP2 + X(3)*TMP3 + X(4)*TMP4) 420 CONTINUE 430 CONTINUE RETURN C C LAST CARD OF SUBROUTINE SSQFCN. C END SUBROUTINE INITPT(N,X,NPROB,FACTOR) INTEGER N,NPROB DOUBLE PRECISION FACTOR DOUBLE PRECISION X(N) C ********** C C SUBROUTINE INITPT C C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE C FUNCTIONS DEFINED BY SUBROUTINE SSQFCN. THE SUBROUTINE RETURNS C IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR C THE 11TH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN C THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS C THE VECTOR X(J) = FACTOR, J=1,...,N. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE INITPT(N,X,NPROB,FACTOR) C C WHERE C C N IS A POSITIVE INTEGER INPUT VARIABLE. C C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. C C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. C C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO C MULTIPLICATION IS PERFORMED. C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER IVAR,J DOUBLE PRECISION C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14, * C15,C16,C17,FIVE,H,HALF,ONE,SEVEN,TEN,THREE, * TWENTY,TWNTF,TWO,ZERO DOUBLE PRECISION DFLOAT DATA ZERO,HALF,ONE,TWO,THREE,FIVE,SEVEN,TEN,TWENTY,TWNTF * /0.0D0,5.0D-1,1.0D0,2.0D0,3.0D0,5.0D0,7.0D0,1.0D1,2.0D1, * 2.5D1/ DATA C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17 * /1.2D0,2.5D-1,3.9D-1,4.15D-1,2.0D-2,4.0D3,2.5D2,3.0D-1, * 4.0D-1,1.5D0,1.0D-2,1.3D0,6.5D-1,7.0D-1,6.0D-1,4.5D0, * 5.5D0/ DFLOAT(IVAR) = IVAR C C SELECTION OF INITIAL POINT. C GO TO (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170, * 190,200), NPROB C C LINEAR FUNCTION - FULL RANK OR RANK 1. C 10 CONTINUE DO 20 J = 1, N X(J) = ONE 20 CONTINUE GO TO 210 C C ROSENBROCK FUNCTION. C 30 CONTINUE X(1) = -C1 X(2) = ONE GO TO 210 C C HELICAL VALLEY FUNCTION. C 40 CONTINUE X(1) = -ONE X(2) = ZERO X(3) = ZERO GO TO 210 C C POWELL SINGULAR FUNCTION. C 50 CONTINUE X(1) = THREE X(2) = -ONE X(3) = ZERO X(4) = ONE GO TO 210 C C FREUDENSTEIN AND ROTH FUNCTION. C 60 CONTINUE X(1) = HALF X(2) = -TWO GO TO 210 C C BARD FUNCTION. C 70 CONTINUE X(1) = ONE X(2) = ONE X(3) = ONE GO TO 210 C C KOWALIK AND OSBORNE FUNCTION. C 80 CONTINUE X(1) = C2 X(2) = C3 X(3) = C4 X(4) = C3 GO TO 210 C C MEYER FUNCTION. C 90 CONTINUE X(1) = C5 X(2) = C6 X(3) = C7 GO TO 210 C C WATSON FUNCTION. C 100 CONTINUE DO 110 J = 1, N X(J) = ZERO 110 CONTINUE GO TO 210 C C BOX 3-DIMENSIONAL FUNCTION. C 120 CONTINUE X(1) = ZERO X(2) = TEN X(3) = TWENTY GO TO 210 C C JENNRICH AND SAMPSON FUNCTION. C 130 CONTINUE X(1) = C8 X(2) = C9 GO TO 210 C C BROWN AND DENNIS FUNCTION. C 140 CONTINUE X(1) = TWNTF X(2) = FIVE X(3) = -FIVE X(4) = -ONE GO TO 210 C C CHEBYQUAD FUNCTION. C 150 CONTINUE H = ONE/DFLOAT(N+1) DO 160 J = 1, N X(J) = DFLOAT(J)*H 160 CONTINUE GO TO 210 C C BROWN ALMOST-LINEAR FUNCTION. C 170 CONTINUE DO 180 J = 1, N X(J) = HALF 180 CONTINUE GO TO 210 C C OSBORNE 1 FUNCTION. C 190 CONTINUE X(1) = HALF X(2) = C10 X(3) = -ONE X(4) = C11 X(5) = C5 GO TO 210 C C OSBORNE 2 FUNCTION. C 200 CONTINUE X(1) = C12 X(2) = C13 X(3) = C13 X(4) = C14 X(5) = C15 X(6) = THREE X(7) = FIVE X(8) = SEVEN X(9) = TWO X(10) = C16 X(11) = C17 210 CONTINUE C C COMPUTE MULTIPLE OF INITIAL POINT. C IF (FACTOR .EQ. ONE) GO TO 260 IF (NPROB .EQ. 11) GO TO 230 DO 220 J = 1, N X(J) = FACTOR*X(J) 220 CONTINUE GO TO 250 230 CONTINUE DO 240 J = 1, N X(J) = FACTOR 240 CONTINUE 250 CONTINUE 260 CONTINUE RETURN C C LAST CARD OF SUBROUTINE INITPT. C END GWW/minpack/lmdif.f0000644000077300007730000003670112341332532014703 0ustar giannozzgiannozz subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn, * diag,mode,factor,nprint,info,nfev,fjac,ldfjac, * ipvt,qtf,wa1,wa2,wa3,wa4) integer m,n,maxfev,mode,nprint,info,nfev,ldfjac integer ipvt(n) double precision ftol,xtol,gtol,epsfcn,factor double precision x(n),fvec(m),diag(n),fjac(ldfjac,n),qtf(n), * wa1(n),wa2(n),wa3(n),wa4(m) external fcn c ********** c c subroutine lmdif c c the purpose of lmdif is to minimize the sum of the squares of c m nonlinear functions in n variables by a modification of c the levenberg-marquardt algorithm. the user must provide a c subroutine which calculates the functions. the jacobian is c then calculated by a forward-difference approximation. c c the subroutine statement is c c subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn, c diag,mode,factor,nprint,info,nfev,fjac, c ldfjac,ipvt,qtf,wa1,wa2,wa3,wa4) c c where c c fcn is the name of the user-supplied subroutine which c calculates the functions. fcn must be declared c in an external statement in the user calling c program, and should be written as follows. c c subroutine fcn(m,n,x,fvec,iflag) c integer m,n,iflag c double precision x(n),fvec(m) c ---------- c calculate the functions at x and c return this vector in fvec. c ---------- c return c end c c the value of iflag should not be changed by fcn unless c the user wants to terminate execution of lmdif. c in this case set iflag to a negative integer. c c m is a positive integer input variable set to the number c of functions. c c n is a positive integer input variable set to the number c of variables. n must not exceed m. c c x is an array of length n. on input x must contain c an initial estimate of the solution vector. on output x c contains the final estimate of the solution vector. c c fvec is an output array of length m which contains c the functions evaluated at the output x. c c ftol is a nonnegative input variable. termination c occurs when both the actual and predicted relative c reductions in the sum of squares are at most ftol. c therefore, ftol measures the relative error desired c in the sum of squares. c c xtol is a nonnegative input variable. termination c occurs when the relative error between two consecutive c iterates is at most xtol. therefore, xtol measures the c relative error desired in the approximate solution. c c gtol is a nonnegative input variable. termination c occurs when the cosine of the angle between fvec and c any column of the jacobian is at most gtol in absolute c value. therefore, gtol measures the orthogonality c desired between the function vector and the columns c of the jacobian. c c maxfev is a positive integer input variable. termination c occurs when the number of calls to fcn is at least c maxfev by the end of an iteration. c c epsfcn is an input variable used in determining a suitable c step length for the forward-difference approximation. this c approximation assumes that the relative errors in the c functions are of the order of epsfcn. if epsfcn is less c than the machine precision, it is assumed that the relative c errors in the functions are of the order of the machine c precision. c c diag is an array of length n. if mode = 1 (see c below), diag is internally set. if mode = 2, diag c must contain positive entries that serve as c multiplicative scale factors for the variables. c c mode is an integer input variable. if mode = 1, the c variables will be scaled internally. if mode = 2, c the scaling is specified by the input diag. other c values of mode are equivalent to mode = 1. c c factor is a positive input variable used in determining the c initial step bound. this bound is set to the product of c factor and the euclidean norm of diag*x if nonzero, or else c to factor itself. in most cases factor should lie in the c interval (.1,100.). 100. is a generally recommended value. c c nprint is an integer input variable that enables controlled c printing of iterates if it is positive. in this case, c fcn is called with iflag = 0 at the beginning of the first c iteration and every nprint iterations thereafter and c immediately prior to return, with x and fvec available c for printing. if nprint is not positive, no special calls c of fcn with iflag = 0 are made. c c info is an integer output variable. if the user has c terminated execution, info is set to the (negative) c value of iflag. see description of fcn. otherwise, c info is set as follows. c c info = 0 improper input parameters. c c info = 1 both actual and predicted relative reductions c in the sum of squares are at most ftol. c c info = 2 relative error between two consecutive iterates c is at most xtol. c c info = 3 conditions for info = 1 and info = 2 both hold. c c info = 4 the cosine of the angle between fvec and any c column of the jacobian is at most gtol in c absolute value. c c info = 5 number of calls to fcn has reached or c exceeded maxfev. c c info = 6 ftol is too small. no further reduction in c the sum of squares is possible. c c info = 7 xtol is too small. no further improvement in c the approximate solution x is possible. c c info = 8 gtol is too small. fvec is orthogonal to the c columns of the jacobian to machine precision. c c nfev is an integer output variable set to the number of c calls to fcn. c c fjac is an output m by n array. the upper n by n submatrix c of fjac contains an upper triangular matrix r with c diagonal elements of nonincreasing magnitude such that c c t t t c p *(jac *jac)*p = r *r, c c where p is a permutation matrix and jac is the final c calculated jacobian. column j of p is column ipvt(j) c (see below) of the identity matrix. the lower trapezoidal c part of fjac contains information generated during c the computation of r. c c ldfjac is a positive integer input variable not less than m c which specifies the leading dimension of the array fjac. c c ipvt is an integer output array of length n. ipvt c defines a permutation matrix p such that jac*p = q*r, c where jac is the final calculated jacobian, q is c orthogonal (not stored), and r is upper triangular c with diagonal elements of nonincreasing magnitude. c column j of p is column ipvt(j) of the identity matrix. c c qtf is an output array of length n which contains c the first n elements of the vector (q transpose)*fvec. c c wa1, wa2, and wa3 are work arrays of length n. c c wa4 is a work array of length m. c c subprograms called c c user-supplied ...... fcn c c minpack-supplied ... dpmpar,enorm,fdjac2,lmpar,qrfac c c fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod c c argonne national laboratory. minpack project. march 1980. c burton s. garbow, kenneth e. hillstrom, jorge j. more c c ********** integer i,iflag,iter,j,l double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm, * one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio, * sum,temp,temp1,temp2,xnorm,zero double precision dpmpar,enorm data one,p1,p5,p25,p75,p0001,zero * /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/ c c epsmch is the machine precision. c epsmch = dpmpar(1) c info = 0 iflag = 0 nfev = 0 c c check the input parameters for errors. c if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m * .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero * .or. maxfev .le. 0 .or. factor .le. zero) go to 300 if (mode .ne. 2) go to 20 do 10 j = 1, n if (diag(j) .le. zero) go to 300 10 continue 20 continue c c evaluate the function at the starting point c and calculate its norm. c iflag = 1 call fcn(m,n,x,fvec,iflag) nfev = 1 if (iflag .lt. 0) go to 300 fnorm = enorm(m,fvec) c c initialize levenberg-marquardt parameter and iteration counter. c par = zero iter = 1 c c beginning of the outer loop. c 30 continue c c calculate the jacobian matrix. c iflag = 2 call fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa4) nfev = nfev + n if (iflag .lt. 0) go to 300 c c if requested, call fcn to enable printing of iterates. c if (nprint .le. 0) go to 40 iflag = 0 c if (mod(iter-1,nprint) .eq. 0) c call fcn(m,n,x,fvec,iflag) ! write(*,*) 'ATTENZIONE l', fvec(1:10) if (iflag .lt. 0) go to 300 40 continue call fcn(m,n,x,fvec,iflag) ! write(*,*) 'ATTENZIONE l', fvec(1:10) c c compute the qr factorization of the jacobian. c call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3) c c on the first iteration and if mode is 1, scale according c to the norms of the columns of the initial jacobian. c if (iter .ne. 1) go to 80 if (mode .eq. 2) go to 60 do 50 j = 1, n diag(j) = wa2(j) if (wa2(j) .eq. zero) diag(j) = one 50 continue 60 continue c c on the first iteration, calculate the norm of the scaled x c and initialize the step bound delta. c do 70 j = 1, n wa3(j) = diag(j)*x(j) 70 continue xnorm = enorm(n,wa3) delta = factor*xnorm if (delta .eq. zero) delta = factor 80 continue c c form (q transpose)*fvec and store the first n components in c qtf. c do 90 i = 1, m wa4(i) = fvec(i) 90 continue do 130 j = 1, n if (fjac(j,j) .eq. zero) go to 120 sum = zero do 100 i = j, m sum = sum + fjac(i,j)*wa4(i) 100 continue temp = -sum/fjac(j,j) do 110 i = j, m wa4(i) = wa4(i) + fjac(i,j)*temp 110 continue 120 continue fjac(j,j) = wa1(j) qtf(j) = wa4(j) 130 continue c c compute the norm of the scaled gradient. c gnorm = zero if (fnorm .eq. zero) go to 170 do 160 j = 1, n l = ipvt(j) if (wa2(l) .eq. zero) go to 150 sum = zero do 140 i = 1, j sum = sum + fjac(i,j)*(qtf(i)/fnorm) 140 continue gnorm = dmax1(gnorm,dabs(sum/wa2(l))) 150 continue 160 continue 170 continue c c test for convergence of the gradient norm. c c ATTENZIONE c write(*,*) 'ATTENZIONE0',wa2(1:5) c write(*,*) 'ATTENZIONE',fnorm,gnorm,gtol,epsmch if (gnorm .le. gtol) info = 4 if (info .ne. 0) go to 300 c c rescale if necessary. c if (mode .eq. 2) go to 190 do 180 j = 1, n diag(j) = dmax1(diag(j),wa2(j)) 180 continue 190 continue c c beginning of the inner loop. c 200 continue c c determine the levenberg-marquardt parameter. c call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2, * wa3,wa4) c c store the direction p and x + p. calculate the norm of p. c do 210 j = 1, n wa1(j) = -wa1(j) wa2(j) = x(j) + wa1(j) wa3(j) = diag(j)*wa1(j) 210 continue pnorm = enorm(n,wa3) c c on the first iteration, adjust the initial step bound. c if (iter .eq. 1) delta = dmin1(delta,pnorm) c c evaluate the function at x + p and calculate its norm. c iflag = 1 call fcn(m,n,wa2,wa4,iflag) nfev = nfev + 1 if (iflag .lt. 0) go to 300 fnorm1 = enorm(m,wa4) c c compute the scaled actual reduction. c actred = -one if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 c c compute the scaled predicted reduction and c the scaled directional derivative. c do 230 j = 1, n wa3(j) = zero l = ipvt(j) temp = wa1(l) do 220 i = 1, j wa3(i) = wa3(i) + fjac(i,j)*temp 220 continue 230 continue temp1 = enorm(n,wa3)/fnorm temp2 = (dsqrt(par)*pnorm)/fnorm prered = temp1**2 + temp2**2/p5 dirder = -(temp1**2 + temp2**2) c c compute the ratio of the actual to the predicted c reduction. c ratio = zero if (prered .ne. zero) ratio = actred/prered c c update the step bound. c if (ratio .gt. p25) go to 240 if (actred .ge. zero) temp = p5 if (actred .lt. zero) * temp = p5*dirder/(dirder + p5*actred) if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1 delta = temp*dmin1(delta,pnorm/p1) par = par/temp go to 260 240 continue if (par .ne. zero .and. ratio .lt. p75) go to 250 delta = pnorm/p5 par = p5*par 250 continue 260 continue c c test for successful iteration. c if (ratio .lt. p0001) go to 290 c c successful iteration. update x, fvec, and their norms. c do 270 j = 1, n x(j) = wa2(j) wa2(j) = diag(j)*x(j) 270 continue do 280 i = 1, m fvec(i) = wa4(i) 280 continue xnorm = enorm(n,wa2) fnorm = fnorm1 iter = iter + 1 290 continue c c tests for convergence. c if (dabs(actred) .le. ftol .and. prered .le. ftol * .and. p5*ratio .le. one) info = 1 if (delta .le. xtol*xnorm) info = 2 if (dabs(actred) .le. ftol .and. prered .le. ftol * .and. p5*ratio .le. one .and. info .eq. 2) info = 3 if (info .ne. 0) go to 300 c c tests for termination and stringent tolerances. c if (nfev .ge. maxfev) info = 5 if (dabs(actred) .le. epsmch .and. prered .le. epsmch * .and. p5*ratio .le. one) info = 6 if (delta .le. epsmch*xnorm) info = 7 if (gnorm .le. epsmch) info = 8 if (info .ne. 0) go to 300 c c end of the inner loop. repeat if iteration unsuccessful. c if (ratio .lt. p0001) go to 200 c c end of the outer loop. c go to 30 300 continue c c termination, either normal or user imposed. c if (iflag .lt. 0) info = iflag iflag = 0 if (nprint .gt. 0) call fcn(m,n,x,fvec,iflag) return c c last card of subroutine lmdif. c end GWW/minpack/make.depend0000644000077300007730000000000012341332532015516 0ustar giannozzgiannozzGWW/head/0000755000077300007730000000000012341332543012713 5ustar giannozzgiannozzGWW/head/phq_readin.f900000644000077300007730000005444412341332532015356 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! ! ! !---------------------------------------------------------------------------- SUBROUTINE phq_readin() !---------------------------------------------------------------------------- ! ! This routine reads the control variables for the program phononq. ! from standard input (unit 5). ! A second routine readfile reads the variables saved on a file ! by the self-consistent program. ! ! USE kinds, ONLY : DP USE parameters, ONLY : nsx USE ions_base, ONLY : nat, ntyp => nsp USE io_global, ONLY : ionode_id USE mp, ONLY : mp_bcast,mp_barrier USE mp_world, ONLY : world_comm USE ions_base, ONLY : amass, atm USE input_parameters, ONLY : max_seconds, nk1, nk2, nk3, k1, k2, k3 USE start_k, ONLY : reset_grid USE klist, ONLY : xk, nks, nkstot, lgauss, two_fermi_energies, lgauss USE ktetra, ONLY : ltetra USE control_flags, ONLY : gamma_only, tqr, restart, lkpoint_dir USE uspp, ONLY : okvan USE fixed_occ, ONLY : tfixed_occ USE lsda_mod, ONLY : lsda, nspin USE spin_orb, ONLY : domag USE cellmd, ONLY : lmovecell USE run_info, ONLY : title USE control_ph, ONLY : maxter, alpha_mix, lgamma, lgamma_gamma, epsil, & zue, zeu, xmldyn, newgrid, & trans, reduce_io, tr2_ph, niter_ph, & nmix_ph, ldisp, recover, lrpa, lnoloc, start_irr, & last_irr, start_q, last_q, current_iq, tmp_dir_ph, & ext_recover, ext_restart, u_from_file, ldiag, & search_sym, lqdir, electron_phonon USE save_ph, ONLY : tmp_dir_save USE gamma_gamma, ONLY : asr USE qpoint, ONLY : nksq, xq USE partial, ONLY : atomo, nat_todo, nat_todo_input USE output, ONLY : fildyn, fildvscf, fildrho USE disp, ONLY : nq1, nq2, nq3 USE io_files, ONLY : tmp_dir, prefix USE noncollin_module, ONLY : i_cons, noncolin USE ldaU, ONLY : lda_plus_u USE control_flags, ONLY : iverbosity, modenum, twfcollect,io_level USE io_global, ONLY : ionode, stdout USE mp_global, ONLY : nproc_pool_file, nproc_image_file, & ntask_groups_file, nproc_bgrp_file USE mp_images, ONLY : nimage, my_image_id, nproc_image USE mp_pools, ONLY : nproc_pool, npool USE mp_bands, ONLY : ntask_groups USE paw_variables, ONLY : okpaw USE ramanm, ONLY : eth_rps, eth_ns, lraman, elop, dek USE freq_ph, ONLY : fpol, fiu, nfs USE ph_restart, ONLY : ph_readfile USE xml_io_base, ONLY : create_directory USE el_phon, ONLY : elph,elph_mat,elph_simple,elph_nbnd_min, elph_nbnd_max, & el_ph_sigma, el_ph_nsigma, el_ph_ngauss,auxdvscf USE dfile_star, ONLY : drho_star, dvscf_star USE wannier_gw, ONLY : l_head, omega_gauss, n_gauss, grid_type, nsteps_lanczos,second_grid_n,second_grid_i,& &l_scissor,scissor USE save_ph, ONLY : save_ph_input_variables ! IMPLICIT NONE ! CHARACTER(LEN=256), EXTERNAL :: trimcheck ! INTEGER :: ios, ipol, iter, na, it, ierr ! integer variable for I/O control ! counter on polarizations ! counter on iterations ! counter on atoms ! counter on types REAL(DP) :: amass_input(nsx) ! save masses read from input here CHARACTER (LEN=256) :: outdir ! CHARACTER(LEN=80) :: card CHARACTER(LEN=1), EXTERNAL :: capital CHARACTER(LEN=6) :: int_to_char INTEGER :: i LOGICAL :: nogg INTEGER, EXTERNAL :: atomic_number REAL(DP), EXTERNAL :: atom_weight LOGICAL, EXTERNAL :: imatches LOGICAL, EXTERNAL :: has_xml ! NAMELIST / INPUTPH / tr2_ph, amass, alpha_mix, niter_ph, nmix_ph, & nat_todo, iverbosity, outdir, epsil, & trans, zue, zeu, max_seconds, reduce_io, & modenum, prefix, fildyn, fildvscf, fildrho, & ldisp, nq1, nq2, nq3, & eth_rps, eth_ns, lraman, elop, dek, recover, & fpol, asr, lrpa, lnoloc, start_irr, last_irr, & start_q, last_q, nogg, ldiag, search_sym, lqdir, & nk1, nk2, nk3, k1, k2, k3, & drho_star, dvscf_star, & elph_nbnd_min, elph_nbnd_max, el_ph_ngauss,el_ph_nsigma, el_ph_sigma, & electron_phonon,& l_head, omega_gauss, n_gauss, grid_type,nsteps_lanczos,l_scissor,scissor,& second_grid_n,second_grid_i ! tr2_ph : convergence threshold ! amass : atomic masses ! alpha_mix : the mixing parameter ! niter_ph : maximum number of iterations ! nmix_ph : number of previous iterations used in mixing ! nat_todo : number of atom to be displaced ! iverbosity : verbosity control ! outdir : directory where input, output, temporary files reside ! epsil : if true calculate dielectric constant ! trans : if true calculate phonon ! electron-phonon : select the kind of electron-phonon calculation ! elph : if true calculate electron-phonon coefficients ! elph_mat : if true eph coefficients for wannier ! zue : if .true. calculate effective charges ( d force / dE ) ! zeu : if .true. calculate effective charges ( d P / du ) ! lraman : if true calculate raman tensor ! elop : if true calculate electro-optic tensor ! max_seconds : maximum cputime for this run ! reduce_io : reduce I/O to the strict minimum ! modenum : single mode calculation ! prefix : the prefix of files produced by pwscf ! fildyn : output file for the dynamical matrix ! fildvscf : output file containing deltavsc ! fildrho : output file containing deltarho ! fildrho_dir : directory where fildrho files will be stored (default: outdir or ESPRESSO_FILDRHO_DIR variable) ! eth_rps : threshold for calculation of Pc R |psi> (Raman) ! eth_ns : threshold for non-scf wavefunction calculation (Raman) ! dek : delta_xk used for wavefunctions derivation (Raman) ! recover : recover=.true. to restart from an interrupted run ! asr : in the gamma_gamma case apply acoustic sum rule ! start_q : in q list does the q points from start_q to last_q ! last_q : ! start_irr : does the irred. representation from start_irr to last_irr ! last_irr : ! nogg : if .true. lgamma_gamma tricks are not used ! ldiag : if .true. force diagonalization of the dyn mat ! lqdir : if .true. each q writes in its own directory ! search_sym : if .true. analyze symmetry if possible ! nk1,nk2,nk3, ! ik1, ik2, ik3: when specified in input it uses for the phonon run ! a different mesh than that used for the charge density. ! ! dvscf_star%open : if .true. write in dvscf_star%dir the dvscf_q' for all q' in the ! star of q with suffix dvscf_star%ext. The dvscf_q' is written in the basis dvscf_star%basis; ! if dvscf_star%pat is .true. also save a pattern file. ! dvscf_star%dir, dvscf_star%ext, dvscf_star%basis : see dvscf_star%open ! drho_star%open : like dvscf_star%open but for drho_q ! drho_star%dir, drho_star%ext, drho_star%basis : see drho_star%open ! ! elph_nbnd_min, ! elph_nbnd_max: if (elph_mat=.true.) it dumps the eph matrix element from elph_nbnd_min ! to elph_nbnd_max ! el_ph_ngauss, ! el_ph_nsigma, ! el_ph_sigma : if (elph_mat=.true.) it defines the kind and the val-ue of the ! smearing to be used in the eph coupling calculation. ! ! l_head : if true calculates the head of the symmetrized dielectric matrix -1 ! n_gauss : number of frequency steps for head calculation ! omega_gauss : period for frequency calculation ! grid_type : 0 GL -T,T 2 GL 0 T IF (ionode) THEN ! ! ... Input from file ? ! CALL input_from_file ( ) ! ! ... Read the first line of the input file ! READ( 5, '(A)', IOSTAT = ios ) title ! ENDIF ! CALL mp_bcast(ios, ionode_id, world_comm ) CALL errore( 'phq_readin', 'reading title ', ABS( ios ) ) CALL mp_bcast(title, ionode_id, world_comm ) ! ! Rewind the input if the title is actually the beginning of inputph namelist ! IF( imatches("&inputph", title) ) THEN WRITE(*, '(6x,a)') "Title line not specified: using 'default'." title='default' IF (ionode) REWIND(5, iostat=ios) CALL mp_bcast(ios, ionode_id, world_comm ) CALL errore('phq_readin', 'Title line missing from input.', abs(ios)) ENDIF ! ! ... set default values for variables in namelist ! tr2_ph = 1.D-12 eth_rps = 1.D-9 eth_ns = 1.D-12 amass(:) = 0.D0 alpha_mix(:) = 0.D0 alpha_mix(1) = 0.7D0 niter_ph = maxter nmix_ph = 4 nat_todo = 0 modenum = 0 iverbosity = 0 trans = .TRUE. lrpa = .FALSE. lnoloc = .FALSE. epsil = .FALSE. zeu = .TRUE. zue = .FALSE. fpol = .FALSE. electron_phonon=' ' elph_nbnd_min = 1 elph_nbnd_max = 0 el_ph_sigma = 0.02 el_ph_nsigma = 30 el_ph_ngauss = 1 lraman = .FALSE. elop = .FALSE. max_seconds = 1.E+7_DP reduce_io = .FALSE. CALL get_env( 'ESPRESSO_TMPDIR', outdir ) IF ( TRIM( outdir ) == ' ' ) outdir = './' prefix = 'pwscf' fildyn = 'matdyn' fildrho = ' ' fildvscf = ' ' ldisp = .FALSE. nq1 = 0 nq2 = 0 nq3 = 0 dek = 1.0d-3 nogg = .FALSE. recover = .FALSE. asr = .FALSE. start_irr = 0 last_irr = -1000 start_q = 1 last_q =-1000 ldiag =.FALSE. lqdir =.FALSE. search_sym =.TRUE. nk1 = 0 nk2 = 0 nk3 = 0 k1 = 0 k2 = 0 k3 = 0 ! drho_star%open = .FALSE. drho_star%basis = 'modes' drho_star%pat = .TRUE. drho_star%ext = 'drho' CALL get_env( 'ESPRESSO_FILDRHO_DIR', drho_star%dir) IF ( TRIM( drho_star%dir ) == ' ' ) & drho_star%dir = TRIM(outdir)//"/Rotated_DRHO/" ! dvscf_star%open = .FALSE. dvscf_star%basis = 'modes' dvscf_star%pat = .FALSE. dvscf_star%ext = 'dvscf' CALL get_env( 'ESPRESSO_FILDVSCF_DIR', dvscf_star%dir) IF ( TRIM( dvscf_star%dir ) == ' ' ) & dvscf_star%dir = TRIM(outdir)//"/Rotated_DVSCF/" ! ! ... reading the namelist inputph ! IF (ionode) READ( 5, INPUTPH, IOSTAT = ios ) ! CALL mp_bcast(ios, ionode_id, world_comm) CALL errore( 'phq_readin', 'reading inputph namelist', ABS( ios ) ) ! IF (ionode) tmp_dir = trimcheck (outdir) drho_star%dir=trimcheck(drho_star%dir) dvscf_star%dir=trimcheck(dvscf_star%dir) ! filename for the star must always be automatically generated: IF(drho_star%ext(1:5)/='auto:') drho_star%ext = 'auto:'//drho_star%ext IF(dvscf_star%ext(1:5)/='auto:') dvscf_star%ext = 'auto:'//dvscf_star%ext CALL bcast_ph_input ( ) CALL mp_bcast(nogg, ionode_id, world_comm ) ! ! ... Check all namelist variables ! IF (tr2_ph <= 0.D0) CALL errore (' phq_readin', ' Wrong tr2_ph ', 1) IF (eth_rps<= 0.D0) CALL errore ( 'phq_readin', ' Wrong eth_rps', 1) IF (eth_ns <= 0.D0) CALL errore ( 'phq_readin', ' Wrong eth_ns ', 1) DO iter = 1, maxter IF (alpha_mix (iter) .LT.0.D0.OR.alpha_mix (iter) .GT.1.D0) CALL & errore ('phq_readin', ' Wrong alpha_mix ', iter) ENDDO IF (niter_ph.LT.1.OR.niter_ph.GT.maxter) CALL errore ('phq_readin', & ' Wrong niter_ph ', 1) IF (nmix_ph.LT.1.OR.nmix_ph.GT.5) CALL errore ('phq_readin', ' Wrong & &nmix_ph ', 1) IF (iverbosity.NE.0.AND.iverbosity.NE.1) CALL errore ('phq_readin', & &' Wrong iverbosity ', 1) IF (fildyn.EQ.' ') CALL errore ('phq_readin', ' Wrong fildyn ', 1) IF (max_seconds.LT.0.1D0) CALL errore ('phq_readin', ' Wrong max_seconds', 1) IF (modenum < 0) CALL errore ('phq_readin', ' Wrong modenum ', 1) IF (dek <= 0.d0) CALL errore ( 'phq_readin', ' Wrong dek ', 1) ! SELECT CASE( trim( electron_phonon ) ) CASE( 'simple' ) elph=.true. elph_mat=.false. elph_simple=.true. CASE( 'Wannier' ) elph=.true. elph_mat=.true. elph_simple=.false. auxdvscf=trim(fildvscf) CASE( 'interpolated' ) elph=.true. elph_mat=.false. elph_simple=.false. CASE DEFAULT elph=.false. elph_mat=.false. elph_simple=.false. END SELECT epsil = epsil .OR. lraman .OR. elop IF (modenum /= 0) search_sym=.FALSE. if(elph_simple.or.elph_mat) then trans=.false. else trans = trans .OR. ldisp endif ! ! Set default value for fildrho and fildvscf if they are required IF ( (lraman.OR.elop.OR.drho_star%open) .AND. fildrho == ' ') fildrho = 'drho' IF ( (elph_mat.OR.dvscf_star%open) .AND. fildvscf == ' ') fildvscf = 'dvscf' ! ! We can calculate dielectric, raman or elop tensors and no Born effective ! charges dF/dE, but we cannot calculate Born effective charges dF/dE ! without epsil. ! IF (zeu) zeu = epsil ! ! reads the q point (just if ldisp = .false.) ! IF (ionode) THEN IF (.NOT. ldisp) & READ (5, *, iostat = ios) (xq (ipol), ipol = 1, 3) END IF CALL mp_bcast(ios, ionode_id, world_comm) CALL errore ('phq_readin', 'reading xq', ABS (ios) ) CALL mp_bcast(xq, ionode_id, world_comm ) IF (.NOT.ldisp) THEN lgamma = xq (1) .EQ.0.D0.AND.xq (2) .EQ.0.D0.AND.xq (3) .EQ.0.D0 IF ( (epsil.OR.zue) .AND..NOT.lgamma) CALL errore ('phq_readin', & 'gamma is needed for elec.field', 1) ENDIF IF (zue.AND..NOT.trans) CALL errore ('phq_readin', 'trans must be & &.t. for Zue calc.', 1) IF (trans.AND.(lrpa.OR.lnoloc)) CALL errore('phq_readin', & 'only dielectric constant with lrpa or lnoloc',1) IF (lrpa.or.lnoloc) THEN zeu=.FALSE. lraman=.FALSE. elop = .FALSE. ENDIF ! ! reads the frequencies ( just if fpol = .true. ) ! IF ( fpol ) THEN nfs=0 IF (ionode) THEN READ (5, *, iostat = ios) card IF ( TRIM(card)=='FREQUENCIES'.OR. & TRIM(card)=='frequencies'.OR. & TRIM(card)=='Frequencies') THEN READ (5, *, iostat = ios) nfs ENDIF ENDIF CALL mp_bcast(ios, ionode_id, world_comm ) CALL errore ('phq_readin', 'reading number of FREQUENCIES', ABS(ios) ) CALL mp_bcast(nfs, ionode_id, world_comm ) if (nfs < 1) call errore('phq_readin','Too few frequencies',1) ALLOCATE(fiu(nfs)) IF (ionode) THEN IF ( TRIM(card) == 'FREQUENCIES' .OR. & TRIM(card) == 'frequencies' .OR. & TRIM(card) == 'Frequencies' ) THEN DO i = 1, nfs READ (5, *, iostat = ios) fiu(i) END DO END IF END IF CALL mp_bcast(ios, ionode_id, world_comm) CALL errore ('phq_readin', 'reading FREQUENCIES card', ABS(ios) ) CALL mp_bcast(fiu, ionode_id, world_comm ) ELSE nfs=1 ALLOCATE(fiu(1)) fiu=0.0_DP END IF ! ! ! Here we finished the reading of the input file. ! Now allocate space for pwscf variables, read and check them. ! ! amass will also be read from file: ! save its content in auxiliary variables ! amass_input(:)= amass(:) ! tmp_dir_save=tmp_dir tmp_dir_ph= TRIM (tmp_dir) // '_ph' // TRIM(int_to_char(my_image_id)) //'/' CALL create_directory(tmp_dir_ph) ext_restart=.FALSE. ext_recover=.FALSE. IF (recover) THEN CALL ph_readfile('init',0,0,ierr) IF (ierr /= 0 ) THEN recover=.FALSE. goto 1001 ENDIF tmp_dir=tmp_dir_ph CALL check_restart_recover(ext_recover, ext_restart) tmp_dir=tmp_dir_save IF (ldisp) lgamma = (current_iq==1) ! ! If there is a restart or a recover file ph.x has saved its own data-file ! and we read the initial information from that file ! IF ((ext_recover.OR.ext_restart).AND..NOT.lgamma) & tmp_dir=tmp_dir_ph u_from_file=.true. ENDIF 1001 CONTINUE CALL read_file ( ) ! ! init_start_grid returns .true. if a new k-point grid is set from values ! read from input (this happens if nk1*nk2*nk3, else it returns .false., ! leaves the current values, as read in read_file, unchanged) ! newgrid = reset_grid (nk1, nk2, nk3, k1, k2, k3) ! tmp_dir=tmp_dir_save ! IF (modenum > 3*nat) CALL errore ('phq_readin', ' Wrong modenum ', 2) IF (gamma_only) CALL errore('phq_readin',& 'cannot start from pw.x data file using Gamma-point tricks',1) IF (lda_plus_u) CALL errore('phq_readin',& 'The phonon code with LDA+U is not yet available',1) IF (okpaw.and.(lraman.or.elop)) CALL errore('phq_readin',& 'The phonon code with paw and raman or elop is not yet available',1) IF (okpaw.and.noncolin.and.domag) CALL errore('phq_readin',& 'The phonon code with paw and domag is not available yet',1) IF (okvan.and.(lraman.or.elop)) CALL errore('phq_readin',& 'The phonon code with US-PP and raman or elop not yet available',1) IF (noncolin.and.(lraman.or.elop)) CALL errore('phq_readin', & 'lraman, elop, and noncolin not programed',1) IF (lmovecell) CALL errore('phq_readin', & 'The phonon code is not working after vc-relax',1) IF (nproc_image /= nproc_image_file .and. .not. twfcollect) & CALL errore('phq_readin',& 'pw.x run with a different number of processors. Use wf_collect=.true.',1) IF (nproc_pool /= nproc_pool_file .and. .not. twfcollect) & CALL errore('phq_readin',& 'pw.x run with a different number of pools. Use wf_collect=.true.',1) IF (ntask_groups > 1) & CALL errore('phq_readin','task_groups not available in phonon',1) IF (nproc_bgrp_file /= nproc_pool_file) & CALL errore('phq_readin','band parallelization not available in phonon',1) IF (elph.and.nimage>1) CALL errore('phq_readin',& 'el-ph with image parallelization is not yet available',1) if(elph_mat.and.fildvscf.eq.' ') call errore('phq_readin',& 'el-ph with wannier requires fildvscf',1) IF(elph_mat.and.npool.ne.1) call errore('phq_readin',& 'el-ph with wannier : pools not implemented',1) IF (elph.OR.fildvscf /= ' ') lqdir=.TRUE. IF(dvscf_star%open.and.nimage>1) CALL errore('phq_readin',& 'dvscf_star with image parallelization is not yet available',1) IF(drho_star%open.and.nimage>1) CALL errore('phq_readin',& 'drho_star with image parallelization is not yet available',1) IF (.NOT.ldisp) lqdir=.FALSE. IF (i_cons /= 0) & CALL errore('phq_readin',& 'The phonon code with constrained magnetization is not yet available',1) IF (two_fermi_energies .AND. (ltetra .OR. lgauss)) & CALL errore('phq_readin',& 'The phonon code with two fermi energies is not available for metals',1) IF (tqr) CALL errore('phq_readin',& 'The phonon code with Q in real space not available',1) IF (start_irr < 0 ) CALL errore('phq_readin', 'wrong start_irr',1) ! IF (start_q <= 0 ) CALL errore('phq_readin', 'wrong start_q',1) ! ! the dynamical matrix is written in xml format if fildyn ends in ! .xml or in the noncollinear case. ! xmldyn=has_xml(fildyn) IF (noncolin) xmldyn=.TRUE. ! ! If a band structure calculation needs to be done do not open a file ! for k point ! IF (reduce_io) io_level=0 lkpoint_dir=.FALSE. restart = recover ! ! set masses to values read from input, if available; ! leave values read from file otherwise ! DO it = 1, ntyp IF (amass_input(it) < 0.0_DP) amass_input(it)= & atom_weight(atomic_number(TRIM(atm(it)))) IF (amass_input(it) > 0.D0) amass(it) = amass_input(it) IF (amass(it) <= 0.D0) CALL errore ('phq_readin', 'Wrong masses', it) ENDDO lgamma_gamma=.FALSE. IF (.NOT.ldisp) THEN IF (nkstot==1.OR.(nkstot==2.AND.nspin==2)) THEN lgamma_gamma=(lgamma.AND.(ABS(xk(1,1))<1.D-12) & .AND.(ABS(xk(2,1))<1.D-12) & .AND.(ABS(xk(3,1))<1.D-12) ) ENDIF IF (nogg) lgamma_gamma=.FALSE. IF ((nat_todo /= 0) .and. lgamma_gamma) CALL errore( & 'phq_readin', 'gamma_gamma tricks with nat_todo & & not available. Use nogg=.true.', 1) ! IF (lgamma) THEN nksq = nks ELSE nksq = nks / 2 ENDIF ENDIF IF (lgamma_gamma.AND.ldiag) CALL errore('phq_readin','incompatible flags',1) ! IF (tfixed_occ) & CALL errore('phq_readin','phonon with arbitrary occupations not tested',1) ! IF (elph.AND..NOT.lgauss) CALL errore ('phq_readin', 'Electron-& &phonon only for metals', 1) ! IF (elph.AND.fildvscf.EQ.' ') CALL errore ('phq_readin', 'El-ph needs & ! &a DeltaVscf file', 1) ! There might be other variables in the input file which describe ! partial computation of the dynamical matrix. Read them here ! CALL allocate_part ( nat ) ! IF ( nat_todo < 0 .OR. nat_todo > nat ) & CALL errore ('phq_readin', 'nat_todo is wrong', 1) IF (nat_todo.NE.0) THEN IF (ionode) & READ (5, *, iostat = ios) (atomo (na), na = 1, & nat_todo) CALL mp_bcast(ios, ionode_id, world_comm ) CALL errore ('phq_readin', 'reading atoms', ABS (ios) ) CALL mp_bcast(atomo, ionode_id, world_comm ) ENDIF nat_todo_input=nat_todo IF (epsil.AND.lgauss) & CALL errore ('phq_readin', 'no elec. field with metals', 1) IF (modenum > 0) THEN IF ( ldisp ) & CALL errore('phq_readin','Dispersion calculation and & & single mode calculation not possibile !',1) nat_todo = 0 ENDIF IF (modenum > 0 .OR. lraman ) lgamma_gamma=.FALSE. IF (.NOT.lgamma_gamma) asr=.FALSE. ! IF (ldisp .AND. (nq1 .LE. 0 .OR. nq2 .LE. 0 .OR. nq3 .LE. 0)) & CALL errore('phq_readin','nq1, nq2, and nq3 must be greater than 0',1) ! CALL save_ph_input_variables() RETURN ! END SUBROUTINE phq_readin GWW/head/lanczos_k.f900000644000077300007730000002262612341332532015224 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! subroutine lanczos_state_k(ik,nstates, nsteps,in_states,d,f,omat,dpsi_ipol, t_out) !this subroutine perform nsteps collective lanczos iterations !on orthonormal zstates state ! k points version USE io_global, ONLY : stdout, ionode, ionode_id USE io_files, ONLY : prefix USE kinds, ONLY : DP USE wannier_gw USE gvect USE constants, ONLY : e2, pi, tpi, fpi USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2 USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx USE wavefunctions_module, ONLY : evc, psic USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : mpime, world_comm USE gvecs, ONLY : nls, nlsm, doublegrid USE g_psi_mod, ONLY : h_diag, s_diag USE uspp, ONLY : vkb, nkb, okvan USE klist, ONLY : xk USE noncollin_module, ONLY : noncolin, npol implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER, INTENT(in) :: ik!k point INTEGER, INTENT(in) :: nstates!number of states INTEGER, INTENT(in) :: nsteps!number of Lanczos iteration to be performed COMPLEX(kind=DP), INTENT(in) :: in_states(npwx,nstates)!states for starting lanczos chains COMPLEX(kind=DP), INTENT(out) :: d(nsteps,nstates)!diagonal part COMPLEX(kind=DP), INTENT(out) :: f(nsteps,nstates)!off-diagonal part COMPLEX(kind=DP), INTENT(out) :: omat(nsteps,3,nstates)!overlaps COMPLEX(kind=DP), INTENT(in) :: dpsi_ipol(npwx,nstates,3)!other r|\Psi_v> states COMPLEX(kind=DP), INTENT(out) :: t_out(npwx,nsteps,nstates)!complete orthonormal basis COMPLEX(kind=DP), ALLOCATABLE :: psi_1(:,:),psi_2(:,:),psi_3(:,:),spsi(:,:) COMPLEX(kind=DP), ALLOCATABLE :: u_0(:,:),u_1(:,:) COMPLEX(kind=DP), ALLOCATABLE :: alpha(:), delta(:) REAL(kind=DP), ALLOCATABLE :: gamma(:), n_1(:), beta(:) REAL(kind=DP), ALLOCATABLE :: c(:) INTEGER :: is,ig,ii,jj,it,ipol INTEGER :: iunlan COMPLEX(kind=DP) :: csca allocate(psi_1(npwx,nstates),psi_2(npwx,nstates),psi_3(npwx,nstates)) allocate(u_0(npwx,nstates),u_1(npwx,nstates)) allocate(alpha(nstates),beta(nstates),gamma(nstates),n_1(nstates),delta(nstates)) allocate(c(nstates)) allocate(spsi(npwx,nstates)) t_out(:,:,:)=(0.d0,0.d0) !first step psi_1(1:npw,1:nstates)=in_states(1:npw,1:nstates) !calculate n_1 n_1(:)=0.d0 do is=1,nstates do ig=1,npw n_1(is)=n_1(is)+dble(conjg(psi_1(ig,is))*psi_1(ig,is)) enddo enddo call mp_sum(n_1(:),world_comm) n_1(:)=dsqrt(n_1(:)) do is=1,nstates psi_1(1:npw,is)=psi_1(1:npw,is)/n_1(is) enddo !for h_psi allocations are required ALLOCATE( h_diag( npwx, npol ) ) ALLOCATE( s_diag( npwx, npol ) ) ! ! !npw and igk should already been read!! IF ( nkb > 0 ) CALL init_us_2( npw, igk, xk(1,ik), vkb ) do ig = 1, npw g2kin (ig) = ( (xk (1,ik ) + g (1,igk (ig)) ) **2 + & (xk (2,ik ) + g (2,igk (ig)) ) **2 + & (xk (3,ik ) + g (3,igk (ig)) ) **2 ) * tpiba2 enddo !calculate H|\phi_i> !call h_psi( npw, npw, nstates,psi_1(:,:), u_0 ) call h_psiq (npwx, npw, nstates, psi_1, u_0, spsi) if(l_scissor) then call h_psi_scissor( ik,npwx, npw, nstates, psi_1, u_0 ) endif !calculate n_1 n_1(:)=0.d0 do is=1,nstates do ig=1,npw n_1(is)=n_1(is)+dble(conjg(u_0(ig,is))*u_0(ig,is)) enddo enddo call mp_sum(n_1(:),world_comm) n_1(:)=dsqrt(n_1(:)) write(stdout,*) 'Lanczos N1', n_1(:) call flush_unit(stdout) !calculate alpha alpha(:)=(0.d0,0.d0) do is=1,nstates do ig=1,npw alpha(is)=alpha(is)+conjg(psi_1(ig,is))*u_0(ig,is) enddo enddo call mp_sum(alpha(:),world_comm) alpha(:)=alpha(:)/n_1(:) write(stdout,*) 'Lanczos alpha', alpha(:) call flush_unit(stdout) !calculate psi_2 and beta do is=1,nstates psi_2(1:npw,is)=u_0(1:npw,is)/n_1(is)-alpha(is)*psi_1(1:npw,is) enddo beta(:)=0.d0 do is=1,nstates do ig=1,npw beta(is)=beta(is)+dble(conjg(psi_2(ig,is))*psi_2(ig,is)) enddo enddo call mp_sum(beta(:),world_comm) beta(:)=dsqrt(beta(:)) write(stdout,*) 'Lanczos beta', beta(:) call flush_unit(stdout) do is=1,nstates psi_2(:,is)=psi_2(:,is)/beta(is) enddo !calculate d d(:,:)=0.d0 do is=1,nstates do ig=1,npw d(1,is)=d(1,is)+conjg(psi_1(ig,is))*u_0(ig,is) enddo enddo do is=1,nstates call mp_sum(d(1,is),world_comm) enddo write(stdout,*) 'Lanczos Diagonal 1', d(1,:) call flush_unit(stdout) !calculate f f(:,:)=(0.d0,0.d0) do is=1,nstates do ig=1,npw f(1,is)=f(1,is)+conjg(psi_2(ig,is))*u_0(ig,is) enddo call mp_sum(f(1,is),world_comm) enddo write(stdout,*) 'ATTENZIONE1' call flush_unit(stdout) omat(:,:,:)=(0.d0,0.d0) do is=1,nstates do ipol=1,3 call zgemm('C','N',1,1,npw,(1.d0,0.d0),dpsi_ipol(:,is,ipol),npwx,psi_1(:,is),npwx,(0.d0,0.d0),omat(1,ipol,is),1) call zgemm('C','N',1,1,npw,(1.d0,0.d0),dpsi_ipol(:,is,ipol),npwx,psi_2(:,is),npwx,(0.d0,0.d0),omat(2,ipol,is),1) enddo t_out(1:npw,1,is)=psi_1(1:npw,is) t_out(1:npw,2,is)=psi_2(1:npw,is) end do call mp_sum(omat(1:2,1:3,1:nstates),world_comm) !do iterate do it=2,nsteps write(stdout,*) 'lanczos h_psi' call flush_unit(stdout) !calculate H|\phi_i+1> !call h_psi( npw, npw, nstates,psi_2(:,:), u_1 ) call h_psiq (npwx, npw, nstates, psi_2, u_1, spsi) if(l_scissor) then call h_psi_scissor( ik,npwx, npw, nstates, psi_2, u_1 ) endif write(stdout,*) 'lanczos alfa beta gamma' call flush_unit(stdout) !calculate n_1 n_1(:)=0.d0 do is=1,nstates do ig=1,npw n_1(is)=n_1(is)+dble(conjg(u_1(ig,is))*u_1(ig,is)) enddo enddo call mp_sum(n_1(:),world_comm) n_1(:)=dsqrt(n_1(:)) !calculate alpha alpha(:)=(0.d0,0.d0) do is=1,nstates do ig=1,npw alpha(is)=alpha(is)+conjg(psi_1(ig,is))*u_1(ig,is) enddo enddo call mp_sum(alpha(:),world_comm) alpha(:)=alpha(:)/n_1(:) !calculate beta delta(:)=(0.d0,0.d0) do is=1,nstates do ig=1,npw delta(is)=delta(is)+conjg(psi_2(ig,is))*u_1(ig,is) enddo enddo call mp_sum(delta(:),world_comm) delta(:)=delta(:)/n_1(:) !calculate psi_3 and gamma do is=1,nstates psi_3(1:npw,is)=u_1(1:npw,is)/n_1(is)-alpha(is)*psi_1(1:npw,is)-delta(is)*psi_2(1:npw,is) enddo gamma(:)=0.d0 do is=1,nstates do ig=1,npw gamma(is)=gamma(is)+dble(conjg(psi_3(ig,is))*psi_3(ig,is)) enddo enddo call mp_sum(gamma(:),world_comm) gamma(:)=dsqrt(gamma(:)) do is=1,nstates psi_3(:,is)=psi_3(:,is)/gamma(is) enddo write(stdout,*) 'lanczos d f omat' call flush_unit(stdout) !calculate d do is=1,nstates do ig=1,npw d(it,is)=d(it,is)+dble(conjg(psi_2(ig,is))*u_1(ig,is)) enddo call mp_sum(d(it,is),world_comm) enddo !calculate f do is=1,nstates do ig=1,npw f(it,is)=f(it,is)+conjg(psi_3(ig,is))*u_1(ig,is) enddo call mp_sum(f(it,is),world_comm) enddo if(it/=nsteps) then do is=1,nstates do ipol=1,3 call zgemm('C','N',1,1,npw,(1.d0,0.d0),dpsi_ipol(:,is,ipol),npwx,psi_3(:,is),npwx,(0.d0,0.d0),& &omat(it+1,ipol,is),1) enddo t_out(1:npw,it+1,is)=psi_3(1:npw,is) end do call mp_sum(omat(it+1,1:3,1:nstates),world_comm) endif !update arrays psi_1(:,:)=psi_2(:,:) psi_2(:,:)=psi_3(:,:) u_0(:,:)=u_1(:,:) enddo deallocate(psi_1,psi_2,psi_3) deallocate(u_0,u_1) deallocate(alpha,beta,gamma,n_1) deallocate(c) deallocate(delta) deallocate(h_diag,s_diag) deallocate(spsi) return end subroutine lanczos_state_k subroutine h_psi_scissor( ik,lda, n, m, psi, hpsi ) !NOT_TO_BE_INCLUDED_START !add to hpsi part dur to self-consistent GW calculation ! ... input ! ... lda leading dimension of arrays psi, spsi, hpsi ! ... n true dimension of psi, spsi, hpsi ! ... m number of states psi ! ... psi ! ... output: ! ... hpsi H*psi USE kinds, ONLY : DP USE gvect, ONLY : gstart USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx,et USE wavefunctions_module, ONLY : evc USE wannier_gw, ONLY : scissor USE mp, ONLY : mp_sum USE mp_world, ONLY : world_comm USE control_ph, ONLY : nbnd_occ implicit none INTEGER, INTENT(in) :: ik!k point INTEGER, INTENT(IN) :: lda, n, m COMPLEX(kind=DP), INTENT(IN) :: psi(lda,m) COMPLEX(kind=DP), INTENT(OUT) :: hpsi(lda,m) INTEGER :: ii,jj REAL(kind=DP), ALLOCATABLE :: prod(:,:) allocate(prod(nbnd_occ(ik),m)) prod=0.d0 call dgemm('T','N', nbnd_occ(ik),m,2*npw,2.d0,evc,2*npwx,psi,2*lda,0.d0,prod,nbnd_occ(ik)) do ii=1,nbnd_occ(ik) do jj=1,m if(gstart==2) prod(ii,jj)=prod(ii,jj)-dble(conjg(evc(1,ii))*psi(1,jj)) enddo enddo call mp_sum(prod,world_comm) do jj=1,m do ii=1,nbnd_occ(ik) prod(ii,jj)=prod(ii,jj)*scissor enddo enddo call dgemm('N','N',2*npw,m,nbnd_occ(ik),1.d0,evc,2*npwx,prod,nbnd_occ(ik),1.d0,hpsi,2*lda) deallocate(prod) return !NOT_TO_BE_INCLUDED_END end subroutine h_psi_scissor GWW/head/bcast_ph_input.f900000644000077300007730000000775012341332532016244 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! ! !----------------------------------------------------------------------- subroutine bcast_ph_input ( ) !----------------------------------------------------------------------- ! ! In this routine the first processor sends the phonon input to all ! the other processors ! ! #ifdef __PARA use mp, only: mp_bcast use mp_world, only: world_comm USE mp_global, only : intra_image_comm USE control_ph, ONLY : start_irr, last_irr, start_q, last_q, nmix_ph, & niter_ph, lnoloc, alpha_mix, tr2_ph, lrpa, recover, & ldisp, reduce_io, zue, zeu, epsil, trans, & lgamma USE gamma_gamma, ONLY : asr USE disp, ONLY : nq1, nq2, nq3 USE partial, ONLY : nat_todo USE freq_ph, ONLY : fpol USE output, ONLY : fildvscf, fildyn, fildrho use io_files, ONLY : tmp_dir, prefix USE control_flags, only: iverbosity, modenum USE ramanm, ONLY: lraman, elop, dek, eth_rps, eth_ns USE input_parameters, ONLY: max_seconds USE ions_base, ONLY : amass USE io_global, ONLY : ionode_id USE run_info, ONLY : title USE wannier_gw, ONLY : l_head, omega_gauss, n_gauss, grid_type, nsteps_lanczos,& &second_grid_n,second_grid_i,l_scissor,scissor implicit none ! ! logicals ! call mp_bcast (lgamma, ionode_id, world_comm ) call mp_bcast (epsil, ionode_id, world_comm ) call mp_bcast (trans, ionode_id, world_comm ) call mp_bcast (zue, ionode_id, world_comm ) call mp_bcast (zeu, ionode_id, world_comm ) call mp_bcast (reduce_io, ionode_id, world_comm ) call mp_bcast (ldisp, ionode_id, world_comm ) call mp_bcast (lraman, ionode_id, world_comm ) call mp_bcast (elop, ionode_id, world_comm ) call mp_bcast (fpol, ionode_id, world_comm ) call mp_bcast (recover, ionode_id, world_comm ) call mp_bcast (asr, ionode_id, world_comm ) call mp_bcast (lrpa, ionode_id, world_comm ) call mp_bcast (lnoloc, ionode_id, world_comm ) ! ! integers ! call mp_bcast (start_irr, ionode_id, world_comm ) call mp_bcast (last_irr, ionode_id, world_comm ) call mp_bcast (start_q, ionode_id, world_comm ) call mp_bcast (last_q, ionode_id, world_comm ) call mp_bcast (niter_ph, ionode_id, world_comm ) call mp_bcast (nmix_ph, ionode_id, world_comm ) call mp_bcast (iverbosity, ionode_id, world_comm ) call mp_bcast (modenum, ionode_id, world_comm ) call mp_bcast (nat_todo, ionode_id, world_comm ) CALL mp_bcast( nq1, ionode_id, world_comm ) CALL mp_bcast( nq2, ionode_id, world_comm ) CALL mp_bcast( nq3, ionode_id, world_comm ) ! ! real*8 ! call mp_bcast (tr2_ph, ionode_id, world_comm ) call mp_bcast (eth_rps, ionode_id, world_comm ) call mp_bcast (eth_ns, ionode_id, world_comm ) call mp_bcast (amass, ionode_id, world_comm ) call mp_bcast (alpha_mix, ionode_id, world_comm ) call mp_bcast (max_seconds, ionode_id, world_comm ) call mp_bcast (dek, ionode_id, world_comm ) ! ! characters ! call mp_bcast (title, ionode_id, world_comm ) call mp_bcast (fildyn, ionode_id, world_comm ) call mp_bcast (fildvscf, ionode_id, world_comm ) call mp_bcast (fildrho, ionode_id, world_comm ) call mp_bcast (tmp_dir, ionode_id, world_comm ) call mp_bcast (prefix, ionode_id, world_comm ) ! ! head and wings ! call mp_bcast(l_head, ionode_id, world_comm) call mp_bcast(omega_gauss, ionode_id, world_comm) call mp_bcast(n_gauss, ionode_id, world_comm) call mp_bcast(grid_type, ionode_id, world_comm) call mp_bcast(nsteps_lanczos, ionode_id, world_comm) call mp_bcast(second_grid_n, ionode_id, world_comm) call mp_bcast(second_grid_i, ionode_id, world_comm) call mp_bcast(l_scissor, ionode_id, world_comm) call mp_bcast(scissor, ionode_id, world_comm) #endif return end subroutine bcast_ph_input GWW/head/openfilq.f900000644000077300007730000001603712341332532015055 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! ! !---------------------------------------------------------------------------- SUBROUTINE openfilq() !---------------------------------------------------------------------------- ! ! ... This subroutine opens all the files necessary for the phononq ! ... calculation. ! USE kinds, ONLY : DP USE control_flags, ONLY : io_level, modenum USE units_ph, ONLY : iuwfc, iudwf, iubar, iucom, iudvkb3, & iudrhous, iuebar, iudrho, iudyn, iudvscf, & lrwfc, lrdwf, lrbar, lrcom, lrdvkb3, & lrdrhous, lrebar, lrdrho ! USE io_files, ONLY : tmp_dir USE control_ph, ONLY : epsil, zue, ext_recover, trans, lgamma, & tmp_dir_ph, start_irr, last_irr USE save_ph, ONLY : tmp_dir_save USE qpoint, ONLY : nksq USE output, ONLY : fildyn, fildvscf USE wvfct, ONLY : nbnd, npwx USE lsda_mod, ONLY : nspin USE uspp, ONLY : nkb, okvan USE io_files, ONLY : prefix,tmp_dir, iunigk,diropn,seqopn USE noncollin_module, ONLY : npol, nspin_mag USE control_flags, ONLY : twfcollect USE mp_global, ONLY : me_pool USE io_global, ONLY : ionode USE ramanm, ONLY: lraman, elop, iuchf, iud2w, iuba2, lrchf, lrd2w, lrba2 USE wannier_gw, ONLY : l_head USE fft_base, ONLY : dfftp, dffts USE buffers, ONLY : open_buffer ! IMPLICIT NONE ! INTEGER :: ios ! integer variable for I/O control CHARACTER (len=256) :: filint ! the name of the file LOGICAL :: exst, exst_mem ! logical variable to check file existe ! REAL(DP) :: edum(1,1), wdum(1,1) INTEGER :: ndr, ierr ! ! IF (LEN_TRIM(prefix) == 0) CALL errore ('openfilq', 'wrong prefix', 1) ! ! There are six direct access files to be opened in the tmp area ! ! The file with the wavefunctions. In the lgamma case reads those ! written by pw.x. In the other cases those calculated by ph.x ! tmp_dir=tmp_dir_ph IF (lgamma.AND.modenum==0) tmp_dir=tmp_dir_save ! iuwfc = 20 ! lrwfc = 2 * nbnd * npwx * npol ! CALL diropn (iuwfc, 'wfc', lrwfc, exst) iuwfc = 20 lrwfc = nbnd * npwx * npol CALL open_buffer (iuwfc, 'wfc', lrwfc, io_level, exst_mem, exst, tmp_dir) IF (.NOT.exst.AND..NOT.exst_mem) THEN CALL errore ('openfilq', 'file '//trim(prefix)//'.wfc not found', 1) END IF ! IF (.NOT.exst) THEN ! CALL errore ('openfilq', 'file '//trim(prefix)//'.wfc not found', 1) ! END IF ! ! From now on all files are written with the _ph prefix ! tmp_dir=tmp_dir_ph ! ! The file with deltaV_{bare} * psi ! ! iubar = 21 ! lrbar = 2 * nbnd * npwx * npol ! CALL diropn (iubar, 'bar', lrbar, exst) ! IF (ext_recover.AND..NOT.exst) & ! CALL errore ('openfilq','file '//trim(prefix)//'.bar not found', 1) iubar = 21 lrbar = nbnd * npwx * npol CALL open_buffer (iubar, 'bar', lrbar, io_level, exst_mem, exst, tmp_dir) IF (ext_recover.AND..NOT.exst) & CALL errore ('openfilq','file '//trim(prefix)//'.bar not found', 1) ! ! The file with the solution delta psi ! ! iudwf = 22 ! lrdwf = 2 * nbnd * npwx * npol ! CALL diropn (iudwf, 'dwf', lrdwf, exst) ! IF (ext_recover.AND..NOT.exst) & ! CALL errore ('openfilq','file '//trim(prefix)//'.dwf not found', 1) iudwf = 22 lrdwf = nbnd * npwx * npol CALL open_buffer (iudwf, 'dwf', lrdwf, io_level, exst_mem, exst, tmp_dir) IF (ext_recover.AND..NOT.exst) & CALL errore ('openfilq','file '//trim(prefix)//'.dwf not found', 1) ! ! open a file with the static change of the charge ! IF (okvan) THEN iudrhous = 25 lrdrhous = 2 * dfftp%nnr * nspin_mag CALL diropn (iudrhous, 'prd', lrdrhous, exst) IF (ext_recover.AND..NOT.exst) & CALL errore ('openfilq','file '//trim(prefix)//'.prd not found', 1) ENDIF ! ! Optional file(s) containing Delta\rho (opened and written in solve_e ! and solve_linter). Used for third-order calculations. ! iudrho = 23 lrdrho = 2 * dfftp%nr1x * dfftp%nr2x * dfftp%nr3x * nspin_mag ! ! ! Here the sequential files ! ! The igk at a given k (and k+q if q!=0) ! iunigk = 24 IF (nksq > 1) CALL seqopn (iunigk, 'igk', 'unformatted', exst) ! ! a formatted file which contains the dynamical matrix in cartesian ! coordinates is opened in the current directory ! ... by the first node only, other nodes write on unit 6 (i.e./dev/null ! exception: electron-phonon calculation from saved data ! (iudyn is read, not written, by all nodes) ! IF ( ( .NOT. ionode ) .AND. (trans) ) THEN iudyn = 6 GOTO 400 ENDIF IF ((trans.AND.(start_irr/=0.OR.last_irr/=0))) THEN iudyn = 26 OPEN (unit=iudyn, file=fildyn, status='unknown', err=100, iostat=ios) 100 CALL errore ('openfilq', 'opening file'//fildyn, ABS (ios) ) REWIND (iudyn) ENDIF ! ! An optional file for electron-phonon calculations containing deltaVscf ! 400 IF (fildvscf.NE.' ') THEN iudvscf = 27 IF ( me_pool == 0 ) THEN CALL diropn (iudvscf, fildvscf, lrdrho, exst) END IF END IF ! ! In the USPP case we need two files for the Commutator, the first is ! given by filbar and a second which just contains P_c x |psi>, ! which is required for the calculation of the Born effective carges ! IF (okvan .AND. (epsil .OR. zue .OR. l_head)) THEN iucom = 28 lrcom = 2 * nbnd * npwx * npol CALL diropn (iucom, 'com', lrcom, exst) IF (ext_recover.AND..NOT.exst) & CALL errore ('openfilq', 'file '//trim(prefix)//'.com not found', 1) ! ! In the USPP case we also need a file in order to store derivatives ! of kb projectors ! iudvkb3 = 29 lrdvkb3 = 2 * npwx * nkb * 3 CALL diropn (iudvkb3, 'dvkb3', lrdvkb3, exst) IF (ext_recover.AND..NOT.exst) & CALL errore ('openfilq', 'file '//trim(prefix)//'.dvkb3 not found', 1) ENDIF IF (epsil .OR. zue .OR. l_head) THEN ! iuebar = 30 ! lrebar = 2 * nbnd * npwx * npol ! CALL diropn (iuebar, 'ebar', lrebar, exst) ! IF (ext_recover.AND..NOT.exst) & ! CALL errore ('openfilq','file '//trim(prefix)//'.ebar not found', 1) iuebar = 30 lrebar = nbnd * npwx * npol CALL open_buffer (iuebar, 'ebar', lrebar, io_level, exst_mem, exst, tmp_dir) IF (ext_recover.AND..NOT.exst) & CALL errore ('openfilq','file '//trim(prefix)//'.ebar not found', 1) ENDIF ! ! files used by raman calculation ! IF (lraman .OR.elop) THEN iuchf = 31 lrchf = 2 * nbnd * npwx * npol CALL diropn (iuchf, 'cwf', lrchf, exst) iud2w = 32 lrd2w = 2 * nbnd * npwx * npol CALL diropn (iud2w, 'd2w', lrd2w, exst) iuba2 = 33 lrba2 = 2 * nbnd * npwx * npol CALL diropn(iuba2, 'ba2', lrba2, exst) ENDIF RETURN ! END SUBROUTINE openfilq GWW/head/head.f900000644000077300007730000001117512341332532014137 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! ! !----------------------------------------------------------------------- PROGRAM head !----------------------------------------------------------------------- ! ! ... This is the main driver of the phonon code. ! ... It reads all the quantities calculated by pwscf, it ! ... checks if some recover file is present and determines ! ... which calculation needs to be done. Finally, it makes ! ... a loop over the q points. At a generic q, if necessary it ! ... recalculates the band structure calling pwscf again. ! ... Then it can calculate the response to an atomic displacement, ! ... the dynamical matrix at that q, and the electron-phonon ! ... interaction at that q. At q=0 it can calculate the linear response ! ... to an electric field perturbation and hence the dielectric ! ... constant, the Born effective charges and the polarizability ! ... at imaginary frequencies. ! ... At q=0, from the second order response to an electric field, ! ... it can calculate also the electro-optic and the raman tensors. ! ... Presently implemented: ! ... dynamical matrix (q/=0) NC [4], US [4], PAW [3] ! ... dynamical matrix (q=0) NC [5], US [5], PAW [3] ! ... dielectric constant NC [5], US [5], PAW [3] ! ... born effective charges NC [5], US [5], PAW [3] ! ... polarizability (iu) NC [2], US [2] ! ... elctron-phonon NC [3], US [3] ! ... electro-optic NC [1] ! ... raman tensor NC [1] ! ! NC = norm conserving pseudopotentials ! US = ultrasoft pseudopotentials ! PAW = projector augmented-wave ! [1] LDA, [2] [1]+GGA, [3] [2]+LSDA/sGGA, [4] [3]+Spin-orbit/nonmagnetic, ! [5] [4]+Spin-orbit/magnetic ! USE io_global, ONLY : stdout USE disp, ONLY : nqs USE control_ph, ONLY : epsil, trans, bands_computed, ldisp USE output, ONLY : fildrho USE check_stop, ONLY : check_stop_init USE ph_restart, ONLY : ph_writefile, destroy_status_run USE save_ph, ONLY : clean_input_variables USE mp_global, ONLY: mp_startup, nimage !USE path_io_routines, ONLY : io_path_start USE environment, ONLY: environment_start USE wannier_gw, ONLY : l_head USE control_ph, ONLY : epsil, trans, qplot, only_init, & only_wfc USE el_phon, ONLY : elph, elph_mat, elph_simple ! IMPLICIT NONE ! INTEGER :: iq,ierr LOGICAL :: do_band, do_iq, setup_pw CHARACTER (LEN=9) :: code = 'PHONON' CHARACTER (LEN=256) :: auxdyn ! ! Initialize MPI, clocks, print initial messages ! #ifdef __MPI CALL mp_startup ( ) !IF (nimage>1) CALL io_path_start() #endif CALL environment_start ( code ) ! WRITE( stdout, '(/5x,"Ultrasoft (Vanderbilt) Pseudopotentials")' ) ! ! ... and begin with the initialization part ! CALL phq_readin() ! CALL check_stop_init() ! ! ... Checking the status of the calculation and if necessary initialize ! ... the q mesh ! CALL check_initial_status(auxdyn) ! ldisp=.false. DO iq = 1, nqs ! CALL prepare_q(auxdyn, do_band, do_iq, setup_pw, iq) ! ! If this q is not done in this run, cycle ! IF (.NOT.do_iq) CYCLE ! ! If necessary the bands are recalculated ! !IF (setup_pw) CALL run_pwscf(do_band) IF (setup_pw) CALL run_nscf(do_band, iq) ! ! Initialize the quantities which do not depend on ! the linear response of the system CALL initialize_ph() ! ! electric field perturbation ! IF (epsil) CALL phescf() if(l_head) then call solve_head endif ! ! phonon perturbation ! !IF ( trans ) THEN ! ! ! CALL phqscf() ! CALL dynmatrix() ! ! ! IF ( fildrho /= ' ' ) CALL punch_plot_ph() ! ! !END IF ! ! electron-phonon interaction ! !IF ( elph ) THEN ! ! ! IF ( .NOT. trans ) THEN ! ! ! CALL dvanqq() ! CALL elphon() ! ! ! END IF ! ! ! CALL elphsum() ! ! !END IF ! ! ... cleanup of the variables for the next q point ! CALL clean_pw_ph(iq) ! END DO CALL ph_writefile('init',0,0,ierr) CALL collect_grid_files() CALL destroy_status_run() ! IF (bands_computed) CALL print_clock_pw() ! CALL stop_ph( .TRUE. ) ! STOP ! END PROGRAM head GWW/head/Makefile0000644000077300007730000000212312341332532014347 0ustar giannozzgiannozz# Makefile for head (head.x) # # Author G. Stenuit # include ../../make.sys # location of include files IFLAGS=-I../../include # location of needed modules MODFLAGS= $(MOD_FLAG)../../iotk/src $(MOD_FLAG)../../Modules \ $(MOD_FLAG)../../PHonon/PH $(MOD_FLAG)../../PW/src \ $(MOD_FLAG). #location of needed libraries LIBOBJS= ../../iotk/src/libiotk.a ../../flib/flib.a \ ../../clib/clib.a ../../flib/ptools.a HEADOBJS = \ bcast_ph_input.o \ close_phq.o \ lanczos_k.o \ openfilq.o \ phq_readin.o \ solve_head.o QEMODS = ../../Modules/libqemod.a LIBPWPH = ../../PHonon/PH/libph.a ../../PW/src/libpw.a LIBMIN= ../minpack/minpacklib.a TLDEPS= bindir mods libs pw ph all : tldeps head.x head.x : head.o $(LIBOBJS) $(HEADOBJS) $(LIBPWPH) $(LIBMIN) $(LD) $(LDFLAGS) -o head.x head.o \ $(HEADOBJS) $(LIBPWPH) $(QEMODS) $(LIBOBJS) $(LIBMIN) $(LIBS) - ( cd ../../bin ; ln -fs ../GWW/head/head.x . ) tldeps : if test -n "$(TLDEPS)" ; then \ ( cd ../.. ; $(MAKE) $(TLDEPS) || exit 1 ) ; fi clean : - /bin/rm -fv *.x *.o *.a *~ *.F90 *.d *.mod *.i *.L include make.depend GWW/head/close_phq.f900000644000077300007730000000514612341332532015214 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! ! !---------------------------------------------------------------------------- SUBROUTINE close_phq( flag ) !---------------------------------------------------------------------------- ! ! ... Close all files. ! ... Called at the end of the run with flag=.TRUE. (removes 'recover') ! ... or during execution with flag=.FALSE. (does not remove 'recover') ! USE io_files, ONLY : iunigk USE control_flags, ONLY : twfcollect USE mp_global, ONLY : me_pool USE io_global, ONLY : ionode, stdout USE uspp, ONLY : okvan USE units_ph, ONLY : iuwfc, iudwf, iubar, iudrhous, iuebar, iudrho, & iudvscf, iucom, iudvkb3 USE control_ph, ONLY : zue, epsil USE recover_mod, ONLY : clean_recover USE output, ONLY : fildrho, fildvscf USE ramanm, ONLY : lraman, elop, iuchf, iud2w, iuba2 USE wannier_gw, ONLY : l_head ! IMPLICIT NONE ! LOGICAL :: flag LOGICAL :: exst ! ! IF ( twfcollect ) THEN ! CLOSE( UNIT = iuwfc, STATUS = 'DELETE' ) ! ELSE ! CLOSE( UNIT = iuwfc, STATUS = 'KEEP' ) ! END IF ! IF (flag) THEN CLOSE( UNIT = iudwf, STATUS = 'DELETE' ) CLOSE( UNIT = iubar, STATUS = 'DELETE' ) ! IF ( okvan ) CLOSE( UNIT = iudrhous, STATUS = 'DELETE' ) ! IF ( epsil .OR. zue .OR. l_head) THEN CLOSE( UNIT = iuebar, STATUS = 'DELETE' ) IF (okvan) CLOSE( UNIT = iucom, STATUS = 'DELETE' ) IF (okvan) CLOSE( UNIT = iudvkb3, STATUS = 'DELETE' ) ENDIF ELSE CLOSE( UNIT = iudwf, STATUS = 'KEEP' ) CLOSE( UNIT = iubar, STATUS = 'KEEP' ) ! IF ( okvan ) CLOSE( UNIT = iudrhous, STATUS = 'KEEP' ) ! IF ( epsil .OR. zue .OR. l_head) THEN CLOSE( UNIT = iuebar, STATUS = 'KEEP' ) IF (okvan) CLOSE( UNIT = iucom, STATUS = 'KEEP' ) IF (okvan) CLOSE( UNIT = iudvkb3, STATUS = 'KEEP' ) ENDIF ENDIF ! IF ( ionode .AND. & fildrho /= ' ') CLOSE( UNIT = iudrho, STATUS = 'KEEP' ) ! IF ( flag ) CALL clean_recover() ! IF ( fildvscf /= ' ' ) CLOSE( UNIT = iudvscf, STATUS = 'KEEP' ) ! IF (lraman .OR.elop) THEN CLOSE ( UNIT=iuchf, STATUS = 'keep' ) CLOSE ( UNIT=iud2w, STATUS = 'keep' ) CLOSE ( UNIT=iuba2, STATUS = 'keep' ) ENDIF ! CLOSE( UNIT = iunigk, STATUS = 'DELETE' ) ! RETURN ! END SUBROUTINE close_phq GWW/head/solve_head.f900000644000077300007730000004034512341332532015350 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! ! !----------------------------------------------------------------------- subroutine solve_head !----------------------------------------------------------------------- ! !calculates the head and wings of the dielectric matrix ! USE ions_base, ONLY : nat USE io_global, ONLY : stdout, ionode,ionode_id USE io_files, ONLY : diropn,prefix, iunigk, tmp_dir use pwcom USE check_stop, ONLY : max_seconds USE wavefunctions_module, ONLY : evc USE kinds, ONLY : DP USE becmod, ONLY : becp,calbec USE uspp_param, ONLY : nhm use phcom USE wannier_gw, ONLY : n_gauss, omega_gauss, grid_type,& nsteps_lanczos,second_grid_n,second_grid_i,& l_scissor,scissor USE control_ph, ONLY : tr2_ph USE gvect, ONLY : ig_l2g USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : world_comm, mpime, nproc USE uspp, ONLY : nkb, vkb ! USE symme, ONLY: s USE mp_pools, ONLY : inter_pool_comm, intra_pool_comm USE symme, only : crys_to_cart, symmatrix USE mp_wave, ONLY : mergewf,splitwf USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft USE buffers, ONLY : get_buffer USE constants, ONLY : rytoev implicit none INTEGER, EXTERNAL :: find_free_unit real(DP) :: thresh, anorm, averlt, dr2 ! thresh: convergence threshold ! anorm : the norm of the error ! averlt: average number of iterations ! dr2 : self-consistency error complex(DP) , allocatable :: ps (:,:) logical :: conv_root, exst ! conv_root: true if linear system is converged integer :: kter, iter0, ipol,jpol, ibnd, jbnd, iter, lter, & ik, ig, irr, ir, is, nrec, ios ! counters integer :: ltaver, lintercall real(DP) :: tcpu, get_clock ! timing variables ! the name of the file with the mixing potential external ch_psi_all, cg_psi REAL(kind=DP), ALLOCATABLE :: head(:,:),head_tmp(:) COMPLEX(kind=DP) :: sca, sca2 REAL(kind=DP), ALLOCATABLE :: x(:),w(:), freqs(:) COMPLEX(kind=DP), ALLOCATABLE :: e_head(:,:)!wing of symmetric dielectric matrix (for G of local processor) COMPLEX(kind=DP), ALLOCATABLE :: e_head_g(:),e_head_g_tmp(:,:,:) COMPLEX(kind=DP), ALLOCATABLE :: e_head_pol(:,:,:) INTEGER :: i, j,k,iun REAL(kind=DP) :: ww, weight COMPLEX(kind=DP), ALLOCATABLE :: tmp_g(:) COMPLEX(kind=DP), ALLOCATABLE :: psi_v(:,:), prod(:) COMPLEX(kind=DP), ALLOCATABLE :: pola_charge(:,:,:,:) COMPLEX(kind=DP), ALLOCATABLE :: dpsi_ipol(:,:,:) REAL(kind=DP), ALLOCATABLE :: epsilon_g(:,:,:) INTEGER :: i_start,idumm,idumm1,idumm2,idumm3,ii REAL(kind=DP) :: rdumm COMPLEX(kind=DP), ALLOCATABLE :: d(:,:),f(:,:),omat(:,:,:) INTEGER :: iv, info COMPLEX(kind=DP), ALLOCATABLE :: z_dl(:),z_d(:),z_du(:),z_b(:) COMPLEX(kind=DP) :: csca, csca1 COMPLEX(kind=DP), ALLOCATABLE :: t_out(:,:,:), psi_tmp(:) INTEGER :: n INTEGER :: npwx_g write(stdout,*) 'Routine solve_head' call flush_unit(stdout) if(grid_type==5) then n=n_gauss n_gauss=n+second_grid_n*(1+second_grid_i*2) endif allocate(e_head(npw,n_gauss+1)) allocate(e_head_pol(ngm,n_gauss+1,3)) e_head(:,:) =(0.d0,0.d0) allocate(x(2*n_gauss+1),w(2*n_gauss+1), freqs(n_gauss+1)) allocate(head(n_gauss+1,3),head_tmp(n_gauss+1)) head(:,:)=0.d0 allocate(psi_v(dffts%nnr, nbnd), prod(dfftp%nnr)) allocate (tmp_g(ngm)) allocate( pola_charge(dfftp%nnr,nspin,3,n_gauss+1)) allocate(epsilon_g(3,3,n_gauss+1)) allocate(psi_tmp(npwx)) epsilon_g(:,:,:)=0.d0 e_head_pol(:,:,:)=0.d0 pola_charge(:,:,:,:)=0.d0 !setup Gauss Legendre frequency grid !IT'S OF CAPITAL IMPORTANCE TO NULLIFY THE FOLLOWING ARRAYS x(:)=0.d0 w(:)=0.d0 if(grid_type==0) then call legzo(n_gauss*2+1,x,w) freqs(1:n_gauss+1)=-x(n_gauss+1:2*n_gauss+1)*omega_gauss else if(grid_type==2) then call legzo(n_gauss,x,w) freqs(1) = 0.d0 freqs(2:n_gauss+1)=(1.d0-x(1:n_gauss))*omega_gauss/2.d0 else if(grid_type==3) then!equally spaced grid freqs(1) = 0.d0 do i=1,n_gauss freqs(1+i)=omega_gauss*dble(i)/dble(n_gauss) enddo else if(grid_type==4) then!equally spaced grid shifted of 1/2 freqs(1) = 0.d0 do i=1,n_gauss freqs(i+1)=(omega_gauss/dble(n_gauss))*dble(i)-(0.5d0*omega_gauss/dble(n_gauss)) enddo else!equally spaced grid more dense at -1 , 0 and 1 freqs(1)=0.d0 ii=2 do i=1,second_grid_n freqs(ii)=(omega_gauss/dble(2*second_grid_n*n))*dble(i)-0.5d0*omega_gauss/dble(2*second_grid_n*n) ii=ii+1 enddo do j=1,second_grid_i do i=1,second_grid_n freqs(ii)=(omega_gauss/dble(2*second_grid_n*n))*dble(i+second_grid_n+2*second_grid_n*(j-1))& &-0.5d0*omega_gauss/dble(2*second_grid_n*n) ii=ii+1 enddo freqs(ii)=omega_gauss/dble(n)*dble(j) ii=ii+1 do i=1,second_grid_n freqs(ii)=(omega_gauss/dble(2*second_grid_n*n))*dble(i+2*second_grid_n*j)& &-0.5d0*omega_gauss/dble(2*second_grid_n*n) ii=ii+1 enddo enddo do i=second_grid_i+1,n freqs(ii)=omega_gauss/dble(n)*dble(i) ii=ii+1 enddo ! freqs(1)=0.d0 ! do i=1,10 ! freqs(i+1)=(omega_gauss/dble(10*n))*dble(i)-0.5d0*omega_gauss/dble(10*n) ! enddo ! freqs(11+1)=omega_gauss/dble(n) ! do i=1,5 ! freqs(i+12)=(omega_gauss/dble(10*n))*dble(i)+ omega_gauss/dble(n)-0.5d0*omega_gauss/dble(10*n) ! enddo ! do i=2,n ! freqs(16+i)=(omega_gauss/dble(n))*dble(i) ! enddo endif do i=1,n_gauss+1 write(stdout,*) 'Freq',i,freqs(i) enddo CALL flush_unit( stdout ) deallocate(x,w) head(:,:)=0.d0 !if (lsda) call errore ('solve_head', ' LSDA not implemented', 1) call start_clock ('solve_head') allocate (ps (nbnd,nbnd)) ps (:,:) = (0.d0, 0.d0) IF (ionode .AND. fildrho /= ' ') THEN INQUIRE (UNIT = iudrho, OPENED = exst) IF (exst) CLOSE (UNIT = iudrho, STATUS='keep') CALL DIROPN (iudrho, TRIM(fildrho)//'.E', lrdrho, exst) end if ! ! ! if q=0 for a metal: allocate and compute local DOS at Ef ! if (degauss.ne.0.d0.or..not.lgamma) call errore ('solve_e', & 'called in the wrong case', 1) ! ! ! only one iteration is required ! if(.not.l_scissor) scissor=0.d0 !loop on k points if (nksq.gt.1) rewind (unit = iunigk) do ik=1, nksq allocate (dpsi_ipol(npwx,nbnd_occ(ik),3)) allocate(t_out(npwx,nsteps_lanczos,nbnd_occ(ik))) write(stdout,*) 'ik:', ik call flush_unit(stdout) weight = wk (ik) ww = fpi * weight / omega if (lsda) current_spin = isk (ik) if (nksq.gt.1) then read (iunigk, err = 100, iostat = ios) npw, igk 100 call errore ('solve_head', 'reading igk', abs (ios) ) endif ! ! reads unperturbed wavefuctions psi_k in G_space, for all bands ! ! if (nksq.gt.1) call davcio (evc, lrwfc, iuwfc, ik, - 1) if (nksq.gt.1) call get_buffer(evc, lrwfc, iuwfc, ik) npwq = npw call init_us_2 (npw, igk, xk (1, ik), vkb) !trasform valence wavefunctions to real space do ibnd=1,nbnd psi_v(:,ibnd) = ( 0.D0, 0.D0 ) psi_v(nls(igk(1:npw)),ibnd) = evc(1:npw,ibnd) CALL invfft ('Wave', psi_v(:,ibnd), dffts) enddo ! ! compute the kinetic energy ! do ig = 1, npwq g2kin (ig) = ( (xk (1,ik ) + g (1,igk (ig)) ) **2 + & (xk (2,ik ) + g (2,igk (ig)) ) **2 + & (xk (3,ik ) + g (3,igk (ig)) ) **2 ) * tpiba2 enddo ! dpsi_ipol(:,:,:)=(0.d0,0.d0) !loop on carthesian directions do ipol = 1,3 write(stdout,*) 'ipol:', ipol call flush_unit(stdout) ! ! computes/reads P_c^+ x psi_kpoint into dvpsi array ! do jpol=1,3 call dvpsi_e (ik, jpol) ! ! Orthogonalize dvpsi to valence states: ps = ! CALL ZGEMM( 'C', 'N', nbnd_occ (ik), nbnd_occ (ik), npw, & (1.d0,0.d0), evc(1,1), npwx, dvpsi(1,1), npwx, (0.d0,0.d0), & ps(1,1), nbnd ) #ifdef __PARA !call reduce (2 * nbnd * nbnd_occ (ik), ps) call mp_sum(ps(1:nbnd_occ (ik),1:nbnd_occ (ik)),world_comm) #endif ! dpsi is used as work space to store S|evc> ! !CALL ccalbec (nkb, npwx, npw, nbnd_occ(ik), becp, vkb, evc) CALL calbec(npw,vkb,evc,becp,nbnd_occ(ik)) CALL s_psi (npwx, npw, nbnd_occ(ik), evc, dpsi) ! ! |dvpsi> = - (|dvpsi> - S|evc>) ! note the change of sign! ! CALL ZGEMM( 'N', 'N', npw, nbnd_occ(ik), nbnd_occ(ik), & (1.d0,0.d0), dpsi(1,1), npwx, ps(1,1), nbnd, (-1.d0,0.d0), & dvpsi(1,1), npwx ) !create lanczos chain for dvpsi dpsi_ipol(1:npw,1:nbnd_occ(ik),jpol)=dvpsi(1:npw,1:nbnd_occ(ik)) enddo dvpsi(1:npw,1:nbnd_occ(ik))=dpsi_ipol(1:npw,1:nbnd_occ(ik),ipol) allocate(d(nsteps_lanczos,nbnd_occ(ik)),f(nsteps_lanczos,nbnd_occ(ik))) allocate(omat(nsteps_lanczos,3,nbnd_occ(ik))) write(stdout,*) 'before lanczos_state_k' call lanczos_state_k(ik,nbnd_occ(ik), nsteps_lanczos ,dvpsi,d,f,omat,dpsi_ipol,t_out) write(stdout,*) 'after lanczos_state_k' !loop on frequency allocate(z_dl(nsteps_lanczos-1),z_d(nsteps_lanczos),z_du(nsteps_lanczos-1),z_b(nsteps_lanczos)) do i=1,n_gauss+1 !loop on valence states do iv=1,nbnd_occ(ik) !invert Hamiltonian z_dl(1:nsteps_lanczos-1)=conjg(f(1:nsteps_lanczos-1,iv)) z_du(1:nsteps_lanczos-1)=f(1:nsteps_lanczos-1,iv) z_d(1:nsteps_lanczos)=d(1:nsteps_lanczos,iv)+dcmplx(-et(iv,ik)-scissor/rytoev,freqs(i)) z_b(:)=(0.d0,0.d0) z_b(1)=dble(omat(1,ipol,iv)) call zgtsv(nsteps_lanczos,1,z_dl,z_d,z_du,z_b,nsteps_lanczos,info) if(info/=0) then write(stdout,*) 'problems with ZGTSV' call flush_unit(stdout) stop endif do jpol=1,3 !multiply with overlap factors call zgemm('T','N',1,1,nsteps_lanczos,(1.d0,0.d0),omat(:,jpol,iv),nsteps_lanczos& &,z_b,nsteps_lanczos,(0.d0,0.d0),csca,1) !update epsilon array NO SYMMETRIES for the moment epsilon_g(jpol,ipol,i)=epsilon_g(jpol,ipol,i)+4.d0*ww*dble(csca) enddo !update part for wing calculation call zgemm('N','N',npw,1,nsteps_lanczos,(1.d0,0.d0),t_out(:,:,iv),npwx,z_b,nsteps_lanczos,& &(0.d0,0.d0),psi_tmp,npwx) !fourier trasform prod(:) = ( 0.D0, 0.D0 ) prod(nls(igk(1:npw))) = psi_tmp(1:npw) CALL invfft ('Wave', prod, dffts) ! product dpsi * psi_v prod(1:dffts%nnr)=conjg(prod(1:dffts%nnr))*psi_v(1:dffts%nnr,iv) if(doublegrid) then call cinterpolate(prod,prod,1) endif !US part STLL TO BE ADDED!! pola_charge(1:dffts%nnr,1,ipol,i)=pola_charge(1:dffts%nnr,1,ipol,i)-prod(1:dffts%nnr)*ww enddo enddo deallocate(z_dl,z_d,z_du,z_b) deallocate(d,f,omat) enddo deallocate(dpsi_ipol) deallocate(t_out) enddo !print out results ! ! symmetrize ! do i=1,n_gauss+1 WRITE( stdout,'(/,10x,"Unsymmetrized in crystal axis ",/)') WRITE( stdout,'(10x,"(",3f15.5," )")') ((epsilon_g(ipol,jpol,i),& & ipol=1,3),jpol=1,3) ! call symtns (epsilon_g(:,:,i), nsym, s) ! ! pass to cartesian axis ! WRITE( stdout,'(/,10x,"Symmetrized in crystal axis ",/)') WRITE( stdout,'(10x,"(",3f15.5," )")') ((epsilon_g(ipol,jpol,i),& & ipol=1,3),jpol=1,3) ! call trntns (epsilon_g(:,:,i), at, bg, 1) call crys_to_cart ( epsilon_g(:,:,i) ) call symmatrix ( epsilon_g(:,:,i)) ! ! add the diagonal part ! ! do ipol = 1, 3 ! epsilon (ipol, ipol) = epsilon (ipol, ipol) + 1.d0 ! enddo ! ! and print the result ! WRITE( stdout, '(/,10x,"Dielectric constant in cartesian axis ",/)') WRITE( stdout, '(10x,"(",3f18.9," )")') ((epsilon_g(ipol,jpol,i), ipol=1,3), jpol=1,3) head(i,1)=epsilon_g(1,1,i) head(i,2)=epsilon_g(2,2,i) head(i,3)=epsilon_g(3,3,i) #ifdef __PARA call mp_sum ( pola_charge(:,:,:,i) , inter_pool_comm ) call psyme (pola_charge(:,:,:,i)) #else call syme (pola_charge(:,:,:,i)) #endif do ipol=1,3 CALL fwfft ('Dense', pola_charge(1:dfftp%nnr,1,ipol,i), dfftp) tmp_g(:)=(0.d0,0.d0) !tmp_g(gstart:npw)=pola_charge(nl(igk(gstart:ngm)),1,ipol,i) tmp_g(gstart:ngm)=pola_charge(nl(gstart:ngm),1,ipol,i) sca=(0.d0,0.d0) do ig=1,ngm sca=sca+conjg(tmp_g(ig))*tmp_g(ig) enddo call mp_sum(sca,world_comm) write(stdout,*) 'POLA SCA', sca,ngm !loop on frequency do ig=gstart,ngm e_head_pol(ig,i,ipol)=-4.d0*tmp_g(ig) enddo enddo !TD writes on files if(ionode) then write(stdout,*) 'HEAD:',freqs(i),head(i,1),head(i,2),head(i,3) write(stdout,*) 'E_HEAD :', i write(stdout,*) i,e_head_pol(2,i,1) write(stdout,*) i,e_head_pol(2,i,2) write(stdout,*) i,e_head_pol(2,i,3) endif call flush_unit(stdout) enddo !writes on file head if(ionode) then iun = find_free_unit() open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.head', status='unknown',form='unformatted') write(iun) n_gauss write(iun) omega_gauss write(iun) freqs(1:n_gauss+1) write(iun) head(1:n_gauss+1,1) write(iun) head(1:n_gauss+1,2) write(iun) head(1:n_gauss+1,3) close(iun) endif !writes on file wings !collect data !calculate total number of G for wave function npwx_g=ngm call mp_sum(npwx_g,world_comm) allocate(e_head_g(ngm_g)) if(ionode) then iun = find_free_unit() open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.e_head', status='unknown',form='unformatted') write(iun) n_gauss write(iun) omega_gauss write(iun) freqs(1:n_gauss+1) write(iun) npwx_g endif call mp_barrier( world_comm ) do ipol=1,3 do i=1,n_gauss+1 e_head_g(:)=(0.d0,0.d0) call mergewf(e_head_pol(:,i,ipol),e_head_g ,ngm,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) if(ionode) then ! do ig=1,npwx_g write(iun) e_head_g(1:npwx_g) ! enddo endif enddo enddo call mp_barrier( world_comm ) write(stdout,*) 'ATT02' if(ionode) close(iun) ! if(ionode) then ! open( unit= iun, file=trim(tmp_dir)//trim(prefix)////'.e_head', status='old',position='rewind',form='unformatted') ! read(iun) idumm ! read(iun) rdumm ! read(iun) head_tmp(1:n_gauss+1) ! read(iun) idumm ! allocate(e_head_g_tmp(n_gauss+1,npwx_g,3)) ! do ipol=1,3 ! do ii=1,n_gauss+1 ! do ig=1,npwx_g ! read(iun) e_head_g_tmp(ii,ig,ipol) ! enddo ! enddo ! enddo ! rewind(iun) ! write(iun) n_gauss ! write(iun) omega_gauss ! write(iun) freqs(1:n_gauss+1) ! write(iun) npwx_g ! do ipol=1,3 ! do ig=1,npwx_g ! write(iun) e_head_g_tmp(1:n_gauss+1,ig,ipol) ! enddo ! enddo close(iun) ! deallocate(e_head_g_tmp) ! endif call mp_barrier( world_comm ) write(stdout,*) 'ATT1' deallocate(e_head_g) deallocate(psi_tmp) deallocate(prod) deallocate (ps) deallocate(psi_v) deallocate(pola_charge) deallocate(head,head_tmp,freqs) deallocate(e_head, tmp_g) deallocate(epsilon_g) deallocate(e_head_pol) call mp_barrier( world_comm ) write(stdout,*) 'ATT2' call stop_clock ('solve_head') return end subroutine solve_head GWW/head/make.depend0000644000077300007730000001027512341332532015014 0ustar giannozzgiannozzbcast_ph_input.o : ../../Modules/control_flags.o bcast_ph_input.o : ../../Modules/input_parameters.o bcast_ph_input.o : ../../Modules/io_files.o bcast_ph_input.o : ../../Modules/io_global.o bcast_ph_input.o : ../../Modules/ions_base.o bcast_ph_input.o : ../../Modules/mp.o bcast_ph_input.o : ../../Modules/mp_global.o bcast_ph_input.o : ../../Modules/mp_world.o bcast_ph_input.o : ../../Modules/run_info.o bcast_ph_input.o : ../../Modules/wannier_gw.o bcast_ph_input.o : ../../PHonon/PH/phcom.o bcast_ph_input.o : ../../PHonon/PH/ramanm.o close_phq.o : ../../Modules/control_flags.o close_phq.o : ../../Modules/io_files.o close_phq.o : ../../Modules/io_global.o close_phq.o : ../../Modules/mp_global.o close_phq.o : ../../Modules/uspp.o close_phq.o : ../../Modules/wannier_gw.o close_phq.o : ../../PHonon/PH/phcom.o close_phq.o : ../../PHonon/PH/ramanm.o close_phq.o : ../../PHonon/PH/write_rec.o head.o : ../../Modules/check_stop.o head.o : ../../Modules/environment.o head.o : ../../Modules/io_global.o head.o : ../../Modules/mp_global.o head.o : ../../Modules/wannier_gw.o head.o : ../../PHonon/PH/elph.o head.o : ../../PHonon/PH/ph_restart.o head.o : ../../PHonon/PH/phcom.o head.o : ../../PHonon/PH/save_ph_input.o lanczos_k.o : ../../Modules/cell_base.o lanczos_k.o : ../../Modules/constants.o lanczos_k.o : ../../Modules/io_files.o lanczos_k.o : ../../Modules/io_global.o lanczos_k.o : ../../Modules/kind.o lanczos_k.o : ../../Modules/mp.o lanczos_k.o : ../../Modules/mp_world.o lanczos_k.o : ../../Modules/noncol.o lanczos_k.o : ../../Modules/recvec.o lanczos_k.o : ../../Modules/uspp.o lanczos_k.o : ../../Modules/wannier_gw.o lanczos_k.o : ../../Modules/wavefunctions.o lanczos_k.o : ../../PHonon/PH/phcom.o lanczos_k.o : ../../PW/src/g_psi_mod.o lanczos_k.o : ../../PW/src/pwcom.o openfilq.o : ../../Modules/control_flags.o openfilq.o : ../../Modules/fft_base.o openfilq.o : ../../Modules/io_files.o openfilq.o : ../../Modules/io_global.o openfilq.o : ../../Modules/kind.o openfilq.o : ../../Modules/mp_global.o openfilq.o : ../../Modules/noncol.o openfilq.o : ../../Modules/uspp.o openfilq.o : ../../Modules/wannier_gw.o openfilq.o : ../../PHonon/PH/phcom.o openfilq.o : ../../PHonon/PH/ramanm.o openfilq.o : ../../PHonon/PH/save_ph_input.o openfilq.o : ../../PW/src/buffers.o openfilq.o : ../../PW/src/pwcom.o phq_readin.o : ../../Modules/control_flags.o phq_readin.o : ../../Modules/input_parameters.o phq_readin.o : ../../Modules/io_files.o phq_readin.o : ../../Modules/io_global.o phq_readin.o : ../../Modules/ions_base.o phq_readin.o : ../../Modules/kind.o phq_readin.o : ../../Modules/mp.o phq_readin.o : ../../Modules/mp_bands.o phq_readin.o : ../../Modules/mp_global.o phq_readin.o : ../../Modules/mp_images.o phq_readin.o : ../../Modules/mp_pools.o phq_readin.o : ../../Modules/mp_world.o phq_readin.o : ../../Modules/noncol.o phq_readin.o : ../../Modules/parameters.o phq_readin.o : ../../Modules/paw_variables.o phq_readin.o : ../../Modules/run_info.o phq_readin.o : ../../Modules/uspp.o phq_readin.o : ../../Modules/wannier_gw.o phq_readin.o : ../../Modules/xml_io_base.o phq_readin.o : ../../PHonon/PH/dfile_star.o phq_readin.o : ../../PHonon/PH/elph.o phq_readin.o : ../../PHonon/PH/ph_restart.o phq_readin.o : ../../PHonon/PH/phcom.o phq_readin.o : ../../PHonon/PH/ramanm.o phq_readin.o : ../../PHonon/PH/save_ph_input.o phq_readin.o : ../../PW/src/ldaU.o phq_readin.o : ../../PW/src/pwcom.o phq_readin.o : ../../PW/src/start_k.o solve_head.o : ../../Modules/becmod.o solve_head.o : ../../Modules/check_stop.o solve_head.o : ../../Modules/constants.o solve_head.o : ../../Modules/fft_base.o solve_head.o : ../../Modules/fft_interfaces.o solve_head.o : ../../Modules/io_files.o solve_head.o : ../../Modules/io_global.o solve_head.o : ../../Modules/ions_base.o solve_head.o : ../../Modules/kind.o solve_head.o : ../../Modules/mp.o solve_head.o : ../../Modules/mp_pools.o solve_head.o : ../../Modules/mp_wave.o solve_head.o : ../../Modules/mp_world.o solve_head.o : ../../Modules/recvec.o solve_head.o : ../../Modules/uspp.o solve_head.o : ../../Modules/wannier_gw.o solve_head.o : ../../Modules/wavefunctions.o solve_head.o : ../../PHonon/PH/phcom.o solve_head.o : ../../PW/src/buffers.o solve_head.o : ../../PW/src/pwcom.o solve_head.o : ../../PW/src/symme.o GWW/Makefile0000644000077300007730000000106412341332532013451 0ustar giannozzgiannozzinclude ../make.sys all: libminpack pw4gwwa heada gwwa libminpack: ( cd minpack ; $(MAKE) all || exit 1 ) pw4gwwa: ( cd pw4gww ; $(MAKE) all || exit 1 ) heada: libminpack ( cd head ; $(MAKE) all || exit 1 ) gwwa: ( cd gww ; $(MAKE) all || exit 1 ) clean: ( cd pw4gww ; $(MAKE) clean ) ( cd head ; $(MAKE) clean ) ( cd gww ; $(MAKE) clean ) ( cd minpack ; $(MAKE) clean ) doc: if test -d Doc ; then \ (cd Doc ; $(MAKE) all || exit 1 ) ; fi doc_clean: if test -d Doc ; then \ (cd Doc ; $(MAKE) clean ) ; fi distclean: clean doc_clean GWW/pw4gww/0000755000077300007730000000000012341332543013251 5ustar giannozzgiannozzGWW/pw4gww/diago_cg_g.f900000644000077300007730000003470312341332532015640 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !---------------------------------------------------------------------------- SUBROUTINE diago_cg_g(ndim,omat,smat,maxter,max_state,e,ovec,cutoff,ethr,found_state,l_para) !---------------------------------------------------------------------------- ! ! ... "poor man" iterative diagonalization of a genralized real symmetric matrix O and S ! ... through preconditioned conjugate gradient algorithm ! ... Band-by-band algorithm with minimal use of memory ! USE constants, ONLY : pi USE kinds, ONLY : DP USE io_global, ONLY : stdout USE mp_world, ONLY : mpime,nproc,world_comm USE mp, ONLY : mp_sum USE random_numbers, ONLY : randy ! IMPLICIT NONE ! ! ... I/O variables ! INTEGER, INTENT(in) :: ndim!matrix dimension REAL(kind=DP), INTENT(in) :: omat(ndim,ndim)!matrix to be diagonalized REAL(kind=DP), INTENT(in) :: smat(ndim,ndim)!overlap matrix INTEGER, INTENT(in) ::maxter!maximum number of iterations INTEGER, INTENT(in) :: max_state!maximum number of eigenvectors to be found REAL(kind=DP),INTENT(inout) :: e(ndim)!eigenvalues REAL(kind=DP), INTENT(inout) :: ovec(ndim,max_state)!eigenvector REAL(kind=DP),INTENT(in) :: cutoff!found eigenvalues larger than cutoff REAL (DP), INTENT(IN) :: ethr!threshold for convergence INTEGER, INTENT(out) :: found_state!number of states found LOGICAL, INTENT(in) :: l_para!if true omat is distributed among processors ! ! ... local variables ! INTEGER :: i, j, m, iter, moved, iw, ig REAL (DP), ALLOCATABLE :: lagrange(:) REAL (DP), ALLOCATABLE :: hpsi(:), spsi(:), g(:), cg(:), & scg(:), ppsi(:), g0(:) REAL (DP) :: psi_norm, a0, b0, gg0, gamma, gg, gg1, & cg0, e0, es(2) REAL (DP) :: theta, cost, sint, cos2t, sin2t LOGICAL :: reorder=.true. LOGICAL :: l_all_ok, l_first_out INTEGER :: m_first_out, delta_first_out=10000 INTEGER :: l_blk,nbegin,nend,nsize REAL(kind=DP)::avg_iter INTEGER :: notconv REAL(kind=DP), ALLOCATABLE :: aux(:,:) REAL (DP) :: rtmp(2) REAL (DP), ALLOCATABLE :: hr(:,:,:), sr(:,:) REAL (DP), ALLOCATABLE :: en(:),ctmp(:) REAL(kind=DP) :: rr REAL(kind=DP), ALLOCATABLE :: ovec2(:,:) ! ! ... external functions ! REAL (DP), EXTERNAL :: DDOT ! ! CALL start_clock( 'diago_cg' ) ! ! ! ALLOCATE( spsi( ndim ) ) ALLOCATE( scg( ndim ) ) ALLOCATE( hpsi( ndim ) ) ALLOCATE( g( ndim ) ) ALLOCATE( cg( ndim ) ) ALLOCATE( g0( ndim ) ) ALLOCATE( ppsi( ndim ) ) ! ALLOCATE( lagrange( max_state) ) ! avg_iter = 0.D0 notconv = 0 moved = 0 l_all_ok=.true. l_first_out=.false. ! ! ... every eigenfunction is calculated separately ! write(stdout,*) 'ATTENZIONE1' call flush_unit(stdout) l_blk= (ndim)/nproc if(l_blk*nproc < ndim) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 if(nend > ndim) nend=ndim nsize=nend-nbegin+1 !initialization DO iw = 1, max_state DO ig = 1, ndim rr = randy()!rndm() ovec(ig,iw)=rr END DO END DO allocate(aux(ndim,2)) ALLOCATE( hr( max_state, max_state, 2 ) ) ALLOCATE( sr( max_state, max_state ) ) ALLOCATE( en( max_state) ,ctmp(max_state)) DO m = 1, max_state call gradient(ovec(1:ndim,m),aux(1:ndim,1)) !aux(:,2)=ovec(:,m) call gradient_s(ovec(1:ndim,m),aux(1:ndim,2)) CALL DGEMV( 'T', nsize, 2, 1.D0, aux(nbegin:nend,1:2), nsize, ovec(nbegin:nend,m), 1, 0.D0, rtmp, 1 ) call mp_sum(rtmp(1:2),world_comm) hr(m,m,1) = rtmp(1) sr(m,m) = rtmp(2) DO j = m + 1, max_state CALL DGEMV( 'T', nsize, 2, 1.D0, aux(nbegin:nend,1:2), nsize, ovec(nbegin:nend,j), 1, 0.D0, rtmp, 1 ) hr(j,m,1) = rtmp(1) sr(j,m) = rtmp(2) hr(m,j,1) = rtmp(1) sr(m,j) = rtmp(2) END DO END DO write(stdout,*) 'ATTENZIONE2' call flush_unit(stdout) call mp_sum(hr(:,:,1),world_comm) call mp_sum(sr(:,:),world_comm) write(stdout,*) 'Call rdiaghg' call flush_unit(stdout) CALL rdiaghg( max_state, max_state, hr, sr, max_state, en, hr(1,1,2) ) write(stdout,*) 'Done' call flush_unit(stdout) e(1:max_state) = en(1:max_state) ! DO i = 1,ndim ! DO m = 1, max_state ! ctmp(m) = SUM( hr(:,m,2) * ovec(i,:) ) ! END DO ! ovec(i,1:max_state) = ctmp(1:max_state) ! END DO allocate(ovec2(ndim,max_state)) ovec2(:,:)=ovec(:,:) ovec(:,:)=0.d0 call dgemm('N','N',nsize,max_state,max_state,1.d0,ovec2(nbegin:nend,1:max_state),& &nsize,hr(1:max_state,1:max_state,2),max_state,0.d0,ovec(nbegin:nend,1:max_state),nsize) call mp_sum(ovec(:,:),world_comm) deallocate(ovec2) deallocate(aux) deallocate(hr,sr) deallocate(en,ctmp) write(stdout,*) 'ATTENZIONE3' call flush_unit(stdout) states: DO m = 1, max_state write(stdout,*) 'ATTENZIONE4',m call flush_unit(stdout) ! ! ... calculate S|psi> ! !spsi(:)=ovec(:,m) call gradient_s(ovec(:,m),spsi) ! ! ... orthogonalize starting eigenfunction to those already calculated ! CALL DGEMV( 'T', nsize, m, 1.D0, ovec(nbegin:nend,1:m), nsize, spsi(nbegin:nend), 1, 0.D0, lagrange, 1 ) ! call mp_sum(lagrange(1:m),world_comm) ! psi_norm = lagrange(m) ! DO j = 1, m - 1 ! ovec(:,m) = ovec(:,m) - lagrange(j) * ovec(:,j) ! psi_norm = psi_norm - lagrange(j)**2 ! END DO ! psi_norm = SQRT( psi_norm ) ! ovec(:,m) = ovec(:,m) / psi_norm ! ! ... calculate starting gradient (|hpsi> = H|psi>) ... ! call gradient(ovec(1:ndim,m),hpsi) !spsi(1:ndim)=ovec(1:ndim,m) call gradient_s(ovec(1:ndim,m),spsi(1:ndim)) ! ! ... and starting eigenvalue (e = = ) ! ! ... NB: DDOT(2*ndim,a,1,b,1) = DBLE( ZDOTC(ndim,a,1,b,1) ) ! e(m) = DDOT( nsize, ovec(nbegin:nend,m), 1, hpsi(nbegin:nend), 1 ) ! call mp_sum(e(m),world_comm) ! ! ! ... start iteration for this band ! iterate: DO iter = 1, maxter ! ! ... calculate P (PHP)|y> ! ... ( P = preconditioning matrix, assumed diagonal ) ! g(1:ndim) = hpsi(1:ndim)! / precondition(:) ppsi(1:ndim) = spsi(1:ndim)! / precondition(:) ! ! ... ppsi is now S P(P^2)|y> = S P^2|psi>) ! es(1) = DDOT( nsize, spsi(nbegin:nend), 1, g(nbegin:nend), 1 ) es(2) = DDOT( nsize, spsi(nbegin:nend), 1, ppsi(nbegin:nend), 1 ) call mp_sum(es(1:2),world_comm) ! es(1) = es(1) / es(2) ! g(:) = g(:) - es(1) * ppsi(:) ! ! ... e1 = / ensures that ! ... = 0 ! ! ... orthogonalize to lowest eigenfunctions (already calculated) ! ! ... scg is used as workspace ! ! scg(1:ndim)=g(1:ndim) call gradient_s(g(1:ndim),scg(1:ndim)) ! CALL DGEMV( 'T', nsize, ( m - 1 ), 1.D0, & ovec(nbegin:nend,1:m-1), nsize, scg(nbegin:nend), 1, 0.D0, lagrange, 1 ) ! call mp_sum(lagrange(1:m-1),world_comm) ! ! DO j = 1, ( m - 1 ) ! g(:) = g(:) - lagrange(j) * ovec(:,j) scg(:) = scg(:) - lagrange(j) * ovec(:,j) ! END DO ! IF ( iter /= 1 ) THEN ! ! ... gg1 is (used in Polak-Ribiere formula) ! gg1 = DDOT( nsize, g(nbegin:nend), 1, g0(nbegin:nend), 1 ) ! call mp_sum(gg1,world_comm) ! ! END IF ! ! ... gg is ! g0(:) = scg(:) ! g0(1:ndim) = g0(1:ndim)! * precondition(:) ! gg = DDOT( nsize, g(nbegin:nend), 1, g0(nbegin:nend), 1 ) ! call mp_sum(gg,world_comm) ! ! IF ( iter == 1 ) THEN ! ! ... starting iteration, the conjugate gradient |cg> = |g> ! gg0 = gg ! cg(:) = g(:) ! ELSE ! ! ... |cg(n+1)> = |g(n+1)> + gamma(n) * |cg(n)> ! ! ... Polak-Ribiere formula : ! gamma = ( gg - gg1 ) / gg0 gg0 = gg ! cg(:) = cg(:) * gamma cg(:) = g + cg(:) ! ! ... The following is needed because ! ... is not 0. In fact : ! ... = sin(theta)* ! psi_norm = gamma * cg0 * sint ! cg(:) = cg(:) - psi_norm * ovec(:,m) ! END IF ! ! ... |cg> contains now the conjugate gradient ! ! ... |scg> is S|cg> ! call gradient(cg,ppsi) !scg(1:ndim)=cg(1:ndim) call gradient_s(cg(1:ndim),scg(1:ndim)) ! cg0 = DDOT( nsize, cg(nbegin:nend), 1, scg(nbegin:nend), 1 ) ! call mp_sum(cg0,world_comm) ! ! cg0 = SQRT( cg0 ) ! ! ... |ppsi> contains now HP|cg> ! ... minimize , where : ! ... |y(t)> = cos(t)|y> + sin(t)/cg0 |cg> ! ... Note that = 1, = 0 , ! ... = cg0^2 ! ... so that the result is correctly normalized : ! ... = 1 ! a0 = 2.D0 * DDOT( nsize, ovec(nbegin:nend,m), 1, ppsi(nbegin:nend), 1 ) ! ! a0 = a0 / cg0 ! call mp_sum(a0,world_comm) ! b0 = DDOT( nsize, cg(nbegin:nend), 1, ppsi(nbegin:nend), 1 ) ! ! b0 = b0 / cg0**2 ! call mp_sum(b0,world_comm) ! e0 = e(m) ! theta = 0.5D0 * ATAN( a0 / ( e0 - b0 ) ) ! cost = COS( theta ) sint = SIN( theta ) ! cos2t = cost*cost - sint*sint sin2t = 2.D0*cost*sint ! es(1) = 0.5D0 * ( ( e0 - b0 ) * cos2t + a0 * sin2t + e0 + b0 ) es(2) = 0.5D0 * ( - ( e0 - b0 ) * cos2t - a0 * sin2t + e0 + b0 ) ! ! ... there are two possible solutions, choose the minimum ! IF ( es(2) < es(1) ) THEN ! theta = theta + 0.5D0 * pi ! cost = COS( theta ) sint = SIN( theta ) ! END IF ! ! ... new estimate of the eigenvalue ! e(m) = MIN( es(1), es(2) ) ! ! ... upgrade |psi> ! ovec(:,m) = cost * ovec(:,m) + sint / cg0 * cg(:) ! ! ... here one could test convergence on the energy ! IF ( ABS( e(m) - e0 ) < ethr ) THEN write(stdout,*) 'State:',m,'Iterations:',iter,e(m) call flush_unit(stdout) EXIT iterate ELSE l_all_ok=.false. END IF ! ! ... upgrade H|psi> and S|psi> ! spsi(:) = cost * spsi(:) + sint / cg0 * scg(:) ! hpsi(:) = cost * hpsi(:) + sint / cg0 * ppsi(:) ! END DO iterate ! IF ( iter >= maxter ) notconv = notconv + 1 ! avg_iter = avg_iter + iter + 1 ! ! ... reorder eigenvalues if they are not in the right order ! ... ( this CAN and WILL happen in not-so-special cases ) ! IF ( m > 1 .AND. reorder ) THEN ! IF ( e(m) - e(m-1) < - 2.D0 * ethr ) THEN write(stdout,*) 'DO REORDER:',m call flush_unit(stdout) ! ! ... if the last calculated eigenvalue is not the largest... ! DO i = m - 2, 1, - 1 ! IF ( e(m) - e(i) > 2.D0 * ethr ) EXIT ! END DO ! i = i + 1 ! moved = moved + 1 ! ! ... last calculated eigenvalue should be in the ! ... i-th position: reorder ! e0 = e(m) ! ppsi(:) = ovec(:,m) ! DO j = m, i + 1, - 1 ! e(j) = e(j-1) ! ovec(:,j) = ovec(:,j-1) ! END DO ! e(i) = e0 ! ovec(:,i) = ppsi(:) ! ! ... this procedure should be good if only a few inversions occur, ! ... extremely inefficient if eigenvectors are often in bad order ! ... ( but this should not happen ) ! END IF ! END IF if(abs(e(m))>cutoff) EXIT ! END DO states found_state=m ! avg_iter = avg_iter / DBLE( found_state ) ! DEALLOCATE( lagrange ) DEALLOCATE( ppsi ) DEALLOCATE( g0 ) DEALLOCATE( cg ) DEALLOCATE( g ) DEALLOCATE( hpsi ) DEALLOCATE( scg ) DEALLOCATE( spsi ) ! CALL stop_clock( 'diago_cg' ) RETURN CONTAINS SUBROUTINE gradient(vec,grad) !apply gradient implicit none REAL(kind=DP), INTENT(in) :: vec(ndim) REAL(kind=DP), INTENT(out) :: grad(ndim) grad(:)=0.d0 if(.not.l_para) then call dgemm('T','N',nsize,1,ndim,1.d0,omat(1:ndim,nbegin:nend),ndim,vec,ndim,0.d0,grad(nbegin:nend),nsize) else call dgemm('T','N',nsize,1,ndim,1.d0,omat(1:ndim,1:nsize),ndim,vec,ndim,0.d0,grad(nbegin:nend),nsize) endif call mp_sum(grad(1:ndim),world_comm) return END SUBROUTINE gradient ! SUBROUTINE gradient_s(vec,grad) !apply S matrix implicit none REAL(kind=DP), INTENT(in) :: vec(ndim) REAL(kind=DP), INTENT(out) :: grad(ndim) grad(:)=0.d0 if(.not.l_para) then call dgemm('T','N',nsize,1,ndim,1.d0,smat(1:ndim,nbegin:nend),ndim,vec,ndim,0.d0,grad(nbegin:nend),nsize) else call dgemm('T','N',nsize,1,ndim,1.d0,smat(1:ndim,1:nsize),ndim,vec,ndim,0.d0,grad(nbegin:nend),nsize) endif call mp_sum(grad(1:ndim),world_comm) return END SUBROUTINE gradient_s END SUBROUTINE diago_cg_g GWW/pw4gww/allocate_wannier.f900000644000077300007730000000373512341332532017106 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !these subroutines allocate and deallocate what's needed for the wannier functions subroutine allocate_wannier USE wannier_gw, ONLY : wannier_centers, wannier_radii, u_trans, w_centers, w_radii, becp_gw, becp_gw_c, vg_q USE wvfct, ONLY : nbnd, npw,npwx USE uspp, ONLY : okvan,nkb USE lsda_mod, ONLY : nspin implicit none allocate(wannier_centers(3,nbnd,nspin)) allocate(wannier_radii(nbnd,nspin)) allocate(u_trans(nbnd,nbnd,nspin)) allocate(w_centers(3,nbnd,nspin)) allocate(w_radii(nbnd,nspin)) if(okvan) then allocate(becp_gw(nkb,nbnd,nspin)) allocate(becp_gw_c(nkb,nbnd,nspin)) endif allocate(vg_q(npwx)) return end subroutine allocate_wannier subroutine deallocate_wannier USE wannier_gw, ONLY : wannier_centers, wannier_radii, u_trans, w_centers, w_radii, becp_gw, & & becp_gw_c, vg_q implicit none if(allocated(wannier_centers)) deallocate(wannier_centers) if(allocated(wannier_radii)) deallocate(wannier_radii) if(allocated(u_trans)) deallocate(u_trans) if(allocated(w_centers)) deallocate(w_centers) if(allocated(w_radii)) deallocate(w_radii) if(allocated(becp_gw)) deallocate(becp_gw) if(allocated(becp_gw_c)) deallocate(becp_gw_c) if(allocated(vg_q)) deallocate(vg_q) return end subroutine deallocate_wannier GWW/pw4gww/openfil_pw4gww.f900000644000077300007730000000505512341332532016547 0ustar giannozzgiannozz! ! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! ! Author: L. Martin-Samos ! !---------------------------------------------------------------------------- SUBROUTINE openfil_pw4gww() !---------------------------------------------------------------------------- ! ! ... This routine opens all files needed to the self consistent run, ! ... sets various file names, units, record lengths ! USE kinds, ONLY : DP USE wvfct, ONLY : nbnd, npwx use control_flags, ONLY: twfcollect USE io_files, ONLY : prefix, tmp_dir, iunwfc, nwordwfc, iunsat, nwordatwfc, diropn USE noncollin_module, ONLY : npol USE ldaU, ONLY : lda_plus_u USE basis, ONLY : natomwfc USE ions_base, ONLY : nat, ityp USE noncollin_module, ONLY : noncolin USE uspp_param, ONLY : n_atom_wfc ! IMPLICIT NONE ! LOGICAL :: exst ! ! twfcollect=.false. ! ! ... nwordwfc is the record length for the direct-access file ! ... containing wavefunctions ! nwordwfc = nbnd * npwx * npol ! CALL diropn( iunwfc, 'wfc', 2*nwordwfc, exst ) ! IF ( .NOT. exst ) THEN call errore ('openfil_pw4gww','file '//TRIM( prefix )//'.wfc'//' not found',1) END IF ! !!!! ... iunigk contains the number of PW and the indices igk !!!! ... Note that unit 15 is reserved for error messages ! !!!! CALL seqopn( iunigk, 'igk', 'UNFORMATTED', exst ) !!!! !!!! IF ( .NOT. exst ) THEN !!!! call errore ('openfil_pp','file '//TRIM( prefix )//'.igk'//' not found',1) !!!! END IF ! ! ... Needed for LDA+U ! ! ... iunat contains the (orthogonalized) atomic wfcs ! ... iunsat contains the (orthogonalized) atomic wfcs * S ! ... iunocc contains the atomic occupations computed in new_ns ! ... it is opened and closed for each reading-writing operation ! natomwfc = n_atom_wfc( nat, ityp, noncolin ) nwordatwfc = 2*npwx*natomwfc*npol ! IF ( lda_plus_u ) then !CALL diropn( iunat, 'atwfc', nwordatwfc, exst ) IF ( .NOT. exst ) THEN call errore ('openfil_pw4gww','file '//TRIM( prefix )//'.atwfc'//' not found',1) END IF CALL diropn( iunsat, 'satwfc', nwordatwfc, exst ) IF ( .NOT. exst ) THEN call errore ('openfil_pw4gww','file '//TRIM( prefix )//'.satwfc'//' not found',1) END IF END IF ! RETURN ! END SUBROUTINE openfil_pw4gww GWW/pw4gww/matrix_wannier_gamma.f900000644000077300007730000003234312341332532017765 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! subroutine write_wfc_grid_2 !this subroutine read real wavefunctions from file !on the small charge grid, and write on the !wavefunction grid in real space USE kinds, ONLY : DP USE io_files, ONLY : diropn USE io_global, ONLY : stdout USE gvecs, ONLY : doublegrid USE wvfct, ONLY : nbnd USE fft_base, ONLY : dfftp, dffts implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER :: iw,ix,iy,iz,nn REAL(kind=DP), ALLOCATABLE :: tmprealis(:),tmpreal2(:) INTEGER :: iunwfcreal, iunwfcreal2 INTEGER :: iqq LOGICAL :: exst INTEGER :: nrxxs2 REAL(kind=DP) :: sca nrxxs2=(dffts%nr1/2+1)*(dffts%nr2/2+1)*(dffts%nr3/2+1) iunwfcreal=find_free_unit() CALL diropn( iunwfcreal, 'real_whole', dffts%nnr, exst ) iunwfcreal2=find_free_unit() CALL diropn( iunwfcreal2, 'real_whole2', nrxxs2, exst ) allocate(tmprealis(dffts%nnr)) allocate(tmpreal2(nrxxs2)) do iw=1,nbnd CALL davcio( tmprealis,dffts%nnr,iunwfcreal,iw,-1) tmpreal2(:)=0.d0 iqq=0 sca=0.d0 do ix=1,dffts%nr1,2 do iy=1,dffts%nr2,2 do iz=1,dffts%nr3,2 iqq=iqq+1 nn=(iz-1)*dffts%nr1*dffts%nr2+(iy-1)*dffts%nr1+ix tmpreal2(iqq)=tmprealis(nn) sca=sca+tmprealis(nn)**2.d0!ATTENZIONE enddo enddo enddo !tmpreal2(:)=tmpreal2(:)/(sqrt(sca/dble(iqq))) write(*,*) 'MODULUS', iw,sca/dble(iqq) CALL davcio( tmpreal2,nrxxs2,iunwfcreal2,iw,1) enddo deallocate(tmprealis,tmpreal2) close(iunwfcreal) close(iunwfcreal2) return end subroutine !----------------------------------------------------------------------- subroutine matrix_wannier_gamma_big( matsincos, ispin, n_set, itask ) !----------------------------------------------------------------------- ! !this subroutine calculates the terms !in real space for gamma only case USE kinds, ONLY : DP USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2 USE constants, ONLY : e2, pi, tpi, fpi USE uspp, ONLY : okvan, nkb USE io_files, ONLY : diropn USE io_global, ONLY : stdout USE gvecs, ONLY : doublegrid ! USE realus, ONLY : qsave, box,maxbox USE wannier_gw, ONLY : becp_gw, expgsave, becp_gw_c, maxiter2,num_nbndv USE ions_base, ONLY : nat, ntyp =>nsp, ityp USE uspp_param, ONLY : lmaxq,upf,nh, nhm USE lsda_mod, ONLY : nspin USE mp_global, ONLY : intra_image_comm, me_pool USE mp, ONLY : mp_bcast,mp_barrier,mp_sum USE mp_world, ONLY : world_comm USE fft_base, ONLY : dffts,dfftp USE wvfct, ONLY : nbnd, ecutwfc implicit none INTEGER, EXTERNAL :: find_free_unit ! INTEGER, INTENT(in) :: ispin!spin polarization considred ! COMPLEX(dp), INTENT(out) :: matp(nbnd_normal,nbnd_normal,3) REAL(dp), INTENT(out) :: matsincos(nbnd,nbnd,6) INTEGER, INTENT(in) :: n_set !defines the number of states INTEGER, INTENT(in) :: itask !if ==1 consider subspace {C'} INTEGER :: iiw,jjw, jw_begin INTEGER :: iw,jw,ir,ix,iy,iz,nn,ii REAL(kind=DP), ALLOCATABLE :: tmprealis(:,:),tmprealjs(:,:), tmpreal(:) COMPLEX(kind=DP), ALLOCATABLE :: tmpexp(:), tmpexp2(:,:) INTEGER :: iunwfcreal2 COMPLEX(kind=DP) :: sca,ee,sca1 REAL(kind=DP) :: dsgn LOGICAL :: exst INTEGER :: iqq INTEGER :: na, ih, jh, np INTEGER :: ikb, jkb, ijkb0, is INTEGER :: isgn,mdir INTEGER :: nr3s_start, nr3s_end INTEGER :: nr3_start, nr3_end INTEGER :: nbnd_eff write(stdout,*) 'MATRIX BIG1' call flush_unit(stdout) iunwfcreal2=find_free_unit() CALL diropn( iunwfcreal2, 'real_whole', dffts%nnr, exst ) allocate(tmprealis(dffts%nnr,n_set),tmprealjs(dffts%nnr,n_set), tmpreal(dffts%nnr)) allocate(tmpexp2(dffts%nnr,6)) !set npp for not parallel case #ifndef __PARA dfftp%npp(1) = dfftp%nr3 dffts%npp(1) = dffts%nr3 #endif !set up exponential grid tmpexp2(:,:)=(0.d0,0.d0) #ifndef __PARA iqq=0 do ix=1,dffts%nr1 do iy=1,dffts%nr2 do iz=1,dffts%nr3 iqq=(iz-1)*(dffts%nr1x*dffts%nr2x)+(iy-1)*dffts%nr1x+ix tmpexp2(iqq,1) = exp(cmplx(0.d0,1.d0)*tpi*real(ix-1)/real(dffts%nr1)) tmpexp2(iqq,2) = exp(cmplx(0.d0,1.d0)*tpi*real(iy-1)/real(dffts%nr2)) tmpexp2(iqq,3) = exp(cmplx(0.d0,1.d0)*tpi*real(iz-1)/real(dffts%nr3)) tmpexp2(iqq,4) = exp(cmplx(0.d0,-1.d0)*tpi*real(ix-1)/real(dffts%nr1)) tmpexp2(iqq,5) = exp(cmplx(0.d0,-1.d0)*tpi*real(iy-1)/real(dffts%nr2)) tmpexp2(iqq,6) = exp(cmplx(0.d0,-1.d0)*tpi*real(iz-1)/real(dffts%nr3)) enddo enddo enddo #else write(stdout,*) 'NRS', dffts%nr1,dffts%nr2,dffts%nr3 write(stdout,*) 'NRXS', dffts%nr1x,dffts%nr2x,dffts%nr3x nr3s_start=0 nr3s_end =0 do ii=1,me_pool + 1 nr3s_start=nr3s_end+1 nr3s_end=nr3s_end+dffts%npp(ii) end do tmpexp2(:,:)=(0.d0,0.d0) do iz=1,dffts%npp(me_pool+1) do iy=1,dffts%nr2 do ix=1,dffts%nr1 iqq=(iz-1)*(dffts%nr1x*dffts%nr2x)+(iy-1)*dffts%nr1+ix tmpexp2(iqq,1) = exp(cmplx(0.d0,1.d0)*tpi*real(ix-1)/real(dffts%nr1)) tmpexp2(iqq,2) = exp(cmplx(0.d0,1.d0)*tpi*real(iy-1)/real(dffts%nr2)) tmpexp2(iqq,3) = exp(cmplx(0.d0,1.d0)*tpi*real(iz+nr3s_start-1-1)/real(dffts%nr3)) tmpexp2(iqq,4) = exp(cmplx(0.d0,-1.d0)*tpi*real(ix-1)/real(dffts%nr1)) tmpexp2(iqq,5) = exp(cmplx(0.d0,-1.d0)*tpi*real(iy-1)/real(dffts%nr2)) tmpexp2(iqq,6) = exp(cmplx(0.d0,-1.d0)*tpi*real(iz+nr3s_start-1-1)/real(dffts%nr3)) enddo enddo enddo #endif write(stdout,*) 'Calculate grid' nbnd_eff=num_nbndv(ispin) write(stdout,*) 'MATRIX BIG2' call flush_unit(stdout) do iiw=1,nbnd_eff/n_set+1 write(stdout,*) 'MATRIX IIW',iiw call flush_unit(stdout) do iw=(iiw-1)*n_set+1,min(iiw*n_set,nbnd_eff) !read from disk wfc on coarse grid CALL davcio( tmprealis(:,iw-(iiw-1)*n_set),dffts%nnr,iunwfcreal2,iw+(ispin-1)*nbnd,-1) enddo !read in iw wfcs do jjw=iiw,nbnd_eff/n_set+1 write(stdout,*) 'MATRIX JJW',jjw call flush_unit(stdout) do jw=(jjw-1)*n_set+1,min(jjw*n_set,nbnd_eff) CALL davcio( tmprealjs(:,jw-(jjw-1)*n_set),dffts%nnr,iunwfcreal2,jw+(ispin-1)*nbnd,-1) enddo !do product do iw=(iiw-1)*n_set+1,min(iiw*n_set,nbnd_eff) if(iiw==jjw) then jw_begin=iw else jw_begin=(jjw-1)*n_set+1 endif do jw=jw_begin,min(jjw*n_set,nbnd_eff) tmpreal(:)=tmprealis(:,iw-(iiw-1)*n_set)*tmprealjs(:,jw-(jjw-1)*n_set) !put on fine grid !add us part !calculate matrix element do mdir=1,3 sca=0.d0 do ir=1,dffts%nnr sca=sca+tmpreal(ir)*tmpexp2(ir,mdir) enddo sca=sca/dble(dffts%nr1*dffts%nr2*dffts%nr3) call mp_sum(sca,world_comm) !call reduce(2,sca) matsincos(iw,jw,mdir)=dble(sca) matsincos(jw,iw,mdir)=dble(sca) matsincos(iw,jw,mdir+3)=dimag(sca) matsincos(jw,iw,mdir+3)=dimag(sca) !matp(iw,jw,mdir)=sca !matp(jw,iw,mdir)=sca enddo enddo enddo enddo enddo deallocate(tmprealis,tmprealjs) deallocate(tmpexp2) write(stdout,*) 'Calculate US' call flush_unit(stdout) if(okvan) then allocate(tmpexp(dfftp%nnr)) allocate(expgsave(maxval(nh),maxval(nh),nat,3)) expgsave(:,:,:,:)=0.d0 do mdir=1,3 #ifndef __PARA if(mdir==1) then do ix=1,dfftp%nr1 ee=exp(cmplx(0.d0,1.d0)*tpi*real(ix)/real(dfftp%nr1)) do iy=1,dfftp%nr2 do iz=1,dfftp%nr3 nn=(iz-1)*dfftp%nr1x*dfftp%nr2+(iy-1)*dfftp%nr1+ix tmpexp(nn)=ee enddo enddo enddo else if(mdir==2) then do iy=1,dfftp%nr2 ee=exp(cmplx(0.d0,1.d0)*tpi*real(iy)/real(dfftp%nr2)) do ix=1,dfftp%nr1 do iz=1,dfftp%nr3 nn=(iz-1)*dfftp%nr1x*dfftp%nr2x+(iy-1)*dfftp%nr1x+ix tmpexp(nn)=ee enddo enddo enddo else if(mdir==3) then do iz=1,dfftp%nr3 ee=exp(cmplx(0.d0,1.d0)*tpi*real(iz)/real(dfftp%nr3)) do ix=1,dfftp%nr1 do iy=1,dfftp%nr2 nn=(iz-1)*dfftp%nr1x*dfftp%nr2x+(iy-1)*dfftp%nr1x+ix tmpexp(nn)=ee enddo enddo enddo endif #else nr3_start=0 nr3_end =0 do ii=1,me_pool + 1 nr3_start=nr3_end+1 nr3_end=nr3_end+dfftp%npp(ii) end do do iz=1,dfftp%npp(me_pool+1) do iy=1,dfftp%nr2 do ix=1,dfftp%nr1 nn=(iz-1)*dfftp%nr1x*dfftp%nr2x+(iy-1)*dfftp%nr1x+ix if(mdir==1) then tmpexp(nn)= exp(cmplx(0.d0,1.d0)*tpi*real(ix-1)/real(dfftp%nr1)) elseif(mdir==2) then tmpexp(nn)= exp(cmplx(0.d0,1.d0)*tpi*real(iy-1)/real(dfftp%nr2)) else tmpexp(nn)= exp(cmplx(0.d0,1.d0)*tpi*real(iz+nr3_start-1-1)/real(dfftp%nr3)) endif enddo enddo enddo #endif do np = 1, ntyp if ( upf(np)%tvanp ) then do na = 1, nat if ( ityp(na) == np ) then do ih = 1, nh(np) do jh = ih, nh(np) expgsave(ih,jh,na,mdir)=(0.d0,0.d0) !do ir =1,maxbox(na) ! expgsave(ih,jh,na,mdir)=expgsave(ih,jh,na,mdir)+qsave(ih,jh,na)%q(ir)*tmpexp(box(ir,na)) !enddo enddo enddo endif enddo endif enddo expgsave(:,:,:,mdir)=expgsave(:,:,:,mdir)*omega/dble(dfftp%nr1*dfftp%nr2*dfftp%nr3) #ifdef __PARA ! call reduce (2 *maxval(nh) *maxval(nh)* nat, expgsave(:,:,:,mdir)) call mp_sum( expgsave(:,:,:,mdir),world_comm) #endif do iw=1,nbnd_eff do jw=iw,nbnd_eff do is=1, nspin ijkb0 = 0 do np = 1, ntyp if ( upf(np)%tvanp ) then do na = 1, nat if ( ityp(na) == np ) then do ih = 1, nh(np) ikb = ijkb0 + ih do jh = 1, nh(np) jkb = ijkb0 + jh if(ih <= jh) then if(itask /= 1) then matsincos(iw,jw,mdir)=matsincos(iw,jw,mdir)+& &dble(expgsave(ih,jh,na,mdir) * becp_gw(ikb,iw,1)*becp_gw(jkb,jw,1)) matsincos(iw,jw,mdir+3)=matsincos(iw,jw,mdir+3)+& &dimag(expgsave(ih,jh,na,mdir) * becp_gw(ikb,iw,1)*becp_gw(jkb,jw,1)) else matsincos(iw,jw,mdir)=matsincos(iw,jw,mdir)+& &dble(expgsave(ih,jh,na,mdir) * becp_gw_c(ikb,iw,1)*becp_gw_c(jkb,jw,1)) matsincos(iw,jw,mdir+3)=matsincos(iw,jw,mdir+3)+& &dimag(expgsave(ih,jh,na,mdir) * becp_gw_c(ikb,iw,1)*becp_gw_c(jkb,jw,1)) endif else if(itask /= 1) then !matp(iw,jw,mdir)=matp(iw,jw,mdir)+expgsave(jh,ih,na,mdir) * becp_gw(ikb,iw,1)*becp_gw(jkb,jw,1) matsincos(iw,jw,mdir)=matsincos(iw,jw,mdir)+& &dble(expgsave(jh,ih,na,mdir) * becp_gw(ikb,iw,1)*becp_gw(jkb,jw,1)) matsincos(iw,jw,mdir+3)=matsincos(iw,jw,mdir+3)+& &dimag(expgsave(jh,ih,na,mdir) * becp_gw(ikb,iw,1)*becp_gw(jkb,jw,1)) else !matp(iw,jw,mdir)=matp(iw,jw,mdir)+expgsave(jh,ih,na,mdir) * becp_gw_c(ikb,iw,1)*becp_gw_c(jkb,jw,1) matsincos(iw,jw,mdir)=matsincos(iw,jw,mdir)+& &dble(expgsave(jh,ih,na,mdir) * becp_gw_c(ikb,iw,1)*becp_gw_c(jkb,jw,1)) matsincos(iw,jw,mdir+3)=matsincos(iw,jw,mdir+3)+& &dimag(expgsave(jh,ih,na,mdir) * becp_gw_c(ikb,iw,1)*becp_gw_c(jkb,jw,1)) endif endif enddo enddo ijkb0=ijkb0+nh(np) endif enddo else do na=1,nat if(ityp(na) == np) ijkb0=ijkb0+nh(np) enddo endif enddo enddo ! matp(jw,iw,mdir)=matp(iw,jw,mdir) matsincos(jw,iw,mdir)=matsincos(iw,jw,mdir) matsincos(jw,iw,mdir+3)=matsincos(iw,jw,mdir+3) enddo enddo enddo deallocate(tmpexp) endif close(iunwfcreal2) return end subroutine GWW/pw4gww/rotate_wannier.f900000644000077300007730000001025112341332532016607 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !----------------------------------------- subroutine rotate_wannier( rot_u,ispin, iun_wannier) !---------------------------------------- ! ! this routine reads the wavefunctions from iun_wannier ! (GAMMA-ONLY CALCULATIONS) and rotate the wavefunctions ! according to rot_u ! only ispin states used (not implemented ye ! ONLY -NORMCONSERVING USE kinds, ONLY : DP USE us USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, ecutwfc USE gvect USE basis USE klist USE constants, ONLY : e2, pi, tpi, fpi USE io_files, ONLY: nwordwfc USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2 USE wavefunctions_module, ONLY: evc implicit none INTEGER, INTENT(in) :: ispin!+1 or -1 INTEGER, INTENT(in) :: iun_wannier !units for reading wfc REAL(kind=DP), INTENT(in) :: rot_u(nbnd,nbnd) COMPLEX(kind=DP), ALLOCATABLE :: evc0(:,:)!reads wavefunctions here COMPLEX(kind=DP), ALLOCATABLE :: evc1(:,:)!reads wavefunctions here integer i,j,k,ig INTEGER :: igk0(npwx) INTEGER :: npw0 REAL(kind=dp) :: g2kin_bp(npwx) REAL(kind=dp) :: add COMPLEX(kind=DP) :: sca allocate( evc0(npwx,nbnd)) allocate( evc1(npwx,nbnd)) !reads wfcs from iun_wannier CALL gk_sort(xk(1,1),ngm,g,ecutwfc/tpiba2, & & npw0,igk0,g2kin_bp) CALL davcio(evc0,2*nwordwfc,iun_wannier,1,-1) evc1=(0.d0,0.d0) !rotate do i=1,nbnd do j=1,nbnd do ig=1,npw0 evc1(ig,i)=evc1(ig,i)+rot_u(j,i)*evc0(ig,j) enddo enddo enddo !check for debug ! do i=1,nbnd ! do j=1,nbnd ! sca=(0.d0,0.d0) ! do ig=1,npw0 ! sca=sca+conjg(evc1(ig,i))*evc1(ig,j) ! enddo ! write(*,*) 'rotata_wannier_check :', i,j, sca ! enddo ! enddo !write back on file evc(1:npw0,1:nbnd)=evc1(1:npw0,1:nbnd) write(*,*) 'writing wannier wfcs on file'!ATTENZIONE CALL davcio(evc1,2*nwordwfc,iun_wannier,1,1) DEALLOCATE(evc0) DEALLOCATE(evc1) return end subroutine rotate_wannier !----------------------------------------- subroutine rotate_wannier_gamma( rot_u,ispin, itrasp) !---------------------------------------- ! ! (GAMMA-ONLY CALCULATIONS) and rotate the wavefunctions ! according to rot_u ! only ispin states used (not implemented ye ! ONLY -NORMCONSERVING USE kinds, ONLY : DP USE us USE wvfct, ONLY : igk, g2kin, npwx, npw, nbndx,nbnd USE gvect USE basis USE klist USE constants, ONLY : e2, pi, tpi, fpi USE io_files, ONLY: nwordwfc USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2 USE wavefunctions_module, ONLY: evc implicit none INTEGER, INTENT(in) :: ispin!+1 or -1 REAL(kind=DP), INTENT(in) :: rot_u(nbnd,nbnd) INTEGER, INTENT(in) :: itrasp!if 1 takes U^T REAL(kind=DP), ALLOCATABLE :: evc0(:,:),evc_re(:,:),evc_im(:,:)!reads wavefunctions here integer i,j,k,ig allocate( evc0(npw,nbnd)) allocate( evc_re(npw,nbnd)) allocate( evc_im(npw,nbnd)) !now real part if(itrasp/=1) then evc0(:,:)=dble(evc(:,:)) call dgemm('N','N',npw,nbnd,nbnd,1.d0,evc0,npw,rot_u,nbnd,0.d0,evc_re,npw) !now imaginary part evc0(:,:)=dimag(evc(:,:)) call dgemm('N','N',npw,nbnd,nbnd,1.d0,evc0,npw,rot_u,nbnd,0.d0,evc_im,npw) else evc0(:,:)=dble(evc(:,:)) call dgemm('N','T',npw,nbnd,nbnd,1.d0,evc0,npw,rot_u,nbnd,0.d0,evc_re,npw) !now imaginary part evc0(:,:)=dimag(evc(:,:)) call dgemm('N','T',npw,nbnd,nbnd,1.d0,evc0,npw,rot_u,nbnd,0.d0,evc_im,npw) endif ! do i=1,nbnd ! do ig=1,npw ! evc(ig,i)=dcmplx(evc_re(ig,i),evc_im(ig,i)) ! enddo ! enddo evc(:,1:nbnd)=dcmplx(evc_re(:,1:nbnd),evc_im(:,1:nbnd)) !rotate ! do i=1,nbnd ! do j=1,nbnd ! do ig=1,npw ! evc(ig,i)=evc(ig,i)+rot_u(j,i)*evc0(ig,j) ! enddo ! enddo ! enddo DEALLOCATE(evc0) deallocate(evc_re,evc_im) return end subroutine rotate_wannier_gamma GWW/pw4gww/full.f900000644000077300007730000000633112341332532014534 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !this subroutine writes polarizability basis in real space on charge grid on disk subroutine write_pola_basis(numpw) USE io_global, ONLY : stdout, ionode, ionode_id USE io_files, ONLY : prefix, tmp_dir, diropn USE kinds, ONLY : DP USE wannier_gw USE gvect USE constants, ONLY : e2, pi, tpi, fpi USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2 USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, ecutwfc USE wavefunctions_module, ONLY : evc, psic USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_pools, ONLY : intra_pool_comm USE mp_world, ONLY : mpime,nproc USE gvecs, ONLY : nls, nlsm, doublegrid USE mp_wave, ONLY : mergewf,splitwf USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft implicit none INTEGER, INTENT(in) :: numpw!dimesion of polarizability bassis COMPLEX(kind=DP), allocatable :: p_basis(:,:) INTEGER, external :: find_free_unit INTEGER :: iungprod,iw,ii,iun,ig LOGICAL :: exst REAL(kind=DP), allocatable :: p_basis_r(:,:) REAL(kind=DP), ALLOCATABLE :: fac(:) REAL(kind=DP) :: qq iungprod = find_free_unit() CALL diropn( iungprod, 'wiwjwfc_red', max_ngm*2, exst ) allocate(p_basis(max_ngm,numpw)) allocate(p_basis_r(dfftp%nnr,2)) allocate(fac(npw)) if(l_truncated_coulomb) then do ig=1,max_ngm qq = g(1,ig)**2.d0 + g(2,ig)**2.d0 + g(3,ig)**2.d0 if (qq > 1.d-8) then fac(ig)=(e2*fpi/(tpiba2*qq))*(1.d0-dcos(dsqrt(qq)*truncation_radius*tpiba)) else fac(ig)=e2*fpi*(truncation_radius**2.d0/2.d0) endif enddo fac(:)=fac(:)/omega else fac(:)=0.d0 fac(1:npw)=vg_q(1:npw) endif do iw=1,numpw call davcio(p_basis(:,iw),max_ngm*2,iungprod,iw,-1) do ig=1,npw p_basis(ig,iw)=p_basis(ig,iw)*fac(ig) enddo enddo close(iungprod) iun=find_free_unit() CALL diropn( iun, 'basis2full',dfftp%nnr, exst ) ii=0 do iw=1,numpw,2 psic(1:dfftp%nnr)=(0.d0,0.d0) if(iw !if required used truncation formula of Onida, PRB 62, 4927 (2000) USE io_global, ONLY : stdout, ionode USE io_files, ONLY : prefix, tmp_dir, diropn use mp_pools, ONLY : nproc_pool, me_pool use mp_world, ONLY : world_comm USE kinds, ONLY : DP USE gvect USE basis USE klist USE constants, ONLY : e2, pi, tpi, fpi USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, ecutwfc USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2 USE wannier_gw USE mp, ONLY : mp_sum USE control_flags, ONLY : gamma_only implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER, INTENT(in) :: n_set !defines the number of states to be read from disk at the same time LOGICAL, INTENT(in) :: l_square!if true calculate v^1/2 for the symmetric dielectric matrix LOGICAL, INTENT(in) :: lzero!if true put to zero the G=0,G=0 of v INTEGER, INTENT(in) :: orthonorm!if ==1 opens orthonormalized products of wannier file, if==2 reduced one REAL(kind=DP), INTENT(in) :: ecutoff!cutoff in Rydberg for g sum INTEGER :: iungprod, iunuterms ! --- Internal definitions --- COMPLEX(kind=DP), ALLOCATABLE :: tmpspacei(:,:) COMPLEX(kind=DP), ALLOCATABLE :: tmpspacej(:,:) REAL(kind=DP), ALLOCATABLE ::fac(:) REAL(kind=DP), ALLOCATABLE :: uterms(:,:)!temporary reading array INTEGER :: iw,jw, iiw,jjw,jw_begin INTEGER :: ig LOGICAL :: exst REAL (kind=DP) :: qq INTEGER :: igk0(npwx) REAL(kind=dp) :: g2kin_bp(npwx) INTEGER :: npw0 REAL(kind=DP) :: exxdiv INTEGER :: ngm_max INTEGER :: iw_min,iw_max,jw_min,jw_max COMPLEX(kind=DP), ALLOCATABLE :: umat_tmp(:,:) write(stdout,*) 'Routine wannier_uterms : start' ! exxdiv=exx_divergence_new() !determine ngm_max ngm_max=0 do ig=1,ngm if(gg(ig)*tpiba2 >= ecutoff) exit ngm_max=ngm_max+1 enddo write(stdout,*) 'NGM MAX:', ngm_max, ngm ! reads wfcs from iunwfc CALL gk_sort(xk(1,1),ngm,g,ecutwfc/tpiba2, & & npw0,igk0,g2kin_bp) allocate(uterms(numw_prod,numw_prod)) allocate(tmpspacei(max_ngm,n_set),tmpspacej(max_ngm,n_set),fac(max_ngm)) allocate(umat_tmp(n_set,n_set)) iungprod = find_free_unit() if(orthonorm==0) then CALL diropn( iungprod, 'wiwjwfc', max_ngm*2, exst ) else if(orthonorm==1) then CALL diropn( iungprod, 'wiwjwfc_on', max_ngm*2, exst ) else CALL diropn( iungprod, 'wiwjwfc_red', max_ngm*2, exst ) endif !sets factors terms !sets factors terms !this has already been called call exx_grid_init() if(l_truncated_coulomb) then do ig=1,max_ngm qq = g(1,ig)**2.d0 + g(2,ig)**2.d0 + g(3,ig)**2.d0 if (qq > 1.d-8) then fac(ig)=(e2*fpi/(tpiba2*qq))*(1.d0-dcos(dsqrt(qq)*truncation_radius*tpiba)) else fac(ig)=e2*fpi*(truncation_radius**2.d0/2.d0) endif enddo fac(:)=fac(:)/omega else fac(:)=0.d0 fac(1:npw)=vg_q(1:npw) endif if(lzero .and. gstart==2) fac(1)=0.d0 if(l_square) fac(:)=dsqrt(fac(:)) !open output file if(ionode) then iunuterms = find_free_unit() open( unit= iunuterms, file=trim(tmp_dir)//trim(prefix)//'.uterms', status='unknown',form='unformatted') endif uterms(:,:)=0.d0 do iiw=1,ceiling(real(numw_prod)/real(n_set)) write(stdout,*) 'uterms iiw', iiw do iw=(iiw-1)*n_set+1,min(iiw*n_set,numw_prod) CALL davcio(tmpspacei(:,iw-(iiw-1)*n_set),max_ngm*2,iungprod,iw,-1) if(gamma_only .and. gstart == 2) then tmpspacei(1,iw-(iiw-1)*n_set)=dble(tmpspacei(1,iw-(iiw-1)*n_set)) endif enddo iw_min=(iiw-1)*n_set+1 iw_max=min(iiw*n_set,numw_prod) do jjw=iiw,ceiling(real(numw_prod)/real(n_set)) write(stdout,*) 'uterms jjw', jjw do jw=(jjw-1)*n_set+1,min(jjw*n_set,numw_prod) CALL davcio(tmpspacej(:,jw-(jjw-1)*n_set),max_ngm*2,iungprod,jw,-1) if(gamma_only .and. gstart == 2) then tmpspacej(1,jw-(jjw-1)*n_set)=dble(tmpspacej(1,jw-(jjw-1)*n_set)) endif enddo jw_min=(jjw-1)*n_set+1 jw_max=min(jjw*n_set,numw_prod) !!!!!!!!!!!!!!!!!!!!!!!!!!! !uses blas routine do jw=1,jw_max-jw_min+1 tmpspacej(1:ngm_max,jw)= tmpspacej(1:ngm_max,jw)*fac(1:ngm_max) if(gstart==2) tmpspacej(1,jw)=0.5d0*tmpspacej(1,jw) enddo call zgemm('C','N',n_set,n_set,ngm_max,(1.d0,0.d0),tmpspacei,max_ngm,tmpspacej,max_ngm,(0.d0,0.d0),umat_tmp,n_set) call mp_sum(umat_tmp(:,:),world_comm) do iw=iw_min,iw_max do jw=jw_min,jw_max uterms(iw,jw)=2.d0*dble(umat_tmp(iw-iw_min+1,jw-jw_min+1)) uterms(jw,iw)=uterms(iw,jw) enddo enddo !!!!!!!!!!!!!!!!!!!!!!!!!!! ! do iw=(iiw-1)*n_set+1,min(iiw*n_set,numw_prod) ! if(iiw==jjw) then ! jw_begin=iw ! else ! jw_begin=(jjw-1)*n_set+1 ! endif ! do jw=jw_begin,min(jjw*n_set,numw_prod) ! uterms(iw,jw)=0.d0 ! if(.not.gamma_only) then ! do ig=1,ngm_max ! uterms(iw,jw)=uterms(iw,jw) + dble(fac(ig)*& ! &conjg(tmpspacei(ig,iw-(iiw-1)*n_set))*tmpspacej(ig,jw-(jjw-1)*n_set)) ! enddo ! else ! do ig=1,ngm_max ! uterms(iw,jw)=uterms(iw,jw) + 2.d0*dble(fac(ig)*& ! &conjg(tmpspacei(ig,iw-(iiw-1)*n_set))*tmpspacej(ig,jw-(jjw-1)*n_set)) ! enddo ! if(gstart==2) then ! uterms(iw,jw)=uterms(iw,jw)-dble(fac(1)*& ! &conjg(tmpspacei(1,iw-(iiw-1)*n_set))*tmpspacej(1,jw-(jjw-1)*n_set)) ! endif ! ! endif ! call reduce(1, uterms(iw,jw)) ! uterms(jw,iw)=uterms(iw,jw) ! enddo ! enddo enddo enddo if(ionode) then do iw=1,numw_prod write(iunuterms) uterms(iw,1:iw) enddo close(iunuterms) endif close(iungprod) deallocate(tmpspacei,tmpspacej,fac,uterms) deallocate(umat_tmp) return end subroutine wannier_uterms subroutine calculate_vg0 !this subroutine calculate the G=0 element of the Coulomb interatction !by integrating over q !and write them on disk USE wannier_gw, ONLY : vg_q USE wvfct, ONLY : npw,npwx USE gvect USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2, bg USE constants, ONLY : e2, pi, tpi, fpi USE io_global, ONLY : stdout, ionode USE io_files, ONLY : prefix, tmp_dir, diropn implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER :: ig,iun INTEGER, PARAMETER :: n_int=20 INTEGER :: ix,iy,iz,n_int_loc REAL(kind=DP) :: qq_fact, qq(3) LOGICAL :: exst REAL(kind=DP), ALLOCATABLE :: q1(:),q2(:),q3(:) REAL(kind=DP) :: qx(3),qy(3),qz(3), qq0,qq1 write(stdout,*)'BG1', bg(1:3,1) write(stdout,*)'BG2', bg(1:3,2) write(stdout,*)'BG3', bg(1:3,3) if(bg(2,1)==0.d0 .and. bg(3,1)==0.d0 .and.bg(1,2)==0.d0 .and.bg(3,2)==0.d0 .and. bg(1,3)==0.d0 .and.bg(2,3)==0.d0 ) then call flush_unit(stdout) do ig=1,npw vg_q(ig)=0.d0 if(ig==1 .and. gstart==2) then n_int_loc=n_int*50 else n_int_loc=n_int endif allocate(q1(-n_int_loc+1:n_int_loc)) allocate(q2(-n_int_loc+1:n_int_loc)) allocate(q3(-n_int_loc+1:n_int_loc)) do ix=-n_int_loc+1,n_int_loc q1(ix)=(0.5d0*(1.d0/dble(n_int_loc)*(dble(ix-1))+0.5d0/dble(n_int_loc))*bg(1,1)+g(1,ig))**2.d0 enddo do ix=-n_int_loc+1,n_int_loc q2(ix)=(0.5d0*(1.d0/dble(n_int_loc)*(dble(ix-1))+0.5d0/dble(n_int_loc))*bg(2,2)+g(2,ig))**2.d0 enddo do ix=-n_int_loc+1,n_int_loc q3(ix)=(0.5d0*(1.d0/dble(n_int_loc)*(dble(ix-1))+0.5d0/dble(n_int_loc))*bg(3,3)+g(3,ig))**2.d0 enddo do ix=-n_int_loc+1,n_int_loc qq0=q1(ix) do iy=-n_int_loc+1,n_int_loc qq1=qq0+q2(iy) do iz=-n_int_loc+1,n_int_loc qq_fact=qq1+q3(iz) vg_q(ig)=vg_q(ig)+1.d0/qq_fact enddo enddo enddo vg_q(ig)=vg_q(ig)*e2*fpi/(8.d0*(dble(n_int_loc))**3.d0)/tpiba2 deallocate(q1,q2,q3) enddo else do ig=1,npw vg_q(ig)=0.d0 if(ig==1 .and. gstart==2) then n_int_loc=n_int*50 else n_int_loc=n_int endif do ix=-n_int_loc+1,n_int_loc do iy=-n_int_loc+1,n_int_loc do iz=-n_int_loc+1,n_int_loc qx(:)=0.5d0*(1.d0/dble(n_int_loc)*(dble(ix-1))+0.5d0/dble(n_int_loc))*bg(:,1) qy(:)=0.5d0*(1.d0/dble(n_int_loc)*(dble(iy-1))+0.5d0/dble(n_int_loc))*bg(:,2) qz(:)=0.5d0*(1.d0/dble(n_int_loc)*(dble(iz-1))+0.5d0/dble(n_int_loc))*bg(:,3) qq(:)=qx(:)+qy(:)+qz(:)+g(:,ig) qq_fact=qq(1)**2+qq(2)**2+qq(3)**2 vg_q(ig)=vg_q(ig)+1.d0/qq_fact enddo enddo enddo vg_q(ig)=vg_q(ig)*e2*fpi/(8.d0*(dble(n_int_loc))**3.d0)/tpiba2 enddo endif vg_q(:)=vg_q(:)/omega if(gstart==2) write(stdout,*) 'V(G=0) = ',vg_q(1) ! if(ionode) then ! iun = find_free_unit() ! open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.vg_q', status='unknown',form='unformatted') ! write(iun) vg_q(1:npw) ! close(iun) ! endif iun = find_free_unit() CALL diropn( iun, 'vgq', npwx, exst ) CALL davcio(vg_q,npwx,iun,1,1) close(iun) return end subroutine calculate_vg0 subroutine read_vg0 !this subroutine read v(G) for pbc from disk USE wannier_gw, ONLY : vg_q USE wvfct, ONLY : npw,npwx USE io_global, ONLY : stdout, ionode, ionode_id USE io_files, ONLY : prefix, tmp_dir,diropn USE mp, ONLY : mp_bcast implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER :: iun LOGICAL :: exst ! if(ionode) then ! iun = find_free_unit() ! open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.vg_q', status='old',form='unformatted') ! read(iun) vg_q(1:npw) ! close(iun) ! endif ! call mp_bcast(vg_q(1:npw),ionode_id) iun = find_free_unit() CALL diropn( iun, 'vgq', npwx, exst ) CALL davcio(vg_q,npwx,iun,1,-1) close(iun) return end subroutine read_vg0 GWW/pw4gww/mp_wave_parallel.f900000644000077300007730000002563012341332532017107 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! MODULE mp_wave_parallel IMPLICIT NONE SAVE CONTAINS SUBROUTINE mergewfp ( npw,pw, pwt, ngwl, ig_l2g, mpime, nproc, root, comm ) ! ... This subroutine merges the pieces of a wave functions (pw) splitted across ! ... processors into a total wave function (pwt) containing al the components ! ... in a pre-defined order (the same as if only one processor is used) USE kinds USE parallel_include USE io_global, ONLY :stdout IMPLICIT NONE INTEGER, INTENT(in) :: npw,ngwl COMPLEX(DP), intent(in) :: PW(npw,nproc) COMPLEX(DP), intent(out) :: PWT(:) INTEGER, INTENT(IN) :: mpime ! index of the calling processor ( starting from 0 ) INTEGER, INTENT(IN) :: nproc ! number of processors INTEGER, INTENT(IN) :: root ! root processor ( the one that should receive the data ) INTEGER, INTENT(IN) :: comm ! communicator INTEGER, INTENT(IN) :: ig_l2g(:) INTEGER, ALLOCATABLE :: ig_ip(:) COMPLEX(DP), ALLOCATABLE :: pw_ip(:) INTEGER :: ierr, i, ip, ngw_ip, ngw_lmax, itmp, igwx, gid, req #if defined __MPI INTEGER :: istatus(MPI_STATUS_SIZE) #endif INTEGER :: iorig, idest ! ! ... Subroutine Body ! igwx = MAXVAL( ig_l2g(1:ngwl) ) #if defined __MPI gid = comm ! ... Get local and global wavefunction dimensions CALL MPI_ALLREDUCE( ngwl, ngw_lmax, 1, MPI_INTEGER, MPI_MAX, gid, IERR ) CALL MPI_ALLREDUCE( igwx, itmp, 1, MPI_INTEGER, MPI_MAX, gid, IERR ) igwx = itmp #endif IF( igwx > SIZE( pwt ) ) & CALL errore(' mergewf ',' wrong size for pwt ',SIZE(pwt) ) #if defined __MPI ALLOCATE(ig_ip(ngw_lmax)) ALLOCATE(pw_ip(ngw_lmax)) do ip = 0, nproc-1 if( ip/=0) then ! ... In turn each processors send to root the wave components and their indexes in the ! ... global array idest=mpime+ip if(idest>nproc-1)idest=idest-nproc iorig=mpime-ip if(iorig<0)iorig=iorig+nproc CALL MPI_ISEND( ig_l2g, ngwl, MPI_INTEGER, idest, IP, gid, req,IERR ) CALL MPI_RECV( ig_ip, ngw_lmax, MPI_INTEGER, iorig, IP, gid, istatus, IERR ) CALL MPI_WAIT(req,istatus,ierr) CALL MPI_ISEND( pw(1,idest+1), ngwl, MPI_DOUBLE_COMPLEX, idest, IP, gid, req,IERR ) CALL MPI_RECV( pw_ip, ngw_lmax, MPI_DOUBLE_COMPLEX, iorig, IP, gid, istatus, IERR ) CALL MPI_GET_COUNT( istatus, MPI_DOUBLE_COMPLEX, ngw_ip, ierr ) CALL MPI_WAIT(req,istatus,ierr) DO I = 1, ngw_ip PWT(ig_ip(i)) = pw_ip(i) END DO ELSE DO I = 1, ngwl PWT(ig_l2g(i)) = pw(i,mpime+1) END DO END IF CALL MPI_BARRIER( gid, IERR ) END DO DEALLOCATE(ig_ip) DEALLOCATE(pw_ip) #elif ! defined __PARA DO I = 1, ngwl PWT( ig_l2g(i) ) = pw(i,1) END DO #else CALL errore(' MERGEWF ',' no communication protocol ',0) #endif RETURN END SUBROUTINE mergewfp SUBROUTINE splitwfp (npw, pw, pwt, ngwl, ig_l2g, mpime, nproc,root, comm ) ! ... This subroutine splits a total wave function (pwt) containing al the components ! ... in a pre-defined order (the same as if only one processor is used), across ! ... processors (pw). USE kinds USE parallel_include USE io_global, ONLY : stdout IMPLICIT NONE INTEGER, INTENT(in) :: npw,nproc COMPLEX(DP), INTENT(OUT) :: PW(npw,nproc) COMPLEX(DP), INTENT(IN) :: PWT(:) INTEGER, INTENT(IN) :: mpime, root INTEGER, INTENT(IN) :: comm ! communicator INTEGER, INTENT(IN) :: ig_l2g(:) INTEGER, INTENT(IN) :: ngwl INTEGER, ALLOCATABLE :: ig_ip(:) COMPLEX(DP), ALLOCATABLE :: pw_ip(:) INTEGER ierr, i, ngw_ip, ip, ngw_lmax, gid, igwx, itmp,len, req #if defined __MPI integer istatus(MPI_STATUS_SIZE) #endif INTEGER :: iorig, idest ! ! ... Subroutine Body ! igwx = MAXVAL( ig_l2g(1:ngwl) ) #if defined __MPI gid = comm ! ... Get local and global wavefunction dimensions CALL MPI_ALLREDUCE(ngwl, ngw_lmax, 1, MPI_INTEGER, MPI_MAX, gid, IERR ) CALL MPI_ALLREDUCE(igwx, itmp , 1, MPI_INTEGER, MPI_MAX, gid, IERR ) igwx = itmp #endif IF( igwx > SIZE( pwt ) ) & CALL errore(' splitwf ',' wrong size for pwt ',SIZE(pwt) ) #if defined __MPI ALLOCATE(ig_ip(ngw_lmax)) ALLOCATE(pw_ip(ngw_lmax)) DO ip = 0, nproc-1 idest=mpime+ip if(idest>nproc-1)idest=idest-nproc iorig=mpime-ip if(iorig<0)iorig=iorig+nproc if(ip/=0) then CALL MPI_ISEND( ig_l2g, ngwl, MPI_INTEGER, iorig, IP, gid,req,IERR) CALL MPI_RECV( ig_ip, ngw_lmax, MPI_INTEGER, idest, IP, gid, istatus, IERR ) CALL MPI_GET_COUNT(istatus, MPI_INTEGER, ngw_ip, ierr) DO i = 1, ngw_ip pw_ip(i) = PWT(ig_ip(i)) END DO CALL MPI_WAIT(req,istatus,ierr) CALL MPI_ISEND( pw_ip, ngw_ip, MPI_DOUBLE_COMPLEX, idest, IP, gid,req, IERR ) CALL MPI_RECV( pw(1,iorig+1), ngwl, MPI_DOUBLE_COMPLEX, iorig, IP, gid, istatus, IERR ) !CALL MPI_GET_COUNT(istatus, MPI_INTEGER, ngw_ip, ierr) CALL MPI_WAIT(req,istatus,ierr) ELSE DO i = 1, ngwl pw(i,mpime+1) = PWT(ig_l2g(i)) END DO END IF CALL MPI_BARRIER(gid, IERR) END DO DEALLOCATE(ig_ip) DEALLOCATE(pw_ip) #elif ! defined __PARA DO I = 1, ngwl pw(i,1) = pwt( ig_l2g(i) ) END DO #else CALL errore(' SPLITWF ',' no communication protocol ',0) #endif RETURN END SUBROUTINE splitwfp END MODULE mp_wave_parallel SUBROUTINE reorderwfp (nbands,npw1, npw2,pw1,pw2, ngwl1,ngwl2, ig_l2g1,ig_l2g2,n_g,mpime, nproc,root, comm ) USE kinds USE parallel_include USE io_global, ONLY : stdout USE mp_wave_parallel IMPLICIT NONE INTEGER, INTENT(in) :: npw1,npw2,nbands COMPLEX(DP), INTENT(OUT) :: pw1(npw1,nbands),pw2(npw2,nbands) INTEGER, INTENT(IN) :: mpime, root, nproc INTEGER, INTENT(IN) :: comm ! communicator INTEGER, INTENT(IN) :: ig_l2g1(ngwl1),ig_l2g2(ngwl2) INTEGER, INTENT(IN) :: ngwl1,ngwl2 INTEGER, INTENT(in) :: n_g!global maximum number of G vectors for both grids COMPLEX(kind=DP), ALLOCATABLE :: cbuf1(:,:),cbuf2(:,:), pwt(:) INTEGER :: ii, ilast allocate(cbuf1(npw1,nproc),cbuf2(npw2,nproc)) allocate(pwt(n_g)) cbuf1(:,:)=(0.d0,0.d0) cbuf2(:,:)=(0.d0,0.d0) !loop on block of states do ii=1,nbands,nproc ilast=min(nbands,ii+nproc-1) cbuf1(1:npw1,1:(ilast-ii+1))=pw1(1:npw1,ii:ilast) call mergewfp ( npw1,cbuf1, pwt, ngwl1, ig_l2g1, mpime, nproc, root, comm ) call splitwfp (npw2, cbuf2, pwt, ngwl2, ig_l2g2, mpime, nproc,root, comm ) pw2(1:npw2,ii:ilast)=cbuf2(1:npw2,1:(ilast-ii+1)) enddo deallocate(cbuf1,cbuf2) deallocate(pwt) return END SUBROUTINE reorderwfp SUBROUTINE reorderwfp_col (nbands,npw1, npw2,pw1,pw2, ngwl1,ngwl2, ig_l2g1,ig_l2g2,n_g,mpime, nproc, comm ) !routine using collective mpi calls USE kinds USE parallel_include USE io_global, ONLY : stdout USE mp_wave_parallel IMPLICIT NONE INTEGER, INTENT(in) :: npw1,npw2,nbands COMPLEX(kind=DP) :: pw1(npw1,nbands),pw2(npw2,nbands) INTEGER, INTENT(IN) :: mpime, nproc INTEGER, INTENT(IN) :: comm ! communicator INTEGER, INTENT(IN) :: ig_l2g1(ngwl1),ig_l2g2(ngwl2) INTEGER, INTENT(IN) :: ngwl1,ngwl2 INTEGER, INTENT(in) :: n_g!global maximum number of G vectors for both grids INTEGER :: ngwl1_max,ngwl2_max,npw1_max,npw2_max INTEGER :: gid,ierr INTEGER, ALLOCATABLE :: npw1_loc(:),npw2_loc(:) INTEGER, ALLOCATABLE :: ig_l2g1_tot(:,:),ig_l2g2_tot(:,:), itmp(:) INTEGER :: ii,ip,ilast,iband COMPLEX(kind=DP), ALLOCATABLE :: pw1_tot(:,:),pw2_tot(:,:) COMPLEX(kind=DP), ALLOCATABLE :: pw1_tmp(:),pw2_tmp(:), pw_global(:) gid=comm #if defined __MPI allocate(npw1_loc(nproc),npw2_loc(nproc)) !all procs gather correspondance arrays CALL MPI_ALLREDUCE( ngwl1, ngwl1_max, 1, MPI_INTEGER, MPI_MAX, gid, IERR ) CALL MPI_ALLREDUCE( ngwl2, ngwl2_max, 1, MPI_INTEGER, MPI_MAX, gid, IERR ) CALL MPI_ALLREDUCE( npw1, npw1_max, 1, MPI_INTEGER, MPI_MAX, gid, IERR ) CALL MPI_ALLREDUCE( npw2, npw2_max, 1, MPI_INTEGER, MPI_MAX, gid, IERR ) CALL MPI_ALLGATHER (npw1,1,MPI_INTEGER,npw1_loc,1,MPI_INTEGER,gid,IERR) CALL MPI_ALLGATHER (npw2,1,MPI_INTEGER,npw2_loc,1,MPI_INTEGER,gid,IERR) allocate(ig_l2g1_tot(ngwl1_max,nproc),ig_l2g2_tot(ngwl2_max,nproc)) allocate(itmp(ngwl1_max)) itmp(1:ngwl1)=ig_l2g1(1:ngwl1) CALL MPI_ALLGATHER (itmp,ngwl1_max,MPI_INTEGER,ig_l2g1_tot,ngwl1_max,MPI_INTEGER,gid,IERR) deallocate(itmp) allocate(itmp(ngwl2_max)) itmp(1:ngwl2)=ig_l2g2(1:ngwl2) CALL MPI_ALLGATHER (itmp,ngwl2_max,MPI_INTEGER,ig_l2g2_tot,ngwl2_max,MPI_INTEGER,gid,IERR) deallocate(itmp) allocate(pw1_tot(npw1_max,nproc),pw2_tot(npw2_max,nproc)) allocate(pw1_tmp(npw1_max),pw2_tmp(npw2_max)) allocate(pw_global(n_g)) do ii=1,nbands,nproc ilast=min(nbands,ii+nproc-1) do iband=ii,ilast ip=mod(iband,nproc)!ip starts from 1 to nproc-1 pw1_tmp(1:npw1)=pw1(1:npw1,iband) CALL MPI_GATHER (pw1_tmp,npw1_max,MPI_DOUBLE_COMPLEX,pw1_tot,npw1_max,MPI_DOUBLE_COMPLEX,ip,gid,ierr) enddo pw_global=0.d0 do ip=1,nproc pw_global(ig_l2g1_tot(1:npw1_loc(ip),ip))=pw1_tot(1:npw1_loc(ip),ip) enddo do ip=1,nproc pw2_tot(1:npw2_loc(ip),ip)=pw_global(ig_l2g2_tot(1:npw2_loc(ip),ip)) enddo do iband=ii,ilast ip=mod(iband,nproc) CALL MPI_SCATTER (pw2_tot,npw2_max,MPI_DOUBLE_COMPLEX,pw2_tmp,npw2_max ,MPI_DOUBLE_COMPLEX,ip,gid,ierr) pw2(1:npw2,iband)=pw2_tmp(1:npw2) enddo enddo deallocate(npw1_loc,npw2_loc) deallocate(ig_l2g1_tot,ig_l2g2_tot) deallocate(pw1_tot,pw2_tot) deallocate(pw1_tmp,pw2_tmp) deallocate(pw_global) #endif return END SUBROUTINE reorderwfp_col GWW/pw4gww/start_pw4gww.f900000644000077300007730000000123312341332532016242 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! ! subroutine start_pw4gww ! ! Usage: [mpirun, mpprun, whatever] postproc [-npool N] ! ! Wrapper routine for postprocessing initialization ! USE mp_global, ONLY: mp_startup USE environment, ONLY: environment_start implicit none character(len=9) :: code = 'PW4GWW' ! #ifdef __PARA CALL mp_startup ( ) #endif CALL environment_start ( code ) ! return end subroutine start_pw4gww GWW/pw4gww/o_rinitcgg.f900000644000077300007730000001054712341332532015722 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !---------------------------------------------------------------------------- SUBROUTINE o_rinitcgg( npwx, npw, nstart, numwp, psi, o_evc, e, numv, v_states,hdiag,ptype,fcw_number,fcw_state,fcw_mat,ethr) !---------------------------------------------------------------------------- ! ! ... Operator O diagonalization in the subspace spanned ! ... by nstart states psi (atomic or random wavefunctions). ! ... Produces on output numwp eigenvectors (numwp <= nstart) in o_evc. ! ... Minimal memory use - o_evc and psi may overlap ! ... Calls o_1psi to calculate O|psi> ! USE kinds, ONLY : DP USE gvect, ONLY : gstart USE io_global, ONLY : stdout USE mp, ONLY : mp_sum USE mp_world, ONLY : world_comm USE fft_base, ONLY : dffts ! IMPLICIT NONE ! INTEGER :: npw, npwx, nstart, numwp ! dimension of the matrix to be diagonalized ! leading dimension of matrix psi, as declared in the calling pgm unit ! input number of states ! output number of states COMPLEX (DP) :: psi(npwx,nstart), o_evc(npwx,numwp) ! input and output eigenvectors (may overlap) REAL(DP) :: e(numwp) INTEGER, INTENT(in) :: numv!number of valence states REAL(kind=DP), INTENT(in) :: v_states(dffts%nnr,numv) !valence states in real space REAL(kind=DP), INTENT(in) :: hdiag(npw)!inverse of estimation of diagonal part of hamiltonian INTEGER, INTENT(in) :: ptype!type of approximation for O operator INTEGER, INTENT(in) :: fcw_number!number of "fake conduction" states for O matrix method COMPLEX(kind=DP) :: fcw_state(npw,fcw_number)! "fake conduction" states for O matrix method REAL(kind=DP) :: fcw_mat(fcw_number,fcw_number)! "fake conduction" matrix REAL(kind=DP), INTENT(in) :: ethr!threshold for o_1psi_gamma ! eigenvalues ! !... local variables ! INTEGER :: m, i, j, npw2, npwx2 REAL (DP) :: rtmp(2) COMPLEX (DP), ALLOCATABLE :: aux(:,:) COMPLEX (DP), ALLOCATABLE :: ctmp(:) REAL (DP), ALLOCATABLE :: hr(:,:,:), sr(:,:) REAL (DP), ALLOCATABLE :: en(:) ! ! CALL start_clock( 'wfcrot1' ) ! npw2 = 2 * npw npwx2 = 2 * npwx ! ALLOCATE( aux( npwx, 2 ) ) ALLOCATE( ctmp( numwp ) ) ALLOCATE( hr( nstart, nstart, 2 ) ) ALLOCATE( sr( nstart, nstart ) ) ALLOCATE( en( nstart ) ) ! ! ... Set up the Hamiltonian and Overlap matrix ! DO m = 1, nstart ! !CALL h_1psi( npwx, npw, psi(1,m), aux(1,1), aux(1,2) ) write(stdout,*) 'Call o_1psi_gamma',m,nstart call flush_unit(stdout) call o_1psi_gamma( numv, v_states, psi(1,m), aux(1,1),.false.,hdiag,ptype,fcw_number,fcw_state,fcw_mat,ethr) write(stdout,*) 'Done' call flush_unit(stdout) !call o_1psi_gamma_real( numv, v_states, psi(1,m), aux(1,1)) aux(:,2)=psi(:,m) ! CALL DGEMV( 'T', npw2, 2, 2.D0, aux, npwx2, psi(1,m), 1, 0.D0, rtmp, 1 ) ! IF ( gstart == 2 ) rtmp(:) = rtmp(:) - psi(1,m) * aux(1,:) ! hr(m,m,1) = rtmp(1) sr(m,m) = rtmp(2) ! DO j = m + 1, nstart ! CALL DGEMV( 'T', npw2, 2, 2.D0, aux, npwx2, psi(1,j), 1, 0.D0, rtmp, 1 ) ! IF ( gstart == 2 ) rtmp(:) = rtmp(:) - psi(1,j) * aux(1,:) ! hr(j,m,1) = rtmp(1) sr(j,m) = rtmp(2) ! hr(m,j,1) = rtmp(1) sr(m,j) = rtmp(2) ! END DO ! END DO ! !CALL reduce( nstart * nstart, hr(1,1,1) ) call mp_sum(hr(:,:,1),world_comm) !CALL reduce( nstart * nstart, sr(1,1) ) CALL mp_sum(sr(:,:),world_comm) ! ! ... diagonalize ! write(stdout,*) 'Call rdiaghg' call flush_unit(stdout) CALL rdiaghg( nstart, numwp, hr, sr, nstart, en, hr(1,1,2) ) write(stdout,*) 'Done' call flush_unit(stdout) ! e(1:numwp) = en(1:numwp) ! ! ... update the basis set ! DO i = 1, npw ! DO m = 1, numwp ! ctmp(m) = SUM( hr(:,m,2) * psi(i,:) ) ! END DO ! o_evc(i,1:numwp) = ctmp(1:numwp) ! END DO ! DEALLOCATE( en ) DEALLOCATE( sr ) DEALLOCATE( hr ) DEALLOCATE( ctmp ) DEALLOCATE( aux ) ! CALL stop_clock( 'wfcrot1' ) ! RETURN ! END SUBROUTINE o_rinitcgg GWW/pw4gww/contour_terms.f900000644000077300007730000000472112341332532016476 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !this routines calculates the terms <\psi_i|s_\alpha> where s_alpha is the global !s_basis and write them on disk !the KS states are taken on evc subroutine contour_terms(n_s,s_basis,ispin,istate) !NOT_TO_BE_INCLUDED_START USE io_global, ONLY : stdout, ionode, ionode_id USE io_files, ONLY : prefix, tmp_dir, nwordwfc,iunwfc USE kinds, ONLY : DP USE wannier_gw, ONLY : num_nbnds,num_nbndv,s_first_state,s_last_state, l_verbose USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, ecutwfc USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : mpime,nproc,world_comm USE wavefunctions_module, ONLY : evc USE gvect, ONLY : gstart implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER, INTENT(in) :: n_s!number of global s vectors COMPLEX(kind=DP), INTENT(in) :: s_basis( npw,n_s)!s vectors INTEGER, INTENT(in) :: ispin!spin channel INTEGER, INTENT(in) :: istate!KS states relative to global s vectors for big_system option REAL(kind=DP), ALLOCATABLE :: c_mat(:,:) INTEGER :: ii,jj,iun,ig CHARACTER(4) :: nfile allocate(c_mat(n_s,num_nbnds)) call dgemm('T','N',n_s,num_nbnds,2*npw,2.d0,s_basis,2*npw,evc,2*npwx,0.d0,c_mat,n_s) if(gstart==2) then do ii=1,n_s do jj=1,num_nbnds c_mat(ii,jj)= c_mat(ii,jj)-dble(s_basis(1,ii)*conjg(evc(1,jj))) enddo enddo endif !DEBUG call mp_sum(c_mat,world_comm) if(ionode) then iun= find_free_unit() write(nfile,'(4i1)') istate/1000,mod(istate,1000)/100,mod(istate,100)/10,mod(istate,10) if(ispin==1) then open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.s_contour'//nfile , status='unknown',form='unformatted') else open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.s_contour2'//nfile , status='unknown',form='unformatted') endif write(iun) num_nbnds write(iun) n_s do jj=1,num_nbnds write(iun) c_mat(1:n_s,jj)!GIUSTO CUSSI !write(iun) c_mat(1:n_s,4)!ATTENZIONE DEBUG enddo close(iun) endif deallocate(c_mat) return !NOT_TO_BE_INCLUDED_END end subroutine contour_terms GWW/pw4gww/energies_xc.f900000644000077300007730000003727712341332532016102 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! ! !---------------------------------------------------------------------------- SUBROUTINE energies_xc( lda, n, m, psi, e_xc, e_h,ispin ) !---------------------------------------------------------------------------- ! ! computes the expectation values of the exchange and correlation potential ! and of hartree potential ! ... input: ! ... lda leading dimension of arrays psi, spsi, hpsi ! ... n true dimension of psi, spsi, hpsi ! ... m number of states psi ! ... psi ! ! ... output: ! e_xc ! e_h USE kinds, ONLY : DP USE uspp, ONLY : vkb, nkb USE wvfct, ONLY : igk, g2kin, ecutwfc USE gvecs, ONLY : nls, doublegrid USE gvect, ONLY : ngm, gstart, nl, nlm, g, gg, gcutm USE cell_base, ONLY : alat, omega USE lsda_mod, ONLY : nspin USE ldaU, ONLY : lda_plus_u USE lsda_mod, ONLY : current_spin USE gvect, ONLY : gstart USE io_global, ONLY :stdout USE scf, ONLY : rho, vltot, vrs, rho_core,rhog_core, scf_type USE constants, ONLY :rytoev USE io_files, ONLY : diropn USE mp, ONLY : mp_sum, mp_barrier USE mp_world, ONLY : world_comm USE control_flags, ONLY : gamma_only USE funct, ONLY : dft_is_meta USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft USE exx, ONLY : vexx !Suriano USE funct, ONLY : exx_is_active,dft_is_hybrid ! IMPLICIT NONE INTEGER, EXTERNAL :: find_free_unit ! ! ... input/output arguments ! INTEGER :: lda, n, m COMPLEX(DP) :: psi(lda,m) REAL(kind=DP) :: e_xc(m), e_h(m) INTEGER, INTENT(in) :: ispin !spin 1,2 REAL(kind=DP), ALLOCATABLE :: vr(:,:) ! ! CALL start_clock( 'h_psi' ) allocate(vr(dfftp%nnr,nspin)) ! IF ( gamma_only ) THEN ! CALL energies_xc_gamma() ! ELSE ! CALL energies_xc_k( ) ! END IF ! CALL stop_clock( 'h_psi' ) deallocate(vr) ! RETURN ! CONTAINS ! !----------------------------------------------------------------------- SUBROUTINE energies_xc_k( ) !----------------------------------------------------------------------- ! ! ... k-points version ! USE wavefunctions_module, ONLY : psic USE becmod, ONLY : becp ! IMPLICIT NONE ! INTEGER :: ibnd, j,is, ig REAL(dp) :: etxc,vtxc REAL(kind=DP) :: ehart, charge ! counters ! ! ! ! ... Here we apply the kinetic energy (k+G)^2 psi ! ! ! ! ... Here we add the Hubbard potential times psi ! ! ! ... the local potential V_Loc psi. First the psi in real space !set exchange and correlation potential if(.not.allocated(psic)) write(stdout,*) 'psic not allocated' if (dft_is_meta()) then ! call v_xc_meta( rho, rho_core, rhog_core, etxc, vtxc, v%of_r, v%kin_r ) else CALL v_xc( rho, rho_core, rhog_core, etxc, vtxc, vr ) endif do is=1,nspin vrs(:,is)=vr(:,is) if(doublegrid) call interpolate(vrs(1,is),vrs(1,is),-1) enddo ! DO ibnd = 1, m ! CALL start_clock( 'firstfft' ) ! psic(1:dffts%nnr) = ( 0.D0, 0.D0 ) ! psic(nls(igk(1:n))) = psi(1:n,ibnd) ! CALL invfft ('Wave', psic, dffts) ! CALL stop_clock( 'firstfft' ) ! ! ... product with the potential vrs = (vltot+vr) on the smooth grid ! psic(1:dffts%nnr) = psic(1:dffts%nnr) * vrs(1:dffts%nnr,1) ! ! ... back to reciprocal space ! CALL start_clock( 'secondfft' ) ! CALL fwfft ('Wave', psic, dffts) ! ! ... addition to the total product ! e_xc(ibnd)=0.d0 do ig=1,n e_xc(ibnd)=e_xc(ibnd)+real(conjg(psi(ig,ibnd))*psic(nls(igk(ig)))) enddo call mp_sum(e_xc(ibnd),world_comm) write(stdout,*) 'energies_xc :', ibnd, e_xc(ibnd)*rytoev ! CALL stop_clock( 'secondfft' ) ! END DO vr(:,:)=0.d0 call v_h(rho%of_g , ehart, charge, vr ) do is=1,nspin vrs(:,is)=vr(:,is) if(doublegrid) call interpolate(vrs(1,is),vrs(1,is),-1) enddo DO ibnd = 1, m CALL start_clock( 'firstfft' ) psic(1:dffts%nnr) = ( 0.D0, 0.D0 ) psic(nls(igk(1:n))) = psi(1:n,ibnd) CALL invfft ('Wave', psic, dffts) CALL stop_clock( 'firstfft' ) psic(1:dffts%nnr) = psic(1:dffts%nnr) * vrs(1:dffts%nnr,1) CALL start_clock( 'secondfft' ) CALL fwfft ('Wave', psic, dffts) e_h(ibnd)=0.d0 do ig=1,n e_h(ibnd)=e_h(ibnd)+real(conjg(psi(ig,ibnd))*psic(nls(igk(ig)))) enddo call mp_sum(e_h(ibnd),world_comm) write(stdout,*) 'energies_h :', ibnd, e_h(ibnd)*rytoev CALL stop_clock( 'secondfft' ) enddo! ! ! ! RETURN ! END SUBROUTINE energies_xc_k SUBROUTINE energies_xc_gamma USE uspp, ONLY : okvan USE wannier_gw, ONLY : becp_gw, restart_gww,l_whole_s,l_verbose,& &l_scissor,scissor,num_nbndv ! USE realus, ONLY : adduspos_gamma_r USE wvfct, ONLY : npwx,npw,nbnd, et,g2kin USE wavefunctions_module, ONLY : evc USE klist, ONLY : xk USE mp, ONLY : mp_sum USE mp_world, ONLY : world_comm USE gvect, ONLY : gstart,g USE constants, ONLY : rytoev USE becmod, ONLY : becp, calbec,allocate_bec_type,deallocate_bec_type USE cell_base, ONLY : tpiba2 USE io_global, ONLY : ionode USE io_files, ONLY :prefix,tmp_dir USE exx, ONLY : exxalfa implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER :: ibnd,jbnd,ir,ig INTEGER :: iunwfcreal,iunu REAL(kind=DP) :: etxc,vtxc,ehart, charge REAL(kind=DP), ALLOCATABLE :: psi_r(:),psi_rs(:) LOGICAL :: exst REAL(kind=DP), ALLOCATABLE :: rho_fake_core(:) COMPLEX(kind=DP), ALLOCATABLE :: hpsi(:,:) REAL(kind=DP), ALLOCATABLE :: exact_x(:) REAL(kind=DP), ALLOCATABLE :: e_hub(:)!Hubbard contribution to KS energies REAL(kind=DP), ALLOCATABLE :: et_off(:,:)!off-diagonal energies allocate(exact_x(nbnd)) allocate(e_hub(nbnd)) if(l_whole_s) then allocate (et_off(nbnd,nbnd)) endif !if required calculates also the KS energies ! if(restart_gww==-1) then if(l_verbose) write(stdout,*) 'ATTENZIONE1' call flush_unit(stdout) !allocate( becp%r( nkb, nbnd ) ) call allocate_bec_type ( nkb, nbnd, becp) if(l_verbose) write(stdout,*) 'ATTENZIONE2' call flush_unit(stdout) IF ( nkb > 0 ) CALL init_us_2( npw, igk, xk(1,1), vkb ) !call ccalbec( nkb, npwx, npw, nbnd, becp%r, vkb, evc ) !if(nkb> 0)CALL calbec ( npw, vkb, psi, becp, nbnd) if(l_verbose)write(stdout,*) 'ATTENZIONE3' call flush_unit(stdout) allocate(hpsi(npwx,nbnd)) if(l_verbose)write(stdout,*) 'ATTENZIONE4' call flush_unit(stdout) g2kin(1:npw) = ( ( xk(1,1) + g(1,igk(1:npw)) )**2 + & ( xk(2,1) + g(2,igk(1:npw)) )**2 + & ( xk(3,1) + g(3,igk(1:npw)) )**2 ) * tpiba2 if(l_verbose)write(stdout,*) 'ATTENZIONE5' call flush_unit(stdout) ! exxalfa=0.d0!ATTENZIONE call h_psi( npwx, npw, nbnd, psi, hpsi ) et(:,ispin)=0.d0 if(l_verbose)write(stdout,*) 'ATTENZIONE6' if(l_verbose)write(stdout,*) 'EXXALFA', exxalfa call flush_unit(stdout) do ibnd=1,nbnd ! call dgemm('T','N',1,1,2*npw,2.d0,evc(:,ibnd),2*npwx,hpsi(:,ibnd),2*npwx,& ! &0.d0,et(ibnd,1),1) do ig=1,npw et(ibnd,ispin)=et(ibnd,ispin)+2.d0*dble(conjg(evc(ig,ibnd))*hpsi(ig,ibnd)) enddo if(gstart==2) then et(ibnd,ispin)=et(ibnd,ispin)-dble(conjg(evc(1,ibnd))*hpsi(1,ibnd)) endif enddo call mp_sum(et(:,ispin),world_comm) if(l_scissor) then et(1:num_nbndv(ispin),ispin)=et(1:num_nbndv(ispin),ispin)+scissor/rytoev endif if(l_verbose)write(stdout,*) 'ATTENZIONE7' call flush_unit(stdout) !if required calculate Hubbard U contribution to eigen-energies e_hub(:)=0.d0 if ( lda_plus_u ) then hpsi(:,:)=(0.d0,0.d0) CALL vhpsi( npwx, npw, nbnd, psi, hpsi ) do ibnd=1,nbnd do ig=1,npw e_hub(ibnd)=e_hub(ibnd)+2.d0*dble(conjg(psi(ig,ibnd))*hpsi(ig,ibnd)) enddo if(gstart==2) then e_hub(ibnd)=e_hub(ibnd)-dble(conjg(psi(1,ibnd))*hpsi(1,ibnd)) endif enddo call mp_sum(e_hub(:),world_comm) do ibnd=1,nbnd write(stdout,*) 'Hubbard U energy:',ibnd,e_hub(ibnd)*rytoev enddo call flush_unit(stdout) endif do ibnd=1,nbnd write(stdout,*) 'KS energy:',ibnd,et(ibnd,ispin)*rytoev enddo call flush_unit(stdout) !in case of hybrid functionals and HF we have to calculated also the exact exchange part if(dft_is_hybrid()) then !NOT_TO_BE_INCLUDED_START hpsi(:,:)=(0.d0,0.d0) call vexx( npwx, npw, nbnd, psi, hpsi ) do ibnd=1,nbnd call dgemm('T','N',1,1,2*npw,2.d0,evc(:,ibnd),2*npwx,hpsi(:,ibnd),2*npwx,& &0.d0,exact_x(ibnd),1) if(gstart==2) then exact_x(ibnd)=exact_x(ibnd)-dble(conjg(evc(1,ibnd))*hpsi(1,ibnd)) endif call mp_sum(exact_x(ibnd),world_comm) write(stdout,*) 'Exact exchange :',ibnd, exact_x(ibnd) enddo !NOT_TO_BE_INCLUDED_END end if ! deallocate(hpsi,becp%r) call deallocate_bec_type ( becp) ! endif allocate(psi_r(dfftp%nnr),psi_rs(dfftp%nnr)) iunwfcreal=find_free_unit() CALL diropn( iunwfcreal, 'real_whole', dfftp%nnr, exst ) !calculate xc potential on fine grid if(.not.allocated(vr)) write(stdout,*) 'vr not allocated' allocate(rho_fake_core(dfftp%nnr)) rho_fake_core(:)=0.d0 if (dft_is_meta()) then ! call v_xc_meta( rho, rho_core, rhog_core, etxc, vtxc, v%of_r, v%kin_r ) else CALL v_xc( rho, rho_core, rhog_core, etxc, vtxc, vr ) endif deallocate(rho_fake_core) if(l_whole_s) then !NOT_TO_BE_INCLUDED_START allocate(hpsi(npwx,nbnd)) hpsi(:,:)=(0.d0,0.d0) CALL vloc_psi_gamma ( npwx, npw, nbnd, evc, vr(1,ispin), hpsi ) call dgemm('T','N',nbnd,nbnd,2*npw,2.d0,evc,2*npwx,hpsi,2*npwx,& &0.d0,et_off,nbnd) if(gstart==2) then do ibnd=1,nbnd do jbnd=1,nbnd et_off(ibnd,jbnd)=et_off(ibnd,jbnd)-dble(conjg(evc(1,ibnd))*hpsi(1,jbnd)) enddo enddo endif deallocate(hpsi) call mp_sum(et_off,world_comm) !write on file if(ionode) then iunu = find_free_unit() if(ispin==1) then open(unit=iunu,file=trim(tmp_dir)//trim(prefix)//'.exc_off',status='unknown',form='unformatted') else open(unit=iunu,file=trim(tmp_dir)//trim(prefix)//'.exc_off2',status='unknown',form='unformatted') endif write(iunu) nbnd do ibnd=1,nbnd write(iunu) et_off(1:nbnd,ibnd) enddo close(iunu) endif !NOT_TO_BE_INCLUDED_END endif do ibnd=1,m!loop on states !read from disk wfc on coarse grid CALL davcio( psi_rs,dffts%nnr,iunwfcreal,ibnd+(ispin-1)*nbnd,-1) if(doublegrid) then call interpolate(psi_r,psi_rs,1) else psi_r(:)=psi_rs(:) endif do ir=1,dfftp%nnr psi_r(ir)=psi_r(ir)**2.d0 enddo !if(okvan) call adduspos_gamma_r(ibnd,ibnd,psi_r,1,becp_gw(:,ibnd),becp_gw(:,ibnd)) e_xc(ibnd)=0.d0 do ir=1,dfftp%nnr e_xc(ibnd)=e_xc(ibnd)+psi_r(ir)*vr(ir,ispin)!the 1 is for the spin NOT IMPLEMENTED YET enddo e_xc(ibnd)=e_xc(ibnd)/dble(dfftp%nr1*dfftp%nr2*dfftp%nr3) call mp_sum(e_xc(ibnd),world_comm) !ifrequired add the contribution from exact exchange for hybrids and HF if(dft_is_hybrid()) then !NOT_TO_BE_INCLUDED_START e_xc(ibnd)=e_xc(ibnd)+exact_x(ibnd) !NOT_TO_BE_INCLUDED_END endif write(stdout,*) 'Routine energies_xc :', ibnd, e_xc(ibnd)*rytoev !now hartree term enddo !if required add to e_xc Hubbard U terms if(lda_plus_u) then e_xc(1:nbnd)=e_xc(1:nbnd)+e_hub(1:nbnd) endif vr(:,:)=0.d0 call v_h(rho%of_g , ehart, charge, vr ) do ibnd=1,m!loop on states !read from disk wfc on coarse grid CALL davcio( psi_rs,dffts%nnr,iunwfcreal,ibnd+(ispin-1)*nbnd,-1) if(doublegrid) then call interpolate(psi_r,psi_rs,1) else psi_r(:)=psi_rs(:) endif do ir=1,dfftp%nnr psi_r(ir)=psi_r(ir)**2.d0 enddo !if(okvan) call adduspos_gamma_r(ibnd,ibnd,psi_r,1,becp_gw(:,ibnd),becp_gw(:,ibnd)) e_h(ibnd)=0.d0 do ir=1,dfftp%nnr e_h(ibnd)=e_h(ibnd)+psi_r(ir)*vr(ir,ispin) enddo e_h(ibnd)=e_h(ibnd)/dble(dfftp%nr1*dfftp%nr2*dfftp%nr3) call mp_sum(e_h(ibnd),world_comm) write(stdout,*) 'Routine energies_h :', ibnd, e_h(ibnd)*rytoev !now hartree term enddo deallocate(psi_r,psi_rs) deallocate(exact_x) close(iunwfcreal) deallocate(e_hub) if(l_whole_s) then !NOT_TO_BE_INCLUDED_START deallocate(et_off) !NOT_TO_BE_INCLUDED_END endif return END SUBROUTINE energies_xc_gamma ! END SUBROUTINE energies_xc SUBROUTINE write_energies_xc(e_xc) USE kinds, ONLY : DP USE wannier_gw, ONLY : num_nbnds, l_verbose USE io_files, ONLY : prefix,tmp_dir USE io_global, ONLY : ionode USE wvfct, ONLY : nbnd USE lsda_mod, ONLY : nspin implicit none INTEGER, EXTERNAL :: find_free_unit REAL(kind=DP) :: e_xc(nbnd,nspin)!exchange and correlation energies INTEGER :: iunu, iw if(ionode) then iunu = find_free_unit() open(unit=iunu,file=trim(tmp_dir)//trim(prefix)//'.dft_xc',status='unknown',form='unformatted') write(iunu) nbnd do iw=1,nbnd write(iunu) e_xc(iw,1) if(l_verbose) WRITE(*,*) 'SCRITTO e_XC 1', e_xc(iw,1) enddo if(nspin==2) then do iw=1,nbnd write(iunu) e_xc(iw,2) if(l_verbose) WRITE(*,*) 'SCRITTO e_XC 2', e_xc(iw,2) enddo endif close(iunu) endif return END SUBROUTINE write_energies_xc GWW/pw4gww/o_bands.f900000644000077300007730000003554012341332532015203 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! SUBROUTINE o_bands(numv, v_states,numpw,o_basis,ethr,cutoff,ptype) !this subroutines find the lowest eigenstates of the O matrix !GAMMA ONLY VERSION !ONLY FOR NORM_CONSERVING PSEUDOPOTENTIALS USE kinds, ONLY : DP USE constants, ONLY : eps4 USE io_global, ONLY : stdout, ionode,ionode_id USE cell_base, ONLY : tpiba2 USE klist, ONLY : nkstot, nks, wk, xk, nelec USE gvect, ONLY : g, gstart USE wvfct, ONLY : g2kin, wg, nbndx, et, nbnd, npwx, igk, & npw, current_k USE control_flags, ONLY : max_cg_iter, david USE g_psi_mod, ONLY : h_diag USE mp, ONLY : mp_sum,mp_bcast USE becmod, ONLY : becp,allocate_bec_type,deallocate_bec_type USE uspp, ONLY : vkb, nkb, okvan USE klist, ONLY : xk USE control_flags, ONLY : isolve USE io_files, ONLY : prefix, tmp_dir, diropn USE mp_world, ONLY : mpime, nproc, world_comm USE fft_base, ONLY : dfftp, dffts implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER, INTENT(in) :: numv!number of valence states REAL(kind=DP), INTENT(in) :: v_states(dffts%nnr,numv)!valence states in real space INTEGER, INTENT(inout) :: numpw!dimension of polarization basis COMPLEX(kind=DP), INTENT(inout) :: o_basis(npw,numpw) REAL(kind=DP), INTENT(in) :: ethr!threshold for diagonalization REAL(kind=DP), INTENT(in) :: cutoff!cutoff for plane waves INTEGER, INTENT(in) :: ptype!type of approximation for O operator REAL(kind=DP), ALLOCATABLE :: precondition(:) REAL(kind=DP), ALLOCATABLE :: o_values(:)!eigenvalues of O operator COMPLEX(kind=DP), ALLOCATABLE :: psi_test(:) INTEGER :: notconv REAL(kind=DP) :: avg_iter INTEGER :: ig, iw, il,ii,ip REAL(kind=DP)::sca REAL(kind=DP), ALLOCATABLE :: hdiag(:) INTEGER :: dav_iter REAL(kind=DP), ALLOCATABLE :: ovec(:,:) INTEGER :: nfound INTEGER :: iunwfc INTEGER :: l_blk,nbegin,nend,nsize,iunfcw LOGICAL :: exst INTEGER :: fcw_number!number of "fake conduction" states for O matrix method COMPLEX(kind=DP), ALLOCATABLE :: fcw_state(:,:)! "fake conduction" states for O matrix method REAL(kind=DP), ALLOCATABLE :: fcw_mat(:,:)! "fake conduction" matrix REAL(kind=DP), ALLOCATABLE :: eigen(:),work(:) INTEGER :: lwork,info,liwork INTEGER, ALLOCATABLE :: iwork(:) REAL(kind=DP), ALLOCATABLE :: omat(:,:) INTEGER, ALLOCATABLE :: isuppz(:) INTEGER :: n_out,num_fc INTEGER :: istep REAL(kind=DP), PARAMETER :: lambda=0.001d0 isolve=1 allocate(o_values(numpw)) if(ptype==0.or.ptype==1.or.ptype==2) then write(stdout,*) 'PTYPE = 1 or 2 NOT IMPLEMENTED YET' call flush_unit(stdout) ! stop !#ifdef __NOTIMPLEMENTED allocate(psi_test(npw)) allocate(hdiag(npw)) allocate(precondition(npw)) write(stdout,*) 'setting preconditioning' call flush_unit(stdout) !the following is for colling h_1psi routine ! ALLOCATE( becp%r( nkb, 1) ) ! call allocate_bec_type ( nkb, 1, becp) ! IF ( nkb > 0 ) CALL init_us_2( npw, igk, xk(1,1), vkb ) g2kin(1:npw) = ( (g(1,igk(1:npw)) )**2 + & ( g(2,igk(1:npw)) )**2 + & ( g(3,igk(1:npw)) )**2 ) * tpiba2 do ig=1,npw if(g2kin(ig) <= cutoff) then hdiag(ig)=1.d0!/(1.d0+g2kin(ig)) else hdiag(ig)=0.d0 endif enddo hdiag=1.d0 !precondition(1:npw) = 1.D0 + g2kin(1:npw) + & ! SQRT( 1.D0 + ( g2kin(ig) - 1.D0 )**2 ) ! precondition(:)=1.d0 !simple steepest descent only for debug purposes do istep=1,0!100 call o_1psi_gamma( numv, v_states, o_basis(:,1), psi_test,.false.,hdiag,ptype,fcw_number,fcw_state,fcw_mat,ethr) sca=0.d0 do ig=1,npw sca=sca+2.d0*dble(conjg(o_basis(ig,1))*psi_test(ig)) enddo if(gstart==2) sca=sca-dble(conjg(o_basis(1,1))*psi_test(1)) call mp_sum(sca,world_comm) write(stdout,*) 'Steepest:',sca o_basis(1:npw,1)= o_basis(1:npw,1)-lambda*psi_test(1:npw) sca=0.d0 do ig=1,npw sca=sca+2.d0*dble(conjg(o_basis(ig,1))*o_basis(ig,1)) enddo if(gstart==2) sca=sca-dble(conjg(o_basis(1,1))*o_basis(1,1)) call mp_sum(sca,world_comm) sca=dsqrt(sca) o_basis(:,1)=o_basis(:,1)/sca enddo if(isolve==1) then write(stdout,*) 'call o_rcgdiagg',max_cg_iter call flush_unit(stdout) !precondition(:)=hdiag(:) do il=1,50 call o_rcgdiagg( npw, npw, numpw, o_basis, o_values, precondition, & ethr, 100, .true., notconv, avg_iter, numv, v_states,hdiag,ptype,fcw_number,fcw_state,fcw_mat) if(notconv <= 0) exit enddo do iw=1,numpw write(stdout,*) 'Eigen:', iw, o_values(iw) enddo else !davidson strategy !precondition(:)=hdiag(:) do il=1,50 ! call o_regterg( npw, npw, numpw, david*numpw, o_basis, ethr, & ! .true., gstart, o_values, notconv, .true., dav_iter,& ! numv, v_states,hdiag, precondition) if(notconv <= 0) exit enddo do iw=1,numpw write(stdout,*) 'Eigen:', iw, o_values(iw) enddo endif !controlla se sono autovalori do iw=1,numpw call o_1psi_gamma( numv, v_states, o_basis(:,iw), psi_test,.false.,hdiag,ptype,fcw_number,fcw_state,fcw_mat,ethr) sca=0.d0 do ig=1,npw sca=sca+2.d0*dble(conjg(psi_test(ig))*psi_test(ig)) enddo if(gstart==2) sca=sca-dble(conjg(psi_test(1))*psi_test(1)) call mp_sum(sca,world_comm) sca=dsqrt(sca) psi_test(:)=psi_test(:)/sca sca=0.d0 do ig=1,npw sca=sca+2.d0*dble(conjg(o_basis(ig,iw))*psi_test(ig)) enddo if(gstart==2) sca=sca-dble(conjg(o_basis(1,iw))*psi_test(1)) call mp_sum(sca,world_comm) write(stdout,*) 'Eig prod:',iw,sca enddo call flush_unit(stdout) deallocate(precondition) deallocate(psi_test) ! deallocate (becp%r) ! call deallocate_bec_type ( becp) deallocate(hdiag) !#endif __NOTIMPLEMENTED else if(ptype==3 .or. ptype==4) then !read from file if(ionode) then iunfcw = find_free_unit() open(unit=iunfcw,file=trim(tmp_dir)//trim(prefix)//'.nfcws',status='old') read(iunfcw,*) fcw_number close(iunfcw) endif call mp_bcast(fcw_number, ionode_id,world_comm) if(numpw>fcw_number) then numpw=fcw_number write(stdout,*) 'Set polarizability basis dimension:', numpw call flush_unit(stdout) endif allocate(ovec(fcw_number,numpw)) write(stdout,*) 'ATT1', fcw_number call flush_unit(stdout) l_blk= (fcw_number)/nproc if(l_blk*nproc < (fcw_number)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 if(nend > fcw_number) nend=fcw_number nsize=nend-nbegin+1 write(stdout,*) 'ATT2', fcw_number call flush_unit(stdout) if(nsize>0) then allocate(fcw_mat(fcw_number,nsize)) else allocate(fcw_mat(fcw_number,1)) endif allocate(fcw_state(npw,fcw_number)) write(stdout,*) 'ATT3', fcw_number call flush_unit(stdout) iunfcw = find_free_unit() CALL diropn( iunfcw, 'fcw', npw*2, exst ) do ii=1,fcw_number CALL davcio(fcw_state(:,ii), 2*npw,iunfcw,ii,-1) enddo close(iunfcw) write(stdout,*) 'ATT4', fcw_number call flush_unit(stdout) CALL diropn( iunfcw, 'fmat',fcw_number, exst ) do ii=1,nsize CALL davcio(fcw_mat(:,ii), fcw_number,iunfcw,ii,-1) enddo close(iunfcw) write(stdout,*) 'ATT5', fcw_number call flush_unit(stdout) if(ptype==3) then call diago_cg(fcw_number,fcw_mat,1000,numpw,o_values,ovec,0.d0,1d-8,nfound,.true.) else allocate(omat(fcw_number,fcw_number)) omat(:,:)=0.d0 if(nsize>0) omat(1:fcw_number,nbegin:nend)=fcw_mat(1:fcw_number,1:nsize) do iw=1,fcw_number call mp_sum(omat(:,iw),world_comm) enddo if(ionode) then allocate(isuppz(fcw_number)) allocate(work(1),iwork(1)) call DSYEVR('V','I','U',fcw_number,omat,fcw_number,0.d0,0.d0,& &fcw_number-numpw+1,fcw_number,1d-8,n_out,o_values,ovec,fcw_number,isuppz,work,-1,iwork,-1,info) lwork=work(1) liwork=iwork(1) deallocate(work,iwork) allocate(work(lwork)) allocate(iwork(liwork)) call DSYEVR('V','I','U',fcw_number,omat,fcw_number,0.d0,0.d0,& &fcw_number-numpw+1,fcw_number,1d-8,n_out,o_values,ovec,fcw_number,isuppz,work,lwork,iwork,liwork,info) if(info/=0) then write(stdout,*) 'ROUTINE fake_conduction_wannier, INFO:', info stop endif deallocate(isuppz) deallocate(work,iwork) else o_values(:)=0.d0 ovec(:,:)=0.d0 endif do iw=1,numpw call mp_sum(ovec(:,iw),world_comm) enddo call mp_sum(o_values(:),world_comm) deallocate(omat) do iw=1,numpw write(stdout,*) 'POLARIZABILITY eigen:', iw, o_values(iw) enddo call flush_unit(stdout) endif call dgemm('N','N',2*npw,numpw,fcw_number,1.d0,fcw_state,2*npw,ovec,fcw_number,0.d0,o_basis,2*npw) deallocate(ovec) deallocate(fcw_mat,fcw_state) else if(ptype==5) then !just real plane waves g2kin(1:npw) = ( (g(1,igk(1:npw)) )**2 + & ( g(2,igk(1:npw)) )**2 + & ( g(3,igk(1:npw)) )**2 ) * tpiba2 num_fc=0 do ig=1,npw if(g2kin(ig) <= cutoff) num_fc=num_fc+1 enddo call mp_sum(num_fc,world_comm) num_fc=(num_fc-1)*2!G=0 excluded o_basis(:,:)=(0.d0,0.d0) write(stdout,*) 'Number of G states', num_fc if(num_fc>numpw) then write(stdout,*) 'numw_prod too small:', num_fc call flush_unit(stdout) stop endif numpw=num_fc ii=0 do ip=0,nproc-1 if(mpime==ip) then do ig=gstart,npw if(g2kin(ig) <= cutoff) then ii=ii+1 o_basis(ig,ii)=cmplx(dsqrt(0.5d0),0.d0) ii=ii+1 o_basis(ig,ii)=cmplx(0.d0,dsqrt(0.5d0)) endif enddo else ii=0 endif call mp_sum(ii,world_comm) enddo if(ii/=num_fc) then write(stdout,*) 'ERRORE G STATES',ii call flush_unit(stdout) stop return endif endif if(allocated(o_values) )deallocate(o_values) return end SUBROUTINE o_bands subroutine o_extra_pw( p_basis, numwp, numwp_max,cutoff) !this subroutines add to the polarizability basis at the end, plane waves (sin and cos) up to the specified cutoff USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode,ionode_id USE cell_base, ONLY : tpiba2 USE klist, ONLY : nkstot, nks, wk, xk, nelec USE gvect, ONLY : g, gstart USE wvfct, ONLY : g2kin, wg, nbndx, et, nbnd, npwx, igk, & npw, current_k USE control_flags, ONLY : max_cg_iter, david USE g_psi_mod, ONLY : h_diag USE mp, ONLY : mp_sum,mp_bcast USE klist, ONLY : xk USE mp_world, ONLY : mpime, nproc, world_comm USE wannier_gw, ONLY : optimal_options implicit none INTEGER, INTENT(inout) :: numwp!dimension of polarization basis COMPLEX(kind=DP), INTENT(inout) :: p_basis(npw,numwp_max) REAL(kind=DP), INTENT(in) :: cutoff INTEGER, INTENT(in) :: numwp_max!max dimension of polarizability basis INTEGER :: num_fc, ii, ip, ig, info,numwp2 TYPE(optimal_options) :: options !just real plane waves g2kin(1:npw) = ( (g(1,igk(1:npw)) )**2 + & ( g(2,igk(1:npw)) )**2 + & ( g(3,igk(1:npw)) )**2 ) * tpiba2 num_fc=0 do ig=1,npw if(g2kin(ig) <= cutoff) num_fc=num_fc+1 enddo call mp_sum(num_fc,world_comm) num_fc=(num_fc-1)*2!G=0 excluded p_basis(:,numwp+1:numwp+num_fc)=(0.d0,0.d0) write(stdout,*) 'Number of G states added to the polarizability basis', num_fc ii=numwp do ip=0,nproc-1 if(mpime==ip) then do ig=gstart,npw if(g2kin(ig) <= cutoff) then ii=ii+1 p_basis(ig,ii)=cmplx(dsqrt(0.5d0),0.d0) ii=ii+1 p_basis(ig,ii)=cmplx(0.d0,dsqrt(0.5d0)) endif enddo else ii=0 endif call mp_sum(ii,world_comm) enddo if(ii/=num_fc+numwp) then write(stdout,*) 'ERRORE G STATES',ii call flush_unit(stdout) stop return endif numwp=numwp+num_fc write(stdout,*) 'UPDATED DIMESION OF POLARIZABILITY BASIS: ', numwp !now re-orthonormalize options%l_complete=.true. options%idiago=0 options%ithres=0 options%thres=0.d0 call optimal_driver(numwp,p_basis,npw,options,numwp2, info) write(stdout,*) 'UPDATED DIMESION OF POLARIZABILITY BASIS: ', numwp if(info/=0) then write(stdout,*) 'PROBLEM WITH OPTIMAL_DRIVER' call flush_unit(stdout) stop return endif return end subroutine o_extra_pw subroutine update_numwp(numwp, cutoff) !this subroutine adds to numwp the number of plane-waves differnt from 0 till the specified cutoff USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode,ionode_id USE cell_base, ONLY : tpiba2 USE klist, ONLY : nkstot, nks, wk, xk, nelec USE gvect, ONLY : g, gstart USE wvfct, ONLY : g2kin, wg, nbndx, et, nbnd, npwx, igk, & npw, current_k USE control_flags, ONLY : max_cg_iter, david USE g_psi_mod, ONLY : h_diag USE mp, ONLY : mp_sum,mp_bcast USE klist, ONLY : xk USE mp_world, ONLY : mpime, nproc, world_comm implicit none INTEGER, INTENT(inout) :: numwp!dimension of polarization basis REAL(kind=DP), INTENT(in) :: cutoff INTEGER :: num_fc, ig !just real plane waves g2kin(1:npw) = ( (g(1,igk(1:npw)) )**2 + & ( g(2,igk(1:npw)) )**2 + & ( g(3,igk(1:npw)) )**2 ) * tpiba2 num_fc=0 do ig=1,npw if(g2kin(ig) <= cutoff) num_fc=num_fc+1 enddo call mp_sum(num_fc,world_comm) num_fc=(num_fc-1)*2!G=0 excluded numwp=numwp+num_fc return end subroutine update_numwp GWW/pw4gww/exchange_custom.f900000644000077300007730000020471612341332532016755 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !routines for rapid evaluation of Fock operators MODULE exchange_custom USE kinds, ONLY: DP USE fft_custom_gwl IMPLICIT NONE TYPE exchange_cus !data structure for general Fock operator REAL(kind=DP), DIMENSION(:,:,:), POINTER :: wfc!valence wfcs in real space REAL(kind=DP) :: dual!dual for defining the grid on real space REAL(kind=DP) :: cutoff!G space cutoff in Ryberg REAL(kind=DP) :: truncation_radius!for Coulomb interaction in Bohr REAL(kind=DP), DIMENSION(:), POINTER :: fac!factors on G space of Coulomb interaction INTEGER :: nbndv(2)!number of valence states TYPE(fft_cus) :: fft_g2r!from wfcs to real space TYPE(fft_cus) :: fft_r2g!from real space to restricted G space TYPE(fft_cus) :: fft_small!for periodic calculations !the following for small REAL(kind=DP), DIMENSION(:), POINTER :: fac_s INTEGER, DIMENSION(:,:,:), POINTER :: r2s_xy INTEGER, DIMENSION(:,:,:), POINTER :: s2r_xy INTEGER :: n(3),m(3)!I have the relation n*edge=diameter*m LOGICAL :: l_localized!if true consider valence wfcs as localized REAL(kind=DP) :: thrs_loc!threshold for localized valence wfcs INTEGER, DIMENSION (:,:), POINTER :: n_loc!number of points above thrs INTEGER, DIMENSION (:,:,:), POINTER :: tab_loc!table for points above threshold INTEGER :: nspin!number of spin channels REAL(kind=DP), DIMENSION(:,:,:,:,:),POINTER :: wfc_red!valence wfcs in real space ready for the reduced grid END TYPE exchange_cus SAVE !to be use in pw.x LOGICAL :: l_exchange_fast=.false. REAL(kind=DP) :: exchange_fast_dual=2.d0 REAL(kind=DP) :: exchange_fast_cutoff=40.d0 REAL(kind=DP) :: exchange_fast_radius=10.d0 INTEGER :: exchange_fast_nbndv(2) LOGICAL :: l_exchange_turbo=.false. INTEGER :: exchange_m(3) INTEGER :: exchange_n(3) LOGICAL :: l_exchange_localized=.false. REAL(kind=DP) :: exchange_thrs_loc CONTAINS SUBROUTINE periodic_fock_cus(ispin,psi,xpsi,exx_cus) !apply Fock operator to a wavefunction !experimental version work just with factor 1/2 USE io_global, ONLY : stdout, ionode,ionode_id USE mp_global, ONLY : me_pool,intra_pool_comm USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2,bg USE constants, ONLY : e2, pi, tpi, fpi, RYTOEV USE wavefunctions_module, ONLY : psic USE mp, ONLY : mp_sum USE mp_world, ONLY : world_comm, nproc USE wvfct, ONLY : npwx, npw, wg USE gvect USE mp_wave, ONLY : mergewf,splitwf implicit none INTEGER, INTENT(in) :: ispin! spin channel COMPLEX(kind=DP), INTENT(in) :: psi(npw) COMPLEX(kind=DP), INTENT(inout) :: xpsi(npw) TYPE(exchange_cus), INTENT(in) :: exx_cus INTEGER, ALLOCATABLE :: r2s_xy(:) !real to small XY index INTEGER :: i,j,k,n,ii,jj,kk,ig,iv,jv INTEGER :: ix,iy,iz, ix_s,iy_s,iz_s,iz_eff INTEGER :: rz_start,rz_end,iqq,iqq_s,rz_start_s,rz_end_s REAL(kind=DP), ALLOCATABLE :: fac(:),prodr(:),prods(:,:),planes(:),vexc(:) REAL(kind=DP) :: qq_fact, sca INTEGER :: iorig, idest INTEGER,ALLOCATABLE :: z2proc_s(:),z2proc(:) INTEGER :: req, ierr #ifdef __MPI INTEGER :: istatus(MPI_STATUS_SIZE) #endif COMPLEX(kind=DP), ALLOCATABLE :: prods_g(:,:) COMPLEX(kind=DP), ALLOCATABLE :: psi_t(:),evc_g(:),vexc_g(:) REAL(kind=DP), ALLOCATABLE :: psi_r(:),psi_r_red(:,:,:),plane(:) INTEGER :: i_mod, j_mod,k_mod,iplane INTEGER :: jd,jdmax,ir,nr3small,nr3small_max,nplane REAL(kind=DP), ALLOCATABLE :: prod_r_red(:,:,:) REAL(kind=DP), ALLOCATABLE :: vexc_red(:,:,:) INTEGER :: ip_todo,token,ip_delta,tag,ip REAL(kind=DP), ALLOCATABLE :: b_plane(:,:) INTEGER, ALLOCATABLE :: b_iplane(:),b_z(:) INTEGER, ALLOCATABLE :: proc_list(:) INTEGER :: offset !write(stdout,*) 'periodic_fock' !call flush_unit(stdout) CALL start_clock('periodic_fock') !setup correspondence grids rz_start=0 rz_end =0 do ii=1,me_pool + 1 rz_start=rz_end+1 rz_end=rz_end+exx_cus%fft_g2r%dfftt%npp(ii) end do rz_start_s=0 rz_end_s=0 do ii=1,me_pool + 1 rz_start_s=rz_end_s+1 rz_end_s=rz_end_s+exx_cus%fft_small%dfftt%npp(ii) end do nr3small=rz_end_s-rz_start_s+1 allocate(z2proc_s(exx_cus%fft_small%nr3t)) allocate(z2proc(exx_cus%fft_g2r%nr3t)) allocate(vexc(exx_cus%fft_g2r%nrxxt)) allocate( evc_g( exx_cus%fft_g2r%ngmt_g ) ) allocate(vexc_g(exx_cus%fft_g2r%npwt)) j=0 k=0 do ii=1,nproc j=k+1 k=k+exx_cus%fft_small%dfftt%npp(ii) z2proc_s(j:k)=ii-1 end do j=0 k=0 do ii=1,nproc j=k+1 k=k+exx_cus%fft_g2r%dfftt%npp(ii) z2proc(j:k)=ii-1 end do allocate(fac(exx_cus%fft_small%ngmt)) !setup fac do ig=1,exx_cus%fft_small%ngmt qq_fact = exx_cus%fft_small%gt(1,ig)**2.d0 + exx_cus%fft_small%gt(2,ig)**2.d0 + exx_cus%fft_small%gt(3,ig)**2.d0 if (qq_fact > 1.d-8) then fac(ig)=(e2*fpi/(exx_cus%fft_small%tpiba2_t*qq_fact))*(1.d0-dcos(dsqrt(qq_fact)*& &(exx_cus%truncation_radius*dble(exx_cus%n(1))/dble(exx_cus%m(1)))*exx_cus%fft_small%tpiba_t)) else fac(ig)=e2*fpi*((exx_cus%truncation_radius*dble(exx_cus%n(1))/dble(exx_cus%m(1)))**2.d0/2.d0) endif end do fac(:)=fac(:)/omega/(dble(exx_cus%n(1)*exx_cus%n(2)*exx_cus%n(3))) allocate(prodr(exx_cus%fft_g2r%nrxxt)) allocate(prods(exx_cus%fft_small%nrxxt,2)) allocate(planes(exx_cus%fft_small%nrx1t*exx_cus%fft_small%nrx2t)) allocate(prods_g(exx_cus%fft_small%ngmt,2)) allocate(plane(exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t)) allocate(psi_t(exx_cus%fft_g2r%npwt)) allocate(psi_r(exx_cus%fft_g2r%nrxxt)) allocate(psi_r_red(exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t,nr3small,exx_cus%m(3))) allocate(prod_r_red(exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t,nr3small,exx_cus%m(3))) allocate(vexc_red(exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t,nr3small,exx_cus%m(3))) !loop on KS states vexc(:)=0.d0 vexc_red=0.d0 CALL start_clock('pf_mergesplit') if(exx_cus%fft_g2r%dual_t==4.d0) then psi_t(1:exx_cus%fft_g2r%npwt)=psi(1:exx_cus%fft_g2r%npwt) else call mergewf(psi(:),evc_g,npw,ig_l2g,me_pool,nproc,ionode_id,intra_pool_comm) call splitwf(psi_t(:),evc_g,exx_cus%fft_g2r%npwt,exx_cus%fft_g2r%ig_l2gt,& &me_pool,nproc,ionode_id,intra_pool_comm) endif CALL stop_clock('pf_mergesplit') psic(:)=(0.d0,0.d0) psic(exx_cus%fft_g2r%nlt(1:exx_cus%fft_g2r%npwt)) = psi_t(1:exx_cus%fft_g2r%npwt) psic(exx_cus%fft_g2r%nltm(1:exx_cus%fft_g2r%npwt)) = CONJG( psi_t(1:exx_cus%fft_g2r%npwt) ) CALL start_clock('pf_fftext') CALL cft3t( exx_cus%fft_g2r, psic, exx_cus%fft_g2r%nr1t, exx_cus%fft_g2r%nr2t, exx_cus%fft_g2r%nr3t, & &exx_cus%fft_g2r%nrx1t, exx_cus%fft_g2r%nrx2t, exx_cus%fft_g2r%nrx3t, 2 ) psi_r(1:exx_cus%fft_g2r%nrxxt)= DBLE(psic(1:exx_cus%fft_g2r%nrxxt)) CALL stop_clock('pf_fftext') !put the psi wavefunction already on the small z distribution among processor !!!!!!!!!!! !first the internal case do k=1,exx_cus%n(3) do iz=rz_start,rz_end iz_s=mod(iz-1+(k-1)*exx_cus%fft_g2r%nr3t,exx_cus%fft_small%nr3t)+1 iplane=(iz-1+(k-1)*exx_cus%fft_g2r%nr3t)/exx_cus%fft_small%nr3t+1 idest=z2proc_s(iz_s) !put plane on small plane if(me_pool==idest) then do iqq=1,exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t psi_r_red(iqq,iz_s-rz_start_s+1,iplane)=& &psi_r((iz-rz_start)*(exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t)+iqq) enddo endif enddo enddo nr3small_max=nr3small #ifdef __MPI CALL MPI_ALLREDUCE( nr3small, nr3small_max,1,MPI_INTEGER, MPI_MAX,intra_pool_comm, req,IERR ) #endif allocate(b_plane(exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t,nr3small_max)) allocate(b_iplane(nr3small_max),b_z(nr3small_max)) allocate(proc_list(nproc)) !loop on task delta do ip_delta=1,nproc-1 if(mod(ip_delta,2)==0) then !if(mod(me_pool+1,2)==0) then!even ! if(mod((me_pool+1)/2,2)==0) then ! token=0 ! else ! token=1 ! endif ! else ! ! if(mod((me_pool+2)/2,2)==0) then ! token=0 ! else ! token=1 ! endif ! ! endif proc_list=0 do ip=1,nproc if(proc_list(ip)==0) then if(proc_list(mod(ip+ip_delta-1,nproc)+1)==0) then proc_list(ip)=-1 proc_list(mod(ip+ip_delta-1,nproc)+1)=1 else endif endif enddo if(proc_list(me_pool+1) ==-1) then token=0 else token=1 endif else if(mod(me_pool+1,2)==0) then token=0 else token=1 endif endif do ip_todo=1,2 if(mod(ip_todo+token,2)==0) then !if I am a sender !loop on my data to see if and what I have to send nplane=0 do k=1,exx_cus%n(3) do iz=rz_start,rz_end iz_s=mod(iz-1+(k-1)*exx_cus%fft_g2r%nr3t,exx_cus%fft_small%nr3t)+1 iplane=(iz-1+(k-1)*exx_cus%fft_g2r%nr3t)/exx_cus%fft_small%nr3t+1 idest=z2proc_s(iz_s) if(idest==mod(me_pool+ip_delta,nproc)) then nplane=nplane+1 do iqq=1,exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t b_plane(iqq,nplane)=& &psi_r((iz-rz_start)*(exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t)+iqq) enddo b_z(nplane)=iz_s b_iplane(nplane)=iplane endif enddo enddo !send nplane #ifdef __MPI idest=mod(me_pool+ip_delta,nproc) CALL MPI_ISEND( nplane,1, MPI_INTEGER, idest, 0, intra_pool_comm, req,IERR ) CALL MPI_WAIT(req,istatus,ierr) if(nplane>0) then CALL MPI_ISEND( b_plane,exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t*nplane, MPI_DOUBLE_PRECISION, & &idest, 1, intra_pool_comm, req,IERR ) CALL MPI_WAIT(req,istatus,ierr) CALL MPI_ISEND( b_z,nplane, MPI_INTEGER,idest, 2, intra_pool_comm, req,IERR ) CALL MPI_WAIT(req,istatus,ierr) CALL MPI_ISEND( b_iplane,nplane, MPI_INTEGER,idest, 3, intra_pool_comm, req,IERR ) CALL MPI_WAIT(req,istatus,ierr) endif #endif else !if I am receiver !see if and what I have to receive #ifdef __MPI iorig=me_pool-ip_delta if(iorig<0) iorig=iorig+nproc CALL MPI_RECV( nplane,1, MPI_INTEGER, iorig, 0, intra_pool_comm, istatus,IERR ) if(nplane>0) then CALL MPI_RECV( b_plane,exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t*nplane, MPI_DOUBLE_PRECISION, & &iorig, 1, intra_pool_comm, istatus,IERR ) CALL MPI_RECV( b_z,nplane, MPI_INTEGER,iorig, 2, intra_pool_comm, istatus,IERR ) CALL MPI_RECV( b_iplane,nplane, MPI_INTEGER,iorig, 3, intra_pool_comm, istatus,IERR ) do ii=1,nplane do iqq=1,exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t psi_r_red(iqq,b_z(ii)-rz_start_s+1,b_iplane(ii))=b_plane(iqq,ii) enddo enddo endif #endif endif enddo enddo deallocate(b_plane,b_iplane,b_z,proc_list) !!!!!!!!! ! do k=1,exx_cus%n(3) ! do iz=1,exx_cus%fft_g2r%nr3t ! if(iz >= rz_start .and. iz <= rz_end) then ! !if Z is mine determine owner and send it ! iz_s=mod(iz-1+(k-1)*exx_cus%fft_g2r%nr3t,exx_cus%fft_small%nr3t)+1 ! iplane=(iz-1+(k-1)*exx_cus%fft_g2r%nr3t)/exx_cus%fft_small%nr3t+1 ! idest=z2proc_s(iz_s) ! !put plane on small plane ! if(me_pool==idest) then ! do iqq=1,exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t ! psi_r_red(iqq,iz_s-rz_start_s+1,iplane)=& ! &psi_r((iz-rz_start)*(exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t)+iqq) ! enddo ! else ! do iqq=1,exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t ! plane(iqq)=psi_r((iz-rz_start)*(exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t)+iqq) ! enddo ! CALL MPI_ISEND( plane,exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t, MPI_DOUBLE_PRECISION, & ! &idest, iz, intra_pool_comm, req,IERR ) ! CALL MPI_WAIT(req,istatus,ierr) ! ! endif ! ! else ! iz_s=mod(iz-1+(k-1)*exx_cus%fft_g2r%nr3t,exx_cus%fft_small%nr3t)+1 ! iplane=(iz-1+(k-1)*exx_cus%fft_g2r%nr3t)/exx_cus%fft_small%nr3t+1 ! !if Z o small cell is mine receive it ! if(z2proc_s(iz_s)==me_pool) then ! iorig=z2proc(iz) ! CALL MPI_RECV( plane, exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t, MPI_DOUBLE_PRECISION, & ! &iorig, iz, intra_pool_comm, istatus, IERR ) ! do iqq=1,exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t ! psi_r_red(iqq,iz_s-rz_start_s+1,iplane)=plane(iqq) ! enddo ! ! ! ! endif ! endif ! enddo ! enddo !loop on KS valence states CALL start_clock('pf_inner') do k=1,exx_cus%n(3) do j=1,exx_cus%n(2) do i=1,exx_cus%n(1) do jv=1,exx_cus%nbndv(ispin),2!loop on bands !do product if(jv0) then CALL MPI_ISEND( b_plane,exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t*nplane, MPI_DOUBLE_PRECISION, & &idest, 1, intra_pool_comm, req,IERR ) CALL MPI_WAIT(req,istatus,ierr) CALL MPI_ISEND( b_z,nplane, MPI_INTEGER,idest, 2, intra_pool_comm, req,IERR ) CALL MPI_WAIT(req,istatus,ierr) endif #endif else !if I am receiver !see if and what I have to receive #ifdef __MPI iorig=me_pool-ip_delta if(iorig<0) iorig=iorig+nproc CALL MPI_RECV( nplane,1, MPI_INTEGER, iorig, 0, intra_pool_comm, istatus,IERR ) if(nplane>0) then CALL MPI_RECV( b_plane,exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t*nplane, MPI_DOUBLE_PRECISION, & &iorig, 1, intra_pool_comm, istatus,IERR ) CALL MPI_RECV( b_z,nplane, MPI_INTEGER,iorig, 2, intra_pool_comm, istatus,IERR ) do ii=1,nplane do iqq=1,exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t vexc((b_z(ii)-rz_start)*exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t+iqq)=& &b_plane(iqq,ii) enddo enddo endif #endif endif enddo enddo deallocate(b_plane,b_z,proc_list) !!!!!!!!!!!!! !now find vexc from vexc_red ! do iz_s=1,exx_cus%fft_small%nr3t ! !send and receive z and z+alat ! do ii=1,exx_cus%m(3) ! iz=mod(iz_s+exx_cus%fft_small%nr3t*(ii-1)-1,exx_cus%fft_g2r%nrx3t)+1 ! ! ! !do periodic replica ! if(iz_s >= rz_start_s .and. iz_s <= rz_end_s) then ! !if Z is mine determine owner and send ! idest=z2proc(iz) ! !put plane on small plane ! if(me_pool==idest) then ! do iqq=1,exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t ! vexc((iz-rz_start)*exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t+iqq)=vexc_red(iqq,iz_s-rz_start_s+1,ii) ! enddo ! else ! do iqq=1,exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t ! plane(iqq)=vexc_red(iqq,iz_s-rz_start_s+1,ii) ! enddo ! CALL MPI_ISEND( plane, exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t, MPI_DOUBLE_PRECISION, & ! &idest, iz, intra_pool_comm, req,IERR ) ! CALL MPI_WAIT(req,istatus,ierr) ! ! endif ! else ! !if Z on large cell is mine receive it ! if(z2proc(iz)==me_pool) then ! iorig=z2proc_s(iz_s) ! CALL MPI_RECV( plane, exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t, MPI_DOUBLE_PRECISION, & ! &iorig, iz, intra_pool_comm, istatus, IERR ) ! do iqq=1,exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t ! vexc((iz-rz_start)*exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t+iqq)=plane(iqq) ! enddo ! endif ! endif ! ! enddo ! enddo !!!!!!!!! !do fft and back to standard ordering !do scalar producs psic(1:exx_cus%fft_g2r%nrxxt)=dcmplx(vexc(1:exx_cus%fft_g2r%nrxxt),0.d0) CALL start_clock('pf_fftext') CALL cft3t( exx_cus%fft_g2r, psic, exx_cus%fft_g2r%nr1t, exx_cus%fft_g2r%nr2t, exx_cus%fft_g2r%nr3t, & &exx_cus%fft_g2r%nrx1t, exx_cus%fft_g2r%nrx2t, exx_cus%fft_g2r%nrx3t, -2 ) CALL stop_clock('pf_fftext') vexc_g(1:exx_cus%fft_g2r%npwt) = psic(exx_cus%fft_g2r%nlt(1:exx_cus%fft_g2r%npwt)) !put in the order or wfcs CALL start_clock('pf_mergesplit') if(exx_cus%fft_g2r%dual_t==4.d0) then xpsi(1:exx_cus%fft_g2r%npwt)=vexc_g(1:exx_cus%fft_g2r%npwt) else call mergewf(vexc_g,evc_g,exx_cus%fft_g2r%npwt,exx_cus%fft_g2r%ig_l2gt,me_pool,nproc,ionode_id,intra_pool_comm) call splitwf(xpsi,evc_g,npw,ig_l2g,me_pool,nproc,ionode_id,intra_pool_comm) endif CALL stop_clock('pf_mergesplit') deallocate(fac) deallocate(prodr,prods) deallocate(planes) deallocate(z2proc_s) deallocate(z2proc) deallocate(prods_g) deallocate(vexc) deallocate(psi_t,psi_r,evc_g) deallocate(psi_r_red,plane,prod_r_red) deallocate(vexc_red) CALL stop_clock('periodic_fock') return END SUBROUTINE periodic_fock_cus SUBROUTINE periodic_dft_exchange(nbnds,psi,exx_cus) !experimental version work just with factor 1/2 USE io_global, ONLY : stdout, ionode,ionode_id USE mp_global, ONLY : me_pool,intra_pool_comm USE cell_base, ONLY : at, alat, tpiba, omega, tpiba2,bg USE constants, ONLY : e2, pi, tpi, fpi, RYTOEV USE wavefunctions_module, ONLY : psic USE mp, ONLY : mp_sum USE mp_world, ONLY : world_comm, nproc USE wvfct, ONLY : npwx, npw USE gvect USE mp_wave, ONLY : mergewf,splitwf implicit none INTEGER, INTENT(in) :: nbnds!total number of states COMPLEX(kind=DP), INTENT(in) :: psi(npwx,nbnds)!wavefunctions TYPE(exchange_cus), INTENT(in) :: exx_cus TYPE(fft_cus) :: fft_small INTEGER, ALLOCATABLE :: r2s_xy(:) !real to small XY index INTEGER, ALLOCATABLE :: r2s_z(:)!real to small Z index (large) INTEGER :: i,j,k,n,ii,jj,kk,ig,iv,jv INTEGER :: ix,iy,iz, ix_s,iy_s,iz_s,iz_eff INTEGER :: rz_start,rz_end,iqq,iqq_s,rz_start_s,rz_end_s REAL(kind=DP), ALLOCATABLE :: fac(:),prodr(:),prods(:),planes(:),vexc(:) REAL(kind=DP) :: qq_fact, sca INTEGER :: iorig, idest INTEGER,ALLOCATABLE :: z2proc_s(:),z2proc(:) INTEGER :: req, ierr #ifdef __MPI INTEGER :: istatus(MPI_STATUS_SIZE) #endif COMPLEX(kind=DP), ALLOCATABLE :: prods_g(:) COMPLEX(kind=DP), ALLOCATABLE :: psi_t(:),evc_g(:) REAL(kind=DP), ALLOCATABLE :: psi_r(:) !setup small grid fft_small%at_t(1:3,1:3)=exx_cus%fft_g2r%at_t(1:3,1:3) fft_small%bg_t(1:3,1:3)=exx_cus%fft_g2r%bg_t(1:3,1:3) fft_small%alat_t=exx_cus%fft_g2r%alat_t/2.d0 fft_small%omega_t=exx_cus%fft_g2r%omega_t/8.d0 fft_small%tpiba_t=exx_cus%fft_g2r%tpiba_t*2.d0 fft_small%tpiba2_t=exx_cus%fft_g2r%tpiba2_t*4.d0 fft_small%ecutt=exx_cus%fft_g2r%ecutt fft_small%dual_t=exx_cus%fft_g2r%dual_t call initialize_fft_custom_cell(fft_small) write(stdout,*) 'Dimensions of real cell' write(stdout,*) exx_cus%fft_g2r%nr1t,exx_cus%fft_g2r%nr2t,exx_cus%fft_g2r%nr3t write(stdout,*) exx_cus%fft_g2r%nrx1t,exx_cus%fft_g2r%nrx2t,exx_cus%fft_g2r%nrx3t write(stdout,*) 'Dimensions of small cell' write(stdout,*) fft_small%nr1t,fft_small%nr2t,fft_small%nr3t write(stdout,*) fft_small%nrx1t,fft_small%nrx2t,fft_small%nrx3t allocate(r2s_xy(exx_cus%fft_g2r%nrxxt)) allocate(r2s_z(exx_cus%fft_g2r%nrxxt)) !setup correspondence grids rz_start=0 rz_end =0 do ii=1,me_pool + 1 rz_start=rz_end+1 rz_end=rz_end+exx_cus%fft_g2r%dfftt%npp(ii) end do rz_start_s=0 rz_end_s=0 do ii=1,me_pool + 1 rz_start_s=rz_end_s+1 rz_end_s=rz_end_s+fft_small%dfftt%npp(ii) end do allocate(z2proc_s(fft_small%nr3t)) allocate(z2proc(exx_cus%fft_g2r%nr3t)) allocate(vexc(exx_cus%fft_g2r%nrxxt)) allocate( evc_g( exx_cus%fft_g2r%ngmt_g ) ) j=0 k=0 do ii=1,nproc j=k+1 k=k+fft_small%dfftt%npp(ii) z2proc_s(j:k)=ii-1 end do j=0 k=0 do ii=1,nproc j=k+1 k=k+exx_cus%fft_g2r%dfftt%npp(ii) z2proc(j:k)=ii-1 end do r2s_xy(:)=0 do iz=1,exx_cus%fft_g2r%dfftt%npp(me_pool+1) do iy=1,exx_cus%fft_g2r%nr2t do ix=1,exx_cus%fft_g2r%nr1t iqq=(iz-1)*(exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t)+(iy-1)*exx_cus%fft_g2r%nrx1t+ix iy_s=mod(iy-1,fft_small%nr2t)+1 ix_s=mod(ix-1,fft_small%nr1t)+1 iqq_s=(iy_s-1)*fft_small%nrx1t+ix_s r2s_xy(iqq)=iqq_s!XY correspondance only iz_eff=iz+rz_start-1 iz_s=mod(iz_eff-1,fft_small%nr3t)+1 enddo enddo enddo allocate(fac(fft_small%ngmt)) !setup fac do ig=1,fft_small%ngmt qq_fact = fft_small%gt(1,ig)**2.d0 + fft_small%gt(2,ig)**2.d0 + fft_small%gt(3,ig)**2.d0 if (qq_fact > 1.d-8) then fac(ig)=(e2*fpi/(fft_small%tpiba2_t*qq_fact))*(1.d0-dcos(dsqrt(qq_fact)*& &(exx_cus%truncation_radius/2.d0)*fft_small%tpiba_t)) else fac(ig)=e2*fpi*((exx_cus%truncation_radius/2.d0)**2.d0/2.d0) endif end do fac(:)=fac(:)/omega allocate(prodr(exx_cus%fft_g2r%nrxxt)) allocate(prods(fft_small%nrxxt)) allocate(planes(fft_small%nrx1t*fft_small%nrx2t)) allocate(prods_g(fft_small%ngmt)) allocate(psi_t(exx_cus%fft_g2r%npwt)) allocate(psi_r(exx_cus%fft_g2r%nrxxt)) !loop on KS states do iv=1,nbnds vexc(:)=0.d0 if(exx_cus%fft_g2r%dual_t==4.d0) then psi_t(1:exx_cus%fft_g2r%npwt)=psi(1:exx_cus%fft_g2r%npwt,iv) else call mergewf(psi(:,iv),evc_g,npw,ig_l2g,me_pool,nproc,ionode_id,intra_pool_comm) call splitwf(psi_t(:),evc_g,exx_cus%fft_g2r%npwt,exx_cus%fft_g2r%ig_l2gt,& &me_pool,nproc,ionode_id,intra_pool_comm) endif psic(:)=(0.d0,0.d0) psic(exx_cus%fft_g2r%nlt(1:exx_cus%fft_g2r%npwt)) = psi_t(1:exx_cus%fft_g2r%npwt) psic(exx_cus%fft_g2r%nltm(1:exx_cus%fft_g2r%npwt)) = CONJG( psi_t(1:exx_cus%fft_g2r%npwt) ) CALL cft3t( exx_cus%fft_g2r, psic, exx_cus%fft_g2r%nr1t, exx_cus%fft_g2r%nr2t, exx_cus%fft_g2r%nr3t, & &exx_cus%fft_g2r%nrx1t, exx_cus%fft_g2r%nrx2t, exx_cus%fft_g2r%nrx3t, 2 ) psi_r(1:exx_cus%fft_g2r%nrxxt)= DBLE(psic(1:exx_cus%fft_g2r%nrxxt)) !loop on KS valence states do jv=1,exx_cus%nbndv(1) !do product prodr(1:exx_cus%fft_g2r%nrxxt)=psi_r(1:exx_cus%fft_g2r%nrxxt)*exx_cus%wfc(1:exx_cus%fft_g2r%nrxxt,jv,1) !put on small cell !loop on real Z direction prods(:)=0.d0 do iz=1,exx_cus%fft_g2r%nr3t if(iz >= rz_start .and. iz <= rz_end) then planes(:)=0.d0 do iy=1,exx_cus%fft_g2r%nr2t do ix=1,exx_cus%fft_g2r%nr1t iqq=(iz-rz_start)*(exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t)+(iy-1)*exx_cus%fft_g2r%nrx1t+ix planes(r2s_xy(iqq))=planes(r2s_xy(iqq))+prodr(iqq) enddo enddo !if Z is mine determine owner and send it iz_s=mod(iz-1,fft_small%nr3t)+1 idest=z2proc_s(iz_s) !put plane on small plane if(me_pool==idest) then do iqq_s=1,fft_small%nrx1t*fft_small%nrx2t prods((iz_s-rz_start_s)*(fft_small%nrx1t*fft_small%nrx2t)+iqq_s)=& & prods((iz_s-rz_start_s)*(fft_small%nrx1t*fft_small%nrx2t)+iqq_s)+planes(iqq_s) enddo else #ifdef __MPI CALL MPI_ISEND( planes, fft_small%nrx1t*fft_small%nrx2t, MPI_DOUBLE_PRECISION, & &idest, iz, intra_pool_comm, req,IERR ) CALL MPI_WAIT(req,istatus,ierr) #endif endif else iz_s=mod(iz-1,fft_small%nr3t)+1 !if Z o small cell is mine receive it if(z2proc_s(iz_s)==me_pool) then iorig=z2proc(iz) #ifdef __MPI CALL MPI_RECV( planes, fft_small%nrx1t*fft_small%nrx2t, MPI_DOUBLE_PRECISION, & &iorig, iz, intra_pool_comm, istatus, IERR ) #endif do iqq_s=1,fft_small%nrx1t*fft_small%nrx2t prods((iz_s-rz_start_s)*(fft_small%nrx1t*fft_small%nrx2t)+iqq_s)=& &prods((iz_s-rz_start_s)*(fft_small%nrx1t*fft_small%nrx2t)+iqq_s)+planes(iqq_s) enddo endif endif enddo ! do fft psic(1:fft_small%nrxxt)=cmplx(prods(1:fft_small%nrxxt),0.d0) CALL cft3t( fft_small, psic, fft_small%nr1t, fft_small%nr2t, fft_small%nr3t, & &fft_small%nrx1t, fft_small%nrx2t, fft_small%nrx3t, -1 ) prods_g(1:fft_small%ngmt) = psic(fft_small%nlt(1:fft_small%ngmt)) !apply fac prods_g(1:fft_small%ngmt)=fac(1:fft_small%ngmt)*prods_g(1:fft_small%ngmt) !put back on large cell psic=0.d0 psic(fft_small%nlt(1:fft_small%ngmt)) = prods_g(1:fft_small%ngmt) psic(fft_small%nltm(1:fft_small%ngmt)) = CONJG( prods_g(1:fft_small%ngmt)) CALL cft3t( fft_small, psic, fft_small%nr1t, fft_small%nr2t, fft_small%nr3t, & &fft_small%nrx1t, fft_small%nrx2t, fft_small%nrx3t, +1 ) prods(1:fft_small%nrxxt)=dble(psic(1:fft_small%nrxxt)) !loop on small z grid do iz_s=1,fft_small%nr3t !send and receive z and z+alat do ii=1,2 iz=iz_s+fft_small%nr3t*(ii-1) !do periodic replica if(iz_s >= rz_start_s .and. iz_s <= rz_end_s) then !if Z is mine determine owner and send idest=z2proc(iz) !put plane on small plane if(me_pool==idest) then do iqq_s=1,fft_small%nrx1t*fft_small%nrx2t planes(iqq_s)=prods((iz_s-rz_start_s)*(fft_small%nrx1t*fft_small%nrx2t)+iqq_s) enddo !do replicas do jj=1,2 do kk=1,2 do iy_s=1,fft_small%nr2t do ix_s=1,fft_small%nr1t iy=iy_s+fft_small%nr2t*(jj-1) ix=ix_s+fft_small%nr1t*(kk-1) iqq=(iz-rz_start)*(exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t)+(iy-1)*exx_cus%fft_g2r%nrx1t+ix prodr(iqq)=planes(r2s_xy(iqq)) enddo enddo enddo enddo else do iqq_s=1,fft_small%nrx1t*fft_small%nrx2t planes(iqq_s)=prods((iz_s-rz_start_s)*(fft_small%nrx1t*fft_small%nrx2t)+iqq_s) enddo #ifdef __MPI CALL MPI_ISEND( planes, fft_small%nrx1t*fft_small%nrx2t, MPI_DOUBLE_PRECISION, & &idest, iz, intra_pool_comm, req,IERR ) CALL MPI_WAIT(req,istatus,ierr) #endif endif else !if Z on large cell is mine receive it if(z2proc(iz)==me_pool) then iorig=z2proc_s(iz_s) #ifdef __MPI CALL MPI_RECV( planes, fft_small%nrx1t*fft_small%nrx2t, MPI_DOUBLE_PRECISION, & &iorig, iz, intra_pool_comm, istatus, IERR ) #endif do jj=1,2 do kk=1,2 do iy_s=1,fft_small%nr2t do ix_s=1,fft_small%nr1t iy=iy_s+fft_small%nr2t*(jj-1) ix=ix_s+fft_small%nr1t*(kk-1) iqq=(iz-rz_start)*(exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t)+(iy-1)*exx_cus%fft_g2r%nrx1t+ix prodr(iqq)=planes(r2s_xy(iqq)) enddo enddo enddo enddo endif endif enddo!ii enddo !do product vexc(1:exx_cus%fft_g2r%nrxxt)=vexc(1:exx_cus%fft_g2r%nrxxt)+prodr(1:exx_cus%fft_g2r%nrxxt)*& &exx_cus%wfc(1:exx_cus%fft_g2r%nrxxt,jv,1) !sum up result terms !end loop enddo !do scalar producs sca=0.d0 do i=1,exx_cus%fft_g2r%nrxxt sca=sca+psi_r(i)*vexc(i) enddo call mp_sum(sca,world_comm) sca=sca/dble(exx_cus%fft_g2r%nr1t*exx_cus%fft_g2r%nr2t*exx_cus%fft_g2r%nr3t) write(stdout,*) 'PERIODIC EXCHANGE', iv, sca call flush_unit(stdout) !end loop enddo deallocate(r2s_xy,r2s_z) deallocate(fac) deallocate(prodr,prods) deallocate(planes) deallocate(z2proc_s) deallocate(z2proc) deallocate(prods_g) deallocate(vexc) deallocate(psi_t,psi_r,evc_g) return END SUBROUTINE periodic_dft_exchange SUBROUTINE setup_exx_cus(nspin,num_nbndv_max,num_nbndv,ks_wfcs, exx_cus, dual, cutoff, truncation_radius) !ATTENZIONE now only for cubic cell to be extended USE io_global, ONLY : stdout, ionode, ionode_id USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, ecutwfc USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2,bg USE constants, ONLY : e2, pi, tpi, fpi, RYTOEV USE wavefunctions_module, ONLY : psic USE mp_global, ONLY : intra_pool_comm, me_pool USE gvect USE mp_wave, ONLY : mergewf,splitwf USE mp, ONLY : mp_barrier, mp_sum USE mp_world, ONLY : world_comm, mpime, nproc IMPLICIT NONE INTEGER, INTENT(in) :: nspin!spin multiplicity INTEGER, INTENT(in) ::num_nbndv_max!max number of valence states for both spins INTEGER, INTENT(in) :: num_nbndv(2)!number of valence states COMPLEX(kind=DP), INTENT(in) :: ks_wfcs(npwx, num_nbndv_max,2)!KS valence wfcs TYPE(exchange_cus), INTENT(out) :: exx_cus!the structure to be created REAL(kind=DP), INTENT(in) :: dual!for defining the real space grid REAL(kind=DP), INTENT(in) :: cutoff !for the defining the G space grid REAL(kind=DP), INTENT(in) :: truncation_radius!Bohr REAL(kind=DP) :: qq_fact INTEGER :: ig,ii,i,j,iv,ir,n_max,is,k,jj,kk COMPLEX(kind=DP), ALLOCATABLE :: state_fc_t(:,:),evc_g(:) INTEGER :: rz_start,rz_end,ix,iy,iz,iqq,iqq_s,ix_s,iy_s INTEGER :: rz_start_s,rz_end_s,nr3small INTEGER :: iorig, idest,iz_s,jv INTEGER,ALLOCATABLE :: z2proc_s(:),z2proc(:) INTEGER iplane REAL(kind=DP), ALLOCATABLE :: plane(:) INTEGER :: req, ierr #ifdef __MPI INTEGER :: istatus(MPI_STATUS_SIZE) #endif CALL start_clock('setup_exx') !setup parameters exx_cus%nbndv(1:2)=num_nbndv(1:2) exx_cus%dual=dual exx_cus%cutoff=cutoff exx_cus%truncation_radius=truncation_radius exx_cus%l_localized=l_exchange_localized exx_cus%thrs_loc=exchange_thrs_loc exx_cus%nspin=nspin !define grids exx_cus%fft_g2r%ecutt=ecutwfc exx_cus%fft_g2r%dual_t=dual call mp_barrier( world_comm ) write(stdout,*) 'Before initialize_fft_custom',exx_cus%fft_g2r%ecutt,exx_cus%fft_g2r%dual_t call flush_unit(stdout) call initialize_fft_custom(exx_cus%fft_g2r) write(stdout,*) "GRID G to R", exx_cus%fft_g2r%nr1t, exx_cus%fft_g2r%nr2t, exx_cus%fft_g2r%nr3t write(stdout,*) "GRID G to R",exx_cus%fft_g2r%npwt call flush_unit(stdout) exx_cus%fft_r2g%ecutt=cutoff exx_cus%fft_r2g%dual_t=ecutwfc*dual/cutoff call initialize_fft_custom(exx_cus%fft_r2g) write(stdout,*) "GRID R to G", exx_cus%fft_r2g%nr1t, exx_cus%fft_r2g%nr2t, exx_cus%fft_r2g%nr3t write(stdout,*) "GRID R to G",exx_cus%fft_r2g%npwt call flush_unit(stdout) if(l_exchange_turbo) then !setup small grid exx_cus%m(1:3)=exchange_m(1:3) exx_cus%n(1:3)=exchange_n(1:3) do i=1,3 exx_cus%fft_small%at_t(1:3,i)=exx_cus%fft_g2r%at_t(1:3,i) exx_cus%fft_small%bg_t(1:3,i)=exx_cus%fft_g2r%bg_t(1:3,i) enddo exx_cus%fft_small%alat_t=exx_cus%fft_g2r%alat_t*dble(exchange_n(1))/dble(exchange_m(1)) exx_cus%fft_small%omega_t=exx_cus%fft_g2r%omega_t*(dble(exchange_n(1))/dble(exchange_m(1)))**3.d0 exx_cus%fft_small%tpiba_t=exx_cus%fft_g2r%tpiba_t/(dble(exchange_n(1))/dble(exchange_m(1))) exx_cus%fft_small%tpiba2_t=exx_cus%fft_g2r%tpiba2_t/(dble(exchange_n(1))/dble(exchange_m(1)))**2.d0 exx_cus%fft_small%ecutt=exx_cus%fft_g2r%ecutt exx_cus%fft_small%dual_t=exx_cus%fft_g2r%dual_t call initialize_fft_custom_cell(exx_cus%fft_small) allocate(exx_cus%r2s_xy(exx_cus%fft_g2r%nrxxt,exx_cus%n(1),exx_cus%n(2))) allocate(exx_cus%fac_s(exx_cus%fft_small%ngmt)) !setup correspondence grids rz_start=0 rz_end =0 do ii=1,me_pool + 1 rz_start=rz_end+1 rz_end=rz_end+exx_cus%fft_g2r%dfftt%npp(ii) end do exx_cus%r2s_xy(:,:,:)=0 do i=1,exx_cus%n(1) do j=1,exx_cus%n(2) do iz=1,exx_cus%fft_g2r%dfftt%npp(me_pool+1) do iy=1,exx_cus%fft_g2r%nr2t do ix=1,exx_cus%fft_g2r%nr1t iqq=(iz-1)*(exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t)+(iy-1)*exx_cus%fft_g2r%nrx1t+ix iy_s=mod(iy-1+(j-1)*exx_cus%fft_g2r%nr2t,exx_cus%fft_small%nr2t)+1 ix_s=mod(ix-1+(i-1)*exx_cus%fft_g2r%nr1t,exx_cus%fft_small%nr1t)+1 iqq_s=(iy_s-1)*exx_cus%fft_small%nrx1t+ix_s exx_cus%r2s_xy(iqq,i,j)=iqq_s!XY correspondance only enddo enddo enddo enddo enddo allocate(exx_cus%s2r_xy(exx_cus%fft_small%nrx1t*exx_cus%fft_small%nrx2t,exx_cus%m(1),exx_cus%m(2))) do jj=1,exx_cus%m(2) do kk=1,exx_cus%m(1) do iy_s=1,exx_cus%fft_small%nr2t do ix_s=1,exx_cus%fft_small%nr1t iy=mod(iy_s+exx_cus%fft_small%nr2t*(jj-1)-1,exx_cus%fft_g2r%nr2t)+1 ix=mod(ix_s+exx_cus%fft_small%nr1t*(kk-1)-1,exx_cus%fft_g2r%nr1t)+1 iqq=(iy-1)*exx_cus%fft_g2r%nrx1t+ix iqq_s=(iy_s-1)*exx_cus%fft_small%nrx1t+ix_s exx_cus%s2r_xy(iqq_s,kk,jj)=iqq enddo enddo enddo enddo endif !setup fac allocate(exx_cus%fac(exx_cus%fft_r2g%ngmt)) do ig=1,exx_cus%fft_r2g%ngmt qq_fact = exx_cus%fft_r2g%gt(1,ig)**2.d0 + exx_cus%fft_r2g%gt(2,ig)**2.d0 + exx_cus%fft_r2g%gt(3,ig)**2.d0 if (qq_fact > 1.d-8) then exx_cus%fac(ig)=(e2*fpi/(tpiba2*qq_fact))*(1.d0-dcos(dsqrt(qq_fact)*exx_cus%truncation_radius*tpiba)) else exx_cus%fac(ig)=e2*fpi*(exx_cus%truncation_radius**2.d0/2.d0) endif end do exx_cus%fac(:)=exx_cus%fac(:)/omega !put wfcs in real space allocate(exx_cus%wfc(exx_cus%fft_g2r%nrxxt,num_nbndv_max,nspin)) allocate(state_fc_t(exx_cus%fft_g2r%npwt,num_nbndv_max)) allocate( evc_g( exx_cus%fft_g2r%ngmt_g ) ) do is=1,nspin if(exx_cus%fft_g2r%dual_t==4.d0) then state_fc_t(1:exx_cus%fft_g2r%npwt,1:exx_cus%nbndv(is))=ks_wfcs(1:exx_cus%fft_g2r%npwt,1:exx_cus%nbndv(is),is) else do ii=1,exx_cus%nbndv(is) call mergewf(ks_wfcs(:,ii,is),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) call splitwf(state_fc_t(:,ii),evc_g,exx_cus%fft_g2r%npwt,exx_cus%fft_g2r%ig_l2gt,& &mpime,nproc,ionode_id,intra_pool_comm) enddo endif do ii=1,exx_cus%nbndv(is),2 psic(:)=(0.d0,0.d0) if(ii==exx_cus%nbndv(is)) then psic(exx_cus%fft_g2r%nlt(1:exx_cus%fft_g2r%npwt)) = state_fc_t(1:exx_cus%fft_g2r%npwt,ii) psic(exx_cus%fft_g2r%nltm(1:exx_cus%fft_g2r%npwt)) = CONJG( state_fc_t(1:exx_cus%fft_g2r%npwt,ii) ) else psic(exx_cus%fft_g2r%nlt(1:exx_cus%fft_g2r%npwt))=state_fc_t(1:exx_cus%fft_g2r%npwt,ii)+& &(0.d0,1.d0)*state_fc_t(1:exx_cus%fft_g2r%npwt,ii+1) psic(exx_cus%fft_g2r%nltm(1:exx_cus%fft_g2r%npwt)) = CONJG( state_fc_t(1:exx_cus%fft_g2r%npwt,ii) )+& &(0.d0,1.d0)*CONJG( state_fc_t(1:exx_cus%fft_g2r%npwt,ii+1) ) endif CALL cft3t( exx_cus%fft_g2r, psic, exx_cus%fft_g2r%nr1t, exx_cus%fft_g2r%nr2t, exx_cus%fft_g2r%nr3t, & &exx_cus%fft_g2r%nrx1t, exx_cus%fft_g2r%nrx2t, exx_cus%fft_g2r%nrx3t, 2 ) exx_cus%wfc(1:exx_cus%fft_g2r%nrxxt,ii,is)= DBLE(psic(1:exx_cus%fft_g2r%nrxxt)) if(ii/=exx_cus%nbndv(1)) exx_cus%wfc(1:exx_cus%fft_g2r%nrxxt,ii+1,is)=& &DIMAG(psic(1:exx_cus%fft_g2r%nrxxt)) enddo enddo !now put on the reduced grid if(l_exchange_turbo) then !find maximum rz_start=0 rz_end =0 do ii=1,me_pool + 1 rz_start=rz_end+1 rz_end=rz_end+exx_cus%fft_g2r%dfftt%npp(ii) end do rz_start_s=0 rz_end_s=0 do ii=1,me_pool + 1 rz_start_s=rz_end_s+1 rz_end_s=rz_end_s+exx_cus%fft_small%dfftt%npp(ii) end do nr3small=rz_end_s-rz_start_s+1 allocate(exx_cus%wfc_red(exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t,nr3small,exx_cus%m(3),num_nbndv_max,exx_cus%nspin)) allocate(z2proc_s(exx_cus%fft_small%nr3t)) allocate(z2proc(exx_cus%fft_g2r%nr3t)) j=0 k=0 do ii=1,nproc j=k+1 k=k+exx_cus%fft_small%dfftt%npp(ii) z2proc_s(j:k)=ii-1 end do j=0 k=0 do ii=1,nproc j=k+1 k=k+exx_cus%fft_g2r%dfftt%npp(ii) z2proc(j:k)=ii-1 end do allocate(plane(exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t)) do k=1,exx_cus%n(3) do iz=1,exx_cus%fft_g2r%nr3t if(iz >= rz_start .and. iz <= rz_end) then !if Z is mine determine owner and send it iz_s=mod(iz-1+(k-1)*exx_cus%fft_g2r%nr3t,exx_cus%fft_small%nr3t)+1 iplane=(iz-1+(k-1)*exx_cus%fft_g2r%nr3t)/exx_cus%fft_small%nr3t+1 idest=z2proc_s(iz_s) !put plane on small plane if(me_pool==idest) then do is=1,exx_cus%nspin do jv=1,exx_cus%nbndv(is) do iqq=1,exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t exx_cus%wfc_red(iqq,iz_s-rz_start_s+1,iplane,jv,is)=& &exx_cus%wfc((iz-rz_start)*(exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t)+iqq,jv,is) enddo enddo enddo else do is=1,exx_cus%nspin do jv=1,exx_cus%nbndv(is) do iqq=1,exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t plane(iqq)=exx_cus%wfc((iz-rz_start)*(exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t)+iqq,jv,is) enddo #ifdef __MPI CALL MPI_ISEND( plane,exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t, MPI_DOUBLE_PRECISION, & &idest, iz, intra_pool_comm, req,IERR ) CALL MPI_WAIT(req,istatus,ierr) #endif enddo enddo endif else iz_s=mod(iz-1+(k-1)*exx_cus%fft_g2r%nr3t,exx_cus%fft_small%nr3t)+1 iplane=(iz-1+(k-1)*exx_cus%fft_g2r%nr3t)/exx_cus%fft_small%nr3t+1 !if Z o small cell is mine receive it if(z2proc_s(iz_s)==me_pool) then iorig=z2proc(iz) do is=1,exx_cus%nspin do jv=1,exx_cus%nbndv(is) #ifdef __MPI CALL MPI_RECV( plane, exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t, MPI_DOUBLE_PRECISION, & &iorig, iz, intra_pool_comm, istatus, IERR ) #endif do iqq=1,exx_cus%fft_g2r%nrx1t*exx_cus%fft_g2r%nrx2t exx_cus%wfc_red(iqq,iz_s-rz_start_s+1,iplane,jv,is)=plane(iqq) enddo enddo enddo endif endif enddo enddo deallocate(z2proc,z2proc_s,plane) endif deallocate(state_fc_t,evc_g) if(exx_cus%l_localized) then allocate(exx_cus%n_loc(num_nbndv_max,nspin)) allocate(exx_cus%tab_loc(exx_cus%fft_g2r%nrxxt,num_nbndv_max,nspin))!memory could be reduce here do is=1,nspin do iv=1,exx_cus%nbndv(is) exx_cus%n_loc(iv,is)=0 do ir=1,exx_cus%fft_g2r%nrxxt if((exx_cus%wfc(ir,iv,is)**2.d0>exx_cus%thrs_loc) )then exx_cus%n_loc(iv,is)=exx_cus%n_loc(iv,is)+1 exx_cus%tab_loc(exx_cus%n_loc(iv,is),iv,is)=ir endif enddo n_max=exx_cus%n_loc(iv,is) call mp_sum(n_max,world_comm) write(stdout,*) 'Using localized wfcs for exchange:',is,iv,n_max,& &exx_cus%fft_g2r%nr1t*exx_cus%fft_g2r%nr2t*exx_cus%fft_g2r%nr3t enddo enddo endif CALL stop_clock('setup_exx') return END SUBROUTINE setup_exx_cus SUBROUTINE free_memory_exx_cus(exx_cus) IMPLICIT NONE TYPE(exchange_cus) :: exx_cus deallocate(exx_cus%wfc) deallocate(exx_cus%fac) if(l_exchange_turbo) then deallocate(exx_cus%fac_s) deallocate(exx_cus%r2s_xy) deallocate(exx_cus%wfc_red) deallocate(exx_cus%s2r_xy) endif if(exx_cus%l_localized) then deallocate(exx_cus%n_loc) deallocate(exx_cus%tab_loc) endif return END SUBROUTINE free_memory_exx_cus SUBROUTINE fock_cus(psi,xpsi,exx_cus) !apply Fock operator to a wavefunction USE io_global, ONLY : stdout, ionode, ionode_id USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, ecutwfc USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2,bg USE constants, ONLY : e2, pi, tpi, fpi, RYTOEV USE wavefunctions_module, ONLY : psic USE gvect USE mp_pools, ONLY : intra_pool_comm USE mp_world, ONLY : mpime, nproc USE mp_wave, ONLY : mergewf,splitwf IMPLICIT NONE COMPLEX(kind=DP), INTENT(in) :: psi(npw) COMPLEX(kind=DP), INTENT(inout) :: xpsi(npw) TYPE(exchange_cus), INTENT(in) :: exx_cus REAL(kind=DP), ALLOCATABLE :: prods_r(:,:),psi_r(:),prod_tot(:) COMPLEX(kind=DP), ALLOCATABLE :: prods_g(:,:),evc_g(:), psi_t(:), prod_tot_g(:) INTEGER :: iv,ig INTEGER, ALLOCATABLE :: igkt(:) CALL start_clock('fock') allocate(prods_r(exx_cus%fft_g2r%nrxxt,exx_cus%nbndv(1))) allocate(prod_tot(exx_cus%fft_g2r%nrxxt)) allocate(prods_g(exx_cus%fft_r2g%npwt,exx_cus%nbndv(1))) allocate(prod_tot_g(exx_cus%fft_g2r%npwt)) allocate(psi_t(exx_cus%fft_g2r%npwt)) allocate(psi_r(exx_cus%fft_g2r%nrxxt)) !put psi on the g2r G grid allocate( evc_g( exx_cus%fft_g2r%ngmt_g ) ) allocate( igkt( exx_cus%fft_g2r%npwt ) ) do ig=1,exx_cus%fft_g2r%npwt igkt(ig)=ig enddo if(exx_cus%fft_g2r%dual_t==4.d0) then psi_t(1:exx_cus%fft_g2r%npwt)=psi(1:exx_cus%fft_g2r%npwt) else call mergewf(psi,evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) call splitwf(psi_t(:),evc_g,exx_cus%fft_g2r%npwt,exx_cus%fft_g2r%ig_l2gt,& &mpime,nproc,ionode_id,intra_pool_comm) endif !trasform psi to R space psic(:)=(0.d0,0.d0) psic(exx_cus%fft_g2r%nlt(1:exx_cus%fft_g2r%npwt)) = psi_t(1:exx_cus%fft_g2r%npwt) psic(exx_cus%fft_g2r%nltm(1:exx_cus%fft_g2r%npwt)) = CONJG( psi_t(1:exx_cus%fft_g2r%npwt) ) CALL cft3t( exx_cus%fft_g2r, psic, exx_cus%fft_g2r%nr1t, exx_cus%fft_g2r%nr2t, exx_cus%fft_g2r%nr3t, & &exx_cus%fft_g2r%nrx1t, exx_cus%fft_g2r%nrx2t, exx_cus%fft_g2r%nrx3t, 2 ) psi_r(1:exx_cus%fft_g2r%nrxxt)= DBLE(psic(1:exx_cus%fft_g2r%nrxxt)) !products with \Psi_v do iv=1,exx_cus%nbndv(1) prods_r(1:exx_cus%fft_g2r%nrxxt,iv)=psi_r(1:exx_cus%fft_g2r%nrxxt)*& &exx_cus%wfc(1:exx_cus%fft_g2r%nrxxt,iv,1) enddo !to G r2G grid do iv=1,exx_cus%nbndv(1),2 if(iv==exx_cus%nbndv(1)) then psic(1:exx_cus%fft_r2g%nrxxt)=dcmplx(prods_r(1:exx_cus%fft_r2g%nrxxt,iv),0.d0) else psic(1:exx_cus%fft_r2g%nrxxt)=dcmplx(prods_r(1:exx_cus%fft_r2g%nrxxt,iv),prods_r(1:exx_cus%fft_r2g%nrxxt,iv+1)) endif CALL cft3t( exx_cus%fft_r2g, psic, exx_cus%fft_r2g%nr1t, exx_cus%fft_r2g%nr2t, exx_cus%fft_r2g%nr3t, & &exx_cus%fft_r2g%nrx1t, exx_cus%fft_r2g%nrx2t, exx_cus%fft_r2g%nrx3t, -2 ) if(iv==exx_cus%nbndv(1)) then prods_g(1:exx_cus%fft_r2g%npwt, iv) = psic(exx_cus%fft_r2g%nlt(igkt(1:exx_cus%fft_r2g%npwt))) else prods_g(1:exx_cus%fft_r2g%npwt, iv)= 0.5d0*(psic(exx_cus%fft_r2g%nlt(igkt(1:exx_cus%fft_r2g%npwt)))+& &conjg( psic(exx_cus%fft_r2g%nltm(igkt(1:exx_cus%fft_r2g%npwt))))) prods_g(1:exx_cus%fft_r2g%npwt, iv+1)= (0.d0,-0.5d0)*(psic(exx_cus%fft_r2g%nlt(igkt(1:exx_cus%fft_r2g%npwt))) - & &conjg(psic(exx_cus%fft_r2g%nltm(igkt(1:exx_cus%fft_r2g%npwt))))) endif enddo !multiply with fac do iv=1,exx_cus%nbndv(1) prods_g(1:exx_cus%fft_r2g%npwt,iv)=prods_g(1:exx_cus%fft_r2g%npwt,iv)*exx_cus%fac(1:exx_cus%fft_r2g%npwt) enddo !to R r2G grid do iv=1,exx_cus%nbndv(1),2 psic(:)=(0.d0,0.d0) if(iv==exx_cus%nbndv(1)) then psic(exx_cus%fft_r2g%nlt(1:exx_cus%fft_r2g%npwt)) = prods_g(1:exx_cus%fft_r2g%npwt,iv) psic(exx_cus%fft_r2g%nltm(1:exx_cus%fft_r2g%npwt)) = CONJG( prods_g(1:exx_cus%fft_r2g%npwt,iv) ) else psic(exx_cus%fft_r2g%nlt(1:exx_cus%fft_r2g%npwt))=prods_g(1:exx_cus%fft_r2g%npwt,iv)+& &(0.d0,1.d0)*prods_g(1:exx_cus%fft_r2g%npwt,iv+1) psic(exx_cus%fft_r2g%nltm(1:exx_cus%fft_r2g%npwt)) = CONJG( prods_g(1:exx_cus%fft_r2g%npwt,iv) )+& &(0.d0,1.d0)*CONJG( prods_g(1:exx_cus%fft_r2g%npwt,iv+1) ) endif CALL cft3t( exx_cus%fft_r2g, psic, exx_cus%fft_r2g%nr1t, exx_cus%fft_r2g%nr2t, exx_cus%fft_r2g%nr3t, & &exx_cus%fft_r2g%nrx1t, exx_cus%fft_r2g%nrx2t, exx_cus%fft_r2g%nrx3t, 2 ) prods_r(1:exx_cus%fft_r2g%nrxxt,iv)= DBLE(psic(1:exx_cus%fft_r2g%nrxxt)) if(iv/=exx_cus%nbndv(1)) prods_r(1:exx_cus%fft_r2g%nrxxt,iv+1)=& &DIMAG(psic(1:exx_cus%fft_r2g%nrxxt)) enddo !products with \Psi_v do iv=1,exx_cus%nbndv(1) prods_r(1:exx_cus%fft_g2r%nrxxt,iv)= prods_r(1:exx_cus%fft_g2r%nrxxt,iv)*exx_cus%wfc(1:exx_cus%fft_g2r%nrxxt,iv,1) enddo !sum up prod_tot=0.d0 do iv=1,exx_cus%nbndv(1) prod_tot(1:exx_cus%fft_g2r%nrxxt)=prod_tot(1:exx_cus%fft_g2r%nrxxt)+prods_r(1:exx_cus%fft_g2r%nrxxt,iv) enddo !transform to G space g2r grid psic(1:exx_cus%fft_g2r%nrxxt)=dcmplx(prod_tot(1:exx_cus%fft_g2r%nrxxt),0.d0) CALL cft3t( exx_cus%fft_g2r, psic, exx_cus%fft_g2r%nr1t, exx_cus%fft_g2r%nr2t, exx_cus%fft_g2r%nr3t, & &exx_cus%fft_g2r%nrx1t, exx_cus%fft_g2r%nrx2t, exx_cus%fft_g2r%nrx3t, -2 ) prod_tot_g(1:exx_cus%fft_g2r%npwt) = psic(exx_cus%fft_g2r%nlt(igkt(1:exx_cus%fft_g2r%npwt))) !put in the order or wfcs if(exx_cus%fft_g2r%dual_t==4.d0) then xpsi(1:exx_cus%fft_g2r%npwt)=prod_tot_g(1:exx_cus%fft_g2r%npwt) else call mergewf(prod_tot_g,evc_g,exx_cus%fft_g2r%npwt,exx_cus%fft_g2r%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) call splitwf(xpsi,evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) endif deallocate(prods_r,prods_g,prod_tot) deallocate(evc_g,psi_t,psi_r,prod_tot_g) deallocate(igkt) CALL stop_clock('fock') return END SUBROUTINE fock_cus SUBROUTINE fast_vexx(lda, n, m, psi, hpsi,exx_cus,exxalpha,ispin) IMPLICIT NONE INTEGER :: lda, n, m, nqi, myrank, mysize COMPLEX(DP) :: psi(lda,m) COMPLEX(DP) :: hpsi(lda,m) TYPE(exchange_cus) :: exx_cus REAL(kind=DP) :: exxalpha INTEGER, INTENT(in) :: ispin COMPLEX(kind=DP), ALLOCATABLE :: xpsi(:) INTEGER :: ii allocate(xpsi(lda)) do ii=1,m if(.not.l_exchange_turbo) then call fock_cus(psi(1,ii),xpsi,exx_cus) else call periodic_fock_cus(ispin,psi(1,ii),xpsi,exx_cus) endif hpsi(1:n,ii)=hpsi(1:n,ii)-exxalpha*xpsi(1:n) enddo deallocate(xpsi) return END SUBROUTINE fast_vexx FUNCTION exchange_energy_fast(exx_cus,exxalpha) USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, ecutwfc USE wavefunctions_module, ONLY : evc USE mp, ONLY : mp_sum USE mp_world, ONLY : world_comm USE gvect, ONLY : gstart USE io_files, ONLY : prefix, tmp_dir, nwordwfc,iunwfc IMPLICIT NONE REAL(kind=DP) :: exchange_energy_fast TYPE(exchange_cus) :: exx_cus REAL(kind=DP) :: exxalpha INTEGER :: ii,ig,is COMPLEX(kind=DP), ALLOCATABLE :: psi(:,:),xpsi(:) exchange_energy_fast=0.d0 allocate(xpsi(npwx),psi(npwx,nbnd)) do is=1,exx_cus%nspin if(exx_cus%nspin==1) then psi(1:npw,1:exx_cus%nbndv(is))=evc(1:npw,1:exx_cus%nbndv(is)) else CALL davcio(psi,2*nwordwfc,iunwfc,is,-1) endif do ii=1,exx_cus%nbndv(is) if(.not.l_exchange_turbo) then call fock_cus(psi(:,ii),xpsi,exx_cus) else call periodic_fock_cus(is,psi(:,ii),xpsi,exx_cus) endif do ig=1,npw exchange_energy_fast=exchange_energy_fast+2.d0*dble(psi(ig,ii)*conjg(xpsi(ig))) enddo if(gstart==2) exchange_energy_fast=exchange_energy_fast-dble(psi(1,ii)*conjg(xpsi(1))) enddo enddo deallocate(xpsi,psi) call mp_sum(exchange_energy_fast,world_comm) if(exx_cus%nspin==1) then exchange_energy_fast=-exchange_energy_fast*exxalpha*2.d0!the 2 is for spin ATTENZIONE else exchange_energy_fast=-exchange_energy_fast*exxalpha endif return END FUNCTION exchange_energy_fast subroutine dft_exchange_fast(ispin,nbnd_s,psi,exx_cus) USE io_global, ONLY : stdout, ionode, ionode_id USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, ecutwfc,wg USE gvect USE mp, ONLY : mp_sum USE mp_world, ONLY : world_comm implicit none INTEGER, INTENT(in) :: ispin!spin channel INTEGER, INTENT(in) :: nbnd_s!number of states COMPLEX(kind=DP), INTENT(in) :: psi(npwx,nbnd_s)!wavefunctions TYPE(exchange_cus), INTENT(in) :: exx_cus!descriptor of exchange INTEGER :: ii,ig COMPLEX(kind=DP), ALLOCATABLE :: xpsi(:,:) REAL(kind=DP) :: sca allocate(xpsi(npwx,nbnd_s)) !loop on states do ii=1,nbnd_s !apply X operator if(.not.l_exchange_turbo) then call fock_cus(psi(:,ii),xpsi(:,ii),exx_cus) else call periodic_fock_cus(ispin,psi(:,ii),xpsi(:,ii),exx_cus) endif enddo !calculate overlap do ii=1,nbnd_s sca=0.d0 do ig=1,npw sca=sca+2.d0*dble(psi(ig,ii)*conjg(xpsi(ig,ii))) enddo if(gstart==2) sca=sca-dble(psi(1,ii)*conjg(xpsi(1,ii))) call mp_sum(sca,world_comm) write(stdout,*) 'EXCHANGE FAST',ii, sca enddo call flush_unit(stdout) deallocate(xpsi) return end subroutine dft_exchange_fast END MODULE exchange_custom GWW/pw4gww/hpsi_pw4gww.f900000644000077300007730000000445612341332532016062 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !this subroutine applies (H-e(iv)) to an array of num_nbndv wavefunctions !NO SPIN YET subroutine hpsi_pw4gww( ndim,psi,ppsi,et,ik,numv) ! ch_psi_all (n, h, ah, e, ik, m) USE kinds, ONLY : DP USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, ecutwfc USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : mpime, nproc implicit none INTEGER, INTENT(in) :: ndim !leading dimension of psi and psip INTEGER, INTENT(in) :: numv!number of bands INTEGER, INTENT(in) ::ik!dumm integer COMPLEX(kind=DP), INTENT(in) :: psi(ndim,numv) COMPLEX(kind=DP), INTENT(out) :: ppsi(ndim,numv) REAL(kind=DP) :: et(numv) INTEGER :: iv !apply h_psi do iv=1,numv call pc_operator(psi(1,iv),1,.false.) enddo call h_psi( ndim, npw, numv, psi, ppsi ) do iv=1,numv ppsi(1:npw,iv)=ppsi(1:npw,iv)-et(iv)*psi(1:npw,iv) !ppsi(1:npw,iv)=ppsi(1:npw,iv)-100.d0*psi(1:npw,iv) enddo do iv=1,numv call pc_operator(ppsi(1,iv),1,.false.) enddo return end subroutine hpsi_pw4gww !----------------------------------------------------------------- subroutine cg_psi_pw4gww (lda, n, m, psi, h_diag) !----------------------------------------------------------------- ! ! This routine gives a preconditioning to the linear system solver. ! The preconditioning is diagonal in reciprocal space ! ! USE kinds, only : DP USE wvfct, ONLY : et implicit none integer :: lda, n, m ! input: the leading dimension of the psi vector ! input: the real dimension of the vector ! input: the number of vectors complex(DP) :: psi (lda, m) ! inp/out: the vector to be preconditioned real(DP) :: h_diag (lda, m) ! input: the preconditioning vector integer :: k, i ! counter on bands ! counter on the elements of the vector ! do k = 1, m do i = 1, n psi (i, k) = psi (i, k) * 1.d0/(1.d0+h_diag (i, k))!-et(k,1)) !psi (i, k) = psi (i, k) * 1.d0/(h_diag (i, k)-100.d0) enddo enddo return end subroutine cg_psi_pw4gww GWW/pw4gww/pola_lanczos.f900000644000077300007730000025335012341332532016263 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !routines for the calculation of the polarization !lanczos-style !ONLY FOR NORMCONSERVING PSEUDOS !!!!! subroutine pola_basis_lanczos(n_set,nstates,numpw, nsteps,ispin) !this subroutine calculates the basis for every v !the minimal orthonormal basis for the w_v(r)*w^P'_i(r) products USE io_global, ONLY : stdout, ionode, ionode_id USE io_files, ONLY : prefix, tmp_dir, diropn USE kinds, ONLY : DP USE wannier_gw USE gvect USE constants, ONLY : e2, pi, tpi, fpi USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2 USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, ecutwfc USE wavefunctions_module, ONLY : evc, psic USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : world_comm, mpime, nproc USE mp_pools, ONLY : intra_pool_comm USE gvecs, ONLY : nls, nlsm, doublegrid USE fft_custom_gwl USE mp_wave, ONLY : mergewf,splitwf USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER, INTENT(in) :: n_set !defines the number of states to be read from disk at the same tim\e INTEGER, INTENT(in) :: nstates!number of orthonormal states to retain INTEGER, INTENT(in) :: numpw!dimension of polarization basis INTEGER, INTENT(in) :: nsteps!number of lanczos steps INTEGER, INTENT(in) :: ispin! spin channel INTEGER :: iv,iw,ig,ii,jj REAL(kind=DP), ALLOCATABLE :: wv_real(:),tmp_r(:),tmp_r2(:) COMPLEX(kind=DP), ALLOCATABLE :: tmp_g(:), wp_prod(:,:,:) INTEGER :: iungprod,iunrprod, iungresult,iuntmat LOGICAL :: exst REAL(kind=DP), ALLOCATABLE :: omat(:,:),omat_hold(:,:) REAL(kind=DP), ALLOCATABLE :: eigen(:),work(:) INTEGER :: lwork,info,liwork COMPLEX(kind=DP), ALLOCATABLE :: wp_g(:,:)!product terms in g wfc grid COMPLEX(kind=DP), ALLOCATABLE :: wp_g_t(:,:)! REAL(kind=DP), ALLOCATABLE :: t_mat(:,:),t_mat_hold(:,:), t_mat_hold2(:,:) CHARACTER(4) :: nfile LOGICAL :: l_reduce_io=.true.!if true reduces io COMPLEX(kind=DP), ALLOCATABLE :: p_basis(:,:)!polarizability basis LOGICAL :: l_dsyevr=.true.!if true uses dsyevr REAL(kind=DP), ALLOCATABLE :: vectors(:,:)!for dsyevr INTEGER, ALLOCATABLE :: iwork(:), ifail(:) INTEGER, ALLOCATABLE :: isuppz(:) INTEGER :: n_found LOGICAL :: l_fft_custom=.false.!if true uses custom fft grid COMPLEX(kind=DP), ALLOCATABLE :: evc_t(:,:),p_basis_t(:,:) COMPLEX(kind=DP), ALLOCATABLE :: evc_g(:) LOGICAL :: l_sumrule=.false.!if true imposes the sum rule over the norm of Pc|\Phi_\mu\Psi_v> for each of them REAL(kind=DP), ALLOCATABLE :: norms(:) REAL(kind=DP) :: norm_t, c_norm,norm REAL(kind=DP), ALLOCATABLE :: p_basis_r(:,:) !polarizabilty basis in real custom space INTEGER :: ivv,nbuf REAL(kind=DP) :: vl,vu INTEGER :: il,iu REAL(kind=DP), ALLOCATABLE :: t_eigen_hold(:) TYPE(fft_cus) :: fc write(stdout,*) 'Routine pola_basis_lanczos' call flush_unit(stdout) fc%ecutt=ecutwfc fc%dual_t=dual_vt if(l_verbose) write(stdout,*) 'Call initialize_fft_custom' call flush_unit(stdout) call initialize_fft_custom(fc) allocate(evc_g(fc%ngmt_g)) allocate(wv_real(fc%nrxxt)) allocate(norms(numpw)) !read w^P'_i on file on real space !open product of wanniers filed iungprod = find_free_unit() CALL diropn( iungprod, 'wiwjwfc_red', max_ngm*2, exst ) if(.not.l_reduce_io) then iunrprod = find_free_unit() CALL diropn( iunrprod, 'wiwjwfc_red_r', dfftp%nnr, exst ) endif iungresult = find_free_unit() CALL diropn( iungresult, 'vw_lanczos',npw*2, exst) if(.not.l_reduce_io) then allocate(tmp_g(max_ngm),tmp_r(dfftp%nnr)) do iw=1,numpw call davcio(tmp_g,max_ngm*2,iungprod,iw,-1) !trasform to r-space psic(:)=(0.d0,0.d0) do ig=1,max_ngm psic(nl(ig))=tmp_g(ig) psic(nlm(ig))=CONJG(tmp_g(ig)) enddo CALL invfft ('Dense', psic, dfftp) tmp_r(:)=dble(psic(:)) call davcio(tmp_r,dfftp%nnr,iunrprod,iw,1) enddo deallocate(tmp_g,tmp_r) close(iunrprod) else !read polarizability basis functions allocate(p_basis(max_ngm,numpw)) do iw=1,numpw call davcio(p_basis(:,iw),max_ngm*2,iungprod,iw,-1) enddo endif close(iungprod) if(l_verbose) write(stdout,*) 'pola_basis_lanczos 1' call flush_unit(stdout) !now polarizability basis are put on the ordering of the redueced grid, if required allocate(p_basis_t(fc%npwt,numpw)) if(fc%dual_t==4.d0) then p_basis_t(:,:)=p_basis(:,:) else call reorderwfp_col(numpw,npw,fc%npwt,p_basis(1,1),p_basis_t(1,1), npw,fc%npwt, & & ig_l2g,fc%ig_l2gt,fc%ngmt_g,mpime, nproc,intra_pool_comm ) !do ii=1,numpw ! call mergewf(p_basis(:,ii),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) ! call splitwf(p_basis_t(:,ii),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) !enddo endif !trasform to real space allocate(p_basis_r(fc%nrxxt,numpw)) do ii=1,numpw,2 psic(:)=(0.d0,0.d0) if(ii==numpw) then psic(fc%nlt(1:fc%npwt)) = p_basis_t(1:fc%npwt,ii) psic(fc%nltm(1:fc%npwt)) = CONJG( p_basis_t(1:fc%npwt,ii) ) else psic(fc%nlt(1:fc%npwt))=p_basis_t(1:fc%npwt,ii)+(0.d0,1.d0)*p_basis_t(1:fc%npwt,ii+1) psic(fc%nltm(1:fc%npwt)) = CONJG( p_basis_t(1:fc%npwt,ii) )+(0.d0,1.d0)*CONJG( p_basis_t(1:fc%npwt,ii+1) ) endif CALL cft3t(fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) p_basis_r(1:fc%nrxxt,ii)= DBLE(psic(1:fc%nrxxt)) if(ii/=numpw) p_basis_r(1:fc%nrxxt,ii+1)= DIMAG(psic(1:fc%nrxxt)) enddo !now valence wavefunctions are put on the ordering of the reduced grid allocate(evc_t(fc%npwt,num_nbndv(ispin))) if(fc%dual_t==4.d0) then evc_t(:,1:num_nbndv(ispin))=evc(:,1:num_nbndv(ispin)) else call reorderwfp_col(num_nbndv(ispin),npw,fc%npwt,evc(1,1),evc_t(1,1), npw,fc%npwt, & & ig_l2g,fc%ig_l2gt,fc%ngmt_g,mpime, nproc,intra_pool_comm ) endif !loop on v allocate(tmp_r(fc%nrxxt),tmp_r2(fc%nrxxt)) allocate(omat(numpw,numpw),omat_hold(numpw,numpw)) allocate(t_mat(numpw,nstates), t_mat_hold(numpw,nstates), t_mat_hold2(numpw,nstates)) allocate(wp_g(npw,nstates)) allocate(wp_g_t(fc%npwt,nstates)) allocate(t_eigen_hold(nstates)) nbuf=min(5,nproc) allocate(wp_prod(fc%npwt,numpw,nbuf)) do ivv=1,num_nbndv(ispin),nbuf !put iv on real space do iv=ivv,min(ivv+nbuf-1,num_nbndv(ispin)) psic(:)=(0.d0,0.d0) psic(fc%nlt(1:fc%npwt)) = evc_t(1:fc%npwt,iv) psic(fc%nltm(1:fc%npwt)) = CONJG( evc_t(1:fc%npwt,iv) ) CALL cft3t(fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) wv_real(1:fc%nrxxt)= DBLE(psic(1:fc%nrxxt)) !!loop on products of wanniers if(.not.l_reduce_io) then iunrprod = find_free_unit() CALL diropn( iunrprod, 'wiwjwfc_red_r', dfftp%nnr, exst ) endif ! allocate(tmp_r(fc%nrxxt)) if(l_verbose) write(stdout,*) 'do fft' call flush_unit(stdout) do ii=1,numpw,2 !!read n_set w^P'_i from disk if(.not.l_reduce_io) then call davcio(tmp_r,dfftp%nnr,iunrprod,ii,-1) write(stdout,*) 'ERROR l_reduce_io must be true' call flush_unit(stdout) stop endif tmp_r(1:fc%nrxxt)=p_basis_r(1:fc%nrxxt,ii)*wv_real(1:fc%nrxxt) if(ii/=numpw) then tmp_r2(1:fc%nrxxt)=p_basis_r(1:fc%nrxxt,ii+1)*wv_real(1:fc%nrxxt) else tmp_r2(1:fc%nrxxt)=0.d0 endif !!form products with w_v and trasfrom in G space psic(1:fc%nrxxt)=dcmplx(tmp_r(1:fc%nrxxt),tmp_r2(1:fc%nrxxt)) CALL cft3t(fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, -2 ) if(ii==numpw) then wp_prod(1:fc%npwt, ii,iv-ivv+1) = psic(fc%nlt(1:fc%npwt)) else wp_prod(1:fc%npwt, ii,iv-ivv+1)= 0.5d0*(psic(fc%nlt(1:fc%npwt))+conjg( psic(fc%nltm(1:fc%npwt)))) wp_prod(1:fc%npwt, ii+1,iv-ivv+1)= (0.d0,-0.5d0)*(psic(fc%nlt(1:fc%npwt)) - conjg(psic(fc%nltm(1:fc%npwt)))) endif enddo if(l_verbose) write(stdout,*) 'do pc_operator' call flush_unit(stdout) call pc_operator_t_m(numpw,wp_prod(1,1,iv-ivv+1),evc_t,ispin, fc) if(l_verbose) write(stdout,*) 'calculate omat' call flush_unit(stdout) if(.not.l_reduce_io) close(iunrprod) !!calculate overlap matrix call dgemm('T','N',numpw,numpw,2*fc%npwt,2.d0,wp_prod(1,1,iv-ivv+1),2*fc%npwt,& &wp_prod(1,1,iv-ivv+1),2*fc%npwt,0.d0,omat,numpw) if(fc%gstart_t==2) then do ii=1,numpw do jj=1,numpw omat(jj,ii)=omat(jj,ii)-dble(conjg(wp_prod(1,jj,iv-ivv+1))*wp_prod(1,ii,iv-ivv+1)) enddo enddo endif do ii=1,numpw call mp_sum(omat(1:numpw,ii), world_comm) enddo !set up norms ! do ii=1,numpw ! norms(ii)=omat(ii,ii) ! enddo if(iv-ivv==mpime) then omat_hold(:,:)=omat(:,:) endif enddo !! !!solve eigen/values vector problem !! if(l_verbose) write(stdout,*) 'solve eig' call flush_unit(stdout) call flush_unit(stdout) do iv=ivv,min(ivv+nbuf-1,num_nbndv(ispin)) if(l_verbose) write(stdout,*) 'solve eig', iv call flush_unit(stdout) if(iv-ivv==mpime) then if(.not.l_dsyevr) then allocate(eigen(numpw)) allocate(work(1)) call DSYEV( 'V', 'U', numpw, omat_hold, numpw, eigen, work, -1, info ) lwork=work(1) deallocate(work) allocate(work(lwork)) call DSYEV( 'V', 'U', numpw, omat_hold, numpw, eigen, work, lwork, info ) deallocate(work) if(info/=0) then write(stdout,*) 'ROUTINE pola_basis_lanczos, INFO:', info stop endif ! do iw=1,numpw ! write(stdout,*) 'EIGEN:',iv,iw, eigen(iw) ! enddo ! call flush_unit(stdout) else if(l_verbose) write(stdout,*) 'ATT1' call flush_unit(stdout) allocate(eigen(numpw)) allocate(vectors(numpw,nstates)) allocate(isuppz(2*nstates)) allocate(work(1),iwork(1)) if(l_verbose) write(stdout,*) 'ATT2' call flush_unit(stdout) call DSYEVR('V','I','U',numpw,omat_hold,numpw,0.d0,0.d0,numpw-nstates+1,numpw,0.d0,n_found,eigen,& & vectors,numpw,isuppz,work, -1,iwork,-1, info) lwork=work(1) liwork=iwork(1) deallocate(work,iwork) allocate(work(lwork)) allocate(iwork(liwork)) if(l_verbose) write(stdout,*) 'ATT3',numpw,nstates,size(omat_hold(:,1)),size(omat_hold(1,:)),lwork,liwork call flush_unit(stdout) vl=0.d0 vu=0.d0 il=numpw-nstates+1 iu=numpw call DSYEVR('V','I','U',numpw,omat_hold,numpw,vl,vu,il,iu,0.d0,n_found,eigen,& & vectors,numpw,isuppz,work,lwork,iwork,liwork, info) if(info/=0) then write(stdout,*) 'ROUTINE pola_lanczos DSYEVR, INFO:', info stop endif if(l_verbose) write(stdout,*) 'ATT4' call flush_unit(stdout) deallocate(isuppz) deallocate(work,iwork) do iw=1,nstates,nstates-1 write(stdout,*) 'EIGEN T LOCAL:',iv,iw, eigen(iw) enddo call flush_unit(stdout) endif !!find transformation matrix and write on disk ! if(l_verbose) write(stdout,*) 'pola_basis_lanczos t_mat' call flush_unit(stdout) if(.not.l_dsyevr) then do ii=1,nstates do jj=1,numpw t_mat_hold(jj,ii)=omat_hold(jj,numpw-ii+1)*(dsqrt(eigen(numpw-ii+1))) enddo t_eigen_hold(ii)=eigen(numpw-ii+1) enddo else do ii=1,nstates do jj=1,numpw t_mat_hold(jj,ii)=vectors(jj,ii)*(dsqrt(eigen(ii))) enddo t_eigen_hold(ii)=eigen(ii) enddo endif !!find liner dependent products if(.not.l_dsyevr) then do ii=1,nstates t_mat_hold2(:,ii)=omat_hold(:,numpw-ii+1)*(1.d0/dsqrt(eigen(numpw-ii+1))) enddo else do ii=1,nstates t_mat_hold2(:,ii)=vectors(:,ii)*(1.d0/dsqrt(eigen(ii))) enddo endif deallocate(eigen) if(l_dsyevr) deallocate(vectors) endif enddo allocate(eigen(nstates)) do iv=ivv,min(ivv+nbuf-1,num_nbndv(ispin)) if(iv-ivv == mpime) then t_mat(:,:)=t_mat_hold(:,:) eigen(1:nstates)=t_eigen_hold(1:nstates) endif call mp_bcast(t_mat,iv-ivv,world_comm) call mp_bcast(eigen(1:nstates),iv-ivv,world_comm) !if required imposes sum rule ! if(l_sumrule) then ! norm_t=0.d0 ! do jj=1,numpw ! do ii=1,nstates ! norm_t=norm_t+t_mat(jj,ii)**2.d0 ! enddo ! enddo ! norm=0.d0 ! do jj=1,numpw ! norm=norm+norms(jj) ! enddo ! c_norm=dsqrt(norm/norm_t) ! write(stdout,*) 'Sum rule:',c_norm ! t_mat(:,:)=t_mat(:,:)*c_norm ! endif if(ionode) then iuntmat = find_free_unit() write(nfile,'(4i1)') iv/1000,mod(iv,1000)/100,mod(iv,100)/10,mod(iv,10) if(ispin==1) then open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.p_mat_lanczos'//nfile, status='unknown',form='unformatted') else open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.p_mat_lanczos2'//nfile, status='unknown',form='unformatted') endif write(iuntmat) iv write(iuntmat) num_nbndv(ispin) write(iuntmat) numpw write(iuntmat) nstates do ii=1,nstates write(iuntmat) t_mat(1:numpw,ii) enddo close(iuntmat) endif !write on disk file with eigen values if(ionode) then iuntmat = find_free_unit() write(nfile,'(4i1)') iv/1000,mod(iv,1000)/100,mod(iv,100)/10,mod(iv,10) if(ispin==1) then open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.p_eig_lanczos'//nfile, status='unknown',form='unformatted') else open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.p_eig_lanczos2'//nfile, status='unknown',form='unformatted') endif write(iuntmat) nstates write(iuntmat) eigen(1:nstates) close(iuntmat) endif if(l_verbose) write(stdout,*) 'pola_basis update wp_g' call flush_unit(stdout) !!find liner dependent products if(iv-ivv == mpime) then t_mat(:,:)=t_mat_hold2(:,:) endif call mp_bcast(t_mat,iv-ivv,world_comm) if(l_verbose) write(stdout,*) 'pola_basis update wp_g dgemm' call flush_unit(stdout) call dgemm('N','N',2*fc%npwt,nstates,numpw,1.d0,wp_prod(1,1,iv-ivv+1),2*fc%npwt,t_mat,numpw,0.d0,wp_g_t,2*fc%npwt) write(stdout,*) 'pola_basis update merge-split',iv,ivv call flush_unit(stdout) !put the correct order if(fc%dual_t==4.d0) then wp_g(:,:)=wp_g_t(:,:) else call reorderwfp_col(nstates,fc%npwt,npw,wp_g_t(1,1),wp_g(1,1),fc%npwt,npw, & & fc%ig_l2gt,ig_l2g,fc%ngmt_g,mpime, nproc,intra_pool_comm ) !do ii=1,nstates ! call mergewf(wp_g_t(:,ii),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) ! call splitwf(wp_g(:,ii),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) !enddo endif if(l_verbose) write(stdout,*) 'pola_basis update davcio',iv call flush_unit(stdout) !!write on disk do ii=1,nstates call davcio(wp_g(:,ii),npw*2,iungresult,ii+(iv-1)*nstates,1) enddo if(l_verbose) write(stdout,*) 'pola_basis update done' call flush_unit(stdout) enddo deallocate(eigen) enddo deallocate(t_mat,t_mat_hold,t_mat_hold2) deallocate(omat,omat_hold,tmp_r,tmp_r2,p_basis_r) deallocate(wp_g,wp_g_t) close(iungresult) deallocate(norms) deallocate(wv_real,wp_prod) deallocate(t_eigen_hold) if(l_verbose) write(stdout,*) 'Exiting pola_basis_lanczos' call flush_unit(stdout) if(l_reduce_io) deallocate(p_basis) deallocate(p_basis_t,evc_t) if(l_verbose) write(stdout,*) 'Call deallocate_fft_custom' call flush_unit(stdout) deallocate(evc_g) call deallocate_fft_custom(fc) return end subroutine pola_basis_lanczos subroutine pc_operator(state,ispin,l_cond) !this operator project the wavefunction state on the conduction !subspace, the valence wavefunction are in evc !ONLY FOR GAMMA POINT NOW!!!! USE io_global, ONLY : stdout USE kinds, ONLY : DP USE gvect USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx USE wavefunctions_module, ONLY : evc, psic USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : world_comm USE wannier_gw, ONLY : num_nbndv,num_nbnds implicit none COMPLEX(kind=DP), INTENT(inout) :: state(npw)!state to be projected INTEGER, INTENT(in) :: ispin!spin channel LOGICAL :: l_cond!if true project out alson conduction states till num_nbnds INTEGER :: iv,ig REAL(kind=DP), ALLOCATABLE :: prod(:) if(.not.l_cond) then if(num_nbndv(ispin)==0) return allocate(prod(num_nbndv(ispin))) call dgemm('T','N', num_nbndv(ispin),1,2*npw,2.d0,evc,2*npwx,state,2*npw,& & 0.d0,prod,num_nbndv(ispin)) do iv=1,num_nbndv(ispin) if(gstart==2) prod(iv)=prod(iv)-dble(conjg(evc(1,iv))*state(1)) enddo call mp_sum(prod(:), world_comm) call dgemm('N','N',2*npw,1,num_nbndv(ispin),-1.d0,evc,2*npwx,prod,& &num_nbndv(ispin),1.d0,state,2*npw) else allocate(prod(num_nbnds)) call dgemm('T','N', num_nbnds,1,2*npw,2.d0,evc,2*npwx,state,2*npw,& & 0.d0,prod,num_nbnds) do iv=1,num_nbnds if(gstart==2) prod(iv)=prod(iv)-dble(conjg(evc(1,iv))*state(1)) enddo call mp_sum(prod(:), world_comm) call dgemm('N','N',2*npw,1,num_nbnds,-1.d0,evc,2*npwx,prod,& &num_nbnds,1.d0,state,2*npw) endif deallocate(prod) return end subroutine pc_operator subroutine pc_operator_t(state,evc_t,ispin, fc) !this operator project the wavefunction state on the conduction !subspace, the valence wavefunction are in evc !ONLY FOR GAMMA POINT NOW!!!! USE io_global, ONLY : stdout USE kinds, ONLY : DP USE gvect USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx USE wavefunctions_module, ONLY : evc, psic USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : world_comm USE wannier_gw, ONLY : num_nbndv USE fft_custom_gwl USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft implicit none TYPE(fft_cus), INTENT(in) :: fc COMPLEX(kind=DP), INTENT(inout) :: state(fc%npwt)!state to be projected ! COMPLEX(kind=DP), INTENT(inout) :: evc_t(fc%npwt,num_nbndv(ispin)) ! above syntax not accepted by all compilers COMPLEX(kind=DP), INTENT(inout) :: evc_t(fc%npwt,*)!valence states INTEGER, INTENT(in) :: ispin!spin channel INTEGER :: iv,ig REAL(kind=DP), ALLOCATABLE :: prod(:) allocate(prod(num_nbndv(ispin))) call dgemm('T','N', num_nbndv(ispin),1,2*fc%npwt,2.d0,evc_t,2*fc%npwt,state,2*fc%npwt,& & 0.d0,prod,num_nbndv(ispin)) do iv=1,num_nbndv(ispin) if(fc%gstart_t==2) prod(iv)=prod(iv)-dble(conjg(evc_t(1,iv))*state(1)) enddo call mp_sum(prod(:), world_comm) call dgemm('N','N',2*fc%npwt,1,num_nbndv(ispin),-1.d0,evc_t,2*fc%npwt,prod,& &num_nbndv(ispin),1.d0,state,2*fc%npwt) deallocate(prod) return end subroutine pc_operator_t subroutine lanczos_state(zstates, nstates, itype, nsteps,istate,ispin) !this subroutine perform nsteps collective lanczos iterations !on orthonormal zstates state !GAMMA POINT ONLY!!! USE io_global, ONLY : stdout, ionode, ionode_id USE io_files, ONLY : prefix, tmp_dir USE kinds, ONLY : DP USE wannier_gw USE gvect USE constants, ONLY : e2, pi, tpi, fpi USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2 USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, ecutwfc USE wavefunctions_module, ONLY : evc, psic USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : mpime, nproc, world_comm USE gvecs, ONLY : nls, nlsm, doublegrid USE g_psi_mod, ONLY : h_diag, s_diag USE becmod, ONLY : becp,allocate_bec_type,deallocate_bec_type USE uspp, ONLY : vkb, nkb, okvan USE klist, ONLY : xk USE noncollin_module, ONLY : noncolin, npol USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft implicit none INTEGER, EXTERNAL :: find_free_unit COMPLEX(kind=DP), INTENT(in) :: zstates(npw,nstates)!states for starting lanczos chains INTEGER, INTENT(in) :: nstates!number of states INTEGER, INTENT(in) :: itype!matrices to be saved: 0 for polarization; 1 for self-energy; 2 for other uses INTEGER, INTENT(in) :: nsteps!number of Lanczos iteration to be performed INTEGER, INTENT(in) :: istate!corresponding KS state(for labelling output files) INTEGER, INTENT(in) :: ispin!spin channel 1,2 COMPLEX(kind=DP), ALLOCATABLE :: psi_1(:,:),psi_2(:,:),psi_3(:,:) COMPLEX(kind=DP), ALLOCATABLE :: u_0(:,:),u_1(:,:) REAL(kind=DP), ALLOCATABLE :: alpha(:),beta(:),gamma(:), n_1(:) REAL(kind=DP), ALLOCATABLE :: d(:,:),f(:,:),c(:) REAL(kind=DP), ALLOCATABLE :: omat(:,:)!overlap with intermediate lanczos states to be saved on disk for each iteration! CHARACTER(4) :: nfile INTEGER :: is,ig,ii,jj,it INTEGER :: iunlan LOGICAL :: omat_div = .false. INTEGER :: l_blk,nbegin,nend,nsize INTEGER :: ip,nbegin_ip, nend_ip, nsize_ip REAL(kind=DP), ALLOCATABLE :: omat_tot(:,:,:) INTEGER :: iv ! allocate(alpha(nstates),beta(nstates),gamma(nstates),n_1(nstates)) ! allocate(d(nsteps,nstates),f(nsteps,nstates),c(nstates)) !if omat_div is true distribute memory on MPI tasks, but it is slower if(nstates < 1600) then omat_div=.false. else omat_div=.true. endif call start_clock('lanczos_state') !to decide whether to calculate the overlap matrix column by column or distributed on processors if(omat_div) then l_blk= (nstates)/nproc if(l_blk*nproc < (nstates)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 if(nend > nstates) nend=nstates nsize=nend-nbegin+1 allocate(omat(nstates,l_blk)) allocate(omat_tot(nstates,l_blk,nsteps)) else l_blk=nstates allocate(omat(nstates,nstates)) endif allocate(psi_1(npw,l_blk),psi_2(npw,l_blk),psi_3(npw,l_blk)) allocate(u_0(npw,l_blk),u_1(npw,l_blk)) allocate(alpha(l_blk),beta(l_blk),gamma(l_blk),n_1(l_blk)) allocate(d(nsteps,nstates),f(nsteps,nstates),c(l_blk)) d(:,:)=0.d0 f(:,:)=0.d0 !loop on l_blk ALLOCATE( h_diag( npwx,npol ) ) ALLOCATE( s_diag( npwx,npol ) ) call allocate_bec_type ( nkb, l_blk, becp) IF ( nkb > 0 ) CALL init_us_2( npw, igk, xk(1,1), vkb ) g2kin(1:npw) = ( (g(1,igk(1:npw)) )**2 + & ( g(2,igk(1:npw)) )**2 + & ( g(3,igk(1:npw)) )**2 ) * tpiba2 ip=0 do iv=1,nstates,l_blk nbegin_ip=iv nend_ip=min(nbegin_ip+l_blk-1,nstates) nsize_ip=nend_ip-nbegin_ip+1 !first step psi_1(1:npw,1:nsize_ip)=zstates(1:npw,nbegin_ip:nend_ip) !for h_psi allocations are required write(stdout,*) 'lanczos_state:', istate,ispin call flush_unit(stdout) !calculate H|\phi_i> call h_psi( npw, npw, nsize_ip,psi_1(1,1), u_0 ) if(l_selfconsistent) call h_psi_self( npw, npw, nsize_ip,psi_1(1,1), u_0 ) if(l_scissor) call h_psi_scissor(ispin, npw, npw, nsize_ip,psi_1(1,1), u_0 ) !calculate n_1 n_1(1:nsize_ip)=0.d0 do is=1,nsize_ip do ig=1,npw n_1(is)=n_1(is)+2.d0*dble(conjg(u_0(ig,is))*u_0(ig,is)) enddo if(gstart==2) n_1(is)=n_1(is)-dble(conjg(u_0(1,is))*u_0(1,is)) enddo call mp_sum(n_1(1:nsize_ip), world_comm) n_1(1:nsize_ip)=dsqrt(n_1(1:nsize_ip)) !calculate alpha alpha(1:nsize_ip)=0.d0 do is=1,nsize_ip do ig=1,npw alpha(is)=alpha(is)+2.d0*dble(conjg(psi_1(ig,is))*u_0(ig,is)) enddo if(gstart==2) alpha(is)=alpha(is)-dble(conjg(psi_1(1,is))*u_0(1,is)) enddo call mp_sum(alpha(1:nsize_ip), world_comm) alpha(1:nsize_ip)=alpha(1:nsize_ip)/n_1(1:nsize_ip) !calculate psi_2 and beta do is=1,nsize_ip psi_2(:,is)=u_0(:,is)/n_1(is)-alpha(is)*psi_1(:,is) enddo beta(1:nsize_ip)=0.d0 do is=1,nsize_ip do ig=1,npw beta(is)=beta(is)+2.d0*dble(conjg(psi_2(ig,is))*psi_2(ig,is)) enddo if(gstart==2) beta(is)=beta(is)-dble(conjg(psi_2(1,is))*psi_2(1,is)) enddo call mp_sum(beta(1:nsize_ip), world_comm) beta(1:nsize_ip)=dsqrt(beta(1:nsize_ip)) do is=1,nsize_ip psi_2(:,is)=psi_2(:,is)/beta(is) enddo !calculate d do is=1,nsize_ip do ig=1,npw d(1,is+nbegin_ip-1)=d(1,is+nbegin_ip-1)+2.d0*dble(conjg(psi_1(ig,is))*u_0(ig,is)) enddo if(gstart==2) d(1,is+nbegin_ip-1)=d(1,is+nbegin_ip-1)-dble(conjg(psi_1(1,is))*u_0(1,is)) enddo call mp_sum(d(1,nbegin_ip:nend_ip), world_comm) if(l_verbose) write(stdout,*) 'Lanczos Diagonal 1', d(1,nbegin_ip:nend_ip) call flush_unit(stdout) !calculate f do is=1,nsize_ip do ig=1,npw f(1,is+nbegin_ip-1)=f(1,is+nbegin_ip-1)+2.d0*dble(conjg(psi_2(ig,is))*u_0(ig,is)) enddo if(gstart==2) f(1,is+nbegin_ip-1)=f(1,is+nbegin_ip-1)-dble(conjg(psi_2(1,is))*u_0(1,is)) enddo call mp_sum(f(1,nbegin_ip:nend_ip), world_comm) if(l_verbose) write(stdout,*) 'ATTENZIONE1' call flush_unit(stdout) !calculate overlaps and write on output file if(omat_div) then call dgemm('T','N',nstates,nsize_ip,2*npw,2.d0,zstates,2*npw,psi_1(1,1),2*npw,0.d0,omat,nstates) if(gstart==2) then do ii=1,nsize_ip do jj=1,nstates omat(jj,ii)=omat(jj,ii)-dble(conjg(zstates(1,jj))*psi_1(1,ii)) enddo enddo endif do ii=1,nsize_ip call mp_sum(omat(:,ii), world_comm) enddo if(ip==mpime) omat_tot(1:nstates,1:nsize_ip,1)=omat(1:nstates,1:nsize_ip) else omat(:,:)=0.d0 call dgemm('T','N',nstates,nstates,2*npw,2.d0,zstates,2*npw,psi_1,2*npw,0.d0,omat,nstates) if(gstart==2) then do ii=1,nstates do jj=1,nstates omat(jj,ii)=omat(jj,ii)-dble(conjg(zstates(1,jj))*psi_1(1,ii)) enddo enddo endif if(l_verbose) write(stdout,*) 'ATTENZIONE2' call flush_unit(stdout) do ii=1,nstates call mp_sum(omat(:,ii), world_comm) enddo if(ionode) then iunlan=find_free_unit() write(nfile,'(4i1)') istate/1000,mod(istate,1000)/100,mod(istate,100)/10,mod(istate,10) if(ispin==1) then if(itype==0) then open( unit= iunlan, file=trim(tmp_dir)//trim(prefix)//'.p_iter_lanczos',& &status='unknown',form='unformatted') else if(itype==1) then open( unit= iunlan, file=trim(tmp_dir)//trim(prefix)//'.s_iter_lanczos'//'_'//nfile,& &status='unknown',form='unformatted') else open( unit= iunlan, file=trim(tmp_dir)//trim(prefix)//'.o_iter_lanczos',& &status='unknown',form='unformatted') endif else if(itype==0) then open( unit= iunlan, file=trim(tmp_dir)//trim(prefix)//'.p_iter_lanczos2', & &status='unknown',form='unformatted') else if(itype==1) then open( unit= iunlan, file=trim(tmp_dir)//trim(prefix)//'.s_iter_lanczos2'//'_'//nfile, & &status='unknown',form='unformatted') else open( unit= iunlan, file=trim(tmp_dir)//trim(prefix)//'.o_iter_lanczos2', & &status='unknown',form='unformatted') endif endif write(iunlan) nstates write(iunlan) istate write(iunlan) nsteps do is=1,nstates write(iunlan) omat(1:nstates,is) enddo endif endif if(l_verbose) write(stdout,*) 'ATTENZIONE3' call flush_unit(stdout) !calculate second overlap if(omat_div) then call dgemm('T','N',nstates,nsize_ip,2*npw,2.d0,zstates,2*npw,psi_2(1,1),2*npw,0.d0,omat,nstates) if(gstart==2) then do ii=1,nsize_ip do jj=1,nstates omat(jj,ii)=omat(jj,ii)-dble(conjg(zstates(1,jj))*psi_2(1,ii)) enddo enddo endif do ii=1,nsize_ip call mp_sum(omat(:,ii), world_comm) enddo if(ip==mpime) omat_tot(1:nstates,1:nsize_ip,2)=omat(1:nstates,1:nsize_ip) else omat(:,:)=0.d0 call dgemm('T','N',nstates,nstates,2*npw,2.d0,zstates,2*npw,psi_2,2*npw,0.d0,omat,nstates) if(gstart==2) then do ii=1,nstates do jj=1,nstates omat(jj,ii)=omat(jj,ii)-dble(conjg(zstates(1,jj))*psi_2(1,ii)) enddo enddo endif if(l_verbose) write(stdout,*) 'ATTENZIONE4' call flush_unit(stdout) do ii=1,nstates call mp_sum(omat(:,ii), world_comm) enddo if(ionode) then do is=1,nstates write(iunlan) omat(1:nstates,is) enddo endif endif !do iterate do it=2,nsteps if(l_verbose) write(stdout,*) 'lanczos h_psi' call flush_unit(stdout) !calculate H|\phi_i+1> call h_psi( npw, npw, nsize_ip,psi_2(1,1), u_1 ) if(l_selfconsistent) call h_psi_self( npw, npw, nsize_ip,psi_2(1,1), u_1 ) if(l_scissor) call h_psi_scissor( ispin,npw, npw, nsize_ip,psi_2(1,1), u_1 ) if(l_verbose) write(stdout,*) 'lanczos alfa beta gamma' call flush_unit(stdout) !calculate n_1 n_1(1:nsize_ip)=0.d0 do is=1,nsize_ip do ig=1,npw n_1(is)=n_1(is)+2.d0*dble(conjg(u_1(ig,is))*u_1(ig,is)) enddo if(gstart==2) n_1(is)=n_1(is)-dble(conjg(u_1(1,is))*u_1(1,is)) enddo call mp_sum(n_1(1:nsize_ip), world_comm) n_1(1:nsize_ip)=dsqrt(n_1(1:nsize_ip)) !calculate alpha alpha(1:nsize_ip)=0.d0 do is=1,nsize_ip do ig=1,npw alpha(is)=alpha(is)+2.d0*dble(conjg(psi_1(ig,is))*u_1(ig,is)) enddo if(gstart==2) alpha(is)=alpha(is)-dble(conjg(psi_1(1,is))*u_1(1,is)) enddo call mp_sum(alpha(1:nsize_ip), world_comm) alpha(1:nsize_ip)=alpha(1:nsize_ip)/n_1(1:nsize_ip) !calculate beta beta(1:nsize_ip)=0.d0 do is=1,nsize_ip do ig=1,npw beta(is)=beta(is)+2.d0*dble(conjg(psi_2(ig,is))*u_1(ig,is)) enddo if(gstart==2) beta(is)=beta(is)-dble(conjg(psi_2(1,is))*u_1(1,is)) enddo call mp_sum(beta(1:nsize_ip), world_comm) beta(1:nsize_ip)=beta(1:nsize_ip)/n_1(1:nsize_ip) !calculate psi_3 and gamma do is=1,nsize_ip psi_3(:,is)=u_1(:,is)/n_1(is)-alpha(is)*psi_1(:,is)-beta(is)*psi_2(:,is) enddo gamma(1:nsize_ip)=0.d0 do is=1,nsize_ip do ig=1,npw gamma(is)=gamma(is)+2.d0*dble(conjg(psi_3(ig,is))*psi_3(ig,is)) enddo if(gstart==2) gamma(is)=gamma(is)-dble(conjg(psi_3(1,is))*psi_3(1,is)) enddo call mp_sum(gamma(1:nsize_ip), world_comm) gamma(1:nsize_ip)=dsqrt(gamma(1:nsize_ip)) do is=1,nsize_ip psi_3(:,is)=psi_3(:,is)/gamma(is) enddo if(l_verbose) write(stdout,*) 'lanczos d f omat' call flush_unit(stdout) !calculate d do is=1,nsize_ip do ig=1,npw d(it,is+nbegin_ip-1)=d(it,is+nbegin_ip-1)+2.d0*dble(conjg(psi_2(ig,is))*u_1(ig,is)) enddo if(gstart==2) d(it,is+nbegin_ip-1)=d(it,is+nbegin_ip-1)-dble(conjg(psi_2(1,is))*u_1(1,is)) enddo call mp_sum(d(it,nbegin_ip:nend_ip), world_comm) !calculate f do is=1,nsize_ip do ig=1,npw f(it,is+nbegin_ip-1)=f(it,is+nbegin_ip-1)+2.d0*dble(conjg(psi_3(ig,is))*u_1(ig,is)) enddo if(gstart==2) f(it,is+nbegin_ip-1)=f(it,is+nbegin_ip-1)-dble(conjg(psi_3(1,is))*u_1(1,is)) enddo call mp_sum(f(it,nbegin_ip:nend_ip), world_comm) !calculate overlap if(it /=nsteps) then if(omat_div) then call dgemm('T','N',nstates,nsize_ip,2*npw,2.d0,zstates,2*npw,psi_3(1,1),2*npw,0.d0,omat,nstates) if(gstart==2) then do ii=1,nsize_ip do jj=1,nstates omat(jj,ii)=omat(jj,ii)-dble(conjg(zstates(1,jj))*psi_3(1,ii)) enddo enddo endif do ii=1,nsize_ip call mp_sum(omat(:,ii), world_comm) enddo if(ip==mpime) omat_tot(1:nstates,1:nsize_ip,it+1)=omat(1:nstates,1:nsize_ip) else omat(:,:)=0.d0 call dgemm('T','N',nstates,nstates,2*npw,2.d0,zstates,2*npw,psi_3,2*npw,0.d0,omat,nstates) if(gstart==2) then do ii=1,nstates do jj=1,nstates omat(jj,ii)=omat(jj,ii)-dble(conjg(zstates(1,jj))*psi_3(1,ii)) enddo enddo endif do ii=1,nstates call mp_sum(omat(:,ii), world_comm) enddo if(ionode) then do is=1,nstates write(iunlan) omat(1:nstates,is) enddo endif endif endif !update arrays psi_1(1:npw,1:nsize_ip)=psi_2(1:npw,1:nsize_ip) psi_2(1:npw,1:nsize_ip)=psi_3(1:npw,1:nsize_ip) u_0(1:npw,1:nsize_ip)=u_1(1:npw,1:nsize_ip) enddo ip=ip+1 enddo !if omat is distribute here writes onfile if(omat_div) then if(ionode) then iunlan=find_free_unit() write(nfile,'(4i1)') istate/1000,mod(istate,1000)/100,mod(istate,100)/10,mod(istate,10) if(ispin==1) then if(itype==0) then open( unit= iunlan, file=trim(tmp_dir)//trim(prefix)//'.p_iter_lanczos', & &status='unknown',form='unformatted') else open( unit= iunlan, file=trim(tmp_dir)//trim(prefix)//'.s_iter_lanczos'//'_'//nfile, & &status='unknown',form='unformatted') endif else if(itype==0) then open( unit= iunlan, file=trim(tmp_dir)//trim(prefix)//'.p_iter_lanczos2', & &status='unknown',form='unformatted') else open( unit= iunlan, file=trim(tmp_dir)//trim(prefix)//'.s_iter_lanczos2'//'_'//nfile, & &status='unknown',form='unformatted') endif endif write(iunlan) nstates write(iunlan) istate write(iunlan) nsteps endif do it=1,nsteps do ip=0,nproc-1 nbegin_ip=ip*l_blk+1 nend_ip=min(nbegin_ip+l_blk-1,nstates) nsize_ip=nend_ip-nbegin_ip+1 if(nsize_ip >=1) then if(mpime==ip) omat(1:nstates,1:nsize_ip)=omat_tot(1:nstates,1:nsize_ip,it) do is=1,nsize_ip call mp_bcast(omat(1:nstates,is),ip,world_comm) if(ionode) write(iunlan) omat(1:nstates,is) enddo endif enddo enddo endif !write tridiagonal matrix on disk if(ionode) then do is=1,nstates write(iunlan) d(1:nsteps,is) enddo do is=1,nstates write(iunlan) f(1:nsteps,is) enddo endif if(ionode) close(iunlan) deallocate(psi_1,psi_2,psi_3) deallocate(u_0,u_1) deallocate(alpha,beta,gamma,n_1) deallocate(f,d,omat,c) deallocate(h_diag,s_diag) call deallocate_bec_type(becp) call stop_clock('lanczos_state') return end subroutine lanczos_state subroutine orthonormalize_two_manifolds( state1, n1,state2, n2, threshold, state_out, n_out) !this subroutine form am orthormal basis set from 2 manifold (with orthonormal basis sets) !ONLY FOR NORM_CONSERVING CASE USE io_global, ONLY : stdout, ionode, ionode_id USE kinds, ONLY : DP USE gvect USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : world_comm USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft USE wannier_gw, ONLY : l_verbose implicit none COMPLEX(kind=DP), INTENT(in) :: state1(npw,n1)!1st orthonormal basis INTEGER, INTENT(in) :: n1!number of 1st basis elements COMPLEX(kind=DP), INTENT(in) :: state2(npw,n2)!2nd orthonormal basis INTEGER, INTENT(in) :: n2!number of 2nd basis elements REAL(kind=DP), INTENT(in) :: threshold!threshold for orthonormality COMPLEX(kind=DP), INTENT(out) :: state_out(npw,n1+n2)!output basis set INTEGER, INTENT(out) :: n_out!number of output states INTEGER :: ii,jj REAL(kind=DP), ALLOCATABLE :: omat(:,:),tmp_mat(:,:) REAL(kind=DP), ALLOCATABLE :: eigen(:),work(:) INTEGER :: lwork,info,liwork REAL(kind=DP), ALLOCATABLE :: omat1(:,:),omat2(:,:) !buid overlap matrix if(l_verbose) write(stdout,*) 'orthonormalize dgemm' call flush_unit(stdout) allocate(omat(n1+n2,n1+n2)) omat(:,:)=0.d0 do ii=1,n1+n2 omat(ii,ii)=1.d0 enddo allocate(tmp_mat(n1,n2)) call dgemm('T','N',n1,n2,2*npw,2.d0,state1,2*npw,state2,2*npw,0.d0,tmp_mat,n1) if(gstart==2) then do ii=1,n2 do jj=1,n1 tmp_mat(jj,ii)=tmp_mat(jj,ii)-dble(conjg(state1(1,jj))*state2(1,ii)) enddo enddo endif if(l_verbose) write(stdout,*) 'orthonormalize mp_sum' call flush_unit(stdout) do ii=1,n2 call mp_sum(tmp_mat(:,ii), world_comm) enddo if(l_verbose) write(stdout,*) 'orthonormalize copy array' call flush_unit(stdout) omat(1:n1,n1+1:n1+n2)=tmp_mat(1:n1,1:n2) deallocate(tmp_mat) !diagonalize allocate(eigen(n1+n2)) if(l_verbose) write(stdout,*) 'orthonormalize dsyev' call flush_unit(stdout) if(ionode) then allocate(work(1)) call DSYEV( 'V', 'U', n1+n2, omat, n1+n2, eigen, work, -1, info ) lwork=work(1) deallocate(work) allocate(work(lwork)) call DSYEV( 'V', 'U', n1+n2, omat, n1+n2, eigen, work, lwork, info ) deallocate(work) if(info/=0) then write(stdout,*) 'ROUTINE orthonormalize_two_manifolds, INFO:', info stop endif else eigen(:)=0.d0 omat(:,:)=0.d0 endif if(l_verbose) write(stdout,*) 'orthonormalize mp_bcast now mp_sum' call flush_unit(stdout) do ii=1,n1+n2 !call mp_bcast(omat(:,ii), ionode_id,world_comm) call mp_sum(omat(:,ii), world_comm) enddo !call mp_bcast(eigen(:), ionode_id,world_comm) call mp_sum(eigen(:), world_comm) do ii=1,n1+n2 if(l_verbose) write(stdout,*) 'EIGEN:',ii, eigen(ii) enddo call flush_unit(stdout) if(l_verbose) write(stdout,*) 'orthonormalize copy' call flush_unit(stdout) !construct orthonormal basis set ! state_out(:,:)=(0.d0,0.d0) n_out=0 do ii=1,n1+n2 if(eigen(ii) >= threshold) then n_out=n_out+1 endif enddo allocate(omat1(n1,n_out),omat2(n2, n_out)) do ii=1,n_out omat1(1:n1,ii)=omat(1:n1,n1+n2-n_out+ii)/dsqrt(eigen(n1+n2-n_out+ii)) enddo do ii=1,n_out omat2(1:n2,ii)=omat(n1+1:n1+n2,n1+n2-n_out+ii)/dsqrt(eigen(n1+n2-n_out+ii)) enddo call dgemm('N','N',2*npw,n_out,n1,1.d0,state1,2*npw,omat1,n1,0.d0,state_out,2*npw) call dgemm('N','N',2*npw,n_out,n2,1.d0,state2,2*npw,omat2,n2,1.d0,state_out,2*npw) deallocate(omat1,omat2) ! n_out=0 ! do ii=1,n1+n2 ! if(eigen(ii) >= threshold) then ! n_out=n_out+1 ! do jj=1,n1 ! state_out(:,n_out)=state_out(:,n_out)+omat(jj,ii)*state1(:,jj)/dsqrt(eigen(ii)) ! enddo ! do jj=1,n2 ! state_out(:,n_out)=state_out(:,n_out)+omat(jj+n1,ii)*state2(:,jj)/dsqrt(eigen(ii)) ! enddo ! endif ! enddo write(stdout,*) 'orthonormalize_two_manifolds: basis dimension:', n_out call flush_unit(stdout) deallocate (omat) return end subroutine orthonormalize_two_manifolds subroutine global_pola_lanczos(nstates,nstates_eff,threshold,nglobal,nsteps,numpw,ispin,l_eigen) !this subroutine from the orthonormal basis at each v !construct a global basis for the lanczos calculation of the !polarization USE io_global, ONLY : stdout, ionode, ionode_id USE io_files, ONLY : prefix, tmp_dir, diropn USE kinds, ONLY : DP USE wannier_gw, ONLY : num_nbndv,max_ngm,l_pmatrix USE gvect USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, ecutwfc USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : world_comm USE wavefunctions_module, ONLY : evc, psic USE gvect USE gvecs, ONLY : nls, nlsm, doublegrid USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft USE wannier_gw, ONLY : l_verbose implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER, INTENT(in) :: nstates!number of orthonormal states for each v INTEGER, INTENT(in) :: nstates_eff!effective number of orthonormal states for each v REAL(kind=DP),INTENT(in) :: threshold!threshold for orthonormalization algorithm INTEGER, INTENT(out) :: nglobal!total number of final orthonormal states INTEGER, INTENT(in) :: nsteps!number of lanczos steps INTEGER, INTENT(in) :: numpw!number of wannier products for testing INTEGER, INTENT(in) :: ispin!spin channel 1,2 LOGICAL, INTENT(in) :: l_eigen!if true partial t states are scaled with the corresponding eigenvalue INTEGER :: iunv,iuntmat LOGICAL :: exst INTEGER :: ii,jj,iv,ic COMPLEX(kind=DP), ALLOCATABLE :: old_basis(:,:), new_basis(:,:),v_basis(:,:) INTEGER :: nglobal_old REAL(kind=DP), ALLOCATABLE :: t_mat(:,:) CHARACTER(4) :: nfile !for test: REAL(kind=DP) :: sca,sca1 INTEGER :: iungprod,ig,iw REAL(kind=DP), ALLOCATABLE :: wv_real(:),tmp_r(:) COMPLEX(kind=DP), ALLOCATABLE :: tmp_g(:),wp_prod(:) LOGICAL :: l_test=.false. REAL(kind=DP)::proj_tot INTEGER :: nbuffer,ndelta!for avoiding nested allocation/deallocation cycles LOGICAL :: l_update_memory INTEGER, PARAMETER :: offset=0!ATTENZIONE THEN PUT 0!!!!!!! REAL(kind=DP), ALLOCATABLE :: eigen(:) INTEGER :: idumm if(num_nbndv(ispin) == 0) return nbuffer=6*numpw ndelta=numpw !set first basis from first valence state !if required read eigenvectors too allocate(eigen(nstates)) if(l_eigen) then if(ionode) then iv=1 iuntmat = find_free_unit() write(nfile,'(4i1)') iv/1000,mod(iv,1000)/100,mod(iv,100)/10,mod(iv,10) if(ispin==1) then open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.p_eig_lanczos'//nfile, & &status='old',form='unformatted') else open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.p_eig_lanczos2'//nfile, & &status='old',form='unformatted') endif read(iuntmat) idumm read(iuntmat) eigen(1:nstates) close(iuntmat) endif call mp_bcast(eigen, ionode_id,world_comm) endif allocate(old_basis(npw,nbuffer)) iunv = find_free_unit() CALL diropn( iunv, 'vw_lanczos',npw*2, exst) if(.not.l_eigen) then do ii=1,nstates_eff call davcio(old_basis(:,ii),npw*2,iunv,ii+offset,-1) enddo nglobal=nstates_eff else nglobal=1 call davcio(old_basis(:,nglobal),npw*2,iunv,1+offset,-1) do ii=2,nstates_eff if(eigen(ii) > threshold) then nglobal=nglobal+1 call davcio(old_basis(:,nglobal),npw*2,iunv,ii+offset,-1) endif enddo endif !loop on valence states (from 2nd) allocate(v_basis(npw,nstates_eff)) allocate(new_basis(npw,nbuffer)) do iv=2,num_nbndv(ispin) !!read from disk do ii=1,nstates_eff call davcio(v_basis(:,ii),npw*2,iunv,ii+offset+(iv-1)*(nstates+offset),-1) enddo if(l_eigen) then if(ionode) then iuntmat = find_free_unit() write(nfile,'(4i1)') iv/1000,mod(iv,1000)/100,mod(iv,100)/10,mod(iv,10) if(ispin==1) then open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.p_eig_lanczos'//nfile, & &status='old',form='unformatted') else open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.p_eig_lanczos2'//nfile, & &status='old',form='unformatted') endif read(iuntmat) idumm read(iuntmat) eigen(1:nstates) close(iuntmat) endif call mp_bcast(eigen, ionode_id,world_comm) endif if(nglobal+nstates_eff >nbuffer) then deallocate(new_basis) allocate(new_basis(npw,nbuffer+ndelta)) l_update_memory=.true. else l_update_memory=.false. endif !!calculate basis nglobal_old=nglobal if(l_verbose) write(stdout,*) 'Call orthonormalize_two_manifolds' call flush_unit(stdout) if(.not.l_pmatrix) then !call orthonormalize_two_manifolds( old_basis, nglobal_old,v_basis, nstates, threshold, new_basis, nglobal) call orthonormalize_two_manifolds_prj( old_basis, nglobal_old,v_basis, nstates_eff, threshold, new_basis, nglobal,& l_eigen,eigen) else call orthonormalize_two_manifolds_scalapack(old_basis, nglobal_old,v_basis, nstates_eff, threshold, new_basis, nglobal) endif if(l_verbose) write(stdout,*) 'Done orthonormalize_two_manifolds',ispin call flush_unit(stdout) !!set arrays for next iteration if(l_update_memory) then deallocate(old_basis) allocate(old_basis(npw,nbuffer+ndelta)) nbuffer=nbuffer+ndelta endif old_basis(:,1:nglobal)=new_basis(:,1:nglobal) !deallocate(new_basis) enddo deallocate(new_basis) write(stdout,*) 'TOTAL NUMBER OF GLOBAL T VECTORS: ', nglobal !call lanczos chain routine call lanczos_state(old_basis, nglobal, 0, nsteps,1,ispin) !calculate matrix element and write on disk allocate(t_mat(nglobal,nstates_eff)) do iv=1,num_nbndv(ispin) write(nfile,'(4i1)') iv/1000,mod(iv,1000)/100,mod(iv,100)/10,mod(iv,10) if(ionode) then iuntmat=find_free_unit() if(ispin==1) then open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.pt_mat_lanczos'//nfile, & &status='unknown',form='unformatted') else open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.pt_mat_lanczos2'//nfile, & &status='unknown',form='unformatted') endif endif do ii=1,nstates_eff call davcio(v_basis(:,ii),npw*2,iunv,ii+offset+(iv-1)*(nstates+offset),-1) enddo call dgemm('T','N',nglobal,nstates_eff,2*npw,2.d0,old_basis,2*npw,v_basis,2*npw,0.d0,t_mat,nglobal) if(gstart==2) then do ii=1,nstates_eff do jj=1,nglobal t_mat(jj,ii)=t_mat(jj,ii)-dble(conjg(old_basis(1,jj))*v_basis(1,ii)) enddo enddo endif call mp_sum(t_mat(:,:), world_comm) if(ionode) then write(iuntmat) nglobal write(iuntmat) nstates_eff write(iuntmat) iv do ii=1,nstates_eff write(iuntmat) t_mat(1:nglobal,ii) enddo close(iuntmat) endif enddo close(iunv) !THE FOLLOWING PART IS FOR TESTING POURPOSES !test that the basis {t_i} is orthonormal deallocate(t_mat) if(l_test) then write(stdout,*) 'TEST1' call flush_unit(stdout) allocate(t_mat(nglobal,nglobal)) write(stdout,*) 'TEST2' call flush_unit(stdout) call dgemm('T','N',nglobal,nglobal,2*npw,2.d0,old_basis,2*npw,old_basis,2*npw,0.d0,t_mat,nglobal) if(gstart==2) then do ii=1,nglobal do jj=1,nglobal t_mat(jj,ii)=t_mat(jj,ii)-dble(conjg(old_basis(1,jj))*old_basis(1,ii)) enddo enddo endif write(stdout,*) 'TEST3' call flush_unit(stdout) call mp_sum(t_mat(:,:), world_comm) !!write diagonal terms do ii=1,nglobal sca=0.d0 do jj=1,nglobal if(ii/=jj) sca=sca+abs(t_mat(ii,jj)) enddo write(stdout,*) 'Diagonal',ii,t_mat(ii,ii),sca call flush_unit(stdout) enddo deallocate(t_mat) allocate(t_mat(nglobal,1)) !test for representability iungprod = find_free_unit() CALL diropn( iungprod, 'wiwjwfc_red', max_ngm*2, exst ) allocate(wv_real(dfftp%nnr),tmp_r(dfftp%nnr),tmp_g(ngm),wp_prod(npw)) proj_tot=0.d0 do iv=1,num_nbndv(ispin),num_nbndv(ispin)-1!ATTENZIONE !put iv on real space psic(:)=(0.d0,0.d0) psic(nls(igk(1:npw))) = evc(1:npw,iv) psic(nlsm(igk(1:npw))) = CONJG( evc(1:npw,iv) ) CALL invfft ('Wave', psic, dffts) wv_real(:)= DBLE(psic(:)) !loop on wannier_products do iw=1,numpw call davcio(tmp_g,max_ngm*2,iungprod,iw,-1) !trasform to r-space psic(:)=(0.d0,0.d0) do ig=1,max_ngm psic(nl(ig))=tmp_g(ig) psic(nlm(ig))=CONJG(tmp_g(ig)) enddo CALL invfft ('Dense', psic, dfftp) tmp_r(:)=dble(psic(:)) !!form products with w_v and trasfrom in G space psic(:)=cmplx(tmp_r(:)*wv_real(:),0.d0) CALL fwfft ('Wave', psic, dffts) wp_prod(1:npw) = psic(nls(igk(1:npw))) !!project on conduction subspace call pc_operator(wp_prod(:),ispin, .false.) !!do scalar product call dgemm('T','N',nglobal,1,2*npw,2.d0,old_basis,2*npw,wp_prod,2*npw,0.d0,t_mat,nglobal) if(gstart==2) then do jj=1,nglobal t_mat(jj,1)=t_mat(jj,1)-dble(conjg(old_basis(1,jj))*wp_prod(1)) enddo endif call mp_sum(t_mat(:,1), world_comm) sca=0.d0 do ii=1,nglobal sca=sca+t_mat(ii,1)**2.d0 end do !calculate norm sca1=0.d0 do ig=1,npw sca1=sca1+2.d0*dble(conjg(wp_prod(ig))*wp_prod(ig)) enddo if(gstart==2) sca1=sca1-dble(conjg(wp_prod(1))*wp_prod(1)) call mp_sum(sca1, world_comm) write(stdout,*) 'Projection',iv,iw,sca/sca1 proj_tot=proj_tot+sca/sca1 ! do ii=1,nglobal,50 ! write(stdout,*) 'Q terms',iv,iw,ii, t_mat(ii,1) ! enddo call flush_unit(stdout) enddo enddo write(stdout,*) 'Average projection', proj_tot/dble(numpw*2) call flush_unit(stdout) deallocate(t_mat) deallocate(wv_real,tmp_g,tmp_r,wp_prod) close(iungprod) !END OF TESTING PART endif deallocate(old_basis) deallocate(v_basis) deallocate(eigen) return end subroutine global_pola_lanczos subroutine orthonormalize_two_manifolds_scalapack( state1, n1,state2, n2, threshold, state_out, n_out) !this subroutine form am orthormal basis set from 2 manifold (with orthonormal basis sets) !ONLY FOR NORM_CONSERVING CASE #ifdef __SCALAPACK USE io_global, ONLY : stdout, ionode, ionode_id USE kinds, ONLY : DP USE gvect USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : world_comm USE wannier_gw, ONLY : p_mpime,p_nproc, npcol, nprow,icontxt,myrow,mycol implicit none COMPLEX(kind=DP), INTENT(in) :: state1(npw,n1)!1st orthonormal basis INTEGER, INTENT(in) :: n1!number of 1st basis elements COMPLEX(kind=DP), INTENT(in) :: state2(npw,n2)!2nd orthonormal basis INTEGER, INTENT(in) :: n2!number of 2nd basis elements REAL(kind=DP), INTENT(in) :: threshold!threshold for orthonormality COMPLEX(kind=DP), INTENT(out) :: state_out(npw,n1+n2)!output basis set INTEGER, INTENT(out) :: n_out!number of output states INTEGER :: ii,jj REAL(kind=DP), ALLOCATABLE :: omat(:,:),tmp_mat(:,:) REAL(kind=DP), ALLOCATABLE :: eigen(:),work(:) INTEGER :: lwork,info,liwork INTEGER, ALLOCATABLE :: iwork(:) INTEGER :: n, n_r,n_c,n_dimr,n_dimc,n1_r,n1_dimr,n2_c,n2_dimc INTEGER :: icrow, iccol, iproc,ilrow,ilcol INTEGER, EXTERNAL :: indxg2l,indxg2p REAL(kind=DP), EXTERNAL :: ddot REAL(kind=DP) :: sca INTEGER :: desc_a(9),desc_b(9) !buid overlap matrix n=n1+n2 n_r=ceiling(real(n)/real(max(nprow,npcol))) n_c=ceiling(real(n)/real(max(nprow,npcol))) n_dimr=ceiling (real(n)/real(n_r*nprow))*n_r n_dimc=ceiling (real(n)/real(n_c*npcol))*n_c n1_r=ceiling(real(n1)/real(max(nprow,npcol))) n1_dimr=ceiling (real(n1)/real(n1_r*nprow))*n1_r n2_c=ceiling(real(n2)/real(max(nprow,npcol))) n2_dimc=ceiling (real(n2)/real(n2_c*npcol))*n2_c allocate(omat(n_dimr,n_dimc)) omat(:,:)=0.d0 do ii=1,n icrow = indxg2p(ii,n_r,0,0,nprow) iccol = indxg2p(ii,n_c,0,0,npcol) iproc=icrow*npcol+iccol if(myrow==icrow .and. mycol==iccol) then ilrow=indxg2l(ii,n_r,0,0,nprow) ilcol=indxg2l(ii,n_c,0,0,npcol) omat(ilrow,ilcol)=1.d0 endif enddo write(stdout,*) 'orthonormalize para1' call flush_unit(stdout) do ii=1,n1 do jj=1,n2 sca=2.d0*ddot(2*npw,state1(:,ii),1,state2(:,jj),1) if(gstart==2) sca=sca-dble(conjg(state1(1,ii))*state2(1,jj)) call mp_sum(sca, world_comm) icrow = indxg2p(ii,n_r,0,0,nprow) iccol = indxg2p(jj+n1,n_c,0,0,npcol) iproc=icrow*npcol+iccol if(myrow==icrow .and. mycol==iccol) then ilrow=indxg2l(ii,n_r,0,0,nprow) ilcol=indxg2l(jj+n1,n_c,0,0,npcol) omat(ilrow,ilcol)=sca endif enddo enddo allocate(tmp_mat(n_dimr,n_dimc)) ! A = omat desc_a(1)=1 desc_a(2)=icontxt desc_a(3)=n desc_a(4)=n desc_a(5)=n_r desc_a(6)=n_c desc_a(7)=0 desc_a(8)=0 desc_a(9)=n_dimr !B = tmp_mat desc_b(1)=1 desc_b(2)=icontxt desc_b(3)=n desc_b(4)=n desc_b(5)=n_r desc_b(6)=n_c desc_b(7)=0 desc_b(8)=0 desc_b(9)=n_dimr !diagonalize allocate(work(1)) allocate(eigen(n)) write(stdout,*) 'orthonormalize para2' call flush_unit(stdout) call pdsyev('V','U',n,omat,1,1,desc_a,eigen,tmp_mat,1,1,desc_b,work,-1,info) lwork=work(1) deallocate(work) allocate(work(lwork)) call pdsyev('V','U',n,omat,1,1,desc_a,eigen,tmp_mat,1,1,desc_b,work,lwork,info) deallocate(work) if(info/=0) then write(stdout,*) 'ROUTINE orthonormalize_two_manifolds_scalapack, INFO:', info stop endif write(stdout,*) 'orthonormalize para3' call flush_unit(stdout) do ii=1,n,n write(stdout,*) 'EIGEN:',ii, eigen(ii) enddo call flush_unit(stdout) state_out(:,:)=(0.d0,0.d0) n_out=0 do ii=1,n if(eigen(ii) >= threshold) then n_out=n_out+1 do jj=1,n1 icrow = indxg2p(jj,n_r,0,0,nprow) iccol = indxg2p(ii,n_c,0,0,npcol) iproc=icrow*npcol+iccol if(myrow==icrow .and. mycol==iccol) then ilrow=indxg2l(jj,n_r,0,0,nprow) ilcol=indxg2l(ii,n_c,0,0,npcol) sca=tmp_mat(ilrow,ilcol) endif call mp_bcast(sca, iproc,world_comm) state_out(:,n_out)=state_out(:,n_out)+sca*state1(:,jj)/dsqrt(eigen(ii)) enddo do jj=1,n2 icrow = indxg2p(jj+n1,n_r,0,0,nprow) iccol = indxg2p(ii,n_c,0,0,npcol) iproc=icrow*npcol+iccol if(myrow==icrow .and. mycol==iccol) then ilrow=indxg2l(jj+n1,n_r,0,0,nprow) ilcol=indxg2l(ii,n_c,0,0,npcol) sca=tmp_mat(ilrow,ilcol) endif call mp_bcast(sca, iproc,world_comm) state_out(:,n_out)=state_out(:,n_out)+sca*state2(:,jj)/dsqrt(eigen(ii)) enddo endif enddo write(stdout,*) 'orthonormalize para4' call flush_unit(stdout) write(stdout,*) 'orthonormalize_two_manifolds: basis dimension:', n_out call flush_unit(stdout) deallocate (omat,tmp_mat,eigen) #endif return end subroutine orthonormalize_two_manifolds_scalapack subroutine orthonormalize_two_manifolds_prj( state1, n1,state2, n2, threshold, state_out, n_out,l_w,weight) !this subroutine form am orthormal basis set from 2 manifold (with orthonormal basis sets) !ONLY FOR NORM_CONSERVING CASE !first projects out of the second manifold the first one !the orthonormalizes the second manifold USE io_global, ONLY : stdout, ionode, ionode_id USE kinds, ONLY : DP USE gvect USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : world_comm USE wannier_gw, ONLY : l_verbose implicit none COMPLEX(kind=DP), INTENT(in) :: state1(npw,n1)!1st orthonormal basis INTEGER, INTENT(in) :: n1!number of 1st basis elements COMPLEX(kind=DP), INTENT(inout) :: state2(npw,n2)!2nd orthonormal basis INTEGER, INTENT(in) :: n2!number of 2nd basis elements REAL(kind=DP), INTENT(in) :: threshold!threshold for orthonormality COMPLEX(kind=DP), INTENT(out) :: state_out(npw,n1+n2)!output basis set INTEGER, INTENT(out) :: n_out!number of output states LOGICAL, INTENT(in) :: l_w!if true considere the weigth in eig REAL(kind=DP), INTENT(in) :: weight(n2)!weigths INTEGER :: ii,jj REAL(kind=DP), ALLOCATABLE :: omat(:,:),tmp_mat(:,:) REAL(kind=DP), ALLOCATABLE :: eigen(:),work(:) INTEGER :: lwork,info,liwork REAL(kind=DP), ALLOCATABLE :: omat1(:,:),omat2(:,:) !buid overlap matrix if(l_verbose) write(stdout,*) 'orthonormalize dgemm' call flush_unit(stdout) allocate(tmp_mat(n1,n2)) call dgemm('T','N',n1,n2,2*npw,2.d0,state1,2*npw,state2,2*npw,0.d0,tmp_mat,n1) if(gstart==2) then do ii=1,n2 do jj=1,n1 tmp_mat(jj,ii)=tmp_mat(jj,ii)-dble(conjg(state1(1,jj))*state2(1,ii)) enddo enddo endif if(l_verbose) write(stdout,*) 'orthonormalize mp_sum' call flush_unit(stdout) do ii=1,n2 call mp_sum(tmp_mat(:,ii), world_comm) enddo call dgemm('N','N',2*npw, n2,n1,-1.d0,state1,2*npw,tmp_mat,n1,1.d0,state2,2*npw) deallocate(tmp_mat) if(l_w) then do ii=1,n2 state2(1:npw,ii)=state2(1:npw,ii)*weight(ii) enddo endif allocate(omat(n2,n2)) if(gstart==2) state2(1,1:n2)=dcmplx(dble(state2(1,1:n2)),0.d0) call dgemm('T','N',n2,n2,2*npw,2.d0,state2,2*npw,state2,2*npw,0.d0,omat,n2) if(gstart==2) then do ii=1,n2 do jj=1,n2 omat(jj,ii)=omat(jj,ii)-dble(conjg(state2(1,jj))*state2(1,ii)) enddo enddo endif if(l_verbose) write(stdout,*) 'orthonormalize mp_sum' call flush_unit(stdout) do ii=1,n2 call mp_sum(omat(:,ii), world_comm) enddo !diagonalize allocate(eigen(n2)) if(l_verbose) write(stdout,*) 'orthonormalize dsyev' call flush_unit(stdout) if(ionode) then allocate(work(1)) if(l_w) omat(1:n2,1:n2)=omat(1:n2,1:n2)/weight(1)!to avoid numerical instabilities in DSYEV call DSYEV( 'V', 'U', n2, omat,n2, eigen, work, -1, info ) lwork=work(1) deallocate(work) allocate(work(lwork)) call DSYEV( 'V', 'U', n2, omat, n2, eigen, work, lwork, info ) deallocate(work) if(info/=0) then write(stdout,*) 'ROUTINE orthonormalize_two_manifolds, INFO:', info stop endif if(l_w) eigen(1:n2)=eigen(1:n2)*weight(1)!to avoid numerical instabilities in DSYEV else eigen(:)=0.d0 omat(:,:)=0.d0 endif if(l_verbose) write(stdout,*) 'orthonormalize mp_bcast now mp_sum' call flush_unit(stdout) do ii=1,n2 !call mp_bcast(omat(:,ii), ionode_id,world_comm) call mp_sum(omat(:,ii), world_comm) enddo !call mp_bcast(eigen(:), ionode_id,world_comm) call mp_sum(eigen(:), world_comm) ! do ii=1,n2 do ii=1,n2,n2-1 write(stdout,*) 'EIGEN GLOBAL:',ii, eigen(ii) enddo call flush_unit(stdout) if(l_verbose) write(stdout,*) 'orthonormalize copy' call flush_unit(stdout) !construct orthonormal basis set ! state_out(:,:)=(0.d0,0.d0) n_out=0 do ii=1,n2 if(eigen(ii) >= threshold) then n_out=n_out+1 endif enddo do ii=n2-n_out+1,n2 omat(1:n2,ii)=omat(1:n2,ii)/dsqrt(eigen(ii)) enddo call dgemm('N','N',2*npw,n_out,n2,1.d0,state2,2*npw,omat(:,n2-n_out+1:n2),n2,0.d0,state_out,2*npw) state_out(:,n_out+1:n_out+n1)=state1(:,1:n1) n_out=n_out+n1 write(stdout,*) 'orthonormalize_two_manifolds: basis dimension:', n_out call flush_unit(stdout) deallocate (omat,eigen) return end subroutine orthonormalize_two_manifolds_prj subroutine pc_operator_test(state) !this operator project the wavefunction state on the conduction !subspace, the valence wavefunction are in evc !ONLY FOR GAMMA POINT NOW!!!! USE io_global, ONLY : stdout USE kinds, ONLY : DP USE gvect USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx USE wavefunctions_module, ONLY : evc, psic USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : world_comm USE wannier_gw, ONLY : num_nbndv implicit none COMPLEX(kind=DP), INTENT(inout) :: state(npw)!state to be projected INTEGER :: iv,ig REAL(kind=DP), ALLOCATABLE :: prod(:) allocate(prod(nbnd-num_nbndv(1))) prod(:)=0.d0 call dgemm('T','N', nbnd-num_nbndv(1),1,2*npw,2.d0,evc(:,num_nbndv(1)+1:nbnd),2*npwx,state,2*npw,0.d0,prod,nbnd-num_nbndv(1)) do iv=num_nbndv(1)+1,nbnd if(gstart==2) prod(iv-num_nbndv(1))=prod(iv-num_nbndv(1))-dble(conjg(evc(1,iv))*state(1)) enddo call mp_sum(prod(:), world_comm) call dgemm('N','N',2*npw,1,nbnd-num_nbndv(1),1.d0,evc(:,num_nbndv(1)+1:nbnd),2*npwx,prod,nbnd-num_nbndv(1),0.d0,state,2*npw) deallocate(prod) return end subroutine pc_operator_test subroutine pc_operator_t_m(numpw,state,evc_t,ispin,fc) !this operator project the wavefunction state on the conduction !subspace, the valence wavefunction are in evc !it works on an arry of states !ONLY FOR GAMMA POINT NOW!!!! USE io_global, ONLY : stdout USE kinds, ONLY : DP USE gvect USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx USE wavefunctions_module, ONLY : evc, psic USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : world_comm USE wannier_gw, ONLY : num_nbndv USE fft_custom_gwl implicit none TYPE(fft_cus), INTENT(in) :: fc INTEGER, INTENT(in) :: numpw!number of vectors INTEGER, INTENT(in) :: ispin!spin channel COMPLEX(kind=DP), INTENT(inout) :: state(fc%npwt,numpw)!state to be projected ! COMPLEX(kind=DP), INTENT(inout) :: evc_t(fc%npwt,num_nbndv(ispin)) ! above syntax not accepted by all compilers COMPLEX(kind=DP), INTENT(inout) :: evc_t(fc%npwt,*)!valence states INTEGER :: ii,iv,ig REAL(kind=DP), ALLOCATABLE :: prod(:,:) allocate(prod(num_nbndv(ispin),numpw)) call dgemm('T','N', num_nbndv(ispin),numpw,2*fc%npwt,2.d0,evc_t,2*fc%npwt,state,2*fc%npwt,& & 0.d0,prod,num_nbndv(ispin)) if(fc%gstart_t==2) then do ii=1,numpw do iv=1,num_nbndv(ispin) prod(iv,ii)=prod(iv,ii)-dble(conjg(evc_t(1,iv))*state(1,ii)) enddo enddo endif do ii=1,numpw call mp_sum(prod(:,ii), world_comm) enddo call dgemm('N','N',2*fc%npwt,numpw,num_nbndv(ispin),-1.d0,evc_t,2*fc%npwt,prod,& &num_nbndv(ispin),1.d0,state,2*fc%npwt) deallocate(prod) return end subroutine pc_operator_t_m subroutine pc_operator_t_r(numpw,state,evc_r,ispin,fc) !NOT_TO_BE_INCLUDED_START !this operator project the wavefunction state on the conduction !subspace, the valence wavefunction are in evc USE io_global, ONLY : stdout USE kinds, ONLY : DP USE gvect USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx USE wavefunctions_module, ONLY : evc, psic USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : world_comm USE wannier_gw, ONLY : num_nbndv USE fft_custom_gwl implicit none TYPE(fft_cus), INTENT(in) :: fc INTEGER, INTENT(in) :: numpw!number of vectors INTEGER, INTENT(in) :: ispin!spin channel REAL(kind=DP), INTENT(inout) :: state(fc%nrxxt,numpw)!state to be projected ! REAL(kind=DP), INTENT(inout) :: evc_r(fc%nrxxt,num_nbndv(ispin)) ! above syntax not accepted by all compilers REAL(kind=DP), INTENT(inout) :: evc_r(fc%nrxxt,*)!valence states INTEGER :: ii,iv,ig REAL(kind=DP), ALLOCATABLE :: prod(:,:) allocate(prod(num_nbndv(ispin),numpw)) call dgemm('T','N', num_nbndv(ispin),numpw,fc%nrxxt,1.d0,evc_r,fc%nrxxt,state,fc%nrxxt,& & 0.d0,prod,num_nbndv(ispin)) do ii=1,numpw call mp_sum(prod(:,ii), world_comm) prod(:,ii)=prod(:,ii)/dble(fc%nr1t*fc%nr2t*fc%nr3t) enddo call dgemm('N','N',fc%nrxxt,numpw,num_nbndv(ispin),-1.d0,evc_r,fc%nrxxt,prod,& &num_nbndv(ispin),1.d0,state,fc%nrxxt) deallocate(prod) return !NOT_TO_BE_INCLUDED_END end subroutine pc_operator_t_r subroutine h_psi_self( lda, n, m, psi, hpsi ) !NOT_TO_BE_INCLUDED_START !add to hpsi part dur to self-consistent GW calculation ! ... input: ! ... lda leading dimension of arrays psi, spsi, hpsi ! ... n true dimension of psi, spsi, hpsi ! ... m number of states psi ! ... psi ! ! ... output: ! ... hpsi H*psi ! USE kinds, ONLY : DP USE gvect, ONLY : gstart USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx,et USE wavefunctions_module, ONLY : evc USE wannier_gw, ONLY : n_gw_states, ene_gw, delta_self USE mp, ONLY : mp_sum USE mp_world, ONLY : world_comm ! implicit none INTEGER, INTENT(IN) :: lda, n, m COMPLEX(kind=DP), INTENT(IN) :: psi(lda,m) COMPLEX(kind=DP), INTENT(OUT) :: hpsi(lda,m) INTEGER :: ii,jj REAL(kind=DP), ALLOCATABLE :: prod(:,:) !apply \Delta1 hpsi(1:n,1:m)=hpsi(1:n,1:m)+delta_self*psi(1:n,1:m) !apply \Sum_i (e^GW_i-e^DFT_i-Delta)|\psi_i><\psi_i| allocate(prod(n_gw_states,m)) prod(:,:)=0.d0 call dgemm('T','N', n_gw_states,m,2*npw,2.d0,evc,2*npwx,psi,2*lda,0.d0,prod,n_gw_states) do ii=1,n_gw_states do jj=1,m if(gstart==2) prod(ii,jj)=prod(ii,jj)-dble(conjg(evc(1,ii))*psi(1,jj)) enddo enddo call mp_sum(prod,world_comm) do jj=1,m do ii=1,n_gw_states prod(ii,jj)=prod(ii,jj)*(ene_gw(ii,1)-et(ii,1)-delta_self) enddo enddo call dgemm('N','N',2*npw,m,n_gw_states,1.d0,evc,2*npwx,prod,n_gw_states,1.d0,hpsi,2*lda) deallocate(prod) return !NOT_TO_BE_INCLUDED_END end subroutine h_psi_self subroutine h_psi_scissor( ispin,lda, n, m, psi, hpsi ) !NOT_TO_BE_INCLUDED_START !add to hpsi part dur to self-consistent GW calculation ! ... input: ! ... lda leading dimension of arrays psi, spsi, hpsi ! ... n true dimension of psi, spsi, hpsi ! ... m number of states psi ! ... psi ! ... output: ! ... hpsi H*psi USE kinds, ONLY : DP USE gvect, ONLY : gstart USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx,et USE wavefunctions_module, ONLY : evc USE wannier_gw, ONLY : num_nbndv,scissor USE mp, ONLY : mp_sum USE mp_world, ONLY : world_comm USE constants, ONLY : rytoev implicit none INTEGER, INTENT(in) :: ispin!spin channel INTEGER, INTENT(IN) :: lda, n, m COMPLEX(kind=DP), INTENT(IN) :: psi(lda,m) COMPLEX(kind=DP), INTENT(OUT) :: hpsi(lda,m) INTEGER :: ii,jj REAL(kind=DP), ALLOCATABLE :: prod(:,:) allocate(prod(num_nbndv(ispin),m)) prod=0.d0 call dgemm('T','N', num_nbndv(ispin),m,2*npw,2.d0,evc,2*npwx,psi,2*lda,0.d0,prod,num_nbndv(ispin)) do ii=1,num_nbndv(ispin) do jj=1,m if(gstart==2) prod(ii,jj)=prod(ii,jj)-dble(conjg(evc(1,ii))*psi(1,jj)) enddo enddo call mp_sum(prod,world_comm) do jj=1,m do ii=1,num_nbndv(ispin) prod(ii,jj)=prod(ii,jj)*scissor/rytoev enddo enddo call dgemm('N','N',2*npw,m,num_nbndv(ispin),1.d0,evc,2*npwx,prod,num_nbndv(ispin),1.d0,hpsi,2*lda) deallocate(prod) return !NOT_TO_BE_INCLUDED_END end subroutine h_psi_scissor subroutine pola_basis_lanczos_real(n_set,nstates,numpw, nsteps,ispin) !NOT_TO_BE_INCLUDED_START !this subroutine calculates the basis for every v !the minimal orthonormal basis for the w_v(r)*w^P'_i(r) products USE io_global, ONLY : stdout, ionode, ionode_id USE io_files, ONLY : prefix, tmp_dir, diropn USE kinds, ONLY : DP USE wannier_gw USE gvect USE constants, ONLY : e2, pi, tpi, fpi USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2 USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, ecutwfc USE wavefunctions_module, ONLY : evc, psic USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_pools, ONLY : intra_pool_comm USE mp_world, ONLY : world_comm, mpime, nproc USE gvecs, ONLY : nls, nlsm, doublegrid USE fft_custom_gwl USE mp_wave, ONLY : mergewf,splitwf USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER, INTENT(in) :: n_set !defines the number of states to be read from disk at the same tim\e INTEGER, INTENT(in) :: nstates!number of orthonormal states to retain INTEGER, INTENT(in) :: numpw!dimension of polarization basis INTEGER, INTENT(in) :: nsteps!number of lanczos steps INTEGER, INTENT(in) :: ispin! spin channel INTEGER :: iv,iw,ig,ii,jj,ir REAL(kind=DP), ALLOCATABLE :: wv_real(:),tmp_r(:),tmp_r2(:) COMPLEX(kind=DP), ALLOCATABLE :: tmp_g(:) REAL(kind=DP), ALLOCATABLE :: wp_prod(:,:,:) INTEGER :: iungprod,iunrprod, iungresult,iuntmat LOGICAL :: exst REAL(kind=DP), ALLOCATABLE :: omat(:,:),omat_hold(:,:) REAL(kind=DP), ALLOCATABLE :: eigen(:),work(:) INTEGER :: lwork,info,liwork COMPLEX(kind=DP), ALLOCATABLE :: wp_g(:,:),wp_g_t2(:,:)!product terms in g wfc grid REAL(kind=DP), ALLOCATABLE :: wp_g_t(:,:)! REAL(kind=DP), ALLOCATABLE :: t_mat(:,:),t_mat_hold(:,:), t_mat_hold2(:,:) CHARACTER(4) :: nfile COMPLEX(kind=DP), ALLOCATABLE :: p_basis(:,:)!polarizability basis LOGICAL :: l_dsyevr=.true.!if true uses dsyevr REAL(kind=DP), ALLOCATABLE :: vectors(:,:)!for dsyevr INTEGER, ALLOCATABLE :: iwork(:), ifail(:) INTEGER, ALLOCATABLE :: isuppz(:) INTEGER :: n_found LOGICAL :: l_fft_custom=.false.!if true uses custom fft grid COMPLEX(kind=DP), ALLOCATABLE :: evc_t(:,:),p_basis_t(:,:) REAL(kind=DP), ALLOCATABLE :: evc_r(:,:) COMPLEX(kind=DP), ALLOCATABLE :: evc_g(:) LOGICAL :: l_sumrule=.false.!if true imposes the sum rule over the norm of Pc|\Phi_\mu\Psi_v> for each of them REAL(kind=DP), ALLOCATABLE :: norms(:) REAL(kind=DP) :: norm_t, c_norm,norm REAL(kind=DP), ALLOCATABLE :: p_basis_r(:,:) !polarizabilty basis in real custom space INTEGER :: ivv,nbuf REAL(kind=DP) :: vl,vu INTEGER :: il,iu REAL(kind=DP), ALLOCATABLE :: t_eigen_hold(:) REAL(kind=DP) :: sca TYPE(fft_cus) :: fc write(stdout,*) 'Routine pola_basis_lanczos_real' call flush_unit(stdout) fc%ecutt=ecutwfc fc%dual_t=dual_vt if(l_verbose) write(stdout,*) 'Call initialize_fft_custom' call flush_unit(stdout) call initialize_fft_custom(fc) ! allocate(evc_g(fc%ngmt_g)) ! allocate(wv_real(dfftp%nnr)) ! allocate(wp_prod(npw,numpw)) allocate(wv_real(fc%nrxxt)) ! allocate(wp_g_t2(fc%npwt)) allocate(norms(numpw)) !read w^P'_i on file on real space !open product of wanniers filed iungprod = find_free_unit() CALL diropn( iungprod, 'wiwjwfc_red', max_ngm*2, exst ) iungresult = find_free_unit() CALL diropn( iungresult, 'vw_lanczos',npw*2, exst) !read polarizability basis functions allocate(p_basis(max_ngm,numpw)) do iw=1,numpw call davcio(p_basis(:,iw),max_ngm*2,iungprod,iw,-1) enddo close(iungprod) if(l_verbose) write(stdout,*) 'pola_basis_lanczos 1' call flush_unit(stdout) !now polarizability basis are put on the ordering of the redueced grid, if required allocate(p_basis_t(fc%npwt,numpw)) ! if(fc%dual_t==4.d0) then ! p_basis_t(:,:)=p_basis(:,:) ! else call reorderwfp (numpw,npw, fc%npwt,p_basis(:,:),p_basis_t(:,:), & &npw,fc%npwt, ig_l2g,fc%ig_l2gt, fc%ngmt_g , mpime, nproc,ionode_id, intra_pool_comm ) ! do ii=1,numpw ! call mergewf(p_basis(:,ii),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) ! call splitwf(p_basis_t(:,ii),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) ! enddo !trasform to real space allocate(p_basis_r(fc%nrxxt,numpw)) do ii=1,numpw,2 psic(:)=(0.d0,0.d0) if(ii==numpw) then psic(fc%nlt(1:fc%npwt)) = p_basis_t(1:fc%npwt,ii) psic(fc%nltm(1:fc%npwt)) = CONJG( p_basis_t(1:fc%npwt,ii) ) else psic(fc%nlt(1:fc%npwt))=p_basis_t(1:fc%npwt,ii)+(0.d0,1.d0)*p_basis_t(1:fc%npwt,ii+1) psic(fc%nltm(1:fc%npwt)) = CONJG( p_basis_t(1:fc%npwt,ii) )+(0.d0,1.d0)*CONJG( p_basis_t(1:fc%npwt,ii+1) ) endif CALL cft3t(fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) p_basis_r(1:fc%nrxxt,ii)= DBLE(psic(1:fc%nrxxt)) if(ii/=numpw) p_basis_r(1:fc%nrxxt,ii+1)= DIMAG(psic(1:fc%nrxxt)) enddo ! endif !now valence wavefunctions are put on the ordering of the reduced grid allocate(evc_t(fc%npwt,num_nbndv(ispin))) allocate(evc_r(fc%nrxxt,num_nbndv(ispin))) if(fc%dual_t==4.d0) then evc_t(:,1:num_nbndv(ispin))=evc(:,1:num_nbndv(ispin)) else call reorderwfp (num_nbndv(ispin),npw, fc%npwt,evc(:,:),evc_t(:,:), & &npw,fc%npwt, ig_l2g,fc%ig_l2gt, fc%ngmt_g , mpime, nproc,ionode_id, intra_pool_comm ) ! do iv=1,num_nbndv(ispin) ! call mergewf(evc(:,iv),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) ! call splitwf(evc_t(:,iv),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) ! enddo endif evc_r=0.d0 do iv=1,num_nbndv(ispin) psic(:)=(0.d0,0.d0) psic(fc%nlt(1:fc%npwt)) = evc_t(1:fc%npwt,iv) psic(fc%nltm(1:fc%npwt)) = CONJG( evc_t(1:fc%npwt,iv) ) CALL cft3t(fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) evc_r(1:fc%nrxxt,iv)= DBLE(psic(1:fc%nrxxt)) enddo !loop on v allocate(tmp_r(fc%nrxxt),tmp_r2(fc%nrxxt)) allocate(omat(numpw,numpw),omat_hold(numpw,numpw)) allocate(t_mat(numpw,nstates), t_mat_hold(numpw,nstates), t_mat_hold2(numpw,nstates)) allocate(wp_g(npw,nstates)) allocate(wp_g_t(fc%nrxxt,nstates)) allocate(t_eigen_hold(nstates)) !set the number of products to be distributed nbuf=min(12,nproc) allocate(wp_prod(fc%nrxxt,numpw,nbuf)) wp_prod=0.d0 wp_g_t=0.d0 do ivv=1,num_nbndv(ispin),nbuf !put iv on real space do iv=ivv,min(ivv+nbuf-1,num_nbndv(ispin)) wv_real(1:fc%nrxxt)= evc_r(1:fc%nrxxt,iv) !!loop on products of wanniers ! allocate(tmp_r(fc%nrxxt)) if(l_verbose) write(stdout,*) 'do fft',fc%nrxxt, numpw,iv-ivv+1 call flush_unit(stdout) do ii=1,numpw wp_prod(1:fc%nrxxt, ii,iv-ivv+1)=p_basis_r(1:fc%nrxxt,ii)*wv_real(1:fc%nrxxt) enddo call pc_operator_t_r(numpw,wp_prod(1,1,iv-ivv+1),evc_r,ispin, fc) if(l_verbose) write(stdout,*) 'calculate omat' call flush_unit(stdout) !!calculate overlap matrix call dgemm('T','N',numpw,numpw,fc%nrxxt,1.d0,wp_prod(1,1,iv-ivv+1),fc%nrxxt,& &wp_prod(1,1,iv-ivv+1),fc%nrxxt,0.d0,omat,numpw) do ii=1,numpw call mp_sum(omat(1:numpw,ii),world_comm) omat(1:numpw,ii)=omat(1:numpw,ii)/dble(fc%nr1t*fc%nr2t*fc%nr3t) enddo !set up norms ! do ii=1,numpw ! norms(ii)=omat(ii,ii) ! enddo if(iv-ivv==mpime) then omat_hold(:,:)=omat(:,:) endif enddo !! !!solve eigen/values vector problem !! if(l_verbose) write(stdout,*) 'solve eig' call flush_unit(stdout) call flush_unit(stdout) do iv=ivv,min(ivv+nbuf-1,num_nbndv(ispin)) if(l_verbose) write(stdout,*) 'solve eig', iv call flush_unit(stdout) if(iv-ivv==mpime) then if(.not.l_dsyevr) then allocate(eigen(numpw)) allocate(work(1)) call DSYEV( 'V', 'U', numpw, omat_hold, numpw, eigen, work, -1, info ) lwork=work(1) deallocate(work) allocate(work(lwork)) call DSYEV( 'V', 'U', numpw, omat_hold, numpw, eigen, work, lwork, info ) deallocate(work) if(info/=0) then write(stdout,*) 'ROUTINE pola_basis_lanczos, INFO:', info stop endif ! do iw=1,numpw ! write(stdout,*) 'EIGEN:',iv,iw, eigen(iw) ! enddo ! call flush_unit(stdout) else if(l_verbose) write(stdout,*) 'ATT1' call flush_unit(stdout) allocate(eigen(numpw)) allocate(vectors(numpw,nstates)) allocate(isuppz(2*nstates)) allocate(work(1),iwork(1)) if(l_verbose) write(stdout,*) 'ATT2' call flush_unit(stdout) call DSYEVR('V','I','U',numpw,omat_hold,numpw,0.d0,0.d0,numpw-nstates+1,numpw,0.d0,n_found,eigen,& & vectors,numpw,isuppz,work, -1,iwork,-1, info) lwork=work(1) liwork=iwork(1) deallocate(work,iwork) allocate(work(lwork)) allocate(iwork(liwork)) if(l_verbose) write(stdout,*) 'ATT3',numpw,nstates,size(omat_hold(:,1)),size(omat_hold(1,:)),lwork,liwork call flush_unit(stdout) vl=0.d0 vu=0.d0 il=numpw-nstates+1 iu=numpw call DSYEVR('V','I','U',numpw,omat_hold,numpw,vl,vu,il,iu,0.d0,n_found,eigen,& & vectors,numpw,isuppz,work,lwork,iwork,liwork, info) if(info/=0) then write(stdout,*) 'ROUTINE pola_lanczos DSYEVR, INFO:', info stop endif if(l_verbose) write(stdout,*) 'ATT4' call flush_unit(stdout) deallocate(isuppz) deallocate(work,iwork) do iw=1,nstates write(stdout,*) 'EIGEN:',iv,iw, eigen(iw) enddo call flush_unit(stdout) endif !!find transformation matrix and write on disk ! if(l_verbose) write(stdout,*) 'pola_basis_lanczos t_mat' call flush_unit(stdout) if(.not.l_dsyevr) then do ii=1,nstates do jj=1,numpw t_mat_hold(jj,ii)=omat_hold(jj,numpw-ii+1)*(dsqrt(eigen(numpw-ii+1))) enddo t_eigen_hold(ii)=eigen(numpw-ii+1) enddo else do ii=1,nstates do jj=1,numpw t_mat_hold(jj,ii)=vectors(jj,ii)*(dsqrt(eigen(ii))) enddo t_eigen_hold(ii)=eigen(ii) enddo endif !!find liner dependent products if(.not.l_dsyevr) then do ii=1,nstates t_mat_hold2(:,ii)=omat_hold(:,numpw-ii+1)*(1.d0/dsqrt(eigen(numpw-ii+1))) enddo else do ii=1,nstates t_mat_hold2(:,ii)=vectors(:,ii)*(1.d0/dsqrt(eigen(ii))) enddo endif deallocate(eigen) if(l_dsyevr) deallocate(vectors) endif enddo allocate(eigen(nstates)) do iv=ivv,min(ivv+nbuf-1,num_nbndv(ispin)) if(iv-ivv == mpime) then t_mat(:,:)=t_mat_hold(:,:) eigen(1:nstates)=t_eigen_hold(1:nstates) endif call mp_bcast(t_mat,iv-ivv,world_comm) call mp_bcast(eigen(1:nstates),iv-ivv,world_comm) !if required imposes sum rule ! if(l_sumrule) then ! norm_t=0.d0 ! do jj=1,numpw ! do ii=1,nstates ! norm_t=norm_t+t_mat(jj,ii)**2.d0 ! enddo ! enddo ! norm=0.d0 ! do jj=1,numpw ! norm=norm+norms(jj) ! enddo ! c_norm=dsqrt(norm/norm_t) ! write(stdout,*) 'Sum rule:',c_norm ! t_mat(:,:)=t_mat(:,:)*c_norm ! endif if(ionode) then iuntmat = find_free_unit() write(nfile,'(4i1)') iv/1000,mod(iv,1000)/100,mod(iv,100)/10,mod(iv,10) if(ispin==1) then open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.p_mat_lanczos'//nfile, & &status='unknown',form='unformatted') else open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.p_mat_lanczos2'//nfile, & &status='unknown',form='unformatted') endif write(iuntmat) iv write(iuntmat) num_nbndv(ispin) write(iuntmat) numpw write(iuntmat) nstates do ii=1,nstates write(iuntmat) t_mat(1:numpw,ii) enddo close(iuntmat) endif !write on disk file with eigen values if(ionode) then iuntmat = find_free_unit() write(nfile,'(4i1)') iv/1000,mod(iv,1000)/100,mod(iv,100)/10,mod(iv,10) if(ispin==1) then open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.p_eig_lanczos'//nfile, & &status='unknown',form='unformatted') else open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.p_eig_lanczos2'//nfile, & &status='unknown',form='unformatted') endif write(iuntmat) nstates write(iuntmat) eigen(1:nstates) close(iuntmat) endif if(l_verbose) write(stdout,*) 'pola_basis update wp_g' call flush_unit(stdout) !!find liner dependent products if(iv-ivv == mpime) then t_mat(:,:)=t_mat_hold2(:,:) endif call mp_bcast(t_mat,iv-ivv,world_comm) if(l_verbose) write(stdout,*) 'pola_basis update wp_g dgemm' call flush_unit(stdout) call dgemm('N','N',fc%nrxxt,nstates,numpw,1.d0,wp_prod(1,1,iv-ivv+1),fc%nrxxt,t_mat,numpw,0.d0,wp_g_t,fc%nrxxt) write(stdout,*) 'pola_basis update merge-split',iv,ivv call flush_unit(stdout) !put the correct order psic=0.d0 allocate(wp_g_t2(fc%npwt,nstates)) do ii=1,nstates,2 if(ii==nstates) then psic(1:fc%nrxxt)=wp_g_t(1:fc%nrxxt,ii) else psic(1:fc%nrxxt)=cmplx(wp_g_t(1:fc%nrxxt,ii),wp_g_t(1:fc%nrxxt,ii+1)) endif CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, -2 ) if(ii==nstates) then wp_g_t2(1:fc%npwt,ii) = psic(fc%nlt(1:fc%npwt)) !project on conduction manifold call pc_operator_t(wp_g_t2(:,ii),evc_t,ispin,fc) else wp_g_t2(1:fc%npwt, ii)= 0.5d0*(psic(fc%nlt(1:fc%npwt))+conjg( psic(fc%nltm(1:fc%npwt)))) wp_g_t2(1:fc%npwt, ii+1)= (0.d0,-0.5d0)*(psic(fc%nlt(1:fc%npwt)) - conjg(psic(fc%nltm(1:fc%npwt)))) call pc_operator_t(wp_g_t2(:,ii),evc_t,ispin,fc) call pc_operator_t(wp_g_t2(:,ii+1),evc_t,ispin,fc) endif enddo if(fc%dual_t==4.d0) then wp_g(1:npw,1:nstates)=wp_g_t2(1:fc%npwt,1:nstates) else call reorderwfp (nstates,fc%npwt, npw,wp_g_t2,wp_g, & &fc%npwt,npw, fc%ig_l2gt,ig_l2g, fc%ngmt_g , mpime, nproc,ionode_id, intra_pool_comm ) ! call mergewf(wp_g_t2(:),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) ! call splitwf(wp_g(:,ii),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) endif deallocate(wp_g_t2) if(l_verbose) write(stdout,*) 'pola_basis update davcio',iv call flush_unit(stdout) !!write on disk do ii=1,nstates call davcio(wp_g(:,ii),npw*2,iungresult,ii+(iv-1)*nstates,1) enddo if(l_verbose) write(stdout,*) 'pola_basis update done' call flush_unit(stdout) enddo deallocate(eigen) enddo deallocate(evc_r) deallocate(t_mat,t_mat_hold,t_mat_hold2) deallocate(omat,omat_hold,tmp_r,tmp_r2,p_basis_r) deallocate(wp_g,wp_g_t) close(iungresult) deallocate(norms) deallocate(wv_real,wp_prod) deallocate(t_eigen_hold) if(l_verbose) write(stdout,*) 'Exiting pola_basis_lanczos' call flush_unit(stdout) deallocate(p_basis) deallocate(p_basis_t,evc_t) if(l_verbose) write(stdout,*) 'Call deallocate_fft_custom' call flush_unit(stdout) !deallocate(evc_g) call deallocate_fft_custom(fc) return !NOT_TO_BE_INCLUDED_END end subroutine pola_basis_lanczos_real GWW/pw4gww/Makefile0000644000077300007730000000323612341332532014713 0ustar giannozzgiannozz# Makefile for pw4gww (PW4GWW) # Author G. Stenuit and L. Martin-Samos include ../../make.sys # location of include files IFLAGS=-I../../include # location of needed modules MODFLAGS= $(MOD_FLAG)../../iotk/src $(MOD_FLAG)../../Modules \ $(MOD_FLAG)../../PW/src $(MOD_FLAG). #location of needed libraries LIBOBJS= ../../iotk/src/libiotk.a ../../flib/flib.a \ ../../clib/clib.a ../../flib/ptools.a PW4GWWOBJS = \ allocate_wannier.o \ produce_wannier_gamma.o \ start_pw4gww.o \ stop_pp.o \ openfil_pw4gww.o \ dft_exchange.o \ wfc_real.o \ full.o \ energies_xc.o \ wannier.o \ write_wannier_matrix.o \ rotate_wannier.o \ self_lanczos.o \ pola_lanczos.o \ matrix_wannier_gamma.o \ calculate_wing.o \ fake_conduction.o \ o_1psi.o \ o_bands.o \ optimal.o \ pola_partial.o \ semicore.o \ semicore_read.o \ v_basis.o \ wannier_uterms.o \ write_vpot_matrix.o \ diago_cg.o \ o_rinitcgg.o \ diago_cg_g.o \ contour_terms.o \ fft_custom.o \ exchange_custom.o \ mp_wave_parallel.o \ wannier_bse.o\ hpsi_pw4gww.o \ cgsolve_all_gamma.o QEMODS = ../../Modules/libqemod.a PWOBJS = ../../PW/src/libpw.a LIBMIN= ../minpack/minpacklib.a TLDEPS= bindir libs pw all : tldeps pw4gww.x pw4gww.x : pw4gww.o libpw4gww.a $(PW4GWWOBJS) $(PWOBJS) $(QEMODS) $(LIBMIN) $(LD) $(LDFLAGS) -o $@ \ pw4gww.o libpw4gww.a $(PWOBJS) $(QEMODS) $(LIBOBJS) $(LIBMIN) $(LIBS) - ( cd ../../bin ; ln -fs ../GWW/pw4gww/$@ . ) tldeps : if test -n "$(TLDEPS)" ; then \ ( cd ../.. ; $(MAKE) $(TLDEPS) || exit 1 ) ; fi libpw4gww.a : $(PW4GWWOBJS) $(AR) $(ARFLAGS) $@ $? $(RANLIB) $@ clean : - /bin/rm -fv *.x *.o *~ *.F90 *.d *.mod *.i *.L libpw4gww.a include make.depend # DO NOT DELETE GWW/pw4gww/v_basis.f900000644000077300007730000001014612341332532015217 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! SUBROUTINE v_basis(numpw,o_basis,cutoff) !this subroutine calculate the coulomb v operator on the space of polarizability basis !functions and retains only eigenstate larger than cutoff USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode,ionode_id USE cell_base, ONLY : tpiba2,tpiba USE klist, ONLY : nkstot, nks, wk, xk, nelec USE gvect, ONLY : g, gstart USE wvfct, ONLY : g2kin, wg, nbndx, et, nbnd, npwx, igk, & npw, current_k USE mp, ONLY : mp_sum,mp_bcast USE mp_world, ONLY : world_comm USE klist, ONLY : xk USE wannier_gw, ONLY : l_truncated_coulomb,truncation_radius USE exx, ONLY : exx_divergence, exx_grid_init, yukawa USE constants, ONLY : e2,fpi implicit none INTEGER, INTENT(inout) :: numpw!dimension of polarization basis COMPLEX(kind=DP), INTENT(inout) :: o_basis(npw,numpw) REAL(kind=DP), INTENT(in) :: cutoff!cutoff for v eigen values REAL(kind=DP), ALLOCATABLE :: fac(:) INTEGER :: ig,ii,jj REAL(kind=DP) :: qq REAL(kind=DP), ALLOCATABLE :: vmat(:,:) COMPLEX(kind=DP), ALLOCATABLE :: vo_basis(:,:) REAL(kind=DP), ALLOCATABLE :: eigen(:),vectors(:,:) INTEGER, ALLOCATABLE :: iwork(:), ifail(:) INTEGER, ALLOCATABLE :: isuppz(:) INTEGER :: n_found REAL(kind=DP), ALLOCATABLE :: work(:) INTEGER :: lwork,info,liwork allocate(fac(npw)) do ig=1,npw qq = g(1,ig)**2.d0 + g(2,ig)**2.d0 + g(3,ig)**2.d0 if(.not.l_truncated_coulomb) then if (qq > 1.d-8) then fac(ig)=e2*fpi/(tpiba2*qq + yukawa ) else fac(ig)= 0.d0 if (yukawa .gt. 1.d-8 ) then fac(ig) = fac(ig) + e2*fpi/(tpiba2*qq + yukawa ) end if end if else if (qq > 1.d-8) then fac(ig)=(e2*fpi/(tpiba2*qq))*(1.d0-dcos(dsqrt(qq)*truncation_radius*tpiba)) else fac(ig)=e2*fpi*(truncation_radius**2.d0/2.d0) endif !if(abs(fac(ig)) <=1.d-8) fac(ig)=1.d-8!ATTENZIONE endif end do allocate(vmat(numpw,numpw)) allocate(vo_basis(npw,numpw)) do ii=1,numpw vo_basis(:,ii)=fac(:)*o_basis(:,ii) enddo deallocate(fac) call dgemm('T','N',numpw,numpw,2*npw,2.d0,o_basis,2*npw,vo_basis,2*npw,0.d0,vmat,numpw) if(gstart==2) then do ii=1,numpw do jj=1,numpw vmat(jj,ii)=vmat(jj,ii)-dble(conjg(o_basis(1,jj))*vo_basis(1,ii)) enddo enddo endif do ii=1,numpw call mp_sum(vmat(:,ii),world_comm) enddo allocate(eigen(numpw)) allocate(vectors(numpw,numpw)) if(ionode) then allocate(isuppz(2*numpw)) allocate(work(1),iwork(1)) call DSYEVR('V','V','U',numpw,vmat,numpw,cutoff,1.d5,1,1,0.d0,n_found,eigen,& & vectors,numpw,isuppz,work, -1,iwork,-1, info) lwork=work(1) liwork=iwork(1) deallocate(work,iwork) allocate(work(lwork)) allocate(iwork(liwork)) call DSYEVR('V','V','U',numpw,vmat,numpw, cutoff,1.d5,1,1,0.d0,n_found,eigen,& & vectors,numpw,isuppz,work,lwork,iwork,liwork, info) if(info/=0) then write(stdout,*) 'ROUTINE v_basis DSYEVR, INFO:', info stop endif deallocate(isuppz) deallocate(work,iwork) else eigen(:)=0.d0 vectors(:,:)=0.d0 n_found=0 endif call mp_sum(n_found,world_comm) call mp_sum(eigen(1:n_found),world_comm) do ii=1,n_found write(stdout,*) 'v_basis:',ii,eigen(ii) call mp_sum(vectors(:,ii),world_comm) enddo deallocate(vmat) vo_basis(:,:)=o_basis(:,:) call dgemm('N','N',2*npw,n_found,numpw,1.d0,vo_basis,2*npw,vectors,numpw,0.d0,o_basis,2*npw) numpw=n_found deallocate(eigen,vectors,vo_basis) return END SUBROUTINE v_basis GWW/pw4gww/produce_wannier_gamma.f900000644000077300007730000006444612341332532020133 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! SUBROUTINE produce_wannier_gamma USE wannier_gw USE wvfct, ONLY : npw USE io_global, ONLY : ionode_id USE mp, ONLY : mp_barrier, mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : prefix, tmp_dir, nwordwfc,iunwfc USE wvfct, ONLY : nbnd, et, npwx USE io_global, ONLY : stdout, ionode USE wavefunctions_module, ONLY : evc USE exx, ONLY : ecutfock,vexx,exx_div_check,exx_grid_init,exx_grid_check,exxinit,x_occupation USE funct, ONLY : exx_is_active, dft_is_hybrid,start_exx,stop_exx USE wvfct, ONLY : current_k, ecutwfc,et USE scf, ONLY : scf_type, scf_type_COPY, & create_scf_type, destroy_scf_type, & rho, rho_core, rhog_core, & v, vltot, vrs, kedtau, vnew USE ener, ONLY : etot, hwf_energy, eband, deband, ehart, & vtxc, etxc, etxcc, ewld, demet, epaw, & elondon USE ldaU, ONLY : eth, Hubbard_U, Hubbard_lmax, & niter_with_fixed_ns, lda_plus_u USE extfield, ONLY : tefield, etotefield USE lsda_mod, ONLY : lsda, nspin,current_spin,isk USE gvecs, ONLY : doublegrid USE fake_cond_mod USE constants, ONLY : rytoev USE fft_base, ONLY : dfftp USE exchange_custom USE fft_custom_gwl USE klist, ONLY : nks implicit none INTEGER, EXTERNAL :: find_free_unit REAL(kind=DP), ALLOCATABLE :: e_xc(:,:),e_h(:,:),e_x(:,:) INTEGER :: ii,iw,jw,iunuterms,iun,iun2 REAL(kind=DP), ALLOCATABLE :: tmp_rot(:,:) REAL(kind=DP), ALLOCATABLE :: v_states(:,:)!valence states in real space COMPLEX(kind=DP), ALLOCATABLE :: o_basis(:,:)!polarization basis !(from diagonalization of O matrix) REAL(kind=DP), ALLOCATABLE :: o_mat(:,:) ! INTEGER :: fcw_number!number of "producs of fake conduction with valence wannier" states for O matrix method ! COMPLEX(kind=DP), POINTER, DIMENSION(:,:) :: fcw_state! fcw states for O matrix method ! REAL(kind=DP), POINTER, DIMENSION(:,:) :: fcw_mat! "fcw matrix REAL(kind=DP), TARGET, ALLOCATABLE :: uterms(:,:), uterms_tmp(:)!matrix for 1/|r-r'| terms between product of wanniers REAL(kind=DP) :: charge INTEGER :: idumm REAL(kind=DP) :: rdumm1,rdumm2,rdumm3 INTEGER :: is COMPLEX(kind=DP), ALLOCATABLE :: ks_wfcs(:,:,:)!Kohn-Sham wfcs (or wannier's) with spin multiplicity COMPLEX(kind=DP), ALLOCATABLE :: ks_wfcs_diag(:,:,:)!Kohn-Sham with spin multiplicity INTEGER :: num_nbndv_max INTEGER :: istate INTEGER :: numw_prod_all TYPE(exchange_cus) :: exx_cus ! interface ! subroutine fake_conduction_wannier(fcw_n,fcw_s,fcw_m,cut,s_cut) ! USE kinds, ONLY : DP ! INTEGER,INTENT(out) :: fcw_n!number of "fake conduction" states for O matrix method ! COMPLEX(kind=DP), POINTER, DIMENSION(:,:) :: fcw_s! "fake conduction" states for O matrix method ! REAL(kind=DP), POINTER, DIMENSION(:,:) :: fcw_m! "fake conduction" matrix ! REAL(kind=DP), INTENT(in) :: cut!cutoff for planewaves ! REAL(kind=DP), INTENT(in) :: s_cut!cutoff for orthonormalization ! INTEGER, INTENT(in) :: n_fast! number of fast conduction states, 0 = disabled ! REAL(kind=DP), INTENT(in) :: o_fast!offset for fast polarizability matrix 0 = disabled ! LOGICAL, INTENT(in) :: l_fast!if true fast polarizability matrix calculation ! end subroutine fake_conduction_wannier ! end interface allocate(e_xc(nbnd,nspin),e_h(nbnd,nspin), e_x(nbnd,nspin)) allocate(ks_wfcs(npwx,nbnd,nspin)) allocate(ks_wfcs_diag(npwx,nbnd,nspin)) call start_clock('produce_wannier') !setup global cutoff ecutoff_global=ecutwfc if(restart_gww>=2) then if(extra_pw_cutoff>0.d0) call update_numwp(numw_prod, extra_pw_cutoff) if(.not.l_truncated_coulomb) numw_prod=numw_prod+1 endif !setup parallel environment #ifndef __PARA l_pmatrix=.false. #endif #ifndef __SCALAPACK l_pmatrix=.false. #endif if(l_pmatrix) then #ifdef __SCALAPACK call blacs_pinfo(p_mpime,p_nproc) write(stdout,*) 'PINFO',p_mpime,p_nproc ! nprow=int(sqrt(real(p_nproc))) ! npcol=p_nproc/nprow write(stdout,*) 'NPROW NPCOL', nprow, npcol call blacs_get(0,0,icontxt) call blacs_gridinit(icontxt,'R',nprow, npcol) call blacs_gridinfo(icontxt, nprow, npcol, myrow,mycol) write(stdout,*) 'MYROW MYCOL', myrow,mycol #endif endif if(l_scissor) then do is=1,nspin et(1:num_nbndv(is),is)=et(1:num_nbndv(is),is)+scissor/rytoev enddo endif if(l_truncated_coulomb) then l_zero=.false. l_wing=.false. else l_zero=.false. l_wing=.true. endif !set ngm max call max_ngm_set if(l_selfconsistent) then !NOT_TO_BE_INCLUDED_START if(ionode) then iun = find_free_unit() open( unit=iun, file='bands.dat', status='old',form='formatted') read(iun,*) n_gw_states endif call mp_bcast(n_gw_states,ionode_id,world_comm) allocate(ene_gw(n_gw_states,1)) if(ionode) then do ii=1,n_gw_states read(iun,*) idumm,rdumm1,rdumm2,ene_gw(ii,1),rdumm3 enddo close(iun) endif call mp_bcast(ene_gw(:,1),ionode_id,world_comm) ene_gw(:,1)=ene_gw(:,1)/rytoev delta_self=ene_gw(n_gw_states,1)-rdumm1/rytoev!offset for all the conduction states above those calculated !NOT_TO_BE_INCLUDED_END endif if( dft_is_hybrid()) then !NOT_TO_BE_INCLUDED_START ecutfock=exchange_fast_dual*ecutwfc CALL exx_grid_init() CALL exx_div_check() call stop_exx() call exxinit call start_exx() current_k= 1 !the following is very important if ( exx_is_active()) then CALL v_of_rho( rho, rho_core, rhog_core, & ehart, etxc, vtxc, eth, etotefield, charge, v) CALL set_vrs( vrs, vltot, v%of_r, kedtau, v%kin_r, dfftp%nnr, nspin, doublegrid ) end if !NOT_TO_BE_INCLUDED_END endif if(restart_gww <= 0 ) then !calculate coulomb potential by integration over q for PBC if(.not.l_truncated_coulomb) call calculate_vg0() !save KS wfcs if nspin==1 if(nspin==1) CALL davcio(evc,2*nwordwfc,iunwfc,1,1) !loop on spin do is=1,nspin IF (lsda) current_spin = isk(is) if(nspin/=1) CALL davcio(evc,2*nwordwfc,iunwfc,is,-1)!read wfcs for if(l_verbose) write(stdout,*) 'ATT1' call flush_unit(stdout) CALL wfc_gamma_real(0,is) call flush_unit(stdout) call energies_xc( npwx, npw, nbnd, evc, e_xc(:,is),e_h(:,is),is ) if( is == nspin) call write_energies_xc(e_xc) CALL flush_unit( stdout ) call go_wannier(iunwfc,1.d-9,40,num_nbndv(is), 0, is) call wfc_gamma_real(0,is) !if required save MLWF for plotting if(l_plot_mlwf) then call write_wfc_plot(0) endif !write transformation matrix u on file if(ionode ) call write_wannier_matrix(e_xc,e_h,is) do ii=1,nbnd call mp_barrier( world_comm ) call mp_bcast(u_trans(:,ii,is),ionode_id,world_comm) enddo !u_trans TO BE BROADCASTED enddo deallocate(evc) else deallocate(evc) endif write(stdout,*) 'USE RESTART: 1' call flush_unit(stdout) if(restart_gww <= 1) then !read coulomb potential for PBC if(.not.l_truncated_coulomb) call read_vg0 allocate( evc( npwx, nbnd ) ) !if required localize the valence wfcs if(pmat_type==2 .or. pmat_type==3 .or. pmat_type == 4) then call read_wannier_matrix allocate(tmp_rot(nbnd,nbnd)) endif do is=1,nspin call davcio(evc,2*nwordwfc,iunwfc,is,-1) ks_wfcs_diag(1:npw,1:nbnd,is)=evc(1:npw,1:nbnd) if(pmat_type==2 .or. pmat_type==3 .or. pmat_type == 4) then tmp_rot(:,:)=dble(u_trans(:,:,is)) call rotate_wannier_gamma( tmp_rot,1,0) endif ks_wfcs(1:npw,1:nbnd,is)=evc(1:npw,1:nbnd) enddo if(pmat_type==2 .or. pmat_type==3 .or. pmat_type == 4) deallocate(tmp_rot) !if required calculate optimal basis for products of valence wannier fncs times !fake conduction states if (pmat_type==3 .or. pmat_type==4) then if(l_verbose) write(stdout,*) 'Before fake_conduction_wannier' !ATTENZIONE call flush_unit(stdout) !nullify(fcw_state) !call fake_conduction_wannier(fcw_number,fcw_state,fcw_mat,pmat_cutoff,s_pmat)!,n_fast_pmat,off_fast_pmat,l_fast_pola) call start_clock('f_conduction') if(.not.lwannier) then if(.not.l_real) then call fake_conduction_wannier(pmat_cutoff,s_pmat,ks_wfcs,l_frac_occ,ks_wfcs_diag,l_cond_pol_base) else !NOT_TO_BE_INCLUDED_START call fake_conduction_real(pmat_cutoff,s_pmat,ks_wfcs,l_frac_occ,ks_wfcs_diag,l_cond_pol_base) !NOT_TO_BE_INCLUDED_END endif else !NOT_TO_BE_INCLUDED_START !still to be implemented with spin call fake_conduction_wannier_real(pmat_cutoff,s_pmat) !NOT_TO_BE_INCLUDED_END endif call stop_clock('f_conduction') if(l_verbose) write(stdout,*) 'After fake_conduction_wannier' !ATTENZIONE call flush_unit(stdout) call print_clock('f_conduction') call print_clock('mpsum') call print_clock('fc_optimal') call print_clock('fc_merge') call print_clock('fc_loop') call print_clock('fc_dgemm') deallocate(fcw_state,fcw_mat) endif !calculates the polarization basis diagonalizing the O matrix if(pmat_type==0 .or. pmat_type == 1 .or. pmat_type == 2) then allocate(v_states(dfftp%nnr,num_nbndv(1))) else allocate(v_states(1,1)) endif numw_prod_all=numw_prod if(extra_pw_cutoff>0.d0) call update_numwp(numw_prod_all, extra_pw_cutoff) allocate(o_basis(npw,numw_prod_all)) write(stdout,*) 'NUMW_PROD_ALL', numw_prod_all!DEBUG !calculate array of valence states in real space if(l_verbose) write(stdout,*) 'Call evc_to_real' call flush_unit(stdout) if(pmat_type==0 .or. pmat_type == 1 .or. pmat_type == 2) call evc_to_real(num_nbndv(1), v_states) !allocate and set trial product with random number if(l_verbose) write(stdout,*) 'Call o_basis_init' call flush_unit(stdout) !nullify(fcw_state) if(pmat_type==0 .or.pmat_type == 1 .or. pmat_type == 2) call o_basis_init(numw_prod,& & o_basis,num_nbndv(1),v_states,pmat_cutoff,pmat_type,fcw_number,fcw_state,fcw_mat,pmat_ethr) !diagonalize products if(l_verbose) write(stdout,*) 'Call o_bands' call flush_unit(stdout) call start_clock('o_bands') !note: v_states is relevant only for pmat_type == 0,1,2 call o_bands(num_nbndv(1), v_states,numw_prod,o_basis,pmat_ethr,pmat_cutoff,pmat_type) call stop_clock('o_bands') !write them to disk if(l_v_basis) then call v_basis(numw_prod,o_basis,v_cutoff) endif if(l_verbose) write(stdout,*) 'Call o_bands write' call flush_unit(stdout) !if PBC add also the last one the G=0 element !NOTE for PBC that numpw BECOMES numpw+1 AT THIS POINT, FOLLOWING ROUTINE !if required add plane waves to the basis obtained till now if(extra_pw_cutoff>0.d0) then call o_extra_pw( o_basis, numw_prod, numw_prod_all,extra_pw_cutoff) endif call o_basis_write(numw_prod, o_basis,.true.,ecutoff_global,.not.l_truncated_coulomb) !deallocate arrays deallocate(v_states,o_basis) deallocate(evc) if(.not.l_zero) then call wannier_uterms(nset,.false.,.false.,2, ecutoff_global) CALL flush_unit( stdout ) allocate(uterms(numw_prod,numw_prod)) if(ionode) then iunuterms = find_free_unit() open( unit= iunuterms, file=trim(tmp_dir)//trim(prefix)//'.uterms', status='old',form='unformatted') endif allocate(uterms_tmp(numw_prod)) do iw=1,numw_prod if(ionode) read(iunuterms) uterms_tmp(1:iw) call mp_bcast(uterms_tmp(1:iw), ionode_id,world_comm) do jw=1,iw uterms(iw,jw)=uterms_tmp(jw) uterms(jw,iw)=uterms(iw,jw) enddo enddo deallocate(uterms_tmp) if(ionode) close(iunuterms) if(ionode) call write_vpot_matrix(uterms,0) deallocate(uterms) CALL flush_unit( stdout ) else write(stdout,*) 'NOT LZERO NOT IMPLEMENTED' call flush_unit(stdout) stop endif if(l_verbose) write(stdout,*) 'OUT OF RESTART_GWW1',numw_prod call flush_unit(stdout) call mp_barrier( world_comm ) endif if(restart_gww <= 2 ) then !read coulomb potential for PBC write(stdout,*) 'USE RESTART: 2 LANCZOS RESTART:0' call flush_unit(stdout) if(.not.l_truncated_coulomb) call read_vg0 if(l_big_system.and.l_list) then !read list of KS state for which the self-energy will be calculated if(ionode) then iun = find_free_unit() open( unit=iun, file='list_1.dat', status='old') read(iun,*) n_list(1) if(nspin==2) then iun2 = find_free_unit() open( unit=iun2, file='list_2.dat', status='old') read(iun,*) n_list(2) else n_list(2)=0 endif endif call mp_bcast(n_list,ionode_id,world_comm) allocate(i_list(max(n_list(1),n_list(2)),2)) i_list=0 if(ionode) then do ii=1,n_list(1) read(iun,*) i_list(ii,1) enddo close(iun) if(nspin==2) then do ii=1,n_list(2) read(iun2,*) i_list(ii,2) enddo close(iun2) endif endif call mp_bcast(i_list,ionode_id,world_comm) s_first_state=1 s_last_state=num_nbnds endif do is=1,nspin IF (lsda) current_spin = isk(is) allocate( evc( npwx, nbnd ) ) call davcio(evc,2*nwordwfc,iunwfc,is,-1) !if required calculate partial occupancies factors if(l_frac_occ) then !NOT_TO_BE_INCLUDED_START call pola_partial(numw_prod,is) !NOT_TO_BE_INCLUDED_END endif !if EXX is one calculates stuff for Fock operator if(dft_is_hybrid()) then !NOT_TO_BE_INCLUDED_START call exxinit current_k= 1 !NOT_TO_BE_INCLUDED_END endif call read_wannier_matrix allocate(tmp_rot(nbnd,nbnd)) tmp_rot(1:nbnd,1:nbnd)=dble(u_trans(1:nbnd,1:nbnd,is)) if(l_t_wannier) call rotate_wannier_gamma( tmp_rot,1,0) deallocate(tmp_rot) if(n_pola_lanczos > numw_prod) n_pola_lanczos=numw_prod if(n_self_lanczos > numw_prod) n_self_lanczos=numw_prod if(n_pola_lanczos_eff == 0) n_pola_lanczos_eff=n_pola_lanczos if(n_self_lanczos_eff == 0) n_self_lanczos_eff=n_self_lanczos if(lanczos_restart <= 0) then call start_clock('pola_basis') if(.not.l_real) then call pola_basis_lanczos(nset,n_pola_lanczos,numw_prod,nsteps_lanczos_pola,is) else !NOT_TO_BE_INCLUDED_START call pola_basis_lanczos_real(nset,n_pola_lanczos,numw_prod,nsteps_lanczos_pola,is) !NOT_TO_BE_INCLUDED_END endif call stop_clock('pola_basis') endif write(stdout,*) 'USE RESTART: 2 LANCZOS_RESTART:1' call flush_unit(stdout) if(lanczos_restart <= 1) then call start_clock('global_pola') call davcio(evc,2*nwordwfc,iunwfc,is,-1)!re-read for testing and for selfconsistency call global_pola_lanczos(n_pola_lanczos,n_pola_lanczos_eff,s_pola_lanczos,nump_lanczos,& nsteps_lanczos_pola,numw_prod,is,l_ts_eigen) call stop_clock('global_pola') endif write(stdout,*) 'USE RESTART: 2 LANCZOS_RESTART:2' call flush_unit(stdout) if(lanczos_restart <= 2) then call start_clock('self_basis') call davcio(evc,2*nwordwfc,iunwfc,is,-1) if(.not.l_real) then call self_basis_lanczos(nset,n_self_lanczos,numw_prod,nsteps_lanczos_self,is,l_full,n_full) else !NOT_TO_BE_INCLUDED_START call self_basis_lanczos_real(nset,n_self_lanczos,numw_prod,nsteps_lanczos_self,is) !NOT_TO_BE_INCLUDED_END endif call stop_clock('self_basis') call print_clock('self_basis') call print_clock('sl_loop') call print_clock('sl_dgemm') call print_clock('sl_dsyevX') call print_clock('sl_mpbcast') call print_clock('sl_merge') endif CALL flush_unit( stdout ) ! ALLOCATE( evc( npwx, nbnd ) ) ! deallocate(evc) write(stdout,*) 'USE RESTART: 2 LANCZOS_RESTART:3' call flush_unit(stdout) if(lanczos_restart <= 3) then ! CALL davcio(evc,2*nwordwfc,iunwfc,1,-1) ! CALL dft_exchange(num_nbndv,num_nbnds,nset,e_x) ! CALL flush_unit( stdout ) call mp_barrier( world_comm ) call davcio(evc,2*nwordwfc,iunwfc,is,-1) call start_clock('global_self') if(.not.l_big_system) then call global_self_lanczos(n_self_lanczos,n_self_lanczos_eff,s_self_lanczos,nums_lanczos,& nsteps_lanczos_self,numw_prod,s_g_lanczos,is,l_ts_eigen,1,l_full) else if(.not.l_list) then do istate=s_first_state,s_last_state call global_self_lanczos(n_self_lanczos,n_self_lanczos_eff,s_self_lanczos,nums_lanczos,& nsteps_lanczos_self,numw_prod,s_g_lanczos,is,l_ts_eigen,istate,l_full) enddo else do ii=1,n_list(is) istate=i_list(ii,is) call global_self_lanczos(n_self_lanczos,n_self_lanczos_eff,s_self_lanczos,nums_lanczos,& nsteps_lanczos_self,numw_prod,s_g_lanczos,is,l_ts_eigen,istate,l_full) enddo endif endif call stop_clock('global_self') endif deallocate(evc) ! if(.not.l_truncated_coulomb) call calculate_wing(nset,2) enddo if(l_big_system.and.l_list) deallocate(i_list) endif write(stdout,*) 'USE RESTART: 3 LANCZOS_RESTART /=2,3' call flush_unit(stdout) if(restart_gww <= 3 .and. lanczos_restart /=3 .and. lanczos_restart /=2 ) then !ATTENZIONE RESTART lanczos_restart never been here! !read coulomb potential for PBC if(.not.l_truncated_coulomb) call read_vg0 if(.not.l_truncated_coulomb) call calculate_wing(nset,2) CALL flush_unit( stdout ) ALLOCATE( evc( npwx, nbnd ) ) do is=1,nspin CALL davcio(evc,2*nwordwfc,iunwfc,is,-1) ks_wfcs(1:npw,1:nbnd,is)=evc(1:npw,1:nbnd) enddo CALL dft_exchange(num_nbndv,num_nbnds,nset,e_x,ks_wfcs) CALL flush_unit( stdout ) !DEBUG TEST if(l_verbose) then if(nspin==1) then num_nbndv_max=num_nbndv(1) else num_nbndv_max=max(num_nbndv(1),num_nbndv(2)) endif CALL setup_exx_cus(nspin,num_nbndv_max,num_nbndv,evc, exx_cus, 1.d0, 40.d0, truncation_radius) CALL dft_exchange_fast(1,num_nbnds,ks_wfcs(:,:,1),exx_cus) write(stdout,*) 'BEFORE periodic_dft_exchange' call flush_unit(stdout) !CALL periodic_dft_exchange(exx_cus) write(stdout,*) 'AFTER periodic_dft_exchange' call flush_unit(stdout) call free_memory_exx_cus(exx_cus) endif deallocate(evc) endif write(stdout,*) 'USE RESTART: 4 LANCZOS_RESTART /=2,3' call flush_unit(stdout) if(restart_gww <= 4 .and. l_semicore .and. lanczos_restart /=3 .and. lanczos_restart /=2) then !NOT_TO_BE_INCLUDED_START allocate( evc( npwx, nbnd ) ) do is=1,nspin CALL davcio(evc,2*nwordwfc,iunwfc,is,-1) call semicore(n_semicore, num_nbnds,is) enddo deallocate(evc) !NOT_TO_BE_INCLUDED_END endif write(stdout,*) 'USE RESTART: 5 LANCZOS_RESTART /=2,3' call flush_unit(stdout) if(restart_gww <= 5 .and. l_semicore_read .and. lanczos_restart /=3 .and. lanczos_restart /=2) then !NOT_TO_BE_INCLUDED_START if(.not.l_truncated_coulomb) call read_vg0 allocate( evc( npwx, nbnd ) ) do is=1,nspin CALL davcio(evc,2*nwordwfc,iunwfc,is,-1) call semicore_read(num_nbnds,numw_prod,is) enddo deallocate(evc) !NOT_TO_BE_INCLUDED_END endif !NOT_TO_BE_INCLUDED_START if(restart_gww<=6 .and. l_full) then call write_pola_basis(numw_prod) endif if (l_bse) then call read_wannier_matrix allocate(tmp_rot(nbnd,nbnd)) allocate( evc( npwx, nbnd ) ) do is=1,nspin allocate(o_mat(num_nbndv(is),num_nbndv(is))) call davcio(evc,2*nwordwfc,iunwfc,is,-1) tmp_rot(:,:)=dble(u_trans(:,:,is)) call rotate_wannier_gamma( tmp_rot,1,0) if(.not.l_truncated_coulomb) call read_vg0 call wannier_bse(is,evc,o_mat) deallocate(o_mat) enddo deallocate(tmp_rot) deallocate(evc) endif !NOT_TO_BE_INCLUDED_END deallocate(e_xc,e_h,e_x) deallocate(ks_wfcs,ks_wfcs_diag) write(stdout,*) 'PW4GWW COMPLETED' call stop_clock('produce_wannier') call print_clock('produce_wannier') call print_clock('f_conduction') call print_clock('o_bands') call print_clock('pola_basis') call print_clock('global_pola') call print_clock('self_basis') call print_clock('cft3t') call print_clock('h_psi') call print_clock('fft') call print_clock('ffts') call print_clock('fftw') call print_clock('davcio') call print_clock('mpsum') call print_clock('global_self') call print_clock('lanczos_state') call flush_unit(stdout) return END SUBROUTINE produce_wannier_gamma GWW/pw4gww/semicore.f900000644000077300007730000001222612341332532015400 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !this routine calculate the terms \psi_i(r)\_psi_v(sc)(r) !and write them on disk on global G grid subroutine semicore(n_semicore, num_nbnds,ispin) !NOT_TO_BE_INCLUDED_START USE io_global, ONLY : stdout, ionode,ionode_id USE io_files, ONLY : diropn,prefix,tmp_dir, iunigk use pwcom USE wavefunctions_module, ONLY : evc USE kinds, ONLY : DP USE gvect, ONLY : ig_l2g USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_wave, ONLY : mergewf,splitwf USE mp_pools, ONLY : intra_pool_comm, inter_pool_comm, intra_pool_comm USE mp_world, ONLY : world_comm, mpime, nproc USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft USE wavefunctions_module, ONLY : psic USE wvfct, ONLY : et implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER, INTENT(in) :: n_semicore!number of semicore states INTEGER, INTENT(in) :: num_nbnds!total KS states considered INTEGER, INTENT(in) :: ispin!spin channel REAL(kind=DP), ALLOCATABLE :: psi_sc(:,:) COMPLEX(kind=DP), ALLOCATABLE :: prod(:), prod_g(:,:), prod_g_tot(:) INTEGER :: iv, iun, ii INTEGER :: npwx_g !fft trasform semicore states to R space allocate(psi_sc(dfftp%nnr,n_semicore)) allocate(prod(dfftp%nnr), prod_g(npw,2),prod_g_tot(ngm_g)) do iv=1,n_semicore,2 psic(:)=(0.d0,0.d0) if(iv ! spsi(1:npw)=psi(1:npw,m) ! ! ... orthogonalize starting eigenfunction to those already calculated ! CALL DGEMV( 'T', npw2, m, 2.D0, psi, npwx2, spsi, 1, 0.D0, lagrange, 1 ) ! IF ( gstart == 2 ) lagrange(1:m) = lagrange(1:m) - psi(1,1:m) * spsi(1) ! CALL mp_sum( lagrange( 1:m ), world_comm) ! psi_norm = lagrange(m) ! DO j = 1, m - 1 ! psi(:,m) = psi(:,m) - lagrange(j) * psi(:,j) ! psi_norm = psi_norm - lagrange(j)**2 ! END DO ! psi_norm = SQRT( psi_norm ) ! psi(:,m) = psi(:,m) / psi_norm ! ... set Im[ psi(G=0) ] - needed for numerical stability IF ( gstart == 2 ) psi(1,m) = CMPLX( DBLE(psi(1,m)), 0.D0 ,kind=DP) ! ! ... calculate starting gradient (|hpsi> = H|psi>) ... ! !CALL h_1psi( npwx, npw, psi(1,m), hpsi, spsi ) call o_1psi_gamma( numv, v_states, psi(1,m), hpsi,.false.,hdiag, ptype,fcw_number,fcw_state,fcw_mat,ethr) spsi(1:npw)=psi(1:npw,m) ! ! ... and starting eigenvalue (e = = ) ! ! ... NB: ddot(2*npw,a,1,b,1) = DBLE( zdotc(npw,a,1,b,1) ) ! e(m) = 2.D0 * ddot( npw2, psi(1,m), 1, hpsi, 1 ) ! IF ( gstart == 2 ) e(m) = e(m) - psi(1,m) * hpsi(1) ! CALL mp_sum( e(m), world_comm) ! ! ... start iteration for this band ! iterate: DO iter = 1, maxter ! ! ... calculate P (PHP)|y> ! ... ( P = preconditioning matrix, assumed diagonal ) ! g(1:npw) = hpsi(1:npw)! / precondition(:) ppsi(1:npw) = spsi(1:npw)! / precondition(:) ! ! ... ppsi is now S P(P^2)|y> = S P^2|psi>) ! es(1) = 2.D0 * ddot( npw2, spsi(1), 1, g(1), 1 ) es(2) = 2.D0 * ddot( npw2, spsi(1), 1, ppsi(1), 1 ) ! IF ( gstart == 2 ) THEN ! es(1) = es(1) - spsi(1) * g(1) es(2) = es(2) - spsi(1) * ppsi(1) ! END IF ! CALL mp_sum( es, world_comm ) ! es(1) = es(1) / es(2) ! g(:) = g(:) - es(1) * ppsi(:) ! ! ... e1 = / ensures that ! ... = 0 ! ! ... orthogonalize to lowest eigenfunctions (already calculated) ! ! ... scg is used as workspace ! !CALL s_1psi( npwx, npw, g(1), scg(1) ) scg(1:npw)=g(1:npw) ! CALL DGEMV( 'T', npw2, ( m - 1 ), 2.D0, & psi, npwx2, scg, 1, 0.D0, lagrange, 1 ) ! IF ( gstart == 2 ) & lagrange(1:m-1) = lagrange(1:m-1) - psi(1,1:m-1) * scg(1) ! CALL mp_sum( lagrange( 1 : m-1 ), world_comm) ! DO j = 1, ( m - 1 ) ! g(:) = g(:) - lagrange(j) * psi(:,j) scg(:) = scg(:) - lagrange(j) * psi(:,j) ! END DO ! IF ( iter /= 1 ) THEN ! ! ... gg1 is (used in Polak-Ribiere formula) ! gg1 = 2.D0 * ddot( npw2, g(1), 1, g0(1), 1 ) ! IF ( gstart == 2 ) gg1 = gg1 - g(1) * g0(1) ! CALL mp_sum( gg1, world_comm ) ! END IF ! ! ... gg is ! g0(:) = scg(:) ! g0(1:npw) = g0(1:npw)! * precondition(:) ! gg = 2.D0 * ddot( npw2, g(1), 1, g0(1), 1 ) ! IF ( gstart == 2 ) gg = gg - g(1) * g0(1) ! CALL mp_sum( gg, world_comm ) ! IF ( iter == 1 ) THEN ! ! ... starting iteration, the conjugate gradient |cg> = |g> ! gg0 = gg ! cg(:) = g(:) ! ELSE ! ! ... |cg(n+1)> = |g(n+1)> + gamma(n) * |cg(n)> ! ! ... Polak-Ribiere formula : ! gamma = ( gg - gg1 ) / gg0 gg0 = gg ! cg(:) = cg(:) * gamma cg(:) = g + cg(:) ! ! ... The following is needed because ! ... is not 0. In fact : ! ... = sin(theta)* ! psi_norm = gamma * cg0 * sint ! cg(:) = cg(:) - psi_norm * psi(:,m) ! END IF ! ! ... |cg> contains now the conjugate gradient ! ... set Im[ cg(G=0) ] - needed for numerical stability IF ( gstart == 2 ) cg(1) = CMPLX( DBLE(cg(1)), 0.D0 ,kind=DP) ! ! ... |scg> is S|cg> ! !CALL h_1psi( npwx, npw, cg(1), ppsi(1), scg(1) ) call o_1psi_gamma( numv, v_states, cg, ppsi,.false.,hdiag, ptype,fcw_number,fcw_state,fcw_mat,ethr) sca=0.d0 do ig=1,npw sca=sca+2.d0*dble(conjg(cg(ig))*ppsi(ig)) enddo if(gstart==2) sca=sca-dble(conjg(cg(1))*ppsi(1)) call mp_sum(sca, world_comm) scg(1:npw)=cg(1:npw) ! cg0 = 2.D0 * ddot( npw2, cg(1), 1, scg(1), 1 ) ! IF ( gstart == 2 ) cg0 = cg0 - cg(1) * scg(1) ! CALL mp_sum( cg0, world_comm ) ! cg0 = SQRT( cg0 ) ! ! ... |ppsi> contains now HP|cg> ! ... minimize , where : ! ... |y(t)> = cos(t)|y> + sin(t)/cg0 |cg> ! ... Note that = 1, = 0 , ! ... = cg0^2 ! ... so that the result is correctly normalized : ! ... = 1 ! a0 = 4.D0 * ddot( npw2, psi(1,m), 1, ppsi(1), 1 ) ! IF ( gstart == 2 ) a0 = a0 - 2.D0 * psi(1,m) * ppsi(1) ! a0 = a0 / cg0 ! CALL mp_sum( a0, world_comm ) ! b0 = 2.D0 * ddot( npw2, cg(1), 1, ppsi(1), 1 ) ! IF ( gstart == 2 ) b0 = b0 - cg(1) * ppsi(1) ! b0 = b0 / cg0**2 ! CALL mp_sum( b0, world_comm ) ! e0 = e(m) ! theta = 0.5D0 * ATAN( a0 / ( e0 - b0 ) ) ! cost = COS( theta ) sint = SIN( theta ) ! cos2t = cost*cost - sint*sint sin2t = 2.D0*cost*sint ! es(1) = 0.5D0 * ( ( e0 - b0 ) * cos2t + a0 * sin2t + e0 + b0 ) es(2) = 0.5D0 * ( - ( e0 - b0 ) * cos2t - a0 * sin2t + e0 + b0 ) ! ! ... there are two possible solutions, choose the minimum ! IF ( es(2) < es(1) ) THEN ! theta = theta + 0.5D0 * pi ! cost = COS( theta ) sint = SIN( theta ) ! END IF ! ! ... new estimate of the eigenvalue ! e(m) = MIN( es(1), es(2) ) ! ! ... upgrade |psi> ! psi(:,m) = cost * psi(:,m) + sint / cg0 * cg(:) ! ! ... here one could test convergence on the energy ! ! IF ( ABS( e(m) - e0 ) < ethr ) EXIT iterate ! ! ! ... upgrade H|psi> and S|psi> ! spsi(:) = cost * spsi(:) + sint / cg0 * scg(:) ! hpsi(:) = cost * hpsi(:) + sint / cg0 * ppsi(:) ! END DO iterate ! IF ( iter >= maxter ) notconv = notconv + 1 ! avg_iter = avg_iter + iter + 1 ! ! ... reorder eigenvalues if they are not in the right order ! ... ( this CAN and WILL happen in not-so-special cases ) ! IF ( m > 1 .AND. reorder ) THEN ! IF ( e(m) - e(m-1) < - 2.D0 * ethr ) THEN ! ! ... if the last calculated eigenvalue is not the largest... ! DO i = m - 2, 1, - 1 ! IF ( e(m) - e(i) > 2.D0 * ethr ) EXIT ! END DO ! i = i + 1 ! moved = moved + 1 ! ! ... last calculated eigenvalue should be in the ! ... i-th position: reorder ! e0 = e(m) ! ppsi(:) = psi(:,m) ! DO j = m, i + 1, - 1 ! e(j) = e(j-1) ! psi(:,j) = psi(:,j-1) ! END DO ! e(i) = e0 ! psi(:,i) = ppsi(:) ! ! ... this procedure should be good if only a few inversions occur, ! ... extremely inefficient if eigenvectors are often in bad order ! ... ( but this should not happen ) ! END IF ! END IF ! END DO ! avg_iter = avg_iter / DBLE( nbnd ) ! DEALLOCATE( lagrange ) DEALLOCATE( ppsi ) DEALLOCATE( g0 ) DEALLOCATE( cg ) DEALLOCATE( g ) DEALLOCATE( hpsi ) DEALLOCATE( scg ) DEALLOCATE( spsi ) ! CALL stop_clock( 'rcgdiagg' ) ! RETURN ! END SUBROUTINE o_rcgdiagg ! !---------------------------------------------------------------------------- SUBROUTINE o_1psi_gamma( numv, v_states, psi, opsi,l_freq,hdiag, ptype,fcw_number,fcw_state,fcw_mat,ethr) !---------------------------------------------------------------------------- ! ! !this subroutines applies the O oprator to a state psi !IT WORKS ONLY FOR NORMCONSERVING PSEUDOPOTENTIALS !the valence states in G space must be in evc ! Gamma point version USE io_global, ONLY : stdout, ionode, ionode_id USE kinds, ONLY : DP USE wannier_gw USE gvect USE constants, ONLY : e2, pi, tpi, fpi USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2 USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, et USE wavefunctions_module, ONLY : evc, psic USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : world_comm, mpime, nproc USE gvecs, ONLY : nls, nlsm, doublegrid USE kinds, ONLY : DP USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft USE becmod, ONLY : becp,allocate_bec_type,deallocate_bec_type USE uspp, ONLY : vkb, nkb, okvan USE g_psi_mod, ONLY : h_diag, s_diag USE klist, ONLY : xk ! IMPLICIT NONE INTEGER, INTENT(in) :: numv!number of valence states REAL(kind=DP), INTENT(in) :: v_states(dffts%nnr,numv)!valence states in real space COMPLEX(kind=DP), INTENT(in) :: psi(npw)!input wavefunction COMPLEX(kind=DP), INTENT(out) :: opsi(npw)!O|\psi> LOGICAL, INTENT(in) :: l_freq!if true estimates the operator a 0 frequency REAL(kind=DP), INTENT(in) :: hdiag(npw)!inverse of estimation of diagonal part of hamiltonian INTEGER, INTENT(in) :: ptype!type of approximation for O operator INTEGER, INTENT(in) :: fcw_number!number of "fake conduction" states for O matrix method COMPLEX(kind=DP) :: fcw_state(npw,fcw_number)! "fake conduction" states for O matrix method REAL(kind=DP) :: fcw_mat(fcw_number,fcw_number)! "fake conduction" matrix REAL(kind=DP), INTENT(in) :: ethr!threshold on (H-e) inversion REAL(kind=DP), ALLOCATABLE :: psi_r(:,:), psi_v(:) COMPLEX(kind=DP), ALLOCATABLE :: psi_g(:,:), h_psi_g(:,:),s_psi_g(:,:) REAL(kind=DP) :: ec INTEGER :: iv,ii,jj,ig REAL(kind=DP),ALLOCATABLE :: p_terms(:),s_terms(:) INTEGER :: l_blk,nbegin,nend,nsize !REAL(kind=DP), ALLOCATABLE :: h_diag (:,:) COMPLEX(kind=DP), ALLOCATABLE :: psi_g2(:,:) INTEGER :: kter LOGICAL :: lconv_root,lfirst REAL(kind=DP) :: anorm EXTERNAL :: hpsi_pw4gww,cg_psi_pw4gww COMPLEX(kind=DP), POINTER, SAVE :: tmp_psi(:,:) allocate(psi_r(dffts%nnr,2),psi_v(dffts%nnr)) if(pmat_type/=0) then allocate(h_psi_g(npw,2),s_psi_g(npw,2),psi_g(npw,2)) else allocate(h_psi_g(npw,numv),s_psi_g(npw,numv),psi_g(npw,numv)) endif !fourier transform psi to R space opsi(1:npw)=(0.d0,0.d0) if(pmat_type==0 .or. pmat_type==1 .or. pmat_type==2) then psic(:)=(0.d0,0.d0) psic(nls(1:npw)) = psi(1:npw) psic(nlsm(1:npw)) = CONJG( psi(1:npw) ) CALL invfft ('Wave', psic, dffts) psi_v(:)= DBLE(psic(:)) endif if(pmat_type==0) then call start_clock('opsi_total') call allocate_bec_type ( nkb, numv, becp) IF ( nkb > 0 ) CALL init_us_2( npw, igk, xk(1,1), vkb ) if(.not.associated(tmp_psi)) then allocate( tmp_psi(npw,num_nbndv(1))) lfirst=.true. else lfirst=.false. endif allocate (h_diag(npw, numv),s_diag(npw,numv)) allocate(psi_g2(npw,numv)) ! ! compute the kinetic energy ! do ig = 1, npw g2kin (ig) = ( g (1,ig)**2 + g (2,ig)**2 + g (3,ig)**2 ) * tpiba2 enddo h_diag=0.d0 do iv = 1, numv do ig = 1, npw !h_diag(ig,ibnd)=1.d0/max(1.0d0,g2kin(ig)/eprec(ibnd,ik)) !h_diag(ig,iv) = 1.D0 + g2kin(ig) + & ! SQRT( 1.D0 + ( g2kin(ig) - 1.D0 )**2 ) h_diag(ig,iv)=g2kin(ig) !h_diag(ig,iv)=1.d0/max(1.0d0,g2kin(ig)/8.d0) enddo enddo do iv=1,numv,2 !!product with psi_v if(iv/=numv) then psi_r(1:dffts%nnr,1)=psi_v(1:dffts%nnr)*v_states(1:dffts%nnr, iv) psi_r(1:dffts%nnr,2)=psi_v(1:dffts%nnr)*v_states(1:dffts%nnr, iv+1) else psi_r(1:dffts%nnr,1)=psi_v(1:dffts%nnr)*v_states(1:dffts%nnr, iv) endif !!fourier transfrm to G if(iv/=numv) then psic(1:dffts%nnr)=cmplx(psi_r(1:dffts%nnr,1),psi_r(1:dffts%nnr,2)) else psic(1:dffts%nnr)=cmplx(psi_r(1:dffts%nnr,1),0.d0) endif call start_clock('opsi_fft') CALL fwfft ('Wave', psic, dffts) call stop_clock('opsi_fft') if(iv/=numv) then psi_g(1:npw,iv)=0.5d0*(psic(nls(1:npw))+conjg(psic(nlsm(1:npw)))) psi_g(1:npw,iv+1)=(0.d0,-0.5d0)*(psic(nls(1:npw))-conjg(psic(nlsm(1:npw)))) if(gstart==2) psi_g(1,iv)=dble(psi_g(1,iv)) if(gstart==2) psi_g(1,iv+1)=dble(psi_g(1,iv+1)) else psi_g(1:npw,iv)=psic(nls(1:npw)) if(gstart==2) psi_g(1,iv)=dble(psi_g(1,iv)) endif !!project on conduction manifold call start_clock('opsi_pc') if(iv/=numv) then call pc_operator(psi_g(:,iv),1,.false.) call pc_operator(psi_g(:,iv+1),1,.false.) else call pc_operator(psi_g(:,iv),1,.false.) endif call stop_clock('opsi_pc') enddo write(stdout,*) 'DEBUG1' call flush_unit(stdout) !call (H-e)^-1 solver if(.true.) then psi_g2(1:npw,1:numv)=psi_g(1:npw,1:numv) else psi_g2(1:npw,1:numv)=tmp_psi(1:npw,1:numv) endif write(stdout,*) 'DEBUG1.5' call flush_unit(stdout) call cgsolve_all_gamma (hpsi_pw4gww,cg_psi_pw4gww,et(1,1),psi_g,psi_g2, & h_diag,npw,npw,ethr,1,kter,lconv_root,anorm,numv,1) tmp_psi(1:npw,1:numv)=psi_g2(1:npw,1:numv) write(stdout,*) 'DEBUG2',kter,lconv_root,anorm call flush_unit(stdout) do iv=1,numv,2 !!project on conduction manifold call start_clock('opsi_pc') if(iv/=numv) then call pc_operator(psi_g2(:,iv),1,.false.) call pc_operator(psi_g2(:,iv+1),1,.false.) else call pc_operator(psi_g2(:,iv),1,.false.) endif call stop_clock('opsi_pc') !!fourier transform to R space psic(:)=(0.d0,0.d0) if(iv/=numv) then psic(nls(1:npw)) = psi_g2(1:npw,iv)+(0.d0,1.d0)*psi_g2(1:npw,iv+1) psic(nlsm(1:npw)) = CONJG( psi_g2(1:npw,iv) )+(0.d0,1.d0)*conjg(psi_g2(1:npw,iv+1)) else psic(nls(1:npw)) = psi_g2(1:npw,iv) psic(nlsm(1:npw)) = CONJG( psi_g2(1:npw,iv) ) endif call start_clock('opsi_fft') CALL invfft ('Wave', psic, dffts) call stop_clock('opsi_fft') if(iv/=numv) then psi_r(:,1)= DBLE(psic(:)) psi_r(:,2)= dimag(psic(:)) else psi_r(:,1)= DBLE(psic(:)) endif !!product with psi_v if(iv/=numv) then psi_r(1:dffts%nnr,1)=psi_r(1:dffts%nnr,1)*v_states(1:dffts%nnr,iv) psi_r(1:dffts%nnr,2)=psi_r(1:dffts%nnr,2)*v_states(1:dffts%nnr,iv+1) else psi_r(1:dffts%nnr,1)=psi_r(1:dffts%nnr,1)*v_states(1:dffts%nnr,iv) endif !!fourier transform in G space!! sum up results !!TAKE CARE OF SIGN if(iv/=numv) then psic(:)=cmplx(psi_r(:,1),psi_r(:,2)) else psic(:)=cmplx(psi_r(:,1),0.d0) endif CALL fwfft ('Wave', psic, dffts) if(iv/=numv) then opsi(1:npw)=opsi(1:npw)-0.5d0*(psic(nls(1:npw))+conjg(psic(nlsm(1:npw)))) opsi(1:npw)=opsi(1:npw)-(0.d0,-0.5d0)*(psic(nls(1:npw))-conjg(psic(nlsm(1:npw)))) else opsi(1:npw)=opsi(1:npw)-psic(nls(igk(1:npw))) endif enddo deallocate(h_diag,s_diag) deallocate(psi_g2) call deallocate_bec_type(becp) call stop_clock('opsi_total') ! call print_clock('opsi_total') ! call print_clock('opsi_fft') ! call print_clock('opsi_pc') else if(pmat_type==1) then !loop on v call start_clock('opsi_total') do iv=1,numv,2 !!product with psi_v if(iv/=numv) then psi_r(1:dffts%nnr,1)=psi_v(1:dffts%nnr)*v_states(1:dffts%nnr, iv) psi_r(1:dffts%nnr,2)=psi_v(1:dffts%nnr)*v_states(1:dffts%nnr, iv+1) else psi_r(1:dffts%nnr,1)=psi_v(1:dffts%nnr)*v_states(1:dffts%nnr, iv) endif !!fourier transfrm to G if(iv/=numv) then psic(1:dffts%nnr)=cmplx(psi_r(1:dffts%nnr,1),psi_r(1:dffts%nnr,2)) else psic(1:dffts%nnr)=cmplx(psi_r(1:dffts%nnr,1),0.d0) endif call start_clock('opsi_fft') CALL fwfft ('Wave', psic, dffts) call stop_clock('opsi_fft') if(iv/=numv) then psi_g(1:npw,1)=0.5d0*(psic(nls(1:npw))+conjg(psic(nlsm(1:npw)))) psi_g(1:npw,2)=(0.d0,-0.5d0)*(psic(nls(1:npw))-conjg(psic(nlsm(1:npw)))) if(gstart==2) psi_g(1,1)=dble(psi_g(1,1)) if(gstart==2) psi_g(1,2)=dble(psi_g(1,2)) else psi_g(1:npw,1)=psic(nls(1:npw)) if(gstart==2) psi_g(1,1)=dble(psi_g(1,1)) endif !!project on conduction manifold call start_clock('opsi_pc') if(iv/=numv) then call pc_operator(psi_g(:,1),1,.false.) call pc_operator(psi_g(:,2),1,.false.) else call pc_operator(psi_g(:,1),1,.false.) endif !call pc_operator_test(psi_g) if(l_freq) then ! call cgsolve_all_gamma (h_psi, cg_psi, e, d0psi, dpsi, h_diag, & ! ndmx, ndim, ethr, ik, kter, conv_root, anorm, nbnd, npol) endif call stop_clock('opsi_pc') !!fourier transform to R space psic(:)=(0.d0,0.d0) if(iv/=numv) then psic(nls(1:npw)) = psi_g(1:npw,1)+(0.d0,1.d0)*psi_g(1:npw,2) psic(nlsm(1:npw)) = CONJG( psi_g(1:npw,1) )+(0.d0,1.d0)*conjg(psi_g(1:npw,2)) else psic(nls(1:npw)) = psi_g(1:npw,1) psic(nlsm(1:npw)) = CONJG( psi_g(1:npw,1) ) endif call start_clock('opsi_fft') CALL invfft ('Wave', psic, dffts) call stop_clock('opsi_fft') if(iv/=numv) then psi_r(:,1)= DBLE(psic(:)) psi_r(:,2)= dimag(psic(:)) else psi_r(:,1)= DBLE(psic(:)) endif !!product with psi_v if(iv/=numv) then psi_r(1:dffts%nnr,1)=psi_r(1:dffts%nnr,1)*v_states(1:dffts%nnr,iv) psi_r(1:dffts%nnr,2)=psi_r(1:dffts%nnr,2)*v_states(1:dffts%nnr,iv+1) else psi_r(1:dffts%nnr,1)=psi_r(1:dffts%nnr,1)*v_states(1:dffts%nnr,iv) endif !!fourier transform in G space !! sum up results !!TAKE CARE OF SIGN if(iv/=numv) then psic(:)=cmplx(psi_r(:,1),psi_r(:,2)) else psic(:)=cmplx(psi_r(:,1),0.d0) endif CALL fwfft ('Wave', psic, dffts) if(iv/=numv) then opsi(1:npw)=opsi(1:npw)-0.5d0*(psic(nls(1:npw))+conjg(psic(nlsm(1:npw)))) opsi(1:npw)=opsi(1:npw)-(0.d0,-0.5d0)*(psic(nls(1:npw))-conjg(psic(nlsm(1:npw)))) else opsi(1:npw)=opsi(1:npw)-psic(nls(igk(1:npw))) endif enddo call stop_clock('opsi_total') ! call print_clock('opsi_total') ! call print_clock('opsi_fft') ! call print_clock('opsi_pc') else if(pmat_type==2) then psi_r(:,1)=0.d0 do iv=1,numv psi_r(1:dffts%nnr,1)=psi_r(1:dffts%nnr,1)+psi_v(1:dffts%nnr)*v_states(1:dffts%nnr, iv) enddo psic(:)=cmplx(psi_r(:,1),0.d0) CALL fwfft ('Wave', psic, dffts) psi_g(1:npw,1)=psic(nls(igk(1:npw))) if(gstart==2) psi_g(1,1)=dble(psi_g(1,1)) call pc_operator(psi_g(:,1),1,.false.) psi_g(1:npw,1)=psi_g(1:npw,1)*hdiag(1:npw) call pc_operator(psi_g(:,1),1,.false.) psic(nls(igk(1:npw))) = psi_g(1:npw,1) psic(nlsm(igk(1:npw))) = CONJG( psi_g(1:npw,1) ) CALL invfft ('Wave', psic, dffts) psi_r(:,1)=dble(psic(:)) psi_v(:)= psi_r(:,1) psi_r(:,1)=0.d0 do iv=1,numv psi_r(1:dffts%nnr,1)=psi_r(1:dffts%nnr,1)+psi_v(1:dffts%nnr)*v_states(1:dffts%nnr, iv) enddo psic(:)=cmplx(psi_r(:,1),0.d0) CALL fwfft ('Wave', psic, dffts) opsi(1:npw)=-psic(nls(igk(1:npw))) else!cases 3,4 !form scalar products allocate(p_terms(fcw_number),s_terms(fcw_number)) call dgemm('T','N',fcw_number,1,2*npw,2.d0,fcw_state,2*npw,psi,2*npw,0.d0,p_terms,fcw_number) if(gstart==2) then do ii=1,fcw_number p_terms(ii)=p_terms(ii)-dble(conjg(fcw_state(1,ii))*psi(1)) enddo endif call mp_sum(p_terms(:),world_comm) !multiply to D matrix l_blk= (fcw_number)/nproc if(l_blk*nproc < (fcw_number)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 if(nend > fcw_number) nend=fcw_number nsize=nend-nbegin+1 s_terms(:)=0.d0 if(nsize>0) then call dgemm('T','N',nsize,1,fcw_number,1.d0,fcw_mat,fcw_number,p_terms,fcw_number,0.d0,& &s_terms(nbegin:nend),nsize) endif !collect from processors call mp_sum(s_terms,world_comm) !multiply with gamma functions call dgemm('N','N',2*npw,1,fcw_number,-1.d0,fcw_state,2*npw,s_terms,fcw_number,0.d0,opsi,2*npw) deallocate(p_terms,s_terms) endif if(gstart==2) opsi(1)=(0.d0,0.d0) ! deallocate(psi_r, psi_g,psi_v) deallocate(h_psi_g,s_psi_g) ! RETURN ! END SUBROUTINE o_1psi_gamma SUBROUTINE evc_to_real(numv, v_states) !this subroutine fourier transform states from evc !to real space USE io_global, ONLY : stdout, ionode, ionode_id USE kinds, ONLY : DP USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx USE wavefunctions_module, ONLY : evc, psic USE gvecs, ONLY : nls, nlsm, doublegrid USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft implicit none INTEGER, INTENT(in) :: numv!number of states to be transformed REAL(kind=DP), INTENT(out) :: v_states(dffts%nnr,numv)!target arrsy INTEGER :: iv do iv=1,numv,2 psic(:)=(0.d0,0.d0) if(iv < numv) then psic(nls(igk(1:npw))) = evc(1:npw,iv)+(0.d0,1.d0)*evc(1:npw,iv+1) psic(nlsm(igk(1:npw))) = CONJG( evc(1:npw,iv) )+(0.d0,1.d0)*CONJG(evc(1:npw,iv+1)) else psic(nls(igk(1:npw))) = evc(1:npw,iv) psic(nlsm(igk(1:npw))) = CONJG( evc(1:npw,iv) ) endif CALL invfft ('Wave', psic, dffts) if(iv= ecutoff) exit ngm_max=ngm_max+1 enddo else ngm_max=ngm endif write(stdout,*) 'NGM MAX:', ngm_max, ngm iungprod = find_free_unit() CALL diropn( iungprod, 'wiwjwfc_red', max_ngm*2, exst ) do iw=1,numpw psic(:)=(0.d0,0.d0) psic(nls(igk(1:npw))) = o_basis(1:npw,iw) psic(nlsm(igk(1:npw))) = CONJG( o_basis(1:npw,iw)) tmp_g(1:max_ngm)=psic(nl(1:max_ngm)) if(gstart==2) tmp_g(1)=(0.d0,0.d0) CALL davcio(tmp_g, max_ngm*2,iungprod,iw,1) enddo if(l_pbc) then numpw=numpw+1 tmp_g(1:max_ngm)=(0.d0,0.d0) if(gstart==2) tmp_g(1)=(1.d0,0.d0) CALL davcio(tmp_g, max_ngm*2,iungprod,numpw,1) endif close(iungprod) deallocate(tmp_g) return END SUBROUTINE o_basis_write !---------------------------------------------------------------------------- SUBROUTINE o_1psi_gamma_real( numv, v_states, psi, opsi) !---------------------------------------------------------------------------- ! ! !this subroutines applies the O oprator to a state psi !IT WORKS ONLY FOR NORMCONSERVING PSEUDOPOTENTIALS !the valence states in G space must be in evc ! Gamma point version in real space USE io_global, ONLY : stdout, ionode, ionode_id USE kinds, ONLY : DP USE wannier_gw USE gvect USE constants, ONLY : e2, pi, tpi, fpi USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2 USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx USE wavefunctions_module, ONLY : evc, psic USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : mpime, world_comm USE gvecs, ONLY : nls, nlsm, doublegrid USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft USE kinds, ONLY : DP ! IMPLICIT NONE INTEGER, INTENT(in) :: numv!number of valence states REAL(kind=DP), INTENT(in) :: v_states(dffts%nnr,numv)!valence states in real space COMPLEX(kind=DP), INTENT(in) :: psi(npw)!input wavefunction COMPLEX(kind=DP), INTENT(out) :: opsi(npw)!O|\psi> REAL(kind=DP), ALLOCATABLE :: psi_r(:), psi_v(:), psi_w(:) COMPLEX(kind=DP), ALLOCATABLE :: psi_g(:) REAL(kind=DP), ALLOCATABLE :: prod(:) INTEGER :: iv allocate(psi_r(dffts%nnr),psi_g(npw),psi_v(dffts%nnr)) allocate(prod(numv),psi_w(dffts%nnr)) !fourier transform psi to R space opsi(1:npw)=(0.d0,0.d0) psic(:)=(0.d0,0.d0) psic(nls(igk(1:npw))) = psi(1:npw) psic(nlsm(igk(1:npw))) = CONJG( psi(1:npw) ) CALL invfft ('Wave', psic, dffts) psi_v(1:dffts%nnr)= DBLE(psic(1:dffts%nnr)) psi_w(:)=0.d0 !loop on v do iv=1,numv !!product with psi_v psi_r(1:dffts%nnr)=psi_v(1:dffts%nnr)*v_states(1:dffts%nnr, iv) !!project on conduction manifold call dgemm('T','N',numv,1,dffts%nnr,1.d0,v_states,dffts%nnr,psi_r,dffts%nnr,0.d0,prod,numv) call mp_sum(prod(1:numv), world_comm) prod(:)=prod(:)/dble(dffts%nr1*dffts%nr2*dffts%nr3) call dgemm('N','N',dffts%nnr,1,numv,-1.d0,v_states,dffts%nnr,prod,numv,1.d0, psi_r,dffts%nnr) ! psi_r(1:dffts%nnr)=psi_r(1:dffts%nnr)*v_states(1:dffts%nnr,iv) !add up result (with sign) psi_w(:)=psi_w(:)-psi_r(:) enddo !!fourier transform in G space psic(:)=cmplx(psi_w(:),0.d0) CALL fwfft ('Wave', psic, dffts) opsi(1:npw)=psic(nls(igk(1:npw))) if(gstart==2) opsi(1)=dble(opsi(1)) ! deallocate(psi_r, psi_g,psi_v) deallocate(prod,psi_w) ! RETURN ! END SUBROUTINE o_1psi_gamma_real SUBROUTINE o_basis_test(numv,v_states,numpw, lcutoff,ecutoff) !this subroutines writes the basis of the polarization on file USE io_global, ONLY : stdout, ionode, ionode_id USE kinds, ONLY : DP USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx USE wavefunctions_module, ONLY : evc, psic USE gvecs, ONLY : nls, nlsm, doublegrid USE wavefunctions_module, ONLY : psic USE io_files, ONLY : prefix, tmp_dir, diropn USE gvect, ONLY : ngm, gg,gstart USE cell_base, ONLY: tpiba2 USE wannier_gw, ONLY : max_ngm USE gvect, ONLY : nl USE mp, ONLY : mp_sum USE mp_world, ONLY : world_comm USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER, INTENT(in) :: numv!number of valence states REAL(kind=DP), INTENT(in) :: v_states(dffts%nnr,numv)!valence states in real space INTEGER, INTENT(in) :: numpw!dimension of the polarization basis REAL(kind=DP), INTENT(in) :: ecutoff!cutoff in Rydberg for g sum LOGICAL, INTENT(in) :: lcutoff !if true uses cutoff on G defined by ecutoff INTEGER :: iw, iungprod, ig,ngm_max LOGICAL :: exst COMPLEX(kind=DP), ALLOCATABLE :: tmp_g(:), psi1(:),psi2(:) REAL(kind=DP) :: sca allocate(tmp_g(max_ngm),psi1(npw),psi2(npw)) if(lcutoff) then ngm_max=0 do ig=1,ngm if(gg(ig)*tpiba2 >= ecutoff) exit ngm_max=ngm_max+1 enddo else ngm_max=ngm endif write(stdout,*) 'NGM MAX:', ngm_max, ngm iungprod = find_free_unit() CALL diropn( iungprod, 'wiwjwfc_red', max_ngm*2, exst ) do iw=1,numpw CALL davcio(tmp_g, max_ngm*2,iungprod,iw,-1) psic(:)=(0.d0,0.d0) do ig=1,max_ngm psic(nls(ig))=tmp_g(ig) psic(nlsm(ig))=conjg(tmp_g(ig)) enddo do ig=1,npw psi1(ig)=psic(nls(igk(ig))) enddo call o_1psi_gamma( numv, v_states, psi1, psi2) sca=0.d0 do ig=1,npw sca=sca+2.d0*dble(conjg(psi2(ig))*psi2(ig)) enddo if(gstart==2) sca=sca-dble(conjg(psi2(1))*psi2(1)) call mp_sum(sca,world_comm) sca=dsqrt(sca) psi2(:)=psi2(:)/sca sca=0.d0 do ig=1,npw sca=sca+2.d0*dble(conjg(psi1(ig))*psi2(ig)) enddo if(gstart==2) sca=sca-dble(conjg(psi1(1))*psi2(1)) call mp_sum(sca,world_comm) write(stdout,*) 'o basis test:',iw,sca enddo close(iungprod) deallocate(tmp_g,psi1,psi2) return END SUBROUTINE o_basis_test GWW/pw4gww/stop_pp.f900000644000077300007730000000200212341332532015245 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! ! ! ! Author: L. Martin-Samos ! !-------------------------------------------------------------------- subroutine stop_pp !-------------------------------------------------------------------- ! ! Synchronize processes before stopping. ! use control_flags, only: twfcollect use io_files, only: iunwfc use mp_global, only: mp_global_end USE parallel_include #ifdef __PARA integer :: info logical :: op inquire ( iunwfc, opened = op ) if ( op ) then if (twfcollect) then close (unit = iunwfc, status = 'delete') else close (unit = iunwfc, status = 'keep') end if end if call mp_global_end ( ) #endif #ifdef __T3E ! ! set streambuffers off ! call set_d_stream (0) #endif stop end subroutine stop_pp GWW/pw4gww/write_vpot_matrix.f900000644000077300007730000000356212341332532017363 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! subroutine write_vpot_matrix( vmat, ort) !this subroutine writes the coulomb potential on the basis ! of orthonormalized products of wanniers !to be read by GWW code USE kinds, ONLY : DP USE wannier_gw, ONLY : numw_prod USE io_global, ONLY : stdout USE io_files, ONLY : prefix, tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit REAL(kind=DP) :: vmat(numw_prod,numw_prod) INTEGER :: ort!if ort==0 writes nonorthogonal file, if ort==1 writes orthogonal file, !if ort==2 writes nonorthogonal ^1/2 file INTEGER :: iunu, iw iunu = find_free_unit() if(ort == 1) then open(unit=iunu,file=trim(tmp_dir)//trim(prefix)//'.vpot',status='unknown',form='unformatted') ! open(unit=iunu,file=trim(tmp_dir)//trim(prefix)//'.vpot',status='unknown',form='formatted') else if(ort==0) then open(unit=iunu,file=trim(tmp_dir)//trim(prefix)//'.vpot_no',status='unknown',form='unformatted') ! open(unit=iunu,file=trim(tmp_dir)//trim(prefix)//'.vpot_no',status='unknown',form='formatted') else if(ort==2) then open(unit=iunu,file=trim(tmp_dir)//trim(prefix)//'.vpot_no_sym',status='unknown',form='unformatted') else if(ort==3) then open(unit=iunu,file=trim(tmp_dir)//trim(prefix)//'.vpot_no_zero',status='unknown',form='unformatted') else if(ort==4) then open(unit=iunu,file=trim(tmp_dir)//trim(prefix)//'.vpot_no_sym_zero',status='unknown',form='unformatted') endif write(iunu) numw_prod ! write(iunu,*) numw_prod do iw=1,numw_prod write(iunu) vmat(1:numw_prod,iw) ! write(iunu,*) vmat(1:numw_prod,iw) enddo close(iunu) return end subroutine GWW/pw4gww/dft_exchange.f900000644000077300007730000003517312341332532016217 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! subroutine dft_exchange(nbnd_v,nbnd_s,n_set, e_x,ks_wfcs) !this subroutine calculates the exchange !energy term for every state and writes on disk USE io_global, ONLY : stdout, ionode, ionode_id USE io_files, ONLY : prefix, tmp_dir, iunwfc, nwordwfc, iunigk USE mp_global, ONLY : nproc_pool, me_pool USE kinds, ONLY : DP USE basis USE klist USE constants, ONLY : e2, pi, tpi, fpi, RYTOEV USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, ecutwfc,wg USE io_files, ONLY: USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2,bg USE wannier_gw USE gvect USE gvecs, ONLY : nls, nlsm, doublegrid USE uspp USE uspp_param, ONLY : lmaxq,upf,nh, nhm USE wavefunctions_module, ONLY : psic ! USE realus, ONLY : adduspos_gamma_r USE cell_base, ONLY : at, bg, omega USE mp, ONLY : mp_sum, mp_bcast USE mp_world, ONLY : world_comm USE control_flags, ONLY : gamma_only !USE exx, ONLY : exx_divergence_new, exx_grid_init, yukawa,exx_divergence_old USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft USE fft_base, ONLY : dfftp USE io_global, ONLY : ionode USE lsda_mod, ONLY : nspin implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER, INTENT(in) :: nbnd_v(nspin) !number of valence states for both spin channels INTEGER, INTENT(in) :: nbnd_s !number of states considered INTEGER, INTENT(in) :: n_set !defines the number of states to be read from disk at the same time REAL(kind=DP), INTENT(out) :: e_x(nbnd,nspin)!in output exchange energies COMPLEX(kind=DP), INTENT(in) :: ks_wfcs(npwx,nbnd,nspin)!all kohn sham wavefunctions REAL(kind=DP), ALLOCATABLE :: fac(:) REAL(kind=DP) :: qq_fact,exxdiv INTEGER :: ig,iiv,iv,jjs,js,hw,ks REAL(kind=DP), ALLOCATABLE :: becpr(:,:) REAL(kind=DP), ALLOCATABLE :: tmpreal1(:), tmpreal_v(:,:),tmpreal_s(:,:) INTEGER :: igk0(npwx) REAL(kind=dp) :: g2kin_bp(npwx) INTEGER :: npw0 INTEGER :: jmin,jmax COMPLEX(kind=DP), ALLOCATABLE :: prod_g(:),prod_c(:),prod_g2(:,:) REAL(kind=DP), ALLOCATABLE :: prod_r(:) REAL(kind=DP) :: exc INTEGER :: iun INTEGER, PARAMETER :: n_int=20 REAL(kind=DP) :: qx,qy,qz INTEGER :: ix,iy,iz,n_int_loc,iunu REAL(kind=DP), ALLOCATABLE :: e_x_off(:,:,:) COMPLEX(kind=DP) :: c_exc INTEGER :: isv allocate(fac(ngm)) if(l_whole_s) then allocate(e_x_off(nbnd_s,nbnd_s,nspin)) e_x_off(:,:,:)=0.d0 endif !sets factors terms !sets factors terms !this has already been called call exx_grid_init() if(l_truncated_coulomb) then do ig=1,ngm qq_fact = g(1,ig)**2.d0 + g(2,ig)**2.d0 + g(3,ig)**2.d0 if (qq_fact > 1.d-8) then fac(ig)=(e2*fpi/(tpiba2*qq_fact))*(1.d0-dcos(dsqrt(qq_fact)*truncation_radius*tpiba)) else fac(ig)=e2*fpi*(truncation_radius**2.d0/2.d0) endif end do fac(:)=fac(:)/omega else fac(:)=0.d0 fac(1:npw)=vg_q(1:npw) endif e_x(:,:)=0.d0 CALL gk_sort(xk(1,1),ngm,g,ecutwfc/tpiba2, & & npw0,igk0,g2kin_bp) if(okvan) allocate(becpr(nkb,nbnd_s)) if ( nkb > 0 .and. okvan) then CALL init_us_2( npw, igk, xk(1,1), vkb ) ! CALL ccalbec( nkb, npwx, npw, nbnd_s, becpr, vkb, evc) ATTENZIONE endif allocate(tmpreal1(dfftp%nnr)) allocate(tmpreal_v(dfftp%nnr,n_set)) allocate(tmpreal_s(dfftp%nnr,n_set)) allocate(prod_g(ngm),prod_g2(ngm,nbnd_s)) allocate(prod_c(dfftp%nnr)) allocate(prod_r(dfftp%nnr)) !external loop on valence state do isv=1,nspin do iiv=1,ceiling(real(nbnd_v(isv))/real(n_set)) !read states and do fourier transform do hw=(iiv-1)*n_set+1,min(iiv*n_set,nbnd_v(isv)),2 psic(:)=(0.d0,0.d0) psic(:)=(0.d0,0.d0) IF ( hw < min(iiv*n_set,nbnd_v(isv))) then psic(nls(igk(1:npw0))) = ks_wfcs(1:npw0,hw,isv) + & ( 0.D0, 1.D0 ) * ks_wfcs(1:npw0,hw+1,isv) psic(nlsm(igk(1:npw0))) = CONJG( ks_wfcs(1:npw,hw,isv) - & ( 0.D0, 1.D0 ) * ks_wfcs(1:npw0,hw+1,isv) ) ELSE psic(nls(igk(1:npw0))) = ks_wfcs(1:npw0,hw,isv) psic(nlsm(igk(1:npw0))) = CONJG( ks_wfcs(1:npw0,hw,isv) ) END IF CALL invfft ('Wave', psic, dffts) tmpreal1(1:dfftp%nnr)=dble(psic(1:dfftp%nnr)) if(doublegrid) then call interpolate(tmpreal_v(:,hw-(iiv-1)*n_set),tmpreal1,1) else tmpreal_v(:,hw-(iiv-1)*n_set)=tmpreal1(:) endif if ( hw < min(iiv*n_set,nbnd_v(isv))) then tmpreal1(1:dfftp%nnr)=aimag(psic(1:dfftp%nnr)) if(doublegrid) then call interpolate(tmpreal_v(:,hw-(iiv-1)*n_set+1),tmpreal1,1) else tmpreal_v(:,hw-(iiv-1)*n_set+1)=tmpreal1(:) endif endif enddo do jjs=1,ceiling(real(nbnd_s)/real(n_set)) !external loop on states !read states and do fourier transform do hw=(jjs-1)*n_set+1,min(jjs*n_set,nbnd_s),2 psic(:)=(0.d0,0.d0) psic(:)=(0.d0,0.d0) IF ( hw < min(jjs*n_set,nbnd_s)) then psic(nls(igk(1:npw0))) = ks_wfcs(1:npw0,hw,isv) + & ( 0.D0, 1.D0 ) * ks_wfcs(1:npw0,hw+1,isv) psic(nlsm(igk(1:npw0))) = CONJG( ks_wfcs(1:npw,hw,isv) - & ( 0.D0, 1.D0 ) * ks_wfcs(1:npw0,hw+1,isv) ) ELSE psic(nls(igk(1:npw0))) = ks_wfcs(1:npw0,hw,isv) psic(nlsm(igk(1:npw0))) = CONJG( ks_wfcs(1:npw0,hw,isv) ) END IF CALL invfft ('Wave', psic, dffts) tmpreal1(1:dfftp%nnr)=dble(psic(1:dfftp%nnr)) if(doublegrid) then call interpolate(tmpreal_s(:,hw-(jjs-1)*n_set),tmpreal1,1) else tmpreal_s(:,hw-(jjs-1)*n_set)=tmpreal1(:) endif if ( hw < min(jjs*n_set,nbnd_s)) then tmpreal1(1:dfftp%nnr)=aimag(psic(1:dfftp%nnr)) if(doublegrid) then call interpolate(tmpreal_s(:,hw-(jjs-1)*n_set+1),tmpreal1,1) else tmpreal_s(:,hw-(jjs-1)*n_set+1)=tmpreal1(:) endif endif enddo !internal loop on valence states do iv=(iiv-1)*n_set+1,min(iiv*n_set,nbnd_v(isv)) jmin=(jjs-1)*n_set+1 jmax=min(jjs*n_set,nbnd_s) !for whole X operator for given iv calculate products in real space with all the !KS states and store in G space if(l_whole_s) then !NOT_TO_BE_INCLUDED_START do ks=1,nbnd_s,1 psic(:)=(0.d0,0.d0) psic(nls(igk(1:npw0))) = ks_wfcs(1:npw0,ks,isv) psic(nlsm(igk(1:npw0))) = CONJG( ks_wfcs(1:npw0,ks,isv) ) CALL invfft ('Wave', psic, dffts) prod_c(1:dfftp%nnr)=dcmplx(dble(psic(1:dfftp%nnr))*tmpreal_v(1:dfftp%nnr,iv-(iiv-1)*n_set)& & ,0.d0) CALL fwfft ('Dense', prod_c, dfftp) prod_g2(1:ngm,ks)=prod_c(nl(1:ngm)) enddo !NOT_TO_BE_INCLUDED_END endif do js=jmin,jmax !do product in real speace prod_r(:)=tmpreal_v(:,iv-(iiv-1)*n_set)*tmpreal_s(:,js-(jjs-1)*n_set) ! if(okvan) call adduspos_gamma_r & ATTENZIONE ! (iv,js, prod_r(:),1,becpr(:,iv),becpr(:,js)) prod_c(:)=dcmplx(prod_r(:),0.d0) CALL fwfft ('Dense', prod_c, dfftp) !go to g_space prod_g(1:ngm)=prod_c(nl(1:ngm)) !calculated exchange exc=0.d0 do ig=1,ngm exc=exc+2.d0*dble(conjg(prod_g(ig))*prod_g(ig))*fac(ig)*wg(iv,isv)*dble(nspin)/2.d0 enddo if(gstart==2) exc=exc-dble(prod_g(1))*dble(prod_g(1))*fac(1)*wg(iv,isv)*dble(nspin)/2.d0 call mp_sum(exc,world_comm) exc=-exc e_x(js,isv)=e_x(js,isv)+exc !poor programmer solution for off diagonal terms.... !ONLY FOR NORMCONSERVING PSEUDOS if(l_whole_s) then !NOT_TO_BE_INCLUDED_START write(stdout,*) 'Call complete X operator part',iv call flush_unit(stdout) do ks=1,nbnd_s,1 c_exc=(0.d0,0.d0) do ig=1,ngm c_exc=c_exc+conjg(prod_g2(ig,ks))*prod_g(ig)*fac(ig)+& &prod_g2(ig,ks)*conjg(prod_g(ig))*fac(ig) enddo if(gstart==2) c_exc=c_exc-conjg(prod_g2(1,ks))*prod_g(1)*fac(1) call mp_sum(c_exc,world_comm) c_exc=-c_exc e_x_off(ks,js,isv)=e_x_off(ks,js,isv)+dble(c_exc) enddo !NOT_TO_BE_INCLUDED_END endif enddo enddo enddo enddo enddo!ivv do isv=1,nspin do iv=1,nbnd_s write(stdout,*) 'Exchange energy', iv,isv, e_x(iv,isv) enddo enddo !write on file if(ionode) then iun = find_free_unit() open(unit=iun,file=trim(tmp_dir)//trim(prefix)//'.exchange',status='unknown',form='unformatted') write(iun) nbnd_s do isv=1,nspin !NOT_TO_BE_INCLUDED_START if(l_selfconsistent) e_x(1:nbnd_s,isv)=0.d0 !NOT_TO_BE_INCLUDED_END write(iun) e_x(1:nbnd_s,isv) enddo close(iun) endif !if required write on disk off-diagonal terms if(l_whole_s) then !NOT_TO_BE_INCLUDED_START if(ionode) then do iv=1,nbnd_s write(stdout,*) 'Exchange energy off', iv, e_x_off(iv,iv,1) enddo !write on file iun = find_free_unit() open(unit=iun,file=trim(tmp_dir)//trim(prefix)//'.exchange_off',status='unknown',form='unformatted') write(iun) nbnd_s do isv=1,nspin do js=1,nbnd_s write(iun) e_x_off(1:nbnd_s,js,isv) enddo enddo close(iun) endif !NOT_TO_BE_INCLUDED_END endif deallocate(tmpreal1,tmpreal_s,tmpreal_v) deallocate(fac) deallocate(prod_c,prod_g,prod_g2) deallocate(prod_r) if(okvan) deallocate(becpr) if(l_whole_s) then !NOT_TO_BE_INCLUDED_START deallocate(e_x_off) !NOT_TO_BE_INCLUDED_END endif end subroutine dft_exchange !---------------------------------------------------------------------- subroutine addus_charge(r_ij,becp_iw,becp_jw) !---------------------------------------------------------------------- ! ! This routine adds to the charge density the part which is due to ! the US augmentation. ! USE kinds, ONLY : DP USE ions_base, ONLY : nat, ntyp => nsp, ityp USE gvect, ONLY : ngm, nl, nlm, gg, g, eigts1, eigts2, & eigts3, mill USE lsda_mod, ONLY : nspin USE scf, ONLY : rho USE uspp, ONLY : okvan, nkb USE uspp_param, ONLY : lmaxq, upf, nh USE wavefunctions_module, ONLY : psic USE control_flags , ONLY : gamma_only USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft ! implicit none COMPLEX(kind=DP), INTENT(inout) :: r_ij(dfftp%nnr)!where to add the us term COMPLEX(kind=DP), INTENT(in) :: becp_iw( nkb)!overlap of wfcs with us projectors COMPLEX(kind=DP), INTENT(in) :: becp_jw( nkb)!overlap of wfcs with us projectors ! ! here the local variables ! integer :: ig, na, nt, ih, jh, is ! counters real(DP), allocatable :: qmod (:), ylmk0 (:,:) ! the modulus of G ! the spherical harmonics complex(DP) :: skk complex(DP), allocatable :: aux (:,:), qgm(:) ! work space for rho(G,nspin) ! Fourier transform of q INTEGER, ALLOCATABLE :: ind_cor(:,:,:) INTEGER :: ijkb0, ikb,np if (.not.okvan) return allocate (aux ( ngm, nspin)) allocate (qmod( ngm)) allocate (qgm( ngm)) allocate (ylmk0( ngm, lmaxq * lmaxq)) aux (:,:) = (0.d0, 0.d0) call ylmr2 (lmaxq * lmaxq, ngm, g, gg, ylmk0) do ig = 1, ngm qmod (ig) = sqrt (gg (ig) ) enddo !found index correspondence allocate(ind_cor(ntyp,nat,maxval(nh(1:ntyp)))) ijkb0 = 0 do np = 1, ntyp if ( upf(np)%tvanp ) then do na = 1, nat if ( ityp(na) == np ) then do ih = 1, nh(np) ikb = ijkb0 + ih ind_cor(np,na,ih)=ikb enddo ijkb0=ijkb0+nh(np) endif enddo else do na=1,nat if(ityp(na) == np) ijkb0=ijkb0+nh(np) enddo endif enddo do nt = 1, ntyp if (upf(nt)%tvanp ) then do ih = 1, nh (nt) do jh = 1, nh (nt) call qvan2 (ngm, ih, jh, nt, qmod, qgm, ylmk0) do na = 1, nat if (ityp (na) .eq.nt) then ! ! Multiply becsum and qg with the correct structure factor ! do is = 1, nspin do ig = 1, ngm skk = eigts1 (mill(1,ig), na) * & eigts2 (mill(2,ig), na) * & eigts3 (mill(3,ig), na) aux(ig,is)=aux(ig,is) + qgm(ig)*skk*& &conjg(becp_iw(ind_cor(nt,na,ih)))*becp_jw(ind_cor(nt,na,jh)) enddo enddo endif enddo enddo enddo endif enddo deallocate(ind_cor) ! deallocate (ylmk0) deallocate (qgm) deallocate (qmod) ! ! convert aux to real space and add to the charge density ! do is = 1, nspin!SPIN TO BE IMPLEMENTED YET psic(:) = (0.d0, 0.d0) psic( nl(:) ) = aux(:,is) if (gamma_only) psic( nlm(:) ) = CONJG(aux(:,is)) CALL invfft ('Dense', psic, dfftp) r_ij(:)=r_ij(:)+psic(:) enddo deallocate (aux) return end subroutine addus_charge GWW/pw4gww/diago_cg.f900000644000077300007730000003614012341332532015327 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !---------------------------------------------------------------------------- SUBROUTINE diago_cg(ndim,omat,maxter,max_state,e,ovec,cutoff,ethr,found_state,l_para) !---------------------------------------------------------------------------- ! ! ... "poor man" iterative diagonalization of a real symmetric matrix O ! ... through preconditioned conjugate gradient algorithm ! ... Band-by-band algorithm with minimal use of memory ! USE constants, ONLY : pi USE kinds, ONLY : DP USE io_global, ONLY : stdout USE mp_world, ONLY : mpime,nproc,world_comm USE mp, ONLY : mp_sum USE random_numbers, ONLY : randy ! IMPLICIT NONE ! ! ... I/O variables ! INTEGER, INTENT(in) :: ndim!matrix dimension REAL(kind=DP), INTENT(in) :: omat(ndim,ndim)!matrix to be diagonalized INTEGER, INTENT(in) ::maxter!maximum number of iterations INTEGER, INTENT(in) :: max_state!maximum number of eigenvectors to be found REAL(kind=DP),INTENT(inout) :: e(ndim)!eigenvalues REAL(kind=DP), INTENT(inout) :: ovec(ndim,max_state)!eigenvector REAL(kind=DP),INTENT(in) :: cutoff!found eigenvalues larger than cutoff REAL (DP), INTENT(IN) :: ethr!threshold for convergence INTEGER, INTENT(out) :: found_state!number of states found LOGICAL, INTENT(in) :: l_para!if true omat is distributed among processors ! ! ... local variables ! INTEGER :: i, j, m, iter, moved, iw, ig REAL (DP), ALLOCATABLE :: lagrange(:) REAL (DP), ALLOCATABLE :: hpsi(:), spsi(:), g(:), cg(:), & scg(:), ppsi(:), g0(:) REAL (DP) :: psi_norm, a0, b0, gg0, gamma, gg, gg1, & cg0, e0, es(2) REAL (DP) :: theta, cost, sint, cos2t, sin2t LOGICAL :: reorder=.true. LOGICAL :: l_all_ok, l_first_out INTEGER :: m_first_out, delta_first_out=10000 INTEGER :: l_blk,nbegin,nend,nsize REAL(kind=DP)::avg_iter INTEGER :: notconv REAL(kind=DP), ALLOCATABLE :: aux(:,:) REAL (DP) :: rtmp(2) REAL (DP), ALLOCATABLE :: hr(:,:,:), sr(:,:) REAL (DP), ALLOCATABLE :: en(:),ctmp(:) REAL(kind=DP) :: rr REAL(kind=DP), ALLOCATABLE :: ovec2(:,:) ! ! ... external functions ! REAL (DP), EXTERNAL :: DDOT ! ! CALL start_clock( 'diago_cg' ) ! ! ! ALLOCATE( spsi( ndim ) ) ALLOCATE( scg( ndim ) ) ALLOCATE( hpsi( ndim ) ) ALLOCATE( g( ndim ) ) ALLOCATE( cg( ndim ) ) ALLOCATE( g0( ndim ) ) ALLOCATE( ppsi( ndim ) ) ! ALLOCATE( lagrange( max_state) ) ! avg_iter = 0.D0 notconv = 0 moved = 0 l_all_ok=.true. l_first_out=.false. ! ! ... every eigenfunction is calculated separately ! write(stdout,*) 'ATTENZIONE1' call flush_unit(stdout) l_blk= (ndim)/nproc if(l_blk*nproc < ndim) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 if(nend > ndim) nend=ndim nsize=nend-nbegin+1!WARNING it could be < 1 !initialization DO iw = 1, max_state DO ig = 1, ndim rr = randy()!rndm() ovec(ig,iw)=rr END DO END DO allocate(aux(ndim,2)) ALLOCATE( hr( max_state, max_state, 2 ) ) ALLOCATE( sr( max_state, max_state ) ) ALLOCATE( en( max_state) ,ctmp(max_state)) DO m = 1, max_state call gradient(ovec(1:ndim,m),aux(1:ndim,1)) aux(:,2)=ovec(:,m) if(nsize > 0 )then !CALL DGEMV( 'T', nsize, 2, 1.D0, aux(nbegin:nend,1:2), nsize, ovec(nbegin:nend,m), 1, 0.D0, rtmp, 1 ) CALL DGEMV( 'T', nsize, 2, 1.D0, aux(nbegin,1), ndim, ovec(nbegin,m), 1, 0.D0, rtmp, 1 ) else rtmp(1:2)=0.d0 endif call mp_sum(rtmp(1:2),world_comm) hr(m,m,1) = rtmp(1) sr(m,m) = rtmp(2) DO j = m + 1, max_state if(nsize>0) then !CALL DGEMV( 'T', nsize, 2, 1.D0, aux(nbegin:nend,1:2), nsize, ovec(nbegin:nend,j), 1, 0.D0, rtmp, 1 ) CALL DGEMV( 'T', nsize, 2, 1.D0, aux(nbegin,1), ndim, ovec(nbegin,j), 1, 0.D0, rtmp, 1 ) else rtmp(1:2)=0.d0 endif hr(j,m,1) = rtmp(1) sr(j,m) = rtmp(2) hr(m,j,1) = rtmp(1) sr(m,j) = rtmp(2) END DO END DO write(stdout,*) 'ATTENZIONE2' call flush_unit(stdout) call mp_sum(hr(:,:,1),world_comm) call mp_sum(sr(:,:),world_comm) write(stdout,*) 'Call rdiaghg' call flush_unit(stdout) CALL rdiaghg( max_state, max_state, hr, sr, max_state, en, hr(1,1,2) ) write(stdout,*) 'Done' call flush_unit(stdout) e(1:max_state) = en(1:max_state) ! DO i = 1,ndim ! DO m = 1, max_state ! ctmp(m) = SUM( hr(:,m,2) * ovec(i,:) ) ! END DO ! ovec(i,1:max_state) = ctmp(1:max_state) ! END DO allocate(ovec2(ndim,max_state)) ovec2(:,:)=ovec(:,:) ovec(:,:)=0.d0 if(nsize > 0) then call dgemm('N','N',nsize,max_state,max_state,1.d0,ovec2(nbegin:nend,1:max_state),& &nsize,hr(1:max_state,1:max_state,2),max_state,0.d0,ovec(nbegin:nend,1:max_state),nsize) endif call mp_sum(ovec(:,:),world_comm) deallocate(ovec2) deallocate(aux) deallocate(hr,sr) deallocate(en,ctmp) write(stdout,*) 'ATTENZIONE3' call flush_unit(stdout) states: DO m = 1, max_state write(stdout,*) 'ATTENZIONE4',m call flush_unit(stdout) ! ! ... calculate S|psi> ! !CALL s_1psi( ndmx, ndim, psi(1,m), spsi ) spsi(:)=ovec(:,m) ! ! ... orthogonalize starting eigenfunction to those already calculated ! if(nsize>0) then !CALL DGEMV( 'T', nsize, m, 1.D0, ovec(nbegin:nend,1:m), nsize, spsi(nbegin:nend), 1, 0.D0, lagrange, 1 ) CALL DGEMV( 'T', nsize, m, 1.D0, ovec(nbegin,1), SIZE(ovec,1), spsi(nbegin), 1, 0.D0, lagrange, 1 ) else lagrange(:)=0.d0 endif ! call mp_sum(lagrange(1:m),world_comm) ! psi_norm = lagrange(m) ! DO j = 1, m - 1 ! ovec(:,m) = ovec(:,m) - lagrange(j) * ovec(:,j) ! psi_norm = psi_norm - lagrange(j)**2 ! END DO ! psi_norm = SQRT( psi_norm ) ! ovec(:,m) = ovec(:,m) / psi_norm ! ! ... calculate starting gradient (|hpsi> = H|psi>) ... ! call gradient(ovec(1:ndim,m),hpsi) spsi(1:ndim)=ovec(1:ndim,m) ! ! ... and starting eigenvalue (e = = ) ! ! ... NB: DDOT(2*ndim,a,1,b,1) = DBLE( ZDOTC(ndim,a,1,b,1) ) ! if(nsize>0) then e(m) = DDOT( nsize, ovec(nbegin:nend,m), 1, hpsi(nbegin:nend), 1 ) else e(m)=0.d0 endif ! call mp_sum(e(m),world_comm) ! ! ! ... start iteration for this band ! iterate: DO iter = 1, maxter ! ! ... calculate P (PHP)|y> ! ... ( P = preconditioning matrix, assumed diagonal ) ! g(1:ndim) = hpsi(1:ndim)! / precondition(:) ppsi(1:ndim) = spsi(1:ndim)! / precondition(:) ! ! ... ppsi is now S P(P^2)|y> = S P^2|psi>) ! if(nsize>0) then es(1) = DDOT( nsize, spsi(nbegin:nend), 1, g(nbegin:nend), 1 ) es(2) = DDOT( nsize, spsi(nbegin:nend), 1, ppsi(nbegin:nend), 1 ) else es(1:2)=0.d0 endif call mp_sum(es(1:2),world_comm) ! es(1) = es(1) / es(2) ! g(:) = g(:) - es(1) * ppsi(:) ! ! ... e1 = / ensures that ! ... = 0 ! ! ... orthogonalize to lowest eigenfunctions (already calculated) ! ! ... scg is used as workspace ! !CALL s_1psi( ndmx, ndim, g(1), scg(1) ) scg(1:ndim)=g(1:ndim) ! if(nsize> 0) then !CALL DGEMV( 'T', nsize, ( m - 1 ), 1.D0, & ! ovec(nbegin:nend,1:m-1), nsize, scg(nbegin:nend), 1, 0.D0, lagrange, 1 ) CALL DGEMV( 'T', nsize, ( m - 1 ), 1.D0, ovec(nbegin,1), SIZE(ovec,1), scg(nbegin), 1, 0.D0, lagrange, 1 ) else lagrange(1:m-1)=0.d0 endif ! call mp_sum(lagrange(1:m-1),world_comm) ! ! DO j = 1, ( m - 1 ) ! g(:) = g(:) - lagrange(j) * ovec(:,j) scg(:) = scg(:) - lagrange(j) * ovec(:,j) ! END DO ! IF ( iter /= 1 ) THEN ! ! ... gg1 is (used in Polak-Ribiere formula) ! if(nsize>0) then gg1 = DDOT( nsize, g(nbegin:nend), 1, g0(nbegin:nend), 1 ) else gg1=0.d0 endif ! call mp_sum(gg1,world_comm) ! ! END IF ! ! ... gg is ! g0(:) = scg(:) ! g0(1:ndim) = g0(1:ndim)! * precondition(:) ! if(nsize>0) then gg = DDOT( nsize, g(nbegin:nend), 1, g0(nbegin:nend), 1 ) else gg=0.d0 endif ! call mp_sum(gg,world_comm) ! ! IF ( iter == 1 ) THEN ! ! ... starting iteration, the conjugate gradient |cg> = |g> ! gg0 = gg ! cg(:) = g(:) ! ELSE ! ! ... |cg(n+1)> = |g(n+1)> + gamma(n) * |cg(n)> ! ! ... Polak-Ribiere formula : ! gamma = ( gg - gg1 ) / gg0 gg0 = gg ! cg(:) = cg(:) * gamma cg(:) = g + cg(:) ! ! ... The following is needed because ! ... is not 0. In fact : ! ... = sin(theta)* ! psi_norm = gamma * cg0 * sint ! cg(:) = cg(:) - psi_norm * ovec(:,m) ! END IF ! ! ... |cg> contains now the conjugate gradient ! ! ... |scg> is S|cg> ! call gradient(cg,ppsi) scg(1:ndim)=cg(1:ndim) ! if(nsize>0) then cg0 = DDOT( nsize, cg(nbegin:nend), 1, scg(nbegin:nend), 1 ) else cg0=0.d0 endif ! call mp_sum(cg0,world_comm) ! ! cg0 = SQRT( cg0 ) ! ! ... |ppsi> contains now HP|cg> ! ... minimize , where : ! ... |y(t)> = cos(t)|y> + sin(t)/cg0 |cg> ! ... Note that = 1, = 0 , ! ... = cg0^2 ! ... so that the result is correctly normalized : ! ... = 1 ! if(nsize>0) then a0 = 2.D0 * DDOT( nsize, ovec(nbegin:nend,m), 1, ppsi(nbegin:nend), 1 ) else a0=0.d0 endif ! ! a0 = a0 / cg0 ! call mp_sum(a0,world_comm) ! if(nsize>0) then b0 = DDOT( nsize, cg(nbegin:nend), 1, ppsi(nbegin:nend), 1 ) else b0=0.d0 endif ! ! b0 = b0 / cg0**2 ! call mp_sum(b0,world_comm) ! e0 = e(m) ! theta = 0.5D0 * ATAN( a0 / ( e0 - b0 ) ) ! cost = COS( theta ) sint = SIN( theta ) ! cos2t = cost*cost - sint*sint sin2t = 2.D0*cost*sint ! es(1) = 0.5D0 * ( ( e0 - b0 ) * cos2t + a0 * sin2t + e0 + b0 ) es(2) = 0.5D0 * ( - ( e0 - b0 ) * cos2t - a0 * sin2t + e0 + b0 ) ! ! ... there are two possible solutions, choose the minimum ! IF ( es(2) < es(1) ) THEN ! theta = theta + 0.5D0 * pi ! cost = COS( theta ) sint = SIN( theta ) ! END IF ! ! ... new estimate of the eigenvalue ! e(m) = MIN( es(1), es(2) ) ! ! ... upgrade |psi> ! ovec(:,m) = cost * ovec(:,m) + sint / cg0 * cg(:) ! ! ... here one could test convergence on the energy ! IF ( ABS( e(m) - e0 ) < ethr ) THEN write(stdout,*) 'State:',m,'Iterations:',iter,e(m) call flush_unit(stdout) EXIT iterate ELSE l_all_ok=.false. END IF ! ! ... upgrade H|psi> and S|psi> ! spsi(:) = cost * spsi(:) + sint / cg0 * scg(:) ! hpsi(:) = cost * hpsi(:) + sint / cg0 * ppsi(:) ! END DO iterate ! IF ( iter >= maxter ) notconv = notconv + 1 ! avg_iter = avg_iter + iter + 1 ! ! ... reorder eigenvalues if they are not in the right order ! ... ( this CAN and WILL happen in not-so-special cases ) ! IF ( m > 1 .AND. reorder ) THEN ! IF ( e(m) - e(m-1) < - 2.D0 * ethr ) THEN write(stdout,*) 'DO REORDER:',m call flush_unit(stdout) ! ! ... if the last calculated eigenvalue is not the largest... ! DO i = m - 2, 1, - 1 ! IF ( e(m) - e(i) > 2.D0 * ethr ) EXIT ! END DO ! i = i + 1 ! moved = moved + 1 ! ! ... last calculated eigenvalue should be in the ! ... i-th position: reorder ! e0 = e(m) ! ppsi(:) = ovec(:,m) ! DO j = m, i + 1, - 1 ! e(j) = e(j-1) ! ovec(:,j) = ovec(:,j-1) ! END DO ! e(i) = e0 ! ovec(:,i) = ppsi(:) ! ! ... this procedure should be good if only a few inversions occur, ! ... extremely inefficient if eigenvectors are often in bad order ! ... ( but this should not happen ) ! END IF ! END IF if(abs(e(m))max_state) found_state=max_state ! avg_iter = avg_iter / DBLE( found_state ) ! DEALLOCATE( lagrange ) DEALLOCATE( ppsi ) DEALLOCATE( g0 ) DEALLOCATE( cg ) DEALLOCATE( g ) DEALLOCATE( hpsi ) DEALLOCATE( scg ) DEALLOCATE( spsi ) ! CALL stop_clock( 'diago_cg' ) RETURN CONTAINS SUBROUTINE gradient(vec,grad) !apply gradient implicit none REAL(kind=DP), INTENT(in) :: vec(ndim) REAL(kind=DP), INTENT(out) :: grad(ndim) grad(:)=0.d0 if(nsize>0) then if(.not.l_para) then call dgemm('T','N',nsize,1,ndim,-1.d0,omat(1:ndim,nbegin:nend),ndim,vec,ndim,0.d0,grad(nbegin:nend),nsize) else call dgemm('T','N',nsize,1,ndim,-1.d0,omat(1:ndim,1:nsize),ndim,vec,ndim,0.d0,grad(nbegin:nend),nsize) endif endif call mp_sum(grad(1:ndim),world_comm) return END SUBROUTINE gradient ! END SUBROUTINE diago_cg GWW/pw4gww/cgsolve_all_gamma.f900000644000077300007730000002200512341332532017222 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! ! ! !---------------------------------------------------------------------- subroutine cgsolve_all_gamma (h_psi, cg_psi, e, d0psi, dpsi, h_diag, & ndmx, ndim, ethr, ik, kter, conv_root, anorm, nbnd, npol) !---------------------------------------------------------------------- ! ! iterative solution of the linear system: ! ! ( h - e + Q ) * dpsi = d0psi (1) ! ! where h is a complex hermitean matrix, e is a real sca ! dpsi and d0psi are complex vectors ! ! on input: ! h_psi EXTERNAL name of a subroutine: ! h_psi(ndim,psi,psip) ! Calculates H*psi products. ! Vectors psi and psip should be dimensined ! (ndmx,nvec). nvec=1 is used! ! ! cg_psi EXTERNAL name of a subroutine: ! g_psi(ndmx,ndim,notcnv,psi,e) ! which calculates (h-e)^-1 * psi, with ! some approximation, e.g. (diag(h)-e) ! ! e real unperturbed eigenvalue. ! ! dpsi contains an estimate of the solution ! vector. ! ! d0psi contains the right hand side vector ! of the system. ! ! ndmx integer row dimension of dpsi, ecc. ! ! ndim integer actual row dimension of dpsi ! ! ethr real convergence threshold. solution ! improvement is stopped when the error in ! eq (1), defined as l.h.s. - r.h.s., becomes ! less than ethr in norm. ! ! on output: dpsi contains the refined estimate of the ! solution vector. ! ! d0psi is corrupted on exit ! ! revised (extensively) 6 Apr 1997 by A. Dal Corso & F. Mauri ! revised (to reduce memory) 29 May 2004 by S. de Gironcoli ! USE kinds, ONLY : DP USE mp_global, ONLY : intra_pool_comm USE mp, ONLY : mp_sum USE control_flags, ONLY : gamma_only USE gvect, ONLY : gstart implicit none ! ! first the I/O variables ! integer :: ndmx, & ! input: the maximum dimension of the vectors ndim, & ! input: the actual dimension of the vectors kter, & ! output: counter on iterations nbnd, & ! input: the number of bands npol, & ! input: number of components of the wavefunctions ik ! input: the k point real(DP) :: & e(nbnd), & ! input: the actual eigenvalue anorm, & ! output: the norm of the error in the solution h_diag(ndmx*npol,nbnd), & ! input: an estimate of ( H - \epsilon ) ethr ! input: the required precision complex(DP) :: & dpsi (ndmx*npol, nbnd), & ! output: the solution of the linear syst d0psi (ndmx*npol, nbnd) ! input: the known term logical :: conv_root ! output: if true the root is converged external h_psi ! input: the routine computing h_psi external cg_psi ! input: the routine computing cg_psi ! ! here the local variables ! integer, parameter :: maxter = 200 ! the maximum number of iterations integer :: iter, ibnd, lbnd ! counters on iteration, bands integer , allocatable :: conv (:) ! if 1 the root is converged complex(DP), allocatable :: g (:,:), t (:,:), h (:,:), hold (:,:) ! the gradient of psi ! the preconditioned gradient ! the delta gradient ! the conjugate gradient ! work space complex(DP) :: dcgamma, dclambda ! the ratio between rho ! step length complex(DP), external :: zdotc REAL(kind=dp), EXTERNAL :: ddot ! the scalar product real(DP), allocatable :: rho (:), rhoold (:), eu (:), a(:), c(:) ! the residue ! auxiliary for h_diag real(DP) :: kter_eff ! account the number of iterations with b ! coefficient of quadratic form ! call start_clock ('cgsolve') allocate ( g(ndmx*npol,nbnd), t(ndmx*npol,nbnd), h(ndmx*npol,nbnd), & hold(ndmx*npol ,nbnd) ) allocate (a(nbnd), c(nbnd)) allocate (conv ( nbnd)) allocate (rho(nbnd),rhoold(nbnd)) allocate (eu ( nbnd)) ! WRITE( stdout,*) g,t,h,hold kter_eff = 0.d0 do ibnd = 1, nbnd conv (ibnd) = 0 enddo g=(0.d0,0.d0) t=(0.d0,0.d0) h=(0.d0,0.d0) hold=(0.d0,0.d0) do iter = 1, maxter ! ! compute the gradient. can reuse information from previous step ! if (iter == 1) then call h_psi (ndim, dpsi, g, e, ik, nbnd) do ibnd = 1, nbnd call zaxpy (ndim, (-1.d0,0.d0), d0psi(1,ibnd), 1, g(1,ibnd), 1) enddo IF (npol==2) THEN do ibnd = 1, nbnd call zaxpy (ndim, (-1.d0,0.d0), d0psi(ndmx+1,ibnd), 1, & g(ndmx+1,ibnd), 1) enddo END IF endif ! ! compute preconditioned residual vector and convergence check ! lbnd = 0 do ibnd = 1, nbnd if (conv (ibnd) .eq.0) then lbnd = lbnd+1 call zcopy (ndmx*npol, g (1, ibnd), 1, h (1, ibnd), 1) call cg_psi(ndmx, ndim, 1, h(1,ibnd), h_diag(1,ibnd) ) IF (gamma_only) THEN rho(lbnd)=2.0d0*ddot(2*ndmx*npol,h(1,ibnd),1,g(1,ibnd),1) IF(gstart==2) THEN rho(lbnd)=rho(lbnd)-DBLE(h(1,ibnd))*DBLE(g(1,ibnd)) ENDIF ELSE rho(lbnd) = zdotc (ndmx*npol, h(1,ibnd), 1, g(1,ibnd), 1) ENDIF endif enddo kter_eff = kter_eff + DBLE (lbnd) / DBLE (nbnd) #ifdef __MPI call mp_sum( rho(1:lbnd) , intra_pool_comm ) #endif do ibnd = nbnd, 1, -1 if (conv(ibnd).eq.0) then rho(ibnd)=rho(lbnd) lbnd = lbnd -1 anorm = sqrt (rho (ibnd) ) ! write(6,*) ibnd, anorm if (anorm.lt.ethr) conv (ibnd) = 1 endif enddo ! conv_root = .true. do ibnd = 1, nbnd conv_root = conv_root.and. (conv (ibnd) .eq.1) enddo if (conv_root) goto 100 ! ! compute the step direction h. Conjugate it to previous step ! lbnd = 0 do ibnd = 1, nbnd if (conv (ibnd) .eq.0) then ! ! change sign to h ! call dscal (2 * ndmx * npol, - 1.d0, h (1, ibnd), 1) if (iter.ne.1) then dcgamma = rho (ibnd) / rhoold (ibnd) call zaxpy (ndmx*npol, dcgamma, hold (1, ibnd), 1, h (1, ibnd), 1) endif ! ! here hold is used as auxiliary vector in order to efficiently compute t = A*h ! it is later set to the current (becoming old) value of h ! lbnd = lbnd+1 call zcopy (ndmx*npol, h (1, ibnd), 1, hold (1, lbnd), 1) eu (lbnd) = e (ibnd) endif enddo ! ! compute t = A*h ! call h_psi (ndim, hold, t, eu, ik, lbnd) ! ! compute the coefficients a and c for the line minimization ! compute step length lambda lbnd=0 do ibnd = 1, nbnd if (conv (ibnd) .eq.0) then lbnd=lbnd+1 IF (gamma_only) THEN a(lbnd) = 2.0d0*ddot(2*ndmx*npol,h(1,ibnd),1,g(1,ibnd),1) c(lbnd) = 2.0d0*ddot(2*ndmx*npol,h(1,ibnd),1,t(1,lbnd),1) IF (gstart == 2) THEN a(lbnd)=a(lbnd)-DBLE(h(1,ibnd))*DBLE(g(1,ibnd)) c(lbnd)=c(lbnd)-DBLE(h(1,ibnd))*DBLE(t(1,lbnd)) ENDIF ELSE a(lbnd) = zdotc (ndmx*npol, h(1,ibnd), 1, g(1,ibnd), 1) c(lbnd) = zdotc (ndmx*npol, h(1,ibnd), 1, t(1,lbnd), 1) ENDIF end if end do #ifdef __MPI call mp_sum( a(1:lbnd), intra_pool_comm ) call mp_sum( c(1:lbnd), intra_pool_comm ) #endif lbnd=0 do ibnd = 1, nbnd if (conv (ibnd) .eq.0) then lbnd=lbnd+1 dclambda = CMPLX( - a(lbnd) / c(lbnd), 0.d0,kind=DP) ! ! move to new position ! call zaxpy (ndmx*npol, dclambda, h(1,ibnd), 1, dpsi(1,ibnd), 1) ! ! update to get the gradient ! !g=g+lam call zaxpy (ndmx*npol, dclambda, t(1,lbnd), 1, g(1,ibnd), 1) ! ! save current (now old) h and rho for later use ! call zcopy (ndmx*npol, h(1,ibnd), 1, hold(1,ibnd), 1) rhoold (ibnd) = rho (ibnd) endif enddo enddo 100 continue kter = kter_eff deallocate (eu) deallocate (rho, rhoold) deallocate (conv) deallocate (a,c) deallocate (g, t, h, hold) call stop_clock ('cgsolve') return end subroutine cgsolve_all_gamma GWW/pw4gww/wannier_bse.f900000644000077300007730000002301312341332532016062 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! ! This subroutine computes the overlap between Wannier orbitals Ovv' and ! computes the (v*w_v*w_v')(r) term for each vv' such that Ovv'>s_bse, and ! writes to disk Ovv' and (v*w_v*w_v')(r) ,and z_beta_v_v'=v*phi_beta*wv*wv' subroutine wannier_bse(ispin,w_wfcs,o_mat) USE io_global, ONLY : stdout, ionode, ionode_id USE io_files, ONLY : prefix, tmp_dir, diropn USE kinds, ONLY : DP USE wannier_gw, ONLY : num_nbndv,dual_bse,s_bse,l_truncated_coulomb,truncation_radius,vg_q,& max_ngm,numw_prod USE fft_custom_gwl USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, ecutwfc USE mp_pools, ONLY : intra_pool_comm USE mp_world, ONLY : mpime, nproc, world_comm USE mp, ONLY : mp_sum USE gvect USE wavefunctions_module, ONLY : psic USE constants, ONLY : e2, fpi USE cell_base, ONLY: tpiba,tpiba2,omega USE mp_wave, ONLY : mergewf,splitwf implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER, intent(in) :: ispin COMPLEX(kind=DP), intent(in) :: w_wfcs(npw,num_nbndv(ispin)) REAL(kind=DP), intent(out) :: o_mat(num_nbndv(ispin),num_nbndv(ispin)) TYPE(fft_cus) :: fc COMPLEX(kind=DP), allocatable :: w_wfcs_t(:,:) REAL(kind=DP), ALLOCATABLE :: w_wfcs_r(:,:) REAL(kind=DP), ALLOCATABLE :: w_wfcs_2(:,:) REAL(kind=DP), ALLOCATABLE :: ww_prod(:) COMPLEX(kind=DP), allocatable :: ww_prodg(:),ww_prodg2(:) COMPLEX(kind=DP), ALLOCATABLE :: evc_g(:) COMPLEX(kind=DP), ALLOCATABLE :: p_basis(:,:) REAL(kind=DP), ALLOCATABLE :: fac(:) REAL(kind=DP), ALLOCATABLE :: z(:) INTEGER, ALLOCATABLE ::iww(:) INTEGER :: ii,ig, iv,jv,np,np_max,i INTEGER :: iunu, iungprod,iunz,iuni REAL(kind=DP) :: qq LOGICAL :: exst logical :: debug integer :: iundebug fc%ecutt=ecutwfc fc%dual_t=dual_bse debug=.true. ! FFT the wannier function to r-space (dual grid) write(stdout,*) 'Call initialize_fft_custom' call initialize_fft_custom(fc) allocate(w_wfcs_t(fc%npwt,num_nbndv(ispin))) allocate( evc_g(fc%ngmt_g ) ) allocate(w_wfcs_r(fc%nrxxt,num_nbndv(ispin))) allocate(w_wfcs_2(fc%nrxxt,num_nbndv(ispin))) if(fc%dual_t==4.d0) then w_wfcs_t(1:fc%npwt,1:num_nbndv(ispin))= w_wfcs(1:fc%npwt,1:num_nbndv(ispin)) else do ii=1, num_nbndv(ispin) call mergewf(w_wfcs(:,ii),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) call splitwf(w_wfcs_t(:,ii),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) enddo endif do ii=1,num_nbndv(ispin),2 psic(1:fc%nrxxt)=(0.d0,0.d0) if (ii==num_nbndv(ispin)) then psic(fc%nlt(1:fc%npwt)) = w_wfcs_t(1:fc%npwt,ii) psic(fc%nltm(1:fc%npwt)) = CONJG( w_wfcs_t(1:fc%npwt,ii) ) else psic(fc%nlt(1:fc%npwt))=w_wfcs_t(1:fc%npwt,ii)+(0.d0,1.d0)*w_wfcs_t(1:fc%npwt,ii+1) psic(fc%nltm(1:fc%npwt)) =CONJG(w_wfcs_t(1:fc%npwt,ii))+(0.d0,1.d0)*CONJG(w_wfcs_t(1:fc%npwt,ii+1)) endif CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) w_wfcs_r(1:fc%nrxxt,ii)= DBLE(psic(1:fc%nrxxt)) if(ii/=num_nbndv(ispin)) w_wfcs_r(1:fc%nrxxt,ii+1)= DIMAG(psic(1:fc%nrxxt)) w_wfcs_2(1:fc%nrxxt,ii)=w_wfcs_r(1:fc%nrxxt,ii)**2 if(ii/=num_nbndv(ispin)) w_wfcs_2(1:fc%nrxxt,ii+1)=w_wfcs_r(1:fc%nrxxt,ii+1)**2 enddo ! compute the overlap matrix o_vv' call dgemm('T','N',num_nbndv(ispin),num_nbndv(ispin),fc%nrxxt,1.d0, w_wfcs_2, & & fc%nrxxt,w_wfcs_2, fc%nrxxt, 0.d0, o_mat,num_nbndv(ispin)) call mp_sum(o_mat,world_comm) o_mat(1:num_nbndv(ispin),1:num_nbndv(ispin))= & & o_mat(1:num_nbndv(ispin),1:num_nbndv(ispin))/(fc%nr1t*fc%nr2t*fc%nr3t) do iv=1,num_nbndv(ispin) do jv=1,num_nbndv(ispin) write(stdout,*) 'iv,jv,o_mat',iv,jv,o_mat(iv,jv) enddo enddo call flush_unit(stdout) ! write it on disk if(ionode) then iunu = find_free_unit() if (ispin==1) open(unit=iunu,file=trim(tmp_dir)//trim(prefix)//'.wbse1',status='unknown',form='unformatted') if (ispin==2) open(unit=iunu,file=trim(tmp_dir)//trim(prefix)//'.wbse2',status='unknown',form='unformatted') write(iunu) num_nbndv(ispin) write(iunu) s_bse do ii=1,num_nbndv(ispin) write(iunu) o_mat(1:num_nbndv(ispin),ii) enddo close(iunu) endif ! if Ovv'> s_bse compute in G-space the v*w_v*w_v' product iungprod = find_free_unit() if (ispin==1) CALL diropn( iungprod, 'vww_bse1.',npw*2, exst) if (ispin==2) CALL diropn( iungprod, 'vww_bse2.',npw*2, exst) if(debug) then iundebug = find_free_unit() open(iundebug,file='vww_pw4gww.dat') endif ! compute V(G) allocate(fac(npw)) if(l_truncated_coulomb) then do ig=1,npw qq = g(1,ig)**2.d0 + g(2,ig)**2.d0 + g(3,ig)**2.d0 if (qq > 1.d-8) then fac(ig)=(e2*fpi/(tpiba2*qq))*(1.d0-dcos(dsqrt(qq)*truncation_radius*tpiba)) else fac(ig)=e2*fpi*(truncation_radius**2.d0/2.d0) endif enddo fac(:)=fac(:)/omega else fac(:)=0.d0 fac(1:npw)=vg_q(1:npw) endif allocate(ww_prod(fc%nrxxt)) allocate(ww_prodg(fc%npwt)) allocate(ww_prodg2(npw)) ii=0 do iv=1, num_nbndv(ispin) do jv=1, num_nbndv(ispin) if (o_mat(iv,jv)>=s_bse) then ii=ii+1 ww_prod(1:fc%nrxxt)= w_wfcs_r(1:fc%nrxxt,iv)* w_wfcs_r(1:fc%nrxxt,jv) psic(1:fc%nrxxt)=ww_prod(1:fc%nrxxt) CALL cft3t(fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, -2 ) ww_prodg(1:fc%npwt) = psic(fc%nlt(1:fc%npwt)) if(fc%dual_t==4.d0) then ww_prodg2(:)=ww_prodg(:) else call mergewf(ww_prodg,evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) call splitwf(ww_prodg2,evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) endif ww_prodg2(1:npw)=ww_prodg2(1:npw)*fac(1:npw) call davcio(ww_prodg2,npw*2,iungprod,ii,1) if(debug) then if(ionode) then write(iundebug,*) npw do i=1,npw write(iundebug,*) ww_prodg2(i) enddo endif endif endif enddo enddo write(stdout,*) 'bse ii found=',ii write(stdout,*) 'max_ngm=',max_ngm write(stdout,*) 'npw=',npw call flush_unit(stdout) close(iungprod) ! read polarization basis allocate(p_basis(npw,numw_prod)) CALL diropn( iungprod, 'wiwjwfc_red', npw*2, exst ) do ii=1,numw_prod call davcio(p_basis(:,ii),npw*2,iungprod,ii,-1) p_basis(1:npw,ii)=p_basis(1:npw,ii)*fac(1:npw) enddo close(iungprod) ! maximum number of non-zero overlap np_max=0 do iv=1, num_nbndv(ispin) np=0 do jv=1, num_nbndv(ispin) if (o_mat(iv,jv)>=s_bse) np=np+1 enddo if (np>np_max) np_max=np enddo if(ionode) then iunz = find_free_unit() if (ispin==1) open(unit=iunz,file=trim(tmp_dir)//trim(prefix)//'.zbse1',status='unknown',form='unformatted') if (ispin==2) open(unit=iunz,file=trim(tmp_dir)//trim(prefix)//'.zbse2',status='unknown',form='unformatted') write(iunz) num_nbndv(ispin) write(iunz) s_bse write (iunz) np_max write (iunz) numw_prod endif allocate(z(numw_prod)) z(1:numw_prod)=0.d0 do iv=1, num_nbndv(ispin) do jv=1, num_nbndv(ispin) if (o_mat(jv,iv)>=s_bse) then ww_prod(1:fc%nrxxt)= w_wfcs_r(1:fc%nrxxt,iv)* w_wfcs_r(1:fc%nrxxt,jv) psic(1:fc%nrxxt)=dcmplx(ww_prod(1:fc%nrxxt),0.d0) CALL cft3t(fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, -2 ) ww_prodg(1:fc%npwt) = psic(fc%nlt(1:fc%npwt)) call mergewf(ww_prodg,evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) call splitwf(ww_prodg2,evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) call dgemm('T','N',numw_prod,1,2*npw,2.d0,p_basis,& &2*npw,ww_prodg2,2*npw,0.d0,z,numw_prod) if(gstart==2) then do ii=1,numw_prod z(ii)=z(ii)-dble(p_basis(1,ii)*conjg(ww_prodg2(1))) enddo endif call mp_sum(z,world_comm) if(ionode) then write(iunz) z endif endif enddo enddo close(iunz) allocate(iww(np_max)) ! in file iwwbse1 we write, for each iv, the set of jv for which ! o_mat(iv,jv)>=s_bse if(ionode) then iuni = find_free_unit() if (ispin==1) open(unit=iuni,file=trim(tmp_dir)//trim(prefix)//'.iwwbse1',status='unknown',form='unformatted') if (ispin==2) open(unit=iuni,file=trim(tmp_dir)//trim(prefix)//'.iwwbse2',status='unknown',form='unformatted') write(iuni) num_nbndv(ispin) write(iuni) s_bse write (iuni) np_max endif do iv=1, num_nbndv(ispin) ii=0 iww(1:np_max)=0 do jv=1, num_nbndv(ispin) if (o_mat(jv,iv)>=s_bse) then ii=ii+1 iww(ii)=jv endif enddo if(ionode) write(iuni) iww enddo close(iuni) if(debug) close(iundebug) deallocate(iww) deallocate(z) deallocate(p_basis) deallocate(ww_prod) deallocate(ww_prodg) deallocate(ww_prodg2) deallocate(fac) call deallocate_fft_custom(fc) deallocate(w_wfcs_t) deallocate(w_wfcs_r) deallocate(w_wfcs_2) deallocate(evc_g) end subroutine GWW/pw4gww/wannier.f900000644000077300007730000003017212341332532015235 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !------------------------- subroutine go_wannier( iun_wannier, tresh, maxiter,nbndv, itask, ispin) !------------------------- ! this routine read the wfcs from iun_wannier then ! transfrom to real wfcs, transform to wannier functions ! with treshold tresh and maxiter ! using Gygi scheme ! and writes wfcs on iun_wannier and writes wannier_centers file ! it's possible to localized two different subspaces USE kinds, ONLY : DP USE us USE wvfct, ONLY : igk, g2kin, npwx, npw, nbndx,nbnd USE wavefunctions_module, ONLY : evc USE gvect USE basis USE klist USE constants, ONLY : e2, pi, tpi, fpi USE io_files, ONLY: nwordwfc USE io_global, ONLY : stdout USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2 USE wannier_gw USE mp, ONLY : mp_sum, mp_bcast, mp_barrier USE mp_world, ONLY : mpime, nproc USE control_flags, ONLY : gamma_only implicit none INTEGER, INTENT(in) :: iun_wannier !units for reading wfc REAL(kind=DP), INTENT(in) :: tresh! treshold on wannier wfcs'spread INTEGER, INTENT(in) :: maxiter!max number of iterations INTEGER, INTENT(in) :: nbndv !number of first bands wich are localized separately INTEGER,INTENT(in) :: itask! if == 1 calculate {C'} subspace INTEGER, INTENT(in) :: ispin!spin channel ! --- Internal definitions --- INTEGER :: i,j,k,l,it,iw, ii COMPLEX(kind=DP), ALLOCATABLE :: matgp(:,:,:)! for matrix REAL(kind=DP), ALLOCATABLE :: matsincos(:,:,:) !respective sin and cos matrices REAL(kind=DP), ALLOCATABLE ::rot_u(:,:) ! unitarian matrix which transorm to wannier wfcs REAL(kind=DP) :: w(6) ! weights for orthorombic cells COMPLEX(kind=DP), ALLOCATABLE :: crot_u(:,:),crot_u_tmp(:,:) INTEGER nbnd_start, nbnd_end!for conduction states manifolds REAL(kind=DP) :: theta, theta4, d2, aa(2), cc, ss, tempi, tempj REAL(kind=DP) :: omg0,omg1!omega for testi convergence COMPLEX(kind=DP) :: sca REAL(kind=DP), ALLOCATABLE :: tmp_mat(:,:) INTEGER :: nbnd_second INTEGER :: n_oper INTEGER :: na,nb REAL(kind=DP) :: delta REAL(kind=DP), ALLOCATABLE :: vtmpi(:),vtmpj(:) REAL(Kind=DP), ALLOCATABLE :: ene_tmp(:) INTEGER :: nbnd_par,nbnd_start_me,nbnd_end_me,nbnd_start_proc,nbnd_end_proc,ip REAL(kind=DP), ALLOCATABLE :: matsincos_par(:,:,:) INTEGER :: n_oper_par,oper_start,oper_end REAL(kind=DP) :: sca_mat(6) ! ALLOCATE( matgp(nbnd,nbnd,3)) ALLOCATE( matsincos(nbnd,nbnd,6)) !transfrom to real wfcs: write(stdout,*) 'Transform to real wfcs' call flush_unit(stdout) if(nbndv<0 .OR. nbndv > nbnd) call errore('go_wannier','nbndv: illegal value',1) !if(mod(nbndv,2) /= 0 ) call errore('go_wannier','nbndv, odd',1) if(.not.gamma_only) then !call real_wfc(u_trans, 1, iun_wannier,nbndv) else !writes KS wavefunctions on file u_trans(:,:,ispin)=(0.d0,0.d0)!it could also be defined as real do iw=1,nbnd u_trans(iw,iw,ispin)=(1.d0,0.d0) enddo endif ! set matg p,m matrices if(gamma_only) then !call matrix_wannier_gamma_big(matgp,1,nset,itask) call matrix_wannier_gamma_big(matsincos,ispin,nset,itask) else write(stdout,*)'ONLY GAMMA POINT IMPLEMENTED' stop endif write(stdout,*) 'Out of matrix_wannier_gamma_big' call flush_unit(stdout) ! set weights do i=1,3 w(i)=((at(i,i)*alat)/pi) w(i+3)=((at(i,i)*alat)/pi) enddo ! calculates matsincos do i=1,3 matsincos(1:nbnd,1:nbnd,i)=w(i)*matsincos(1:nbnd,1:nbnd,i) matsincos(1:nbnd,1:nbnd,i+3)=w(i)*matsincos(1:nbnd,1:nbnd,i+3) ! matsincos(1:nbnd,1:nbnd,i)=w(i)*real(matgp(1:nbnd,1:nbnd,i)) ! matsincos(1:nbnd,1:nbnd,i+3)=w(i)*aimag(matgp(1:nbnd,1:nbnd,i)) enddo ! deallocate(matgp) n_oper=6 !----------------Young'su stuff----- ! Scale thr according to # of Wannier orbitals and cell length ! set initial rotation matrix ALLOCATE (rot_u(nbnd,nbnd)) rot_u(:,:)=0.d0 do i=1,nbnd rot_u(i,i)=1.d0 end do ! now valence subspace ! calculate omega omg0 = 0.d0 do k=1,6 do i=1,nbndv omg0=omg0 + matsincos(i,i,k)*matsincos(i,i,k) enddo enddo write(stdout ,*) 'LOCALIZING WANNIER FUNCTIONS:' call flush_unit(stdout) ! Start Iteration ===================================================== do it=1,maxiter do i=1,nbndv do j=i+1,nbndv ! Construct aa aa(:)=0.d0 do k=1,n_oper aa(1)=aa(1)+matsincos(i,j,k)*(matsincos(i,i,k)-matsincos(j,j,k)) aa(2)=aa(2)+matsincos(i,j,k)*matsincos(i,j,k)-& &0.25d0*(matsincos(i,i,k)-matsincos(j,j,k))*(matsincos(i,i,k)-matsincos(j,j,k)) end do if(abs(aa(2)).gt.1.d-14) then theta4=-aa(1)/aa(2) theta=0.25*atan(theta4) elseif (abs(aa(1)).lt.1.d-14) then theta=0.d0 aa(2)=0.d0 else theta=pi/4.d0 endif d2=aa(1)*sin(4.*theta)-aa(2)*cos(4.*theta) if(d2.le.0.d0) theta=theta+pi/4.d0 ! cc=cos(theta) ss=sin(theta) ! update overlap matrices do l=1,n_oper ! AR do k=1,nbndv tempi=matsincos(k,i,l)*cc+matsincos(k,j,l)*ss tempj=-matsincos(k,i,l)*ss+matsincos(k,j,l)*cc matsincos(k,i,l)=tempi matsincos(k,j,l)=tempj end do ! R^+ A R do k=1,nbndv tempi=cc*matsincos(i,k,l)+ss*matsincos(j,k,l) tempj=-ss*matsincos(i,k,l)+cc*matsincos(j,k,l) matsincos(i,k,l)=tempi matsincos(j,k,l)=tempj end do end do ! update U : U=UR do k=1,nbndv tempi=rot_u(k,i)*cc+rot_u(k,j)*ss tempj=-rot_u(k,i)*ss+rot_u(k,j)*cc rot_u(k,i)=tempi rot_u(k,j)=tempj end do ! end do end do omg1=0.d0 do k=1,n_oper do i=1,nbndv omg1=omg1+matsincos(i,i,k)*matsincos(i,i,k) end do end do write(stdout,*) 'Spread', omg1,omg0 call flush_unit(stdout) if(abs(omg1-omg0).lt.tresh ) EXIT omg0=omg1 end do !centers of wanniers do i=1,nbndv do k=1,3 wannier_centers(k,i,1)=aimag(log(matsincos(i,i,k)+(0.d0,1.d0)*matsincos(i,i,k+3))) wannier_centers(k,i,1)=wannier_centers(k,i,1)*at(k,k)/2.d0/pi if(wannier_centers(k,i,1) < 0.d0) wannier_centers(k,i,1)=at(k,k)+wannier_centers(k,i,1) end do enddo do i=1,nbndv write(stdout,*) 'Center Wannier:', wannier_centers(1,i,1)*alat,wannier_centers(3,i,1)*alat,wannier_centers(3,i,1)*alat enddo call flush_unit(stdout) !---now conduction subspace deallocate(matsincos) !!!!!!!!!!!!!!!!!!!!!!!!!!!!! !------ rotate wfc if(.not.gamma_only) then !call rotate_wannier(rot_u,1,iun_wannier) else call rotate_wannier_gamma(rot_u,1,0) endif !------------update u_trans !crot_u and u_trans are complex, rot_u is real allocate(crot_u(nbnd,nbnd),crot_u_tmp(nbnd,nbnd)) crot_u_tmp(:,:)=dcmplx(rot_u(:,:),0.d0) call zgemm('T','N',nbnd,nbnd,nbnd,(1.d0,0.d0),crot_u_tmp,nbnd,u_trans(1,1,ispin),nbnd,& &(0.d0,0.d0),crot_u,nbnd) u_trans(1:nbnd,1:nbnd,ispin)=crot_u(1:nbnd,1:nbnd) ! deallocate(rot_u) deallocate(crot_u,crot_u_tmp) return end subroutine go_wannier function fast_sin(theta,na,nb,table_sin_a, table_sin_b, table_cos_a, table_cos_b) !this routine calculates fast the sinus !using sin(alpha+beta)=sin(alpha)*cos(beta)+sin(beta)cos(alpha) USE kinds, ONLY : DP USE constants, ONLY : pi,tpi implicit none REAL(kind=DP) :: fast_sin!the calculated value for the sin REAL(kind=DP), INTENT(in) :: theta!the input angle in radiants INTEGER :: na!number of elements in the table (pi/2)/Na from 0 to pi/2 INTEGER :: nb!number of elements in the table (pi/2)/(Na*Nb) for 0 to (pi/2)/(Na) REAL(kind=DP) :: table_sin_a(na)!tabel of sin (pi/2)/Na from 0 to pi/2 REAL(kind=DP) :: table_sin_b(nb)!tabel of sin (pi/2)/Na from 0 to pi/2 REAL(kind=DP) :: table_cos_a(na)!tabel of cos (pi/2)/Na from 0 to pi/2 REAL(kind=DP) :: table_cos_b(nb)!tabel of cos (pi/2)/Na from 0 to pi/2 REAL(kind=DP) :: angle, angle_p INTEGER :: ia,ib REAL(kind=DP) :: sign, da, db !find angle from 0 to pi/2 angle_p= theta - real(floor(theta/tpi))*tpi if( angle_p <= (pi/2.d0)) then angle=angle_p sign=1.d0 else if( angle_p <= pi) then sign=1.d0 angle=pi-angle_p else if(angle_p <= 3.d0*pi/2.d0) then sign=-1.d0 angle=angle_p-pi else sign=-1.d0 angle=tpi-angle_p endif !determines ia, ib da=pi/(2.d0*real(na)) db=da/real(nb) ia=floor(angle/(da)) ib=floor((angle-real(ia)*da)/db) ia=ia+1 ib=ib+1 !sin(a+b) fast_sin=sign*(table_sin_a(ia)*table_cos_b(ib)+table_sin_b(ib)*table_cos_a(ia)) return end function fast_sin function fast_cos(theta,na,nb,table_sin_a, table_sin_b, table_cos_a, table_cos_b) !this routine calculates fast the sinus !using cos(alpha+beta)=cos(alpha)*cos(beta)-sin(alpha)*sin(beta) USE kinds, ONLY : DP USE constants, ONLY : pi,tpi implicit none REAL(kind=DP) :: fast_cos!the calculated value for the cos REAL(kind=DP), INTENT(in) :: theta!the input angle in radiants INTEGER :: na!number of elements in the table (pi/2)/Na from 0 to pi/2 INTEGER :: nb!number of elements in the table (pi/2)/(Na*Nb) for 0 to (pi/2)/(Na) REAL(kind=DP) :: table_sin_a(na)!tabel of sin (pi/2)/Na from 0 to pi/2 REAL(kind=DP) :: table_sin_b(nb)!tabel of sin (pi/2)/Na from 0 to pi/2 REAL(kind=DP) :: table_cos_a(na)!tabel of cos (pi/2)/Na from 0 to pi/2 REAL(kind=DP) :: table_cos_b(nb)!tabel of cos (pi/2)/Na from 0 to pi/2 REAL(kind=DP) :: angle, angle_p INTEGER :: ia,ib REAL(kind=DP) :: sign, da, db !find angle from 0 to pi/2 angle_p= theta - real(floor(theta/tpi))*tpi if( angle_p <= (pi/2.d0)) then angle=angle_p sign=1.d0 else if( angle_p <= pi) then sign=-1.d0 angle=pi-angle_p else if(angle_p <= 3.d0*pi/2.d0) then sign=-1.d0 angle=angle_p-pi else sign=1.d0 angle=tpi-angle_p endif !determines ia, ib da=pi/(2.d0*real(na)) db=da/real(nb) ia=floor(angle/(da)) ib=floor((angle-real(ia)*da)/db) ia=ia+1 ib=ib+1 !cos(a+b) fast_cos=sign*(table_cos_a(ia)*table_cos_b(ib)-table_sin_a(ia)*table_sin_b(ib)) return end function fast_cos function fast_atan(tg,na,nb,table_sin_a, table_sin_b, table_cos_a, table_cos_b) !this routine calculates fast the arctan using a bisection algorithm USE kinds, ONLY : DP USE constants, ONLY : pi implicit none REAL(kind=DP) :: fast_atan!the calculated value for the atan REAL(kind=DP), INTENT(in) :: tg!the input tan INTEGER :: na!number of elements in the table (pi/2)/Na from 0 to pi/2 INTEGER :: nb!number of elements in the table (pi/2)/(Na*Nb) for 0 to (pi/2)/(Na) REAL(kind=DP) :: table_sin_a(na)!tabel of sin (pi/2)/Na from 0 to pi/2 REAL(kind=DP) :: table_sin_b(nb)!tabel of sin (pi/2)/Na from 0 to pi/2 REAL(kind=DP) :: table_cos_a(na)!tabel of cos (pi/2)/Na from 0 to pi/2 REAL(kind=DP) :: table_cos_b(nb)!tabel of cos (pi/2)/Na from 0 to pi/2 INTEGER, PARAMETER :: n=20!number of bisections REAL(kind=DP) :: sign, tang INTEGER :: i REAL(kind=DP) :: ang, delta REAL(kind=DP) :: tan_try REAL(kind=DP), EXTERNAL :: fast_sin, fast_cos if(tg >= 0.d0) then sign=1.d0 tang=tg else sign=-1.d0 tang=-tg endif ang=pi/4.d0 delta=pi/4.d0 do i=1,n delta=delta/2.d0 tan_try=fast_sin(ang,na,nb,table_sin_a, table_sin_b, table_cos_a, table_cos_b)/& &fast_cos(ang,na,nb,table_sin_a, table_sin_b, table_cos_a, table_cos_b) if(tang >= tan_try) then ang=ang+delta else ang=ang-delta endif enddo fast_atan=sign*ang return end function fast_atan GWW/pw4gww/self_lanczos.f900000644000077300007730000017215712341332532016266 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !routines for the calculation of the self-energy !lanczos-style !ONLY FOR NORMCONSERVING PSEUDOS !!!!! subroutine self_basis_lanczos(n_set,nstates,numpw, nsteps,ispin,lfull,nfull) !this subroutine calculates the basis for every v !the minimal orthonormal basis for the Psi_i(r)*(v(r,r')*w^P'_i(r')) products USE io_global, ONLY : stdout, ionode, ionode_id USE io_files, ONLY : prefix, tmp_dir, diropn USE kinds, ONLY : DP USE wannier_gw USE gvect USE constants, ONLY : e2, pi, tpi, fpi USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2 USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, ecutwfc USE wavefunctions_module, ONLY : evc, psic USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : world_comm, mpime, nproc USE mp_pools, ONLY : intra_pool_comm USE gvecs, ONLY : nls, nlsm, doublegrid !USE exx, ONLY : exx_divergence_new, yukawa USE fft_custom_gwl USE mp_wave, ONLY : mergewf,splitwf USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER, INTENT(in) :: n_set !defines the number of states to be read from disk at the same tim\e INTEGER, INTENT(in) :: nstates!number of orthonormal states to retain INTEGER, INTENT(in) :: numpw!dimension of polarization basis INTEGER, INTENT(in) :: nsteps!number of lanczos steps INTEGER, INTENT(in) :: ispin!spin channel 1,2 LOGICAL, INTENT(in) :: lfull!if true prepare terms for full-relativistic calculation INTEGER, INTENT(in) :: nfull!in case of full-relativistic calculation the number of KS states (*1/2) to be treated in G !as proper two dimensional spinors INTEGER :: iv,iw,ig,ii,jj REAL(kind=DP), ALLOCATABLE :: wv_real(:),tmp_r(:),tmp_r2(:) COMPLEX(kind=DP), ALLOCATABLE :: tmp_g(:), wp_prod(:,:,:) INTEGER :: iungprod,iunrprod, iungresult,iuntmat LOGICAL :: exst REAL(kind=DP), ALLOCATABLE :: omat(:,:),omat_hold(:,:) REAL(kind=DP), ALLOCATABLE :: eigen(:),work(:) INTEGER :: lwork,info,liwork COMPLEX(kind=DP), ALLOCATABLE :: wp_g(:,:)!product terms in g wfc grid REAL(kind=DP), ALLOCATABLE :: t_mat(:,:),t_mat_hold(:,:),t_mat_hold2(:,:) CHARACTER(4) :: nfile REAL(kind=DP), ALLOCATABLE :: fac(:) REAL(kind=DP) :: qq,exxdiv LOGICAL :: l_reduce_io=.true.!MUST BE THE SAME AS IN POLA_LANCZOS COMPLEX(kind=DP), ALLOCATABLE :: p_basis(:,:)!polarizability basis LOGICAL :: l_dsyevr=.true.!if true uses dsyevr REAL(kind=DP), ALLOCATABLE :: vectors(:,:)!for dsyevr INTEGER, ALLOCATABLE :: iwork(:), ifail(:) INTEGER, ALLOCATABLE :: isuppz(:) INTEGER :: n_found INTEGER, PARAMETER :: n_int=20 REAL(kind=DP) :: qx,qy,qz INTEGER :: ix,iy,iz,n_int_loc REAL(kind=DP) :: qq_fact COMPLEX(kind=DP), ALLOCATABLE :: evc_t(:,:),p_basis_t(:,:) COMPLEX(kind=DP), ALLOCATABLE :: evc_g(:) COMPLEX(kind=DP), ALLOCATABLE :: wp_g_t(:,:) REAL(kind=DP), ALLOCATABLE :: p_basis_r(:,:) INTEGER :: ivv,nbuf INTEGER, PARAMETER :: offset=0!ATTENZIONE RESTART it is to used a reduced polarizability basis it should be 0 INTEGER :: first_state!attenzione should be 1 RESTART INTEGER :: last_state!ATTENZIONE RESTART should be num_nbnds INTEGER :: il,iu REAL(kind=DP) :: vl,vu REAL(kind=DP), ALLOCATABLE :: t_eigen_hold(:) REAL(kind=DP), ALLOCATABLE :: fumat(:,:) TYPE(fft_cus) :: fc write(stdout,*) 'Routine self_basis_lanczos' call flush_unit(stdout) if(s_first_state==0) then first_state=1 else first_state=s_first_state endif if(s_last_state==0) then last_state=num_nbnds else last_state=s_last_state endif ! first_state=1!1 ! last_state=num_nbnds !calculate V(G) ! if(.not.l_truncated_coulomb) then exxdiv=0.d0!exx_divergence_new() else exxdiv = 0.d0 endif allocate(fac(max_ngm)) if(l_truncated_coulomb) then do ig=1,max_ngm qq = g(1,ig)**2.d0 + g(2,ig)**2.d0 + g(3,ig)**2.d0 if (qq > 1.d-8) then fac(ig)=(e2*fpi/(tpiba2*qq))*(1.d0-dcos(dsqrt(qq)*truncation_radius*tpiba)) else fac(ig)=e2*fpi*(truncation_radius**2.d0/2.d0) endif enddo fac(:)=fac(:)/omega else fac(:)=0.d0 fac(1:npw)=vg_q(1:npw) endif if(l_verbose) write(stdout,*) 'Call initialize_fft_custom' fc%ecutt=ecutwfc fc%dual_t=dual_vs call flush_unit(stdout) call initialize_fft_custom(fc) !allocate(evc_g(fc%ngmt_g)) allocate(wv_real(fc%nrxxt)) !read w^P'_i on file on real space !open product of wanniers filed iungprod = find_free_unit() CALL diropn( iungprod, 'wiwjwfc_red', max_ngm*2, exst ) if(.not.l_reduce_io) then iunrprod = find_free_unit() CALL diropn( iunrprod, 'wiwjwfc_red_r', dfftp%nnr, exst ) else allocate(p_basis(max_ngm,numpw)) do iw=1,numpw call davcio(p_basis(:,iw),max_ngm*2,iungprod,iw,-1) enddo endif iungresult = find_free_unit() if(ispin==1) then CALL diropn( iungresult, 'vw_lanczos_ss',npw*2, exst) else CALL diropn( iungresult, 'vw_lanczos_2ss',npw*2, exst) endif if(.not.l_reduce_io) then allocate(tmp_g(max_ngm),tmp_r(dfftp%nnr)) do iw=1,numpw call davcio(tmp_g,max_ngm*2,iungprod,iw,-1) !trasform to r-space psic(:)=(0.d0,0.d0) do ig=1,max_ngm psic(nl(ig))=tmp_g(ig)*fac(ig) psic(nlm(ig))=CONJG(tmp_g(ig))*fac(ig) enddo CALL invfft ('Dense', psic, dfftp) tmp_r(:)=dble(psic(:)) call davcio(tmp_r,dfftp%nnr,iunrprod,iw,1) enddo deallocate(tmp_g,tmp_r) endif close(iungprod) if(.not.l_reduce_io) close(iunrprod) !now polarizability basis times v are put on the ordering of the redueced grid, if required allocate(p_basis_t(fc%npwt,numpw)) do ii=1,numpw p_basis(1:npw,ii)=fac(1:npw)*p_basis(1:npw,ii) enddo if(fc%dual_t==4.d0) then p_basis_t(:,:)=p_basis(:,:) else call reorderwfp_col(numpw,npw,fc%npwt,p_basis(1,1),p_basis_t(1,1), npw,fc%npwt, & & ig_l2g,fc%ig_l2gt,fc%ngmt_g,mpime, nproc,intra_pool_comm ) endif !trasform to real space allocate(p_basis_r(fc%nrxxt,numpw)) do ii=1,numpw,2 psic(:)=(0.d0,0.d0) if(ii==numpw) then psic(fc%nlt(1:fc%npwt)) = p_basis_t(1:fc%npwt,ii) psic(fc%nltm(1:fc%npwt)) = CONJG( p_basis_t(1:fc%npwt,ii) ) else psic(fc%nlt(1:fc%npwt))=p_basis_t(1:fc%npwt,ii)+(0.d0,1.d0)*p_basis_t(1:fc%npwt,ii+1) psic(fc%nltm(1:fc%npwt)) = CONJG( p_basis_t(1:fc%npwt,ii) )+(0.d0,1.d0)*CONJG( p_basis_t(1:fc%npwt,ii+1) ) endif CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) p_basis_r(1:fc%nrxxt,ii)= DBLE(psic(1:fc%nrxxt)) if(ii/=numpw) p_basis_r(1:fc%nrxxt,ii+1)= DIMAG(psic(1:fc%nrxxt)) enddo !now valence wavefunctions are put on the ordering of the reduced grid allocate(evc_t(fc%npwt,num_nbnds)) if(fc%dual_t==4.d0) then evc_t(:,1:num_nbnds)=evc(:,1:num_nbnds) else call reorderwfp_col(num_nbnds,npw,fc%npwt,evc(1,1),evc_t(1,1), npw,fc%npwt, & & ig_l2g,fc%ig_l2gt,fc%ngmt_g,mpime, nproc,intra_pool_comm ) !do iv=1,num_nbnds ! call mergewf(evc(:,iv),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) ! call splitwf(evc_t(:,iv),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) !enddo endif if(l_verbose) write(stdout,*) 'self_basis_lanczos 1' call flush_unit(stdout) nbuf=min(5,nproc) allocate(wp_prod(fc%npwt,numpw,nbuf)) allocate(tmp_r(fc%nrxxt),tmp_r2(fc%nrxxt)) allocate(omat(numpw,numpw),omat_hold(numpw,numpw)) allocate(t_mat(numpw,nstates), t_mat_hold(numpw,nstates), t_mat_hold2(numpw,nstates)) allocate(wp_g(npw,nstates)) allocate(wp_g_t(fc%npwt,nstates)) allocate(t_eigen_hold(nstates)) !loop on kohn-sham states do ivv=first_state,last_state,nbuf call start_clock('sl_loop') do iv=ivv,min(ivv+nbuf-1,last_state) !put iv on real space psic(:)=(0.d0,0.d0) psic(fc%nlt(1:fc%npwt)) = evc_t(1:fc%npwt,iv) psic(fc%nltm(1:fc%npwt)) = CONJG( evc_t(1:fc%npwt,iv) ) CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) wv_real(1:fc%nrxxt)= DBLE(psic(1:fc%nrxxt)) !!loop on products of wanniers if(.not.l_reduce_io) then iunrprod = find_free_unit() CALL diropn( iunrprod, 'wiwjwfc_red_r', dfftp%nnr, exst ) endif if(l_verbose) write(stdout,*) 'do fft' call flush_unit(stdout) do ii=offset+1,numpw,2 !!read n_set w^P'_i from disk if(.not.l_reduce_io) then call davcio(tmp_r,dfftp%nnr,iunrprod,ii,-1) endif tmp_r(1:fc%nrxxt)=p_basis_r(1:fc%nrxxt,ii)*wv_real(1:fc%nrxxt) if(ii/=numpw) then tmp_r2(1:fc%nrxxt)=p_basis_r(1:fc%nrxxt,ii+1)*wv_real(1:fc%nrxxt) else tmp_r2(1:fc%nrxxt)=0.d0 endif !!form products with w_v and trasfrom in G space psic(1:fc%nrxxt)=dcmplx(tmp_r(1:fc%nrxxt),tmp_r2(1:fc%nrxxt)) CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, -2 ) if(ii==numpw) then wp_prod(1:fc%npwt, ii,iv-ivv+1) = psic(fc%nlt(1:fc%npwt)) else wp_prod(1:fc%npwt, ii,iv-ivv+1)= 0.5d0*(psic(fc%nlt(1:fc%npwt))+conjg( psic(fc%nltm(1:fc%npwt)))) wp_prod(1:fc%npwt, ii+1,iv-ivv+1)= (0.d0,-0.5d0)*(psic(fc%nlt(1:fc%npwt)) - conjg(psic(fc%nltm(1:fc%npwt)))) endif !!form products with w_v and trasfrom in G space enddo !if required project off first nfull states if(lfull .and. nfull > 1 ) then allocate(fumat(nfull,numpw)) call DGEMM('T','N',nfull,numpw,2*fc%npwt,2.d0,evc_t,2*fc%npwt,wp_prod(1,1,iv-ivv+1),2*fc%npwt,0.d0,fumat,nfull) if(fc%gstart_t==2) then do ii=1,nfull do jj=1,numpw fumat(ii,jj)=fumat(ii,jj)-dble(conjg(evc_t(1,ii))*wp_prod(1,jj,iv-ivv+1)) enddo enddo endif call mp_sum(fumat,world_comm) call DGEMM('N','N',2*fc%npwt,numpw,nfull,-1.d0,evc_t,2*fc%npwt,fumat,nfull,1.d0,wp_prod(1,1,iv-ivv+1),2*fc%npwt) deallocate(fumat) endif if(l_verbose) write(stdout,*) 'calculate omat' call flush_unit(stdout) if(.not.l_reduce_io) close(iunrprod) !!calculate overlap matrix call dgemm('T','N',numpw-offset,numpw-offset,2*fc%npwt,2.d0,wp_prod(1,offset+1,iv-ivv+1),& &2*fc%npwt,wp_prod(1,offset+1,iv-ivv+1),2*fc%npwt,0.d0,omat,numpw) if(fc%gstart_t==2) then do ii=1,numpw-offset do jj=1,numpw-offset omat(jj,ii)=omat(jj,ii)-dble(conjg(wp_prod(1,offset+jj,iv-ivv+1))*wp_prod(1,offset+ii,iv-ivv+1)) enddo enddo endif do ii=1,numpw-offset call mp_sum(omat(1:numpw-offset,ii),world_comm) enddo if(iv-ivv==mpime) then omat_hold(:,:)=omat(:,:) endif enddo !! !!solve eigen/values vector problem !! if(l_verbose) write(stdout,*) 'solve eig' call flush_unit(stdout) do iv=ivv,min(ivv+nbuf-1,last_state) if(iv-ivv==mpime) then if(.not.l_dsyevr) then allocate(eigen(numpw-offset)) allocate(work(1)) call DSYEV( 'V', 'U', numpw-offset, omat_hold, numpw, eigen, work, -1, info ) lwork=work(1) deallocate(work) allocate(work(lwork)) call DSYEV( 'V', 'U', numpw-offset, omat_hold, numpw, eigen, work, lwork, info ) deallocate(work) if(info/=0) then write(stdout,*) 'ROUTINE self_basis_lanczos, INFO:', info stop endif !do iw=1,numpw ! write(stdout,*) 'EIGEN:',iv,iw, eigen(iw) !enddo !call flush_unit(stdout) else allocate(eigen(numpw-offset)) allocate(vectors(numpw-offset,nstates)) allocate(isuppz(2*nstates)) allocate(work(1),iwork(1)) omat_hold(1:numpw,1:numpw)=omat_hold(1:numpw,1:numpw)*1.d10!to cope with DSYEVR instabilities call DSYEVR('V','I','U',numpw-offset,omat_hold,numpw,0.d0,0.d0,& &numpw-offset-nstates+1,numpw-offset,0.d0,n_found,eigen,& & vectors,numpw-offset,isuppz,work, -1,iwork,-1, info) lwork=work(1) liwork=iwork(1) deallocate(work,iwork) allocate(work(lwork)) allocate(iwork(liwork)) vl=0.d0 vu=0.d0 il=numpw-offset-nstates+1 iu=numpw-offset call DSYEVR('V','I','U',numpw-offset,omat_hold,numpw,vl,vu,il,iu,0.d0,n_found,eigen,& & vectors,numpw-offset,isuppz,work,lwork,iwork,liwork, info) eigen(1:numpw)=eigen(1:numpw)*1.d-10!to cope with DSYEVR instabilities if(info/=0) then write(stdout,*) 'ROUTINE pola_lanczos DSYEVR, INFO:', info stop endif deallocate(isuppz) deallocate(work,iwork) do iw=1,nstates, nstates-1 write(stdout,*) 'EIGEN S LOCAL:',iv,iw, eigen(iw) enddo call flush_unit(stdout) endif t_mat_hold(:,:)=0.d0 t_mat_hold2(:,:)=0.d0 if(.not.l_dsyevr) then do ii=1,nstates do jj=1,numpw-offset t_mat_hold(jj+offset,ii)=omat_hold(jj,numpw-offset-ii+1)*(dsqrt(eigen(numpw-offset-ii+1))) enddo t_eigen_hold(ii)=eigen(numpw-ii+1) enddo else do ii=1,nstates do jj=1,numpw-offset t_mat_hold(jj+offset,ii)=vectors(jj,ii)*(dsqrt(eigen(ii))) enddo t_eigen_hold(ii)=eigen(ii) enddo endif if(.not.l_dsyevr) then do ii=1,nstates t_mat_hold2(offset+1:numpw,ii)=omat_hold(1:numpw-offset,numpw-offset-ii+1)*(1.d0/dsqrt(eigen(numpw-offset-ii+1))) enddo else do ii=1,nstates t_mat_hold2(offset+1:numpw,ii)=vectors(1:numpw-offset,ii)*(1.d0/dsqrt(eigen(ii))) enddo endif deallocate(eigen) if(l_dsyevr) deallocate(vectors) endif enddo !!find liner dependent products !!find transformation matrix and write on disk ! if(l_verbose) write(stdout,*) 'write on file' call flush_unit(stdout) allocate(eigen(nstates)) do iv=ivv,min(ivv+nbuf-1,last_state) if(iv-ivv == mpime) then t_mat(:,:)=t_mat_hold(:,:) eigen(1:nstates)=t_eigen_hold(1:nstates) endif call mp_bcast(t_mat,iv-ivv,world_comm) call mp_bcast(eigen(1:nstates),iv-ivv,world_comm) if(ionode) then iuntmat = find_free_unit() write(nfile,'(4i1)') iv/1000,mod(iv,1000)/100,mod(iv,100)/10,mod(iv,10) if(ispin==1) then open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.s_mat_lanczos'//nfile, status='unknown',form='unformatted') else open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.s_mat_lanczos2'//nfile, status='unknown',form='unformatted') endif write(iuntmat) iv write(iuntmat) num_nbndv(1)!for compatibility with polarization file write(iuntmat) numpw write(iuntmat) nstates do ii=1,nstates write(iuntmat) t_mat(1:numpw,ii) enddo close(iuntmat) endif !write on disk file with eigen values if(ionode) then iuntmat = find_free_unit() write(nfile,'(4i1)') iv/1000,mod(iv,1000)/100,mod(iv,100)/10,mod(iv,10) if(ispin==1) then open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.s_eig_lanczos'//nfile, status='unknown',form='unformatted') else open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.s_eig_lanczos2'//nfile, status='unknown',form='unformatted') endif write(iuntmat) nstates write(iuntmat) eigen(1:nstates) close(iuntmat) endif !!find liner dependent products if(iv-ivv == mpime) then t_mat(:,:)=t_mat_hold2(:,:) endif call mp_bcast(t_mat,iv-ivv,world_comm) call dgemm('N','N',2*fc%npwt,nstates,numpw,1.d0,wp_prod(1,1,iv-ivv+1),2*fc%npwt,t_mat,numpw,0.d0,wp_g_t,2*fc%npwt) !put the correct order if(l_verbose) write(stdout,*) 'do merge split',iv,ivv call flush_unit(stdout) if(fc%dual_t==4.d0) then wp_g(:,:)=wp_g_t(:,:) else call reorderwfp_col(nstates,fc%npwt,npw,wp_g_t(1,1),wp_g(1,1),fc%npwt,npw, & & fc%ig_l2gt,ig_l2g,fc%ngmt_g,mpime, nproc,intra_pool_comm ) !do ii=1,nstates ! call mergewf(wp_g_t(:,ii),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) ! call splitwf(wp_g(:,ii),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) !enddo endif if(l_verbose) write(stdout,*) 'do davcio' call flush_unit(stdout) !!write on disk do ii=1,nstates call davcio(wp_g(:,ii),npw*2,iungresult,ii+(iv-first_state)*nstates,1) enddo enddo deallocate(eigen) call stop_clock('sl_loop') enddo deallocate(tmp_r,tmp_r2,omat,omat_hold,p_basis_r) deallocate(t_mat,t_mat_hold,t_mat_hold2) deallocate(wp_g,wp_g_t) close(iungresult) deallocate(wv_real,wp_prod) if(l_verbose) write(stdout,*) 'Exiting self_basis_lanczos' call flush_unit(stdout) deallocate(p_basis_t) if(l_verbose) write(stdout,*) 'Call deallocate_fft_custom' call flush_unit(stdout) call deallocate_fft_custom(fc) deallocate(t_eigen_hold) if(l_reduce_io) deallocate(p_basis) return end subroutine self_basis_lanczos subroutine global_self_lanczos(nstates,nstates_eff,threshold,nglobal,nsteps,numpw,g_threshold,ispin,l_eigen,istate,lfull) !this subroutine from the orthonormal basis at each ks-state i !construct a global basis for the lanczos calculation of the !self-energy USE io_global, ONLY : stdout, ionode, ionode_id USE io_files, ONLY : prefix, tmp_dir, diropn USE kinds, ONLY : DP USE wannier_gw, ONLY : num_nbnds,max_ngm,l_truncated_coulomb,truncation_radius,& &num_nbndv,l_pmatrix,vg_q,s_first_state,s_last_state, l_verbose,& &l_contour,l_big_system,l_list,n_list,i_list,optimal_options USE gvect USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, ecutwfc USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : world_comm, mpime,nproc USE wavefunctions_module, ONLY : evc, psic USE gvect USE gvecs, ONLY : nls, nlsm, doublegrid ! USE exx, ONLY : exx_divergence_new, yukawa USE constants, ONLY : e2, pi, tpi, fpi USE cell_base, ONLY : at, alat, tpiba, omega, tpiba2 USE wvfct, ONLY : et USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER, INTENT(in) :: nstates!number of orthonormal states for each v INTEGER, INTENT(in) :: nstates_eff!number of orthonormal states for each v REAL(kind=DP),INTENT(in) :: threshold!threshold for orthonormalization algorithm INTEGER, INTENT(out) :: nglobal!total number of final orthonormal states INTEGER, INTENT(in) :: nsteps!number of lanczos steps INTEGER, INTENT(in) :: numpw!number of wannier products for testing REAL(kind=DP), INTENT(in) :: g_threshold!threshold for eigen values of trial green function INTEGER, INTENT(in) :: ispin!spin channel 1,2 LOGICAL, INTENT(in) :: l_eigen!if true partial t states are scaled with the corresponding eigenvalue INTEGER, INTENT(in) :: istate!considered state for l_big_systems case LOGICAL, INTENT(in) :: lfull!if true writes on disk global s vectors on charge R grid for further processing INTEGER :: iunv,iuntmat LOGICAL :: exst INTEGER :: ii,jj,iv,ic,is COMPLEX(kind=DP), ALLOCATABLE :: old_basis(:,:), new_basis(:,:),v_basis(:,:) INTEGER :: nglobal_old REAL(kind=DP), ALLOCATABLE :: t_mat(:,:) CHARACTER(4) :: nfile !for test: REAL(kind=DP) :: sca,sca1 INTEGER :: iungprod,ig,iw REAL(kind=DP), ALLOCATABLE :: wv_real(:),tmp_r(:) COMPLEX(kind=DP), ALLOCATABLE :: tmp_g(:),wp_prod(:) REAL(kind=DP), ALLOCATABLE :: fac(:) REAL(kind=DP) :: qq,exxdiv !For trial Green's function LOGICAL :: l_greent=.false.!if true calculate the trial green function REAL(kind=DP), ALLOCATABLE :: o_t_psi(:,:) REAL(kind=DP), ALLOCATABLE :: gtrail(:,:) REAL(kind=DP) :: offset REAL(kind=DP), ALLOCATABLE :: eigen(:),work(:) INTEGER :: lwork,info LOGICAL :: l_test=.false.!ATTENZIONE REAL(kind=DP) :: proj_tot INTEGER :: nbuffer,ndelta!for avoiding nested allocation/deallocation cycles LOGICAL :: l_update_memory INTEGER, PARAMETER :: offset_s=0!RESTART ATTENZIONE THEN PUT 0!!!!!!! INTEGER :: iuns INTEGER :: ip LOGICAL, PARAMETER :: l_restart = .false. !if true do a restart RESTART ATTENZIONE INTEGER :: first_state, last_state! ATTENZIONE should be 1 and num_nbnd REAL(kind=DP), ALLOCATABLE :: s_eigen(:) INTEGER :: idumm INTEGER :: iunc TYPE(optimal_options) :: options LOGICAL, PARAMETER :: l_reortho=.true. nbuffer=6*numpw ndelta=numpw if(.not.l_big_system) then if(s_first_state==0) then first_state=1 else first_state=s_first_state endif if(s_last_state==0) then last_state=num_nbnds else last_state=s_last_state endif else first_state=istate last_state=istate endif ! first_state=1 ! last_state=num_nbnds !calculate V(G) allocate(s_eigen(nstates)) if(l_eigen) then if(ionode) then iv=first_state iuntmat = find_free_unit() write(nfile,'(4i1)') iv/1000,mod(iv,1000)/100,mod(iv,100)/10,mod(iv,10) if(ispin==1) then open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.s_eig_lanczos'//nfile, status='old',form='unformatted') else open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.s_eig_lanczos2'//nfile, status='old',form='unformatted') endif read(iuntmat) idumm read(iuntmat) s_eigen(1:nstates) close(iuntmat) endif call mp_bcast(s_eigen, ionode_id,world_comm) endif allocate(fac(max_ngm)) if(l_truncated_coulomb) then do ig=1,max_ngm qq = g(1,ig)**2.d0 + g(2,ig)**2.d0 + g(3,ig)**2.d0 if (qq > 1.d-8) then fac(ig)=(e2*fpi/(tpiba2*qq))*(1.d0-dcos(dsqrt(qq)*truncation_radius*tpiba)) else fac(ig)=e2*fpi*(truncation_radius**2.d0/2.d0) endif end do fac(:)=fac(:)/omega else fac(:)=0.d0 fac(1:npw)=vg_q(1:npw) endif if(.not.l_restart) then !set first basis from first valence state allocate(old_basis(npw,nbuffer)) iunv = find_free_unit() if(ispin==1) then CALL diropn( iunv, 'vw_lanczos_ss',npw*2, exst) else CALL diropn( iunv, 'vw_lanczos_2ss',npw*2, exst) endif if(.not.l_eigen) then do ii=1,nstates_eff if(.not.l_big_system) then !call davcio(old_basis(:,ii),npw*2,iunv,ii+offset_s+(first_state-1)*(nstates+offset_s),-1) call davcio(old_basis(:,ii),npw*2,iunv,ii+offset_s,-1) else call davcio(old_basis(:,ii),npw*2,iunv,ii+offset_s+(istate-s_first_state)*(nstates+offset_s),-1) endif enddo nglobal=nstates_eff else nglobal=1 if(.not.l_big_system) then !call davcio(old_basis(:,nglobal),npw*2,iunv,1+offset_s+(first_state-1)*(nstates+offset_s),-1) call davcio(old_basis(:,nglobal),npw*2,iunv,1+offset_s,-1) else call davcio(old_basis(:,nglobal),npw*2,iunv,1+offset_s+(istate-s_first_state)*(nstates+offset_s),-1) endif do ii=2,nstates_eff if(s_eigen(ii) > threshold) then nglobal=nglobal+1 if(.not.l_big_system) then !call davcio(old_basis(:,nglobal),npw*2,iunv,ii+offset_s+(first_state-1)*(nstates+offset_s),-1) call davcio(old_basis(:,nglobal),npw*2,iunv,ii+offset_s,-1) else call davcio(old_basis(:,nglobal),npw*2,iunv,ii+offset_s+(istate-s_first_state)*(nstates+offset_s),-1) endif endif enddo endif !loop on valence states (from 2nd) allocate(v_basis(npw,nstates_eff)) allocate(new_basis(npw,nbuffer)) do iv=first_state+1,last_state !!read from disk do ii=1,nstates_eff if(.not.l_big_system) then !call davcio(v_basis(:,ii),npw*2,iunv,ii+offset_s+(iv-1)*(nstates+offset_s),-1) call davcio(v_basis(:,ii),npw*2,iunv,ii+offset_s+(iv-first_state)*(nstates+offset_s),-1) else call davcio(v_basis(:,ii),npw*2,iunv,ii+offset_s+(iv-s_first_state)*(nstates+offset_s),-1) endif enddo if(l_eigen) then if(ionode) then iuntmat = find_free_unit() write(nfile,'(4i1)') iv/1000,mod(iv,1000)/100,mod(iv,100)/10,mod(iv,10) if(ispin==1) then open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.s_eig_lanczos'//nfile, status='old',form='unformatted') else open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.s_eig_lanczos2'//nfile, status='old',form='unformatted') endif read(iuntmat) idumm read(iuntmat) s_eigen(1:nstates) close(iuntmat) endif call mp_bcast(s_eigen, ionode_id,world_comm) endif if(nglobal+nstates_eff >nbuffer) then deallocate(new_basis) allocate(new_basis(npw,nbuffer+ndelta)) l_update_memory=.true. else l_update_memory=.false. endif ! allocate(new_basis(npw,nglobal+nstates_eff)) !!calculate basis nglobal_old=nglobal if(.not.l_pmatrix) then !call orthonormalize_two_manifolds( old_basis, nglobal_old,v_basis, nstates, threshold, new_basis, nglobal) call orthonormalize_two_manifolds_prj( old_basis, nglobal_old,v_basis, nstates_eff, threshold, new_basis, nglobal,& &l_eigen,s_eigen) else call orthonormalize_two_manifolds_scalapack(old_basis, nglobal_old,v_basis, nstates_eff, threshold, new_basis, nglobal) endif !!set arrays for next iteration if(l_update_memory) then deallocate(old_basis) allocate(old_basis(npw,nbuffer+ndelta)) nbuffer=nbuffer+ndelta endif old_basis(:,1:nglobal)=new_basis(:,1:nglobal) !deallocate(old_basis) !allocate(old_basis(npw,nglobal)) !old_basis(:,1:nglobal)=new_basis(:,1:nglobal) !deallocate(new_basis) enddo deallocate(new_basis) if(l_greent) then !NOT_TO_BE_INCLUDED_START !if required turn the basis to a more diagonal form !a)calculate overlaps if(l_verbose) write(stdout,*) 'GREENT 1' call flush_unit(stdout) allocate(o_t_psi(nglobal,nbnd)) call dgemm('T','N',nglobal,nbnd,2*npw,2.d0,old_basis,2*npw,evc,2*npwx,0.d0,o_t_psi,nglobal) if(gstart==2) then do ii=1,nbnd do jj=1,nglobal o_t_psi(jj,ii)=o_t_psi(jj,ii)-dble(conjg(old_basis(1,jj))*evc(1,ii)) enddo enddo endif call mp_sum(o_t_psi(:,:),world_comm) offset=(et(num_nbndv(1)+1,1)-et(num_nbndv(1),1))/2.d0 if(l_verbose) write(stdout,*) 'GREENT 2' call flush_unit(stdout) !b)calculate matrix G^T_ij=/(E_i'+offset) allocate(gtrail(nglobal,nglobal)) !mettere DGEMM!! gtrail(:,:)=0.d0 do jj=1,nglobal do ii=1,nglobal do is=1,nbnd gtrail(ii,jj)=gtrail(ii,jj)+o_t_psi(ii,is)*o_t_psi(jj,is)/(et(is,1)-offset) enddo enddo enddo if(l_verbose) write(stdout,*) 'GREENT 3' call flush_unit(stdout) deallocate(o_t_psi) !c)diagonalize allocate(eigen(nglobal)) if(ionode) then allocate(work(1)) call DSYEV( 'V', 'U', nglobal, gtrail, nglobal, eigen, work, -1, info ) lwork=work(1) deallocate(work) allocate(work(lwork)) call DSYEV( 'V', 'U', nglobal, gtrail, nglobal, eigen, work, lwork, info ) deallocate(work) if(info/=0) then write(stdout,*) 'ROUTINE self_lanczos, INFO:', info stop endif else gtrail(:,:)=0.d0 eigen(:)=0.d0 endif if(l_verbose) write(stdout,*) 'GREENT 4' call flush_unit(stdout) do ii=1,nglobal !call mp_bcast(gtrail(:,ii), ionode_id,world_comm) call mp_sum(gtrail(:,ii),world_comm) enddo !call mp_bcast(eigen(:), ionode_id,world_comm) call mp_sum(eigen(:),world_comm) do ii=1,nglobal if(l_verbose) write(stdout,*) 'EIGEN GTRAIL:',ii, eigen(ii) enddo call flush_unit(stdout) !d)calculate t_i' eigen states of G^T allocate(new_basis(npw,nglobal)) call dgemm('N','N',npw*2,nglobal,nglobal,1.d0,old_basis,2*npw,gtrail,nglobal,0.d0,new_basis,2*npw) !e)take eigen states corresponding to eigevalues large than threshold nglobal_old=nglobal nglobal=0 do ii=1,nglobal_old if(abs(eigen(ii)) >= g_threshold) then nglobal=nglobal+1 old_basis(:,nglobal)=new_basis(:,ii) endif enddo ! old_basis(:,:)=new_basis(:,:) write(stdout,*) 'NUMBER T STATES:',nglobal call flush_unit(stdout) deallocate(eigen) deallocate(gtrail,new_basis) !NOT_TO_BE_INCLUDED_END endif write(stdout,*) 'TOTAL NUMBER OF GLOBAL S VECTORS: ', nglobal !re-orthonormalized them it should be important in large systems if(l_reortho.and. .not.l_big_system) then if(l_verbose) write(stdout,*) 'Call optimal driver' call flush_unit(stdout) options%l_complete=.true. options%idiago=0 call optimal_driver(nglobal,old_basis,npw,options,idumm, info) endif !call lanczos chain routine if(.not.l_big_system) then call lanczos_state(old_basis, nglobal, 1, nsteps,1,ispin) else call lanczos_state(old_basis, nglobal, 1, nsteps,istate-s_first_state+1,ispin) endif !if required calculate overlaps with KS states !NOT_TO_BE_INCLUDED_START if(l_contour) then if(.not.l_big_system) then call contour_terms(nglobal,old_basis,ispin,1) else call contour_terms(nglobal,old_basis,ispin,istate) endif endif !NOT_TO_BE_INCLUDED_END !do ip=0,nproc-1 ! if(mpime==ip) then iuns = find_free_unit() CALL diropn( iuns, 's_vectors',npw*2, exst) do ii=1,nglobal call davcio(old_basis(:,ii),npw*2,iuns,ii,1) enddo close(iuns) ! endif ! call mp_barrier ! enddo else if(l_verbose) write(stdout,*) 'Doing restart iuns' call flush_unit(stdout) nglobal=721!RESTART here put te value from the ouputfile write(stdout,*) 'Total number of s vectors:', nglobal call flush_unit(stdout) allocate(old_basis(npw,nglobal)) iunv = find_free_unit() CALL diropn( iunv, 'vw_lanczos_ss',npw*2, exst) allocate(v_basis(npw,nstates_eff)) do ip=0,nproc-1 if(mpime==ip) then iuns = find_free_unit() CALL diropn( iuns, 's_vectors',npw*2, exst) do ii=1,nglobal call davcio(old_basis(:,ii),npw*2,iuns,ii,-1) enddo close(iuns) endif call mp_barrier( world_comm ) enddo endif !if required writes global s vectors on disk if(lfull) then iunc = find_free_unit() CALL diropn( iunc, 'sreal2full',dffts%nnr, exst) do ii=1,nglobal,2 psic(1:dffts%nnr)=(0.d0,0.d0) do ig=1,npw if(ii 1.d-8) then fac(ig)=(e2*fpi/(tpiba2*qq))*(1.d0-dcos(dsqrt(qq)*truncation_radius*tpiba)) else fac(ig)=e2*fpi*(truncation_radius**2.d0/2.d0) endif enddo fac(:)=fac(:)/omega else fac(:)=0.d0 fac(1:npw)=vg_q(1:npw) endif if(l_verbose) write(stdout,*) 'Call initialize_fft_custom' fc%ecutt=ecutwfc fc%dual_t=dual_vs call flush_unit(stdout) call initialize_fft_custom(fc) allocate(evc_g(fc%ngmt_g*nproc)) allocate(wv_real(fc%nrxxt)) !read w^P'_i on file on real space !open product of wanniers filed iungprod = find_free_unit() CALL diropn( iungprod, 'wiwjwfc_red', max_ngm*2, exst ) allocate(p_basis(max_ngm,numpw)) do iw=1,numpw call davcio(p_basis(:,iw),max_ngm*2,iungprod,iw,-1) enddo iungresult = find_free_unit() if(ispin==1) then CALL diropn( iungresult, 'vw_lanczos_ss',npw*2, exst) else CALL diropn( iungresult, 'vw_lanczos_2ss',npw*2, exst) endif close(iungprod) !now polarizability basis times v are put on the ordering of the redueced grid, if required allocate(p_basis_t(fc%npwt,numpw)) do ii=1,numpw p_basis(1:npw,ii)=fac(1:npw)*p_basis(1:npw,ii) enddo if(fc%dual_t==4.d0) then p_basis_t(:,:)=p_basis(:,:) else call reorderwfp (numpw,npw, fc%npwt,p_basis(:,:),p_basis_t(:,:), & &npw,fc%npwt, ig_l2g,fc%ig_l2gt, fc%ngmt_g , mpime, nproc,ionode_id, intra_pool_comm ) !do ii=1,numpw ! call mergewf(p_basis(:,ii),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) ! call splitwf(p_basis_t(:,ii),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) !enddo !trasform to real space allocate(p_basis_r(fc%nrxxt,numpw)) do ii=1,numpw,2 psic(:)=(0.d0,0.d0) if(ii==numpw) then psic(fc%nlt(1:fc%npwt)) = p_basis_t(1:fc%npwt,ii) psic(fc%nltm(1:fc%npwt)) = CONJG( p_basis_t(1:fc%npwt,ii) ) else psic(fc%nlt(1:fc%npwt))=p_basis_t(1:fc%npwt,ii)+(0.d0,1.d0)*p_basis_t(1:fc%npwt,ii+1) psic(fc%nltm(1:fc%npwt)) = CONJG( p_basis_t(1:fc%npwt,ii) )+(0.d0,1.d0)*CONJG( p_basis_t(1:fc%npwt,ii+1) ) endif CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) p_basis_r(1:fc%nrxxt,ii)= DBLE(psic(1:fc%nrxxt)) if(ii/=numpw) p_basis_r(1:fc%nrxxt,ii+1)= DIMAG(psic(1:fc%nrxxt)) enddo endif !now valence wavefunctions are put on the ordering of the reduced grid allocate(evc_t(fc%npwt,num_nbnds)) if(fc%dual_t==4.d0) then evc_t(:,1:num_nbnds)=evc(:,1:num_nbnds) else call reorderwfp (num_nbnds,npw, fc%npwt,evc(:,:),evc_t(:,:), & &npw,fc%npwt, ig_l2g,fc%ig_l2gt, fc%ngmt_g , mpime, nproc,ionode_id, intra_pool_comm ) !do iv=1,num_nbnds ! call mergewf(evc(:,iv),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) ! call splitwf(evc_t(:,iv),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) !enddo endif if(l_verbose) write(stdout,*) 'self_basis_lanczos 1' call flush_unit(stdout) !nbuf=min(5,nproc) ATTENZIONE iera cussi nbuf=nproc allocate(wp_prod(fc%nrxxt,numpw,nbuf)) allocate(tmp_r(fc%nrxxt),tmp_r2(fc%nrxxt)) allocate(omat(numpw,numpw),omat_hold(numpw,numpw)) allocate(t_mat(numpw,nstates), t_mat_hold(numpw,nstates), t_mat_hold2(numpw,nstates)) allocate(wp_g(npw,nstates)) allocate(wp_g_t(fc%nrxxt,nstates)) allocate(t_eigen_hold(nstates)) allocate(wp_g_t3(npw*nproc)) !loop on kohn-sham states do ivv=first_state,last_state,nbuf call start_clock('sl_loop') do iv=ivv,min(ivv+nbuf-1,last_state) !put iv on real space psic(:)=(0.d0,0.d0) psic(fc%nlt(1:fc%npwt)) = evc_t(1:fc%npwt,iv) psic(fc%nltm(1:fc%npwt)) = CONJG( evc_t(1:fc%npwt,iv) ) CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) wv_real(1:fc%nrxxt)= DBLE(psic(1:fc%nrxxt)) !!loop on products of wanniers if(l_verbose) write(stdout,*) 'do fft' call flush_unit(stdout) do ii=offset+1,numpw wp_prod(1:fc%nrxxt, ii,iv-ivv+1)=p_basis_r(1:fc%nrxxt,ii)*wv_real(1:fc%nrxxt) enddo if(l_verbose) write(stdout,*) 'calculate omat' call flush_unit(stdout) !!calculate overlap matrix call start_clock('sl_dgemm') call dgemm('T','N',numpw-offset,numpw-offset,fc%nrxxt,1.d0,wp_prod(1,offset+1,iv-ivv+1),& &fc%nrxxt,wp_prod(1,offset+1,iv-ivv+1),fc%nrxxt,0.d0,omat,numpw) call stop_clock('sl_dgemm') do ii=1,numpw-offset call mp_sum(omat(1:numpw-offset,ii),world_comm) omat(1:numpw-offset,ii)=omat(1:numpw-offset,ii)/dble(fc%nr1t*fc%nr2t*fc%nr3t) enddo if(iv-ivv==mpime) then omat_hold(:,:)=omat(:,:) endif enddo !! !!solve eigen/values vector problem !! if(l_verbose) write(stdout,*) 'solve eig' call flush_unit(stdout) do iv=ivv,min(ivv+nbuf-1,last_state) if(iv-ivv==mpime) then call start_clock('sl_dsyevX') if(.not.l_dsyevr) then allocate(eigen(numpw-offset)) allocate(work(1)) call DSYEV( 'V', 'U', numpw-offset, omat_hold, numpw, eigen, work, -1, info ) lwork=work(1) deallocate(work) allocate(work(lwork)) call DSYEV( 'V', 'U', numpw-offset, omat_hold, numpw, eigen, work, lwork, info ) deallocate(work) if(info/=0) then write(stdout,*) 'ROUTINE self_basis_lanczos, INFO:', info stop endif !do iw=1,numpw ! write(stdout,*) 'EIGEN:',iv,iw, eigen(iw) !enddo !call flush_unit(stdout) else allocate(eigen(numpw-offset)) allocate(vectors(numpw-offset,nstates)) allocate(isuppz(2*nstates)) allocate(work(1),iwork(1)) call DSYEVR('V','I','U',numpw-offset,omat_hold,numpw,0.d0,0.d0,& &numpw-offset-nstates+1,numpw-offset,0.d0,n_found,eigen,& & vectors,numpw-offset,isuppz,work, -1,iwork,-1, info) lwork=work(1) liwork=iwork(1) deallocate(work,iwork) allocate(work(lwork)) allocate(iwork(liwork)) vl=0.d0 vu=0.d0 il=numpw-offset-nstates+1 iu=numpw-offset call DSYEVR('V','I','U',numpw-offset,omat_hold,numpw,vl,vu,il,iu,0.d0,n_found,eigen,& & vectors,numpw-offset,isuppz,work,lwork,iwork,liwork, info) if(info/=0) then write(stdout,*) 'ROUTINE pola_lanczos DSYEVR, INFO:', info stop endif deallocate(isuppz) deallocate(work,iwork) !do iw=1,nstates !write(stdout,*) 'EIGEN:',iv,iw, eigen(iw) !enddo !call flush_unit(stdout) endif call stop_clock('sl_dsyevX') t_mat_hold(:,:)=0.d0 t_mat_hold2(:,:)=0.d0 if(.not.l_dsyevr) then do ii=1,nstates do jj=1,numpw-offset t_mat_hold(jj+offset,ii)=omat_hold(jj,numpw-offset-ii+1)*(dsqrt(eigen(numpw-offset-ii+1))) enddo t_eigen_hold(ii)=eigen(numpw-ii+1) enddo else do ii=1,nstates do jj=1,numpw-offset t_mat_hold(jj+offset,ii)=vectors(jj,ii)*(dsqrt(eigen(ii))) enddo t_eigen_hold(ii)=eigen(ii) enddo endif if(.not.l_dsyevr) then do ii=1,nstates t_mat_hold2(offset+1:numpw,ii)=omat_hold(1:numpw-offset,numpw-offset-ii+1)*(1.d0/dsqrt(eigen(numpw-offset-ii+1))) enddo else do ii=1,nstates t_mat_hold2(offset+1:numpw,ii)=vectors(1:numpw-offset,ii)*(1.d0/dsqrt(eigen(ii))) enddo endif deallocate(eigen) if(l_dsyevr) deallocate(vectors) endif enddo !!find liner dependent products !!find transformation matrix and write on disk ! if(l_verbose) write(stdout,*) 'write on file' call flush_unit(stdout) allocate(eigen(nstates)) do iv=ivv,min(ivv+nbuf-1,last_state) if(iv-ivv == mpime) then t_mat(:,:)=t_mat_hold(:,:) eigen(1:nstates)=t_eigen_hold(1:nstates) endif call start_clock('sl_mpbcast') call mp_bcast(t_mat,iv-ivv,world_comm) call mp_bcast(eigen(1:nstates),iv-ivv,world_comm) call stop_clock('sl_mpbcast') if(ionode) then iuntmat = find_free_unit() write(nfile,'(4i1)') iv/1000,mod(iv,1000)/100,mod(iv,100)/10,mod(iv,10) if(ispin==1) then open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.s_mat_lanczos'//nfile, status='unknown',form='unformatted') else open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.s_mat_lanczos2'//nfile, status='unknown',form='unformatted') endif write(iuntmat) iv write(iuntmat) num_nbndv(1)!for compatibility with polarization file write(iuntmat) numpw write(iuntmat) nstates do ii=1,nstates write(iuntmat) t_mat(1:numpw,ii) enddo close(iuntmat) endif !write on disk file with eigen values if(ionode) then iuntmat = find_free_unit() write(nfile,'(4i1)') iv/1000,mod(iv,1000)/100,mod(iv,100)/10,mod(iv,10) if(ispin==1) then open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.s_eig_lanczos'//nfile, status='unknown',form='unformatted') else open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.s_eig_lanczos2'//nfile, status='unknown',form='unformatted') endif write(iuntmat) nstates write(iuntmat) eigen(1:nstates) close(iuntmat) endif !!find liner dependent products if(iv-ivv == mpime) then t_mat(:,:)=t_mat_hold2(:,:) endif call start_clock('sl_mpbcast') call mp_bcast(t_mat,iv-ivv,world_comm) call stop_clock('sl_mpbcast') call start_clock('sl_dgemm') call dgemm('N','N',fc%nrxxt,nstates,numpw,1.d0,wp_prod(1,1,iv-ivv+1),fc%nrxxt,t_mat,numpw,0.d0,wp_g_t,fc%nrxxt) call stop_clock('sl_dgemm') !put the correct order psic=(0.d0,0.d0) write(stdout,*) 'do merge split',iv,ivv call flush_unit(stdout) call start_clock('sl_merge') allocate(wp_g_t2(fc%npwt,nstates)) do ii=1,nstates,2 if(ii==nstates) then psic(1:fc%nrxxt)=cmplx(wp_g_t(1:fc%nrxxt,ii),0.d0) else psic(1:fc%nrxxt)=cmplx(wp_g_t(1:fc%nrxxt,ii),wp_g_t(1:fc%nrxxt,ii+1)) endif CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, -2 ) if(ii==nstates) then wp_g_t2(1:fc%npwt,ii) = psic(fc%nlt(1:fc%npwt)) else wp_g_t2(1:fc%npwt, ii)= 0.5d0*(psic(fc%nlt(1:fc%npwt))+conjg( psic(fc%nltm(1:fc%npwt)))) wp_g_t2(1:fc%npwt, ii+1)= (0.d0,-0.5d0)*(psic(fc%nlt(1:fc%npwt)) - conjg(psic(fc%nltm(1:fc%npwt)))) endif enddo if(fc%dual_t==4.d0) then wp_g(1:npw,1:nstates)=wp_g_t2(1:fc%npwt,1:nstates) else call reorderwfp (nstates,fc%npwt, npw,wp_g_t2,wp_g, & &fc%npwt,npw, fc%ig_l2gt,ig_l2g, fc%ngmt_g , mpime, nproc,ionode_id, intra_pool_comm ) ! call mergewfv(min(ii+nproc-1,nstates)-ii+1,fc%ngmt_g,wp_g_t2,& ! &evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) ! call splitwfv(min(ii+nproc-1,nstates)-ii+1,fc%ngmt_g,wp_g_t3,& ! &evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) endif call stop_clock('sl_merge') deallocate(wp_g_t2) if(l_verbose) write(stdout,*) 'do davcio' call flush_unit(stdout) !!write on disk do ii=1,nstates call davcio(wp_g(:,ii),npw*2,iungresult,ii+(iv-first_state)*nstates,1) enddo enddo deallocate(eigen) call stop_clock('sl_loop') enddo deallocate(tmp_r,tmp_r2,omat,omat_hold,p_basis_r) deallocate(t_mat,t_mat_hold,t_mat_hold2) deallocate(wp_g,wp_g_t) close(iungresult) deallocate(wv_real,wp_prod) if(l_verbose) write(stdout,*) 'Exiting self_basis_lanczos' call flush_unit(stdout) deallocate(p_basis_t,evc_g) if(l_verbose) write(stdout,*) 'Call deallocate_fft_custom' call flush_unit(stdout) call deallocate_fft_custom(fc) deallocate(t_eigen_hold) deallocate(p_basis) return !NOT_TO_BE_INCLUDED_END end subroutine self_basis_lanczos_real SUBROUTINE mergewfv ( nn,lda,pw, pwt, ngwl, ig_l2g, mpime, nproc, root, comm ) ! ... This subroutine merges the pieces of a wave functions (pw) splitted across ! ... processors into a total wave function (pwt) containing al the components ! ... in a pre-defined order (the same as if only one processor is used) USE kinds USE parallel_include IMPLICIT NONE COMPLEX(DP), intent(in) :: PW(ngwl*nproc) COMPLEX(DP), intent(out) :: PWT(lda*nproc) INTEGER, intent(in) :: nn !number of wfcs INTEGER, intent(in) :: lda!leading dimension of pwt INTEGER, INTENT(IN) :: mpime ! index of the calling processor ( starting from 0 ) INTEGER, INTENT(IN) :: nproc ! number of processors INTEGER, INTENT(IN) :: root ! root processor ( the one that should receive the data ) INTEGER, INTENT(IN) :: comm ! communicator INTEGER, INTENT(IN) :: ig_l2g(ngwl) INTEGER, INTENT(IN) :: ngwl INTEGER, ALLOCATABLE :: ig_ip(:) COMPLEX(DP), ALLOCATABLE :: pw_ip(:) INTEGER :: ierr, i, ip, ngw_ip, ngw_lmax, itmp, igwx, gid, J #if defined __MPI INTEGER :: istatus(MPI_STATUS_SIZE) #endif ! ! ... Subroutine Body ! igwx = MAXVAL( ig_l2g(1:ngwl) ) #if defined __MPI gid = comm ! ... Get local and global wavefunction dimensions CALL MPI_ALLREDUCE( ngwl, ngw_lmax, 1, MPI_INTEGER, MPI_MAX, gid, IERR ) CALL MPI_ALLREDUCE( igwx, itmp, 1, MPI_INTEGER, MPI_MAX, gid, IERR ) igwx = itmp #endif IF( igwx > SIZE( pwt ) ) & CALL errore(' mergewf ',' wrong size for pwt ',SIZE(pwt) ) #if defined __MPI DO ip = 1, nproc IF( (ip-1) /= root ) THEN ! ... In turn each processors send to root the wave components and their indexes in the ! ... global array IF ( mpime == (ip-1) ) THEN CALL MPI_SEND( ig_l2g, ngwl, MPI_INTEGER, ROOT, IP, gid, IERR ) CALL MPI_SEND( pw(1), ngwl*nn, MPI_DOUBLE_COMPLEX, ROOT, IP+NPROC, gid, IERR ) END IF IF ( mpime == root) THEN ALLOCATE(ig_ip(ngw_lmax)) ALLOCATE(pw_ip(ngw_lmax*nn)) CALL MPI_RECV( ig_ip, ngw_lmax, MPI_INTEGER, (ip-1), IP, gid, istatus, IERR ) CALL MPI_GET_COUNT( istatus, MPI_INTEGER, ngw_ip, ierr ) CALL MPI_RECV( pw_ip, ngw_lmax*nn, MPI_DOUBLE_COMPLEX, (ip-1), IP+NPROC, gid, istatus, IERR ) ! CALL MPI_GET_COUNT( istatus, MPI_DOUBLE_COMPLEX, ngw_ip, ierr ) ! ngw_ip=ngw_ip/nn DO J=1,nn DO I = 1, ngw_ip PWT(ig_ip(i)+lda*(J-1)) = pw_ip(i+(ngw_ip)*(J-1)) END DO END DO DEALLOCATE(ig_ip) DEALLOCATE(pw_ip) END IF ELSE IF(mpime == root) THEN DO J=1,nn DO I = 1, ngwl PWT(ig_l2g(i)+lda*(J-1)) = pw(i+ngwl*(J-1)) END DO END DO END IF END IF CALL MPI_BARRIER( gid, IERR ) END DO #else do J=1,nn DO I = 1, ngwl ! WRITE( stdout,*) 'MW ', ig_l2g(i), i PWT( ig_l2g(i)+lda*(J-1) ) = pw(i+ngwl*(J-1)) END DO END do #endif RETURN END SUBROUTINE mergewfv !=----------------------------------------------------------------------------=! SUBROUTINE splitwfv ( nn, lda, pw, pwt, ngwl, ig_l2g, mpime, nproc, root, comm ) ! ... This subroutine splits a total wave function (pwt) containing al the components ! ... in a pre-defined order (the same as if only one processor is used), across ! ... processors (pw). USE kinds USE parallel_include IMPLICIT NONE COMPLEX(DP), INTENT(OUT) :: PW(ngwl*nproc) COMPLEX(DP), INTENT(IN) :: PWT(lda*nproc) INTEGER, intent(in) :: nn !number of wfcs INTEGER, intent(in) :: lda!leading dimension of pwt INTEGER, INTENT(IN) :: mpime, nproc, root INTEGER, INTENT(IN) :: comm ! communicator INTEGER, INTENT(IN) :: ig_l2g(ngwl) INTEGER, INTENT(IN) :: ngwl INTEGER, ALLOCATABLE :: ig_ip(:) COMPLEX(DP), ALLOCATABLE :: pw_ip(:) INTEGER ierr, i, ngw_ip, ip, ngw_lmax, gid, igwx, itmp, J #if defined __MPI integer istatus(MPI_STATUS_SIZE) #endif ! ! ... Subroutine Body ! igwx = MAXVAL( ig_l2g(1:ngwl) ) #if defined __MPI gid = comm ! ... Get local and global wavefunction dimensions CALL MPI_ALLREDUCE(ngwl, ngw_lmax, 1, MPI_INTEGER, MPI_MAX, gid, IERR ) CALL MPI_ALLREDUCE(igwx, itmp , 1, MPI_INTEGER, MPI_MAX, gid, IERR ) igwx = itmp #endif IF( igwx > SIZE( pwt ) ) & CALL errore(' splitwf ',' wrong size for pwt ',SIZE(pwt) ) #if defined __MPI DO ip = 1, nproc ! ... In turn each processor send to root the the indexes of its wavefunction conponents ! ... Root receive the indexes and send the componens of the wavefunction read from the disk (pwt) IF ( (ip-1) /= root ) THEN IF ( mpime == (ip-1) ) THEN CALL MPI_SEND( ig_l2g, ngwl, MPI_INTEGER, ROOT, IP, gid,IERR) CALL MPI_RECV( pw(1), ngwl*nn, MPI_DOUBLE_COMPLEX, ROOT, IP+NPROC, gid, istatus, IERR ) END IF IF ( mpime == root ) THEN ALLOCATE(ig_ip(ngw_lmax)) ALLOCATE(pw_ip(ngw_lmax*nn)) CALL MPI_RECV( ig_ip, ngw_lmax, MPI_INTEGER, (ip-1), IP, gid, istatus, IERR ) CALL MPI_GET_COUNT(istatus, MPI_INTEGER, ngw_ip, ierr) DO J=1,nn DO i = 1, ngw_ip pw_ip(i+ngw_ip*(J-1)) = PWT(ig_ip(i)+lda*(J-1)) END DO END DO CALL MPI_SEND( pw_ip, ngw_ip*nn, MPI_DOUBLE_COMPLEX, (ip-1), IP+NPROC, gid, IERR ) DEALLOCATE(ig_ip) DEALLOCATE(pw_ip) END IF ELSE IF ( mpime == root ) THEN DO J=1,nn DO i = 1, ngwl pw(i+ngwl*(J-1)) = PWT(ig_l2g(i)+lda*(J-1)) END DO END DO END IF END IF CALL MPI_BARRIER(gid, IERR) END DO #elif ! defined __PARA DO J=1,nn DO I = 1, ngwl pw(i+ngwl*(J-1)) = pwt( ig_l2g(i)+lda*(J-1) ) END DO END DO #else CALL errore(' SPLITWF ',' no communication protocol ',0) #endif RETURN END SUBROUTINE splitwfv !=----------------------------------------------------------------------------=! GWW/pw4gww/fake_conduction.f900000644000077300007730000031577612341332532016745 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !this subroutine build a set of fake_conduction states !then it find the optimal basis set for representing !the products with valence wannier functions MODULE fake_cond_mod USE kinds, ONLY : DP IMPLICIT NONE SAVE INTEGER :: fcw_number!number of "producs of fake conduction with valence wannier" states for O matrix method COMPLEX(kind=DP), ALLOCATABLE, DIMENSION(:,:) :: fcw_state! fcw states for O matrix method REAL(kind=DP), ALLOCATABLE, DIMENSION(:,:) :: fcw_mat! "fcw matrix CONTAINS subroutine fake_conduction_wannier( cutoff, s_cutoff,ks_wfcs ,l_frac, ks_wfcs_diag,l_cond) !IT WORKS ONLY FOR NORMCONSERVING PSEUDOPOTENTIALS !the valence states in G space must be in evc ! Gamma point version USE io_global, ONLY : stdout, ionode, ionode_id USE kinds, ONLY : DP USE wannier_gw USE gvect USE constants, ONLY : e2, pi, tpi, fpi USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2 USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, et, ecutwfc, wg USE wavefunctions_module, ONLY : evc, psic USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_pools, ONLY : intra_pool_comm USE mp_world, ONLY: world_comm, mpime, nproc USE gvecs, ONLY : nls, nlsm, doublegrid USE kinds, ONLY : DP USE io_files, ONLY : prefix, tmp_dir, diropn USE g_psi_mod, ONLY : h_diag, s_diag USE noncollin_module, ONLY : noncolin, npol USE becmod, ONLY : becp USE uspp, ONLY : vkb, nkb, okvan USE klist, ONLY : xk USE fft_custom_gwl USE mp_wave, ONLY : mergewf,splitwf USE fft_base, ONLY : dfftp USE lsda_mod, ONLY : nspin implicit none INTEGER, EXTERNAL :: find_free_unit ! INTEGER,INTENT(out) :: fcw_number!number of "fake conduction" states for O matrix method ! COMPLEX(kind=DP), POINTER, DIMENSION(:,:) :: fcw_state! "fake conduction" states for O matrix method ! REAL(kind=DP), POINTER, DIMENSION(:,:) :: fcw_mat! "fake conduction" matrix REAL(kind=DP), INTENT(in) :: cutoff!cutoff for planewaves REAL(kind=DP), INTENT(in) :: s_cutoff!cutoff for orthonormalization COMPLEX(kind=DP), INTENT(in) :: ks_wfcs(npwx,nbnd,nspin)!Kohn-Sham or Wannier wavefunctios LOGICAL, INTENT(in) :: l_frac!if true consider fractional occupancies COMPLEX(kind=DP), INTENT(in) :: ks_wfcs_diag(npwx,nbnd,nspin)!Kohn-Sham wavefunctios LOGICAL, INTENT(in) :: l_cond!if true consider also conduction states for the construction of the polarizability basis COMPLEX(kind=DP), ALLOCATABLE :: state_fc(:,:,:) COMPLEX(kind=DP), ALLOCATABLE :: state_g(:,:) COMPLEX(kind=DP), ALLOCATABLE :: fcw_state_old(:,:) COMPLEX(kind=DP), ALLOCATABLE :: h_state_fc(:,:) COMPLEX(kind=DP), ALLOCATABLE :: evc_g(:),evc_t(:,:,:),state_fc_t(:,:,:),state_g_t(:,:) COMPLEX(kind=DP), ALLOCATABLE :: fcw_state_n(:,:) REAL(kind=DP), ALLOCATABLE :: wv_real(:),state_real(:),wv_real_all(:,:),state_real_tmp(:) REAL(kind=DP), ALLOCATABLE :: state_real_tmp2(:),state_real2(:) REAL(kind=DP), ALLOCATABLE :: omat(:,:) REAL(kind=DP), ALLOCATABLE :: eigen(:),work(:) REAL(kind=DP), ALLOCATABLE :: tmp_mat(:,:),tmp_mat2(:,:) REAL(kind=DP), ALLOCATABLE :: omat2(:,:) REAL(kind=DP), ALLOCATABLE :: hmat(:,:) REAL(kind=DP), ALLOCATABLE :: e_fake(:), vec_fake(:,:) REAL(kind=DP), ALLOCATABLE :: gap(:) REAL(kind=DP), ALLOCATABLE :: hmat_i(:,:),hmat_o(:,:), omat_i(:,:) REAL(kind=DP), ALLOCATABLE :: ovec(:) REAL(kind=DP), ALLOCATABLE :: g2kint(:) INTEGER, ALLOCATABLE :: iwork(:), ifail(:) INTEGER, ALLOCATABLE :: isuppz(:) INTEGER, ALLOCATABLE :: iclustr(:) INTEGER, ALLOCATABLE :: igkt(:) REAL(kind=DP):: sca1,sca2 LOGICAL :: l_test=.false.!if true test the completness of the basis LOGICAL :: l_dsyevr=.true.!if true uses dsyevr instead of dsyev LOGICAL :: l_diago_cg=.true.!if true uses diago_cg instead of dsyevr ATTENZIONE LOGICAL :: exst LOGICAL :: l_dsygvx=.false.!if .true. uses serial dsygvx instead of parallel diago_cg_g LOGICAL :: l_gramsc=.true.!if true orthonormalization through gram-schimdt LOGICAL :: l_diago_para=.true.!if true uses parallel diago_cg LOGICAL :: l_fft_custom=.false. INTEGER :: ig,ip, ii, iv, jj, iw, ir, is INTEGER :: num_fc!number of fake conduction states INTEGER :: lwork,info,liwork INTEGER :: n_out INTEGER :: fcw_number_old INTEGER :: l_blk,nbegin,nend INTEGER :: max_state INTEGER :: iunfcw INTEGER :: nsize INTEGER :: nbegin_loc,nend_loc,nsize_loc INTEGER :: n_found_state !variables for scalapack INTEGER :: num_fc_r,num_fc_c,num_fc_dimr,num_fc_dimc INTEGER :: m,nz,icrow,iccol,iproc,ilrow,ilcol INTEGER :: desc_a(9),desc_b(9),desc_c(9) INTEGER :: n_computed INTEGER :: num_built!number of states already built INTEGER :: num_out INTEGER :: kilobytes INTEGER :: kb_old, kb_new INTEGER, EXTERNAL :: indxg2p,indxg2l TYPE(optimal_options) :: options INTEGER :: bufferx,fcw_numberx,fcw_number_oldx, fcw_numberx_tmp LOGICAL :: l_restart0!if true restart is enabled INTEGER :: iunrestart0, iv_start,iunfsr REAL(kind=DP), ALLOCATABLE :: state_fc_r(:,:,:) INTEGER :: num_nbndv_max, num_fc_spin INTEGER :: num_fc_eff(2),num_fc_eff_max LOGICAL :: l_do_optimal INTEGER :: iun_oap TYPE(fft_cus) :: fc !determine bufferx,fcw_numberx bufferx=num_nbndv(1)*300/4 bufferx=max(1000,bufferx) !ONLY FOR PROJECT ON JADE bufferx=5000 fcw_numberx=bufferx fcw_number_oldx=bufferx fcw_numberx_tmp=bufferx !generate fake conduction states !!determine number of states !generate custom in grid in case can be equal to norm-conserving grid fc%ecutt=ecutwfc fc%dual_t=dual_pb write(stdout,*) 'Call initialize_fft_custom' CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory0', kilobytes call flush_unit(stdout) call initialize_fft_custom(fc) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory0.0', kilobytes call flush_unit(stdout) ! this is for compatibility allocate( igkt( fc%npwt ) ) do ig=1,fc%npwt igkt(ig)=ig enddo !allocate( evc_g( fc%ngmt_g ) ) !plane waves basis set !state_fc are first obtained on the ordering of the normconserving grid g2kin(1:npw) = ( (g(1,igk(1:npw)) )**2 + & ( g(2,igk(1:npw)) )**2 + & ( g(3,igk(1:npw)) )**2 ) * tpiba2 num_fc=0 do ig=1,npw if(g2kin(ig) <= cutoff) num_fc=num_fc+1 enddo call mp_sum(num_fc,world_comm) num_fc=(num_fc-1)*2+1 if(.not.l_cond) then if(.not.l_frac) then num_fc_eff(1:2)=num_fc num_fc_eff_max=num_fc else !NOT_TO_BE_INCLUDED_START num_fc_eff(1:2)=num_fc+num_nbndv(1:2)-num_nbndv_min(1:2) num_fc_eff_max=max(num_fc_eff(1),num_fc_eff(2)) !NOT_TO_BE_INCLUDED_END endif else if(.not.l_frac) then num_fc_eff(1:2)=num_fc+num_nbnds-num_nbndv(1:2) num_fc_eff_max=num_fc+num_nbnds-min(num_nbndv(1),num_nbndv(2)) else !NOT_TO_BE_INCLUDED_START num_fc_eff(1:2)=num_fc+num_nbndv(1:2)-num_nbndv_min(1:2)+num_nbnds-num_nbndv(1:2) num_fc_eff_max=max(num_fc_eff(1),num_fc_eff(2)) !NOT_TO_BE_INCLUDED_END endif endif allocate( state_fc( npw, num_fc_eff_max, nspin ) ) state_fc(:,:,:)=(0.d0,0.d0) write(stdout,*) "Number of projected orthonormalized plane waves:", num_fc CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory0.1', kilobytes, ' new kb = ', & &(SIZE( state_fc )*16 + SIZE( igkt )*4)/1024 call flush_unit(stdout) ii=0 do ip=0,nproc-1 if(mpime==ip) then do ig=gstart,npw if(g2kin(ig) <= cutoff) then ii=ii+1 state_fc(ig,ii,1)=cmplx(dsqrt(0.5d0),0.d0) ii=ii+1 state_fc(ig,ii,1)=cmplx(0.d0,dsqrt(0.5d0)) endif enddo if(gstart==2) then ii=ii+1 state_fc(1,ii,1)=(1.d0,0.d0) endif else ii=0 endif call mp_sum(ii,world_comm) enddo if(ii/=num_fc) then write(stdout,*) 'ERRORE FAKE CONDUCTION',ii call flush_unit(stdout) stop return endif if(l_verbose) write(stdout,*) 'FAKE1' call flush_unit(stdout) if(nspin==2) state_fc(:,1:num_fc,2)=state_fc(:,1:num_fc,1) do is=1,nspin !!project out of valence space do ii=1,num_fc evc(1:npw,1:num_nbndv(is))=ks_wfcs(1:npw,1:num_nbndv(is),is)!for calling pc_operator call pc_operator(state_fc(:,ii,is),is,l_cond) enddo enddo !!add partially occupied states if(l_frac) then !NOT_TO_BE_INCLUDED_START do is=1,nspin do ii=num_nbndv_min(is)+1,num_nbndv(is) state_fc(1:npw,num_fc+ii-num_nbndv_min(is),is)=ks_wfcs_diag(1:npw,ii,is) enddo enddo !NOT_TO_BE_INCLUDED_END endif !!add conduction states if required if(l_cond) then if(.not.l_frac) then do is=1,nspin do ii=num_nbndv(is)+1,num_nbnds state_fc(1:npw,num_fc+ii-num_nbndv(is),is)=ks_wfcs_diag(1:npw,ii,is) enddo enddo else !NOT_TO_BE_INCLUDED_START do is=1,nspin do ii=num_nbndv(is)+1,num_nbnds state_fc(1:npw,num_fc+num_nbndv(is)-num_nbndv_min(is)+ii-num_nbndv(is),is)=ks_wfcs_diag(1:npw,ii,is) enddo enddo !NOT_TO_BE_INCLUDED_END endif endif !orthonormalize fake_conduction states !for the moment finds all the first fcw_fast_n eigenstates if(l_verbose) write(stdout,*) 'CASE ORTHONORMALIZATION ONLY' call flush_unit(stdout) !if required orthonormalize the projected plane_waves or read from disk l_do_optimal=.false. inquire(file=trim(tmp_dir)//trim(prefix)//'.restart_fk0_status', exist = exst) if(.not. exst) then l_do_optimal=.true. else iunrestart0 = find_free_unit() open( unit= iunrestart0, file=trim(tmp_dir)//trim(prefix)//'.restart_fk0_status', status='old') read(iunrestart0,*) iv_start close(iunrestart0) if(iv_start<1 ) l_do_optimal=.true. endif if(l_do_optimal) then if(l_verbose) write(stdout,*) 'Call optimal driver' call flush_unit(stdout) options%l_complete=.true. options%idiago=0 do is=1,nspin call optimal_driver(num_fc_eff(is),state_fc(1,1,is),npw,options,num_out, info) enddo !read orthonormalized projected plane-waves from disk endif CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory0.3', kilobytes call flush_unit(stdout) !now state_fc are put on the ordering of the redueced grid, if required allocate(state_fc_t(fc%npwt,num_fc_eff_max,nspin)) if(l_do_optimal) then if(fc%dual_t==4.d0) then do is=1,nspin state_fc_t(1:fc%npwt,1:num_fc_eff(is),is)=state_fc(1:fc%npwt,1:num_fc_eff(is),is) enddo else do is=1,nspin call reorderwfp_col (num_fc_eff(is),npw,fc%npwt,state_fc(1,1,is),state_fc_t(1,1,is), npw,fc%npwt, & & ig_l2g,fc%ig_l2gt,fc%ngmt_g,mpime, nproc,intra_pool_comm ) enddo endif iun_oap = find_free_unit() CALL diropn( iun_oap, 'oap', fc%npwt*2, exst ) do ii=1,num_fc_eff(1) CALL davcio( state_fc_t(:,ii,1), 2*fc%npwt, iun_oap, ii, 1 ) enddo close(iun_oap) else if(l_verbose) write(stdout,*) 'Read OAP from disk' call flush_unit(stdout) iun_oap = find_free_unit() CALL diropn( iun_oap, 'oap', fc%npwt*2, exst ) do ii=1,num_fc_eff(1) CALL davcio( state_fc_t(:,ii,1), 2*fc%npwt, iun_oap, ii, -1 ) enddo close(iun_oap) endif deallocate(state_fc) if(l_iter_algorithm) then allocate(state_fc_r(fc%nrxxt,num_fc_eff_max,nspin)) do is=1,nspin do ii=1,num_fc_eff(is),2 psic(:)=(0.d0,0.d0) if(ii==num_fc_eff(is)) then psic(fc%nlt(1:fc%npwt)) = state_fc_t(1:fc%npwt,ii,is) psic(fc%nltm(1:fc%npwt)) = CONJG( state_fc_t(1:fc%npwt,ii,is) ) else psic(fc%nlt(1:fc%npwt))=state_fc_t(1:fc%npwt,ii,is)+(0.d0,1.d0)*state_fc_t(1:fc%npwt,ii+1,is) psic(fc%nltm(1:fc%npwt)) = CONJG( state_fc_t(1:fc%npwt,ii,is) )+(0.d0,1.d0)*CONJG( state_fc_t(1:fc%npwt,ii+1,is) ) endif CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) state_fc_r(1:fc%nrxxt,ii,is)= DBLE(psic(1:fc%nrxxt)) if(ii/=num_fc_eff(is)) state_fc_r(1:fc%nrxxt,ii+1,is)= DIMAG(psic(1:fc%nrxxt)) enddo enddo deallocate(state_fc_t) endif CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory0.4', kilobytes, ' new kb = ', (SIZE( state_fc_t ))/64 call flush_unit(stdout) !set maximum number of valence states for both spin channels if(nspin==1) then num_nbndv_max=num_nbndv(1) else num_nbndv_max=max(num_nbndv(1),num_nbndv(2)) endif !now valence wavefunctions are put on the ordering of the reduced grid allocate(evc_t(fc%npwt,num_nbndv_max,nspin)) if(fc%dual_t==4.d0) then evc_t(1:fc%npwt,1:num_nbndv_max,1:nspin)=ks_wfcs(1:fc%npwt,1:num_nbndv_max,1:nspin) else do is=1,nspin call reorderwfp_col(num_nbndv(is),npw,fc%npwt,ks_wfcs(1,1,is),evc_t(1,1,is), npw,fc%npwt, & & ig_l2g,fc%ig_l2gt,fc%ngmt_g,mpime, nproc,intra_pool_comm ) ! do iv=1,num_nbndv(is) ! call mergewf(ks_wfcs(:,iv,is),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) ! call splitwf(evc_t(:,iv,is),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) ! enddo enddo endif CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory0.5', kilobytes, ' new kb = ', (SIZE( evc_t ))/64 call flush_unit(stdout) !cycle on v !! product in real space with wannier !! orthonormalize and take N most important !! gram-schmidt like !calculate D matrix ! l_blk= (num_fc)/nproc ! if(l_blk*nproc < (num_fc)) l_blk = l_blk+1 ! nbegin=mpime*l_blk+1 ! nend=nbegin+l_blk-1 ! if(nend > num_fc) nend=num_fc ! nsize=nend-nbegin+1 !check for restart if(ionode) then inquire(file=trim(tmp_dir)//trim(prefix)//'.restart_fk0_status', exist = exst) if(.not. exst) then iv_start=1 else iunrestart0 = find_free_unit() open( unit= iunrestart0, file=trim(tmp_dir)//trim(prefix)//'.restart_fk0_status', status='old') read(iunrestart0,*) iv_start read(iunrestart0,*) fcw_number read(iunrestart0,*) fcw_numberx close(iunrestart0) if(iv_start<1 ) then iv_start=1 else iv_start=iv_start+1 endif endif endif call mp_bcast(iv_start,ionode_id,world_comm) if(iv_start/=1) then call mp_bcast(fcw_number,ionode_id,world_comm) call mp_bcast(fcw_numberx,ionode_id,world_comm) fcw_number_oldx=fcw_numberx fcw_numberx_tmp=fcw_numberx fcw_number_old=fcw_number allocate(fcw_state(fc%npwt,fcw_numberx)) allocate(fcw_state_old(fc%npwt,fcw_numberx)) !read them from file iunfsr = find_free_unit() CALL diropn( iunfsr, 'fsr', fc%npwt*2, exst ) do ii=1,fcw_number CALL davcio( fcw_state(1,ii), 2*fc%npwt, iunfsr, ii, -1 ) fcw_state_old(:,ii)=fcw_state(:,ii) enddo close(iunfsr) endif allocate (wv_real(fc%nrxxt),state_real(fc%nrxxt),state_real2(fc%nrxxt),state_g(fc%npwt,num_fc_eff_max*nspin)) FIRST_LOOP: do iv=iv_start,num_nbndv_max call mp_barrier( world_comm ) write(stdout,*) 'FK state:', iv,fc%nrxxt,fc%npwt,num_fc CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory1', kilobytes call flush_unit(stdout) call mp_barrier( world_comm ) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory2', kilobytes, ' new kb = ', & (SIZE(wv_real)+SIZE(state_real)+SIZE(state_real2)+SIZE(state_g)*2)/128 call flush_unit(stdout) num_fc_spin=0 do is=1,nspin if(iv<= num_nbndv(is)) then psic(:)=(0.d0,0.d0) psic(fc%nlt(igkt(1:fc%npwt))) = evc_t(1:fc%npwt,iv,is) psic(fc%nltm(igkt(1:fc%npwt))) = CONJG( evc_t(1:fc%npwt,iv,is) ) call mp_barrier( world_comm ) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory3', kilobytes call flush_unit(stdout) CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) call mp_barrier( world_comm ) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory4', kilobytes call flush_unit(stdout) wv_real(1:fc%nrxxt)= DBLE(psic(1:fc%nrxxt)) if(l_verbose) then if(fc%gstart_t==2) write(stdout,*) 'FAKE modulus valence', iv, evc_t(1,iv,is) endif !loop on fake conduction states if(l_verbose) write(stdout,*) 'Start FFTs part' call flush_unit(stdout) do ii=1,num_fc_eff(is),2 !fourier transform each state to real space if(.not.l_iter_algorithm) then psic(:)=(0.d0,0.d0) if(ii==num_fc_eff(is)) then psic(fc%nlt(igkt(1:fc%npwt))) = state_fc_t(1:fc%npwt,ii,is) psic(fc%nltm(igkt(1:fc%npwt))) = CONJG( state_fc_t(1:fc%npwt,ii,is) ) else psic(fc%nlt(igkt(1:fc%npwt)))=state_fc_t(1:fc%npwt,ii,is)+(0.d0,1.d0)*state_fc_t(1:fc%npwt,ii+1,is) psic(fc%nltm(igkt(1:fc%npwt))) = CONJG( state_fc_t(1:fc%npwt,ii,is) )+& &(0.d0,1.d0)*CONJG( state_fc_t(1:fc%npwt,ii+1,is) ) endif CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) state_real(1:fc%nrxxt)= DBLE(psic(1:fc%nrxxt)) if(iifcw_numberx_tmp) then deallocate(tmp_mat2) fcw_numberx_tmp=fcw_numberx_tmp+bufferx allocate(tmp_mat2(fcw_numberx_tmp,num_fc_eff_max*nspin)) if(l_verbose) write(stdout,*) 'Updated dimension of tmp_mat2', fcw_numberx_tmp endif endif call dgemm('T','N',fcw_number,num_fc_spin,2*fc%npwt,2.d0,fcw_state,2*fc%npwt,& &state_g,2*fc%npwt,0.d0,tmp_mat2,fcw_numberx_tmp) if(fc%gstart_t==2) then do ii=1,num_fc_spin do jj=1,fcw_number tmp_mat2(jj,ii)=tmp_mat2(jj,ii)-dble(conjg(fcw_state(1,jj))*state_g(1,ii)) enddo enddo endif do ii=1,num_fc_spin call mp_sum(tmp_mat2(1:fcw_number,ii),world_comm) enddo !call mp_sum(tmp_mat2) call dgemm('N','N',2*fc%npwt, num_fc_spin,fcw_number,-1.d0,fcw_state,2*fc%npwt,tmp_mat2,& &fcw_numberx_tmp,1.d0,state_g,2*fc%npwt) if(iv==num_nbndv_max) deallocate(tmp_mat2) endif CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory6', kilobytes if(l_verbose) write(stdout,*) 'End Projection part' call flush_unit(stdout) !calculate overlap matrix if(l_verbose) write(stdout,*) 'FK2'!ATTENZIONE call flush_unit(stdout) max_state=max(300,num_fc/20) if(max_state > num_fc) max_state=num_fc/2 l_blk= (num_fc_spin)/nproc if(l_blk*nproc < (num_fc_spin)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 if(nend > num_fc_spin) nend=num_fc nsize=nend-nbegin+1 if( .not. l_iter_algorithm ) then if(.not.l_diago_para) then allocate(omat(num_fc_spin,num_fc_spin)) if(l_dsyevr) then allocate(omat2(num_fc_spin,num_fc_spin)) else if(l_diago_cg) then allocate(omat2(num_fc_spin,max_state)) endif else allocate(omat(num_fc_spin,l_blk)) allocate(omat2(num_fc_spin,max_state)) endif CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory6.1', kilobytes, ' new kb = ', (SIZE(omat)+SIZE(omat2))/128 call flush_unit(stdout) if(.not.l_diago_para) then call dgemm('T','N',num_fc_spin,num_fc_spin,2*fc%npwt,2.d0,state_g,2*fc%npwt,state_g,2*fc%npwt,0.d0,omat,num_fc_spin) if(fc%gstart_t==2) then do ii=1,num_fc_spin do jj=1,num_fc_spin omat(jj,ii)=omat(jj,ii)-dble(conjg(state_g(1,jj))*state_g(1,ii)) enddo enddo endif call mp_sum(omat,world_comm) else allocate(tmp_mat(num_fc_spin,l_blk)) do ip=0,nproc-1 nbegin_loc=ip*l_blk+1 nend_loc=nbegin_loc+l_blk-1 if(nend_loc > num_fc_spin) nend_loc=num_fc_spin nsize_loc=nend_loc-nbegin_loc+1 if(nsize_loc >0) then call dgemm('T','N',num_fc_spin,nsize_loc,2*fc%npwt,2.d0,state_g,2*fc%npwt,& &state_g(1,nbegin_loc),2*fc%npwt,0.d0,tmp_mat,num_fc_spin) if(fc%gstart_t==2) then do ii=nbegin_loc,nend_loc do jj=1,num_fc_spin tmp_mat(jj,ii-nbegin_loc+1)=tmp_mat(jj,ii-nbegin_loc+1)-dble(conjg(state_g(1,jj))*state_g(1,ii)) enddo enddo endif do ii=1,nsize_loc call mp_sum(tmp_mat(:,ii),world_comm) enddo if(ip==mpime) then omat(:,1:nsize_loc)=tmp_mat(:,1:nsize_loc) endif endif enddo deallocate(tmp_mat) endif CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory6.2', kilobytes call flush_unit(stdout) !solve eigenvalues problem allocate(eigen(num_fc_spin)) if(.not.l_diago_cg) then if(ionode) then if(.not.l_dsyevr) then allocate(work(1)) call DSYEV( 'V', 'U', num_fc_spin, omat, num_fc_spin, eigen, work, -1, info ) lwork=work(1) deallocate(work) allocate(work(lwork)) call DSYEV( 'V', 'U', num_fc_spin, omat, num_fc_spin, eigen, work, lwork, info ) deallocate(work) if(info/=0) then write(stdout,*) 'ROUTINE fake_conduction_wannier, INFO:', info stop endif else allocate(isuppz(2*num_fc_spin)) allocate(work(1),iwork(1)) call DSYEVR('V','V','U',num_fc_spin,omat,num_fc_spin,s_cutoff,1.d6,1,1,0.001d0*s_cutoff,& &n_out,eigen,omat2,num_fc_spin,isuppz,work,-1,iwork,-1,info) lwork=work(1) liwork=iwork(1) deallocate(work,iwork) allocate(work(lwork)) allocate(iwork(liwork)) call DSYEVR('V','V','U',num_fc_spin,omat,num_fc_spin,s_cutoff,10000d0,1,1,& &0.001d0*s_cutoff,n_out,eigen,omat2,num_fc_spin,isuppz,work,lwork,iwork,liwork,info) if(info/=0) then write(stdout,*) 'ROUTINE fake_conduction_wannier, INFO:', info stop endif deallocate(work,iwork) deallocate(isuppz) endif else omat(:,:)=0.d0 if(l_dsyevr) then omat2(:,:)=0.d0 n_out=0 endif eigen(:)=0.d0 endif if(l_verbose) write(stdout,*) 'FK3'!ATTENZIONE call flush_unit(stdout) if(l_dsyevr) then call mp_sum(n_out,world_comm) do iw=1,n_out call mp_sum(omat2(:,iw),world_comm) enddo else call mp_sum(omat,world_comm) endif !call mp_bcast(eigen(:), ionode_id,world_comm) call mp_sum(eigen(:),world_comm) else if(l_verbose) write(stdout,*) 'Before diago_cg',max_state call flush_unit(stdout) if(l_diago_para) then call diago_cg(num_fc_spin,omat,1000,max_state,eigen,omat2,s_cutoff,0.000001d0*s_cutoff,n_out,.true.) else call diago_cg(num_fc_spin,omat,1000,max_state,eigen,omat2,s_cutoff,0.000001d0*s_cutoff,n_out,.false.) endif if(l_verbose) write(stdout,*) 'After diago_cg' call flush_unit(stdout) endif CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory6.3', kilobytes, ' new kb = ', SIZE(eigen)/128 call flush_unit(stdout) !if first valence state construct first basis if(iv==1) then !construct orthonormal basis set ! state_out(:,:)=(0.d0,0.d0) if(.not.(l_dsyevr.or.l_diago_cg)) then n_out=0 do ii=1,num_fc_spin if(l_verbose) write(stdout,*) 'FK eigen:', eigen(ii) if(eigen(ii) >= s_cutoff) then n_out=n_out+1 endif enddo else do ii=1,n_out if(l_verbose) write(stdout,*) 'FK eigen:', eigen(ii) enddo endif if(l_verbose) write(stdout,*) 'FK orthonormal states:', n_out, num_fc_spin call flush_unit(stdout) if(.not.(l_dsyevr.or.l_diago_cg)) then do ii=num_fc_spin-n_out+1,num_fc_spin omat(1:num_fc_spin,ii)=omat(1:num_fc_spin,ii)/dsqrt(eigen(ii)) enddo else do ii=1,n_out omat2(1:num_fc_spin,ii)=omat2(1:num_fc_spin,ii)/dsqrt(abs(eigen(ii))) enddo endif fcw_number=n_out if(fcw_number= s_cutoff) then n_out=n_out+1 endif enddo endif if(l_verbose) write(stdout,*) 'FK orthonormal states:', n_out call flush_unit(stdout) if(.not.(l_dsyevr.or.l_diago_cg)) then do ii=num_fc_spin-n_out+1,num_fc_spin omat(1:num_fc_spin,ii)=omat(1:num_fc_spin,ii)/dsqrt(eigen(ii)) enddo else do ii=1,n_out omat2(1:num_fc_spin,ii)=omat2(1:num_fc_spin,ii)/dsqrt(abs(eigen(ii))) enddo endif fcw_number=n_out+fcw_number_old kb_old = SIZE( fcw_state ) if(fcw_number>fcw_numberx) then fcw_numberx=fcw_numberx+bufferx deallocate(fcw_state) allocate(fcw_state(fc%npwt,fcw_numberx)) endif kb_new = SIZE( fcw_state ) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory6.3.1', kilobytes, ' new kb = ', ( kb_new - kb_old )/64 call flush_unit(stdout) if(.not.(l_dsyevr.or.l_diago_cg)) then call dgemm('N','N',2*fc%npwt,n_out,num_fc_spin,1.d0,state_g,2*fc%npwt,& &omat(1,num_fc_spin-n_out+1),num_fc_spin,0.d0,fcw_state,2*fc%npwt) else call dgemm('N','N',2*fc%npwt,n_out,num_fc_spin,1.d0,state_g,2*fc%npwt,omat2(1,1),num_fc_spin,0.d0,fcw_state,2*fc%npwt) endif fcw_state(:,n_out+1:fcw_number)=fcw_state_old(:,1:fcw_number_old) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory6.3.2', kilobytes call flush_unit(stdout) !write restart on file iunfsr = find_free_unit() CALL diropn( iunfsr, 'fsr', fc%npwt*2, exst ) do ii=1,n_out CALL davcio( fcw_state(1,ii), 2*fc%npwt, iunfsr, fcw_number_old+ii, 1 ) enddo close(iunfsr) endif CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory6.4', kilobytes call flush_unit(stdout) ! if iv is not the last save a copy of the basis if(iv/=num_nbndv_max) then if(l_verbose) write(stdout,*) 'FK5'!ATTENZIONE call flush_unit(stdout) kb_old = 0 if( iv/=1 .and. allocated( fcw_state_old ) ) then kb_old = kb_old + SIZE( fcw_state_old ) if(fcw_number > fcw_number_oldx)then fcw_number_oldx=fcw_number_oldx+bufferx deallocate(fcw_state_old) allocate(fcw_state_old(fc%npwt,fcw_number_oldx)) endif else allocate(fcw_state_old(fc%npwt,fcw_number_oldx)) endif fcw_state_old(1:fc%npwt,1:fcw_number_oldx)=fcw_state(1:fc%npwt,1:fcw_number_oldx) kb_new = SIZE(fcw_state_old) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory6.4.1', kilobytes, ' new kb = ', (kb_new-kb_old)/64 call flush_unit(stdout) fcw_number_old=fcw_number endif if(l_verbose) write(stdout,*) 'FK6'!ATTENZIONE call flush_unit(stdout) kb_old = SIZE( omat ) + SIZE( eigen ) deallocate( omat, eigen ) if( allocated( omat2 ) ) then kb_old = kb_old + SIZE( omat2 ) deallocate(omat2) endif kb_old = kb_old + SIZE( wv_real ) + SIZE( state_real ) + SIZE( state_real2 ) + 2*SIZE( state_g ) !deallocate( wv_real, state_real, state_real2, state_g ) if(l_verbose) write(stdout,*) 'FK7'!ATTENZIONE call flush_unit(stdout) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory6.5', kilobytes, ' old kb = ', kb_old / 128 call flush_unit(stdout) else ! -------------------------iter algorithm CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory6.6', kilobytes call flush_unit(stdout) !uses iterative algorithm !allocate max number of new states !deallocate(wv_real,state_real,state_real2) !gram shimdt like allocate(ovec(num_fc_spin)) num_built=0 do ii=1,num_fc_spin if(num_built>0) then call dgemm('T','N',num_built,1,2*fc%npwt,2.d0,state_g,2*fc%npwt,state_g(1,ii),2*fc%npwt,0.d0,ovec,num_fc_spin) if(fc%gstart_t==2) then do jj=1,num_built ovec(jj)=ovec(jj) -dble(conjg(state_g(1,jj))*state_g(1,ii)) enddo endif call mp_sum(ovec(1:num_built),world_comm) call dgemm('T','N',1,1,2*fc%npwt,2.d0,state_g(1,ii),2*fc%npwt,state_g(1,ii),2*fc%npwt,0.d0,sca2,1) if(fc%gstart_t==2) sca2=sca2-dble(conjg(state_g(1,ii))*state_g(1,ii)) call mp_sum(sca2,world_comm) sca1=0.d0 do jj=1,num_built sca1=sca1+ovec(jj)**2.d0 enddo if(abs(sca2-sca1) >= s_cutoff) then if(num_built+1 /= ii) state_g(1:fc%npwt,num_built+1)=state_g(1:fc%npwt,ii) call dgemm('N','N',2*fc%npwt,1,num_built,-1.d0,state_g,2*fc%npwt,& &ovec,num_fc_spin,1.d0,state_g(1,num_built+1),2*fc%npwt) num_built=num_built+1 call dgemm('T','N',1,1,2*fc%npwt,2.d0,state_g(1,num_built),& &2*fc%npwt,state_g(1,num_built),2*fc%npwt,0.d0,ovec(num_built),1) if(fc%gstart_t==2) ovec(num_built)=ovec(num_built)-dble(conjg(state_g(1,num_built))*state_g(1,num_built)) call mp_sum(ovec(num_built),world_comm) ovec(num_built)=1.d0/dsqrt(ovec(num_built)) state_g(1:fc%npwt,num_built)=state_g(1:fc%npwt,num_built)*ovec(num_built) endif else call dgemm('T','N',1,1,2*fc%npwt,2.d0,state_g(1,ii),& &2*fc%npwt,state_g(1,ii),2*fc%npwt,0.d0,ovec(1),1) if(fc%gstart_t==2) ovec(1)=ovec(1)-dble(conjg(state_g(1,ii))*state_g(1,ii)) call mp_sum(ovec(1),world_comm) if(ovec(1) >= s_cutoff) then num_built=1 ovec(num_built)=1.d0/dsqrt(ovec(num_built)) state_g(1:fc%npwt,num_built)=state_g(1:fc%npwt,ii)*ovec(num_built) endif endif enddo deallocate(ovec) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory6.7', kilobytes write(stdout,*) 'FK GS', num_built call flush_unit(stdout) !opportune basis if( iv == 1 ) then fcw_number=num_built allocate( fcw_state( fc%npwt, fcw_numberx ) ) allocate( fcw_state_old( fc%npwt, fcw_number_oldx ) ) if(num_built>0) then fcw_state(1:fc%npwt,1:num_built) = state_g(1:fc%npwt,1:num_built) iunfsr = find_free_unit() CALL diropn( iunfsr, 'fsr', 2*fc%npwt, exst ) do ii=1,num_built CALL davcio( fcw_state(1,ii), 2*fc%npwt, iunfsr, ii, 1 ) enddo close(iunfsr) endif else if(fcw_number+num_built>fcw_number_oldx) then fcw_number_oldx=fcw_number_oldx+bufferx deallocate(fcw_state_old) allocate( fcw_state_old( fc%npwt, fcw_number_oldx ) ) endif fcw_state_old(1:fc%npwt,1:fcw_number) = fcw_state(1:fc%npwt,1:fcw_number) if(fcw_number+num_built>fcw_numberx) then fcw_numberx=fcw_numberx+bufferx deallocate(fcw_state) allocate(fcw_state(fc%npwt,fcw_numberx)) endif fcw_state(1:fc%npwt,1:fcw_number)=fcw_state_old(1:fc%npwt,1:fcw_number) if(num_built> 0) then fcw_state(1:fc%npwt,fcw_number+1:fcw_number+num_built)=state_g(1:fc%npwt,1:num_built) CALL diropn( iunfsr, 'fsr', 2*fc%npwt, exst ) do ii=1,num_built CALL davcio( fcw_state(1,ii+fcw_number), 2*fc%npwt, iunfsr, ii+fcw_number, 1 ) enddo close(iunfsr) endif fcw_number=fcw_number+num_built endif end if CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory6.8', kilobytes call flush_unit(stdout) iunrestart0 = find_free_unit() open( unit= iunrestart0, file=trim(tmp_dir)//trim(prefix)//'.restart_fk0_status', status='unknown') write(iunrestart0,*) iv write(iunrestart0,*) fcw_number write(iunrestart0,*) fcw_numberx close(iunrestart0) end do FIRST_LOOP deallocate( wv_real, state_real, state_real2, state_g ) if(l_verbose) write(stdout,*) 'FK8' CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory7', kilobytes call flush_unit(stdout) if(num_nbndv(1)/=1 ) deallocate(fcw_state_old) ! calculate D matrix distributed among processors if(fcw_number < nproc) then write(stdout,*) 'too many processors' stop endif l_blk= (fcw_number)/nproc if(l_blk*nproc < (fcw_number)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 if(nend > fcw_number) nend=fcw_number nsize=nend-nbegin+1 allocate(fcw_mat(fcw_number,l_blk)) fcw_mat(:,:)=0.d0 if(l_verbose) write(stdout,*) 'FK9' call flush_unit(stdout) allocate(wv_real_all(fc%nrxxt,num_nbndv_max)) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory8', kilobytes allocate(state_real(fc%nrxxt),state_real_tmp(fc%nrxxt),state_real_tmp2(fc%nrxxt)) allocate(state_g(fc%npwt,num_nbndv_max)) allocate(tmp_mat(fcw_number,num_nbndv_max)) write(stdout,*) 'Calculate FK matrix' call flush_unit(stdout) do is=1,nspin do iv=1,num_nbndv(is) psic(:)=(0.d0,0.d0) psic(fc%nlt(igkt(1:fc%npwt))) = evc_t(1:fc%npwt,iv,is) psic(fc%nltm(igkt(1:fc%npwt))) = CONJG( evc_t(1:fc%npwt,iv,is) ) CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) wv_real_all(1:fc%nrxxt,iv)= DBLE(psic(1:fc%nrxxt)) !check for modulus sca1=0.d0 do ir=1,fc%nrxxt sca1=sca1+wv_real_all(ir,iv)**2.d0 enddo call mp_sum(sca1,world_comm) if(l_verbose) write(stdout,*) 'Modulus:',fc%nrxxt,fc%nr1t*fc%nr2t*fc%nr3t, sca1/(dble(fc%nr1t*fc%nr2t*fc%nr3t)) enddo !loop on fake conduction states call mp_barrier( world_comm ) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory9', kilobytes do ii=1,num_fc_eff(is) if(.not.l_iter_algorithm) then psic(:)=(0.d0,0.d0) psic(fc%nlt(igkt(1:fc%npwt))) = state_fc_t(1:fc%npwt,ii,is) psic(fc%nltm(igkt(1:fc%npwt))) = CONJG( state_fc_t(1:fc%npwt,ii,is) ) CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) state_real(1:fc%nrxxt)= DBLE(psic(1:fc%nrxxt)) endif do iv=1,num_nbndv(is),2 !form product in real space if(.not.l_iter_algorithm) then state_real_tmp(:)=state_real(:)*wv_real_all(:,iv) if(iv < num_nbndv(is)) then state_real_tmp2(:)=state_real(:)*wv_real_all(:,iv+1) else state_real_tmp2(:)=0.d0 endif else state_real_tmp(1:fc%nrxxt)=state_fc_r(1:fc%nrxxt,ii,is)*wv_real_all(1:fc%nrxxt,iv) if(iv < num_nbndv(is)) then state_real_tmp2(1:fc%nrxxt)=state_fc_r(1:fc%nrxxt,ii,is)*wv_real_all(1:fc%nrxxt,iv+1) else state_real_tmp2(1:fc%nrxxt)=0.d0 endif endif !back to G space psic(1:fc%nrxxt)=dcmplx(state_real_tmp(1:fc%nrxxt),state_real_tmp2(1:fc%nrxxt)) CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, -2 ) if(iv < num_nbndv(is)) then state_g(1:fc%npwt, iv)= 0.5d0*(psic(fc%nlt(igkt(1:fc%npwt)))+conjg( psic(fc%nltm(igkt(1:fc%npwt))))) state_g(1:fc%npwt, iv+1)= (0.d0,-0.5d0)*(psic(fc%nlt(igkt(1:fc%npwt))) - conjg(psic(fc%nltm(igkt(1:fc%npwt))))) else state_g(1:fc%npwt, iv) = psic(fc%nlt(igkt(1:fc%npwt))) endif enddo !do products with fcw states call dgemm('T','N',fcw_number,num_nbndv(is),2*fc%npwt,2.d0,fcw_state,2*fc%npwt,state_g,2*fc%npwt,0.d0,tmp_mat,fcw_number) if(fc%gstart_t==2) then do iv=1,num_nbndv(is) do jj=1,fcw_number tmp_mat(jj,iv)=tmp_mat(jj,iv)-dble(conjg(fcw_state(1,jj))*state_g(1,iv)) enddo enddo endif call mp_sum(tmp_mat,world_comm) if(l_frac) then if(ii<=num_fc) then do iv=1,num_nbndv(is) if(nspin==1) then sca1=dsqrt(abs(wg(iv,is))/2.d0) else sca1=dsqrt(abs(wg(iv,is))) endif tmp_mat(1:fcw_number,iv)=tmp_mat(1:fcw_number,iv)*sca1 enddo else do iv=1,num_nbndv(is) if(nspin==1) then sca1=dsqrt(abs(wg(ii-num_fc+num_nbndv_min(is),is)-wg(iv,is))/2.d0) else sca1=dsqrt(abs(wg(ii-num_fc+num_nbndv_min(is),is)-wg(iv,is))) endif tmp_mat(1:fcw_number,iv)=tmp_mat(1:fcw_number,iv)*sca1 enddo endif endif CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory10', kilobytes if(l_verbose) write(stdout,*) 'TOTAL NUMBER OF FCW STATES:', fcw_number,ii,dfftp%nnr,fc%nrxxt,wg(1,is) call flush_unit(stdout) call mp_barrier( world_comm ) !calculate contribution to D matrix if(nsize>0) then call dgemm('N','T',fcw_number,nend-nbegin+1,num_nbndv(is),1.d0,tmp_mat,fcw_number,& &tmp_mat(nbegin:nend,1:num_nbndv(is)),nend-nbegin+1,1.d0,fcw_mat,fcw_number) endif if(l_test) then do iv=1,num_nbndv(is) sca1=0.d0 do jj=1,fcw_number sca1=sca1+tmp_mat(jj,iv)**2.d0 enddo sca2=0.d0 do ig=1,fc%npwt sca2=sca2+2.d0*dble(conjg(state_g(ig,iv))*state_g(ig,iv)) enddo if(fc%gstart_t==2) sca2=sca2-dble(state_g(1,iv))**2.d0 call mp_sum(sca2,world_comm) write(stdout,*) 'Projection', ii,iv,sca1/sca2 enddo endif enddo enddo!on spin !if required put fcw_state on normconserving ordering allocate(fcw_state_n(npw,fcw_number)) if(fc%dual_t==4.d0) then fcw_state_n(1:fc%npwt,1:fcw_number)=fcw_state(1:fc%npwt,1:fcw_number) else call reorderwfp_col(fcw_number,fc%npwt,npw,fcw_state(1,1),fcw_state_n(1,1),fc%npwt,npw, & & fc%ig_l2gt,ig_l2g,fc%ngmt_g,mpime, nproc,intra_pool_comm ) ! do ii=1,fcw_number ! call mergewf(fcw_state(:,ii),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) ! call splitwf(fcw_state_n(:,ii),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) ! enddo endif CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory11', kilobytes !save on file iunfcw = find_free_unit() CALL diropn( iunfcw, 'fcw', npw*2, exst ) do ii=1,fcw_number CALL davcio( fcw_state_n(1,ii), 2*npw, iunfcw, ii, 1 ) enddo close(iunfcw) !write number of states if(ionode) then open(unit=iunfcw,file=trim(tmp_dir)//trim(prefix)//'.nfcws',status='unknown') write(iunfcw,*) fcw_number close(iunfcw) endif CALL diropn( iunfcw, 'fmat',fcw_number, exst ) do ii=1,nsize CALL davcio( fcw_mat(1,ii), fcw_number, iunfcw, ii, 1 ) enddo close(iunfcw) if(l_verbose) write(stdout,*) 'Call deallocate_fft_custom' call flush_unit(stdout) call deallocate_fft_custom(fc) iunrestart0 = find_free_unit() open( unit= iunrestart0, file=trim(tmp_dir)//trim(prefix)//'.restart_fk0_status', status='unknown') write(iunrestart0,*) -1 write(iunrestart0,*) fcw_number write(iunrestart0,*) fcw_numberx close(iunrestart0) deallocate(wv_real_all) if( allocated( state_fc_t ) ) deallocate( state_fc_t ) deallocate(state_real,state_g,state_real_tmp,state_real_tmp2) deallocate(tmp_mat) if(allocated(e_fake)) deallocate(e_fake) deallocate(fcw_state_n) deallocate(evc_t) if( allocated( state_fc ) ) deallocate( state_fc ) if( allocated( state_g ) ) deallocate( state_g ) if( allocated( fcw_state_old ) ) deallocate( fcw_state_old ) if( allocated( h_state_fc ) ) deallocate( h_state_fc ) if( allocated( evc_g ) ) deallocate( evc_g ) if( allocated( evc_t ) ) deallocate( evc_t ) if( allocated( state_fc_t ) ) deallocate( state_fc_t ) if( allocated( state_g_t ) ) deallocate( state_g_t ) if( allocated( fcw_state_n ) ) deallocate( fcw_state_n ) if( allocated( wv_real ) ) deallocate( wv_real ) if( allocated( state_real ) ) deallocate( state_real ) if( allocated( wv_real_all ) ) deallocate( wv_real_all ) if( allocated( state_real_tmp ) ) deallocate( state_real_tmp ) if( allocated( state_real_tmp2 ) ) deallocate( state_real_tmp2 ) if( allocated( state_real2 ) ) deallocate( state_real2 ) if( allocated( omat ) ) deallocate( omat ) if( allocated( eigen ) ) deallocate( eigen ) if( allocated( work ) ) deallocate( work ) if( allocated( tmp_mat ) ) deallocate( tmp_mat ) if( allocated( omat2 ) ) deallocate( omat2 ) if( allocated( hmat ) ) deallocate( hmat ) if( allocated( e_fake ) ) deallocate( e_fake ) if( allocated( vec_fake ) ) deallocate( vec_fake ) if( allocated( gap ) ) deallocate( gap ) if( allocated( hmat_i ) ) deallocate( hmat_i ) if( allocated( hmat_o ) ) deallocate( hmat_o ) if( allocated( omat_i ) ) deallocate( omat_i ) if( allocated( ovec ) ) deallocate( ovec ) if( allocated( g2kint ) ) deallocate( g2kint ) ! if( allocated( iwork ) ) deallocate( iwork ) if( allocated( ifail ) ) deallocate( ifail ) if( allocated( isuppz ) ) deallocate( isuppz ) if( allocated( iclustr ) ) deallocate( iclustr ) if( allocated( igkt ) ) deallocate( igkt ) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory12', kilobytes if(l_verbose) write(stdout,*) 'memory fcw_state = ', SIZE( fcw_state ) / 64 , ' kb' if(l_verbose) write(stdout,*) 'memory fcw_mat = ', SIZE( fcw_mat ) / 64 , ' kb' call flush_unit(stdout) return end subroutine fake_conduction_wannier subroutine fake_conduction_wannier_real( cutoff, s_cutoff ) !IT WORKS ONLY FOR NORMCONSERVING PSEUDOPOTENTIALS !the valence states in G space must be in evc ! Gamma point version !real space version USE io_global, ONLY : stdout, ionode, ionode_id USE kinds, ONLY : DP USE wannier_gw USE gvect USE constants, ONLY : e2, pi, tpi, fpi USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2 USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, et, ecutwfc USE wavefunctions_module, ONLY : evc, psic USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : world_comm, mpime, nproc USE mp_pools, ONLY : intra_pool_comm USE gvecs, ONLY : nls, nlsm, doublegrid USE kinds, ONLY : DP USE io_files, ONLY : prefix, tmp_dir, diropn USE g_psi_mod, ONLY : h_diag, s_diag USE noncollin_module, ONLY : noncolin, npol USE becmod, ONLY : becp USE uspp, ONLY : vkb, nkb, okvan USE klist, ONLY : xk USE fft_custom_gwl USE mp_wave, ONLY : mergewf,splitwf USE fft_base, ONLY : dfftp implicit none INTEGER, EXTERNAL :: find_free_unit ! INTEGER,INTENT(out) :: fcw_number!number of "fake conduction" states for O matrix method ! COMPLEX(kind=DP), POINTER, DIMENSION(:,:) :: fcw_state! "fake conduction" states for O matrix method ! REAL(kind=DP), POINTER, DIMENSION(:,:) :: fcw_mat! "fake conduction" matrix REAL(kind=DP), INTENT(in) :: cutoff!cutoff for planewaves REAL(kind=DP), INTENT(in) :: s_cutoff!cutoff for orthonormalization !NOT_TO_BE_INCLUDED_START COMPLEX(kind=DP), ALLOCATABLE :: state_fc(:,:) !COMPLEX(kind=DP), ALLOCATABLE :: state_g(:,:) COMPLEX(kind=DP), ALLOCATABLE :: fcw_state_old(:,:) COMPLEX(kind=DP), ALLOCATABLE :: h_state_fc(:,:) COMPLEX(kind=DP), ALLOCATABLE :: evc_g(:),evc_t(:,:),state_fc_t(:,:),state_g_t(:,:) COMPLEX(kind=DP), ALLOCATABLE :: fcw_state_n(:,:) REAL(kind=DP), ALLOCATABLE :: wv_real(:),state_real(:),state_real_tmp(:) REAL(kind=DP), ALLOCATABLE :: state_real_tmp2(:),state_real2(:) REAL(kind=DP), ALLOCATABLE :: omat(:,:) REAL(kind=DP), ALLOCATABLE :: eigen(:),work(:) REAL(kind=DP), ALLOCATABLE :: tmp_mat(:,:),tmp_mat2(:,:) REAL(kind=DP), ALLOCATABLE :: omat2(:,:) REAL(kind=DP), ALLOCATABLE :: hmat(:,:) REAL(kind=DP), ALLOCATABLE :: e_fake(:), vec_fake(:,:) REAL(kind=DP), ALLOCATABLE :: gap(:) REAL(kind=DP), ALLOCATABLE :: hmat_i(:,:),hmat_o(:,:), omat_i(:,:) REAL(kind=DP), ALLOCATABLE :: ovec(:) REAL(kind=DP), ALLOCATABLE :: g2kint(:) INTEGER, ALLOCATABLE :: iwork(:), ifail(:) INTEGER, ALLOCATABLE :: isuppz(:) INTEGER, ALLOCATABLE :: iclustr(:) INTEGER, ALLOCATABLE :: igkt(:) REAL(kind=DP):: sca1,sca2 LOGICAL :: l_test=.false.!if true test the completness of the basis LOGICAL :: l_dsyevr=.true.!if true uses dsyevr instead of dsyev LOGICAL :: l_diago_cg=.true.!if true uses diago_cg instead of dsyevr ATTENZIONE LOGICAL :: exst LOGICAL :: l_dsygvx=.false.!if .true. uses serial dsygvx instead of parallel diago_cg_g LOGICAL :: l_gramsc=.true.!if true orthonormalization through gram-schimdt LOGICAL :: l_diago_para=.true.!if true uses parallel diago_cg LOGICAL :: l_fft_custom=.false. INTEGER :: ig,ip, ii, iv, jj, iw, ir INTEGER :: num_fc!number of fake conduction states INTEGER :: lwork,info,liwork INTEGER :: n_out INTEGER :: fcw_number_old INTEGER :: l_blk,nbegin,nend INTEGER :: max_state INTEGER :: iunfcw INTEGER :: nsize INTEGER :: nbegin_loc,nend_loc,nsize_loc INTEGER :: n_found_state !variables for scalapack INTEGER :: num_fc_r,num_fc_c,num_fc_dimr,num_fc_dimc INTEGER :: m,nz,icrow,iccol,iproc,ilrow,ilcol INTEGER :: desc_a(9),desc_b(9),desc_c(9) INTEGER :: n_computed INTEGER :: num_built!number of states already built INTEGER :: num_out INTEGER :: kilobytes INTEGER :: kb_old, kb_new INTEGER, EXTERNAL :: indxg2p,indxg2l TYPE(optimal_options) :: options INTEGER :: bufferx,fcw_numberx,fcw_number_oldx, fcw_numberx_tmp LOGICAL :: l_restart0!if true restart is enabled INTEGER :: iunrestart0, iv_start,iunfsr REAL(kind=DP), ALLOCATABLE :: state_fc_r(:,:) INTEGER, ALLOCATABLE :: g_to_loc(:) !global to local correspondance INTEGER, ALLOCATABLE :: loc_to_g(:) INTEGER :: n_loc!number of local r points REAL(kind=DP), ALLOCATABLE:: state_r(:,:),wv_real_loc(:),state_loc(:) REAL(kind=DP), ALLOCATABLE :: fcw_state_r(:,:), fcw_state_r_loc(:,:) INTEGER :: nmod REAL(kind=DP), ALLOCATABLE :: tmp_vec(:) TYPE(fft_cus) :: fc !determine bufferx,fcw_numberx bufferx=num_nbndv(1)*300/4 bufferx=max(1000,bufferx) !ONLY FOR PROJECT ON JADE bufferx=5000 fcw_numberx=bufferx fcw_number_oldx=bufferx fcw_numberx_tmp=bufferx !generate fake conduction states !!determine number of states !generate custom in grid in case can be equal to norm-conserving grid fc%ecutt=ecutwfc fc%dual_t=dual_pb write(stdout,*) 'Call initialize_fft_custom' CALL memstat( kilobytes ) write(stdout,*) 'memory0', kilobytes call flush_unit(stdout) call initialize_fft_custom(fc) CALL memstat( kilobytes ) write(stdout,*) 'memory0.0', kilobytes call flush_unit(stdout) ! this is for compatibility allocate( igkt( fc%npwt ) ) do ig=1,fc%npwt igkt(ig)=ig enddo allocate( evc_g( fc%ngmt_g ) ) !plane waves basis set !state_fc are first obtained on the ordering of the normconserving grid g2kin(1:npw) = ( (g(1,igk(1:npw)) )**2 + & ( g(2,igk(1:npw)) )**2 + & ( g(3,igk(1:npw)) )**2 ) * tpiba2 num_fc=0 do ig=1,npw if(g2kin(ig) <= cutoff) num_fc=num_fc+1 enddo call mp_sum(num_fc,world_comm) num_fc=(num_fc-1)*2+1 allocate( state_fc( npw, num_fc ) ) state_fc(:,:)=(0.d0,0.d0) write(stdout,*) "Number of fake conduction states:", num_fc CALL memstat( kilobytes ) write(stdout,*) 'memory0.1', kilobytes, ' new kb = ', (SIZE( state_fc )*16 + SIZE( evc_g )*16 + SIZE( igkt )*4)/1024 call flush_unit(stdout) ii=0 do ip=0,nproc-1 if(mpime==ip) then do ig=gstart,npw if(g2kin(ig) <= cutoff) then ii=ii+1 state_fc(ig,ii)=cmplx(dsqrt(0.5d0),0.d0) ii=ii+1 state_fc(ig,ii)=cmplx(0.d0,dsqrt(0.5d0)) endif enddo if(gstart==2) then ii=ii+1 state_fc(1,ii)=(1.d0,0.d0) endif else ii=0 endif call mp_sum(ii,world_comm) enddo if(ii/=num_fc) then write(stdout,*) 'ERRORE FAKE CONDUCTION',ii call flush_unit(stdout) stop return endif write(stdout,*) 'FAKE1' call flush_unit(stdout) !!project out of valence space do ii=1,num_fc call pc_operator(state_fc(:,ii),1,.false.)!ATTENZIONE spin not implemented yet here ! if(gstart==2) write(stdout,*) 'FAKE modulus', ii, state_fc(1,ii) enddo !orthonormalize fake_conduction states !for the moment finds all the first fcw_fast_n eigenstates write(stdout,*) 'CASE ORTHONORMALIZATION ONLY' call flush_unit(stdout) options%l_complete=.true. options%idiago=0 call optimal_driver(num_fc,state_fc,npw,options,num_out, info) CALL memstat( kilobytes ) write(stdout,*) 'memory0.3', kilobytes call flush_unit(stdout) !now state_fc are put on the ordering of the redueced grid, if required allocate(state_fc_t(fc%npwt,num_fc)) if(fc%dual_t==4.d0) then state_fc_t(:,:)=state_fc(:,:) else do ii=1,num_fc call mergewf(state_fc(:,ii),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) call splitwf(state_fc_t(:,ii),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) enddo endif allocate(state_fc_r(fc%nrxxt,num_fc)) do ii=1,num_fc,2 psic(:)=(0.d0,0.d0) if(ii==num_fc) then psic(fc%nlt(1:fc%npwt)) = state_fc_t(1:fc%npwt,ii) psic(fc%nltm(1:fc%npwt)) = CONJG( state_fc_t(1:fc%npwt,ii) ) else psic(fc%nlt(1:fc%npwt))=state_fc_t(1:fc%npwt,ii)+(0.d0,1.d0)*state_fc_t(1:fc%npwt,ii+1) psic(fc%nltm(1:fc%npwt)) = CONJG( state_fc_t(1:fc%npwt,ii) )+(0.d0,1.d0)*CONJG( state_fc_t(1:fc%npwt,ii+1) ) endif CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) state_fc_r(1:fc%nrxxt,ii)= DBLE(psic(1:fc%nrxxt)) if(ii/=num_fc) state_fc_r(1:fc%nrxxt,ii+1)= DIMAG(psic(1:fc%nrxxt)) enddo CALL memstat( kilobytes ) write(stdout,*) 'memory0.4', kilobytes, ' new kb = ', (SIZE( state_fc_t ))/64 call flush_unit(stdout) !now valence wavefunctions are put on the ordering of the reduced grid allocate(evc_t(fc%npwt,num_nbndv(1))) if(fc%dual_t==4.d0) then evc_t(:,1:num_nbndv(1))=evc(:,1:num_nbndv(1)) else do iv=1,num_nbndv(1) call mergewf(evc(:,iv),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) call splitwf(evc_t(:,iv),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) enddo endif CALL memstat( kilobytes ) write(stdout,*) 'memory0.5', kilobytes, ' new kb = ', (SIZE( evc_t ))/64 call flush_unit(stdout) !cycle on v !! product in real space with wannier !! orthonormalize and take N most important !! gram-schmidt like !calculate D matrix l_blk= (num_fc)/nproc if(l_blk*nproc < (num_fc)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 if(nend > num_fc) nend=num_fc nsize=nend-nbegin+1 !check for restart allocate(fcw_state_r(fc%nrxxt,fcw_numberx)) allocate (wv_real(fc%nrxxt))!,state_g(fc%npwt,num_fc)) allocate(wv_real_loc(fc%nrxxt)) ! allocate(state_r(fc%nrxxt,num_fc)) allocate(g_to_loc(fc%nrxxt),loc_to_g(fc%nrxxt)) fcw_number=0 FIRST_LOOP: do iv=1,num_nbndv(1) call mp_barrier( world_comm ) write(stdout,*) 'FK state:', iv,fc%nrxxt,fc%npwt,num_fc CALL memstat( kilobytes ) write(stdout,*) 'memory1', kilobytes call flush_unit(stdout) ! allocate (wv_real(fc%nrxxt),state_real(fc%nrxxt),state_real2(fc%nrxxt),state_g(fc%npwt,num_fc)) ! if(l_iter_algorithm) allocate (state_g_r(fc%nrxxt,num_fc)) call mp_barrier( world_comm ) CALL memstat( kilobytes ) write(stdout,*) 'memory2', kilobytes, ' new kb = ', & (SIZE(wv_real))/128 call flush_unit(stdout) psic(:)=(0.d0,0.d0) psic(fc%nlt(igkt(1:fc%npwt))) = evc_t(1:fc%npwt,iv) psic(fc%nltm(igkt(1:fc%npwt))) = CONJG( evc_t(1:fc%npwt,iv) ) call mp_barrier( world_comm ) CALL memstat( kilobytes ) write(stdout,*) 'memory3', kilobytes call flush_unit(stdout) CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) call mp_barrier( world_comm ) CALL memstat( kilobytes ) write(stdout,*) 'memory4', kilobytes call flush_unit(stdout) wv_real(:)= DBLE(psic(:)) if(fc%gstart_t==2) write(stdout,*) 'FAKE modulus valence', iv, evc_t(1,iv) !loop on fake conduction states !find global to local correspodance n_loc=0 do ir=1,fc%nrxxt if(wv_real(ir)**2.d0 >= wannier_thres) then n_loc=n_loc+1 g_to_loc(ir)=n_loc loc_to_g(n_loc)=ir else g_to_loc(ir)=0 endif enddo write(stdout,*) 'Start products',n_loc,fc%nrxxt,loc_to_g(n_loc) call flush_unit(stdout) do ir=1,n_loc wv_real_loc(ir)=wv_real(loc_to_g(ir)) enddo if(n_loc>= 1) then allocate(state_loc(n_loc)) else allocate(state_loc(1)) endif write(stdout,*) 'End products part' call mp_barrier( world_comm ) CALL memstat( kilobytes ) write(stdout,*) 'memory5', kilobytes call flush_unit(stdout) !if not first valence wannier project the products out of partial orthonormal basis !loop on fake conduction states allocate(tmp_vec(fcw_numberx)) if(n_loc >=1 ) then allocate(fcw_state_r_loc(n_loc,fcw_numberx)) else allocate(fcw_state_r_loc(1,fcw_numberx)) endif !$OMP PARALLEL SHARED(fcw_number,n_loc,fcw_state_r,fcw_state_r_loc,loc_to_g) PRIVATE(ii,ir) !$OMP DO do ii=1,fcw_number do ir=1,n_loc fcw_state_r_loc(ir,ii)=fcw_state_r(loc_to_g(ir),ii) enddo enddo !$OMP END DO !$OMP END PARALLEL do ii=1,num_fc !global to local trasform do ir=1,n_loc state_loc(ir)=state_fc_r(loc_to_g(ir),ii) enddo do ir=1,n_loc state_loc(ir)=state_loc(ir)*wv_real_loc(ir) enddo if(iv==1 .and. ii==1) then !put the first one as it is !calculate modulus if(n_loc >=1) then call dgemm('T','N',1,1,n_loc,1.d0,state_loc,n_loc,state_loc,n_loc,0.d0,sca2,1) else sca2=0.d0 endif call mp_sum(sca2,world_comm) sca2=sca2/dble(fc%nr1t*fc%nr2t*fc%nr3t) sca2=1.d0/dsqrt(sca2) if(n_loc >= 1) fcw_state_r_loc(1:n_loc,1)=state_loc(1:n_loc)*sca2 fcw_state_r(:,1)=0.d0 !$OMP PARALLEL SHARED(fcw_state_r,fcw_state_r_loc,loc_to_g,n_loc) PRIVATE(ir) !$OMP DO do ir=1,n_loc fcw_state_r(loc_to_g(ir),1)=fcw_state_r_loc(ir,1) enddo !$OMP END DO !$OMP END PARALLEL fcw_number=1 else if(n_loc >=1) then call dgemm('T','N',fcw_number,1,n_loc,1.d0,fcw_state_r_loc,n_loc,state_loc,n_loc,0.d0,tmp_vec,fcw_numberx) else tmp_vec(1:fcw_number)=0.d0 endif call mp_sum(tmp_vec,world_comm) tmp_vec(:)=tmp_vec(:)/dble(fc%nr1t*fc%nr2t*fc%nr3t) if(n_loc >=1) then call dgemm('T','N',1,1,n_loc,1.d0,state_loc,n_loc,state_loc,n_loc,0.d0,sca2,1) else sca2=0.d0 endif call mp_sum(sca2,world_comm) sca2=sca2/dble(fc%nr1t*fc%nr2t*fc%nr3t) sca1=0.d0 do jj=1,fcw_number sca1=sca1+tmp_vec(jj)**2.d0 enddo if(abs(sca2-sca1) >= s_cutoff) then fcw_state_r(:,fcw_number+1)=0.d0 !$OMP PARALLEL SHARED(fcw_state_r,state_loc,loc_to_g,fcw_number,n_loc) PRIVATE(ir) !$OMP DO do ir=1,n_loc fcw_state_r(loc_to_g(ir),fcw_number+1)=state_loc(ir) enddo !$OMP END DO !$OMP END PARALLEL call dgemm('N','N',fc%nrxxt, 1,fcw_number,-1.d0,fcw_state_r,fc%nrxxt,tmp_vec,& &fcw_numberx,1.d0,fcw_state_r(1,fcw_number+1),fc%nrxxt) sca1=1.d0/(dsqrt(abs(sca2-sca1))) fcw_state_r(:,fcw_number+1)= fcw_state_r(:,fcw_number+1)*sca1 !$OMP PARALLEL SHARED(fcw_state_r,fcw_state_r_loc,loc_to_g,fcw_number,n_loc) PRIVATE(ir) !$OMP DO do ir=1,n_loc fcw_state_r_loc(ir,fcw_number+1)=fcw_state_r(loc_to_g(ir),fcw_number+1) enddo !$OMP END DO !$OMP END PARALLEL fcw_number=fcw_number+1 endif endif enddo deallocate(tmp_vec) deallocate(fcw_state_r_loc) deallocate(state_loc) call flush_unit(stdout) write(stdout,*) 'memory6.8', kilobytes call flush_unit(stdout) end do FIRST_LOOP write(stdout,*) 'FK8' CALL memstat( kilobytes ) write(stdout,*) 'memory7', kilobytes call flush_unit(stdout) ! calculate D matrix distributed among processors if(fcw_number < nproc) then write(stdout,*) 'too many processors' stop endif l_blk= (fcw_number)/nproc if(l_blk*nproc < (fcw_number)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 if(nend > fcw_number) nend=fcw_number nsize=nend-nbegin+1 allocate(fcw_mat(fcw_number,l_blk)) fcw_mat(:,:)=0.d0 write(stdout,*) 'FK9' call flush_unit(stdout) CALL memstat( kilobytes ) write(stdout,*) 'memory8', kilobytes allocate(tmp_mat(fcw_number,100)) do iv=1,num_nbndv(1) psic(:)=(0.d0,0.d0) psic(fc%nlt(1:fc%npwt)) = evc_t(1:fc%npwt,iv) psic(fc%nltm(1:fc%npwt)) = CONJG( evc_t(1:fc%npwt,iv) ) CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) wv_real(1:fc%nrxxt)= DBLE(psic(1:fc%nrxxt)) !find global to local correspodance n_loc=0 do ir=1,fc%nrxxt if(wv_real(ir)**2.d0 >= wannier_thres) then n_loc=n_loc+1 g_to_loc(ir)=n_loc loc_to_g(n_loc)=ir else g_to_loc(ir)=0 endif enddo do ir=1,n_loc wv_real_loc(ir)=wv_real(loc_to_g(ir)) enddo !put fcw_state_r and state_fc_r on local grid if(n_loc >= 1) then allocate(state_r(n_loc,num_fc)) allocate(fcw_state_r_loc(n_loc, fcw_number)) else allocate(state_r(n_loc,num_fc)) allocate(fcw_state_r_loc(n_loc, fcw_number)) endif do ii=1,num_fc !global to local trasform do ir=1,n_loc state_r(ir,ii)=state_fc_r(loc_to_g(ir),ii)*wv_real_loc(ir) enddo enddo do ii=1,fcw_number do ir=1,n_loc fcw_state_r_loc(ir,ii)=fcw_state_r(loc_to_g(ir),ii) enddo enddo do ii=1,num_fc,100 nmod=min(ii+100-1,num_fc)-ii+1 if(n_loc >= 1 ) then call dgemm('T','N',fcw_number,nmod,n_loc,1.d0,fcw_state_r_loc,n_loc,state_r(1,ii),n_loc,0.d0,tmp_mat,fcw_number) else tmp_mat(:,:)=0.d0 endif call mp_sum(tmp_mat,world_comm) tmp_mat(:,:)=tmp_mat(:,:)/dble(fc%nr1t*fc%nr2t*fc%nr3t) CALL memstat( kilobytes ) write(stdout,*) 'memory10', kilobytes write(stdout,*) 'TOTAL NUMBER OF FCW STATES:', fcw_number,ii,dfftp%nnr,fc%nrxxt,n_loc call flush_unit(stdout) if(nsize>0) then call dgemm('N','T',fcw_number,nend-nbegin+1,nmod,1.d0,tmp_mat,fcw_number,& &tmp_mat(nbegin:nend,1:nmod),nend-nbegin+1,1.d0,fcw_mat,fcw_number) endif enddo deallocate(state_r) deallocate(fcw_state_r_loc) enddo !trasform fcw_state_r to fcw_state allocate(fcw_state(fc%npwt,fcw_number)) do ii=1,fcw_number,2 if(ii==fcw_number) then psic(1:fc%nrxxt)=dcmplx(fcw_state_r(1:fc%nrxxt,ii),0.d0) else psic(1:fc%nrxxt)=dcmplx(fcw_state_r(1:fc%nrxxt,ii),fcw_state_r(1:fc%nrxxt,ii+1)) endif CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, -2 ) if(ii==fcw_number) then fcw_state(1:fc%npwt, ii) = psic(fc%nlt(1:fc%npwt)) if(fc%gstart_t==2) fcw_state(1,ii)=(0.d0,0.d0) else fcw_state(1:fc%npwt, ii)= 0.5d0*(psic(fc%nlt(igkt(1:fc%npwt)))+conjg( psic(fc%nltm(igkt(1:fc%npwt))))) fcw_state(1:fc%npwt, ii+1)= (0.d0,-0.5d0)*(psic(fc%nlt(igkt(1:fc%npwt))) - conjg(psic(fc%nltm(igkt(1:fc%npwt))))) if(fc%gstart_t==2) fcw_state(1,ii)=(0.d0,0.d0) if(fc%gstart_t==2) fcw_state(1,ii+1)=(0.d0,0.d0) endif enddo !write(stdout,*) 'Att0' ! call flush_unit(stdout) call mp_barrier( world_comm ) CALL memstat( kilobytes ) write(stdout,*) 'memory9', kilobytes call flush_unit(stdout) !if required put fcw_state on normconserving ordering deallocate(fcw_state_r) allocate(fcw_state_n(npw,fcw_number)) if(fc%dual_t==4.d0) then fcw_state_n(:,:)=fcw_state(:,:) else do ii=1,fcw_number call mergewf(fcw_state(:,ii),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) call splitwf(fcw_state_n(:,ii),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) enddo endif CALL memstat( kilobytes ) write(stdout,*) 'memory11', kilobytes !save on file iunfcw = find_free_unit() CALL diropn( iunfcw, 'fcw', npw*2, exst ) do ii=1,fcw_number CALL davcio( fcw_state_n(1,ii), 2*npw, iunfcw, ii, 1 ) enddo close(iunfcw) !write number of states if(ionode) then open(unit=iunfcw,file=trim(tmp_dir)//trim(prefix)//'.nfcws',status='unknown') write(iunfcw,*) fcw_number close(iunfcw) endif CALL diropn( iunfcw, 'fmat',fcw_number, exst ) do ii=1,nsize CALL davcio( fcw_mat(1,ii), fcw_number, iunfcw, ii, 1 ) enddo close(iunfcw) write(stdout,*) 'Call deallocate_fft_custom' call flush_unit(stdout) call deallocate_fft_custom(fc) deallocate(g_to_loc,loc_to_g) deallocate(wv_real_loc) if( allocated( state_fc_t ) ) deallocate( state_fc_t ) deallocate(tmp_mat) if(allocated(e_fake)) deallocate(e_fake) deallocate(fcw_state_n) deallocate(evc_g,evc_t) if( allocated( state_fc ) ) deallocate( state_fc ) if( allocated( fcw_state_old ) ) deallocate( fcw_state_old ) if( allocated( h_state_fc ) ) deallocate( h_state_fc ) if( allocated( evc_g ) ) deallocate( evc_g ) if( allocated( evc_t ) ) deallocate( evc_t ) if( allocated( state_fc_t ) ) deallocate( state_fc_t ) if( allocated( state_g_t ) ) deallocate( state_g_t ) if( allocated( fcw_state_n ) ) deallocate( fcw_state_n ) if( allocated( wv_real ) ) deallocate( wv_real ) if( allocated( state_real ) ) deallocate( state_real ) if( allocated( state_real_tmp ) ) deallocate( state_real_tmp ) if( allocated( state_real_tmp2 ) ) deallocate( state_real_tmp2 ) if( allocated( state_real2 ) ) deallocate( state_real2 ) if( allocated( omat ) ) deallocate( omat ) if( allocated( eigen ) ) deallocate( eigen ) if( allocated( work ) ) deallocate( work ) if( allocated( tmp_mat ) ) deallocate( tmp_mat ) if( allocated( omat2 ) ) deallocate( omat2 ) if( allocated( hmat ) ) deallocate( hmat ) if( allocated( e_fake ) ) deallocate( e_fake ) if( allocated( vec_fake ) ) deallocate( vec_fake ) if( allocated( gap ) ) deallocate( gap ) if( allocated( hmat_i ) ) deallocate( hmat_i ) if( allocated( hmat_o ) ) deallocate( hmat_o ) if( allocated( omat_i ) ) deallocate( omat_i ) if( allocated( ovec ) ) deallocate( ovec ) if( allocated( g2kint ) ) deallocate( g2kint ) ! if( allocated( iwork ) ) deallocate( iwork ) if( allocated( ifail ) ) deallocate( ifail ) if( allocated( isuppz ) ) deallocate( isuppz ) if( allocated( iclustr ) ) deallocate( iclustr ) if( allocated( igkt ) ) deallocate( igkt ) CALL memstat( kilobytes ) write(stdout,*) 'memory12', kilobytes write(stdout,*) 'memory fcw_state = ', SIZE( fcw_state ) / 64 , ' kb' write(stdout,*) 'memory fcw_mat = ', SIZE( fcw_mat ) / 64 , ' kb' call flush_unit(stdout) return !NOT_TO_BE_INCLUDED_END end subroutine fake_conduction_wannier_real subroutine fake_conduction_real( cutoff, s_cutoff,ks_wfcs ,l_frac, ks_wfcs_diag,l_cond) !IT WORKS ONLY FOR NORMCONSERVING PSEUDOPOTENTIALS !the valence states in G space must be in evc ! Gamma point version USE io_global, ONLY : stdout, ionode, ionode_id USE kinds, ONLY : DP USE wannier_gw USE gvect USE constants, ONLY : e2, pi, tpi, fpi USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2 USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, et, ecutwfc, wg USE wavefunctions_module, ONLY : evc, psic USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : world_comm, mpime, nproc USE mp_pools, ONLY : intra_pool_comm USE gvecs, ONLY : nls, nlsm, doublegrid USE kinds, ONLY : DP USE io_files, ONLY : prefix, tmp_dir, diropn USE g_psi_mod, ONLY : h_diag, s_diag USE noncollin_module, ONLY : noncolin, npol USE becmod, ONLY : becp USE uspp, ONLY : vkb, nkb, okvan USE klist, ONLY : xk USE fft_custom_gwl USE mp_wave, ONLY : mergewf,splitwf USE fft_base, ONLY : dfftp USE lsda_mod, ONLY : nspin USE mp_wave_parallel implicit none INTEGER, EXTERNAL :: find_free_unit ! INTEGER,INTENT(out) :: fcw_number!number of "fake conduction" states for O matrix method ! COMPLEX(kind=DP), POINTER, DIMENSION(:,:) :: fcw_state! "fake conduction" states for O matrix method ! REAL(kind=DP), POINTER, DIMENSION(:,:) :: fcw_mat! "fake conduction" matrix REAL(kind=DP), INTENT(in) :: cutoff!cutoff for planewaves REAL(kind=DP), INTENT(in) :: s_cutoff!cutoff for orthonormalization COMPLEX(kind=DP), INTENT(in) :: ks_wfcs(npwx,nbnd,nspin)!Kohn-Sham or Wannier wavefunctios LOGICAL, INTENT(in) :: l_frac!if true consider fractional occupancies COMPLEX(kind=DP), INTENT(in) :: ks_wfcs_diag(npwx,nbnd,nspin)!Kohn-Sham wavefunctios LOGICAL, INTENT(in) :: l_cond!if true consider also conduction states for the construction of the polarizability basis !NOT_TO_BE_INCLUDED_START COMPLEX(kind=DP), ALLOCATABLE :: state_fc(:,:,:) REAL(kind=DP), ALLOCATABLE :: state_g(:,:) REAL(kind=DP), ALLOCATABLE :: fcw_state_r(:,:) REAL(kind=DP), ALLOCATABLE :: fcw_state_old_r(:,:) COMPLEX(kind=DP), ALLOCATABLE :: h_state_fc(:,:) COMPLEX(kind=DP), ALLOCATABLE :: evc_g(:),evc_t(:,:,:),state_fc_t(:,:,:),state_g_t(:,:) COMPLEX(kind=DP), ALLOCATABLE :: fcw_state_n(:,:) REAL(kind=DP), ALLOCATABLE :: wv_real(:),state_real(:),wv_real_all(:,:),state_real_tmp(:) REAL(kind=DP), ALLOCATABLE :: state_real_tmp2(:),state_real2(:) REAL(kind=DP), ALLOCATABLE :: omat(:,:) REAL(kind=DP), ALLOCATABLE :: eigen(:),work(:) REAL(kind=DP), ALLOCATABLE :: tmp_mat(:,:),tmp_mat2(:,:) REAL(kind=DP), ALLOCATABLE :: omat2(:,:) REAL(kind=DP), ALLOCATABLE :: hmat(:,:) REAL(kind=DP), ALLOCATABLE :: e_fake(:), vec_fake(:,:) REAL(kind=DP), ALLOCATABLE :: gap(:) REAL(kind=DP), ALLOCATABLE :: hmat_i(:,:),hmat_o(:,:), omat_i(:,:) REAL(kind=DP), ALLOCATABLE :: ovec(:) REAL(kind=DP), ALLOCATABLE :: g2kint(:) INTEGER, ALLOCATABLE :: iwork(:), ifail(:) INTEGER, ALLOCATABLE :: isuppz(:) INTEGER, ALLOCATABLE :: iclustr(:) INTEGER, ALLOCATABLE :: igkt(:) REAL(kind=DP):: sca1,sca2 LOGICAL :: l_test=.false.!if true test the completness of the basis LOGICAL :: l_dsyevr=.true.!if true uses dsyevr instead of dsyev LOGICAL :: l_diago_cg=.true.!if true uses diago_cg instead of dsyevr ATTENZIONE LOGICAL :: exst LOGICAL :: l_dsygvx=.false.!if .true. uses serial dsygvx instead of parallel diago_cg_g LOGICAL :: l_gramsc=.true.!if true orthonormalization through gram-schimdt LOGICAL :: l_diago_para=.true.!if true uses parallel diago_cg LOGICAL :: l_fft_custom=.false. INTEGER :: ig,ip, ii, iv, jj, iw, ir, is INTEGER :: num_fc!number of fake conduction states INTEGER :: lwork,info,liwork INTEGER :: n_out INTEGER :: fcw_number_old INTEGER :: l_blk,nbegin,nend INTEGER :: max_state INTEGER :: iunfcw INTEGER :: nsize INTEGER :: nbegin_loc,nend_loc,nsize_loc INTEGER :: n_found_state !variables for scalapack INTEGER :: num_fc_r,num_fc_c,num_fc_dimr,num_fc_dimc INTEGER :: m,nz,icrow,iccol,iproc,ilrow,ilcol INTEGER :: desc_a(9),desc_b(9),desc_c(9) INTEGER :: n_computed INTEGER :: num_built!number of states already built INTEGER :: num_out INTEGER :: kilobytes INTEGER :: kb_old, kb_new INTEGER, EXTERNAL :: indxg2p,indxg2l TYPE(optimal_options) :: options INTEGER :: bufferx,fcw_numberx,fcw_number_oldx, fcw_numberx_tmp LOGICAL :: l_restart0!if true restart is enabled INTEGER :: iunrestart0, iv_start,iunfsr REAL(kind=DP), ALLOCATABLE :: state_fc_r(:,:,:) INTEGER :: num_nbndv_max, num_fc_spin INTEGER :: num_fc_eff(2),num_fc_eff_max LOGICAL :: l_do_optimal INTEGER :: iun_oap COMPLEX(kind=DP), ALLOCATABLE :: cbuf(:,:) TYPE(fft_cus) :: fc !determine bufferx,fcw_numberx bufferx=num_nbndv(1)*300/4 bufferx=max(1000,bufferx) !ONLY FOR PROJECT ON JADE bufferx=5000 fcw_numberx=bufferx fcw_number_oldx=bufferx fcw_numberx_tmp=bufferx !generate fake conduction states !!determine number of states !generate custom in grid in case can be equal to norm-conserving grid fc%ecutt=ecutwfc fc%dual_t=dual_pb write(stdout,*) 'Call initialize_fft_custom' CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory0', kilobytes call flush_unit(stdout) call initialize_fft_custom(fc) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory0.0', kilobytes call flush_unit(stdout) ! this is for compatibility allocate( igkt( fc%npwt ) ) do ig=1,fc%npwt igkt(ig)=ig enddo allocate( evc_g( fc%ngmt_g ) ) !plane waves basis set !state_fc are first obtained on the ordering of the normconserving grid g2kin(1:npw) = ( (g(1,igk(1:npw)) )**2 + & ( g(2,igk(1:npw)) )**2 + & ( g(3,igk(1:npw)) )**2 ) * tpiba2 num_fc=0 do ig=1,npw if(g2kin(ig) <= cutoff) num_fc=num_fc+1 enddo call start_clock('mpsum') call mp_sum(num_fc,world_comm) call stop_clock('mpsum') num_fc=(num_fc-1)*2+1 if(.not.l_cond) then if(.not.l_frac) then num_fc_eff(1:2)=num_fc num_fc_eff_max=num_fc else num_fc_eff(1:2)=num_fc+num_nbndv(1:2)-num_nbndv_min(1:2) num_fc_eff_max=max(num_fc_eff(1),num_fc_eff(2)) endif else if(.not.l_frac) then num_fc_eff(1:2)=num_fc+num_nbnds-num_nbndv(1:2) num_fc_eff_max=num_fc+num_nbnds-min(num_nbndv(1),num_nbndv(2)) else num_fc_eff(1:2)=num_fc+num_nbndv(1:2)-num_nbndv_min(1:2)+num_nbnds-num_nbndv(1:2) num_fc_eff_max=max(num_fc_eff(1),num_fc_eff(2)) endif endif allocate( state_fc( npw, num_fc_eff_max, nspin ) ) state_fc(:,:,:)=(0.d0,0.d0) write(stdout,*) "Number of projected orthonormalized plane waves:", num_fc CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory0.1', kilobytes, ' new kb = ', & &(SIZE( state_fc )*16 + SIZE( evc_g )*16 + SIZE( igkt )*4)/1024 call flush_unit(stdout) ii=0 do ip=0,nproc-1 if(mpime==ip) then do ig=gstart,npw if(g2kin(ig) <= cutoff) then ii=ii+1 state_fc(ig,ii,1)=cmplx(dsqrt(0.5d0),0.d0) ii=ii+1 state_fc(ig,ii,1)=cmplx(0.d0,dsqrt(0.5d0)) endif enddo if(gstart==2) then ii=ii+1 state_fc(1,ii,1)=(1.d0,0.d0) endif else ii=0 endif call start_clock('mpsum') call mp_sum(ii,world_comm) call stop_clock('mpsum') enddo if(ii/=num_fc) then write(stdout,*) 'ERRORE FAKE CONDUCTION',ii call flush_unit(stdout) stop return endif if(l_verbose) write(stdout,*) 'FAKE1' call flush_unit(stdout) if(nspin==2) state_fc(:,1:num_fc,2)=state_fc(:,1:num_fc,1) do is=1,nspin !!project out of valence space do ii=1,num_fc evc(1:npw,1:num_nbndv(is))=ks_wfcs(1:npw,1:num_nbndv(is),is)!for calling pc_operator call pc_operator(state_fc(:,ii,is),is,l_cond) enddo enddo !!add partially occupied states if(l_frac) then do is=1,nspin do ii=num_nbndv_min(is)+1,num_nbndv(is) state_fc(1:npw,num_fc+ii-num_nbndv_min(is),is)=ks_wfcs_diag(1:npw,ii,is) enddo enddo endif !!add conduction states if required if(l_cond) then if(.not.l_frac) then do is=1,nspin do ii=num_nbndv(is)+1,num_nbnds state_fc(1:npw,num_fc+ii-num_nbndv(is),is)=ks_wfcs_diag(1:npw,ii,is) enddo enddo else do is=1,nspin do ii=num_nbndv(is)+1,num_nbnds state_fc(1:npw,num_fc+num_nbndv(is)-num_nbndv_min(is)+ii-num_nbndv(is),is)=ks_wfcs_diag(1:npw,ii,is) enddo enddo endif endif !orthonormalize fake_conduction states !for the moment finds all the first fcw_fast_n eigenstates if(l_verbose) write(stdout,*) 'CASE ORTHONORMALIZATION ONLY' call flush_unit(stdout) !if required orthonormalize the projected plane_waves or read from disk l_do_optimal=.false. inquire(file=trim(tmp_dir)//trim(prefix)//'.restart_fk0_status', exist = exst) if(.not. exst) then l_do_optimal=.true. else iunrestart0 = find_free_unit() open( unit= iunrestart0, file=trim(tmp_dir)//trim(prefix)//'.restart_fk0_status', status='old') read(iunrestart0,*) iv_start close(iunrestart0) if(iv_start<1 ) l_do_optimal=.true. endif if(l_do_optimal) then if(l_verbose) write(stdout,*) 'Call optimal driver' call flush_unit(stdout) options%l_complete=.true. options%idiago=0 call start_clock('fc_optimal') do is=1,nspin call optimal_driver(num_fc_eff(is),state_fc(1,1,is),npw,options,num_out, info) enddo call stop_clock('fc_optimal') !read orthonormalized projected plane-waves from disk endif CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory0.3', kilobytes call flush_unit(stdout) !now state_fc are put on the ordering of the redueced grid, if required allocate(state_fc_t(fc%npwt,num_fc_eff_max,nspin)) if(l_do_optimal) then if(fc%dual_t==4.d0) then do is=1,nspin state_fc_t(1:fc%npwt,1:num_fc_eff(is),is)=state_fc(1:fc%npwt,1:num_fc_eff(is),is) enddo else call start_clock('fc_merge') do is=1,nspin call reorderwfp (num_fc_eff(is),npw, fc%npwt,state_fc(:,:,is),state_fc_t(:,:,is), & &npw,fc%npwt, ig_l2g,fc%ig_l2gt, fc%ngmt_g , mpime, nproc,ionode_id, intra_pool_comm ) ! do ii=1,num_fc_eff(is) ! call mergewf(state_fc(:,ii,is),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) ! call splitwf(state_fc_t(:,ii,is),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) ! enddo enddo call stop_clock('fc_merge') endif iun_oap = find_free_unit() CALL diropn( iun_oap, 'oap', fc%npwt*2, exst ) do ii=1,num_fc_eff(1) CALL davcio( state_fc_t(:,ii,1), 2*fc%npwt, iun_oap, ii, 1 ) enddo close(iun_oap) else if(l_verbose) write(stdout,*) 'Read OAP from disk' call flush_unit(stdout) iun_oap = find_free_unit() CALL diropn( iun_oap, 'oap', fc%npwt*2, exst ) do ii=1,num_fc_eff(1) CALL davcio( state_fc_t(:,ii,1), 2*fc%npwt, iun_oap, ii, -1 ) enddo close(iun_oap) endif deallocate(state_fc) allocate(state_fc_r(fc%nrxxt,num_fc_eff_max,nspin)) do is=1,nspin do ii=1,num_fc_eff(is),2 psic(:)=(0.d0,0.d0) if(ii==num_fc_eff(is)) then psic(fc%nlt(1:fc%npwt)) = state_fc_t(1:fc%npwt,ii,is) psic(fc%nltm(1:fc%npwt)) = CONJG( state_fc_t(1:fc%npwt,ii,is) ) else psic(fc%nlt(1:fc%npwt))=state_fc_t(1:fc%npwt,ii,is)+(0.d0,1.d0)*state_fc_t(1:fc%npwt,ii+1,is) psic(fc%nltm(1:fc%npwt)) = CONJG( state_fc_t(1:fc%npwt,ii,is) )+(0.d0,1.d0)*CONJG( state_fc_t(1:fc%npwt,ii+1,is) ) endif CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) state_fc_r(1:fc%nrxxt,ii,is)= DBLE(psic(1:fc%nrxxt)) if(ii/=num_fc_eff(is)) state_fc_r(1:fc%nrxxt,ii+1,is)= DIMAG(psic(1:fc%nrxxt)) enddo enddo deallocate(state_fc_t) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory0.4', kilobytes, ' new kb = ', (SIZE( state_fc_t ))/64 call flush_unit(stdout) !set maximum number of valence states for both spin channels if(nspin==1) then num_nbndv_max=num_nbndv(1) else num_nbndv_max=max(num_nbndv(1),num_nbndv(2)) endif !now valence wavefunctions are put on the ordering of the reduced grid allocate(evc_t(fc%npwt,num_nbndv_max,nspin)) if(fc%dual_t==4.d0) then evc_t(1:fc%npwt,1:num_nbndv_max,1:nspin)=ks_wfcs(1:fc%npwt,1:num_nbndv_max,1:nspin) else call start_clock('fc_merge') do is=1,nspin call reorderwfp (num_nbndv(is),npw, fc%npwt,ks_wfcs(:,:,is),evc_t(:,:,is), & &npw,fc%npwt, ig_l2g,fc%ig_l2gt, fc%ngmt_g , mpime, nproc,ionode_id, intra_pool_comm ) ! do iv=1,num_nbndv(is) ! call mergewf(ks_wfcs(:,iv,is),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) ! call splitwf(evc_t(:,iv,is),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) ! enddo enddo call stop_clock('fc_merge') endif CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory0.5', kilobytes, ' new kb = ', (SIZE( evc_t ))/64 call flush_unit(stdout) !cycle on v !! product in real space with wannier !! orthonormalize and take N most important !! gram-schmidt like !calculate D matrix ! l_blk= (num_fc)/nproc ! if(l_blk*nproc < (num_fc)) l_blk = l_blk+1 ! nbegin=mpime*l_blk+1 ! nend=nbegin+l_blk-1 ! if(nend > num_fc) nend=num_fc ! nsize=nend-nbegin+1 !check for restart if(ionode) then inquire(file=trim(tmp_dir)//trim(prefix)//'.restart_fk0_status', exist = exst) if(.not. exst) then iv_start=1 else iunrestart0 = find_free_unit() open( unit= iunrestart0, file=trim(tmp_dir)//trim(prefix)//'.restart_fk0_status', status='old') read(iunrestart0,*) iv_start read(iunrestart0,*) fcw_number read(iunrestart0,*) fcw_numberx close(iunrestart0) if(iv_start<1 ) then iv_start=1 else iv_start=iv_start+1 endif endif endif call mp_bcast(iv_start,ionode_id,world_comm) if(iv_start/=1) then call mp_bcast(fcw_number,ionode_id,world_comm) call mp_bcast(fcw_numberx,ionode_id,world_comm) fcw_number_oldx=fcw_numberx fcw_numberx_tmp=fcw_numberx fcw_number_old=fcw_number allocate(fcw_state_r(fc%nrxxt,fcw_numberx)) allocate(fcw_state_old_r(fc%nrxxt,fcw_numberx)) !read them from file iunfsr = find_free_unit() CALL diropn( iunfsr, 'fsr', fc%nrxxt, exst ) do ii=1,fcw_number CALL davcio( fcw_state_r(1,ii), fc%nrxxt, iunfsr, ii, -1 ) fcw_state_old_r(1:fc%nrxxt,ii)=fcw_state_r(1:fc%nrxxt,ii) enddo close(iunfsr) endif allocate (wv_real(fc%nrxxt),state_real(fc%nrxxt),state_real2(fc%nrxxt),state_g(fc%nrxxt,num_fc_eff_max*nspin)) FIRST_LOOP: do iv=iv_start,num_nbndv_max call start_clock('fc_loop') write(stdout,*) 'FK state:', iv,fc%nrxxt,fc%npwt,num_fc CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory1', kilobytes call flush_unit(stdout) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory2', kilobytes, ' new kb = ', & (SIZE(wv_real)+SIZE(state_real)+SIZE(state_real2)+SIZE(state_g))/128 call flush_unit(stdout) num_fc_spin=0 do is=1,nspin if(iv<= num_nbndv(is)) then psic(:)=(0.d0,0.d0) psic(fc%nlt(igkt(1:fc%npwt))) = evc_t(1:fc%npwt,iv,is) psic(fc%nltm(igkt(1:fc%npwt))) = CONJG( evc_t(1:fc%npwt,iv,is) ) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory3', kilobytes call flush_unit(stdout) CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory4', kilobytes call flush_unit(stdout) wv_real(:)= DBLE(psic(:)) if(l_verbose) then if(fc%gstart_t==2) write(stdout,*) 'FAKE modulus valence', iv, evc_t(1,iv,is) endif !loop on fake conduction states call flush_unit(stdout) do ii=1,num_fc_eff(is) state_g(1:fc%nrxxt, ii+num_fc_spin)=state_fc_r(1:fc%nrxxt,ii,is)*wv_real(1:fc%nrxxt) enddo num_fc_spin=num_fc_spin+num_fc_eff(is) endif enddo!on spin CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory5', kilobytes call flush_unit(stdout) !if not first valence wannier project the products out of partial orthonormal basis if(l_verbose) write(stdout,*) 'Start Projection part' call flush_unit(stdout) if(iv/=1) then ! build overlap matrix if(iv==2 .or. (iv_start/=1.and. iv==iv_start)) then allocate(tmp_mat2(fcw_numberx_tmp,num_fc_eff_max*nspin)) else if(fcw_number>fcw_numberx_tmp) then deallocate(tmp_mat2) fcw_numberx_tmp=fcw_numberx_tmp+bufferx allocate(tmp_mat2(fcw_numberx_tmp,num_fc_eff_max*nspin)) if(l_verbose) write(stdout,*) 'Updated dimension of tmp_mat2', fcw_numberx_tmp endif endif call start_clock('fc_dgemm') call dgemm('T','N',fcw_number,num_fc_spin,fc%nrxxt,1.d0,fcw_state_r,fc%nrxxt,& &state_g,fc%nrxxt,0.d0,tmp_mat2,fcw_numberx_tmp) call stop_clock('fc_dgemm') do ii=1,num_fc_spin call start_clock('mpsum') call mp_sum(tmp_mat2(1:fcw_number,ii),world_comm) call stop_clock('mpsum') tmp_mat2(1:fcw_number,ii)=tmp_mat2(1:fcw_number,ii)/dble(fc%nr1t*fc%nr2t*fc%nr3t) enddo !call mp_sum(tmp_mat2,world_comm) call start_clock('fc_dgemm') call dgemm('N','N',fc%nrxxt, num_fc_spin,fcw_number,-1.d0,fcw_state_r,fc%nrxxt,tmp_mat2,& &fcw_numberx_tmp,1.d0,state_g,fc%nrxxt) call stop_clock('fc_dgemm') if(iv==num_nbndv_max) deallocate(tmp_mat2) endif CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory6', kilobytes if(l_verbose) write(stdout,*) 'End Projection part' call flush_unit(stdout) !calculate overlap matrix if(l_verbose) write(stdout,*) 'FK2'!ATTENZIONE call flush_unit(stdout) max_state=max(300,num_fc/20) if(max_state > num_fc) max_state=num_fc/2 l_blk= (num_fc_spin)/nproc if(l_blk*nproc < (num_fc_spin)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 if(nend > num_fc_spin) nend=num_fc nsize=nend-nbegin+1 CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory6.6', kilobytes call flush_unit(stdout) !uses iterative algorithm !allocate max number of new states !deallocate(wv_real,state_real,state_real2) !gram shimdt like allocate(ovec(num_fc_spin)) num_built=0 do ii=1,num_fc_spin if(num_built>0) then call start_clock('fc_dgemm') call dgemm('T','N',num_built,1,fc%nrxxt,1.d0,state_g,fc%nrxxt,state_g(1,ii),fc%nrxxt,0.d0,ovec,num_fc_spin) call stop_clock('fc_dgemm') call start_clock('mpsum') call mp_sum(ovec(1:num_built),world_comm) call stop_clock('mpsum') ovec(1:num_built)=ovec(1:num_built)/dble(fc%nr1t*fc%nr2t*fc%nr3t) call start_clock('fc_dgemm') call dgemm('T','N',1,1,fc%nrxxt,1.d0,state_g(1,ii),fc%nrxxt,state_g(1,ii),fc%nrxxt,0.d0,sca2,1) call stop_clock('fc_dgemm') call start_clock('mpsum') call mp_sum(sca2,world_comm) call stop_clock('mpsum') sca2=sca2/dble(fc%nr1t*fc%nr2t*fc%nr3t) sca1=0.d0 do jj=1,num_built sca1=sca1+ovec(jj)**2.d0 enddo if(abs(sca2-sca1) >= s_cutoff) then if(num_built+1 /= ii) state_g(1:fc%nrxxt,num_built+1)=state_g(1:fc%nrxxt,ii) call start_clock('fc_dgemm') call dgemm('N','N',fc%nrxxt,1,num_built,-1.d0,state_g,fc%nrxxt,& &ovec,num_fc_spin,1.d0,state_g(1,num_built+1),fc%nrxxt) call stop_clock('fc_dgemm') num_built=num_built+1 call start_clock('fc_dgemm') call dgemm('T','N',1,1,fc%nrxxt,1.d0,state_g(1,num_built),& &fc%nrxxt,state_g(1,num_built),fc%nrxxt,0.d0,ovec(num_built),1) call stop_clock('fc_dgemm') call start_clock('mpsum') call mp_sum(ovec(num_built),world_comm) call stop_clock('mpsum') ovec(num_built)=ovec(num_built)/dble(fc%nr1t*fc%nr2t*fc%nr3t) ovec(num_built)=1.d0/dsqrt(ovec(num_built)) state_g(1:fc%nrxxt,num_built)=state_g(1:fc%nrxxt,num_built)*ovec(num_built) endif else call start_clock('fc_dgemm') call dgemm('T','N',1,1,fc%nrxxt,1.d0,state_g(1,ii),& &fc%nrxxt,state_g(1,ii),fc%nrxxt,0.d0,ovec(1),1) call stop_clock('fc_dgemm') call start_clock('mpsum') call mp_sum(ovec(1),world_comm) call stop_clock('mpsum') ovec(1)=ovec(1)/dble(fc%nr1t*fc%nr2t*fc%nr3t) if(ovec(1) >= s_cutoff) then num_built=1 ovec(num_built)=1.d0/dsqrt(ovec(num_built)) state_g(1:fc%nrxxt,num_built)=state_g(1:fc%nrxxt,ii)*ovec(num_built) endif endif enddo deallocate(ovec) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory6.7', kilobytes write(stdout,*) 'FK GS', num_built call flush_unit(stdout) !opportune basis if( iv == 1 ) then fcw_number=num_built allocate( fcw_state_r( fc%nrxxt, fcw_numberx ) ) allocate( fcw_state_old_r( fc%nrxxt, fcw_number_oldx ) ) if(num_built>0) then fcw_state_r(1:fc%nrxxt,1:num_built) = state_g(1:fc%nrxxt,1:num_built) iunfsr = find_free_unit() CALL diropn( iunfsr, 'fsr', fc%nrxxt, exst ) do ii=1,num_built CALL davcio( fcw_state_r(1,ii), fc%nrxxt, iunfsr, ii, 1 ) enddo close(iunfsr) endif else if(fcw_number+num_built>fcw_number_oldx) then fcw_number_oldx=fcw_number_oldx+bufferx deallocate(fcw_state_old_r) allocate( fcw_state_old_r( fc%nrxxt, fcw_number_oldx ) ) endif fcw_state_old_r(1:fc%nrxxt,1:fcw_number) = fcw_state_r(1:fc%nrxxt,1:fcw_number) if(fcw_number+num_built>fcw_numberx) then fcw_numberx=fcw_numberx+bufferx deallocate(fcw_state_r) allocate(fcw_state_r(fc%nrxxt,fcw_numberx)) endif fcw_state_r(1:fc%nrxxt,1:fcw_number)=fcw_state_old_r(1:fc%nrxxt,1:fcw_number) if(num_built> 0) then fcw_state_r(1:fc%nrxxt,fcw_number+1:fcw_number+num_built)=state_g(1:fc%nrxxt,1:num_built) CALL diropn( iunfsr, 'fsr', fc%nrxxt, exst ) do ii=1,num_built CALL davcio( fcw_state_r(1,ii+fcw_number), fc%nrxxt, iunfsr, ii+fcw_number, 1 ) enddo close(iunfsr) endif fcw_number=fcw_number+num_built endif CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory6.8', kilobytes call flush_unit(stdout) iunrestart0 = find_free_unit() open( unit= iunrestart0, file=trim(tmp_dir)//trim(prefix)//'.restart_fk0_status', status='unknown') write(iunrestart0,*) iv write(iunrestart0,*) fcw_number write(iunrestart0,*) fcw_numberx close(iunrestart0) call stop_clock('fc_loop') end do FIRST_LOOP deallocate( wv_real, state_real, state_real2, state_g ) if(l_verbose) write(stdout,*) 'FK8' CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory7', kilobytes call flush_unit(stdout) if(num_nbndv(1)/=1 ) deallocate(fcw_state_old_r) ! calculate D matrix distributed among processors if(fcw_number < nproc) then write(stdout,*) 'too many processors' stop endif l_blk= (fcw_number)/nproc if(l_blk*nproc < (fcw_number)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 if(nend > fcw_number) nend=fcw_number nsize=nend-nbegin+1 allocate(fcw_mat(fcw_number,l_blk)) fcw_mat(:,:)=0.d0 if(l_verbose) write(stdout,*) 'FK9' call flush_unit(stdout) allocate(wv_real_all(fc%nrxxt,num_nbndv_max)) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory8', kilobytes allocate(state_real(fc%nrxxt),state_real_tmp(fc%nrxxt),state_real_tmp2(fc%nrxxt)) allocate(state_g(fc%nrxxt,num_nbndv_max)) allocate(tmp_mat(fcw_number,num_nbndv_max)) write(stdout,*) 'Calculate FK matrix' call flush_unit(stdout) do is=1,nspin do iv=1,num_nbndv(is) psic(:)=(0.d0,0.d0) psic(fc%nlt(igkt(1:fc%npwt))) = evc_t(1:fc%npwt,iv,is) psic(fc%nltm(igkt(1:fc%npwt))) = CONJG( evc_t(1:fc%npwt,iv,is) ) CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) wv_real_all(1:fc%nrxxt,iv)= DBLE(psic(1:fc%nrxxt)) !check for modulus sca1=0.d0 do ir=1,fc%nrxxt sca1=sca1+wv_real_all(ir,iv)**2.d0 enddo call start_clock('mpsum') call mp_sum(sca1,world_comm) call stop_clock('mpsum') if(l_verbose) write(stdout,*) 'Modulus:',fc%nrxxt,fc%nr1t*fc%nr2t*fc%nr3t, sca1/(dble(fc%nr1t*fc%nr2t*fc%nr3t)) enddo !loop on fake conduction states CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory9', kilobytes do ii=1,num_fc_eff(is) do iv=1,num_nbndv(is) state_g(1:fc%nrxxt,iv)=state_fc_r(1:fc%nrxxt,ii,is)*wv_real_all(1:fc%nrxxt,iv) enddo !do products with fcw states call start_clock('fc_dgemm') call dgemm('T','N',fcw_number,num_nbndv(is),fc%nrxxt,1.d0,fcw_state_r,fc%nrxxt,state_g,fc%nrxxt,0.d0,tmp_mat,fcw_number) call stop_clock('fc_dgemm') call start_clock('mpsum') call mp_sum(tmp_mat,world_comm) call stop_clock('mpsum') tmp_mat=tmp_mat/dble(fc%nr1t*fc%nr2t*fc%nr3t) if(l_frac) then if(ii<=num_fc) then do iv=1,num_nbndv(is) if(nspin==1) then sca1=dsqrt(abs(wg(iv,is))/2.d0) else sca1=dsqrt(abs(wg(iv,is))) endif tmp_mat(1:fcw_number,iv)=tmp_mat(1:fcw_number,iv)*sca1 enddo else do iv=1,num_nbndv(is) if(nspin==1) then sca1=dsqrt(abs(wg(ii-num_fc+num_nbndv_min(is),is)-wg(iv,is))/2.d0) else sca1=dsqrt(abs(wg(ii-num_fc+num_nbndv_min(is),is)-wg(iv,is))) endif tmp_mat(1:fcw_number,iv)=tmp_mat(1:fcw_number,iv)*sca1 enddo endif endif CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory10', kilobytes if(l_verbose) write(stdout,*) 'TOTAL NUMBER OF FCW STATES:', fcw_number,ii,dfftp%nnr,fc%nrxxt,wg(1,is) call flush_unit(stdout) !calculate contribution to D matrix if(nsize>0) then call start_clock('fc_dgemm') call dgemm('N','T',fcw_number,nend-nbegin+1,num_nbndv(is),1.d0,tmp_mat,fcw_number,& &tmp_mat(nbegin:nend,1:num_nbndv(is)),nend-nbegin+1,1.d0,fcw_mat,fcw_number) call stop_clock('fc_dgemm') endif enddo enddo!on spin !if required put fcw_state on normconserving ordering allocate(fcw_state_n(npw,fcw_number)) allocate(fcw_state(fc%npwt,fcw_number))!ATTENZIONE the use of memory could be reduced psic=0.d0 do ii=1,fcw_number,2 if(ii==fcw_number) then psic(1:fc%nrxxt)=cmplx(fcw_state_r(1:fc%nrxxt,ii),0.d0) else psic(1:fc%nrxxt)=cmplx(fcw_state_r(1:fc%nrxxt,ii),fcw_state_r(1:fc%nrxxt,ii+1)) endif CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, -2 ) if(ii==fcw_number) then fcw_state(1:fc%npwt, ii) = psic(fc%nlt(1:fc%npwt)) if(fc%gstart_t==2) fcw_state(1,ii)=(0.d0,0.d0) else fcw_state(1:fc%npwt, ii)= 0.5d0*(psic(fc%nlt(igkt(1:fc%npwt)))+conjg( psic(fc%nltm(igkt(1:fc%npwt))))) fcw_state(1:fc%npwt, ii+1)= (0.d0,-0.5d0)*(psic(fc%nlt(igkt(1:fc%npwt))) - conjg(psic(fc%nltm(igkt(1:fc%npwt))))) if(fc%gstart_t==2) fcw_state(1,ii)=(0.d0,0.d0) if(fc%gstart_t==2) fcw_state(1,ii+1)=(0.d0,0.d0) endif enddo if(fc%dual_t==4.d0) then fcw_state_n(1:fc%npwt,1:fcw_number)=fcw_state(1:fc%npwt,1:fcw_number) else call start_clock('fc_merge') call reorderwfp (fcw_number,fc%npwt, npw,fcw_state,fcw_state_n, & &fc%npwt,npw, fc%ig_l2gt,ig_l2g, fc%ngmt_g , mpime, nproc,ionode_id, intra_pool_comm ) ! call mergewf(fcw_state(:,1),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) ! call splitwf(fcw_state_n(:,ii),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) call stop_clock('fc_merge') endif CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory11', kilobytes !save on file iunfcw = find_free_unit() CALL diropn( iunfcw, 'fcw', npw*2, exst ) do ii=1,fcw_number CALL davcio( fcw_state_n(1,ii), 2*npw, iunfcw, ii, 1 ) enddo close(iunfcw) !write number of states if(ionode) then open(unit=iunfcw,file=trim(tmp_dir)//trim(prefix)//'.nfcws',status='unknown') write(iunfcw,*) fcw_number close(iunfcw) endif CALL diropn( iunfcw, 'fmat',fcw_number, exst ) do ii=1,nsize CALL davcio( fcw_mat(1,ii), fcw_number, iunfcw, ii, 1 ) enddo close(iunfcw) if(l_verbose) write(stdout,*) 'Call deallocate_fft_custom' call flush_unit(stdout) call deallocate_fft_custom(fc) iunrestart0 = find_free_unit() open( unit= iunrestart0, file=trim(tmp_dir)//trim(prefix)//'.restart_fk0_status', status='unknown') write(iunrestart0,*) -1 write(iunrestart0,*) fcw_number write(iunrestart0,*) fcw_numberx close(iunrestart0) deallocate(wv_real_all) deallocate(fcw_state_r) if( allocated( state_fc_t ) ) deallocate( state_fc_t ) deallocate(state_real,state_g,state_real_tmp,state_real_tmp2) deallocate(tmp_mat) if(allocated(e_fake)) deallocate(e_fake) deallocate(fcw_state_n) deallocate(evc_g,evc_t) if( allocated( state_fc ) ) deallocate( state_fc ) if( allocated( state_g ) ) deallocate( state_g ) if( allocated( fcw_state_old_r ) ) deallocate( fcw_state_old_r ) if( allocated( h_state_fc ) ) deallocate( h_state_fc ) if( allocated( evc_g ) ) deallocate( evc_g ) if( allocated( evc_t ) ) deallocate( evc_t ) if( allocated( state_fc_t ) ) deallocate( state_fc_t ) if( allocated( state_g_t ) ) deallocate( state_g_t ) if( allocated( fcw_state_n ) ) deallocate( fcw_state_n ) if( allocated( wv_real ) ) deallocate( wv_real ) if( allocated( state_real ) ) deallocate( state_real ) if( allocated( wv_real_all ) ) deallocate( wv_real_all ) if( allocated( state_real_tmp ) ) deallocate( state_real_tmp ) if( allocated( state_real_tmp2 ) ) deallocate( state_real_tmp2 ) if( allocated( state_real2 ) ) deallocate( state_real2 ) if( allocated( omat ) ) deallocate( omat ) if( allocated( eigen ) ) deallocate( eigen ) if( allocated( work ) ) deallocate( work ) if( allocated( tmp_mat ) ) deallocate( tmp_mat ) if( allocated( omat2 ) ) deallocate( omat2 ) if( allocated( hmat ) ) deallocate( hmat ) if( allocated( e_fake ) ) deallocate( e_fake ) if( allocated( vec_fake ) ) deallocate( vec_fake ) if( allocated( gap ) ) deallocate( gap ) if( allocated( hmat_i ) ) deallocate( hmat_i ) if( allocated( hmat_o ) ) deallocate( hmat_o ) if( allocated( omat_i ) ) deallocate( omat_i ) if( allocated( ovec ) ) deallocate( ovec ) if( allocated( g2kint ) ) deallocate( g2kint ) ! if( allocated( iwork ) ) deallocate( iwork ) if( allocated( ifail ) ) deallocate( ifail ) if( allocated( isuppz ) ) deallocate( isuppz ) if( allocated( iclustr ) ) deallocate( iclustr ) if( allocated( igkt ) ) deallocate( igkt ) CALL memstat( kilobytes ) if(l_verbose) write(stdout,*) 'memory12', kilobytes if(l_verbose) write(stdout,*) 'memory fcw_state = ', SIZE( fcw_state ) / 64 , ' kb' if(l_verbose) write(stdout,*) 'memory fcw_mat = ', SIZE( fcw_mat ) / 64 , ' kb' call flush_unit(stdout) return !NOT_TO_BE_INCLUDED_END end subroutine fake_conduction_real END MODULE fake_cond_mod GWW/pw4gww/semicore_read.f900000644000077300007730000002036012341332532016371 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !this routine calculate the terms \int dr \psi_i(r)\_psi_v(sc)(r) (v\Phi_\mu)(r) !where \psi_i(r)\_psi_v(sc)(r) are read from the disk subroutine semicore_read(num_nbnds,numpw, ispin) !NOT_TO_BE_INCLUDED_START USE io_global, ONLY : stdout, ionode,ionode_id USE io_files, ONLY : diropn,prefix, tmp_dir, iunigk use pwcom USE wavefunctions_module, ONLY : evc USE kinds, ONLY : DP USE gvect, ONLY : ig_l2g USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_global, ONLY : inter_pool_comm, intra_pool_comm USE mp_wave, ONLY : mergewf,splitwf USE mp_world, ONLY : mpime, nproc, world_comm USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft USE wavefunctions_module, ONLY : psic USE wvfct, ONLY : et USE lsda_mod, ONLY : nspin USE wannier_gw, ONLY : max_ngm, l_truncated_coulomb,vg_q,truncation_radius USE constants, ONLY : pi, tpi, fpi USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2 implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER, INTENT(in) :: num_nbnds!total KS states considered INTEGER, INTENT(in) :: numpw!dimension of polarizability basis INTEGER, INTENT(in) :: ispin!spin channel INTEGER :: num_nbnds_sc,n_semicore,npwx_g_sc INTEGER :: iv, iun, ii,jj,iunw,ii_max INTEGER :: ig REAL(kind=DP), ALLOCATABLE :: et_sc(:) COMPLEX(kind=DP), ALLOCATABLE :: tmp_g(:),tmp_wfc(:) REAL(kind=DP), ALLOCATABLE :: pp_sc(:,:,:),tmp_r(:),prods(:) INTEGER :: iungprod,iw LOGICAL :: exst REAL(kind=DP), ALLOCATABLE :: fac(:) REAL(kind=DP) :: qq COMPLEX(kind=DP), ALLOCATABLE :: psi_all(:,:)!for all-electron (with semicore) wfcs REAL(kind=DP), ALLOCATABLE :: o_mat(:,:) REAL(kind=DP) :: sca INTEGER, ALLOCATABLE :: order(:) allocate(tmp_wfc(npwx)) allocate(order(num_nbnds)) allocate(fac(max_ngm)) allocate(psi_all(npwx,num_nbnds)) allocate(o_mat(num_nbnds,num_nbnds)) if(l_truncated_coulomb) then do ig=1,max_ngm qq = g(1,ig)**2.d0 + g(2,ig)**2.d0 + g(3,ig)**2.d0 if (qq > 1.d-8) then fac(ig)=(e2*fpi/(tpiba2*qq))*(1.d0-dcos(dsqrt(qq)*truncation_radius*tpiba)) else fac(ig)=e2*fpi*(truncation_radius**2.d0/2.d0) endif enddo fac(:)=fac(:)/omega else fac(:)=0.d0 fac(1:npw)=vg_q(1:npw) endif !open files and allocate if(ionode) then iun = find_free_unit() if(ispin==1) then open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.sc_states', status='old',form='unformatted') else open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.sc_states2', status='old',form='unformatted') endif read(iun) num_nbnds_sc read(iun) n_semicore read(iun) npwx_g_sc endif call mp_bcast( num_nbnds_sc, ionode_id,world_comm) call mp_bcast(n_semicore, ionode_id,world_comm) call mp_bcast(npwx_g_sc,ionode_id,world_comm) allocate(pp_sc(dfftp%nnr,n_semicore,num_nbnds)) allocate(tmp_g(npwx_g_sc)) allocate(et_sc(num_nbnds_sc)) if(ionode) read(iun) et_sc(1:num_nbnds_sc) call mp_bcast(et_sc, ionode_id,world_comm) write(stdout,*) 'NUM. SEMICORE:', n_semicore write(stdout,*) 'NUM. BANDS SC:',num_nbnds_sc write(stdout,*) 'NUM. BANDS:',num_nbnds write(stdout,*) 'NPWX_G_SC:',npwx_g_sc write(stdout,*) 'ET_SC:',et_sc(1:num_nbnds_sc) !write header on file for each spin channel iunw = find_free_unit() if(ispin==1) then open( unit= iunw, file=trim(tmp_dir)//trim(prefix)//'.sc_gvphi', status='unknown',form='unformatted') else open( unit= iunw, file=trim(tmp_dir)//trim(prefix)//'.sc_gvphi2', status='unknown',form='unformatted') endif write(iunw) n_semicore write(iunw) et_sc(1:n_semicore) write(iunw) num_nbnds write(iunw) numpw !read in all semicore products and split to charge grid do ii=1,num_nbnds_sc-n_semicore!as they are written do iv=1,n_semicore write(stdout,*) 'Reading state:', ii,iv call flush_unit(stdout) if(ionode) read(iun) tmp_g(1:npwx_g_sc) call splitwf(tmp_wfc,tmp_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) !check for consistency if(gstart==2) write(stdout,*) 'It should be zero:', tmp_wfc(1) !trasform them to R grid psic(:)=(0.d0,0.d0) psic(nls(igk(1:npw))) = tmp_wfc(1:npw) psic(nlsm(igk(1:npw))) = CONJG( tmp_wfc(1:npw) ) CALL invfft ('Wave', psic, dffts) if(ii (num_nbnds_sc-n_semicore)) then pp_sc(1:dfftp%nnr,1:n_semicore,num_nbnds_sc-n_semicore+1:num_nbnds)=0.d0 endif if(num_nbnds > (num_nbnds_sc-n_semicore)) then psi_all(1:npwx,num_nbnds_sc-n_semicore+1:num_nbnds)=(0.d0,0.d0) endif deallocate(tmp_g) close(iun) !check all-electrons states call dgemm('T','N',num_nbnds,num_nbnds,2*npw,2.d0,psi_all,2*npwx,psi_all,2*npwx,0.d0,o_mat,num_nbnds) if(gstart==2) then do ii=1,num_nbnds do jj=1,num_nbnds o_mat(ii,jj)=o_mat(ii,jj)-psi_all(1,ii)*psi_all(1,jj) enddo enddo endif call mp_sum(o_mat,world_comm) do ii=1,num_nbnds write(stdout,*) 'Orthonormality:',ii,o_mat(1:num_nbnds,ii) enddo !do products of all electron with pseudo states and determines the correspondance call dgemm('T','N',num_nbnds,num_nbnds,2*npw,2.d0,psi_all,2*npwx,evc,2*npwx,0.d0,o_mat,num_nbnds) if(gstart==2) then do ii=1,num_nbnds do jj=1,num_nbnds o_mat(ii,jj)=o_mat(ii,jj)-psi_all(1,ii)*evc(1,jj) enddo enddo endif call mp_sum(o_mat,world_comm) do ii=1,num_nbnds sca=0.d0 ii_max=0 do jj=1,num_nbnds if(abs(o_mat(jj,ii))>sca) then ii_max=jj sca=abs(o_mat(jj,ii)) endif enddo write(stdout,*) 'KS state:',ii,'corresponds to AE state:',ii_max,sca order(ii)=ii_max enddo do ii=1,num_nbnds sca=0.d0 ii_max=0 do jj=1,num_nbnds if(abs(o_mat(ii,jj))>sca) then ii_max=jj sca=abs(o_mat(ii,jj)) endif enddo write(stdout,*) 'AE state',ii,'corresponds to pseudo state:',ii_max,sca enddo !open polarizability basis allocate(tmp_g(max_ngm),tmp_r(dfftp%nnr),prods(n_semicore)) iungprod = find_free_unit() CALL diropn( iungprod, 'wiwjwfc_red', max_ngm*2, exst ) !loop on pol basis vectors do iw=1,numpw call davcio(tmp_g,max_ngm*2,iungprod,iw,-1) !trasform to r-space psic(:)=(0.d0,0.d0) do ig=1,max_ngm psic(nl(ig))=tmp_g(ig)*fac(ig) psic(nlm(ig))=CONJG(tmp_g(ig))*fac(ig) enddo CALL invfft ('Dense', psic, dfftp) tmp_r(1:dfftp%nnr)=dble(psic(1:dfftp%nnr)) do ii=1,num_nbnds !!do products call dgemv ('T',dfftp%nnr,n_semicore,1.d0,pp_sc(1,1,order(ii)),dfftp%nnr,tmp_r,1,0.d0,prods, 1) call mp_sum(prods(1:n_semicore),world_comm) prods(1:n_semicore)=prods(1:n_semicore)/dble(dfftp%nr1*dfftp%nr2*dfftp%nr3) !! write on disk write(iunw) prods(1:n_semicore) enddo enddo close(iungprod) deallocate(tmp_g,tmp_r,prods) close(iunw) deallocate(pp_sc) deallocate(tmp_wfc) deallocate(psi_all) deallocate(o_mat) deallocate(order) return !NOT_TO_BE_INCLUDED_END end subroutine semicore_read GWW/pw4gww/optimal.f900000644000077300007730000000676112341332532015246 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !this subroutine contains the routines dedicated to obtaining optimal basis sets SUBROUTINE optimal_driver(num_in,wfcs,lda,options,num_out, info) !this routine is a driver for performing the calculation of the optimal basis set !using the appropriate method USE kinds, ONLY : DP USE wannier_gw, ONLY : optimal_options USE io_global, ONLY : stdout implicit none INTEGER, INTENT(in) :: num_in!number of initial vectors COMPLEX(kind=DP), INTENT(inout) :: wfcs(lda,num_in)!in input non-orthonormal in output optimal basis INTEGER, INTENT(in) :: lda!leading dimension of wfcs, essetally npw or npwx TYPE(optimal_options), INTENT(in) :: options!options to be used INTEGER, INTENT(out) :: num_out!final number of orthonormal basis functions INTEGER, INTENT(out) :: info!final outcome status 0== OK REAL(kind=DP) :: tr !select routine select case (options%idiago) case(0) !Gram_Schmidt like if(options%l_complete) then tr=0.d0 else tr=options%thres endif call optimal_gram_schmidt(num_in,wfcs,lda,options%ithres,tr,num_out) case default write(stdout,*) 'optimal driver: NOT IMPLEMENTED YET' call flush_unit(stdout) stop end select info=0 return END SUBROUTINE optimal_driver SUBROUTINE optimal_gram_schmidt(num_in,wfcs,lda,ithres,thres,num_out) !this subroutine performs a gram_schmidt orthonormalization and retains !vectors which are above the give threshold USE kinds, ONLY : DP USE mp_world, ONLY : world_comm, mpime, nproc USE mp, ONLY : mp_sum,mp_bcast USE io_global, ONLY : stdout, ionode,ionode_id USE wvfct, ONLY : g2kin, wg, nbndx, et, nbnd, npwx, igk, & npw, current_k USE gvect, ONLY : gstart implicit none INTEGER, INTENT(in) :: num_in!number of initial vectors COMPLEX(kind=DP), INTENT(inout) :: wfcs(lda,num_in)!in input non-orthonormal in output optimal basis INTEGER, INTENT(in) :: lda!leading dimension of wfcs, essetally npw or npwx INTEGER, INTENT(in) :: ithres!kind of threshold REAL(kind=DP), INTENT(in) :: thres!thrshold for the optimal basis INTEGER, INTENT(out) :: num_out!final number of orthonormal basis functions INTEGER :: i,j REAL(kind=DP), ALLOCATABLE :: prod(:) REAL(kind=DP) :: sca REAL(kind=DP), EXTERNAL :: ddot allocate(prod(num_in)) num_out=0 do i=1,num_in if(num_out >0) then call dgemv('T',2*npw,num_out,2.d0, wfcs,2*lda,wfcs(:,i),1,0.d0,prod,1) if(gstart==2) then prod(1:num_out)=prod(1:num_out) - dble(wfcs(1,1:num_out)*conjg(wfcs(1,i))) endif call mp_sum(prod(1:num_out),world_comm) call dgemm('N','N',2*npw,1,num_out,-1.d0,wfcs,2*lda,prod,num_in,1.d0,wfcs(:,i),2*lda) endif sca = 2.d0*ddot(2*npw,wfcs(:,i),1,wfcs(:,i),1) if(gstart==2) then sca=sca-dble((wfcs(1,i)*conjg(wfcs(1,i)))) endif call mp_sum(sca,world_comm) if(sca >= thres) then num_out=num_out+1 sca=dsqrt(sca) call dcopy(2*npw,wfcs(:,i),1,wfcs(:,num_out),1) wfcs(1:npw,num_out)=wfcs(1:npw,num_out)/sca endif enddo deallocate(prod) return END SUBROUTINE optimal_gram_schmidt GWW/pw4gww/pw4gww.f900000644000077300007730000006266312341332532015043 0ustar giannozzgiannozz! ! Copyright (C) 2001-2014 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! ! ! Original version by Andrea Ferretti ! Modified mainly by Layla Martin-Samos ! Modified by Joe Stenuit ! !=----------------------------------------------------------------------------=! MODULE io_base_export !=----------------------------------------------------------------------------=! USE kinds IMPLICIT NONE SAVE INTEGER, PARAMETER :: file_version = 202 INTEGER :: restart_module_verbosity = 0 END MODULE !----------------------------------------------------------------------- program gwl_punch !----------------------------------------------------------------------- ! ! read in PWSCF data in XML format using IOTK lib ! then prepare matrices for GWL calculation ! ! input: namelist "&inputpp", with variables ! prefix prefix of input files saved by program pwscf ! outdir temporary directory where files resides ! pp_file output file. If it is omitted, a directory ! "prefix.export/" is created in outdir and ! some output files are put there. Anyway all the data ! are accessible through the "prefix.export/index.xml" file which ! contains implicit pointers to all the other files in the ! export directory. If reading is done by the IOTK library ! all data appear to be in index.xml even if physically it ! is not. ! uspp_spsi using US PP if set .TRUE. writes S | psi > ! and | psi > separately in the output file ! single_file one-file output is produced ! ascii .... ! ! pseudo_dir pseudopotential directory ! psfile(:) name of the pp file for each species ! USE kinds, ONLY : i4b USE gvect, ONLY : mill use pwcom USE constants, ONLY : rytoev use io_global, ONLY : stdout, ionode, ionode_id use io_files, ONLY : psfile, pseudo_dir use io_files, ONLY : prefix, tmp_dir, outdir use ions_base, ONLY : ntype => nsp use iotk_module use mp_pools, ONLY : kunit use mp, ONLY: mp_bcast use mp_world, ONLY: world_comm, mpime use control_flags, ONLY : gamma_only use uspp, ONLY : okvan use ldaU, ONLY : lda_plus_u USE basis, ONLY : swfcatom use scf, only : vrs, vltot, v, kedtau USE klist, ONLY : xk, wk, nks, nkstot USE fft_base, ONLY : dfftp USE wannier_gw, ONLY : lwannier, & num_nbndv, & num_nbnds, & nset, & l_truncated_coulomb, & truncation_radius, & remainder, & restart_gww, & numw_prod, & l_gram,& l_head,& n_gauss,& omega_gauss, & l_exchange, & l_zero, & l_wing, & grid_type, & nset_overlap, & nspace,& ecutoff_global, & maxiter2,& diago_thr2, & l_plot_mlwf,& l_pmatrix,& npcol,& nprow,& n_pola_lanczos,& n_self_lanczos,& nsteps_lanczos_pola,& nsteps_lanczos_self,& s_pola_lanczos,& s_self_lanczos,& s_g_lanczos,& l_pmat_diago,& pmat_ethr, & pmat_cutoff,& pmat_type,& lanczos_restart,& n_pola_lanczos_eff,& n_self_lanczos_eff,& n_pmat,& s_pmat,& n_fast_pmat,& off_fast_pmat,& l_fast_pola,& l_v_basis,& v_cutoff,& l_iter_algorithm,& dual_pb, & l_t_wannier,& dual_vt,& dual_vs,& wannier_thres,& s_first_state,& s_last_state,& l_selfconsistent,& l_whole_s,& l_ts_eigen,& l_frac_occ,& num_nbndv_min,& l_cond_pol_base,& l_semicore,& n_semicore,& l_semicore_read,& l_verbose,& l_contour,& l_real,& l_bse,& s_bse,& dual_bse,& l_big_system,& extra_pw_cutoff,& l_list,& l_scissor,& scissor,& l_full,& n_full USE exchange_custom, ONLY : exchange_fast_dual ! implicit none integer :: i, kunittmp, ios character(len=200) :: pp_file character(len=iotk_attlenx) :: attr logical :: found, uspp_spsi, ascii, single_file, raw ! INTEGER(i4b), EXTERNAL :: C_MKDIR CHARACTER(LEN=256), EXTERNAL :: trimcheck NAMELIST /inputpw4gww/ prefix, outdir, pp_file, uspp_spsi, ascii, single_file, raw, & psfile, pseudo_dir, & lwannier, num_nbndv, & nset,num_nbnds, & l_truncated_coulomb, & truncation_radius, & remainder, restart_gww, numw_prod, & l_gram, l_head, n_gauss, omega_gauss, l_exchange, & l_zero, l_wing, grid_type, & nset_overlap, nspace, & ecutoff_global,& maxiter2,diago_thr2,l_plot_mlwf,& l_pmatrix, npcol,nprow,& n_pola_lanczos, nsteps_lanczos_pola,nsteps_lanczos_self,& s_pola_lanczos,s_self_lanczos,n_self_lanczos,s_g_lanczos,& l_pmat_diago,pmat_ethr,pmat_cutoff, pmat_type, lanczos_restart,& n_pola_lanczos_eff,n_self_lanczos_eff,n_pmat,s_pmat,n_fast_pmat,& off_fast_pmat,l_fast_pola,l_v_basis,v_cutoff,l_iter_algorithm,& dual_pb, l_t_wannier, dual_vt, dual_vs,wannier_thres,s_first_state,& s_last_state,l_selfconsistent,l_whole_s,l_ts_eigen,l_frac_occ,num_nbndv_min,& l_cond_pol_base,l_semicore,n_semicore,l_semicore_read, l_verbose, l_contour,& l_real,exchange_fast_dual,l_bse,s_bse,dual_bse,l_big_system,extra_pw_cutoff,& l_list,l_scissor,scissor,l_full,n_full ! call start_pw4gww( ) ! ! set default values for variables in namelist ! prefix='export' CALL get_env( 'ESPRESSO_TMPDIR', outdir ) IF ( TRIM( outdir ) == ' ' ) outdir = './' pp_file= ' ' uspp_spsi = .FALSE. ascii = .FALSE. single_file = .FALSE. raw = .FALSE. ! ! nppstr = 1 ! lwannier = .false. wannier_thres=0.d0 num_nbndv(1:2) = 1 num_nbnds = 1 nset = 250 l_truncated_coulomb = .false. truncation_radius = 10.d0 remainder=-1 restart_gww=-1 numw_prod=1 l_gram=.false. l_head=.false. l_exchange=.false. n_gauss=79 omega_gauss=20.d0 l_zero=.true. l_wing=.false. grid_type=3 nset_overlap=250 nspace=1 ecutoff_global = 400.d0 maxiter2=0 diago_thr2=0.d0 l_plot_mlwf=.false. l_pmatrix=.false. npcol=1 nprow=1 n_pola_lanczos=400 n_self_lanczos=600 nsteps_lanczos_pola=20 nsteps_lanczos_self=40 s_pola_lanczos=0.5d0 s_self_lanczos=1d-12 s_g_lanczos=0.d0 l_pmat_diago=.true. pmat_ethr=1d-5 pmat_cutoff=3.d0 pmat_type=4 lanczos_restart=0 n_pola_lanczos_eff=0 n_self_lanczos_eff=0 n_pmat=100 s_pmat=0.01d0 n_fast_pmat=0 off_fast_pmat=0.d0 l_fast_pola=.false. l_v_basis=.false. v_cutoff=0.01d0 l_iter_algorithm=.true. dual_pb=1.d0 dual_vt=1.d0 dual_vs=1.d0 l_t_wannier=.true. s_first_state=0 s_last_state=0 l_selfconsistent=.false. l_whole_s=.false. l_ts_eigen=.true. l_frac_occ=.false. num_nbndv_min(1:2)=1 l_cond_pol_base=.false. l_semicore=.false. n_semicore=1 l_semicore_read=.false. l_verbose=.false. l_contour=.false. l_real=.false. exchange_fast_dual=4.d0 l_bse=.false. s_bse=0.d0 dual_bse=1.d0 l_big_system=.false. l_list=.false. extra_pw_cutoff=0.d0 l_scissor=.false. scissor=0.d0 l_full=.false. n_full=0 ! ! Reading input file ! IF ( ionode ) THEN ! CALL input_from_file ( ) ! READ(5,inputpw4gww,IOSTAT=ios) ! ! call read_namelists( 'PW4GWW' ) ! IF (ios /= 0) CALL errore ('pw4gww', 'reading inputpw4gww namelist', ABS(ios) ) ! !----------------------------------------------------------------------- ! IF( pp_file == ' ' ) THEN ! ! pp_file = TRIM(prefix)//".export/index.xml" ! ! if(ionode) ios = C_MKDIR( TRIM(outdir)//"/"//TRIM(prefix)// & ! ".export" , LEN(TRIM(outdir)//"/"//TRIM(prefix)//".export") ) ! ENDIF ! ENDIF #ifndef __MPI dual_pb=4.d0 dual_vs=4.d0 dual_vt=4.d0 #endif !------------------------------------------------------------------------- ! ... Broadcasting variables !------------------------------------------------------------------------ tmp_dir = trimcheck( outdir ) CALL mp_bcast( outdir, ionode_id, world_comm ) CALL mp_bcast( tmp_dir, ionode_id, world_comm ) CALL mp_bcast( prefix, ionode_id, world_comm ) CALL mp_bcast( pp_file, ionode_id, world_comm ) CALL mp_bcast( uspp_spsi, ionode_id, world_comm ) CALL mp_bcast( ascii, ionode_id, world_comm ) CALL mp_bcast( single_file, ionode_id, world_comm ) CALL mp_bcast( raw, ionode_id, world_comm ) CALL mp_bcast( pseudo_dir, ionode_id, world_comm ) CALL mp_bcast( psfile, ionode_id, world_comm ) CALL mp_bcast( lwannier, ionode_id, world_comm ) CALL mp_bcast( wannier_thres, ionode_id, world_comm) CALL mp_bcast( num_nbndv, ionode_id, world_comm ) CALL mp_bcast( num_nbnds, ionode_id, world_comm ) CALL mp_bcast( nset, ionode_id, world_comm ) CALL mp_bcast(l_truncated_coulomb, ionode_id, world_comm) CALL mp_bcast(truncation_radius, ionode_id, world_comm) CALL mp_bcast(remainder, ionode_id, world_comm) CALL mp_bcast(restart_gww, ionode_id, world_comm) call mp_bcast(numw_prod, ionode_id, world_comm) CALL mp_bcast(l_gram, ionode_id, world_comm) CALL mp_bcast(l_head, ionode_id, world_comm) CALL mp_bcast(n_gauss, ionode_id, world_comm) CALL mp_bcast(omega_gauss, ionode_id, world_comm) CALL mp_bcast(l_exchange, ionode_id, world_comm) CALL mp_bcast(l_zero, ionode_id, world_comm) CALL mp_bcast(l_wing, ionode_id, world_comm) CALL mp_bcast(grid_type, ionode_id, world_comm) CALL mp_bcast(nset_overlap, ionode_id, world_comm) CALL mp_bcast(nspace, ionode_id, world_comm) CALL mp_bcast(ecutoff_global, ionode_id, world_comm) CALL mp_bcast(maxiter2, ionode_id, world_comm) CALL mp_bcast(diago_thr2, ionode_id, world_comm) CALL mp_bcast(l_plot_mlwf, ionode_id, world_comm) CALL mp_bcast(l_pmatrix, ionode_id, world_comm) CALL mp_bcast(npcol, ionode_id, world_comm) CALL mp_bcast(nprow, ionode_id, world_comm) CALL mp_bcast(n_pola_lanczos, ionode_id, world_comm) CALL mp_bcast(n_self_lanczos, ionode_id, world_comm) CALL mp_bcast(nsteps_lanczos_pola, ionode_id, world_comm) CALL mp_bcast(nsteps_lanczos_self, ionode_id, world_comm) CALL mp_bcast(s_pola_lanczos, ionode_id, world_comm) CALL mp_bcast(s_self_lanczos, ionode_id, world_comm) CALL mp_bcast(s_g_lanczos, ionode_id, world_comm) CALL mp_bcast(l_pmat_diago, ionode_id, world_comm) CALL mp_bcast(pmat_ethr, ionode_id, world_comm) CALL mp_bcast(pmat_cutoff, ionode_id, world_comm) CALL mp_bcast(pmat_type, ionode_id, world_comm) CALL mp_bcast(lanczos_restart, ionode_id, world_comm) CALL mp_bcast(n_pola_lanczos_eff, ionode_id, world_comm) CALL mp_bcast(n_self_lanczos_eff, ionode_id, world_comm) CALL mp_bcast(n_pmat, ionode_id, world_comm) CALL mp_bcast(s_pmat, ionode_id, world_comm) CALL mp_bcast(n_fast_pmat, ionode_id, world_comm) CALL mp_bcast(off_fast_pmat, ionode_id, world_comm) CALL mp_bcast(l_fast_pola, ionode_id, world_comm) CALL mp_bcast(l_v_basis, ionode_id, world_comm) CALL mp_bcast(v_cutoff, ionode_id, world_comm) CALL mp_bcast(l_iter_algorithm, ionode_id, world_comm) CALL mp_bcast(dual_pb, ionode_id, world_comm) CALL mp_bcast(dual_vt, ionode_id, world_comm) CALL mp_bcast(dual_vs, ionode_id, world_comm) CALL mp_bcast(l_t_wannier, ionode_id, world_comm) CALL mp_bcast(s_first_state, ionode_id, world_comm) CALL mp_bcast(s_last_state, ionode_id, world_comm) CALL mp_bcast(l_selfconsistent, ionode_id, world_comm) CALL mp_bcast(l_whole_s, ionode_id, world_comm) CALL mp_bcast(l_ts_eigen, ionode_id, world_comm) CALL mp_bcast(l_frac_occ, ionode_id, world_comm) CALL mp_bcast(num_nbndv_min, ionode_id, world_comm) CALL mp_bcast(l_cond_pol_base, ionode_id, world_comm) CALL mp_bcast(l_semicore, ionode_id, world_comm) CALL mp_bcast(n_semicore, ionode_id, world_comm) CALL mp_bcast(l_semicore_read, ionode_id, world_comm) CALL mp_bcast(l_verbose, ionode_id, world_comm) CALL mp_bcast(l_contour, ionode_id, world_comm) CALL mp_bcast(l_real, ionode_id, world_comm) CALL mp_bcast(exchange_fast_dual, ionode_id, world_comm) CALL mp_bcast(l_bse, ionode_id, world_comm) CALL mp_bcast(s_bse, ionode_id, world_comm) CALL mp_bcast(dual_bse, ionode_id, world_comm) CALL mp_bcast(l_big_system, ionode_id, world_comm) CALL mp_bcast(extra_pw_cutoff, ionode_id, world_comm) CALL mp_bcast(l_list, ionode_id, world_comm) CALL mp_bcast(l_scissor, ionode_id, world_comm) CALL mp_bcast(scissor, ionode_id, world_comm) CALL mp_bcast(l_full, ionode_id, world_comm) CALL mp_bcast(n_full, ionode_id, world_comm) call read_file #if defined __PARA kunittmp = kunit #else kunittmp = 1 #endif ! call openfil_pw4gww ! read wave functions (direct access) call read_export(pp_file,kunittmp,uspp_spsi, ascii, single_file, raw) ! ! after read_file everything is known ! realy? call summary() ! ! init some quantities igk,.... ! CALL hinit0() ! if(lda_plus_u) then CALL init_ns() endif CALL set_vrs(vrs, vltot, v%of_r, kedtau, v%kin_r, dfftp%nnr, nspin, doublegrid ) !------------------------------------------------- ! allocating wannier stuff (from init_run.f90) !----------------------------------------------------- CALL allocate_wannier() ! This is something from hinit0.f90, qpointlist ???? ! ! ! ----------------------------------------------------- ! now calculating the first wannier stuff (first in non_scf.f90) ! ----------------------------------------------------- if(l_verbose) write(stdout,*) 'To check, we print the KS eigenvalues:' CALL flush_unit( stdout ) ! CALL print_ks_energies() ! ! IF(l_head .and. .not.gamma_only) THEN ! write(stdout,*) 'BEFORE calculate_head' ! CALL flush_unit( stdout ) ! CALL calculate_head ! write(stdout,*) 'AFTER calculate_head' ! CALL flush_unit( stdout ) ! ENDIF ! IF(l_exchange) THEN IF(gamma_only) THEN call dft_exchange(num_nbndv(1),num_nbnds,nset) ELSE !!! add this, since wk are used in dft_exchange_k ! CALL weights ( ) ! if(l_verbose) write(stdout,*) 'BEFORE dft_exchange_k' CALL flush_unit( stdout ) !call dft_exchange_k(num_nbndv,num_nbnds,ecutoff_global) if(l_verbose) write(stdout,*) 'AFTER dft_exchange_k' CALL flush_unit( stdout ) ENDIF ENDIF if(l_verbose) write(stdout,*) 'BEFORE produce_wannier_gamma' CALL flush_unit( stdout ) CALL produce_wannier_gamma if(l_verbose) write(stdout,*) 'AFTER produce_wannier_gamma' CALL flush_unit( stdout ) ! ENDIF ! ! !deallocate wannier stuff (clean_pw.f90) ! CALL deallocate_wannier() call stop_pp stop end program gwl_punch ! !----------------------------------------------------------------------- subroutine read_export (pp_file,kunit,uspp_spsi, ascii, single_file, raw) !----------------------------------------------------------------------- ! use iotk_module use kinds, ONLY : DP use pwcom use control_flags, ONLY : gamma_only use becmod, ONLY : bec_type, becp, calbec, & allocate_bec_type, deallocate_bec_type ! use symme, ONLY : nsym, s, invsym, sname, irt, ftau ! use symme, ONLY : nsym, s, invsym, irt, ftau ! use char, ONLY : sname ! occhio sname is in symme which is now outside pwcom use uspp, ONLY : nkb, vkb use wavefunctions_module, ONLY : evc use io_files, ONLY : nd_nmbr, outdir, prefix, iunwfc, nwordwfc, iunsat, nwordatwfc use io_files, ONLY : pseudo_dir, psfile use io_global, ONLY : ionode, stdout USE ions_base, ONLY : atm, nat, ityp, tau, nsp use mp_pools, ONLY : nproc_pool, my_pool_id, intra_pool_comm, & inter_pool_comm use mp, ONLY : mp_sum, mp_max use mp_world, ONLY : world_comm, nproc, mpime use ldaU, ONLY : lda_plus_u USE basis, ONLY : swfcatom implicit none CHARACTER(5), PARAMETER :: fmt_name="QEXPT" CHARACTER(5), PARAMETER :: fmt_version="1.1.0" integer, intent(in) :: kunit character(80), intent(in) :: pp_file logical, intent(in) :: uspp_spsi, ascii, single_file, raw integer :: i, j, k, ig, ik, ibnd, na, ngg,ig_, ierr integer, allocatable :: kisort(:) real(DP) :: xyz(3), tmp(3) integer :: npool, nkbl, nkl, nkr, npwx_g integer :: ike, iks, npw_g, ispin, local_pw integer, allocatable :: ngk_g( : ) integer, allocatable :: itmp_g( :, : ) real(DP),allocatable :: rtmp_g( :, : ) real(DP),allocatable :: rtmp_gg( : ) integer, allocatable :: itmp1( : ) integer, allocatable :: igwk( :, : ) integer, allocatable :: l2g_new( : ) integer, allocatable :: igk_l2g( :, : ) real(DP) :: wfc_scal logical :: twf0, twfm character(iotk_attlenx) :: attr complex(DP), allocatable :: sevc (:,:) write(stdout,*) "nkstot=", nkstot IF( nkstot > 0 ) THEN IF( ( kunit < 1 ) .OR. ( MOD( nkstot, kunit ) /= 0 ) ) & CALL errore( ' write_export ',' wrong kunit ', 1 ) IF( ( nproc_pool > nproc ) .OR. ( MOD( nproc, nproc_pool ) /= 0 ) ) & CALL errore( ' write_export ',' nproc_pool ', 1 ) ! find out the number of pools npool = nproc / nproc_pool ! find out number of k points blocks nkbl = nkstot / kunit ! k points per pool nkl = kunit * ( nkbl / npool ) ! find out the reminder nkr = ( nkstot - nkl * npool ) / kunit ! Assign the reminder to the first nkr pools IF( my_pool_id < nkr ) nkl = nkl + kunit ! find out the index of the first k point in this pool iks = nkl * my_pool_id + 1 IF( my_pool_id >= nkr ) iks = iks + nkr * kunit ! find out the index of the last k point in this pool ike = iks + nkl - 1 END IF write(stdout,*) "after first init" ! find out the global number of G vectors: ngm_g ngm_g = ngm call mp_sum( ngm_g , intra_pool_comm ) ! collect all G vectors across processors within the pools ! and compute their modules ! allocate( itmp_g( 3, ngm_g ) ) allocate( rtmp_g( 3, ngm_g ) ) allocate( rtmp_gg( ngm_g ) ) itmp_g = 0 do ig = 1, ngm itmp_g( 1, ig_l2g( ig ) ) = mill(1, ig ) itmp_g( 2, ig_l2g( ig ) ) = mill(2, ig ) itmp_g( 3, ig_l2g( ig ) ) = mill(3, ig ) end do call mp_sum( itmp_g , intra_pool_comm ) ! ! here we are in crystal units rtmp_g(1:3,1:ngm_g) = REAL( itmp_g(1:3,1:ngm_g) ) ! ! go to cartesian units (tpiba) call cryst_to_cart( ngm_g, rtmp_g, bg , 1 ) ! ! compute squared moduli do ig = 1, ngm_g rtmp_gg(ig) = rtmp_g(1,ig)**2 + rtmp_g(2,ig)**2 + rtmp_g(3,ig)**2 enddo deallocate( rtmp_g ) ! build the G+k array indexes allocate ( igk_l2g ( npwx, nks ) ) allocate ( kisort( npwx ) ) do ik = 1, nks kisort = 0 npw = npwx call gk_sort (xk (1, ik+iks-1), ngm, g, ecutwfc / tpiba2, npw, kisort(1), g2kin) ! ! mapping between local and global G vector index, for this kpoint ! DO ig = 1, npw ! igk_l2g(ig,ik) = ig_l2g( kisort(ig) ) ! END DO ! igk_l2g( npw+1 : npwx, ik ) = 0 ! ngk (ik) = npw end do deallocate (kisort) ! compute the global number of G+k vectors for each k point allocate( ngk_g( nkstot ) ) ngk_g = 0 ngk_g( iks:ike ) = ngk( 1:nks ) CALL mp_sum( ngk_g, world_comm ) ! compute the Maximum G vector index among all G+k and processors npw_g = MAXVAL( igk_l2g(:,:) ) CALL mp_max( npw_g, world_comm ) ! compute the Maximum number of G vector among all k points npwx_g = MAXVAL( ngk_g( 1:nkstot ) ) deallocate(rtmp_gg) allocate( igwk( npwx_g,nkstot ) ) write(stdout,*) "after g stuff" ! wfc grids DO ik = 1, nkstot igwk(:,ik) = 0 ! ALLOCATE( itmp1( npw_g ), STAT= ierr ) IF ( ierr/=0 ) CALL errore('pw_export','allocating itmp1', ABS(ierr) ) itmp1 = 0 ! IF( ik >= iks .AND. ik <= ike ) THEN DO ig = 1, ngk( ik-iks+1 ) itmp1( igk_l2g( ig, ik-iks+1 ) ) = igk_l2g( ig, ik-iks+1 ) END DO END IF ! CALL mp_sum( itmp1, world_comm ) ! ngg = 0 DO ig = 1, npw_g IF( itmp1( ig ) == ig ) THEN ngg = ngg + 1 igwk( ngg , ik) = ig END IF END DO IF( ngg /= ngk_g( ik ) ) THEN WRITE( stdout,*) ' ik, ngg, ngk_g = ', ik, ngg, ngk_g( ik ) END IF ! DEALLOCATE( itmp1 ) ! ENDDO ! deallocate( itmp_g ) write(stdout,*)"after wfc waves" #ifdef __PARA call poolrecover (et, nbnd, nkstot, nks) #endif wfc_scal = 1.0d0 twf0 = .true. twfm = .false. do ik = 1, nkstot local_pw = 0 IF( (ik >= iks) .AND. (ik <= ike) ) THEN call davcio (evc, 2*nwordwfc, iunwfc, (ik-iks+1), - 1) IF ( lda_plus_u ) CALL davcio( swfcatom, nwordatwfc, iunsat, (ik-iks+1), -1 ) local_pw = ngk(ik-iks+1) ENDIF allocate(l2g_new(local_pw)) l2g_new = 0 do ig = 1, local_pw ngg = igk_l2g(ig,ik-iks+1) do ig_ = 1, ngk_g(ik) if(ngg == igwk(ig_,ik)) then l2g_new(ig) = ig_ exit end if end do end do ispin = isk( ik ) ! WRITE(0,*) ' ### ', ik,nkstot,iks,ike,kunit,nproc,nproc_pool deallocate(l2g_new) end do ! write(stdout,*) "after davcio" ! If specified and if USPP are used the wfcs S_psi are written ! | spsi_nk > = \hat S | psi_nk > ! where S is the overlap operator of US PP ! IF ( uspp_spsi .AND. nkb > 0 ) THEN ALLOCATE( sevc(npwx,nbnd), STAT=ierr ) IF (ierr/=0) CALL errore( ' read_export ',' Unable to allocate SEVC ', ABS(ierr) ) CALL init_us_1 CALL init_at_1 CALL allocate_bec_type (nkb,nbnd,becp) do ik = 1, nkstot local_pw = 0 IF( (ik >= iks) .AND. (ik <= ike) ) THEN CALL gk_sort (xk (1, ik+iks-1), ngm, g, ecutwfc / tpiba2, npw, igk, g2kin) CALL davcio (evc, 2*nwordwfc, iunwfc, (ik-iks+1), - 1) CALL init_us_2(npw, igk, xk(1, ik), vkb) local_pw = ngk(ik-iks+1) IF ( gamma_only ) THEN if(nkb>0) CALL calbec ( ngk_g(ik), vkb, evc, becp ) ELSE CALL calbec ( npw, vkb, evc, becp ) ENDIF CALL s_psi(npwx, npw, nbnd, evc, sevc) ENDIF ALLOCATE(l2g_new(local_pw)) l2g_new = 0 DO ig = 1, local_pw ngg = igk_l2g(ig,ik-iks+1) DO ig_ = 1, ngk_g(ik) IF(ngg == igwk(ig_,ik)) THEN l2g_new(ig) = ig_ EXIT ENDIF ENDDO ENDDO ispin = isk( ik ) DEALLOCATE(l2g_new) ENDDO DEALLOCATE( sevc, STAT=ierr ) IF ( ierr/= 0 ) CALL errore('read_export','Unable to deallocate SEVC',ABS(ierr)) CALL deallocate_bec_type ( becp ) ENDIF DEALLOCATE( igk_l2g ) DEALLOCATE( igwk ) DEALLOCATE ( ngk_g ) end subroutine read_export GWW/pw4gww/pola_partial.f900000644000077300007730000001420512341332532016240 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !routines for the set up of terms related with the calòculation !of the polarizability for partially occupied states subroutine pola_partial(numpw,ispin) !NOT_TO_BE_INCLUDED_START !this subroutine calculates the basis for every v !the minimal orthonormal basis for the w_v(r)*w^P'_i(r) products !the occupancies are from variable wg and ste to range 0,1 USE io_global, ONLY : stdout, ionode, ionode_id USE io_files, ONLY : prefix, tmp_dir, diropn USE kinds, ONLY : DP USE wannier_gw USE gvect USE constants, ONLY : e2, pi, tpi, fpi USE cell_base, ONLY: at, alat, tpiba, omega, tpiba2 USE wvfct, ONLY : igk, g2kin, npwx, npw, nbnd, nbndx, ecutwfc,wg USE wavefunctions_module, ONLY : evc, psic USE mp, ONLY : mp_sum, mp_barrier, mp_bcast USE mp_world, ONLY : mpime,nproc, world_comm USE mp_pools, ONLY : intra_pool_comm USE gvecs, ONLY : nls, nlsm, doublegrid USE fft_custom_gwl USE mp_wave, ONLY : mergewf,splitwf USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft USE lsda_mod, ONLY : lsda, nspin implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER, INTENT(in) :: numpw!dimension of polarization basis INTEGER, INTENT(in) :: ispin! spin channel COMPLEX(kind=DP), ALLOCATABLE :: evc_g(:),p_basis(:,:),p_basis_t(:,:),evc_t(:,:) INTEGER :: iw,ii,iv,jv INTEGER :: iungprod,iun LOGICAL :: exst REAL(kind=DP), ALLOCATABLE :: evc_r(:,:), prod_r(:), psi_psi_phi(:) COMPLEX(kind=DP), ALLOCATABLE :: prod_g(:) TYPE(fft_cus) :: fc fc%ecutt=ecutwfc fc%dual_t=dual_vt write(stdout,*) 'Call initialize_fft_custom' call flush_unit(stdout) call initialize_fft_custom(fc) allocate(evc_g(fc%ngmt_g)) iungprod = find_free_unit() CALL diropn( iungprod, 'wiwjwfc_red', max_ngm*2, exst ) !read polarizability basis functions allocate(p_basis(max_ngm,numpw)) do iw=1,numpw call davcio(p_basis(:,iw),max_ngm*2,iungprod,iw,-1) enddo close(iungprod) !now polarizability basis are put on the ordering of the redueced grid, if required allocate(p_basis_t(fc%npwt,numpw)) if(fc%dual_t==4.d0) then p_basis_t(1:npw,1:numpw)=p_basis(1:npw,1:numpw) else do ii=1,numpw call mergewf(p_basis(:,ii),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) call splitwf(p_basis_t(:,ii),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) enddo endif allocate(evc_t(fc%npwt,num_nbndv(ispin))) if(fc%dual_t==4.d0) then evc_t(1:npw,1:num_nbndv(ispin))=evc(1:npw,1:num_nbndv(ispin)) else do ii=1,num_nbndv(ispin) call mergewf(evc(:,ii),evc_g,npw,ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) call splitwf(evc_t(:,ii),evc_g,fc%npwt,fc%ig_l2gt,mpime,nproc,ionode_id,intra_pool_comm) enddo endif !put KS wfcs in real space allocate(evc_r(fc%nrxxt,num_nbndv(ispin))) do iv=1,num_nbndv(ispin),2 psic(:)=(0.d0,0.d0) if(iv==num_nbndv(ispin)) then psic(fc%nlt(1:fc%npwt)) = evc_t(1:fc%npwt,iv) psic(fc%nltm(1:fc%npwt)) = CONJG( evc_t(1:fc%npwt,iv) ) else psic(fc%nlt(1:fc%npwt))=evc_t(1:fc%npwt,iv)+(0.d0,1.d0)*evc_t(1:fc%npwt,iv+1) psic(fc%nltm(1:fc%npwt)) = CONJG( evc_t(1:fc%npwt,iv) )+(0.d0,1.d0)*CONJG( evc_t(1:fc%npwt,iv+1) ) endif CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, 2 ) evc_r(1:fc%nrxxt,iv)= DBLE(psic(1:fc%nrxxt)) if(iv/=num_nbndv(ispin)) evc_r(1:fc%nrxxt,iv+1)= DIMAG(psic(1:fc%nrxxt)) enddo !open file and write occupancies if(ionode) then iun=find_free_unit() if(ispin==1) then open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.occ_mat', status='unknown',form='unformatted') else open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.occ_mat2', status='unknown',form='unformatted') endif write(iun) num_nbndv_min(ispin) write(iun) num_nbndv(ispin) write(iun) numpw if(nspin==1) then write(iun) wg(1:num_nbndv(ispin),ispin)/2.d0 else write(iun) wg(1:num_nbndv(ispin),ispin) endif endif !loop on partially occupied states allocate(prod_r(fc%nrxxt)) allocate(prod_g(fc%npwt),psi_psi_phi(numpw)) do iv=num_nbndv_min(ispin)+1,num_nbndv(ispin) !loop on all states do jv=1,num_nbndv(ispin) prod_r(1:fc%nrxxt)=evc_r(1:fc%nrxxt,iv)*evc_r(1:fc%nrxxt,jv) psic(1:fc%nrxxt)=dcmplx(prod_r(1:fc%nrxxt),0.d0) CALL cft3t( fc, psic, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, -2 ) prod_g(1:fc%npwt) = psic(fc%nlt(1:fc%npwt)) !do product with polarizability basis call dgemm('T','N',numpw,1,2*fc%npwt,2.0,p_basis_t,2*fc%npwt,prod_g,2*fc%npwt,0.d0,psi_psi_phi,numpw) if(fc%gstart_t==2) then do ii=1,numpw psi_psi_phi(ii)=psi_psi_phi(ii)-dble(conjg(p_basis_t(1,ii))*prod_g(1)) enddo endif call mp_sum(psi_psi_phi,world_comm) if(ionode) write(iun) psi_psi_phi(1:numpw) enddo enddo !write if(ionode) close(iun) write(stdout,*) 'Call deallocate_fft_custom' call flush_unit(stdout) deallocate(evc_g,p_basis,p_basis_t) deallocate(evc_t,evc_r) deallocate(prod_r,prod_g) deallocate(psi_psi_phi) call deallocate_fft_custom(fc) return !NOT_TO_BE_INCLUDED_END end subroutine pola_partial GWW/pw4gww/fft_custom.f900000644000077300007730000006371012341332532015747 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !this module contains routines for fft with an custom selected cutoff MODULE fft_custom_gwl USE kinds, ONLY: DP USE parallel_include USE fft_types, ONLY: fft_dlay_descriptor IMPLICIT NONE TYPE fft_cus ! ... data structure containing all information ! ... about fft data distribution for a given ! ... potential grid, and its wave functions sub-grid. TYPE ( fft_dlay_descriptor ) :: dfftt ! descriptor for custom grim REAL(kind=DP) :: ecutt!custom cutoff in rydberg REAL(kind=DP) :: dual_t!dual facor REAL(kind=DP) :: gcutmt INTEGER :: nr1t,nr2t,nr3t INTEGER :: nrx1t,nrx2t,nrx3t INTEGER :: nrxxt INTEGER :: ngmt,ngmt_l,ngmt_g INTEGER, DIMENSION(:), POINTER :: nlt,nltm REAL(kind=DP), DIMENSION(:), POINTER :: ggt REAL(kind=DP), DIMENSION(:,:),POINTER :: gt INTEGER, DIMENSION(:), POINTER :: ig_l2gt INTEGER :: gstart_t INTEGER, DIMENSION(:), POINTER :: ig1t,ig2t,ig3t INTEGER :: nlgt INTEGER :: npwt,npwxt !we redifine the cell for arbitrary cell possibility REAL(DP) :: alat_t = 0.0_DP REAl(DP) :: omega_t = 0.0_DP REAL(DP) :: tpiba_t = 0.0_DP, tpiba2_t = 0.0_DP REAL(DP) :: at_t(3,3) = RESHAPE( (/ 0.0_DP /), (/ 3, 3 /), (/ 0.0_DP /) ) REAL(DP) :: bg_t(3,3) = RESHAPE( (/ 0.0_DP /), (/ 3, 3 /), (/ 0.0_DP /) ) END TYPE fft_cus !=------------------------------------------------------- !=----------------------------------------------------------------------=! CONTAINS !=----------------------------------------------------------------------=! ! SUBROUTINE set_custom_grid(fc) !----------------------------------------------------------------------- ! This routine computes the dimensions of the minimum FFT grid ! compatible with the input cut-off ! ! NB: The values of nr1, nr2, nr3 are computed only if they are not ! given as input parameters. Input values are kept otherwise. ! USE io_global, ONLY : stdout use fft_scalar, only: allowed USE fft_base, ONLY : dfftp implicit none type(fft_cus) :: fc integer, parameter :: nmax = 5000 ! an unreasonably big number for a FFT grid ! ! the values of nr1, nr2, nr3 are computed only if they are not given ! as input parameters ! fc%gcutmt = fc%dual_t*fc%ecutt / fc%tpiba2_t fc%nr1t=0 fc%nr2t=0 fc%nr3t=0 if (fc%nr1t == 0) then ! ! estimate nr1 and check if it is an allowed value for FFT ! fc%nr1t = int (2 * sqrt (fc%gcutmt) * sqrt (fc%at_t (1, 1) **2 + fc%at_t (2, 1) & **2 + fc%at_t (3, 1) **2) ) + 1 10 continue if (fc%nr1t > nmax) & call errore ('set_fft_dim', 'nr1 is unreasonably large', fc%nr1t) if (allowed (fc%nr1t) ) goto 15 fc%nr1t = fc%nr1t + 1 goto 10 else if (.not.allowed (fc%nr1t) ) call errore ('set_fft_dim', & 'input nr1t value not allowed', 1) endif 15 continue ! if (fc%nr2t == 0) then ! ! estimate nr1 and check if it is an allowed value for FFT ! fc%nr2t = int (2 * sqrt (fc%gcutmt) * sqrt (fc%at_t (1, 2) **2 + fc%at_t (2, 2) & **2 + fc%at_t (3, 2) **2) ) + 1 20 continue if (fc%nr2t > nmax) & call errore ('set_fft_dim', 'nr2t is unreasonably large', fc%nr2t) if (allowed (fc%nr2t) ) goto 25 fc%nr2t = fc%nr2t + 1 goto 20 else if (.not.allowed (fc%nr2t) ) call errore ('set_fft_dim', & 'input nr2t value not allowed', 2) endif 25 continue ! if (fc%nr3t == 0) then ! ! estimate nr3 and check if it is an allowed value for FFT ! fc%nr3t = int (2 * sqrt (fc%gcutmt) * sqrt (fc%at_t (1, 3) **2 + fc%at_t (2, 3) & **2 + fc%at_t (3, 3) **2) ) + 1 30 continue if (fc%nr3t > nmax) & call errore ('set_fft_dim', 'nr3 is unreasonably large', fc%nr3t) if (allowed (fc%nr3t) ) goto 35 fc%nr3t = fc%nr3t + 1 goto 30 else if (.not.allowed (fc%nr3t) ) call errore ('set_fft_dim', & 'input nr3t value not allowed', 3) endif 35 continue ! ! here we compute nr3s if it is not in input ! if(fc%dual_t==4.d0) then fc%nr1t=dfftp%nr1 fc%nr2t=dfftp%nr2 fc%nr3t=dfftp%nr3 endif ! return END SUBROUTINE set_custom_grid SUBROUTINE data_structure_custom(fc) !----------------------------------------------------------------------- ! this routine sets the data structure for the fft arrays ! (both the smooth and the hard mesh) ! In the parallel case, it distributes columns to processes, too ! USE io_global, ONLY : stdout USE kinds, ONLY : DP USE klist, ONLY : xk, nks ! USE gvect, ONLY : nr1, nr2, nr3, nrx1, nrx2, nrx3, nrxx, & ! ngm, ngm_l, ngm_g, gcutm, ecutwfc ! USE gsmooth, ONLY : nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, nrxxs, & ! ngms, ngms_l, ngms_g, gcutms USE mp, ONLY : mp_sum, mp_max,mp_barrier USE mp_global, ONLY : intra_pool_comm, nproc_pool, me_pool, my_image_id, & inter_pool_comm,root_pool USE mp_world, ONLY : world_comm, nproc USE stick_base USE fft_scalar, ONLY : good_fft_dimension USE fft_types, ONLY : fft_dlay_allocate, fft_dlay_set, fft_dlay_scalar ! ! IMPLICIT NONE TYPE(fft_cus) :: fc INTEGER :: n1, n2, n3, i1, i2, i3 ! counters on G space ! REAL(DP) :: amod ! modulus of G vectors INTEGER, ALLOCATABLE :: stw(:,:) ! sticks maps INTEGER :: ub(3), lb(3) ! upper and lower bounds for maps REAL(DP) :: gkcut ! cut-off for the wavefunctions INTEGER :: ncplane, nxx INTEGER :: ncplanes, nxxs #ifdef __PARA INTEGER, ALLOCATABLE :: st(:,:), sts(:,:) ! sticks maps INTEGER, ALLOCATABLE :: ngc (:), ngcs (:), ngkc (:) INTEGER :: ncp (nproc), nct, nkcp (nproc), ncts, ncps(nproc) INTEGER :: ngp (nproc), ngps(nproc), ngkp (nproc), ncp_(nproc),& i, j, jj, idum ! nxx ! local fft data dim ! ncplane, &! number of columns in a plane ! nct, &! total number of non-zero columns ! ncp(nproc), &! number of (density) columns per proc LOGICAL :: tk = .true. ! map type: true for full space sticks map, false for half space sticks map INTEGER, ALLOCATABLE :: in1(:), in2(:), idx(:) ! sticks coordinates ! ! Subroutine body ! call mp_barrier( world_comm ) write(stdout,*) 'ATT1.0' call flush_unit(stdout) tk = .false. ! ! set the values of fft arrays ! fc%nrx1t = good_fft_dimension (fc%nr1t) fc%nrx2t = fc%nr2t ! nrx2 is there just for compatibility fc%nrx3t = good_fft_dimension (fc%nr3t) ! compute number of points per plane ncplane = fc%nrx1t * fc%nrx2t ncplanes = fc%nrx1t * fc%nrx2t call mp_barrier( world_comm ) write(stdout,*) 'ATT1.1' call flush_unit(stdout) ! ! check the number of plane per process ! IF ( fc%nr3t < nproc_pool ) & CALL infomsg ('data_structure', 'some processors have no planes ') ! ! compute gkcut calling an internal procedure ! CALL calculate_gkcut() ! ! Now compute for each point of the big plane how many column have ! non zero vectors on the smooth and thick mesh ! call mp_barrier( world_comm ) write(stdout,*) 'ATT1.2' call flush_unit(stdout) n1 = fc%nr1t + 1 n2 = fc%nr2t + 1 n3 = fc%nr3t + 1 ub = (/ n1, n2, n3 /) lb = (/ -n1, -n2, -n3 /) ALLOCATE( stw ( lb(1) : ub(1), lb(2) : ub(2) ) ) ALLOCATE( st ( lb(1) : ub(1), lb(2) : ub(2) ) ) ALLOCATE( sts ( lb(1) : ub(1), lb(2) : ub(2) ) ) ! ! ... Fill in the stick maps, for given g-space base (b1,b2,b3) ! ... and cut-offs ! ... The value of the element (i,j) of the map ( st ) is equal to the ! ... number of G-vector belonging to the (i,j) stick. ! call mp_barrier( world_comm ) write(stdout,*) 'ATT1.3' call flush_unit(stdout) CALL sticks_maps( tk, ub, lb, fc%bg_t(:,1), fc%bg_t(:,2), fc%bg_t(:,3), fc%gcutmt, gkcut, fc%gcutmt, st, & &stw, sts ,me_pool,nproc_pool,intra_pool_comm) write(stdout,*) 'ATT1.3.1' call flush_unit(stdout) nct = count( st > 0 ) ncts = count( sts > 0 ) IF ( nct > ncplane ) & & CALL errore('data_structure','too many sticks',1) IF ( ncts > ncplanes ) & & CALL errore('data_structure','too many sticks',2) IF ( nct == 0 ) & & CALL errore('data_structure','number of sticks 0', 1) IF ( ncts == 0 ) & & CALL errore('data_structure','number smooth sticks 0', 1) ! ! local pointers deallocated at the end ! ALLOCATE( in1( nct ), in2( nct ) ) ALLOCATE( ngc( nct ), ngcs( nct ), ngkc( nct ) ) ALLOCATE( idx( nct ) ) ! ! ... initialize the sticks indexes array ist ! ... nct counts columns containing G-vectors for the dense grid ! ... ncts counts columns contaning G-vectors for the smooth grid ! write(stdout,*) 'ATT1.5' call flush_unit(stdout) CALL sticks_countg( tk, ub, lb, st, stw, sts, in1, in2, ngc, ngkc, ngcs ) CALL sticks_sort( ngc, ngkc, ngcs, nct, idx ,nproc_pool) CALL sticks_dist( tk, ub, lb, idx, in1, in2, ngc, ngkc, ngcs, nct, & ncp, nkcp, ncps, ngp, ngkp, ngps, st, stw, sts ,nproc_pool) CALL sticks_pairup( tk, ub, lb, idx, in1, in2, ngc, ngkc, ngcs, nct, & ncp, nkcp, ncps, ngp, ngkp, ngps, st, stw, sts ,nproc_pool) write(stdout,*) 'ATT1.6' call flush_unit(stdout) ! set the total number of G vectors IF( tk ) THEN fc%ngmt = ngp ( me_pool + 1 ) ELSE IF( st( 0, 0 ) == ( me_pool + 1 ) ) THEN fc%ngmt = ngp ( me_pool + 1 ) / 2 + 1 ELSE fc%ngmt = ngp ( me_pool + 1 ) / 2 ENDIF ENDIF CALL fft_dlay_allocate( fc%dfftt, me_pool,root_pool,nproc_pool,intra_pool_comm ,0, fc%nrx1t, fc%nrx2t ) ! here set the fft data layout structures for dense and smooth mesh, ! according to stick distribution CALL fft_dlay_set( fc%dfftt, & tk, nct, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, ub, lb, idx, in1(:), in2(:), ncp, nkcp, ngp, ngkp, st, stw) ! if tk = .FALSE. only half reciprocal space is considered, then we ! need to correct the number of sticks IF( .not. tk ) THEN nct = nct*2 - 1 ncts = ncts*2 - 1 ENDIF ! ! set the number of plane per process ! ! npp ( 1 : nproc_pool ) = dfftp%npp ( 1 : nproc_pool ) ! npps( 1 : nproc_pool ) = dffts%npp ( 1 : nproc_pool ) IF ( fc%dfftt%nnp /= ncplane ) & & CALL errore('data_structure','inconsistent plane dimension on dense grid', abs(fc%dfftt%nnp-ncplane) ) WRITE( stdout, '(/5x,"Planes per process (custom) : nr3t =", & & i4," npp = ",i4," ncplane =",i6)') fc%nr3t, fc%dfftt%npp (me_pool + 1) , ncplane WRITE( stdout,*) WRITE( stdout,'(5X, & & "Proc/ planes cols G "/5X)') DO i=1,nproc_pool WRITE( stdout,'(5x,i4,1x,i5,i7,i9)') i, fc%dfftt%npp(i), ncp(i), ngp(i) ENDDO IF ( nproc_pool > 1 ) THEN WRITE( stdout,'(5x,"tot",2x,i5,i7,i9)') & sum(fc%dfftt%npp(1:nproc_pool)), sum(ncp(1:nproc_pool)), sum(ngp(1:nproc_pool)) ENDIF WRITE( stdout,*) DEALLOCATE( stw, st, sts, in1, in2, idx, ngc, ngcs, ngkc ) ! ! ncp0 = starting column for each processor ! ! ncp0( 1:nproc_pool ) = dfftp%iss( 1:nproc_pool ) ! ncp0s( 1:nproc_pool ) = dffts%iss( 1:nproc_pool ) ! ! array ipc and ipcl ( ipc contain the number of the ! column for that processor or zero if the ! column do not belong to the processor, ! ipcl contains the point in the plane for ! each column) ! ! ipc ( 1:ncplane ) = > dfftp%isind( 1:ncplane ) ! icpl( 1:nct ) = > dfftp%ismap( 1:nct ) ! ipcs ( 1:ncplanes ) = > dffts%isind( 1:ncplanes ) ! icpls( 1:ncts ) = > dffts%ismap( 1:ncts ) fc%nrxxt = fc%dfftt%nnr ! ! nxx is just a copy ! nxx = fc%nrxxt nxxs = fc%nrxxt #else fc%nrx1t = good_fft_dimension (fc%nr1t) ! ! nrx2 and nrx3 are there just for compatibility ! fc%nrx2t = fc%nr2t fc%nrx3t = fc%nr3t fc%nrxxt = fc%nrx1t * fc%nrx2t * fc%nrx3t ! nxx is just a copy ! nxx = fc%nrxxt nxxs = fc%nrxxt CALL fft_dlay_allocate( fc%dfftt, me_pool,root_pool,nproc_pool, intra_pool_comm,0,max(fc%nrx1t, fc%nrx3t), fc%nrx2t ) CALL calculate_gkcut() ! ! compute the number of g necessary to the calculation ! n1 = fc%nr1t + 1 n2 = fc%nr2t + 1 n3 = fc%nr3t + 1 fc%ngmt = 0 ub = (/ n1, n2, n3 /) lb = (/ -n1, -n2, -n3 /) ! ALLOCATE( stw ( lb(2):ub(2), lb(3):ub(3) ) ) stw = 0 DO i1 = - n1, n1 ! ! Gamma-only: exclude space with x<0 ! IF (i1 < 0) GOTO 10 ! DO i2 = - n2, n2 ! ! Gamma-only: exclude plane with x=0, y<0 ! IF(i1 == 0.and. i2 < 0) GOTO 20 ! DO i3 = - n3, n3 ! ! Gamma-only: exclude line with x=0, y=0, z<0 ! IF(i1 == 0 .and. i2 == 0 .and. i3 < 0) GOTO 30 ! amod = (i1 * fc%bg_t (1, 1) + i2 * fc%bg_t (1, 2) + i3 * fc%bg_t (1, 3) ) **2 + & (i1 * fc%bg_t (2, 1) + i2 * fc%bg_t (2, 2) + i3 * fc%bg_t (2, 3) ) **2 + & (i1 * fc%bg_t (3, 1) + i2 * fc%bg_t (3, 2) + i3 * fc%bg_t (3, 3) ) **2 IF (amod <= fc%gcutmt) fc%ngmt = fc%ngmt + 1 IF (amod <= fc%gcutmt ) THEN stw( i2, i3 ) = 1 stw( -i2, -i3 ) = 1 ENDIF 30 CONTINUE ENDDO 20 CONTINUE ENDDO 10 CONTINUE ENDDO CALL fft_dlay_scalar( fc%dfftt, ub, lb, fc%nr1t, fc%nr2t, fc%nr3t, fc%nrx1t, fc%nrx2t, fc%nrx3t, stw ) DEALLOCATE( stw ) #endif IF( nxx < fc%dfftt%nnr ) & CALL errore( ' data_structure ', ' inconsistent value for nxx ', abs( nxx - fc%dfftt%nnr ) ) ! ! compute the global number of g, i.e. the sum over all processors ! within a pool ! fc%ngmt_l = fc%ngmt fc%ngmt_g = fc%ngmt ; CALL mp_sum( fc%ngmt_g , intra_pool_comm ) ! IF( use_task_groups ) THEN IF(.false.) THEN !ATTENZIONE ! ! Initialize task groups. ! Note that this call modify dffts adding task group data. ! CALL task_groups_init( fc%dfftt ) ! ENDIF CONTAINS SUBROUTINE calculate_gkcut() USE io_global, ONLY : stdout INTEGER :: kpoint IF (nks == 0) THEN ! ! if k-points are automatically generated (which happens later) ! use max(bg)/2 as an estimate of the largest k-point ! gkcut = 0.5d0 * max ( & sqrt (sum(fc%bg_t (1:3, 1)**2) ), & sqrt (sum(fc%bg_t (1:3, 2)**2) ), & sqrt (sum(fc%bg_t (1:3, 3)**2) ) ) ELSE gkcut = 0.0d0 DO kpoint = 1, nks gkcut = max (gkcut, sqrt ( sum(xk (1:3, kpoint)**2) ) ) ENDDO ENDIF gkcut = (sqrt (fc%ecutt) / fc%tpiba_t + gkcut)**2 ! ! ... find maximum value among all the processors ! CALL mp_max (gkcut, inter_pool_comm ) END SUBROUTINE calculate_gkcut END SUBROUTINE data_structure_custom SUBROUTINE initialize_fft_custom(fc) !this subroutines initialize all the fft stuff for the custom defined grid USE kinds, ONLY : DP USE gvect, ONLY : g,mill USE cell_base, ONLY : at, bg,tpiba2,tpiba,omega,alat USE io_global, ONLY : stdout use control_flags, ONLY : gamma_only USE mp, ONLY : mp_barrier USE mp_world, ONLY : world_comm implicit none TYPE (fft_cus) :: fc INTEGER :: ng,n1t,n2t,n3t fc%at_t(1:3,1:3)=at(1:3,1:3) fc%bg_t(1:3,1:3)=bg(1:3,1:3) fc%alat_t=alat fc%omega_t=omega fc%tpiba_t=tpiba fc%tpiba2_t=tpiba2 call mp_barrier( world_comm ) write(stdout,*) 'ATT1' call flush_unit(stdout) call set_custom_grid(fc) call mp_barrier( world_comm ) write(stdout,*) 'ATT2' call flush_unit(stdout) call data_structure_custom(fc) call mp_barrier( world_comm ) write(stdout,*) 'ATT3' call flush_unit(stdout) allocate(fc%nlt(fc%ngmt)) allocate(fc%nltm(fc%ngmt)) write(stdout,*) 'ATT4' call flush_unit(stdout) call ggent(fc) return END SUBROUTINE initialize_fft_custom SUBROUTINE initialize_fft_custom_cell(fc) !this subroutines initialize all the fft stuff for the custom defined grid !for an arbitratry cell USE kinds, ONLY : DP USE gvect, ONLY : g,mill USE cell_base, ONLY : at, bg,tpiba2,tpiba,omega,alat USE io_global, ONLY : stdout use control_flags, ONLY : gamma_only USE mp, ONLY : mp_barrier USE mp_world, ONLY : world_comm implicit none TYPE (fft_cus) :: fc INTEGER :: ng,n1t,n2t,n3t !the following must be provided from input !fc%at_t(1:3,1:3)=at(1:3,1:3) !fc%bg_t(1:3,1:3)=bg(1:3,1:3) !fc%alat_t=alat !fc%omega_t=omega !fc%tpiba_t=tpiba !fc%tpiba2_t=tpiba2 call mp_barrier( world_comm ) write(stdout,*) 'ATT1' call flush_unit(stdout) call set_custom_grid(fc) call mp_barrier( world_comm ) write(stdout,*) 'ATT2' call flush_unit(stdout) call data_structure_custom(fc) call mp_barrier( world_comm ) write(stdout,*) 'ATT3' call flush_unit(stdout) allocate(fc%nlt(fc%ngmt)) allocate(fc%nltm(fc%ngmt)) write(stdout,*) 'ATT4' call flush_unit(stdout) call ggent(fc) return END SUBROUTINE initialize_fft_custom_cell SUBROUTINE ggent(fc) USE kinds, ONLY : DP USE control_flags, ONLY : gamma_only USE constants, ONLY : eps8 implicit none TYPE(fft_cus) :: fc ! REAL(DP) :: t (3), tt, swap ! INTEGER :: ngmx, n1, n2, n3, n1s, n2s, n3s ! REAL(DP), ALLOCATABLE :: g2sort_g(:) ! array containing all g vectors, on all processors: replicated data INTEGER, ALLOCATABLE :: mill_g(:,:), mill_unsorted(:,:) ! array containing all g vectors generators, on all processors: ! replicated data INTEGER, ALLOCATABLE :: igsrt(:) ! #ifdef __PARA INTEGER :: m1, m2, mc ! #endif INTEGER :: i, j, k, ipol, ng, igl, iswap, indsw allocate(fc%gt(3,fc%ngmt),fc%ggt(fc%ngmt)) ALLOCATE( fc%ig_l2gt( fc%ngmt_l ) ) ALLOCATE( mill_g( 3, fc%ngmt_g ),mill_unsorted( 3, fc%ngmt_g ) ) ALLOCATE( igsrt( fc%ngmt_g ) ) ALLOCATE( g2sort_g( fc%ngmt_g ) ) ALLOCATE(fc%ig1t(fc%ngmt),fc%ig2t(fc%ngmt),fc%ig3t(fc%ngmt)) g2sort_g(:) = 1.0d20 ! ! save present value of ngm in ngmx variable ! ngmx = fc%ngmt ! fc%ngmt = 0 iloop: DO i = -fc%nr1t-1, fc%nr1t+1 ! ! gamma-only: exclude space with x < 0 ! IF ( gamma_only .and. i < 0) CYCLE iloop jloop: DO j = -fc%nr2t-1, fc%nr2t+1 ! ! gamma-only: exclude plane with x = 0, y < 0 ! IF ( gamma_only .and. i == 0 .and. j < 0) CYCLE jloop kloop: DO k = -fc%nr3t-1, fc%nr3t+1 ! ! gamma-only: exclude line with x = 0, y = 0, z < 0 ! IF ( gamma_only .and. i == 0 .and. j == 0 .and. k < 0) CYCLE kloop t(:) = i * fc%bg_t (:,1) + j * fc%bg_t (:,2) + k * fc%bg_t (:,3) tt = sum(t(:)**2) IF (tt <= fc%gcutmt) THEN fc%ngmt = fc%ngmt + 1 IF (fc%ngmt > fc%ngmt_g) CALL errore ('ggent', 'too many g-vectors', fc%ngmt) mill_unsorted( :, fc%ngmt ) = (/ i,j,k /) IF ( tt > eps8 ) THEN g2sort_g(fc%ngmt) = tt ELSE g2sort_g(fc%ngmt) = 0.d0 ENDIF ENDIF ENDDO kloop ENDDO jloop ENDDO iloop IF (fc%ngmt /= fc%ngmt_g ) & CALL errore ('ggen', 'g-vectors missing !', abs(fc%ngmt - fc%ngmt_g)) igsrt(1) = 0 CALL hpsort_eps( fc%ngmt_g, g2sort_g, igsrt, eps8 ) mill_g(1,:) = mill_unsorted(1,igsrt(:)) mill_g(2,:) = mill_unsorted(2,igsrt(:)) mill_g(3,:) = mill_unsorted(3,igsrt(:)) DEALLOCATE( g2sort_g, igsrt, mill_unsorted ) fc%ngmt = 0 ngloop: DO ng = 1, fc%ngmt_g i = mill_g(1, ng) j = mill_g(2, ng) k = mill_g(3, ng) #ifdef __PARA m1 = mod (i, fc%nr1t) + 1 IF (m1 < 1) m1 = m1 + fc%nr1t m2 = mod (j, fc%nr2t) + 1 IF (m2 < 1) m2 = m2 + fc%nr2t mc = m1 + (m2 - 1) * fc%nrx1t IF ( fc%dfftt%isind ( mc ) == 0) CYCLE ngloop #endif fc%ngmt = fc%ngmt + 1 ! Here map local and global g index !!! fc%ig_l2gt( fc%ngmt ) = ng fc%gt (1:3, fc%ngmt) = i * fc%bg_t (:, 1) + j * fc%bg_t (:, 2) + k * fc%bg_t (:, 3) fc%ggt (fc%ngmt) = sum(fc%gt (1:3, fc%ngmt)**2) IF (fc%ngmt > ngmx) CALL errore ('ggen', 'too many g-vectors', fc%ngmt) ENDDO ngloop IF (fc%ngmt /= ngmx) & CALL errore ('ggent', 'g-vectors missing !', abs(fc%ngmt - ngmx)) ! ! here to initialize berry_phase ! CALL berry_setup(ngm, ngm_g, nr1, nr2, nr3, mill_g) ! ! determine first nonzero g vector ! IF (fc%ggt(1).le.eps8) THEN fc%gstart_t=2 ELSE fc%gstart_t=1 ENDIF ! ! Now set nl and nls with the correct fft correspondence ! DO ng = 1, fc%ngmt n1 = nint (sum(fc%gt (:, ng) * fc%at_t (:, 1))) + 1 fc%ig1t (ng) = n1 - 1 IF (n1<1) n1 = n1 + fc%nr1t n2 = nint (sum(fc%gt (:, ng) * fc%at_t (:, 2))) + 1 fc%ig2t (ng) = n2 - 1 IF (n2<1) n2 = n2 + fc%nr2t n3 = nint (sum(fc%gt (:, ng) * fc%at_t (:, 3))) + 1 fc%ig3t (ng) = n3 - 1 IF (n3<1) n3 = n3 + fc%nr3t IF (n1>fc%nr1t .or. n2>fc%nr2t .or. n3>fc%nr3t) & CALL errore('ggent','Mesh too small?',ng) #if defined (__PARA) && !defined (__USE_3D_FFT) fc%nlt (ng) = n3 + ( fc%dfftt%isind (n1 + (n2 - 1) * fc%nrx1t) - 1) * fc%nrx3t #else fc%nlt (ng) = n1 + (n2 - 1) * fc%nrx1t + (n3 - 1) * fc%nrx1t * fc%nrx2t #endif ENDDO ! DEALLOCATE( mill_g ) ! ! calculate number of G shells: ngl IF ( gamma_only) THEN DO ng = 1, fc%ngmt n1 = -fc%ig1t (ng) + 1 IF (n1 < 1) n1 = n1 + fc%nr1t n2 = -fc%ig2t (ng) + 1 IF (n2 < 1) n2 = n2 + fc%nr2t n3 = -fc%ig3t (ng) + 1 IF (n3 < 1) n3 = n3 + fc%nr3t IF (n1>fc%nr1t .or. n2>fc%nr2t .or. n3>fc%nr3t) THEN CALL errore('ggent meno','Mesh too small?',ng) ENDIF #if defined (__PARA) && !defined (__USE_3D_FFT) fc%nltm(ng) = n3 + (fc%dfftt%isind (n1 + (n2 - 1) * fc%nrx1t) - 1) * fc%nrx3t #else fc%nltm(ng) = n1 + (n2 - 1) * fc%nrx1t + (n3 - 1) * fc%nrx1t * fc%nrx2t #endif ENDDO ENDIF !set npwt,npwxt if(gamma_only) then fc%npwt=0 fc%npwxt=0 do ng = 1, fc%ngmt tt = (fc%gt (1, ng) ) **2 + (fc%gt (2, ng) ) **2 + (fc%gt (3, ng) ) **2 if (tt <= fc%ecutt / fc%tpiba2_t) then ! ! here if |k+G|^2 <= Ecut increase the number of G inside the sphere ! fc%npwt = fc%npwt + 1 endif enddo fc%npwxt=fc%npwt endif return END SUBROUTINE ggent SUBROUTINE deallocate_fft_custom(fc) !this subroutine deallocates all the fft custom stuff USE fft_types, ONLY : fft_dlay_deallocate implicit none TYPE(fft_cus) :: fc deallocate(fc%nlt,fc%nltm) call fft_dlay_deallocate(fc%dfftt) deallocate(fc%ig_l2gt,fc%ggt,fc%gt) deallocate(fc%ig1t,fc%ig2t,fc%ig3t) return END SUBROUTINE deallocate_fft_custom SUBROUTINE cft3t( fc, f, n1, n2, n3, nx1, nx2, nx3, sign ) !---------------------------------------------------------------------------- ! ! ... sign = +-1 : parallel 3d fft for rho and for the potential ! ... sign = +-2 : parallel 3d fft for wavefunctions ! ! ... sign = + : G-space to R-space, output = \sum_G f(G)exp(+iG*R) ! ... fft along z using pencils (cft_1z) ! ... transpose across nodes (fft_scatter) ! ... and reorder ! ... fft along y (using planes) and x (cft_2xy) ! ... sign = - : R-space to G-space, output = \int_R f(R)exp(-iG*R)/Omega ! ... fft along x and y(using planes) (cft_2xy) ! ... transpose across nodes (fft_scatter) ! ... and reorder ! ... fft along z using pencils (cft_1z) ! ! ... The array "planes" signals whether a fft is needed along y : ! ... planes(i)=0 : column f(i,*,*) empty , don't do fft along y ! ... planes(i)=1 : column f(i,*,*) filled, fft along y needed ! ... "empty" = no active components are present in f(i,*,*) ! ... after (sign>0) or before (sign<0) the fft on z direction ! ! ... Note that if sign=+/-1 (fft on rho and pot.) all fft's are needed ! ... and all planes(i) are set to 1 ! USE kinds, ONLY : DP USE fft_parallel, ONLY : tg_cft3s USE fft_scalar, ONLY : cfft3ds, cfft3d ! common scalar fft driver USE io_global, ONLY : stdout ! IMPLICIT NONE ! TYPE(fft_cus) :: fc INTEGER, INTENT(IN) :: n1, n2, n3, nx1, nx2, nx3, sign #if defined (__PARA) && !defined(__USE_3D_FFT) ! COMPLEX(DP), INTENT(INOUT) :: f( fc%dfftt%nnr ) ! ! ... call the general purpose parallel driver ! call start_clock('cft3t') CALL tg_cft3s( f, fc%dfftt, sign ) call stop_clock('cft3t') ! #else ! ! ... serial case ! COMPLEX(DP), INTENT(INOUT) :: f(nx1*nx2*nx3) ! ! ! ! ... sign = +-1 : complete 3d fft (for rho and for the potential) ! IF ( sign == 1 ) THEN ! CALL cfft3d( f, n1, n2, n3, nx1, nx2, nx3, 1 ) ! ELSE IF ( sign == -1 ) THEN ! CALL cfft3d( f, n1, n2, n3, nx1, nx2, nx3, -1 ) ! ! ... sign = +-2 : if available, call the "short" fft (for psi's) ! ELSE IF ( sign == 2 ) THEN ! CALL cfft3ds( f, n1, n2, n3, nx1, nx2, nx3, 1, fc%dfftt%isind, fc%dfftt%iplw ) ! ELSE IF ( sign == -2 ) THEN ! CALL cfft3ds( f, n1, n2, n3, nx1, nx2, nx3, -1, fc%dfftt%isind, fc%dfftt%iplw ) ! ELSE ! CALL errore( 'cft3t', 'what should i do?', 1 ) ! END IF ! ! #endif ! RETURN ! END SUBROUTINE cft3t END MODULE fft_custom_gwl GWW/pw4gww/wfc_real.f900000644000077300007730000001073712341332532015361 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !---------------------------------------------------------------------------- SUBROUTINE wfc_gamma_real(itask,ispin) !this subroutine writes the wfcs on real space - coarse grid !on disk !it works only at GAMMA !it supports US pseudopotentials !it also sets uo the array bec_gw USE kinds, ONLY : DP USE gvect, ONLY : gstart USE gvecs, ONLY : nls, nlsm, doublegrid USE io_files, ONLY : iunwfc, nwordwfc, iunigk, diropn USE wvfct, ONLY : nbnd, npwx, npw, igk, wg, et USE mp, ONLY : mp_bcast USE io_global, ONLY : stdout USE klist, ONLY : lgauss, degauss, ngauss, nks, & nkstot, wk, xk, nelec, nelup, neldw, & two_fermi_energies USE lsda_mod, ONLY : lsda, nspin, current_spin, isk USE wavefunctions_module, ONLY : evc, psic USE io_files, ONLY : diropn USE wannier_gw, ONLY : becp_gw, becp_gw_c, l_verbose USE uspp USE control_flags, ONLY : gamma_only USE fft_base, ONLY : dfftp, dffts USE fft_interfaces, ONLY : fwfft, invfft IMPLICIT NONE INTEGER, EXTERNAL :: find_free_unit INTEGER, INTENT(in) :: itask !if ==1 consider subspace{c'} INTEGER, INTENT(in) :: ispin!spin variable 1,2 ! INTEGER :: ikb, jkb, ijkb0, ih, jh, ijh, na, np INTEGER :: ir, is, ig, ibnd, ik INTEGER :: iunwfcreal LOGICAL :: exst REAL(kind=DP), ALLOCATABLE :: tmpreal(:) if(l_verbose) write(stdout,*) 'FUNCTION WFC_REAL' !ATTENZIONE call flush_unit(stdout) allocate(tmpreal(dffts%nnr)) IF(.not.gamma_only) THEN write(stdout,*) ' wfc_gamma_real only for GAMMA' stop ENDIF iunwfcreal=find_free_unit() CALL diropn( iunwfcreal, 'real_whole', dffts%nnr, exst ) ! ! if ( nkb > 0 .and. okvan) then CALL init_us_2( npw, igk, xk(1,1), vkb ) if(itask/=1) then !CALL ccalbec( nkb, npwx, npw, nbnd, becp_gw, vkb, evc ) else !CALL ccalbec( nkb, npwx, npw, nbnd, becp_gw_c, vkb, evc ) endif endif ! ! ! ... here we compute the band energy: the sum of the eigenvalues ! if(gstart==2) then do ibnd=1,nbnd evc(1,ibnd)=dble(evc(1,ibnd)) enddo endif DO ibnd = 1, nbnd, 2 if(l_verbose) write(stdout,*) 'IBND:',ibnd call flush_unit(stdout) ! psic(:) = ( 0.D0, 0.D0 ) ! IF ( ibnd < nbnd ) THEN ! ! ... two ffts at the same time ! psic(nls(igk(1:npw))) = evc(1:npw,ibnd) + & ( 0.D0, 1.D0 ) * evc(1:npw,ibnd+1) psic(nlsm(igk(1:npw))) = CONJG( evc(1:npw,ibnd) - & ( 0.D0, 1.D0 ) * evc(1:npw,ibnd+1) ) ! ELSE ! psic(nls(igk(1:npw))) = evc(1:npw,ibnd) psic(nlsm(igk(1:npw))) = CONJG( evc(1:npw,ibnd) ) ! END IF ! if(l_verbose) write(stdout,*) 'before' call flush_unit(stdout) CALL invfft ('Wave', psic, dffts) ! ! ! ... increment the charge density ... ! ! if(l_verbose) write(stdout,*) 'after' call flush_unit(stdout) tmpreal(:)= DBLE(psic(:)) CALL davcio( tmpreal,dffts%nnr,iunwfcreal,ibnd+(ispin-1)*nbnd,1) if(ibnd+1 <= nbnd) then tmpreal(:)=dimag(psic(:)) CALL davcio( tmpreal,dffts%nnr,iunwfcreal,ibnd+1+(ispin-1)*nbnd,1) endif ! END DO ! close(iunwfcreal) deallocate(tmpreal) ! END SUBROUTINE SUBROUTINE write_wfc_plot(itask) !save wannier functions on disk for plotting USE io_files, ONLY : nwordwfc, diropn USE wavefunctions_module, ONLY : evc implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER, INTENT(in) :: itask!0 save MLWF, 1 save ULWF INTEGER :: iunplot LOGICAL :: exst iunplot=find_free_unit() if(itask==0) then CALL diropn( iunplot, 'wfc_mlwf', nwordwfc, exst ) else CALL diropn( iunplot, 'wfc_ulwf', nwordwfc, exst ) endif CALL davcio(evc,2*nwordwfc,iunplot,1,1) close(iunplot) return END SUBROUTINE write_wfc_plot GWW/pw4gww/make.depend0000644000077300007730000004204112341332532015346 0ustar giannozzgiannozzallocate_wannier.o : ../../Modules/uspp.o allocate_wannier.o : ../../Modules/wannier_gw.o allocate_wannier.o : ../../PW/src/pwcom.o calculate_wing.o : ../../Modules/cell_base.o calculate_wing.o : ../../Modules/constants.o calculate_wing.o : ../../Modules/fft_base.o calculate_wing.o : ../../Modules/io_files.o calculate_wing.o : ../../Modules/io_global.o calculate_wing.o : ../../Modules/kind.o calculate_wing.o : ../../Modules/mp.o calculate_wing.o : ../../Modules/mp_global.o calculate_wing.o : ../../Modules/mp_wave.o calculate_wing.o : ../../Modules/mp_world.o calculate_wing.o : ../../Modules/recvec.o calculate_wing.o : ../../Modules/wannier_gw.o calculate_wing.o : ../../PW/src/pwcom.o cgsolve_all_gamma.o : ../../Modules/control_flags.o cgsolve_all_gamma.o : ../../Modules/kind.o cgsolve_all_gamma.o : ../../Modules/mp.o cgsolve_all_gamma.o : ../../Modules/mp_global.o cgsolve_all_gamma.o : ../../Modules/recvec.o contour_terms.o : ../../Modules/io_files.o contour_terms.o : ../../Modules/io_global.o contour_terms.o : ../../Modules/kind.o contour_terms.o : ../../Modules/mp.o contour_terms.o : ../../Modules/mp_world.o contour_terms.o : ../../Modules/recvec.o contour_terms.o : ../../Modules/wannier_gw.o contour_terms.o : ../../Modules/wavefunctions.o contour_terms.o : ../../PW/src/pwcom.o dft_exchange.o : ../../Modules/cell_base.o dft_exchange.o : ../../Modules/constants.o dft_exchange.o : ../../Modules/control_flags.o dft_exchange.o : ../../Modules/fft_base.o dft_exchange.o : ../../Modules/fft_interfaces.o dft_exchange.o : ../../Modules/io_files.o dft_exchange.o : ../../Modules/io_global.o dft_exchange.o : ../../Modules/ions_base.o dft_exchange.o : ../../Modules/kind.o dft_exchange.o : ../../Modules/mp.o dft_exchange.o : ../../Modules/mp_global.o dft_exchange.o : ../../Modules/mp_world.o dft_exchange.o : ../../Modules/recvec.o dft_exchange.o : ../../Modules/uspp.o dft_exchange.o : ../../Modules/wannier_gw.o dft_exchange.o : ../../Modules/wavefunctions.o dft_exchange.o : ../../PW/src/atomic_wfc_mod.o dft_exchange.o : ../../PW/src/pwcom.o dft_exchange.o : ../../PW/src/scf_mod.o diago_cg.o : ../../Modules/constants.o diago_cg.o : ../../Modules/io_global.o diago_cg.o : ../../Modules/kind.o diago_cg.o : ../../Modules/mp.o diago_cg.o : ../../Modules/mp_world.o diago_cg.o : ../../Modules/random_numbers.o diago_cg_g.o : ../../Modules/constants.o diago_cg_g.o : ../../Modules/io_global.o diago_cg_g.o : ../../Modules/kind.o diago_cg_g.o : ../../Modules/mp.o diago_cg_g.o : ../../Modules/mp_world.o diago_cg_g.o : ../../Modules/random_numbers.o energies_xc.o : ../../Modules/becmod.o energies_xc.o : ../../Modules/cell_base.o energies_xc.o : ../../Modules/constants.o energies_xc.o : ../../Modules/control_flags.o energies_xc.o : ../../Modules/fft_base.o energies_xc.o : ../../Modules/fft_interfaces.o energies_xc.o : ../../Modules/funct.o energies_xc.o : ../../Modules/io_files.o energies_xc.o : ../../Modules/io_global.o energies_xc.o : ../../Modules/kind.o energies_xc.o : ../../Modules/mp.o energies_xc.o : ../../Modules/mp_world.o energies_xc.o : ../../Modules/recvec.o energies_xc.o : ../../Modules/uspp.o energies_xc.o : ../../Modules/wannier_gw.o energies_xc.o : ../../Modules/wavefunctions.o energies_xc.o : ../../PW/src/exx.o energies_xc.o : ../../PW/src/ldaU.o energies_xc.o : ../../PW/src/pwcom.o energies_xc.o : ../../PW/src/scf_mod.o exchange_custom.o : ../../Modules/cell_base.o exchange_custom.o : ../../Modules/constants.o exchange_custom.o : ../../Modules/io_files.o exchange_custom.o : ../../Modules/io_global.o exchange_custom.o : ../../Modules/kind.o exchange_custom.o : ../../Modules/mp.o exchange_custom.o : ../../Modules/mp_global.o exchange_custom.o : ../../Modules/mp_pools.o exchange_custom.o : ../../Modules/mp_wave.o exchange_custom.o : ../../Modules/mp_world.o exchange_custom.o : ../../Modules/recvec.o exchange_custom.o : ../../Modules/wavefunctions.o exchange_custom.o : ../../PW/src/pwcom.o exchange_custom.o : fft_custom.o fake_conduction.o : ../../Modules/becmod.o fake_conduction.o : ../../Modules/cell_base.o fake_conduction.o : ../../Modules/constants.o fake_conduction.o : ../../Modules/fft_base.o fake_conduction.o : ../../Modules/io_files.o fake_conduction.o : ../../Modules/io_global.o fake_conduction.o : ../../Modules/kind.o fake_conduction.o : ../../Modules/mp.o fake_conduction.o : ../../Modules/mp_pools.o fake_conduction.o : ../../Modules/mp_wave.o fake_conduction.o : ../../Modules/mp_world.o fake_conduction.o : ../../Modules/noncol.o fake_conduction.o : ../../Modules/recvec.o fake_conduction.o : ../../Modules/uspp.o fake_conduction.o : ../../Modules/wannier_gw.o fake_conduction.o : ../../Modules/wavefunctions.o fake_conduction.o : ../../PW/src/g_psi_mod.o fake_conduction.o : ../../PW/src/pwcom.o fake_conduction.o : fft_custom.o fake_conduction.o : mp_wave_parallel.o fft_custom.o : ../../Modules/cell_base.o fft_custom.o : ../../Modules/constants.o fft_custom.o : ../../Modules/control_flags.o fft_custom.o : ../../Modules/fft_base.o fft_custom.o : ../../Modules/fft_parallel.o fft_custom.o : ../../Modules/fft_scalar.o fft_custom.o : ../../Modules/fft_types.o fft_custom.o : ../../Modules/io_global.o fft_custom.o : ../../Modules/kind.o fft_custom.o : ../../Modules/mp.o fft_custom.o : ../../Modules/mp_global.o fft_custom.o : ../../Modules/mp_world.o fft_custom.o : ../../Modules/parallel_include.o fft_custom.o : ../../Modules/recvec.o fft_custom.o : ../../Modules/stick_base.o fft_custom.o : ../../PW/src/pwcom.o full.o : ../../Modules/cell_base.o full.o : ../../Modules/constants.o full.o : ../../Modules/fft_base.o full.o : ../../Modules/fft_interfaces.o full.o : ../../Modules/io_files.o full.o : ../../Modules/io_global.o full.o : ../../Modules/kind.o full.o : ../../Modules/mp.o full.o : ../../Modules/mp_pools.o full.o : ../../Modules/mp_wave.o full.o : ../../Modules/mp_world.o full.o : ../../Modules/recvec.o full.o : ../../Modules/wannier_gw.o full.o : ../../Modules/wavefunctions.o full.o : ../../PW/src/pwcom.o hpsi_pw4gww.o : ../../Modules/kind.o hpsi_pw4gww.o : ../../Modules/mp.o hpsi_pw4gww.o : ../../Modules/mp_world.o hpsi_pw4gww.o : ../../PW/src/pwcom.o matrix_wannier_gamma.o : ../../Modules/cell_base.o matrix_wannier_gamma.o : ../../Modules/constants.o matrix_wannier_gamma.o : ../../Modules/fft_base.o matrix_wannier_gamma.o : ../../Modules/io_files.o matrix_wannier_gamma.o : ../../Modules/io_global.o matrix_wannier_gamma.o : ../../Modules/ions_base.o matrix_wannier_gamma.o : ../../Modules/kind.o matrix_wannier_gamma.o : ../../Modules/mp.o matrix_wannier_gamma.o : ../../Modules/mp_global.o matrix_wannier_gamma.o : ../../Modules/mp_world.o matrix_wannier_gamma.o : ../../Modules/recvec.o matrix_wannier_gamma.o : ../../Modules/uspp.o matrix_wannier_gamma.o : ../../Modules/wannier_gw.o matrix_wannier_gamma.o : ../../PW/src/pwcom.o mp_wave_parallel.o : ../../Modules/io_global.o mp_wave_parallel.o : ../../Modules/kind.o mp_wave_parallel.o : ../../Modules/parallel_include.o o_1psi.o : ../../Modules/becmod.o o_1psi.o : ../../Modules/cell_base.o o_1psi.o : ../../Modules/constants.o o_1psi.o : ../../Modules/fft_base.o o_1psi.o : ../../Modules/fft_interfaces.o o_1psi.o : ../../Modules/io_files.o o_1psi.o : ../../Modules/io_global.o o_1psi.o : ../../Modules/kind.o o_1psi.o : ../../Modules/mp.o o_1psi.o : ../../Modules/mp_global.o o_1psi.o : ../../Modules/mp_world.o o_1psi.o : ../../Modules/random_numbers.o o_1psi.o : ../../Modules/recvec.o o_1psi.o : ../../Modules/uspp.o o_1psi.o : ../../Modules/wannier_gw.o o_1psi.o : ../../Modules/wavefunctions.o o_1psi.o : ../../PW/src/g_psi_mod.o o_1psi.o : ../../PW/src/pwcom.o o_bands.o : ../../Modules/becmod.o o_bands.o : ../../Modules/cell_base.o o_bands.o : ../../Modules/constants.o o_bands.o : ../../Modules/control_flags.o o_bands.o : ../../Modules/fft_base.o o_bands.o : ../../Modules/io_files.o o_bands.o : ../../Modules/io_global.o o_bands.o : ../../Modules/kind.o o_bands.o : ../../Modules/mp.o o_bands.o : ../../Modules/mp_world.o o_bands.o : ../../Modules/recvec.o o_bands.o : ../../Modules/uspp.o o_bands.o : ../../Modules/wannier_gw.o o_bands.o : ../../PW/src/g_psi_mod.o o_bands.o : ../../PW/src/pwcom.o o_rinitcgg.o : ../../Modules/fft_base.o o_rinitcgg.o : ../../Modules/io_global.o o_rinitcgg.o : ../../Modules/kind.o o_rinitcgg.o : ../../Modules/mp.o o_rinitcgg.o : ../../Modules/mp_world.o o_rinitcgg.o : ../../Modules/recvec.o openfil_pw4gww.o : ../../Modules/control_flags.o openfil_pw4gww.o : ../../Modules/io_files.o openfil_pw4gww.o : ../../Modules/ions_base.o openfil_pw4gww.o : ../../Modules/kind.o openfil_pw4gww.o : ../../Modules/noncol.o openfil_pw4gww.o : ../../Modules/uspp.o openfil_pw4gww.o : ../../PW/src/atomic_wfc_mod.o openfil_pw4gww.o : ../../PW/src/ldaU.o openfil_pw4gww.o : ../../PW/src/pwcom.o optimal.o : ../../Modules/io_global.o optimal.o : ../../Modules/kind.o optimal.o : ../../Modules/mp.o optimal.o : ../../Modules/mp_world.o optimal.o : ../../Modules/recvec.o optimal.o : ../../Modules/wannier_gw.o optimal.o : ../../PW/src/pwcom.o pola_lanczos.o : ../../Modules/becmod.o pola_lanczos.o : ../../Modules/cell_base.o pola_lanczos.o : ../../Modules/constants.o pola_lanczos.o : ../../Modules/fft_base.o pola_lanczos.o : ../../Modules/fft_interfaces.o pola_lanczos.o : ../../Modules/io_files.o pola_lanczos.o : ../../Modules/io_global.o pola_lanczos.o : ../../Modules/kind.o pola_lanczos.o : ../../Modules/mp.o pola_lanczos.o : ../../Modules/mp_pools.o pola_lanczos.o : ../../Modules/mp_wave.o pola_lanczos.o : ../../Modules/mp_world.o pola_lanczos.o : ../../Modules/noncol.o pola_lanczos.o : ../../Modules/recvec.o pola_lanczos.o : ../../Modules/uspp.o pola_lanczos.o : ../../Modules/wannier_gw.o pola_lanczos.o : ../../Modules/wavefunctions.o pola_lanczos.o : ../../PW/src/g_psi_mod.o pola_lanczos.o : ../../PW/src/pwcom.o pola_lanczos.o : fft_custom.o pola_partial.o : ../../Modules/cell_base.o pola_partial.o : ../../Modules/constants.o pola_partial.o : ../../Modules/fft_base.o pola_partial.o : ../../Modules/fft_interfaces.o pola_partial.o : ../../Modules/io_files.o pola_partial.o : ../../Modules/io_global.o pola_partial.o : ../../Modules/kind.o pola_partial.o : ../../Modules/mp.o pola_partial.o : ../../Modules/mp_pools.o pola_partial.o : ../../Modules/mp_wave.o pola_partial.o : ../../Modules/mp_world.o pola_partial.o : ../../Modules/recvec.o pola_partial.o : ../../Modules/wannier_gw.o pola_partial.o : ../../Modules/wavefunctions.o pola_partial.o : ../../PW/src/pwcom.o pola_partial.o : fft_custom.o produce_wannier_gamma.o : ../../Modules/constants.o produce_wannier_gamma.o : ../../Modules/fft_base.o produce_wannier_gamma.o : ../../Modules/funct.o produce_wannier_gamma.o : ../../Modules/io_files.o produce_wannier_gamma.o : ../../Modules/io_global.o produce_wannier_gamma.o : ../../Modules/mp.o produce_wannier_gamma.o : ../../Modules/mp_world.o produce_wannier_gamma.o : ../../Modules/recvec.o produce_wannier_gamma.o : ../../Modules/wannier_gw.o produce_wannier_gamma.o : ../../Modules/wavefunctions.o produce_wannier_gamma.o : ../../PW/src/exx.o produce_wannier_gamma.o : ../../PW/src/ldaU.o produce_wannier_gamma.o : ../../PW/src/pwcom.o produce_wannier_gamma.o : ../../PW/src/scf_mod.o produce_wannier_gamma.o : exchange_custom.o produce_wannier_gamma.o : fake_conduction.o produce_wannier_gamma.o : fft_custom.o pw4gww.o : ../../Modules/becmod.o pw4gww.o : ../../Modules/constants.o pw4gww.o : ../../Modules/control_flags.o pw4gww.o : ../../Modules/fft_base.o pw4gww.o : ../../Modules/io_files.o pw4gww.o : ../../Modules/io_global.o pw4gww.o : ../../Modules/ions_base.o pw4gww.o : ../../Modules/kind.o pw4gww.o : ../../Modules/mp.o pw4gww.o : ../../Modules/mp_pools.o pw4gww.o : ../../Modules/mp_world.o pw4gww.o : ../../Modules/recvec.o pw4gww.o : ../../Modules/uspp.o pw4gww.o : ../../Modules/wannier_gw.o pw4gww.o : ../../Modules/wavefunctions.o pw4gww.o : ../../PW/src/atomic_wfc_mod.o pw4gww.o : ../../PW/src/ldaU.o pw4gww.o : ../../PW/src/pwcom.o pw4gww.o : ../../PW/src/scf_mod.o pw4gww.o : ../../iotk/src/iotk_module.o pw4gww.o : exchange_custom.o rotate_wannier.o : ../../Modules/cell_base.o rotate_wannier.o : ../../Modules/constants.o rotate_wannier.o : ../../Modules/io_files.o rotate_wannier.o : ../../Modules/kind.o rotate_wannier.o : ../../Modules/recvec.o rotate_wannier.o : ../../Modules/wavefunctions.o rotate_wannier.o : ../../PW/src/atomic_wfc_mod.o rotate_wannier.o : ../../PW/src/pwcom.o self_lanczos.o : ../../Modules/cell_base.o self_lanczos.o : ../../Modules/constants.o self_lanczos.o : ../../Modules/fft_base.o self_lanczos.o : ../../Modules/fft_interfaces.o self_lanczos.o : ../../Modules/io_files.o self_lanczos.o : ../../Modules/io_global.o self_lanczos.o : ../../Modules/kind.o self_lanczos.o : ../../Modules/mp.o self_lanczos.o : ../../Modules/mp_pools.o self_lanczos.o : ../../Modules/mp_wave.o self_lanczos.o : ../../Modules/mp_world.o self_lanczos.o : ../../Modules/parallel_include.o self_lanczos.o : ../../Modules/recvec.o self_lanczos.o : ../../Modules/wannier_gw.o self_lanczos.o : ../../Modules/wavefunctions.o self_lanczos.o : ../../PW/src/pwcom.o self_lanczos.o : fft_custom.o semicore.o : ../../Modules/fft_base.o semicore.o : ../../Modules/fft_interfaces.o semicore.o : ../../Modules/io_files.o semicore.o : ../../Modules/io_global.o semicore.o : ../../Modules/kind.o semicore.o : ../../Modules/mp.o semicore.o : ../../Modules/mp_pools.o semicore.o : ../../Modules/mp_wave.o semicore.o : ../../Modules/mp_world.o semicore.o : ../../Modules/recvec.o semicore.o : ../../Modules/wavefunctions.o semicore.o : ../../PW/src/pwcom.o semicore_read.o : ../../Modules/cell_base.o semicore_read.o : ../../Modules/constants.o semicore_read.o : ../../Modules/fft_base.o semicore_read.o : ../../Modules/fft_interfaces.o semicore_read.o : ../../Modules/io_files.o semicore_read.o : ../../Modules/io_global.o semicore_read.o : ../../Modules/kind.o semicore_read.o : ../../Modules/mp.o semicore_read.o : ../../Modules/mp_global.o semicore_read.o : ../../Modules/mp_wave.o semicore_read.o : ../../Modules/mp_world.o semicore_read.o : ../../Modules/recvec.o semicore_read.o : ../../Modules/wannier_gw.o semicore_read.o : ../../Modules/wavefunctions.o semicore_read.o : ../../PW/src/pwcom.o start_pw4gww.o : ../../Modules/environment.o start_pw4gww.o : ../../Modules/mp_global.o stop_pp.o : ../../Modules/control_flags.o stop_pp.o : ../../Modules/io_files.o stop_pp.o : ../../Modules/mp_global.o stop_pp.o : ../../Modules/parallel_include.o v_basis.o : ../../Modules/cell_base.o v_basis.o : ../../Modules/constants.o v_basis.o : ../../Modules/io_global.o v_basis.o : ../../Modules/kind.o v_basis.o : ../../Modules/mp.o v_basis.o : ../../Modules/mp_world.o v_basis.o : ../../Modules/recvec.o v_basis.o : ../../Modules/wannier_gw.o v_basis.o : ../../PW/src/exx.o v_basis.o : ../../PW/src/pwcom.o wannier.o : ../../Modules/cell_base.o wannier.o : ../../Modules/constants.o wannier.o : ../../Modules/control_flags.o wannier.o : ../../Modules/io_files.o wannier.o : ../../Modules/io_global.o wannier.o : ../../Modules/kind.o wannier.o : ../../Modules/mp.o wannier.o : ../../Modules/mp_world.o wannier.o : ../../Modules/recvec.o wannier.o : ../../Modules/wannier_gw.o wannier.o : ../../Modules/wavefunctions.o wannier.o : ../../PW/src/atomic_wfc_mod.o wannier.o : ../../PW/src/pwcom.o wannier_bse.o : ../../Modules/cell_base.o wannier_bse.o : ../../Modules/constants.o wannier_bse.o : ../../Modules/io_files.o wannier_bse.o : ../../Modules/io_global.o wannier_bse.o : ../../Modules/kind.o wannier_bse.o : ../../Modules/mp.o wannier_bse.o : ../../Modules/mp_pools.o wannier_bse.o : ../../Modules/mp_wave.o wannier_bse.o : ../../Modules/mp_world.o wannier_bse.o : ../../Modules/recvec.o wannier_bse.o : ../../Modules/wannier_gw.o wannier_bse.o : ../../Modules/wavefunctions.o wannier_bse.o : ../../PW/src/pwcom.o wannier_bse.o : fft_custom.o wannier_uterms.o : ../../Modules/cell_base.o wannier_uterms.o : ../../Modules/constants.o wannier_uterms.o : ../../Modules/control_flags.o wannier_uterms.o : ../../Modules/io_files.o wannier_uterms.o : ../../Modules/io_global.o wannier_uterms.o : ../../Modules/kind.o wannier_uterms.o : ../../Modules/mp.o wannier_uterms.o : ../../Modules/mp_pools.o wannier_uterms.o : ../../Modules/mp_world.o wannier_uterms.o : ../../Modules/recvec.o wannier_uterms.o : ../../Modules/wannier_gw.o wannier_uterms.o : ../../PW/src/atomic_wfc_mod.o wannier_uterms.o : ../../PW/src/pwcom.o wfc_real.o : ../../Modules/control_flags.o wfc_real.o : ../../Modules/fft_base.o wfc_real.o : ../../Modules/fft_interfaces.o wfc_real.o : ../../Modules/io_files.o wfc_real.o : ../../Modules/io_global.o wfc_real.o : ../../Modules/kind.o wfc_real.o : ../../Modules/mp.o wfc_real.o : ../../Modules/recvec.o wfc_real.o : ../../Modules/uspp.o wfc_real.o : ../../Modules/wannier_gw.o wfc_real.o : ../../Modules/wavefunctions.o wfc_real.o : ../../PW/src/pwcom.o write_vpot_matrix.o : ../../Modules/io_files.o write_vpot_matrix.o : ../../Modules/io_global.o write_vpot_matrix.o : ../../Modules/kind.o write_vpot_matrix.o : ../../Modules/wannier_gw.o write_wannier_matrix.o : ../../Modules/io_files.o write_wannier_matrix.o : ../../Modules/io_global.o write_wannier_matrix.o : ../../Modules/kind.o write_wannier_matrix.o : ../../Modules/mp.o write_wannier_matrix.o : ../../Modules/mp_world.o write_wannier_matrix.o : ../../Modules/wannier_gw.o write_wannier_matrix.o : ../../PW/src/pwcom.o GWW/pw4gww/calculate_wing.f900000644000077300007730000002205512341332532016554 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! subroutine calculate_wing(n_set, orthonorm) !this subroutine calculate the terms !\Sum_G \epsilon(G'=0, G, iw) ! it requires the file .e_head USE io_global, ONLY : stdout, ionode, ionode_id USE io_files, ONLY : prefix, tmp_dir, diropn USE kinds, ONLY : DP USE wannier_gw USE mp, ONLY : mp_bcast, mp_sum USE gvect, ONLY : mill, ngm, gstart,g,ngm_g, ig_l2g USE cell_base, ONLY : tpiba USE mp_wave, ONLY : mergewf,splitwf USE mp_global, ONLY : intra_pool_comm USE mp_world, ONLY : mpime, nproc, world_comm USE wvfct, ONLY : npwx, npw USE cell_base, ONLY : at,bg implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER, INTENT(in) :: n_set !defines the number of states to be read from disk at the same time INTEGER, INTENT(in) :: orthonorm!if ==1 opens orthonormalized products of wannier file, if ==2 reduced one INTEGER iun, iungprod INTEGER :: n_g, ngm_k INTEGER :: ig, igg, iw, iiw, i, ii, ipol REAL(kind=DP) :: omega_g REAL(kind=DP), ALLOCATABLE :: freqs(:) COMPLEX(kind=DP), ALLOCATABLE :: e_head(:,:,:), e_head_g0(:) LOGICAL :: exst COMPLEX(kind=DP), ALLOCATABLE :: tmpspacei(:,:) REAL(kind=DP), ALLOCATABLE :: wing(:,:,:), wing_c(:,:,:) REAL(kind=DP) :: sca REAL(kind=DP), ALLOCATABLE :: fact(:) REAL(kind=DP) :: qq INTEGER :: npwx_g INTEGER, ALLOCATABLE :: k2g_ig_l2g(:) npwx_g=npwx call mp_sum(npwx_g,world_comm) !read file .e_head write(stdout,*) 'Routine calculate_wing' call flush_unit(stdout) allocate(fact(ngm)) allocate(k2g_ig_l2g(ngm)) fact(:)=0.d0 if(gstart==2) fact(1)=0.d0 do ig=gstart,npw ! qq = g(1,ig)**2.d0 + g(2,ig)**2.d0 + g(3,ig)**2.d0 ! fact(ig)=1.d0/tpiba/dsqrt(qq) fact(ig)=dsqrt(vg_q(ig)) end do call ktogamma_ig_l2g ( k2g_ig_l2g, at, bg ) write(stdout,*) 'ATT0.1' call flush_unit(stdout) if(ionode) then iun = find_free_unit() open( unit= iun, file=trim(tmp_dir)//'/_ph0/'//trim(prefix)//'.e_head', status='old',form='unformatted') read(iun) n_g read(iun) omega_g endif call mp_bcast(n_g, ionode_id,world_comm) call mp_bcast(omega_g, ionode_id,world_comm) allocate(freqs(n_g+1)) if(ionode) then read(iun) freqs(1:n_g+1) read(iun) ngm_k endif write(stdout,*) 'ATT0.2' call flush_unit(stdout) call mp_bcast(freqs(:), ionode_id,world_comm) call mp_bcast(ngm_k, ionode_id,world_comm) allocate(e_head_g0(ngm_k)) allocate(e_head(npw, n_g+1,3)) e_head(:,:,:) = (0.d0,0.d0) do ipol=1,3 do ii=1,n_g+1 e_head_g0(:)=(0.d0,0.d0) if(ionode) read(iun) e_head_g0(1:ngm_k) ! sca=0.d0 ! do ig=1,ngm_k ! sca=sca+dble(e_head_g0(ig)*conjg(e_head_g0(ig))) ! enddo ! call mp_sum(sca,world_comm) ! write(stdout,*) 'POLA SCA0',ii, sca,ngm_k call splitwf(e_head(:, ii,ipol),e_head_g0,npw,k2g_ig_l2g,mpime,nproc,ionode_id,intra_pool_comm) ! sca=0.d0 ! do ig=1,npw ! sca=sca+2.d0*dble(e_head(ig, ii,ipol)*conjg(e_head(ig, ii,ipol))) ! enddo ! if(gstart==2) sca=sca -dble(e_head(1, ii,ipol)*conjg(e_head(1, ii,ipol))) ! call mp_sum(sca,world_comm) ! write(stdout,*) 'POLA SCA',ii, sca,npw enddo enddo if(ionode) close(iun) write(stdout,*) 'ATT1' call flush_unit(stdout) deallocate(e_head_g0) !loop on n_set groups write(stdout,*) 'ATT2' call flush_unit(stdout) allocate(tmpspacei(max_ngm,n_set)) iungprod = find_free_unit() if(orthonorm==0) then CALL diropn( iungprod, 'wiwjwfc', max_ngm*2, exst ) else if(orthonorm==1) then CALL diropn( iungprod, 'wiwjwfc_on', max_ngm*2, exst ) else CALL diropn( iungprod, 'wiwjwfc_red', max_ngm*2, exst ) endif allocate(wing(numw_prod, n_g+1,3)) wing(:,:,:)=0.d0 !allocate(wing_c(numw_prod, n_g+1,3)) !wing_c(:,:,:)=0.d0 do iiw=1,ceiling(real(numw_prod)/real(n_set)) !read states do iw=(iiw-1)*n_set+1,min(iiw*n_set,numw_prod) CALL davcio(tmpspacei(:,iw-(iiw-1)*n_set),max_ngm*2,iungprod,iw,-1) enddo write(stdout,*) 'ATT3' call flush_unit(stdout) !loop on states do iw=(iiw-1)*n_set+1,min(iiw*n_set,numw_prod) do ipol=1,3 do i=1, n_g+1 sca=0.d0 do ig=1,max_ngm ! sca=sca+2.d0*real(tmpspacei(ig,iw-(iiw-1)*n_set)*conjg(e_head(ig,i,ipol)))*fact(ig) sca=sca+2.d0*dble((tmpspacei(ig,iw-(iiw-1)*n_set))*conjg(e_head(ig,i,ipol)))!*fact(ig)!ATTENZIONE enddo call mp_sum(sca,world_comm) wing(iw,i,ipol)=sca enddo enddo enddo enddo write(stdout,*) 'ATT4' call flush_unit(stdout) !write terms on file if(ionode) then iun = find_free_unit() open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.wing', status='unknown',form='unformatted') write(iun) n_g write(iun) omega_g write(iun) numw_prod do ipol=1,3 do i=1,n_g+1 write(iun) wing(1:numw_prod,i,ipol) enddo ! do i=1,n_g+1 ! write(iun) wing_c(1:numw_prod,i,ipol) ! enddo enddo close(iun) endif deallocate(tmpspacei) close(iungprod) deallocate(fact) deallocate(freqs) ! if(ionode) deallocate (e_head_g) deallocate(e_head) deallocate(wing) deallocate(k2g_ig_l2g) return end subroutine calculate_wing !----------------------------------------------------------------------- SUBROUTINE ktogamma_ig_l2g ( k2g_ig_l2g, at, bg ) !---------------------------------------------------------------------- ! ! This routine generates all the reciprocal lattice vectors ! contained in the sphere of radius gcutm. Furthermore it ! computes the indices nl which give the correspondence ! between the fft mesh points and the array of g vectors. ! USE gvect, ONLY : ig_l2g, g, gg, ngm, ngm_g, gcutm, & mill, nl, gstart USE fft_base, ONLY : dfftp, dffts ! USE kinds, ONLY : DP USE constants, ONLY : eps8 IMPLICIT NONE ! INTEGER, INTENT(out) :: k2g_ig_l2g(ngm) REAL(DP), INTENT(IN) :: at(3,3), bg(3,3) ! here a few local variables ! REAL(DP) :: t (3), tt INTEGER :: ngm_, n1, n2, n3, n1s, n2s, n3s ! REAL(DP), ALLOCATABLE :: g2sort_g(:) ! array containing all g vectors, on all processors: replicated data INTEGER, ALLOCATABLE :: mill_g(:,:), mill_unsorted(:,:) ! array containing all g vectors generators, on all processors: ! replicated data INTEGER, ALLOCATABLE :: igsrt(:) ! #ifdef __PARA INTEGER :: m1, m2, mc #endif INTEGER :: ni, nj, nk, i, j, k, ipol, ng, igl, indsw,ig ! ! counters ! ! set the total number of fft mesh points and and initial value of gg ! The choice of gcutm is due to the fact that we have to order the ! vectors after computing them. ! ! ! set d vector for unique ordering ! ! and computes all the g vectors inside a sphere ! ALLOCATE( mill_g( 3, ngm_g*3 ),mill_unsorted( 3, ngm_g*3 ) ) ALLOCATE( igsrt( ngm_g*3 ) ) ALLOCATE( g2sort_g( ngm_g*3 ) ) g2sort_g(:) = 1.0d20 ! ! save present value of ngm ! ! ngm_ = 0 ! ! max miller indices (same convention as in module stick_set) ! ni = (dfftp%nr1-1)/2 nj = (dfftp%nr2-1)/2 nk = (dfftp%nr3-1)/2 ! iloop: DO i = -ni, ni ! jloop: DO j = -nj, nj ! kloop: DO k = -nk, nk ! t(:) = i * bg (:,1) + j * bg (:,2) + k * bg (:,3) tt = sum(t(:)**2) IF (tt <= gcutm) THEN ngm_ = ngm_ + 1 mill_unsorted( :, ngm_ ) = (/ i,j,k /) IF ( tt > eps8 ) THEN g2sort_g(ngm_) = tt ELSE g2sort_g(ngm_) = 0.d0 ENDIF ENDIF ENDDO kloop ENDDO jloop ENDDO iloop igsrt(1) = 0 CALL hpsort_eps( ngm_, g2sort_g, igsrt, eps8 ) mill_g(1,1:ngm_) = mill_unsorted(1,igsrt(1:ngm_)) mill_g(2,1:ngm_) = mill_unsorted(2,igsrt(1:ngm_)) mill_g(3,1:ngm_) = mill_unsorted(3,igsrt(1:ngm_)) DEALLOCATE( g2sort_g, igsrt, mill_unsorted ) do ig=1,ngm do ng=1,ngm_ if(mill_g(1,ng)==mill(1,ig).and.mill_g(2,ng)==mill(2,ig).and.mill_g(3,ng)==mill(3,ig)) then k2g_ig_l2g(ig)=ng exit endif enddo enddo ! DEALLOCATE( mill_g ) END SUBROUTINE ktogamma_ig_l2g GWW/pw4gww/write_wannier_matrix.f900000644000077300007730000001004712341332532020032 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! subroutine write_wannier_matrix(e_xc,e_h, ispin) !this subroutine writes the inverse transfromation matrix from KS eigenstates !to ML wanniers on file, to be read by GWW code !the INVERSE matrix is calculated here USE kinds, ONLY : DP USE wannier_gw, ONLY : u_trans, num_nbndv, l_selfconsistent,ene_gw,delta_self,n_gw_states USE wvfct, ONLY : et,nbnd USE io_global, ONLY : stdout USE io_files, ONLY : prefix, tmp_dir USE lsda_mod, ONLY : nspin implicit none INTEGER, EXTERNAL :: find_free_unit REAL(kind=DP) :: e_xc(nbnd,nspin)!exchange and correlation energies REAL(kind=DP) :: e_h(nbnd,nspin)!hartree energies INTEGER, INTENT(in) :: ispin!spin channel COMPLEX(kind=DP) :: sca INTEGER :: iunu, iw,jw INTEGER :: ivpt(nbnd), info COMPLEX(kind=DP) :: cdet(2),det COMPLEX(kind=DP), ALLOCATABLE :: cdwork(:) REAL(kind=DP), ALLOCATABLE :: et_new(:) INTEGER :: is do iw=1,nbnd do jw=iw,nbnd sca=u_trans(iw,jw,ispin) u_trans(iw,jw,ispin)=conjg(u_trans(jw,iw,ispin)) u_trans(jw,iw,ispin)=conjg(sca) enddo enddo iunu = find_free_unit() open(unit=iunu,file=trim(tmp_dir)//trim(prefix)//'.wannier',status='unknown',form='unformatted') write(iunu) nspin write(iunu) nbnd do is=1,nspin write(iunu) num_nbndv(is) if(.not.l_selfconsistent) then write(iunu) et(1:nbnd,is) else allocate(et_new(nbnd)) et_new(1:n_gw_states)=ene_gw(1:n_gw_states,is) if(nbnd>n_gw_states) et_new(n_gw_states+1:nbnd)=et(n_gw_states+1:nbnd,is)+delta_self write(iunu) et_new(1:nbnd) deallocate(et_new) endif if(l_selfconsistent) e_xc(:,is)=0.d0 write(iunu) e_xc(1:nbnd,is) write(iunu) e_h(1:nbnd,is) do iw=1,nbnd write(iunu) u_trans(1:nbnd,iw,is) enddo enddo close(iunu) return end subroutine subroutine read_wannier_matrix !this read the inverse transfromation matrix from KS eigenstates !to ML wanniers on file, to be read by GWW code !the INVERSE matrix is calculated here USE kinds, ONLY : DP USE wannier_gw, ONLY : u_trans, num_nbndv USE wvfct, ONLY : et,nbnd USE io_global, ONLY : stdout,ionode,ionode_id USE io_files, ONLY : prefix, tmp_dir USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE lsda_mod, ONLY :nspin implicit none INTEGER, EXTERNAL :: find_free_unit INTEGER :: iunu, iw, is INTEGER :: idumm REAL(kind=DP), ALLOCATABLE :: rdummv(:) allocate(rdummv(nbnd)) if(ionode) then iunu = find_free_unit() open(unit=iunu,file=trim(tmp_dir)//trim(prefix)//'.wannier',status='old',form='unformatted') read(iunu) idumm read(iunu) idumm endif do is=1,nspin if(ionode) then read(iunu) idumm read(iunu) rdummv(1:nbnd) read(iunu) rdummv(1:nbnd) read(iunu) rdummv(1:nbnd) endif do iw=1,nbnd if(ionode) read(iunu) u_trans(1:nbnd,iw,is) call mp_bcast(u_trans(1:nbnd,iw,is),ionode_id,world_comm) enddo enddo if(ionode) close(iunu) deallocate(rdummv) return end subroutine read_wannier_matrix GWW/examples/0000755000077300007730000000000012341332543013630 5ustar giannozzgiannozzGWW/examples/example02/0000755000077300007730000000000012341332543015425 5ustar giannozzgiannozzGWW/examples/example02/si_pw4gww.in0000755000077300007730000000025412341332532017711 0ustar giannozzgiannozz&inputpw4gww prefix='si' num_nbndv(1)=16 num_nbnds=32 l_truncated_coulomb=.false. numw_prod=100 pmat_cutoff=3d0 s_self_lanczos=1d-8 / GWW/examples/example02/si_head.in0000755000077300007730000000035712341332532017357 0ustar giannozzgiannozzcalculation of head &inputph trans=.false. l_head=.true. tr2_ph=1.d-4, prefix='si', omega_gauss=20.0 n_gauss=97 grid_type=5 second_grid_i=1 second_grid_n=10 niter_ph=1 nsteps_lanczos=30 outdir='./' / 0.0 0.0 0.0 GWW/examples/example02/Si.pz-vbc.UPF0000755000077300007730000017736312341332532017576 0ustar giannozzgiannozz Generated using unknown code Author: von Barth and Car Generation date: before 1984 Info: Si LDA 3s2 3p2 VonBarth-Car, l=2 local 0 The Pseudo was generated with a Non-Relativistic Calculation 0.00000000000E+00 Local Potential cutoff radius nl pn l occ Rcut Rcut US E pseu 3S 0 0 2.00 0.00000000000 0.00000000000 0.00000000000 3P 0 1 2.00 0.00000000000 0.00000000000 0.00000000000 0 Version Number Si Element NC Norm - Conserving pseudopotential F Nonlinear Core Correction SLA PZ NOGX NOGC PZ Exchange-Correlation functional 4.00000000000 Z valence 0.00000000000 Total energy 0.0000000 0.0000000 Suggested cutoff for wfc and rho 1 Max angular momentum component 431 Number of points in mesh 2 2 Number of Wavefunctions, Number of Projectors Wavefunctions nl l occ 3S 0 2.00 3P 1 2.00 1.30825992062E-03 1.34137867819E-03 1.37533584110E-03 1.41015263368E-03 1.44585081756E-03 1.48245270526E-03 1.51998117417E-03 1.55845968079E-03 1.59791227544E-03 1.63836361728E-03 1.67983898971E-03 1.72236431620E-03 1.76596617645E-03 1.81067182305E-03 1.85650919848E-03 1.90350695260E-03 1.95169446052E-03 2.00110184102E-03 2.05175997530E-03 2.10370052636E-03 2.15695595874E-03 2.21155955880E-03 2.26754545558E-03 2.32494864208E-03 2.38380499717E-03 2.44415130798E-03 2.50602529292E-03 2.56946562524E-03 2.63451195723E-03 2.70120494495E-03 2.76958627369E-03 2.83969868402E-03 2.91158599845E-03 2.98529314892E-03 3.06086620479E-03 3.13835240167E-03 3.21780017097E-03 3.29925917012E-03 3.38278031365E-03 3.46841580500E-03 3.55621916913E-03 3.64624528601E-03 3.73855042489E-03 3.83319227948E-03 3.93023000403E-03 4.02972425027E-03 4.13173720535E-03 4.23633263067E-03 4.34357590180E-03 4.45353404926E-03 4.56627580048E-03 4.68187162272E-03 4.80039376712E-03 4.92191631390E-03 5.04651521860E-03 5.17426835959E-03 5.30525558674E-03 5.43955877133E-03 5.57726185723E-03 5.71845091334E-03 5.86321418742E-03 6.01164216124E-03 6.16382760710E-03 6.31986564586E-03 6.47985380639E-03 6.64389208648E-03 6.81208301540E-03 6.98453171795E-03 7.16134598020E-03 7.34263631681E-03 7.52851604013E-03 7.71910133106E-03 7.91451131160E-03 8.11486811934E-03 8.32029698382E-03 8.53092630477E-03 8.74688773236E-03 8.96831624951E-03 9.19535025627E-03 9.42813165627E-03 9.66680594547E-03 9.91152230307E-03 1.01624336848E-02 1.04196969183E-02 1.06834728016E-02 1.09539262032E-02 1.12312261653E-02 1.15155460093E-02 1.18070634444E-02 1.21059606785E-02 1.24124245322E-02 1.27266465552E-02 1.30488231466E-02 1.33791556773E-02 1.37178506158E-02 1.40651196574E-02 1.44211798568E-02 1.47862537629E-02 1.51605695591E-02 1.55443612047E-02 1.59378685820E-02 1.63413376461E-02 1.67550205781E-02 1.71791759435E-02 1.76140688530E-02 1.80599711289E-02 1.85171614747E-02 1.89859256492E-02 1.94665566453E-02 1.99593548730E-02 2.04646283472E-02 2.09826928803E-02 2.15138722794E-02 2.20584985491E-02 2.26169120985E-02 2.31894619542E-02 2.37765059784E-02 2.43784110929E-02 2.49955535079E-02 2.56283189576E-02 2.62771029408E-02 2.69423109688E-02 2.76243588182E-02 2.83236727911E-02 2.90406899815E-02 2.97758585485E-02 3.05296379963E-02 3.13024994618E-02 3.20949260084E-02 3.29074129285E-02 3.37404680529E-02 3.45946120682E-02 3.54703788422E-02 3.63683157577E-02 3.72889840544E-02 3.82329591799E-02 3.92008311496E-02 4.01932049148E-02 4.12107007415E-02 4.22539545976E-02 4.33236185509E-02 4.44203611761E-02 4.55448679730E-02 4.66978417950E-02 4.78800032883E-02 4.90920913422E-02 5.03348635513E-02 5.16090966887E-02 5.29155871916E-02 5.42551516589E-02 5.56286273622E-02 5.70368727685E-02 5.84807680770E-02 5.99612157692E-02 6.14791411732E-02 6.30354930418E-02 6.46312441454E-02 6.62673918806E-02 6.79449588929E-02 6.96649937163E-02 7.14285714286E-02 7.32367943232E-02 7.50907925983E-02 7.69917250632E-02 7.89407798625E-02 8.09391752191E-02 8.29881601949E-02 8.50890154723E-02 8.72430541543E-02 8.94516225851E-02 9.17161011920E-02 9.40379053477E-02 9.64184862554E-02 9.88593318558E-02 1.01361967757E-01 1.03927958187E-01 1.06558906974E-01 1.09256458547E-01 1.12022298964E-01 1.14858156963E-01 1.17765805050E-01 1.20747060599E-01 1.23803786991E-01 1.26937894780E-01 1.30151342885E-01 1.33446139817E-01 1.36824344930E-01 1.40288069712E-01 1.43839479105E-01 1.47480792855E-01 1.51214286901E-01 1.55042294799E-01 1.58967209178E-01 1.62991483238E-01 1.67117632280E-01 1.71348235283E-01 1.75685936511E-01 1.80133447168E-01 1.84693547094E-01 1.89369086499E-01 1.94162987747E-01 1.99078247183E-01 2.04117937005E-01 2.09285207181E-01 2.14583287425E-01 2.20015489208E-01 2.25585207835E-01 2.31295924560E-01 2.37151208767E-01 2.43154720199E-01 2.49310211247E-01 2.55621529293E-01 2.62092619116E-01 2.68727525357E-01 2.75530395050E-01 2.82505480209E-01 2.89657140489E-01 2.96989845911E-01 3.04508179655E-01 3.12216840924E-01 3.20120647881E-01 3.28224540665E-01 3.36533584471E-01 3.45052972722E-01 3.53788030314E-01 3.62744216941E-01 3.71927130513E-01 3.81342510648E-01 3.90996242266E-01 4.00894359264E-01 4.11043048286E-01 4.21448652594E-01 4.32117676029E-01 4.43056787079E-01 4.54272823043E-01 4.65772794309E-01 4.77563888734E-01 4.89653476136E-01 5.02049112899E-01 5.14758546701E-01 5.27789721352E-01 5.41150781760E-01 5.54850079022E-01 5.68896175645E-01 5.83297850898E-01 5.98064106295E-01 6.13204171227E-01 6.28727508728E-01 6.44643821388E-01 6.60963057422E-01 6.77695416883E-01 6.94851358040E-01 7.12441603915E-01 7.30477148985E-01 7.48969266052E-01 7.67929513291E-01 7.87369741474E-01 8.07302101377E-01 8.27739051373E-01 8.48693365221E-01 8.70178140050E-01 8.92206804543E-01 9.14793127333E-01 9.37951225606E-01 9.61695573929E-01 9.86041013291E-01 1.01100276038E+00 1.03659641711E+00 1.06283798035E+00 1.08974385192E+00 1.11733084887E+00 1.14561621398E+00 1.17461762651E+00 1.20435321329E+00 1.23484156004E+00 1.26610172296E+00 1.29815324067E+00 1.33101614642E+00 1.36471098059E+00 1.39925880354E+00 1.43468120880E+00 1.47100033651E+00 1.50823888732E+00 1.54642013654E+00 1.58556794867E+00 1.62570679239E+00 1.66686175578E+00 1.70905856203E+00 1.75232358551E+00 1.79668386827E+00 1.84216713694E+00 1.88880182004E+00 1.93661706576E+00 1.98564276019E+00 2.03590954598E+00 2.08744884152E+00 2.14029286053E+00 2.19447463225E+00 2.25002802205E+00 2.30698775262E+00 2.36538942562E+00 2.42526954402E+00 2.48666553483E+00 2.54961577255E+00 2.61415960312E+00 2.68033736854E+00 2.74819043207E+00 2.81776120409E+00 2.88909316858E+00 2.96223091035E+00 3.03722014286E+00 3.11410773684E+00 3.19294174952E+00 3.27377145474E+00 3.35664737368E+00 3.44162130651E+00 3.52874636468E+00 3.61807700420E+00 3.70966905963E+00 3.80357977898E+00 3.89986785951E+00 3.99859348440E+00 4.09981836039E+00 4.20360575631E+00 4.31002054267E+00 4.41912923217E+00 4.53100002129E+00 4.64570283293E+00 4.76330936007E+00 4.88389311061E+00 5.00752945333E+00 5.13429566498E+00 5.26427097854E+00 5.39753663284E+00 5.53417592323E+00 5.67427425373E+00 5.81791919035E+00 5.96520051586E+00 6.11621028587E+00 6.27104288641E+00 6.42979509289E+00 6.59256613062E+00 6.75945773678E+00 6.93057422407E+00 7.10602254585E+00 7.28591236305E+00 7.47035611265E+00 7.65946907800E+00 7.85336946087E+00 8.05217845529E+00 8.25602032337E+00 8.46502247291E+00 8.67931553705E+00 8.89903345594E+00 9.12431356043E+00 9.35529665792E+00 9.59212712035E+00 9.83495297449E+00 1.00839259944E+01 1.03392017963E+01 1.06009399359E+01 1.08693040080E+01 1.11444617490E+01 1.14265851414E+01 1.17158505214E+01 1.20124386894E+01 1.23165350226E+01 1.26283295912E+01 1.29480172768E+01 1.32757978947E+01 1.36118763185E+01 1.39564626080E+01 1.43097721411E+01 1.46720257475E+01 1.50434498476E+01 1.54242765936E+01 1.58147440146E+01 1.62150961654E+01 1.66255832791E+01 1.70464619236E+01 1.74779951617E+01 1.79204527158E+01 1.83741111361E+01 1.88392539741E+01 1.93161719590E+01 1.98051631802E+01 2.03065332731E+01 2.08205956104E+01 2.13476714976E+01 2.18880903745E+01 2.24421900204E+01 2.30103167656E+01 2.35928257078E+01 2.41900809341E+01 2.48024557485E+01 2.54303329051E+01 2.60741048475E+01 2.67341739543E+01 2.74109527901E+01 2.81048643636E+01 2.88163423923E+01 2.95458315731E+01 3.02937878603E+01 3.10606787512E+01 3.18469835773E+01 3.26531938049E+01 3.34798133416E+01 3.43273588515E+01 3.51963600781E+01 3.60873601755E+01 3.70009160477E+01 3.79375986970E+01 3.88979935804E+01 3.98827009761E+01 4.08923363581E+01 4.19275307816E+01 4.29889312766E+01 4.40772012531E+01 4.51930209152E+01 4.63370876865E+01 4.75101166460E+01 4.87128409750E+01 4.99460124154E+01 5.12104017394E+01 5.25067992316E+01 5.38360151825E+01 5.51988803954E+01 5.65962467054E+01 5.80289875120E+01 5.94979983247E+01 6.10041973233E+01 3.27064980156E-05 3.35344669548E-05 3.43833960275E-05 3.52538158420E-05 3.61462704389E-05 3.70613176316E-05 3.79995293542E-05 3.89614920197E-05 3.99478068860E-05 4.09590904320E-05 4.19959747429E-05 4.30591079050E-05 4.41491544113E-05 4.52667955763E-05 4.64127299621E-05 4.75876738149E-05 4.87923615130E-05 5.00275460254E-05 5.12939993826E-05 5.25925131591E-05 5.39238989684E-05 5.52889889700E-05 5.66886363894E-05 5.81237160520E-05 5.95951249292E-05 6.11037826994E-05 6.26506323229E-05 6.42366406311E-05 6.58627989308E-05 6.75301236238E-05 6.92396568424E-05 7.09924671004E-05 7.27896499614E-05 7.46323287231E-05 7.65216551197E-05 7.84588100418E-05 8.04450042742E-05 8.24814792530E-05 8.45695078413E-05 8.67103951250E-05 8.89054792283E-05 9.11561321503E-05 9.34637606222E-05 9.58298069870E-05 9.82557501007E-05 1.00743106257E-04 1.03293430134E-04 1.05908315767E-04 1.08589397545E-04 1.11338351232E-04 1.14156895012E-04 1.17046790568E-04 1.20009844178E-04 1.23047907848E-04 1.26162880465E-04 1.29356708990E-04 1.32631389668E-04 1.35988969283E-04 1.39431546431E-04 1.42961272833E-04 1.46580354686E-04 1.50291054031E-04 1.54095690177E-04 1.57996641147E-04 1.61996345160E-04 1.66097302162E-04 1.70302075385E-04 1.74613292949E-04 1.79033649505E-04 1.83565907920E-04 1.88212901003E-04 1.92977533276E-04 1.97862782790E-04 2.02871702984E-04 2.08007424596E-04 2.13273157619E-04 2.18672193309E-04 2.24207906238E-04 2.29883756407E-04 2.35703291407E-04 2.41670148637E-04 2.47788057577E-04 2.54060842119E-04 2.60492422958E-04 2.67086820040E-04 2.73848155080E-04 2.80780654131E-04 2.87888650232E-04 2.95176586110E-04 3.02649016963E-04 3.10310613304E-04 3.18166163880E-04 3.26220578666E-04 3.34478891932E-04 3.42946265394E-04 3.51627991436E-04 3.60529496419E-04 3.69656344073E-04 3.79014238976E-04 3.88609030116E-04 3.98446714551E-04 4.08533441152E-04 4.18875514453E-04 4.29479398586E-04 4.40351721324E-04 4.51499278223E-04 4.62929036868E-04 4.74648141230E-04 4.86663916132E-04 4.98983871824E-04 5.11615708679E-04 5.24567322006E-04 5.37846806986E-04 5.51462463729E-04 5.65422802463E-04 5.79736548854E-04 5.94412649461E-04 6.09460277323E-04 6.24888837698E-04 6.40707973939E-04 6.56927573520E-04 6.73557774220E-04 6.90608970454E-04 7.08091819777E-04 7.26017249537E-04 7.44396463712E-04 7.63240949908E-04 7.82562486545E-04 8.02373150209E-04 8.22685323212E-04 8.43511701323E-04 8.64865301706E-04 8.86759471056E-04 9.09207893942E-04 9.32224601359E-04 9.55823979498E-04 9.80020778739E-04 1.00483012287E-03 1.03026751854E-03 1.05634886494E-03 1.08309046377E-03 1.11050902940E-03 1.13862169932E-03 1.16744604487E-03 1.19700008221E-03 1.22730228356E-03 1.25837158878E-03 1.29022741722E-03 1.32288967979E-03 1.35637879147E-03 1.39071568406E-03 1.42592181921E-03 1.46201920192E-03 1.49903039423E-03 1.53697852933E-03 1.57588732604E-03 1.61578110364E-03 1.65668479702E-03 1.69862397232E-03 1.74162484291E-03 1.78571428571E-03 1.83091985808E-03 1.87726981496E-03 1.92479312658E-03 1.97351949656E-03 2.02347938048E-03 2.07470400487E-03 2.12722538681E-03 2.18107635386E-03 2.23629056463E-03 2.29290252980E-03 2.35094763369E-03 2.41046215639E-03 2.47148329639E-03 2.53404919392E-03 2.59819895468E-03 2.66397267436E-03 2.73141146368E-03 2.80055747409E-03 2.87145392408E-03 2.94414512625E-03 3.01867651496E-03 3.09509467476E-03 3.17344736949E-03 3.25378357213E-03 3.33615349541E-03 3.42060862324E-03 3.50720174280E-03 3.59598697763E-03 3.68701982137E-03 3.78035717252E-03 3.87605736997E-03 3.97418022945E-03 4.07478708095E-03 4.17794080701E-03 4.28370588208E-03 4.39214841278E-03 4.50333617921E-03 4.61733867735E-03 4.73422716247E-03 4.85407469368E-03 4.97695617958E-03 5.10294842511E-03 5.23213017952E-03 5.36458218562E-03 5.50038723021E-03 5.63963019587E-03 5.78239811400E-03 5.92878021917E-03 6.07886800498E-03 6.23275528118E-03 6.39053823232E-03 6.55231547789E-03 6.71818813393E-03 6.88825987624E-03 7.06263700522E-03 7.24142851222E-03 7.42474614778E-03 7.61270449137E-03 7.80542102309E-03 8.00301619703E-03 8.20561351662E-03 8.41333961177E-03 8.62632431805E-03 8.84470075785E-03 9.06860542354E-03 9.29817826282E-03 9.53356276620E-03 9.77490605666E-03 1.00223589816E-02 1.02760762072E-02 1.05362163149E-02 1.08029419007E-02 1.10764196770E-02 1.13568205761E-02 1.16443198577E-02 1.19390972184E-02 1.22413369034E-02 1.25512278225E-02 1.28689636675E-02 1.31947430338E-02 1.35287695440E-02 1.38712519755E-02 1.42224043911E-02 1.45824462724E-02 1.49516026574E-02 1.53301042807E-02 1.57181877182E-02 1.61160955347E-02 1.65240764355E-02 1.69423854221E-02 1.73712839510E-02 1.78110400979E-02 1.82619287246E-02 1.87242316513E-02 1.91982378323E-02 1.96842435369E-02 2.01825525344E-02 2.06934762843E-02 2.12173341305E-02 2.17544535013E-02 2.23051701136E-02 2.28698281833E-02 2.34487806402E-02 2.40423893482E-02 2.46510253323E-02 2.52750690096E-02 2.59149104278E-02 2.65709495087E-02 2.72435962980E-02 2.79332712218E-02 2.86404053494E-02 2.93654406627E-02 3.01088303323E-02 3.08710390010E-02 3.16525430740E-02 3.24538310169E-02 3.32754036605E-02 3.41177745147E-02 3.49814700886E-02 3.58670302200E-02 3.67750084129E-02 3.77059721831E-02 3.86605034134E-02 3.96391987169E-02 4.06426698099E-02 4.16715438945E-02 4.27264640507E-02 4.38080896377E-02 4.49170967068E-02 4.60541784236E-02 4.72200455010E-02 4.84154266440E-02 4.96410690048E-02 5.08977386496E-02 5.21862210379E-02 5.35073215132E-02 5.48618658063E-02 5.62507005513E-02 5.76746938154E-02 5.91347356405E-02 6.06317386004E-02 6.21666383707E-02 6.37403943137E-02 6.53539900780E-02 6.70084342136E-02 6.87047608018E-02 7.04440301021E-02 7.22273292144E-02 7.40557727586E-02 7.59305035715E-02 7.78526934209E-02 7.98235437380E-02 8.18442863685E-02 8.39161843421E-02 8.60405326627E-02 8.82186591170E-02 9.04519251051E-02 9.27417264908E-02 9.50894944745E-02 9.74966964878E-02 9.99648371101E-02 1.02495459010E-01 1.05090143908E-01 1.07750513567E-01 1.10478230804E-01 1.13275000532E-01 1.16142570823E-01 1.19082734002E-01 1.22097327765E-01 1.25188236333E-01 1.28357391624E-01 1.31606774464E-01 1.34938415821E-01 1.38354398081E-01 1.41856856343E-01 1.45447979759E-01 1.49130012897E-01 1.52905257147E-01 1.56776072160E-01 1.60744877322E-01 1.64814153265E-01 1.68986443420E-01 1.73264355602E-01 1.77650563646E-01 1.82147809076E-01 1.86758902816E-01 1.91486726950E-01 1.96334236522E-01 2.01304461382E-01 2.06400508084E-01 2.11625561823E-01 2.16982888426E-01 2.22475836399E-01 2.28107839011E-01 2.33882416448E-01 2.39803178009E-01 2.45873824362E-01 2.52098149860E-01 2.58480044907E-01 2.65023498397E-01 2.71732600201E-01 2.78611543726E-01 2.85664628535E-01 2.92896263036E-01 3.00310967235E-01 3.07913375566E-01 3.15708239779E-01 3.23700431920E-01 3.31894947368E-01 3.40296907962E-01 3.48911565201E-01 3.57744303526E-01 3.66800643687E-01 3.76086246190E-01 3.85606914840E-01 3.95368600365E-01 4.05377404134E-01 4.15639581978E-01 4.26161548090E-01 4.36949879043E-01 4.48011317894E-01 4.59352778403E-01 4.70981349352E-01 4.82904298975E-01 4.95129079506E-01 5.07663331828E-01 5.20514890260E-01 5.33691787441E-01 5.47202259363E-01 5.61054750510E-01 5.75257919140E-01 5.89820642696E-01 6.04752023353E-01 6.20061393712E-01 6.35758322626E-01 6.51852621188E-01 6.68354348858E-01 6.85273819752E-01 7.02621609091E-01 7.20408559808E-01 7.38645789327E-01 7.57344696509E-01 7.76516968779E-01 7.96174589433E-01 8.16329845123E-01 8.36995333540E-01 8.58183971287E-01 8.79909001952E-01 9.02184004387E-01 9.25022901193E-01 9.48439967425E-01 9.72449839511E-01 9.97067524402E-01 1.02230840895E+00 1.04818826954E+00 1.07472328191E+00 1.10193003133E+00 1.12982552288E+00 1.15842719216E+00 1.18775291615E+00 1.21782102438E+00 1.24865031039E+00 1.28026004349E+00 1.31266998079E+00 1.34590037956E+00 1.37997200988E+00 1.41490616763E+00 1.45072468780E+00 1.48744995812E+00 1.52510493308E+00 -1.85087419695E+01 -1.85087406352E+01 -1.85087392325E+01 -1.85087377579E+01 -1.85087362077E+01 -1.85087345780E+01 -1.85087328648E+01 -1.85087310637E+01 -1.85087291703E+01 -1.85087271798E+01 -1.85087250872E+01 -1.85087228874E+01 -1.85087205747E+01 -1.85087181435E+01 -1.85087155877E+01 -1.85087129008E+01 -1.85087100761E+01 -1.85087071066E+01 -1.85087039849E+01 -1.85087007031E+01 -1.85086972531E+01 -1.85086936261E+01 -1.85086898133E+01 -1.85086858049E+01 -1.85086815910E+01 -1.85086771611E+01 -1.85086725040E+01 -1.85086676082E+01 -1.85086624613E+01 -1.85086570506E+01 -1.85086513625E+01 -1.85086453827E+01 -1.85086390963E+01 -1.85086324877E+01 -1.85086255402E+01 -1.85086182365E+01 -1.85086105583E+01 -1.85086024865E+01 -1.85085940008E+01 -1.85085850801E+01 -1.85085757020E+01 -1.85085658430E+01 -1.85085554787E+01 -1.85085445829E+01 -1.85085331285E+01 -1.85085210868E+01 -1.85085084277E+01 -1.85084951196E+01 -1.85084811292E+01 -1.85084664216E+01 -1.85084509598E+01 -1.85084347054E+01 -1.85084176175E+01 -1.85083996536E+01 -1.85083807687E+01 -1.85083609155E+01 -1.85083400445E+01 -1.85083181035E+01 -1.85082950375E+01 -1.85082707890E+01 -1.85082452972E+01 -1.85082184986E+01 -1.85081903259E+01 -1.85081607089E+01 -1.85081295735E+01 -1.85080968418E+01 -1.85080624320E+01 -1.85080262581E+01 -1.85079882296E+01 -1.85079482514E+01 -1.85079062236E+01 -1.85078620412E+01 -1.85078155936E+01 -1.85077667648E+01 -1.85077154327E+01 -1.85076614689E+01 -1.85076047386E+01 -1.85075450998E+01 -1.85074824037E+01 -1.85074164933E+01 -1.85073472039E+01 -1.85072743624E+01 -1.85071977867E+01 -1.85071172853E+01 -1.85070326569E+01 -1.85069436902E+01 -1.85068501627E+01 -1.85067518405E+01 -1.85066484781E+01 -1.85065398170E+01 -1.85064255856E+01 -1.85063054984E+01 -1.85061792554E+01 -1.85060465410E+01 -1.85059070236E+01 -1.85057603545E+01 -1.85056061672E+01 -1.85054440764E+01 -1.85052736770E+01 -1.85050945434E+01 -1.85049062278E+01 -1.85047082599E+01 -1.85045001450E+01 -1.85042813632E+01 -1.85040513680E+01 -1.85038095848E+01 -1.85035554096E+01 -1.85032882077E+01 -1.85030073115E+01 -1.85027120197E+01 -1.85024015947E+01 -1.85020752615E+01 -1.85017322050E+01 -1.85013715689E+01 -1.85009924526E+01 -1.85005939099E+01 -1.85001749459E+01 -1.84997345147E+01 -1.84992715174E+01 -1.84987847983E+01 -1.84982731431E+01 -1.84977352752E+01 -1.84971698528E+01 -1.84965754655E+01 -1.84959506308E+01 -1.84952937907E+01 -1.84946033073E+01 -1.84938774592E+01 -1.84931144372E+01 -1.84923123396E+01 -1.84914691678E+01 -1.84905828212E+01 -1.84896510918E+01 -1.84886716595E+01 -1.84876420854E+01 -1.84865598066E+01 -1.84854221296E+01 -1.84842262237E+01 -1.84829691141E+01 -1.84816476744E+01 -1.84802586193E+01 -1.84787984965E+01 -1.84772636782E+01 -1.84756503519E+01 -1.84739545119E+01 -1.84721719490E+01 -1.84702982403E+01 -1.84683287389E+01 -1.84662585620E+01 -1.84640825798E+01 -1.84617954027E+01 -1.84593913685E+01 -1.84568645286E+01 -1.84542086342E+01 -1.84514171209E+01 -1.84484830932E+01 -1.84453993082E+01 -1.84421581584E+01 -1.84387516536E+01 -1.84351714021E+01 -1.84314085909E+01 -1.84274539654E+01 -1.84232978073E+01 -1.84189299122E+01 -1.84143395660E+01 -1.84095155201E+01 -1.84044459657E+01 -1.83991185065E+01 -1.83935201306E+01 -1.83876371811E+01 -1.83814553253E+01 -1.83749595225E+01 -1.83681339905E+01 -1.83609621708E+01 -1.83534266922E+01 -1.83455093325E+01 -1.83371909797E+01 -1.83284515904E+01 -1.83192701472E+01 -1.83096246146E+01 -1.82994918925E+01 -1.82888477688E+01 -1.82776668694E+01 -1.82659226072E+01 -1.82535871290E+01 -1.82406312601E+01 -1.82270244480E+01 -1.82127347037E+01 -1.81977285411E+01 -1.81819709155E+01 -1.81654251593E+01 -1.81480529171E+01 -1.81298140781E+01 -1.81106667082E+01 -1.80905669798E+01 -1.80694691012E+01 -1.80473252440E+01 -1.80240854707E+01 -1.79996976605E+01 -1.79741074362E+01 -1.79472580893E+01 -1.79190905069E+01 -1.78895430985E+01 -1.78585517239E+01 -1.78260496232E+01 -1.77919673484E+01 -1.77562326981E+01 -1.77187706563E+01 -1.76795033340E+01 -1.76383499182E+01 -1.75952266247E+01 -1.75500466602E+01 -1.75027201914E+01 -1.74531543249E+01 -1.74012530971E+01 -1.73469174780E+01 -1.72900453884E+01 -1.72305317344E+01 -1.71682684587E+01 -1.71031446134E+01 -1.70350464552E+01 -1.69638575656E+01 -1.68894589986E+01 -1.68117294596E+01 -1.67305455172E+01 -1.66457818523E+01 -1.65573115468E+01 -1.64650064157E+01 -1.63687373859E+01 -1.62683749266E+01 -1.61637895326E+01 -1.60548522669E+01 -1.59414353643E+01 -1.58234129011E+01 -1.57006615333E+01 -1.55730613079E+01 -1.54404965492E+01 -1.53028568235E+01 -1.51600379842E+01 -1.50119432985E+01 -1.48584846573E+01 -1.46995838672E+01 -1.45351740231E+01 -1.43652009602E+01 -1.41896247794E+01 -1.40084214407E+01 -1.38215844172E+01 -1.36291263982E+01 -1.34310810294E+01 -1.32275046736E+01 -1.30184781748E+01 -1.28041086009E+01 -1.25845309428E+01 -1.23599097382E+01 -1.21304405887E+01 -1.18963515325E+01 -1.16579042342E+01 -1.14153949465E+01 -1.11691551970E+01 -1.09195521524E+01 -1.06669886077E+01 -1.04119025475E+01 -1.01547662298E+01 -9.89608474036E+00 -9.63639397058E+00 -9.37625797899E+00 -9.11626570059E+00 -8.85702698106E+00 -8.59916792380E+00 -8.34332555400E+00 -8.09014182138E+00 -7.84025698450E+00 -7.59430244220E+00 -7.35289310330E+00 -7.11661941193E+00 -6.88603917288E+00 -6.66166934816E+00 -6.44397802023E+00 -6.23337673901E+00 -6.03021348602E+00 -5.83476649871E+00 -5.64723919894E+00 -5.46775646085E+00 -5.29636243234E+00 -5.13302009126E+00 -4.97761267135E+00 -4.82994703371E+00 -4.68975898952E+00 -4.55672050045E+00 -4.43044859764E+00 -4.31051577430E+00 -4.19646152370E+00 -4.08780462219E+00 -3.98405569953E+00 -3.88472960398E+00 -3.78935706081E+00 -3.69749514438E+00 -3.60873613682E+00 -3.52271442888E+00 -3.43911122760E+00 -3.35765696297E+00 -3.27813142365E+00 -3.20036178802E+00 -3.12421884008E+00 -3.04961175950E+00 -2.97648194079E+00 -2.90479632434E+00 -2.83454070769E+00 -2.76571345426E+00 -2.69831993280E+00 -2.63236791770E+00 -2.56786406737E+00 -2.50481149052E+00 -2.44320831743E+00 -2.38304712540E+00 -2.32431502680E+00 -2.26699421607E+00 -2.21106278391E+00 -2.15649563655E+00 -2.10326539769E+00 -2.05134321279E+00 -2.00069941363E+00 -1.95130403217E+00 -1.90312717332E+00 -1.85613926883E+00 -1.81031123867E+00 -1.76561458530E+00 -1.72202144257E+00 -1.67950459582E+00 -1.63803748477E+00 -1.59759419695E+00 -1.55814945627E+00 -1.51967860930E+00 -1.48215761079E+00 -1.44556300901E+00 -1.40987193115E+00 -1.37506206914E+00 -1.34111166569E+00 -1.30799950068E+00 -1.27570487795E+00 -1.24420761228E+00 -1.21348801688E+00 -1.18352689099E+00 -1.15430550794E+00 -1.12580560340E+00 -1.09800936401E+00 -1.07089941622E+00 -1.04445881543E+00 -1.01867103539E+00 -9.93519957912E-01 -9.68989862750E-01 -9.45065417795E-01 -9.21731669490E-01 -8.98974033484E-01 -8.76778285513E-01 -8.55130552512E-01 -8.34017303944E-01 -8.13425343339E-01 -7.93341800054E-01 -7.73754121219E-01 -7.54650063898E-01 -7.36017687432E-01 -7.17845345981E-01 -7.00121681238E-01 -6.82835615338E-01 -6.65976343925E-01 -6.49533329406E-01 -6.33496294363E-01 -6.17855215125E-01 -6.02600315510E-01 -5.87722060708E-01 -5.73211151327E-01 -5.59058517574E-01 -5.45255313594E-01 -5.31792911934E-01 -5.18662898156E-01 -5.05857065573E-01 -4.93367410123E-01 -4.81186125364E-01 -4.69305597598E-01 -4.57718401108E-01 -4.46417293518E-01 -4.35395211269E-01 -4.24645265201E-01 -4.14160736246E-01 -4.03935071234E-01 -3.93961878790E-01 -3.84234925345E-01 -3.74748131237E-01 -3.65495566909E-01 -3.56471449209E-01 -3.47670137769E-01 -3.39086131482E-01 -3.30714065066E-01 -3.22548705706E-01 -3.14584949787E-01 -3.06817819702E-01 -2.99242460742E-01 -2.91854138062E-01 -2.84648233718E-01 -2.77620243787E-01 -2.70765775545E-01 -2.64080544727E-01 -2.57560372846E-01 -2.51201184582E-01 -2.44999005236E-01 -2.38949958244E-01 -2.33050262754E-01 -2.27296231265E-01 -2.21684267320E-01 -2.16210863258E-01 -2.10872598023E-01 -2.05666135027E-01 -2.00588220061E-01 -1.95635679261E-01 -1.90805417130E-01 -1.86094414595E-01 -1.81499727128E-01 -1.77018482898E-01 -1.72647880983E-01 -1.68385189613E-01 -1.64227744469E-01 -1.60172947010E-01 -1.56218262858E-01 -1.52361220205E-01 -1.48599408275E-01 -1.44930475812E-01 -1.41352129615E-01 -1.37862133099E-01 -1.34458304905E-01 -1.31138517529E-01 1 0 Beta L 359 5.62466109801E-03 5.76705055555E-03 5.91304456932E-03 6.06273472856E-03 6.21621414849E-03 6.37357899691E-03 6.53492757816E-03 6.70036063836E-03 6.86998197605E-03 7.04389722080E-03 7.22221535975E-03 7.40504751623E-03 7.59250847636E-03 7.78471485692E-03 7.98178693728E-03 8.18384835393E-03 8.39102487909E-03 8.60344625251E-03 8.82124526539E-03 9.04455806558E-03 9.27352415737E-03 9.50828670672E-03 9.74899223570E-03 9.99579153833E-03 1.02488390697E-02 1.05082926403E-02 1.07743143322E-02 1.10470708034E-02 1.13267323722E-02 1.16134736274E-02 1.19074743437E-02 1.22089182604E-02 1.25179933861E-02 1.28348929144E-02 1.31598155288E-02 1.34929638754E-02 1.38345467001E-02 1.41847770157E-02 1.45438739334E-02 1.49120620517E-02 1.52895717606E-02 1.56766386309E-02 1.60735049392E-02 1.64804187520E-02 1.68976345344E-02 1.73254131502E-02 1.77640218601E-02 1.82137352365E-02 1.86748345522E-02 1.91476077786E-02 1.96323505002E-02 2.01293662189E-02 2.06389651302E-02 2.11614668702E-02 2.16971971546E-02 2.22464917456E-02 2.28096940077E-02 2.33871558210E-02 2.39792387995E-02 2.45863130674E-02 2.52087584774E-02 2.58469643017E-02 2.65013295342E-02 2.71722638025E-02 2.78601867530E-02 2.85655286576E-02 2.92887310190E-02 3.00302462605E-02 3.07905389420E-02 3.15700820898E-02 3.23693687921E-02 3.31888923477E-02 3.40291703766E-02 3.48907295476E-02 3.57741055693E-02 3.66798553928E-02 3.76085419371E-02 3.85607493423E-02 3.95370737997E-02 4.05381235391E-02 4.15645310264E-02 4.26169346324E-02 4.36959938807E-02 4.48023863781E-02 4.59368077958E-02 4.70999626923E-02 4.82925828077E-02 4.95154178827E-02 5.07692325813E-02 5.20548125696E-02 5.33729614341E-02 5.47245128606E-02 5.61103092339E-02 5.75312229684E-02 5.89881412076E-02 6.04819840960E-02 6.20136833681E-02 6.35842067173E-02 6.51945363782E-02 6.68456843311E-02 6.85386922402E-02 7.02746191803E-02 7.20545568256E-02 7.38796293727E-02 7.57509782001E-02 7.76697861919E-02 7.96372593328E-02 8.16546357594E-02 8.37231886999E-02 8.58442202515E-02 8.80190673532E-02 9.02491016460E-02 9.25357323737E-02 9.48804001178E-02 9.72845918769E-02 9.97498195228E-02 1.02277647052E-01 1.04869672064E-01 1.07527537722E-01 1.10252923353E-01 1.13047562466E-01 1.15913224158E-01 1.18851731094E-01 1.21864946959E-01 1.24954791330E-01 1.28123227085E-01 1.31372278253E-01 1.34704011258E-01 1.38120552704E-01 1.41624091877E-01 1.45216861868E-01 1.48901172464E-01 1.52679375940E-01 1.56553905935E-01 1.60527252272E-01 1.64601966201E-01 1.68780683828E-01 1.73066094659E-01 1.77460977061E-01 1.81968172732E-01 1.86590606750E-01 1.91331286211E-01 1.96193298753E-01 2.01179814016E-01 2.06294097133E-01 2.11539494708E-01 2.16919457148E-01 2.22437524331E-01 2.28097335431E-01 2.33902638552E-01 2.39857287991E-01 2.45965238254E-01 2.52230571241E-01 2.58657477607E-01 2.65250274289E-01 2.72013397438E-01 2.78951422328E-01 2.86069055597E-01 2.93371139252E-01 3.00862666347E-01 3.08548765936E-01 3.16434775277E-01 3.24526090642E-01 3.32828356385E-01 3.41347381053E-01 3.50089128521E-01 3.59059768769E-01 3.68265637253E-01 3.77713314060E-01 3.87409551311E-01 3.97361290071E-01 4.07575796334E-01 4.18060434764E-01 4.28822922335E-01 4.39871189519E-01 4.51213390406E-01 4.62858000834E-01 4.74813764659E-01 4.87089668155E-01 4.99695091363E-01 5.12639628296E-01 5.25933262823E-01 5.39586302672E-01 5.53609399804E-01 5.68013537551E-01 5.82810102875E-01 5.98010894767E-01 6.13628010107E-01 6.29674078921E-01 6.46162080475E-01 6.63105419297E-01 6.80517935326E-01 6.98414023571E-01 7.16808365698E-01 7.35716295867E-01 7.55153514338E-01 7.75136199529E-01 7.95681049339E-01 8.16805222984E-01 8.38526384581E-01 8.60862645067E-01 8.83832545413E-01 9.07455135237E-01 9.31749775238E-01 9.56736315641E-01 9.82434881745E-01 1.00886586083E+00 1.03604994313E+00 1.06400793560E+00 1.09276068243E+00 1.12232905792E+00 1.15273367149E+00 1.18399485913E+00 1.21613254242E+00 1.24916582175E+00 1.28311297284E+00 1.31799105927E+00 1.35381566890E+00 1.39060060601E+00 1.42835735455E+00 1.46709485250E+00 1.50681876944E+00 1.54753113374E+00 1.58922956197E+00 1.63190664683E+00 1.67554912182E+00 1.72013702621E+00 1.76564272181E+00 1.81202986062E+00 1.85925230289E+00 1.90725273817E+00 1.95596150586E+00 2.00529507253E+00 2.05515448975E+00 2.10542389119E+00 2.15596877433E+00 2.20663399989E+00 2.25724254477E+00 2.30759374727E+00 2.35746064495E+00 2.40658953756E+00 2.45469776150E+00 2.50147308960E+00 2.54657172084E+00 2.58961863654E+00 2.63020719501E+00 2.66789960959E+00 2.70222797865E+00 2.73269681683E+00 2.75878585917E+00 2.77995429329E+00 2.79564665039E+00 2.80529928005E+00 2.80834892053E+00 2.80424292775E+00 2.79245027025E+00 2.77247498567E+00 2.74387020380E+00 2.70625408743E+00 2.65932594670E+00 2.60288313012E+00 2.53683785201E+00 2.46123288917E+00 2.37625618270E+00 2.28225267083E+00 2.17973326541E+00 2.06937918338E+00 1.95204168159E+00 1.82873597414E+00 1.70062889093E+00 1.56901986123E+00 1.43531555864E+00 1.30099842766E+00 1.16758992283E+00 1.03660963539E+00 9.09532269730E-01 7.87743827421E-01 6.72499754486E-01 5.64886853880E-01 4.65791272651E-01 3.75874375649E-01 2.95558054602E-01 2.25020220603E-01 1.64200872170E-01 1.12818183205E-01 7.03935438731E-02 3.62838054778E-02 9.71859914461E-03 -1.01596826759E-02 -2.42557170029E-02 -3.34831942880E-02 -3.87308570216E-02 -4.08341291734E-02 -4.05532867703E-02 -3.85585430862E-02 -3.54218643504E-02 -3.16149074379E-02 -2.75121109389E-02 -2.33977895055E-02 -1.94760182707E-02 -1.58821358571E-02 -1.26948553533E-02 -9.94815030067E-03 -7.64231235677E-03 -5.75377919295E-03 -4.24351808043E-03 -3.06389201853E-03 -2.16404384715E-03 -1.49390358554E-03 -1.00696876226E-03 -6.62031682503E-04 -4.24040096065E-04 -2.64279420765E-04 -1.60059022273E-04 -9.40719583813E-05 -5.35769172654E-05 -2.95242244152E-05 -1.57173394552E-05 -8.06985015261E-06 -3.98925550779E-06 -1.89530073037E-06 -8.63789139864E-07 -3.76899081841E-07 -1.57120455383E-07 -6.24436882749E-08 -2.36049321747E-08 -8.46710422579E-09 -2.87468900803E-09 -9.21339397026E-10 -2.77977947487E-10 -7.87206800148E-11 -2.08600165176E-11 -5.15559237906E-12 -1.18438348222E-12 -2.52004313516E-13 -4.94658567294E-14 -8.92182395518E-15 -1.46911323107E-15 -2.24067217669E-16 -3.42384076646E-17 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 2 1 Beta L 359 8.85855592715E-06 9.31274280176E-06 9.79021610007E-06 1.02921699527E-05 1.08198594009E-05 1.13746040450E-05 1.19577907406E-05 1.25708778813E-05 1.32153984123E-05 1.38929641127E-05 1.46052690854E-05 1.53540945150E-05 1.61413134262E-05 1.69688913180E-05 1.78389015496E-05 1.87535172499E-05 1.97150273380E-05 2.07258317635E-05 2.17884637137E-05 2.29055753356E-05 2.40799615291E-05 2.53145599458E-05 2.66124573325E-05 2.79768974611E-05 2.94112938169E-05 3.09192327695E-05 3.25044830880E-05 3.41710086290E-05 3.59229794378E-05 3.77647717455E-05 3.97009949328E-05 4.17364883534E-05 4.38763403654E-05 4.61259026040E-05 4.84908010798E-05 5.09769456920E-05 5.35905556020E-05 5.63381655728E-05 5.92266434104E-05 6.22632121636E-05 6.54554643921E-05 6.88113811917E-05 7.23393528052E-05 7.60482024045E-05 7.99472019407E-05 8.40460975093E-05 8.83551410599E-05 9.28851030689E-05 9.76473105897E-05 1.02653671026E-04 1.07916697487E-04 1.13449553178E-04 1.19266065646E-04 1.25380782268E-04 1.31808984491E-04 1.38566748071E-04 1.45670965236E-04 1.53139395400E-04 1.60990712696E-04 1.69244534472E-04 1.77921516397E-04 1.87043334947E-04 1.96632792011E-04 2.06713862398E-04 2.17311741322E-04 2.28452939473E-04 2.40165282898E-04 2.52478071492E-04 2.65422047135E-04 2.79029599735E-04 2.93334735334E-04 3.08373202808E-04 3.24182588825E-04 3.40802396922E-04 3.58274189997E-04 3.76641605885E-04 3.95950579101E-04 4.16249324632E-04 4.37588607191E-04 4.60021740787E-04 4.83604778592E-04 5.08396655165E-04 5.34459312767E-04 5.61857875187E-04 5.90660789793E-04 6.20940032936E-04 6.52771235979E-04 6.86233938109E-04 7.21411712173E-04 7.58392449000E-04 7.97268498857E-04 8.38136971372E-04 8.81099940141E-04 9.26264694752E-04 9.73744024341E-04 1.02365648509E-03 1.07612669919E-03 1.13128566948E-03 1.18927109372E-03 1.25022774206E-03 1.31430773901E-03 1.38167101946E-03 1.45248570501E-03 1.52692851156E-03 1.60518517226E-03 1.68745092333E-03 1.77393081483E-03 1.86484089289E-03 1.96040758940E-03 2.06086929903E-03 2.16647652831E-03 2.27749236079E-03 2.39419371386E-03 2.51687132593E-03 2.64583069361E-03 2.78139316572E-03 2.92389656018E-03 3.07369546204E-03 3.23116294605E-03 3.39669087042E-03 3.57069111912E-03 3.75359668297E-03 3.94586226219E-03 4.14796597504E-03 4.36041042874E-03 4.58372315260E-03 4.81845908654E-03 5.06520116313E-03 5.32456183492E-03 5.59718475396E-03 5.88374612794E-03 6.18495638554E-03 6.50156215047E-03 6.83434757291E-03 7.18413691777E-03 7.55179555852E-03 7.93823301715E-03 8.34440456563E-03 8.77131376240E-03 9.22001449752E-03 9.69161412752E-03 1.01872754823E-02 1.07082196410E-02 1.12557294750E-02 1.18311517390E-02 1.24359010310E-02 1.30714622961E-02 1.37393951907E-02 1.44413366679E-02 1.51790057308E-02 1.59542057672E-02 1.67688337799E-02 1.76248737627E-02 1.85244135440E-02 1.94696421302E-02 2.04628567613E-02 2.15064698732E-02 2.26030064997E-02 2.37551220708E-02 2.49655964337E-02 2.62373498167E-02 2.75734397327E-02 2.89770750562E-02 3.04516173193E-02 3.20005912617E-02 3.36276920124E-02 3.53367888914E-02 3.71319352415E-02 3.90173795351E-02 4.09975698784E-02 4.30771597421E-02 4.52610258528E-02 4.75542668325E-02 4.99622201853E-02 5.24904693535E-02 5.51448470856E-02 5.79314600670E-02 6.08566800218E-02 6.39271715604E-02 6.71498910607E-02 7.05321002466E-02 7.40813771782E-02 7.78056261195E-02 8.17130908329E-02 8.58123572038E-02 9.01123714536E-02 9.46224442956E-02 9.93522656855E-02 1.04311908307E-01 1.09511836636E-01 1.14962921303E-01 1.20676432378E-01 1.26664062095E-01 1.32937915217E-01 1.39510517487E-01 1.46394818740E-01 1.53604188847E-01 1.61152422850E-01 1.69053713852E-01 1.77322687259E-01 1.85974327668E-01 1.95024042984E-01 2.04487540599E-01 2.14380951606E-01 2.24720616685E-01 2.35523222541E-01 2.46805659219E-01 2.58585001499E-01 2.70878463642E-01 2.83703297711E-01 2.97076766853E-01 3.11016030646E-01 3.25538059091E-01 3.40659486768E-01 3.56396578980E-01 3.72764963223E-01 3.89779613145E-01 4.07454553844E-01 4.25802744259E-01 4.44835850030E-01 4.64563991982E-01 4.84995483034E-01 5.06136579151E-01 5.27991106862E-01 5.50560198858E-01 5.73841891562E-01 5.97830708857E-01 6.22517244622E-01 6.47887743105E-01 6.73923536679E-01 7.00600590082E-01 7.27888895783E-01 7.55751942348E-01 7.84146083523E-01 8.13019904628E-01 8.42313581396E-01 8.71958252165E-01 9.01875333327E-01 9.31975865487E-01 9.62159905026E-01 9.92315923669E-01 1.02232025225E+00 1.05203662645E+00 1.08131564660E+00 1.10999492296E+00 1.13789834810E+00 1.16483671120E+00 1.19060765520E+00 1.21499601331E+00 1.23777533195E+00 1.25870793699E+00 1.27754751271E+00 1.29404003869E+00 1.30792681123E+00 1.31894689524E+00 1.32684066785E+00 1.33135325746E+00 1.33223938356E+00 1.32926787274E+00 1.32222691102E+00 1.31093011532E+00 1.29522225322E+00 1.27498548862E+00 1.25014598364E+00 1.22067976449E+00 1.18661877941E+00 1.14805612306E+00 1.10515058417E+00 1.05812978718E+00 1.00729227609E+00 9.53007666632E-01 8.95714963864E-01 8.35918574324E-01 7.74182117173E-01 7.11119815352E-01 6.47385441535E-01 5.83659229570E-01 5.20632657218E-01 4.58991859834E-01 3.99400107725E-01 3.42479886306E-01 2.88795544123E-01 2.38837195864E-01 1.93006684515E-01 1.51606425963E-01 1.14831739656E-01 8.27672263457E-02 5.53874313492E-02 3.25619009130E-02 1.40643868234E-02 -4.14221888248E-04 -1.12499692866E-02 -1.88677774040E-02 -2.37222921714E-02 -2.62787118393E-02 -2.69946494903E-02 -2.63039853428E-02 -2.46034832072E-02 -2.22427201751E-02 -1.95176110128E-02 -1.66675366623E-02 -1.38758334570E-02 -1.12731713991E-02 -8.94319737367E-03 -6.92972529198E-03 -5.24473017754E-03 -3.87645707070E-03 -2.79705553395E-03 -1.96929384872E-03 -1.35206995086E-03 -9.04596234136E-04 -5.89278369033E-04 -3.73419509655E-04 -2.29955502644E-04 -1.37461123146E-04 -7.96679659421E-05 -4.47087933697E-05 -2.42607146888E-05 -1.27106920213E-05 -6.41947598637E-06 -3.12003510193E-06 -1.45668996443E-06 -6.52067565478E-07 -2.79290477998E-07 -1.14215843792E-07 -4.44957446730E-08 -1.64737431989E-08 -5.78162781491E-09 -1.91838074563E-09 -6.00105024691E-10 -1.76459119328E-10 -4.86222912055E-11 -1.25135735331E-11 -2.99772412660E-12 -6.66027056873E-13 -1.36687925392E-13 -2.58024793176E-14 -4.45103425450E-15 -7.13053529555E-16 -1.14588836198E-16 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 2 Number of nonzero Dij 1 1 1.52388501179E+00 2 2 3.68330413052E+00 3S 0 2.00 Wavefunction 1.84219730000E-04 1.88883320000E-04 1.93664970000E-04 1.98567680000E-04 2.03594500000E-04 2.08748580000E-04 2.14033140000E-04 2.19451480000E-04 2.25007000000E-04 2.30703160000E-04 2.36543530000E-04 2.42531750000E-04 2.48671580000E-04 2.54966840000E-04 2.61421470000E-04 2.68039520000E-04 2.74825110000E-04 2.81782490000E-04 2.88916010000E-04 2.96230130000E-04 3.03729420000E-04 3.11418570000E-04 3.19302380000E-04 3.27385790000E-04 3.35673860000E-04 3.44171760000E-04 3.52884800000E-04 3.61818440000E-04 3.70978260000E-04 3.80369980000E-04 3.89999490000E-04 3.99872810000E-04 4.09996100000E-04 4.20375690000E-04 4.31018090000E-04 4.41929940000E-04 4.53118080000E-04 4.64589490000E-04 4.76351350000E-04 4.88411020000E-04 5.00776050000E-04 5.13454160000E-04 5.26453290000E-04 5.39781570000E-04 5.53447340000E-04 5.67459150000E-04 5.81825760000E-04 5.96556170000E-04 6.11659600000E-04 6.27145490000E-04 6.43023530000E-04 6.59303670000E-04 6.75996080000E-04 6.93111240000E-04 7.10659830000E-04 7.28652860000E-04 7.47101590000E-04 7.66017560000E-04 7.85412630000E-04 8.05298940000E-04 8.25688950000E-04 8.46595430000E-04 8.68031470000E-04 8.90010510000E-04 9.12546320000E-04 9.35653020000E-04 9.59345100000E-04 9.83637410000E-04 1.00854520000E-03 1.03408400000E-03 1.06027000000E-03 1.08711940000E-03 1.11464920000E-03 1.14287670000E-03 1.17181950000E-03 1.20149590000E-03 1.23192440000E-03 1.26312420000E-03 1.29511490000E-03 1.32791650000E-03 1.36154980000E-03 1.39603580000E-03 1.43139620000E-03 1.46765330000E-03 1.50483000000E-03 1.54294950000E-03 1.58203590000E-03 1.62211390000E-03 1.66320870000E-03 1.70534620000E-03 1.74855290000E-03 1.79285630000E-03 1.83828420000E-03 1.88486540000E-03 1.93262920000E-03 1.98160600000E-03 2.03182660000E-03 2.08332300000E-03 2.13612770000E-03 2.19027420000E-03 2.24579700000E-03 2.30273120000E-03 2.36111300000E-03 2.42097970000E-03 2.48236920000E-03 2.54532080000E-03 2.60987460000E-03 2.67607180000E-03 2.74395480000E-03 2.81356700000E-03 2.88495300000E-03 2.95815860000E-03 3.03323090000E-03 3.11021810000E-03 3.18917000000E-03 3.27013730000E-03 3.35317250000E-03 3.43832930000E-03 3.52566300000E-03 3.61523020000E-03 3.70708940000E-03 3.80130040000E-03 3.89792490000E-03 3.99702610000E-03 4.09866920000E-03 4.20292100000E-03 4.30985050000E-03 4.41952830000E-03 4.53202720000E-03 4.64742230000E-03 4.76579040000E-03 4.88721110000E-03 5.01176570000E-03 5.13953850000E-03 5.27061600000E-03 5.40508710000E-03 5.54304390000E-03 5.68458070000E-03 5.82979520000E-03 5.97878770000E-03 6.13166180000E-03 6.28852440000E-03 6.44948570000E-03 6.61465930000E-03 6.78416270000E-03 6.95811690000E-03 7.13664720000E-03 7.31988280000E-03 7.50795720000E-03 7.70100860000E-03 7.89917990000E-03 8.10261860000E-03 8.31147780000E-03 8.52591570000E-03 8.74609630000E-03 8.97218930000E-03 9.20437090000E-03 9.44282370000E-03 9.68773700000E-03 9.93930750000E-03 1.01977390000E-02 1.04632450000E-02 1.07360440000E-02 1.10163660000E-02 1.13044500000E-02 1.16005440000E-02 1.19049070000E-02 1.22178080000E-02 1.25395290000E-02 1.28703630000E-02 1.32106150000E-02 1.35606070000E-02 1.39206710000E-02 1.42911580000E-02 1.46724340000E-02 1.50648810000E-02 1.54689010000E-02 1.58849150000E-02 1.63133630000E-02 1.67547100000E-02 1.72094410000E-02 1.76780680000E-02 1.81611290000E-02 1.86591900000E-02 1.91728460000E-02 1.97027250000E-02 2.02494900000E-02 2.08138370000E-02 2.13965050000E-02 2.19982720000E-02 2.26199600000E-02 2.32624380000E-02 2.39266290000E-02 2.46135040000E-02 2.53240980000E-02 2.60595040000E-02 2.68208810000E-02 2.76094600000E-02 2.84265470000E-02 2.92735300000E-02 3.01518830000E-02 3.10631720000E-02 3.20090650000E-02 3.29913330000E-02 3.40118650000E-02 3.50726700000E-02 3.61758870000E-02 3.73237980000E-02 3.85188340000E-02 3.97635860000E-02 4.10608200000E-02 4.24134830000E-02 4.38247210000E-02 4.52978940000E-02 4.68365830000E-02 4.84446140000E-02 5.01260700000E-02 5.18853100000E-02 5.37269890000E-02 5.56560720000E-02 5.76778630000E-02 5.97980180000E-02 6.20225750000E-02 6.43579720000E-02 6.68110750000E-02 6.93892010000E-02 7.21001450000E-02 7.49522050000E-02 7.79542090000E-02 8.11155440000E-02 8.44461760000E-02 8.79566820000E-02 9.16582700000E-02 9.55628000000E-02 9.96828080000E-02 1.04031520000E-01 1.08622850000E-01 1.13471430000E-01 1.18592610000E-01 1.24002400000E-01 1.29717510000E-01 1.35755280000E-01 1.42133670000E-01 1.48871140000E-01 1.55986620000E-01 1.63499390000E-01 1.71428950000E-01 1.79794850000E-01 1.88616530000E-01 1.97913080000E-01 2.07702980000E-01 2.18003830000E-01 2.28831980000E-01 2.40202160000E-01 2.52127080000E-01 2.64616920000E-01 2.77678860000E-01 2.91316500000E-01 3.05529320000E-01 3.20312050000E-01 3.35654060000E-01 3.51538760000E-01 3.67942970000E-01 3.84836380000E-01 4.02181010000E-01 4.19930810000E-01 4.38031280000E-01 4.56419280000E-01 4.75022980000E-01 4.93761990000E-01 5.12547650000E-01 5.31283570000E-01 5.49866390000E-01 5.68186760000E-01 5.86130490000E-01 6.03580020000E-01 6.20415900000E-01 6.36518550000E-01 6.51770040000E-01 6.66055930000E-01 6.79267050000E-01 6.91301290000E-01 7.02065130000E-01 7.11475080000E-01 7.19458810000E-01 7.25956080000E-01 7.30919330000E-01 7.34313950000E-01 7.36118330000E-01 7.36323620000E-01 7.34933210000E-01 7.31962140000E-01 7.27436250000E-01 7.21391290000E-01 7.13872060000E-01 7.04931400000E-01 6.94629340000E-01 6.83032230000E-01 6.70211920000E-01 6.56245090000E-01 6.41212500000E-01 6.25198420000E-01 6.08290000000E-01 5.90576720000E-01 5.72149800000E-01 5.53101670000E-01 5.33525390000E-01 5.13514080000E-01 4.93160340000E-01 4.72555720000E-01 4.51790140000E-01 4.30951340000E-01 4.10124390000E-01 3.89391200000E-01 3.68830040000E-01 3.48515180000E-01 3.28516480000E-01 3.08899070000E-01 2.89723100000E-01 2.71043470000E-01 2.52909690000E-01 2.35365710000E-01 2.18449870000E-01 2.02194850000E-01 1.86627670000E-01 1.71769770000E-01 1.57637100000E-01 1.44240290000E-01 1.31584800000E-01 1.19671190000E-01 1.08495340000E-01 9.80487990000E-02 8.83190460000E-02 7.92898830000E-02 7.09417760000E-02 6.32522470000E-02 5.61962560000E-02 4.97466000000E-02 4.38743060000E-02 3.85490200000E-02 3.37393880000E-02 2.94134200000E-02 2.55388380000E-02 2.20834010000E-02 1.90152070000E-02 1.63029630000E-02 1.39162320000E-02 1.18256390000E-02 1.00030550000E-02 8.42174580000E-03 7.05648120000E-03 5.88362540000E-03 4.88118930000E-03 4.02885860000E-03 3.30799500000E-03 2.70161610000E-03 2.19435340000E-03 1.77239540000E-03 1.42341400000E-03 1.13648200000E-03 9.01980660000E-04 7.11502250000E-04 5.57749540000E-04 4.34434060000E-04 3.36175720000E-04 2.58405030000E-04 1.97269630000E-04 1.49545970000E-04 1.12557140000E-04 8.40972500000E-05 6.23627700000E-05 4.58908520000E-05 3.35045580000E-05 2.42647690000E-05 1.74284030000E-05 1.24125100000E-05 8.76373380000E-06 6.13262730000E-06 4.25226340000E-06 2.92068220000E-06 1.98704210000E-06 1.33873530000E-06 8.92976370000E-07 5.89566530000E-07 3.85177100000E-07 2.48947180000E-07 1.59130890000E-07 1.00572820000E-07 6.28291230000E-08 3.87853580000E-08 2.36521340000E-08 1.42441100000E-08 8.46893130000E-09 4.96958660000E-09 2.87740530000E-09 1.64375330000E-09 9.26935810000E-10 5.17300600000E-10 2.88431570000E-10 1.58411090000E-10 8.56653640000E-11 4.55965080000E-11 2.38775610000E-11 1.22970640000E-11 6.22561770000E-12 3.09702600000E-12 1.51319790000E-12 7.25833890000E-13 3.41638340000E-13 1.57716040000E-13 7.13759320000E-14 3.16501520000E-14 1.37443350000E-14 5.84205730000E-15 2.42921730000E-15 9.87606240000E-16 3.92347130000E-16 1.52220220000E-16 5.76406700000E-17 2.12898950000E-17 7.66535140000E-18 2.68858640000E-18 9.18039800000E-19 3.04964680000E-19 9.84885070000E-20 3.09000610000E-20 9.41137000000E-21 2.78060930000E-21 7.96317720000E-22 2.20876360000E-22 5.92893960000E-23 3P 1 2.00 Wavefunction 5.58448210000E-07 5.87080470000E-07 6.17180730000E-07 6.48824270000E-07 6.82090210000E-07 7.17061740000E-07 7.53826290000E-07 7.92475800000E-07 8.33106910000E-07 8.75821230000E-07 9.20725560000E-07 9.67932190000E-07 1.01755920000E-06 1.06973050000E-06 1.12457680000E-06 1.18223510000E-06 1.24284970000E-06 1.30657190000E-06 1.37356140000E-06 1.44398540000E-06 1.51802010000E-06 1.59585070000E-06 1.67767180000E-06 1.76368790000E-06 1.85411420000E-06 1.94917680000E-06 2.04911330000E-06 2.15417360000E-06 2.26462060000E-06 2.38073020000E-06 2.50279300000E-06 2.63111410000E-06 2.76601430000E-06 2.90783100000E-06 3.05691890000E-06 3.21365060000E-06 3.37841820000E-06 3.55163370000E-06 3.73373010000E-06 3.92516280000E-06 4.12641050000E-06 4.33797640000E-06 4.56038950000E-06 4.79420610000E-06 5.04001080000E-06 5.29841810000E-06 5.57007440000E-06 5.85565880000E-06 6.15588550000E-06 6.47150530000E-06 6.80330720000E-06 7.15212120000E-06 7.51881920000E-06 7.90431850000E-06 8.30958270000E-06 8.73562550000E-06 9.18351210000E-06 9.65436240000E-06 1.01493540000E-05 1.06697240000E-05 1.12167750000E-05 1.17918740000E-05 1.23964590000E-05 1.30320420000E-05 1.37002120000E-05 1.44026410000E-05 1.51410840000E-05 1.59173890000E-05 1.67334950000E-05 1.75914450000E-05 1.84933840000E-05 1.94415670000E-05 2.04383650000E-05 2.14862700000E-05 2.25879040000E-05 2.37460200000E-05 2.49635160000E-05 2.62434340000E-05 2.75889770000E-05 2.90035090000E-05 3.04905670000E-05 3.20538700000E-05 3.36973270000E-05 3.54250480000E-05 3.72413530000E-05 3.91507850000E-05 4.11581180000E-05 4.32683730000E-05 4.54868260000E-05 4.78190260000E-05 5.02708040000E-05 5.28482920000E-05 5.55579360000E-05 5.84065120000E-05 6.14011440000E-05 6.45493210000E-05 6.78589160000E-05 7.13382060000E-05 7.49958920000E-05 7.88411230000E-05 8.28835140000E-05 8.71331750000E-05 9.16007350000E-05 9.62973680000E-05 1.01234820000E-04 1.06425440000E-04 1.11882200000E-04 1.17618770000E-04 1.23649480000E-04 1.29989420000E-04 1.36654450000E-04 1.43661230000E-04 1.51027300000E-04 1.58771080000E-04 1.66911930000E-04 1.75470220000E-04 1.84467370000E-04 1.93925870000E-04 2.03869390000E-04 2.14322800000E-04 2.25312250000E-04 2.36865240000E-04 2.49010660000E-04 2.61778900000E-04 2.75201920000E-04 2.89313280000E-04 3.04148300000E-04 3.19744100000E-04 3.36139700000E-04 3.53376130000E-04 3.71496520000E-04 3.90546210000E-04 4.10572880000E-04 4.31626640000E-04 4.53760200000E-04 4.77028940000E-04 5.01491110000E-04 5.27207940000E-04 5.54243810000E-04 5.82666390000E-04 6.12546850000E-04 6.43960000000E-04 6.76984480000E-04 7.11703000000E-04 7.48202490000E-04 7.86574370000E-04 8.26914730000E-04 8.69324630000E-04 9.13910290000E-04 9.60783420000E-04 1.01006140000E-03 1.06186790000E-03 1.11633250000E-03 1.17359180000E-03 1.23378930000E-03 1.29707590000E-03 1.36361040000E-03 1.43355940000E-03 1.50709850000E-03 1.58441200000E-03 1.66569400000E-03 1.75114830000E-03 1.84098940000E-03 1.93544270000E-03 2.03474530000E-03 2.13914660000E-03 2.24890870000E-03 2.36430720000E-03 2.48563210000E-03 2.61318830000E-03 2.74729620000E-03 2.88829310000E-03 3.03653340000E-03 3.19239000000E-03 3.35625510000E-03 3.52854080000E-03 3.70968110000E-03 3.90013180000E-03 4.10037280000E-03 4.31090860000E-03 4.53226980000E-03 4.76501450000E-03 5.00972970000E-03 5.26703300000E-03 5.53757370000E-03 5.82203500000E-03 6.12113540000E-03 6.43563090000E-03 6.76631660000E-03 7.11402880000E-03 7.47964760000E-03 7.86409830000E-03 8.26835490000E-03 8.69344170000E-03 9.14043630000E-03 9.61047250000E-03 1.01047430000E-02 1.06245030000E-02 1.11710720000E-02 1.17458400000E-02 1.23502670000E-02 1.29858920000E-02 1.36543300000E-02 1.43572860000E-02 1.50965470000E-02 1.58739980000E-02 1.66916200000E-02 1.75514970000E-02 1.84558220000E-02 1.94069000000E-02 2.04071570000E-02 2.14591440000E-02 2.25655440000E-02 2.37291760000E-02 2.49530080000E-02 2.62401550000E-02 2.75938960000E-02 2.90176730000E-02 3.05151040000E-02 3.20899900000E-02 3.37463220000E-02 3.54882890000E-02 3.73202890000E-02 3.92469330000E-02 4.12730590000E-02 4.34037380000E-02 4.56442810000E-02 4.80002480000E-02 5.04774590000E-02 5.30819960000E-02 5.58202150000E-02 5.86987480000E-02 6.17245120000E-02 6.49047110000E-02 6.82468380000E-02 7.17586760000E-02 7.54482990000E-02 7.93240660000E-02 8.33946140000E-02 8.76688500000E-02 9.21559370000E-02 9.68652750000E-02 1.01806480000E-01 1.06989340000E-01 1.12423820000E-01 1.18119960000E-01 1.24087880000E-01 1.30337690000E-01 1.36879400000E-01 1.43722920000E-01 1.50877850000E-01 1.58353500000E-01 1.66158660000E-01 1.74301550000E-01 1.82789630000E-01 1.91629470000E-01 2.00826520000E-01 2.10384990000E-01 2.20307600000E-01 2.30595350000E-01 2.41247350000E-01 2.52260530000E-01 2.63629390000E-01 2.75345810000E-01 2.87398740000E-01 2.99774000000E-01 3.12454040000E-01 3.25417760000E-01 3.38640280000E-01 3.52092840000E-01 3.65742680000E-01 3.79553010000E-01 3.93482990000E-01 4.07487820000E-01 4.21518900000E-01 4.35524020000E-01 4.49447730000E-01 4.63231670000E-01 4.76815050000E-01 4.90135240000E-01 5.03128320000E-01 5.15729770000E-01 5.27875200000E-01 5.39501060000E-01 5.50545410000E-01 5.60948610000E-01 5.70654070000E-01 5.79608850000E-01 5.87764310000E-01 5.95076510000E-01 6.01506700000E-01 6.07021580000E-01 6.11593500000E-01 6.15200530000E-01 6.17826490000E-01 6.19460820000E-01 6.20098430000E-01 6.19739460000E-01 6.18389020000E-01 6.16056890000E-01 6.12757170000E-01 6.08508020000E-01 6.03331340000E-01 5.97252450000E-01 5.90299870000E-01 5.82505030000E-01 5.73902040000E-01 5.64527500000E-01 5.54420280000E-01 5.43621320000E-01 5.32173420000E-01 5.20121080000E-01 5.07510270000E-01 4.94388240000E-01 4.80803340000E-01 4.66804780000E-01 4.52442430000E-01 4.37766590000E-01 4.22827820000E-01 4.07676670000E-01 3.92363470000E-01 3.76938150000E-01 3.61449980000E-01 3.45947360000E-01 3.30477610000E-01 3.15086790000E-01 2.99819440000E-01 2.84718400000E-01 2.69824650000E-01 2.55177080000E-01 2.40812350000E-01 2.26764700000E-01 2.13065830000E-01 1.99744770000E-01 1.86827730000E-01 1.74338060000E-01 1.62296140000E-01 1.50719370000E-01 1.39622070000E-01 1.29015560000E-01 1.18908150000E-01 1.09305150000E-01 1.00209010000E-01 9.16193630000E-02 8.35331560000E-02 7.59447920000E-02 6.88462880000E-02 6.22274440000E-02 5.60760410000E-02 5.03780330000E-02 4.51177690000E-02 4.02782040000E-02 3.58411260000E-02 3.17873740000E-02 2.80970630000E-02 2.47497940000E-02 2.17248660000E-02 1.90014700000E-02 1.65588760000E-02 1.43765980000E-02 1.24345580000E-02 1.07132150000E-02 9.19369060000E-03 7.85787140000E-03 6.68849120000E-03 5.66919920000E-03 4.78460950000E-03 4.02033410000E-03 3.36300060000E-03 2.80025640000E-03 2.32075900000E-03 1.91415630000E-03 1.57105620000E-03 1.28298890000E-03 1.04236110000E-03 8.42407030000E-04 6.77133640000E-04 5.41264860000E-04 4.30183770000E-04 3.39882290000E-04 2.66963360000E-04 2.08434130000E-04 1.61738350000E-04 1.24714090000E-04 9.55445520000E-05 7.27129980000E-05 5.49616660000E-05 4.12547140000E-05 3.07450620000E-05 2.27449800000E-05 1.67002290000E-05 1.21675240000E-05 8.79506470000E-06 6.30586810000E-06 4.48362730000E-06 3.16082490000E-06 2.20883300000E-06 1.52974750000E-06 1.04971570000E-06 7.13538400000E-07 4.80345490000E-07 3.20167880000E-07 2.11246630000E-07 1.37943950000E-07 8.91384640000E-08 5.70064370000E-08 3.61067890000E-08 2.27029220000E-08 1.42674480000E-08 8.85928130000E-09 5.43382400000E-09 3.29102710000E-09 1.96759920000E-09 1.16085540000E-09 6.75630550000E-10 3.87774980000E-10 2.19399450000E-10 1.22325940000E-10 6.71841530000E-11 3.63340970000E-11 1.93415330000E-11 1.01302890000E-11 5.21829130000E-12 2.64257200000E-12 1.31501070000E-12 6.42751160000E-13 3.08439410000E-13 1.45247130000E-13 6.70885120000E-14 3.03793580000E-14 1.34797060000E-14 6.78744415714E-08 7.13545064754E-08 7.50130030343E-08 7.88590890270E-08 8.29023713546E-08 8.71529676591E-08 9.16215065447E-08 9.63191601842E-08 1.01257688232E-07 1.06449430194E-07 1.11907378641E-07 1.17645173302E-07 1.23677180253E-07 1.30018467646E-07 1.36684899300E-07 1.43693163923E-07 1.51060771524E-07 1.58806157601E-07 1.66948695010E-07 1.75508750027E-07 1.84507729917E-07 1.93968144961E-07 2.03913648913E-07 2.14369132178E-07 2.25360756054E-07 2.36915999343E-07 2.49063761873E-07 2.61834447976E-07 2.75259995798E-07 2.89373979123E-07 3.04211732346E-07 3.19810373877E-07 3.36208905701E-07 3.53448352448E-07 3.71571877321E-07 3.90624798837E-07 4.10654816265E-07 4.31712016641E-07 4.53849098775E-07 4.77121462721E-07 5.01587359034E-07 5.27307984921E-07 5.54347727408E-07 5.82774255448E-07 6.12658719724E-07 6.44075920306E-07 6.77104481457E-07 7.11827105410E-07 7.48330722397E-07 7.86706692016E-07 8.27051090245E-07 8.69464964226E-07 9.14054465635E-07 9.60931338531E-07 1.01021288628E-06 1.06202260308E-06 1.11649024535E-06 1.17375221788E-06 1.23395201750E-06 1.29724045155E-06 1.36377611639E-06 1.43372574078E-06 1.50726461021E-06 1.58457708406E-06 1.66585696391E-06 1.75130801981E-06 1.84114454664E-06 1.93559183525E-06 2.03488686060E-06 2.13927835599E-06 2.24902895630E-06 2.36441312877E-06 2.48572113165E-06 2.61325762240E-06 2.74734230797E-06 2.88831254237E-06 3.03652180889E-06 3.19234292491E-06 3.35616751171E-06 3.52840686901E-06 3.70949506511E-06 3.89988681093E-06 4.10006118244E-06 4.31052228605E-06 4.53180049455E-06 4.76445188703E-06 5.00906315913E-06 5.26625131335E-06 5.53666446219E-06 5.82098464220E-06 6.11992879567E-06 6.43425330883E-06 6.76475096844E-06 7.11225779352E-06 7.47765145035E-06 7.86185790816E-06 8.26584832990E-06 8.69064772393E-06 9.13733186905E-06 9.60703398772E-06 1.01009476842E-05 1.06203263393E-05 1.11664905868E-05 1.17408317818E-05 1.23448106678E-05 1.29799686984E-05 1.36479261088E-05 1.43503889076E-05 1.50891542767E-05 1.58661130256E-05 1.66832565018E-05 1.75426817035E-05 1.84465978761E-05 1.93973297708E-05 2.03973297626E-05 2.14491755179E-05 2.25555880507E-05 2.37194312366E-05 2.49437246355E-05 2.62316473232E-05 2.75865548592E-05 2.90119797459E-05 3.05116496697E-05 3.20894916731E-05 3.37496506156E-05 3.54964942125E-05 3.73346350415E-05 3.92689333680E-05 4.13045208789E-05 4.34468174476E-05 4.57015356022E-05 4.80747173562E-05 5.05727310430E-05 5.32023150987E-05 5.59705826771E-05 5.88850463364E-05 6.19536580215E-05 6.51848118936E-05 6.85873965497E-05 7.21708049674E-05 7.59449801460E-05 7.99204472220E-05 8.41083475613E-05 8.85204776306E-05 9.31693410122E-05 9.80681800672E-05 1.03231042456E-04 1.08672819036E-04 1.14409306670E-04 1.20457276475E-04 1.26834534249E-04 1.33559983228E-04 1.40653722941E-04 1.48137112473E-04 1.56032873051E-04 1.64365173451E-04 1.73159753976E-04 1.82444023965E-04 1.92247188140E-04 2.02600389931E-04 2.13536834428E-04 2.25092032597E-04 2.37303765482E-04 2.50212516582E-04 2.63861556477E-04 2.78297138544E-04 2.93568802039E-04 3.09729561722E-04 3.26836308957E-04 3.44949993686E-04 3.64135970178E-04 3.84464598480E-04 4.06011232359E-04 4.28857101786E-04 4.53089535561E-04 4.78802479443E-04 5.06097264023E-04 5.35083105229E-04 5.65877738937E-04 5.98608480283E-04 6.33412658145E-04 6.70438902796E-04 7.09847996443E-04 7.51814016158E-04 7.96525492445E-04 8.44186927934E-04 8.95020287690E-04 9.49266311487E-04 1.00718693309E-03 1.06906675351E-03 1.13521543724E-03 1.20597012755E-03 1.28169853611E-03 1.36280101550E-03 1.44971503054E-03 1.54291786080E-03 1.64293097742E-03 1.75032469098E-03 1.86572284794E-03 1.98980863193E-03 2.12333028683E-03 2.26710809147E-03 2.42204193985E-03 2.58911942881E-03 2.76942538420E-03 2.96415198687E-03 3.17460995692E-03 3.40224188817E-03 3.64863587683E-03 3.91554107838E-03 4.20488599179E-03 4.51879680281E-03 4.85961989349E-03 5.22994598895E-03 5.63263623073E-03 6.07085272007E-03 6.54809198021E-03 7.06822148026E-03 7.63552183827E-03 8.25473161734E-03 8.93110025755E-03 9.67044322575E-03 1.04792075613E-02 1.13645406197E-02 1.23343702837E-02 1.33974913756E-02 1.45636625941E-02 1.58437136848E-02 1.72496651358E-02 1.87948595555E-02 2.04941060873E-02 2.23638418504E-02 2.44223076821E-02 2.66897405077E-02 2.91885862155E-02 3.19437294696E-02 3.49827387282E-02 3.83361457460E-02 4.20377375816E-02 4.61248449322E-02 5.06386982499E-02 5.56247550974E-02 6.11330790353E-02 6.72186703971E-02 7.39418818448E-02 8.13687509615E-02 8.95713737220E-02 9.86282030421E-02 1.08624331067E-01 1.19651729937E-01 1.31809307043E-01 1.45203001714E-01 1.59945550727E-01 1.76156216002E-01 1.93960226610E-01 2.13487936246E-01 2.34873680852E-01 2.58254294379E-01 2.83767207995E-01 3.11548049634E-01 3.41727863753E-01 3.74429749556E-01 4.09764968888E-01 4.47828708912E-01 4.88695201116E-01 5.32412672527E-01 5.78997858742E-01 6.28430555358E-01 6.80648141533E-01 7.35540541496E-01 7.92945602988E-01 8.52645438304E-01 9.14363820542E-01 9.77765035375E-01 1.04245426873E+00 1.10798002508E+00 1.17383830195E+00 1.23947888917E+00 1.30431355390E+00 1.36772611076E+00 1.42908366320E+00 1.48774933844E+00 1.54309534707E+00 1.59451636640E+00 1.64144245552E+00 1.68335114630E+00 1.71977826915E+00 1.75032679233E+00 1.77467415974E+00 1.79257705225E+00 1.80387426661E+00 1.80848754596E+00 1.80642021411E+00 1.79775417080E+00 1.78264577959E+00 1.76131997244E+00 1.73406396575E+00 1.70122005100E+00 1.66317799553E+00 1.62036741973E+00 1.57324963909E+00 1.52231014955E+00 1.46805085985E+00 1.41098270247E+00 1.35161866032E+00 1.29046713466E+00 1.22802578658E+00 1.16477601723E+00 1.10117793565E+00 1.03766609613E+00 9.74645759111E-01 9.12489990616E-01 8.51537378857E-01 7.92090476975E-01 7.34414900323E-01 6.78739066643E-01 6.25254460192E-01 5.74116445534E-01 5.25445680079E-01 4.79329659784E-01 4.35824807773E-01 3.94958772738E-01 3.56732867490E-01 3.21124666515E-01 2.88090675842E-01 2.57569078237E-01 2.29482303797E-01 2.03739657116E-01 1.80239802677E-01 1.58873071747E-01 1.39523653428E-01 1.22071592303E-01 1.06394603600E-01 9.23697173770E-02 7.98746725580E-02 6.87892118302E-02 5.89961124946E-02 5.03821054095E-02 4.28385543161E-02 3.62620833301E-02 3.05549888781E-02 2.56255301852E-02 2.13881558631E-02 1.77635685525E-02 1.46787324971E-02 1.20667960690E-02 9.86694576891E-03 8.02420104906E-03 6.48916696713E-03 5.21774402254E-03 4.17081401293E-03 3.31390153063E-03 2.61682464386E-03 2.05333769487E-03 1.60077556029E-03 1.23970206519E-03 9.53569979124E-04 7.28394495230E-04 5.52444963598E-04 4.15956322780E-04 3.10863603533E-04 2.30558422176E-04 1.69670062796E-04 1.23869751783E-04 8.96978572944E-05 6.44131854576E-05 4.58628067488E-05 3.23709005455E-05 2.26448842907E-05 1.56970165064E-05 1.07796229023E-05 7.33220062225E-06 4.93868027793E-06 3.29329859308E-06 2.17364082405E-06 1.41960734920E-06 9.17173538900E-07 5.86010515577E-07 3.70152315431E-07 2.31057002880E-07 1.42546767838E-07 8.68931575221E-08 5.23201825350E-08 3.11079036664E-08 1.82578195566E-08 1.05744841057E-08 6.04162010427E-09 3.40392308423E-09 1.89052556977E-09 1.03467123901E-09 5.57796416152E-10 2.96097686370E-10 1.54706469600E-10 7.95279943828E-11 4.02058440895E-11 1.99816335008E-11 9.75788816220E-12 4.68025536271E-12 2.20380626804E-12 1.01827414674E-12 4.61463594204E-13 2.05014946925E-13 8.92502785130E-14 3.80570669856E-14 1.58913316061E-14 6.49946773805E-15 2.60740042836E-15 1.03084533573E-15 4.07120145099E-16 1.56973730355E-16 5.90528865361E-17 2.16617187479E-17 7.74289322406E-18 2.69517051949E-18 9.12953280198E-19 3.00738870230E-19 9.62722373209E-20 2.99272711938E-20 9.02742082866E-21 2.64033320961E-21 7.48189797580E-22 2.05245510447E-22 5.44611281833E-23 1.39663735504E-23 3.45850628223E-24 8.26258107363E-25 1.90269739282E-25 4.21934575465E-26 9.00173688475E-27 1.84581078498E-27 3.63404947693E-28 GWW/examples/example02/si_pw4gww_planewaves.in0000755000077300007730000000027412341332532022140 0ustar giannozzgiannozz&inputpw4gww prefix='si' num_nbndv(1)=16 num_nbnds=32 l_truncated_coulomb=.false. numw_prod=100 pmat_cutoff=3d0 pmat_type=5 s_self_lanczos=1d-8 / GWW/examples/example02/input_tmp.in0000644000077300007730000000116212341332532017772 0ustar giannozzgiannozz &control calculation='nscf' restart_mode='from_scratch', prefix='si' pseudo_dir='./' / &system ibrav= 8, celldm(1)= 10.26,celldm(2)= 1, celldm(3)=1, nat= 8, ntyp= 1, ecutwfc = 15.0, nosym=.true. nbnd=32 / &electrons diagonalization='cg', conv_thr = 1.0d-10, mixing_beta = 0.5, startingwfc='random', / ATOMIC_SPECIES Si 1. Si.pz-vbc.UPF ATOMIC_POSITIONS (crystal) Si 0.00000 0.00000 0.00000 Si 0.50000 0.50000 0.00000 Si 0.00000 0.50000 0.50000 Si 0.50000 0.00000 0.50000 Si 0.25000 0.25000 0.25000 Si 0.75000 0.75000 0.25000 Si 0.75000 0.25000 0.75000 Si 0.25000 0.75000 0.75000 GWW/examples/example02/si_nscf.in0000755000077300007730000000112512341332532017401 0ustar giannozzgiannozz&control calculation='nscf' restart_mode='from_scratch', prefix='si' pseudo_dir='./' / &system ibrav= 8, celldm(1)= 10.26,celldm(2)= 1, celldm(3)=1, nat= 8, ntyp= 1, ecutwfc = 15.0, nosym=.true. nbnd=32 / &electrons diagonalization='cg', conv_thr = 1.0d-10, mixing_beta = 0.5, startingwfc='random', / ATOMIC_SPECIES Si 1. Si.pz-vbc.UPF ATOMIC_POSITIONS (crystal) Si 0.00000 0.00000 0.00000 Si 0.50000 0.50000 0.00000 Si 0.00000 0.50000 0.50000 Si 0.50000 0.00000 0.50000 Si 0.25000 0.25000 0.25000 Si 0.75000 0.75000 0.25000 Si 0.75000 0.25000 0.75000 Si 0.25000 0.75000 0.75000 GWW/examples/example02/si_scf_k.in0000755000077300007730000000113612341332532017537 0ustar giannozzgiannozz&control calculation='scf' restart_mode='from_scratch', prefix='si' pseudo_dir='./' / &system ibrav= 8, celldm(1)= 10.26,celldm(2)= 1, celldm(3)=1, nat= 8, ntyp= 1, ecutwfc = 15.0 / &electrons diagonalization='david', conv_thr = 1.0d-10, mixing_beta = 0.5, startingwfc='random', / ATOMIC_SPECIES Si 1. Si.pz-vbc.UPF ATOMIC_POSITIONS (crystal) Si 0.00000 0.00000 0.00000 Si 0.50000 0.50000 0.00000 Si 0.00000 0.50000 0.50000 Si 0.50000 0.00000 0.50000 Si 0.25000 0.25000 0.25000 Si 0.75000 0.75000 0.25000 Si 0.75000 0.25000 0.75000 Si 0.25000 0.75000 0.75000 K_POINTS (automatic) 4 4 4 1 1 1 GWW/examples/example02/si_gww.in0000755000077300007730000000046612341332532017263 0ustar giannozzgiannozz&inputgww ggwin%prefix='si' ggwin%n=97, ggwin%n_fit=120, ggwin%max_i=32, ggwin%i_min=1 ggwin%i_max=32 ggwin%l_truncated_coulomb=.false. ggwin%grid_time=3 ggwin%grid_freq=5 ggwin%second_grid_i=1 ggwin%second_grid_n=10 ggwin%omega=20 ggwin%omega_fit=20 ggwin%n_grid_fit=240 ggwin%tau=9.8 ggwin%n_set_pola=16 / GWW/examples/example02/reference/0000755000077300007730000000000012341332543017363 5ustar giannozzgiannozzGWW/examples/example02/reference/si_nscf.out0000644000077300007730000001624312341332532021544 0ustar giannozzgiannozz Program PWSCF v.4.3.2 starts on 16Sep2011 at 15:40: 5 This program is part of the open-source Quantum ESPRESSO suite for quantum simulation of materials; please cite "P. Giannozzi et al., J. Phys.:Condens. Matter 21 395502 (2009); URL http://www.quantum-espresso.org", in publications or presentations arising from this work. More details at http://www.quantum-espresso.org/quote.php Parallel version (MPI), running on 2 processors R & G space division: proc/pool = 2 EXPERIMENTAL VERSION WITH EXACT EXCHANGE Current dimensions of program PWSCF are: Max number of different atomic species (ntypx) = 10 Max number of k-points (npk) = 40000 Max angular momentum in pseudopotentials (lmaxx) = 3 Waiting for input... Reading input from stdin Atomic positions and unit cell read from directory: ./si.save/ gamma-point specific algorithms are used Subspace diagonalization in iterative solution of the eigenvalue problem: a serial algorithm will be used Found symmetry operation: I + ( -0.5000 -0.5000 0.0000) This is a supercell, fractional translations are disabled ATT1.1.1 ATT1.1.2 ATT1.1.3 ATT1.1.4 ATT1.1.5 ATT1.1.6 Parallelization info -------------------- sticks: dense smooth PW G-vecs: dense smooth PW Min 247 247 60 4191 4191 508 Max 250 250 61 4194 4194 513 Sum 497 497 121 8385 8385 1021 Tot 249 249 61 bravais-lattice index = 8 lattice parameter (alat) = 10.2600 a.u. unit-cell volume = 1080.0456 (a.u.)^3 number of atoms/cell = 8 number of atomic types = 1 number of electrons = 32.00 number of Kohn-Sham states= 32 kinetic-energy cutoff = 15.0000 Ry charge density cutoff = 60.0000 Ry Exchange-correlation = SLA PZ NOGX NOGC ( 1 1 0 0 0) EXX-fraction = 0.00 celldm(1)= 10.260000 celldm(2)= 1.000000 celldm(3)= 1.000000 celldm(4)= 0.000000 celldm(5)= 0.000000 celldm(6)= 0.000000 crystal axes: (cart. coord. in units of alat) a(1) = ( 1.000000 0.000000 0.000000 ) a(2) = ( 0.000000 1.000000 0.000000 ) a(3) = ( 0.000000 0.000000 1.000000 ) reciprocal axes: (cart. coord. in units 2 pi/alat) b(1) = ( 1.000000 0.000000 0.000000 ) b(2) = ( 0.000000 1.000000 0.000000 ) b(3) = ( 0.000000 0.000000 1.000000 ) PseudoPot. # 1 for Si read from file: ./Si.pz-vbc.UPF MD5 check sum: 6dfa03ddd5817404712e03e4d12deb78 Pseudo is Norm-conserving, Zval = 4.0 Generated by new atomic code, or converted to UPF format Using radial grid of 431 points, 2 beta functions with: l(1) = 0 l(2) = 1 atomic species valence mass pseudopotential Si 4.00 1.00000 Si( 1.00) No symmetry found Cartesian axes site n. atom positions (alat units) 1 Si tau( 1) = ( 0.0000000 0.0000000 0.0000000 ) 2 Si tau( 2) = ( 0.5000000 0.5000000 0.0000000 ) 3 Si tau( 3) = ( 0.0000000 0.5000000 0.5000000 ) 4 Si tau( 4) = ( 0.5000000 0.0000000 0.5000000 ) 5 Si tau( 5) = ( 0.2500000 0.2500000 0.2500000 ) 6 Si tau( 6) = ( 0.7500000 0.7500000 0.2500000 ) 7 Si tau( 7) = ( 0.7500000 0.2500000 0.7500000 ) 8 Si tau( 8) = ( 0.2500000 0.7500000 0.7500000 ) number of k points= 1 cart. coord. in units 2pi/alat k( 1) = ( 0.0000000 0.0000000 0.0000000), wk = 2.0000000 Dense grid: 4193 G-vectors FFT dimensions: ( 25, 25, 25) Largest allocated arrays est. size (Mb) dimensions Kohn-Sham Wavefunctions 0.13 Mb ( 257, 32) NL pseudopotentials 0.13 Mb ( 257, 32) Each V/rho on FFT grid 0.12 Mb ( 8125) Each G-vector array 0.02 Mb ( 2096) G-vector shells 0.00 Mb ( 133) Largest temporary arrays est. size (Mb) dimensions Each subspace H/S matrix 0.01 Mb ( 32, 32) Each matrix 0.01 Mb ( 32, 32) The potential is recalculated from file : ./si.save/charge-density.dat Starting wfc are random total cpu time spent up to now is 0.3 secs Band Structure Calculation CG style diagonalization ethr = 3.13E-13, avg # of iterations = 39.3 total cpu time spent up to now is 1.8 secs End of band structure calculation k = 0.0000 0.0000 0.0000 band energies (ev): -5.8356 -1.6936 -1.6936 -1.6935 -1.6935 -1.6935 -1.6935 3.2044 3.2044 3.2044 3.2044 3.2044 3.2044 6.0789 6.0789 6.0789 6.7558 6.7558 6.7558 6.7558 6.7558 6.7558 8.6434 8.6434 8.6434 9.3574 13.7717 13.9854 13.9854 16.1090 16.1090 16.1090 highest occupied, lowest unoccupied level (ev): 6.0789 6.7558 Writing output data file si.save init_run : 0.04s CPU 0.07s WALL ( 1 calls) electrons : 1.38s CPU 1.54s WALL ( 1 calls) Called by init_run: wfcinit : 0.00s CPU 0.00s WALL ( 1 calls) potinit : 0.01s CPU 0.01s WALL ( 1 calls) Called by electrons: c_bands : 1.38s CPU 1.54s WALL ( 1 calls) v_of_rho : 0.00s CPU 0.00s WALL ( 1 calls) Called by c_bands: init_us_2 : 0.00s CPU 0.00s WALL ( 1 calls) rcgdiagg : 1.31s CPU 1.47s WALL ( 4 calls) wfcrot : 0.06s CPU 0.07s WALL ( 4 calls) Called by *cgdiagg: h_psi : 1.05s CPU 1.15s WALL ( 1133 calls) rdiaghg : 0.00s CPU 0.00s WALL ( 4 calls) Called by h_psi: add_vuspsi : 0.03s CPU 0.04s WALL ( 1133 calls) General routines calbec : 0.04s CPU 0.06s WALL ( 2262 calls) fft : 0.00s CPU 0.00s WALL ( 3 calls) fftw : 0.87s CPU 0.95s WALL ( 2386 calls) davcio : 0.00s CPU 0.00s WALL ( 2 calls) Parallel routines fft_scatter : 0.11s CPU 0.17s WALL ( 2389 calls) EXX routines PWSCF : 1.52s CPU 1.87s WALL This run was terminated on: 15:40: 7 16Sep2011 =------------------------------------------------------------------------------= JOB DONE. =------------------------------------------------------------------------------= GWW/examples/example02/reference/si_scf_k.out0000644000077300007730000003050112341332532021671 0ustar giannozzgiannozz Program PWSCF v.4.3.2 starts on 16Sep2011 at 15:34:11 This program is part of the open-source Quantum ESPRESSO suite for quantum simulation of materials; please cite "P. Giannozzi et al., J. Phys.:Condens. Matter 21 395502 (2009); URL http://www.quantum-espresso.org", in publications or presentations arising from this work. More details at http://www.quantum-espresso.org/quote.php Parallel version (MPI), running on 2 processors R & G space division: proc/pool = 2 EXPERIMENTAL VERSION WITH EXACT EXCHANGE Current dimensions of program PWSCF are: Max number of different atomic species (ntypx) = 10 Max number of k-points (npk) = 40000 Max angular momentum in pseudopotentials (lmaxx) = 3 Waiting for input... Reading input from stdin Subspace diagonalization in iterative solution of the eigenvalue problem: a serial algorithm will be used Found symmetry operation: I + ( -0.5000 -0.5000 0.0000) This is a supercell, fractional translations are disabled ATT1.1.6 Parallelization info -------------------- sticks: dense smooth PW G-vecs: dense smooth PW Min 248 248 72 4192 4192 682 Max 249 249 73 4193 4193 683 Sum 497 497 145 8385 8385 1365 bravais-lattice index = 8 lattice parameter (alat) = 10.2600 a.u. unit-cell volume = 1080.0456 (a.u.)^3 number of atoms/cell = 8 number of atomic types = 1 number of electrons = 32.00 number of Kohn-Sham states= 16 kinetic-energy cutoff = 15.0000 Ry charge density cutoff = 60.0000 Ry convergence threshold = 1.0E-10 mixing beta = 0.5000 number of iterations used = 8 plain mixing Exchange-correlation = SLA PZ NOGX NOGC ( 1 1 0 0 0) EXX-fraction = 0.00 celldm(1)= 10.260000 celldm(2)= 1.000000 celldm(3)= 1.000000 celldm(4)= 0.000000 celldm(5)= 0.000000 celldm(6)= 0.000000 crystal axes: (cart. coord. in units of alat) a(1) = ( 1.000000 0.000000 0.000000 ) a(2) = ( 0.000000 1.000000 0.000000 ) a(3) = ( 0.000000 0.000000 1.000000 ) reciprocal axes: (cart. coord. in units 2 pi/alat) b(1) = ( 1.000000 0.000000 0.000000 ) b(2) = ( 0.000000 1.000000 0.000000 ) b(3) = ( 0.000000 0.000000 1.000000 ) PseudoPot. # 1 for Si read from file: ./Si.pz-vbc.UPF MD5 check sum: 6dfa03ddd5817404712e03e4d12deb78 Pseudo is Norm-conserving, Zval = 4.0 Generated by new atomic code, or converted to UPF format Using radial grid of 431 points, 2 beta functions with: l(1) = 0 l(2) = 1 atomic species valence mass pseudopotential Si 4.00 1.00000 Si( 1.00) 24 Sym. Ops. (no inversion) found Cartesian axes site n. atom positions (alat units) 1 Si tau( 1) = ( 0.0000000 0.0000000 0.0000000 ) 2 Si tau( 2) = ( 0.5000000 0.5000000 0.0000000 ) 3 Si tau( 3) = ( 0.0000000 0.5000000 0.5000000 ) 4 Si tau( 4) = ( 0.5000000 0.0000000 0.5000000 ) 5 Si tau( 5) = ( 0.2500000 0.2500000 0.2500000 ) 6 Si tau( 6) = ( 0.7500000 0.7500000 0.2500000 ) 7 Si tau( 7) = ( 0.7500000 0.2500000 0.7500000 ) 8 Si tau( 8) = ( 0.2500000 0.7500000 0.7500000 ) number of k points= 4 cart. coord. in units 2pi/alat k( 1) = ( 0.1250000 0.1250000 0.1250000), wk = 0.2500000 k( 2) = ( 0.1250000 0.1250000 0.3750000), wk = 0.7500000 k( 3) = ( 0.1250000 0.3750000 0.3750000), wk = 0.7500000 k( 4) = ( 0.3750000 0.3750000 0.3750000), wk = 0.2500000 Dense grid: 8385 G-vectors FFT dimensions: ( 25, 25, 25) Largest allocated arrays est. size (Mb) dimensions Kohn-Sham Wavefunctions 0.13 Mb ( 534, 16) NL pseudopotentials 0.26 Mb ( 534, 32) Each V/rho on FFT grid 0.12 Mb ( 8125) Each G-vector array 0.03 Mb ( 4192) G-vector shells 0.00 Mb ( 134) Largest temporary arrays est. size (Mb) dimensions Auxiliary wavefunctions 0.52 Mb ( 534, 64) Each subspace H/S matrix 0.06 Mb ( 64, 64) Each matrix 0.01 Mb ( 32, 16) Arrays for rho mixing 0.99 Mb ( 8125, 8) Initial potential from superposition of free atoms starting charge 31.99603, renormalised to 32.00000 Starting wfc are random total cpu time spent up to now is 0.5 secs Self-consistent Calculation iteration # 1 ecut= 15.00 Ry beta=0.50 Davidson diagonalization with overlap ethr = 1.00E-02, avg # of iterations = 7.0 Threshold (ethr) on eigenvalues was too large: Diagonalizing with lowered threshold Davidson diagonalization with overlap ethr = 7.41E-04, avg # of iterations = 1.8 Exx not active 0. total cpu time spent up to now is 1.5 secs total energy = -63.33724468 Ry Harris-Foulkes estimate = -63.40289217 Ry estimated scf accuracy < 0.23836628 Ry iteration # 2 ecut= 15.00 Ry beta=0.50 Davidson diagonalization with overlap ethr = 7.45E-04, avg # of iterations = 1.0 Exx not active 0. total cpu time spent up to now is 1.8 secs total energy = -63.33375275 Ry Harris-Foulkes estimate = -63.34485875 Ry estimated scf accuracy < 0.03910822 Ry iteration # 3 ecut= 15.00 Ry beta=0.50 Davidson diagonalization with overlap ethr = 1.22E-04, avg # of iterations = 2.0 Exx not active 0. total cpu time spent up to now is 2.1 secs total energy = -63.33767848 Ry Harris-Foulkes estimate = -63.33807270 Ry estimated scf accuracy < 0.00094620 Ry iteration # 4 ecut= 15.00 Ry beta=0.50 Davidson diagonalization with overlap ethr = 2.96E-06, avg # of iterations = 3.0 Exx not active 0. total cpu time spent up to now is 2.4 secs total energy = -63.33797841 Ry Harris-Foulkes estimate = -63.33810520 Ry estimated scf accuracy < 0.00025887 Ry iteration # 5 ecut= 15.00 Ry beta=0.50 Davidson diagonalization with overlap ethr = 8.09E-07, avg # of iterations = 2.0 Exx not active 0. total cpu time spent up to now is 2.8 secs total energy = -63.33801471 Ry Harris-Foulkes estimate = -63.33801448 Ry estimated scf accuracy < 0.00000136 Ry iteration # 6 ecut= 15.00 Ry beta=0.50 Davidson diagonalization with overlap ethr = 4.26E-09, avg # of iterations = 4.2 Exx not active 0. total cpu time spent up to now is 3.2 secs total energy = -63.33801535 Ry Harris-Foulkes estimate = -63.33801602 Ry estimated scf accuracy < 0.00000199 Ry iteration # 7 ecut= 15.00 Ry beta=0.50 Davidson diagonalization with overlap ethr = 4.26E-09, avg # of iterations = 1.0 Exx not active 0. total cpu time spent up to now is 3.5 secs total energy = -63.33801530 Ry Harris-Foulkes estimate = -63.33801542 Ry estimated scf accuracy < 0.00000026 Ry iteration # 8 ecut= 15.00 Ry beta=0.50 Davidson diagonalization with overlap ethr = 8.15E-10, avg # of iterations = 2.2 Exx not active 0. total cpu time spent up to now is 3.8 secs total energy = -63.33801534 Ry Harris-Foulkes estimate = -63.33801534 Ry estimated scf accuracy < 4.4E-09 Ry iteration # 9 ecut= 15.00 Ry beta=0.50 Davidson diagonalization with overlap ethr = 1.37E-11, avg # of iterations = 3.0 Exx not active 0. total cpu time spent up to now is 4.1 secs total energy = -63.33801534 Ry Harris-Foulkes estimate = -63.33801534 Ry estimated scf accuracy < 1.6E-09 Ry iteration # 10 ecut= 15.00 Ry beta=0.50 Davidson diagonalization with overlap ethr = 5.13E-12, avg # of iterations = 2.0 Exx not active 0. total cpu time spent up to now is 4.4 secs End of self-consistent calculation k = 0.1250 0.1250 0.1250 ( 1060 PWs) bands (ev): -5.6482 -2.5539 -2.5539 -2.5539 -0.7104 -0.7104 -0.7103 2.6086 2.6086 2.6086 3.3742 3.3742 3.3742 4.4787 5.7832 5.7832 k = 0.1250 0.1250 0.3750 ( 1065 PWs) bands (ev): -5.1102 -4.0553 -2.3711 -2.3711 -0.8194 -0.8194 1.1657 1.9768 1.9768 2.8614 3.0895 3.0895 3.3850 3.8526 4.7449 4.8250 k = 0.1250 0.3750 0.3750 ( 1058 PWs) bands (ev): -4.5976 -3.6263 -3.6263 -2.9152 -0.5444 0.2538 0.2538 1.4572 2.0519 2.7308 2.7308 3.7475 4.1305 4.1305 4.1756 5.2937 k = 0.3750 0.3750 0.3750 ( 1046 PWs) bands (ev): -4.1528 -3.4191 -3.4191 -3.4191 -0.6736 -0.6736 -0.6736 0.1234 3.7875 3.7875 3.7876 4.5018 4.5018 4.5018 4.9800 4.9800 ! total energy = -63.33801534 Ry Harris-Foulkes estimate = -63.33801534 Ry estimated scf accuracy < 1.1E-11 Ry The total energy is the sum of the following terms: one-electron contribution = 18.68312209 Ry hartree contribution = 4.35517119 Ry xc contribution = -19.17259032 Ry ewald contribution = -67.20371830 Ry - averaged Fock potential = -0.00000000 Ry + Fock energy = 0.00000000 Ry DEXX 0. 1.E-10 convergence has been achieved in 10 iterations Writing output data file si.save init_run : 0.17s CPU 0.42s WALL ( 1 calls) electrons : 3.38s CPU 3.91s WALL ( 1 calls) Called by init_run: wfcinit : 0.09s CPU 0.29s WALL ( 1 calls) potinit : 0.01s CPU 0.01s WALL ( 1 calls) Called by electrons: c_bands : 2.84s CPU 3.20s WALL ( 11 calls) sum_band : 0.45s CPU 0.57s WALL ( 11 calls) v_of_rho : 0.03s CPU 0.03s WALL ( 11 calls) mix_rho : 0.03s CPU 0.05s WALL ( 11 calls) Called by c_bands: init_us_2 : 0.07s CPU 0.07s WALL ( 92 calls) cegterg : 2.68s CPU 3.02s WALL ( 44 calls) Called by *egterg: h_psi : 2.10s CPU 2.41s WALL ( 165 calls) g_psi : 0.02s CPU 0.02s WALL ( 117 calls) cdiaghg : 0.22s CPU 0.40s WALL ( 157 calls) Called by h_psi: add_vuspsi : 0.09s CPU 0.10s WALL ( 165 calls) General routines calbec : 0.12s CPU 0.17s WALL ( 165 calls) fft : 0.03s CPU 0.05s WALL ( 45 calls) fftw : 1.94s CPU 2.29s WALL ( 4926 calls) davcio : 0.07s CPU 0.11s WALL ( 136 calls) Parallel routines fft_scatter : 0.29s CPU 0.57s WALL ( 4971 calls) EXX routines PWSCF : 3.61s CPU 4.48s WALL This run was terminated on: 15:34:16 16Sep2011 =------------------------------------------------------------------------------= JOB DONE. =------------------------------------------------------------------------------= GWW/examples/example02/reference/si_head.out0000644000077300007730000056761712341332532021534 0ustar giannozzgiannozz Program PHONON v.4.3.2 starts on 16Sep2011 at 15:35:44 This program is part of the open-source Quantum ESPRESSO suite for quantum simulation of materials; please cite "P. Giannozzi et al., J. Phys.:Condens. Matter 21 395502 (2009); URL http://www.quantum-espresso.org", in publications or presentations arising from this work. More details at http://www.quantum-espresso.org/quote.php Parallel version (MPI), running on 2 processors R & G space division: proc/pool = 2 Ultrasoft (Vanderbilt) Pseudopotentials Info: using nr1, nr2, nr3 values from input Info: using nr1s, nr2s, nr3s values from input IMPORTANT: XC functional enforced from input : Exchange-correlation = SLA PZ NOGX NOGC ( 1 1 0 0 0) EXX-fraction = 0.00 Any further DFT definition will be discarded Please, verify this is what you really want ATT1.1.6 Parallelization info -------------------- sticks: dense smooth PW G-vecs: dense smooth PW Min 248 248 72 4192 4192 682 Max 249 249 73 4193 4193 683 Sum 497 497 145 8385 8385 1365 IMPORTANT: XC functional enforced from input : Exchange-correlation = SLA PZ NOGX NOGC ( 1 1 0 0 0) EXX-fraction = 0.00 Any further DFT definition will be discarded Please, verify this is what you really want EXX fraction changed: 0.00 EXX Screening parameter changed: 0.0000000 Calculation of q = 0.0000000 0.0000000 0.0000000 bravais-lattice index = 8 lattice parameter (alat) = 10.2600 a.u. unit-cell volume = 1080.0456 (a.u.)^3 number of atoms/cell = 8 number of atomic types = 1 kinetic-energy cut-off = 15.0000 Ry charge density cut-off = 60.0000 Ry convergence threshold = 1.0E-04 beta = 0.7000 number of iterations used = 4 Exchange-correlation = SLA PZ NOGX NOGC ( 1 1 0 0 0) EXX-fraction = 0.00 celldm(1)= 10.26000 celldm(2)= 1.00000 celldm(3)= 1.00000 celldm(4)= 0.00000 celldm(5)= 0.00000 celldm(6)= 0.00000 crystal axes: (cart. coord. in units of alat) a(1) = ( 1.0000 0.0000 0.0000 ) a(2) = ( 0.0000 1.0000 0.0000 ) a(3) = ( 0.0000 0.0000 1.0000 ) reciprocal axes: (cart. coord. in units 2 pi/alat) b(1) = ( 1.0000 0.0000 0.0000 ) b(2) = ( 0.0000 1.0000 0.0000 ) b(3) = ( 0.0000 0.0000 1.0000 ) Atoms inside the unit cell: Cartesian axes site n. atom mass positions (alat units) 1 Si 1.0000 tau( 1) = ( 0.00000 0.00000 0.00000 ) 2 Si 1.0000 tau( 2) = ( 0.50000 0.50000 0.00000 ) 3 Si 1.0000 tau( 3) = ( 0.00000 0.50000 0.50000 ) 4 Si 1.0000 tau( 4) = ( 0.50000 0.00000 0.50000 ) 5 Si 1.0000 tau( 5) = ( 0.25000 0.25000 0.25000 ) 6 Si 1.0000 tau( 6) = ( 0.75000 0.75000 0.25000 ) 7 Si 1.0000 tau( 7) = ( 0.75000 0.25000 0.75000 ) 8 Si 1.0000 tau( 8) = ( 0.25000 0.75000 0.75000 ) Computing dynamical matrix for q = ( 0.0000000 0.0000000 0.0000000 ) 25 Sym.Ops. (with q -> -q+G ) G cutoff = 159.9876 ( 4192 G-vectors) FFT grid: ( 25, 25, 25) number of k points= 4 cart. coord. in units 2pi/alat k( 1) = ( 0.1250000 0.1250000 0.1250000), wk = 0.2500000 k( 2) = ( 0.1250000 0.1250000 0.3750000), wk = 0.7500000 k( 3) = ( 0.1250000 0.3750000 0.3750000), wk = 0.7500000 k( 4) = ( 0.3750000 0.3750000 0.3750000), wk = 0.2500000 PseudoPot. # 1 for Si read from file: ./Si.pz-vbc.UPF MD5 check sum: 6dfa03ddd5817404712e03e4d12deb78 Pseudo is Norm-conserving, Zval = 4.0 Generated by new atomic code, or converted to UPF format Using radial grid of 431 points, 2 beta functions with: l(1) = 0 l(2) = 1 Atomic displacements: There are 24 irreducible representations Representation 1 1 modes - To be done Representation 2 1 modes - To be done Representation 3 1 modes - To be done Representation 4 1 modes - To be done Representation 5 1 modes - To be done Representation 6 1 modes - To be done Representation 7 1 modes - To be done Representation 8 1 modes - To be done Representation 9 1 modes - To be done Representation 10 1 modes - To be done Representation 11 1 modes - To be done Representation 12 1 modes - To be done Representation 13 1 modes - To be done Representation 14 1 modes - To be done Representation 15 1 modes - To be done Representation 16 1 modes - To be done Representation 17 1 modes - To be done Representation 18 1 modes - To be done Representation 19 1 modes - To be done Representation 20 1 modes - To be done Representation 21 1 modes - To be done Representation 22 1 modes - To be done Representation 23 1 modes - To be done Representation 24 1 modes - To be done PHONON : 0.41s CPU 0.74s WALL Routine solve_head Freq 1 0. Freq 2 0.005154639175257732 Freq 3 0.015463917525773196 Freq 4 0.025773195876288662 Freq 5 0.03608247422680412 Freq 6 0.04639175257731958 Freq 7 0.05670103092783505 Freq 8 0.06701030927835051 Freq 9 0.07731958762886598 Freq 10 0.08762886597938145 Freq 11 0.0979381443298969 Freq 12 0.10824742268041238 Freq 13 0.11855670103092784 Freq 14 0.12886597938144329 Freq 15 0.13917525773195874 Freq 16 0.14948453608247422 Freq 17 0.15979381443298968 Freq 18 0.17010309278350513 Freq 19 0.18041237113402062 Freq 20 0.19072164948453607 Freq 21 0.20103092783505153 Freq 22 0.20618556701030927 Freq 23 0.211340206185567 Freq 24 0.22164948453608246 Freq 25 0.23195876288659792 Freq 26 0.2422680412371134 Freq 27 0.25257731958762886 Freq 28 0.26288659793814434 Freq 29 0.2731958762886598 Freq 30 0.28350515463917525 Freq 31 0.29381443298969073 Freq 32 0.3041237113402062 Freq 33 0.41237113402061853 Freq 34 0.6185567010309279 Freq 35 0.8247422680412371 Freq 36 1.0309278350515463 Freq 37 1.2371134020618557 Freq 38 1.443298969072165 Freq 39 1.6494845360824741 Freq 40 1.8556701030927834 Freq 41 2.0618556701030926 Freq 42 2.268041237113402 Freq 43 2.4742268041237114 Freq 44 2.6804123711340204 Freq 45 2.88659793814433 Freq 46 3.092783505154639 Freq 47 3.2989690721649483 Freq 48 3.5051546391752577 Freq 49 3.7113402061855667 Freq 50 3.917525773195876 Freq 51 4.123711340206185 Freq 52 4.329896907216495 Freq 53 4.536082474226804 Freq 54 4.742268041237113 Freq 55 4.948453608247423 Freq 56 5.154639175257731 Freq 57 5.360824742268041 Freq 58 5.56701030927835 Freq 59 5.77319587628866 Freq 60 5.979381443298969 Freq 61 6.185567010309278 Freq 62 6.391752577319587 Freq 63 6.597938144329897 Freq 64 6.804123711340206 Freq 65 7.010309278350515 Freq 66 7.216494845360824 Freq 67 7.422680412371133 Freq 68 7.628865979381443 Freq 69 7.835051546391752 Freq 70 8.041237113402062 Freq 71 8.24742268041237 Freq 72 8.45360824742268 Freq 73 8.65979381443299 Freq 74 8.865979381443298 Freq 75 9.072164948453608 Freq 76 9.278350515463917 Freq 77 9.484536082474227 Freq 78 9.690721649484535 Freq 79 9.896907216494846 Freq 80 10.103092783505154 Freq 81 10.309278350515463 Freq 82 10.515463917525773 Freq 83 10.721649484536082 Freq 84 10.927835051546392 Freq 85 11.1340206185567 Freq 86 11.340206185567009 Freq 87 11.54639175257732 Freq 88 11.752577319587628 Freq 89 11.958762886597938 Freq 90 12.164948453608247 Freq 91 12.371134020618555 Freq 92 12.577319587628866 Freq 93 12.783505154639174 Freq 94 12.989690721649485 Freq 95 13.195876288659793 Freq 96 13.402061855670102 Freq 97 13.608247422680412 Freq 98 13.81443298969072 Freq 99 14.02061855670103 Freq 100 14.22680412371134 Freq 101 14.432989690721648 Freq 102 14.639175257731958 Freq 103 14.845360824742267 Freq 104 15.051546391752577 Freq 105 15.257731958762886 Freq 106 15.463917525773194 Freq 107 15.670103092783505 Freq 108 15.876288659793813 Freq 109 16.082474226804123 Freq 110 16.288659793814432 Freq 111 16.49484536082474 Freq 112 16.70103092783505 Freq 113 16.90721649484536 Freq 114 17.11340206185567 Freq 115 17.31958762886598 Freq 116 17.525773195876287 Freq 117 17.731958762886595 Freq 118 17.938144329896907 Freq 119 18.144329896907216 Freq 120 18.350515463917525 Freq 121 18.556701030927833 Freq 122 18.76288659793814 Freq 123 18.969072164948454 Freq 124 19.175257731958762 Freq 125 19.38144329896907 Freq 126 19.58762886597938 Freq 127 19.79381443298969 Freq 128 20. ik: 1 ipol: 1 before lanczos_state_k Lanczos N1 1.7869124915815684 1.8883923019509363 1.3591953334688476 1.5477905436415782 1.4164823252269694 1.2943387867162692 1.3497667674333882 0.7125508878417742 0.6924979169503213 0.7460256460649055 0.5461996797899602 0.5641405864900643 0.5527642946596356 0.903322877682871 0.6908620497246275 0.6910274944237459 Lanczos alpha (0.6766937787468074,8.174812057768283E-18) (0.6862744263144461,-5.576971492323466E-17) (0.6498525356516635,-4.1293543238266595E-17) (0.6557240586235155,-4.113974082050433E-19) (0.6851241099106041,-4.980566543243967E-18) (0.6872958575842942,6.044724141278776E-17) (0.6855930134833788,2.408821015892976E-17) (0.8885766763430085,4.911723285311862E-17) (0.9020726323866534,2.684667917023671E-16) (0.8683859817700894,-2.4489718467673036E-17) (0.9571093720139426,-9.63642050596414E-17) (0.9394746344783489,-1.936413050197549E-16) (0.950474725394577,2.9320922796590177E-16) (0.9048645738272625,2.2035780304308293E-16) (0.9736343495612761,-2.3477428680368513E-16) (0.9737903205953025,-1.6191781818147463E-16) Lanczos beta 0.7362645786708523 0.7273427058730824 0.7600603146508205 0.7550006350608625 0.7284263545611207 0.7263775906148741 0.7279850409608557 0.45872812237665817 0.43158425121755106 0.49588888540196036 0.2897268541282938 0.3426184629756171 0.3108018603324396 0.42569954549236605 0.22811434271959327 0.22744760169079925 Lanczos Diagonal 1 (1.2091925662182041,1.4607673782357772E-17) (1.2959553436779951,-1.0531510034303459E-16) (0.8832765339006389,-5.612599127184604E-17) (1.014923497175753,-6.367570180984203E-19) (0.9704661922752302,-7.054884478121864E-18) (0.8895936864207732,7.823920911057314E-17) (0.9253906655843754,3.2513465559474725E-17) (0.6331560996437036,3.4998527877820834E-17) (0.6246834188656504,1.8591269402422502E-16) (0.6478382130837382,-1.8269958041793424E-17) (0.5227728325179853,-5.263409794679019E-17) (0.5299957712871545,-1.0924091938254596E-16) (0.5253884911745442,1.62075592084268E-16) (0.8173848707429274,1.9905424476475298E-16) (0.6726470224202077,-1.6219664500383146E-16) (0.6729158853350681,-1.1188966420050406E-16) ATTENZIONE1 lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat after lanczos_state_k ipol: 2 before lanczos_state_k Lanczos N1 1.7869124266727687 1.7417330550870829 1.4147375697108397 1.5477905180993752 1.8605524375014053 1.1513374848644584 1.3497667199419692 0.7125508887130615 0.7043879455396213 0.7223056529016878 0.5482145287925189 0.5592010945259516 0.5527642924000503 0.9033227787626741 0.690987636834781 0.6908876783919747 Lanczos alpha (0.6766937785129429,-1.2482829664079715E-18) (0.670662969509796,6.061459931257578E-17) (0.6504898256834962,-4.3832777870741823E-17) (0.6557240497347391,2.5890227715733315E-18) (0.7126393992095883,-1.6411227625890744E-18) (0.6984675413322231,-2.172800454253418E-17) (0.685593011626298,-4.457131112504227E-17) (0.8885766750022271,-1.4500874225393391E-16) (0.8939361833471826,2.0646668684313353E-16) (0.8824033368885935,-1.8826071130811452E-16) (0.9550501497780017,-9.585634860809234E-17) (0.9441753054917253,2.5397590212748334E-18) (0.9504747280819777,-2.9844739845681277E-16) (0.9048645945475648,2.3564374171404213E-17) (0.9737526965584653,1.1422768505454072E-16) (0.9736584847567001,8.662473191082898E-17) Lanczos beta 0.7362645788857938 0.7417622134675662 0.7595149680435889 0.7550006427808343 0.701530531548126 0.715641735580953 0.7279850427097962 0.45872812497380955 0.448194266030563 0.47049373114620363 0.2964442804457782 0.32944345872942593 0.31080185211399836 0.42569950144940105 0.22760862449634203 0.22801130467870626 Lanczos Diagonal 1 (1.209192521876928,-2.2305723446783505E-18) (1.1681158628180721,1.0557445124357201E-16) (0.9202723951090972,-6.201187763852837E-17) (1.0149234666691522,4.007264896984567E-18) (1.3259029712589365,-3.0533949561741425E-18) (0.8041718622969038,-2.501626610112483E-17) (0.9253906305179647,-6.01608724207613E-17) (0.6331560994625341,-1.0332610816420388E-16) (0.6296778716314522,1.4543264536780718E-16) (0.6373649183739435,-1.3598177599714382E-16) (0.5235723678337718,-5.254984298395676E-17) (0.5279838642553475,1.4202360245290464E-18) (0.5253884905123647,-1.6497106502661597E-16) (0.8173847999506667,2.128623595631624E-17) (0.6728510746564296,7.892991815694472E-17) (0.6726886500802045,5.984795992119984E-17) ATTENZIONE1 lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat after lanczos_state_k ipol: 3 before lanczos_state_k Lanczos N1 1.786912337270756 1.274192383436327 2.338188032798992 1.54779072670112 1.122983513989408 2.11341116806226 1.349766735970578 0.712550907089301 0.7640255394875354 0.6871875647900851 0.5771557084060542 0.5432795370201812 0.5527642918361774 0.9033228246487335 0.6909667856073906 0.6909035112360036 Lanczos alpha (0.6766937754828398,-4.461266754716603E-17) (0.6510209810378169,7.44592448972633E-17) (0.7494918650140828,-4.563772450082706E-17) (0.6557240338845773,-6.693531322158527E-18) (0.7020773464835699,4.866383380788325E-17) (0.743506675447728,-5.094522344714396E-17) (0.685593008937564,6.593501980122578E-17) (0.8885766627682412,5.809126896053347E-17) (0.8586252377274443,-8.132992324956462E-17) (0.9058375090554602,2.2477349893777297E-17) (0.9276208895728363,1.1715890592788444E-16) (0.9601305530865974,-4.5113628292277093E-17) (0.9504747277590297,-4.8950611069324685E-17) (0.9048645819415521,-1.1152510607152602E-16) (0.9737330617294281,1.475330179763198E-16) (0.9736734148999875,1.0725351536429375E-16) Lanczos beta 0.736264581670734 0.7590597356259636 0.6620135529411106 0.7550006565468269 0.7121006948140048 0.6687285126003418 0.7279850452419598 0.45872814867157863 0.5126038442476714 0.4236253146215392 0.3735230718819092 0.2795520005824021 0.31080185310161845 0.4256995282446742 0.2276926096627503 0.227947540274062 Lanczos Diagonal 1 (1.2091924559646134,-7.971892603858965E-17) (0.8295259754956318,9.487540272451308E-17) (1.752452909456126,-1.0670958127201118E-16) (1.0149235789215998,-1.0360185709320456E-17) (0.7884212856464785,5.464868309377329E-17) (1.5713353114200703,-1.0766820419262133E-16) (0.9253906378779032,8.899689646325596E-17) (0.6331561070738942,4.1392986391796686E-17) (0.6560116104723239,-6.213813848722846E-17) (0.6224802719433384,1.54461553364395E-17) (0.5353816916536646,6.761893134688641E-17) (0.5216192823598171,-2.4509311091928844E-17) (0.5253884897979035,-2.7058149862683404E-17) (0.8173848300840382,-1.007431738357805E-16) (0.6728172037028257,1.0194041520205505E-16) (0.6727143811515515,7.410183035759521E-17) ATTENZIONE1 lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat after lanczos_state_k ik: 2 ipol: 1 before lanczos_state_k Lanczos N1 2.146388628327507 2.4843905579786587 1.7180896760365314 1.7180938511481427 1.7118327793040986 1.7118351287860893 1.5767479950112613 1.007012118237846 1.007012907040707 1.0783455522126453 0.7672153805891797 0.7672153571534824 0.72529402129952 0.592951624441818 0.6714128367165224 0.7687929608857665 Lanczos alpha (0.7192799815361455,-4.8300098383640396E-17) (0.7692121762672559,5.373091118971021E-17) (0.6945869659781317,-3.156456797190713E-17) (0.6945865203511818,3.4073259459974756E-17) (0.7360500328774741,-6.347727896273406E-17) (0.736049941273502,2.1592473274761593E-17) (0.7327917171704749,-1.0202852946866054E-16) (0.8466999321409533,-3.789047166736956E-17) (0.846699677342575,6.249431905845233E-17) (0.81495182705725,-2.7509438332145886E-16) (0.8966916027827633,1.51486768670208E-17) (0.8966914731016941,-1.4405657163505209E-18) (0.916842758116885,1.5508737448656852E-16) (0.9594975913673683,4.867430468171911E-16) (0.961075922823254,2.737158213169714E-16) (0.9413428269184885,3.156500410039638E-17) Lanczos beta 0.6947203093053795 0.6389934490135177 0.7194087479960843 0.719409178247288 0.6769271372171972 0.6769272368218572 0.6804530103147074 0.5320706954085193 0.532071100876546 0.5795287047041328 0.4426558138089666 0.44265607650490024 0.3992484901519707 0.2817168297426038 0.2762844016035539 0.33745174797163185 Lanczos Diagonal 1 (1.5438543729528018,-1.0367078191774554E-16) (1.9110234678005864,1.334885684313059E-16) (1.1933626953565657,-5.4230758361086995E-17) (1.1933648297057498,5.854105756675791E-17) (1.2599945734875195,-1.0866248686943865E-16) (1.2599961460129188,3.6962754269111704E-17) (1.1554278708094055,-1.608732792736579E-16) (0.8526370921771018,-3.815616413478891E-17) (0.8526375034711751,6.293258590858154E-17) (0.8787996779747544,-2.9664680469337566E-16) (0.6879555893000993,1.1622297887953865E-17) (0.6879554687921985,-1.105224140572927E-18) (0.6649805709339387,1.1248394549414788E-16) (0.5689356554492928,2.886150802960134E-16) (0.6452787116427106,1.8377631604462053E-16) (0.7236977391152424,2.4266952962715095E-17) ATTENZIONE1 lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat after lanczos_state_k ipol: 2 before lanczos_state_k Lanczos N1 2.1463886220897077 2.484390533518875 1.7180896837226043 1.7180938349385535 1.711832778504246 1.711835136478162 1.5767481173531013 1.0070121221623665 1.007012912323955 1.0783455202028893 0.7672153813925323 0.7672153604336968 0.7252940093975736 0.5929516185213263 0.6714128472455602 0.7687929693666317 Lanczos alpha (0.7192799809844854,2.5827078784333075E-18) (0.7692121761229083,3.553347403994614E-17) (0.6945869661657543,-2.84765893609978E-17) (0.6945865192405968,7.340905370400766E-17) (0.7360500330860689,9.872750355179282E-18) (0.736049942917822,-7.393464766526491E-19) (0.7327917166630219,-7.03062296808674E-17) (0.846699932777321,-6.467113593501418E-17) (0.8466996736272007,3.3350006233238044E-17) (0.8149518359603833,8.748935180443597E-17) (0.8966916020713356,-1.5441410114753826E-16) (0.8966914719251853,-1.0683681509602386E-16) (0.9168427640483598,-3.1118887355309967E-16) (0.9594975933974665,1.9088242601700806E-17) (0.9610759199123834,1.3494530061956104E-16) (0.9413428239526207,1.00383914020993E-16) Lanczos beta 0.6947203098765415 0.6389934491872822 0.7194087478149366 0.7194091793195522 0.6769271369903838 0.6769272350339217 0.680453010861192 0.5320706943958461 0.5320711067889238 0.5795286921842593 0.4426558152501111 0.4426560788881689 0.39924847653079926 0.2817168228282943 0.2762844117292319 0.3374517562451025 Lanczos Diagonal 1 (1.5438543672820009,5.543494804450699E-18) (1.911023448627207,8.827902652788089E-17) (1.193362701017564,-4.8925334408735183E-17) (1.1933648165386983,1.2612364259752875E-16) (1.2599945732558675,1.6900497671985332E-17) (1.2599961544894733,-1.2656392767653357E-18) (1.155427959660367,-1.1085521528750239E-16) (0.8526370961408231,-6.512461784056951E-17) (0.8526375042030696,3.3583886902955096E-17) (0.8787996614889994,9.43437505837681E-17) (0.6879555894746405,-1.1846887350429363E-16) (0.6879554708309031,-8.196684560148416E-17) (0.6649805643237885,-2.257034257792422E-16) (0.5689356509723452,1.1318404345406224E-17) (0.6452787198075193,9.060400851138752E-17) (0.7236977448185057,7.717444733684386E-17) ATTENZIONE1 lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat after lanczos_state_k ipol: 3 before lanczos_state_k Lanczos N1 1.629485741463342 1.3439322140347953 2.611944333278177 2.6119453913812896 2.3356016674184246 2.3355809946614725 1.0178148383335175 1.0017053214302785 1.0017068104171114 1.1884240530111454 0.7406457325318184 0.7406459619249778 0.9087330668828488 1.249365427211587 0.9244380150997896 0.8482930788614433 Lanczos alpha (0.6563342583834856,-1.737078495939828E-17) (0.6421310812447882,9.364537753081967E-17) (0.7905463327228007,-2.115722282668157E-18) (0.7905506846839574,-9.259071161393533E-17) (0.7686648954156154,7.821182463756929E-17) (0.7686658257570036,-9.15658451202737E-17) (0.7956016472455064,7.277012260293821E-17) (0.8589398794150117,-1.4230542464541956E-17) (0.8589399231091767,2.1442317921092005E-17) (0.850100366951158,9.133725265901055E-18) (0.9217207610836478,-1.7888817209235417E-16) (0.9217202774152276,-6.585393813464627E-17) (0.8679931523753264,-8.069370122857455E-17) (0.8404204765546731,-3.1199534663001516E-17) (0.894700345427219,1.0514269671615234E-16) (0.9410296427575303,-6.11267999825651E-17) Lanczos beta 0.7544702388247001 0.7665948568177318 0.6124022336818602 0.6123966157203391 0.6396516853379676 0.6396505673516621 0.6058201209106854 0.5120764430732242 0.5120763697820846 0.5266207042165234 0.3878541460231951 0.38785529544096636 0.49657616478194444 0.5419348877749197 0.4466668690337518 0.33832412188851707 Lanczos Diagonal 1 (1.0694873156698066,-2.8305446409365376E-17) (0.8629806457178653,1.2585303955911876E-16) (2.0648630139491635,-5.526148827005462E-18) (2.0648752175135856,-2.4184188248473244E-16) (1.7952950114187203,1.8267166803534425E-16) (1.7952812938838245,-2.1385944762302719E-16) (0.8097751619690653,7.406651057261981E-17) (0.860404647998699,-1.4254810113571226E-17) (0.8604059707176123,2.147891589268674E-17) (1.0102797235583572,1.0854738799592435E-17) (0.6826685482825835,-1.3249276126061965E-16) (0.6826684014919586,-4.877445335628306E-17) (0.7887740793913423,-7.332903459557086E-17) (1.0499922877280947,-3.897961995304361E-17) (0.8270950114358344,9.719790585451905E-17) (0.7982689329546695,-5.1853441358157776E-17) ATTENZIONE1 lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat after lanczos_state_k ik: 3 ipol: 1 before lanczos_state_k Lanczos N1 1.8691750874657553 2.0423168760345445 2.042323525707613 1.4474333408882594 1.7746397145014845 1.6469372860179134 1.646950276463917 1.3515513570318543 0.8787412751347372 0.9021380002790702 0.9021383171645313 0.8629042078629028 0.7366895160861937 0.7366896299309067 1.0540343041646165 0.7663866305951357 Lanczos alpha (0.6888765611774379,2.560012699497436E-17) (0.7135857162507007,2.3475388642947586E-18) (0.7135904027991217,1.5420649633570624E-17) (0.6609226083053207,-2.844103811810669E-17) (0.7633991762090718,-1.5575426940209818E-17) (0.7554587391286969,1.8755049606779028E-16) (0.7554572233724643,1.5874888241203394E-16) (0.7756977566766592,-1.3618783896365627E-17) (0.8611199655843058,7.00108392197371E-17) (0.8910940278423157,-9.03368082143487E-17) (0.8910938024079835,2.3587830769238592E-17) (0.9258454036849381,-1.309807281441603E-16) (0.9324582202922098,-5.262811960946888E-17) (0.9324581017346985,6.549596676617001E-17) (0.8770143890051332,-2.834726722894075E-18) (0.954086825180095,-3.406984163150092E-17) Lanczos beta 0.7248786680958056 0.7005679307269024 0.7005631570622215 0.7504540664363768 0.6459270065288419 0.6551962251677584 0.6551979728710765 0.6311045795165785 0.5084018143870901 0.4538187232185963 0.4538191658690507 0.3779024854052657 0.3612778257926786 0.36127813178951523 0.4804641104993731 0.299530182148253 Lanczos Diagonal 1 (1.2876309064919462,4.7851119614965644E-17) (1.457368150796004,4.7944182396961535E-18) (1.457382467355818,3.149395552833577E-17) (0.9566414190079527,-4.1166506821621504E-17) (1.3547584961183357,-2.764077121841268E-17) (1.244193165519131,3.0888390498519987E-16) (1.2442004828899433,2.6145151577683715E-16) (1.0483953556829038,-1.8406485856256526E-17) (0.7567016566015339,6.152141412920485E-17) (0.8038897843382888,-8.149626751408642E-17) (0.8038898633400816,2.1279485955722654E-17) (0.7989158946702609,-1.1302382146454286E-16) (0.6869321950776615,-3.877058396762595E-17) (0.6869322138930107,4.825019951893675E-17) (0.9244032512573819,-2.9878992088625E-18) (0.7311993872449832,-2.611067113287587E-17) ATTENZIONE1 lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat after lanczos_state_k ipol: 2 before lanczos_state_k Lanczos N1 1.9874126166647303 1.9634132723519415 1.9634178297620521 2.223090075446986 2.03333499363074 1.661324258351558 1.6613239110931555 1.464707866791008 1.2204309201779187 0.9607694732175923 0.9607692602869354 0.8695926019475815 0.7697945476372672 0.7697950308981799 0.6190389750347136 0.6953094824831237 Lanczos alpha (0.7033400044059227,-1.6388612668442002E-17) (0.7059945994266955,2.38944296547182E-17) (0.7059942161337487,-8.725126013161426E-17) (0.7438008956456693,-7.65571100410414E-17) (0.7777038002044744,-1.6184291358978918E-16) (0.7615247301471677,-2.2716229766469374E-17) (0.7615245021494252,-8.750132644213655E-17) (0.798290049368635,-2.098208905478367E-17) (0.8376430985088046,4.848454677662034E-17) (0.8440544595413214,-1.5424497866323786E-16) (0.8440547973749899,7.666425712064953E-17) (0.8868795428046776,-1.2504265435537336E-16) (0.9453063329126042,6.093289369624929E-17) (0.9453062946529813,-5.259217766229685E-19) (0.9659551022360016,-7.402221779512683E-17) (0.9736765589088339,1.203322568731841E-16) Lanczos beta 0.7108535982903067 0.7082172163823315 0.7082175984721739 0.6684012474829027 0.6286308926130822 0.6481358541033521 0.648136121988329 0.6022731913999015 0.5462179414121897 0.5362574655223055 0.5362569337810629 0.4620007322013354 0.3261839005152202 0.32618401139456804 0.2587097610532609 0.227934110285077 Lanczos Diagonal 1 (1.3978267985613577,-3.257093558689307E-17) (1.3861591667231663,4.6914640319353535E-17) (1.386161631665886,-1.7131067981161833E-16) (1.6535363892184667,-1.7019335153714192E-16) (1.5813323516353672,-3.290808596732744E-16) (1.2651395075281138,-3.773902356932332E-17) (1.2651388643041512,-1.4536804587068924E-16) (1.169261715291222,-3.073263090025115E-17) (1.0222855374937834,5.91720400370001E-17) (0.810941758460475,-1.481938668967378E-16) (0.8109419033156082,7.365666160425387E-17) (0.7712238892416011,-1.087361671553212E-16) (0.7276916609231021,4.690580933913392E-17) (0.7276920883006357,-4.0485197028550365E-19) (0.5979638564177264,-4.5822637833691655E-17) (0.67700654428085,8.366815925251995E-17) ATTENZIONE1 lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat after lanczos_state_k ipol: 3 before lanczos_state_k Lanczos N1 1.9874126838692097 1.9634132453922295 1.9634178590480604 2.2230900645285647 2.0333349616676686 1.6613242899549587 1.661323903888272 1.4647078481028677 1.2204309139045466 0.960769468882133 0.960769251722231 0.8695925833819019 0.7697945469299431 0.7697950309052708 0.6190389760492373 0.6953094804240944 Lanczos alpha (0.7033400068014178,-4.095471936419313E-17) (0.7059945962536701,-6.278473693838045E-17) (0.7059942177040107,-1.0525355834907964E-17) (0.7438008943117206,7.918167719060447E-17) (0.7777037966511856,-6.046480132103448E-18) (0.7615247310673605,4.0250524984186733E-17) (0.7615245042125033,-9.089310789678759E-17) (0.7982900460013077,1.0085865847286752E-17) (0.8376431005251267,-1.9199062970437613E-17) (0.8440544604308293,2.5101093980702262E-17) (0.8440548006565717,-6.120197347430758E-17) (0.8868795513261761,7.423255372199567E-17) (0.9453063325999412,4.0886229250937673E-16) (0.9453062947069877,-7.784818707536613E-17) (0.9659551013149319,4.438404303861427E-17) (0.9736765590103755,-1.6669812177277316E-16) Lanczos beta 0.7108535959201309 0.7082172195453994 0.7082175969068419 0.6684012489673284 0.6286308970089929 0.6481358530221764 0.6481361195643247 0.6022731958631652 0.5462179383200938 0.5362574641222441 0.5362569286159338 0.46200071584303914 0.32618390142134573 0.32618401123804897 0.2587097644923003 0.22793410985132095 Lanczos Diagonal 1 (1.397826850589794,-8.139392872870136E-17) (1.3861591414597951,-1.2327238411328296E-16) (1.386161655424719,-2.0665671619094004E-17) (1.653536378131847,1.7602799985514087E-16) (1.5813323195525388,-1.2294519447634884E-17) (1.2651395331236237,6.686917483966835E-17) (1.2651388622448967,-1.5100289284762907E-16) (1.1692616954405146,1.4772846861433586E-17) (1.0222855346997184,-2.3431129967122113E-17) (0.8109417556557232,2.4116364732199816E-17) (0.8109418992393712,-5.880097425883433E-17) (0.7712238801863116,6.455207816214603E-17) (0.7276916600137778,3.1473996321899354E-16) (0.7276920883489126,-5.992714757560077E-17) (0.5979638568275327,2.7475452555549056E-17) (0.6770065423466243,-1.159067844374993E-16) ATTENZIONE1 lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat after lanczos_state_k ik: 4 ipol: 1 before lanczos_state_k Lanczos N1 1.7742303034376432 1.850876542426595 1.772809396894945 1.810409237738256 1.9234703580142571 1.9031688405504226 1.9443922396234372 1.6346968183084774 0.8063651060228805 0.8768958757287456 0.8306633805512001 0.6574381015146331 0.6679323433835807 0.6620338430790684 0.7582362802207937 0.6213865570444934 Lanczos alpha (0.6783786525888963,1.7927941673843498E-17) (0.693020628238886,6.598828502291854E-17) (0.6848408484894621,-3.188745881956951E-17) (0.6886651479358271,4.714082277649378E-17) (0.7841910780279291,-8.662126663719033E-17) (0.7823912189833879,-6.902286754620806E-17) (0.7861133840444166,-9.501546639748984E-17) (0.7663849005895662,-5.841083380080514E-17) (0.926376484874199,-1.0154229116616526E-17) (0.8978807239762207,-5.934788551068451E-17) (0.9155536490473565,8.413769795026272E-17) (0.9638930529326207,-7.338375434703491E-18) (0.9588884128806893,7.089720304488151E-17) (0.9616615920192406,1.5511761608976419E-16) (0.9437766976110803,1.3727041461046942E-17) (0.9749553588390029,5.20826118328385E-17) Lanczos beta 0.7347124632886498 0.7209177545569115 0.7286926733817444 0.7250795225480623 0.6205194220501044 0.622787267417766 0.618082314442207 0.6423816499156264 0.3765987364186481 0.440238805095527 0.40219586735329443 0.2662896590336004 0.2837833885962191 0.27423891488084373 0.3305836430410912 0.22240064809058424 Lanczos Diagonal 1 (1.203599962628417,3.180829739599572E-17) (1.282695624225096,1.2213616882388013E-16) (1.2140922915796257,-5.653038663843342E-17) (1.246765745531404,8.534418102914632E-17) (1.508368293605967,-1.666134387502849E-16) (1.4890225890894462,-1.3136217079938217E-16) (1.5285127634000824,-1.847473355074807E-16) (1.2528069585934225,-9.548400416892142E-17) (0.7469976724426868,-8.188016038201105E-18) (0.7873479037510881,-5.2041916037541026E-17) (0.7605168891936642,6.989010461116101E-17) (0.633700018783166,-4.824527613993084E-18) (0.6404725846587612,4.7354534969109235E-17) (0.6366525195060331,1.0269311150917012E-16) (0.7156057325556904,1.0408340855860843E-17) (0.6058241537010466,3.236343484869231E-17) ATTENZIONE1 lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat after lanczos_state_k ipol: 2 before lanczos_state_k Lanczos N1 1.7742303248468043 1.6913127750016936 1.9642398478977594 1.8104089192652224 1.923470335936236 1.9290396307443767 1.9179616515341011 1.6346967694151795 0.8519258495565922 0.8156369053648023 0.8306633814539341 0.6534271260470885 0.6767077302832539 0.6620338407281119 0.6289286665194086 0.6538002702258119 Lanczos alpha (0.6783786545754085,-4.9406120168129364E-17) (0.6773607091147102,-7.551138958056376E-18) (0.7064203080126553,2.2919976188417826E-17) (0.6886651383382623,3.9754206729656266E-17) (0.7841910762817448,2.6416958456306054E-17) (0.7846944285645744,8.06639326624466E-18) (0.7836945876011882,1.6513967268795577E-17) (0.7663848942698817,3.423770472113183E-17) (0.9069756918351093,-1.2208459626651322E-16) (0.9221124819506463,-5.998843169917862E-17) (0.9155536505170506,5.2666598566332625E-17) (0.9658916809569754,2.069818933574317E-16) (0.9549443248697653,7.448042287829133E-17) (0.9616615931055174,6.320944639185023E-17) (0.9719820854081168,-8.024695615880749E-17) (0.9633802214449976,-2.688117153870239E-16) Lanczos beta 0.7347124614544495 0.7356510516186429 0.7077925885648318 0.725079531663625 0.6205194242568712 0.6198827742240592 0.621146354223064 0.6423816574552419 0.4211829702400419 0.386921918002616 0.402195864007697 0.2589464436096903 0.2967850002931943 0.2742389110716389 0.23505494175976574 0.26813904775057784 Lanczos Diagonal 1 (1.203599980676465,-8.765783663532041E-17) (1.1456288206099157,-1.2771337785573726E-17) (1.3875789183626663,4.50203305421581E-17) (1.2467655088346083,7.197137044168323E-17) (1.5083682729338461,5.0812235956364596E-17) (1.5137066507253762,1.5560392287755523E-17) (1.5030961655339112,3.1673155936239256E-17) (1.2528069107915694,5.596826529982504E-17) (0.7726760367938035,-1.0400702339212283E-16) (0.7521089711764822,-4.8928778788805854E-17) (0.7605168912409868,4.374821485478678E-17) (0.6311398251605078,1.3524758372033155E-16) (0.6462182066294931,5.0401477916505464E-17) (0.6366525179643604,4.18467925650943E-17) (0.6113073968564808,-5.046961112920023E-17) (0.6298582491109419,-1.7574917215990027E-16) ATTENZIONE1 lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat after lanczos_state_k ipol: 3 before lanczos_state_k Lanczos N1 1.7742303238029793 1.9149910275906599 1.7231187022407377 1.8104088856029967 1.9234703096791859 1.9387107034117699 1.908569635755615 1.6346967786650046 0.847196530294877 0.8181633859309703 0.8306633681638121 0.6880689150354037 0.6504666080079885 0.6620338379722953 0.625785813350302 0.6696328185867387 Lanczos alpha (0.678378654923585,1.453169065746224E-17) (0.7003940554345985,1.9578680534607563E-16) (0.680141762077926,9.1316092406837E-17) (0.6886651418293454,5.64457091865331E-17) (0.7841910708735034,7.26264933943328E-17) (0.7855837779033108,7.812854946482933E-17) (0.7828628389484127,-4.6858156496562646E-17) (0.766384895403672,-3.1758246122310745E-17) (0.9088150136471592,-1.383913981934696E-17) (0.9209797198268229,1.8822547566580486E-17) (0.9155536572203045,1.0341896549287325E-17) (0.9501493832193847,2.6327637463755516E-17) (0.9673981393918856,1.9601796627458068E-17) (0.961661594294057,-3.6305798281384E-16) (0.9731995124451952,-1.1302149966787824E-19) (0.9587969656546679,1.0912161523307311E-16) Lanczos beta 0.734712461132971 0.7137563779833264 0.7330806118548865 0.7250795283478685 0.6205194310916203 0.6187553053470827 0.6221943228555117 0.6423816561025886 0.4171993180357739 0.38961051791206935 0.4021958487484969 0.3117950441681623 0.2532604191363452 0.27423890690384156 0.22996240774620602 0.2840922009689851 Lanczos Diagonal 1 (1.2035999805861017,2.5782566220593956E-17) (1.3412483319350914,3.7492997555837386E-16) (1.1719649904114444,1.5734846664176426E-16) (1.2467654919728948,1.0218981346546223E-16) (1.5083682419407098,1.3969490374011065E-16) (1.5230196786478032,1.5146865508950053E-16) (1.4941482433783786,-8.943205467682418E-17) (1.2528069197338991,-5.1915102632191747E-17) (0.7699449262417646,-1.1724471237216415E-17) (0.7535118859472698,1.5399919248920235E-17) (0.7605168846413144,8.590634620832716E-18) (0.65376825523332,1.8115228945131704E-17) (0.629260186323479,1.2750314163125078E-17) (0.6366525161010509,-2.4035666976872613E-16) (0.6090144484476339,-7.072725109573408E-20) (0.6420419145637478,7.307141477726035E-17) ATTENZIONE1 lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat lanczos h_psi lanczos alfa beta gamma lanczos d f omat after lanczos_state_k Unsymmetrized in crystal axis ( 12.32323 -5.26390 -3.32915 ) ( -5.26394 15.68659 -6.19700 ) ( -3.32920 -6.19703 12.49072 ) Symmetrized in crystal axis ( 12.32323 -5.26390 -3.32915 ) ( -5.26394 15.68659 -6.19700 ) ( -3.32920 -6.19703 12.49072 ) Dielectric constant in cartesian axis ( 13.500182454 0.000000000 0.000000000 ) ( 0.000000000 13.500182454 0.000000000 ) ( 0.000000000 0.000000000 13.500182454 ) POLA SCA (0.3143201189263525,0.) POLA SCA (0.3143201189263526,0.) POLA SCA (0.31432011892635253,0.) HEAD: 0. 13.50018245397647 13.500182453976477 13.500182453976473 E_HEAD : 1 1 (9.164402306340251E-18,0.000003368260464315057) 1 (9.201528428093294E-19,2.5974180624258396E-18) 1 (1.982870248204427E-18,3.2756020118540617E-18) Unsymmetrized in crystal axis ( 12.31863 -5.26153 -3.32768 ) ( -5.26157 15.68069 -6.19430 ) ( -3.32774 -6.19432 12.48610 ) Symmetrized in crystal axis ( 12.31863 -5.26153 -3.32768 ) ( -5.26157 15.68069 -6.19430 ) ( -3.32774 -6.19432 12.48610 ) Dielectric constant in cartesian axis ( 13.495139082 0.000000000 0.000000000 ) ( 0.000000000 13.495139082 0.000000000 ) ( 0.000000000 0.000000000 13.495139082 ) POLA SCA (0.31414745212665385,0.) POLA SCA (0.31414745212665385,0.) POLA SCA (0.3141474521266539,0.) HEAD: 0.005154639175257732 13.495139081947665 13.495139081947668 13.495139081947665 E_HEAD : 2 2 (6.0514492997648074E-18,0.000003750864503626105) 2 (2.68940425485198E-18,6.548369363575633E-18) 2 (2.981894787514039E-18,-2.2382096176443164E-18) Unsymmetrized in crystal axis ( 12.28198 -5.24264 -3.31599 ) ( -5.24269 15.63363 -6.17273 ) ( -3.31604 -6.17275 12.44925 ) Symmetrized in crystal axis ( 12.28198 -5.24264 -3.31599 ) ( -5.24269 15.63363 -6.17273 ) ( -3.31604 -6.17275 12.44925 ) Dielectric constant in cartesian axis ( 13.454952101 0.000000000 0.000000000 ) ( 0.000000000 13.454952101 0.000000000 ) ( 0.000000000 0.000000000 13.454952101 ) POLA SCA (0.31277265055465026,0.) POLA SCA (0.3127726505546503,0.) POLA SCA (0.3127726505546503,0.) HEAD: 0.015463917525773196 13.454952100775651 13.45495210077565 13.454952100775644 E_HEAD : 3 3 (3.918373729856245E-18,0.000004408362828058813) 3 (4.4195758164278235E-18,-2.4504578460772185E-18) 3 (-8.83014906853663E-19,-4.519051799434237E-18) Unsymmetrized in crystal axis ( 12.20944 -5.20531 -3.29289 ) ( -5.20535 15.54048 -6.13007 ) ( -3.29294 -6.13008 12.37634 ) Symmetrized in crystal axis ( 12.20944 -5.20531 -3.29289 ) ( -5.20535 15.54048 -6.13007 ) ( -3.29294 -6.13008 12.37634 ) Dielectric constant in cartesian axis ( 13.375421058 0.000000000 0.000000000 ) ( 0.000000000 13.375421058 0.000000000 ) ( 0.000000000 0.000000000 13.375421058 ) POLA SCA (0.31005755523745815,0.) POLA SCA (0.31005755523745815,0.) POLA SCA (0.31005755523745804,0.) HEAD: 0.025773195876288662 13.37542105848923 13.375421058489229 13.375421058489232 E_HEAD : 4 4 (4.439601367754205E-18,0.000004959140385863435) 4 (-3.2365221613872564E-18,2.977405512893591E-19) 4 (8.769840322692125E-19,4.185096713626991E-18) Unsymmetrized in crystal axis ( 12.10255 -5.15034 -3.25891 ) ( -5.15038 15.40313 -6.06721 ) ( -3.25896 -6.06722 12.26887 ) Symmetrized in crystal axis ( 12.10255 -5.15034 -3.25891 ) ( -5.15038 15.40313 -6.06721 ) ( -3.25896 -6.06722 12.26887 ) Dielectric constant in cartesian axis ( 13.258183207 0.000000000 0.000000000 ) ( 0.000000000 13.258183207 0.000000000 ) ( 0.000000000 0.000000000 13.258183207 ) POLA SCA (0.30606896227153974,0.) POLA SCA (0.30606896227153974,0.) POLA SCA (0.30606896227153974,0.) HEAD: 0.03608247422680412 13.25818320749561 13.258183207495607 13.258183207495605 E_HEAD : 5 5 (1.1186884406668049E-17,0.0000054390385563375795) 5 (-1.2363443602225747E-18,-1.7983102393271876E-18) 5 (-2.329713299446118E-18,6.764366844436154E-18) Unsymmetrized in crystal axis ( 11.96345 -5.07890 -3.21481 ) ( -5.07894 15.22429 -5.98545 ) ( -3.21486 -5.98546 12.12900 ) Symmetrized in crystal axis ( 11.96345 -5.07890 -3.21481 ) ( -5.07894 15.22429 -5.98545 ) ( -3.21486 -5.98546 12.12900 ) Dielectric constant in cartesian axis ( 13.105578506 0.000000000 0.000000000 ) ( 0.000000000 13.105578506 0.000000000 ) ( 0.000000000 0.000000000 13.105578506 ) POLA SCA (0.3009017694994268,0.) POLA SCA (0.3009017694994268,0.) POLA SCA (0.3009017694994268,0.) HEAD: 0.04639175257731958 13.105578506147303 13.105578506147308 13.10557850614731 E_HEAD : 6 6 (7.048818123740015E-18,0.000005857996315926869) 6 (1.296740492762183E-18,-4.822649847828139E-18) 6 (-4.570589783384205E-18,4.973799150320671E-20) Unsymmetrized in crystal axis ( 11.79484 -4.99246 -3.16155 ) ( -4.99250 15.00732 -5.88640 ) ( -3.16159 -5.88641 11.95941 ) Symmetrized in crystal axis ( 11.79484 -4.99246 -3.16155 ) ( -4.99250 15.00732 -5.88640 ) ( -3.16159 -5.88641 11.95941 ) Dielectric constant in cartesian axis ( 12.920524997 0.000000000 0.000000000 ) ( 0.000000000 12.920524997 0.000000000 ) ( 0.000000000 0.000000000 12.920524997 ) POLA SCA (0.2946733836112089,0.) POLA SCA (0.294673383611209,0.) POLA SCA (0.2946733836112089,0.) HEAD: 0.05670103092783505 12.920524997126606 12.920524997126604 12.920524997126606 E_HEAD : 7 7 (3.369826022445446E-18,0.000006209634695462939) 7 (-2.092548356813495E-18,-3.0678601613308777E-18) 7 (1.1651446409251253E-18,4.718003765447067E-18) Unsymmetrized in crystal axis ( 11.59980 -4.89269 -3.10018 ) ( -4.89272 14.75612 -5.77193 ) ( -3.10021 -5.77194 11.76320 ) Symmetrized in crystal axis ( 11.59980 -4.89269 -3.10018 ) ( -4.89272 14.75612 -5.77193 ) ( -3.10021 -5.77194 11.76320 ) Dielectric constant in cartesian axis ( 12.706373919 0.000000000 0.000000000 ) ( 0.000000000 12.706373919 0.000000000 ) ( 0.000000000 0.000000000 12.706373919 ) POLA SCA (0.28751730346985727,0.) POLA SCA (0.28751730346985727,0.) POLA SCA (0.28751730346985727,0.) HEAD: 0.06701030927835051 12.70637391889369 12.706373918893691 12.706373918893691 E_HEAD : 8 8 (5.510398992515076E-18,0.000006484941538495264) 8 (-6.039613253960803E-20,3.8607168812787934E-18) 8 (-1.2458838214574054E-18,4.497735517361434E-18) Unsymmetrized in crystal axis ( 11.38168 -4.78140 -3.03186 ) ( -4.78142 14.47490 -5.64405 ) ( -3.03189 -5.64405 11.54370 ) Symmetrized in crystal axis ( 11.38168 -4.78140 -3.03186 ) ( -4.78142 14.47490 -5.64405 ) ( -3.03189 -5.64405 11.54370 ) Dielectric constant in cartesian axis ( 12.466757877 0.000000000 0.000000000 ) ( 0.000000000 12.466757877 0.000000000 ) ( 0.000000000 0.000000000 12.466757877 ) POLA SCA (0.27957648934342405,0.) POLA SCA (0.27957648934342405,0.) POLA SCA (0.27957648934342405,0.) HEAD: 0.07731958762886598 12.466757877206142 12.466757877206142 12.466757877206136 E_HEAD : 9 9 (1.0010145373702279E-17,0.000006678874523966271) 9 (2.557953848736361E-19,-4.758063585599999E-18) 9 (1.792999342747903E-18,-1.9895196601282807E-18) Unsymmetrized in crystal axis ( 11.14392 -4.66046 -2.95777 ) ( -4.66047 14.16805 -5.50485 ) ( -2.95778 -5.50485 11.30436 ) Symmetrized in crystal axis ( 11.14392 -4.66046 -2.95777 ) ( -4.66047 14.16805 -5.50485 ) ( -2.95778 -5.50485 11.30436 ) Dielectric constant in cartesian axis ( 12.205444128 0.000000000 0.000000000 ) ( 0.000000000 12.205444128 0.000000000 ) ( 0.000000000 0.000000000 12.205444128 ) POLA SCA (0.27099706884756836,0.) POLA SCA (0.27099706884756836,0.) POLA SCA (0.27099706884756836,0.) HEAD: 0.08762886597938145 12.205444127827155 12.20544412782715 12.205444127827155 E_HEAD : 10 10 (6.637687905900183E-18,0.0000067914394395996006) 10 (-1.3269385590319874E-18,2.6932767810666085E-18) 10 (1.4264034831762418E-18,-3.2684965844964585E-19) Unsymmetrized in crystal axis ( 10.88999 -4.53172 -2.87905 ) ( -4.53173 13.83998 -5.35642 ) ( -2.87906 -5.35642 11.04864 ) Symmetrized in crystal axis ( 10.88999 -4.53172 -2.87905 ) ( -4.53173 13.83998 -5.35642 ) ( -2.87906 -5.35642 11.04864 ) Dielectric constant in cartesian axis ( 11.926202431 0.000000000 0.000000000 ) ( 0.000000000 11.926202431 0.000000000 ) ( 0.000000000 0.000000000 11.926202431 ) POLA SCA (0.26192280303695026,0.) POLA SCA (0.2619228030369502,0.) POLA SCA (0.26192280303695026,0.) HEAD: 0.0979381443298969 11.92620243074854 11.926202430748548 11.926202430748546 E_HEAD : 11 11 (1.3998654793451447E-17,0.00000682666928462288) 11 (1.9859669464494805E-18,4.299827231464895E-18) 11 (5.952947553303223E-19,-4.476419235288631E-19) Unsymmetrized in crystal axis ( 10.62321 -4.39699 -2.79682 ) ( -4.39699 13.49498 -5.20081 ) ( -2.79682 -5.20080 10.77990 ) Symmetrized in crystal axis ( 10.62321 -4.39699 -2.79682 ) ( -4.39699 13.49498 -5.20081 ) ( -2.79682 -5.20080 10.77990 ) Dielectric constant in cartesian axis ( 11.632693727 0.000000000 0.000000000 ) ( 0.000000000 11.632693727 0.000000000 ) ( 0.000000000 0.000000000 11.632693727 ) POLA SCA (0.2524905772996192,0.) POLA SCA (0.2524905772996193,0.) POLA SCA (0.2524905772996192,0.) HEAD: 0.10824742268041238 11.632693726540523 11.632693726540518 11.632693726540518 E_HEAD : 12 12 (4.657638726171859E-18,0.000006791316297010497) 12 (-1.8296475445822578E-18,4.4618815749335876E-18) 12 (3.0860459587084278E-18,-3.709033080667723E-18) Unsymmetrized in crystal axis ( 10.34675 -4.25797 -2.71210 ) ( -4.25796 13.13712 -5.03992 ) ( -2.71209 -5.03992 10.50128 ) Symmetrized in crystal axis ( 10.34675 -4.25797 -2.71210 ) ( -4.25796 13.13712 -5.03992 ) ( -2.71209 -5.03992 10.50128 ) Dielectric constant in cartesian axis ( 11.328382693 0.000000000 0.000000000 ) ( 0.000000000 11.328382693 0.000000000 ) ( 0.000000000 0.000000000 11.328382693 ) POLA SCA (0.24282702680905605,0.) POLA SCA (0.24282702680905605,0.) POLA SCA (0.24282702680905605,0.) HEAD: 0.11855670103092784 11.328382692877737 11.328382692877737 11.328382692877733 E_HEAD : 13 13 (6.536641998893111E-18,0.0000066937897345989366) 13 (-5.307754236127949E-18,-1.0399192900030496E-18) 13 (-1.2336865470169434E-18,4.853006885241484E-18) Unsymmetrized in crystal axis ( 10.06351 -4.11621 -2.62582 ) ( -4.11619 12.77018 -4.87555 ) ( -2.62580 -4.87554 10.21573 ) Symmetrized in crystal axis ( 10.06351 -4.11621 -2.62582 ) ( -4.11619 12.77018 -4.87555 ) ( -2.62580 -4.87554 10.21573 ) Dielectric constant in cartesian axis ( 11.016474517 0.000000000 0.000000000 ) ( 0.000000000 11.016474517 0.000000000 ) ( 0.000000000 0.000000000 11.016474517 ) POLA SCA (0.23304627820628776,0.) POLA SCA (0.23304627820628776,0.) POLA SCA (0.23304627820628773,0.) HEAD: 0.12886597938144329 11.016474517109025 11.016474517109025 11.016474517109025 E_HEAD : 14 14 (1.4036878727577988E-17,0.000006543365454522956) 14 (-2.248867758680717E-18,-5.839106325192245E-19) 14 (-4.705403547269199E-18,4.092726157978177E-18) Unsymmetrized in crystal axis ( 9.77613 -3.97310 -2.53881 ) ( -3.97308 12.39761 -4.70929 ) ( -2.53879 -4.70928 9.92589 ) Symmetrized in crystal axis ( 9.77613 -3.97310 -2.53881 ) ( -3.97308 12.39761 -4.70929 ) ( -2.53879 -4.70928 9.92589 ) Dielectric constant in cartesian axis ( 10.699874202 0.000000000 0.000000000 ) ( 0.000000000 10.699874202 0.000000000 ) ( 0.000000000 0.000000000 10.699874202 ) POLA SCA (0.2232486983065051,0.) POLA SCA (0.22324869830650512,0.) POLA SCA (0.22324869830650512,0.) HEAD: 0.13917525773195874 10.699874202489243 10.699874202489243 10.699874202489243 E_HEAD : 15 15 (6.755071634136466E-18,0.0000063495893868097554) 15 (-1.1155520951433574E-18,3.5015579709840246E-18) 15 (-2.1120427726607078E-18,3.431921413721284E-18) Unsymmetrized in crystal axis ( 9.48693 -3.82988 -2.45179 ) ( -3.82986 12.02247 -4.54258 ) ( -2.45177 -4.54257 9.63410 ) Symmetrized in crystal axis ( 9.48693 -3.82988 -2.45179 ) ( -3.82986 12.02247 -4.54258 ) ( -2.45177 -4.54257 9.63410 ) Dielectric constant in cartesian axis ( 10.381165454 0.000000000 0.000000000 ) ( 0.000000000 10.381165454 0.000000000 ) ( 0.000000000 0.000000000 10.381165454 ) POLA SCA (0.2135204875575489,0.) POLA SCA (0.2135204875575489,0.) POLA SCA (0.21352048755754888,0.) HEAD: 0.14948453608247422 10.381165454140367 10.381165454140369 10.381165454140367 E_HEAD : 16 16 (8.884471196845873E-18,0.0000061218172934144095) 16 (-8.1357143244531465E-19,-2.6917605920910233E-18) 16 (-2.99192365760953E-18,3.4106051316484815E-19) Unsymmetrized in crystal axis ( 9.19796 -3.68761 -2.36537 ) ( -3.68758 11.64744 -4.37665 ) ( -2.36534 -4.37664 9.34242 ) Symmetrized in crystal axis ( 9.19796 -3.68761 -2.36537 ) ( -3.68758 11.64744 -4.37665 ) ( -2.36534 -4.37664 9.34242 ) Dielectric constant in cartesian axis ( 10.062605579 0.000000000 0.000000000 ) ( 0.000000000 10.062605579 0.000000000 ) ( 0.000000000 0.000000000 10.062605579 ) POLA SCA (0.20393393514893743,0.) POLA SCA (0.20393393514893737,0.) POLA SCA (0.20393393514893743,0.) HEAD: 0.15979381443298968 10.06260557935284 10.06260557935284 10.062605579352839 E_HEAD : 17 17 (9.042842711295832E-18,0.000005868864799924866) 17 (3.165467887811247E-18,-1.6382040716371795E-18) 17 (-5.854691731421724E-19,-4.2348347051301976E-18) Unsymmetrized in crystal axis ( 8.91095 -3.54718 -2.28007 ) ( -3.54715 11.27484 -4.21255 ) ( -2.28004 -4.21255 9.05261 ) Symmetrized in crystal axis ( 8.91095 -3.54718 -2.28007 ) ( -3.54715 11.27484 -4.21255 ) ( -2.28004 -4.21255 9.05261 ) Dielectric constant in cartesian axis ( 9.746132734 0.000000000 0.000000000 ) ( 0.000000000 9.746132734 0.000000000 ) ( 0.000000000 0.000000000 9.746132734 ) POLA SCA (0.19454815572114392,0.) POLA SCA (0.19454815572114395,0.) POLA SCA (0.19454815572114395,0.) HEAD: 0.17010309278350513 9.74613273436438 9.746132734364382 9.74613273436438 E_HEAD : 18 18 (4.894221610796016E-18,0.000005598757704842882) 18 (1.968203378055478E-18,-2.354438191176471E-18) 18 (3.0830305214162025E-19,-1.6910917111090381E-18) Unsymmetrized in crystal axis ( 8.62737 -3.40933 -2.19629 ) ( -3.40930 10.90663 -4.05118 ) ( -2.19626 -4.05117 8.76615 ) Symmetrized in crystal axis ( 8.62737 -3.40933 -2.19629 ) ( -3.40930 10.90663 -4.05118 ) ( -2.19626 -4.05117 8.76615 ) Dielectric constant in cartesian axis ( 9.433382092 0.000000000 0.000000000 ) ( 0.000000000 9.433382092 0.000000000 ) ( 0.000000000 0.000000000 9.433382092 ) POLA SCA (0.18541014594604177,0.) POLA SCA (0.18541014594604177,0.) POLA SCA (0.18541014594604177,0.) HEAD: 0.18041237113402062 9.433382091704477 9.433382091704479 9.433382091704479 E_HEAD : 19 19 (1.5650830493695403E-17,0.000005318575340841477) 19 (2.007283228522283E-18,2.1378095149161836E-18) 19 (3.0859104334368672E-18,3.375077994860476E-18) Unsymmetrized in crystal axis ( 8.34843 -3.27466 -2.11438 ) ( -3.27464 10.54443 -3.89325 ) ( -2.11435 -3.89324 8.48427 ) Symmetrized in crystal axis ( 8.34843 -3.27466 -2.11438 ) ( -3.27464 10.54443 -3.89325 ) ( -2.11435 -3.89324 8.48427 ) Dielectric constant in cartesian axis ( 9.125707942 0.000000000 0.000000000 ) ( 0.000000000 9.125707942 0.000000000 ) ( 0.000000000 0.000000000 9.125707942 ) POLA SCA (0.17655602547522647,0.) POLA SCA (0.17655602547522647,0.) POLA SCA (0.17655602547522647,0.) HEAD: 0.19072164948453607 9.125707942257938 9.125707942257938 9.125707942257938 E_HEAD : 20 20 (4.409014944417295E-18,0.000005034376598780882) 20 (-5.069722419648316E-18,9.441283339980609E-19) 20 (9.412230109889786E-19,-4.142464149481385E-18) Unsymmetrized in crystal axis ( 8.07510 -3.14364 -2.03460 ) ( -3.14362 10.18956 -3.73934 ) ( -2.03457 -3.73933 8.20797 ) Symmetrized in crystal axis ( 8.07510 -3.14364 -2.03460 ) ( -3.14362 10.18956 -3.73934 ) ( -2.03457 -3.73933 8.20797 ) Dielectric constant in cartesian axis ( 8.824209271 0.000000000 0.000000000 ) ( 0.000000000 8.824209271 0.000000000 ) ( 0.000000000 0.000000000 8.824209271 ) POLA SCA (0.1680123553736439,0.) POLA SCA (0.1680123553736439,0.) POLA SCA (0.1680123553736439,0.) HEAD: 0.20103092783505153 8.824209270712867 8.824209270712869 8.824209270712869 E_HEAD : 21 21 (1.6543128340205414E-18,0.000004751194358056154) 21 (1.1191048088221576E-18,1.1334910196862322E-18) 21 (3.7852208346900175E-18,9.80548975348939E-19) Unsymmetrized in crystal axis ( 7.94079 -3.07962 -1.99557 ) ( -3.07959 10.01521 -3.66403 ) ( -1.99554 -3.66402 8.07216 ) Symmetrized in crystal axis ( 7.94079 -3.07962 -1.99557 ) ( -3.07959 10.01521 -3.66403 ) ( -1.99554 -3.66402 8.07216 ) Dielectric constant in cartesian axis ( 8.676056028 0.000000000 0.000000000 ) ( 0.000000000 8.676056028 0.000000000 ) ( 0.000000000 0.000000000 8.676056028 ) POLA SCA (0.1638629508276495,0.) POLA SCA (0.1638629508276495,0.) POLA SCA (0.1638629508276495,0.) HEAD: 0.20618556701030927 8.676056028045691 8.676056028045688 8.676056028045688 E_HEAD : 22 22 (7.846167598247502E-18,0.000004611287269931296) 22 (-1.5027978861326124E-18,-9.492613536584219E-19) 22 (6.343260335398004E-19,-3.105071755271638E-18) Unsymmetrized in crystal axis ( 7.80816 -3.01663 -1.95714 ) ( -3.01661 9.84307 -3.58988 ) ( -1.95711 -3.58988 7.93804 ) Symmetrized in crystal axis ( 7.80816 -3.01663 -1.95714 ) ( -3.01661 9.84307 -3.58988 ) ( -1.95711 -3.58988 7.93804 ) Dielectric constant in cartesian axis ( 8.529756873 0.000000000 0.000000000 ) ( 0.000000000 8.529756873 0.000000000 ) ( 0.000000000 0.000000000 8.529756873 ) POLA SCA (0.1597974545334684,0.) POLA SCA (0.1597974545334684,0.) POLA SCA (0.15979745453346844,0.) HEAD: 0.211340206185567 8.529756873288953 8.529756873288951 8.529756873288948 E_HEAD : 23 23 (-4.530107710241934E-19,0.000004473081872579258) 23 (-5.71986902286881E-19,-1.452331161691696E-18) 23 (3.770448580089902E-18,-2.6432189770275734E-18) Unsymmetrized in crystal axis ( 7.54821 -2.89388 -1.88215 ) ( -2.89386 9.50577 -3.44521 ) ( -1.88212 -3.44521 7.67508 ) Symmetrized in crystal axis ( 7.54821 -2.89388 -1.88215 ) ( -2.89386 9.50577 -3.44521 ) ( -1.88212 -3.44521 7.67508 ) Dielectric constant in cartesian axis ( 8.243020574 0.000000000 0.000000000 ) ( 0.000000000 8.243020574 0.000000000 ) ( 0.000000000 0.000000000 8.243020574 ) POLA SCA (0.15192265863594434,0.) POLA SCA (0.15192265863594434,0.) POLA SCA (0.15192265863594434,0.) HEAD: 0.22164948453608246 8.243020574400814 8.243020574400814 8.243020574400813 E_HEAD : 24 24 (2.341564994489255E-18,0.000004203194629484926) 24 (1.5383250229206171E-18,2.2618066680647406E-18) 24 (-1.543649783735182E-18,-1.2292389328649735E-18) Unsymmetrized in crystal axis ( 7.29568 -2.77556 -1.80972 ) ( -2.77554 9.17826 -3.30556 ) ( -1.80969 -3.30556 7.41955 ) Symmetrized in crystal axis ( 7.29568 -2.77556 -1.80972 ) ( -2.77554 9.17826 -3.30556 ) ( -1.80969 -3.30556 7.41955 ) Dielectric constant in cartesian axis ( 7.964495519 0.000000000 0.000000000 ) ( 0.000000000 7.964495519 0.000000000 ) ( 0.000000000 0.000000000 7.964495519 ) POLA SCA (0.1443934861056254,0.) POLA SCA (0.14439348610562536,0.) POLA SCA (0.1443934861056254,0.) HEAD: 0.23195876288659792 7.964495519495798 7.964495519495795 7.964495519495795 E_HEAD : 25 25 (8.108208652196901E-18,0.000003943892884318445) 25 (6.217248937900875E-19,3.0704520821494762E-18) 25 (2.0307953723600752E-18,-1.6910917111090385E-18) Unsymmetrized in crystal axis ( 7.05088 -2.66177 -1.73990 ) ( -2.66175 8.86095 -3.17107 ) ( -1.73987 -3.17107 7.17175 ) Symmetrized in crystal axis ( 7.05088 -2.66177 -1.73990 ) ( -2.66175 8.86095 -3.17107 ) ( -1.73987 -3.17107 7.17175 ) Dielectric constant in cartesian axis ( 7.694526866 0.000000000 0.000000000 ) ( 0.000000000 7.694526866 0.000000000 ) ( 0.000000000 0.000000000 7.694526866 ) POLA SCA (0.13721069107123246,0.) POLA SCA (0.1372106910712325,0.) POLA SCA (0.1372106910712325,0.) HEAD: 0.2422680412371134 7.694526866332315 7.694526866332313 7.694526866332315 E_HEAD : 26 26 (2.8539628643248818E-18,0.0000036968527679121194) 26 (-9.876544027065398E-19,1.2140523232995888E-19) 26 (-2.0159384144652347E-21,1.8403056856186595E-18) Unsymmetrized in crystal axis ( 6.81398 -2.55254 -1.67271 ) ( -2.55253 8.55411 -3.04181 ) ( -1.67269 -3.04181 6.93190 ) Symmetrized in crystal axis ( 6.81398 -2.55254 -1.67271 ) ( -2.55253 8.55411 -3.04181 ) ( -1.67269 -3.04181 6.93190 ) Dielectric constant in cartesian axis ( 7.433332468 0.000000000 0.000000000 ) ( 0.000000000 7.433332468 0.000000000 ) ( 0.000000000 0.000000000 7.433332468 ) POLA SCA (0.1303711949590508,0.) POLA SCA (0.13037119495905078,0.) POLA SCA (0.13037119495905078,0.) HEAD: 0.25257731958762886 7.433332468299297 7.433332468299298 7.433332468299298 E_HEAD : 27 27 (3.924476314136454E-18,0.000003463176893379597) 27 (3.410605131648479E-19,2.140765659902101E-18) 27 (-2.1098743683157368E-18,3.709033080667723E-18) Unsymmetrized in crystal axis ( 6.58510 -2.44788 -1.60816 ) ( -2.44787 8.25787 -2.91779 ) ( -1.60814 -2.91779 6.70010 ) Symmetrized in crystal axis ( 6.58510 -2.44788 -1.60816 ) ( -2.44787 8.25787 -2.91779 ) ( -1.60814 -2.91779 6.70010 ) Dielectric constant in cartesian axis ( 7.181023349 0.000000000 0.000000000 ) ( 0.000000000 7.181023349 0.000000000 ) ( 0.000000000 0.000000000 7.181023349 ) POLA SCA (0.12386889657297451,0.) POLA SCA (0.12386889657297451,0.) POLA SCA (0.12386889657297455,0.) HEAD: 0.26288659793814434 7.181023348549712 7.181023348549712 7.181023348549714 E_HEAD : 28 28 (6.1891523787925506E-18,0.000003243498290561775) 28 (2.0321522242738866E-18,-1.4151548856367047E-18) 28 (-1.324014140512142E-18,-5.684341886080817E-20) Unsymmetrized in crystal axis ( 6.36424 -2.34773 -1.54620 ) ( -2.34772 7.97226 -2.79898 ) ( -1.54619 -2.79898 6.47636 ) Symmetrized in crystal axis ( 6.36424 -2.34773 -1.54620 ) ( -2.34772 7.97226 -2.79898 ) ( -1.54619 -2.79898 6.47636 ) Dielectric constant in cartesian axis ( 6.937621913 0.000000000 0.000000000 ) ( 0.000000000 6.937621913 0.000000000 ) ( 0.000000000 0.000000000 6.937621913 ) POLA SCA (0.11769536600383956,0.) POLA SCA (0.11769536600383956,0.) POLA SCA (0.11769536600383956,0.) HEAD: 0.2731958762886598 6.937621912764681 6.937621912764684 6.937621912764684 E_HEAD : 29 29 (2.6719710394033885E-18,0.000003038073979498165) 29 (-1.1119993814645569E-18,3.131895852143303E-18) 29 (1.455202603382888E-20,-9.947598300641408E-19) Unsymmetrized in crystal axis ( 6.15136 -2.25200 -1.48682 ) ( -2.25199 7.69722 -2.68531 ) ( -1.48681 -2.68530 6.26065 ) Symmetrized in crystal axis ( 6.15136 -2.25200 -1.48682 ) ( -2.25199 7.69722 -2.68531 ) ( -1.48681 -2.68530 6.26065 ) Dielectric constant in cartesian axis ( 6.703077952 0.000000000 0.000000000 ) ( 0.000000000 6.703077952 0.000000000 ) ( 0.000000000 0.000000000 6.703077952 ) POLA SCA (0.11184043107924237,0.) POLA SCA (0.11184043107924238,0.) POLA SCA (0.11184043107924235,0.) HEAD: 0.28350515463917525 6.703077951804645 6.703077951804648 6.703077951804649 E_HEAD : 30 30 (1.1760207898953182E-18,0.0000028468664455754585) 30 (-5.329070518200753E-19,1.3168143604604805E-18) 30 (3.320538559826308E-19,-2.842170943040401E-19) Unsymmetrized in crystal axis ( 5.94636 -2.16059 -1.42993 ) ( -2.16059 7.43262 -2.57665 ) ( -1.42992 -2.57665 6.05287 ) Symmetrized in crystal axis ( 5.94636 -2.16059 -1.42993 ) ( -2.16059 7.43262 -2.57665 ) ( -1.42992 -2.57665 6.05287 ) Dielectric constant in cartesian axis ( 6.477282553 0.000000000 0.000000000 ) ( 0.000000000 6.477282553 0.000000000 ) ( 0.000000000 0.000000000 6.477282553 ) POLA SCA (0.10629266686001415,0.) POLA SCA (0.10629266686001415,0.) POLA SCA (0.10629266686001416,0.) HEAD: 0.29381443298969073 6.477282553202506 6.477282553202509 6.477282553202508 E_HEAD : 31 31 (2.6818806196633047E-18,0.0000026696126915036867) 31 (-1.0480505352461478E-18,2.934206832583622E-19) 31 (-1.5687388996328544E-18,-4.867217739956686E-19) Unsymmetrized in crystal axis ( 5.74909 -2.07338 -1.37548 ) ( -2.07338 7.17827 -2.47289 ) ( -1.37548 -2.47289 5.85288 ) Symmetrized in crystal axis ( 5.74909 -2.07338 -1.37548 ) ( -2.07338 7.17827 -2.47289 ) ( -1.37548 -2.47289 5.85288 ) Dielectric constant in cartesian axis ( 6.260080081 0.000000000 0.000000000 ) ( 0.000000000 6.260080081 0.000000000 ) ( 0.000000000 0.000000000 6.260080081 ) POLA SCA (0.10103979936476543,0.) POLA SCA (0.1010397993647654,0.) POLA SCA (0.10103979936476543,0.) HEAD: 0.3041237113402062 6.260080081040123 6.260080081040125 6.260080081040123 E_HEAD : 32 32 (6.51042365764862E-18,0.0000025058814754116274) 32 (-1.8580692540126617E-18,-2.106570939821445E-19) 32 (-2.3950703616562596E-18,1.4566126083082064E-19) Unsymmetrized in crystal axis ( 4.09205 -1.37305 -0.93061 ) ( -1.37305 5.05481 -1.63691 ) ( -0.93061 -1.63691 4.17115 ) Symmetrized in crystal axis ( 4.09205 -1.37305 -0.93061 ) ( -1.37305 5.05481 -1.63691 ) ( -0.93061 -1.63691 4.17115 ) Dielectric constant in cartesian axis ( 4.439334283 0.000000000 0.000000000 ) ( 0.000000000 4.439334283 0.000000000 ) ( 0.000000000 0.000000000 4.439334283 ) POLA SCA (0.060482034817868804,0.) POLA SCA (0.06048203481786881,0.) POLA SCA (0.06048203481786881,0.) HEAD: 0.41237113402061853 4.439334283390509 4.439334283390509 4.439334283390509 E_HEAD : 33 33 (3.5052830903935974E-18,0.0000014368268032280584) 33 (3.1956659540810506E-18,1.7832245825365885E-18) 33 (1.2719385549149476E-18,2.7178259642823838E-18) Unsymmetrized in crystal axis ( 2.34018 -0.70908 -0.49171 ) ( -0.70908 2.84677 -0.84234 ) ( -0.49172 -0.84234 2.38914 ) Symmetrized in crystal axis ( 2.34018 -0.70908 -0.49171 ) ( -0.70908 2.84677 -0.84234 ) ( -0.49172 -0.84234 2.38914 ) Dielectric constant in cartesian axis ( 2.525362932 0.000000000 0.000000000 ) ( 0.000000000 2.525362932 0.000000000 ) ( 0.000000000 0.000000000 2.525362932 ) POLA SCA (0.025735887170019362,0.) POLA SCA (0.025735887170019362,0.) POLA SCA (0.02573588717001936,0.) HEAD: 0.6185567010309279 2.5253629324966957 2.525362932496696 2.5253629324966957 E_HEAD : 34 34 (3.588594300833422E-18,8.478742441702991E-7) 34 (-1.185718190299667E-18,-1.4196483954218888E-18) 34 (-1.6057881207457575E-18,-1.1368683772161604E-18) Unsymmetrized in crystal axis ( 1.48434 -0.42108 -0.29473 ) ( -0.42108 1.78816 -0.49867 ) ( -0.29473 -0.49867 1.51668 ) Symmetrized in crystal axis ( 1.48434 -0.42108 -0.29473 ) ( -0.42108 1.78816 -0.49867 ) ( -0.29473 -0.49867 1.51668 ) Dielectric constant in cartesian axis ( 1.596394562 0.000000000 0.000000000 ) ( 0.000000000 1.596394562 0.000000000 ) ( 0.000000000 0.000000000 1.596394562 ) POLA SCA (0.0126743412511129,0.) POLA SCA (0.012674341251112903,0.) POLA SCA (0.012674341251112903,0.) HEAD: 0.8247422680412371 1.596394562265912 1.5963945622659124 1.5963945622659124 E_HEAD : 35 35 (2.336951248832636E-18,5.532226805555639E-7) 35 (-2.4291679778798433E-19,2.8916646028077745E-19) 35 (-6.365240840379254E-19,4.991562718714703E-19) Unsymmetrized in crystal axis ( 1.01673 -0.27610 -0.19402 ) ( -0.27610 1.21711 -0.32633 ) ( -0.19402 -0.32633 1.03936 ) Symmetrized in crystal axis ( 1.01673 -0.27610 -0.19402 ) ( -0.27610 1.21711 -0.32633 ) ( -0.19402 -0.32633 1.03936 ) Dielectric constant in cartesian axis ( 1.091066192 0.000000000 0.000000000 ) ( 0.000000000 1.091066192 0.000000000 ) ( 0.000000000 0.000000000 1.091066192 ) POLA SCA (0.006971997687153732,0.) POLA SCA (0.0069719976871537356,0.) POLA SCA (0.006971997687153732,0.) HEAD: 1.0309278350515463 1.0910661924060532 1.0910661924060527 1.0910661924060532 E_HEAD : 36 36 (1.748433256318286E-18,3.4117464535282945E-7) 36 (-7.314149286230532E-19,-6.430631783907286E-19) 36 (9.985036140470507E-20,2.27373675443232E-19) Unsymmetrized in crystal axis ( 0.73694 -0.19417 -0.13670 ) ( -0.19417 0.87841 -0.22921 ) ( -0.13670 -0.22921 0.75353 ) Symmetrized in crystal axis ( 0.73694 -0.19417 -0.13670 ) ( -0.19417 0.87841 -0.22921 ) ( -0.13670 -0.22921 0.75353 ) Dielectric constant in cartesian axis ( 0.789630117 0.000000000 0.000000000 ) ( 0.000000000 0.789630117 0.000000000 ) ( 0.000000000 0.000000000 0.789630117 ) POLA SCA (0.004169074492942015,0.) POLA SCA (0.004169074492942015,0.) POLA SCA (0.004169074492942015,0.) HEAD: 1.2371134020618557 0.7896301171014134 0.7896301171014138 0.7896301171014136 E_HEAD : 37 37 (1.0744046100129814E-18,2.11543714001202E-7) 37 (3.6654013157999536E-19,-7.630919821813992E-20) 37 (7.045620055261271E-20,5.524469770534779E-19) Unsymmetrized in crystal axis ( 0.55743 -0.14371 -0.10128 ) ( -0.14371 0.66242 -0.16950 ) ( -0.10128 -0.16950 0.57006 ) Symmetrized in crystal axis ( 0.55743 -0.14371 -0.10128 ) ( -0.14371 0.66242 -0.16950 ) ( -0.10128 -0.16950 0.57006 ) Dielectric constant in cartesian axis ( 0.596634048 0.000000000 0.000000000 ) ( 0.000000000 0.596634048 0.000000000 ) ( 0.000000000 0.000000000 0.596634048 ) POLA SCA (0.002659535634714681,0.) POLA SCA (0.0026595356347146808,0.) POLA SCA (0.0026595356347146808,0.) HEAD: 1.443298969072165 0.5966340477426842 0.5966340477426842 0.5966340477426842 E_HEAD : 38 38 (1.796505030006115E-18,1.3433088379661129E-7) 38 (1.6414647419082937E-19,4.774523553347518E-19) 38 (-3.3560292403162637E-19,-3.5527136788005016E-19) Unsymmetrized in crystal axis ( 0.43583 -0.11054 -0.07795 ) ( -0.11054 0.51674 -0.13031 ) ( -0.07795 -0.13031 0.44573 ) Symmetrized in crystal axis ( 0.43583 -0.11054 -0.07795 ) ( -0.11054 0.51674 -0.13031 ) ( -0.07795 -0.13031 0.44573 ) Dielectric constant in cartesian axis ( 0.466100792 0.000000000 0.000000000 ) ( 0.000000000 0.466100792 0.000000000 ) ( 0.000000000 0.000000000 0.466100792 ) POLA SCA (0.0017859368258699628,0.) POLA SCA (0.001785936825869963,0.) POLA SCA (0.0017859368258699632,0.) HEAD: 1.6494845360824741 0.46610079175047353 0.4661007917504736 0.4661007917504736 E_HEAD : 39 39 (9.30975742636825E-19,8.648819645584103E-8) 39 (1.176836406102668E-20,-4.114790766554825E-19) 39 (-1.9312668834753268E-19,-6.927791673660978E-20) Unsymmetrized in crystal axis ( 0.34984 -0.08762 -0.06181 ) ( -0.08762 0.41407 -0.10325 ) ( -0.06181 -0.10325 0.35779 ) Symmetrized in crystal axis ( 0.34984 -0.08762 -0.06181 ) ( -0.08762 0.41407 -0.10325 ) ( -0.06181 -0.10325 0.35779 ) Dielectric constant in cartesian axis ( 0.373899758 0.000000000 0.000000000 ) ( 0.000000000 0.373899758 0.000000000 ) ( 0.000000000 0.000000000 0.373899758 ) POLA SCA (0.001250163470065035,0.) POLA SCA (0.0012501634700650347,0.) POLA SCA (0.0012501634700650345,0.) HEAD: 1.8556701030927834 0.3738997576207724 0.37389975762077227 0.37389975762077227 E_HEAD : 40 40 (8.669717167559193E-19,5.560148447751168E-8) 40 (4.0634162701280724E-20,6.685101657086158E-20) 40 (1.0704431810485424E-19,1.1279865930191593E-19) Unsymmetrized in crystal axis ( 0.28688 -0.07113 -0.05019 ) ( -0.07113 0.33908 -0.08380 ) ( -0.05019 -0.08380 0.29340 ) Symmetrized in crystal axis ( 0.28688 -0.07113 -0.05019 ) ( -0.07113 0.33908 -0.08380 ) ( -0.05019 -0.08380 0.29340 ) Dielectric constant in cartesian axis ( 0.306452676 0.000000000 0.000000000 ) ( 0.000000000 0.306452676 0.000000000 ) ( 0.000000000 0.000000000 0.306452676 ) POLA SCA (0.0009055016550029982,0.) POLA SCA (0.0009055016550029982,0.) POLA SCA (0.000905501655002998,0.) HEAD: 2.0618556701030926 0.3064526759430489 0.30645267594304887 0.30645267594304887 E_HEAD : 41 41 (4.029210506746738E-19,3.509171858427607E-8) 41 (1.8318679906315053E-20,6.243903370685075E-20) 41 (-9.674175048828178E-21,-3.8369307731045413E-19) Unsymmetrized in crystal axis ( 0.23944 -0.05888 -0.04156 ) ( -0.05888 0.28269 -0.06935 ) ( -0.04156 -0.06935 0.24488 ) Symmetrized in crystal axis ( 0.23944 -0.05888 -0.04156 ) ( -0.05888 0.28269 -0.06935 ) ( -0.04156 -0.06935 0.24488 ) Dielectric constant in cartesian axis ( 0.255671775 0.000000000 0.000000000 ) ( 0.000000000 0.255671775 0.000000000 ) ( 0.000000000 0.000000000 0.255671775 ) POLA SCA (0.0006747517905586059,0.) POLA SCA (0.0006747517905586057,0.) POLA SCA (0.0006747517905586059,0.) HEAD: 2.268041237113402 0.25567177500930494 0.2556717750093048 0.2556717750093049 E_HEAD : 42 42 (7.439658326456423E-19,2.121700080632394E-8) 42 (-3.1752378504279483E-19,-2.8811825700855027E-20) 42 (2.6191476338964646E-19,2.930988785010414E-20) Unsymmetrized in crystal axis ( 0.20284 -0.04954 -0.03497 ) ( -0.04954 0.23925 -0.05834 ) ( -0.03497 -0.05834 0.20744 ) Symmetrized in crystal axis ( 0.20284 -0.04954 -0.03497 ) ( -0.04954 0.23925 -0.05834 ) ( -0.03497 -0.05834 0.20744 ) Dielectric constant in cartesian axis ( 0.216507502 0.000000000 0.000000000 ) ( 0.000000000 0.216507502 0.000000000 ) ( 0.000000000 0.000000000 0.216507502 ) POLA SCA (0.0005149609387017375,0.) POLA SCA (0.0005149609387017375,0.) POLA SCA (0.0005149609387017377,0.) HEAD: 2.4742268041237114 0.21650750193807802 0.21650750193807802 0.21650750193807808 E_HEAD : 43 43 (6.59016103102685E-19,1.1707409738562545E-8) 43 (1.4144241333724494E-19,1.4540273451685726E-19) 43 (-9.156532038937394E-20,1.8829382497642655E-19) Unsymmetrized in crystal axis ( 0.17401 -0.04225 -0.02983 ) ( -0.04225 0.20508 -0.04975 ) ( -0.02983 -0.04975 0.17795 ) Symmetrized in crystal axis ( 0.17401 -0.04225 -0.02983 ) ( -0.04225 0.20508 -0.04975 ) ( -0.02983 -0.04975 0.17795 ) Dielectric constant in cartesian axis ( 0.185680295 0.000000000 0.000000000 ) ( 0.000000000 0.185680295 0.000000000 ) ( 0.000000000 0.000000000 0.185680295 ) POLA SCA (0.0004010715857886008,0.) POLA SCA (0.00040107158578860075,0.) POLA SCA (0.0004010715857886007,0.) HEAD: 2.6804123711340204 0.18568029491650673 0.18568029491650676 0.18568029491650684 E_HEAD : 44 44 (5.836181375504253E-19,5.128655416824835E-9) 44 (8.08242361927114E-20,-2.2620014856426092E-20) 44 (5.2733359620296553E-20,-1.0924594562311543E-19) Unsymmetrized in crystal axis ( 0.15091 -0.03646 -0.02574 ) ( -0.03646 0.17773 -0.04293 ) ( -0.02574 -0.04293 0.15432 ) Symmetrized in crystal axis ( 0.15091 -0.03646 -0.02574 ) ( -0.03646 0.17773 -0.04293 ) ( -0.02574 -0.04293 0.15432 ) Dielectric constant in cartesian axis ( 0.160987567 0.000000000 0.000000000 ) ( 0.000000000 0.160987567 0.000000000 ) ( 0.000000000 0.000000000 0.160987567 ) POLA SCA (0.0003178579032850187,0.) POLA SCA (0.00031785790328501867,0.) POLA SCA (0.0003178579032850188,0.) HEAD: 2.88659793814433 0.16098756661105462 0.1609875666110546 0.16098756661105462 E_HEAD : 45 45 (5.778124581779356E-19,5.506654744809038E-10) 45 (-3.241851231905457E-20,1.1134777487249813E-20) 45 (1.4963392878618852E-19,-3.5971225997855086E-20) Unsymmetrized in crystal axis ( 0.13211 -0.03178 -0.02244 ) ( -0.03178 0.15551 -0.03741 ) ( -0.02244 -0.03741 0.13510 ) Symmetrized in crystal axis ( 0.13211 -0.03178 -0.02244 ) ( -0.03178 0.15551 -0.03741 ) ( -0.02244 -0.03741 0.13510 ) Dielectric constant in cartesian axis ( 0.140906836 0.000000000 0.000000000 ) ( 0.000000000 0.140906836 0.000000000 ) ( 0.000000000 0.000000000 0.140906836 ) POLA SCA (0.00025573430815399427,0.) POLA SCA (0.00025573430815399416,0.) POLA SCA (0.0002557343081539943,0.) HEAD: 3.092783505154639 0.14090683599997886 0.14090683599997889 0.14090683599997886 E_HEAD : 46 46 (5.197768698288526E-19,-2.641625175355599E-9) 46 (-8.504308368628698E-20,2.7716506220936807E-20) 46 (3.870186180233504E-20,-3.5971225997855056E-20) Unsymmetrized in crystal axis ( 0.11662 -0.02795 -0.01973 ) ( -0.02795 0.13720 -0.03290 ) ( -0.01973 -0.03290 0.11925 ) Symmetrized in crystal axis ( 0.11662 -0.02795 -0.01973 ) ( -0.02795 0.13720 -0.03290 ) ( -0.01973 -0.03290 0.11925 ) Dielectric constant in cartesian axis ( 0.124359112 0.000000000 0.000000000 ) ( 0.000000000 0.124359112 0.000000000 ) ( 0.000000000 0.000000000 0.124359112 ) POLA SCA (0.00020847546916330555,0.) POLA SCA (0.00020847546916330555,0.) POLA SCA (0.00020847546916330555,0.) HEAD: 3.2989690721649483 0.12435911181441574 0.12435911181441571 0.12435911181441577 E_HEAD : 47 47 (6.838812875684274E-19,-4.862025770005386E-9) 47 (-4.629630012686903E-20,-6.594627950407559E-20) 47 (1.1228215809243802E-20,-1.1102230246251566E-19) Unsymmetrized in crystal axis ( 0.10370 -0.02477 -0.01749 ) ( -0.02477 0.12194 -0.02915 ) ( -0.01749 -0.02915 0.10604 ) Symmetrized in crystal axis ( 0.10370 -0.02477 -0.01749 ) ( -0.02477 0.12194 -0.02915 ) ( -0.01749 -0.02915 0.10604 ) Dielectric constant in cartesian axis ( 0.110562801 0.000000000 0.000000000 ) ( 0.000000000 0.110562801 0.000000000 ) ( 0.000000000 0.000000000 0.110562801 ) POLA SCA (0.0001719257431092853,0.) POLA SCA (0.0001719257431092853,0.) POLA SCA (0.00017192574310928528,0.) HEAD: 3.5051546391752577 0.11056280090849552 0.1105628009084955 0.11056280090849546 E_HEAD : 48 48 (4.1375776483831525E-19,-6.393394861642587E-9) 48 (-5.695444116327054E-20,-1.8211949519796304E-19) 48 (9.784381976199843E-20,-2.495781359357352E-19) Unsymmetrized in crystal axis ( 0.09282 -0.02210 -0.01561 ) ( -0.02210 0.10910 -0.02601 ) ( -0.01561 -0.02601 0.09491 ) Symmetrized in crystal axis ( 0.09282 -0.02210 -0.01561 ) ( -0.02210 0.10910 -0.02601 ) ( -0.01561 -0.02601 0.09491 ) Dielectric constant in cartesian axis ( 0.098940706 0.000000000 0.000000000 ) ( 0.000000000 0.098940706 0.000000000 ) ( 0.000000000 0.000000000 0.098940706 ) POLA SCA (0.00014324253035252662,0.) POLA SCA (0.00014324253035252662,0.) POLA SCA (0.0001432425303525266,0.) HEAD: 3.7113402061855667 0.0989407059335004 0.09894070593350039 0.0989407059335004 E_HEAD : 49 49 (3.2829953053362273E-19,-7.431918863145093E-9) 49 (1.906252933281394E-19,3.2640414622444467E-20) 49 (6.42461255602586E-21,5.773159728050815E-20) Unsymmetrized in crystal axis ( 0.08356 -0.01984 -0.01401 ) ( -0.01984 0.09818 -0.02335 ) ( -0.01401 -0.02335 0.08544 ) Symmetrized in crystal axis ( 0.08356 -0.01984 -0.01401 ) ( -0.01984 0.09818 -0.02335 ) ( -0.01401 -0.02335 0.08544 ) Dielectric constant in cartesian axis ( 0.089059200 0.000000000 0.000000000 ) ( 0.000000000 0.089059200 0.000000000 ) ( 0.000000000 0.000000000 0.089059200 ) POLA SCA (0.00012043854926580218,0.) POLA SCA (0.00012043854926580215,0.) POLA SCA (0.0001204385492658021,0.) HEAD: 3.917525773195876 0.08905919979867556 0.08905919979867556 0.08905919979867559 E_HEAD : 50 50 (4.008167841693459E-19,-8.115472685779945E-9) 50 (3.430589146091734E-20,-3.555420796099926E-20) 50 (1.0823790664154376E-19,1.616484723854228E-19) Unsymmetrized in crystal axis ( 0.07562 -0.01791 -0.01265 ) ( -0.01791 0.08882 -0.02108 ) ( -0.01265 -0.02108 0.07732 ) Symmetrized in crystal axis ( 0.07562 -0.01791 -0.01265 ) ( -0.01791 0.08882 -0.02108 ) ( -0.01265 -0.02108 0.07732 ) Dielectric constant in cartesian axis ( 0.080587479 0.000000000 0.000000000 ) ( 0.000000000 0.080587479 0.000000000 ) ( 0.000000000 0.000000000 0.080587479 ) POLA SCA (0.00010209705199221344,0.) POLA SCA (0.00010209705199221344,0.) POLA SCA (0.00010209705199221345,0.) HEAD: 4.123711340206185 0.0805874786927397 0.0805874786927397 0.0805874786927397 E_HEAD : 51 51 (3.9267074312747915E-19,-8.542091383898277E-9) 51 (-4.796163466380676E-20,-7.485918369155896E-21) 51 (1.4351782151142044E-20,4.307665335545606E-20) Unsymmetrized in crystal axis ( 0.06876 -0.01625 -0.01148 ) ( -0.01625 0.08074 -0.01912 ) ( -0.01148 -0.01912 0.07030 ) Symmetrized in crystal axis ( 0.06876 -0.01625 -0.01148 ) ( -0.01625 0.08074 -0.01912 ) ( -0.01148 -0.01912 0.07030 ) Dielectric constant in cartesian axis ( 0.073269674 0.000000000 0.000000000 ) ( 0.000000000 0.073269674 0.000000000 ) ( 0.000000000 0.000000000 0.073269674 ) POLA SCA (0.00008719009480275848,0.) POLA SCA (0.00008719009480275848,0.) POLA SCA (0.00008719009480275848,0.) HEAD: 4.329896907216495 0.0732696738595597 0.0732696738595597 0.0732696738595597 E_HEAD : 52 52 (3.960252847083056E-19,-8.782201468875872E-9) 52 (5.1070259132757214E-20,-1.6429792198773257E-21) 52 (3.260997437590251E-20,-1.465494392505207E-20) Unsymmetrized in crystal axis ( 0.06280 -0.01481 -0.01046 ) ( -0.01481 0.07372 -0.01743 ) ( -0.01046 -0.01743 0.06420 ) Symmetrized in crystal axis ( 0.06280 -0.01481 -0.01046 ) ( -0.01481 0.07372 -0.01743 ) ( -0.01046 -0.01743 0.06420 ) Dielectric constant in cartesian axis ( 0.066905392 0.000000000 0.000000000 ) ( 0.000000000 0.066905392 0.000000000 ) ( 0.000000000 0.000000000 0.066905392 ) POLA SCA (0.00007495987937214155,0.) POLA SCA (0.00007495987937214152,0.) POLA SCA (0.00007495987937214152,0.) HEAD: 4.536082474226804 0.0669053923630429 0.0669053923630429 0.06690539236304288 E_HEAD : 53 53 (3.88865635741176E-19,-8.886849180209656E-9) 53 (5.007105841059457E-20,-1.3385767544578115E-21) 53 (-4.673768984271619E-21,-1.0658141036401503E-19) Unsymmetrized in crystal axis ( 0.05758 -0.01355 -0.00957 ) ( -0.01355 0.06757 -0.01595 ) ( -0.00957 -0.01595 0.05886 ) Symmetrized in crystal axis ( 0.05758 -0.01355 -0.00957 ) ( -0.01355 0.06757 -0.01595 ) ( -0.00957 -0.01595 0.05886 ) Dielectric constant in cartesian axis ( 0.061335900 0.000000000 0.000000000 ) ( 0.000000000 0.061335900 0.000000000 ) ( 0.000000000 0.000000000 0.061335900 ) POLA SCA (0.00006483964198453982,0.) POLA SCA (0.0000648396419845398,0.) POLA SCA (0.00006483964198453984,0.) HEAD: 4.742268041237113 0.06133590029604069 0.06133590029604066 0.06133590029604064 E_HEAD : 54 54 (2.820046889099897E-19,-8.893317905042777E-9) 54 (3.241851231905457E-20,1.709418366677585E-20) 54 (-2.9109875419170133E-20,-3.552713678800501E-20) Unsymmetrized in crystal axis ( 0.05298 -0.01245 -0.00879 ) ( -0.01245 0.06216 -0.01465 ) ( -0.00879 -0.01465 0.05416 ) Symmetrized in crystal axis ( 0.05298 -0.01245 -0.00879 ) ( -0.01245 0.06216 -0.01465 ) ( -0.00879 -0.01465 0.05416 ) Dielectric constant in cartesian axis ( 0.056434156 0.000000000 0.000000000 ) ( 0.000000000 0.056434156 0.000000000 ) ( 0.000000000 0.000000000 0.056434156 ) POLA SCA (0.00005639989566055209,0.) POLA SCA (0.00005639989566055209,0.) POLA SCA (0.000056399895660552086,0.) HEAD: 4.948453608247423 0.05643415561413703 0.05643415561413704 0.056434155614137026 E_HEAD : 55 55 (2.94862299488438E-19,-8.82901517590118E-9) 55 (4.8072656966269285E-20,-1.3517587046994566E-20) 55 (-9.700214694511347E-21,-1.731947918415244E-20) Unsymmetrized in crystal axis ( 0.04891 -0.01148 -0.00810 ) ( -0.01148 0.05738 -0.01350 ) ( -0.00810 -0.01350 0.05000 ) Symmetrized in crystal axis ( 0.04891 -0.01148 -0.00810 ) ( -0.01148 0.05738 -0.01350 ) ( -0.00810 -0.01350 0.05000 ) Dielectric constant in cartesian axis ( 0.052097513 0.000000000 0.000000000 ) ( 0.000000000 0.052097513 0.000000000 ) ( 0.000000000 0.000000000 0.052097513 ) POLA SCA (0.00004931125788841558,0.) POLA SCA (0.00004931125788841558,0.) POLA SCA (0.00004931125788841558,0.) HEAD: 5.154639175257731 0.052097513285624016 0.052097513285624 0.05209751328562403 E_HEAD : 56 56 (2.6249444109680087E-19,-8.714195431561267E-9) 56 (1.0991207943789057E-20,-5.788146705503059E-20) 56 (5.208554485176953E-20,4.973799150320702E-20) Unsymmetrized in crystal axis ( 0.04530 -0.01061 -0.00749 ) ( -0.01061 0.05312 -0.01249 ) ( -0.00749 -0.01249 0.04631 ) Symmetrized in crystal axis ( 0.04530 -0.01061 -0.00749 ) ( -0.01061 0.05312 -0.01249 ) ( -0.00749 -0.01249 0.04631 ) Dielectric constant in cartesian axis ( 0.048242315 0.000000000 0.000000000 ) ( 0.000000000 0.048242315 0.000000000 ) ( 0.000000000 0.000000000 0.048242315 ) POLA SCA (0.000043318332288235834,0.) POLA SCA (0.00004331833228823583,0.) POLA SCA (0.00004331833228823584,0.) HEAD: 5.360824742268041 0.048242315086365624 0.04824231508636561 0.04824231508636564 E_HEAD : 57 57 (2.273100888996452E-19,-8.563888567836744E-9) 57 (1.2656542480726785E-20,4.055143765200361E-20) 57 (9.909458302262762E-21,5.817568649035821E-20) Unsymmetrized in crystal axis ( 0.04207 -0.00984 -0.00695 ) ( -0.00984 0.04933 -0.01158 ) ( -0.00695 -0.01158 0.04301 ) Symmetrized in crystal axis ( 0.04207 -0.00984 -0.00695 ) ( -0.00984 0.04933 -0.01158 ) ( -0.00695 -0.01158 0.04301 ) Dielectric constant in cartesian axis ( 0.044799828 0.000000000 0.000000000 ) ( 0.000000000 0.044799828 0.000000000 ) ( 0.000000000 0.000000000 0.044799828 ) POLA SCA (0.00003822108485047862,0.) POLA SCA (0.000038221084850478625,0.) POLA SCA (0.000038221084850478625,0.) HEAD: 5.56701030927835 0.04479982797555862 0.0447998279755586 0.04479982797555861 E_HEAD : 58 58 (2.326558015167253E-19,-8.389279854363218E-9) 58 (2.19824158875781E-20,2.8025143851092594E-20) 58 (-1.4645034221904344E-20,-5.773159728050815E-20) Unsymmetrized in crystal axis ( 0.03917 -0.00915 -0.00646 ) ( -0.00915 0.04592 -0.01077 ) ( -0.00646 -0.01077 0.04004 ) Symmetrized in crystal axis ( 0.03917 -0.00915 -0.00646 ) ( -0.00915 0.04592 -0.01077 ) ( -0.00646 -0.01077 0.04004 ) Dielectric constant in cartesian axis ( 0.041713160 0.000000000 0.000000000 ) ( 0.000000000 0.041713160 0.000000000 ) ( 0.000000000 0.000000000 0.041713160 ) POLA SCA (0.000033861382574765914,0.) POLA SCA (0.00003386138257476593,0.) POLA SCA (0.00003386138257476597,0.) HEAD: 5.77319587628866 0.04171316045335332 0.04171316045335332 0.04171316045335332 E_HEAD : 59 59 (1.8422638876209577E-19,-8.198706441483573E-9) 59 (3.9301895071730546E-20,3.056809557742761E-20) 59 (2.435898011458407E-20,4.7517545453956705E-20) Unsymmetrized in crystal axis ( 0.03657 -0.00853 -0.00603 ) ( -0.00853 0.04286 -0.01004 ) ( -0.00603 -0.01004 0.03738 ) Symmetrized in crystal axis ( 0.03657 -0.00853 -0.00603 ) ( -0.00853 0.04286 -0.01004 ) ( -0.00603 -0.01004 0.03738 ) Dielectric constant in cartesian axis ( 0.038934897 0.000000000 0.000000000 ) ( 0.000000000 0.038934897 0.000000000 ) ( 0.000000000 0.000000000 0.038934897 ) POLA SCA (0.000030113140546157572,0.) POLA SCA (0.000030113140546157575,0.) POLA SCA (0.00003011314054615749,0.) HEAD: 5.979381443298969 0.03893489695794911 0.038934896957949106 0.0389348969579491 E_HEAD : 60 60 (1.7087387463555174E-19,-7.998383129929288E-9) 60 (1.8873791418627684E-21,2.8771459286962436E-20) 60 (-3.750301239694969E-20,3.04201108747293E-20) Unsymmetrized in crystal axis ( 0.03421 -0.00797 -0.00563 ) ( -0.00797 0.04009 -0.00938 ) ( -0.00563 -0.00938 0.03497 ) Symmetrized in crystal axis ( 0.03421 -0.00797 -0.00563 ) ( -0.00797 0.04009 -0.00938 ) ( -0.00563 -0.00938 0.03497 ) Dielectric constant in cartesian axis ( 0.036425266 0.000000000 0.000000000 ) ( 0.000000000 0.036425266 0.000000000 ) ( 0.000000000 0.000000000 0.036425266 ) POLA SCA (0.000026875025761933374,0.) POLA SCA (0.000026875025761933374,0.) POLA SCA (0.000026875025761933374,0.) HEAD: 6.185567010309278 0.03642526551840835 0.03642526551840833 0.036425265518408335 E_HEAD : 61 61 (1.835531884564141E-19,-7.792935056934016E-9) 61 (2.6201263381153693E-20,-2.8345163486477112E-21) 61 (2.5180006503379704E-20,-3.419486915845483E-20) Unsymmetrized in crystal axis ( 0.03208 -0.00747 -0.00527 ) ( -0.00747 0.03759 -0.00879 ) ( -0.00527 -0.00879 0.03279 ) Symmetrized in crystal axis ( 0.03208 -0.00747 -0.00527 ) ( -0.00747 0.03759 -0.00879 ) ( -0.00527 -0.00879 0.03279 ) Dielectric constant in cartesian axis ( 0.034150706 0.000000000 0.000000000 ) ( 0.000000000 0.034150706 0.000000000 ) ( 0.000000000 0.000000000 0.034150706 ) POLA SCA (0.000024064995562430345,0.) POLA SCA (0.000024064995562430345,0.) POLA SCA (0.000024064995562430345,0.) HEAD: 6.391752577319587 0.03415070566551413 0.03415070566551414 0.03415070566551413 E_HEAD : 62 62 (2.1011304399681314E-19,-7.585791469904013E-9) 62 (-1.587618925213974E-20,6.335012352074116E-21) 62 (4.4935097851840637E-20,-3.486100297322992E-20) Unsymmetrized in crystal axis ( 0.03014 -0.00701 -0.00495 ) ( -0.00701 0.03531 -0.00825 ) ( -0.00495 -0.00825 0.03080 ) Symmetrized in crystal axis ( 0.03014 -0.00701 -0.00495 ) ( -0.00701 0.03531 -0.00825 ) ( -0.00495 -0.00825 0.03080 ) Dielectric constant in cartesian axis ( 0.032082740 0.000000000 0.000000000 ) ( 0.000000000 0.032082740 0.000000000 ) ( 0.000000000 0.000000000 0.032082740 ) POLA SCA (0.000021616168059304033,0.) POLA SCA (0.00002161616805930403,0.) POLA SCA (0.000021616168059304033,0.) HEAD: 6.597938144329897 0.032082739763643724 0.03208273976364372 0.03208273976364372 E_HEAD : 63 63 (2.0075106169872213E-19,-7.3794787054866094E-9) 63 (1.7208456881689932E-20,-2.8512452493559836E-20) 63 (2.1272769249148725E-21,-3.1086244689504386E-21) Unsymmetrized in crystal axis ( 0.02837 -0.00659 -0.00466 ) ( -0.00659 0.03323 -0.00775 ) ( -0.00466 -0.00775 0.02900 ) Symmetrized in crystal axis ( 0.02837 -0.00659 -0.00466 ) ( -0.00659 0.03323 -0.00775 ) ( -0.00466 -0.00775 0.02900 ) Dielectric constant in cartesian axis ( 0.030197076 0.000000000 0.000000000 ) ( 0.000000000 0.030197076 0.000000000 ) ( 0.000000000 0.000000000 0.030197076 ) POLA SCA (0.000019473670314647987,0.) POLA SCA (0.000019473670314647987,0.) POLA SCA (0.000019473670314647987,0.) HEAD: 6.804123711340206 0.030197076491883214 0.030197076491883208 0.0301970764918832 E_HEAD : 64 64 (1.925872466875686E-19,-7.1758394840855125E-9) 64 (3.869127240818671E-20,6.4236861137398004E-21) 64 (1.7912000594794775E-20,8.881784197001253E-20) Unsymmetrized in crystal axis ( 0.02675 -0.00621 -0.00439 ) ( -0.00621 0.03133 -0.00731 ) ( -0.00439 -0.00731 0.02734 ) Symmetrized in crystal axis ( 0.02675 -0.00621 -0.00439 ) ( -0.00621 0.03133 -0.00731 ) ( -0.00439 -0.00731 0.02734 ) Dielectric constant in cartesian axis ( 0.028472893 0.000000000 0.000000000 ) ( 0.000000000 0.028472893 0.000000000 ) ( 0.000000000 0.000000000 0.028472893 ) POLA SCA (0.000017592211630735597,0.) POLA SCA (0.000017592211630735597,0.) POLA SCA (0.000017592211630735597,0.) HEAD: 7.010309278350515 0.028472893487669407 0.028472893487669418 0.028472893487669418 E_HEAD : 65 65 (2.006866342486722E-19,-6.976197924711603E-9) 65 (-5.995204332975847E-20,2.9683210845342888E-21) 65 (-3.7729461361442207E-20,4.529709940470639E-20) Unsymmetrized in crystal axis ( 0.02526 -0.00586 -0.00414 ) ( -0.00586 0.02959 -0.00689 ) ( -0.00414 -0.00689 0.02582 ) Symmetrized in crystal axis ( 0.02526 -0.00586 -0.00414 ) ( -0.00586 0.02959 -0.00689 ) ( -0.00414 -0.00689 0.02582 ) Dielectric constant in cartesian axis ( 0.026892259 0.000000000 0.000000000 ) ( 0.000000000 0.026892259 0.000000000 ) ( 0.000000000 0.000000000 0.026892259 ) POLA SCA (0.00001593419977301829,0.) POLA SCA (0.00001593419977301829,0.) POLA SCA (0.000015934199773018298,0.) HEAD: 7.216494845360824 0.026892259386841578 0.026892259386841578 0.02689225938684159 E_HEAD : 66 66 (1.7126931008565397E-19,-6.781484324967614E-9) 66 (3.0531133177191807E-20,-2.6059365668972576E-20) 66 (-1.135826514514939E-20,-2.2204460492503135E-20) Unsymmetrized in crystal axis ( 0.02390 -0.00554 -0.00391 ) ( -0.00554 0.02799 -0.00652 ) ( -0.00391 -0.00652 0.02443 ) Symmetrized in crystal axis ( 0.02390 -0.00554 -0.00391 ) ( -0.00554 0.02799 -0.00652 ) ( -0.00391 -0.00652 0.02443 ) Dielectric constant in cartesian axis ( 0.025439665 0.000000000 0.000000000 ) ( 0.000000000 0.025439665 0.000000000 ) ( 0.000000000 0.000000000 0.025439665 ) POLA SCA (0.000014468267391696029,0.) POLA SCA (0.000014468267391696032,0.) POLA SCA (0.000014468267391696043,0.) HEAD: 7.422680412371133 0.02543966515050207 0.02543966515050207 0.02543966515050207 E_HEAD : 67 67 (1.6188164241415992E-19,-6.59232992183123E-9) 67 (2.8921309791485327E-20,1.844850994009667E-20) 67 (-1.2845668235417742E-20,5.329070518200751E-21) Unsymmetrized in crystal axis ( 0.02264 -0.00524 -0.00370 ) ( -0.00524 0.02651 -0.00617 ) ( -0.00370 -0.00617 0.02315 ) Symmetrized in crystal axis ( 0.02264 -0.00524 -0.00370 ) ( -0.00524 0.02651 -0.00617 ) ( -0.00370 -0.00617 0.02315 ) Dielectric constant in cartesian axis ( 0.024101642 0.000000000 0.000000000 ) ( 0.000000000 0.024101642 0.000000000 ) ( 0.000000000 0.000000000 0.024101642 ) POLA SCA (0.000013168110985618828,0.) POLA SCA (0.000013168110985618828,0.) POLA SCA (0.00001316811098561883,0.) HEAD: 7.628865979381443 0.024101641690033402 0.024101641690033416 0.024101641690033412 E_HEAD : 68 68 (1.8212283150911047E-19,-6.409139126021813E-9) 68 (-7.105427357601002E-21,-2.6582673211698122E-20) 68 (3.161517388402174E-20,1.7319479184152445E-20) Unsymmetrized in crystal axis ( 0.02148 -0.00497 -0.00351 ) ( -0.00497 0.02515 -0.00585 ) ( -0.00351 -0.00585 0.02196 ) Symmetrized in crystal axis ( 0.02148 -0.00497 -0.00351 ) ( -0.00497 0.02515 -0.00585 ) ( -0.00351 -0.00585 0.02196 ) Dielectric constant in cartesian axis ( 0.022866446 0.000000000 0.000000000 ) ( 0.000000000 0.022866446 0.000000000 ) ( 0.000000000 0.000000000 0.022866446 ) POLA SCA (0.000012011569899676672,0.) POLA SCA (0.000012011569899676672,0.) POLA SCA (0.000012011569899676672,0.) HEAD: 7.835051546391752 0.022866446100192766 0.02286644610019276 0.02286644610019277 E_HEAD : 69 69 (1.3351872884351343E-19,-6.232144768553051E-9) 69 (1.9095836023552693E-20,-2.978750177697357E-20) 69 (1.957491486743463E-20,-7.105427357601E-21) Unsymmetrized in crystal axis ( 0.02041 -0.00472 -0.00333 ) ( -0.00472 0.02390 -0.00555 ) ( -0.00333 -0.00555 0.02086 ) Symmetrized in crystal axis ( 0.02041 -0.00472 -0.00333 ) ( -0.00472 0.02390 -0.00555 ) ( -0.00333 -0.00555 0.02086 ) Dielectric constant in cartesian axis ( 0.021723803 0.000000000 0.000000000 ) ( 0.000000000 0.021723803 0.000000000 ) ( 0.000000000 0.000000000 0.021723803 ) POLA SCA (0.000010979891052312062,0.) POLA SCA (0.000010979891052312062,0.) POLA SCA (0.000010979891052312059,0.) HEAD: 8.041237113402062 0.02172380278634813 0.021723802786348126 0.02172380278634813 E_HEAD : 70 70 (1.2190345154689341E-19,-6.061450461526453E-9) 70 (-2.8810287489022814E-20,3.4580914165044864E-20) 70 (4.570884259682273E-21,-3.9745984281580613E-20) Unsymmetrized in crystal axis ( 0.01942 -0.00449 -0.00317 ) ( -0.00449 0.02273 -0.00528 ) ( -0.00317 -0.00528 0.01985 ) Symmetrized in crystal axis ( 0.01942 -0.00449 -0.00317 ) ( -0.00449 0.02273 -0.00528 ) ( -0.00317 -0.00528 0.01985 ) Dielectric constant in cartesian axis ( 0.020664689 0.000000000 0.000000000 ) ( 0.000000000 0.020664689 0.000000000 ) ( 0.000000000 0.000000000 0.020664689 ) POLA SCA (0.000010057138392093924,0.) POLA SCA (0.000010057138392093924,0.) POLA SCA (0.000010057138392093923,0.) HEAD: 8.24742268041237 0.020664688779671238 0.02066468877967124 0.02066468877967124 E_HEAD : 71 71 (1.7178455941014903E-19,-5.897063147724869E-9) 71 (1.4321877017664524E-20,-1.3393973176254641E-20) 71 (3.445031888993499E-20,2.442490654175345E-20) Unsymmetrized in crystal axis ( 0.01849 -0.00427 -0.00302 ) ( -0.00427 0.02165 -0.00503 ) ( -0.00302 -0.00503 0.01890 ) Symmetrized in crystal axis ( 0.01849 -0.00427 -0.00302 ) ( -0.00427 0.02165 -0.00503 ) ( -0.00302 -0.00503 0.01890 ) Dielectric constant in cartesian axis ( 0.019681155 0.000000000 0.000000000 ) ( 0.000000000 0.019681155 0.000000000 ) ( 0.000000000 0.000000000 0.019681155 ) POLA SCA (0.000009229715887284609,0.) POLA SCA (0.00000922971588728461,0.) POLA SCA (0.000009229715887284604,0.) HEAD: 8.45360824742268 0.019681154826611546 0.019681154826611542 0.019681154826611546 E_HEAD : 72 72 (1.2622418659843212E-19,-5.7389181529738935E-9) 72 (2.592370762499741E-20,-3.2184605017703244E-21) 72 (3.713461923934307E-21,1.465494392505206E-20) Unsymmetrized in crystal axis ( 0.01763 -0.00407 -0.00288 ) ( -0.00407 0.02064 -0.00479 ) ( -0.00288 -0.00479 0.01802 ) Symmetrized in crystal axis ( 0.01763 -0.00407 -0.00288 ) ( -0.00407 0.02064 -0.00479 ) ( -0.00288 -0.00479 0.01802 ) Dielectric constant in cartesian axis ( 0.018766176 0.000000000 0.000000000 ) ( 0.000000000 0.018766176 0.000000000 ) ( 0.000000000 0.000000000 0.018766176 ) POLA SCA (0.000008485980139475623,0.) POLA SCA (0.000008485980139475623,0.) POLA SCA (0.000008485980139475618,0.) HEAD: 8.65979381443299 0.018766175598912086 0.018766175598912086 0.018766175598912086 E_HEAD : 73 73 (1.1780488404048576E-19,-5.586898474861601E-9) 73 (-1.942890293094028E-21,-2.140280204144206E-21) 73 (-9.280155835844669E-21,1.8873791418627663E-20) Unsymmetrized in crystal axis ( 0.01683 -0.00388 -0.00274 ) ( -0.00388 0.01970 -0.00457 ) ( -0.00274 -0.00457 0.01721 ) Symmetrized in crystal axis ( 0.01683 -0.00388 -0.00274 ) ( -0.00388 0.01970 -0.00457 ) ( -0.00274 -0.00457 0.01721 ) Dielectric constant in cartesian axis ( 0.017913524 0.000000000 0.000000000 ) ( 0.000000000 0.017913524 0.000000000 ) ( 0.000000000 0.000000000 0.017913524 ) POLA SCA (0.000007815924170809374,0.) POLA SCA (0.000007815924170809374,0.) POLA SCA (0.000007815924170809364,0.) HEAD: 8.865979381443298 0.0179135237307424 0.017913523730742398 0.0179135237307424 E_HEAD : 74 74 (1.4544532703832483E-19,-5.440849640969193E-9) 74 (9.936496070395155E-21,-1.9754727388991407E-20) 74 (6.391012479543956E-21,-1.7763568394002506E-20) Unsymmetrized in crystal axis ( 0.01609 -0.00371 -0.00262 ) ( -0.00371 0.01882 -0.00436 ) ( -0.00262 -0.00436 0.01644 ) Symmetrized in crystal axis ( 0.01609 -0.00371 -0.00262 ) ( -0.00371 0.01882 -0.00436 ) ( -0.00262 -0.00436 0.01644 ) Dielectric constant in cartesian axis ( 0.017117663 0.000000000 0.000000000 ) ( 0.000000000 0.017117663 0.000000000 ) ( 0.000000000 0.000000000 0.017117663 ) POLA SCA (0.000007210918053402651,0.) POLA SCA (0.000007210918053402652,0.) POLA SCA (0.0000072109180534026625,0.) HEAD: 9.072164948453608 0.017117663447778767 0.01711766344777877 0.01711766344777877 E_HEAD : 75 75 (1.2912715698150585E-19,-5.300591138102329E-9) 75 (-1.820765760385257E-20,6.502036661360823E-21) 75 (-8.51871126657123E-21,-8.881784197001256E-21) Unsymmetrized in crystal axis ( 0.01539 -0.00355 -0.00251 ) ( -0.00355 0.01801 -0.00417 ) ( -0.00251 -0.00417 0.01573 ) Symmetrized in crystal axis ( 0.01539 -0.00355 -0.00251 ) ( -0.00355 0.01801 -0.00417 ) ( -0.00251 -0.00417 0.01573 ) Dielectric constant in cartesian axis ( 0.016373660 0.000000000 0.000000000 ) ( 0.000000000 0.016373660 0.000000000 ) ( 0.000000000 0.000000000 0.016373660 ) POLA SCA (0.0000066634951799763726,0.) POLA SCA (0.000006663495179976372,0.) POLA SCA (0.0000066634951799763726,0.) HEAD: 9.278350515463917 0.01637366038141216 0.01637366038141215 0.016373660381412154 E_HEAD : 76 76 (1.5848430983699085E-19,-5.165925195049105E-9) 76 (2.775557561562892E-21,-1.2561035386638245E-20) 76 (8.157158892630427E-22,6.2172489379008735E-21) Unsymmetrized in crystal axis ( 0.01473 -0.00339 -0.00240 ) ( -0.00339 0.01724 -0.00399 ) ( -0.00240 -0.00399 0.01506 ) Symmetrized in crystal axis ( 0.01473 -0.00339 -0.00240 ) ( -0.00339 0.01724 -0.00399 ) ( -0.00240 -0.00399 0.01506 ) Dielectric constant in cartesian axis ( 0.015677105 0.000000000 0.000000000 ) ( 0.000000000 0.015677105 0.000000000 ) ( 0.000000000 0.000000000 0.015677105 ) POLA SCA (0.000006167175369660938,0.) POLA SCA (0.000006167175369660937,0.) POLA SCA (0.000006167175369660937,0.) HEAD: 9.484536082474227 0.0156771048134642 0.015677104813464206 0.015677104813464206 E_HEAD : 77 77 (9.798972338108288E-20,-5.036643500533066E-9) 77 (3.641531520770513E-20,1.2013309472230131E-21) 77 (-1.231481680550571E-20,8.659739592076222E-21) Unsymmetrized in crystal axis ( 0.01412 -0.00325 -0.00230 ) ( -0.00325 0.01652 -0.00382 ) ( -0.00230 -0.00382 0.01443 ) Symmetrized in crystal axis ( 0.01412 -0.00325 -0.00230 ) ( -0.00325 0.01652 -0.00382 ) ( -0.00230 -0.00382 0.01443 ) Dielectric constant in cartesian axis ( 0.015024046 0.000000000 0.000000000 ) ( 0.000000000 0.015024046 0.000000000 ) ( 0.000000000 0.000000000 0.015024046 ) POLA SCA (0.000005716317846976958,0.) POLA SCA (0.000005716317846976959,0.) POLA SCA (0.000005716317846976958,0.) HEAD: 9.690721649484535 0.01502404611317885 0.01502404611317885 0.01502404611317885 E_HEAD : 78 78 (8.58455005614155E-20,-4.9125323231826736E-9) 78 (-2.1094237467877983E-21,7.30734661851795E-21) 78 (-1.2298058126295386E-20,-4.107825191113077E-21) Unsymmetrized in crystal axis ( 0.01354 -0.00312 -0.00220 ) ( -0.00312 0.01585 -0.00367 ) ( -0.00220 -0.00367 0.01384 ) Symmetrized in crystal axis ( 0.01354 -0.00312 -0.00220 ) ( -0.00312 0.01585 -0.00367 ) ( -0.00220 -0.00367 0.01384 ) Dielectric constant in cartesian axis ( 0.014410937 0.000000000 0.000000000 ) ( 0.000000000 0.014410937 0.000000000 ) ( 0.000000000 0.000000000 0.014410937 ) POLA SCA (0.000005305998560452779,0.) POLA SCA (0.000005305998560452778,0.) POLA SCA (0.000005305998560452778,0.) HEAD: 9.896907216494846 0.014410936539297176 0.014410936539297177 0.014410936539297176 E_HEAD : 79 79 (1.0053561357039809E-19,-4.793376393590232E-9) 79 (8.548717289613706E-21,-5.007949951743042E-21) 79 (-9.529104112998627E-21,1.4210854715202006E-20) Unsymmetrized in crystal axis ( 0.01300 -0.00299 -0.00211 ) ( -0.00299 0.01521 -0.00352 ) ( -0.00211 -0.00352 0.01329 ) Symmetrized in crystal axis ( 0.01300 -0.00299 -0.00211 ) ( -0.00299 0.01521 -0.00352 ) ( -0.00211 -0.00352 0.01329 ) Dielectric constant in cartesian axis ( 0.013834583 0.000000000 0.000000000 ) ( 0.000000000 0.013834583 0.000000000 ) ( 0.000000000 0.000000000 0.013834583 ) POLA SCA (0.0000049319074203004015,0.) POLA SCA (0.000004931907420300401,0.) POLA SCA (0.0000049319074203004015,0.) HEAD: 10.103092783505154 0.01383458290888052 0.013834582908880516 0.013834582908880512 E_HEAD : 80 80 (9.682700689565178E-20,-4.6789618037969E-9) 80 (4.829470157119432E-21,-1.082792656721714E-20) 80 (1.194643191970522E-20,8.881784197001253E-21) Unsymmetrized in crystal axis ( 0.01249 -0.00287 -0.00203 ) ( -0.00287 0.01461 -0.00338 ) ( -0.00203 -0.00338 0.01277 ) Symmetrized in crystal axis ( 0.01249 -0.00287 -0.00203 ) ( -0.00287 0.01461 -0.00338 ) ( -0.00203 -0.00338 0.01277 ) Dielectric constant in cartesian axis ( 0.013292105 0.000000000 0.000000000 ) ( 0.000000000 0.013292105 0.000000000 ) ( 0.000000000 0.000000000 0.013292105 ) POLA SCA (0.000004590261906509182,0.) POLA SCA (0.000004590261906509182,0.) POLA SCA (0.0000045902619065091824,0.) HEAD: 10.309278350515463 0.013292104898936624 0.01329210489893663 0.013292104898936627 E_HEAD : 81 81 (9.060268946146773E-20,-4.569078166287655E-9) 81 (1.2351231148954869E-20,2.4705237918998766E-21) 81 (-1.4431762244569795E-20,2.6090241078691184E-20) Unsymmetrized in crystal axis ( 0.01201 -0.00276 -0.00195 ) ( -0.00276 0.01405 -0.00325 ) ( -0.00195 -0.00325 0.01228 ) Symmetrized in crystal axis ( 0.01201 -0.00276 -0.00195 ) ( -0.00276 0.01405 -0.00325 ) ( -0.00195 -0.00325 0.01228 ) Dielectric constant in cartesian axis ( 0.012780899 0.000000000 0.000000000 ) ( 0.000000000 0.012780899 0.000000000 ) ( 0.000000000 0.000000000 0.012780899 ) POLA SCA (0.000004277734185431213,0.) POLA SCA (0.000004277734185431212,0.) POLA SCA (0.000004277734185431219,0.) HEAD: 10.515463917525773 0.012780898960459704 0.012780898960459705 0.01278089896045971 E_HEAD : 82 82 (1.1542908512430588E-19,-4.463520173852154E-9) 82 (8.881784197001253E-21,2.0868277929610293E-20) 82 (2.461664687539434E-21,-3.219646771412956E-21) Unsymmetrized in crystal axis ( 0.01156 -0.00266 -0.00188 ) ( -0.00266 0.01352 -0.00312 ) ( -0.00188 -0.00312 0.01181 ) Symmetrized in crystal axis ( 0.01156 -0.00266 -0.00188 ) ( -0.00266 0.01352 -0.00312 ) ( -0.00188 -0.00312 0.01181 ) Dielectric constant in cartesian axis ( 0.012298607 0.000000000 0.000000000 ) ( 0.000000000 0.012298607 0.000000000 ) ( 0.000000000 0.000000000 0.012298607 ) POLA SCA (0.000003991389416503043,0.) POLA SCA (0.000003991389416503044,0.) POLA SCA (0.000003991389416503043,0.) HEAD: 10.721649484536082 0.012298606997762267 0.012298606997762267 0.012298606997762258 E_HEAD : 83 83 (8.568860224214831E-20,-4.362088711372226E-9) 83 (5.107025913275722E-21,2.0274792383715747E-20) 83 (8.37245746246573E-21,4.3298697960381104E-21) Unsymmetrized in crystal axis ( 0.01113 -0.00256 -0.00181 ) ( -0.00256 0.01302 -0.00301 ) ( -0.00181 -0.00301 0.01138 ) Symmetrized in crystal axis ( 0.01113 -0.00256 -0.00181 ) ( -0.00256 0.01302 -0.00301 ) ( -0.00181 -0.00301 0.01138 ) Dielectric constant in cartesian axis ( 0.011843089 0.000000000 0.000000000 ) ( 0.000000000 0.011843089 0.000000000 ) ( 0.000000000 0.000000000 0.011843089 ) POLA SCA (0.0000037286333630856674,0.) POLA SCA (0.0000037286333630856674,0.) POLA SCA (0.0000037286333630856687,0.) HEAD: 10.927835051546392 0.011843089107161175 0.011843089107161177 0.011843089107161172 E_HEAD : 84 84 (8.770878132938337E-20,-4.264591606760516E-9) 84 (4.440892098500628E-21,-6.378588226743409E-21) 84 (7.007543277304229E-22,-5.884182030513332E-21) Unsymmetrized in crystal axis ( 0.01073 -0.00246 -0.00174 ) ( -0.00246 0.01255 -0.00290 ) ( -0.00174 -0.00290 0.01096 ) Symmetrized in crystal axis ( 0.01073 -0.00246 -0.00174 ) ( -0.00246 0.01255 -0.00290 ) ( -0.00174 -0.00290 0.01096 ) Dielectric constant in cartesian axis ( 0.011412400 0.000000000 0.000000000 ) ( 0.000000000 0.011412400 0.000000000 ) ( 0.000000000 0.000000000 0.011412400 ) POLA SCA (0.000003487167766864678,0.) POLA SCA (0.000003487167766864678,0.) POLA SCA (0.000003487167766864678,0.) HEAD: 11.1340206185567 0.011412399784596359 0.011412399784596362 0.011412399784596364 E_HEAD : 85 85 (7.138318465187149E-20,-4.170844114529504E-9) 85 (8.049116928532385E-21,-8.257380095647352E-21) 85 (-6.458981910477438E-21,-1.3433698597964394E-20) Unsymmetrized in crystal axis ( 0.01034 -0.00237 -0.00168 ) ( -0.00237 0.01210 -0.00279 ) ( -0.00168 -0.00279 0.01057 ) Symmetrized in crystal axis ( 0.01034 -0.00237 -0.00168 ) ( -0.00237 0.01210 -0.00279 ) ( -0.00168 -0.00279 0.01057 ) Dielectric constant in cartesian axis ( 0.011004767 0.000000000 0.000000000 ) ( 0.000000000 0.011004767 0.000000000 ) ( 0.000000000 0.000000000 0.011004767 ) POLA SCA (0.0000032649522225123306,0.) POLA SCA (0.000003264952222512331,0.) POLA SCA (0.000003264952222512331,0.) HEAD: 11.340206185567009 0.011004767106649492 0.011004767106649492 0.011004767106649492 E_HEAD : 86 86 (8.865695797249792E-20,-4.080669185508424E-9) 86 (7.494005416219809E-22,-5.6510994216152725E-21) 86 (-3.9458417734188296E-21,1.7541523789077475E-20) Unsymmetrized in crystal axis ( 0.00998 -0.00229 -0.00162 ) ( -0.00229 0.01167 -0.00269 ) ( -0.00162 -0.00269 0.01020 ) Symmetrized in crystal axis ( 0.00998 -0.00229 -0.00162 ) ( -0.00229 0.01167 -0.00269 ) ( -0.00162 -0.00269 0.01020 ) Dielectric constant in cartesian axis ( 0.010618574 0.000000000 0.000000000 ) ( 0.000000000 0.010618574 0.000000000 ) ( 0.000000000 0.000000000 0.010618574 ) POLA SCA (0.000003060171512784727,0.) POLA SCA (0.0000030601715127847264,0.) POLA SCA (0.000003060171512784727,0.) HEAD: 11.54639175257732 0.010618574467672526 0.010618574467672526 0.010618574467672526 E_HEAD : 87 87 (8.061751292782642E-20,-3.9938975765013155E-9) 87 (1.94844140821715E-20,-1.163813343360058E-20) 87 (1.3818316830494344E-20,3.774758283725533E-21) Unsymmetrized in crystal axis ( 0.00964 -0.00221 -0.00156 ) ( -0.00221 0.01127 -0.00260 ) ( -0.00156 -0.00260 0.00985 ) Symmetrized in crystal axis ( 0.00964 -0.00221 -0.00156 ) ( -0.00221 0.01127 -0.00260 ) ( -0.00156 -0.00260 0.00985 ) Dielectric constant in cartesian axis ( 0.010252345 0.000000000 0.000000000 ) ( 0.000000000 0.010252345 0.000000000 ) ( 0.000000000 0.000000000 0.010252345 ) POLA SCA (0.0000028712075450803266,0.) POLA SCA (0.000002871207545080326,0.) POLA SCA (0.000002871207545080326,0.) HEAD: 11.752577319587628 0.010252344520487894 0.010252344520487892 0.010252344520487894 E_HEAD : 88 88 (7.648088974645411E-20,-3.9103678356849916E-9) 88 (9.270362255620057E-21,1.5210561063094595E-20) 88 (6.999742964127854E-21,1.9206858326015212E-20) Unsymmetrized in crystal axis ( 0.00931 -0.00214 -0.00151 ) ( -0.00214 0.01089 -0.00251 ) ( -0.00151 -0.00251 0.00952 ) Symmetrized in crystal axis ( 0.00931 -0.00214 -0.00151 ) ( -0.00214 0.01089 -0.00251 ) ( -0.00151 -0.00251 0.00952 ) Dielectric constant in cartesian axis ( 0.009904725 0.000000000 0.000000000 ) ( 0.000000000 0.009904725 0.000000000 ) ( 0.000000000 0.000000000 0.009904725 ) POLA SCA (0.000002696615177420988,0.) POLA SCA (0.000002696615177420988,0.) POLA SCA (0.0000026966151774209885,0.) HEAD: 11.958762886597938 0.009904725021899296 0.009904725021899296 0.009904725021899296 E_HEAD : 89 89 (7.402560351952656E-20,-3.829926205364875E-9) 89 (-5.8286708792820706E-21,-3.991874374507405E-21) 89 (4.411023334500275E-22,-5.551115123125783E-22) Unsymmetrized in crystal axis ( 0.00900 -0.00206 -0.00146 ) ( -0.00206 0.01052 -0.00243 ) ( -0.00146 -0.00243 0.00920 ) Symmetrized in crystal axis ( 0.00900 -0.00206 -0.00146 ) ( -0.00206 0.01052 -0.00243 ) ( -0.00146 -0.00243 0.00920 ) Dielectric constant in cartesian axis ( 0.009574476 0.000000000 0.000000000 ) ( 0.000000000 0.009574476 0.000000000 ) ( 0.000000000 0.000000000 0.009574476 ) POLA SCA (0.000002535101341646355,0.) POLA SCA (0.0000025351013416463545,0.) POLA SCA (0.000002535101341646354,0.) HEAD: 12.164948453608247 0.00957447632906641 0.00957447632906641 0.00957447632906641 E_HEAD : 90 90 (6.213240302378281E-20,-3.752426445124163E-9) 90 (1.4849232954361472E-20,1.3516478624973745E-20) 90 (-5.026611146362239E-21,-1.9650947535865273E-20) Unsymmetrized in crystal axis ( 0.00871 -0.00200 -0.00141 ) ( -0.00200 0.01018 -0.00235 ) ( -0.00141 -0.00235 0.00890 ) Symmetrized in crystal axis ( 0.00871 -0.00200 -0.00141 ) ( -0.00200 0.01018 -0.00235 ) ( -0.00141 -0.00235 0.00890 ) Dielectric constant in cartesian axis ( 0.009260460 0.000000000 0.000000000 ) ( 0.000000000 0.009260460 0.000000000 ) ( 0.000000000 0.000000000 0.009260460 ) POLA SCA (0.000002385506969691235,0.) POLA SCA (0.0000023855069696912353,0.) POLA SCA (0.0000023855069696912353,0.) HEAD: 12.371134020618555 0.009260460330263603 0.009260460330263605 0.009260460330263606 E_HEAD : 91 91 (8.381191888943021E-20,-3.6777296171290884E-9) 91 (-2.220446049250306E-22,2.843757610451153E-20) 91 (-3.946793031123265E-21,-6.772360450213455E-21) Unsymmetrized in crystal axis ( 0.00842 -0.00193 -0.00136 ) ( -0.00193 0.00985 -0.00227 ) ( -0.00136 -0.00227 0.00861 ) Symmetrized in crystal axis ( 0.00842 -0.00193 -0.00136 ) ( -0.00193 0.00985 -0.00227 ) ( -0.00136 -0.00227 0.00861 ) Dielectric constant in cartesian axis ( 0.008961631 0.000000000 0.000000000 ) ( 0.000000000 0.008961631 0.000000000 ) ( 0.000000000 0.000000000 0.008961631 ) POLA SCA (0.0000022467913093719067,0.) POLA SCA (0.000002246791309371907,0.) POLA SCA (0.000002246791309371906,0.) HEAD: 12.577319587628866 0.0089616306249673 0.008961630624967304 0.0089616306249673 E_HEAD : 92 92 (7.091639784123533E-20,-3.6057038327981237E-9) 92 (5.1902926401226066E-21,-7.521602940781433E-21) 92 (-7.97079510062223E-21,-1.4488410471358293E-20) Unsymmetrized in crystal axis ( 0.00816 -0.00187 -0.00132 ) ( -0.00187 0.00954 -0.00220 ) ( -0.00132 -0.00220 0.00834 ) Symmetrized in crystal axis ( 0.00816 -0.00187 -0.00132 ) ( -0.00187 0.00954 -0.00220 ) ( -0.00132 -0.00220 0.00834 ) Dielectric constant in cartesian axis ( 0.008677024 0.000000000 0.000000000 ) ( 0.000000000 0.008677024 0.000000000 ) ( 0.000000000 0.000000000 0.008677024 ) POLA SCA (0.000002118018282495416,0.) POLA SCA (0.000002118018282495415,0.) POLA SCA (0.0000021180182824954185,0.) HEAD: 12.783505154639174 0.008677023794652093 0.008677023794652093 0.008677023794652093 E_HEAD : 93 93 (6.663561051778065E-20,-3.5362239788924167E-9) 93 (-4.440892098500609E-22,1.954263827993281E-21) 93 (-5.295113973196952E-21,-4.440892098500618E-22) Unsymmetrized in crystal axis ( 0.00790 -0.00181 -0.00128 ) ( -0.00181 0.00924 -0.00213 ) ( -0.00128 -0.00213 0.00808 ) Symmetrized in crystal axis ( 0.00790 -0.00181 -0.00128 ) ( -0.00181 0.00924 -0.00213 ) ( -0.00128 -0.00213 0.00808 ) Dielectric constant in cartesian axis ( 0.008405752 0.000000000 0.000000000 ) ( 0.000000000 0.008405752 0.000000000 ) ( 0.000000000 0.000000000 0.008405752 ) POLA SCA (0.0000019983445929949587,0.) POLA SCA (0.0000019983445929949583,0.) POLA SCA (0.000001998344592994958,0.) HEAD: 12.989690721649485 0.008405751627981113 0.008405751627981113 0.008405751627981113 E_HEAD : 94 94 (4.586025554748528E-20,-3.469171429852092E-9) 94 (5.551115123125785E-22,-1.3382491909352405E-20) 94 (1.0300408675173699E-20,1.5543122344752184E-21) Unsymmetrized in crystal axis ( 0.00766 -0.00175 -0.00124 ) ( -0.00175 0.00895 -0.00206 ) ( -0.00124 -0.00206 0.00783 ) Symmetrized in crystal axis ( 0.00766 -0.00175 -0.00124 ) ( -0.00175 0.00895 -0.00206 ) ( -0.00124 -0.00206 0.00783 ) Dielectric constant in cartesian axis ( 0.008146994 0.000000000 0.000000000 ) ( 0.000000000 0.008146994 0.000000000 ) ( 0.000000000 0.000000000 0.008146994 ) POLA SCA (0.0000018870093383191138,0.) POLA SCA (0.0000018870093383191136,0.) POLA SCA (0.000001887009338319113,0.) HEAD: 13.195876288659793 0.008146994182949363 0.008146994182949362 0.008146994182949362 E_HEAD : 95 95 (6.100083134454147E-20,-3.404433752205005E-9) 95 (1.8596235662471395E-21,-2.3620804135941747E-21) 95 (5.524838572915178E-21,-1.0769163338864017E-20) Unsymmetrized in crystal axis ( 0.00743 -0.00170 -0.00120 ) ( -0.00170 0.00868 -0.00200 ) ( -0.00120 -0.00200 0.00759 ) Symmetrized in crystal axis ( 0.00743 -0.00170 -0.00120 ) ( -0.00170 0.00868 -0.00200 ) ( -0.00120 -0.00200 0.00759 ) Dielectric constant in cartesian axis ( 0.007899994 0.000000000 0.000000000 ) ( 0.000000000 0.007899994 0.000000000 ) ( 0.000000000 0.000000000 0.007899994 ) POLA SCA (0.0000017833249151748016,0.) POLA SCA (0.0000017833249151748016,0.) POLA SCA (0.0000017833249151748056,0.) HEAD: 13.402061855670102 0.00789999358455278 0.00789999358455278 0.00789999358455278 E_HEAD : 96 96 (6.625062549157143E-20,-3.3419044131271226E-9) 96 (1.0713652187632764E-20,-3.8665730553178725E-22) 96 (1.6769763430532552E-21,-2.2759572004815717E-21) Unsymmetrized in crystal axis ( 0.00721 -0.00165 -0.00117 ) ( -0.00165 0.00842 -0.00194 ) ( -0.00117 -0.00194 0.00736 ) Symmetrized in crystal axis ( 0.00721 -0.00165 -0.00117 ) ( -0.00165 0.00842 -0.00194 ) ( -0.00117 -0.00194 0.00736 ) Dielectric constant in cartesian axis ( 0.007664048 0.000000000 0.000000000 ) ( 0.000000000 0.007664048 0.000000000 ) ( 0.000000000 0.000000000 0.007664048 ) POLA SCA (0.0000016866690423222213,0.) POLA SCA (0.0000016866690423222215,0.) POLA SCA (0.0000016866690423222215,0.) HEAD: 13.608247422680412 0.007664048470179143 0.007664048470179143 0.007664048470179142 E_HEAD : 97 97 (5.455171872828363E-20,-3.281482483461329E-9) 97 (-3.5804692544161326E-21,-6.126629012159757E-21) 97 (1.4036262378289817E-21,-1.931788062847773E-20) Unsymmetrized in crystal axis ( 0.00699 -0.00160 -0.00113 ) ( -0.00160 0.00818 -0.00188 ) ( -0.00113 -0.00188 0.00715 ) Symmetrized in crystal axis ( 0.00699 -0.00160 -0.00113 ) ( -0.00160 0.00818 -0.00188 ) ( -0.00113 -0.00188 0.00715 ) Dielectric constant in cartesian axis ( 0.007438509 0.000000000 0.000000000 ) ( 0.000000000 0.007438509 0.000000000 ) ( 0.000000000 0.000000000 0.007438509 ) POLA SCA (0.0000015964777495586745,0.) POLA SCA (0.0000015964777495586745,0.) POLA SCA (0.0000015964777495586745,0.) HEAD: 13.81443298969072 0.00743850900653719 0.007438509006537193 0.007438509006537193 E_HEAD : 98 98 (6.041042988118835E-20,-3.2230723551674445E-9) 98 (-5.634381849972671E-21,-7.594907686665883E-21) 98 (2.6061979559708242E-22,-5.329070518200752E-21) Unsymmetrized in crystal axis ( 0.00679 -0.00155 -0.00110 ) ( -0.00155 0.00794 -0.00183 ) ( -0.00110 -0.00183 0.00694 ) Symmetrized in crystal axis ( 0.00679 -0.00155 -0.00110 ) ( -0.00155 0.00794 -0.00183 ) ( -0.00110 -0.00183 0.00694 ) Dielectric constant in cartesian axis ( 0.007222772 0.000000000 0.000000000 ) ( 0.000000000 0.007222772 0.000000000 ) ( 0.000000000 0.000000000 0.007222772 ) POLA SCA (0.0000015122392042103562,0.) POLA SCA (0.0000015122392042103564,0.) POLA SCA (0.000001512239204210356,0.) HEAD: 14.02061855670103 0.007222772411876184 0.007222772411876188 0.007222772411876188 E_HEAD : 99 99 (5.967714105502988E-20,-3.166583458902805E-9) 99 (2.595146320061304E-21,6.396753112995074E-22) 99 (-7.96409493766055E-23,1.9428902930940242E-20) Unsymmetrized in crystal axis ( 0.00660 -0.00151 -0.00107 ) ( -0.00151 0.00771 -0.00178 ) ( -0.00107 -0.00178 0.00674 ) Symmetrized in crystal axis ( 0.00660 -0.00151 -0.00107 ) ( -0.00151 0.00771 -0.00178 ) ( -0.00107 -0.00178 0.00674 ) Dielectric constant in cartesian axis ( 0.007016279 0.000000000 0.000000000 ) ( 0.000000000 0.007016279 0.000000000 ) ( 0.000000000 0.000000000 0.007016279 ) POLA SCA (0.0000014334882651118037,0.) POLA SCA (0.0000014334882651118035,0.) POLA SCA (0.0000014334882651118033,0.) HEAD: 14.22680412371134 0.007016278925764963 0.0070162789257649655 0.007016278925764965 E_HEAD : 100 100 (5.4008086791609684E-20,-3.1119299970265306E-9) 100 (-1.5681900222830341E-21,5.902926287300916E-21) 100 (-1.5293494191309164E-21,-1.1934897514720433E-20) Unsymmetrized in crystal axis ( 0.00641 -0.00147 -0.00104 ) ( -0.00147 0.00749 -0.00172 ) ( -0.00104 -0.00172 0.00655 ) Symmetrized in crystal axis ( 0.00641 -0.00147 -0.00104 ) ( -0.00147 0.00749 -0.00172 ) ( -0.00104 -0.00172 0.00655 ) Dielectric constant in cartesian axis ( 0.006818508 0.000000000 0.000000000 ) ( 0.000000000 0.006818508 0.000000000 ) ( 0.000000000 0.000000000 0.006818508 ) POLA SCA (0.0000013598016697906044,0.) POLA SCA (0.0000013598016697906041,0.) POLA SCA (0.000001359801669790605,0.) HEAD: 14.432989690721648 0.006818508176016214 0.00681850817601621 0.006818508176016213 E_HEAD : 101 101 (6.287900066947568E-20,-3.059030682321773E-9) 101 (-3.913536161803677E-21,-5.199657330508332E-22) 101 (1.9257509122785783E-21,4.829470157119432E-21) Unsymmetrized in crystal axis ( 0.00623 -0.00143 -0.00101 ) ( -0.00143 0.00729 -0.00168 ) ( -0.00101 -0.00168 0.00637 ) Symmetrized in crystal axis ( 0.00623 -0.00143 -0.00101 ) ( -0.00143 0.00729 -0.00168 ) ( -0.00101 -0.00168 0.00637 ) Dielectric constant in cartesian axis ( 0.006628976 0.000000000 0.000000000 ) ( 0.000000000 0.006628976 0.000000000 ) ( 0.000000000 0.000000000 0.006628976 ) POLA SCA (0.0000012907937738821608,0.) POLA SCA (0.0000012907937738821613,0.) POLA SCA (0.000001290793773882162,0.) HEAD: 14.639175257731958 0.006628975898643058 0.006628975898643059 0.006628975898643059 E_HEAD : 102 102 (5.932227599987749E-20,-3.007808491656411E-9) 102 (-1.165734175856415E-21,-1.551526131353463E-21) 102 (8.617170574883417E-21,1.6098233857064764E-21) Unsymmetrized in crystal axis ( 0.00606 -0.00139 -0.00098 ) ( -0.00139 0.00709 -0.00163 ) ( -0.00098 -0.00163 0.00619 ) Symmetrized in crystal axis ( 0.00606 -0.00139 -0.00098 ) ( -0.00139 0.00709 -0.00163 ) ( -0.00098 -0.00163 0.00619 ) Dielectric constant in cartesian axis ( 0.006447231 0.000000000 0.000000000 ) ( 0.000000000 0.006447231 0.000000000 ) ( 0.000000000 0.000000000 0.006447231 ) POLA SCA (0.000001226112773077091,0.) POLA SCA (0.000001226112773077091,0.) POLA SCA (0.000001226112773077092,0.) HEAD: 14.845360824742267 0.006447230972172278 0.006447230972172274 0.006447230972172276 E_HEAD : 103 103 (5.997712937854309E-20,-2.9581904275285954E-9) 103 (1.0963452368173421E-20,8.074143046354606E-21) 103 (-8.635600158931098E-22,-1.0824674490095276E-20) Unsymmetrized in crystal axis ( 0.00590 -0.00135 -0.00095 ) ( -0.00135 0.00689 -0.00159 ) ( -0.00095 -0.00159 0.00603 ) Symmetrized in crystal axis ( 0.00590 -0.00135 -0.00095 ) ( -0.00135 0.00689 -0.00159 ) ( -0.00095 -0.00159 0.00603 ) Dielectric constant in cartesian axis ( 0.006272853 0.000000000 0.000000000 ) ( 0.000000000 0.006272853 0.000000000 ) ( 0.000000000 0.000000000 0.006272853 ) POLA SCA (0.0000011654373474856683,0.) POLA SCA (0.0000011654373474856683,0.) POLA SCA (0.000001165437347485666,0.) HEAD: 15.051546391752577 0.006272852732341687 0.006272852732341686 0.006272852732341685 E_HEAD : 104 104 (5.101573539805312E-20,-2.9101072939919374E-9) 104 (-9.783840404509194E-21,-2.082890413245277E-21) 104 (6.061050133196553E-21,7.049916206369744E-21) Unsymmetrized in crystal axis ( 0.00574 -0.00131 -0.00093 ) ( -0.00131 0.00671 -0.00154 ) ( -0.00093 -0.00154 0.00587 ) Symmetrized in crystal axis ( 0.00574 -0.00131 -0.00093 ) ( -0.00131 0.00671 -0.00154 ) ( -0.00093 -0.00154 0.00587 ) Dielectric constant in cartesian axis ( 0.006105449 0.000000000 0.000000000 ) ( 0.000000000 0.006105449 0.000000000 ) ( 0.000000000 0.000000000 0.006105449 ) POLA SCA (0.0000011084736764617743,0.) POLA SCA (0.0000011084736764617745,0.) POLA SCA (0.0000011084736764617738,0.) HEAD: 15.257731958762886 0.006105448537285163 0.006105448537285167 0.006105448537285165 E_HEAD : 105 105 (4.9453853633387646E-20,-2.8634934816318406E-9) 105 (-9.714451465470061E-23,-8.836993822669384E-21) 105 (1.4718611937390933E-20,-7.716050021144837E-21) Unsymmetrized in crystal axis ( 0.00559 -0.00128 -0.00090 ) ( -0.00128 0.00653 -0.00150 ) ( -0.00090 -0.00150 0.00571 ) Symmetrized in crystal axis ( 0.00559 -0.00128 -0.00090 ) ( -0.00128 0.00653 -0.00150 ) ( -0.00090 -0.00150 0.00571 ) Dielectric constant in cartesian axis ( 0.005944652 0.000000000 0.000000000 ) ( 0.000000000 0.005944652 0.000000000 ) ( 0.000000000 0.000000000 0.005944652 ) POLA SCA (0.0000010549527788911209,0.) POLA SCA (0.000001054952778891121,0.) POLA SCA (0.0000010549527788911209,0.) HEAD: 15.463917525773194 0.005944651556848248 0.005944651556848248 0.005944651556848248 E_HEAD : 106 106 (5.568651857260327E-20,-2.8182867654172607E-9) 106 (8.187894806610533E-22,1.3145223422447695E-21) 106 (-8.37323501224153E-21,-6.050715484207104E-21) Unsymmetrized in crystal axis ( 0.00544 -0.00124 -0.00088 ) ( -0.00124 0.00636 -0.00146 ) ( -0.00088 -0.00146 0.00556 ) Symmetrized in crystal axis ( 0.00544 -0.00124 -0.00088 ) ( -0.00124 0.00636 -0.00146 ) ( -0.00088 -0.00146 0.00556 ) Dielectric constant in cartesian axis ( 0.005790119 0.000000000 0.000000000 ) ( 0.000000000 0.005790119 0.000000000 ) ( 0.000000000 0.000000000 0.005790119 ) POLA SCA (0.000001004628139902603,0.) POLA SCA (0.000001004628139902603,0.) POLA SCA (0.0000010046281399026038,0.) HEAD: 15.670103092783505 0.005790118762757381 0.005790118762757383 0.005790118762757383 E_HEAD : 107 107 (5.362779974437043E-20,-2.7744281129701843E-9) 107 (3.663735981263017E-21,5.480543051112963E-21) 107 (-4.305094585256735E-21,6.883382752675971E-21) Unsymmetrized in crystal axis ( 0.00530 -0.00121 -0.00086 ) ( -0.00121 0.00620 -0.00143 ) ( -0.00086 -0.00143 0.00542 ) Symmetrized in crystal axis ( 0.00530 -0.00121 -0.00086 ) ( -0.00121 0.00620 -0.00143 ) ( -0.00086 -0.00143 0.00542 ) Dielectric constant in cartesian axis ( 0.005641529 0.000000000 0.000000000 ) ( 0.000000000 0.005641529 0.000000000 ) ( 0.000000000 0.000000000 0.005641529 ) POLA SCA (9.572735900642939E-7,0.) POLA SCA (9.572735900642937E-7,0.) POLA SCA (9.572735900642926E-7,0.) HEAD: 15.876288659793813 0.005641529099051065 0.005641529099051066 0.005641529099051065 E_HEAD : 108 108 (4.901880503325258E-20,-2.7318615037143782E-9) 108 (3.635980405647387E-21,-1.0597424417723114E-20) 108 (4.191903190234978E-21,9.825473767932636E-21) Unsymmetrized in crystal axis ( 0.00517 -0.00118 -0.00083 ) ( -0.00118 0.00604 -0.00139 ) ( -0.00083 -0.00139 0.00528 ) Symmetrized in crystal axis ( 0.00517 -0.00118 -0.00083 ) ( -0.00118 0.00604 -0.00139 ) ( -0.00083 -0.00139 0.00528 ) Dielectric constant in cartesian axis ( 0.005498582 0.000000000 0.000000000 ) ( 0.000000000 0.005498582 0.000000000 ) ( 0.000000000 0.000000000 0.005498582 ) POLA SCA (9.126814075075573E-7,0.) POLA SCA (9.126814075075573E-7,0.) POLA SCA (9.126814075075586E-7,0.) HEAD: 16.082474226804123 0.00549858181452625 0.005498581814526248 0.00549858181452625 E_HEAD : 109 109 (3.890543475069658E-20,-2.690533756612268E-9) 109 (6.272760089132134E-21,-8.789538470927216E-22) 109 (1.8003751468339158E-21,-1.412758798835512E-20) Unsymmetrized in crystal axis ( 0.00504 -0.00115 -0.00081 ) ( -0.00115 0.00589 -0.00135 ) ( -0.00081 -0.00135 0.00515 ) Symmetrized in crystal axis ( 0.00504 -0.00115 -0.00081 ) ( -0.00115 0.00589 -0.00135 ) ( -0.00081 -0.00135 0.00515 ) Dielectric constant in cartesian axis ( 0.005360995 0.000000000 0.000000000 ) ( 0.000000000 0.005360995 0.000000000 ) ( 0.000000000 0.000000000 0.005360995 ) POLA SCA (8.706606171931673E-7,0.) POLA SCA (8.706606171931673E-7,0.) POLA SCA (8.706606171931668E-7,0.) HEAD: 16.288659793814432 0.0053609949410058436 0.005360994941005844 0.0053609949410058436 E_HEAD : 110 110 (4.358959579036162E-20,-2.650394370313697E-9) 110 (-1.137978600240786E-21,-8.595986479395934E-21) 110 (-3.616086222224565E-21,2.5257573810222323E-21) Unsymmetrized in crystal axis ( 0.00492 -0.00112 -0.00079 ) ( -0.00112 0.00575 -0.00132 ) ( -0.00079 -0.00132 0.00502 ) Symmetrized in crystal axis ( 0.00492 -0.00112 -0.00079 ) ( -0.00112 0.00575 -0.00132 ) ( -0.00079 -0.00132 0.00502 ) Dielectric constant in cartesian axis ( 0.005228504 0.000000000 0.000000000 ) ( 0.000000000 0.005228504 0.000000000 ) ( 0.000000000 0.000000000 0.005228504 ) POLA SCA (8.310354647837791E-7,0.) POLA SCA (8.310354647837791E-7,0.) POLA SCA (8.310354647837791E-7,0.) HEAD: 16.49484536082474 0.005228503903031676 0.005228503903031677 0.005228503903031677 E_HEAD : 111 111 (4.224032959866764E-20,-2.6113953718073513E-9) 111 (-8.229528170033974E-21,2.1640037441122267E-21) 111 (3.7439931603436394E-21,-5.440092820663267E-21) Unsymmetrized in crystal axis ( 0.00480 -0.00110 -0.00077 ) ( -0.00110 0.00561 -0.00129 ) ( -0.00077 -0.00129 0.00490 ) Symmetrized in crystal axis ( 0.00480 -0.00110 -0.00077 ) ( -0.00110 0.00561 -0.00129 ) ( -0.00077 -0.00129 0.00490 ) Dielectric constant in cartesian axis ( 0.005100860 0.000000000 0.000000000 ) ( 0.000000000 0.005100860 0.000000000 ) ( 0.000000000 0.000000000 0.005100860 ) POLA SCA (7.936440453948814E-7,0.) POLA SCA (7.936440453948814E-7,0.) POLA SCA (7.936440453948814E-7,0.) HEAD: 16.70103092783505 0.0051008602461670785 0.0051008602461670785 0.005100860246167078 E_HEAD : 112 112 (4.399028200727654E-20,-2.5734911719906552E-9) 112 (2.373101715136272E-21,-9.854732032936252E-21) 112 (-2.7485557393912006E-22,-4.996003610813195E-22) Unsymmetrized in crystal axis ( 0.00468 -0.00107 -0.00075 ) ( -0.00107 0.00547 -0.00126 ) ( -0.00075 -0.00126 0.00478 ) Symmetrized in crystal axis ( 0.00468 -0.00107 -0.00075 ) ( -0.00107 0.00547 -0.00126 ) ( -0.00075 -0.00126 0.00478 ) Dielectric constant in cartesian axis ( 0.004977830 0.000000000 0.000000000 ) ( 0.000000000 0.004977830 0.000000000 ) ( 0.000000000 0.000000000 0.004977830 ) POLA SCA (7.583370699255594E-7,0.) POLA SCA (7.583370699255595E-7,0.) POLA SCA (7.583370699255594E-7,0.) HEAD: 16.90721649484536 0.0049778304724823145 0.0049778304724823145 0.0049778304724823145 E_HEAD : 113 113 (3.3725124407677753E-20,-2.5366384318686046E-9) 113 (7.466249840604179E-21,-8.173214468320081E-21) 113 (3.407380281871311E-21,1.2490009027033016E-21) Unsymmetrized in crystal axis ( 0.00457 -0.00104 -0.00074 ) ( -0.00104 0.00534 -0.00123 ) ( -0.00074 -0.00123 0.00467 ) Symmetrized in crystal axis ( 0.00457 -0.00104 -0.00074 ) ( -0.00104 0.00534 -0.00123 ) ( -0.00074 -0.00123 0.00467 ) Dielectric constant in cartesian axis ( 0.004859195 0.000000000 0.000000000 ) ( 0.000000000 0.004859195 0.000000000 ) ( 0.000000000 0.000000000 0.004859195 ) POLA SCA (7.249767537765959E-7,0.) POLA SCA (7.249767537765959E-7,0.) POLA SCA (7.24976753776596E-7,0.) HEAD: 17.11340206185567 0.004859194973020039 0.00485919497302004 0.004859194973020039 E_HEAD : 114 114 (3.080655296517964E-20,-2.5007959364050925E-9) 114 (6.661338147750943E-22,-7.254597310855442E-21) 114 (3.620031873746443E-21,-7.521760991835435E-21) Unsymmetrized in crystal axis ( 0.00446 -0.00102 -0.00072 ) ( -0.00102 0.00521 -0.00120 ) ( -0.00072 -0.00120 0.00456 ) Symmetrized in crystal axis ( 0.00446 -0.00102 -0.00072 ) ( -0.00102 0.00521 -0.00120 ) ( -0.00072 -0.00120 0.00456 ) Dielectric constant in cartesian axis ( 0.004744747 0.000000000 0.000000000 ) ( 0.000000000 0.004744747 0.000000000 ) ( 0.000000000 0.000000000 0.004744747 ) POLA SCA (6.934358145920886E-7,0.) POLA SCA (6.934358145920886E-7,0.) POLA SCA (6.934358145920888E-7,0.) HEAD: 17.31958762886598 0.004744747048117898 0.004744747048117898 0.004744747048117898 E_HEAD : 115 115 (3.764663211684558E-20,-2.465924475108211E-9) 115 (-2.4286128663675307E-21,-4.619563838731019E-21) 115 (-5.52674108832405E-21,4.1633363423443456E-22) Unsymmetrized in crystal axis ( 0.00436 -0.00099 -0.00070 ) ( -0.00099 0.00509 -0.00117 ) ( -0.00070 -0.00117 0.00445 ) Symmetrized in crystal axis ( 0.00436 -0.00099 -0.00070 ) ( -0.00099 0.00509 -0.00117 ) ( -0.00070 -0.00117 0.00445 ) Dielectric constant in cartesian axis ( 0.004634292 0.000000000 0.000000000 ) ( 0.000000000 0.004634292 0.000000000 ) ( 0.000000000 0.000000000 0.004634292 ) POLA SCA (6.63596567251512E-7,0.) POLA SCA (6.635965672515121E-7,0.) POLA SCA (6.635965672515118E-7,0.) HEAD: 17.525773195876287 0.004634292007419732 0.004634292007419732 0.004634292007419732 E_HEAD : 116 116 (4.571227681319332E-20,-2.4319867300468256E-9) 116 (-2.775557561562929E-23,-3.880056099302487E-22) 116 (-1.1947796767715932E-21,1.1102230246251553E-21) Unsymmetrized in crystal axis ( 0.00426 -0.00097 -0.00069 ) ( -0.00097 0.00497 -0.00114 ) ( -0.00069 -0.00114 0.00435 ) Symmetrized in crystal axis ( 0.00426 -0.00097 -0.00069 ) ( -0.00097 0.00497 -0.00114 ) ( -0.00069 -0.00114 0.00435 ) Dielectric constant in cartesian axis ( 0.004527646 0.000000000 0.000000000 ) ( 0.000000000 0.004527646 0.000000000 ) ( 0.000000000 0.000000000 0.004527646 ) POLA SCA (6.353501057251958E-7,0.) POLA SCA (6.353501057251959E-7,0.) POLA SCA (6.353501057251958E-7,0.) HEAD: 17.731958762886595 0.004527646342251618 0.004527646342251618 0.0045276463422516166 E_HEAD : 117 117 (3.413598076083914E-20,-2.3989471723984415E-9) 117 (-6.93889390390723E-22,-1.3457566821747718E-20) 117 (2.2428175128762793E-21,1.02695629777827E-21) Unsymmetrized in crystal axis ( 0.00416 -0.00095 -0.00067 ) ( -0.00095 0.00486 -0.00112 ) ( -0.00067 -0.00112 0.00425 ) Symmetrized in crystal axis ( 0.00416 -0.00095 -0.00067 ) ( -0.00095 0.00486 -0.00112 ) ( -0.00067 -0.00112 0.00425 ) Dielectric constant in cartesian axis ( 0.004424637 0.000000000 0.000000000 ) ( 0.000000000 0.004424637 0.000000000 ) ( 0.000000000 0.000000000 0.004424637 ) POLA SCA (6.085955626156326E-7,0.) POLA SCA (6.085955626156326E-7,0.) POLA SCA (6.085955626156328E-7,0.) HEAD: 17.938144329896907 0.004424636963787574 0.004424636963787576 0.004424636963787574 E_HEAD : 118 118 (2.6499711877727393E-20,-2.366771960326281E-9) 118 (4.413136522884998E-21,-3.826909744945955E-21) 118 (6.149095237596697E-22,7.244205235679148E-21) Unsymmetrized in crystal axis ( 0.00407 -0.00093 -0.00066 ) ( -0.00093 0.00475 -0.00109 ) ( -0.00066 -0.00109 0.00416 ) Symmetrized in crystal axis ( 0.00407 -0.00093 -0.00066 ) ( -0.00093 0.00475 -0.00109 ) ( -0.00066 -0.00109 0.00416 ) Dielectric constant in cartesian axis ( 0.004325101 0.000000000 0.000000000 ) ( 0.000000000 0.004325101 0.000000000 ) ( 0.000000000 0.000000000 0.004325101 ) POLA SCA (5.832394382642453E-7,0.) POLA SCA (5.832394382642453E-7,0.) POLA SCA (5.832394382642454E-7,0.) HEAD: 18.144329896907216 0.004325100501094628 0.004325100501094628 0.004325100501094627 E_HEAD : 119 119 (3.9156594323051717E-20,-2.3354288492600515E-9) 119 (-3.955169525227121E-21,-1.1925586968268882E-21) 119 (4.382072013060919E-22,-1.9984014443252826E-21) Unsymmetrized in crystal axis ( 0.00398 -0.00091 -0.00064 ) ( -0.00091 0.00465 -0.00107 ) ( -0.00064 -0.00107 0.00406 ) Symmetrized in crystal axis ( 0.00398 -0.00091 -0.00064 ) ( -0.00091 0.00465 -0.00107 ) ( -0.00064 -0.00107 0.00406 ) Dielectric constant in cartesian axis ( 0.004228883 0.000000000 0.000000000 ) ( 0.000000000 0.004228883 0.000000000 ) ( 0.000000000 0.000000000 0.004228883 ) POLA SCA (5.591949922287887E-7,0.) POLA SCA (5.591949922287888E-7,0.) POLA SCA (5.591949922287892E-7,0.) HEAD: 18.350515463917525 0.004228882653737466 0.004228882653737464 0.004228882653737464 E_HEAD : 120 120 (4.010784522160338E-20,-2.304887102599601E-9) 120 (-4.10782519111308E-21,-8.030017096577964E-21) 120 (-4.976260662476136E-21,-1.387778780781442E-22) Unsymmetrized in crystal axis ( 0.00389 -0.00089 -0.00063 ) ( -0.00089 0.00454 -0.00104 ) ( -0.00063 -0.00104 0.00397 ) Symmetrized in crystal axis ( 0.00389 -0.00089 -0.00063 ) ( -0.00089 0.00454 -0.00104 ) ( -0.00063 -0.00104 0.00397 ) Dielectric constant in cartesian axis ( 0.004135838 0.000000000 0.000000000 ) ( 0.000000000 0.004135838 0.000000000 ) ( 0.000000000 0.000000000 0.004135838 ) POLA SCA (5.363816907478633E-7,0.) POLA SCA (5.363816907478635E-7,0.) POLA SCA (5.363816907478631E-7,0.) HEAD: 18.556701030927833 0.004135837594149036 0.004135837594149038 0.004135837594149036 E_HEAD : 121 121 (3.438050335455117E-20,-2.275117410431793E-9) 121 (4.524158825347512E-21,3.953344301574685E-21) 121 (-2.0450717156393526E-21,8.298917109073047E-21) Unsymmetrized in crystal axis ( 0.00380 -0.00087 -0.00061 ) ( -0.00087 0.00445 -0.00102 ) ( -0.00061 -0.00102 0.00389 ) Symmetrized in crystal axis ( 0.00380 -0.00087 -0.00061 ) ( -0.00087 0.00445 -0.00102 ) ( -0.00061 -0.00102 0.00389 ) Dielectric constant in cartesian axis ( 0.004045827 0.000000000 0.000000000 ) ( 0.000000000 0.004045827 0.000000000 ) ( 0.000000000 0.000000000 0.004045827 ) POLA SCA (5.147247045214901E-7,0.) POLA SCA (5.147247045214902E-7,0.) POLA SCA (5.1472470452149E-7,0.) HEAD: 18.76288659793814 0.004045827415442066 0.004045827415442065 0.004045827415442066 E_HEAD : 122 122 (3.490346977076712E-20,-2.2460918124969643E-9) 122 (-7.771561172376094E-22,-8.669762718229539E-21) 122 (1.0237683569323803E-21,2.1926904736346844E-21) Unsymmetrized in crystal axis ( 0.00372 -0.00085 -0.00060 ) ( -0.00085 0.00435 -0.00100 ) ( -0.00060 -0.00100 0.00380 ) Symmetrized in crystal axis ( 0.00372 -0.00085 -0.00060 ) ( -0.00085 0.00435 -0.00100 ) ( -0.00060 -0.00100 0.00380 ) Dielectric constant in cartesian axis ( 0.003958722 0.000000000 0.000000000 ) ( 0.000000000 0.003958722 0.000000000 ) ( 0.000000000 0.000000000 0.003958722 ) POLA SCA (4.941544517630952E-7,0.) POLA SCA (4.941544517630951E-7,0.) POLA SCA (4.941544517630967E-7,0.) HEAD: 18.969072164948454 0.003958721620754822 0.003958721620754822 0.003958721620754822 E_HEAD : 123 123 (3.25635981210598E-20,-2.2177836251822685E-9) 123 (-1.2212453270876724E-21,-1.6039114795464462E-21) 123 (-4.013190818892897E-21,-5.3013149425851234E-21) Unsymmetrized in crystal axis ( 0.00364 -0.00083 -0.00059 ) ( -0.00083 0.00426 -0.00098 ) ( -0.00059 -0.00098 0.00372 ) Symmetrized in crystal axis ( 0.00364 -0.00083 -0.00059 ) ( -0.00083 0.00426 -0.00098 ) ( -0.00059 -0.00098 0.00372 ) Dielectric constant in cartesian axis ( 0.003874397 0.000000000 0.000000000 ) ( 0.000000000 0.003874397 0.000000000 ) ( 0.000000000 0.000000000 0.003874397 ) POLA SCA (4.746061820297766E-7,0.) POLA SCA (4.7460618202977655E-7,0.) POLA SCA (4.7460618202977713E-7,0.) HEAD: 19.175257731958762 0.0038743966505984735 0.003874396650598472 0.003874396650598472 E_HEAD : 124 124 (2.930931424398079E-20,-2.1901673726141548E-9) 124 (-2.622901895676933E-21,6.78571411653282E-21) 124 (-4.156913450323986E-21,-2.498001805406604E-22) Unsymmetrized in crystal axis ( 0.00357 -0.00081 -0.00057 ) ( -0.00081 0.00417 -0.00096 ) ( -0.00057 -0.00096 0.00364 ) Symmetrized in crystal axis ( 0.00357 -0.00081 -0.00057 ) ( -0.00081 0.00417 -0.00096 ) ( -0.00057 -0.00096 0.00364 ) Dielectric constant in cartesian axis ( 0.003792735 0.000000000 0.000000000 ) ( 0.000000000 0.003792735 0.000000000 ) ( 0.000000000 0.000000000 0.003792735 ) POLA SCA (4.56019596824055E-7,0.) POLA SCA (4.56019596824055E-7,0.) POLA SCA (4.5601959682405484E-7,0.) HEAD: 19.38144329896907 0.003792735445007686 0.0037927354450076854 0.0037927354450076854 E_HEAD : 125 125 (3.119522741479397E-20,-2.163218724215821E-9) 125 (5.2735593669694946E-21,1.31051465217695E-21) 125 (3.1297205656556354E-21,1.4988010832439616E-21) Unsymmetrized in crystal axis ( 0.00349 -0.00080 -0.00056 ) ( -0.00080 0.00408 -0.00094 ) ( -0.00056 -0.00094 0.00357 ) Symmetrized in crystal axis ( 0.00349 -0.00080 -0.00056 ) ( -0.00080 0.00408 -0.00094 ) ( -0.00056 -0.00094 0.00357 ) Dielectric constant in cartesian axis ( 0.003713627 0.000000000 0.000000000 ) ( 0.000000000 0.003713627 0.000000000 ) ( 0.000000000 0.000000000 0.003713627 ) POLA SCA (4.383385033897236E-7,0.) POLA SCA (4.383385033897236E-7,0.) POLA SCA (4.3833850338972316E-7,0.) HEAD: 19.58762886597938 0.003713627037596028 0.003713627037596029 0.003713627037596028 E_HEAD : 126 126 (2.896973974191803E-20,-2.136914432809112E-9) 126 (-4.267419750902945E-21,-2.3018409854850006E-21) 126 (-4.472449766788463E-21,6.2172489379008765E-21) Unsymmetrized in crystal axis ( 0.00342 -0.00078 -0.00055 ) ( -0.00078 0.00400 -0.00092 ) ( -0.00055 -0.00092 0.00349 ) Symmetrized in crystal axis ( 0.00342 -0.00078 -0.00055 ) ( -0.00078 0.00400 -0.00092 ) ( -0.00055 -0.00092 0.00349 ) Dielectric constant in cartesian axis ( 0.003636966 0.000000000 0.000000000 ) ( 0.000000000 0.003636966 0.000000000 ) ( 0.000000000 0.000000000 0.003636966 ) POLA SCA (4.215104985039024E-7,0.) POLA SCA (4.2151049850390236E-7,0.) POLA SCA (4.215104985039022E-7,0.) HEAD: 19.79381443298969 0.0036369661788863764 0.003636966178886375 0.0036369661788863746 E_HEAD : 127 127 (2.808798925743839E-20,-2.1112322785711846E-9) 127 (-3.566591466608316E-21,2.385961117878581E-21) 127 (3.5137557086456296E-21,-4.912736883966318E-21) Unsymmetrized in crystal axis ( 0.00335 -0.00076 -0.00054 ) ( -0.00076 0.00391 -0.00090 ) ( -0.00054 -0.00090 0.00342 ) Symmetrized in crystal axis ( 0.00335 -0.00076 -0.00054 ) ( -0.00076 0.00391 -0.00090 ) ( -0.00054 -0.00090 0.00342 ) Dielectric constant in cartesian axis ( 0.003562653 0.000000000 0.000000000 ) ( 0.000000000 0.003562653 0.000000000 ) ( 0.000000000 0.000000000 0.003562653 ) POLA SCA (4.0548667940349075E-7,0.) POLA SCA (4.0548667940349075E-7,0.) POLA SCA (4.0548667940349075E-7,0.) HEAD: 20. 0.003562652986528027 0.003562652986528026 0.003562652986528025 E_HEAD : 128 128 (3.194092097306624E-20,-2.0861510144515043E-9) 128 (-4.163336342344324E-23,-3.2610768469290564E-22) 128 (4.349332204416071E-21,-9.409140133698202E-21) ATT01 ATT02 ATT1 ATT2 PHONON : 0m57.70s CPU 1m 5.39s WALL INITIALIZATION: phq_setup : 0.00s CPU 0.00s WALL ( 1 calls) phq_init : 0.09s CPU 0.09s WALL ( 1 calls) phq_init : 0.09s CPU 0.09s WALL ( 1 calls) init_vloc : 0.00s CPU 0.00s WALL ( 1 calls) init_us_1 : 0.01s CPU 0.01s WALL ( 1 calls) ortho : 0.01s CPU 0.01s WALL ( 12 calls) cgsolve : 4.85s CPU 5.77s WALL ( 12 calls) cgsolve : 4.85s CPU 5.77s WALL ( 12 calls) ch_psi : 4.68s CPU 5.57s WALL ( 293 calls) ch_psi : 4.68s CPU 5.57s WALL ( 293 calls) h_psiq : 10.42s CPU 13.43s WALL ( 653 calls) last : 0.50s CPU 0.59s WALL ( 293 calls) h_psiq : 10.42s CPU 13.43s WALL ( 653 calls) firstfft : 4.48s CPU 5.50s WALL ( 9733 calls) secondfft : 3.95s CPU 5.53s WALL ( 9733 calls) add_vuspsi : 0.44s CPU 0.47s WALL ( 653 calls) General routines calbec : 0.72s CPU 1.00s WALL ( 1010 calls) fft : 0.31s CPU 0.57s WALL ( 387 calls) fftw : 18.09s CPU 22.05s WALL ( 44106 calls) davcio : 0.03s CPU 0.03s WALL ( 44 calls) GWW/examples/example02/reference/si_gww.out0000644000077300007730000033754712341332532021434 0ustar giannozzgiannozz MPI PARALLEL VERSION PROGRAM GWL: Version 0.91 Number of procs: 2 PROGRAM GWL: Version 0.91 Number of intervals: 97 Number of intervals for fit: 120 Maximum imaginary time: 9.8 Print whole Sigma: F Maximum state considered: 32 Prefix:si Rows together in FFT: 50 Accurate treatment of conduction states Uses contractions on single states Uses no fft grid for time/space integrations Time grid : 3 Frequency grid : 5 Max frequency : 20. Consider states from: 1 to 32 Maximum number of iterations in minpack: 20000 Number of cycles over minpack: 1 Uses LDA Hartree : T Uses LDA Exchange : T Uses SYMMETRIZED DIELECTRIC MATRIX Head of dielectric matrix from file Treatment of W divergence: 0 Wings of dielectric matrix from file Offset fit : 2 Read vcprim terms from file Calculates the polarization directly from the overlaps Polarization Calculated through Lanczos scheme Self-energy Calculated through Lanczos scheme Convolution done analytically Block length fequency 100 Block length states 5 Block length valence states 16 Block length fequency lc 1 Reduced disk I/O Uses double grid, subdivisions: 10 till : 1 t vectors from Wannier products Use truncated Extended interaction Calculate Self-energy through FT Spin multiplicity: 1 Partiallly occpuied states: F min -127 0 1 128 max 0 0 128 128 min pola 0 max pola 63 min state 1 max state 16 min state range 1 max state range 16 DB1 97 DB2 DB3 N: 127 127 Omega: 20. 20. freq: -127 -20. -20. weight: -127 0.20618556701030927 0.20618556701030927 freq: -126 -19.79381443298969 -19.79381443298969 weight: -126 0.20618556701030927 0.20618556701030927 freq: -125 -19.58762886597938 -19.58762886597938 weight: -125 0.20618556701030927 0.20618556701030927 freq: -124 -19.38144329896907 -19.38144329896907 weight: -124 0.20618556701030927 0.20618556701030927 freq: -123 -19.175257731958762 -19.175257731958762 weight: -123 0.20618556701030927 0.20618556701030927 freq: -122 -18.969072164948454 -18.969072164948454 weight: -122 0.20618556701030927 0.20618556701030927 freq: -121 -18.76288659793814 -18.76288659793814 weight: -121 0.20618556701030927 0.20618556701030927 freq: -120 -18.556701030927833 -18.556701030927833 weight: -120 0.20618556701030927 0.20618556701030927 freq: -119 -18.350515463917525 -18.350515463917525 weight: -119 0.20618556701030927 0.20618556701030927 freq: -118 -18.144329896907216 -18.144329896907216 weight: -118 0.20618556701030927 0.20618556701030927 freq: -117 -17.938144329896907 -17.938144329896907 weight: -117 0.20618556701030927 0.20618556701030927 freq: -116 -17.731958762886595 -17.731958762886595 weight: -116 0.20618556701030927 0.20618556701030927 freq: -115 -17.525773195876287 -17.525773195876287 weight: -115 0.20618556701030927 0.20618556701030927 freq: -114 -17.31958762886598 -17.31958762886598 weight: -114 0.20618556701030927 0.20618556701030927 freq: -113 -17.11340206185567 -17.11340206185567 weight: -113 0.20618556701030927 0.20618556701030927 freq: -112 -16.90721649484536 -16.90721649484536 weight: -112 0.20618556701030927 0.20618556701030927 freq: -111 -16.70103092783505 -16.70103092783505 weight: -111 0.20618556701030927 0.20618556701030927 freq: -110 -16.49484536082474 -16.49484536082474 weight: -110 0.20618556701030927 0.20618556701030927 freq: -109 -16.288659793814432 -16.288659793814432 weight: -109 0.20618556701030927 0.20618556701030927 freq: -108 -16.082474226804123 -16.082474226804123 weight: -108 0.20618556701030927 0.20618556701030927 freq: -107 -15.876288659793813 -15.876288659793813 weight: -107 0.20618556701030927 0.20618556701030927 freq: -106 -15.670103092783505 -15.670103092783505 weight: -106 0.20618556701030927 0.20618556701030927 freq: -105 -15.463917525773194 -15.463917525773194 weight: -105 0.20618556701030927 0.20618556701030927 freq: -104 -15.257731958762886 -15.257731958762886 weight: -104 0.20618556701030927 0.20618556701030927 freq: -103 -15.051546391752577 -15.051546391752577 weight: -103 0.20618556701030927 0.20618556701030927 freq: -102 -14.845360824742267 -14.845360824742267 weight: -102 0.20618556701030927 0.20618556701030927 freq: -101 -14.639175257731958 -14.639175257731958 weight: -101 0.20618556701030927 0.20618556701030927 freq: -100 -14.432989690721648 -14.432989690721648 weight: -100 0.20618556701030927 0.20618556701030927 freq: -99 -14.22680412371134 -14.22680412371134 weight: -99 0.20618556701030927 0.20618556701030927 freq: -98 -14.02061855670103 -14.02061855670103 weight: -98 0.20618556701030927 0.20618556701030927 freq: -97 -13.81443298969072 -13.81443298969072 weight: -97 0.20618556701030927 0.20618556701030927 freq: -96 -13.608247422680412 -13.608247422680412 weight: -96 0.20618556701030927 0.20618556701030927 freq: -95 -13.402061855670102 -13.402061855670102 weight: -95 0.20618556701030927 0.20618556701030927 freq: -94 -13.195876288659793 -13.195876288659793 weight: -94 0.20618556701030927 0.20618556701030927 freq: -93 -12.989690721649485 -12.989690721649485 weight: -93 0.20618556701030927 0.20618556701030927 freq: -92 -12.783505154639174 -12.783505154639174 weight: -92 0.20618556701030927 0.20618556701030927 freq: -91 -12.577319587628866 -12.577319587628866 weight: -91 0.20618556701030927 0.20618556701030927 freq: -90 -12.371134020618555 -12.371134020618555 weight: -90 0.20618556701030927 0.20618556701030927 freq: -89 -12.164948453608247 -12.164948453608247 weight: -89 0.20618556701030927 0.20618556701030927 freq: -88 -11.958762886597938 -11.958762886597938 weight: -88 0.20618556701030927 0.20618556701030927 freq: -87 -11.752577319587628 -11.752577319587628 weight: -87 0.20618556701030927 0.20618556701030927 freq: -86 -11.54639175257732 -11.54639175257732 weight: -86 0.20618556701030927 0.20618556701030927 freq: -85 -11.340206185567009 -11.340206185567009 weight: -85 0.20618556701030927 0.20618556701030927 freq: -84 -11.1340206185567 -11.1340206185567 weight: -84 0.20618556701030927 0.20618556701030927 freq: -83 -10.927835051546392 -10.927835051546392 weight: -83 0.20618556701030927 0.20618556701030927 freq: -82 -10.721649484536082 -10.721649484536082 weight: -82 0.20618556701030927 0.20618556701030927 freq: -81 -10.515463917525773 -10.515463917525773 weight: -81 0.20618556701030927 0.20618556701030927 freq: -80 -10.309278350515463 -10.309278350515463 weight: -80 0.20618556701030927 0.20618556701030927 freq: -79 -10.103092783505154 -10.103092783505154 weight: -79 0.20618556701030927 0.20618556701030927 freq: -78 -9.896907216494846 -9.896907216494846 weight: -78 0.20618556701030927 0.20618556701030927 freq: -77 -9.690721649484535 -9.690721649484535 weight: -77 0.20618556701030927 0.20618556701030927 freq: -76 -9.484536082474227 -9.484536082474227 weight: -76 0.20618556701030927 0.20618556701030927 freq: -75 -9.278350515463917 -9.278350515463917 weight: -75 0.20618556701030927 0.20618556701030927 freq: -74 -9.072164948453608 -9.072164948453608 weight: -74 0.20618556701030927 0.20618556701030927 freq: -73 -8.865979381443298 -8.865979381443298 weight: -73 0.20618556701030927 0.20618556701030927 freq: -72 -8.65979381443299 -8.65979381443299 weight: -72 0.20618556701030927 0.20618556701030927 freq: -71 -8.45360824742268 -8.45360824742268 weight: -71 0.20618556701030927 0.20618556701030927 freq: -70 -8.24742268041237 -8.24742268041237 weight: -70 0.20618556701030927 0.20618556701030927 freq: -69 -8.041237113402062 -8.041237113402062 weight: -69 0.20618556701030927 0.20618556701030927 freq: -68 -7.835051546391752 -7.835051546391752 weight: -68 0.20618556701030927 0.20618556701030927 freq: -67 -7.628865979381443 -7.628865979381443 weight: -67 0.20618556701030927 0.20618556701030927 freq: -66 -7.422680412371133 -7.422680412371133 weight: -66 0.20618556701030927 0.20618556701030927 freq: -65 -7.216494845360824 -7.216494845360824 weight: -65 0.20618556701030927 0.20618556701030927 freq: -64 -7.010309278350515 -7.010309278350515 weight: -64 0.20618556701030927 0.20618556701030927 freq: -63 -6.804123711340206 -6.804123711340206 weight: -63 0.20618556701030927 0.20618556701030927 freq: -62 -6.597938144329897 -6.597938144329897 weight: -62 0.20618556701030927 0.20618556701030927 freq: -61 -6.391752577319587 -6.391752577319587 weight: -61 0.20618556701030927 0.20618556701030927 freq: -60 -6.185567010309278 -6.185567010309278 weight: -60 0.20618556701030927 0.20618556701030927 freq: -59 -5.979381443298969 -5.979381443298969 weight: -59 0.20618556701030927 0.20618556701030927 freq: -58 -5.77319587628866 -5.77319587628866 weight: -58 0.20618556701030927 0.20618556701030927 freq: -57 -5.56701030927835 -5.56701030927835 weight: -57 0.20618556701030927 0.20618556701030927 freq: -56 -5.360824742268041 -5.360824742268041 weight: -56 0.20618556701030927 0.20618556701030927 freq: -55 -5.154639175257731 -5.154639175257731 weight: -55 0.20618556701030927 0.20618556701030927 freq: -54 -4.948453608247423 -4.948453608247423 weight: -54 0.20618556701030927 0.20618556701030927 freq: -53 -4.742268041237113 -4.742268041237113 weight: -53 0.20618556701030927 0.20618556701030927 freq: -52 -4.536082474226804 -4.536082474226804 weight: -52 0.20618556701030927 0.20618556701030927 freq: -51 -4.329896907216495 -4.329896907216495 weight: -51 0.20618556701030927 0.20618556701030927 freq: -50 -4.123711340206185 -4.123711340206185 weight: -50 0.20618556701030927 0.20618556701030927 freq: -49 -3.917525773195876 -3.917525773195876 weight: -49 0.20618556701030927 0.20618556701030927 freq: -48 -3.7113402061855667 -3.7113402061855667 weight: -48 0.20618556701030927 0.20618556701030927 freq: -47 -3.5051546391752577 -3.5051546391752577 weight: -47 0.20618556701030927 0.20618556701030927 freq: -46 -3.2989690721649483 -3.2989690721649483 weight: -46 0.20618556701030927 0.20618556701030927 freq: -45 -3.092783505154639 -3.092783505154639 weight: -45 0.20618556701030927 0.20618556701030927 freq: -44 -2.88659793814433 -2.88659793814433 weight: -44 0.20618556701030927 0.20618556701030927 freq: -43 -2.6804123711340204 -2.6804123711340204 weight: -43 0.20618556701030927 0.20618556701030927 freq: -42 -2.4742268041237114 -2.4742268041237114 weight: -42 0.20618556701030927 0.20618556701030927 freq: -41 -2.268041237113402 -2.268041237113402 weight: -41 0.20618556701030927 0.20618556701030927 freq: -40 -2.0618556701030926 -2.0618556701030926 weight: -40 0.20618556701030927 0.20618556701030927 freq: -39 -1.8556701030927834 -1.8556701030927834 weight: -39 0.20618556701030927 0.20618556701030927 freq: -38 -1.6494845360824741 -1.6494845360824741 weight: -38 0.20618556701030927 0.20618556701030927 freq: -37 -1.443298969072165 -1.443298969072165 weight: -37 0.20618556701030927 0.20618556701030927 freq: -36 -1.2371134020618557 -1.2371134020618557 weight: -36 0.20618556701030927 0.20618556701030927 freq: -35 -1.0309278350515463 -1.0309278350515463 weight: -35 0.20618556701030927 0.20618556701030927 freq: -34 -0.8247422680412371 -0.8247422680412371 weight: -34 0.20618556701030927 0.20618556701030927 freq: -33 -0.6185567010309279 -0.6185567010309279 weight: -33 0.20618556701030927 0.20618556701030927 freq: -32 -0.41237113402061853 -0.41237113402061853 weight: -32 0.20618556701030927 0.20618556701030927 freq: -31 -0.3041237113402062 -0.3041237113402062 weight: -31 0.010309278350515464 0.010309278350515464 freq: -30 -0.29381443298969073 -0.29381443298969073 weight: -30 0.010309278350515464 0.010309278350515464 freq: -29 -0.28350515463917525 -0.28350515463917525 weight: -29 0.010309278350515464 0.010309278350515464 freq: -28 -0.2731958762886598 -0.2731958762886598 weight: -28 0.010309278350515464 0.010309278350515464 freq: -27 -0.26288659793814434 -0.26288659793814434 weight: -27 0.010309278350515464 0.010309278350515464 freq: -26 -0.25257731958762886 -0.25257731958762886 weight: -26 0.010309278350515464 0.010309278350515464 freq: -25 -0.2422680412371134 -0.2422680412371134 weight: -25 0.010309278350515464 0.010309278350515464 freq: -24 -0.23195876288659792 -0.23195876288659792 weight: -24 0.010309278350515464 0.010309278350515464 freq: -23 -0.22164948453608246 -0.22164948453608246 weight: -23 0.010309278350515464 0.010309278350515464 freq: -22 -0.211340206185567 -0.211340206185567 weight: -22 0.010309278350515464 0.010309278350515464 freq: -21 -0.20618556701030927 -0.20618556701030927 weight: -21 0. 0. freq: -20 -0.20103092783505153 -0.20103092783505153 weight: -20 0.010309278350515464 0.010309278350515464 freq: -19 -0.19072164948453607 -0.19072164948453607 weight: -19 0.010309278350515464 0.010309278350515464 freq: -18 -0.18041237113402062 -0.18041237113402062 weight: -18 0.010309278350515464 0.010309278350515464 freq: -17 -0.17010309278350513 -0.17010309278350513 weight: -17 0.010309278350515464 0.010309278350515464 freq: -16 -0.15979381443298968 -0.15979381443298968 weight: -16 0.010309278350515464 0.010309278350515464 freq: -15 -0.14948453608247422 -0.14948453608247422 weight: -15 0.010309278350515464 0.010309278350515464 freq: -14 -0.13917525773195874 -0.13917525773195874 weight: -14 0.010309278350515464 0.010309278350515464 freq: -13 -0.12886597938144329 -0.12886597938144329 weight: -13 0.010309278350515464 0.010309278350515464 freq: -12 -0.11855670103092784 -0.11855670103092784 weight: -12 0.010309278350515464 0.010309278350515464 freq: -11 -0.10824742268041238 -0.10824742268041238 weight: -11 0.010309278350515464 0.010309278350515464 freq: -10 -0.0979381443298969 -0.0979381443298969 weight: -10 0.010309278350515464 0.010309278350515464 freq: -9 -0.08762886597938145 -0.08762886597938145 weight: -9 0.010309278350515464 0.010309278350515464 freq: -8 -0.07731958762886598 -0.07731958762886598 weight: -8 0.010309278350515464 0.010309278350515464 freq: -7 -0.06701030927835051 -0.06701030927835051 weight: -7 0.010309278350515464 0.010309278350515464 freq: -6 -0.05670103092783505 -0.05670103092783505 weight: -6 0.010309278350515464 0.010309278350515464 freq: -5 -0.04639175257731958 -0.04639175257731958 weight: -5 0.010309278350515464 0.010309278350515464 freq: -4 -0.03608247422680412 -0.03608247422680412 weight: -4 0.010309278350515464 0.010309278350515464 freq: -3 -0.025773195876288662 -0.025773195876288662 weight: -3 0.010309278350515464 0.010309278350515464 freq: -2 -0.015463917525773196 -0.015463917525773196 weight: -2 0.010309278350515464 0.010309278350515464 freq: -1 -0.005154639175257732 -0.005154639175257732 weight: -1 0.010309278350515464 0.010309278350515464 freq: 0 0. 0. weight: 0 0. 0. freq: 1 0.005154639175257732 0.005154639175257732 weight: 1 0.010309278350515464 0.010309278350515464 freq: 2 0.015463917525773196 0.015463917525773196 weight: 2 0.010309278350515464 0.010309278350515464 freq: 3 0.025773195876288662 0.025773195876288662 weight: 3 0.010309278350515464 0.010309278350515464 freq: 4 0.03608247422680412 0.03608247422680412 weight: 4 0.010309278350515464 0.010309278350515464 freq: 5 0.04639175257731958 0.04639175257731958 weight: 5 0.010309278350515464 0.010309278350515464 freq: 6 0.05670103092783505 0.05670103092783505 weight: 6 0.010309278350515464 0.010309278350515464 freq: 7 0.06701030927835051 0.06701030927835051 weight: 7 0.010309278350515464 0.010309278350515464 freq: 8 0.07731958762886598 0.07731958762886598 weight: 8 0.010309278350515464 0.010309278350515464 freq: 9 0.08762886597938145 0.08762886597938145 weight: 9 0.010309278350515464 0.010309278350515464 freq: 10 0.0979381443298969 0.0979381443298969 weight: 10 0.010309278350515464 0.010309278350515464 freq: 11 0.10824742268041238 0.10824742268041238 weight: 11 0.010309278350515464 0.010309278350515464 freq: 12 0.11855670103092784 0.11855670103092784 weight: 12 0.010309278350515464 0.010309278350515464 freq: 13 0.12886597938144329 0.12886597938144329 weight: 13 0.010309278350515464 0.010309278350515464 freq: 14 0.13917525773195874 0.13917525773195874 weight: 14 0.010309278350515464 0.010309278350515464 freq: 15 0.14948453608247422 0.14948453608247422 weight: 15 0.010309278350515464 0.010309278350515464 freq: 16 0.15979381443298968 0.15979381443298968 weight: 16 0.010309278350515464 0.010309278350515464 freq: 17 0.17010309278350513 0.17010309278350513 weight: 17 0.010309278350515464 0.010309278350515464 freq: 18 0.18041237113402062 0.18041237113402062 weight: 18 0.010309278350515464 0.010309278350515464 freq: 19 0.19072164948453607 0.19072164948453607 weight: 19 0.010309278350515464 0.010309278350515464 freq: 20 0.20103092783505153 0.20103092783505153 weight: 20 0.010309278350515464 0.010309278350515464 freq: 21 0.20618556701030927 0.20618556701030927 weight: 21 0. 0. freq: 22 0.211340206185567 0.211340206185567 weight: 22 0.010309278350515464 0.010309278350515464 freq: 23 0.22164948453608246 0.22164948453608246 weight: 23 0.010309278350515464 0.010309278350515464 freq: 24 0.23195876288659792 0.23195876288659792 weight: 24 0.010309278350515464 0.010309278350515464 freq: 25 0.2422680412371134 0.2422680412371134 weight: 25 0.010309278350515464 0.010309278350515464 freq: 26 0.25257731958762886 0.25257731958762886 weight: 26 0.010309278350515464 0.010309278350515464 freq: 27 0.26288659793814434 0.26288659793814434 weight: 27 0.010309278350515464 0.010309278350515464 freq: 28 0.2731958762886598 0.2731958762886598 weight: 28 0.010309278350515464 0.010309278350515464 freq: 29 0.28350515463917525 0.28350515463917525 weight: 29 0.010309278350515464 0.010309278350515464 freq: 30 0.29381443298969073 0.29381443298969073 weight: 30 0.010309278350515464 0.010309278350515464 freq: 31 0.3041237113402062 0.3041237113402062 weight: 31 0.010309278350515464 0.010309278350515464 freq: 32 0.41237113402061853 0.41237113402061853 weight: 32 0.20618556701030927 0.20618556701030927 freq: 33 0.6185567010309279 0.6185567010309279 weight: 33 0.20618556701030927 0.20618556701030927 freq: 34 0.8247422680412371 0.8247422680412371 weight: 34 0.20618556701030927 0.20618556701030927 freq: 35 1.0309278350515463 1.0309278350515463 weight: 35 0.20618556701030927 0.20618556701030927 freq: 36 1.2371134020618557 1.2371134020618557 weight: 36 0.20618556701030927 0.20618556701030927 freq: 37 1.443298969072165 1.443298969072165 weight: 37 0.20618556701030927 0.20618556701030927 freq: 38 1.6494845360824741 1.6494845360824741 weight: 38 0.20618556701030927 0.20618556701030927 freq: 39 1.8556701030927834 1.8556701030927834 weight: 39 0.20618556701030927 0.20618556701030927 freq: 40 2.0618556701030926 2.0618556701030926 weight: 40 0.20618556701030927 0.20618556701030927 freq: 41 2.268041237113402 2.268041237113402 weight: 41 0.20618556701030927 0.20618556701030927 freq: 42 2.4742268041237114 2.4742268041237114 weight: 42 0.20618556701030927 0.20618556701030927 freq: 43 2.6804123711340204 2.6804123711340204 weight: 43 0.20618556701030927 0.20618556701030927 freq: 44 2.88659793814433 2.88659793814433 weight: 44 0.20618556701030927 0.20618556701030927 freq: 45 3.092783505154639 3.092783505154639 weight: 45 0.20618556701030927 0.20618556701030927 freq: 46 3.2989690721649483 3.2989690721649483 weight: 46 0.20618556701030927 0.20618556701030927 freq: 47 3.5051546391752577 3.5051546391752577 weight: 47 0.20618556701030927 0.20618556701030927 freq: 48 3.7113402061855667 3.7113402061855667 weight: 48 0.20618556701030927 0.20618556701030927 freq: 49 3.917525773195876 3.917525773195876 weight: 49 0.20618556701030927 0.20618556701030927 freq: 50 4.123711340206185 4.123711340206185 weight: 50 0.20618556701030927 0.20618556701030927 freq: 51 4.329896907216495 4.329896907216495 weight: 51 0.20618556701030927 0.20618556701030927 freq: 52 4.536082474226804 4.536082474226804 weight: 52 0.20618556701030927 0.20618556701030927 freq: 53 4.742268041237113 4.742268041237113 weight: 53 0.20618556701030927 0.20618556701030927 freq: 54 4.948453608247423 4.948453608247423 weight: 54 0.20618556701030927 0.20618556701030927 freq: 55 5.154639175257731 5.154639175257731 weight: 55 0.20618556701030927 0.20618556701030927 freq: 56 5.360824742268041 5.360824742268041 weight: 56 0.20618556701030927 0.20618556701030927 freq: 57 5.56701030927835 5.56701030927835 weight: 57 0.20618556701030927 0.20618556701030927 freq: 58 5.77319587628866 5.77319587628866 weight: 58 0.20618556701030927 0.20618556701030927 freq: 59 5.979381443298969 5.979381443298969 weight: 59 0.20618556701030927 0.20618556701030927 freq: 60 6.185567010309278 6.185567010309278 weight: 60 0.20618556701030927 0.20618556701030927 freq: 61 6.391752577319587 6.391752577319587 weight: 61 0.20618556701030927 0.20618556701030927 freq: 62 6.597938144329897 6.597938144329897 weight: 62 0.20618556701030927 0.20618556701030927 freq: 63 6.804123711340206 6.804123711340206 weight: 63 0.20618556701030927 0.20618556701030927 freq: 64 7.010309278350515 7.010309278350515 weight: 64 0.20618556701030927 0.20618556701030927 freq: 65 7.216494845360824 7.216494845360824 weight: 65 0.20618556701030927 0.20618556701030927 freq: 66 7.422680412371133 7.422680412371133 weight: 66 0.20618556701030927 0.20618556701030927 freq: 67 7.628865979381443 7.628865979381443 weight: 67 0.20618556701030927 0.20618556701030927 freq: 68 7.835051546391752 7.835051546391752 weight: 68 0.20618556701030927 0.20618556701030927 freq: 69 8.041237113402062 8.041237113402062 weight: 69 0.20618556701030927 0.20618556701030927 freq: 70 8.24742268041237 8.24742268041237 weight: 70 0.20618556701030927 0.20618556701030927 freq: 71 8.45360824742268 8.45360824742268 weight: 71 0.20618556701030927 0.20618556701030927 freq: 72 8.65979381443299 8.65979381443299 weight: 72 0.20618556701030927 0.20618556701030927 freq: 73 8.865979381443298 8.865979381443298 weight: 73 0.20618556701030927 0.20618556701030927 freq: 74 9.072164948453608 9.072164948453608 weight: 74 0.20618556701030927 0.20618556701030927 freq: 75 9.278350515463917 9.278350515463917 weight: 75 0.20618556701030927 0.20618556701030927 freq: 76 9.484536082474227 9.484536082474227 weight: 76 0.20618556701030927 0.20618556701030927 freq: 77 9.690721649484535 9.690721649484535 weight: 77 0.20618556701030927 0.20618556701030927 freq: 78 9.896907216494846 9.896907216494846 weight: 78 0.20618556701030927 0.20618556701030927 freq: 79 10.103092783505154 10.103092783505154 weight: 79 0.20618556701030927 0.20618556701030927 freq: 80 10.309278350515463 10.309278350515463 weight: 80 0.20618556701030927 0.20618556701030927 freq: 81 10.515463917525773 10.515463917525773 weight: 81 0.20618556701030927 0.20618556701030927 freq: 82 10.721649484536082 10.721649484536082 weight: 82 0.20618556701030927 0.20618556701030927 freq: 83 10.927835051546392 10.927835051546392 weight: 83 0.20618556701030927 0.20618556701030927 freq: 84 11.1340206185567 11.1340206185567 weight: 84 0.20618556701030927 0.20618556701030927 freq: 85 11.340206185567009 11.340206185567009 weight: 85 0.20618556701030927 0.20618556701030927 freq: 86 11.54639175257732 11.54639175257732 weight: 86 0.20618556701030927 0.20618556701030927 freq: 87 11.752577319587628 11.752577319587628 weight: 87 0.20618556701030927 0.20618556701030927 freq: 88 11.958762886597938 11.958762886597938 weight: 88 0.20618556701030927 0.20618556701030927 freq: 89 12.164948453608247 12.164948453608247 weight: 89 0.20618556701030927 0.20618556701030927 freq: 90 12.371134020618555 12.371134020618555 weight: 90 0.20618556701030927 0.20618556701030927 freq: 91 12.577319587628866 12.577319587628866 weight: 91 0.20618556701030927 0.20618556701030927 freq: 92 12.783505154639174 12.783505154639174 weight: 92 0.20618556701030927 0.20618556701030927 freq: 93 12.989690721649485 12.989690721649485 weight: 93 0.20618556701030927 0.20618556701030927 freq: 94 13.195876288659793 13.195876288659793 weight: 94 0.20618556701030927 0.20618556701030927 freq: 95 13.402061855670102 13.402061855670102 weight: 95 0.20618556701030927 0.20618556701030927 freq: 96 13.608247422680412 13.608247422680412 weight: 96 0.20618556701030927 0.20618556701030927 freq: 97 13.81443298969072 13.81443298969072 weight: 97 0.20618556701030927 0.20618556701030927 freq: 98 14.02061855670103 14.02061855670103 weight: 98 0.20618556701030927 0.20618556701030927 freq: 99 14.22680412371134 14.22680412371134 weight: 99 0.20618556701030927 0.20618556701030927 freq: 100 14.432989690721648 14.432989690721648 weight: 100 0.20618556701030927 0.20618556701030927 freq: 101 14.639175257731958 14.639175257731958 weight: 101 0.20618556701030927 0.20618556701030927 freq: 102 14.845360824742267 14.845360824742267 weight: 102 0.20618556701030927 0.20618556701030927 freq: 103 15.051546391752577 15.051546391752577 weight: 103 0.20618556701030927 0.20618556701030927 freq: 104 15.257731958762886 15.257731958762886 weight: 104 0.20618556701030927 0.20618556701030927 freq: 105 15.463917525773194 15.463917525773194 weight: 105 0.20618556701030927 0.20618556701030927 freq: 106 15.670103092783505 15.670103092783505 weight: 106 0.20618556701030927 0.20618556701030927 freq: 107 15.876288659793813 15.876288659793813 weight: 107 0.20618556701030927 0.20618556701030927 freq: 108 16.082474226804123 16.082474226804123 weight: 108 0.20618556701030927 0.20618556701030927 freq: 109 16.288659793814432 16.288659793814432 weight: 109 0.20618556701030927 0.20618556701030927 freq: 110 16.49484536082474 16.49484536082474 weight: 110 0.20618556701030927 0.20618556701030927 freq: 111 16.70103092783505 16.70103092783505 weight: 111 0.20618556701030927 0.20618556701030927 freq: 112 16.90721649484536 16.90721649484536 weight: 112 0.20618556701030927 0.20618556701030927 freq: 113 17.11340206185567 17.11340206185567 weight: 113 0.20618556701030927 0.20618556701030927 freq: 114 17.31958762886598 17.31958762886598 weight: 114 0.20618556701030927 0.20618556701030927 freq: 115 17.525773195876287 17.525773195876287 weight: 115 0.20618556701030927 0.20618556701030927 freq: 116 17.731958762886595 17.731958762886595 weight: 116 0.20618556701030927 0.20618556701030927 freq: 117 17.938144329896907 17.938144329896907 weight: 117 0.20618556701030927 0.20618556701030927 freq: 118 18.144329896907216 18.144329896907216 weight: 118 0.20618556701030927 0.20618556701030927 freq: 119 18.350515463917525 18.350515463917525 weight: 119 0.20618556701030927 0.20618556701030927 freq: 120 18.556701030927833 18.556701030927833 weight: 120 0.20618556701030927 0.20618556701030927 freq: 121 18.76288659793814 18.76288659793814 weight: 121 0.20618556701030927 0.20618556701030927 freq: 122 18.969072164948454 18.969072164948454 weight: 122 0.20618556701030927 0.20618556701030927 freq: 123 19.175257731958762 19.175257731958762 weight: 123 0.20618556701030927 0.20618556701030927 freq: 124 19.38144329896907 19.38144329896907 weight: 124 0.20618556701030927 0.20618556701030927 freq: 125 19.58762886597938 19.58762886597938 weight: 125 0.20618556701030927 0.20618556701030927 freq: 126 19.79381443298969 19.79381443298969 weight: 126 0.20618556701030927 0.20618556701030927 freq: 127 20. 20. weight: 127 0.20618556701030927 0.20618556701030927 ENE H (0.2378210872411728,0.) (0.30771711468696594,0.) (0.30771711468696594,0.) (0.3077172636985779,0.) (0.3077172636985779,0.) (0.3077172636985779,0.) (0.3077174425125122,0.) (0.256617933511734,0.) (0.256617933511734,0.) (0.256617933511734,0.) (0.2566167414188385,0.) (0.2566167414188385,0.) (0.2566167414188385,0.) (0.3868509531021118,0.) (0.3868509531021118,0.) (0.3868509531021118,0.) (-0.012976822443306446,0.) (-0.012976822443306446,0.) (-0.012977002188563347,0.) (-0.012977002188563347,0.) (-0.012977002188563347,0.) (-0.0129774771630764,0.) (0.16253481805324554,0.) (0.16253481805324554,0.) (0.16253481805324554,0.) (0.36384832859039307,0.) (-0.18529018759727478,0.) (0.15331920981407166,0.) (0.15331922471523285,0.) (0.2774766683578491,0.) (0.27747663855552673,0.) (0.2774742841720581,0.) Routine calculate_compact_pola_lanczos ******************************* RESTART FROM POINT 3 ******************************* Routine: do_polarization_lanczos Lanczos dimensions 247 20 Lanczos elemets: 1 6.178513738578622 2.5348364993474255 Lanczos elemets: 2 6.842518835122502 2.4675848469798827 Lanczos elemets: 3 5.261091393193509 2.32217774021342 Lanczos elemets: 4 5.166349575694816 2.3011329389148862 Lanczos elemets: 5 5.507884211869593 2.6761431466509387 Lanczos elemets: 6 5.36355880777325 2.520706280356123 Lanczos elemets: 7 5.442834579328281 2.2738076232466993 Lanczos elemets: 8 4.907170007418452 2.291721763935929 Lanczos elemets: 9 4.769376618948284 2.6710405684605796 Lanczos elemets: 10 5.710738804613744 2.4301020184292623 Lanczos elemets: 11 7.086109980518222 2.677422683826806 Lanczos elemets: 12 6.394523547111799 2.7000248692478985 Lanczos elemets: 13 5.446814903184362 2.4179421986187632 Lanczos elemets: 14 4.98229334913993 2.340417299931784 Lanczos elemets: 15 5.700419830575656 2.453226252469394 Lanczos elemets: 16 5.31319026860815 2.653651483274599 Lanczos elemets: 17 5.069102626889894 2.3804055178890033 Lanczos elemets: 18 5.048242554352829 2.3156723449185384 Lanczos elemets: 19 4.869060638749425 2.704050985800642 Lanczos elemets: 20 6.229935541064633 2.5874550911213263 Lanczos elemets: 21 5.562516482818321 2.367166914349938 Lanczos elemets: 22 6.292095701884378 2.237401972930655 Lanczos elemets: 23 6.399562362685086 2.575237752145959 Lanczos elemets: 24 5.398155808282408 2.451531599240929 Lanczos elemets: 25 4.915761920048176 2.3472690324555443 Lanczos elemets: 26 5.782010778403373 2.384970953101435 Lanczos elemets: 27 4.929420572769256 2.458010913513303 Lanczos elemets: 28 5.109903097853246 2.3510249861881882 Lanczos elemets: 29 4.8155218306457925 2.2471327464163555 Lanczos elemets: 30 4.75711483677485 2.7270378041823 Lanczos elemets: 31 5.532308113219942 2.567934043978939 Lanczos elemets: 32 5.6257246655929976 2.5539463186228595 Lanczos elemets: 33 5.285780875486749 2.2799516704308536 Lanczos elemets: 34 5.596880575630086 2.3895097257245306 Lanczos elemets: 35 5.726528001350225 2.53236755358469 Lanczos elemets: 36 4.565929968727007 2.540036505105098 Lanczos elemets: 37 4.164810614575993 2.3893327287985766 Lanczos elemets: 38 4.72610922958785 2.2312185005067158 Lanczos elemets: 39 4.545412507826402 2.327831480651616 Lanczos elemets: 40 5.165624846903305 2.1026541214573844 Lanczos elemets: 41 4.749921043623811 2.2865141802615536 Lanczos elemets: 42 4.0740942489154985 2.221438002447155 Lanczos elemets: 43 3.620658291530463 2.083245606870424 Lanczos elemets: 44 4.097547687926623 2.5362589115151395 Lanczos elemets: 45 5.468253700529775 2.5704035772615517 Lanczos elemets: 46 5.058559408956703 2.6057269117255735 Lanczos elemets: 47 5.314146572201686 2.5626848665144304 Lanczos elemets: 48 5.38524792038161 2.4626343708748535 Lanczos elemets: 49 4.582050324844863 2.2127754721876363 Lanczos elemets: 50 4.280635262855137 2.3600575599722253 Lanczos elemets: 51 4.667574631084184 2.549570275178082 Lanczos elemets: 52 3.7444537983793165 2.1879094477587726 Lanczos elemets: 53 4.350392274072061 2.0982377138897745 Lanczos elemets: 54 3.906462342448025 2.3968891023720627 Lanczos elemets: 55 5.07220923607512 2.1294779983649406 Lanczos elemets: 56 4.381982012847754 2.284934280115386 Lanczos elemets: 57 3.619694027262283 2.1381542086057777 Lanczos elemets: 58 3.180618331461835 2.0052105203986628 Lanczos elemets: 59 4.2185559975554305 2.5779531411280185 Lanczos elemets: 60 5.265163940003836 2.561038100524526 Lanczos elemets: 61 5.939438739893277 2.691573459246574 Lanczos elemets: 62 5.769807539546904 2.4540504349348016 Lanczos elemets: 63 5.8230046930446 2.4282284694017644 Lanczos elemets: 64 4.1453698715311 2.3224557165602 Lanczos elemets: 65 5.239314568228972 2.284247825548557 Lanczos elemets: 66 4.607029019881022 2.251859691952772 Lanczos elemets: 67 5.0586823196820765 2.44635417886323 Lanczos elemets: 68 5.43479706750217 2.1633706180764047 Lanczos elemets: 69 4.424830608963556 2.2002505302266124 Lanczos elemets: 70 3.905226565398183 2.1100038355058013 Lanczos elemets: 71 4.107927379480816 2.5875279528600115 Lanczos elemets: 72 5.3802700594383275 2.4270095407085197 Lanczos elemets: 73 5.2869642881484875 2.771787623053962 Lanczos elemets: 74 5.256169990791079 2.730995302887366 Lanczos elemets: 75 5.3786761654236575 2.4761626239057914 Lanczos elemets: 76 4.655953430252586 2.382868517721447 Lanczos elemets: 77 4.427526377528495 2.4298075527838634 Lanczos elemets: 78 4.158028149036635 2.3776841139230527 Lanczos elemets: 79 3.901217920312555 2.1982109083430403 Lanczos elemets: 80 4.460420625836287 2.2471731826136816 Lanczos elemets: 81 3.893754207857627 2.4621024628782284 Lanczos elemets: 82 4.998267950747968 2.3198458493517355 Lanczos elemets: 83 4.742372211886252 2.190631448135503 Lanczos elemets: 84 3.500233114898248 2.0749647423612663 Lanczos elemets: 85 3.123330803028696 1.9811901117933886 Lanczos elemets: 86 4.111485029912288 2.5873175351325166 Lanczos elemets: 87 5.586909426087612 2.5730387966765864 Lanczos elemets: 88 5.034713050078647 2.637857540708177 Lanczos elemets: 89 5.082010846939545 2.3974264757270225 Lanczos elemets: 90 5.677482019446524 2.407500925742286 Lanczos elemets: 91 4.361915623980415 2.1405586377465466 Lanczos elemets: 92 4.100567227016338 2.3951985183097637 Lanczos elemets: 93 4.2665748720081496 2.343355722120996 Lanczos elemets: 94 3.6357318191023524 2.160614066946386 Lanczos elemets: 95 4.232403084262893 2.077075012675529 Lanczos elemets: 96 3.6812295921752733 2.204778444264122 Lanczos elemets: 97 4.971145768858085 2.0799271265501247 Lanczos elemets: 98 4.260809351778748 2.2752686890195415 Lanczos elemets: 99 3.4296714553022283 2.0559268263436623 Lanczos elemets: 100 3.204499152127966 2.019383194563158 Lanczos elemets: 101 3.925941392449016 2.511356909303468 Lanczos elemets: 102 5.625454391258003 2.767010459185747 Lanczos elemets: 103 5.630051042396498 2.6382224131795327 Lanczos elemets: 104 5.303727538822894 2.522432409524432 Lanczos elemets: 105 5.887793717874382 2.658646459068051 Lanczos elemets: 106 5.559065361100581 2.4148324927482907 Lanczos elemets: 107 4.128426892698519 2.3839611871169155 Lanczos elemets: 108 4.942430498624905 2.168898020564636 Lanczos elemets: 109 4.49434152761155 2.28634794857772 Lanczos elemets: 110 5.0150211197266 2.4141314720450007 Lanczos elemets: 111 5.327978804039498 2.1488474945093747 Lanczos elemets: 112 4.55593998638917 2.2797169687272874 Lanczos elemets: 113 3.7870165692174664 2.0416061836167065 Lanczos elemets: 114 3.9298048197946542 2.5768720395283604 Lanczos elemets: 115 5.010454428831706 2.585855307397841 Lanczos elemets: 116 5.108816551925566 2.747099818532039 Lanczos elemets: 117 5.344519481787554 2.386956401538602 Lanczos elemets: 118 4.580831611815157 2.5501713213760455 Lanczos elemets: 119 5.079038292445316 2.6622499005987947 Lanczos elemets: 120 4.915602784906915 2.5382933082946812 Lanczos elemets: 121 4.201470939445444 2.176696855996302 Lanczos elemets: 122 3.99162068723292 2.3015012808311557 Lanczos elemets: 123 3.678464369273711 2.1500779999197714 Lanczos elemets: 124 3.7052364330908016 2.1834287234533836 Lanczos elemets: 125 3.600946689278012 2.2832870740571076 Lanczos elemets: 126 3.432909964604634 2.1228575852680134 Lanczos elemets: 127 4.883609880595314 2.1449694664746173 Lanczos elemets: 128 3.495537704564546 2.2378256165402557 Lanczos elemets: 129 3.1752539444959003 2.0681494981044937 Lanczos elemets: 130 2.928025295070669 1.8379983346352495 Lanczos elemets: 131 3.7541381718555566 2.484545768233507 Lanczos elemets: 132 4.812169953088537 2.574751926556199 Lanczos elemets: 133 5.129371763511106 2.642864679218382 Lanczos elemets: 134 5.376177815466657 2.6137343794511683 Lanczos elemets: 135 4.5681294578628595 2.606350971796566 Lanczos elemets: 136 4.3812890737014225 2.092709630525512 Lanczos elemets: 137 5.10380659641685 2.7667035084159197 Lanczos elemets: 138 3.884795612886322 2.044567508377776 Lanczos elemets: 139 4.063257128369421 2.290958022577163 Lanczos elemets: 140 3.761578937589227 2.2127674941523634 Lanczos elemets: 141 3.3420740086913794 2.022235416083925 Lanczos elemets: 142 3.701405780512415 2.124818356049201 Lanczos elemets: 143 3.3545006948331157 2.0263496856710352 Lanczos elemets: 144 4.769796054615316 2.0157214247986905 Lanczos elemets: 145 3.712218539047437 2.2535583959562464 Lanczos elemets: 146 3.1463234369081308 2.015616946757743 Lanczos elemets: 147 2.811944289045122 1.8191184427744935 Lanczos elemets: 148 3.703360723894805 2.4839377577513377 Lanczos elemets: 149 5.204211606345497 2.2809268975792647 Lanczos elemets: 150 5.294437603658308 2.3743364373022526 Lanczos elemets: 151 4.392152282250761 2.5852337131074767 Lanczos elemets: 152 5.1632452828299655 2.552210795788847 Lanczos elemets: 153 4.4560785985887295 2.6786887162528368 Lanczos elemets: 154 4.795882731515476 2.458799708630695 Lanczos elemets: 155 4.095349178041853 1.9636275234223117 Lanczos elemets: 156 4.189215021828896 2.63988317071993 Lanczos elemets: 157 3.5559162682145957 2.010335313033802 Lanczos elemets: 158 3.7476337649417024 2.009664219859634 Lanczos elemets: 159 3.547745483872406 2.054425408360999 Lanczos elemets: 160 3.0397209453457963 1.777702704758626 Lanczos elemets: 161 3.1138414872924782 1.87019227867893 Lanczos elemets: 162 3.0179866018388495 1.9376595991283037 Lanczos elemets: 163 4.648680868758322 2.0462009462835975 Lanczos elemets: 164 3.139101866771183 2.0883380040660606 Lanczos elemets: 165 2.7165727994088753 1.8830678286999512 Lanczos elemets: 166 2.5490235944648107 1.6860006998945303 Lanczos elemets: 167 3.659631057841951 2.453678409819778 Lanczos elemets: 168 5.221180958011688 2.4715432595561397 Lanczos elemets: 169 4.33444784294989 2.537261175906152 Lanczos elemets: 170 5.239699565340762 2.547701440477568 Lanczos elemets: 171 4.527463976580549 2.6282773723260284 Lanczos elemets: 172 4.626955734301744 2.495785052005705 Lanczos elemets: 173 4.069658041651786 1.9718253402063595 Lanczos elemets: 174 4.1554954167781055 2.612437732312575 Lanczos elemets: 175 3.5248333928634983 2.015462884973734 Lanczos elemets: 176 3.755806102237007 2.020113398523959 Lanczos elemets: 177 3.1178096769111043 1.8383196959831865 Lanczos elemets: 178 3.310854169415954 1.9866694217533976 Lanczos elemets: 179 3.1326561354929776 1.8569200504136611 Lanczos elemets: 180 2.9782512832642967 1.9290029224094165 Lanczos elemets: 181 4.639947036861344 2.0405588671611987 Lanczos elemets: 182 3.02023134118284 2.0582113838355074 Lanczos elemets: 183 2.72037502507283 1.8841046225693334 Lanczos elemets: 184 2.524339667911762 1.6651408018890228 Lanczos elemets: 185 3.586421859310651 2.435049367276351 Lanczos elemets: 186 5.133086703351093 2.260352211534225 Lanczos elemets: 187 5.012969087250777 2.5009979310071353 Lanczos elemets: 188 4.415792312231559 2.472607870968943 Lanczos elemets: 189 4.146220510421843 2.8053652257797586 Lanczos elemets: 190 4.694587323294769 2.3023711381993257 Lanczos elemets: 191 3.7358640054687275 1.9733601468589228 Lanczos elemets: 192 3.681183256390309 1.9905552917163112 Lanczos elemets: 193 4.20586276204138 2.5483822867490726 Lanczos elemets: 194 3.4273820731385936 1.8882014701315768 Lanczos elemets: 195 3.4675764289275977 1.9162712785547735 Lanczos elemets: 196 2.8546225444506232 1.6354614136675218 Lanczos elemets: 197 2.990471382470934 1.744836669433489 Lanczos elemets: 198 2.7269470475213797 1.7793500038528192 Lanczos elemets: 199 2.6389386554320517 1.7386506972520621 Lanczos elemets: 200 4.524354523647629 2.030976966343398 Lanczos elemets: 201 2.557712447345648 1.8800083064479902 Lanczos elemets: 202 2.503128098468307 1.8726350044079498 Lanczos elemets: 203 2.2033546393933943 1.4647402802556277 Lanczos elemets: 204 3.445800183126841 2.399397092242034 Lanczos elemets: 205 4.982968666644543 2.4930943218311494 Lanczos elemets: 206 4.504752498961476 2.6486649927048194 Lanczos elemets: 207 5.035083147260767 2.492755846469417 Lanczos elemets: 208 4.379732918688163 2.6331397307446824 Lanczos elemets: 209 4.704770355331753 2.5265584041912215 Lanczos elemets: 210 4.0237002722384805 1.933643310769114 Lanczos elemets: 211 4.033009944357246 2.619726178884166 Lanczos elemets: 212 3.470962122553903 1.9836028268011514 Lanczos elemets: 213 3.73223816751948 2.0475015699562005 Lanczos elemets: 214 3.1574483439798096 1.9076222164412586 Lanczos elemets: 215 3.319913577943359 1.9834371246294868 Lanczos elemets: 216 3.0661100511038217 2.0243255433560936 Lanczos elemets: 217 2.975257358642888 1.9449631782715353 Lanczos elemets: 218 4.68230696737364 2.0852520771383913 Lanczos elemets: 219 3.234852455140741 2.1711393606137053 Lanczos elemets: 220 2.6694932888626655 1.903611051788077 Lanczos elemets: 221 2.501879719830564 1.6579808818513886 Lanczos elemets: 222 3.515243464875504 2.4636398819801326 Lanczos elemets: 223 0.21816657467363956 1.343557742744175 Lanczos elemets: 224 4.259375029919029 1.8421895462410016 Lanczos elemets: 225 4.585237016123962 1.7133738704379091 Lanczos elemets: 226 4.587675216447947 2.744345898937432 Lanczos elemets: 227 4.633823783644029 2.7629096819122445 Lanczos elemets: 228 5.061544848688339 2.307286769084679 Lanczos elemets: 229 5.081704833594099 2.2964345306282823 Lanczos elemets: 230 5.2082493788322815 2.4518860572984438 Lanczos elemets: 231 4.004184269306958 2.4298315199571734 Lanczos elemets: 232 4.738444916068477 2.3729649464609928 Lanczos elemets: 233 3.940124739377845 2.778666981425446 Lanczos elemets: 234 3.913462507451057 2.459175893219779 Lanczos elemets: 235 3.6515121359433866 1.9888210449378496 Lanczos elemets: 236 3.689365092200554 2.1000425179175126 Lanczos elemets: 237 3.3739381742587105 1.8703889880152929 Lanczos elemets: 238 3.408328062187948 1.897955568265541 Lanczos elemets: 239 2.8190548726575946 1.646820614107762 Lanczos elemets: 240 2.951626021319614 1.7377366922382267 Lanczos elemets: 241 2.6829787409897756 1.7686626307732494 Lanczos elemets: 242 2.6359240271650664 1.7389172010726028 Lanczos elemets: 243 4.510345220755703 2.0330933597160215 Lanczos elemets: 244 2.482023256914065 1.8702587454924864 Lanczos elemets: 245 2.4856457363804028 1.8733661197242935 Lanczos elemets: 246 2.187075200741922 1.464459782796022 Lanczos elemets: 247 3.385486617702168 2.4012844239740785 do_polarization_lanczos1 0 F do_polarization_lanczos iv 1 do_polarization_lanczos1 1 F do_polarization_lanczos iv 1 do_polarization_lanczos1 2 F do_polarization_lanczos iv 1 do_polarization_lanczos1 3 F do_polarization_lanczos iv 1 do_polarization_lanczos1 4 F do_polarization_lanczos iv 1 do_polarization_lanczos1 5 F do_polarization_lanczos iv 1 do_polarization_lanczos1 6 F do_polarization_lanczos iv 1 do_polarization_lanczos1 7 F do_polarization_lanczos iv 1 do_polarization_lanczos1 8 F do_polarization_lanczos iv 1 do_polarization_lanczos1 9 F do_polarization_lanczos iv 1 do_polarization_lanczos1 10 F do_polarization_lanczos iv 1 do_polarization_lanczos1 11 F do_polarization_lanczos iv 1 do_polarization_lanczos1 12 F do_polarization_lanczos iv 1 do_polarization_lanczos1 13 F do_polarization_lanczos iv 1 do_polarization_lanczos1 14 F do_polarization_lanczos iv 1 do_polarization_lanczos1 15 F do_polarization_lanczos iv 1 do_polarization_lanczos1 16 F do_polarization_lanczos iv 1 do_polarization_lanczos1 17 F do_polarization_lanczos iv 1 do_polarization_lanczos1 18 F do_polarization_lanczos iv 1 do_polarization_lanczos1 19 F do_polarization_lanczos iv 1 do_polarization_lanczos1 20 F do_polarization_lanczos iv 1 do_polarization_lanczos1 21 F do_polarization_lanczos iv 1 do_polarization_lanczos1 22 F do_polarization_lanczos iv 1 do_polarization_lanczos1 23 F do_polarization_lanczos iv 1 do_polarization_lanczos1 24 F do_polarization_lanczos iv 1 do_polarization_lanczos1 25 F do_polarization_lanczos iv 1 do_polarization_lanczos1 26 F do_polarization_lanczos iv 1 do_polarization_lanczos1 27 F do_polarization_lanczos iv 1 do_polarization_lanczos1 28 F do_polarization_lanczos iv 1 do_polarization_lanczos1 29 F do_polarization_lanczos iv 1 do_polarization_lanczos1 30 F do_polarization_lanczos iv 1 do_polarization_lanczos1 31 F do_polarization_lanczos iv 1 do_polarization_lanczos1 32 F do_polarization_lanczos iv 1 do_polarization_lanczos1 33 F do_polarization_lanczos iv 1 do_polarization_lanczos1 34 F do_polarization_lanczos iv 1 do_polarization_lanczos1 35 F do_polarization_lanczos iv 1 do_polarization_lanczos1 36 F do_polarization_lanczos iv 1 do_polarization_lanczos1 37 F do_polarization_lanczos iv 1 do_polarization_lanczos1 38 F do_polarization_lanczos iv 1 do_polarization_lanczos1 39 F do_polarization_lanczos iv 1 do_polarization_lanczos1 40 F do_polarization_lanczos iv 1 do_polarization_lanczos1 41 F do_polarization_lanczos iv 1 do_polarization_lanczos1 42 F do_polarization_lanczos iv 1 do_polarization_lanczos1 43 F do_polarization_lanczos iv 1 do_polarization_lanczos1 44 F do_polarization_lanczos iv 1 do_polarization_lanczos1 45 F do_polarization_lanczos iv 1 do_polarization_lanczos1 46 F do_polarization_lanczos iv 1 do_polarization_lanczos1 47 F do_polarization_lanczos iv 1 do_polarization_lanczos1 48 F do_polarization_lanczos iv 1 do_polarization_lanczos1 49 F do_polarization_lanczos iv 1 do_polarization_lanczos1 50 F do_polarization_lanczos iv 1 do_polarization_lanczos1 51 F do_polarization_lanczos iv 1 do_polarization_lanczos1 52 F do_polarization_lanczos iv 1 do_polarization_lanczos1 53 F do_polarization_lanczos iv 1 do_polarization_lanczos1 54 F do_polarization_lanczos iv 1 do_polarization_lanczos1 55 F do_polarization_lanczos iv 1 do_polarization_lanczos1 56 F do_polarization_lanczos iv 1 do_polarization_lanczos1 57 F do_polarization_lanczos iv 1 do_polarization_lanczos1 58 F do_polarization_lanczos iv 1 do_polarization_lanczos1 59 F do_polarization_lanczos iv 1 do_polarization_lanczos1 60 F do_polarization_lanczos iv 1 do_polarization_lanczos1 61 F do_polarization_lanczos iv 1 do_polarization_lanczos1 62 F do_polarization_lanczos iv 1 do_polarization_lanczos1 63 F do_polarization_lanczos iv 1 Call go_dressed_w 0 Read polaw 101 call calculate_w 0 INV EPSI G=0,G=0 -0.930954522762334 0.6899269623975546 INV EPSI G=0,G=0 -0.9309582623784023 0.6899269623975546 INV EPSI G=0,G=0 -0.9309435592169932 0.6899269623975546 1 Read polaw 101 call calculate_w 1 INV EPSI G=0,G=0 -0.9309308411725703 0.6899269623975546 INV EPSI G=0,G=0 -0.9309333970700664 0.6899269623975546 INV EPSI G=0,G=0 -0.9309211538576957 0.6899269623975546 2 Read polaw 101 call calculate_w 2 INV EPSI G=0,G=0 -0.9307383380181771 0.6899269623975546 INV EPSI G=0,G=0 -0.9307421577191846 0.6899269623975546 INV EPSI G=0,G=0 -0.9307286637322114 0.6899269623975546 3 Read polaw 101 call calculate_w 3 INV EPSI G=0,G=0 -0.9303549170961413 0.6899269623975546 INV EPSI G=0,G=0 -0.9303589154663172 0.6899269623975546 INV EPSI G=0,G=0 -0.9303450247291526 0.6899269623975546 4 Read polaw 101 call calculate_w 4 INV EPSI G=0,G=0 -0.929782041591936 0.6899269623975546 INV EPSI G=0,G=0 -0.9297860710746919 0.6899269623975546 INV EPSI G=0,G=0 -0.9297718790962506 0.6899269623975546 5 Read polaw 101 call calculate_w 5 INV EPSI G=0,G=0 -0.9290221719973718 0.6899269623975546 INV EPSI G=0,G=0 -0.9290262107936957 0.6899269623975546 INV EPSI G=0,G=0 -0.9290116949554548 0.6899269623975546 6 Read polaw 101 call calculate_w 6 INV EPSI G=0,G=0 -0.9280784628203759 0.6899269623975546 INV EPSI G=0,G=0 -0.9280825122004106 0.6899269623975546 INV EPSI G=0,G=0 -0.9280676358571621 0.6899269623975546 7 Read polaw 101 call calculate_w 7 INV EPSI G=0,G=0 -0.9269546387963447 0.6899269623975546 INV EPSI G=0,G=0 -0.9269587040713495 0.6899269623975546 INV EPSI G=0,G=0 -0.9269434340748537 0.6899269623975546 8 Read polaw 101 call calculate_w 8 INV EPSI G=0,G=0 -0.9256548846441123 0.6899269623975546 INV EPSI G=0,G=0 -0.925658971079785 0.6899269623975546 INV EPSI G=0,G=0 -0.9256432792514036 0.6899269623975546 9 Read polaw 101 call calculate_w 9 INV EPSI G=0,G=0 -0.9241837373801571 0.6899269623975546 INV EPSI G=0,G=0 -0.9241878494268765 0.6899269623975546 INV EPSI G=0,G=0 -0.924171711465616 0.6899269623975546 10 Read polaw 101 call calculate_w 10 INV EPSI G=0,G=0 -0.9225459847946753 0.6899269623975546 INV EPSI G=0,G=0 -0.9225501260635871 0.6899269623975546 INV EPSI G=0,G=0 -0.9225335205458295 0.6899269623975546 11 Read polaw 101 call calculate_w 11 INV EPSI G=0,G=0 -0.9207465744411859 0.6899269623975546 INV EPSI G=0,G=0 -0.9207507478135735 0.6899269623975546 INV EPSI G=0,G=0 -0.9207336556046604 0.6899269623975546 12 Read polaw 101 call calculate_w 12 INV EPSI G=0,G=0 -0.9187905358930616 0.6899269623975546 INV EPSI G=0,G=0 -0.9187947436266198 0.6899269623975546 INV EPSI G=0,G=0 -0.9187771475908 0.6899269623975546 13 Read polaw 101 call calculate_w 13 INV EPSI G=0,G=0 -0.916682917258239 0.6899269623975546 INV EPSI G=0,G=0 -0.9166871610700194 0.6899269623975546 INV EPSI G=0,G=0 -0.9166690459451095 0.6899269623975546 14 Read polaw 101 call calculate_w 14 INV EPSI G=0,G=0 -0.9144287355650967 0.6899269623975546 INV EPSI G=0,G=0 -0.9144330166955665 0.6899269623975546 INV EPSI G=0,G=0 -0.9144143690442128 0.6899269623975546 15 Read polaw 101 call calculate_w 15 INV EPSI G=0,G=0 -0.9120329397330874 0.6899269623975546 INV EPSI G=0,G=0 -0.912037258998113 0.6899269623975546 INV EPSI G=0,G=0 -0.9120180671867388 0.6899269623975546 16 Read polaw 101 call calculate_w 16 INV EPSI G=0,G=0 -0.9095003843676459 0.6899269623975546 INV EPSI G=0,G=0 -0.909504742203206 0.6899269623975546 INV EPSI G=0,G=0 -0.9094849963843255 0.6899269623975546 17 Read polaw 101 call calculate_w 17 INV EPSI G=0,G=0 -0.9068358124686616 0.6899269623975546 INV EPSI G=0,G=0 -0.9068402089710303 0.6899269623975546 INV EPSI G=0,G=0 -0.9068199010583547 0.6899269623975546 18 Read polaw 101 call calculate_w 18 INV EPSI G=0,G=0 -0.9040438452085559 0.6899269623975546 INV EPSI G=0,G=0 -0.9040482801713197 0.6899269623975546 INV EPSI G=0,G=0 -0.9040274038042294 0.6899269623975546 19 Read polaw 101 call calculate_w 19 INV EPSI G=0,G=0 -0.9011289771276466 0.6899269623975546 INV EPSI G=0,G=0 -0.9011334500761428 0.6899269623975546 INV EPSI G=0,G=0 -0.901112000573535 0.6899269623975546 20 Read polaw 101 call calculate_w 20 INV EPSI G=0,G=0 -0.8980955753416058 0.6899269623975546 INV EPSI G=0,G=0 -0.8981000855649782 0.6899269623975546 INV EPSI G=0,G=0 -0.8980780598699606 0.6899269623975546 21 Read polaw 101 call calculate_w 21 INV EPSI G=0,G=0 -0.8965357546562762 0.6899269623975546 INV EPSI G=0,G=0 -0.8965402831848953 0.6899269623975546 INV EPSI G=0,G=0 -0.8965179687379613 0.6899269623975546 22 Read polaw 101 call calculate_w 22 INV EPSI G=0,G=0 -0.8949478816118921 0.6899269623975546 INV EPSI G=0,G=0 -0.8949524281928083 0.6899269623975546 INV EPSI G=0,G=0 -0.8949298248101605 0.6899269623975546 23 Read polaw 101 call calculate_w 23 INV EPSI G=0,G=0 -0.8916900163678776 0.6899269623975546 INV EPSI G=0,G=0 -0.8916945982099006 0.6899269623975546 INV EPSI G=0,G=0 -0.8916714171382074 0.6899269623975546 24 Read polaw 101 call calculate_w 24 INV EPSI G=0,G=0 -0.8883259839758649 0.6899269623975546 INV EPSI G=0,G=0 -0.8883305998284906 0.6899269623975546 INV EPSI G=0,G=0 -0.8883068424886305 0.6899269623975546 25 Read polaw 101 call calculate_w 25 INV EPSI G=0,G=0 -0.8848596787215256 0.6899269623975546 INV EPSI G=0,G=0 -0.8848643272029294 0.6899269623975546 INV EPSI G=0,G=0 -0.8848399963643208 0.6899269623975546 26 Read polaw 101 call calculate_w 26 INV EPSI G=0,G=0 -0.88129489111002 0.6899269623975546 INV EPSI G=0,G=0 -0.8812995707275896 0.6899269623975546 INV EPSI G=0,G=0 -0.8812746704333371 0.6899269623975546 27 Read polaw 101 call calculate_w 27 INV EPSI G=0,G=0 -0.8776353141963292 0.6899269623975546 INV EPSI G=0,G=0 -0.8776400233650964 0.6899269623975546 INV EPSI G=0,G=0 -0.8776145588569286 0.6899269623975546 28 Read polaw 101 call calculate_w 28 INV EPSI G=0,G=0 -0.8738845497421015 0.6899269623975546 INV EPSI G=0,G=0 -0.8738892868012017 0.6899269623975546 INV EPSI G=0,G=0 -0.8738632644449024 0.6899269623975546 29 Read polaw 101 call calculate_w 29 INV EPSI G=0,G=0 -0.8700461140594155 0.6899269623975546 INV EPSI G=0,G=0 -0.8700508772867283 0.6899269623975546 INV EPSI G=0,G=0 -0.8700243044985951 0.6899269623975546 30 Read polaw 101 call calculate_w 30 INV EPSI G=0,G=0 -0.8661234434505242 0.6899269623975546 INV EPSI G=0,G=0 -0.8661282310756424 0.6899269623975546 INV EPSI G=0,G=0 -0.8661011162503826 0.6899269623975546 31 Read polaw 101 call calculate_w 31 INV EPSI G=0,G=0 -0.8621198991893038 0.6899269623975546 INV EPSI G=0,G=0 -0.8621247094049935 0.6899269623975546 INV EPSI G=0,G=0 -0.8620970618453561 0.6899269623975546 32 Read polaw 101 call calculate_w 32 INV EPSI G=0,G=0 -0.8159910393570851 0.6899269623975546 INV EPSI G=0,G=0 -0.8159959752962156 0.6899269623975546 INV EPSI G=0,G=0 -0.8159634696116518 0.6899269623975546 33 Read polaw 101 call calculate_w 33 INV EPSI G=0,G=0 -0.7161577744485843 0.6899269623975546 INV EPSI G=0,G=0 -0.7161624594827998 0.6899269623975546 INV EPSI G=0,G=0 -0.7161253468180604 0.6899269623975546 34 Read polaw 101 call calculate_w 34 INV EPSI G=0,G=0 -0.6146730369553146 0.6899269623975546 INV EPSI G=0,G=0 -0.6146770879480935 0.6899269623975546 INV EPSI G=0,G=0 -0.6146408397483161 0.6899269623975546 35 Read polaw 101 call calculate_w 35 INV EPSI G=0,G=0 -0.5216187081886885 0.6899269623975546 INV EPSI G=0,G=0 -0.5216220246598207 0.6899269623975546 INV EPSI G=0,G=0 -0.5215898059702304 0.6899269623975546 36 Read polaw 101 call calculate_w 36 INV EPSI G=0,G=0 -0.4410949061888514 0.6899269623975546 INV EPSI G=0,G=0 -0.44109754947832125 0.6899269623975546 INV EPSI G=0,G=0 -0.4410704550881137 0.6899269623975546 37 Read polaw 101 call calculate_w 37 INV EPSI G=0,G=0 -0.3735768267975498 0.6899269623975546 INV EPSI G=0,G=0 -0.3735789152197079 0.6899269623975546 INV EPSI G=0,G=0 -0.3735568240667383 0.6899269623975546 38 Read polaw 101 call calculate_w 38 INV EPSI G=0,G=0 -0.3178344017684558 0.6899269623975546 INV EPSI G=0,G=0 -0.3178360548084369 0.6899269623975546 INV EPSI G=0,G=0 -0.31781832234322926 0.6899269623975546 39 Read polaw 101 call calculate_w 39 INV EPSI G=0,G=0 -0.27207794807352215 0.6899269623975546 INV EPSI G=0,G=0 -0.2720792660741088 0.6899269623975546 INV EPSI G=0,G=0 -0.27206511935925826 0.6899269623975546 40 Read polaw 101 call calculate_w 40 INV EPSI G=0,G=0 -0.23451533656373136 0.6899269623975546 INV EPSI G=0,G=0 -0.23451639760514065 0.6899269623975546 INV EPSI G=0,G=0 -0.2345051150150912 0.6899269623975546 41 Read polaw 101 call calculate_w 41 INV EPSI G=0,G=0 -0.20357108237634436 0.6899269623975546 INV EPSI G=0,G=0 -0.20357194532587441 0.6899269623975546 INV EPSI G=0,G=0 -0.2035629180800087 0.6899269623975546 42 Read polaw 101 call calculate_w 42 INV EPSI G=0,G=0 -0.1779405541521255 0.6899269623975546 INV EPSI G=0,G=0 -0.17794126297171242 0.6899269623975546 INV EPSI G=0,G=0 -0.17793400210360455 0.6899269623975546 43 Read polaw 101 call calculate_w 43 INV EPSI G=0,G=0 -0.15657474627681112 0.6899269623975546 INV EPSI G=0,G=0 -0.15657533386418998 0.6899269623975546 INV EPSI G=0,G=0 -0.1565694562205071 0.6899269623975546 44 Read polaw 101 call calculate_w 44 INV EPSI G=0,G=0 -0.13864185560960984 0.6899269623975546 INV EPSI G=0,G=0 -0.1386423467801423 0.6899269623975546 INV EPSI G=0,G=0 -0.1386375555968561 0.6899269623975546 45 Read polaw 101 call calculate_w 45 INV EPSI G=0,G=0 -0.12348578777594177 0.6899269623975546 INV EPSI G=0,G=0 -0.12348620145045042 0.6899269623975546 INV EPSI G=0,G=0 -0.12348226782525773 0.6899269623975546 46 Read polaw 101 call calculate_w 46 INV EPSI G=0,G=0 -0.11058917528318857 0.6899269623975546 INV EPSI G=0,G=0 -0.11058952605766281 0.6899269623975546 INV EPSI G=0,G=0 -0.11058627337402582 0.6899269623975546 47 Read polaw 101 call calculate_w 47 INV EPSI G=0,G=0 -0.09954293109422874 0.6899269623975546 INV EPSI G=0,G=0 -0.09954323035986079 0.6899269623975546 INV EPSI G=0,G=0 -0.0995405219289921 0.6899269623975546 48 Read polaw 101 call calculate_w 48 INV EPSI G=0,G=0 -0.09002212942409826 0.6899269623975546 INV EPSI G=0,G=0 -0.09002238616936364 0.6899269623975546 INV EPSI G=0,G=0 -0.0900201157072873 0.6899269623975546 49 Read polaw 101 call calculate_w 49 INV EPSI G=0,G=0 -0.08176726444842186 0.6899269623975546 INV EPSI G=0,G=0 -0.0817674858383971 0.6899269623975546 INV EPSI G=0,G=0 -0.08176557023438014 0.6899269623975546 50 Read polaw 101 call calculate_w 50 INV EPSI G=0,G=0 -0.07456981880717173 0.6899269623975546 INV EPSI G=0,G=0 -0.07457001060662727 0.6899269623975546 INV EPSI G=0,G=0 -0.07456838446716374 0.6899269623975546 51 Read polaw 101 call calculate_w 51 INV EPSI G=0,G=0 -0.06826118512234525 0.6899269623975546 INV EPSI G=0,G=0 -0.06826135200850891 0.6899269623975546 INV EPSI G=0,G=0 -0.06825996354760155 0.6899269623975546 52 Read polaw 101 call calculate_w 52 INV EPSI G=0,G=0 -0.06270415724140666 0.6899269623975546 INV EPSI G=0,G=0 -0.0627043030380463 0.6899269623975546 INV EPSI G=0,G=0 -0.06270311097731374 0.6899269623975546 53 Read polaw 101 call calculate_w 53 INV EPSI G=0,G=0 -0.05778637734879222 0.6899269623975546 INV EPSI G=0,G=0 -0.05778650520351514 0.6899269623975546 INV EPSI G=0,G=0 -0.05778547642635523 0.6899269623975546 54 Read polaw 101 call calculate_w 54 INV EPSI G=0,G=0 -0.053415268640779834 0.6899269623975546 INV EPSI G=0,G=0 -0.05341538116083622 0.6899269623975546 INV EPSI G=0,G=0 -0.05341448892929823 0.6899269623975546 55 Read polaw 101 call calculate_w 55 INV EPSI G=0,G=0 -0.04951409737523882 0.6899269623975546 INV EPSI G=0,G=0 -0.049514196732656335 0.6899269623975546 INV EPSI G=0,G=0 -0.049513419324986985 0.6899269623975546 56 Read polaw 101 call calculate_w 56 INV EPSI G=0,G=0 -0.04601889591206221 0.6899269623975546 INV EPSI G=0,G=0 -0.046018983925808166 0.6899269623975546 INV EPSI G=0,G=0 -0.04601830358956993 0.6899269623975546 57 Read polaw 101 call calculate_w 57 INV EPSI G=0,G=0 -0.04287604476161411 0.6899269623975546 INV EPSI G=0,G=0 -0.042876122962383856 0.6899269623975546 INV EPSI G=0,G=0 -0.04287552510532544 0.6899269623975546 58 Read polaw 101 call calculate_w 58 INV EPSI G=0,G=0 -0.040040361436580296 0.6899269623975546 INV EPSI G=0,G=0 -0.0400404311182907 0.6899269623975546 INV EPSI G=0,G=0 -0.040039903679244926 0.6899269623975546 59 Read polaw 101 call calculate_w 59 INV EPSI G=0,G=0 -0.03747358108260601 0.6899269623975546 INV EPSI G=0,G=0 -0.03747364334363268 0.6899269623975546 INV EPSI G=0,G=0 -0.03747317630046898 0.6899269623975546 60 Read polaw 101 call calculate_w 60 INV EPSI G=0,G=0 -0.03514314162054777 0.6899269623975546 INV EPSI G=0,G=0 -0.035143197396951376 0.6899269623975546 INV EPSI G=0,G=0 -0.035142782379473325 0.6899269623975546 61 Read polaw 101 call calculate_w 61 INV EPSI G=0,G=0 -0.03302120688927224 0.6899269623975546 INV EPSI G=0,G=0 -0.03302125698176106 0.6899269623975546 INV EPSI G=0,G=0 -0.033020886965366536 0.6899269623975546 62 Read polaw 101 call calculate_w 62 INV EPSI G=0,G=0 -0.031083876844613667 0.6899269623975546 INV EPSI G=0,G=0 -0.03108392194052223 0.6899269623975546 INV EPSI G=0,G=0 -0.031083591002448174 0.6899269623975546 63 Read polaw 101 call calculate_w 63 INV EPSI G=0,G=0 -0.02931054558975532 0.6899269623975546 INV EPSI G=0,G=0 -0.029310586281073525 0.6899269623975546 INV EPSI G=0,G=0 -0.02931028940534197 0.6899269623975546 Trasform W to Pgreek Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Done ******************************* RESTART FROM POINT 6 ******************************* Routine do_self_lanczos_time Lanczos dimensions 386 40 1 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Read polaw 101 Fourier trasform Pgreek Loop on KS: 1 1 Fourier trasform: Products in imaginary time: Loop on KS: 2 1 Fourier trasform: Products in imaginary time: Loop on KS: 3 1 Fourier trasform: Products in imaginary time: Loop on KS: 4 1 Fourier trasform: Products in imaginary time: Loop on KS: 5 1 Fourier trasform: Products in imaginary time: Loop on KS: 6 1 Fourier trasform: Products in imaginary time: Loop on KS: 7 1 Fourier trasform: Products in imaginary time: Loop on KS: 8 1 Fourier trasform: Products in imaginary time: Loop on KS: 9 1 Fourier trasform: Products in imaginary time: Loop on KS: 10 1 Fourier trasform: Products in imaginary time: Loop on KS: 11 1 Fourier trasform: Products in imaginary time: Loop on KS: 12 1 Fourier trasform: Products in imaginary time: Loop on KS: 13 1 Fourier trasform: Products in imaginary time: Loop on KS: 14 1 Fourier trasform: Products in imaginary time: Loop on KS: 15 1 Fourier trasform: Products in imaginary time: Loop on KS: 16 1 Fourier trasform: Products in imaginary time: Loop on KS: 17 1 Fourier trasform: Products in imaginary time: Loop on KS: 18 1 Fourier trasform: Products in imaginary time: Loop on KS: 19 1 Fourier trasform: Products in imaginary time: Loop on KS: 20 1 Fourier trasform: Products in imaginary time: Loop on KS: 21 1 Fourier trasform: Products in imaginary time: Loop on KS: 22 1 Fourier trasform: Products in imaginary time: Loop on KS: 23 1 Fourier trasform: Products in imaginary time: Loop on KS: 24 1 Fourier trasform: Products in imaginary time: Loop on KS: 25 1 Fourier trasform: Products in imaginary time: Loop on KS: 26 1 Fourier trasform: Products in imaginary time: Loop on KS: 27 1 Fourier trasform: Products in imaginary time: Loop on KS: 28 1 Fourier trasform: Products in imaginary time: Loop on KS: 29 1 Fourier trasform: Products in imaginary time: Loop on KS: 30 1 Fourier trasform: Products in imaginary time: Loop on KS: 31 1 Fourier trasform: Products in imaginary time: Loop on KS: 32 1 Fourier trasform: Products in imaginary time: Call fit_multipole a_0 (0.,0.) a (0.009999999776482582,0.) (0.019999999552965164,0.) b (-0.5,-0.009999999776482582) (1.,-0.009999999776482582) z,s (0.,0.1666666716337204) (0.14822238757677983,-0.03644417047626431) (-0.001614434534243439,-0.009708741989780289) z,s (0.,10.083333015441895) (0.006375266969757287,-0.106257895955215) (-0.0001454505572673048,-0.0029505723811431095) Grad a_0 (-4.9547867147297655,17.39916200488121) Grad a (-6.95144003430716,-1.145989323680728) Grad a (-2.5130192279694326,-3.6897106461096394) Routine fit_multipole: chi1 > chi0 Routine fit_multipole: chi1 > chi0 Routine fit_multipole: maxiter reached 0.029349327120344736 Done Calling minpack Allocated Chi0 initial: 0.029349327120344736 INFO : 2 0.00001 Minpack fit chi0 : 0.00015425426763544797 Done FIT state : 1 1 FIT a_0: (-0.034035988046462115,0.0035142505688871128) FIT a: 1 (0.4804120004725168,0.3421856176997529) FIT b: 1 (-1.669423377005128,-0.45717039705991946) FIT a: 2 (0.8151516580630014,0.3004638666499571) FIT b: 2 (4.295461637755818,-1.529246961841686) Call fit_multipole a_0 (0.,0.) a (0.009999999776482582,0.) (0.019999999552965164,0.) b (-0.5,-0.009999999776482582) (1.,-0.009999999776482582) z,s (0.,0.1666666716337204) (0.11742796575925069,-0.03923560693567372) (-0.001614434534243439,-0.009708741989780289) z,s (0.,10.083333015441895) (-0.0016996462937081598,-0.10888843939074877) (-0.0001454505572673048,-0.0029505723811431095) Grad a_0 (-2.389258347147106,17.98664987932665) Grad a (-6.703312826975753,-0.03603512205048043) Grad a (-3.2004633293057374,-3.0800628254387794) Routine fit_multipole: chi1 > chi0 Routine fit_multipole: chi1 > chi0 Routine fit_multipole: maxiter reached 0.022451477208486743 Done Calling minpack Allocated Chi0 initial: 0.022451477208486743 INFO : 2 0.00001 Minpack fit chi0 : 0.00009858976910634618 Done FIT state : 2 1 FIT a_0: (-0.023115415807386228,0.0030557581458940256) FIT a: 1 (0.45861230795797703,0.2912932721799506) FIT b: 1 (-1.5522826058711159,-0.40909481687761035) FIT a: 2 (0.8984268787118401,0.12981443625911687) FIT b: 2 (3.9099290014171313,-1.492562309199855) Call fit_multipole a_0 (0.,0.) a (0.009999999776482582,0.) (0.019999999552965164,0.) b (-0.5,-0.009999999776482582) (1.,-0.009999999776482582) z,s (0.,0.1666666716337204) (0.11791572122987874,-0.03930648014733877) (-0.001614434534243439,-0.009708741989780289) z,s (0.,10.083333015441895) (-0.0016923589949937728,-0.10904086580741008) (-0.0001454505572673048,-0.0029505723811431095) Grad a_0 (-2.406780798955858,18.018338305077346) Grad a (-6.719654316605027,-0.0425616933477282) Grad a (-3.2024791970695645,-3.09030528357678) Routine fit_multipole: chi1 > chi0 Routine fit_multipole: chi1 > chi0 Routine fit_multipole: maxiter reached 0.02277304744123414 Done Calling minpack Allocated Chi0 initial: 0.02277304744123414 INFO : 2 0.00001 Minpack fit chi0 : 0.00009680851270347481 Done FIT state : 3 1 FIT a_0: (-0.022809407059091936,0.002950651324006208) FIT a: 1 (0.4622917303194509,0.29078337036062507) FIT b: 1 (-1.557573143760482,-0.408583290498453) FIT a: 2 (0.8960014026355723,0.12379635413753698) FIT b: 2 (3.890455542232985,-1.489167380415369) Call fit_multipole a_0 (0.,0.) a (0.009999999776482582,0.) (0.019999999552965164,0.) b (-0.5,-0.009999999776482582) (1.,-0.009999999776482582) z,s (0.,0.1666666716337204) (0.11739553506275649,-0.03925568440178375) (-0.001614434534243439,-0.009708741989780289) z,s (0.,10.083333015441895) (-0.0016951942958244412,-0.1089959020894779) (-0.0001454505572673048,-0.0029505723811431095) Grad a_0 (-2.3930484305522466,18.003600469435003) Grad a (-6.708390665497497,-0.03637380273371921) Grad a (-3.2037262435765212,-3.0829410927421868) Routine fit_multipole: chi1 > chi0 Routine fit_multipole: chi1 > chi0 Routine fit_multipole: maxiter reached 0.0232370610206251 Done Calling minpack Allocated Chi0 initial: 0.0232370610206251 INFO : 2 0.00001 Minpack fit chi0 : 0.00009342516532190384 Done FIT state : 4 1 FIT a_0: (-0.022213855704904653,0.001347062469644266) FIT a: 1 (0.4638950393267678,0.2827131528385965) FIT b: 1 (-1.5666186507265916,-0.39916388235389855) FIT a: 2 (0.8699448794596087,0.1155598458362041) FIT b: 2 (3.8480709392925894,-1.4275936758924719) Call fit_multipole a_0 (0.,0.) a (0.009999999776482582,0.) (0.019999999552965164,0.) b (-0.5,-0.009999999776482582) (1.,-0.009999999776482582) z,s (0.,0.1666666716337204) (0.11722068545242811,-0.03919937050811998) (-0.001614434534243439,-0.009708741989780289) z,s (0.,10.083333015441895) (-0.0016986786693177652,-0.10890735955284285) (-0.0001454505572673048,-0.0029505723811431095) Grad a_0 (-2.3877764106397783,17.988668042285873) Grad a (-6.702069234874897,-0.035062694835812154) Grad a (-3.201879698370107,-3.0793178316449743) Routine fit_multipole: chi1 > chi0 Routine fit_multipole: chi1 > chi0 Routine fit_multipole: maxiter reached 0.02238773261762263 Done Calling minpack Allocated Chi0 initial: 0.02238773261762263 INFO : 2 0.00001 Minpack fit chi0 : 0.00009264962581739675 Done FIT state : 5 1 FIT a_0: (-0.02239571463127718,0.0030514785065951853) FIT a: 1 (0.46245631189000025,0.2914898178724074) FIT b: 1 (-1.5583211115176991,-0.4117509123563229) FIT a: 2 (0.8980560947572963,0.11717644079967766) FIT b: 2 (3.8745811434402717,-1.5009326459312562) Call fit_multipole a_0 (0.,0.) a (0.009999999776482582,0.) (0.019999999552965164,0.) b (-0.5,-0.009999999776482582) (1.,-0.009999999776482582) z,s (0.,0.1666666716337204) (0.11723390270018737,-0.039205268543577386) (-0.001614434534243439,-0.009708741989780289) z,s (0.,10.083333015441895) (-0.0016962758183402225,-0.10900355306896901) (-0.0001454505572673048,-0.0029505723811431095) Grad a_0 (-2.3869331816912087,18.00423611518679) Grad a (-6.706221534219101,-0.03360176034874195) Grad a (-3.2057084445164605,-3.0805698990721573) Routine fit_multipole: chi1 > chi0 Routine fit_multipole: chi1 > chi0 Routine fit_multipole: maxiter reached 0.022157171505665145 Done Calling minpack Allocated Chi0 initial: 0.022157171505665145 INFO : 2 0.00001 Minpack fit chi0 : 0.00008734006458917338 Done FIT state : 6 1 FIT a_0: (-0.021655213778342456,0.0028707515277791858) FIT a: 1 (0.4672691442334978,0.2909317960478336) FIT b: 1 (-1.5656668252708457,-0.4140582115023568) FIT a: 2 (0.8944413712803796,0.1041333241667421) FIT b: 2 (3.836191310733113,-1.4973079718335196) Call fit_multipole a_0 (0.,0.) a (0.009999999776482582,0.) (0.019999999552965164,0.) b (-0.5,-0.009999999776482582) (1.,-0.009999999776482582) z,s (0.,0.1666666716337204) (0.11718911908935853,-0.03916211379361507) (-0.001614434534243439,-0.009708741989780289) z,s (0.,10.083333015441895) (-0.0016878989974540824,-0.10892040701611022) (-0.0001454505572673048,-0.0029505723811431095) Grad a_0 (-2.387323871660594,17.98891299883535) Grad a (-6.701763335190157,-0.03471933885704229) Grad a (-3.202231663779584,-3.0789818981806674) Routine fit_multipole: chi1 > chi0 Routine fit_multipole: chi1 > chi0 Routine fit_multipole: maxiter reached 0.023417339866392387 Done Calling minpack Allocated Chi0 initial: 0.023417339866392387 INFO : 2 0.00001 Minpack fit chi0 : 0.00007606715290067789 Done FIT state : 7 1 FIT a_0: (-0.01991116929076973,0.0010487968543119574) FIT a: 1 (0.475601338911836,0.2812031227114902) FIT b: 1 (-1.5845903926698353,-0.40657653370439495) FIT a: 2 (0.8622878401004548,0.07702690301424549) FIT b: 2 (3.7379536280625323,-1.4406801492852428) Call fit_multipole a_0 (0.,0.) a (0.009999999776482582,0.) (0.019999999552965164,0.) b (-0.5,-0.009999999776482582) (1.,-0.009999999776482582) z,s (0.,0.1666666716337204) (0.10240519341074251,-0.043388950109198306) (-0.001614434534243439,-0.009708741989780289) z,s (0.,10.083333015441895) (-0.00970145609919128,-0.10541296651032901) (-0.0001454505572673048,-0.0029505723811431095) Grad a_0 (0.052269450114592546,17.662116681615604) Grad a (-6.381204958881783,0.9479855598488618) Grad a (-3.597950284776105,-2.4648130152297907) Routine fit_multipole: chi1 > chi0 Routine fit_multipole: chi1 > chi0 Routine fit_multipole: maxiter reached 0.016711986375727596 Done Calling minpack Allocated Chi0 initial: 0.016711986375727596 INFO : 2 0.00001 Minpack fit chi0 : 0.00004533384301652409 Done FIT state : 8 1 FIT a_0: (-0.01301631928357916,0.006929402887842249) FIT a: 1 (0.3901775778027951,0.24029920010168296) FIT b: 1 (-1.3028701164523708,-0.34948159638164616) FIT a: 2 (1.019904144010858,0.01212187776473826) FIT b: 2 (3.9104657792905426,-1.7757037728575076) Call fit_multipole a_0 (0.,0.) a (0.009999999776482582,0.) (0.019999999552965164,0.) b (-0.5,-0.009999999776482582) (1.,-0.009999999776482582) z,s (0.,0.1666666716337204) (0.10219328883866237,-0.043477811257523945) (-0.001614434534243439,-0.009708741989780289) z,s (0.,10.083333015441895) (-0.00972353627738431,-0.10542230098667098) (-0.0001454505572673048,-0.0029505723811431095) Grad a_0 (0.06724041462761196,17.66488510181507) Grad a (-6.378999296408325,0.9562039669590394) Grad a (-3.6028274190666916,-2.4611768975029986) Routine fit_multipole: chi1 > chi0 Routine fit_multipole: chi1 > chi0 Routine fit_multipole: maxiter reached 0.016779421358565177 Done Calling minpack Allocated Chi0 initial: 0.016779421358565177 INFO : 2 0.00001 Minpack fit chi0 : 0.00004550279109644961 Done FIT state : 9 1 FIT a_0: (-0.012885062438345876,0.006962556697090245) FIT a: 1 (0.3901782256076771,0.24042016447773845) FIT b: 1 (-1.3021085163217672,-0.35035444013316064) FIT a: 2 (1.021002578660465,0.00998657150445051) FIT b: 2 (3.90518560715603,-1.7777144228295751) Call fit_multipole a_0 (0.,0.) a (0.009999999776482582,0.) (0.019999999552965164,0.) b (-0.5,-0.009999999776482582) (1.,-0.009999999776482582) z,s (0.,0.1666666716337204) (0.10282672756987371,-0.043416061851289725) (-0.001614434534243439,-0.009708741989780289) z,s (0.,10.083333015441895) (-0.00970393683008988,-0.10531344591245266) (-0.0001454505572673048,-0.0029505723811431095) Grad a_0 (0.044232038563691484,17.654578711499777) Grad a (-6.384892908993063,0.9429962870876255) Grad a (-3.5931962897840277,-2.468183490640755) Routine fit_multipole: chi1 > chi0 Routine fit_multipole: chi1 > chi0 Routine fit_multipole: maxiter reached 0.017261201373982554 Done Calling minpack Allocated Chi0 initial: 0.017261201373982554 INFO : 2 0.00001 Minpack fit chi0 : 0.000042329191955371046 Done FIT state : 10 1 FIT a_0: (-0.012019943387864095,0.007423302031798727) FIT a: 1 (0.39439888797449013,0.2433612060970558) FIT b: 1 (-1.3058859742524085,-0.3566764822458207) FIT a: 2 (1.027481186834314,-0.006728868481765771) FIT b: 2 (3.8710918398232286,-1.8147137504615403) Call fit_multipole a_0 (0.,0.) a (0.009999999776482582,0.) (0.019999999552965164,0.) b (-0.5,-0.009999999776482582) (1.,-0.009999999776482582) z,s (0.,0.1666666716337204) (0.10262396912965033,-0.04348001939815623) (-0.001614434534243439,-0.009708741989780289) z,s (0.,10.083333015441895) (-0.009669900828044866,-0.10537420427863434) (-0.0001454505572673048,-0.0029505723811431095) Grad a_0 (0.04436785383063861,17.662822723669287) Grad a (-6.384440682526617,0.9461603105418699) Grad a (-3.5970114804386952,-2.4680299882633743) Routine fit_multipole: chi1 > chi0 Routine fit_multipole: chi1 > chi0 Routine fit_multipole: maxiter reached 0.016012914626106663 Done Calling minpack Allocated Chi0 initial: 0.016012914626106663 INFO : 2 0.00001 Minpack fit chi0 : 0.000042666807477976825 Done FIT state : 11 1 FIT a_0: (-0.012506401891438876,0.006588500196298813) FIT a: 1 (0.3935686856431439,0.23969664738488933) FIT b: 1 (-1.308020120555618,-0.3514352772223142) FIT a: 2 (1.012238651670212,0.00166344206524323) FIT b: 2 (3.874512219722166,-1.7656580512226703) Call fit_multipole a_0 (0.,0.) a (0.009999999776482582,0.) (0.019999999552965164,0.) b (-0.5,-0.009999999776482582) (1.,-0.009999999776482582) z,s (0.,0.1666666716337204) (0.10191616724561027,-0.043460814147296176) (-0.001614434534243439,-0.009708741989780289) z,s (0.,10.083333015441895) (-0.009693911191077827,-0.10532277585429456) (-0.0001454505572673048,-0.0029505723811431095) Grad a_0 (0.06695413740587194,17.650881854911912) Grad a (-6.371812850943171,0.9573267988675597) Grad a (-3.6018099658825236,-2.458523361373046) Routine fit_multipole: chi1 > chi0 Routine fit_multipole: chi1 > chi0 Routine fit_multipole: maxiter reached 0.016231330489394083 Done Calling minpack Allocated Chi0 initial: 0.016231330489394083 INFO : 2 0.00001 Minpack fit chi0 : 0.000044633888114499766 Done FIT state : 12 1 FIT a_0: (-0.012818414939676469,0.006698036442941457) FIT a: 1 (0.3907787436541169,0.23983541659450702) FIT b: 1 (-1.304085659442401,-0.3510726214078914) FIT a: 2 (1.0147312781111373,0.007561854748838391) FIT b: 2 (3.8887869152188115,-1.7636850106377822) Call fit_multipole a_0 (0.,0.) a (0.009999999776482582,0.) (0.019999999552965164,0.) b (-0.5,-0.009999999776482582) (1.,-0.009999999776482582) z,s (0.,0.1666666716337204) (0.103837312375969,-0.043527410944230134) (-0.001614434534243439,-0.009708741989780289) z,s (0.,10.083333015441895) (-0.009671590309884851,-0.10530207311685957) (-0.0001454505572673048,-0.0029505723811431095) Grad a_0 (0.013225672365778205,17.668155542478242) Grad a (-6.403160867747332,0.9289536628214012) Grad a (-3.5869017625795094,-2.4822156595293743) Routine fit_multipole: chi1 > chi0 Routine fit_multipole: chi1 > chi0 Routine fit_multipole: maxiter reached 0.016680288255838765 Done Calling minpack Allocated Chi0 initial: 0.016680288255838765 INFO : 2 0.00001 Minpack fit chi0 : 0.00004223179719073243 Done FIT state : 13 1 FIT a_0: (-0.01226030953909138,0.006807600162590998) FIT a: 1 (0.3963425046449491,0.2393208243998102) FIT b: 1 (-1.3110300277971991,-0.34995193201667374) FIT a: 2 (1.012502702876901,-0.0024166309804082944) FIT b: 2 (3.8694522609804416,-1.7771029309262265) Call fit_multipole a_0 (0.,0.) a (0.009999999776482582,0.) (0.019999999552965164,0.) b (-0.5,-0.009999999776482582) (1.,-0.009999999776482582) z,s (0.,0.1666666716337204) (0.1358245377339818,-0.04926237350170841) (-0.001614434534243439,-0.009708741989780289) z,s (0.,10.083333015441895) (-0.013015301785141127,-0.10985628628958696) (-0.0001454505572673048,-0.0029505723811431095) Grad a_0 (0.5839282622703383,18.419348351203602) Grad a (-6.875593940082038,1.1201422277213386) Grad a (-3.7058441424909856,-2.5151198544596896) Routine fit_multipole: chi1 > chi0 Routine fit_multipole: chi1 > chi0 Routine fit_multipole: maxiter reached 0.016415663504698027 Done Calling minpack Allocated Chi0 initial: 0.016415663504698027 INFO : 2 0.00001 Minpack fit chi0 : 0.00004203254495861768 Done FIT state : 14 1 FIT a_0: (-0.013666941527849264,0.00005001595185037498) FIT a: 1 (0.4043961908361368,0.20484788464086406) FIT b: 1 (-1.201358050101447,-0.31671759684101297) FIT a: 2 (0.9345452972585466,0.030420441566491655) FIT b: 2 (4.113046123708077,-1.2914326030072407) Call fit_multipole a_0 (0.,0.) a (0.009999999776482582,0.) (0.019999999552965164,0.) b (-0.5,-0.009999999776482582) (1.,-0.009999999776482582) z,s (0.,0.1666666716337204) (0.13592772404895606,-0.049292876777580735) (-0.001614434534243439,-0.009708741989780289) z,s (0.,10.083333015441895) (-0.013046574045622103,-0.10977790370122857) (-0.0001454505572673048,-0.0029505723811431095) Grad a_0 (0.5882264203982479,18.412766093579293) Grad a (-6.87531248765845,1.120968541460189) Grad a (-3.7047138200631267,-2.5144339352955156) Routine fit_multipole: chi1 > chi0 Routine fit_multipole: chi1 > chi0 Routine fit_multipole: maxiter reached 0.016909117866788833 Done Calling minpack Allocated Chi0 initial: 0.016909117866788833 INFO : 2 0.00001 Minpack fit chi0 : 0.000044525469696884446 Done FIT state : 15 1 FIT a_0: (-0.013923506214420015,0.0005943728842939975) FIT a: 1 (0.40318530895153315,0.20557921840747342) FIT b: 1 (-1.1987378869455128,-0.3163715784308973) FIT a: 2 (0.9410532734943463,0.03622302283385106) FIT b: 2 (4.137711256409133,-1.30077752596412) Call fit_multipole a_0 (0.,0.) a (0.009999999776482582,0.) (0.019999999552965164,0.) b (-0.5,-0.009999999776482582) (1.,-0.009999999776482582) z,s (0.,0.1666666716337204) (0.1357958563049163,-0.04920886923184545) (-0.001614434534243439,-0.009708741989780289) z,s (0.,10.083333015441895) (-0.012920018944299186,-0.10973212931321383) (-0.0001454505572673048,-0.0029505723811431095) Grad a_0 (0.566877116000863,18.39028787228962) Grad a (-6.866401586306749,1.1124423873305973) Grad a (-3.696643006853439,-2.5147113543592483) Routine fit_multipole: chi1 > chi0 Routine fit_multipole: chi1 > chi0 Routine fit_multipole: maxiter reached 0.016704311775339944 Done Calling minpack Allocated Chi0 initial: 0.016704311775339944 INFO : 2 0.00001 Minpack fit chi0 : 0.000040415802421251385 Done FIT state : 16 1 FIT a_0: (-0.013532466823814607,-0.00024921934014079673) FIT a: 1 (0.4039765455896989,0.20465037718458093) FIT b: 1 (-1.2015720497317819,-0.3177090127700842) FIT a: 2 (0.9302049607563571,0.028382514711022176) FIT b: 2 (4.104592094867384,-1.2890484408260632) Out of create_self_energy_fit value, zeta: 1 (0.4943952148384264,0.03787852777117307) (-0.6802912154067343,-0.2996208781197531) 1 XC-DFT energy 1 -0.7679509363297908 H-DFT energy 1 3.235720382037882 (3.2357204475186956,0.) GW-PERT energy 1 -5.531223377741176 Iteration energy 1 (0.4842493829325708,0.019045022431681546) Iteration energy 2 (0.48470585073195105,0.01883147651842275) Iteration energy 3 (0.48433951984781143,0.018862416723017153) Iteration energy 4 (0.4845980064086237,0.018933725513345268) Iteration energy 5 (0.48443910010809443,0.018819661603552043) Iteration energy 6 (0.4845190514639238,0.01893783113685886) Iteration energy 7 (0.48449416994730116,0.018836773658631525) Iteration energy 8 (0.48448568759507055,0.018912213657521743) Iteration energy 9 (0.4845105385280925,0.01886272744870203) Iteration energy 10 (0.48448103905783957,0.018890320543197434) value, zeta: 2 (0.32142375806569534,-0.0016292368782249156) (-0.5161556369367698,-0.09230095568106036) 1 XC-DFT energy 2 -0.7936247979553683 H-DFT energy 2 4.186704075955013 (4.186704264093924,0.) GW-PERT energy 2 -1.9659554790063967 Iteration energy 1 (0.3319276361339076,0.00026504972060080456) Iteration energy 2 (0.33185698686843834,0.0001844441495086474) Iteration energy 3 (0.33188613195920286,0.00023469034797317379) Iteration energy 4 (0.33187588567807597,0.00020492441982078446) Iteration energy 5 (0.33187822334484784,0.00022182390794163453) Iteration energy 6 (0.3318787466288939,0.00021259296248510307) Iteration energy 7 (0.3318775035556173,0.00021744700291001506) Iteration energy 8 (0.3318786719301979,0.00021499570562476256) Iteration energy 9 (0.33187779441576737,0.00021617711121039995) Iteration energy 10 (0.3318783845310017,0.00021564059497344856) value, zeta: 3 (0.32170264938751614,-0.001486321903371654) (-0.5146674516710584,-0.09162435131004866) 1 XC-DFT energy 3 -0.7936247978925728 H-DFT energy 3 4.18670407319588 (4.186704264093924,0.) GW-PERT energy 3 -1.9636568161255126 Iteration energy 1 (0.33209389664121136,0.00033574410734572846) Iteration energy 2 (0.33202433467916004,0.0002582317850874094) Iteration energy 3 (0.3320531849278381,0.0003065215372067276) Iteration energy 4 (0.3320428915463573,0.0002779358911493002) Iteration energy 5 (0.33204538856744914,0.00029415477686277336) Iteration energy 6 (0.3320457441703724,0.0002852986485902126) Iteration energy 7 (0.33204463875534374,0.0002899564547345773) Iteration energy 8 (0.33204570698347247,0.00028760181219861236) Iteration energy 9 (0.332044896929424,0.00028873940573787005) Iteration energy 10 (0.33204544411866954,0.00028822023890133497) value, zeta: 4 (0.31924244830777887,-0.001781603966595699) (-0.5093730538974678,-0.08639975031533415) 1 XC-DFT energy 4 -0.7936247019333617 H-DFT energy 4 4.186706320825397 (4.18670629150001,0.) GW-PERT energy 4 -1.986915515607385 Iteration energy 1 (0.33040882996583276,0.00018798639171675735) Iteration energy 2 (0.3303281564952776,0.00009978325726878179) Iteration energy 3 (0.33036186424059744,0.0001541544376036097) Iteration energy 4 (0.33034951397610823,0.00012222164107847378) Iteration energy 5 (0.3303528511283764,0.000140239154395691) Iteration energy 6 (0.3303528783029218,0.00013043228051569378) Iteration energy 7 (0.3303518938814213,0.00013558776150586482) Iteration energy 8 (0.33035292166951397,0.00013297349782689927) Iteration energy 9 (0.3303521224646001,0.0001342468607253705) Iteration energy 10 (0.330352668792928,0.00013365616609588293) value, zeta: 5 (0.32079971241120686,-0.0011008063409329166) (-0.5130366593227728,-0.09311654811507797) 1 XC-DFT energy 5 -0.7936247020095932 H-DFT energy 5 4.186706322786992 (4.18670629150001,0.) GW-PERT energy 5 -1.971798978680049 Iteration energy 1 (0.3315068680332994,0.0006501438302171231) Iteration energy 2 (0.33143180274481054,0.0005697241356540095) Iteration energy 3 (0.3314630502487317,0.0006201607000640846) Iteration energy 4 (0.33145182806373225,0.000590192764691827) Iteration energy 5 (0.3314546114551281,0.0006072258568183969) Iteration energy 6 (0.3314549312760916,0.0005979228607188997) Iteration energy 7 (0.3314537832993504,0.000602810305851742) Iteration energy 8 (0.3314549047877585,0.0006003457373597726) Iteration energy 9 (0.3314540522359567,0.0006015314463252291) Iteration energy 10 (0.33145462797168057,0.0006009939324800179) value, zeta: 6 (0.320336729584479,-0.00030301546293352855) (-0.50942186126463,-0.09413712179133382) 1 XC-DFT energy 6 -0.7936247016270466 H-DFT energy 6 4.186706312702618 (4.18670629150001,0.) GW-PERT energy 6 -1.9761554440651898 Iteration energy 1 (0.3311956176266089,0.0012074209971742467) Iteration energy 2 (0.3311158054485849,0.0011296651128935992) Iteration energy 3 (0.3311495283359317,0.0011789884892806773) Iteration energy 4 (0.3311370240130188,0.0011494892792883182) Iteration energy 5 (0.3311404738735101,0.0011663202339712853) Iteration energy 6 (0.33114044254761865,0.0011571073304698226) Iteration energy 7 (0.33113948352544054,0.0011619536484987342) Iteration energy 8 (0.3311405008114239,0.0011595076069019217) Iteration energy 9 (0.3311397070523087,0.0011606857170011198) Iteration energy 10 (0.33114024905523615,0.0011601504605541352) value, zeta: 7 (0.3178660076527986,0.00046140609082667705) (-0.499949360954247,-0.09031534279417311) 1 XC-DFT energy 7 -0.7936244253820617 H-DFT energy 7 4.1867085366084895 (4.186708724387313,0.) GW-PERT energy 7 -1.9999163532382007 Iteration energy 1 (0.32947979994351473,0.0017798491800784383) Iteration energy 2 (0.3293853843255694,0.0016986996640512009) Iteration energy 3 (0.3294259615628911,0.0017503125749887966) Iteration energy 4 (0.32941022994358893,0.001719469283531866) Iteration energy 5 (0.329415224664278,0.0017370319865785966) Iteration energy 6 (0.32941443129215664,0.0017274355434317434) Iteration energy 7 (0.3294138632416346,0.0017324817426845052) Iteration energy 8 (0.3294146717281071,0.0017299287165806199) Iteration energy 9 (0.32941399307403707,0.0017311672359475727) Iteration energy 10 (0.3294144705100289,0.0017305956174253206) value, zeta: 8 (0.17716152211712557,-0.01066711351236585) (-0.3966303252206216,0.007192643572979104) 1 XC-DFT energy 8 -0.7766137518722036 H-DFT energy 8 3.491464472844262 (3.491464547136077,0.) GW-PERT energy 8 2.715802183754657 Iteration energy 1 (0.19175100153195548,-0.007475590883036634) Iteration energy 2 (0.19163361470848475,-0.0076223876681359715) Iteration energy 3 (0.19168127948393548,-0.007560358894976721) Iteration energy 4 (0.1916619467251724,-0.007586555790457167) Iteration energy 5 (0.1916697800247154,-0.0075754987732395) Iteration energy 6 (0.19166660974246397,-0.007580163077338914) Iteration energy 7 (0.19166789129722217,-0.007578196576292134) Iteration energy 8 (0.19166737389766958,-0.007579025223224817) Iteration energy 9 (0.19166758250640378,-0.007578676229816603) Iteration energy 10 (0.19166749851841733,-0.0075788231370351455) value, zeta: 9 (0.1770597587555538,-0.010539796293779796) (-0.3970336683021156,0.006648853223679831) 1 XC-DFT energy 9 -0.776613752305674 H-DFT energy 9 3.4914644877893473 (3.491464547136077,0.) GW-PERT energy 9 2.714903804023291 Iteration energy 1 (0.1916873992909899,-0.00736830808791171) Iteration energy 2 (0.19156906847343338,-0.007515547121877422) Iteration energy 3 (0.1916170931378046,-0.007453190430571202) Iteration energy 4 (0.19159762668861582,-0.007479583229785425) Iteration energy 5 (0.19160550796264766,-0.007468420179539095) Iteration energy 6 (0.19160232130787008,-0.007473138704043106) Iteration energy 7 (0.1916036080149028,-0.007471145487128572) Iteration energy 8 (0.1916030892313572,-0.007471986957391763) Iteration energy 9 (0.19160329807134377,-0.007471631927979325) Iteration energy 10 (0.1916032141422688,-0.007471781633618321) value, zeta: 10 (0.17813397724309038,-0.010421656725356651) (-0.3975221433107613,0.004401550540292669) 1 XC-DFT energy 10 -0.7766137518562396 H-DFT energy 10 3.4914644723243833 (3.491464547136077,0.) GW-PERT energy 10 2.725357937169083 Iteration energy 1 (0.19243803199413897,-0.007232882175292568) Iteration energy 2 (0.19232774229317118,-0.007375444217698063) Iteration energy 3 (0.1923721353396097,-0.007314899617866313) Iteration energy 4 (0.1923543023977589,-0.007340588052489827) Iteration energy 5 (0.19236145161678742,-0.007329699852318891) Iteration energy 6 (0.19235859190305513,-0.007334310534959268) Iteration energy 7 (0.1923597330626888,-0.0073323599230856185) Iteration energy 8 (0.19235927887988694,-0.007333184418512578) Iteration energy 9 (0.1923594591274855,-0.007332836219515221) Iteration energy 10 (0.19235938782004966,-0.007332983145759614) value, zeta: 11 (0.17748911986701615,-0.010167302796992114) (-0.3955569700048699,0.005407372482001092) 1 XC-DFT energy 11 -0.7766121364635084 H-DFT energy 11 3.4914484144041618 (3.4914483278873885,0.) GW-PERT energy 11 2.718476839744924 Iteration energy 1 (0.19194401490627264,-0.007088772156715967) Iteration energy 2 (0.19182845183677125,-0.007230519239955074) Iteration energy 3 (0.1918750357954812,-0.007170627612646557) Iteration energy 4 (0.19185628560774384,-0.007195914142329077) Iteration energy 5 (0.19186382168055913,-0.007185247174374215) Iteration energy 6 (0.19186079764545522,-0.007189743468116017) Iteration energy 7 (0.19186200906532097,-0.007187849674843566) Iteration energy 8 (0.19186152465885653,-0.007188646729089948) Iteration energy 9 (0.19186171797772933,-0.007188311510207518) Iteration energy 10 (0.19186164099066094,-0.0071884523947328555) value, zeta: 12 (0.17672332984539904,-0.010338918075938619) (-0.39607529813917225,0.005996382657536652) 1 XC-DFT energy 12 -0.7766121366059361 H-DFT energy 12 3.491448419285038 (3.4914483278873885,0.) GW-PERT energy 12 2.711244768356645 Iteration energy 1 (0.19142271757400217,-0.007214071255387783) Iteration energy 2 (0.19130264858408735,-0.007361226075615027) Iteration energy 3 (0.1913512028900173,-0.007298946405688414) Iteration energy 4 (0.19133159572773878,-0.007325286258938635) Iteration energy 5 (0.19133950280824724,-0.007314155375629447) Iteration energy 6 (0.19133631884986788,-0.007318855706914304) Iteration energy 7 (0.1913375989317045,-0.0073168723045971) Iteration energy 8 (0.19133708515530265,-0.007317708656928892) Iteration energy 9 (0.1913372909931977,-0.007317356228521754) Iteration energy 10 (0.19133720868757587,-0.007317504638825786) value, zeta: 13 (0.17875670520978312,-0.0101671247183793) (-0.3956876398804051,0.005582696152700628) 1 XC-DFT energy 13 -0.7766121365952099 H-DFT energy 13 3.4914484189288824 (3.4914483278873885,0.) GW-PERT energy 13 2.7308919152431548 Iteration energy 1 (0.19283953291562936,-0.007103660450076793) Iteration energy 2 (0.19273081122044172,-0.007238794118073877) Iteration energy 3 (0.19277464609496756,-0.007181825742524156) Iteration energy 4 (0.19275699652342243,-0.007205825927666484) Iteration energy 5 (0.192764093624262,-0.007195722590973078) Iteration energy 6 (0.1927612439230436,-0.007199972841182289) Iteration energy 7 (0.19276238643177668,-0.007198186087524025) Iteration energy 8 (0.19276192912117673,-0.007198936719074067) Iteration energy 9 (0.1927621118494284,-0.007198621576244804) Iteration energy 10 (0.19276203897346583,-0.007198753801424734) value, zeta: 14 (0.14683347719931272,-0.005190937546250815) (-0.34487441675759073,0.0122017999405643) 1 XC-DFT energy 14 -0.8265853015435485 H-DFT energy 14 5.263374843475083 (5.263374890827979,0.) GW-PERT energy 14 5.411237571950003 Iteration energy 1 (0.16434145191068383,-0.0039776563643044716) Iteration energy 2 (0.16414558029156354,-0.004097741215379341) Iteration energy 3 (0.16421770069507952,-0.00405371550825033) Iteration energy 4 (0.16419114568010593,-0.004069859475923018) Iteration energy 5 (0.16420092326155786,-0.004063940112007738) Iteration energy 6 (0.16419732315899224,-0.004066110546489171) Iteration energy 7 (0.16419864870882608,-0.004065314738735504) Iteration energy 8 (0.1641981606464742,-0.004065606525597093) Iteration energy 9 (0.16419834034830746,-0.0040654995420401074) Iteration energy 10 (0.16419827418340036,-0.004065538767034013) value, zeta: 15 (0.14680621693072565,-0.0052752262087884805) (-0.3453253607006216,0.012908862960123793) 1 XC-DFT energy 15 -0.8265853016739972 H-DFT energy 15 5.263374847259217 (5.263374890827979,0.) GW-PERT energy 15 5.411227812236415 Iteration energy 1 (0.1643433230766248,-0.0040621669653633785) Iteration energy 2 (0.1641459710626059,-0.004183010264582343) Iteration energy 3 (0.16421883031893633,-0.004138765932020269) Iteration energy 4 (0.16419193207054764,-0.004154967757818234) Iteration energy 5 (0.16420186217670385,-0.004149035574355614) Iteration energy 6 (0.16419819630998214,-0.004151207556007841) Iteration energy 7 (0.16419954960187183,-0.004150412365752351) Iteration energy 8 (0.16419905002916482,-0.004150703481319684) Iteration energy 9 (0.16419923444501144,-0.0041505969109108115) Iteration energy 10 (0.16419916636961712,-0.004150635921746637) value, zeta: 16 (0.14691848968748775,-0.005119872631854108) (-0.34433522739659894,0.011694988017093965) 1 XC-DFT energy 16 -0.8265853016282303 H-DFT energy 16 5.26337484888803 (5.263374890827979,0.) GW-PERT energy 16 5.41179981262583 Iteration energy 1 (0.1643806940235445,-0.0039092239636207005) Iteration energy 2 (0.1641860794303,-0.0040287924652988305) Iteration energy 3 (0.16425755715753834,-0.00398493456440617) Iteration energy 4 (0.16423130472512323,-0.004001025045946266) Iteration energy 5 (0.16424094671890913,-0.003995122266690826) Iteration energy 6 (0.16423740540444143,-0.003997287755033843) Iteration energy 7 (0.16423870605848018,-0.003996493334898404) Iteration energy 8 (0.16423822835433843,-0.003996784772688389) Iteration energy 9 (0.16423840380541438,-0.003996677857241199) Iteration energy 10 (0.1642383393658023,-0.003996717079702908) value, zeta: 17 (-0.3358523267078703,0.0029843084866602865) (-0.32582220188078614,-0.04434451569021092) 1 XC-DFT energy 17 -0.6696558184284294 H-DFT energy 17 -0.17655865048358635 (-0.17655864839708282,0.) GW-PERT energy 17 7.093356662306679 Iteration energy 1 (-0.34396711015256215,0.0013139314655825074) Iteration energy 2 (-0.3439410921231769,0.0013547263076982285) Iteration energy 3 (-0.3439476370871577,0.001339734965119202) Iteration energy 4 (-0.3439462393421405,0.0013450855207486206) Iteration energy 5 (-0.34394642489788996,0.0013432251726353678) Iteration energy 6 (-0.34394646071506957,0.0013438562099691714) Iteration energy 7 (-0.3439464155844242,0.001343647350579083) Iteration energy 8 (-0.34394644163456134,0.0013437147293195034) Iteration energy 9 (-0.34394642939320563,0.0013436935967009594) Iteration energy 10 (-0.3439464345921349,0.0013437000107356656) value, zeta: 18 (-0.33436979879301953,0.0033975912737270048) (-0.32686335893832547,-0.03776803079803004) 1 XC-DFT energy 18 -0.6696558184551326 H-DFT energy 18 -0.1765586496329225 (-0.17655864839708282,0.) GW-PERT energy 18 7.108353511925193 Iteration energy 1 (-0.34287895517848666,0.0017032619374231783) Iteration energy 2 (-0.34284794710927413,0.0017485754590709501) Iteration energy 3 (-0.34285625929258057,0.001731914927533773) Iteration energy 4 (-0.34285424077184834,0.001737897231317384) Iteration energy 5 (-0.34285464105157065,0.0017357940256796794) Iteration energy 6 (-0.34285460424734593,0.0017365190879862352) Iteration energy 7 (-0.342854582945695,0.0017362738269975225) Iteration energy 8 (-0.3428546014884317,0.001736355222386854) Iteration energy 9 (-0.3428545914806671,0.001736328742191276) Iteration energy 10 (-0.3428545960717946,0.001736337172367028) value, zeta: 19 (-0.3343789700516213,0.0027389746886350153) (-0.32301851732706793,-0.036599684135850095) 1 XC-DFT energy 19 -0.6696556378820301 H-DFT energy 19 -0.17656109155127972 (-0.17656109395567413,0.) GW-PERT energy 19 7.1090845663941336 Iteration energy 1 (-0.34283007849525354,0.0012408255247013111) Iteration energy 2 (-0.3427972476317321,0.0012828503346028614) Iteration energy 3 (-0.3428062758728327,0.0012674198475659537) Iteration energy 4 (-0.3428039665551164,0.0012729502830738093) Iteration energy 5 (-0.3428044864376274,0.0012710095690829648) Iteration energy 6 (-0.34280440051763106,0.0012716776022743126) Iteration energy 7 (-0.3428043991837445,0.0012714518128885688) Iteration energy 8 (-0.3428044097260524,0.0012715267691438548) Iteration energy 9 (-0.3428044028708404,0.0012715023373290057) Iteration energy 10 (-0.3428044062411947,0.001271510147897087) value, zeta: 20 (-0.3354242246709652,0.0030671889534843177) (-0.3259913642286805,-0.04588370688981755) 1 XC-DFT energy 20 -0.6696556378776299 H-DFT energy 20 -0.1765610921393172 (-0.17656109395567413,0.) GW-PERT energy 20 7.097739353946989 Iteration energy 1 (-0.3436456722532364,0.0013325858750995456) Iteration energy 2 (-0.3436197833322637,0.001374846347234962) Iteration energy 3 (-0.3436261388786889,0.0013593216186912616) Iteration energy 4 (-0.34362485832898,0.0013648535260824685) Iteration energy 5 (-0.3436249858453408,0.0013629357761871103) Iteration energy 6 (-0.3436250473553897,0.0013635834255007473) Iteration energy 7 (-0.3436249916442751,0.0013633703829669663) Iteration energy 8 (-0.34362502182348154,0.0013634385366777801) Iteration energy 9 (-0.3436250080404885,0.001363417404699141) Iteration energy 10 (-0.3436250137926738,0.0013634237166957053) value, zeta: 21 (-0.33611062743738485,0.0027988119758137198) (-0.32494841810039904,-0.045688186565990746) 1 XC-DFT energy 21 -0.6696556379390806 H-DFT energy 21 -0.1765610896590573 (-0.17656109395567413,0.) GW-PERT energy 21 7.090872435872805 Iteration energy 1 (-0.34414788629464177,0.0011593301428159536) Iteration energy 2 (-0.34412250029255276,0.0011989287979646268) Iteration energy 3 (-0.3441288240031062,0.0011843801300974455) Iteration energy 4 (-0.34412750065969294,0.0011895639700342797) Iteration energy 5 (-0.34412766260264616,0.0011877669012761854) Iteration energy 6 (-0.3441277052874618,0.0011883739306800395) Iteration energy 7 (-0.34412765844459325,0.0011881741180705535) Iteration energy 8 (-0.3441276847817177,0.0011882381265176517) Iteration energy 9 (-0.3441276725721041,0.0011882182310217343) Iteration energy 10 (-0.3441276777067223,0.0011882241987834496) value, zeta: 22 (-0.33695147490331745,0.0026235776679429113) (-0.3249033125448363,-0.051927795592955996) 1 XC-DFT energy 22 -0.6696551880030623 H-DFT energy 22 -0.17656755742229077 (-0.17656755631257345,0.) GW-PERT energy 22 7.082211791384708 Iteration energy 1 (-0.3447745835259766,0.0009416363855182935) Iteration energy 2 (-0.34475281714480843,0.000979302474276661) Iteration energy 3 (-0.3447577942162276,0.0009654867436746789) Iteration energy 4 (-0.3447569676241859,0.0009703743711572399) Iteration energy 5 (-0.3447569497214524,0.0009687011683284508) Iteration energy 6 (-0.34475705580543026,0.0009692559562464453) Iteration energy 7 (-0.3447569873605789,0.0009690779973274971) Iteration energy 8 (-0.34475702074915304,0.0009691330213495164) Iteration energy 9 (-0.34475700636401435,0.0009691167398664102) Iteration energy 10 (-0.3447570121173411,0.0009691212878771699) value, zeta: 23 (-0.3474090815112212,-0.0030048644642129696) (-0.3438559369081602,-0.05806223967394509) 1 XC-DFT energy 23 -0.738597513819375 H-DFT energy 23 2.2113987104484614 (2.2113986623704576,0.) GW-PERT energy 23 8.909971148596144 Iteration energy 1 (-0.35440844489597834,-0.0031267859458962988) Iteration energy 2 (-0.3543816566725157,-0.0031058034022072717) Iteration energy 3 (-0.35438973581698896,-0.003114889980387364) Iteration energy 4 (-0.3543874752747997,-0.003111179684992707) Iteration energy 5 (-0.3543880332444295,-0.003112628421577196) Iteration energy 6 (-0.35438792953336284,-0.0031120834638685146) Iteration energy 7 (-0.354387931216418,-0.0031122816793128782) Iteration energy 8 (-0.3543879432750075,-0.0031122118832226237) Iteration energy 9 (-0.35438793458098444,-0.0031122356525735695) Iteration energy 10 (-0.35438793915461775,-0.0031122278505956585) value, zeta: 24 (-0.3454926881265711,-0.0017247642586447898) (-0.3472700229091139,-0.049623980522745664) 1 XC-DFT energy 24 -0.7385975137390192 H-DFT energy 24 2.2113987073613273 (2.2113986623704576,0.) GW-PERT energy 24 8.929426666366028 Iteration energy 1 (-0.3529904782060858,-0.002113935489588256) Iteration energy 2 (-0.352959576340395,-0.0020873539746964626) Iteration energy 3 (-0.35296907961194723,-0.002098546987888819) Iteration energy 4 (-0.3529663265740218,-0.0020940307131317587) Iteration energy 5 (-0.352967052609338,-0.0020957922625901015) Iteration energy 6 (-0.3529668931696889,-0.0020951247037478554) Iteration energy 7 (-0.35296691242298217,-0.0020953711868840486) Iteration energy 8 (-0.35296691941057395,-0.002095282401983367) Iteration energy 9 (-0.352966911939584,-0.002095313601243584) Iteration energy 10 (-0.3529669163495439,-0.002095302919324679) value, zeta: 25 (-0.34778406692919817,-0.0037299081028907694) (-0.3407794908063575,-0.05957916801734384) 1 XC-DFT energy 25 -0.7385975137839579 H-DFT energy 25 2.211398709287317 (2.2113986623704576,0.) GW-PERT energy 25 8.906392526739669 Iteration energy 1 (-0.3546702940082557,-0.0036785188598814217) Iteration energy 2 (-0.3546438055172967,-0.003659952064512126) Iteration energy 3 (-0.3546518284328004,-0.00366814059402) Iteration energy 4 (-0.35464956500420824,-0.003664766754584367) Iteration energy 5 (-0.354650134497588,-0.003666089165039868) Iteration energy 6 (-0.3546500219586938,-0.003665591461046197) Iteration energy 7 (-0.3546500288485487,-0.0036657721673724053) Iteration energy 8 (-0.354650038182307,-0.003665708762428596) Iteration energy 9 (-0.354650030813255,-0.003665730246437862) Iteration energy 10 (-0.3546500347756746,-0.00366572323998135) value, zeta: 26 (-0.39813237346039626,-0.010033694039044215) (-0.34353135665771656,-0.0933302327643061) 1 XC-DFT energy 26 -0.7965792524959168 H-DFT energy 26 4.9504082856646985 (4.950408268134492,0.) GW-PERT energy 26 9.64541981397638 Iteration energy 1 (-0.4063519802281782,-0.008951527556393966) Iteration energy 2 (-0.40631326856909944,-0.008935830000148096) Iteration energy 3 (-0.4063253623311542,-0.00894516087609061) Iteration energy 4 (-0.4063220189337697,-0.008940686493370605) Iteration energy 5 (-0.40632275715319977,-0.0089425908651573) Iteration energy 6 (-0.40632268415931155,-0.008941847585251982) Iteration energy 7 (-0.4063226368721184,-0.008942116560330525) Iteration energy 8 (-0.40632267994434346,-0.008942026463060797) Iteration energy 9 (-0.4063226559244611,-0.008942053967970827) Iteration energy 10 (-0.40632266708628356,-0.008942046638893954) value, zeta: 27 (-0.434423699258775,0.02148484193533698) (-0.572819602782938,-0.055301509009775554) 1 XC-DFT energy 27 -0.5943495349827251 H-DFT energy 27 -2.5210012342390145 (-2.52100121014534,0.) GW-PERT energy 27 13.740456811749533 Iteration energy 1 (-0.43224213308715387,0.013889837549440093) Iteration energy 2 (-0.4322906719669322,0.013799267741004123) Iteration energy 3 (-0.4322704694087549,0.013853055814708803) Iteration energy 4 (-0.43227768993770044,0.013821750679671146) Iteration energy 5 (-0.43227600317711057,0.013839635160107944) Iteration energy 6 (-0.4322756156559914,0.01382959811956741) Iteration energy 7 (-0.4322765726514722,0.013835132378356096) Iteration energy 8 (-0.43227563301972216,0.013832135831262554) Iteration energy 9 (-0.43227637538308733,0.013833727153281211) Iteration energy 10 (-0.4322758462650993,0.013832900072793669) value, zeta: 28 (-0.39405900317089754,-0.02532824660987862) (-0.2791877171071631,-0.10851815626503636) 1 XC-DFT energy 28 -0.7396537793876615 H-DFT energy 28 2.0860140358629624 (2.086013935718454,0.) GW-PERT energy 28 14.46323973803433 Iteration energy 1 (-0.40663046708401085,-0.022735152349648145) Iteration energy 2 (-0.40653962557044565,-0.02271469400770029) Iteration energy 3 (-0.4065638306666664,-0.022731057284453533) Iteration energy 4 (-0.4065586286521563,-0.022723508362468874) Iteration energy 5 (-0.4065592856429896,-0.02272630895153356) Iteration energy 6 (-0.4065594138615224,-0.022725415488205374) Iteration energy 7 (-0.4065592742446804,-0.02272566190429487) Iteration energy 8 (-0.4065593432145891,-0.022725605862579108) Iteration energy 9 (-0.4065593166538526,-0.022725614352901758) Iteration energy 10 (-0.40655932538576833,-0.022725614908696543) value, zeta: 29 (-0.3950588961482357,-0.02445521416149776) (-0.28404061006479053,-0.10969332849153818) 1 XC-DFT energy 29 -0.7396537795150564 H-DFT energy 29 2.086014040231119 (2.086014138459063,0.) GW-PERT energy 29 14.451494004742461 Iteration energy 1 (-0.4074901349204639,-0.02193366070035085) Iteration energy 2 (-0.4073995717261526,-0.021911605899318173) Iteration energy 3 (-0.40742392845959663,-0.021928642605603364) Iteration energy 4 (-0.40741866332652943,-0.021920760514674013) Iteration energy 5 (-0.40741931535711684,-0.021923712139971865) Iteration energy 6 (-0.4074194633083261,-0.021922759602868932) Iteration energy 7 (-0.40741930907469515,-0.02192302551498819) Iteration energy 8 (-0.4074193856876033,-0.021922964356029487) Iteration energy 9 (-0.40741935584251326,-0.021922973659845905) Iteration energy 10 (-0.40741936578783344,-0.021922974350316655) value, zeta: 30 (-0.4662846353077639,-0.04715535908211864) (-0.29981422155191173,-0.14521573334708862) 1 XC-DFT energy 30 -0.7753825590660082 H-DFT energy 30 3.7752618740087365 (3.7752620675069313,0.) GW-PERT energy 30 16.323868010711486 Iteration energy 1 (-0.4766156611544451,-0.037734333164589046) Iteration energy 2 (-0.4765492927137422,-0.03782151607695142) Iteration energy 3 (-0.4765826259402226,-0.03780351467565397) Iteration energy 4 (-0.4765695597204127,-0.03780443378495485) Iteration energy 5 (-0.47657380662708576,-0.03780600676272519) Iteration energy 6 (-0.4765726930534062,-0.037804905896278884) Iteration energy 7 (-0.4765728869117071,-0.037805411406247644) Iteration energy 8 (-0.4765728979029847,-0.037805224535391244) Iteration energy 9 (-0.47657286780339997,-0.03780528183367804) Iteration energy 10 (-0.4765728854524015,-0.03780526807501339) value, zeta: 31 (-0.46612695773089063,-0.04758623325535655) (-0.2992343094685601,-0.14629001418162363) 1 XC-DFT energy 31 -0.7753825567229851 H-DFT energy 31 3.7752618049992956 (3.775261662025714,0.) GW-PERT energy 31 16.324623175252565 Iteration energy 1 (-0.4765620855823684,-0.03809865518210286) Iteration energy 2 (-0.47649426602728057,-0.038186453491664496) Iteration energy 3 (-0.4765282103225774,-0.03816858779976676) Iteration energy 4 (-0.4765149677436749,-0.03816932894306854) Iteration energy 5 (-0.4765192389327225,-0.0381709987108416) Iteration energy 6 (-0.47651813560390865,-0.03816985983857304) Iteration energy 7 (-0.47651831894636015,-0.038170376546817535) Iteration energy 8 (-0.4765183355335597,-0.038170187700366974) Iteration energy 9 (-0.4765183031811336,-0.03817024470792454) Iteration energy 10 (-0.47651832154733753,-0.03817023142821652) value, zeta: 32 (-0.465140688716042,-0.04703489976061457) (-0.2989244357029341,-0.14370754832542468) 1 XC-DFT energy 32 -0.7753781133758924 H-DFT energy 32 3.775229684682949 (3.775229629009554,0.) GW-PERT energy 32 16.33659246021179 Iteration energy 1 (-0.4756918755191992,-0.03775137628520996) Iteration energy 2 (-0.475622546458901,-0.03783723931981565) Iteration energy 3 (-0.47565645023068426,-0.037820053543841964) Iteration energy 4 (-0.4756433720400279,-0.03782066589891494) Iteration energy 5 (-0.4756475672626158,-0.037822320042831724) Iteration energy 6 (-0.47564648280043537,-0.037821208025893255) Iteration energy 7 (-0.47564666649829296,-0.03782171050574239) Iteration energy 8 (-0.47564667973210606,-0.03782152670487057) Iteration energy 9 (-0.47564664962321185,-0.03782158258111771) Iteration energy 10 (-0.4756466669718122,-0.03782156927760449) QUASI-PARTICLES ENERGIES IN Ev, Spin: 1 1 State: 1DFT : -5.83560 GW-PERT : -5.53122 GW : -5.53468 HF-pert : -12.12638 State: 2DFT : -1.69356 GW-PERT : -1.96596 GW : -1.96449 HF-pert : -6.47993 State: 3DFT : -1.69356 GW-PERT : -1.96366 GW : -1.96222 HF-pert : -6.47993 State: 4DFT : -1.69355 GW-PERT : -1.98692 GW : -1.98525 HF-pert : -6.47993 State: 5DFT : -1.69355 GW-PERT : -1.97180 GW : -1.97026 HF-pert : -6.47993 State: 6DFT : -1.69355 GW-PERT : -1.97616 GW : -1.97453 HF-pert : -6.47993 State: 7DFT : -1.69354 GW-PERT : -1.99992 GW : -1.99801 HF-pert : -6.47992 State: 8DFT : 3.20443 GW-PERT : 2.71580 GW : 2.71860 HF-pert : 0.11083 State: 9DFT : 3.20443 GW-PERT : 2.71490 GW : 2.71772 HF-pert : 0.11083 State: 10DFT : 3.20443 GW-PERT : 2.72536 GW : 2.72801 HF-pert : 0.11083 State: 11DFT : 3.20444 GW-PERT : 2.71848 GW : 2.72125 HF-pert : 0.11084 State: 12DFT : 3.20444 GW-PERT : 2.71124 GW : 2.71412 HF-pert : 0.11084 State: 13DFT : 3.20444 GW-PERT : 2.73089 GW : 2.73350 HF-pert : 0.11084 State: 14DFT : 6.07889 GW-PERT : 5.41124 GW : 5.41653 HF-pert : 3.18250 State: 15DFT : 6.07889 GW-PERT : 5.41123 GW : 5.41654 HF-pert : 3.18250 State: 16DFT : 6.07889 GW-PERT : 5.41180 GW : 5.41707 HF-pert : 3.18250 State: 17DFT : 6.75583 GW-PERT : 7.09336 GW : 7.09235 HF-pert : 11.77198 State: 18DFT : 6.75583 GW-PERT : 7.10835 GW : 7.10720 HF-pert : 11.77198 State: 19DFT : 6.75583 GW-PERT : 7.10908 GW : 7.10789 HF-pert : 11.77198 State: 20DFT : 6.75583 GW-PERT : 7.09774 GW : 7.09672 HF-pert : 11.77198 State: 21DFT : 6.75583 GW-PERT : 7.09087 GW : 7.08988 HF-pert : 11.77198 State: 22DFT : 6.75583 GW-PERT : 7.08221 GW : 7.08132 HF-pert : 11.77198 State: 23DFT : 8.64344 GW-PERT : 8.90997 GW : 8.90910 HF-pert : 13.73080 State: 24DFT : 8.64344 GW-PERT : 8.92943 GW : 8.92844 HF-pert : 13.73080 State: 25DFT : 8.64344 GW-PERT : 8.90639 GW : 8.90554 HF-pert : 13.73080 State: 26DFT : 9.35741 GW-PERT : 9.64542 GW : 9.64427 HF-pert : 15.17258 State: 27DFT : 13.77167 GW-PERT : 13.74046 GW : 13.74146 HF-pert : 19.62287 State: 28DFT : 13.98536 GW-PERT : 14.46324 GW : 14.46022 HF-pert : 19.99174 State: 29DFT : 13.98536 GW-PERT : 14.45149 GW : 14.44852 HF-pert : 19.99174 State: 30DFT : 16.10896 GW-PERT : 16.32387 GW : 16.32348 HF-pert : 22.80759 State: 31DFT : 16.10896 GW-PERT : 16.32462 GW : 16.32423 HF-pert : 22.80759 State: 32DFT : 16.10901 GW-PERT : 16.33659 GW : 16.33610 HF-pert : 22.80760 IMAGINARY ENERGIES IN Ev: State: 1 GW (Im) : 0.25702 State: 2 GW (Im) : 0.00293 State: 3 GW (Im) : 0.00392 State: 4 GW (Im) : 0.00182 State: 5 GW (Im) : 0.00818 State: 6 GW (Im) : 0.01578 State: 7 GW (Im) : 0.02355 State: 8 GW (Im) : -0.10312 State: 9 GW (Im) : -0.10166 State: 10 GW (Im) : -0.09977 State: 11 GW (Im) : -0.09780 State: 12 GW (Im) : -0.09956 State: 13 GW (Im) : -0.09794 State: 14 GW (Im) : -0.05531 State: 15 GW (Im) : -0.05647 State: 16 GW (Im) : -0.05438 State: 17 GW (Im) : 0.01828 State: 18 GW (Im) : 0.02362 State: 19 GW (Im) : 0.01730 State: 20 GW (Im) : 0.01855 State: 21 GW (Im) : 0.01617 State: 22 GW (Im) : 0.01319 State: 23 GW (Im) : -0.04234 State: 24 GW (Im) : -0.02851 State: 25 GW (Im) : -0.04987 State: 26 GW (Im) : -0.12166 State: 27 GW (Im) : 0.18821 State: 28 GW (Im) : -0.30920 State: 29 GW (Im) : -0.29828 State: 30 GW (Im) : -0.51437 State: 31 GW (Im) : -0.51933 State: 32 GW (Im) : -0.51459 Stopping MPI environment GWW/examples/example02/reference/si_pw4gww.out0000644000077300007730000006146512341332532022060 0ustar giannozzgiannozz Program PW4GWW v.4.3.2 starts on 16Sep2011 at 15:41:11 This program is part of the open-source Quantum ESPRESSO suite for quantum simulation of materials; please cite "P. Giannozzi et al., J. Phys.:Condens. Matter 21 395502 (2009); URL http://www.quantum-espresso.org", in publications or presentations arising from this work. More details at http://www.quantum-espresso.org/quote.php Parallel version (MPI), running on 2 processors R & G space division: proc/pool = 2 Info: using nr1, nr2, nr3 values from input Info: using nr1s, nr2s, nr3s values from input IMPORTANT: XC functional enforced from input : Exchange-correlation = SLA PZ NOGX NOGC ( 1 1 0 0 0) EXX-fraction = 0.00 Any further DFT definition will be discarded Please, verify this is what you really want ATT1.1.1 ATT1.1.2 ATT1.1.3 ATT1.1.4 ATT1.1.5 ATT1.1.6 Parallelization info -------------------- sticks: dense smooth PW G-vecs: dense smooth PW Min 247 247 60 4191 4191 508 Max 250 250 61 4194 4194 513 Sum 497 497 121 8385 8385 1021 Tot 249 249 61 IMPORTANT: XC functional enforced from input : Exchange-correlation = SLA PZ NOGX NOGC ( 1 1 0 0 0) EXX-fraction = 0.00 Any further DFT definition will be discarded Please, verify this is what you really want EXX fraction changed: 0.00 EXX Screening parameter changed: 0.0000000 nkstot= 1 after first init after g stuff after wfc waves after davcio bravais-lattice index = 8 lattice parameter (alat) = 10.2600 a.u. unit-cell volume = 1080.0456 (a.u.)^3 number of atoms/cell = 8 number of atomic types = 1 number of electrons = 32.00 number of Kohn-Sham states= 32 kinetic-energy cutoff = 15.0000 Ry charge density cutoff = 60.0000 Ry Exchange-correlation = SLA PZ NOGX NOGC ( 1 1 0 0 0) EXX-fraction = 0.00 celldm(1)= 10.260000 celldm(2)= 1.000000 celldm(3)= 1.000000 celldm(4)= 0.000000 celldm(5)= 0.000000 celldm(6)= 0.000000 crystal axes: (cart. coord. in units of alat) a(1) = ( 1.000000 0.000000 0.000000 ) a(2) = ( 0.000000 1.000000 0.000000 ) a(3) = ( 0.000000 0.000000 1.000000 ) reciprocal axes: (cart. coord. in units 2 pi/alat) b(1) = ( 1.000000 0.000000 0.000000 ) b(2) = ( 0.000000 1.000000 0.000000 ) b(3) = ( 0.000000 0.000000 1.000000 ) PseudoPot. # 1 for Si read from file: ./Si.pz-vbc.UPF MD5 check sum: 6dfa03ddd5817404712e03e4d12deb78 Pseudo is Norm-conserving, Zval = 4.0 Generated by new atomic code, or converted to UPF format Using radial grid of 431 points, 2 beta functions with: l(1) = 0 l(2) = 1 atomic species valence mass pseudopotential Si 4.00 1.00000 Si( 1.00) No symmetry found Cartesian axes site n. atom positions (alat units) 1 Si tau( 1) = ( 0.0000000 0.0000000 0.0000000 ) 2 Si tau( 2) = ( 0.5000000 0.5000000 0.0000000 ) 3 Si tau( 3) = ( 0.0000000 0.5000000 0.5000000 ) 4 Si tau( 4) = ( 0.5000000 0.0000000 0.5000000 ) 5 Si tau( 5) = ( 0.2500000 0.2500000 0.2500000 ) 6 Si tau( 6) = ( 0.7500000 0.7500000 0.2500000 ) 7 Si tau( 7) = ( 0.7500000 0.2500000 0.7500000 ) 8 Si tau( 8) = ( 0.2500000 0.7500000 0.7500000 ) number of k points= 1 cart. coord. in units 2pi/alat k( 1) = ( 0.0000000 0.0000000 0.0000000), wk = 2.0000000 Dense grid: 4193 G-vectors FFT dimensions: ( 25, 25, 25) k = 0.0000 0.0000 0.0000 band energies (ev): -5.8356 -1.6936 -1.6936 -1.6935 -1.6935 -1.6935 -1.6935 3.2044 3.2044 3.2044 3.2044 3.2044 3.2044 6.0789 6.0789 6.0789 6.7558 6.7558 6.7558 6.7558 6.7558 6.7558 8.6434 8.6434 8.6434 9.3574 13.7717 13.9854 13.9854 16.1090 16.1090 16.1090 highest occupied, lowest unoccupied level (ev): 6.0789 6.7558 MAX_NGM: 257 2096 BG1 1. 0. 0. BG2 0. 1. 0. BG3 0. 0. 1. KS energy: 1 -5.8356033220326715 KS energy: 2 -1.6935558290694306 KS energy: 3 -1.6935558290694286 KS energy: 4 -1.6935489410967548 KS energy: 5 -1.693548941096752 KS energy: 6 -1.6935489410967537 KS energy: 7 -1.6935357123402044 KS energy: 8 3.2044284987117218 KS energy: 9 3.2044284987117164 KS energy: 10 3.2044284987117204 KS energy: 11 3.2044411658343046 KS energy: 12 3.2044411658343073 KS energy: 13 3.2044411658343046 KS energy: 14 6.078888770939703 KS energy: 15 6.078888770939716 KS energy: 16 6.078888770939716 KS energy: 17 6.755825924332917 KS energy: 18 6.755825924332914 KS energy: 19 6.755828472912578 KS energy: 20 6.755828472912574 KS energy: 21 6.755828472912568 KS energy: 22 6.7558347917461745 KS energy: 23 8.643435545841141 KS energy: 24 8.643435545841163 KS energy: 25 8.643435545841164 KS energy: 26 9.357414965881647 KS energy: 27 13.771672441221629 KS energy: 28 13.98535828161839 KS energy: 29 13.985358281618696 KS energy: 30 16.10896393535077 KS energy: 31 16.108963940160056 KS energy: 32 16.1090118777345 Routine energies_xc : 1 -10.44850385724432 Routine energies_xc : 2 -10.7978145091816 Routine energies_xc : 3 -10.797814508327225 Routine energies_xc : 4 -10.797813202735759 Routine energies_xc : 5 -10.797813203772943 Routine energies_xc : 6 -10.79781319856813 Routine energies_xc : 7 -10.797809440063968 Routine energies_xc : 8 -10.566367456762904 Routine energies_xc : 9 -10.566367462660569 Routine energies_xc : 10 -10.566367456545704 Routine energies_xc : 11 -10.566345478009856 Routine energies_xc : 12 -10.566345479947683 Routine energies_xc : 13 -10.566345479801747 Routine energies_xc : 14 -11.24626496686803 Routine energies_xc : 15 -11.246264968642874 Routine energies_xc : 16 -11.246264968020183 Routine energies_xc : 17 -9.111130764831543 Routine energies_xc : 18 -9.11113076519486 Routine energies_xc : 19 -9.111128308372855 Routine energies_xc : 20 -9.111128308312988 Routine energies_xc : 21 -9.111128309149066 Routine energies_xc : 22 -9.111122187458214 Routine energies_xc : 23 -10.049130233469361 Routine energies_xc : 24 -10.049130232376065 Routine energies_xc : 25 -10.049130232987487 Routine energies_xc : 26 -10.838011907482208 Routine energies_xc : 27 -8.086536671857779 Routine energies_xc : 28 -10.06350145738799 Routine energies_xc : 29 -10.063501459121285 Routine energies_xc : 30 -10.549616226735079 Routine energies_xc : 31 -10.549616194856629 Routine energies_xc : 32 -10.549555740044946 Routine energies_h : 1 3.235720382037882 Routine energies_h : 2 4.186704075955013 Routine energies_h : 3 4.18670407319588 Routine energies_h : 4 4.186706320825397 Routine energies_h : 5 4.186706322786992 Routine energies_h : 6 4.186706312702618 Routine energies_h : 7 4.1867085366084895 Routine energies_h : 8 3.491464472844262 Routine energies_h : 9 3.4914644877893473 Routine energies_h : 10 3.4914644723243833 Routine energies_h : 11 3.4914484144041618 Routine energies_h : 12 3.491448419285038 Routine energies_h : 13 3.4914484189288824 Routine energies_h : 14 5.263374843475083 Routine energies_h : 15 5.263374847259217 Routine energies_h : 16 5.26337484888803 Routine energies_h : 17 -0.17655865048358635 Routine energies_h : 18 -0.1765586496329225 Routine energies_h : 19 -0.17656109155127972 Routine energies_h : 20 -0.1765610921393172 Routine energies_h : 21 -0.1765610896590573 Routine energies_h : 22 -0.17656755742229077 Routine energies_h : 23 2.2113987104484614 Routine energies_h : 24 2.2113987073613273 Routine energies_h : 25 2.211398709287317 Routine energies_h : 26 4.9504082856646985 Routine energies_h : 27 -2.5210012342390145 Routine energies_h : 28 2.0860140358629624 Routine energies_h : 29 2.086014040231119 Routine energies_h : 30 3.7752618740087365 Routine energies_h : 31 3.7752618049992956 Routine energies_h : 32 3.775229684682949 stop_clock: clock # 12 for h_psi not running Transform to real wfcs MATRIX BIG1 NRS 25 25 25 NRXS 25 25 25 Calculate grid MATRIX BIG2 MATRIX IIW 1 MATRIX JJW 1 Calculate US Out of matrix_wannier_gamma_big LOCALIZING WANNIER FUNCTIONS: 24.81538497893445 Spread 174.05691050008613 24.81538497893445 32 16 Spread 268.99207233149474 174.05691050008613 32 16 Spread 295.2878829540973 268.99207233149474 32 16 Spread 295.7508574649272 295.2878829540973 32 16 Spread 295.75284395478855 295.7508574649272 32 16 Spread 295.7528496113602 295.75284395478855 32 16 Spread 295.7528496254997 295.7528496113602 32 16 Spread 295.75284962552126 295.7528496254997 32 16 Center Wannier: 8.977495767232838 6.4124994284654475 6.4124994284654475 Center Wannier: 6.412499429907659 6.4124994311053864 6.4124994311053864 Center Wannier: 1.2824965413775125 1.282496535806233 1.282496535806233 Center Wannier: 8.977503464016207 1.2824965390045142 1.2824965390045142 Center Wannier: 3.8475005692369324 6.412499429416136 6.412499429416136 Center Wannier: 1.2825042253244352 3.8475005704944425 3.8475005704944425 Center Wannier: 6.4124994298070925 8.977495771775075 8.977495771775075 Center Wannier: 8.97750346252367 8.97750346250972 8.97750346250972 Center Wannier: 6.412499426601353 3.8475005699364444 3.8475005699364444 Center Wannier: 1.2825042312349062 6.41249943605621 6.41249943605621 Center Wannier: 8.977495775296301 3.8475005697118165 3.8475005697118165 Center Wannier: 3.84750056980773 1.2825042305117622 1.2825042305117622 Center Wannier: 3.847500569944101 8.977495767979606 8.977495767979606 Center Wannier: 6.412499434256051 1.2825042290336968 1.2825042290336968 Center Wannier: 1.2824965381366529 8.977503465128347 8.977503465128347 Center Wannier: 3.8475005673763114 3.847500568373926 3.847500568373926 USE RESTART: 1 Call initialize_fft_custom ATT1 ATT2 ATT1.0 ATT1.1 ATT1.2 ATT1.3 ATT1.1.1 ATT1.1.2 ATT1.1.3 ATT1.1.4 ATT1.1.5 ATT1.1.6 ATT1.3.1 ATT1.5 ATT1.6 Planes per process (custom) : nr3t = 15 npp = 8 ncplane = 225 Proc/ planes cols G 1 8 61 513 2 7 60 508 tot 15 121 1021 ATT3 ATT4 Number of projected orthonormalized plane waves: 81 FK state: 1 1800 257 81 FK GS 81 FK state: 2 1800 257 81 FK GS 81 FK state: 3 1800 257 81 FK GS 81 FK state: 4 1800 257 81 FK GS 79 FK state: 5 1800 257 81 FK GS 66 FK state: 6 1800 257 81 FK GS 44 FK state: 7 1800 257 81 FK GS 35 FK state: 8 1800 257 81 FK GS 10 FK state: 9 1800 257 81 FK GS 16 FK state: 10 1800 257 81 FK GS 16 FK state: 11 1800 257 81 FK GS 11 FK state: 12 1800 257 81 FK GS 12 FK state: 13 1800 257 81 FK GS 16 FK state: 14 1800 257 81 FK GS 8 FK state: 15 1800 257 81 FK GS 5 FK state: 16 1800 257 81 FK GS 4 Calculate FK matrix ATT1 565 ATT2 565 ATT3 565 ATT4 565 ATT5 565 POLARIZABILITY eigen: 1 4.598927035682637 POLARIZABILITY eigen: 2 4.5995982107520526 POLARIZABILITY eigen: 3 4.695003658671135 POLARIZABILITY eigen: 4 4.885952814853772 POLARIZABILITY eigen: 5 4.8879374225240095 POLARIZABILITY eigen: 6 5.193870019099938 POLARIZABILITY eigen: 7 5.195567217701443 POLARIZABILITY eigen: 8 5.197019276691524 POLARIZABILITY eigen: 9 5.197815418288458 POLARIZABILITY eigen: 10 5.19830921851353 POLARIZABILITY eigen: 11 5.19853502166394 POLARIZABILITY eigen: 12 5.704967980995052 POLARIZABILITY eigen: 13 5.728988746177183 POLARIZABILITY eigen: 14 5.730544029796606 POLARIZABILITY eigen: 15 5.731558061004314 POLARIZABILITY eigen: 16 5.731945167889938 POLARIZABILITY eigen: 17 5.733304791856477 POLARIZABILITY eigen: 18 5.733497081573247 POLARIZABILITY eigen: 19 5.8281381582586285 POLARIZABILITY eigen: 20 5.833952059197756 POLARIZABILITY eigen: 21 5.83608324746853 POLARIZABILITY eigen: 22 5.838728798384911 POLARIZABILITY eigen: 23 5.839088597167535 POLARIZABILITY eigen: 24 5.840478509887464 POLARIZABILITY eigen: 25 5.960888163310795 POLARIZABILITY eigen: 26 5.9638169689781115 POLARIZABILITY eigen: 27 5.966403691268347 POLARIZABILITY eigen: 28 5.967610906968966 POLARIZABILITY eigen: 29 5.9697791238653615 POLARIZABILITY eigen: 30 5.971153906734182 POLARIZABILITY eigen: 31 6.147793675046685 POLARIZABILITY eigen: 32 6.150136384911021 POLARIZABILITY eigen: 33 6.152092069233019 POLARIZABILITY eigen: 34 6.292902961472278 POLARIZABILITY eigen: 35 6.295148768242601 POLARIZABILITY eigen: 36 6.29867316363637 POLARIZABILITY eigen: 37 6.854196987525375 POLARIZABILITY eigen: 38 6.858636651757742 POLARIZABILITY eigen: 39 6.86000219635342 POLARIZABILITY eigen: 40 6.8634599774065705 POLARIZABILITY eigen: 41 6.863776449269174 POLARIZABILITY eigen: 42 6.865821367175406 POLARIZABILITY eigen: 43 7.05144470537306 POLARIZABILITY eigen: 44 7.0532768118136255 POLARIZABILITY eigen: 45 7.0545629421216836 POLARIZABILITY eigen: 46 7.3765273822594075 POLARIZABILITY eigen: 47 7.382008798329148 POLARIZABILITY eigen: 48 7.384318267840873 POLARIZABILITY eigen: 49 8.561905310019913 POLARIZABILITY eigen: 50 8.564197662580266 POLARIZABILITY eigen: 51 8.567194511905935 POLARIZABILITY eigen: 52 8.567978829675294 POLARIZABILITY eigen: 53 8.57240085403517 POLARIZABILITY eigen: 54 8.574531775035148 POLARIZABILITY eigen: 55 9.026151706664617 POLARIZABILITY eigen: 56 9.028839718776045 POLARIZABILITY eigen: 57 9.5778551618052 POLARIZABILITY eigen: 58 9.582093542077512 POLARIZABILITY eigen: 59 9.586132456993226 POLARIZABILITY eigen: 60 9.586734641336037 POLARIZABILITY eigen: 61 9.588359345639429 POLARIZABILITY eigen: 62 9.589299615917863 POLARIZABILITY eigen: 63 9.781240236356705 POLARIZABILITY eigen: 64 9.78533200697731 POLARIZABILITY eigen: 65 9.786378540637827 POLARIZABILITY eigen: 66 9.787323976214893 POLARIZABILITY eigen: 67 9.78997763821889 POLARIZABILITY eigen: 68 9.79191457291357 POLARIZABILITY eigen: 69 9.901639518511129 POLARIZABILITY eigen: 70 9.902111460633332 POLARIZABILITY eigen: 71 9.905898379860695 POLARIZABILITY eigen: 72 9.907872476816394 POLARIZABILITY eigen: 73 9.908609580618734 POLARIZABILITY eigen: 74 9.90919915675229 POLARIZABILITY eigen: 75 10.97112698757299 POLARIZABILITY eigen: 76 10.97299005675417 POLARIZABILITY eigen: 77 10.97532263356922 POLARIZABILITY eigen: 78 11.338482846124371 POLARIZABILITY eigen: 79 11.340983036589499 POLARIZABILITY eigen: 80 11.34375021314846 POLARIZABILITY eigen: 81 11.344702626817377 POLARIZABILITY eigen: 82 11.345362018730857 POLARIZABILITY eigen: 83 11.346897774151522 POLARIZABILITY eigen: 84 11.417646619666385 POLARIZABILITY eigen: 85 11.422071247011395 POLARIZABILITY eigen: 86 11.424269340134522 POLARIZABILITY eigen: 87 11.425284132482975 POLARIZABILITY eigen: 88 11.427148625171654 POLARIZABILITY eigen: 89 11.428748455860376 POLARIZABILITY eigen: 90 11.55848085161836 POLARIZABILITY eigen: 91 11.56406907723224 POLARIZABILITY eigen: 92 11.565444981476354 POLARIZABILITY eigen: 93 12.74207432267292 POLARIZABILITY eigen: 94 12.743316248715523 POLARIZABILITY eigen: 95 12.746483157800068 POLARIZABILITY eigen: 96 12.749832543115009 POLARIZABILITY eigen: 97 12.75092000987885 POLARIZABILITY eigen: 98 12.752438073134908 POLARIZABILITY eigen: 99 14.075608511079277 POLARIZABILITY eigen: 100 14.700259962320565 NGM MAX: 257 2096 Routine wannier_uterms : start NGM MAX: 257 2096 uterms iiw 1 uterms jjw 1 USE RESTART: 1 LANCZOS RESTART:0 Routine pola_basis_lanczos ATT1 ATT2 ATT1.0 ATT1.1 ATT1.2 ATT1.3 ATT1.1.1 ATT1.1.2 ATT1.1.3 ATT1.1.4 ATT1.1.5 ATT1.1.6 ATT1.3.1 ATT1.5 ATT1.6 Planes per process (custom) : nr3t = 15 npp = 8 ncplane = 225 Proc/ planes cols G 1 8 61 513 2 7 60 508 tot 15 121 1021 ATT3 ATT4 pola_basis update merge-split 1 1 pola_basis update merge-split 2 1 pola_basis update merge-split 3 3 pola_basis update merge-split 4 3 pola_basis update merge-split 5 5 pola_basis update merge-split 6 5 pola_basis update merge-split 7 7 pola_basis update merge-split 8 7 pola_basis update merge-split 9 9 pola_basis update merge-split 10 9 pola_basis update merge-split 11 11 pola_basis update merge-split 12 11 pola_basis update merge-split 13 13 pola_basis update merge-split 14 13 pola_basis update merge-split 15 15 pola_basis update merge-split 16 15 USE RESTART: 1 LANCZOS_RESTART:1 EIGEN: 1 4.1760230431089274E-53 EIGEN: 101 486.6384417643854 orthonormalize_two_manifolds: basis dimension: 43 EIGEN: 1 -6.529409536497316E-55 EIGEN: 101 497.4334737618588 orthonormalize_two_manifolds: basis dimension: 62 EIGEN: 1 -4.459507139811527E-59 EIGEN: 101 489.64342563001173 orthonormalize_two_manifolds: basis dimension: 80 EIGEN: 1 -1.6947984362944375E-53 EIGEN: 101 479.03580884134254 orthonormalize_two_manifolds: basis dimension: 99 EIGEN: 1 3.421734181794452E-60 EIGEN: 101 476.2206199521778 orthonormalize_two_manifolds: basis dimension: 116 EIGEN: 1 1.0148165707690771E-56 EIGEN: 101 463.09325503989703 orthonormalize_two_manifolds: basis dimension: 133 EIGEN: 1 -9.627077191019179E-58 EIGEN: 101 425.95081139271423 orthonormalize_two_manifolds: basis dimension: 146 EIGEN: 1 3.178417267694947E-58 EIGEN: 101 449.49817695514616 orthonormalize_two_manifolds: basis dimension: 161 EIGEN: 1 8.130744265311063E-56 EIGEN: 101 427.7989453084153 orthonormalize_two_manifolds: basis dimension: 176 EIGEN: 1 3.94686406344037E-56 EIGEN: 101 413.04448920390826 orthonormalize_two_manifolds: basis dimension: 188 EIGEN: 1 -6.561279844676379E-56 EIGEN: 101 422.4578537606161 orthonormalize_two_manifolds: basis dimension: 203 EIGEN: 1 2.0670265669316944E-53 EIGEN: 101 420.7951830838149 orthonormalize_two_manifolds: basis dimension: 217 EIGEN: 1 -1.6344036529359043E-55 EIGEN: 101 360.40843455499913 orthonormalize_two_manifolds: basis dimension: 228 EIGEN: 1 3.2575472392282437E-55 EIGEN: 101 348.06405157703165 orthonormalize_two_manifolds: basis dimension: 238 EIGEN: 1 8.041799587555183E-53 EIGEN: 101 358.04357300032245 orthonormalize_two_manifolds: basis dimension: 247 lanczos_state: 1 1 lanczos_state: 1 1 USE RESTART: 1 LANCZOS_RESTART:2 Routine self_basis_lanczos ATT1 ATT2 ATT1.0 ATT1.1 ATT1.2 ATT1.3 ATT1.1.1 ATT1.1.2 ATT1.1.3 ATT1.1.4 ATT1.1.5 ATT1.1.6 ATT1.3.1 ATT1.5 ATT1.6 Planes per process (custom) : nr3t = 15 npp = 8 ncplane = 225 Proc/ planes cols G 1 8 61 513 2 7 60 508 tot 15 121 1021 ATT3 ATT4 do merge split 1 1 do merge split 2 1 do merge split 3 3 do merge split 4 3 do merge split 5 5 do merge split 6 5 do merge split 7 7 do merge split 8 7 do merge split 9 9 do merge split 10 9 do merge split 11 11 do merge split 12 11 do merge split 13 13 do merge split 14 13 do merge split 15 15 do merge split 16 15 do merge split 17 17 do merge split 18 17 do merge split 19 19 do merge split 20 19 do merge split 21 21 do merge split 22 21 do merge split 23 23 do merge split 24 23 do merge split 25 25 do merge split 26 25 do merge split 27 27 do merge split 28 27 do merge split 29 29 do merge split 30 29 do merge split 31 31 do merge split 32 31 USE RESTART: 1 LANCZOS_RESTART:3 EIGEN: 1 1.9601764656701396E-12 EIGEN: 101 0.0009083523836608671 orthonormalize_two_manifolds: basis dimension: 115 EIGEN: 1 1.3108293524070122E-12 EIGEN: 101 0.00048765439888847457 orthonormalize_two_manifolds: basis dimension: 128 EIGEN: 1 1.0829590662010292E-11 EIGEN: 101 0.0005178965599654347 orthonormalize_two_manifolds: basis dimension: 139 EIGEN: 1 5.681297602950374E-12 EIGEN: 101 0.0004764615579743083 orthonormalize_two_manifolds: basis dimension: 149 EIGEN: 1 1.2352048861888178E-12 EIGEN: 101 0.0003575025162049515 orthonormalize_two_manifolds: basis dimension: 158 EIGEN: 1 1.5018596453406526E-11 EIGEN: 101 0.00040999419770178626 orthonormalize_two_manifolds: basis dimension: 167 EIGEN: 1 4.3227513667577976E-11 EIGEN: 101 0.00048706090066602585 orthonormalize_two_manifolds: basis dimension: 181 EIGEN: 1 1.4064309111433243E-11 EIGEN: 101 0.00023618003462611497 orthonormalize_two_manifolds: basis dimension: 192 EIGEN: 1 3.460131501385882E-11 EIGEN: 101 0.00032951347626564305 orthonormalize_two_manifolds: basis dimension: 202 EIGEN: 1 8.560895134782505E-13 EIGEN: 101 0.0002538424368126868 orthonormalize_two_manifolds: basis dimension: 212 EIGEN: 1 1.2013888662346402E-12 EIGEN: 101 0.00025037287757776123 orthonormalize_two_manifolds: basis dimension: 220 EIGEN: 1 1.2688292821347168E-13 EIGEN: 101 0.00028773512574212516 orthonormalize_two_manifolds: basis dimension: 227 EIGEN: 1 3.639561379607801E-11 EIGEN: 101 0.00016519208643878466 orthonormalize_two_manifolds: basis dimension: 237 EIGEN: 1 1.4413061705526092E-11 EIGEN: 101 0.00013718285022918563 orthonormalize_two_manifolds: basis dimension: 246 EIGEN: 1 1.7014489357100586E-11 EIGEN: 101 0.000128487290753381 orthonormalize_two_manifolds: basis dimension: 254 EIGEN: 1 2.2323469285271722E-11 EIGEN: 101 0.000344942008911294 orthonormalize_two_manifolds: basis dimension: 264 EIGEN: 1 2.0277794921930836E-11 EIGEN: 101 0.0003042124749004351 orthonormalize_two_manifolds: basis dimension: 273 EIGEN: 1 2.2682199720222733E-11 EIGEN: 101 0.0002999251212921174 orthonormalize_two_manifolds: basis dimension: 280 EIGEN: 1 2.550324435611147E-11 EIGEN: 101 0.00027306348251554703 orthonormalize_two_manifolds: basis dimension: 287 EIGEN: 1 2.7730399386156934E-11 EIGEN: 101 0.00018514414120643195 orthonormalize_two_manifolds: basis dimension: 294 EIGEN: 1 9.3646351898692E-12 EIGEN: 101 0.00027262504722785647 orthonormalize_two_manifolds: basis dimension: 300 EIGEN: 1 1.694636620166525E-11 EIGEN: 101 0.0000485264834234616 orthonormalize_two_manifolds: basis dimension: 307 EIGEN: 1 2.172264404350237E-11 EIGEN: 101 0.000040478948394456285 orthonormalize_two_manifolds: basis dimension: 314 EIGEN: 1 2.3221610739910574E-11 EIGEN: 101 0.00003477459078842925 orthonormalize_two_manifolds: basis dimension: 321 EIGEN: 1 2.9707618831690874E-11 EIGEN: 101 0.00005847758696829841 orthonormalize_two_manifolds: basis dimension: 326 EIGEN: 1 1.1080269382136433E-11 EIGEN: 101 0.00010782001706659717 orthonormalize_two_manifolds: basis dimension: 327 EIGEN: 1 3.814483200230681E-11 EIGEN: 101 0.0001400692027009194 orthonormalize_two_manifolds: basis dimension: 340 EIGEN: 1 4.144455547036106E-11 EIGEN: 101 0.00018209418407802091 orthonormalize_two_manifolds: basis dimension: 351 EIGEN: 1 4.0801469468458804E-11 EIGEN: 101 0.0000429608136264815 orthonormalize_two_manifolds: basis dimension: 364 EIGEN: 1 9.051924107753462E-12 EIGEN: 101 0.0000454516772814007 orthonormalize_two_manifolds: basis dimension: 374 EIGEN: 1 9.203256437334678E-13 EIGEN: 101 0.000034199177563164736 orthonormalize_two_manifolds: basis dimension: 386 lanczos_state: 1 1 lanczos_state: 1 1 Total number of s vectors: 386 USE RESTART: 4 LANCZOS_RESTART /=3 Routine calculate_wing ATT0.1 ATT0.2 ATT1 ATT2 ATT3 ATT4 Exchange energy 1 1 -1.230314563392938 Exchange energy 2 1 -1.1454168546714825 Exchange energy 3 1 -1.1454168549498094 Exchange energy 4 1 -1.1454169770688887 Exchange energy 5 1 -1.1454169781119585 Exchange energy 6 1 -1.1454169766754199 Exchange energy 7 1 -1.1454173993994863 Exchange energy 8 1 -1.0039892559925037 Exchange energy 9 1 -1.0039892569349038 Exchange energy 10 1 -1.0039892562855113 Exchange energy 11 1 -1.0039875074298426 Exchange energy 12 1 -1.003987508246912 Exchange energy 13 1 -1.003987508503201 Exchange energy 14 1 -1.0394662665704306 Exchange energy 15 1 -1.0394662666545023 Exchange energy 16 1 -1.0394662661566514 Exchange energy 17 1 -0.3009754440684699 Exchange energy 18 1 -0.3009754444220082 Exchange energy 19 1 -0.30097550057912004 Exchange energy 20 1 -0.30097550068875933 Exchange energy 21 1 -0.3009755004531663 Exchange energy 22 1 -0.30097558168614463 Exchange energy 23 1 -0.36468330892190837 Exchange energy 24 1 -0.36468330864679355 Exchange energy 25 1 -0.3646833087090482 Exchange energy 26 1 -0.36917280612657877 Exchange energy 27 1 -0.16429425318219007 Exchange energy 28 1 -0.29819299954311584 Exchange energy 29 1 -0.29819299973824004 Exchange energy 30 1 -0.2830427013086756 Exchange energy 31 1 -0.283042698954885 Exchange energy 32 1 -0.2830407969110809 USE RESTART: 5 LANCZOS_RESTART /=3 USE RESTART: 6 LANCZOS_RESTART /=3 PW4GWW COMPLETED GWW/examples/example02/run_example0000755000077300007730000001256512341332532017701 0ustar giannozzgiannozz#!/bin/sh # run from directory where this script is cd `echo $0 | sed 's/\(.*\)\/.*/\1/'` # extract pathname EXAMPLE_DIR=`pwd` # check whether echo has the -e option if test "`echo -e`" = "-e" ; then ECHO=echo ; else ECHO="echo -e" ; fi $ECHO $ECHO "$EXAMPLE_DIR : starting" $ECHO $ECHO "This example shows how to use pw.x head.x pw4gww.x gww. x to calculate" $ECHO "the GW QP levels of bulk Si" # set the needed environment variables . ../../../environment_variables # required executables and pseudopotentials BIN_LIST="pw.x head.x pw4gww.x gww.x" PSEUDO_LIST="Si.pz-vbc.UPF" $ECHO $ECHO " executables directory: $BIN_DIR" $ECHO " pseudo directory: $PSEUDO_DIR" $ECHO " temporary directory: $TMP_DIR" $ECHO " checking that needed directories and files exist...\c" # check for directories for DIR in "$BIN_DIR" "$PSEUDO_DIR" ; do if test ! -d $DIR ; then $ECHO $ECHO "ERROR: $DIR not existent or not a directory" $ECHO "Aborting" exit 1 fi done for DIR in "$TMP_DIR" "$EXAMPLE_DIR/results" ; do if test ! -d $DIR ; then mkdir $DIR fi done cd $EXAMPLE_DIR/results # check for executables for FILE in $BIN_LIST ; do if test ! -x $BIN_DIR/$FILE ; then $ECHO $ECHO "ERROR: $BIN_DIR/$FILE not existent or not executable" $ECHO "Aborting" exit 1 fi done # check for pseudopotentials for FILE in $PSEUDO_LIST ; do if test ! -r $PSEUDO_DIR/$FILE ; then $ECHO $ECHO "Downloading $FILE to $PSEUDO_DIR...\c" $WGET $PSEUDO_DIR/$FILE $NETWORK_PSEUDO/$FILE 2> /dev/null fi if test $? != 0; then $ECHO $ECHO "ERROR: $PSEUDO_DIR/$FILE not existent or not readable" $ECHO "Aborting" exit 1 fi done $ECHO " done" # how to run executables PW_COMMAND="$PARA_PREFIX $BIN_DIR/pw.x " $ECHO $ECHO " running pw.x as: $PW_COMMAND" $ECHO HEAD_COMMAND="$PARA_PREFIX $BIN_DIR/head.x " $ECHO $ECHO " running pw.x as: $HEAD_COMMAND" $ECHO PW4GWW_COMMAND="$PARA_PREFIX $BIN_DIR/pw4gww.x " $ECHO $ECHO " running pw4gww.x as: $PW4GWW_COMMAND" $ECHO GWW_COMMAND="$PARA_PREFIX $BIN_DIR/gww.x " $ECHO $ECHO " running gww.x as: $GWW_COMMAND" $ECHO # self-consistent calculation cat > si_scf_k.in << EOF &control calculation='scf' restart_mode='from_scratch', prefix='si' pseudo_dir = '$PSEUDO_DIR/', outdir='$TMP_DIR/' / &system ibrav= 8, celldm(1)= 10.26,celldm(2)= 1, celldm(3)=1, nat= 8, ntyp= 1, ecutwfc = 15.0 / &electrons diagonalization='david', conv_thr = 1.0d-10, mixing_beta = 0.5, startingwfc='random', / ATOMIC_SPECIES Si 1. Si.pz-vbc.UPF ATOMIC_POSITIONS (crystal) Si 0.00000 0.00000 0.00000 Si 0.50000 0.50000 0.00000 Si 0.00000 0.50000 0.50000 Si 0.50000 0.00000 0.50000 Si 0.25000 0.25000 0.25000 Si 0.75000 0.75000 0.25000 Si 0.75000 0.25000 0.75000 Si 0.25000 0.75000 0.75000 K_POINTS (automatic) 4 4 4 1 1 1 EOF $ECHO " running the scf calculation for Si...\c" $PW_COMMAND < si_scf_k.in > si_scf_k.out check_failure $? $ECHO " done" #calculation of head cat > si_head.in << EOF calculation of head &inputph trans=.false. l_head=.true. tr2_ph=1.d-4, prefix='si', omega_gauss=20.0 n_gauss=97 grid_type=5 second_grid_i=1 second_grid_n=10 niter_ph=1 nsteps_lanczos=30 outdir='$TMP_DIR/' / 0.0 0.0 0.0 EOF $ECHO " running the head calculation for Si...\c" $HEAD_COMMAND < si_head.in > si_head.out check_failure $? $ECHO " done" # non self-consistent calculation cat > si_nscf.in << EOF &control calculation='nscf' restart_mode='from_scratch', prefix='si' pseudo_dir = '$PSEUDO_DIR/', outdir='$TMP_DIR/' / &system ibrav= 8, celldm(1)= 10.26,celldm(2)= 1, celldm(3)=1, nat= 8, ntyp= 1, ecutwfc = 15.0,nbnd=32 / &electrons diagonalization='david', conv_thr = 1.0d-10, mixing_beta = 0.5, startingwfc='random', / ATOMIC_SPECIES Si 1. Si.pz-vbc.UPF ATOMIC_POSITIONS (crystal) Si 0.00000 0.00000 0.00000 Si 0.50000 0.50000 0.00000 Si 0.00000 0.50000 0.50000 Si 0.50000 0.00000 0.50000 Si 0.25000 0.25000 0.25000 Si 0.75000 0.75000 0.25000 Si 0.75000 0.25000 0.75000 Si 0.25000 0.75000 0.75000 EOF $ECHO " running the nscf calculation for Si...\c" $PW_COMMAND < si_nscf.in > si_nscf.out check_failure $? $ECHO " done" #pw4gww calculations cat > si_pw4gww.in << EOF &inputpw4gww prefix='si' num_nbndv(1)=16 num_nbnds=32 l_truncated_coulomb=.false. numw_prod=100 pmat_cutoff=3d0 s_self_lanczos=1d-8 outdir='$TMP_DIR' / EOF $ECHO " running the pw4gww calculation for Si...\c" $PW4GWW_COMMAND < si_pw4gww.in > si_pw4gww.out check_failure $? $ECHO " done" cat > si_gww.in << EOF &inputgww ggwin%prefix='si' ggwin%n=97, ggwin%n_fit=120, ggwin%max_i=32, ggwin%i_min=1 ggwin%i_max=32 ggwin%l_truncated_coulomb=.false. ggwin%grid_time=3 ggwin%grid_freq=5 ggwin%second_grid_i=1 ggwin%second_grid_n=10 ggwin%omega=20 ggwin%omega_fit=20 ggwin%n_grid_fit=240 ggwin%tau=9.8 ggwin%n_set_pola=16 ggwin%outdir='$TMP_DIR' / EOF $ECHO " running the gww calculation for Si...\c" $GWW_COMMAND < si_gww.in > si_gww.out check_failure $? $ECHO " done" #copy self_energy files $ECHO "copying self-energy files..\c" cp $TMP_DIR/si-im_on_im* . cp $TMP_DIR/si-re_on_im* . # clean TMP_DIR $ECHO " cleaning $TMP_DIR...\c" rm -rf $TMP_DIR/si* $ECHO " done" $ECHO $ECHO "$EXAMPLE_DIR : done" GWW/examples/example03/0000755000077300007730000000000012341332543015426 5ustar giannozzgiannozzGWW/examples/example03/run_example0000755000077300007730000001122612341332532017673 0ustar giannozzgiannozz#!/bin/sh ### ### Initial file from QE modified by ### G. Stenuit (06/08/2009) ### # run from directory where this script is cd `echo $0 | sed 's/\(.*\)\/.*/\1/'` # extract pathname EXAMPLE_DIR=`pwd` # check whether ECHO has the -e option if test "`echo -e`" = "-e" ; then ECHO=echo ; else ECHO="echo -e" ; fi $ECHO $ECHO "$EXAMPLE_DIR : starting" $ECHO $ECHO "This example shows how to use projwfc.x to compute" $ECHO "the orbital decomposition of the total DOS from GWA energies" # set the needed environment variables . ../../../environment_variables # required executables and pseudopotentials BIN_LIST="pw.x projwfc.x" PSEUDO_LIST="C.pz-vbc.UPF H.pz-vbc.UPF" $ECHO $ECHO " executables directory: $BIN_DIR" $ECHO " pseudo directory: $PSEUDO_DIR" $ECHO " temporary directory: $TMP_DIR" $ECHO $ECHO " checking that needed directories and files exist...\c" # check for directories for DIR in "$BIN_DIR" "$PSEUDO_DIR" ; do if test ! -d $DIR ; then $ECHO $ECHO "ERROR: $DIR not existent or not a directory" $ECHO "Aborting" exit 1 fi done for DIR in "$TMP_DIR" "$EXAMPLE_DIR/results" ; do if test ! -d $DIR ; then mkdir $DIR fi done cd $EXAMPLE_DIR/results # check for executables for FILE in $BIN_LIST ; do if test ! -x $BIN_DIR/$FILE ; then $ECHO $ECHO "ERROR: $BIN_DIR/$FILE not existent or not executable" $ECHO "Aborting" exit 1 fi done # check for pseudopotentials for FILE in $PSEUDO_LIST ; do if test ! -r $PSEUDO_DIR/$FILE ; then $ECHO $ECHO "ERROR: $PSEUDO_DIR/$FILE not existent or not readable" $ECHO "Aborting" exit 1 fi done $ECHO " done" # check if bands.dat exist ! if test ! -r ../../example01/results/ch4-bands.dat ; then $ECHO $ECHO "ERROR: ../../example01/results/bands.dat not existent or not readable" $ECHO "Please run example01 FIRST !!" $ECHO "Aborting" exit 1 fi $ECHO " done" # how to run executables PW_COMMAND="$PARA_PREFIX $BIN_DIR/pw.x $PARA_POSTFIX" PROJWFC_COMMAND="$PARA_PREFIX $BIN_DIR/projwfc.x $PARA_POSTFIX" $ECHO $ECHO " running pw.x as: $PW_COMMAND" $ECHO " running projwfc.x as: $PROJWFC_COMMAND" $ECHO # clean TMP_DIR $ECHO " cleaning $TMP_DIR...\c" rm -rf $TMP_DIR/pwscf* $ECHO " done" # self-consistent calculation at Gamma cat > methane_scf.in << EOF &control calculation = 'scf', restart_mode='from_scratch', prefix='ch4', tprnfor = .true., pseudo_dir = '$PSEUDO_DIR/', outdir='$TMP_DIR/' / &system ibrav= 1, celldm(1) =15.0, nat=5, ntyp= 2, ecutwfc =40.0, / &electrons diagonalization='cg' mixing_beta = 0.5, conv_thr = 1.0d-8 / ATOMIC_SPECIES H 1.0 H.pz-vbc.UPF C 12.0 C.pz-vbc.UPF ATOMIC_POSITIONS {bohr} H 1.198204546 1.198204546 1.198204546 H -1.198204546 -1.198204546 1.198204546 H 1.198204546 -1.198204546 -1.198204546 H -1.198204546 1.198204546 -1.198204546 C 0.000000000 0.000000000 0.000000000 EOF $ECHO " running the scf calculation for methane molecule...\c" $PW_COMMAND < methane_scf.in > methane_scf.out check_failure $? $ECHO " done" # non self-consistent calculation at Gamma cat > methane_nscf.in << EOF &control calculation = 'nscf', restart_mode='from_scratch', prefix='ch4', tprnfor = .true., pseudo_dir = '$PSEUDO_DIR/', outdir='$TMP_DIR/' / &system ibrav= 1, celldm(1) =15.0, nat=5, ntyp= 2, ecutwfc =40.0, nbnd=5 / &electrons diagonalization='cg' mixing_beta = 0.5, conv_thr = 1.0d-8 / ATOMIC_SPECIES H 1.0 H.pz-vbc.UPF C 12.0 C.pz-vbc.UPF ATOMIC_POSITIONS {bohr} H 1.198204546 1.198204546 1.198204546 H -1.198204546 -1.198204546 1.198204546 H 1.198204546 -1.198204546 -1.198204546 H -1.198204546 1.198204546 -1.198204546 C 0.000000000 0.000000000 0.000000000 EOF $ECHO " running the non scf calculation for methane molecule...\c" $PW_COMMAND < methane_nscf.in > methane_nscf.out check_failure $? $ECHO " done" # copy the bands.dat file from example01 $ECHO "Copy the bands.dat file generated in example01 ...\c" cp ../../example01/results/ch4-bands.dat bands.dat # projwfc calculation at Gamma cat > methane.pdos_pp.in << EOF &projwfc outdir='$TMP_DIR/' prefix='ch4' lgww=.true. Emin=-30.0, Emax=5.0, DeltaE=0.05, ngauss=0, degauss=0.01559 / EOF $ECHO " running the projwfc calculation at Gamma for C6H6...\c" $PROJWFC_COMMAND < methane.pdos_pp.in > methane.pdos_pp.out check_failure $? $ECHO " done" # clean TMP_DIR $ECHO " cleaning $TMP_DIR...\c" rm -rf $TMP_DIR/pwscf* $ECHO " done" $ECHO $ECHO "$EXAMPLE_DIR: done" GWW/examples/README0000644000077300007730000000112612341332532014506 0ustar giannozzgiannozzto run examples do ./run_example from the following directories: example01 computes the GW quasi-particle energies in CH4 (Methene molecule) example02 computes the GW quasi-particle energies in bulk Si (how to treat extended system) Note: in order to accelerate this example, used as a daily distribution test, it is using parameters (a small 8-atom simulation cell whose Brillouin's zone is sample onlt at the Gamma point) giving quite unconverged results example03 uses projwfc to plot GW DOS of CH4, example01 must be run before. GWW/examples/example01/0000755000077300007730000000000012341332543015424 5ustar giannozzgiannozzGWW/examples/example01/C.pz-vbc.UPF0000644000077300007730000010775212341332532017374 0ustar giannozzgiannozz Generated using ld1 code Author: P. Giannozzi Generation date: 1990 Info: C LDA 2s2 2p2 VonBarth-Car, l=1 local 0 The Pseudo was generated with a Non-Relativistic Calculation 0.00000000000E+00 Local Potential cutoff radius nl pn l occ Rcut Rcut US E pseu 2S 0 0 2.00 0.00000000000 0.00000000000 0.00000000000 2P 0 1 2.00 0.00000000000 0.00000000000 0.00000000000 0 Version Number C Element NC Norm - Conserving pseudopotential F Nonlinear Core Correction SLA PZ NOGX NOGC PZ Exchange-Correlation functional 4.00000000000 Z valence 0.00000000000 Total energy 0.0000000 0.0000000 Suggested cutoff for wfc and rho 0 Max angular momentum component 269 Number of points in mesh 2 1 Number of Wavefunctions, Number of Projectors Wavefunctions nl l occ 2S 0 2.00 2P 1 2.00 5.61495583257E-04 5.87340023303E-04 6.14374027614E-04 6.42652349289E-04 6.72232261592E-04 7.03173673954E-04 7.35539253311E-04 7.69394551019E-04 8.04808135628E-04 8.41851731748E-04 8.80600365321E-04 9.21132515572E-04 9.63530273956E-04 1.00787951042E-03 1.05427004733E-03 1.10279584138E-03 1.15355517387E-03 1.20665084981E-03 1.26219040609E-03 1.32028632928E-03 1.38105628348E-03 1.44462334862E-03 1.51111626973E-03 1.58066971770E-03 1.65342456203E-03 1.72952815614E-03 1.80913463582E-03 1.89240523139E-03 1.97950859428E-03 2.07062113854E-03 2.16592739823E-03 2.26562040109E-03 2.36990205952E-03 2.47898357951E-03 2.59308588842E-03 2.71244008243E-03 2.83728789455E-03 2.96788218428E-03 3.10448744968E-03 3.24738036311E-03 3.39685033153E-03 3.55320008272E-03 3.71674627836E-03 3.88782015537E-03 4.06676819683E-03 4.25395283368E-03 4.44975317877E-03 4.65456579471E-03 4.86880549704E-03 5.09290619438E-03 5.32732176723E-03 5.57252698722E-03 5.82901847872E-03 6.09731572467E-03 6.37796211866E-03 6.67152606556E-03 6.97860213268E-03 7.29981225400E-03 7.63580698979E-03 7.98726684421E-03 8.35490364357E-03 8.73946197802E-03 9.14172070963E-03 9.56249454977E-03 1.00026357093E-02 1.04630356244E-02 1.09446267624E-02 1.14483845097E-02 1.19753291481E-02 1.25265279205E-02 1.31030971928E-02 1.37062047148E-02 1.43370719853E-02 1.49969767261E-02 1.56872554699E-02 1.64093062670E-02 1.71645915171E-02 1.79546409308E-02 1.87810546283E-02 1.96455063797E-02 2.05497469951E-02 2.14956078710E-02 2.24850046987E-02 2.35199413450E-02 2.46025139103E-02 2.57349149740E-02 2.69194380352E-02 2.81584821579E-02 2.94545568299E-02 3.08102870453E-02 3.22284186212E-02 3.37118237586E-02 3.52635068598E-02 3.68866106134E-02 3.85844223593E-02 4.03603807463E-02 4.22180826971E-02 4.41612906931E-02 4.61939403945E-02 4.83201486117E-02 5.05442216427E-02 5.28706639957E-02 5.53041875114E-02 5.78497209065E-02 6.05124197561E-02 6.32976769354E-02 6.62111335419E-02 6.92586903210E-02 7.24465196166E-02 7.57810778724E-02 7.92691187084E-02 8.29177065994E-02 8.67342311827E-02 9.07264222249E-02 9.49023652771E-02 9.92705180510E-02 1.03839727549E-01 1.08619247982E-01 1.13618759511E-01 1.18848387857E-01 1.24318724803E-01 1.30040849653E-01 1.36026351663E-01 1.42287353521E-01 1.48836535896E-01 1.55687163119E-01 1.62853110053E-01 1.70348890188E-01 1.78189685041E-01 1.86391374902E-01 1.94970570994E-01 2.03944649122E-01 2.13331784861E-01 2.23150990368E-01 2.33422152892E-01 2.44166075044E-01 2.55404516941E-01 2.67160240267E-01 2.79457054379E-01 2.92319864529E-01 3.05774722302E-01 3.19848878383E-01 3.34570837750E-01 3.49970417399E-01 3.66078806743E-01 3.82928630776E-01 4.00554016148E-01 4.18990660289E-01 4.38275903704E-01 4.58448805601E-01 4.79550223000E-01 5.01622893484E-01 5.24711521752E-01 5.48862870168E-01 5.74125853465E-01 6.00551637818E-01 6.28193744472E-01 6.57108158138E-01 6.87353440386E-01 7.18990848247E-01 7.52084458286E-01 7.86701296372E-01 8.22911473431E-01 8.60788327447E-01 9.00408571994E-01 9.41852451607E-01 9.85203904304E-01 1.03055073159E+00 1.07798477630E+00 1.12760210856E+00 1.17950322045E+00 1.23379322944E+00 1.29058209136E+00 1.34998482306E+00 1.41212173538E+00 1.47711867679E+00 1.54510728831E+00 1.61622527012E+00 1.69061666044E+00 1.76843212724E+00 1.84982927345E+00 1.93497295611E+00 2.02403562026E+00 2.11719764824E+00 2.21464772499E+00 2.31658322022E+00 2.42321058815E+00 2.53474578563E+00 2.65141470956E+00 2.77345365437E+00 2.90110979063E+00 3.03464166566E+00 3.17431972712E+00 3.32042687082E+00 3.47325901367E+00 3.63312569298E+00 3.80035069340E+00 3.97527270272E+00 4.15824599778E+00 4.34964116204E+00 4.54984583610E+00 4.75926550285E+00 4.97832430868E+00 5.20746592254E+00 5.44715443450E+00 5.69787529571E+00 5.96013630160E+00 6.23446862033E+00 6.52142786859E+00 6.82159523693E+00 7.13557866685E+00 7.46401408210E+00 7.80756667662E+00 8.16693226184E+00 8.54283867587E+00 8.93604725767E+00 9.34735438898E+00 9.77759310732E+00 1.02276347931E+01 1.06983909346E+01 1.11908149737E+01 1.17059042376E+01 1.22447019580E+01 1.28082993843E+01 1.33978379941E+01 1.40145118043E+01 1.46595697903E+01 1.53343184150E+01 1.60401242748E+01 1.67784168678E+01 1.75506914889E+01 1.83585122580E+01 1.92035152884E+01 2.00874119998E+01 2.10119925853E+01 2.19791296364E+01 2.29907819362E+01 2.40489984264E+01 2.51559223569E+01 2.63137956270E+01 2.75249633258E+01 2.87918784818E+01 3.01171070310E+01 3.15033330143E+01 3.29533640129E+01 3.44701368353E+01 3.60567234645E+01 3.77163372809E+01 3.94523395696E+01 4.12682463283E+01 4.31677353890E+01 4.51546538661E+01 4.72330259485E+01 4.94070610499E+01 5.16811623344E+01 5.40599356342E+01 5.65481987783E+01 5.91509913497E+01 6.18735848931E+01 6.47214935906E+01 6.77004854306E+01 7.08165938898E+01 7.40761301526E+01 7.74856958938E+01 8.10521966493E+01 8.47828558020E+01 8.86852292115E+01 9.27672205176E+01 9.70370971477E+01 2.52673012466E-05 2.64303010486E-05 2.76468312426E-05 2.89193557180E-05 3.02504517716E-05 3.16428153279E-05 3.30992663990E-05 3.46227547959E-05 3.62163661033E-05 3.78833279287E-05 3.96270164394E-05 4.14509632007E-05 4.33588623280E-05 4.53545779690E-05 4.74421521300E-05 4.96258128620E-05 5.19099828243E-05 5.42992882416E-05 5.67985682739E-05 5.94128848175E-05 6.21475327566E-05 6.50080506880E-05 6.80002321380E-05 7.11301372966E-05 7.44041052914E-05 7.78287670264E-05 8.14110586119E-05 8.51582354127E-05 8.90778867424E-05 9.31779512343E-05 9.74667329203E-05 1.01952918049E-04 1.06645592678E-04 1.11554261078E-04 1.16688864979E-04 1.22059803709E-04 1.27677955255E-04 1.33554698293E-04 1.39701935236E-04 1.46132116340E-04 1.52858264919E-04 1.59894003722E-04 1.67253582526E-04 1.74951906992E-04 1.83004568858E-04 1.91427877516E-04 2.00238893044E-04 2.09455460762E-04 2.19096247367E-04 2.29180778747E-04 2.39729479525E-04 2.50763714425E-04 2.62305831542E-04 2.74379207610E-04 2.87008295340E-04 3.00218672950E-04 3.14037095971E-04 3.28491551430E-04 3.43611314541E-04 3.59427007989E-04 3.75970663961E-04 3.93275789011E-04 4.11377431933E-04 4.30312254740E-04 4.50118606918E-04 4.70836603099E-04 4.92508204307E-04 5.15177302939E-04 5.38889811666E-04 5.63693756424E-04 5.89639373676E-04 6.16779212164E-04 6.45168239336E-04 6.74863952674E-04 7.05926496145E-04 7.38418782016E-04 7.72406618268E-04 8.07958841887E-04 8.45147458273E-04 8.84047787084E-04 9.24738614781E-04 9.67302354194E-04 1.01182521144E-03 1.05839736053E-03 1.10711312597E-03 1.15807117383E-03 1.21137471158E-03 1.26713169711E-03 1.32545505735E-03 1.38646291704E-03 1.45027883795E-03 1.51703206914E-03 1.58685780869E-03 1.65989747761E-03 1.73629900617E-03 1.81621713358E-03 1.89981372137E-03 1.98725808119E-03 2.07872731775E-03 2.17440668752E-03 2.27448997392E-03 2.37917987981E-03 2.48868843801E-03 2.60323744079E-03 2.72305888903E-03 2.84839546209E-03 2.97950100939E-03 3.11664106445E-03 3.26009338275E-03 3.41014850426E-03 3.56711034188E-03 3.73129679697E-03 3.90304040322E-03 4.08268900012E-03 4.27060643747E-03 4.46717331230E-03 4.67278773970E-03 4.88786615917E-03 5.11284417800E-03 5.34817745356E-03 5.59434261615E-03 5.85183823437E-03 6.12118582483E-03 6.40293090845E-03 6.69764411531E-03 7.00592234037E-03 7.32838995238E-03 7.66570005847E-03 8.01853582686E-03 8.38761187057E-03 8.77367569472E-03 9.17750921048E-03 9.59993031873E-03 1.00417945666E-02 1.05039968801E-02 1.09874733770E-02 1.14932032623E-02 1.20222108120E-02 1.25755674471E-02 1.31543939038E-02 1.37598625036E-02 1.43931995272E-02 1.50556876987E-02 1.57486687830E-02 1.64735463034E-02 1.72317883849E-02 1.80249307267E-02 1.88545797130E-02 1.97224156667E-02 2.06301962520E-02 2.15797600350E-02 2.25730302068E-02 2.36120184788E-02 2.46988291576E-02 2.58356634059E-02 2.70248237018E-02 2.82687185012E-02 2.95698671162E-02 3.09309048173E-02 3.23545881711E-02 3.38438006229E-02 3.54015583367E-02 3.70310163044E-02 3.87354747351E-02 4.05183857397E-02 4.23833603223E-02 4.43341756937E-02 4.63747829217E-02 4.85093149333E-02 5.07420948853E-02 5.30776449202E-02 5.55206953248E-02 5.80761941113E-02 6.07493170379E-02 6.35454780920E-02 6.64703404555E-02 6.95298279741E-02 7.27301371555E-02 7.60777497197E-02 7.95794457259E-02 8.32423173054E-02 8.70737830248E-02 9.10816029116E-02 9.52738941707E-02 9.96591476245E-02 1.04246244910E-01 1.09044476467E-01 1.14063560353E-01 1.19313661930E-01 1.24805414447E-01 1.30549940579E-01 1.36558874955E-01 1.42844387720E-01 1.49419209187E-01 1.56296655615E-01 1.63490656184E-01 1.71015781203E-01 1.78887271623E-01 1.87121069900E-01 1.95733852292E-01 2.04743062624E-01 2.14166947628E-01 2.24024593891E-01 2.34335966514E-01 2.45121949553E-01 2.56404388307E-01 2.68206133572E-01 2.80551087915E-01 2.93464254087E-01 3.06971785662E-01 3.21101040008E-01 3.35880633694E-01 3.51340500448E-01 3.67511951783E-01 3.84427740414E-01 4.02122126595E-01 4.20630947504E-01 4.39991689829E-01 4.60243565690E-01 4.81427592055E-01 5.03586673819E-01 5.26765690693E-01 5.51011588109E-01 5.76373472294E-01 6.02902709732E-01 6.30653031194E-01 6.59680640565E-01 6.90044328674E-01 7.21805592365E-01 7.55028759051E-01 7.89781117000E-01 8.26133051612E-01 8.64158187977E-01 9.03933539993E-01 9.45539666338E-01 9.89060833639E-01 1.03458518713E+00 1.08220492919E+00 1.13201650606E+00 1.18412080322E+00 1.23862334966E+00 1.29563453168E+00 1.35526981640E+00 1.41764998564E+00 1.48290138058E+00 1.55115615759E+00 1.62255255590E+00 1.69723517764E+00 1.77535528063E+00 1.85707108478E+00 1.94254809251E+00 2.03195942397E+00 2.12548616768E+00 2.22331774724E+00 2.32565230505E+00 2.43269710354E+00 2.54466894502E+00 2.66179461074E+00 2.78431132019E+00 2.91246721158E+00 3.04652184438E+00 3.18674672504E+00 3.33342585686E+00 3.48685631522E+00 3.64734884922E+00 3.81522851109E+00 3.99083531452E+00 4.17452492329E+00 4.36666937165E+00 -2.97233180461E+01 -2.97233157749E+01 -2.97233132899E+01 -2.97233105707E+01 -2.97233075956E+01 -2.97233043402E+01 -2.97233007783E+01 -2.97232968809E+01 -2.97232926165E+01 -2.97232879504E+01 -2.97232828450E+01 -2.97232772588E+01 -2.97232711465E+01 -2.97232644586E+01 -2.97232571408E+01 -2.97232491339E+01 -2.97232403730E+01 -2.97232307870E+01 -2.97232202983E+01 -2.97232088218E+01 -2.97231962645E+01 -2.97231825247E+01 -2.97231674909E+01 -2.97231510414E+01 -2.97231330427E+01 -2.97231133490E+01 -2.97230918008E+01 -2.97230682232E+01 -2.97230424253E+01 -2.97230141980E+01 -2.97229833124E+01 -2.97229495182E+01 -2.97229125416E+01 -2.97228720827E+01 -2.97228278138E+01 -2.97227793760E+01 -2.97227263767E+01 -2.97226683865E+01 -2.97226049352E+01 -2.97225355087E+01 -2.97224595442E+01 -2.97223764262E+01 -2.97222854810E+01 -2.97221859716E+01 -2.97220770915E+01 -2.97219579583E+01 -2.97218276067E+01 -2.97216849803E+01 -2.97215289232E+01 -2.97213581710E+01 -2.97211713400E+01 -2.97209669163E+01 -2.97207432435E+01 -2.97204985093E+01 -2.97202307308E+01 -2.97199377385E+01 -2.97196171588E+01 -2.97192663944E+01 -2.97188826041E+01 -2.97184626789E+01 -2.97180032176E+01 -2.97175004987E+01 -2.97169504509E+01 -2.97163486199E+01 -2.97156901324E+01 -2.97149696569E+01 -2.97141813604E+01 -2.97133188619E+01 -2.97123751802E+01 -2.97113426785E+01 -2.97102130019E+01 -2.97089770111E+01 -2.97076247081E+01 -2.97061451565E+01 -2.97045263931E+01 -2.97027553322E+01 -2.97008176604E+01 -2.96986977224E+01 -2.96963783951E+01 -2.96938409515E+01 -2.96910649105E+01 -2.96880278744E+01 -2.96847053500E+01 -2.96810705546E+01 -2.96770942036E+01 -2.96727442786E+01 -2.96679857750E+01 -2.96627804264E+01 -2.96570864043E+01 -2.96508579906E+01 -2.96440452213E+01 -2.96365934982E+01 -2.96284431665E+01 -2.96195290552E+01 -2.96097799777E+01 -2.95991181891E+01 -2.95874587969E+01 -2.95747091224E+01 -2.95607680076E+01 -2.95455250658E+01 -2.95288598702E+01 -2.95106410780E+01 -2.94907254849E+01 -2.94689570073E+01 -2.94451655867E+01 -2.94191660146E+01 -2.93907566733E+01 -2.93597181900E+01 -2.93258120033E+01 -2.92887788384E+01 -2.92483370943E+01 -2.92041811419E+01 -2.91559795373E+01 -2.91033731569E+01 -2.90459732622E+01 -2.89833595069E+01 -2.89150779038E+01 -2.88406387727E+01 -2.87595146990E+01 -2.86711385380E+01 -2.85749015095E+01 -2.84701514398E+01 -2.83561912153E+01 -2.82322775312E+01 -2.80976200300E+01 -2.79513809446E+01 -2.77926753801E+01 -2.76205723877E+01 -2.74340970108E+01 -2.72322335051E+01 -2.70139299592E+01 -2.67781045684E+01 -2.65236538364E+01 -2.62494629971E+01 -2.59544189625E+01 -2.56374261068E+01 -2.52974251837E+01 -2.49334156482E+01 -2.45444815981E+01 -2.41298214709E+01 -2.36887815042E+01 -2.32208928061E+01 -2.27259116571E+01 -2.22038623889E+01 -2.16550818419E+01 -2.10802640029E+01 -2.04805029652E+01 -1.98573318636E+01 -1.92127549344E+01 -1.85492693831E+01 -1.78698733791E+01 -1.71780562968E+01 -1.64777674065E+01 -1.57733596623E+01 -1.50695061691E+01 -1.43710883999E+01 -1.36830573315E+01 -1.30102713364E+01 -1.23573177725E+01 -1.17283284789E+01 -1.11268023961E+01 -1.05554507350E+01 -1.00160808847E+01 -9.50953398522E+00 -9.03568737431E+00 -8.59352689059E+00 -8.18128576655E+00 -7.79663764757E+00 -7.43692277738E+00 -7.09938050338E+00 -6.78135969854E+00 -6.48048242196E+00 -6.19474483595E+00 -5.92255131515E+00 -5.66268995596E+00 -5.41426716178E+00 -5.17662327195E+00 -4.94924963820E+00 -4.73172139457E+00 -4.52365205933E+00 -4.32466891129E+00 -4.13440371905E+00 -3.95249226997E+00 -3.77857735393E+00 -3.61231199438E+00 -3.45336163328E+00 -3.30140514752E+00 -3.15613503599E+00 -3.01725715251E+00 -2.88449024086E+00 -2.75756540678E+00 -2.63622558490E+00 -2.52022502071E+00 -2.40932877345E+00 -2.30331224032E+00 -2.20196070163E+00 -2.10506888585E+00 -2.01244055396E+00 -1.92388810192E+00 -1.83923218077E+00 -1.75830133332E+00 -1.68093164696E+00 -1.60696642162E+00 -1.53625585246E+00 -1.46865672641E+00 -1.40403213212E+00 -1.34225118272E+00 -1.28318875067E+00 -1.22672521436E+00 -1.17274621582E+00 -1.12114242916E+00 -1.07180933905E+00 -1.02464702914E+00 -9.79559979624E-01 -9.36456873825E-01 -8.95250413222E-01 -8.55857140650E-01 -8.18197271270E-01 -7.82194530977E-01 -7.47776001918E-01 -7.14871974809E-01 -6.83415807750E-01 -6.53343791254E-01 -6.24595019210E-01 -5.97111265530E-01 -5.70836866221E-01 -5.45718606645E-01 -5.21705613742E-01 -4.98749252996E-01 -4.76803029930E-01 -4.55822495944E-01 -4.35765158285E-01 -4.16590393991E-01 -3.98259367611E-01 -3.80734952553E-01 -3.63981655886E-01 -3.47965546461E-01 -3.32654186181E-01 -3.18016564310E-01 -3.04023034662E-01 -2.90645255556E-01 -2.77856132418E-01 -2.65629762904E-01 -2.53941384436E-01 -2.42767324054E-01 -2.32084950467E-01 -2.21872628218E-01 -2.12109673864E-01 -2.02776314086E-01 -1.93853645642E-01 -1.85323597078E-01 -1.77168892131E-01 -1.69373014736E-01 -1.61920175578E-01 -1.54795280111E-01 -1.47983897985E-01 -1.41472233826E-01 -1.35247099287E-01 -1.29295886344E-01 -1.23606541756E-01 -1.18167542657E-01 -1.12967873214E-01 -1.07997002321E-01 -1.03244862264E-01 -9.87018283368E-02 -9.43586993423E-02 -9.02066789603E-02 -8.62373579305E-02 -8.24426970215E-02 1 0 Beta L 219 1.09119164250E-02 1.14141682567E-02 1.19395372411E-02 1.24890883887E-02 1.30639335918E-02 1.36652383221E-02 1.42942192368E-02 1.49521508762E-02 1.56403651833E-02 1.63602567647E-02 1.71132833675E-02 1.79009697042E-02 1.87249117559E-02 1.95867777263E-02 2.04883128226E-02 2.14313440354E-02 2.24177801346E-02 2.34496197971E-02 2.45289520792E-02 2.56579635859E-02 2.68389403770E-02 2.80742741769E-02 2.93664671488E-02 3.07181361880E-02 3.21320186492E-02 3.36109780717E-02 3.51580094237E-02 3.67762457792E-02 3.84689649919E-02 4.02395939732E-02 4.20917191858E-02 4.40290918706E-02 4.60556342237E-02 4.81754522666E-02 5.03928338776E-02 5.27122740862E-02 5.51384716514E-02 5.76763304148E-02 6.03309974813E-02 6.31078487573E-02 6.60125031801E-02 6.90508417131E-02 7.22290167528E-02 7.55534662947E-02 7.90309185058E-02 8.26684106172E-02 8.64733125671E-02 9.04533266809E-02 9.46165064431E-02 9.89712799992E-02 1.03526459246E-01 1.08291272770E-01 1.13275355656E-01 1.18488796603E-01 1.23942141893E-01 1.29646437497E-01 1.35613213655E-01 1.41854545825E-01 1.48383058059E-01 1.55211954874E-01 1.62355048099E-01 1.69826778680E-01 1.77642257306E-01 1.85817275986E-01 1.94368367049E-01 2.03312794737E-01 2.12668641907E-01 2.22454795713E-01 2.32691018669E-01 2.43397975881E-01 2.54597270950E-01 2.66311495169E-01 2.78564270758E-01 2.91380292739E-01 3.04785383599E-01 3.18806536603E-01 3.33471966638E-01 3.48811177823E-01 3.64854990224E-01 3.81635639943E-01 3.99186794490E-01 4.17543654874E-01 4.36742981469E-01 4.56823200530E-01 4.77824437834E-01 4.99788612210E-01 5.22759511567E-01 5.46782855048E-01 5.71906344793E-01 5.98179810565E-01 6.25655197729E-01 6.54386777629E-01 6.84431054295E-01 7.15847078689E-01 7.48696311060E-01 7.83042741609E-01 8.18953122070E-01 8.56496781721E-01 8.95746066180E-01 9.36775970383E-01 9.79664569977E-01 1.02449277469E+00 1.07134457739E+00 1.12030703095E+00 1.17147003668E+00 1.22492668215E+00 1.28077288844E+00 1.33910733649E+00 1.40003150700E+00 1.46364938723E+00 1.53006700548E+00 1.59939240875E+00 1.67173497490E+00 1.74720489842E+00 1.82591247195E+00 1.90796715133E+00 1.99347642841E+00 2.08254443362E+00 2.17527031529E+00 2.27174606928E+00 2.37205402307E+00 2.47626388713E+00 2.58442905244E+00 2.69658211322E+00 2.81272966021E+00 2.93284598230E+00 3.05686569645E+00 3.18467472687E+00 3.31610011638E+00 3.45089805737E+00 3.58873964402E+00 3.72919488236E+00 3.87171473869E+00 4.01560936397E+00 4.16002775495E+00 4.30393047489E+00 4.44606476658E+00 4.58493808565E+00 4.71879127054E+00 4.84557496510E+00 4.96293187144E+00 5.06818462457E+00 5.15833922433E+00 5.23010336647E+00 5.27992998877E+00 5.30408959717E+00 5.29877811997E+00 5.26026736806E+00 5.18509924185E+00 5.07032501099E+00 4.91378342041E+00 4.71440417631E+00 4.47251535633E+00 4.19012251658E+00 3.87111916315E+00 3.52138354493E+00 3.14871523455E+00 2.76257689930E+00 2.37362465447E+00 1.99304073912E+00 1.63171975386E+00 1.29939594463E+00 1.00382759520E+00 7.50163583134E-01 5.40600675885E-01 3.74396433541E-01 2.48238825614E-01 1.56904914202E-01 9.40843674598E-02 5.32167425136E-02 2.82014768880E-02 1.38831641636E-02 6.27743891557E-03 2.56461220912E-03 9.21317345749E-04 2.75433412799E-04 5.83029321428E-05 1.16326157773E-06 -6.94000232033E-06 -4.55795263725E-06 -1.99740477429E-06 -6.97140527485E-07 -2.03130279228E-07 -5.00983511413E-08 -1.04600475256E-08 -1.83553171967E-09 -2.67484430064E-10 -3.18760278112E-11 -3.05102136875E-12 -2.29888676828E-13 -1.33861922524E-14 -6.11328854205E-16 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 1 Number of nonzero Dij 1 1 1.16957606628E+00 2S 0 2.00 Wavefunction 2.28061240000E-04 2.38558440000E-04 2.49538800000E-04 2.61024580000E-04 2.73039020000E-04 2.85606480000E-04 2.98752390000E-04 3.12503390000E-04 3.26887320000E-04 3.41933330000E-04 3.57671890000E-04 3.74134870000E-04 3.91355630000E-04 4.09369040000E-04 4.28211580000E-04 4.47921440000E-04 4.68538520000E-04 4.90104600000E-04 5.12663350000E-04 5.36260480000E-04 5.60943780000E-04 5.86763250000E-04 6.13771200000E-04 6.42022340000E-04 6.71573900000E-04 7.02485750000E-04 7.34820510000E-04 7.68643690000E-04 8.04023830000E-04 8.41032590000E-04 8.79744970000E-04 9.20239420000E-04 9.62597970000E-04 1.00690650000E-03 1.05325470000E-03 1.10173660000E-03 1.15245050000E-03 1.20549900000E-03 1.26098980000E-03 1.31903540000E-03 1.37975340000E-03 1.44326690000E-03 1.50970470000E-03 1.57920160000E-03 1.65189850000E-03 1.72794280000E-03 1.80748890000E-03 1.89069820000E-03 1.97773950000E-03 2.06878950000E-03 2.16403300000E-03 2.26366360000E-03 2.36788350000E-03 2.47690450000E-03 2.59094810000E-03 2.71024640000E-03 2.83504180000E-03 2.96558830000E-03 3.10215160000E-03 3.24500980000E-03 3.39445400000E-03 3.55078880000E-03 3.71433320000E-03 3.88542090000E-03 4.06440160000E-03 4.25164090000E-03 4.44752220000E-03 4.65244650000E-03 4.86683400000E-03 5.09112480000E-03 5.32577980000E-03 5.57128190000E-03 5.82813710000E-03 6.09687560000E-03 6.37805320000E-03 6.67225250000E-03 6.98008430000E-03 7.30218940000E-03 7.63923960000E-03 7.99194030000E-03 8.36103140000E-03 8.74729010000E-03 9.15153220000E-03 9.57461520000E-03 1.00174400000E-02 1.04809540000E-02 1.09661540000E-02 1.14740890000E-02 1.20058630000E-02 1.25626400000E-02 1.31456460000E-02 1.37561760000E-02 1.43955950000E-02 1.50653480000E-02 1.57669610000E-02 1.65020480000E-02 1.72723210000E-02 1.80795920000E-02 1.89257890000E-02 1.98129560000E-02 2.07432710000E-02 2.17190510000E-02 2.27427690000E-02 2.38170670000E-02 2.49447670000E-02 2.61288960000E-02 2.73726990000E-02 2.86796610000E-02 3.00535350000E-02 3.14983670000E-02 3.30185220000E-02 3.46187250000E-02 3.63040940000E-02 3.80801840000E-02 3.99530350000E-02 4.19292250000E-02 4.40159300000E-02 4.62209910000E-02 4.85529910000E-02 5.10213370000E-02 5.36363540000E-02 5.64093920000E-02 5.93529420000E-02 6.24807640000E-02 6.58080320000E-02 6.93514920000E-02 7.31296380000E-02 7.71628970000E-02 8.14738390000E-02 8.60874020000E-02 9.10311230000E-02 9.63353900000E-02 1.02033710000E-01 1.08162940000E-01 1.14763610000E-01 1.21880100000E-01 1.29560890000E-01 1.37858740000E-01 1.46830770000E-01 1.56538460000E-01 1.67047540000E-01 1.78427610000E-01 1.90751620000E-01 2.04094960000E-01 2.18534240000E-01 2.34145590000E-01 2.51002410000E-01 2.69172570000E-01 2.88714910000E-01 3.09675080000E-01 3.32080720000E-01 3.55936040000E-01 3.81216000000E-01 4.07860320000E-01 4.35767680000E-01 4.64790660000E-01 4.94731850000E-01 5.25341850000E-01 5.56319700000E-01 5.87316160000E-01 6.17940180000E-01 6.47768460000E-01 6.76357740000E-01 7.03259030000E-01 7.28032750000E-01 7.50263620000E-01 7.69573940000E-01 7.85634540000E-01 7.98172620000E-01 8.06976450000E-01 8.11897290000E-01 8.12848980000E-01 8.09806150000E-01 8.02801390000E-01 7.91922100000E-01 7.77307050000E-01 7.59142580000E-01 7.37658640000E-01 7.13124220000E-01 6.85842340000E-01 6.56144670000E-01 6.24385610000E-01 5.90936210000E-01 5.56177930000E-01 5.20496240000E-01 4.84274450000E-01 4.47887530000E-01 4.11696340000E-01 3.76042110000E-01 3.41241450000E-01 3.07581890000E-01 2.75318040000E-01 2.44668500000E-01 2.15813570000E-01 1.88893830000E-01 1.64009610000E-01 1.41221420000E-01 1.20551280000E-01 1.01984980000E-01 8.54750970000E-02 7.09447920000E-02 5.82921310000E-02 4.73948360000E-02 3.81152710000E-02 3.03054550000E-02 2.38119420000E-02 1.84803600000E-02 1.41594970000E-02 1.07047720000E-02 7.98103950000E-03 5.86466740000E-03 4.24489950000E-03 3.02452910000E-03 2.11996200000E-03 1.46075900000E-03 9.88770080000E-04 6.56975680000E-04 4.28149640000E-04 2.73446490000E-04 1.71001470000E-04 1.04611490000E-04 6.25449480000E-05 3.65088500000E-05 2.07842100000E-05 1.15267480000E-05 6.21992080000E-06 3.26108620000E-06 1.65956250000E-06 8.18667970000E-07 3.90913520000E-07 1.80412660000E-07 8.03596320000E-08 3.45152480000E-08 1.43387890000E-08 5.93228830000E-09 2.35424230000E-09 8.94471490000E-10 3.24711200000E-10 1.12391220000E-10 3.70099790000E-11 1.15680410000E-11 3.42383290000E-12 9.57164160000E-13 2.52081250000E-13 6.23708290000E-14 1.44564310000E-14 3.12948980000E-15 6.30743890000E-16 1.17969830000E-16 2.04048250000E-17 3.25218780000E-18 4.75843400000E-19 6.36631050000E-20 7.75635790000E-21 8.56845860000E-22 8.54407110000E-23 7.65414440000E-24 6.12994000000E-25 4.36619470000E-26 2.75101980000E-27 1.52467280000E-28 7.38903300000E-30 3.11203400000E-31 1.13172540000E-32 3.52974210000E-34 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 0.00000000000E+00 2P 1 2.00 Wavefunction 8.98957130000E-07 9.83615700000E-07 1.07624690000E-06 1.17760160000E-06 1.28850130000E-06 1.40984480000E-06 1.54261580000E-06 1.68789030000E-06 1.84684590000E-06 2.02077100000E-06 2.21107530000E-06 2.41930140000E-06 2.64713680000E-06 2.89642840000E-06 3.16919680000E-06 3.46765280000E-06 3.79421550000E-06 4.15153180000E-06 4.54249780000E-06 4.97028250000E-06 5.43835320000E-06 5.95050370000E-06 6.51088500000E-06 7.12403930000E-06 7.79493630000E-06 8.52901360000E-06 9.33222110000E-06 1.02110690000E-05 1.11726800000E-05 1.22248480000E-05 1.33761020000E-05 1.46357710000E-05 1.60140660000E-05 1.75221570000E-05 1.91722670000E-05 2.09777700000E-05 2.29532980000E-05 2.51148630000E-05 2.74799830000E-05 3.00678260000E-05 3.28993630000E-05 3.59975440000E-05 3.93874750000E-05 4.30966280000E-05 4.71550620000E-05 5.15956640000E-05 5.64544190000E-05 6.17706980000E-05 6.75875790000E-05 7.39521970000E-05 8.09161190000E-05 8.85357710000E-05 9.68728870000E-05 1.05995010000E-04 1.15976040000E-04 1.26896840000E-04 1.38845870000E-04 1.51919910000E-04 1.66224870000E-04 1.81876590000E-04 1.99001830000E-04 2.17739260000E-04 2.38240600000E-04 2.60671830000E-04 2.85214540000E-04 3.12067380000E-04 3.41447680000E-04 3.73593200000E-04 4.08764000000E-04 4.47244620000E-04 4.89346260000E-04 5.35409390000E-04 5.85806410000E-04 6.40944640000E-04 7.01269620000E-04 7.67268660000E-04 8.39474740000E-04 9.18470730000E-04 1.00489410000E-03 1.09944200000E-03 1.20287660000E-03 1.31603150000E-03 1.43981810000E-03 1.57523260000E-03 1.72336440000E-03 1.88540410000E-03 2.06265320000E-03 2.25653400000E-03 2.46860100000E-03 2.70055250000E-03 2.95424410000E-03 3.23170270000E-03 3.53514210000E-03 3.86697990000E-03 4.22985560000E-03 4.62665040000E-03 5.06050850000E-03 5.53486060000E-03 6.05344890000E-03 6.62035380000E-03 7.24002350000E-03 7.91730500000E-03 8.65747810000E-03 9.46629150000E-03 1.03500010000E-02 1.13154120000E-02 1.23699220000E-02 1.35215680000E-02 1.47790740000E-02 1.61519070000E-02 1.76503260000E-02 1.92854410000E-02 2.10692740000E-02 2.30148110000E-02 2.51360720000E-02 2.74481650000E-02 2.99673510000E-02 3.27110970000E-02 3.56981350000E-02 3.89485130000E-02 4.24836320000E-02 4.63262830000E-02 5.05006690000E-02 5.50324050000E-02 5.99485040000E-02 6.52773380000E-02 7.10485660000E-02 7.72930280000E-02 8.40425970000E-02 9.13299840000E-02 9.91884820000E-02 1.07651650000E-01 1.16752930000E-01 1.26525160000E-01 1.37000060000E-01 1.48207520000E-01 1.60174940000E-01 1.72926350000E-01 1.86481480000E-01 2.00854780000E-01 2.16054300000E-01 2.32080610000E-01 2.48925590000E-01 2.66571320000E-01 2.84989010000E-01 3.04138010000E-01 3.23965010000E-01 3.44403510000E-01 3.65373510000E-01 3.86781650000E-01 4.08521720000E-01 4.30475570000E-01 4.52514570000E-01 4.74501410000E-01 4.96292330000E-01 5.17739610000E-01 5.38694190000E-01 5.59008350000E-01 5.78538110000E-01 5.97145370000E-01 6.14699520000E-01 6.31078490000E-01 6.46169150000E-01 6.59867260000E-01 6.72076870000E-01 6.82709610000E-01 6.91684020000E-01 6.98925100000E-01 7.04364440000E-01 7.07940810000E-01 7.09601510000E-01 7.09304040000E-01 7.07018090000E-01 7.02727520000E-01 6.96432030000E-01 6.88148310000E-01 6.77910670000E-01 6.65771070000E-01 6.51798520000E-01 6.36078260000E-01 6.18710530000E-01 5.99809270000E-01 5.79500700000E-01 5.57921850000E-01 5.35219180000E-01 5.11547050000E-01 4.87066300000E-01 4.61942730000E-01 4.36345600000E-01 4.10446070000E-01 3.84415550000E-01 3.58424000000E-01 3.32638200000E-01 3.07219910000E-01 2.82323990000E-01 2.58096500000E-01 2.34672880000E-01 2.12176130000E-01 1.90715170000E-01 1.70383370000E-01 1.51257350000E-01 1.33396060000E-01 1.16840270000E-01 1.01612380000E-01 8.77167280000E-02 7.51402570000E-02 6.38536040000E-02 5.38125840000E-02 4.49599720000E-02 3.72275650000E-02 3.05384160000E-02 2.48091760000E-02 1.99524460000E-02 1.58790590000E-02 1.25002080000E-02 9.72936010000E-03 7.48388970000E-03 5.68641140000E-03 4.26577580000E-03 3.15773900000E-03 2.30531370000E-03 1.65883430000E-03 1.17577310000E-03 8.20355700000E-04 5.63023490000E-04 3.79794600000E-04 2.51580610000E-04 1.63573110000E-04 1.04304180000E-04 6.51708470000E-05 3.98620180000E-05 2.38453890000E-05 1.39376870000E-05 7.95469470000E-06 4.43428940000E-06 2.42381730000E-06 1.32243450000E-06 7.01179730000E-07 3.60817550000E-07 1.79947130000E-07 8.68499360000E-08 4.05042750000E-08 1.82241930000E-08 7.89749940000E-09 3.29055730000E-09 1.31582470000E-09 5.04021790000E-10 1.84569310000E-10 6.44800160000E-11 2.14437850000E-11 6.77329950000E-12 2.02716060000E-12 5.73435020000E-13 1.52917770000E-13 3.83377820000E-14 9.01061930000E-15 1.97946330000E-15 4.05184260000E-16 7.70291150000E-17 1.35542170000E-17 2.19969820000E-18 3.28021010000E-19 4.47709660000E-20 5.57026670000E-21 6.29053060000E-22 6.41936620000E-23 5.89200780000E-24 4.84038870000E-25 3.54099120000E-26 1.04025474629E-07 1.13822193590E-07 1.24541542026E-07 1.36270436219E-07 1.49103933356E-07 1.63146098161E-07 1.78510740388E-07 1.95322435470E-07 2.13717461633E-07 2.33844971361E-07 2.55868139500E-07 2.79965507938E-07 3.06332472932E-07 3.35182800416E-07 3.66750402109E-07 4.01291282055E-07 4.39085481590E-07 4.80439508315E-07 5.25688689439E-07 5.75200012236E-07 6.29375000012E-07 6.88653040090E-07 7.53514955146E-07 8.24486873990E-07 9.02144528386E-07 9.87117946052E-07 1.08009654453E-06 1.18183477621E-06 1.29315829597E-06 1.41497052870E-06 1.54826026469E-06 1.69410959183E-06 1.85370260432E-06 2.02833545146E-06 2.21942607779E-06 2.42852720523E-06 2.65733801768E-06 2.90771719069E-06 3.18170085034E-06 3.48151692123E-06 3.80960362579E-06 4.16863033562E-06 4.56151930878E-06 4.99147002558E-06 5.46198450835E-06 5.97689686523E-06 6.54040645010E-06 7.15711060523E-06 7.83204322139E-06 8.57071784550E-06 9.37917248681E-06 1.02640229534E-05 1.12325132516E-05 1.22925816885E-05 1.34529249975E-05 1.47230767134E-05 1.61134803667E-05 1.76355872483E-05 1.93019505136E-05 2.11263353922E-05 2.31238393729E-05 2.53110229751E-05 2.77060594082E-05 3.03288907462E-05 3.32014153998E-05 3.63476727844E-05 3.97940804753E-05 4.35696606289E-05 4.77063223825E-05 5.22391589586E-05 5.72067804805E-05 6.26516904483E-05 6.86207024128E-05 7.51654042268E-05 8.23426834039E-05 9.02153092407E-05 9.88525893484E-05 1.08331117031E-04 1.18735587637E-04 1.30159764940E-04 1.42707516373E-04 1.56494046005E-04 1.71647235537E-04 1.88309227944E-04 2.06638178018E-04 2.26810290741E-04 2.49022143550E-04 2.73493328146E-04 3.00469474544E-04 3.30225815150E-04 3.63071133919E-04 3.99352560968E-04 4.39460770142E-04 4.83836487816E-04 5.32977475145E-04 5.87446964236E-04 6.47883638011E-04 7.15012657496E-04 7.89659465715E-04 8.72764619790E-04 9.65402464120E-04 1.06880178961E-03 1.18437093768E-03 1.31372671049E-03 1.45872784277E-03 1.62151550982E-03 1.80455924166E-03 2.01071151251E-03 2.24327198859E-03 2.50606244681E-03 2.80351360594E-03 3.14076871038E-03 3.52380309610E-03 3.95956387768E-03 4.45613424260E-03 5.02292334194E-03 5.67088843944E-03 6.41279175193E-03 7.26349955505E-03 8.24032698836E-03 9.36343491665E-03 1.06562880048E-02 1.21461785870E-02 1.38648229402E-02 1.58490404151E-02 1.81415205980E-02 2.07916853693E-02 2.38566497017E-02 2.74022891038E-02 3.15044135211E-02 3.62500406322E-02 4.17387702283E-02 4.80842492799E-02 5.54156754049E-02 6.38794052405E-02 7.36404555211E-02 8.48840712432E-02 9.78171094374E-02 1.12669234804E-01 1.29693864216E-01 1.49168682337E-01 1.71395643097E-01 1.96700259779E-01 2.25430042688E-01 2.57951899746E-01 2.94648172886E-01 3.35911075060E-01 3.82135300281E-01 4.33708202132E-01 4.90997399899E-01 5.54335200615E-01 6.23999361875E-01 7.00190149437E-01 7.83003257445E-01 8.72399095499E-01 9.68169322772E-01 1.06990206749E+00 1.17694878946E+00 1.28839590666E+00 1.40304572942E+00 1.51941113189E+00 1.63572807662E+00 1.74998872574E+00 1.85999612819E+00 1.96343800852E+00 2.05797582216E+00 2.14134166530E+00 2.21143585170E+00 2.26641759131E+00 2.30478236264E+00 2.32542302501E+00 2.32767137089E+00 2.31132116033E+00 2.27663207830E+00 2.22431636976E+00 2.15550869307E+00 2.07172066654E+00 1.97478277363E+00 1.86677492765E+00 1.74995053636E+00 1.62665709580E+00 1.49925710071E+00 1.37005333118E+00 1.24122136105E+00 1.11475181299E+00 9.92404254573E-01 8.75673640250E-01 7.65769924338E-01 6.63610302265E-01 5.69823407153E-01 4.84763868276E-01 4.08535573851E-01 3.41021693983E-01 2.81919140193E-01 2.30775428683E-01 1.87025910969E-01 1.50029700149E-01 1.19102642503E-01 9.35464244275E-02 7.26729699594E-02 5.58238988819E-02 4.23849627201E-02 3.17958383463E-02 2.35556993053E-02 1.72252899476E-02 1.24261336077E-02 8.83761289904E-03 6.19257110410E-03 4.27198245163E-03 2.89917717466E-03 1.93397835100E-03 1.26702877113E-03 8.14495755319E-04 5.13277507214E-04 3.16778033799E-04 1.91276228453E-04 1.12880444172E-04 6.50371734486E-05 3.65432323175E-05 2.00011141897E-05 1.06508296385E-05 5.51128621075E-06 2.76755055762E-06 1.34683091582E-06 6.34256632422E-07 2.88565251208E-07 1.26606876022E-07 5.35178329255E-08 2.17600643654E-08 8.49478422416E-09 3.17802605552E-09 1.13721806846E-09 3.88520620425E-10 1.26554746742E-10 3.93259153500E-11 1.17497916925E-11 3.49766761374E-12 9.83306238400E-13 2.60378634040E-13 6.47619419300E-14 1.50858230340E-14 3.28119261000E-15 6.64242422835E-16 1.24740993673E-16 2.16555346969E-17 3.46278928268E-18 5.08075929609E-19 6.81316603885E-20 8.31534492675E-21 9.19671830253E-22 9.17551722334E-23 8.21876019639E-24 6.57655444325E-25 4.67676887635E-26 2.93957105736E-27 1.62382520339E-28 7.83654991209E-30 3.28348569103E-31 1.18669691154E-32 3.67433596966E-34 9.67734434217E-36 2.15195566003E-37 4.00887879315E-39 6.20557422183E-41 7.91415504591E-43 8.24165248194E-45 6.94315118305E-47 4.68587255342E-49 2.50772373570E-51 GWW/examples/example01/methane_scf_25.in0000644000077300007730000000121412341332532020532 0ustar giannozzgiannozz&control calculation = 'scf', restart_mode='from_scratch', prefix='ch4', tprnfor = .true., pseudo_dir = './', / &system ibrav= 1, celldm(1) =25.0, nat=5, ntyp= 2, ecutwfc =40.0, nbnd=5 / &electrons diagonalization='cg' mixing_beta = 0.5, conv_thr = 1.0d-8 / ATOMIC_SPECIES H 1.0 H.pz-vbc.UPF C 12.0 C.pz-vbc.UPF ATOMIC_POSITIONS {bohr} H 1.198204546 1.198204546 1.198204546 H -1.198204546 -1.198204546 1.198204546 H 1.198204546 -1.198204546 -1.198204546 H -1.198204546 1.198204546 -1.198204546 C 0.000000000 0.000000000 0.000000000 GWW/examples/example01/methane_scf.in0000644000077300007730000000121412341332532020224 0ustar giannozzgiannozz&control calculation = 'scf', restart_mode='from_scratch', prefix='ch4', tprnfor = .true., pseudo_dir = './', / &system ibrav= 1, celldm(1) =15.0, nat=5, ntyp= 2, ecutwfc =40.0, nbnd=5 / &electrons diagonalization='cg' mixing_beta = 0.5, conv_thr = 1.0d-8 / ATOMIC_SPECIES H 1.0 H.pz-vbc.UPF C 12.0 C.pz-vbc.UPF ATOMIC_POSITIONS {bohr} H 1.198204546 1.198204546 1.198204546 H -1.198204546 -1.198204546 1.198204546 H 1.198204546 -1.198204546 -1.198204546 H -1.198204546 1.198204546 -1.198204546 C 0.000000000 0.000000000 0.000000000 GWW/examples/example01/methane_pw4gww_basis.in0000644000077300007730000000025112341332532022071 0ustar giannozzgiannozz&inputpw4gww prefix='ch4' num_nbndv(1)=4 num_nbnds=5 l_truncated_coulomb=.true. truncation_radius=7.5d0 numw_prod=100 pmat_cutoff=3d0 / GWW/examples/example01/methane_gww.in0000644000077300007730000000044512341332532020262 0ustar giannozzgiannozz&inputgww ggwin%prefix='ch4' ggwin%max_i=5, ggwin%i_min=1 ggwin%i_max=5 ggwin%omega=20 ggwin%n=118, ggwin%tau=11.8 ggwin%grid_freq=5 ggwin%second_grid_i=3 ggwin%second_grid_n=10 ggwin%omega_fit=20 ggwin%n_grid_fit=240 ggwin%n_fit=120, ggwin%n_multipoles=2 ggwin%l_truncated_coulomb=.true. / GWW/examples/example01/methane_gww_steps.in0000644000077300007730000000047412341332532021502 0ustar giannozzgiannozz&inputgww ggwin%prefix='ch4' ggwin%max_i=5, ggwin%i_min=4 ggwin%i_max=4 ggwin%omega=20 ggwin%n=118, ggwin%tau=11.8 ggwin%grid_freq=5 ggwin%second_grid_i=3 ggwin%second_grid_n=10 ggwin%omega_fit=20 ggwin%n_grid_fit=240 ggwin%n_fit=120, ggwin%n_multipoles=2 ggwin%l_truncated_coulomb=.true. ggwin%starting_point=6 / GWW/examples/example01/H.pz-vbc.UPF0000644000077300007730000003313312341332532017370 0ustar giannozzgiannozz Generated using ld1 code Author: P. Giannozzi Generation date: 1990 Info: H LDA 1s1 VonBarth-Car local 0 The Pseudo was generated with a Non-Relativistic Calculation 0.00000000000E+00 Local Potential cutoff radius nl pn l occ Rcut Rcut US E pseu 1S 0 0 1.00 0.00000000000 0.00000000000 0.00000000000 0 Version Number H Element NC Norm - Conserving pseudopotential F Nonlinear Core Correction SLA PZ NOGX NOGC PZ Exchange-Correlation functional 1.00000000000 Z valence 0.00000000000 Total energy 0.0000000 0.0000000 Suggested cutoff for wfc and rho -1 Max angular momentum component 131 Number of points in mesh 1 0 Number of Wavefunctions, Number of Projectors Wavefunctions nl l occ 1S 0 1.00 1.83156388887E-02 1.94968961086E-02 2.07543378737E-02 2.20928776651E-02 2.35177458560E-02 2.50345101500E-02 2.66490973364E-02 2.83678164497E-02 3.01973834223E-02 3.21449473269E-02 3.42181183117E-02 3.64249973374E-02 3.87742078317E-02 4.12749293858E-02 4.39369336234E-02 4.67706223840E-02 4.97870683679E-02 5.29980584034E-02 5.64161395038E-02 6.00546678953E-02 6.39278612067E-02 6.80508540250E-02 7.24397570343E-02 7.71117199683E-02 8.20849986239E-02 8.73790261954E-02 9.30144892107E-02 9.90134083638E-02 1.05399224562E-01 1.12196890520E-01 1.19432968267E-01 1.27135732932E-01 1.35335283237E-01 1.44063659101E-01 1.53354966845E-01 1.63245512454E-01 1.73773943450E-01 1.84981399907E-01 1.96911675204E-01 2.09611387151E-01 2.23130160148E-01 2.37520819095E-01 2.52839595805E-01 2.69146348729E-01 2.86504796860E-01 3.04982768711E-01 3.24652467358E-01 3.45590752577E-01 3.67879441171E-01 3.91605626677E-01 4.16862019679E-01 4.43747310081E-01 4.72366552741E-01 5.02831577971E-01 5.35261428519E-01 5.69782824731E-01 6.06530659713E-01 6.45648526428E-01 6.87289278791E-01 7.31615628947E-01 7.78800783071E-01 8.29029118180E-01 8.82496902585E-01 9.39413062813E-01 1.00000000000E+00 1.06449445892E+00 1.13314845307E+00 1.20623024942E+00 1.28402541669E+00 1.36683794117E+00 1.45499141462E+00 1.54883029863E+00 1.64872127070E+00 1.75505465696E+00 1.86824595743E+00 1.98873746958E+00 2.11700001661E+00 2.25353478721E+00 2.39887529397E+00 2.55358945806E+00 2.71828182846E+00 2.89359594417E+00 3.08021684892E+00 3.27887376794E+00 3.49034295746E+00 3.71545073794E+00 3.95507672292E+00 4.21015725614E+00 4.48168907034E+00 4.77073318197E+00 5.07841903718E+00 5.40594892514E+00 5.75460267601E+00 6.12574266188E+00 6.52081912033E+00 6.94137582120E+00 7.38905609893E+00 7.86560927394E+00 8.37289748813E+00 8.91290298120E+00 9.48773583636E+00 1.00996422255E+01 1.07510131861E+01 1.14443939643E+01 1.21824939607E+01 1.29681973170E+01 1.38045741861E+01 1.46948927288E+01 1.56426318842E+01 1.66514949636E+01 1.77254241215E+01 1.88686157593E+01 2.00855369232E+01 2.13809427591E+01 2.27598950935E+01 2.42277822126E+01 2.57903399172E+01 2.74536739355E+01 2.92242837812E+01 3.11090881510E+01 3.31154519587E+01 3.52512151146E+01 3.75247231596E+01 3.99448598758E+01 4.25210820001E+01 4.52634561763E+01 4.81826982911E+01 5.12902153466E+01 5.45981500331E+01 5.81194281774E+01 6.18678092504E+01 1.14472743055E-03 1.21855600679E-03 1.29714611711E-03 1.38080485407E-03 1.46985911600E-03 1.56465688437E-03 1.66556858352E-03 1.77298852811E-03 1.88733646389E-03 2.00905920793E-03 2.13863239448E-03 2.27656233359E-03 2.42338798948E-03 2.57968308661E-03 2.74605835146E-03 2.92316389900E-03 3.11169177299E-03 3.31237865021E-03 3.52600871899E-03 3.75341674346E-03 3.99549132542E-03 4.25317837656E-03 4.52748481464E-03 4.81948249802E-03 5.13031241399E-03 5.46118913721E-03 5.81340557567E-03 6.18833802274E-03 6.58745153512E-03 7.01230565752E-03 7.46456051667E-03 7.94598330825E-03 8.45845520229E-03 9.00397869384E-03 9.58468542781E-03 1.02028445284E-02 1.08608714657E-02 1.15613374942E-02 1.23069797003E-02 1.31007116969E-02 1.39456350093E-02 1.48450511935E-02 1.58024747378E-02 1.68216467956E-02 1.79065498038E-02 1.90614230444E-02 2.02907792099E-02 2.15994220361E-02 2.29924650732E-02 2.44753516673E-02 2.60538762299E-02 2.77342068801E-02 2.95229095463E-02 3.14269736232E-02 3.34538392824E-02 3.56114265457E-02 3.79081662320E-02 4.03530329017E-02 4.29555799244E-02 4.57259768092E-02 4.86750489420E-02 5.18143198863E-02 5.51560564115E-02 5.87133164258E-02 6.25000000000E-02 6.65309036824E-02 7.08217783167E-02 7.53893905888E-02 8.02515885430E-02 8.54273713234E-02 9.09369634136E-02 9.68018936646E-02 1.03045079419E-01 1.09690916060E-01 1.16765372340E-01 1.24296091849E-01 1.32312501038E-01 1.40845924201E-01 1.49929705873E-01 1.59599341129E-01 1.69892614279E-01 1.80849746511E-01 1.92513553057E-01 2.04929610496E-01 2.18146434841E-01 2.32215671121E-01 2.47192295183E-01 2.63134828509E-01 2.80105566896E-01 2.98170823873E-01 3.17401189824E-01 3.37871807821E-01 3.59662667250E-01 3.82858916368E-01 4.07551195021E-01 4.33835988825E-01 4.61816006183E-01 4.91600579622E-01 5.23306093008E-01 5.57056436325E-01 5.92983489772E-01 6.31227639093E-01 6.71938324130E-01 7.15274622771E-01 7.61405872544E-01 8.10512332311E-01 8.62785886629E-01 9.18430795549E-01 9.77664492762E-01 1.04071843523E+00 1.10783900759E+00 1.17928848495E+00 1.25534605770E+00 1.33630892245E+00 1.42249344335E+00 1.51423638829E+00 1.61189624482E+00 1.71585462097E+00 1.82651773633E+00 1.94431800944E+00 2.06971574742E+00 2.20320094466E+00 2.34529519748E+00 2.49655374224E+00 2.65756762500E+00 2.82896601102E+00 3.01141864319E+00 3.20563845916E+00 3.41238437707E+00 3.63246426109E+00 3.86673807815E+00 -1.28520734427E+01 -1.28477738461E+01 -1.28429043374E+01 -1.28373897623E+01 -1.28311451659E+01 -1.28240745458E+01 -1.28160694557E+01 -1.28070074434E+01 -1.27967503082E+01 -1.27851421602E+01 -1.27720072639E+01 -1.27571476510E+01 -1.27403404858E+01 -1.27213351692E+01 -1.26998501721E+01 -1.26755695914E+01 -1.26481394325E+01 -1.26171636282E+01 -1.25821998225E+01 -1.25427549619E+01 -1.24982807663E+01 -1.24481691770E+01 -1.23917479276E+01 -1.23282764256E+01 -1.22569422046E+01 -1.21768582750E+01 -1.20870617994E+01 -1.19865146239E+01 -1.18741063179E+01 -1.17486605129E+01 -1.16089454723E+01 -1.14536899624E+01 -1.12816056190E+01 -1.10914170789E+01 -1.08819011471E+01 -1.06519361513E+01 -1.04005623252E+01 -1.01270535093E+01 -9.83099956200E+00 -9.51239758030E+00 -9.17174826485E+00 -8.81015154043E+00 -8.42939293729E+00 -8.03200948773E+00 -7.62132142072E+00 -7.20141440844E+00 -6.77705742491E+00 -6.35354445007E+00 -5.93645523944E+00 -5.53134165780E+00 -5.14336112886E+00 -4.77689553020E+00 -4.43520848186E+00 -4.12020105875E+00 -3.83231994255E+00 -3.57064956816E+00 -3.33318260449E+00 -3.11721972628E+00 -2.91981450742E+00 -2.73816754273E+00 -2.56989350774E+00 -2.41313003425E+00 -2.26650901749E+00 -2.12904646842E+00 -2.00001310323E+00 -1.87882857167E+00 -1.76499416977E+00 -1.65805827847E+00 -1.55760156978E+00 -1.46323125812E+00 -1.37457855759E+00 -1.29129705286E+00 -1.21306131943E+00 -1.13956564946E+00 -1.07052285704E+00 -1.00566315594E+00 -9.44733105482E-01 -8.87494620162E-01 -8.33724039357E-01 -7.83211253354E-01 -7.35758882343E-01 -6.91181505154E-01 -6.49304934717E-01 -6.09965537422E-01 -5.73009593720E-01 -5.38292697458E-01 -5.05679191609E-01 -4.75041638191E-01 -4.46260320297E-01 -4.19222774302E-01 -3.93823350408E-01 -3.69962799815E-01 -3.47547886901E-01 -3.26491024908E-01 -3.06709933690E-01 -2.88127318203E-01 -2.70670566473E-01 -2.54271465864E-01 -2.38865936533E-01 -2.24393781041E-01 -2.10798449124E-01 -1.98026816728E-01 -1.86028978421E-01 -1.74758052391E-01 -1.64169997248E-01 -1.54223439937E-01 -1.44879514069E-01 -1.36101708050E-01 -1.27855722413E-01 -1.20109335791E-01 -1.12832279008E-01 -1.05996116807E-01 -9.95741367357E-02 -9.35412447679E-02 -8.78738672468E-02 -8.25498587716E-02 -7.75484156634E-02 -7.28499946747E-02 -6.84362366233E-02 -6.42898946538E-02 -6.03947668446E-02 -5.67356328994E-02 -5.32981946727E-02 -5.00690202999E-02 -4.70354917120E-02 -4.41857553301E-02 -4.15086757474E-02 -3.89937922172E-02 -3.66312777775E-02 -3.44119008517E-02 -3.23269891763E-02 0 Number of nonzero Dij 1S 0 1.00 Wavefunction 2.88417980000E-02 3.06992250000E-02 3.26758880000E-02 3.47793630000E-02 3.70176890000E-02 3.93993980000E-02 4.19335360000E-02 4.46296930000E-02 4.74980260000E-02 5.05492900000E-02 5.37948600000E-02 5.72467610000E-02 6.09176880000E-02 6.48210330000E-02 6.89709010000E-02 7.33821290000E-02 7.80702990000E-02 8.30517390000E-02 8.83435240000E-02 9.39634680000E-02 9.99300930000E-02 1.06262600000E-01 1.12980800000E-01 1.20105060000E-01 1.27656180000E-01 1.35655270000E-01 1.44123610000E-01 1.53082380000E-01 1.62552520000E-01 1.72554300000E-01 1.83107100000E-01 1.94228900000E-01 2.05935850000E-01 2.18241720000E-01 2.31157310000E-01 2.44689750000E-01 2.58841850000E-01 2.73611310000E-01 2.88989960000E-01 3.04963070000E-01 3.21508570000E-01 3.38596550000E-01 3.56188710000E-01 3.74238100000E-01 3.92689030000E-01 4.11477200000E-01 4.30530040000E-01 4.49767230000E-01 4.69101320000E-01 4.88438290000E-01 5.07678040000E-01 5.26714510000E-01 5.45435510000E-01 5.63722120000E-01 5.81447800000E-01 5.98477370000E-01 6.14666190000E-01 6.29859740000E-01 6.43894030000E-01 6.56596810000E-01 6.67789700000E-01 6.77290980000E-01 6.84919040000E-01 6.90496050000E-01 6.93851860000E-01 6.94828030000E-01 6.93282060000E-01 6.89091610000E-01 6.82158800000E-01 6.72414560000E-01 6.59822730000E-01 6.44383970000E-01 6.26139280000E-01 6.05172840000E-01 5.81614290000E-01 5.55639920000E-01 5.27472870000E-01 4.97381950000E-01 4.65679080000E-01 4.32715040000E-01 3.98873460000E-01 3.64563110000E-01 3.30208380000E-01 2.96238340000E-01 2.63074440000E-01 2.31117590000E-01 2.00735080000E-01 1.72248160000E-01 1.45921080000E-01 1.21952430000E-01 1.00469460000E-01 8.15259110000E-02 6.51037310000E-02 5.11184740000E-02 3.94280920000E-02 2.98443810000E-02 2.21461340000E-02 1.60929310000E-02 1.14384770000E-02 7.94251530000E-03 5.38057890000E-03 3.55111180000E-03 2.27982720000E-03 1.42143930000E-03 8.59150620000E-04 5.02420710000E-04 2.83624610000E-04 1.54298730000E-04 8.07158740000E-05 4.05091800000E-05 1.94783590000E-05 9.00917540000E-06 4.14767900000E-06 1.81282520000E-06 7.49686700000E-07 2.92297650000E-07 1.07038760000E-07 3.66664760000E-08 1.16987270000E-08 3.46064980000E-09 9.44509430000E-10 2.36607150000E-10 5.41028540000E-11 1.12260320000E-11 2.10050760000E-12 3.52060130000E-13 5.24831520000E-14 6.90637980000E-15 7.95818150000E-16 7.96141140000E-17 6.85203010000E-18 8.31849311873E-04 9.42442415601E-04 1.06771365659E-03 1.20960409069E-03 1.37030929890E-03 1.55231256276E-03 1.75842144146E-03 1.99180949727E-03 2.25606247390E-03 2.55523071950E-03 2.89388696242E-03 3.27719164499E-03 3.71096471127E-03 4.20176631919E-03 4.75698518475E-03 5.38493685657E-03 6.09497158595E-03 6.89759135092E-03 7.80457823274E-03 8.82913331859E-03 9.98602348699E-03 1.12917401588E-02 1.27646611686E-02 1.44252254376E-02 1.62961002922E-02 1.84023522788E-02 2.07716149594E-02 2.34342150665E-02 2.64233217584E-02 2.97749864485E-02 3.35282100704E-02 3.77248655952E-02 4.24095743152E-02 4.76294483486E-02 5.34337019664E-02 5.98730737551E-02 6.69991033114E-02 7.48631489599E-02 8.35151969808E-02 9.30024740638E-02 1.03367760583E-01 1.14647623672E-01 1.26870397131E-01 1.40054155492E-01 1.54204674282E-01 1.69313486120E-01 1.85356115342E-01 2.02290561182E-01 2.20056048426E-01 2.38571963138E-01 2.57736992298E-01 2.77428175045E-01 2.97499895569E-01 3.17782628577E-01 3.38081544125E-01 3.58175162402E-01 3.77814525129E-01 3.96723292073E-01 4.14599521870E-01 4.31119370902E-01 4.45943083426E-01 4.58723071589E-01 4.69114091355E-01 4.76784795066E-01 4.81430403625E-01 4.82785991274E-01 4.80640014718E-01 4.74847246972E-01 4.65340628417E-01 4.52141340500E-01 4.35366035025E-01 4.15230700793E-01 3.92050397959E-01 3.66234166274E-01 3.38275182332E-01 3.08735720698E-01 2.78227628586E-01 2.47388804186E-01 2.16857005550E-01 1.87242305842E-01 1.59100037092E-01 1.32906261173E-01 1.09037574222E-01 8.77571540860E-02 6.92081609813E-02 5.34153404074E-02 4.02945723426E-02 2.96694286234E-02 2.12929615884E-02 1.48723951829E-02 1.00941123927E-02 6.64647416438E-03 4.23849579012E-03 2.61309838409E-03 1.55457443876E-03 8.90687077273E-04 4.90451251146E-04 2.58982428171E-04 1.30838756080E-04 6.30835492907E-05 2.89506292991E-05 1.26103950161E-05 5.19761206186E-06 2.02048968358E-06 7.38139787846E-07 2.52426569837E-07 8.04429193977E-08 2.38080980796E-08 6.51505231558E-09 1.64099366427E-09 3.79406469333E-10 8.11652413880E-11 1.72032410870E-11 3.28633520576E-12 5.62030148157E-13 8.54379161955E-14 1.14572961423E-14 1.34443046226E-15 1.36860213421E-16 1.19760970382E-17 8.92098063359E-19 5.59829434311E-20 2.92711881095E-21 1.26023794465E-22 4.41213217766E-24 1.23946335136E-25 2.75448124386E-27 4.76980819418E-29 6.33326527869E-31 6.33840714800E-33 4.69503164913E-35 GWW/examples/example01/methane_pw4gww.in0000644000077300007730000000022412341332532020710 0ustar giannozzgiannozz&inputpw4gww prefix='ch4' num_nbndv(1)=4 num_nbnds=5 l_truncated_coulomb=.true. truncation_radius=7.5d0 numw_prod=50 / GWW/examples/example01/reference/0000755000077300007730000000000012341332543017362 5ustar giannozzgiannozzGWW/examples/example01/reference/methane_scf.out0000644000077300007730000002762012341332532022374 0ustar giannozzgiannozz Program PWSCF v.4.3.2 starts on 16Sep2011 at 15:23:11 This program is part of the open-source Quantum ESPRESSO suite for quantum simulation of materials; please cite "P. Giannozzi et al., J. Phys.:Condens. Matter 21 395502 (2009); URL http://www.quantum-espresso.org", in publications or presentations arising from this work. More details at http://www.quantum-espresso.org/quote.php Parallel version (MPI), running on 2 processors R & G space division: proc/pool = 2 EXPERIMENTAL VERSION WITH EXACT EXCHANGE Current dimensions of program PWSCF are: Max number of different atomic species (ntypx) = 10 Max number of k-points (npk) = 40000 Max angular momentum in pseudopotentials (lmaxx) = 3 Waiting for input... Reading input from stdin file H.pz-vbc.UPF: wavefunction(s) 1S renormalized gamma-point specific algorithms are used Subspace diagonalization in iterative solution of the eigenvalue problem: a serial algorithm will be used ATT1.1.1 ATT1.1.2 ATT1.1.3 ATT1.1.4 ATT1.1.5 ATT1.1.6 Parallelization info -------------------- sticks: dense smooth PW G-vecs: dense smooth PW Min 1434 1434 357 57654 57654 7179 Max 1435 1435 360 57659 57659 7184 Sum 2869 2869 717 115313 115313 14363 Tot 1435 1435 359 bravais-lattice index = 1 lattice parameter (alat) = 15.0000 a.u. unit-cell volume = 3375.0000 (a.u.)^3 number of atoms/cell = 5 number of atomic types = 2 number of electrons = 8.00 number of Kohn-Sham states= 5 kinetic-energy cutoff = 40.0000 Ry charge density cutoff = 160.0000 Ry convergence threshold = 1.0E-08 mixing beta = 0.5000 number of iterations used = 8 plain mixing Exchange-correlation = SLA PZ NOGX NOGC ( 1 1 0 0 0) EXX-fraction = 0.00 celldm(1)= 15.000000 celldm(2)= 0.000000 celldm(3)= 0.000000 celldm(4)= 0.000000 celldm(5)= 0.000000 celldm(6)= 0.000000 crystal axes: (cart. coord. in units of alat) a(1) = ( 1.000000 0.000000 0.000000 ) a(2) = ( 0.000000 1.000000 0.000000 ) a(3) = ( 0.000000 0.000000 1.000000 ) reciprocal axes: (cart. coord. in units 2 pi/alat) b(1) = ( 1.000000 0.000000 0.000000 ) b(2) = ( 0.000000 1.000000 0.000000 ) b(3) = ( 0.000000 0.000000 1.000000 ) PseudoPot. # 1 for H read from file: ./H.pz-vbc.UPF MD5 check sum: 90becb985b714f09656c73597998d266 Pseudo is Norm-conserving, Zval = 1.0 Generated by new atomic code, or converted to UPF format Using radial grid of 131 points, 0 beta functions with: PseudoPot. # 2 for C read from file: ./C.pz-vbc.UPF MD5 check sum: ab53dd623bfeb79c5a7b057bc96eae20 Pseudo is Norm-conserving, Zval = 4.0 Generated by new atomic code, or converted to UPF format Using radial grid of 269 points, 1 beta functions with: l(1) = 0 atomic species valence mass pseudopotential H 1.00 1.00000 H ( 1.00) C 4.00 12.00000 C ( 1.00) 24 Sym. Ops. (no inversion) found Cartesian axes site n. atom positions (alat units) 1 H tau( 1) = ( 0.0798803 0.0798803 0.0798803 ) 2 H tau( 2) = ( -0.0798803 -0.0798803 0.0798803 ) 3 H tau( 3) = ( 0.0798803 -0.0798803 -0.0798803 ) 4 H tau( 4) = ( -0.0798803 0.0798803 -0.0798803 ) 5 C tau( 5) = ( 0.0000000 0.0000000 0.0000000 ) number of k points= 1 cart. coord. in units 2pi/alat k( 1) = ( 0.0000000 0.0000000 0.0000000), wk = 2.0000000 Dense grid: 57657 G-vectors FFT dimensions: ( 64, 64, 64) Largest allocated arrays est. size (Mb) dimensions Kohn-Sham Wavefunctions 0.27 Mb ( 3590, 5) NL pseudopotentials 0.05 Mb ( 3590, 1) Each V/rho on FFT grid 2.00 Mb ( 131072) Each G-vector array 0.22 Mb ( 28830) G-vector shells 0.01 Mb ( 761) Largest temporary arrays est. size (Mb) dimensions Each subspace H/S matrix 0.00 Mb ( 5, 5) Each matrix 0.00 Mb ( 1, 5) Arrays for rho mixing 16.00 Mb ( 131072, 8) Initial potential from superposition of free atoms Check: negative starting charge= -0.002917 starting charge 7.99987, renormalised to 8.00000 negative rho (up, down): 0.292E-02 0.000E+00 Starting wfc are 8 atomic wfcs total cpu time spent up to now is 1.6 secs Self-consistent Calculation iteration # 1 ecut= 40.00 Ry beta=0.50 CG style diagonalization ethr = 1.00E-02, avg # of iterations = 3.4 negative rho (up, down): 0.144E-02 0.000E+00 Exx not active 0. total cpu time spent up to now is 2.6 secs total energy = -15.84940715 Ry Harris-Foulkes estimate = -16.24267877 Ry estimated scf accuracy < 0.68541180 Ry iteration # 2 ecut= 40.00 Ry beta=0.50 CG style diagonalization ethr = 8.57E-03, avg # of iterations = 3.8 negative rho (up, down): 0.683E-03 0.000E+00 Exx not active 0. total cpu time spent up to now is 3.3 secs total energy = -15.96822268 Ry Harris-Foulkes estimate = -15.98278294 Ry estimated scf accuracy < 0.03868161 Ry iteration # 3 ecut= 40.00 Ry beta=0.50 CG style diagonalization ethr = 4.84E-04, avg # of iterations = 3.4 negative rho (up, down): 0.457E-06 0.000E+00 Exx not active 0. total cpu time spent up to now is 4.0 secs total energy = -15.96619760 Ry Harris-Foulkes estimate = -15.97039274 Ry estimated scf accuracy < 0.00879322 Ry iteration # 4 ecut= 40.00 Ry beta=0.50 CG style diagonalization ethr = 1.10E-04, avg # of iterations = 3.8 negative rho (up, down): 0.464E-04 0.000E+00 Exx not active 0. total cpu time spent up to now is 4.9 secs total energy = -15.96709290 Ry Harris-Foulkes estimate = -15.96884460 Ry estimated scf accuracy < 0.00317099 Ry iteration # 5 ecut= 40.00 Ry beta=0.50 CG style diagonalization ethr = 3.96E-05, avg # of iterations = 3.8 negative rho (up, down): 0.307E-05 0.000E+00 Exx not active 0. total cpu time spent up to now is 5.7 secs total energy = -15.96776612 Ry Harris-Foulkes estimate = -15.96780177 Ry estimated scf accuracy < 0.00009060 Ry iteration # 6 ecut= 40.00 Ry beta=0.50 CG style diagonalization ethr = 1.13E-06, avg # of iterations = 3.8 negative rho (up, down): 0.474E-07 0.000E+00 Exx not active 0. total cpu time spent up to now is 6.5 secs total energy = -15.96778245 Ry Harris-Foulkes estimate = -15.96778334 Ry estimated scf accuracy < 0.00000447 Ry iteration # 7 ecut= 40.00 Ry beta=0.50 CG style diagonalization ethr = 5.59E-08, avg # of iterations = 3.8 Exx not active 0. total cpu time spent up to now is 7.2 secs total energy = -15.96778321 Ry Harris-Foulkes estimate = -15.96778334 Ry estimated scf accuracy < 0.00000037 Ry iteration # 8 ecut= 40.00 Ry beta=0.50 CG style diagonalization ethr = 4.62E-09, avg # of iterations = 3.6 Exx not active 0. total cpu time spent up to now is 8.0 secs total energy = -15.96778326 Ry Harris-Foulkes estimate = -15.96778326 Ry estimated scf accuracy < 0.00000002 Ry iteration # 9 ecut= 40.00 Ry beta=0.50 CG style diagonalization ethr = 2.70E-10, avg # of iterations = 3.6 Exx not active 0. total cpu time spent up to now is 8.6 secs End of self-consistent calculation k = 0.0000 0.0000 0.0000 ( 7182 PWs) bands (ev): -16.6118 -9.1110 -9.1110 -9.1110 -0.5651 highest occupied, lowest unoccupied level (ev): -9.1110 -0.5651 ! total energy = -15.96778326 Ry Harris-Foulkes estimate = -15.96778326 Ry estimated scf accuracy < 4.6E-09 Ry The total energy is the sum of the following terms: one-electron contribution = -35.26101750 Ry hartree contribution = 18.41287416 Ry xc contribution = -6.14149282 Ry ewald contribution = 7.02185290 Ry - averaged Fock potential = -0.00000000 Ry + Fock energy = 0.00000000 Ry DEXX 0. 1.E-8 convergence has been achieved in 9 iterations Forces acting on atoms (Ry/au): atom 1 type 1 force = 0.00003368 0.00003368 0.00003368 atom 2 type 1 force = -0.00003368 -0.00003368 0.00003368 atom 3 type 1 force = 0.00003368 -0.00003368 -0.00003368 atom 4 type 1 force = -0.00003368 0.00003368 -0.00003368 atom 5 type 2 force = 0.00000000 0.00000000 0.00000000 Total force = 0.000117 Total SCF correction = 0.000038 SCF correction compared to forces is large: reduce conv_thr to get better values Writing output data file ch4.save init_run : 0.41s CPU 1.10s WALL ( 1 calls) electrons : 6.04s CPU 6.99s WALL ( 1 calls) forces : 0.17s CPU 0.18s WALL ( 1 calls) Called by init_run: wfcinit : 0.11s CPU 0.76s WALL ( 1 calls) potinit : 0.14s CPU 0.15s WALL ( 1 calls) Called by electrons: c_bands : 4.06s CPU 4.46s WALL ( 9 calls) sum_band : 0.89s CPU 1.02s WALL ( 9 calls) v_of_rho : 0.56s CPU 0.60s WALL ( 10 calls) mix_rho : 0.36s CPU 0.39s WALL ( 9 calls) Called by c_bands: init_us_2 : 0.03s CPU 0.04s WALL ( 19 calls) rcgdiagg : 3.41s CPU 3.68s WALL ( 9 calls) wfcrot : 0.74s CPU 1.51s WALL ( 9 calls) Called by *cgdiagg: h_psi : 4.03s CPU 4.60s WALL ( 134 calls) rdiaghg : 0.00s CPU 0.46s WALL ( 9 calls) Called by h_psi: add_vuspsi : 0.01s CPU 0.01s WALL ( 134 calls) General routines calbec : 0.03s CPU 0.20s WALL ( 263 calls) fft : 0.87s CPU 0.92s WALL ( 41 calls) fftw : 3.72s CPU 4.21s WALL ( 333 calls) davcio : 0.01s CPU 0.02s WALL ( 9 calls) Parallel routines fft_scatter : 1.03s CPU 1.21s WALL ( 374 calls) EXX routines PWSCF : 6.70s CPU 9.02s WALL This run was terminated on: 15:23:20 16Sep2011 =------------------------------------------------------------------------------= JOB DONE. =------------------------------------------------------------------------------= GWW/examples/example01/reference/methane_pw4gww.out0000644000077300007730000002644712341332532023066 0ustar giannozzgiannozz Program PW4GWW v.4.3.2 starts on 16Sep2011 at 15:24:28 This program is part of the open-source Quantum ESPRESSO suite for quantum simulation of materials; please cite "P. Giannozzi et al., J. Phys.:Condens. Matter 21 395502 (2009); URL http://www.quantum-espresso.org", in publications or presentations arising from this work. More details at http://www.quantum-espresso.org/quote.php Parallel version (MPI), running on 2 processors R & G space division: proc/pool = 2 Info: using nr1, nr2, nr3 values from input Info: using nr1s, nr2s, nr3s values from input IMPORTANT: XC functional enforced from input : Exchange-correlation = SLA PZ NOGX NOGC ( 1 1 0 0 0) EXX-fraction = 0.00 Any further DFT definition will be discarded Please, verify this is what you really want file H.pz-vbc.UPF: wavefunction(s) 1S renormalized ATT1.1.1 ATT1.1.2 ATT1.1.3 ATT1.1.4 ATT1.1.5 ATT1.1.6 Parallelization info -------------------- sticks: dense smooth PW G-vecs: dense smooth PW Min 1434 1434 357 57654 57654 7179 Max 1435 1435 360 57659 57659 7184 Sum 2869 2869 717 115313 115313 14363 Tot 1435 1435 359 IMPORTANT: XC functional enforced from input : Exchange-correlation = SLA PZ NOGX NOGC ( 1 1 0 0 0) EXX-fraction = 0.00 Any further DFT definition will be discarded Please, verify this is what you really want EXX fraction changed: 0.00 EXX Screening parameter changed: 0.0000000 nkstot= 1 after first init after g stuff after wfc waves after davcio bravais-lattice index = 1 lattice parameter (alat) = 15.0000 a.u. unit-cell volume = 3375.0000 (a.u.)^3 number of atoms/cell = 5 number of atomic types = 2 number of electrons = 8.00 number of Kohn-Sham states= 5 kinetic-energy cutoff = 40.0000 Ry charge density cutoff = 160.0000 Ry Exchange-correlation = SLA PZ NOGX NOGC ( 1 1 0 0 0) EXX-fraction = 0.00 celldm(1)= 15.000000 celldm(2)= 0.000000 celldm(3)= 0.000000 celldm(4)= 0.000000 celldm(5)= 0.000000 celldm(6)= 0.000000 crystal axes: (cart. coord. in units of alat) a(1) = ( 1.000000 0.000000 0.000000 ) a(2) = ( 0.000000 1.000000 0.000000 ) a(3) = ( 0.000000 0.000000 1.000000 ) reciprocal axes: (cart. coord. in units 2 pi/alat) b(1) = ( 1.000000 0.000000 0.000000 ) b(2) = ( 0.000000 1.000000 0.000000 ) b(3) = ( 0.000000 0.000000 1.000000 ) PseudoPot. # 1 for H read from file: ./H.pz-vbc.UPF MD5 check sum: 90becb985b714f09656c73597998d266 Pseudo is Norm-conserving, Zval = 1.0 Generated by new atomic code, or converted to UPF format Using radial grid of 131 points, 0 beta functions with: PseudoPot. # 2 for C read from file: ./C.pz-vbc.UPF MD5 check sum: ab53dd623bfeb79c5a7b057bc96eae20 Pseudo is Norm-conserving, Zval = 4.0 Generated by new atomic code, or converted to UPF format Using radial grid of 269 points, 1 beta functions with: l(1) = 0 atomic species valence mass pseudopotential H 1.00 1.00000 H ( 1.00) C 4.00 12.00000 C ( 1.00) 24 Sym. Ops. (no inversion) found Cartesian axes site n. atom positions (alat units) 1 H tau( 1) = ( 0.0798803 0.0798803 0.0798803 ) 2 H tau( 2) = ( -0.0798803 -0.0798803 0.0798803 ) 3 H tau( 3) = ( 0.0798803 -0.0798803 -0.0798803 ) 4 H tau( 4) = ( -0.0798803 0.0798803 -0.0798803 ) 5 C tau( 5) = ( 0.0000000 0.0000000 0.0000000 ) number of k points= 1 cart. coord. in units 2pi/alat k( 1) = ( 0.0000000 0.0000000 0.0000000), wk = 2.0000000 Dense grid: 57657 G-vectors FFT dimensions: ( 64, 64, 64) k = 0.0000 0.0000 0.0000 band energies (ev): -16.6118 -9.1110 -9.1110 -9.1110 -0.5651 highest occupied, lowest unoccupied level (ev): -9.1110 -0.5651 MAX_NGM: 3590 28830 KS energy: 1 -16.612458104558677 KS energy: 2 -9.111608390881141 KS energy: 3 -9.111608391016569 KS energy: 4 -9.111608391090758 KS energy: 5 -0.5651693753102617 Routine energies_xc : 1 -14.31029927641566 Routine energies_xc : 2 -13.427202235642545 Routine energies_xc : 3 -13.427202235993297 Routine energies_xc : 4 -13.427202235772315 Routine energies_xc : 5 -2.0960479151122957 Routine energies_h : 1 67.23563581947754 Routine energies_h : 2 61.094752506545284 Routine energies_h : 3 61.094752508792766 Routine energies_h : 4 61.094752507441406 Routine energies_h : 5 4.9260709082213605 stop_clock: clock # 12 for h_psi not running Transform to real wfcs MATRIX BIG1 NRS 64 64 64 NRXS 64 64 64 Calculate grid MATRIX BIG2 MATRIX IIW 1 MATRIX JJW 1 Calculate US Out of matrix_wannier_gamma_big LOCALIZING WANNIER FUNCTIONS: 212.29991707558295 Spread 233.24633419566493 212.29991707558295 5 4 Spread 234.8634536752529 233.24633419566493 5 4 Spread 234.8646232632614 234.8634536752529 5 4 Spread 234.86463119300876 234.8646232632614 5 4 Spread 234.86463119688253 234.86463119300876 5 4 Spread 234.86463119693542 234.86463119688253 5 4 Center Wannier: 0.7945510000164457 0.7945509529358443 0.7945509529358443 Center Wannier: 0.7945508943176969 14.205449042173475 14.205449042173475 Center Wannier: 14.205449059102676 14.205449063312946 14.205449063312946 Center Wannier: 14.205449048421887 0.7945509394245194 0.7945509394245194 USE RESTART: 1 Call initialize_fft_custom ATT1 ATT2 ATT1.0 ATT1.1 ATT1.2 ATT1.3 ATT1.1.1 ATT1.1.2 ATT1.1.3 ATT1.1.4 ATT1.1.5 ATT1.1.6 ATT1.3.1 ATT1.5 ATT1.6 Planes per process (custom) : nr3t = 32 npp = 16 ncplane = 1024 Proc/ planes cols G 1 16 357 7179 2 16 360 7184 tot 32 717 14363 ATT3 ATT4 Number of projected orthonormalized plane waves: 305 FK state: 1 16384 3590 305 FK GS 140 FK state: 2 16384 3590 305 FK GS 74 FK state: 3 16384 3590 305 FK GS 39 FK state: 4 16384 3590 305 FK GS 26 Calculate FK matrix ATT1 279 ATT2 279 ATT3 279 ATT4 279 ATT5 279 POLARIZABILITY eigen: 1 2.7548602709571997 POLARIZABILITY eigen: 2 2.7566456570222195 POLARIZABILITY eigen: 3 2.759885197491636 POLARIZABILITY eigen: 4 3.0593021032510643 POLARIZABILITY eigen: 5 3.0612483265937582 POLARIZABILITY eigen: 6 3.0631616516434566 POLARIZABILITY eigen: 7 3.521842954060495 POLARIZABILITY eigen: 8 5.069714078148258 POLARIZABILITY eigen: 9 5.072475185260758 POLARIZABILITY eigen: 10 5.591566186360086 POLARIZABILITY eigen: 11 5.8776025666501335 POLARIZABILITY eigen: 12 5.882553592682455 POLARIZABILITY eigen: 13 5.883106218240038 POLARIZABILITY eigen: 14 6.721031134643045 POLARIZABILITY eigen: 15 6.72491831484368 POLARIZABILITY eigen: 16 6.728955809959694 POLARIZABILITY eigen: 17 7.705671241891559 POLARIZABILITY eigen: 18 7.707358993799592 POLARIZABILITY eigen: 19 8.987550889624615 POLARIZABILITY eigen: 20 9.446006130967866 POLARIZABILITY eigen: 21 9.45278460069272 POLARIZABILITY eigen: 22 9.459739266949885 POLARIZABILITY eigen: 23 11.80639278796411 POLARIZABILITY eigen: 24 11.811788123926434 POLARIZABILITY eigen: 25 11.816259427824601 POLARIZABILITY eigen: 26 15.262051658754341 POLARIZABILITY eigen: 27 15.264487728822733 POLARIZABILITY eigen: 28 15.266555489692806 POLARIZABILITY eigen: 29 18.211632031111254 POLARIZABILITY eigen: 30 22.995074344532238 POLARIZABILITY eigen: 31 22.999376680718555 POLARIZABILITY eigen: 32 23.001204744933457 POLARIZABILITY eigen: 33 25.339181925892746 POLARIZABILITY eigen: 34 25.34046836954088 POLARIZABILITY eigen: 35 29.155812572512545 POLARIZABILITY eigen: 36 29.162551535646305 POLARIZABILITY eigen: 37 29.16902653810903 POLARIZABILITY eigen: 38 32.81599012295253 POLARIZABILITY eigen: 39 32.8177970151562 POLARIZABILITY eigen: 40 32.82130231952408 POLARIZABILITY eigen: 41 39.901509242398205 POLARIZABILITY eigen: 42 39.90875835978045 POLARIZABILITY eigen: 43 50.446579636890604 POLARIZABILITY eigen: 44 50.454514892909245 POLARIZABILITY eigen: 45 50.46247032916405 POLARIZABILITY eigen: 46 51.608682895206954 POLARIZABILITY eigen: 47 100.3827687763671 POLARIZABILITY eigen: 48 100.38545650803488 POLARIZABILITY eigen: 49 100.39512972523767 POLARIZABILITY eigen: 50 155.73065220564922 NGM MAX: 3590 28830 Routine wannier_uterms : start NGM MAX: 3590 28830 uterms iiw 1 uterms jjw 1 USE RESTART: 1 LANCZOS RESTART:0 Routine pola_basis_lanczos ATT1 ATT2 ATT1.0 ATT1.1 ATT1.2 ATT1.3 ATT1.1.1 ATT1.1.2 ATT1.1.3 ATT1.1.4 ATT1.1.5 ATT1.1.6 ATT1.3.1 ATT1.5 ATT1.6 Planes per process (custom) : nr3t = 32 npp = 16 ncplane = 1024 Proc/ planes cols G 1 16 357 7179 2 16 360 7184 tot 32 717 14363 ATT3 ATT4 pola_basis update merge-split 1 1 pola_basis update merge-split 2 1 pola_basis update merge-split 3 3 pola_basis update merge-split 4 3 USE RESTART: 1 LANCZOS_RESTART:1 EIGEN: 1 0.006445886408227394 EIGEN: 50 53369.774892709924 orthonormalize_two_manifolds: basis dimension: 86 EIGEN: 1 0.0026621714995799317 EIGEN: 50 38249.09073478801 orthonormalize_two_manifolds: basis dimension: 115 EIGEN: 1 0.0016581425556961827 EIGEN: 50 27278.87726392915 orthonormalize_two_manifolds: basis dimension: 137 lanczos_state: 1 1 lanczos_state: 1 1 USE RESTART: 1 LANCZOS_RESTART:2 Routine self_basis_lanczos ATT1 ATT2 ATT1.0 ATT1.1 ATT1.2 ATT1.3 ATT1.1.1 ATT1.1.2 ATT1.1.3 ATT1.1.4 ATT1.1.5 ATT1.1.6 ATT1.3.1 ATT1.5 ATT1.6 Planes per process (custom) : nr3t = 32 npp = 16 ncplane = 1024 Proc/ planes cols G 1 16 357 7179 2 16 360 7184 tot 32 717 14363 ATT3 ATT4 do merge split 1 1 do merge split 2 1 do merge split 3 3 do merge split 4 3 do merge split 5 5 USE RESTART: 1 LANCZOS_RESTART:3 EIGEN: 1 6.8975019676562E-13 EIGEN: 50 2.956373994133227E-7 orthonormalize_two_manifolds: basis dimension: 99 EIGEN: 1 9.147885175697577E-14 EIGEN: 50 5.739285214937278E-8 orthonormalize_two_manifolds: basis dimension: 145 EIGEN: 1 2.173527214610195E-14 EIGEN: 50 2.1157371170768474E-8 orthonormalize_two_manifolds: basis dimension: 179 EIGEN: 1 2.714282167662945E-13 EIGEN: 50 6.563138828937006E-8 orthonormalize_two_manifolds: basis dimension: 221 lanczos_state: 1 1 lanczos_state: 1 1 Total number of s vectors: 221 USE RESTART: 4 LANCZOS_RESTART /=3 Exchange energy 1 1 -1.6915500334996363 Exchange energy 2 1 -1.3772671108061427 Exchange energy 3 1 -1.377267110841976 Exchange energy 4 1 -1.3772671108166437 Exchange energy 5 1 -0.04633261007090452 USE RESTART: 5 LANCZOS_RESTART /=3 USE RESTART: 6 LANCZOS_RESTART /=3 PW4GWW COMPLETED GWW/examples/example01/reference/methane_gww.out0000644000077300007730000020661112341332532022424 0ustar giannozzgiannozz MPI PARALLEL VERSION Number of procs: 2 PROGRAM GWL: Version 0.91 PROGRAM GWL: Version 0.91 Number of intervals: 118 Number of intervals for fit: 120 Maximum imaginary time: 11.8 Print whole Sigma: F Maximum state considered: 5 Prefix:ch4 Rows together in FFT: 50 Accurate treatment of conduction states Uses contractions on single states Uses no fft grid for time/space integrations Time grid : 3 Frequency grid : 5 Max frequency : 20. Consider states from: 1 to 5 Maximum number of iterations in minpack: 20000 Number of cycles over minpack: 1 Uses LDA Hartree : T Uses LDA Exchange : T Uses SYMMETRIZED DIELECTRIC MATRIX Head of dielectric matrix from file Treatment of W divergence: 0 Wings of dielectric matrix from file Offset fit : 2 Read vcprim terms from file Calculates the polarization directly from the overlaps Polarization Calculated through Lanczos scheme Self-energy Calculated through Lanczos scheme Convolution done analytically Block length fequency 100 Block length states 5 Block length valence states 4 Block length fequency lc 1 Reduced disk I/O Uses double grid, subdivisions: 10 till : 3 t vectors from Wannier products Use truncated Coulomb interaction Calculate Self-energy through FT Spin multiplicity: 1 Partiallly occpuied states: F min -188 0 1 189 max 0 0 189 189 min pola 0 max pola 94 min state 1 max state 3 min state range 1 max state range 3 DB1 118 DB2 DB3 N: 188 188 Omega: 20. 20. freq: -188 -20. -20. weight: -188 0.1694915254237288 0.1694915254237288 freq: -187 -19.83050847457627 -19.83050847457627 weight: -187 0.1694915254237288 0.1694915254237288 freq: -186 -19.66101694915254 -19.66101694915254 weight: -186 0.1694915254237288 0.1694915254237288 freq: -185 -19.491525423728813 -19.491525423728813 weight: -185 0.1694915254237288 0.1694915254237288 freq: -184 -19.322033898305083 -19.322033898305083 weight: -184 0.1694915254237288 0.1694915254237288 freq: -183 -19.152542372881356 -19.152542372881356 weight: -183 0.1694915254237288 0.1694915254237288 freq: -182 -18.983050847457626 -18.983050847457626 weight: -182 0.1694915254237288 0.1694915254237288 freq: -181 -18.813559322033896 -18.813559322033896 weight: -181 0.1694915254237288 0.1694915254237288 freq: -180 -18.64406779661017 -18.64406779661017 weight: -180 0.1694915254237288 0.1694915254237288 freq: -179 -18.47457627118644 -18.47457627118644 weight: -179 0.1694915254237288 0.1694915254237288 freq: -178 -18.305084745762713 -18.305084745762713 weight: -178 0.1694915254237288 0.1694915254237288 freq: -177 -18.135593220338983 -18.135593220338983 weight: -177 0.1694915254237288 0.1694915254237288 freq: -176 -17.966101694915253 -17.966101694915253 weight: -176 0.1694915254237288 0.1694915254237288 freq: -175 -17.796610169491526 -17.796610169491526 weight: -175 0.1694915254237288 0.1694915254237288 freq: -174 -17.627118644067796 -17.627118644067796 weight: -174 0.1694915254237288 0.1694915254237288 freq: -173 -17.457627118644066 -17.457627118644066 weight: -173 0.1694915254237288 0.1694915254237288 freq: -172 -17.28813559322034 -17.28813559322034 weight: -172 0.1694915254237288 0.1694915254237288 freq: -171 -17.11864406779661 -17.11864406779661 weight: -171 0.1694915254237288 0.1694915254237288 freq: -170 -16.94915254237288 -16.94915254237288 weight: -170 0.1694915254237288 0.1694915254237288 freq: -169 -16.779661016949152 -16.779661016949152 weight: -169 0.1694915254237288 0.1694915254237288 freq: -168 -16.610169491525422 -16.610169491525422 weight: -168 0.1694915254237288 0.1694915254237288 freq: -167 -16.440677966101696 -16.440677966101696 weight: -167 0.1694915254237288 0.1694915254237288 freq: -166 -16.271186440677965 -16.271186440677965 weight: -166 0.1694915254237288 0.1694915254237288 freq: -165 -16.101694915254235 -16.101694915254235 weight: -165 0.1694915254237288 0.1694915254237288 freq: -164 -15.932203389830509 -15.932203389830509 weight: -164 0.1694915254237288 0.1694915254237288 freq: -163 -15.762711864406779 -15.762711864406779 weight: -163 0.1694915254237288 0.1694915254237288 freq: -162 -15.59322033898305 -15.59322033898305 weight: -162 0.1694915254237288 0.1694915254237288 freq: -161 -15.423728813559322 -15.423728813559322 weight: -161 0.1694915254237288 0.1694915254237288 freq: -160 -15.254237288135592 -15.254237288135592 weight: -160 0.1694915254237288 0.1694915254237288 freq: -159 -15.084745762711863 -15.084745762711863 weight: -159 0.1694915254237288 0.1694915254237288 freq: -158 -14.915254237288135 -14.915254237288135 weight: -158 0.1694915254237288 0.1694915254237288 freq: -157 -14.745762711864407 -14.745762711864407 weight: -157 0.1694915254237288 0.1694915254237288 freq: -156 -14.576271186440678 -14.576271186440678 weight: -156 0.1694915254237288 0.1694915254237288 freq: -155 -14.406779661016948 -14.406779661016948 weight: -155 0.1694915254237288 0.1694915254237288 freq: -154 -14.23728813559322 -14.23728813559322 weight: -154 0.1694915254237288 0.1694915254237288 freq: -153 -14.067796610169491 -14.067796610169491 weight: -153 0.1694915254237288 0.1694915254237288 freq: -152 -13.898305084745761 -13.898305084745761 weight: -152 0.1694915254237288 0.1694915254237288 freq: -151 -13.728813559322033 -13.728813559322033 weight: -151 0.1694915254237288 0.1694915254237288 freq: -150 -13.559322033898304 -13.559322033898304 weight: -150 0.1694915254237288 0.1694915254237288 freq: -149 -13.389830508474576 -13.389830508474576 weight: -149 0.1694915254237288 0.1694915254237288 freq: -148 -13.220338983050848 -13.220338983050848 weight: -148 0.1694915254237288 0.1694915254237288 freq: -147 -13.050847457627118 -13.050847457627118 weight: -147 0.1694915254237288 0.1694915254237288 freq: -146 -12.88135593220339 -12.88135593220339 weight: -146 0.1694915254237288 0.1694915254237288 freq: -145 -12.711864406779661 -12.711864406779661 weight: -145 0.1694915254237288 0.1694915254237288 freq: -144 -12.54237288135593 -12.54237288135593 weight: -144 0.1694915254237288 0.1694915254237288 freq: -143 -12.372881355932202 -12.372881355932202 weight: -143 0.1694915254237288 0.1694915254237288 freq: -142 -12.203389830508474 -12.203389830508474 weight: -142 0.1694915254237288 0.1694915254237288 freq: -141 -12.033898305084746 -12.033898305084746 weight: -141 0.1694915254237288 0.1694915254237288 freq: -140 -11.864406779661017 -11.864406779661017 weight: -140 0.1694915254237288 0.1694915254237288 freq: -139 -11.694915254237287 -11.694915254237287 weight: -139 0.1694915254237288 0.1694915254237288 freq: -138 -11.525423728813559 -11.525423728813559 weight: -138 0.1694915254237288 0.1694915254237288 freq: -137 -11.35593220338983 -11.35593220338983 weight: -137 0.1694915254237288 0.1694915254237288 freq: -136 -11.1864406779661 -11.1864406779661 weight: -136 0.1694915254237288 0.1694915254237288 freq: -135 -11.016949152542372 -11.016949152542372 weight: -135 0.1694915254237288 0.1694915254237288 freq: -134 -10.847457627118644 -10.847457627118644 weight: -134 0.1694915254237288 0.1694915254237288 freq: -133 -10.677966101694915 -10.677966101694915 weight: -133 0.1694915254237288 0.1694915254237288 freq: -132 -10.508474576271187 -10.508474576271187 weight: -132 0.1694915254237288 0.1694915254237288 freq: -131 -10.338983050847457 -10.338983050847457 weight: -131 0.1694915254237288 0.1694915254237288 freq: -130 -10.169491525423728 -10.169491525423728 weight: -130 0.1694915254237288 0.1694915254237288 freq: -129 -10. -10. weight: -129 0.1694915254237288 0.1694915254237288 freq: -128 -9.83050847457627 -9.83050847457627 weight: -128 0.1694915254237288 0.1694915254237288 freq: -127 -9.661016949152541 -9.661016949152541 weight: -127 0.1694915254237288 0.1694915254237288 freq: -126 -9.491525423728813 -9.491525423728813 weight: -126 0.1694915254237288 0.1694915254237288 freq: -125 -9.322033898305085 -9.322033898305085 weight: -125 0.1694915254237288 0.1694915254237288 freq: -124 -9.152542372881356 -9.152542372881356 weight: -124 0.1694915254237288 0.1694915254237288 freq: -123 -8.983050847457626 -8.983050847457626 weight: -123 0.1694915254237288 0.1694915254237288 freq: -122 -8.813559322033898 -8.813559322033898 weight: -122 0.1694915254237288 0.1694915254237288 freq: -121 -8.64406779661017 -8.64406779661017 weight: -121 0.1694915254237288 0.1694915254237288 freq: -120 -8.47457627118644 -8.47457627118644 weight: -120 0.1694915254237288 0.1694915254237288 freq: -119 -8.305084745762711 -8.305084745762711 weight: -119 0.1694915254237288 0.1694915254237288 freq: -118 -8.135593220338983 -8.135593220338983 weight: -118 0.1694915254237288 0.1694915254237288 freq: -117 -7.966101694915254 -7.966101694915254 weight: -117 0.1694915254237288 0.1694915254237288 freq: -116 -7.796610169491525 -7.796610169491525 weight: -116 0.1694915254237288 0.1694915254237288 freq: -115 -7.627118644067796 -7.627118644067796 weight: -115 0.1694915254237288 0.1694915254237288 freq: -114 -7.4576271186440675 -7.4576271186440675 weight: -114 0.1694915254237288 0.1694915254237288 freq: -113 -7.288135593220339 -7.288135593220339 weight: -113 0.1694915254237288 0.1694915254237288 freq: -112 -7.11864406779661 -7.11864406779661 weight: -112 0.1694915254237288 0.1694915254237288 freq: -111 -6.949152542372881 -6.949152542372881 weight: -111 0.1694915254237288 0.1694915254237288 freq: -110 -6.779661016949152 -6.779661016949152 weight: -110 0.1694915254237288 0.1694915254237288 freq: -109 -6.610169491525424 -6.610169491525424 weight: -109 0.1694915254237288 0.1694915254237288 freq: -108 -6.440677966101695 -6.440677966101695 weight: -108 0.1694915254237288 0.1694915254237288 freq: -107 -6.271186440677965 -6.271186440677965 weight: -107 0.1694915254237288 0.1694915254237288 freq: -106 -6.101694915254237 -6.101694915254237 weight: -106 0.1694915254237288 0.1694915254237288 freq: -105 -5.932203389830509 -5.932203389830509 weight: -105 0.1694915254237288 0.1694915254237288 freq: -104 -5.762711864406779 -5.762711864406779 weight: -104 0.1694915254237288 0.1694915254237288 freq: -103 -5.59322033898305 -5.59322033898305 weight: -103 0.1694915254237288 0.1694915254237288 freq: -102 -5.423728813559322 -5.423728813559322 weight: -102 0.1694915254237288 0.1694915254237288 freq: -101 -5.254237288135593 -5.254237288135593 weight: -101 0.1694915254237288 0.1694915254237288 freq: -100 -5.084745762711864 -5.084745762711864 weight: -100 0.1694915254237288 0.1694915254237288 freq: -99 -4.915254237288135 -4.915254237288135 weight: -99 0.1694915254237288 0.1694915254237288 freq: -98 -4.745762711864407 -4.745762711864407 weight: -98 0.1694915254237288 0.1694915254237288 freq: -97 -4.576271186440678 -4.576271186440678 weight: -97 0.1694915254237288 0.1694915254237288 freq: -96 -4.406779661016949 -4.406779661016949 weight: -96 0.1694915254237288 0.1694915254237288 freq: -95 -4.23728813559322 -4.23728813559322 weight: -95 0.1694915254237288 0.1694915254237288 freq: -94 -4.067796610169491 -4.067796610169491 weight: -94 0.1694915254237288 0.1694915254237288 freq: -93 -3.8983050847457625 -3.8983050847457625 weight: -93 0.1694915254237288 0.1694915254237288 freq: -92 -3.7288135593220337 -3.7288135593220337 weight: -92 0.1694915254237288 0.1694915254237288 freq: -91 -3.559322033898305 -3.559322033898305 weight: -91 0.1694915254237288 0.1694915254237288 freq: -90 -3.389830508474576 -3.389830508474576 weight: -90 0.1694915254237288 0.1694915254237288 freq: -89 -3.2203389830508473 -3.2203389830508473 weight: -89 0.1694915254237288 0.1694915254237288 freq: -88 -3.0508474576271185 -3.0508474576271185 weight: -88 0.1694915254237288 0.1694915254237288 freq: -87 -2.8813559322033897 -2.8813559322033897 weight: -87 0.1694915254237288 0.1694915254237288 freq: -86 -2.711864406779661 -2.711864406779661 weight: -86 0.1694915254237288 0.1694915254237288 freq: -85 -2.542372881355932 -2.542372881355932 weight: -85 0.1694915254237288 0.1694915254237288 freq: -84 -2.3728813559322033 -2.3728813559322033 weight: -84 0.1694915254237288 0.1694915254237288 freq: -83 -2.2033898305084745 -2.2033898305084745 weight: -83 0.1694915254237288 0.1694915254237288 freq: -82 -2.0338983050847457 -2.0338983050847457 weight: -82 0.1694915254237288 0.1694915254237288 freq: -81 -1.8644067796610169 -1.8644067796610169 weight: -81 0.1694915254237288 0.1694915254237288 freq: -80 -1.694915254237288 -1.694915254237288 weight: -80 0.1694915254237288 0.1694915254237288 freq: -79 -1.5254237288135593 -1.5254237288135593 weight: -79 0.1694915254237288 0.1694915254237288 freq: -78 -1.3559322033898304 -1.3559322033898304 weight: -78 0.1694915254237288 0.1694915254237288 freq: -77 -1.1864406779661016 -1.1864406779661016 weight: -77 0.1694915254237288 0.1694915254237288 freq: -76 -1.0169491525423728 -1.0169491525423728 weight: -76 0.1694915254237288 0.1694915254237288 freq: -75 -0.847457627118644 -0.847457627118644 weight: -75 0.1694915254237288 0.1694915254237288 freq: -74 -0.6779661016949152 -0.6779661016949152 weight: -74 0.1694915254237288 0.1694915254237288 freq: -73 -0.5889830508474576 -0.5889830508474576 weight: -73 0.00847457627118644 0.00847457627118644 freq: -72 -0.5805084745762712 -0.5805084745762712 weight: -72 0.00847457627118644 0.00847457627118644 freq: -71 -0.5720338983050848 -0.5720338983050848 weight: -71 0.00847457627118644 0.00847457627118644 freq: -70 -0.5635593220338984 -0.5635593220338984 weight: -70 0.00847457627118644 0.00847457627118644 freq: -69 -0.5550847457627118 -0.5550847457627118 weight: -69 0.00847457627118644 0.00847457627118644 freq: -68 -0.5466101694915254 -0.5466101694915254 weight: -68 0.00847457627118644 0.00847457627118644 freq: -67 -0.538135593220339 -0.538135593220339 weight: -67 0.00847457627118644 0.00847457627118644 freq: -66 -0.5296610169491526 -0.5296610169491526 weight: -66 0.00847457627118644 0.00847457627118644 freq: -65 -0.5211864406779662 -0.5211864406779662 weight: -65 0.00847457627118644 0.00847457627118644 freq: -64 -0.5127118644067796 -0.5127118644067796 weight: -64 0.00847457627118644 0.00847457627118644 freq: -63 -0.5084745762711864 -0.5084745762711864 weight: -63 0. 0. freq: -62 -0.5042372881355932 -0.5042372881355932 weight: -62 0.00847457627118644 0.00847457627118644 freq: -61 -0.4957627118644068 -0.4957627118644068 weight: -61 0.00847457627118644 0.00847457627118644 freq: -60 -0.4872881355932204 -0.4872881355932204 weight: -60 0.00847457627118644 0.00847457627118644 freq: -59 -0.4788135593220339 -0.4788135593220339 weight: -59 0.00847457627118644 0.00847457627118644 freq: -58 -0.4703389830508475 -0.4703389830508475 weight: -58 0.00847457627118644 0.00847457627118644 freq: -57 -0.461864406779661 -0.461864406779661 weight: -57 0.00847457627118644 0.00847457627118644 freq: -56 -0.4533898305084746 -0.4533898305084746 weight: -56 0.00847457627118644 0.00847457627118644 freq: -55 -0.44491525423728817 -0.44491525423728817 weight: -55 0.00847457627118644 0.00847457627118644 freq: -54 -0.4364406779661017 -0.4364406779661017 weight: -54 0.00847457627118644 0.00847457627118644 freq: -53 -0.4279661016949153 -0.4279661016949153 weight: -53 0.00847457627118644 0.00847457627118644 freq: -52 -0.4194915254237288 -0.4194915254237288 weight: -52 0.00847457627118644 0.00847457627118644 freq: -51 -0.4110169491525424 -0.4110169491525424 weight: -51 0.00847457627118644 0.00847457627118644 freq: -50 -0.40254237288135597 -0.40254237288135597 weight: -50 0.00847457627118644 0.00847457627118644 freq: -49 -0.3940677966101695 -0.3940677966101695 weight: -49 0.00847457627118644 0.00847457627118644 freq: -48 -0.3855932203389831 -0.3855932203389831 weight: -48 0.00847457627118644 0.00847457627118644 freq: -47 -0.3771186440677966 -0.3771186440677966 weight: -47 0.00847457627118644 0.00847457627118644 freq: -46 -0.3686440677966102 -0.3686440677966102 weight: -46 0.00847457627118644 0.00847457627118644 freq: -45 -0.3601694915254237 -0.3601694915254237 weight: -45 0.00847457627118644 0.00847457627118644 freq: -44 -0.3516949152542373 -0.3516949152542373 weight: -44 0.00847457627118644 0.00847457627118644 freq: -43 -0.3432203389830509 -0.3432203389830509 weight: -43 0.00847457627118644 0.00847457627118644 freq: -42 -0.3389830508474576 -0.3389830508474576 weight: -42 0. 0. freq: -41 -0.3347457627118644 -0.3347457627118644 weight: -41 0.00847457627118644 0.00847457627118644 freq: -40 -0.326271186440678 -0.326271186440678 weight: -40 0.00847457627118644 0.00847457627118644 freq: -39 -0.3177966101694915 -0.3177966101694915 weight: -39 0.00847457627118644 0.00847457627118644 freq: -38 -0.3093220338983051 -0.3093220338983051 weight: -38 0.00847457627118644 0.00847457627118644 freq: -37 -0.3008474576271187 -0.3008474576271187 weight: -37 0.00847457627118644 0.00847457627118644 freq: -36 -0.2923728813559322 -0.2923728813559322 weight: -36 0.00847457627118644 0.00847457627118644 freq: -35 -0.2838983050847458 -0.2838983050847458 weight: -35 0.00847457627118644 0.00847457627118644 freq: -34 -0.2754237288135593 -0.2754237288135593 weight: -34 0.00847457627118644 0.00847457627118644 freq: -33 -0.2669491525423729 -0.2669491525423729 weight: -33 0.00847457627118644 0.00847457627118644 freq: -32 -0.2584745762711865 -0.2584745762711865 weight: -32 0.00847457627118644 0.00847457627118644 freq: -31 -0.25 -0.25 weight: -31 0.00847457627118644 0.00847457627118644 freq: -30 -0.24152542372881358 -0.24152542372881358 weight: -30 0.00847457627118644 0.00847457627118644 freq: -29 -0.23305084745762714 -0.23305084745762714 weight: -29 0.00847457627118644 0.00847457627118644 freq: -28 -0.2245762711864407 -0.2245762711864407 weight: -28 0.00847457627118644 0.00847457627118644 freq: -27 -0.21610169491525424 -0.21610169491525424 weight: -27 0.00847457627118644 0.00847457627118644 freq: -26 -0.2076271186440678 -0.2076271186440678 weight: -26 0.00847457627118644 0.00847457627118644 freq: -25 -0.19915254237288138 -0.19915254237288138 weight: -25 0.00847457627118644 0.00847457627118644 freq: -24 -0.19067796610169493 -0.19067796610169493 weight: -24 0.00847457627118644 0.00847457627118644 freq: -23 -0.1822033898305085 -0.1822033898305085 weight: -23 0.00847457627118644 0.00847457627118644 freq: -22 -0.17372881355932204 -0.17372881355932204 weight: -22 0.00847457627118644 0.00847457627118644 freq: -21 -0.1694915254237288 -0.1694915254237288 weight: -21 0. 0. freq: -20 -0.1652542372881356 -0.1652542372881356 weight: -20 0.00847457627118644 0.00847457627118644 freq: -19 -0.15677966101694915 -0.15677966101694915 weight: -19 0.00847457627118644 0.00847457627118644 freq: -18 -0.14830508474576273 -0.14830508474576273 weight: -18 0.00847457627118644 0.00847457627118644 freq: -17 -0.1398305084745763 -0.1398305084745763 weight: -17 0.00847457627118644 0.00847457627118644 freq: -16 -0.13135593220338984 -0.13135593220338984 weight: -16 0.00847457627118644 0.00847457627118644 freq: -15 -0.12288135593220338 -0.12288135593220338 weight: -15 0.00847457627118644 0.00847457627118644 freq: -14 -0.11440677966101695 -0.11440677966101695 weight: -14 0.00847457627118644 0.00847457627118644 freq: -13 -0.1059322033898305 -0.1059322033898305 weight: -13 0.00847457627118644 0.00847457627118644 freq: -12 -0.09745762711864407 -0.09745762711864407 weight: -12 0.00847457627118644 0.00847457627118644 freq: -11 -0.08898305084745763 -0.08898305084745763 weight: -11 0.00847457627118644 0.00847457627118644 freq: -10 -0.08050847457627118 -0.08050847457627118 weight: -10 0.00847457627118644 0.00847457627118644 freq: -9 -0.07203389830508475 -0.07203389830508475 weight: -9 0.00847457627118644 0.00847457627118644 freq: -8 -0.0635593220338983 -0.0635593220338983 weight: -8 0.00847457627118644 0.00847457627118644 freq: -7 -0.05508474576271186 -0.05508474576271186 weight: -7 0.00847457627118644 0.00847457627118644 freq: -6 -0.046610169491525424 -0.046610169491525424 weight: -6 0.00847457627118644 0.00847457627118644 freq: -5 -0.03813559322033898 -0.03813559322033898 weight: -5 0.00847457627118644 0.00847457627118644 freq: -4 -0.029661016949152543 -0.029661016949152543 weight: -4 0.00847457627118644 0.00847457627118644 freq: -3 -0.021186440677966104 -0.021186440677966104 weight: -3 0.00847457627118644 0.00847457627118644 freq: -2 -0.012711864406779662 -0.012711864406779662 weight: -2 0.00847457627118644 0.00847457627118644 freq: -1 -0.00423728813559322 -0.00423728813559322 weight: -1 0.00847457627118644 0.00847457627118644 freq: 0 0. 0. weight: 0 0. 0. freq: 1 0.00423728813559322 0.00423728813559322 weight: 1 0.00847457627118644 0.00847457627118644 freq: 2 0.012711864406779662 0.012711864406779662 weight: 2 0.00847457627118644 0.00847457627118644 freq: 3 0.021186440677966104 0.021186440677966104 weight: 3 0.00847457627118644 0.00847457627118644 freq: 4 0.029661016949152543 0.029661016949152543 weight: 4 0.00847457627118644 0.00847457627118644 freq: 5 0.03813559322033898 0.03813559322033898 weight: 5 0.00847457627118644 0.00847457627118644 freq: 6 0.046610169491525424 0.046610169491525424 weight: 6 0.00847457627118644 0.00847457627118644 freq: 7 0.05508474576271186 0.05508474576271186 weight: 7 0.00847457627118644 0.00847457627118644 freq: 8 0.0635593220338983 0.0635593220338983 weight: 8 0.00847457627118644 0.00847457627118644 freq: 9 0.07203389830508475 0.07203389830508475 weight: 9 0.00847457627118644 0.00847457627118644 freq: 10 0.08050847457627118 0.08050847457627118 weight: 10 0.00847457627118644 0.00847457627118644 freq: 11 0.08898305084745763 0.08898305084745763 weight: 11 0.00847457627118644 0.00847457627118644 freq: 12 0.09745762711864407 0.09745762711864407 weight: 12 0.00847457627118644 0.00847457627118644 freq: 13 0.1059322033898305 0.1059322033898305 weight: 13 0.00847457627118644 0.00847457627118644 freq: 14 0.11440677966101695 0.11440677966101695 weight: 14 0.00847457627118644 0.00847457627118644 freq: 15 0.12288135593220338 0.12288135593220338 weight: 15 0.00847457627118644 0.00847457627118644 freq: 16 0.13135593220338984 0.13135593220338984 weight: 16 0.00847457627118644 0.00847457627118644 freq: 17 0.1398305084745763 0.1398305084745763 weight: 17 0.00847457627118644 0.00847457627118644 freq: 18 0.14830508474576273 0.14830508474576273 weight: 18 0.00847457627118644 0.00847457627118644 freq: 19 0.15677966101694915 0.15677966101694915 weight: 19 0.00847457627118644 0.00847457627118644 freq: 20 0.1652542372881356 0.1652542372881356 weight: 20 0.00847457627118644 0.00847457627118644 freq: 21 0.1694915254237288 0.1694915254237288 weight: 21 0. 0. freq: 22 0.17372881355932204 0.17372881355932204 weight: 22 0.00847457627118644 0.00847457627118644 freq: 23 0.1822033898305085 0.1822033898305085 weight: 23 0.00847457627118644 0.00847457627118644 freq: 24 0.19067796610169493 0.19067796610169493 weight: 24 0.00847457627118644 0.00847457627118644 freq: 25 0.19915254237288138 0.19915254237288138 weight: 25 0.00847457627118644 0.00847457627118644 freq: 26 0.2076271186440678 0.2076271186440678 weight: 26 0.00847457627118644 0.00847457627118644 freq: 27 0.21610169491525424 0.21610169491525424 weight: 27 0.00847457627118644 0.00847457627118644 freq: 28 0.2245762711864407 0.2245762711864407 weight: 28 0.00847457627118644 0.00847457627118644 freq: 29 0.23305084745762714 0.23305084745762714 weight: 29 0.00847457627118644 0.00847457627118644 freq: 30 0.24152542372881358 0.24152542372881358 weight: 30 0.00847457627118644 0.00847457627118644 freq: 31 0.25 0.25 weight: 31 0.00847457627118644 0.00847457627118644 freq: 32 0.2584745762711865 0.2584745762711865 weight: 32 0.00847457627118644 0.00847457627118644 freq: 33 0.2669491525423729 0.2669491525423729 weight: 33 0.00847457627118644 0.00847457627118644 freq: 34 0.2754237288135593 0.2754237288135593 weight: 34 0.00847457627118644 0.00847457627118644 freq: 35 0.2838983050847458 0.2838983050847458 weight: 35 0.00847457627118644 0.00847457627118644 freq: 36 0.2923728813559322 0.2923728813559322 weight: 36 0.00847457627118644 0.00847457627118644 freq: 37 0.3008474576271187 0.3008474576271187 weight: 37 0.00847457627118644 0.00847457627118644 freq: 38 0.3093220338983051 0.3093220338983051 weight: 38 0.00847457627118644 0.00847457627118644 freq: 39 0.3177966101694915 0.3177966101694915 weight: 39 0.00847457627118644 0.00847457627118644 freq: 40 0.326271186440678 0.326271186440678 weight: 40 0.00847457627118644 0.00847457627118644 freq: 41 0.3347457627118644 0.3347457627118644 weight: 41 0.00847457627118644 0.00847457627118644 freq: 42 0.3389830508474576 0.3389830508474576 weight: 42 0. 0. freq: 43 0.3432203389830509 0.3432203389830509 weight: 43 0.00847457627118644 0.00847457627118644 freq: 44 0.3516949152542373 0.3516949152542373 weight: 44 0.00847457627118644 0.00847457627118644 freq: 45 0.3601694915254237 0.3601694915254237 weight: 45 0.00847457627118644 0.00847457627118644 freq: 46 0.3686440677966102 0.3686440677966102 weight: 46 0.00847457627118644 0.00847457627118644 freq: 47 0.3771186440677966 0.3771186440677966 weight: 47 0.00847457627118644 0.00847457627118644 freq: 48 0.3855932203389831 0.3855932203389831 weight: 48 0.00847457627118644 0.00847457627118644 freq: 49 0.3940677966101695 0.3940677966101695 weight: 49 0.00847457627118644 0.00847457627118644 freq: 50 0.40254237288135597 0.40254237288135597 weight: 50 0.00847457627118644 0.00847457627118644 freq: 51 0.4110169491525424 0.4110169491525424 weight: 51 0.00847457627118644 0.00847457627118644 freq: 52 0.4194915254237288 0.4194915254237288 weight: 52 0.00847457627118644 0.00847457627118644 freq: 53 0.4279661016949153 0.4279661016949153 weight: 53 0.00847457627118644 0.00847457627118644 freq: 54 0.4364406779661017 0.4364406779661017 weight: 54 0.00847457627118644 0.00847457627118644 freq: 55 0.44491525423728817 0.44491525423728817 weight: 55 0.00847457627118644 0.00847457627118644 freq: 56 0.4533898305084746 0.4533898305084746 weight: 56 0.00847457627118644 0.00847457627118644 freq: 57 0.461864406779661 0.461864406779661 weight: 57 0.00847457627118644 0.00847457627118644 freq: 58 0.4703389830508475 0.4703389830508475 weight: 58 0.00847457627118644 0.00847457627118644 freq: 59 0.4788135593220339 0.4788135593220339 weight: 59 0.00847457627118644 0.00847457627118644 freq: 60 0.4872881355932204 0.4872881355932204 weight: 60 0.00847457627118644 0.00847457627118644 freq: 61 0.4957627118644068 0.4957627118644068 weight: 61 0.00847457627118644 0.00847457627118644 freq: 62 0.5042372881355932 0.5042372881355932 weight: 62 0.00847457627118644 0.00847457627118644 freq: 63 0.5084745762711864 0.5084745762711864 weight: 63 0. 0. freq: 64 0.5127118644067796 0.5127118644067796 weight: 64 0.00847457627118644 0.00847457627118644 freq: 65 0.5211864406779662 0.5211864406779662 weight: 65 0.00847457627118644 0.00847457627118644 freq: 66 0.5296610169491526 0.5296610169491526 weight: 66 0.00847457627118644 0.00847457627118644 freq: 67 0.538135593220339 0.538135593220339 weight: 67 0.00847457627118644 0.00847457627118644 freq: 68 0.5466101694915254 0.5466101694915254 weight: 68 0.00847457627118644 0.00847457627118644 freq: 69 0.5550847457627118 0.5550847457627118 weight: 69 0.00847457627118644 0.00847457627118644 freq: 70 0.5635593220338984 0.5635593220338984 weight: 70 0.00847457627118644 0.00847457627118644 freq: 71 0.5720338983050848 0.5720338983050848 weight: 71 0.00847457627118644 0.00847457627118644 freq: 72 0.5805084745762712 0.5805084745762712 weight: 72 0.00847457627118644 0.00847457627118644 freq: 73 0.5889830508474576 0.5889830508474576 weight: 73 0.00847457627118644 0.00847457627118644 freq: 74 0.6779661016949152 0.6779661016949152 weight: 74 0.1694915254237288 0.1694915254237288 freq: 75 0.847457627118644 0.847457627118644 weight: 75 0.1694915254237288 0.1694915254237288 freq: 76 1.0169491525423728 1.0169491525423728 weight: 76 0.1694915254237288 0.1694915254237288 freq: 77 1.1864406779661016 1.1864406779661016 weight: 77 0.1694915254237288 0.1694915254237288 freq: 78 1.3559322033898304 1.3559322033898304 weight: 78 0.1694915254237288 0.1694915254237288 freq: 79 1.5254237288135593 1.5254237288135593 weight: 79 0.1694915254237288 0.1694915254237288 freq: 80 1.694915254237288 1.694915254237288 weight: 80 0.1694915254237288 0.1694915254237288 freq: 81 1.8644067796610169 1.8644067796610169 weight: 81 0.1694915254237288 0.1694915254237288 freq: 82 2.0338983050847457 2.0338983050847457 weight: 82 0.1694915254237288 0.1694915254237288 freq: 83 2.2033898305084745 2.2033898305084745 weight: 83 0.1694915254237288 0.1694915254237288 freq: 84 2.3728813559322033 2.3728813559322033 weight: 84 0.1694915254237288 0.1694915254237288 freq: 85 2.542372881355932 2.542372881355932 weight: 85 0.1694915254237288 0.1694915254237288 freq: 86 2.711864406779661 2.711864406779661 weight: 86 0.1694915254237288 0.1694915254237288 freq: 87 2.8813559322033897 2.8813559322033897 weight: 87 0.1694915254237288 0.1694915254237288 freq: 88 3.0508474576271185 3.0508474576271185 weight: 88 0.1694915254237288 0.1694915254237288 freq: 89 3.2203389830508473 3.2203389830508473 weight: 89 0.1694915254237288 0.1694915254237288 freq: 90 3.389830508474576 3.389830508474576 weight: 90 0.1694915254237288 0.1694915254237288 freq: 91 3.559322033898305 3.559322033898305 weight: 91 0.1694915254237288 0.1694915254237288 freq: 92 3.7288135593220337 3.7288135593220337 weight: 92 0.1694915254237288 0.1694915254237288 freq: 93 3.8983050847457625 3.8983050847457625 weight: 93 0.1694915254237288 0.1694915254237288 freq: 94 4.067796610169491 4.067796610169491 weight: 94 0.1694915254237288 0.1694915254237288 freq: 95 4.23728813559322 4.23728813559322 weight: 95 0.1694915254237288 0.1694915254237288 freq: 96 4.406779661016949 4.406779661016949 weight: 96 0.1694915254237288 0.1694915254237288 freq: 97 4.576271186440678 4.576271186440678 weight: 97 0.1694915254237288 0.1694915254237288 freq: 98 4.745762711864407 4.745762711864407 weight: 98 0.1694915254237288 0.1694915254237288 freq: 99 4.915254237288135 4.915254237288135 weight: 99 0.1694915254237288 0.1694915254237288 freq: 100 5.084745762711864 5.084745762711864 weight: 100 0.1694915254237288 0.1694915254237288 freq: 101 5.254237288135593 5.254237288135593 weight: 101 0.1694915254237288 0.1694915254237288 freq: 102 5.423728813559322 5.423728813559322 weight: 102 0.1694915254237288 0.1694915254237288 freq: 103 5.59322033898305 5.59322033898305 weight: 103 0.1694915254237288 0.1694915254237288 freq: 104 5.762711864406779 5.762711864406779 weight: 104 0.1694915254237288 0.1694915254237288 freq: 105 5.932203389830509 5.932203389830509 weight: 105 0.1694915254237288 0.1694915254237288 freq: 106 6.101694915254237 6.101694915254237 weight: 106 0.1694915254237288 0.1694915254237288 freq: 107 6.271186440677965 6.271186440677965 weight: 107 0.1694915254237288 0.1694915254237288 freq: 108 6.440677966101695 6.440677966101695 weight: 108 0.1694915254237288 0.1694915254237288 freq: 109 6.610169491525424 6.610169491525424 weight: 109 0.1694915254237288 0.1694915254237288 freq: 110 6.779661016949152 6.779661016949152 weight: 110 0.1694915254237288 0.1694915254237288 freq: 111 6.949152542372881 6.949152542372881 weight: 111 0.1694915254237288 0.1694915254237288 freq: 112 7.11864406779661 7.11864406779661 weight: 112 0.1694915254237288 0.1694915254237288 freq: 113 7.288135593220339 7.288135593220339 weight: 113 0.1694915254237288 0.1694915254237288 freq: 114 7.4576271186440675 7.4576271186440675 weight: 114 0.1694915254237288 0.1694915254237288 freq: 115 7.627118644067796 7.627118644067796 weight: 115 0.1694915254237288 0.1694915254237288 freq: 116 7.796610169491525 7.796610169491525 weight: 116 0.1694915254237288 0.1694915254237288 freq: 117 7.966101694915254 7.966101694915254 weight: 117 0.1694915254237288 0.1694915254237288 freq: 118 8.135593220338983 8.135593220338983 weight: 118 0.1694915254237288 0.1694915254237288 freq: 119 8.305084745762711 8.305084745762711 weight: 119 0.1694915254237288 0.1694915254237288 freq: 120 8.47457627118644 8.47457627118644 weight: 120 0.1694915254237288 0.1694915254237288 freq: 121 8.64406779661017 8.64406779661017 weight: 121 0.1694915254237288 0.1694915254237288 freq: 122 8.813559322033898 8.813559322033898 weight: 122 0.1694915254237288 0.1694915254237288 freq: 123 8.983050847457626 8.983050847457626 weight: 123 0.1694915254237288 0.1694915254237288 freq: 124 9.152542372881356 9.152542372881356 weight: 124 0.1694915254237288 0.1694915254237288 freq: 125 9.322033898305085 9.322033898305085 weight: 125 0.1694915254237288 0.1694915254237288 freq: 126 9.491525423728813 9.491525423728813 weight: 126 0.1694915254237288 0.1694915254237288 freq: 127 9.661016949152541 9.661016949152541 weight: 127 0.1694915254237288 0.1694915254237288 freq: 128 9.83050847457627 9.83050847457627 weight: 128 0.1694915254237288 0.1694915254237288 freq: 129 10. 10. weight: 129 0.1694915254237288 0.1694915254237288 freq: 130 10.169491525423728 10.169491525423728 weight: 130 0.1694915254237288 0.1694915254237288 freq: 131 10.338983050847457 10.338983050847457 weight: 131 0.1694915254237288 0.1694915254237288 freq: 132 10.508474576271187 10.508474576271187 weight: 132 0.1694915254237288 0.1694915254237288 freq: 133 10.677966101694915 10.677966101694915 weight: 133 0.1694915254237288 0.1694915254237288 freq: 134 10.847457627118644 10.847457627118644 weight: 134 0.1694915254237288 0.1694915254237288 freq: 135 11.016949152542372 11.016949152542372 weight: 135 0.1694915254237288 0.1694915254237288 freq: 136 11.1864406779661 11.1864406779661 weight: 136 0.1694915254237288 0.1694915254237288 freq: 137 11.35593220338983 11.35593220338983 weight: 137 0.1694915254237288 0.1694915254237288 freq: 138 11.525423728813559 11.525423728813559 weight: 138 0.1694915254237288 0.1694915254237288 freq: 139 11.694915254237287 11.694915254237287 weight: 139 0.1694915254237288 0.1694915254237288 freq: 140 11.864406779661017 11.864406779661017 weight: 140 0.1694915254237288 0.1694915254237288 freq: 141 12.033898305084746 12.033898305084746 weight: 141 0.1694915254237288 0.1694915254237288 freq: 142 12.203389830508474 12.203389830508474 weight: 142 0.1694915254237288 0.1694915254237288 freq: 143 12.372881355932202 12.372881355932202 weight: 143 0.1694915254237288 0.1694915254237288 freq: 144 12.54237288135593 12.54237288135593 weight: 144 0.1694915254237288 0.1694915254237288 freq: 145 12.711864406779661 12.711864406779661 weight: 145 0.1694915254237288 0.1694915254237288 freq: 146 12.88135593220339 12.88135593220339 weight: 146 0.1694915254237288 0.1694915254237288 freq: 147 13.050847457627118 13.050847457627118 weight: 147 0.1694915254237288 0.1694915254237288 freq: 148 13.220338983050848 13.220338983050848 weight: 148 0.1694915254237288 0.1694915254237288 freq: 149 13.389830508474576 13.389830508474576 weight: 149 0.1694915254237288 0.1694915254237288 freq: 150 13.559322033898304 13.559322033898304 weight: 150 0.1694915254237288 0.1694915254237288 freq: 151 13.728813559322033 13.728813559322033 weight: 151 0.1694915254237288 0.1694915254237288 freq: 152 13.898305084745761 13.898305084745761 weight: 152 0.1694915254237288 0.1694915254237288 freq: 153 14.067796610169491 14.067796610169491 weight: 153 0.1694915254237288 0.1694915254237288 freq: 154 14.23728813559322 14.23728813559322 weight: 154 0.1694915254237288 0.1694915254237288 freq: 155 14.406779661016948 14.406779661016948 weight: 155 0.1694915254237288 0.1694915254237288 freq: 156 14.576271186440678 14.576271186440678 weight: 156 0.1694915254237288 0.1694915254237288 freq: 157 14.745762711864407 14.745762711864407 weight: 157 0.1694915254237288 0.1694915254237288 freq: 158 14.915254237288135 14.915254237288135 weight: 158 0.1694915254237288 0.1694915254237288 freq: 159 15.084745762711863 15.084745762711863 weight: 159 0.1694915254237288 0.1694915254237288 freq: 160 15.254237288135592 15.254237288135592 weight: 160 0.1694915254237288 0.1694915254237288 freq: 161 15.423728813559322 15.423728813559322 weight: 161 0.1694915254237288 0.1694915254237288 freq: 162 15.59322033898305 15.59322033898305 weight: 162 0.1694915254237288 0.1694915254237288 freq: 163 15.762711864406779 15.762711864406779 weight: 163 0.1694915254237288 0.1694915254237288 freq: 164 15.932203389830509 15.932203389830509 weight: 164 0.1694915254237288 0.1694915254237288 freq: 165 16.101694915254235 16.101694915254235 weight: 165 0.1694915254237288 0.1694915254237288 freq: 166 16.271186440677965 16.271186440677965 weight: 166 0.1694915254237288 0.1694915254237288 freq: 167 16.440677966101696 16.440677966101696 weight: 167 0.1694915254237288 0.1694915254237288 freq: 168 16.610169491525422 16.610169491525422 weight: 168 0.1694915254237288 0.1694915254237288 freq: 169 16.779661016949152 16.779661016949152 weight: 169 0.1694915254237288 0.1694915254237288 freq: 170 16.94915254237288 16.94915254237288 weight: 170 0.1694915254237288 0.1694915254237288 freq: 171 17.11864406779661 17.11864406779661 weight: 171 0.1694915254237288 0.1694915254237288 freq: 172 17.28813559322034 17.28813559322034 weight: 172 0.1694915254237288 0.1694915254237288 freq: 173 17.457627118644066 17.457627118644066 weight: 173 0.1694915254237288 0.1694915254237288 freq: 174 17.627118644067796 17.627118644067796 weight: 174 0.1694915254237288 0.1694915254237288 freq: 175 17.796610169491526 17.796610169491526 weight: 175 0.1694915254237288 0.1694915254237288 freq: 176 17.966101694915253 17.966101694915253 weight: 176 0.1694915254237288 0.1694915254237288 freq: 177 18.135593220338983 18.135593220338983 weight: 177 0.1694915254237288 0.1694915254237288 freq: 178 18.305084745762713 18.305084745762713 weight: 178 0.1694915254237288 0.1694915254237288 freq: 179 18.47457627118644 18.47457627118644 weight: 179 0.1694915254237288 0.1694915254237288 freq: 180 18.64406779661017 18.64406779661017 weight: 180 0.1694915254237288 0.1694915254237288 freq: 181 18.813559322033896 18.813559322033896 weight: 181 0.1694915254237288 0.1694915254237288 freq: 182 18.983050847457626 18.983050847457626 weight: 182 0.1694915254237288 0.1694915254237288 freq: 183 19.152542372881356 19.152542372881356 weight: 183 0.1694915254237288 0.1694915254237288 freq: 184 19.322033898305083 19.322033898305083 weight: 184 0.1694915254237288 0.1694915254237288 freq: 185 19.491525423728813 19.491525423728813 weight: 185 0.1694915254237288 0.1694915254237288 freq: 186 19.66101694915254 19.66101694915254 weight: 186 0.1694915254237288 0.1694915254237288 freq: 187 19.83050847457627 19.83050847457627 weight: 187 0.1694915254237288 0.1694915254237288 freq: 188 20. 20. weight: 188 0.1694915254237288 0.1694915254237288 ENE H (4.941728591918945,0.) (4.490381717681885,0.) (4.490381717681885,0.) (4.490381717681885,0.) (0.3620595633983612,0.) Routine calculate_compact_pola_lanczos ******************************* RESTART FROM POINT 3 ******************************* Routine: do_polarization_lanczos Lanczos dimensions 137 20 Lanczos elemets: 1 20.907363870069915 12.949907557739298 Lanczos elemets: 2 20.287193006938715 12.360842701707796 Lanczos elemets: 3 17.091883124310208 12.0867681233995 Lanczos elemets: 4 17.43454160496216 12.413821574756966 Lanczos elemets: 5 17.759852374835816 12.516680849018996 Lanczos elemets: 6 22.057216540707703 12.691519047600348 Lanczos elemets: 7 22.595901263615943 12.28501503484163 Lanczos elemets: 8 23.52422086738574 12.652728873540077 Lanczos elemets: 9 28.95066902815276 10.526943565274134 Lanczos elemets: 10 22.274229278816033 11.956162549344068 Lanczos elemets: 11 22.634741999101717 12.504487506741023 Lanczos elemets: 12 18.332870093618197 11.725423454581085 Lanczos elemets: 13 16.216652129971724 10.675463962893586 Lanczos elemets: 14 15.87934183088693 10.960802967877026 Lanczos elemets: 15 16.14252463852222 10.349766558662942 Lanczos elemets: 16 15.71807154066942 10.153728161803276 Lanczos elemets: 17 15.63028638906234 10.562694747538316 Lanczos elemets: 18 15.714723666331373 10.170345312946353 Lanczos elemets: 19 14.77108747345118 10.305576076584067 Lanczos elemets: 20 13.773809858827866 10.918718764116758 Lanczos elemets: 21 17.38503184215025 11.33647636933387 Lanczos elemets: 22 14.301773379275508 13.050390356257296 Lanczos elemets: 23 19.018684662284628 12.539954835287688 Lanczos elemets: 24 19.626080029798466 12.643904683126815 Lanczos elemets: 25 17.26763399795938 12.677807969410159 Lanczos elemets: 26 14.293442493759356 11.34404783599114 Lanczos elemets: 27 15.684398199573948 11.55907451590183 Lanczos elemets: 28 19.71100634711141 13.08515199727073 Lanczos elemets: 29 14.458314034765552 12.06585602489324 Lanczos elemets: 30 14.233012374910675 11.278659114926903 Lanczos elemets: 31 15.606837151166129 12.567608458063127 Lanczos elemets: 32 19.07878569446276 12.493107416856192 Lanczos elemets: 33 19.89378569723711 12.162506364557126 Lanczos elemets: 34 19.816448447739063 13.074817129876399 Lanczos elemets: 35 25.920652947027246 11.682166183703433 Lanczos elemets: 36 17.53049122268233 11.689479581087875 Lanczos elemets: 37 21.759600401295124 12.051995848424216 Lanczos elemets: 38 17.744579948803796 11.77435754371684 Lanczos elemets: 39 15.166966627224154 10.92298913280567 Lanczos elemets: 40 15.989137727374715 10.473613771144098 Lanczos elemets: 41 21.91291106872983 12.03006811868688 Lanczos elemets: 42 12.744584657829405 9.4529275783534 Lanczos elemets: 43 14.889771106683813 10.00584934778302 Lanczos elemets: 44 12.344031239425952 9.515419838247837 Lanczos elemets: 45 16.157377276144985 11.38744859457326 Lanczos elemets: 46 12.532087056417268 10.859355118514543 Lanczos elemets: 47 11.153845677153086 9.278967337683461 Lanczos elemets: 48 13.211889319181715 10.460315465530133 Lanczos elemets: 49 12.326860847588746 9.608447692914464 Lanczos elemets: 50 9.205202179936148 9.361249971550013 Lanczos elemets: 51 15.057512592546754 10.384365839880502 Lanczos elemets: 52 9.094376295724544 7.7409486270582795 Lanczos elemets: 53 10.373767873945207 8.94973909854738 Lanczos elemets: 54 10.944509457865419 9.260900847401324 Lanczos elemets: 55 17.511322553536154 12.535044649378923 Lanczos elemets: 56 11.07238166481778 10.321242476036431 Lanczos elemets: 57 8.557607644638427 9.21351009648203 Lanczos elemets: 58 12.10416680339538 10.262821799469608 Lanczos elemets: 59 19.00776269352692 12.024755703815243 Lanczos elemets: 60 21.634478637472697 13.486916748985664 Lanczos elemets: 61 11.01708805683345 10.16316484984454 Lanczos elemets: 62 13.732658375263131 10.147452876946382 Lanczos elemets: 63 13.280081273600022 10.486035418978787 Lanczos elemets: 64 8.647098891186172 7.227440318607993 Lanczos elemets: 65 23.816253178230028 11.827724684811294 Lanczos elemets: 66 11.228756999909649 10.894410615429742 Lanczos elemets: 67 11.90595665770871 11.05534589717645 Lanczos elemets: 68 13.455340935209875 10.959867567414333 Lanczos elemets: 69 13.401832496698795 8.816186035070256 Lanczos elemets: 70 17.793001290899518 12.272710861045578 Lanczos elemets: 71 15.114068656827076 11.181794464156297 Lanczos elemets: 72 12.123567227907092 9.081772533873098 Lanczos elemets: 73 10.375010116420459 7.928311001076439 Lanczos elemets: 74 12.246653032080268 9.461147416005504 Lanczos elemets: 75 9.150828989029648 8.79457980697978 Lanczos elemets: 76 14.35555521260686 10.605210018532688 Lanczos elemets: 77 10.649160469109098 10.295389177820336 Lanczos elemets: 78 18.22876408076965 10.947148755363738 Lanczos elemets: 79 11.111770301169399 8.85330907723748 Lanczos elemets: 80 15.822470328601238 10.626711141956193 Lanczos elemets: 81 8.056554395819028 7.211591167520007 Lanczos elemets: 82 11.537418007234102 9.49630184814815 Lanczos elemets: 83 8.877583889781121 7.736017592749911 Lanczos elemets: 84 9.383363047224313 7.919153889293224 Lanczos elemets: 85 10.451547871016823 8.345829983476989 Lanczos elemets: 86 10.877595804109479 9.393284138807093 Lanczos elemets: 87 9.572551587140842 8.050260597976532 Lanczos elemets: 88 7.366624880765736 5.534458437633285 Lanczos elemets: 89 7.571511070203255 6.876761464489636 Lanczos elemets: 90 7.68066017510548 7.041425201769411 Lanczos elemets: 91 7.9932222364671865 8.602919792856792 Lanczos elemets: 92 6.5960565690246735 6.1259201273715975 Lanczos elemets: 93 6.658343393081463 6.17472158738534 Lanczos elemets: 94 7.898091855452628 6.302345514530279 Lanczos elemets: 95 8.20004891294893 6.84502888560943 Lanczos elemets: 96 8.111567104556755 6.60328970048385 Lanczos elemets: 97 7.936776160922779 5.7130979193721885 Lanczos elemets: 98 7.745548978879387 5.637474242956153 Lanczos elemets: 99 9.471367663901624 5.861500045561365 Lanczos elemets: 100 14.134631299201345 9.855754010395097 Lanczos elemets: 101 7.990001515711009 6.5752092620067835 Lanczos elemets: 102 8.042357398125262 6.51622846554139 Lanczos elemets: 103 9.674789234714503 7.135314733010562 Lanczos elemets: 104 10.562836320314204 9.340432170640689 Lanczos elemets: 105 10.666181737144083 9.353523272653778 Lanczos elemets: 106 7.798747246445137 8.638586759335677 Lanczos elemets: 107 7.543185939140186 7.7925087983547225 Lanczos elemets: 108 7.380902786325761 7.518343809672256 Lanczos elemets: 109 7.5949835565306945 8.548464189777725 Lanczos elemets: 110 13.16231452731754 9.92417876066591 Lanczos elemets: 111 12.640866318404566 9.855349400094592 Lanczos elemets: 112 12.489943123550887 9.534208904262814 Lanczos elemets: 113 11.807217161318599 9.426835359903881 Lanczos elemets: 114 9.553453818329398 8.239445596698003 Lanczos elemets: 115 9.06896291601062 7.544188049108552 Lanczos elemets: 116 7.277066885804376 4.634099836795398 Lanczos elemets: 117 9.133588033385433 7.516007182842088 Lanczos elemets: 118 6.9612605388676325 4.779738515302345 Lanczos elemets: 119 17.680841828351518 10.855349470186685 Lanczos elemets: 120 17.56399852599654 10.878357963335691 Lanczos elemets: 121 8.730008258519742 8.656210957669229 Lanczos elemets: 122 10.76179695896155 8.14409537332601 Lanczos elemets: 123 13.557670170995005 9.320434179406375 Lanczos elemets: 124 13.552865984915414 9.349367326548645 Lanczos elemets: 125 12.582801690945963 10.938453739307667 Lanczos elemets: 126 7.529375814978942 6.731322823267893 Lanczos elemets: 127 7.573450647444096 6.7798931770218065 Lanczos elemets: 128 7.6377037174495275 6.543050137382328 Lanczos elemets: 129 7.651315446824716 6.550820052587344 Lanczos elemets: 130 9.72448922529395 8.805853034996021 Lanczos elemets: 131 7.675654425120383 7.18815758460549 Lanczos elemets: 132 7.581039929749437 7.095424416648418 Lanczos elemets: 133 7.017703712049137 6.595788496229652 Lanczos elemets: 134 8.16328010706199 7.589814060809421 Lanczos elemets: 135 8.200816884232946 7.619500301508349 Lanczos elemets: 136 8.346869886895833 7.2014608337791035 Lanczos elemets: 137 7.3855764764798515 7.528035329731779 do_polarization_lanczos1 0 F do_polarization_lanczos iv 1 do_polarization_lanczos1 1 F do_polarization_lanczos iv 1 do_polarization_lanczos1 2 F do_polarization_lanczos iv 1 do_polarization_lanczos1 3 F do_polarization_lanczos iv 1 do_polarization_lanczos1 4 F do_polarization_lanczos iv 1 do_polarization_lanczos1 5 F do_polarization_lanczos iv 1 do_polarization_lanczos1 6 F do_polarization_lanczos iv 1 do_polarization_lanczos1 7 F do_polarization_lanczos iv 1 do_polarization_lanczos1 8 F do_polarization_lanczos iv 1 do_polarization_lanczos1 9 F do_polarization_lanczos iv 1 do_polarization_lanczos1 10 F do_polarization_lanczos iv 1 do_polarization_lanczos1 11 F do_polarization_lanczos iv 1 do_polarization_lanczos1 12 F do_polarization_lanczos iv 1 do_polarization_lanczos1 13 F do_polarization_lanczos iv 1 do_polarization_lanczos1 14 F do_polarization_lanczos iv 1 do_polarization_lanczos1 15 F do_polarization_lanczos iv 1 do_polarization_lanczos1 16 F do_polarization_lanczos iv 1 do_polarization_lanczos1 17 F do_polarization_lanczos iv 1 do_polarization_lanczos1 18 F do_polarization_lanczos iv 1 do_polarization_lanczos1 19 F do_polarization_lanczos iv 1 do_polarization_lanczos1 20 F do_polarization_lanczos iv 1 do_polarization_lanczos1 21 F do_polarization_lanczos iv 1 do_polarization_lanczos1 22 F do_polarization_lanczos iv 1 do_polarization_lanczos1 23 F do_polarization_lanczos iv 1 do_polarization_lanczos1 24 F do_polarization_lanczos iv 1 do_polarization_lanczos1 25 F do_polarization_lanczos iv 1 do_polarization_lanczos1 26 F do_polarization_lanczos iv 1 do_polarization_lanczos1 27 F do_polarization_lanczos iv 1 do_polarization_lanczos1 28 F do_polarization_lanczos iv 1 do_polarization_lanczos1 29 F do_polarization_lanczos iv 1 do_polarization_lanczos1 30 F do_polarization_lanczos iv 1 do_polarization_lanczos1 31 F do_polarization_lanczos iv 1 do_polarization_lanczos1 32 F do_polarization_lanczos iv 1 do_polarization_lanczos1 33 F do_polarization_lanczos iv 1 do_polarization_lanczos1 34 F do_polarization_lanczos iv 1 do_polarization_lanczos1 35 F do_polarization_lanczos iv 1 do_polarization_lanczos1 36 F do_polarization_lanczos iv 1 do_polarization_lanczos1 37 F do_polarization_lanczos iv 1 do_polarization_lanczos1 38 F do_polarization_lanczos iv 1 do_polarization_lanczos1 39 F do_polarization_lanczos iv 1 do_polarization_lanczos1 40 F do_polarization_lanczos iv 1 do_polarization_lanczos1 41 F do_polarization_lanczos iv 1 do_polarization_lanczos1 42 F do_polarization_lanczos iv 1 do_polarization_lanczos1 43 F do_polarization_lanczos iv 1 do_polarization_lanczos1 44 F do_polarization_lanczos iv 1 do_polarization_lanczos1 45 F do_polarization_lanczos iv 1 do_polarization_lanczos1 46 F do_polarization_lanczos iv 1 do_polarization_lanczos1 47 F do_polarization_lanczos iv 1 do_polarization_lanczos1 48 F do_polarization_lanczos iv 1 do_polarization_lanczos1 49 F do_polarization_lanczos iv 1 do_polarization_lanczos1 50 F do_polarization_lanczos iv 1 do_polarization_lanczos1 51 F do_polarization_lanczos iv 1 do_polarization_lanczos1 52 F do_polarization_lanczos iv 1 do_polarization_lanczos1 53 F do_polarization_lanczos iv 1 do_polarization_lanczos1 54 F do_polarization_lanczos iv 1 do_polarization_lanczos1 55 F do_polarization_lanczos iv 1 do_polarization_lanczos1 56 F do_polarization_lanczos iv 1 do_polarization_lanczos1 57 F do_polarization_lanczos iv 1 do_polarization_lanczos1 58 F do_polarization_lanczos iv 1 do_polarization_lanczos1 59 F do_polarization_lanczos iv 1 do_polarization_lanczos1 60 F do_polarization_lanczos iv 1 do_polarization_lanczos1 61 F do_polarization_lanczos iv 1 do_polarization_lanczos1 62 F do_polarization_lanczos iv 1 do_polarization_lanczos1 63 F do_polarization_lanczos iv 1 do_polarization_lanczos1 64 F do_polarization_lanczos iv 1 do_polarization_lanczos1 65 F do_polarization_lanczos iv 1 do_polarization_lanczos1 66 F do_polarization_lanczos iv 1 do_polarization_lanczos1 67 F do_polarization_lanczos iv 1 do_polarization_lanczos1 68 F do_polarization_lanczos iv 1 do_polarization_lanczos1 69 F do_polarization_lanczos iv 1 do_polarization_lanczos1 70 F do_polarization_lanczos iv 1 do_polarization_lanczos1 71 F do_polarization_lanczos iv 1 do_polarization_lanczos1 72 F do_polarization_lanczos iv 1 do_polarization_lanczos1 73 F do_polarization_lanczos iv 1 do_polarization_lanczos1 74 F do_polarization_lanczos iv 1 do_polarization_lanczos1 75 F do_polarization_lanczos iv 1 do_polarization_lanczos1 76 F do_polarization_lanczos iv 1 do_polarization_lanczos1 77 F do_polarization_lanczos iv 1 do_polarization_lanczos1 78 F do_polarization_lanczos iv 1 do_polarization_lanczos1 79 F do_polarization_lanczos iv 1 do_polarization_lanczos1 80 F do_polarization_lanczos iv 1 do_polarization_lanczos1 81 F do_polarization_lanczos iv 1 do_polarization_lanczos1 82 F do_polarization_lanczos iv 1 do_polarization_lanczos1 83 F do_polarization_lanczos iv 1 do_polarization_lanczos1 84 F do_polarization_lanczos iv 1 do_polarization_lanczos1 85 F do_polarization_lanczos iv 1 do_polarization_lanczos1 86 F do_polarization_lanczos iv 1 do_polarization_lanczos1 87 F do_polarization_lanczos iv 1 do_polarization_lanczos1 88 F do_polarization_lanczos iv 1 do_polarization_lanczos1 89 F do_polarization_lanczos iv 1 do_polarization_lanczos1 90 F do_polarization_lanczos iv 1 do_polarization_lanczos1 91 F do_polarization_lanczos iv 1 do_polarization_lanczos1 92 F do_polarization_lanczos iv 1 do_polarization_lanczos1 93 F do_polarization_lanczos iv 1 do_polarization_lanczos1 94 F do_polarization_lanczos iv 1 Call go_dressed_w 0 Read polaw 50 call calculate_w 0 1 Read polaw 50 call calculate_w 1 2 Read polaw 50 call calculate_w 2 3 Read polaw 50 call calculate_w 3 4 Read polaw 50 call calculate_w 4 5 Read polaw 50 call calculate_w 5 6 Read polaw 50 call calculate_w 6 7 Read polaw 50 call calculate_w 7 8 Read polaw 50 call calculate_w 8 9 Read polaw 50 call calculate_w 9 10 Read polaw 50 call calculate_w 10 11 Read polaw 50 call calculate_w 11 12 Read polaw 50 call calculate_w 12 13 Read polaw 50 call calculate_w 13 14 Read polaw 50 call calculate_w 14 15 Read polaw 50 call calculate_w 15 16 Read polaw 50 call calculate_w 16 17 Read polaw 50 call calculate_w 17 18 Read polaw 50 call calculate_w 18 19 Read polaw 50 call calculate_w 19 20 Read polaw 50 call calculate_w 20 21 Read polaw 50 call calculate_w 21 22 Read polaw 50 call calculate_w 22 23 Read polaw 50 call calculate_w 23 24 Read polaw 50 call calculate_w 24 25 Read polaw 50 call calculate_w 25 26 Read polaw 50 call calculate_w 26 27 Read polaw 50 call calculate_w 27 28 Read polaw 50 call calculate_w 28 29 Read polaw 50 call calculate_w 29 30 Read polaw 50 call calculate_w 30 31 Read polaw 50 call calculate_w 31 32 Read polaw 50 call calculate_w 32 33 Read polaw 50 call calculate_w 33 34 Read polaw 50 call calculate_w 34 35 Read polaw 50 call calculate_w 35 36 Read polaw 50 call calculate_w 36 37 Read polaw 50 call calculate_w 37 38 Read polaw 50 call calculate_w 38 39 Read polaw 50 call calculate_w 39 40 Read polaw 50 call calculate_w 40 41 Read polaw 50 call calculate_w 41 42 Read polaw 50 call calculate_w 42 43 Read polaw 50 call calculate_w 43 44 Read polaw 50 call calculate_w 44 45 Read polaw 50 call calculate_w 45 46 Read polaw 50 call calculate_w 46 47 Read polaw 50 call calculate_w 47 48 Read polaw 50 call calculate_w 48 49 Read polaw 50 call calculate_w 49 50 Read polaw 50 call calculate_w 50 51 Read polaw 50 call calculate_w 51 52 Read polaw 50 call calculate_w 52 53 Read polaw 50 call calculate_w 53 54 Read polaw 50 call calculate_w 54 55 Read polaw 50 call calculate_w 55 56 Read polaw 50 call calculate_w 56 57 Read polaw 50 call calculate_w 57 58 Read polaw 50 call calculate_w 58 59 Read polaw 50 call calculate_w 59 60 Read polaw 50 call calculate_w 60 61 Read polaw 50 call calculate_w 61 62 Read polaw 50 call calculate_w 62 63 Read polaw 50 call calculate_w 63 64 Read polaw 50 call calculate_w 64 65 Read polaw 50 call calculate_w 65 66 Read polaw 50 call calculate_w 66 67 Read polaw 50 call calculate_w 67 68 Read polaw 50 call calculate_w 68 69 Read polaw 50 call calculate_w 69 70 Read polaw 50 call calculate_w 70 71 Read polaw 50 call calculate_w 71 72 Read polaw 50 call calculate_w 72 73 Read polaw 50 call calculate_w 73 74 Read polaw 50 call calculate_w 74 75 Read polaw 50 call calculate_w 75 76 Read polaw 50 call calculate_w 76 77 Read polaw 50 call calculate_w 77 78 Read polaw 50 call calculate_w 78 79 Read polaw 50 call calculate_w 79 80 Read polaw 50 call calculate_w 80 81 Read polaw 50 call calculate_w 81 82 Read polaw 50 call calculate_w 82 83 Read polaw 50 call calculate_w 83 84 Read polaw 50 call calculate_w 84 85 Read polaw 50 call calculate_w 85 86 Read polaw 50 call calculate_w 86 87 Read polaw 50 call calculate_w 87 88 Read polaw 50 call calculate_w 88 89 Read polaw 50 call calculate_w 89 90 Read polaw 50 call calculate_w 90 91 Read polaw 50 call calculate_w 91 92 Read polaw 50 call calculate_w 92 93 Read polaw 50 call calculate_w 93 94 Read polaw 50 call calculate_w 94 Trasform W to Pgreek Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Done ******************************* RESTART FROM POINT 6 ******************************* Routine do_self_lanczos_time Lanczos dimensions 221 40 1 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Read polaw 50 Fourier trasform Pgreek Loop on KS: 1 1 Fourier trasform: Products in imaginary time: Loop on KS: 2 1 Fourier trasform: Products in imaginary time: Loop on KS: 3 1 Fourier trasform: Products in imaginary time: Loop on KS: 4 1 Fourier trasform: Products in imaginary time: Loop on KS: 5 1 Fourier trasform: Products in imaginary time: Call fit_multipole a_0 (0.,0.) a (0.009999999776482582,0.) (0.019999999552965164,0.) b (-0.5,-0.009999999776482582) (1.,-0.009999999776482582) z,s (0.,0.1666666716337204) (0.06201261203518993,-0.019358232853363442) (-0.001614434534243439,-0.009708741989780289) z,s (0.,10.083333015441895) (-0.017403115113758902,-0.12130505055114546) (-0.0001454505572673048,-0.0029505723811431095) Grad a_0 (0.42212830439640675,15.75890010204806) Grad a (-4.7240446099784705,0.37072725519254884) Grad a (-2.894893556572477,-1.591789037987592) Routine fit_multipole: chi1 > chi0 Routine fit_multipole: chi1 > chi0 Routine fit_multipole: maxiter reached 0.022902876087925822 Done Calling minpack Allocated Chi0 initial: 0.022902876087925822 INFO : 2 0.00001 Minpack fit chi0 : 0.0004839932121600569 Done FIT state : 1 1 FIT a_0: (-0.09288899720899862,-0.028538473925736118) FIT a: 1 (0.263269587293915,0.34131812005221596) FIT b: 1 (-1.7015349296735673,-0.6001007104902382) FIT a: 2 (0.27344992246674077,0.9171764536472236) FIT b: 2 (8.464873179474091,1.973363718387238) Call fit_multipole a_0 (0.,0.) a (0.009999999776482582,0.) (0.019999999552965164,0.) b (-0.5,-0.009999999776482582) (1.,-0.009999999776482582) z,s (0.,0.1666666716337204) (-0.02598523054010976,-0.016912101890800897) (-0.001614434534243439,-0.009708741989780289) z,s (0.,10.083333015441895) (-0.030555818679513642,-0.10878047266287035) (-0.0001454505572673048,-0.0029505723811431095) Grad a_0 (4.986104075655374,13.685420083134032) Grad a (-2.9853919361983814,2.2080477056014995) Grad a (-3.5410611991150907,-0.007211466326349645) Routine fit_multipole: chi1 > chi0 Routine fit_multipole: chi1 > chi0 Routine fit_multipole: maxiter reached 0.009380048601146562 Done Calling minpack Allocated Chi0 initial: 0.009380048601146562 INFO : 2 0.00001 Minpack fit chi0 : 0.00011066951271443083 Done FIT state : 2 1 FIT a_0: (-0.02964366267009599,-0.022391882073973045) FIT a: 1 (0.2664068714155019,0.19790598091600523) FIT b: 1 (-1.9363015747480223,-0.5374129617525306) FIT a: 2 (0.8418344697783462,0.0752408023092941) FIT b: 2 (5.271466238585698,-0.7306082622750365) Call fit_multipole a_0 (0.,0.) a (0.009999999776482582,0.) (0.019999999552965164,0.) b (-0.5,-0.009999999776482582) (1.,-0.009999999776482582) z,s (0.,0.1666666716337204) (-0.025788951179370998,-0.016912286443600124) (-0.001614434534243439,-0.009708741989780289) z,s (0.,10.083333015441895) (-0.030551560509771064,-0.10884497960060154) (-0.0001454505572673048,-0.0029505723811431095) Grad a_0 (4.973793067756555,13.693351360933985) Grad a (-2.989834108742432,2.202967741972011) Grad a (-3.539685735383135,-0.011404668437788746) Routine fit_multipole: chi1 > chi0 Routine fit_multipole: chi1 > chi0 Routine fit_multipole: maxiter reached 0.009448376384917882 Done Calling minpack Allocated Chi0 initial: 0.009448376384917882 INFO : 2 0.00001 Minpack fit chi0 : 0.0001114190522474182 Done FIT state : 3 1 FIT a_0: (-0.030066939589541465,-0.022218564519984847) FIT a: 1 (0.2660397407666428,0.20014392526473693) FIT b: 1 (-1.9338061737216592,-0.5429387167335262) FIT a: 2 (0.8441972916492649,0.08080166715740619) FIT b: 2 (5.291111229286791,-0.7282795519117303) Out of create_self_energy_fit value, zeta: 1 (0.2603357768906899,-0.0035797105327476375) (-0.39164748617630535,-0.12432863212831273) 1 XC-DFT energy 1 -1.05178768928371 H-DFT energy 1 67.23563581947754 (67.23563682451967,0.) GW-PERT energy 1 -20.29571793724957 Iteration energy 1 (0.39000739935284584,0.05224788833315441) Iteration energy 2 (0.3904874096447489,0.027577263390217932) Iteration energy 3 (0.381146695430141,0.04080171768138395) Iteration energy 4 (0.39113202703278743,0.03724190261147094) Iteration energy 5 (0.3843754020808459,0.03543000784186179) Iteration energy 6 (0.3873355095550119,0.03892681428110023) Iteration energy 7 (0.38705154878235626,0.03592529274545242) Iteration energy 8 (0.3860830080125533,0.03765253803501825) Iteration energy 9 (0.3872529601138659,0.037084268194369455) Iteration energy 10 (0.38640810925902225,0.03695291611926836) value, zeta: 2 (0.00830807851544274,-0.0058895044063597204) (-0.13866529136521433,0.009014659675616469) 1 XC-DFT energy 2 -0.9868812482661686 H-DFT energy 2 61.094752506545284 (61.094750299972375,0.) GW-PERT energy 2 -13.676141120095094 Iteration energy 1 (0.06269360397555693,-0.0036508464012795783) Iteration energy 2 (0.0612941000078476,-0.0045889136051467765) Iteration energy 3 (0.06154195844380733,-0.00438626885728316) Iteration energy 4 (0.0614987321576872,-0.004429114468477317) Iteration energy 5 (0.061506135414464924,-0.0044202237826828535) Iteration energy 6 (0.06150489564864786,-0.004422040319321689) Iteration energy 7 (0.06150509732553194,-0.004421674113164773) Iteration energy 8 (0.06150506579949819,-0.00442174706432721) Iteration energy 9 (0.06150507044299691,-0.0044217326886358994) Iteration energy 10 (0.06150506982484977,-0.004421735493062191) value, zeta: 3 (0.00855955247185164,-0.005950476662868694) (-0.13897909279940454,0.008982199931304965) 1 XC-DFT energy 3 -0.9868812482919485 H-DFT energy 3 61.094752508792766 (61.094750299972375,0.) GW-PERT energy 3 -13.671878371566612 Iteration energy 1 (0.06300482050943487,-0.0036369529025886277) Iteration energy 2 (0.061605916112590836,-0.004589599850658682) Iteration energy 3 (0.06185348010688965,-0.004383339759896628) Iteration energy 4 (0.06181037647169674,-0.004427030363018818) Iteration energy 5 (0.061817737911059184,-0.004417950530098597) Iteration energy 6 (0.06181651069586122,-0.004419808005620144) Iteration energy 7 (0.061816708917308894,-0.0044194331832398785) Iteration energy 8 (0.06181667828578932,-0.0044195079038584426) Iteration energy 9 (0.06181668270820176,-0.004419493172889491) Iteration energy 10 (0.06181668214275193,-0.004419496047120403) value, zeta: 4 (0.008434028415909789,-0.005562055019555007) (-0.1382412033130415,0.007523323284176027) 1 XC-DFT energy 4 -0.9868812482757066 H-DFT energy 4 61.094752507441406 (61.094750299972375,0.) GW-PERT energy 4 -13.676540940060042 Iteration energy 1 (0.06239537889821381,-0.0028891600166354205) Iteration energy 2 (0.06107210819749667,-0.0038328613320268434) Iteration energy 3 (0.06130081141019672,-0.0036302840370568724) Iteration energy 4 (0.061262080659204965,-0.0036727187015638194) Iteration energy 5 (0.061268478678930094,-0.0036640138890629732) Iteration energy 6 (0.06126745552513907,-0.003665768820878105) Iteration energy 7 (0.06126761192784083,-0.003665420325284219) Iteration energy 8 (0.061267589615652845,-0.003665488599326472) Iteration energy 9 (0.06126759242951105,-0.0036654753893873224) Iteration energy 10 (0.061267592166146356,-0.0036654779153976746) value, zeta: 5 (-0.048553927740493115,0.0020557367998662555) (-0.03315667638913444,-0.0032532249148312367) 1 XC-DFT energy 5 -0.15405669376161996 H-DFT energy 5 4.9260709082213605 (4.926070879996165,0.) GW-PERT energy 5 0.2141228571881689 Iteration energy 1 (-0.05048827544842557,0.0017230661319912778) Iteration energy 2 (-0.050487394023903495,0.001726315431475424) Iteration energy 3 (-0.05048740413080222,0.0017261973354713127) Iteration energy 4 (-0.050487404523075735,0.0017262014898243479) Iteration energy 5 (-0.05048740448337241,0.0017262013483843805) Iteration energy 6 (-0.05048740448563684,0.0017262013530342478) Iteration energy 7 (-0.05048740448552917,0.0017262013528874139) Iteration energy 8 (-0.050487404485533835,0.0017262013528918235) Iteration energy 9 (-0.05048740448553364,0.0017262013528916952) Iteration energy 10 (-0.05048740448553365,0.0017262013528917056) QUASI-PARTICLES ENERGIES IN Ev, Spin: 1 1 State: 1DFT : -16.61246 GW-PERT : -20.29572 GW : -20.05952 HF-pert : -25.31687 State: 2DFT : -9.11161 GW-PERT : -13.67614 GW : -13.58626 HF-pert : -14.42308 State: 3DFT : -9.11161 GW-PERT : -13.67188 GW : -13.58202 HF-pert : -14.42308 State: 4DFT : -9.11161 GW-PERT : -13.67654 GW : -13.58949 HF-pert : -14.42308 State: 5DFT : -0.56517 GW-PERT : 0.21412 GW : 0.21358 HF-pert : 0.90049 IMAGINARY ENERGIES IN Ev: State: 1 GW (Im) : 0.50277 State: 2 GW (Im) : -0.06016 State: 3 GW (Im) : -0.06013 State: 4 GW (Im) : -0.04987 State: 5 GW (Im) : 0.02349 Stopping MPI environment GWW/examples/example01/methane_scf_35.in0000644000077300007730000000121412341332532020533 0ustar giannozzgiannozz&control calculation = 'scf', restart_mode='from_scratch', prefix='ch4', tprnfor = .true., pseudo_dir = './', / &system ibrav= 1, celldm(1) =35.0, nat=5, ntyp= 2, ecutwfc =40.0, nbnd=5 / &electrons diagonalization='cg' mixing_beta = 0.5, conv_thr = 1.0d-8 / ATOMIC_SPECIES H 1.0 H.pz-vbc.UPF C 12.0 C.pz-vbc.UPF ATOMIC_POSITIONS {bohr} H 1.198204546 1.198204546 1.198204546 H -1.198204546 -1.198204546 1.198204546 H 1.198204546 -1.198204546 -1.198204546 H -1.198204546 1.198204546 -1.198204546 C 0.000000000 0.000000000 0.000000000 GWW/examples/example01/run_example0000755000077300007730000001026512341332532017673 0ustar giannozzgiannozz#!/bin/sh # run from directory where this script is cd `echo $0 | sed 's/\(.*\)\/.*/\1/'` # extract pathname EXAMPLE_DIR=`pwd` # check whether echo has the -e option if test "`echo -e`" = "-e" ; then ECHO=echo ; else ECHO="echo -e" ; fi $ECHO $ECHO "$EXAMPLE_DIR : starting" $ECHO $ECHO "This example shows how to use pw.x pw4gww.x gww. x to calculate" $ECHO "the GW QP levels of CH4" # set the needed environment variables . ../../../environment_variables # required executables and pseudopotentials BIN_LIST="pw.x pw4gww.x gww.x" PSEUDO_LIST="C.pz-vbc.UPF H.pz-vbc.UPF" $ECHO $ECHO " executables directory: $BIN_DIR" $ECHO " pseudo directory: $PSEUDO_DIR" $ECHO " temporary directory: $TMP_DIR" $ECHO " checking that needed directories and files exist...\c" # check for directories for DIR in "$BIN_DIR" "$PSEUDO_DIR" ; do if test ! -d $DIR ; then $ECHO $ECHO "ERROR: $DIR not existent or not a directory" $ECHO "Aborting" exit 1 fi done for DIR in "$TMP_DIR" "$EXAMPLE_DIR/results" ; do if test ! -d $DIR ; then mkdir $DIR fi done cd $EXAMPLE_DIR/results # check for executables for FILE in $BIN_LIST ; do if test ! -x $BIN_DIR/$FILE ; then $ECHO $ECHO "ERROR: $BIN_DIR/$FILE not existent or not executable" $ECHO "Aborting" exit 1 fi done # check for pseudopotentials for FILE in $PSEUDO_LIST ; do if test ! -r $PSEUDO_DIR/$FILE ; then $ECHO $ECHO "Downloading $FILE to $PSEUDO_DIR...\c" $WGET $PSEUDO_DIR/$FILE $NETWORK_PSEUDO/$FILE 2> /dev/null fi if test $? != 0; then $ECHO $ECHO "ERROR: $PSEUDO_DIR/$FILE not existent or not readable" $ECHO "Aborting" exit 1 fi done $ECHO " done" # how to run executables PW_COMMAND="$PARA_PREFIX $BIN_DIR/pw.x $PARA_POSTFIX" $ECHO $ECHO " running pw.x as: $PW_COMMAND" $ECHO PW4GWW_COMMAND="$PARA_PREFIX $BIN_DIR/pw4gww.x $PARA_POSTFIX" $ECHO $ECHO " running pw4gww.x as: $PW4GWW_COMMAND" $ECHO GWW_COMMAND="$PARA_PREFIX $BIN_DIR/gww.x $PARA_POSTFIX" $ECHO $ECHO " running gww.x as: $GWW_COMMAND" $ECHO # self-consistent calculation cat > methane_scf.in << EOF &control calculation = 'scf', restart_mode='from_scratch', prefix='ch4', tprnfor = .true., pseudo_dir = '$PSEUDO_DIR/', outdir='$TMP_DIR/' / &system ibrav= 1, celldm(1) =15.0, nat=5, ntyp= 2, ecutwfc =40.0, nbnd=5 / &electrons diagonalization='cg' mixing_beta = 0.5, conv_thr = 1.0d-8 / ATOMIC_SPECIES H 1.0 H.pz-vbc.UPF C 12.0 C.pz-vbc.UPF ATOMIC_POSITIONS {bohr} H 1.198204546 1.198204546 1.198204546 H -1.198204546 -1.198204546 1.198204546 H 1.198204546 -1.198204546 -1.198204546 H -1.198204546 1.198204546 -1.198204546 C 0.000000000 0.000000000 0.000000000 EOF $ECHO " running the scf calculation for methane...\c" $PW_COMMAND < methane_scf.in > methane_scf.out check_failure $? $ECHO " done" # cat > methane_pw4gww.in << EOF &inputpw4gww prefix='ch4' num_nbndv(1)=4 num_nbnds=5 l_truncated_coulomb=.true. truncation_radius=7.5d0 numw_prod=50 pseudo_dir = '$PSEUDO_DIR/', outdir='$TMP_DIR/' / EOF $ECHO " running the pw4gww calculation for methane...\c" $PW4GWW_COMMAND < methane_pw4gww.in > methane_pw4gww.out check_failure $? $ECHO " done" # cat > methane_gww.in << EOF &inputgww ggwin%prefix='ch4' ggwin%max_i=5, ggwin%i_min=1 ggwin%i_max=5 ggwin%omega=20 ggwin%n=118, ggwin%tau=11.8 ggwin%grid_freq=5 ggwin%second_grid_i=3 ggwin%second_grid_n=10 ggwin%omega_fit=20 ggwin%n_grid_fit=240 ggwin%n_fit=120, ggwin%n_multipoles=2 ggwin%l_truncated_coulomb=.true. ggwin%outdir='$TMP_DIR' / EOF $ECHO " running the gww calculation for methane...\c" $GWW_COMMAND < methane_gww.in > methane_gww.out check_failure $? $ECHO " done" #copy self_energy files $ECHO "copying self-energy files..\c" cp $TMP_DIR/ch4-im_on_im* . cp $TMP_DIR/ch4-re_on_im* . cp $TMP_DIR/ch4-bands.dat . # clean TMP_DIR $ECHO " cleaning $TMP_DIR...\c" rm -rf $TMP_DIR/ch4* $ECHO " done" $ECHO $ECHO "$EXAMPLE_DIR : done" GWW/examples/example01/methane_pw4gww_steps.in0000644000077300007730000000037612341332532022136 0ustar giannozzgiannozz&inputpw4gww prefix='ch4' num_nbndv(1)=4 num_nbnds=5 l_truncated_coulomb=.true. truncation_radius=7.5d0 numw_prod=50 nsteps_lanczos_self=30 restart_gww=2 lanczos_restart=3 s_first_state=4 s_last_state=4 / GWW/gww/0000755000077300007730000000000012341332543012616 5ustar giannozzgiannozzGWW/gww/polarization.f900000644000077300007730000021721212341332532015654 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! MODULE polarization !this module describes the structure for the polarization P ! and dressed iteraction W, imaginary time/frequency USE kinds, ONLY : DP TYPE polaw !this structure describe a generic P or W function !usually in the space of orthonormalized products of wanniers INTEGER :: label!label to read/write to disk LOGICAL :: ontime!if .true. is on imaginary time, otherwise frequency REAL(kind=DP) :: time!imaginary time or frequency INTEGER :: numpw!number of states (products of wanniers) REAL(kind=DP), DIMENSION(:,:), POINTER :: pw!the P or W COMPLEX(kind=DP) :: factor!complex factor to be multiplied to the real matrix pw END TYPE polaw CONTAINS SUBROUTINE initialize_polaw(pw) !this subroutine initializes polaw implicit none TYPE(polaw) :: pw nullify(pw%pw) return END SUBROUTINE initialize_polaw SUBROUTINE free_memory_polaw(pw) !this subroutine deallocates the green descriptor implicit none TYPE(polaw) pw if(associated(pw%pw)) deallocate(pw%pw) nullify(pw%pw) return END SUBROUTINE SUBROUTINE conjugate_polaw(pw) ! this subroutine calculculates the conjugate of the polaw matrix implicit none TYPE(polaw) pw pw%label=-pw%label return END SUBROUTINE conjugate_polaw SUBROUTINE write_polaw(pw,debug) !this subroutine writes the green function on disk !the file name is taken from the label USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(polaw) :: pw!the green function to be written LOGICAL :: debug! if .true. produces formatted output LOGICAL :: direct_file = .true.!if true uses direct- access file to write matrix on disk INTEGER :: iw, jw, iung CHARACTER(5) :: nfile if(pw%label >= 0 ) then write(nfile,'(5i1)') & & pw%label/10000,mod(pw%label,10000)/1000,mod(pw%label,1000)/100,mod(pw%label,100)/10,mod(pw%label,10) iung = find_free_unit() if(.not.debug) then open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polaw.'// nfile, status='unknown',form='unformatted') else open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polaw.'// nfile, status='unknown',form='formatted') endif else write(nfile,'(5i1)') & & -pw%label/10000,mod(-pw%label,10000)/1000,mod(-pw%label,1000)/100,mod(-pw%label,100)/10,mod(-pw%label,10) iung = find_free_unit() if(.not.debug) then open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polaw.-'// nfile, status='unknown',form='unformatted') else open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polaw.-'// nfile, status='unknown',form='formatted') endif endif if(.not.debug) then write(iung) pw%label write(iung) pw%ontime write(iung) pw%time write(iung) pw%numpw write(iung) pw%factor if(.not. direct_file) then do iw=1,pw%numpw write(iung) pw%pw(1:pw%numpw,iw) enddo endif else write(iung,*) pw%label write(iung,*) pw%ontime write(iung,*) pw%time write(iung,*) pw%numpw write(iung,*) pw%factor if(.not. direct_file) then do iw=1,pw%numpw do jw=1,pw%numpw write(iung,*) pw%pw(jw,iw) enddo enddo endif endif close(iung) if(direct_file) then iung = find_free_unit() if(pw%label >= 0 ) then open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polawd.'// nfile, & &status='unknown',recl=pw%numpw*DP,access='direct') else open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polawd.-'// nfile, & &status='unknown',recl=pw%numpw*DP,access='direct') endif do iw=1,pw%numpw write(unit=iung, rec=iw) pw%pw(:,iw) enddo close(iung) endif return END SUBROUTINE SUBROUTINE read_polaw(label, pw,debug,l_verbose) !this subroutine reads the green function from disk !the file name is taken from the label USE io_files, ONLY : prefix,tmp_dir USE io_global, ONLY : stdout implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(polaw) :: pw!the green function to be read INTEGER :: label! the label identifing the required green function LOGICAL :: debug!if true formatted files LOGICAL, INTENT(in) :: l_verbose LOGICAL :: direct_file = .true.!if true uses direct- access file to read matrix from disk INTEGER :: iw, jw, iung CHARACTER(5) :: nfile if(l_verbose) write(stdout,*) 'Read polaw'!ATTENZIONE !first deallocate call free_memory_polaw(pw) if(l_verbose) write(stdout,*) 'Read polaw2'!ATTENZIONE if(label >= 0 ) then write(nfile,'(5i1)') label/10000,mod(label,10000)/1000,mod(label,1000)/100,mod(label,100)/10,mod(label,10) iung = find_free_unit() if(.not.debug) then open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polaw.'// nfile, status='old',form='unformatted') else open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polaw.'// nfile, status='old',form='formatted') endif else write(nfile,'(5i1)') -label/10000,mod(-label,10000)/1000,mod(-label,1000)/100,mod(-label,100)/10,mod(-label,10) iung = find_free_unit() if(.not.debug) then open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polaw.-'// nfile, status='old',form='unformatted') else open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polaw.-'// nfile, status='old',form='formatted') endif endif if(.not.debug) then read(iung) pw%label read(iung) pw%ontime read(iung) pw%time read(iung) pw%numpw read(iung) pw%factor else read(iung,*) pw%label read(iung,*) pw%ontime read(iung,*) pw%time read(iung,*) pw%numpw read(iung,*) pw%factor endif write(stdout,*) 'Read polaw',pw%numpw!ATTENZIONE !now allocate allocate(pw%pw(pw%numpw,pw%numpw)) if(.not. direct_file) then if(.not.debug) then do iw=1,pw%numpw read(iung) pw%pw(1:pw%numpw,iw) enddo else do iw=1,pw%numpw do jw=1,pw%numpw read(iung,*) pw%pw(jw,iw) enddo enddo endif endif close(iung) if(l_verbose) write(stdout,*) 'Read polaw4'!ATTENZIONE if(direct_file) then iung = find_free_unit() if(label >= 0 ) then open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polawd.'// nfile, & &status='unknown',recl=pw%numpw*DP,access='direct') else open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polawd.-'// nfile, & &status='unknown',recl=pw%numpw*DP,access='direct') endif if(l_verbose) write(stdout,*) 'Read polaw5'!ATTENZIONE do iw=1,pw%numpw read(unit=iung, rec=iw) pw%pw(:,iw) enddo close(iung) endif if(l_verbose) write(stdout,*) 'Read polaw6'!ATTENZIONE return END SUBROUTINE SUBROUTINE read_polaw_global(label, pw) !this subroutine reads the green function from disk !the file name is taken from the label !the ionode_id distribute to all the processors USE io_files, ONLY : prefix,tmp_dir USE io_global, ONLY : stdout, ionode, ionode_id USE mp, ONLY : mp_barrier, mp_bcast USE mp_world, ONLY : world_comm implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(polaw) :: pw!the green function to be read INTEGER :: label! the label identifing the required green function LOGICAL :: direct_file = .true.!if true uses direct- access file to read matrix from disk INTEGER :: iw, jw, iung CHARACTER(5) :: nfile !first deallocate call free_memory_polaw(pw) if(ionode) then if(label >= 0 ) then write(nfile,'(5i1)') label/10000,mod(label,10000)/1000,mod(label,1000)/100,mod(label,100)/10,mod(label,10) iung = find_free_unit() open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polaw.'// nfile, status='old',form='unformatted') else write(nfile,'(5i1)') -label/10000,mod(-label,10000)/1000,mod(-label,1000)/100,mod(-label,100)/10,mod(-label,10) iung = find_free_unit() open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polaw.-'// nfile, status='old',form='unformatted') endif read(iung) pw%label read(iung) pw%ontime read(iung) pw%time read(iung) pw%numpw read(iung) pw%factor endif call mp_bcast(pw%label,ionode_id,world_comm) call mp_bcast(pw%ontime,ionode_id,world_comm) call mp_bcast(pw%time,ionode_id,world_comm) call mp_bcast(pw%numpw,ionode_id,world_comm) call mp_bcast(pw%factor,ionode_id,world_comm) allocate(pw%pw(pw%numpw,pw%numpw)) if(ionode) then if(.not. direct_file) then do iw=1,pw%numpw read(iung) pw%pw(1:pw%numpw,iw) enddo endif close(iung) if(direct_file) then iung = find_free_unit() if(label >= 0 ) then open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polawd.'// nfile, & &status='unknown',recl=pw%numpw*DP,access='direct') else open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polawd.-'// nfile, & &status='unknown',recl=pw%numpw*DP,access='direct') endif do iw=1,pw%numpw read(unit=iung, rec=iw) pw%pw(:,iw) enddo close(iung) endif endif do iw=1,pw%numpw call mp_barrier( world_comm ) call mp_bcast(pw%pw(:,iw),ionode_id,world_comm) enddo return END SUBROUTINE read_polaw_global SUBROUTINE write_polaw_range( pw, debug, range_min, range_max, full_range ) !this subroutine writes the green function on disk !the file name is taken from the label !writes column from range_min to range_max USE io_files, ONLY : prefix,tmp_dir USE io_global, ONLY : stdout implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(polaw) :: pw!the green function to be written LOGICAL :: debug! if .true. produces formatted output INTEGER, INTENT(in) :: range_min, range_max!range of column LOGICAL, INTENT(IN) :: full_range LOGICAL :: direct_file = .true.!if true uses direct- access file to write matrix on disk INTEGER :: iw, jw, iung, iww CHARACTER(5) :: nfile !check range if(range_min<1 .or. range_max> pw%numpw) then write(stdout,*) 'write_polaw_range: out of range = ', range_min, range_max stop endif if(pw%label >= 0 ) then write(nfile,'(5i1)') & & pw%label/10000,mod(pw%label,10000)/1000,mod(pw%label,1000)/100,mod(pw%label,100)/10,mod(pw%label,10) iung = find_free_unit() if(.not.debug) then open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polaw.'// nfile, status='unknown',form='unformatted') else open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polaw.'// nfile, status='unknown',form='formatted') endif else write(nfile,'(5i1)') & & -pw%label/10000,mod(-pw%label,10000)/1000,mod(-pw%label,1000)/100,mod(-pw%label,100)/10,mod(-pw%label,10) iung = find_free_unit() if(.not.debug) then open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polaw.-'// nfile, status='unknown',form='unformatted') else open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polaw.-'// nfile, status='unknown',form='formatted') endif endif if(.not.debug) then write(iung) pw%label write(iung) pw%ontime write(iung) pw%time write(iung) pw%numpw write(iung) pw%factor if(.not. direct_file) then do iw=1,pw%numpw write(iung) pw%pw(1:pw%numpw,iw) enddo endif else write(iung,*) pw%label write(iung,*) pw%ontime write(iung,*) pw%time write(iung,*) pw%numpw write(iung,*) pw%factor if(.not. direct_file) then do iw=1,pw%numpw do jw=1,pw%numpw write(iung,*) pw%pw(jw,iw) enddo enddo endif endif close(iung) if(direct_file) then iung = find_free_unit() if(pw%label >= 0 ) then open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polawd.'// nfile, & &status='unknown',recl=pw%numpw*DP,access='direct') else open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polawd.-'// nfile, & &status='unknown',recl=pw%numpw*DP,access='direct') endif do iw=range_min,range_max iww = iw if( .not. full_range ) iww = iw - range_min + 1 write(unit=iung, rec=iw) pw%pw(:,iww) enddo close(iung) endif return END SUBROUTINE write_polaw_range SUBROUTINE read_polaw_range(label, pw,debug,range_min,range_max, full_range ) !this subroutine reads the green function from disk !the file name is taken from the label !reads columns from range_min to range_max USE io_files, ONLY : prefix,tmp_dir USE io_global, ONLY : stdout implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(polaw) :: pw!the green function to be read INTEGER :: label! the label identifing the required green function LOGICAL :: debug!if true formatted files INTEGER, INTENT(in) :: range_min, range_max!defining range LOGICAL, INTENT(IN) :: full_range LOGICAL :: direct_file = .true.!if true uses direct- access file to read matrix from disk INTEGER :: iw, jw, iung, iww CHARACTER(5) :: nfile !check if(range_min<1 ) then write(stdout,*) 'read_polaw_range: out of range ', range_min, range_max stop endif !first deallocate call free_memory_polaw(pw) if(label >= 0 ) then write(nfile,'(5i1)') label/10000,mod(label,10000)/1000,mod(label,1000)/100,mod(label,100)/10,mod(label,10) iung = find_free_unit() if(.not.debug) then open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polaw.'// nfile, status='old',form='unformatted') else open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polaw.'// nfile, status='old',form='formatted') endif else write(nfile,'(5i1)') -label/10000,mod(-label,10000)/1000,mod(-label,1000)/100,mod(-label,100)/10,mod(-label,10) iung = find_free_unit() if(.not.debug) then open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polaw.-'// nfile, status='old',form='unformatted') else open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polaw.-'// nfile, status='old',form='formatted') endif endif if(.not.debug) then read(iung) pw%label read(iung) pw%ontime read(iung) pw%time read(iung) pw%numpw read(iung) pw%factor else read(iung,*) pw%label read(iung,*) pw%ontime read(iung,*) pw%time read(iung,*) pw%numpw read(iung,*) pw%factor endif !now allocate if( full_range ) then allocate(pw%pw(pw%numpw,pw%numpw)) else allocate( pw%pw( pw%numpw, range_max - range_min + 1 ) ) endif if(.not. direct_file) then if(.not.debug) then do iw=1,pw%numpw read(iung) pw%pw(1:pw%numpw,iw) enddo else do iw=1,pw%numpw do jw=1,pw%numpw read(iung,*) pw%pw(jw,iw) enddo enddo endif endif close(iung) if(direct_file) then !check if(range_max > pw%numpw ) then write(stdout,*) 'read_polaw_range: out of range = ', range_min, range_max stop endif iung = find_free_unit() if(label >= 0 ) then open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polawd.'// nfile, & &status='unknown',recl=pw%numpw*DP,access='direct') else open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'polawd.-'// nfile, & &status='unknown',recl=pw%numpw*DP,access='direct') endif do iw=range_min, range_max iww = iw if( .not. full_range ) iww = iw - range_min + 1 read(unit=iung, rec=iw) pw%pw(:,iww) enddo close(iung) endif return END SUBROUTINE read_polaw_range SUBROUTINE create_polarization(time,pr,gf_p,gf_m,qm,debug) !this subroutine set the polarization in imaginary time ! as P(r,r',it)=G(r,r',it)*G(r,r',-it) ! for our basis ! P_{i,j}=\sum_{l,n,m,o} Q_{i,lm}Q_{j,mo}G_{lm}(it)G_{no}(-it) !THERE IS ALSO A SPIN FACTOR 2 USE basic_structures, ONLY : q_mat,wannier_P USE green_function, ONLY : green USE io_global, ONLY : stdout USE constants, ONLY : eps8 implicit none REAL(kind=DP) :: time!imaginary time t, just a check TYPE(polaw) :: pr!polarization P(it) to be created TYPE(green) :: gf_p!green function G(it) TYPE(green) :: gf_m!green function G(-it) TYPE(q_mat) :: qm!overlap matrix Q LOGICAL :: debug!if true check for hermeticity INTEGER :: iw,jw, ip,jp INTEGER :: l,n,m,o !first annihilation call free_memory_polaw(pr) !check time if((abs(gf_p%time - time)>=eps8) .OR. (abs(gf_m%time + time) >= eps8)) then!times are wrong write(stdout,*) 'Subroutine polarization: times are wrong',gf_p%time,gf_m%time stop endif !set pr pr%ontime=.true. pr%time=time pr%numpw=qm%numpw !allocate allocate(pr%pw( pr%numpw,pr%numpw)) pr%pw(:,:) =(0.d0,0.d0) do iw=1,pr%numpw do jw=iw,pr%numpw do ip=1,qm%wp(iw)%numij do jp=1,qm%wp(jw)%numij l=qm%wp(iw)%ij(1,ip) n=qm%wp(iw)%ij(2,ip) m=qm%wp(jw)%ij(1,jp) o=qm%wp(jw)%ij(2,jp) pr%pw(iw,jw)=pr%pw(iw,jw)+qm%wp(iw)%o(ip)*qm%wp(jw)%o(jp)* & & gf_p%gf(l,m,1)*gf_m%gf(n,o,1) !couples are NOT ordered if(l/=n) then pr%pw(iw,jw)=pr%pw(iw,jw)+qm%wp(iw)%o(ip)*qm%wp(jw)%o(jp)* & & gf_p%gf(n,m,1)*gf_m%gf(l,o,1) endif if(m/=o) then pr%pw(iw,jw)=pr%pw(iw,jw)+qm%wp(iw)%o(ip)*qm%wp(jw)%o(jp)* & & gf_p%gf(l,o,1)*gf_m%gf(n,m,1) endif if(l/=n .AND. m/=o) then pr%pw(iw,jw)=pr%pw(iw,jw)+qm%wp(iw)%o(ip)*qm%wp(jw)%o(jp)* & & gf_p%gf(n,o,1)*gf_m%gf(l,m,1) endif enddo pr%pw(jw,iw)=pr%pw(iw,jw) enddo enddo enddo pr%factor=(0.d0,-1.d0) !now spin factor pr%pw(:,:)=2.d0*pr%pw(:,:) return END subroutine SUBROUTINE calculate_w(vp,pp,ww,xc_together,l_symm_epsilon,l_head_epsilon,agz,head,l_divergence,inv_epsi, & &l_wing_epsilon, awing, l_verbose) !this subroutine calculates W=(1+vp)^{-1}v !this is meaningful only on frequency domain !lapack routines are used USE io_global, ONLY : stdout USE basic_structures, ONLY : v_pot, head_epsilon implicit none TYPE(v_pot) :: vp!coulomb potential TYPE(polaw) :: pp!polarization on imaginary frequency, destroyed on exit TYPE(polaw) :: ww!dressed interaction to be calculated LOGICAL :: xc_together!if true the entire W is taken, otherwise W-v LOGICAL :: l_symm_epsilon! if true uses the symmetrized form of the dielectric matrix !for calculating W LOGICAL :: l_head_epsilon!if true add to the symmetrized form of the dielectric matrix !the head terms REAL(kind=DP), DIMENSION(:) :: agz!terms A_ij<\tilde{w^P_j}|G=0> REAL(kind=DP) :: head!term (G=0,G=0) of the symmetric dielectric matrix LOGICAL, INTENT(in) :: l_divergence!if true calculate the head of the inverse dielectric matrix REAL(kind=DP), INTENT(out) :: inv_epsi!head of the inverse dielectric matrix LOGICAL, INTENT(in) :: l_wing_epsilon!if true calculate the wings of the symmetrized dielectric matrix REAL(kind=DP), DIMENSION(:) :: awing!the terms A_ij wing_j LOGICAL, INTENT(in) :: l_verbose INTEGER iw,jw,kw REAL(kind=DP), ALLOCATABLE, DIMENSION(:,:) :: dtmp!temporary array INTEGER, ALLOCATABLE, DIMENSION(:) :: ipiv INTEGER :: info REAL(kind=DP),ALLOCATABLE, DIMENSION(:) :: work INTEGER :: lwork REAL(kind=DP) sca REAL(kind=DP) :: workd !deallocate if the case call free_memory_polaw(ww) !check and set if(pp%ontime) then write(stdout,*) 'Routine calculate_w: frequencies required' stop endif if(pp%numpw /= vp%numpw) then write(stdout,*) 'Routine calculate_w: basis set does not correspond',pp%numpw,vp%numpw stop endif ww%ontime=.false. ww%time=pp%time ww%label=pp%label ww%numpw=pp%numpw allocate(ww%pw(ww%numpw,ww%numpw)) allocate(dtmp(ww%numpw,ww%numpw)) allocate(ipiv(ww%numpw)) if(.not.l_symm_epsilon) then !not symmetric case calculates -vP call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,-1.d0*dble(pp%factor),& & vp%vmat,ww%numpw,pp%pw,ww%numpw,0.d0,dtmp,ww%numpw) else !symmetric case calculates -v^1/2 P v^1/2 call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,-1.d0*dble(pp%factor),& & vp%vmat,ww%numpw,pp%pw,ww%numpw,0.d0,dtmp,ww%numpw) pp%pw(:,:)=dtmp(:,:) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,& & pp%pw,ww%numpw,vp%vmat,ww%numpw,0.d0,dtmp,ww%numpw) endif !if required add the head if(l_symm_epsilon .and.l_head_epsilon) then do jw=1,ww%numpw do iw=1,ww%numpw dtmp(iw,jw)=dtmp(iw,jw)+agz(iw)*agz(jw)*head enddo enddo endif !if required add the wings if(l_symm_epsilon .and.l_wing_epsilon) then do jw=1,ww%numpw do iw=1,ww%numpw dtmp(iw,jw)=dtmp(iw,jw)+agz(iw)*awing(jw)+agz(jw)*awing(iw) enddo enddo endif do iw=1,ww%numpw dtmp(iw,iw)=dtmp(iw,iw)+1.d0 enddo !inverse zmat call dgetrf(ww%numpw,ww%numpw,dtmp,ww%numpw,ipiv,info) if(info /= 0) then write(stdout,*) 'Routine calculate_w: problem with dgetrf :', info stop endif call dgetri(ww%numpw,dtmp,ww%numpw,ipiv,workd,-1,info) if(l_verbose) write(stdout,*) 'Dimension', workd!ATTENZIONE allocate(work(int(workd))) call dgetri(ww%numpw,dtmp,ww%numpw,ipiv,work,int(workd),info) if(info /= 0) then write(stdout,*) 'Routine calculate_w: problem with zgetri :', info stop endif if(.not.xc_together) then do iw=1,ww%numpw dtmp(iw,iw)=dtmp(iw,iw)-1.d0 enddo endif !if required calculates the head (G=0,G=0) of \epsilon^-1 if(l_divergence) then inv_epsi=0.d0 do jw=1,ww%numpw do iw=1,ww%numpw inv_epsi = inv_epsi+dtmp(iw,jw)*agz(iw)*agz(jw) enddo enddo do iw=1,ww%numpw dtmp(iw,iw)=dtmp(iw,iw)-inv_epsi enddo endif if(l_verbose) write(stdout,*) 'INV EPSI G=0,G=0', inv_epsi if(.not. l_symm_epsilon) then !calculates (e-1 -1)v call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,& & dtmp,ww%numpw,vp%vmat,ww%numpw,0.d0,ww%pw,ww%numpw) else !calculates v^1/2 (e-1-1)v^1/2 call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,& & vp%vmat,ww%numpw,dtmp,ww%numpw,0.d0,pp%pw,ww%numpw) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,& & pp%pw,ww%numpw,vp%vmat,ww%numpw,0.d0,ww%pw,ww%numpw) endif ww%factor=(1.d0,0.d0) ! if(.not.xc_together) then ! do iw=1,ww%numpw ! do jw=1,ww%numpw ! ww%pw(iw,jw)=ww%pw(iw,jw)-vp%vmat(iw,jw) ! enddo ! enddo ! endif deallocate(dtmp,ipiv,work) return END SUBROUTINE SUBROUTINE create_polarization_contraction(time,pr,cp,uu,l_hf_energies, ene_hf) !this subroutine set the polarization in imaginary time ! as P(r,r',it)=G(r,r',it)*G(r,r',-it) ! for our basis !uses contractions !THERE IS ALSO A SPIN FACTOR 2 !if required uses HF energies USE io_global, ONLY : stdout USE constants, ONLY : eps8 USE compact_product, ONLY : contraction_pola USE basic_structures, ONLY : wannier_u implicit none REAL(kind=DP) :: time!imaginary time t, just a check TYPE(polaw) :: pr!polarization P(it) to be created TYPE(contraction_pola) :: cp!the contracted products descriptor TYPE(wannier_u) :: uu!for the KS energies LOGICAL, INTENT(in) :: l_hf_energies!if true uses HF energies REAL(kind=DP), INTENT(in) :: ene_hf(:)!HF energies INTEGER :: iw,jw, vv, cc INTEGER :: l,n,m,o REAL(kind=DP) :: offset REAL(kind=DP),ALLOCATABLE :: expene(:)!to calculate the exponentials just once !first annihilation call free_memory_polaw(pr) !set pr pr%ontime=.true. pr%time=time pr%numpw=cp%numpw !calculates energy offset if(.not.l_hf_energies) then if(cp%nums > cp%nums_occ) then offset=-(uu%ene(cp%nums_occ+1,1)+uu%ene(cp%nums_occ,1))/2.d0 else offset=-uu%ene(cp%nums_occ,1) endif else if(cp%nums > cp%nums_occ) then offset=-(ene_hf(cp%nums_occ+1)+ene_hf(cp%nums_occ))/2.d0 else offset=-ene_hf(cp%nums_occ) endif endif !calcualte exponentials of ks energies allocate(expene(cp%nums)) if(.not.l_hf_energies) then do vv=1,cp%nums_occ expene(vv)=exp((uu%ene(vv,1)+offset)*time) enddo do cc=cp%nums_occ+1,cp%nums expene(cc)=exp(-(uu%ene(cc,1)+offset)*time) enddo else do vv=1,cp%nums_occ expene(vv)=exp((ene_hf(vv)+offset)*time) enddo do cc=cp%nums_occ+1,cp%nums expene(cc)=exp(-(ene_hf(cc)+offset)*time) enddo endif !allocate allocate(pr%pw( pr%numpw,pr%numpw)) pr%pw(:,:)=(0.d0,0.d0) do iw=1,pr%numpw do jw=iw,pr%numpw do vv=1,cp%nums_occ do cc=1,cp%nums-cp%nums_occ pr%pw(iw,jw)=pr%pw(iw,jw) + cp%ou(iw,vv,cc)*conjg(cp%ou(jw,vv,cc))*& & expene(vv)*expene(cc+cp%nums_occ) enddo enddo pr%pw(jw,iw)=pr%pw(iw,jw) enddo enddo pr%factor=(0.d0,-1.d0) !now spin factor pr%pw(:,:)=2.d0*pr%pw(:,:) deallocate(expene) return END SUBROUTINE SUBROUTINE invert_ortho_polaw(op,opi) !this subroutine inverts the orthonormalization matrix !acting of products of wanniers USE io_global, ONLY : stdout USE basic_structures, ONLY : ortho_polaw, free_memory implicit none TYPE(ortho_polaw), INTENT(in) :: op !the descriptor of the orthonormalization matrix to be inverted TYPE(ortho_polaw), INTENT(out) :: opi !the descriptor of the orthonormalization matrix to be inverted INTEGER :: info,lwork INTEGER, ALLOCATABLE, DIMENSION(:) :: ipiv REAL(kind=DP), ALLOCATABLE, DIMENSION(:) :: work lwork=op%numpw allocate(ipiv(op%numpw)) allocate(work(lwork)) call free_memory(opi) opi%numpw=op%numpw allocate(opi%on_mat( opi%numpw, opi%numpw)) opi%on_mat(:,:)=op%on_mat(:,:) call dgetrf(opi%numpw,opi%numpw,opi%on_mat,opi%numpw,ipiv,info) if(info /= 0) then write(stdout,*) 'Routine invert_ortho_polaw: problem with dgetrf :', info stop endif call dgetri(opi%numpw,opi%on_mat,opi%numpw,ipiv,work,lwork,info) if(info /= 0) then write(stdout,*) 'Routine invert_ortho_polaw: problem with dgetri :', info stop endif if(op%inverse) then opi%inverse=.false. else opi%inverse=.true. endif deallocate(ipiv,work) return END SUBROUTINE SUBROUTINE distribute_ortho_polaw(op,opd) !this subroutine distributes the orthonormalization matrix ! among processors USE io_global, ONLY : stdout USE basic_structures, ONLY : ortho_polaw, free_memory USE mp_world, ONLY : nproc,mpime implicit none TYPE(ortho_polaw), INTENT(in) :: op !the descriptor of the orthonormalization matrix to be distributed TYPE(ortho_polaw), INTENT(out) :: opd!distributed orthonormalization matrix INTEGER :: l_blk,nbegin,nend,ii call free_memory(opd) opd%numpw = op%numpw opd%inverse = op%inverse l_blk= op%numpw/nproc if(l_blk*nproc < op%numpw) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 if(nend > op%numpw) nend = op%numpw allocate(opd%on_mat(op%numpw,l_blk)) do ii=nbegin,nend opd%on_mat(:,ii-nbegin+1)=op%on_mat(:,ii) enddo return END SUBROUTINE distribute_ortho_polaw SUBROUTINE collect_ortho_polaw(op,opd) !this subroutine collects the orthonormalization matrix ! among processors USE io_global, ONLY : stdout USE basic_structures, ONLY : ortho_polaw, free_memory USE mp_world, ONLY : nproc,mpime,world_comm!group USE parallel_include implicit none TYPE(ortho_polaw), INTENT(out) :: op !the descriptor of the orthonormalization matrix to be distributed TYPE(ortho_polaw), INTENT(in) :: opd!distributed orthonormalization matrix INTEGER :: l_blk,nbegin,nend,ierr call free_memory(op) op%numpw = opd%numpw op%inverse = opd%inverse l_blk= op%numpw/nproc if(l_blk*nproc < op%numpw) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 if(nend > op%numpw) nend = op%numpw allocate(op%on_mat(op%numpw,l_blk*nproc)) #ifdef __PARA call MPI_ALLGATHER(opd%on_mat,l_blk*op%numpw,MPI_DOUBLE_PRECISION, op%on_mat, & & l_blk*op%numpw, MPI_DOUBLE_PRECISION,world_comm, ierr) #else op%on_mat(:,:)=opd%on_mat #endif return END SUBROUTINE collect_ortho_polaw SUBROUTINE orthonormalize(op,pw) !this subroutine rotates the pw data on the basis of the trasform op !perform the trasform \sum_{i',j'} B_{i,i'}P_{i',j'}B_{j,j'} USE io_global, ONLY : stdout USE basic_structures, ONLY : ortho_polaw implicit none TYPE(polaw), INTENT(inout) :: pw!data TYPE(ortho_polaw), INTENT(in) :: op!trasform INTEGER :: iw,jw,kw REAL(kind=DP), ALLOCATABLE :: mat(:,:) if(op%numpw /= pw%numpw) then write(stdout,*) 'ROUTINE ORTHONORMALIZE: BASIS INCONSISTENT' stop endif allocate(mat(op%numpw,op%numpw)) call dgemm('N','N',op%numpw,op%numpw,op%numpw,1.d0,& & op%on_mat,op%numpw,pw%pw,op%numpw,0.d0,mat,op%numpw) call dgemm('N','T',op%numpw,op%numpw,op%numpw,1.d0,& & mat,op%numpw,op%on_mat,op%numpw,0.d0,pw%pw,op%numpw) deallocate(mat) return END SUBROUTINE SUBROUTINE orthonormalize_inverse(op,pw) !this subroutine rotates the pw data on the basis of the trasform op !perform the trasform \sum_{i',j'} B_{i',i}P_{i',j'}B_{j',j} USE io_global, ONLY : stdout USE basic_structures, ONLY : ortho_polaw implicit none TYPE(polaw), INTENT(inout) :: pw!data TYPE(ortho_polaw), INTENT(in) :: op!trasform INTEGER :: iw,jw,kw REAL(kind=DP), ALLOCATABLE :: mat(:,:) if(op%numpw /= pw%numpw) then write(stdout,*) 'ROUTINE ORTHONORMALIZE: BASIS INCONSISTENT' stop endif allocate(mat(op%numpw,op%numpw)) call dgemm('T','N',op%numpw,op%numpw,op%numpw,1.d0,& & op%on_mat,op%numpw,pw%pw,op%numpw,0.d0,mat,op%numpw) call dgemm('N','N',op%numpw,op%numpw,op%numpw,1.d0,& & mat,op%numpw,op%on_mat,op%numpw,0.d0,pw%pw,op%numpw) deallocate(mat) return END SUBROUTINE SUBROUTINE orthonormalize_vpot_inverse(op,vp) !this subroutine rotates the v_pot data on the basis of the trasform op !perform the trasform \sum_{i',j'} B_{i',i}P_{i',j'}B_{j',j} USE io_global, ONLY : stdout USE basic_structures, ONLY : v_pot, ortho_polaw implicit none TYPE(v_pot), INTENT(inout) :: vp!data TYPE(ortho_polaw), INTENT(in) :: op!trasform INTEGER :: iw,jw,kw REAL(kind=DP), ALLOCATABLE :: mat(:,:) if(op%numpw /= vp%numpw) then write(stdout,*) 'ROUTINE ORTHONORMALIZE: BASIS INCONSISTENT' stop endif allocate(mat(op%numpw,op%numpw)) ! mat(:,:)=0.d0 ! do iw=1,op%numpw ! do jw=1,op%numpw ! do kw=1,op%numpw ! mat(iw,jw)=mat(iw,jw)+op%on_mat(kw,iw)*vp%vmat(kw,jw) ! enddo ! enddo ! enddo call dgemm('T','N',op%numpw,op%numpw,op%numpw,1.d0,op%on_mat,op%numpw,vp%vmat,op%numpw,0.d0,mat,op%numpw) ! vp%vmat(:,:)=0.d0 ! do iw=1,op%numpw ! do kw=1,op%numpw ! do jw=1,op%numpw ! vp%vmat(iw,jw)=vp%vmat(iw,jw)+op%on_mat(kw,jw)*mat(iw,kw) ! enddo ! enddo ! enddo call dgemm('N','N',op%numpw,op%numpw,op%numpw,1.d0,mat,op%numpw,op%on_mat,op%numpw,0.d0,vp%vmat,op%numpw) deallocate(mat) return END SUBROUTINE SUBROUTINE orthonormalize_vpot(op,vp) !this subroutine rotates the v_pot data on the basis of the trasform op !perform the trasform \sum_{i',j'} B_{i,i'}P_{i',j'}B_{j,j'} USE io_global, ONLY : stdout USE basic_structures, ONLY : v_pot, ortho_polaw implicit none TYPE(v_pot), INTENT(inout) :: vp!data TYPE(ortho_polaw), INTENT(in) :: op!trasform INTEGER :: iw,jw,kw REAL(kind=DP), ALLOCATABLE :: mat(:,:) if(op%numpw /= vp%numpw) then write(stdout,*) 'ROUTINE ORTHONORMALIZE: BASIS INCONSISTENT' stop endif allocate(mat(op%numpw,op%numpw)) ! mat(:,:)=0.d0 ! do iw=1,op%numpw ! do jw=1,op%numpw ! do kw=1,op%numpw ! mat(iw,jw)=mat(iw,jw)+op%on_mat(iw,kw)*vp%vmat(kw,jw) ! enddo ! enddo ! enddo call dgemm('N','N',op%numpw,op%numpw,op%numpw,1.d0,op%on_mat,op%numpw,vp%vmat,op%numpw,0.d0,mat,op%numpw) ! vp%vmat(:,:)=0.d0 ! do iw=1,op%numpw ! do jw=1,op%numpw ! do kw=1,op%numpw ! vp%vmat(iw,jw)=vp%vmat(iw,jw)+op%on_mat(jw,kw)*mat(iw,kw) ! enddo ! enddo ! enddo call dgemm('N','T',op%numpw,op%numpw,op%numpw,1.d0,mat,op%numpw,op%on_mat,op%numpw,0.d0,vp%vmat,op%numpw) deallocate(mat) return END SUBROUTINE orthonormalize_vpot SUBROUTINE orthonormalize_vpot_para(op,vp) !this subroutine rotates the v_pot data on the basis of the trasform op !perform the trasform \sum_{i',j'} B_{i,i'}P_{i',j'}B_{j,j'} !parallel version USE io_global, ONLY : stdout USE basic_structures, ONLY : v_pot, ortho_polaw USE mp_world, ONLY : mpime, nproc, world_comm USE mp, ONLY : mp_sum implicit none TYPE(v_pot), INTENT(inout) :: vp!data TYPE(ortho_polaw), INTENT(in) :: op!trasform INTEGER :: iw,jw,kw REAL(kind=DP), ALLOCATABLE :: mat(:,:) if(op%numpw /= vp%numpw) then write(stdout,*) 'ROUTINE ORTHONORMALIZE: BASIS INCONSISTENT' stop endif allocate(mat(op%numpw,op%numpw)) mat(:,:)=0.d0 do iw=1,op%numpw do jw=1,op%numpw if(mod(jw,nproc)==mpime) then do kw=1,op%numpw mat(iw,jw)=mat(iw,jw)+op%on_mat(iw,kw)*vp%vmat(kw,jw) enddo endif enddo call mp_sum(mat(iw,:),world_comm) enddo vp%vmat(:,:)=0.d0 do iw=1,op%numpw do jw=1,op%numpw if(mod(jw,nproc)==mpime) then do kw=1,op%numpw vp%vmat(iw,jw)=vp%vmat(iw,jw)+op%on_mat(jw,kw)*mat(iw,kw) enddo endif enddo call mp_sum(vp%vmat(iw,:),world_comm) enddo deallocate(mat) return END SUBROUTINE orthonormalize_vpot_para SUBROUTINE invert_v_pot(vp,vpi) !this subroutine inverts the coulombian matrix !acting on space of orthonormal products of wanniers USE io_global, ONLY : stdout USE basic_structures, ONLY : v_pot, free_memory implicit none TYPE(v_pot), INTENT(in) :: vp !the descriptor of the coulombian matrix to be inverted TYPE(v_pot), INTENT(inout) :: vpi !the descriptor of the inverted coulombian matrix INTEGER :: info,lwork,i,j INTEGER, ALLOCATABLE, DIMENSION(:) :: ipiv REAL(kind=DP), ALLOCATABLE, DIMENSION(:) :: work call free_memory(vpi) lwork=vp%numpw allocate(ipiv(vp%numpw)) allocate(work(lwork)) vpi%numpw=vp%numpw allocate(vpi%vmat( vpi%numpw, vpi%numpw)) !write(stdout,*) size(vpi%vmat,1), size(vpi%vmat,2), size(vp%vmat,1), size(vp%vmat,2) ! vpi%vmat(:,:)=vp%vmat(:,:) ! bug do j = 1, size(vpi%vmat,2) do i = 1, size(vpi%vmat,1) vpi%vmat(i,j)=vp%vmat(i,j) end do end do call dgetrf(vpi%numpw,vpi%numpw,vpi%vmat,vpi%numpw,ipiv,info) if(info /= 0) then write(stdout,*) 'Invert V: problem with dgetrf :', info stop endif call dgetri(vpi%numpw,vpi%vmat,vpi%numpw,ipiv,work,lwork,info) if(info /= 0) then write(stdout,*) 'Invert V: problem with dgetri :', info stop endif deallocate(ipiv,work) return END SUBROUTINE invert_v_pot SUBROUTINE fake_polarization_io(n) !this subroutine just call mp_barrier 2*n+1 times USE mp, ONLY : mp_barrier USE mp_world, ONLY : world_comm implicit none INTEGER :: n INTEGER :: i !we take advantage of the t ==> -t symmetry ! do i=-n,n do i=0,n call mp_barrier( world_comm ) enddo return END SUBROUTINE fake_polarization_io SUBROUTINE orthonormalize_vpot_inverse_para(op,vp) !this subroutine rotates the v_pot data on the basis of the trasform op !perform the trasform \sum_{i',j'} B_{i',i}P_{i',j'}B_{j',j} !parallel version USE io_global, ONLY : stdout USE basic_structures, ONLY : v_pot, ortho_polaw USE mp_world, ONLY : world_comm, mpime, nproc USE mp, ONLY : mp_sum implicit none TYPE(v_pot), INTENT(inout) :: vp!data TYPE(ortho_polaw), INTENT(in) :: op!trasform INTEGER :: iw,jw,kw REAL(kind=DP), ALLOCATABLE :: mat(:,:) if(op%numpw /= vp%numpw) then write(stdout,*) 'ROUTINE ORTHONORMALIZE: BASIS INCONSISTENT' stop endif allocate(mat(op%numpw,op%numpw)) mat(:,:)=0.d0 do iw=1,op%numpw do jw=1,op%numpw if(mod(jw,nproc)==mpime) then do kw=1,op%numpw mat(iw,jw)=mat(iw,jw)+op%on_mat(kw,iw)*vp%vmat(kw,jw) enddo endif enddo call mp_sum(mat(iw,:),world_comm) enddo vp%vmat(:,:)=0.d0 do iw=1,op%numpw do jw=1,op%numpw if(mod(jw,nproc)==mpime) then do kw=1,op%numpw vp%vmat(iw,jw)=vp%vmat(iw,jw)+op%on_mat(kw,jw)*mat(iw,kw) enddo endif enddo call mp_sum(vp%vmat(iw,:),world_comm) enddo deallocate(mat) return END SUBROUTINE orthonormalize_vpot_inverse_para SUBROUTINE create_polarization_contraction_state(time,pr,uu,l_hf_energies, ene_hf,options) !this subroutine set the polarization in imaginary time ! as P(r,r',it)=G(r,r',it)*G(r,r',-it) ! for our basis !uses contractions !THERE IS ALSO A SPIN FACTOR 2 !if required uses HF energies !use single occupied state contractions USE io_global, ONLY : stdout USE constants, ONLY : eps8 USE compact_product, ONLY : contraction_pola_state, free_memory_contraction_pola_state, & &read_contraction_pola_state USE basic_structures, ONLY : wannier_u USE input_gw, ONLY : input_options implicit none REAL(kind=DP) :: time!imaginary time t, just a check TYPE(polaw) :: pr!polarization P(it) to be created TYPE(wannier_u) :: uu!for the KS energies LOGICAL, INTENT(in) :: l_hf_energies!if true uses HF energies REAL(kind=DP), INTENT(in) :: ene_hf(:)!HF energies TYPE(input_options) :: options!for i/o purpoose INTEGER :: iw,jw, vv, cc INTEGER :: l,n,m,o REAL(kind=DP) :: offset REAL(kind=DP),ALLOCATABLE :: expene(:)!to calculate the exponentials just once REAL(kind=DP),ALLOCATABLE :: exptmp(:)!temporary arrays for speed-up REAL(kind=DP),ALLOCATABLE :: outmp(:,:) REAL(kind=DP),ALLOCATABLE :: tmpc(:) TYPE(contraction_pola_state) :: cps !first annihilation call free_memory_polaw(pr) !set pr pr%ontime=.true. pr%time=time !the following for accessing dimension of polarization matrix cps%state=1 call read_contraction_pola_state(cps,options) pr%numpw=cps%numpw !calculates energy offset if(.not.l_hf_energies) then if(uu%nums > uu%nums_occ(1)) then offset=-(uu%ene(uu%nums_occ(1)+1,1)+uu%ene(uu%nums_occ(1),1))/2.d0 else offset=-uu%ene(uu%nums_occ(1),1) endif else if(uu%nums > uu%nums_occ(1)) then offset=-(ene_hf(uu%nums_occ(1)+1)+ene_hf(uu%nums_occ(1)))/2.d0 else offset=-ene_hf(uu%nums_occ(1)) endif endif !calcualte exponentials of ks energies allocate(expene(uu%nums)) if(.not.l_hf_energies) then do vv=1,uu%nums_occ(1) expene(vv)=exp((uu%ene(vv,1)+offset)*time) enddo do cc=uu%nums_occ(1)+1,uu%nums expene(cc)=exp(-(uu%ene(cc,1)+offset)*time) enddo else do vv=1,uu%nums_occ(1) expene(vv)=exp((ene_hf(vv)+offset)*time) enddo do cc=uu%nums_occ(1)+1,uu%nums expene(cc)=exp(-(ene_hf(cc)+offset)*time) enddo endif !allocate allocate(pr%pw( pr%numpw,pr%numpw)) pr%pw(:,:)=0.d0 allocate(exptmp(cps%nums-cps%nums_occ)) allocate(outmp(cps%nums-cps%nums_occ,pr%numpw)) allocate(tmpc(cps%nums-cps%nums_occ)) do vv=1,cps%nums_occ cps%state=vv write(stdout,*) 'read_contraction_pola_state' if(vv /= 1) call read_contraction_pola_state(cps,options) write(stdout,*) 'read_contraction_pola_state', vv do cc=1,cps%nums-cps%nums_occ exptmp(cc)=expene(vv)*expene(cc+cps%nums_occ) enddo do iw=1,pr%numpw do cc=1,cps%nums-cps%nums_occ outmp(cc,iw)=cps%ou(cc,iw)*exptmp(cc) enddo enddo write(stdout,*) 'calculus1' ! do jw=1,pr%numpw ! do iw=jw,pr%numpw ! do cc=1,cps%nums-cps%nums_occ ! tmpc(cc)=cps%ou(cc,iw)*outmp(cc,jw) ! enddo ! pr%pw(iw,jw)=pr%pw(iw,jw)+sum(tmpc(:)) ! enddo ! enddo call dgemm('T','N',pr%numpw,pr%numpw,cps%nums-cps%nums_occ,1.d0,cps%ou,cps%nums-cps%nums_occ, & outmp,cps%nums-cps%nums_occ,1.d0,pr%pw,pr%numpw) call free_memory_contraction_pola_state(cps) enddo do jw=1,pr%numpw do iw=jw,pr%numpw pr%pw(jw,iw)=pr%pw(iw,jw) enddo enddo ! pr%pw(:,:)=(0.d0,-1.d0)*pr%pw(:,:) pr%factor=(0.d0,-1.d0) !now spin factor pr%pw(:,:)=2.d0*pr%pw(:,:) deallocate(expene) deallocate(exptmp) deallocate(outmp) deallocate(tmpc) return END SUBROUTINE create_polarization_contraction_state SUBROUTINE distribute_v_pot(vp,vpd) !this subroutine distributes the coulomb matrix ! among processors USE io_global, ONLY : stdout USE basic_structures, ONLY : v_pot, free_memory USE mp_world, ONLY : nproc,mpime implicit none TYPE(v_pot), INTENT(in) :: vp !the descriptor of the coulomb matrix to be distributed TYPE(v_pot), INTENT(out) :: vpd!distributed coulomb matrix INTEGER :: l_blk,nbegin,nend,ii call free_memory(vpd) vpd%numpw = vp%numpw l_blk= vp%numpw/nproc if(l_blk*nproc < vp%numpw) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 if(nend > vp%numpw) nend = vp%numpw allocate(vpd%vmat(vp%numpw,l_blk)) do ii=nbegin,nend vpd%vmat(:,ii-nbegin+1)=vp%vmat(:,ii) enddo return END SUBROUTINE distribute_v_pot SUBROUTINE collect_v_pot(vp,vpd) !this subroutine collects the coulomb matrix ! among processors USE io_global, ONLY : stdout USE basic_structures, ONLY : v_pot, free_memory USE mp_world, ONLY : nproc,mpime,world_comm!group USE parallel_include implicit none TYPE(v_pot), INTENT(out) :: vp !the descriptor of the coulomb matrix to be distributed TYPE(v_pot), INTENT(in) :: vpd!distributed coulomb matrix INTEGER :: l_blk,nbegin,nend,ierr call free_memory(vp) vp%numpw = vpd%numpw l_blk= vp%numpw/nproc if(l_blk*nproc < vp%numpw) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 if(nend > vp%numpw) nend = vp%numpw allocate(vp%vmat(vp%numpw,l_blk*nproc)) #ifdef __PARA call MPI_ALLGATHER(vpd%vmat,l_blk*vp%numpw,MPI_DOUBLE_PRECISION, vp%vmat, & & l_blk*vp%numpw, MPI_DOUBLE_PRECISION,world_comm, ierr) #else vp%vmat(:,:)=vpd%vmat(:,:) #endif return END SUBROUTINE collect_v_pot SUBROUTINE calculate_w_g(vp,pp,ww,xc_together,l_symm_epsilon,l_head_epsilon,agz,head,l_divergence,inv_epsi, & &l_wing_epsilon, awing, awing_c) !this subroutine calculates W=(1+vp)^{-1}v !this is meaningful only on frequency domain !lapack routines are used !it use exteded basis for G=0 term USE io_global, ONLY : stdout USE basic_structures, ONLY : v_pot, head_epsilon implicit none TYPE(v_pot) :: vp!coulomb potential TYPE(polaw) :: pp!polarization on imaginary frequency, destroyed on exit TYPE(polaw) :: ww!dressed interaction to be calculated LOGICAL :: xc_together!if true the entire W is taken, otherwise W-v LOGICAL :: l_symm_epsilon! if true uses the symmetrized form of the dielectric matrix !for calculating W LOGICAL :: l_head_epsilon!if true add to the symmetrized form of the dielectric matrix !the head terms REAL(kind=DP), DIMENSION(:) :: agz!terms A_ij<\tilde{w^P_j}|G=0> REAL(kind=DP) :: head!term (G=0,G=0) of the symmetric dielectric matrix LOGICAL, INTENT(in) :: l_divergence!if true calculate the head of the inverse dielectric matrix REAL(kind=DP), INTENT(out) :: inv_epsi!head of the inverse dielectric matrix LOGICAL, INTENT(in) :: l_wing_epsilon!if true calculate the wings of the symmetrized dielectric matrix REAL(kind=DP), DIMENSION(:) :: awing!the terms A_ij wing_j REAL(kind=DP), DIMENSION(:) :: awing_c!the terms A_ij wing_j INTEGER iw,jw,kw REAL(kind=DP), ALLOCATABLE, DIMENSION(:,:) :: dtmp!temporary array INTEGER, ALLOCATABLE, DIMENSION(:) :: ipiv INTEGER :: info REAL(kind=DP),ALLOCATABLE, DIMENSION(:) :: work INTEGER :: lwork REAL(kind=DP) sca REAL(kind=DP) :: workd REAL(kind=DP) alpha !deallocate if the case call free_memory_polaw(ww) !check and set if(pp%ontime) then write(stdout,*) 'Routine calculate_w: frequencies required' stop endif if(pp%numpw /= vp%numpw) then write(stdout,*) 'Routine calculate_w: basis set does not correspond',pp%numpw,vp%numpw stop endif ww%ontime=.false. ww%time=pp%time ww%label=pp%label ww%numpw=pp%numpw allocate(ww%pw(ww%numpw,ww%numpw)) allocate(dtmp(ww%numpw+1,ww%numpw+1)) allocate(ipiv(ww%numpw+1)) dtmp(:,:)=0.d0 if(.not.l_symm_epsilon) then !not symmetric case calculates -vP call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,-1.d0*dble(pp%factor),& & vp%vmat,ww%numpw,pp%pw,ww%numpw,0.d0,dtmp,ww%numpw+1) else !symmetric case calculates -v^1/2 P v^1/2 call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,-1.d0*dble(pp%factor),& & vp%vmat,ww%numpw,pp%pw,ww%numpw,0.d0,dtmp,ww%numpw+1) pp%pw(1:ww%numpw,1:ww%numpw)=dtmp(1:ww%numpw,1:ww%numpw) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,& & pp%pw,ww%numpw,vp%vmat,ww%numpw,0.d0,dtmp,ww%numpw+1) endif !calculate normalization factor alpha sca=1.d0 do iw=1,ww%numpw sca=sca-agz(iw)**2.d0 enddo alpha=1.d0/sqrt(sca) write(stdout,*) 'ALPHA :', alpha call flush_unit(stdout) !calculate elements 0',0' 0',i i,O' dtmp(ww%numpw+1,:)=0.d0 dtmp(:,ww%numpw+1)=0.d0 do iw=1,ww%numpw do jw=1,ww%numpw dtmp(ww%numpw+1,ww%numpw+1)=dtmp(ww%numpw+1,ww%numpw+1) & & + alpha**2.d0 * agz(iw)* agz(jw)*dtmp(iw,jw) enddo enddo do iw=1,ww%numpw do jw=1,ww%numpw dtmp(ww%numpw+1,iw)=dtmp(ww%numpw+1,iw)-alpha*dtmp(jw,iw)*agz(jw) enddo enddo do iw=1,ww%numpw dtmp(iw,ww%numpw+1)=dtmp(ww%numpw+1,iw) enddo !if required add the head if(l_symm_epsilon .and.l_head_epsilon) then ! terms i,j do jw=1,ww%numpw do iw=1,ww%numpw dtmp(iw,jw)=dtmp(iw,jw)+agz(iw)*agz(jw)*head enddo enddo endif !term O',0' 0',i i,0' dtmp(ww%numpw+1,ww%numpw+1)= dtmp(ww%numpw+1,ww%numpw+1) + & &head/alpha**2.d0 do iw=1,ww%numpw dtmp(ww%numpw+1,iw)=dtmp(ww%numpw+1,iw)+head*agz(iw)/alpha dtmp(iw,ww%numpw+1)=dtmp(iw,ww%numpw+1)+head*agz(iw)/alpha enddo !if required add the wings !TODO ATTENZIONE if(l_symm_epsilon .and.l_wing_epsilon) then !elements i,j do jw=1,ww%numpw do iw=1,ww%numpw dtmp(iw,jw)=dtmp(iw,jw)+agz(iw)*awing_c(jw)+agz(jw)*awing_c(iw) enddo enddo ! 0',0' do iw=1,ww%numpw dtmp(ww%numpw+1,ww%numpw+1)=dtmp(ww%numpw+1,ww%numpw+1) & & - 2.d0*agz(iw)*awing_c(iw) enddo ! 0',i ',0' do iw=1,ww%numpw dtmp(ww%numpw+1,iw)=dtmp(ww%numpw+1,iw)+awing(iw)/alpha do jw=1,ww%numpw dtmp(ww%numpw+1,iw)=dtmp(ww%numpw+1,iw)-alpha*agz(iw)*awing_c(jw)*agz(jw) enddo dtmp(iw,ww%numpw+1)=dtmp(ww%numpw+1,iw) enddo endif do iw=1,ww%numpw+1 dtmp(iw,iw)=dtmp(iw,iw)+1.d0 enddo !inverse zmat write(stdout,*) 'Before inversion' call flush_unit(stdout) call dgetrf(ww%numpw+1,ww%numpw+1,dtmp,ww%numpw+1,ipiv,info) if(info /= 0) then write(stdout,*) 'Routine calculate_w: problem with dgetrf :', info stop endif write(stdout,*) 'Before inversion2' call flush_unit(stdout) call dgetri(ww%numpw+1,dtmp,ww%numpw+1,ipiv,workd,-1,info) write(stdout,*) 'Dimension', workd,ww%numpw,info!ATTENZIONE call flush_unit(stdout) allocate(work(int(workd))) call dgetri(ww%numpw+1,dtmp,ww%numpw+1,ipiv,work,int(workd),info) write(stdout,*) 'Out of dgetri' call flush_unit(stdout) if(info /= 0) then write(stdout,*) 'Routine calculate_w: problem with zgetri :', info stop endif if(.not.xc_together) then do iw=1,ww%numpw+1 dtmp(iw,iw)=dtmp(iw,iw)-1.d0 enddo endif !if required calculates the head (G=0,G=0) of \epsilon^-1 if(l_divergence) then inv_epsi=0.d0 !term i,j do jw=1,ww%numpw do iw=1,ww%numpw inv_epsi = inv_epsi+dtmp(iw,jw)*agz(iw)*agz(jw) enddo enddo !term 0',0' inv_epsi=inv_epsi+dtmp(ww%numpw+1,ww%numpw+1)/alpha**2.d0 !terms 0',i i,0' do iw=1,ww%numpw inv_epsi=inv_epsi+2.d0*agz(iw)*dtmp(ww%numpw+1,iw)/alpha enddo do iw=1,ww%numpw+1 dtmp(iw,iw)=dtmp(iw,iw)-inv_epsi enddo endif write(stdout,*) 'INV EPSI G=0,G=0', inv_epsi, dtmp(ww%numpw+1,ww%numpw+1) call flush_unit(stdout) if(l_symm_epsilon .and.l_head_epsilon) then!ATTENZIONE !take away the G=0,G=0 term ! terms i,j write(stdout,*) 'Extract G=0,G=0 term' do jw=1,ww%numpw do iw=1,ww%numpw dtmp(iw,jw)=dtmp(iw,jw)-agz(iw)*agz(jw)*inv_epsi enddo enddo endif if(.not. l_symm_epsilon) then !calculates (e-1 -1)v call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,& & dtmp,ww%numpw+1,vp%vmat,ww%numpw,0.d0,ww%pw,ww%numpw) else !calculates v^1/2 (e-1-1)v^1/2 call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,& & vp%vmat,ww%numpw,dtmp,ww%numpw+1,0.d0,pp%pw,ww%numpw) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,& & pp%pw,ww%numpw,vp%vmat,ww%numpw,0.d0,ww%pw,ww%numpw) endif ww%factor=(1.d0,0.d0) ! if(.not.xc_together) then ! do iw=1,ww%numpw ! do jw=1,ww%numpw ! ww%pw(iw,jw)=ww%pw(iw,jw)-vp%vmat(iw,jw) ! enddo ! enddo ! endif deallocate(dtmp,ipiv,work) return END SUBROUTINE calculate_w_g SUBROUTINE create_polarization_file(uu, tf, prefix) USE basic_structures, ONLY : wannier_u, cprim_prod, free_memory, & &initialize_memory_cprim_prod USE times_gw, ONLY : times_freqs USE mp_world, ONLY : world_comm, nproc,mpime USE io_global, ONLY : stdout USE mp, ONLY : mp_barrier implicit none TYPE(wannier_u), INTENT(in) :: uu!for the energies TYPE(times_freqs) :: tf CHARACTER(LEN=256), INTENT(in) :: prefix!to designate the PW files INTEGER :: l_blk, nbegin, nend INTEGER :: it,iv,ic, iw, jw TYPE(polaw) :: pp TYPE(cprim_prod) :: cpp LOGICAL :: ok_read REAL(kind=DP), ALLOCATABLE :: exp_table(:) LOGICAL :: l_first!trick for gaining access to numpw, quite BAD REAL(kind=DP), ALLOCATABLE :: cpmat_tmp(:,:) write(stdout,*) 'Routine create_polarization_file' allocate(exp_table(uu%nums-uu%nums_occ(1))) !loop on time l_blk= (tf%n+1)/nproc if(l_blk*nproc < (tf%n+1)) l_blk = l_blk+1 nbegin=mpime*l_blk nend=nbegin+l_blk-1 do it=nbegin,nend if(it<= tf%n) then call initialize_polaw(pp) l_first=.true. do iv=1,uu%nums_occ(1) !loop on v write(stdout,*) 'STATE', iv call flush_unit(stdout) !set table of exponentials do ic=uu%nums_occ(1)+1,uu%nums exp_table(ic-uu%nums_occ(1))=exp((uu%ene(iv,1)-uu%ene(ic,1))*tf%times(it)) enddo call mp_barrier( world_comm ) call initialize_memory_cprim_prod(cpp) !!read in Svci cpp%cprim=iv call read_data_pw_cprim_prod(cpp, prefix, .true., ok_read, .true.,.false.) !if required allocate polaw if(l_first) then allocate(pp%pw(cpp%numpw,cpp%numpw)) pp%pw(:,:)=0.d0 pp%numpw=cpp%numpw l_first=.false. endif !!!!the following for using blas routine allocate(cpmat_tmp(cpp%nums_cond,cpp%numpw)) call mytranspose(cpp%cpmat, cpp%numpw, cpmat_tmp, cpp%nums_cond, cpp%numpw, cpp%nums_cond) do iw=1,cpp%numpw cpmat_tmp(:,iw)=cpmat_tmp(:,iw)*exp_table(:) enddo !!! !calculate term ! do ic=1,cpp%nums_cond ! do jw=1,cpp%numpw ! do iw=1,cpp%numpw ! pp%pw(iw,jw)=pp%pw(iw,jw)+cpp%cpmat(iw,ic)*cpp%cpmat(jw,ic)*exp_table(ic) ! enddo ! enddo ! enddo call dgemm('N','N',cpp%numpw,cpp%numpw,cpp%nums_cond,1.d0,cpp%cpmat,cpp%numpw,& &cpmat_tmp,cpp%nums_cond,1.d0,pp%pw,cpp%numpw) deallocate(cpmat_tmp) call free_memory(cpp) enddo !write polaw on file ! pp%label=it pp%time=tf%times(it) pp%factor=(0.d0,-1.d0) pp%numpw=cpp%numpw pp%ontime=.true. pp%pw(:,:)=pp%pw(:,:)*2.d0!for spin multiplicity call write_polaw(pp,.false.) call free_memory_polaw(pp) else !just parallelel reading of file do iv=1,uu%nums_occ(1) call mp_barrier( world_comm ) call initialize_memory_cprim_prod(cpp) cpp%cprim=iv call read_data_pw_cprim_prod(cpp, prefix, .true., ok_read, .true.,.false.) call free_memory(cpp) enddo endif enddo deallocate(exp_table) return END SUBROUTINE create_polarization_file SUBROUTINE square_root_polaw(pw,numpw) !this subroutine calculate the square root of the polaw matrix !it is done by calculating the eigenvalues and eigenvectors !it assumes that the matrix is symmetric and positive definite USE io_global, ONLY : stdout implicit none REAL(kind=DP) :: pw(numpw,numpw)!the matrix to be operated INTEGER :: numpw!dimension of the matrix REAL(kind=DP), ALLOCATABLE :: e_va(:), work(:) REAL(kind=DP), ALLOCATABLE :: tmp_pw(:,:) INTEGER :: lwork, info REAL(kind=DP) :: loptwork INTEGER :: iw,jw,kw #ifdef __OPENMP INTEGER :: ntids INTEGER :: omp_get_num_threads, omp_get_max_threads EXTERNAL omp_set_num_threads, omp_get_num_threads, omp_get_max_threads #endif allocate(e_va(numpw)) allocate(tmp_pw(numpw, numpw)) tmp_pw(:,:)=pw(:,:) #ifdef __OPENMP ! go single-thread ntids = omp_get_max_threads() call omp_set_num_threads(1) #endif !check for optimal dimension call DSYEV( 'V', 'U', numpw, tmp_pw, numpw, e_va, loptwork, -1, info) lwork=int(loptwork) allocate(work(lwork)) !calculate the eigenvalues, eigenvectors call DSYEV( 'V', 'U', numpw, tmp_pw, numpw, e_va, work, lwork,info ) if(info /= 0) then write(stdout,*) 'Problem with dsyev', info stop endif #ifdef __OPENMP ! go multi-thread call omp_set_num_threads(ntids) #endif !do square root of eigenvector do iw=1,numpw if(e_va(iw) < 0.d0) then write(stdout,*) 'Problem with eigenvalue', iw stop endif e_va(iw)=dsqrt(e_va(iw)) enddo !reform the matrix pw(:,:)=0.d0 ! Carlo substitute with DGEMM do kw=1,numpw do jw=1,numpw do iw=1,numpw pw(iw,jw)=pw(iw,jw)+tmp_pw(iw,kw)*tmp_pw(jw,kw)*e_va(kw) enddo enddo enddo deallocate(tmp_pw) deallocate(work) deallocate(e_va) return END SUBROUTINE square_root_polaw SUBROUTINE create_polarization_beta(time, pr, uu, qm) !this subroutine create the polarization with the strategy beta: !P_ij(\tau)=\int dr dr' <\omega^{P'}_i(r)U_{v,v'}exp(E_v\tau)\tilde{\omega_v'}(r)*U_{v,v''}\tilde{\omega_v''}(r') ! *U_{c,c'}exp(E_c\tau)\tilde{\omega_c'}(r)U_{c,c''}\tilde{\omega_c''}(r)\omega^{P'}_j(r') !it makes use of S_{i,vc}=\int dr \omega^{P'}_i(r)\tilde{\omega_v}(r)\tilde{\omega_c}(r) USE basic_structures, ONLY : wannier_u, free_memory,q_mat, wannier_P USE times_gw, ONLY : times_freqs USE io_global, ONLY : stdout implicit none REAL(kind=DP), INTENT(in) :: time! imaginary time tau TYPE(wannier_u), INTENT(in) :: uu!for the energies and trasformation matrix TYPE(polaw), INTENT(out) :: pr!polarization P(it) to be created TYPE(q_mat), INTENT(in) :: qm ! for S matrices INTEGER :: i,j,k, ip, ii, jj INTEGER :: nums_cond!number of conduction states INTEGER :: iw,jw REAL(kind=DP), ALLOCATABLE :: v_val(:,:), exp_table_v(:), v_cond(:,:), exp_table_c(:) REAL(kind=DP), ALLOCATABLE :: tmp_mat1(:,:), tmp_mat2(:,:) REAL(kind=DP) :: fermi_en REAL(kind=DP), ALLOCATABLE :: q(:,:),t(:,:), v(:) REAL(kind=DP), EXTERNAL :: ddot write(stdout,*) 'Routine create_polarization_beta' !0)set polarization structure pr%ontime=.true. pr%time=time pr%numpw=qm%numpw pr%factor=(0.d0,-1.d0) !allocate allocate(pr%pw( pr%numpw,pr%numpw)) pr%pw(:,:) =(0.d0,0.d0) !1)calculate V_v'v''= U_{vv'}U_{v,v''}exp(E_v \tau} allocate(v_val(uu%nums_occ(1),uu%nums_occ(1))) allocate(exp_table_v(uu%nums_occ(1))) !fermi_en is used to reduce the numerical error fermi_en=(uu%ene(uu%nums_occ(1)+1,1)+uu%ene(uu%nums_occ(1),1))/2.d0 exp_table_v(1:uu%nums_occ(1))=exp((uu%ene(1:uu%nums_occ(1),1)-fermi_en)*abs(time)) v_val(:,:)=0.d0 allocate(tmp_mat1(uu%nums_occ(1),uu%nums_occ(1)), tmp_mat2(uu%nums_occ(1),uu%nums_occ(1))) tmp_mat1(1:uu%nums_occ(1),1:uu%nums_occ(1))=dble(uu%umat(1:uu%nums_occ(1),1:uu%nums_occ(1),1)) do i=1,uu%nums_occ(1) do j=1,uu%nums_occ(1) tmp_mat2(i,j)=dble(uu%umat(i,j,1))*exp_table_v(i) enddo enddo call dgemm('T','N',uu%nums_occ(1),uu%nums_occ(1),uu%nums_occ(1),1.d0,tmp_mat2,uu%nums_occ(1),tmp_mat1,uu%nums_occ(1),& &0.d0,v_val,uu%nums_occ(1)) deallocate(tmp_mat1,tmp_mat2) deallocate(exp_table_v) !2) calculate V_c'c''= U_{c,c'}U_{c,c''}exp(-E_c \tau} nums_cond=uu%nums-uu%nums_occ(1) allocate(v_cond(nums_cond,nums_cond)) allocate(exp_table_c(nums_cond)) exp_table_c(1:nums_cond)=exp((-uu%ene(uu%nums_occ(1)+1:uu%nums,1) +fermi_en)*abs(time)) allocate(tmp_mat1(nums_cond,nums_cond), tmp_mat2(nums_cond,nums_cond)) tmp_mat1(1:nums_cond,1:nums_cond)=dble(uu%umat(uu%nums_occ(1)+1:uu%nums,uu%nums_occ(1)+1:uu%nums,1)) do i=1,nums_cond do j=1,nums_cond tmp_mat2(i,j)=dble(uu%umat(uu%nums_occ(1)+i,uu%nums_occ(1)+j,1))*exp_table_c(i) enddo enddo call dgemm('T','N',nums_cond,nums_cond,nums_cond,1.d0,tmp_mat2,nums_cond,tmp_mat1,nums_cond,& &0.d0,v_cond,nums_cond) deallocate(tmp_mat1,tmp_mat2) deallocate(exp_table_c) do iw=1,pr%numpw !calculate T_v''c'=S_{i,v'c'}V_{v',v''} allocate(t(uu%nums_occ(1),nums_cond)) t(:,:)=0.d0 do ip=1,qm%wp(iw)%numij i=qm%wp(iw)%ij(1,ip)!valence only j=qm%wp(iw)%ij(2,ip)!valence and conduction if(i>uu%nums_occ(1)) then write(stdout,*) 'create_polarization_beta ERROR' call flush_unit(stdout) stop endif !only valence*conduction products are required if(j>uu%nums_occ(1)) then do ii=1,uu%nums_occ(1) t(ii,j-uu%nums_occ(1))=t(ii,j-uu%nums_occ(1))+qm%wp(iw)%o(ip)*v_val(i,ii) enddo endif enddo !calculate Q v''c''=T_{v''c'}V_{c'c''} allocate( q(uu%nums_occ(1),nums_cond)) call dgemm('N','N',uu%nums_occ(1),nums_cond,nums_cond,1.d0,t,uu%nums_occ(1),v_cond,nums_cond,0.d0,& &q,uu%nums_occ(1)) deallocate(t) !put q on a right order for multiplication with S_{j,v''c''} !WARNING WARNING ATTENZIONE !it suppose that the wp(:)%ij are all the same allocate(v(qm%wp(1)%numij)) v(:)=0.d0 do ip=1,qm%wp(iw)%numij i=qm%wp(iw)%ij(1,ip)!valence only j=qm%wp(iw)%ij(2,ip)!valence and conduction if(j > uu%nums_occ(1)) then v(ip)=q(i,j-uu%nums_occ(1)) endif enddo deallocate(q) !product with jw do jw=iw,pr%numpw pr%pw(iw,jw)= ddot(qm%wp(iw)%numij,qm%wp(jw)%o,1,v,1) pr%pw(jw,iw)=pr%pw(iw,jw) enddo deallocate(v) enddo !now spin factor pr%pw(:,:)=2.d0*pr%pw(:,:) deallocate(v_val,v_cond) return END SUBROUTINE create_polarization_beta SUBROUTINE create_polarization_upper(uu, tf, prefix) !this subroutine adds to the polarization the part from upper reduced states USE basic_structures, ONLY : wannier_u, cprim_prod, free_memory, & &initialize_memory, upper_states USE times_gw, ONLY : times_freqs USE mp_world, ONLY : nproc,mpime USE io_global, ONLY : stdout implicit none TYPE(wannier_u), INTENT(in) :: uu!for the energies TYPE(times_freqs), INTENT(in) :: tf !for grid on imaginary time CHARACTER(LEN=256), INTENT(in) :: prefix!to designate the PW files INTEGER :: l_blk, nbegin, nend INTEGER :: it,iv,ic, iw, jw TYPE(upper_states) :: us TYPE(polaw) :: pp TYPE(cprim_prod) :: cpp LOGICAL :: ok_read REAL(kind=DP), ALLOCATABLE :: exp_table(:) REAL(kind=DP), ALLOCATABLE :: cpmat_tmp(:,:) write(stdout,*) 'Routine create_polarization_upper' !read-in upper states call initialize_memory(us) call read_data_pw_upper_states(us,prefix) allocate(exp_table(us%nums_reduced)) !loop on time l_blk= (tf%n+1)/nproc if(l_blk*nproc < (tf%n+1)) l_blk = l_blk+1 nbegin=mpime*l_blk nend=nbegin+l_blk-1 do it=nbegin,nend if(it<= tf%n) then !read polarization call initialize_polaw(pp) call read_polaw(it,pp,.false.,.false.) do iv=1,uu%nums_occ(1) !loop on v write(stdout,*) 'STATE', iv call flush_unit(stdout) !set table of exponentials do ic=1,us%nums_reduced exp_table(ic)=exp((uu%ene(iv,1)-us%ene(ic))*tf%times(it)) enddo call initialize_memory(cpp) !!read in Svci cpp%cprim=iv call read_data_pw_cprim_prod(cpp, prefix, .true., ok_read, .true.,.true.) !if required allocate polaw !!!!the following for using blas routine allocate(cpmat_tmp(us%nums_reduced,cpp%numpw)) call mytranspose(cpp%cpmat, cpp%numpw, cpmat_tmp, us%nums_reduced, cpp%numpw, us%nums_reduced) do iw=1,cpp%numpw cpmat_tmp(:,iw)=cpmat_tmp(:,iw)*exp_table(:) enddo !!! !calculate term ! do ic=1,cpp%nums_cond ! do jw=1,cpp%numpw ! do iw=1,cpp%numpw ! pp%pw(iw,jw)=pp%pw(iw,jw)+cpp%cpmat(iw,ic)*cpp%cpmat(jw,ic)*exp_table(ic) ! enddo ! enddo ! enddo !factor 2 for spin multiplicity call dgemm('N','N',cpp%numpw,cpp%numpw,us%nums_reduced,2.d0,cpp%cpmat,cpp%numpw,& &cpmat_tmp,us%nums_reduced,1.d0,pp%pw,cpp%numpw) deallocate(cpmat_tmp) call free_memory(cpp) enddo !write polaw on file ! call write_polaw(pp,.false.) call free_memory_polaw(pp) else !just parallelel reading of file do iv=1,uu%nums_occ(1) call initialize_memory(cpp) cpp%cprim=iv call read_data_pw_cprim_prod(cpp, prefix, .true., ok_read, .true.,.true.) call free_memory(cpp) enddo endif enddo deallocate(exp_table) call free_memory(us) return END SUBROUTINE create_polarization_upper SUBROUTINE calculate_w_g_l(vp,pp,ww,xc_together,l_head_epsilon,head,inv_epsi, & &l_wing_epsilon, awing, awing_c, l_verbose) !this subroutine calculates W=(1+vp)^{-1}v !this is meaningful only on frequency domain !lapack routines are used !it use exteded basis for G=0 term !version for lanczos chain scheme USE io_global, ONLY : stdout USE basic_structures, ONLY : v_pot, head_epsilon implicit none TYPE(v_pot) :: vp!coulomb potential TYPE(polaw) :: pp!polarization on imaginary frequency, destroyed on exit TYPE(polaw) :: ww!dressed interaction to be calculated LOGICAL :: xc_together!if true the entire W is taken, otherwise W-v LOGICAL :: l_head_epsilon!if true add to the symmetrized form of the dielectric matrix !the head terms REAL(kind=DP) :: head(3)!term (G=0,G=0) of the symmetric dielectric matrix REAL(kind=DP), INTENT(out) :: inv_epsi!head of the inverse dielectric matrix LOGICAL, INTENT(in) :: l_wing_epsilon!if true calculate the wings of the symmetrized dielectric matrix REAL(kind=DP), DIMENSION(pp%numpw,3) :: awing!the terms A_ij wing_j REAL(kind=DP), DIMENSION(pp%numpw,3) :: awing_c!the terms A_ij wing_j LOGICAL, INTENT(in) :: l_verbose INTEGER iw,jw,kw,ipol REAL(kind=DP), ALLOCATABLE, DIMENSION(:,:) :: dtmp!temporary array INTEGER, ALLOCATABLE, DIMENSION(:) :: ipiv INTEGER :: info REAL(kind=DP),ALLOCATABLE, DIMENSION(:) :: work INTEGER :: lwork REAL(kind=DP) sca REAL(kind=DP) :: workd(1) REAL(kind=DP) alpha REAL(kind=DP) head_v REAL(kind=DP), ALLOCATABLE :: pw_save(:,:) !deallocate if the case call free_memory_polaw(ww) !check and set if(pp%ontime) then write(stdout,*) 'Routine calculate_w: frequencies required' stop endif if(pp%numpw /= vp%numpw) then write(stdout,*) 'Routine calculate_w: basis set does not correspond',pp%numpw,vp%numpw stop endif ww%ontime=.false. ww%time=pp%time ww%label=pp%label ww%numpw=pp%numpw allocate(ww%pw(ww%numpw,ww%numpw)) allocate(dtmp(ww%numpw,ww%numpw)) allocate(ipiv(ww%numpw)) ww%pw(:,:)=0.d0 allocate(pw_save(pp%numpw,pp%numpw)) do ipol=1,3 if(l_verbose) write(stdout,*) 'MAX P:', maxval(pp%pw(:,:)), 'MIN P:', minval(pp%pw(:,:)) call flush_unit(stdout) if(ipol==1) then pw_save(:,:)=pp%pw(:,:) else pp%pw(:,:)=pw_save(:,:) endif dtmp(:,:)=0.d0 head_v=vp%vmat(vp%numpw,vp%numpw) !DEBUG if(l_verbose) write(stdout,*) 'IRR POLA HEAD', pp%pw(pp%numpw,pp%numpw) if(l_verbose) write(stdout,*) 'IRR POLA FIRST', pp%pw(1,1), l_wing_epsilon ! vp%vmat(vp%numpw,1:vp%numpw)=0.d0 !ATTENZIONE DEBUG ! vp%vmat(1:vp%numpw,vp%numpw)=0.d0 pp%pw(pp%numpw,1:pp%numpw)=0.d0 pp%pw(1:pp%numpw,pp%numpw)=0.d0 if(l_wing_epsilon) then!ATTENZIONE ! 0',i ',0' do iw=1,ww%numpw-1 pp%pw(ww%numpw,iw)=awing(iw,ipol) pp%pw(iw,ww%numpw)=pp%pw(ww%numpw,iw) enddo endif !symmetric case calculates -v^1/2 P v^1/2 call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,-1.d0*dble(pp%factor),& &vp%vmat,ww%numpw,pp%pw,ww%numpw,0.d0,dtmp,ww%numpw) pp%pw(1:ww%numpw,1:ww%numpw)=dtmp(1:ww%numpw,1:ww%numpw) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,& & pp%pw,ww%numpw,vp%vmat,ww%numpw,0.d0,dtmp,ww%numpw) !if required add the head if(l_head_epsilon) then !term O',0' 0',i i,0' dtmp(ww%numpw,ww%numpw)= head(ipol) if(l_verbose) write(stdout,*) 'APPLYING HEAD', head!DEBUG endif do iw=1,ww%numpw dtmp(iw,iw)=dtmp(iw,iw)+1.d0 enddo !inverse zmat if(l_verbose) write(stdout,*) 'MAX D:', maxval(dtmp(:,:)), 'MIN D', minval(dtmp(:,:)) if(l_verbose) write(stdout,*) 'Before inversion' call flush_unit(stdout) call dgetrf(ww%numpw,ww%numpw,dtmp,ww%numpw,ipiv,info) if(info /= 0) then write(stdout,*) 'Routine calculate_w: problem with dgetrf :', info stop endif if(l_verbose) write(stdout,*) 'Before inversion2' call flush_unit(stdout) call dgetri(ww%numpw,dtmp,ww%numpw,ipiv,workd,-1,info) if(l_verbose) write(stdout,*) 'Dimension', workd,ww%numpw,info!ATTENZIONE call flush_unit(stdout) allocate(work(int(workd(1)))) call dgetri(ww%numpw,dtmp,ww%numpw,ipiv,work,int(workd(1)),info) if(l_verbose) write(stdout,*) 'Out of dgetri' call flush_unit(stdout) if(l_verbose) write(stdout,*) 'MAX D1:', maxval(dtmp(:,:)), 'MIN D1:', minval(dtmp(:,:)) if(info /= 0) then write(stdout,*) 'Routine calculate_w: problem with zgetri :', info stop endif if(.not.xc_together) then do iw=1,ww%numpw dtmp(iw,iw)=dtmp(iw,iw)-1.d0 enddo endif inv_epsi=0.d0 !term i,j !term 0',0' inv_epsi=dtmp(ww%numpw,ww%numpw) write(stdout,*) 'INV EPSI G=0,G=0', inv_epsi, head_v call flush_unit(stdout) vp%vmat(vp%numpw,vp%numpw)=head_v dtmp(ww%numpw,1:ww%numpw-1)=0.d0 dtmp(1:ww%numpw-1,ww%numpw)=0.d0 !DEBUG ! dtmp(:,:)=0.d0 ! do iw=1,ww%numpw ! dtmp(iw,iw)=inv_epsi ! enddo ! dtmp(ww%numpw,ww%numpw)=0.d0 !DEBUG if(l_verbose) write(stdout,*) 'MAX D2:', maxval(dtmp(:,:)), 'MIN D2:', minval(dtmp(:,:)) call flush_unit(stdout) !calculates v^1/2 (e-1-1)v^1/2 call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,& & vp%vmat,ww%numpw,dtmp,ww%numpw,0.d0,pp%pw,ww%numpw) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,& & pp%pw,ww%numpw,vp%vmat,ww%numpw,1.d0,ww%pw,ww%numpw) if(l_verbose) write(stdout,*) 'MAX W:', maxval(ww%pw(:,:)), 'MIN W:', minval(ww%pw(:,:)) call flush_unit(stdout) deallocate(work) enddo deallocate(pw_save) ww%pw(:,:)=ww%pw(:,:)/3.d0 ! ww%pw(1:ww%numpw-1,1:ww%numpw-1)=0.d0 ! ww%pw(:,ww%numpw)=0.d0 ww%factor=(1.d0,0.d0) if(l_verbose) write(stdout,*) 'MAX:', maxval(ww%pw(:,:)), 'MIN:', minval(ww%pw(:,:)) call flush_unit(stdout) deallocate(dtmp,ipiv) return END SUBROUTINE calculate_w_g_l END MODULE polarization GWW/gww/para_gww.f900000644000077300007730000000752712341332532014756 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! MODULE para_gww !this modules contains arrays indicating if the !processor should perform the task SAVE LOGICAL, ALLOCATABLE :: is_my_time(:) !for 2n+1 times and frequencies LOGICAL :: is_my_last!for extra 0 time calculation LOGICAL, ALLOCATABLE :: is_my_pola(:) !for 0 to n calculations LOGICAL, ALLOCATABLE :: is_my_state(:)!for KS states considered 1 to n_max LOGICAL, ALLOCATABLE :: is_my_state_range(:)!for KS states considered i_min to i_max CONTAINS subroutine free_memory_para_gww implicit none if(allocated(is_my_time)) deallocate(is_my_time) if(allocated(is_my_pola)) deallocate(is_my_pola) if(allocated(is_my_state)) deallocate(is_my_state) if(allocated(is_my_state_range)) deallocate(is_my_state_range) return end subroutine free_memory_para_gww SUBROUTINE setup_para_gww(ntimes,nstates, i_min, i_max) !this subroutine initialize the para variables for the gww !calculation, parallelization is achieved on imaginary times !and frequencies USE mp_world, ONLY : mpime, nproc USE io_global, ONLY : stdout implicit none INTEGER, INTENT(in) :: ntimes!number of time samples INTEGER, INTENT(in) :: nstates!max number of states INTEGER, INTENT(in) :: i_min!lowest state for which the self-energy is calculated INTEGER, INTENT(in) :: i_max!upper state for which the self-energy is calculated INTEGER :: ndelta, it, ip, iqq !allocates arrays allocate(is_my_time(-ntimes:ntimes)) allocate(is_my_pola(0:ntimes)) allocate(is_my_state(nstates)) allocate(is_my_state_range(i_min:i_max)) is_my_time(:)=.false. is_my_pola(:)=.false. is_my_state(:)=.false. is_my_state_range(:)=.false. ndelta=(2*ntimes+1)/nproc if(ndelta*nproc < (2*ntimes+1)) ndelta=ndelta+1 iqq=-ntimes do ip=0,nproc-1 do it=1,ndelta if(iqq <= ntimes.and.(mpime==ip)) then is_my_time(iqq)=.true. endif if(it==1.and.(mpime==ip)) write(stdout,*) 'min', iqq, ip,it,ndelta if(it==ndelta.and.(mpime==ip)) write(stdout,*) 'max', iqq, ip,it,ndelta iqq=iqq+1 enddo enddo if((mpime+1)==nproc) then is_my_last=.true. else is_my_last=.false. endif ndelta=(ntimes+1)/nproc if(ndelta*nproc < (ntimes+1)) ndelta=ndelta+1 iqq=0 do ip=0,nproc-1 do it=1,ndelta if(iqq <= ntimes.and.(mpime==ip)) then is_my_pola(iqq)=.true. endif if(it==1.and.(mpime==ip)) write(stdout,*) 'min pola', iqq if(it==ndelta.and.(mpime==ip)) write(stdout,*) 'max pola', iqq iqq=iqq+1 enddo enddo ndelta=(nstates)/nproc if(ndelta*nproc < nstates) ndelta=ndelta+1 iqq=1 do ip=0,nproc-1 do it=1,ndelta if(iqq <= nstates.and.(mpime==ip)) then is_my_state(iqq)=.true. endif if(it==1.and.(mpime==ip)) write(stdout,*) 'min state', iqq if(it==ndelta.and.(mpime==ip)) write(stdout,*) 'max state', iqq iqq=iqq+1 enddo enddo ndelta=(i_max-i_min+1)/nproc if(ndelta*nproc < (i_max-i_min+1)) ndelta=ndelta+1 iqq=1 do ip=0,nproc-1 do it=1,ndelta if(iqq <= (i_max-i_min+1).and.(mpime==ip)) then is_my_state_range(iqq+i_min-1)=.true. endif if(it==1.and.(mpime==ip)) write(stdout,*) 'min state range', iqq +i_min-1 if(it==ndelta.and.(mpime==ip)) write(stdout,*) 'max state range', iqq+i_min-1 iqq=iqq+1 enddo enddo return END SUBROUTINE setup_para_gww END MODULE para_gww GWW/gww/gv_time.f900000644000077300007730000001721012341332532014567 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! MODULE w_divergence !for the treatment of the G=0,G=0 divergence of the W operator USE kinds, ONLY : DP TYPE gv_time !this structure contains the data for the treatment of the w_divergence INTEGER :: n!number of time/frequency steps REAL(kind=DP) :: omega!frequency range REAL(kind=DP) :: tau!time range INTEGER :: max_i!number of states COMPLEX(kind=DP), DIMENSION(:,:),POINTER :: ex!terms LOGICAL :: ontime!if .true. is on imaginary time, otherwise frequency COMPLEX(kind=DP), DIMENSION(:), POINTER :: inv_epsi!head (G=0,G=0) of the inverse dielectric matrix END TYPE gv_time CONTAINS SUBROUTINE initialize_gv_time(gt) !initialize implicit none TYPE(gv_time) :: gt nullify(gt%ex) nullify(gt%inv_epsi) return END SUBROUTINE initialize_gv_time SUBROUTINE free_memory_gv_time(gt) implicit none TYPE(gv_time) :: gt if(associated(gt%ex)) deallocate(gt%ex) if(associated(gt%inv_epsi)) deallocate(gt%inv_epsi) nullify(gt%ex) return END SUBROUTINE free_memory_gv_time !read data from PW from file SUBROUTINE read_data_pw_gv_time(gt, prefix) USE io_global, ONLY : stdout, ionode, ionode_id USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(gv_time) :: gt!to be read from PW file CHARACTER(LEN=256) :: prefix!to designate the PW files REAL(kind=DP), ALLOCATABLE :: buf(:) INTEGER :: iun,i if(ionode) then iun = find_free_unit() open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'.gv_time', status='old',form='unformatted') read(iun) gt%max_i read(iun) gt%n read(iun) gt%tau endif call mp_bcast(gt%max_i, ionode_id,world_comm) call mp_bcast(gt%n, ionode_id,world_comm) call mp_bcast(gt%tau, ionode_id,world_comm) allocate(gt%ex(gt%max_i,2*gt%n+2)) allocate(gt%inv_epsi(2*gt%n+1)) gt%inv_epsi(:)=0.d0 if(ionode) then allocate(buf(gt%max_i)) do i=1,2*gt%n+2 read(iun) buf(1:gt%max_i) gt%ex(:,i)=cmplx(buf(:),0.d0) enddo close(iun) deallocate(buf) endif call mp_bcast(gt%ex(:,:),ionode_id,world_comm) return END SUBROUTINE read_data_pw_gv_time SUBROUTINE write_gv_time(gt) !save on file USE io_global, ONLY : ionode USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(gv_time) :: gt INTEGER :: iun,i if(ionode) then iun = find_free_unit() open(unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'gv_time', status='unknown',form='unformatted') write(iun) gt%n write(iun) gt%omega write(iun) gt%tau write(iun) gt%max_i write(iun) gt%ontime do i=1,2*gt%n+2 write(iun) gt%ex(1:gt%max_i,i) enddo write(iun) gt%inv_epsi(1:2*gt%n+1) close(iun) end if return END SUBROUTINE write_gv_time SUBROUTINE read_gv_time(gt) !read from file USE io_global, ONLY : ionode, ionode_id USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(gv_time) :: gt INTEGER :: iun,i if(ionode) then iun = find_free_unit() open(unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'gv_time', status='old',form='unformatted') read(iun) gt%n read(iun) gt%omega read(iun) gt%tau read(iun) gt%max_i read(iun) gt%ontime endif call mp_bcast(gt%n, ionode_id,world_comm) call mp_bcast(gt%omega, ionode_id,world_comm) call mp_bcast(gt%tau, ionode_id,world_comm) call mp_bcast(gt%max_i, ionode_id,world_comm) call mp_bcast(gt%ontime, ionode_id,world_comm) allocate(gt%ex(gt%max_i,2*gt%n+2)) allocate(gt%inv_epsi(2*gt%n+1)) if(ionode) then do i=1,2*gt%n+2 read(iun) gt%ex(1:gt%max_i,i) enddo read(iun) gt%inv_epsi(1:2*gt%n+1) close(iun) endif call mp_bcast(gt%ex(:,:), ionode_id,world_comm) call mp_bcast(gt%inv_epsi(:), ionode_id,world_comm) return END SUBROUTINE read_gv_time SUBROUTINE fft_gv_time(gt,tf) !performs fft transform of gv inv_epsi data USE constants, ONLY : pi USE times_gw, ONLY : times_freqs USE io_global, ONLY : stdout implicit none TYPE(gv_time) :: gt TYPE(times_freqs) :: tf! time frequency grids and factors INTEGER :: ii,jj,iw,jw COMPLEX(kind=DP), ALLOCATABLE :: tmpc(:), factors(:) COMPLEX(kind=DP), ALLOCATABLE :: inv_epsi_new(:) allocate(factors(-tf%n:tf%n), tmpc(-tf%n:tf%n)) allocate(inv_epsi_new(2*tf%n+1)) !check for consistency if(tf%n /= gt%n) then write(stdout,*) 'FFT_GV: not consistent n' stop endif if(tf%omega /= gt%omega) then write(stdout,*) 'FFT_GV: not consistent omega' stop endif if(tf%tau /= gt%tau) then write(stdout,*) 'FFT_GV: not consistent tau' stop endif do ii=-tf%n,tf%n write(*,*) 'ATTENZIONE',ii,gt%max_i!ATTENZIONE if(gt%ontime) then!time to frequency transform do jj=-tf%n,tf%n factors(jj)=tf%weights_time(jj)*exp((0.d0,-1.d0)*tf%freqs(ii)*tf%times(jj)) enddo else!frequency to time transform do jj=-tf%n,tf%n factors(jj)=tf%weights_freq(jj)*exp((0.d0,1.d0)*tf%times(ii)*tf%freqs(jj)) enddo factors(:)=factors(:)/(2.d0*pi) endif write(*,*) 'ATTENZIONE2',ii!ATTENZIONE do jj=-tf%n,tf%n tmpc(jj)=gt%inv_epsi(jj+tf%n+1)*factors(jj) enddo inv_epsi_new(ii+tf%n+1)=sum(tmpc(-tf%n:tf%n)) enddo write(stdout,*) 'ATTENZIONE3' !add i factor if(gt%ontime) then gt%ontime=.false. gt%inv_epsi(1:2*gt%n+1)=(0.d0,-1.d0)*inv_epsi_new(1:2*gt%n+1) else gt%ontime=.true. gt%inv_epsi(1:2*gt%n+1)=(0.d0,1.d0)*inv_epsi_new(1:2*gt%n+1) endif write(stdout,*) 'ATTENZIONE4' deallocate(factors,tmpc,inv_epsi_new) write(stdout,*) 'ATTENZIONE5' return end SUBROUTINE fft_gv_time SUBROUTINE setup_gv_time(gt) !this subroutine set up the gv_time structure !with the head of the inverse dielectric matrices !to be done in imaginary time USE io_global, ONLY : stdout implicit none TYPE(gv_time) :: gt!the structure to be set up INTEGER :: ii,it if(.not.gt%ontime) then write(stdout,*) 'Routine setup_gv_time imaginary time required' stop endif do it=1,gt%n gt%ex(:,it)=gt%ex(:,it)*gt%inv_epsi(it) enddo do it=gt%n+2,2*gt%n+1 gt%ex(:,it)=gt%ex(:,it)*gt%inv_epsi(it) enddo !now the t=0 term gt%ex(:,gt%n+1)=0.5d0*gt%inv_epsi(gt%n+1)*(gt%ex(:,gt%n+1)+gt%ex(:,2*gt%n+2)) return END SUBROUTINE setup_gv_time END MODULE w_divergence GWW/gww/go_dressed_w.f900000644000077300007730000002034712341332532015606 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! SUBROUTINE go_dressed_w(options) !this subroutine reads the polarization on imaginary frequency !and calculate the dressed interaction on imaginary frequency !in case of an non-orthogonal basis set transform forth and back !to the corresponding orthonormalized basis set !if required uses the symmetrized dielectric matrix USE kinds, ONLY : DP USE io_global, ONLY : stdout USE input_gw, ONLY : input_options USE basic_structures, ONLY : v_pot,ortho_polaw,free_memory, head_epsilon USE polarization USE para_gww, ONLY : is_my_pola USE mp, ONLY : mp_barrier, mp_sum USE mp_world, ONLY : world_comm USE w_divergence USE start_end implicit none TYPE(input_options) :: options! for imaginary time range,number of samples TYPE(v_pot) :: vp!bare coulomb potential TYPE(polaw) :: pp,ww!polarization and dressed interaction TYPE(ortho_polaw) :: op!orthonormalization matrices TYPE(head_epsilon) :: he!the head (G=0,G=0) of the symmetrized dielectric matrix REAL(kind=DP), ALLOCATABLE :: agz(:)!elements A_ij of the head REAL(kind=DP), ALLOCATABLE :: awing(:,:) !elements A_ij wing_j REAL(kind=DP), ALLOCATABLE :: awing_c(:,:) !elements A_ij wing_c_j INTEGER :: iw, label, ii, jj REAL(kind=DP), ALLOCATABLE :: inv_epsi(:)!for the heads of inverse dielectric matrices LOGICAL :: l_divergence TYPE(gv_time) :: gt!for handling the W(G=0,G=0) divergence REAL(kind=DP) :: dumhead = -1.0d0 REAL(kind=DP) :: head(3) call initialize_polaw(pp) call initialize_polaw(ww) allocate(inv_epsi(options%n+1)) !read coulomb potential if(options%l_verbose) write(stdout,*) 'ATTEZNIONE1' call flush_unit(stdout) if(options%w_divergence==2) then call read_data_pw_v(vp,options%prefix,options%debug,0,.false.) else call read_data_pw_v(vp,options%prefix,options%debug,0,.false.) endif if(options%l_verbose) write(stdout,*) 'ATTEZNIONE2' call flush_unit(stdout) !read in orthonormalization matrix if(options%lnonorthogonal) then call read_data_pw_ortho_polaw(op,options%prefix) call orthonormalize_vpot_para(op,vp) endif if(options%l_verbose) write(stdout,*) 'ATTEZNIONE2.5' call flush_unit(stdout) !if symmetric do symmetrize if(options%l_symm_epsilon) call square_root_polaw(vp%vmat,vp%numpw) if(options%l_verbose) write(stdout,*) 'ATTEZNIONE3' call flush_unit(stdout) allocate(agz(vp%numpw)) allocate(awing(vp%numpw,3)) allocate(awing_c(vp%numpw,3)) !if required read the head if(options%l_symm_epsilon .and. options%l_head_epsilon) then call read_data_pw_head_epsilon(he, options%prefix, options%l_wing_epsilon,.not.options%l_pola_lanczos) endif if(options%l_verbose) write(stdout,*) 'ATTEZNIONE4' call flush_unit(stdout) if(options%w_divergence == 2) then l_divergence=.true. else l_divergence=.false. endif inv_epsi(:)=0.d0 !loop on imaginary frequencies samples do iw=0,options%n if(is_my_pola(iw)) then write(stdout,*) iw!ATTENZIONE call flush_unit(stdout) call read_polaw(iw,pp,options%debug,options%l_verbose) if(options%lnonorthogonal) then call orthonormalize(op,pp) endif write(stdout,*) 'call calculate_w',iw!ATTENZIONE call flush_unit(stdout) if(options%l_symm_epsilon .and. options%l_head_epsilon) then if(options%lnonorthogonal) then call dgemv('N',op%numpw,op%numpw,1.d0,op%on_mat,op%numpw,he%gzero,1,0.d0,agz,1) else !for lanczos calculation it is always ==0 agz(:)= he%gzero(:) endif endif if(options%l_symm_epsilon .and. options%l_wing_epsilon) then if(options%lnonorthogonal) then call dgemv('N',op%numpw,op%numpw,1.d0,op%on_mat,op%numpw,he%wing(1,iw+1,1),1,0.d0,awing(:,1),1) call dgemv('N',op%numpw,op%numpw,1.d0,op%on_mat,op%numpw,he%wing_c(1,iw+1,1),1,0.d0,awing_c(:,1),1) else awing(:,1:3)=he%wing(:,iw+1,1:3) awing_c(:,1:3)=he%wing_c(:,iw+1,1:3) endif else awing(:,:)=0.d0 awing_c(:,:)=0.d0 endif if(options%l_verbose) write(stdout,*) 'call calculate_w2'!ATTENZIONE call flush_unit(stdout) if(options%w_divergence==0) then call calculate_w(vp,pp,ww,options%xc_together,options%l_symm_epsilon,options%l_head_epsilon, & agz, dumhead,l_divergence,inv_epsi(iw+1), options%l_wing_epsilon,awing(:,1),options%l_verbose) else if(options%w_divergence/=3) then call calculate_w_g(vp,pp,ww,options%xc_together,options%l_symm_epsilon,options%l_head_epsilon, & agz, he%head(iw+1,1),l_divergence,inv_epsi(iw+1), options%l_wing_epsilon,awing(:,1),awing_c(:,1)) else if(options%l_head_epsilon) then head(1:3)= he%head(iw+1,1:3) else head=0.d0 endif call calculate_w_g_l(vp,pp,ww,options%xc_together,options%l_head_epsilon, head,inv_epsi(iw+1), & &options%l_wing_epsilon, awing, awing_c,options%l_verbose) endif endif if(options%l_verbose) write(stdout,*) 'calculated w'!ATTENZIONE call flush_unit(stdout) if(options%lnonorthogonal) then call orthonormalize_inverse(op,ww) endif call write_polaw(ww,options%debug) endif enddo call mp_sum(inv_epsi,world_comm) call free_memory(vp) call free_memory_polaw(pp) call free_memory_polaw(ww) if(options%lnonorthogonal) then call free_memory(op) endif if(options%l_symm_epsilon .and. options%l_head_epsilon) then call free_memory(he) endif deallocate(agz) deallocate(awing,awing_c) !if required set up gv_time structure and write it on file if(options%w_divergence == 2) then call initialize_gv_time(gt) call read_data_pw_gv_time(gt, options%prefix) gt%ontime = .false. gt%omega=options%omega ii=gt%n+1 do iw=1,gt%n+1 gt%inv_epsi(iw)=inv_epsi(ii) ii=ii-1 enddo ii=2 do iw=gt%n+2,2*gt%n+1 gt%inv_epsi(iw)=inv_epsi(ii) ii=ii+1 enddo call write_gv_time(gt) call free_memory_gv_time(gt) endif deallocate(inv_epsi) return END SUBROUTINE go_dressed_w SUBROUTINE control_polarization(options) USE kinds, ONLY : DP USE io_global, ONLY : stdout USE input_gw, ONLY : input_options USE basic_structures, ONLY : v_pot,ortho_polaw,free_memory USE polarization USE para_gww, ONLY : is_my_time USE mp, ONLY : mp_barrier USE mp_world, ONLY : world_comm implicit none TYPE(input_options) :: options! for imaginary time range,number of samples TYPE(v_pot) :: vp!bare coulomb potential TYPE(polaw) :: pp,ww!polarization and dressed interaction TYPE(ortho_polaw) :: op,opi!orthonormalization matrices INTEGER :: iw, label INTEGER :: i,j COMPLEX(kind=DP) :: sum !read coulomb potential !read in orthonormalization matrix if(options%lnonorthogonal) then call read_data_pw_ortho_polaw(op,options%prefix) endif !loop on imaginary frequencies samples iw=15 if(is_my_time(iw)) then write(stdout,*) iw!ATTENZIONE call read_polaw(iw,pp,options%debug,options%l_verbose) if(options%lnonorthogonal) then call orthonormalize(op,pp) endif sum = (0.d0, 0.d0) do i= 1, pp%numpw sum=sum+pp%pw(i,i) enddo write(stdout,*) 'SUM VCVC:', sum endif call mp_barrier( world_comm ) call free_memory_polaw(pp) call free_memory_polaw(ww) if(options%lnonorthogonal) then call free_memory(op) call free_memory(opi) endif return END SUBROUTINE GWW/gww/read_data_pw.f900000644000077300007730000014465412341332532015564 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !these subroutines read in the data from PW calculations SUBROUTINE read_data_pw_u(wu,prefix) !this subroutine reads in the energies and the inversewannier transformation matrix USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures USE mp, ONLY : mp_bcast, mp_barrier USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(wannier_u) :: wu!structure to be read and initialized CHARACTER(LEN=256) :: prefix!to designate the PW files INTEGER :: iunu INTEGER :: iw,is if(ionode) then iunu = find_free_unit() open( unit=iunu, file=trim(tmp_dir)//trim(prefix)//'.wannier', status='old',form='unformatted') !read in basis length read(iunu) wu%nspin read(iunu) wu%nums endif call mp_bcast(wu%nspin, ionode_id, world_comm) call mp_bcast(wu%nums, ionode_id, world_comm) !allocate arrays allocate(wu%ene(wu%nums,wu%nspin)) allocate(wu%ene_xc(wu%nums,wu%nspin)) allocate(wu%ene_lda_h(wu%nums,wu%nspin)) allocate(wu%umat(wu%nums,wu%nums,wu%nspin)) do is=1,wu%nspin if(ionode) read(iunu) wu%nums_occ(is) !write(stdout,*) 'DEBUG:', wu%nspin,wu%nums,wu%nums_occ(is) !call flush_unit(stdout) call mp_bcast(wu%nums_occ(is), ionode_id, world_comm) if(ionode) then !read in energies read(iunu) wu%ene(1:wu%nums,is) !read in DFT exchange and correlation energies read(iunu) wu%ene_xc(1:wu%nums,is) read(iunu) wu%ene_lda_h(1:wu%nums,is) !read in transformation matrix do iw=1,wu%nums read(iunu) wu%umat(1:wu%nums,iw,is) enddo endif call mp_bcast(wu%ene(:,is), ionode_id, world_comm) call mp_bcast(wu%ene_xc(:,is), ionode_id, world_comm) call mp_bcast(wu%ene_lda_h(:,is), ionode_id, world_comm) do iw=1,wu%nums call mp_barrier( world_comm ) call mp_bcast(wu%umat(:,iw,is), ionode_id, world_comm) enddo enddo if(ionode) close(iunu) return END SUBROUTINE read_data_pw_v(vp,prefix,debug,ort,l_zero) !read from file and initialize coulomb potential on the basis of products of wanniers USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE constants, ONLY : eps8 USE basic_structures USE mp, ONLY : mp_bcast,mp_barrier USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(v_pot) :: vp!structure to be read and initialized CHARACTER(LEN=256) :: prefix!to designate the PW files LOGICAL :: debug!if true check for simmetry INTEGER :: ort!if ort==0, open non orthogonal file, if ort == 1 open orthogonal file !if ort==2 open non orthogonal symmetric file LOGICAL :: l_zero!if true open file with head put to zero INTEGER :: iunv INTEGER :: iw,jw if(ionode) then iunv=find_free_unit() if(ort==1) then open( unit=iunv, file=trim(tmp_dir)//trim(prefix)//'.vpot', status='old',form='unformatted') else if (ort==0) then if(.not.l_zero) then open( unit=iunv, file=trim(tmp_dir)//trim(prefix)//'.vpot_no', status='old',form='unformatted') else open( unit=iunv, file=trim(tmp_dir)//trim(prefix)//'.vpot_no_zero', status='old',form='unformatted') endif else if (ort==2) then if(.not.l_zero) then open( unit=iunv, file=trim(tmp_dir)//trim(prefix)//'.vpot_no_sym', status='old',form='unformatted') else open( unit=iunv, file=trim(tmp_dir)//trim(prefix)//'.vpot_no_sym_zero', status='old',form='unformatted') endif endif !read in basis length read(iunv) vp%numpw endif call mp_bcast(vp%numpw, ionode_id, world_comm) !allocate array allocate(vp%vmat(vp%numpw,vp%numpw)) !read in potential matrix if(ionode) then do iw=1,vp%numpw read(iunv) vp%vmat(1:vp%numpw,iw) enddo endif do iw=1,vp%numpw call mp_barrier( world_comm ) call mp_bcast(vp%vmat(:,iw), ionode_id, world_comm) enddo !check if(debug) then do iw=1,vp%numpw do jw=1,iw if(abs(vp%vmat(iw,jw)-vp%vmat(jw,iw)) >= eps8) then write(stdout,*) 'Proble vmat not simmetric:',iw,jw,vp%vmat(iw,jw)-vp%vmat(jw,iw) endif enddo enddo endif if(ionode) close(iunv) return END SUBROUTINE SUBROUTINE read_data_pw_q(qm,prefix,l_v_products) !this subroutine reads in and allocate the arrays for the !description of overlaps of (orthonormalized) products of wanniers !with products of wannier USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures USE mp, ONLY : mp_bcast, mp_barrier USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(q_mat) :: qm!structure to be read and initialized CHARACTER(LEN=256) :: prefix!to designate the PW files LOGICAL :: l_v_products!if true read the wp_v file for the products \tilde{w}_i(r)\tilde{w}_j(r)v(r,r')w^P_red_k(r') INTEGER :: iunq INTEGER :: iw if(ionode) then iunq=find_free_unit() if(.not.l_v_products) then open( unit=iunq, file=trim(tmp_dir)//trim(prefix)//'.wp', status='old',form='unformatted') else open( unit=iunq, file=trim(tmp_dir)//trim(prefix)//'.wp_v', status='old',form='unformatted') endif !read in basis length read(iunq) qm%numpw endif call mp_bcast(qm%numpw, ionode_id, world_comm) ! allocate array of descriptors allocate (qm%wp(qm%numpw)) do iw=1,qm%numpw if(ionode) read(iunq) qm%wp(iw)%numij call mp_bcast(qm%wp(iw)%numij, ionode_id, world_comm) !for each descriptor allocates arrays allocate(qm%wp(iw)%ij(2,qm%wp(iw)%numij)) allocate(qm%wp(iw)%o(qm%wp(iw)%numij)) !read data if(ionode) then read(iunq) qm%wp(iw)%ij(1,1:qm%wp(iw)%numij) read(iunq) qm%wp(iw)%ij(2,1:qm%wp(iw)%numij) read(iunq) qm%wp(iw)%o(1:qm%wp(iw)%numij) end if call mp_bcast(qm%wp(iw)%ij(:,:), ionode_id, world_comm) call mp_bcast(qm%wp(iw)%o(:), ionode_id, world_comm) enddo qm%is_parallel=.false. qm%numpw_para=qm%numpw qm%first_para=1 if(ionode) close(iunq) return END SUBROUTINE SUBROUTINE read_data_pw_ortho_polaw(op,prefix) !this subroutine reads in and allocate the arrays for the !description of orthonormalization matrix of wanniers products USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures, ONLY : ortho_polaw, free_memory USE mp, ONLY : mp_bcast, mp_barrier USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(ortho_polaw) :: op!structure to be read and initialized CHARACTER(LEN=256) :: prefix!to designate the PW files INTEGER :: iunq INTEGER :: iw ! call free_memory(op) if(ionode) then iunq=find_free_unit() open( unit=iunq, file=trim(tmp_dir)//trim(prefix)//'.orthonorm', status='old',form='unformatted') !read in basis length read(iunq) op%numpw endif call mp_bcast(op%numpw, ionode_id, world_comm) allocate(op%on_mat(op%numpw,op%numpw)) if(ionode) then do iw=1,op%numpw read(iunq) op%on_mat(1:op%numpw,iw) enddo end if do iw=1,op%numpw call mp_barrier( world_comm ) call mp_bcast( op%on_mat(:,iw), ionode_id, world_comm) enddo op%inverse=.false. if(ionode) close(iunq) END subroutine SUBROUTINE read_data_pw_wp_psi(wp,prefix) !this subroutine reads in and allocate the arrays for the !description of products of valence^2 times two wannier products USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures, ONLY : wp_psi, free_memory USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(wp_psi) :: wp!structure to be read and initialized CHARACTER(LEN=256) :: prefix!to designate the PW files INTEGER :: iunq INTEGER :: iw,hw, jw ! call free_memory(wp) if(ionode) then iunq=find_free_unit() open( unit=iunq, file=trim(tmp_dir)//trim(prefix)//'.wpwp_psi', status='old',form='unformatted') !read in basis length read(iunq) wp%numpw read(iunq) wp%nums_psi endif call mp_bcast(wp%numpw, ionode_id, world_comm) call mp_bcast(wp%nums_psi, ionode_id, world_comm) allocate(wp%wwp(wp%numpw,wp%numpw,wp%nums_psi)) do hw=1,wp%nums_psi if(ionode) then do iw=1,wp%numpw read(iunq) wp%wwp(iw,1:iw,hw) enddo do iw=1,wp%numpw do jw=iw, wp%numpw wp%wwp(iw,jw,hw)=wp%wwp(jw,iw,hw) enddo enddo endif call mp_bcast( wp%wwp(:,:,hw), ionode_id, world_comm) enddo if(ionode) close(iunq) END subroutine SUBROUTINE read_data_pw_u_prim(wu,prefix) !this subroutine reads in the inverse wannier transformation matrix USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures USE mp, ONLY : mp_bcast, mp_barrier USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(wannier_u_prim) :: wu!structure to be read and initialized CHARACTER(LEN=256) :: prefix!to designate the PW files INTEGER :: iunu INTEGER :: iw if(ionode) then iunu = find_free_unit() open( unit=iunu, file=trim(tmp_dir)//trim(prefix)//'.wannier_prim', status='old',form='unformatted') !read in basis length read(iunu) wu%nums_prim read(iunu) wu%nums_occ read(iunu) wu%nums write(*,*) 'read_data_pw_u_prim',wu%nums_prim,wu%nums_occ,wu%nums endif call mp_bcast(wu%nums_prim, ionode_id, world_comm) call mp_bcast(wu%nums_occ, ionode_id, world_comm) call mp_bcast(wu%nums, ionode_id, world_comm) !allocate arrays allocate(wu%umat(wu%nums_prim,wu%nums_prim)) if(ionode) then !read in transformation matrix do iw=1,wu%nums_prim read(iunu) wu%umat(1:wu%nums_prim,iw) enddo endif do iw=1,wu%nums_prim call mp_barrier( world_comm ) call mp_bcast(wu%umat(:,iw), ionode_id, world_comm) enddo if(ionode) close(iunu) return END SUBROUTINE read_data_pw_u_prim SUBROUTINE read_data_pw_v_pot_prim(vp,prefix, l_zero) !this subroutine reads in the coulombian potential and the overlap index USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures USE mp, ONLY : mp_bcast, mp_barrier USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(v_pot_prim) :: vp!structure to be read and initialized CHARACTER(LEN=256) :: prefix!to designate the PW files LOGICAL :: l_zero!if true opens file with head of v pu to zero INTEGER :: iunu INTEGER :: iw if(ionode) then iunu = find_free_unit() if(.not. l_zero) then open( unit=iunu, file=trim(tmp_dir)//trim(prefix)//'.uterms_prim', status='old',form='unformatted') else open( unit=iunu, file=trim(tmp_dir)//trim(prefix)//'.uterms_prim_zero', status='old',form='unformatted') endif !read in basis length read(iunu) vp%numpw_prim read(iunu) vp%numpw write(*,*) 'read_data_pw_v_pot_prim', vp%numpw_prim,vp%numpw endif call mp_bcast(vp%numpw, ionode_id, world_comm) call mp_bcast(vp%numpw_prim, ionode_id, world_comm) !allocate arrays allocate(vp%vmat(vp%numpw_prim,vp%numpw)) allocate(vp%ij(2,vp%numpw_prim)) if(ionode) then !read in transformation matrix do iw=1,vp%numpw_prim read(iunu) vp%vmat(iw,1:vp%numpw) enddo close(iunu) endif do iw=1,vp%numpw call mp_barrier( world_comm ) call mp_bcast(vp%vmat(:,iw), ionode_id, world_comm) enddo if(ionode) then iunu = find_free_unit() open( unit=iunu, file=trim(tmp_dir)//trim(prefix)//'.ij_prim', status='old',form='unformatted') do iw=1,vp%numpw_prim read(iunu) vp%ij(1,iw),vp%ij(2,iw) enddo close(iunu) endif call mp_bcast(vp%ij(:,:), ionode_id, world_comm) vp%is_parallel=.false. vp%numpw_para=vp%numpw vp%first_para=1 return END SUBROUTINE read_data_pw_v_pot_prim SUBROUTINE read_data_pw_wp_psi_cutoff_index(wpi,prefix) !this subroutine reads in and allocate the arrays for the !indices describing of products of valence^2 times two wannier products !when a cutoff is applied USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures, ONLY : wp_psi_cutoff_index, free_memory USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(wp_psi_cutoff_index) :: wpi!structure to be read and initialized CHARACTER(LEN=256) :: prefix!to designate the PW files INTEGER :: iuni INTEGER :: i if(ionode) then iuni=find_free_unit() open( unit=iuni, file=trim(tmp_dir)//trim(prefix)//'.wpwp_psi_index', status='old',form='unformatted') !read in basis length read(iuni) wpi%numpw read(iuni) wpi%nums_psi read(iuni) wpi%numpwpw endif call mp_bcast(wpi%numpw, ionode_id, world_comm) call mp_bcast(wpi%nums_psi, ionode_id, world_comm) call mp_bcast(wpi%numpwpw, ionode_id, world_comm) allocate(wpi%index(2,wpi%numpwpw)) if(ionode) then do i=1,wpi%numpwpw read(iuni) wpi%index(1,i),wpi%index(2,i) enddo close(iuni) endif call mp_bcast(wpi%index, ionode_id, world_comm) return END SUBROUTINE read_data_pw_wp_psi_cutoff_index SUBROUTINE read_data_pw_wp_psi_cutoff_data(wpi,wp,prefix) !this subroutine reads in and allocate the arrays for the !products of valence^2 times two wannier products when a cutoff is applied USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures, ONLY : wp_psi_cutoff_index, wp_psi_cutoff_data,free_memory USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(wp_psi_cutoff_index), INTENT(in) :: wpi!indices TYPE(wp_psi_cutoff_data), INTENT(inout) :: wp!data to be read CHARACTER(LEN=256), INTENT(in) :: prefix!to designate the PW files INTEGER :: iund INTEGER :: i, pos,state REAL(kind=DP) :: w wp%numpw=wpi%numpw wp%nums_psi=wpi%nums_psi wp%numpwpw=wpi%numpwpw allocate(wp%wwp(wp%numpwpw,wp%nums_psi)) if(ionode) then iund=find_free_unit() open( unit=iund, file=trim(tmp_dir)//trim(prefix)//'.wpwp_psi', status='old',form='unformatted') !read in basis length do i=1,wp%nums_psi*wp%numpwpw read(iund) pos,state,w wp%wwp(pos,state)=w enddo close(iund) endif do i=1,wp%nums_psi call mp_bcast(wp%wwp(:,i), ionode_id, world_comm) enddo return END SUBROUTINE read_data_pw_wp_psi_cutoff_data SUBROUTINE read_data_pw_exchange(ene_x,max_i,prefix,nspin) !this subroutine reads in the exchange energies USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit REAL(kind=DP) :: ene_x(max_i,nspin) INTEGER :: max_i CHARACTER(LEN=256) :: prefix!to designate the PW files INTEGER, INTENT(in) :: nspin!spin multiplicity INTEGER :: iunu INTEGER :: ndata,is REAL(kind=DP), ALLOCATABLE :: buf(:) if(ionode) then iunu = find_free_unit() open( unit=iunu, file=trim(tmp_dir)//trim(prefix)//'.exchange', status='old',form='unformatted') read(iunu) ndata allocate(buf(ndata)) do is=1,nspin read(iunu) buf(1:ndata) ene_x(1:max_i,is)=buf(1:max_i) enddo close(iunu) deallocate(buf) endif call mp_bcast(ene_x, ionode_id,world_comm) return end SUBROUTINE read_data_pw_exchange SUBROUTINE read_data_pw_exchange_off(ene_x_off,max_i,prefix,nspin) !this subroutine reads in the whole fock matrix USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit REAL(kind=DP) :: ene_x_off(max_i,max_i,nspin) INTEGER :: max_i CHARACTER(LEN=256) :: prefix!to designate the PW files INTEGER, INTENT(in) :: nspin!spin multiplicity INTEGER :: iunu INTEGER :: ndata,is,ii REAL(kind=DP), ALLOCATABLE :: buf(:) if(ionode) then iunu = find_free_unit() open( unit=iunu, file=trim(tmp_dir)//trim(prefix)//'.exchange_off', status='old',form='unformatted') read(iunu) ndata allocate(buf(ndata)) do is=1,nspin do ii=1,ndata read(iunu) buf(1:ndata) if(ii<=max_i) ene_x_off(1:max_i,ii,is)=buf(1:max_i) enddo enddo close(iunu) deallocate(buf) endif call mp_bcast(ene_x_off, ionode_id,world_comm) return end SUBROUTINE read_data_pw_exchange_off SUBROUTINE read_data_pw_head_epsilon(he, prefix, l_wing_epsilon, l_gzero) !this subroutine reads the data USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures, ONLY : head_epsilon USE mp, ONLY : mp_bcast, mp_barrier USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(head_epsilon) :: he!the head of epsilon to be read CHARACTER(LEN=256) :: prefix!to designate the PW files LOGICAL :: l_wing_epsilon!if true read from file also the wing data LOGICAL :: l_gzero!if true reads also gzero otherwise is initialized to 0 INTEGER :: iun,i, idumm,ipol REAL(kind=DP) :: rdumm if(ionode) then iun = find_free_unit() open( unit=iun, file=trim(tmp_dir)//'/_ph0/'//trim(prefix)//'.head', status='old',form='unformatted') read(iun) he%n read(iun) he%omega endif call mp_bcast(he%n, ionode_id,world_comm) call mp_bcast(he%omega, ionode_id,world_comm) allocate(he%freqs(he%n+1)) allocate(he%head(he%n+1,3)) if(ionode) then read(iun) he%freqs(1:he%n+1) do ipol=1,3 read(iun) he%head(1:he%n+1,ipol) enddo close(iun) endif call mp_bcast(he%freqs, ionode_id,world_comm) call mp_bcast(he%head, ionode_id,world_comm) if(ionode) then iun = find_free_unit() open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'.wing', status='old',form='unformatted') read(iun) idumm read(iun) rdumm if(idumm /= he%n) then write(stdout,*) 'WING: PROBLEM WITH N' endif if(rdumm /= he%omega) then write(stdout,*) 'WING: PROBLEM WITH OMEGA' endif read(iun) he%numpw endif call mp_bcast(he%numpw, ionode_id,world_comm) allocate(he%wing(he%numpw, he%n+1,3)) allocate(he%wing_c(he%numpw, he%n+1,3)) ! if(idumm /= he%numpw) then ! write(stdout,*) 'WING: PROBLEM WITH NUMPW', idumm, he%numpw ! endif if(ionode) then do ipol=1,3 do i=1,he%n+1 read(iun) he%wing(1:he%numpw,i,ipol) enddo enddo ! do i=1,he%n+1 ! read(iun) he%wing_c(1:he%numpw,i,ipol) ! enddo close(iun) endif ! do i=1,he%n+1 ! call mp_barrier ! ! call mp_bcast(he%wing(:,i), ionode_id,world_comm) ! call mp_bcast(he%wing_c(:,i), ionode_id,world_comm) ! enddo call mp_bcast(he%wing, ionode_id,world_comm) if(l_gzero) then if(ionode) then iun = find_free_unit() open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'.gzero', status='old',form='unformatted') read(iun) idumm if(idumm /= he%numpw) then write(stdout,*) 'WING: PROBLEM WITH NUMPW', idumm, he%numpw endif endif allocate(he%gzero(he%numpw)) if(ionode) then do i=1,he%numpw read(iun) he%gzero(i) enddo close(iun) endif call mp_bcast(he%gzero,ionode_id,world_comm) else allocate(he%gzero(he%numpw)) he%gzero(1:he%numpw)=0.d0 endif return END SUBROUTINE read_data_pw_head_epsilon SUBROUTINE read_data_pw_cprim_prod(cpp, prefix, l_vc, ok_read, l_vcw_overlap, l_upper) !this subroutine read the products cprim c v\tilde{w^P} from disk USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures, ONLY : cprim_prod,free_memory USE mp, ONLY : mp_bcast, mp_barrier USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(cprim_prod) :: cpp!the structure to be read CHARACTER(LEN=256) :: prefix!to designate the PW files LOGICAL :: l_vc !if true reads in the vc terms LOGICAL, INTENT(out) :: ok_read!if true effectively read otherwise the file doesn't exist LOGICAL, INTENT(in) :: l_vcw_overlap!if true read the overlaps v c w LOGICAL, INTENT(in) :: l_upper!if true reads data for reduced upper states CHARACTER(4) :: nfile INTEGER :: iunsterms, icp, i call free_memory(cpp) if(.not.l_vcw_overlap) then if(ionode) then write(nfile,'(4i1)') & & cpp%cprim/1000,mod(cpp%cprim,1000)/100,mod(cpp%cprim,100)/10,mod(cpp%cprim,10) if(.not.l_upper) then if(.not. l_vc) then inquire(file=trim(tmp_dir)//trim(prefix)//'.cprim.'//nfile,exist=ok_read) else inquire(file=trim(tmp_dir)//trim(prefix)//'.vcprim.'//nfile,exist=ok_read) endif else if(.not. l_vc) then inquire(file=trim(tmp_dir)//trim(prefix)//'.cprim_up.'//nfile,exist=ok_read) else inquire(file=trim(tmp_dir)//trim(prefix)//'.vcprim_up.'//nfile,exist=ok_read) endif endif endif call mp_bcast(ok_read, ionode_id,world_comm) if(.not. ok_read) return endif if(ionode) then iunsterms = find_free_unit() write(nfile,'(4i1)') & & cpp%cprim/1000,mod(cpp%cprim,1000)/100,mod(cpp%cprim,100)/10,mod(cpp%cprim,10) if(.not.l_upper) then if(l_vcw_overlap) then open( unit= iunsterms, file=trim(tmp_dir)//trim(prefix)//'.vcw_overlap.'//nfile, status='old',form='unformatted') else if(.not. l_vc) then open( unit= iunsterms, file=trim(tmp_dir)//trim(prefix)//'.cprim.'//nfile, status='old',form='unformatted') else open( unit= iunsterms, file=trim(tmp_dir)//trim(prefix)//'.vcprim.'//nfile, status='old',form='unformatted') endif endif else if(l_vcw_overlap) then open( unit= iunsterms, file=trim(tmp_dir)//trim(prefix)//'.vcw_up_overlap.'//nfile, status='old',form='unformatted') else if(.not. l_vc) then open( unit= iunsterms, file=trim(tmp_dir)//trim(prefix)//'.cprim_up.'//nfile, status='old',form='unformatted') else open( unit= iunsterms, file=trim(tmp_dir)//trim(prefix)//'.vcprim_up.'//nfile, status='old',form='unformatted') endif endif endif read(iunsterms) icp if(icp /= cpp%cprim) then write(stdout,*) 'PROBLEM WITH CPRIM_PROD' stop endif read(iunsterms) cpp%nums_occ read(iunsterms) cpp%nums!DIFFERENT MEANING FOR UPPER STATES read(iunsterms) cpp%numpw endif call mp_bcast(cpp%nums_occ, ionode_id,world_comm) call mp_bcast(cpp%nums, ionode_id,world_comm) call mp_bcast(cpp%numpw, ionode_id,world_comm) cpp%nums_cond=cpp%nums-cpp%nums_occ if(.not.l_vc .or. l_vcw_overlap .and. .not.l_upper) then allocate(cpp%cpmat(cpp%numpw,cpp%nums_cond)) else allocate(cpp%cpmat(cpp%numpw,cpp%nums)) endif cpp%lda=cpp%numpw if(.not. l_vc .or. l_vcw_overlap .and. .not.l_upper) then do i=1,cpp%nums_cond call mp_barrier( world_comm ) if(ionode) read(iunsterms) cpp%cpmat(1:cpp%numpw,i) call mp_bcast(cpp%cpmat(:,i), ionode_id,world_comm) enddo else do i=1,cpp%nums call mp_barrier( world_comm ) if(ionode) read(iunsterms) cpp%cpmat(1:cpp%numpw,i) call mp_bcast(cpp%cpmat(:,i), ionode_id,world_comm) enddo endif if(ionode) close(iunsterms) cpp%is_parallel=.false. cpp%numpw_para=cpp%numpw cpp%first_para=1 return END SUBROUTINE read_data_pw_cprim_prod SUBROUTINE read_data_pw_dft_xc(ene_dft_xc,max_i,prefix) !this subroutine reads in the exchange energies USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit REAL(kind=DP) :: ene_dft_xc(max_i) INTEGER :: max_i CHARACTER(LEN=256) :: prefix!to designate the PW files INTEGER :: iunu, i,nn if(ionode) then iunu = find_free_unit() open( unit=iunu, file=trim(tmp_dir)//trim(prefix)//'.dft_xc', status='old',form='unformatted') read(iunu) nn do i=1,max_i read(iunu) ene_dft_xc(i) enddo endif call mp_bcast(ene_dft_xc(1:max_i), ionode_id, world_comm) return end SUBROUTINE read_data_pw_dft_xc SUBROUTINE read_data_pw_dft_xc_off(ene_dft_xc_off,max_i,prefix,ispin) !this subroutine reads in the exchange energies USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit REAL(kind=DP) :: ene_dft_xc_off(max_i,max_i) INTEGER :: max_i CHARACTER(LEN=256) :: prefix!to designate the PW files INTEGER, INTENT(in) :: ispin! spin channel INTEGER :: iunu, ibnd,nn if(ionode) then iunu = find_free_unit() if(ispin==1) then open(unit=iunu,file=trim(tmp_dir)//trim(prefix)//'.exc_off',status='old',form='unformatted') else open(unit=iunu,file=trim(tmp_dir)//trim(prefix)//'.exc_off2',status='old',form='unformatted') endif read(iunu) nn do ibnd=1,nn if(ibnd<=max_i) read(iunu) ene_dft_xc_off(1:max_i,ibnd) enddo close(iunu) endif call mp_bcast(ene_dft_xc_off, ionode_id, world_comm) return end SUBROUTINE read_data_pw_dft_xc_off SUBROUTINE read_data_pw_upper_states(us,prefix) !this subroutine reads in the upper REDUCED states USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(upper_states) :: us!structure to be read and initialized CHARACTER(LEN=256) :: prefix!to designate the PW files INTEGER :: iunu INTEGER :: ii if(ionode) then iunu = find_free_unit() open( unit=iunu, file=trim(tmp_dir)//trim(prefix)//'.upper', status='old',form='unformatted') read(iunu) us%nums_tot read(iunu) us%nums read(iunu) us%nums_occ read(iunu) us%nums_reduced endif call mp_bcast(us%nums_tot, ionode_id, world_comm) call mp_bcast(us%nums, ionode_id, world_comm) call mp_bcast(us%nums_occ, ionode_id, world_comm) call mp_bcast(us%nums_reduced, ionode_id, world_comm) allocate(us%ene(us%nums_reduced)) if(ionode) then do ii=1,us%nums_reduced read(iunu) us%ene(ii) enddo close(iunu) endif call mp_bcast(us%ene(:),ionode_id, world_comm) return END SUBROUTINE read_data_pw_upper_states SUBROUTINE read_data_pw_vt_mat_lanczos(vtl, ii, prefix, l_pola, ispin) !this subroutine reads the terms V^v_{v,l}= from disk USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures, ONLY : vt_mat_lanczos,free_memory,initialize_memory USE mp, ONLY : mp_bcast, mp_barrier, mp_sum USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(vt_mat_lanczos) :: vtl!the structure to be read CHARACTER(LEN=256) :: prefix!to designate the PW files LOGICAL :: l_pola !if true reads the terms for the polarization, otherwise for the self-energy INTEGER :: ii!state to be read INTEGER, INTENT(in) :: ispin!spin channel CHARACTER(4) :: nfile INTEGER :: iuntmat, il INTEGER, PARAMETER :: offset=0!ATTENZIONE RESTART it should be 0 normalwise call initialize_memory(vtl) call free_memory(vtl) vtl%ii=ii write(nfile,'(4i1)') & & vtl%ii/1000,mod(vtl%ii,1000)/100,mod(vtl%ii,100)/10,mod(vtl%ii,10) if(ionode) then iuntmat=find_free_unit() if(ispin==1) then if(l_pola) then open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.p_mat_lanczos'//nfile, status='old',form='unformatted') else open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.s_mat_lanczos'//nfile, status='old',form='unformatted') endif else if(l_pola) then open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.p_mat_lanczos2'//nfile, status='old',form='unformatted') else open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.s_mat_lanczos2'//nfile, status='old',form='unformatted') endif endif read(iuntmat) vtl%ii read(iuntmat) vtl%nums_occ read(iuntmat) vtl%numpw read(iuntmat) vtl%numl vtl%numl=vtl%numl-offset endif call mp_bcast(vtl%nums_occ,ionode_id, world_comm) call mp_bcast(vtl%numpw,ionode_id, world_comm) call mp_bcast(vtl%numl,ionode_id, world_comm) allocate(vtl%vt_mat(vtl%numpw,vtl%numl)) if(ionode) then do il=1,offset read(iuntmat) vtl%vt_mat(1:vtl%numpw,1) enddo endif do il=offset+1,vtl%numl+offset !call mp_barrier( world_comm ) if(ionode) then read(iuntmat) vtl%vt_mat(1:vtl%numpw,il-offset) else vtl%vt_mat(1:vtl%numpw,il-offset)=0.d0 endif !call mp_bcast(vtl%vt_mat(:,il),ionode_id, world_comm) !call mp_sum(vtl%vt_mat(1:vtl%numpw,il)) enddo call mp_bcast(vtl%vt_mat,ionode_id, world_comm) if(ionode) close(iuntmat) return END SUBROUTINE read_data_pw_vt_mat_lanczos SUBROUTINE read_data_pw_mat_lanczos_full(fl, ii, prefix) !this subroutine read the full relativistic overlaps USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures, ONLY : mat_lanczos_full,free_memory,initialize_memory USE mp, ONLY : mp_bcast, mp_barrier, mp_sum USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(mat_lanczos_full) :: fl!the structure to be read CHARACTER(LEN=256) :: prefix!to designate the PW files INTEGER :: ii!state to be read CHARACTER(4) :: nfile INTEGER :: iun, iw,idumm fl%ii=ii write(nfile,'(4i1)') & &fl%ii/1000,mod(fl%ii,1000)/100,mod(fl%ii,100)/10,mod(fl%ii,10) call initialize_memory(fl) if(ionode) then iun=find_free_unit() open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.s_mat_lanczos_full'//nfile, status='old',form='unformatted') read(iun) idumm read(iun) fl%numpw read(iun) fl%nums endif call mp_bcast(fl%numpw, ionode_id, world_comm) call mp_bcast(fl%nums, ionode_id, world_comm) allocate(fl%f_mat(fl%numpw,fl%nums,2)) if(ionode) then do iw=1,fl%nums read(iun) fl%f_mat(1:fl%numpw,iw,1) enddo do iw=1,fl%nums read(iun) fl%f_mat(1:fl%numpw,iw,2) enddo close(iun) endif call mp_bcast(fl%f_mat, ionode_id, world_comm) return END SUBROUTINE read_data_pw_mat_lanczos_full SUBROUTINE read_data_pw_tt_mat_lanczos(ttl, ii, prefix, l_pola,ispin) !this subroutine reads the termsT^v_{i,j}= from disk USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures, ONLY : tt_mat_lanczos,free_memory,initialize_memory USE mp, ONLY : mp_bcast, mp_barrier, mp_sum USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(tt_mat_lanczos) :: ttl!the structure to be read CHARACTER(LEN=256) :: prefix!to designate the PW files LOGICAL :: l_pola !if true reads the terms for the polarization, otherwise for the self-energy INTEGER :: ii!state to be read INTEGER, INTENT(in) :: ispin!spin channel CHARACTER(4) :: nfile INTEGER :: iuntmat, il call initialize_memory(ttl) call free_memory(ttl) ttl%ii=ii write(nfile,'(4i1)') & & ttl%ii/1000,mod(ttl%ii,1000)/100,mod(ttl%ii,100)/10,mod(ttl%ii,10) if(ionode) then iuntmat=find_free_unit() if(ispin==1) then if(l_pola) then open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.pt_mat_lanczos'//nfile, status='old',form='unformatted') else open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.st_mat_lanczos'//nfile, status='old',form='unformatted') endif else if(l_pola) then open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.pt_mat_lanczos2'//nfile, status='old',form='unformatted') else open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.st_mat_lanczos2'//nfile, status='old',form='unformatted') endif endif read(iuntmat) ttl%numt read(iuntmat) ttl%numl read(iuntmat) ttl%ii endif call mp_bcast(ttl%numt,ionode_id, world_comm) call mp_bcast(ttl%numl,ionode_id, world_comm) allocate(ttl%tt_mat(ttl%numt,ttl%numl)) do il=1,ttl%numl !call mp_barrier if(ionode) then read(iuntmat) ttl%tt_mat(1:ttl%numt,il) else ttl%tt_mat(1:ttl%numt,il)=0.d0 endif !call mp_bcast(ttl%tt_mat(:,il),ionode_id, world_comm) !call mp_sum( ttl%tt_mat(1:ttl%numt,il)) enddo call mp_bcast(ttl%tt_mat,ionode_id, world_comm) if(ionode) close(iuntmat) return END SUBROUTINE read_data_pw_tt_mat_lanczos SUBROUTINE read_data_pw_lanczos_chain(lc, ii, prefix, l_pola,ispin) !this subroutine reads the lanczos chain descriptor from disk !the date are distributed over the processors USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures, ONLY : lanczos_chain,free_memory,initialize_memory USE mp, ONLY : mp_bcast, mp_barrier, mp_sum USE mp_world, ONLY : nproc,mpime, world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(lanczos_chain) :: lc!the structure to be read CHARACTER(LEN=256) :: prefix!to designate the PW files LOGICAL :: l_pola !if true reads the terms for the polarization, otherwise for the self-energy INTEGER :: ii!state to be read , only for self-energy INTEGER, INTENT(in) :: ispin!spin multiplicity CHARACTER(4) :: nfile INTEGER :: iunlc, is,it INTEGER :: l_blk,nbegin,nend REAL(kind=DP), ALLOCATABLE :: tmp_mat(:) call initialize_memory(lc) call free_memory(lc) lc%ii=ii write(nfile,'(4i1)') & & lc%ii/1000,mod(lc%ii,1000)/100,mod(lc%ii,100)/10,mod(lc%ii,10) if(ionode) then iunlc=find_free_unit() if(ispin==1) then if(l_pola) then open( unit= iunlc, file=trim(tmp_dir)//trim(prefix)//'.p_iter_lanczos', status='old',form='unformatted') else open( unit= iunlc, file=trim(tmp_dir)//trim(prefix)//'.s_iter_lanczos'//'_'//nfile, status='old',form='unformatted') endif else if(l_pola) then open( unit= iunlc, file=trim(tmp_dir)//trim(prefix)//'.p_iter_lanczos2', status='old',form='unformatted') else open( unit= iunlc, file=trim(tmp_dir)//trim(prefix)//'.s_iter_lanczos2'//'_'//nfile, status='old',form='unformatted') endif endif read(iunlc) lc%numt read(iunlc) lc%ii read(iunlc) lc%num_steps endif write(*,*) lc%numt, lc%ii,lc%num_steps call mp_bcast(lc%numt,ionode_id, world_comm) call mp_bcast(lc%num_steps,ionode_id, world_comm) l_blk= (lc%numt)/nproc if(l_blk*nproc < (lc%numt)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 allocate(tmp_mat(lc%numt)) allocate(lc%o_mat(lc%numt,lc%num_steps,l_blk)) allocate(lc%d(lc%num_steps,lc%numt)) allocate(lc%f(lc%num_steps,lc%numt)) do is=1,lc%num_steps do it=1,lc%numt tmp_mat(1:lc%numt)=0.d0 if(ionode) read(iunlc) tmp_mat(1:lc%numt) call mp_sum(tmp_mat(:),world_comm)!this should be faster than mp_bcat if(it >= nbegin .and. it <= nend) then lc%o_mat(1:lc%numt,is,it-nbegin+1)= tmp_mat(1:lc%numt) endif ! if(ionode) read(iunlc) lc%o_mat(1:lc%numt,is,it) ! call mp_barrier ! call mp_bcast(lc%o_mat(1:lc%numt,is,it),ionode_id, world_comm) enddo enddo do it=1,lc%numt if(ionode) read(iunlc) lc%d(1:lc%num_steps,it) call mp_barrier( world_comm ) call mp_bcast(lc%d(1:lc%num_steps,it),ionode_id, world_comm) enddo do it=1,lc%numt if(ionode) read(iunlc) lc%f(1:lc%num_steps,it) call mp_barrier( world_comm ) call mp_bcast(lc%f(1:lc%num_steps,it),ionode_id, world_comm) enddo if(ionode) close(iunlc) deallocate(tmp_mat) return END SUBROUTINE read_data_pw_lanczos_chain SUBROUTINE read_data_pw_vt_mat_lanczos_single(vtl, ii, prefix, l_pola) !this subroutine reads the terms V^v_{v,l}= from disk !single processor version USE kinds, ONLY : DP USE basic_structures, ONLY : vt_mat_lanczos,free_memory,initialize_memory USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(vt_mat_lanczos) :: vtl!the structure to be read CHARACTER(LEN=256) :: prefix!to designate the PW files LOGICAL :: l_pola !if true reads the terms for the polarization, otherwise for the self-energy INTEGER :: ii!state to be read CHARACTER(4) :: nfile INTEGER :: iuntmat, il INTEGER, PARAMETER :: offset=0!ATTENZIONE RESTART it should be 0 normalwise call initialize_memory(vtl) call free_memory(vtl) vtl%ii=ii write(nfile,'(4i1)') & & vtl%ii/1000,mod(vtl%ii,1000)/100,mod(vtl%ii,100)/10,mod(vtl%ii,10) iuntmat=find_free_unit() if(l_pola) then open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.p_mat_lanczos'//nfile, status='old',form='unformatted') else open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.s_mat_lanczos'//nfile, status='old',form='unformatted') endif read(iuntmat) vtl%ii read(iuntmat) vtl%nums_occ read(iuntmat) vtl%numpw read(iuntmat) vtl%numl vtl%numl=vtl%numl-offset allocate(vtl%vt_mat(vtl%numpw,vtl%numl)) do il=1,offset read(iuntmat) vtl%vt_mat(1:vtl%numpw,1) enddo do il=1+offset,vtl%numl+offset read(iuntmat) vtl%vt_mat(1:vtl%numpw,il-offset) enddo close(iuntmat) return END SUBROUTINE read_data_pw_vt_mat_lanczos_single SUBROUTINE read_data_pw_tt_mat_lanczos_single(ttl, ii, prefix, l_pola) !this subroutine reads the termsT^v_{i,j}= from disk !single processor version USE kinds, ONLY : DP USE basic_structures, ONLY : tt_mat_lanczos,free_memory,initialize_memory USE mp, ONLY : mp_bcast, mp_barrier USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(tt_mat_lanczos) :: ttl!the structure to be read CHARACTER(LEN=256) :: prefix!to designate the PW files LOGICAL :: l_pola !if true reads the terms for the polarization, otherwise for the self-energy INTEGER :: ii!state to be read CHARACTER(4) :: nfile INTEGER :: iuntmat, il call initialize_memory(ttl) call free_memory(ttl) ttl%ii=ii write(nfile,'(4i1)') & & ttl%ii/1000,mod(ttl%ii,1000)/100,mod(ttl%ii,100)/10,mod(ttl%ii,10) iuntmat=find_free_unit() if(l_pola) then open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.pt_mat_lanczos'//nfile, status='old',form='unformatted') else open( unit= iuntmat, file=trim(tmp_dir)//trim(prefix)//'.st_mat_lanczos'//nfile, status='old',form='unformatted') endif read(iuntmat) ttl%numt read(iuntmat) ttl%numl read(iuntmat) ttl%ii allocate(ttl%tt_mat(ttl%numt,ttl%numl)) do il=1,ttl%numl read(iuntmat) ttl%tt_mat(1:ttl%numt,il) enddo close(iuntmat) return END SUBROUTINE read_data_pw_tt_mat_lanczos_single SUBROUTINE read_data_pw_full_prods(fp,prefix) !this subroutine read the full relativistic overlaps USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE basic_structures, ONLY : full_prods,free_memory,initialize_memory USE mp, ONLY : mp_bcast, mp_barrier, mp_sum USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(full_prods) :: fp!the structure to be read CHARACTER(LEN=256) :: prefix!to designate the PW files INTEGER :: iun, is,ii,ipol iun=find_free_unit() if(ionode) then open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.prod_full', status='old',form='unformatted') read(iun) fp%nums read(iun) fp%nbnd read(iun) fp%numpw read(iun) fp%numv endif call mp_bcast(fp%nums,ionode_id, world_comm) call mp_bcast(fp%nbnd, ionode_id, world_comm) call mp_bcast(fp%numpw, ionode_id, world_comm) call mp_bcast(fp%numv, ionode_id, world_comm) allocate(fp%ene_ks(fp%nbnd)) allocate(fp%gmat(fp%numpw,2,fp%nbnd,fp%nums)) if(ionode) then read(iun) fp%ene_ks(1:fp%nbnd) do is=1,fp%nums do ii=1,fp%nbnd do ipol=1,2 read(iun) fp%gmat(1:fp%numpw,ipol,ii,is) enddo enddo enddo close(iun) endif call mp_bcast(fp%ene_ks, ionode_id, world_comm) call mp_bcast(fp%gmat, ionode_id, world_comm) return END SUBROUTINE read_data_pw_full_prods SUBROUTINE read_data_pw_partial_occ(po, prefix, ispin) USE kinds, ONLY : DP USE basic_structures, ONLY : partial_occ,free_memory,initialize_memory USE mp, ONLY : mp_bcast, mp_barrier USE mp_world, ONLY : world_comm USE io_global, ONLY : ionode, ionode_id USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(partial_occ), INTENT(out) :: po!the structure to be read CHARACTER(LEN=256),INTENT(in) :: prefix!to designate the PW files INTEGER, INTENT(in) :: ispin!spin channel INTEGER :: iun, iv,jv call free_memory(po) if(ionode) then iun=find_free_unit() if(ispin==1) then open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.occ_mat', status='old',form='unformatted') else open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.occ_mat2', status='old',form='unformatted') endif read(iun) po%nums_occ_min read(iun) po%nums_occ read(iun) po%numpw endif call mp_bcast(po%nums_occ_min,ionode_id, world_comm) call mp_bcast(po%nums_occ, ionode_id, world_comm) call mp_bcast(po%numpw, ionode_id, world_comm) allocate(po%f_occ(po%nums_occ)) if(ionode) read(iun) po%f_occ(1:po%nums_occ) call mp_bcast(po%f_occ, ionode_id, world_comm) allocate(po%ppp_mat(po%numpw,po%nums_occ,po%nums_occ_min+1:po%nums_occ)) do iv=po%nums_occ_min+1,po%nums_occ do jv=1,po%nums_occ if(ionode) read(iun) po%ppp_mat(1:po%numpw,jv,iv) call mp_bcast( po%ppp_mat(1:po%numpw,jv,iv),ionode_id, world_comm) enddo enddo if(ionode) close(iun) return END SUBROUTINE read_data_pw_partial_occ SUBROUTINE read_data_pw_semicore(sc, prefix, ispin) !NOT_TO_BE_INCLUDED_START USE kinds, ONLY : DP USE basic_structures, ONLY : semicore,free_memory,initialize_memory USE mp, ONLY : mp_bcast, mp_barrier USE mp_world, ONLY : world_comm USE io_global, ONLY : ionode, ionode_id USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(semicore), INTENT(out) :: sc!the structure to be read CHARACTER(LEN=256),INTENT(in) :: prefix!to designate the PW files INTEGER, INTENT(in) :: ispin!spin channel INTEGER :: iun, iw,ii REAL(kind=DP), ALLOCATABLE :: tmp_prod(:) if(ionode) then iun=find_free_unit() if(ispin==1) then open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.sc_gvphi', status='old',form='unformatted') else open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.sc_gvphi2', status='old',form='unformatted') endif read(iun) sc%n_semicore endif call mp_bcast(sc%n_semicore, ionode_id, world_comm) allocate(sc%en_sc(sc%n_semicore)) if(ionode) then read(iun) sc%en_sc(1:sc%n_semicore) read(iun) sc%nums read(iun) sc%numpw endif call mp_bcast(sc%en_sc,ionode_id, world_comm) call mp_bcast(sc%nums, ionode_id, world_comm) call mp_bcast(sc%numpw, ionode_id, world_comm) allocate(sc%ppw_mat(sc%numpw,sc%n_semicore,sc%nums)) allocate(tmp_prod(sc%n_semicore)) if(ionode) then do iw=1,sc%numpw do ii=1,sc%nums read(iun) tmp_prod(1:sc%n_semicore) sc%ppw_mat(iw,1:sc%n_semicore,ii)= tmp_prod(1:sc%n_semicore) enddo enddo endif call mp_bcast(sc%ppw_mat, ionode_id, world_comm) deallocate(tmp_prod) if(ionode) close(iun) return !NOT_TO_BE_INCLUDED_END END SUBROUTINE read_data_pw_semicore SUBROUTINE read_data_pw_contour(ct,prefix,ispin,istate) !NOT_TO_BE_INCLUDED_START !this subroutines reads the overlaps USE kinds, ONLY : DP USE basic_structures, ONLY : contour_terms,free_memory,initialize_memory USE mp, ONLY : mp_bcast, mp_barrier USE mp_world, ONLY : world_comm USE io_global, ONLY : ionode, ionode_id USE io_files, ONLY : tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(contour_terms), INTENT(out) :: ct!the structure to be read CHARACTER(LEN=256),INTENT(in) :: prefix!to designate the PW files INTEGER, INTENT(in) :: ispin!spin channel INTEGER, INTENT(in) :: istate!!KS states relative to global s vectors for big_system option INTEGER :: iun, iw,ii CHARACTER(4) :: nfile if(ionode) then iun=find_free_unit() write(nfile,'(4i1)') istate/1000,mod(istate,1000)/100,mod(istate,100)/10,mod(istate,10) if(ispin==1) then open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.s_contour'//nfile, status='old',form='unformatted') else open( unit= iun, file=trim(tmp_dir)//trim(prefix)//'.s_contour'//nfile, status='old',form='unformatted') endif read(iun) ct%nums read(iun) ct%numt endif call mp_bcast(ct%nums, ionode_id, world_comm) call mp_bcast(ct%numt, ionode_id, world_comm) allocate(ct%cmat(ct%numt,ct%nums)) if(ionode) then do ii=1,ct%nums read(iun) ct%cmat(1:ct%numt,ii) enddo close(iun) endif call mp_bcast(ct%cmat, ionode_id, world_comm) return !NOT_TO_BE_INCLUDED_END END SUBROUTINE read_data_pw_contour GWW/gww/go_polarization.f900000644000077300007730000001103512341332532016334 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! SUBROUTINE go_polarization(tf, options, qp) !this subroutines reads in the green functions and calculates !the polarization at every imaginary time !only positive imaginary times are required!! USE kinds, ONLY : DP USE input_gw, ONLY : input_options USE basic_structures, ONLY : q_mat, wannier_u,free_memory USE green_function, ONLY : green,read_green,free_memory_green, initialize_green USE polarization, ONLY : polaw,free_memory_polaw,write_polaw,create_polarization,& &create_polarization_contraction,create_polarization_contraction_state,& &create_polarization_file,create_polarization_beta, create_polarization_upper USE io_global, ONLY : stdout, ionode USE compact_product, ONLY : contraction_pola,do_contraction_pola,free_memory_contraction_pola, & &do_contraction_pola_state USE para_gww, ONLY : is_my_pola USE mp, ONLY : mp_barrier USE mp_world, ONLY : world_comm USE energies_gww, ONLY : quasi_particles USE times_gw, ONLY : times_freqs implicit none TYPE(times_freqs) , INTENT(in) :: tf!for time grid TYPE(input_options), INTENT(in) :: options! for imaginary time range and number of samples TYPE(quasi_particles),INTENT(in) :: qp!for HF energies TYPE(green) :: gp,gm TYPE(q_mat) :: qm TYPE(polaw) :: pp TYPE(wannier_u) :: uu TYPE(contraction_pola) :: cp REAL(kind=DP) :: time,dt INTEGER :: iw !read in overlap matrix write(stdout,*) 'GO POLARIZATION' !ATTENZIONE call flush_unit(stdout) if(.not. options%lpola_file) then call read_data_pw_q(qm,options%prefix,.false.) call initialize_green(gp) call initialize_green(gm) !loop on time samples dt=options%tau/real(options%n) write(stdout,*) 'GO POLARIZATION1' !ATTENZIONE if(options%use_contractions .and. .not.options%l_pola_beta) then call read_data_pw_u(uu,options%prefix) write(stdout,*) 'Calculates contraction of polarization' if(.not.options%l_contraction_single_state) then call do_contraction_pola(qm,uu,cp) else call do_contraction_pola_state(qm, uu, options) endif endif if(options%l_pola_beta) then call read_data_pw_u(uu,options%prefix) endif do iw=0,options%n if(is_my_pola(iw)) then write(stdout,*) 'Calculate Polarization:', iw if(options%l_fft_timefreq) then time=dt*real(iw) else time=tf%times(iw) endif if(.not.options%l_pola_beta) then if(.not.options%use_contractions) then write(*,*) 'CREATE POLARIZATION AND NO CONTRACTIONS' stop call read_green(iw,gp,options%debug,.false.) call read_green(-iw,gm,options%debug,.true.) call create_polarization(time,pp,gp,gm,qm,options%debug) else if(.not.options%l_contraction_single_state) then call create_polarization_contraction(time,pp,cp,uu,options%l_hf_energies,qp%ene_hf(:,1)) else call create_polarization_contraction_state(time,pp,uu,options%l_hf_energies,qp%ene_hf(:,1),options) endif endif else call create_polarization_beta(time, pp, uu, qm) endif pp%label=iw call write_polaw(pp,options%debug) !we take advantage of the P(t)=P(-t) symmetry ! if(iw /= 0) then ! pp%time=-time ! pp%label=-iw ! call write_polaw(pp,options%debug) ! endif endif enddo call mp_barrier( world_comm ) call free_memory(qm) call free_memory_green(gp) call free_memory_green(gm) call free_memory_polaw(pp) call free_memory_contraction_pola(cp) else call read_data_pw_u(uu,options%prefix) call create_polarization_file(uu, tf, options%prefix) endif if(options%l_pola_upper) then call create_polarization_upper(uu, tf, options%prefix) endif call free_memory(uu) return END SUBROUTINE GWW/gww/fft_gw.f900000644000077300007730000007421712341332532014423 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! MODULE fft_gw !this modules contains the structures and subroutine !which permits ffts: the structures polaw are read from !disk in a series of rows a then ffts are performed !SEE INTERNAL NOTES USE kinds, only : DP TYPE fft_data !this structures described a series of row from polaw !at all times/frequencies in imaginary time !to construct from polaw the convention for the labels is: !label=i , i=-n,+n INTEGER :: label!label to read/write from/to disk LOGICAL :: ontime!if .true. data are on imaginary time INTEGER :: numpw!number of coloumns same as in polaw INTEGER :: numrows!number of rows INTEGER :: firstrow!first row included INTEGER :: lastrow!last row included REAL(kind=DP) :: period!max time tau data are from O to tau INTEGER :: n !number of campions on time/frequency T COMPLEX(kind=DP), DIMENSION(:,:,:), POINTER :: fd!data in format (numpw,numrows,2*n+1) COMPLEX :: factor!used for real matrices !we take advantage of the symmetry t ==> -t ! the format will be for GL grid (numpw,numrows,n+1) END TYPE fft_data CONTAINS SUBROUTINE free_memory_fft_data(fftd) !this subroutine deallocates the fft descriptor implicit none TYPE(fft_data) :: fftd if(associated(fftd%fd)) deallocate(fftd%fd) nullify(fftd%fd) return END SUBROUTINE SUBROUTINE read_fft_data(label,fftd,debug) !this subroutine reads the fft descriptor from file !we take care of the t ==> -t symmetry USE io_files, ONLY : prefix, tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(fft_data) :: fftd INTEGER :: label !label for the corresponding file LOGICAL :: debug !if true formatted files INTEGER :: iunf, iw,it, jw CHARACTER(5) :: nfile CALL free_memory_fft_data(fftd) !open file if(label >= 0 ) then write(nfile,'(5i1)') & & label/10000,mod(label,10000)/1000,mod(label,1000)/100,mod(label,100)/10,mod(label,10) iunf = find_free_unit() if(.not.debug) then open( unit=iunf, file=trim(tmp_dir)//trim(prefix)//'-'//'fftdata.'// nfile, status='old',form='unformatted') else open( unit=iunf, file=trim(tmp_dir)//trim(prefix)//'-'//'fftdata.'// nfile, status='old',form='formatted') endif else write(nfile,'(5i1)') & & -label/10000,mod(-label,10000)/1000,mod(-label,1000)/100,mod(-label,100)/10,mod(-label,10) iunf = find_free_unit() if(.not.debug) then open( unit=iunf, file=trim(tmp_dir)//trim(prefix)//'-'//'fftdata.-'// nfile, status='old',form='unformatted') else open( unit=iunf, file=trim(tmp_dir)//trim(prefix)//'-'//'fftdata.-'// nfile, status='old',form='formatted') endif endif if(.not.debug) then read(iunf) fftd%label read(iunf) fftd%ontime read(iunf) fftd%numpw read(iunf) fftd%numrows read(iunf) fftd%firstrow read(iunf) fftd%lastrow read(iunf) fftd%period read(iunf) fftd%n else read(iunf,*) fftd%label read(iunf,*) fftd%ontime read(iunf,*) fftd%numpw read(iunf,*) fftd%numrows read(iunf,*) fftd%firstrow read(iunf,*) fftd%lastrow read(iunf,*) fftd%period read(iunf,*) fftd%n endif ! allocate(fftd%fd(fftd%numpw,fftd%numrows,2*fftd%n+2)) allocate(fftd%fd(fftd%numpw,fftd%numrows,fftd%n+1)) if(.not.debug) then ! do it=1,2*fftd%n+2 do it=1,fftd%n+1 do iw=1,fftd%numrows read(iunf) fftd%fd(1:fftd%numpw,iw,it) enddo enddo else ! do it=1,2*fftd%n+2 do it=1,fftd%n+1 do iw=1,fftd%numrows do jw=1,fftd%numpw read(iunf,*) fftd%fd(jw,iw,it) enddo enddo enddo endif close(iunf) return END SUBROUTINE SUBROUTINE write_fft_data(fftd,debug) !this subroutine writes the fft descriptor on file !we take care of the t ==> -t symmetry USE io_files, ONLY : prefix, tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(fft_data) :: fftd LOGICAL :: debug!if true formatted output INTEGER :: iunf, iw,it,jw CHARACTER(5) :: nfile !open file if(fftd%label >= 0 ) then write(nfile,'(5i1)') & & fftd%label/10000,mod(fftd%label,10000)/1000,mod(fftd%label,1000)/100,mod(fftd%label,100)/10,mod(fftd%label,10) iunf = find_free_unit() if(.not.debug) then open( unit=iunf, file=trim(tmp_dir)//trim(prefix)//'-'//'fftdata.'// nfile, status='unknown',form='unformatted') else open( unit=iunf, file=trim(tmp_dir)//trim(prefix)//'-'//'fftdata.'// nfile, status='unknown',form='formatted') endif else write(nfile,'(5i1)') & & -fftd%label/10000,mod(-fftd%label,10000)/1000,mod(-fftd%label,1000)/100,mod(-fftd%label,100)/10,mod(-fftd%label,10) iunf = find_free_unit() if(.not.debug) then open( unit=iunf, file=trim(tmp_dir)//trim(prefix)//'-'//'fftdata.-'// nfile, status='unknown',form='unformatted') else open( unit=iunf, file=trim(tmp_dir)//trim(prefix)//'-'//'fftdata.-'// nfile, status='unknown',form='formatted') endif endif if(.not.debug) then write(iunf) fftd%label write(iunf) fftd%ontime write(iunf) fftd%numpw write(iunf) fftd%numrows write(iunf) fftd%firstrow write(iunf) fftd%lastrow write(iunf) fftd%period write(iunf) fftd%n ! do it=1,2*fftd%n+2 do it=1,fftd%n+1 do iw=1,fftd%numrows write(iunf) fftd%fd(1:fftd%numpw,iw,it) enddo enddo else write(iunf,*) fftd%label write(iunf,*) fftd%ontime write(iunf,*) fftd%numpw write(iunf,*) fftd%numrows write(iunf,*) fftd%firstrow write(iunf,*) fftd%lastrow write(iunf,*) fftd%period write(iunf,*) fftd%n ! do it=1,2*fftd%n+2 do it=1,fftd%n+1 do iw=1,fftd%numrows do jw=1,fftd%numpw write(iunf,*) fftd%fd(jw,iw,it) enddo enddo enddo endif close(iunf) return END SUBROUTINE SUBROUTINE create_fft_data(tf,firstr,lastr,period,n,label,fftd,debug) ! this subroutine creates the descriptor for the fftw reading !data from polaw on disk !data is put on appropiate order for FFT !total period=2*T+T/n USE polarization, ONLY : polaw,read_polaw, free_memory_polaw,& & read_polaw_range USE io_global, ONLY : stdout USE constants, ONLY : eps8, pi USE times_gw, ONLY : times_freqs implicit none TYPE(times_freqs), INTENT(in) :: tf!for time frequency grids INTEGER :: firstr !first row to be read (included) INTEGER :: lastr !last row to be read (included) REAL(kind=DP) :: period!period tau (data from -T to T) INTEGER :: n ! number of steps on T TYPE(fft_data) :: fftd!structure to be initialized LOGICAL :: debug!if true formatted files TYPE(polaw) :: pw INTEGER :: label, il, iw, ipos REAL(kind=DP) :: tfcheck, totalperiod LOGICAL, PARAMETER :: direct_access = .true. !first dealloacate and set write(stdout,*) 'VALUE TF', tf%l_fft_timefreq!ATTENZIONE totalperiod=2.d0*period+2.d0*period/real(n) CALL free_memory_fft_data(fftd) fftd%label=label fftd%period=period fftd%firstrow=firstr fftd%lastrow=lastr fftd%numrows=abs(lastr-firstr)+1 fftd%n=n !read the -n polaw if(.not.direct_access) then ! CALL read_polaw(-n,pw,debug) CALL read_polaw(n,pw,debug,.false.) else ! CALL read_polaw_range(-n,pw,debug,firstr,firstr+fftd%numrows-1, .true.) CALL read_polaw_range(n,pw,debug,firstr,firstr+fftd%numrows-1, .true. ) endif fftd%ontime=pw%ontime fftd%numpw=pw%numpw !we take care of the t ==> -t symmetry ! allocate(fftd%fd(fftd%numpw,fftd%numrows,2*fftd%n+2)) allocate(fftd%fd(fftd%numpw,fftd%numrows,fftd%n+1)) fftd%fd(:,:,:)=(0.d0,0.d0) !test time frequency !does not stop any more to permit prallel execution if(tf%l_fft_timefreq) then if(fftd%ontime) then!check imaginary time tfcheck=-period if(abs(pw%time-tfcheck) >= eps8) then write(stdout,*) 'routine create_fft_data: times do not correspond ',n !stop endif else !check imaginary frequency tfcheck=(2.d0*pi/totalperiod)*real(-n) if(abs(pw%time-tfcheck) >= eps8) then write(stdout,*) 'routine create_fft_data: frequencies do not correspond ',n !stop endif endif endif !put in data at the right position !the position at 1 is zero for definition !we take advantage of the t ==> -t symmetry ! do iw=1,fftd%numrows ! fftd%fd(1:fftd%numpw,iw,2) = pw%pw(1:fftd%numpw,firstr+iw-1) ! enddo !read in the other times/frequencies !we take advantage of the t ==> -t symmetry ! do il=-n+1,n!loop on time/frequency do il=0,n CALL read_polaw(il,pw,debug,.false.) !consistency test !in case of parallel the check on ontime must not be done ! if(pw%ontime .NEQV. fftd%ontime .OR. pw%numpw /= fftd%numpw ) then if( pw%numpw /= fftd%numpw ) then write(stdout,*) 'routine create_fft_data: consistency failed' write(stdout,*) 'il', il write(stdout,*) 'ontime',pw%ontime,fftd%ontime, pw%numpw stop endif !test time frequency if(tf%l_fft_timefreq) then if(fftd%ontime) then!check imaginary time tfcheck=period/real(n)*real(il) if(abs(pw%time-tfcheck) >= eps8) then write(stdout,*) 'routine create_fft_data: times do not correspond ',n !stop endif else !check imaginary frequency tfcheck=(2.d0*pi/totalperiod)*real(il) if(abs(pw%time-tfcheck) >= eps8) then write(stdout,*) 'routine create_fft_data: frequencies do not correspond ',n !stop endif endif endif !put in data at the right position !we take care of the t ==> -t symmetry ! ipos=il+n+2 ipos=il+1 do iw=1,fftd%numrows fftd%fd(1:fftd%numpw,iw,ipos) = pw%pw(1:fftd%numpw,firstr+iw-1) enddo enddo CALL free_memory_polaw(pw) END SUBROUTINE SUBROUTINE create_fft_data2( tf, firstr, lastr, period, n, fftd, debug ) ! this subroutine creates the descriptor for the fftw reading !data from polaw on disk !data is put on appropiate order for FFT !total period=2*T+T/n USE polarization, ONLY : polaw,read_polaw, free_memory_polaw,& & read_polaw_range USE io_global, ONLY : stdout USE constants, ONLY : eps8, pi USE times_gw, ONLY : times_freqs USE mp_world, ONLY : nproc, mpime,world_comm! group USE parallel_include implicit none TYPE(times_freqs), INTENT(in) :: tf!for time frequency grids INTEGER :: firstr !first row to be read (included) INTEGER :: lastr !last row to be read (included) REAL(kind=DP) :: period!period tau (data from -T to T) INTEGER :: n ! number of steps on T TYPE(fft_data) :: fftd!structure to be initialized LOGICAL :: debug!if true formatted files TYPE(polaw) :: pw INTEGER :: il, iw, ipos, numrows_read, nblk_siz, k, ierr INTEGER :: nbegin, nend, nbegin_ip, nend_ip, ip REAL(kind=DP) :: tfcheck, totalperiod COMPLEX(kind=DP), ALLOCATABLE :: rcvbuf( : ), sndbuf( : ) LOGICAL, PARAMETER :: direct_access = .true. !first dealloacate and set write(stdout,*) 'VALUE TF', tf%l_fft_timefreq!ATTENZIONE totalperiod=2.d0*period+2.d0*period/real(n) CALL free_memory_fft_data(fftd) fftd%label =0 fftd%period =period fftd%firstrow=firstr fftd%lastrow =lastr numrows_read = lastr - firstr + 1 fftd%numrows = numrows_read / nproc if( MOD( numrows_read, nproc ) /= 0 ) fftd%numrows = fftd%numrows + 1 fftd%n = n allocate( fftd%fd( fftd%numpw, fftd%numrows, fftd%n + 1 ) ) fftd%fd(:,:,:) = (0.d0,0.d0) nblk_siz = (n + 1) / nproc if( MOD( (n + 1), nproc ) /= 0 ) nblk_siz = nblk_siz + 1 nbegin = 0 + mpime * nblk_siz nend = nbegin + nblk_siz - 1 ALLOCATE( sndbuf( fftd%numpw * fftd%numrows * nproc ) ) ALLOCATE( rcvbuf( fftd%numpw * fftd%numrows * nproc ) ) do il = nbegin, nend if( il <= n ) then CALL read_polaw_range( il, pw, debug, firstr, lastr, .false. ) do iw = 1, numrows_read do k = 1, fftd%numpw sndbuf( k + fftd%numpw * ( iw - 1 ) ) = pw%pw( k, iw ) ! pw%pw( k, firstr + iw - 1 ) end do end do do iw = numrows_read + 1, fftd%numrows * nproc do k = 1, fftd%numpw sndbuf( k + fftd%numpw * ( iw - 1 ) ) = 0.0d0 end do end do else sndbuf = 0.0d0 end if #ifdef __PARA CALL MPI_ALLTOALL( sndbuf, fftd%numrows * fftd%numpw, MPI_DOUBLE_COMPLEX, & rcvbuf, fftd%numrows * fftd%numpw, MPI_DOUBLE_COMPLEX, world_comm, ierr ) #else rcvbuf(:)=sndbuf(:) #endif do ip = 0, nproc - 1 nbegin_ip = 0 + ip * nblk_siz ipos = il - nbegin + nbegin_ip if( ipos <= n ) then do iw = 1, fftd%numrows do k = 1, fftd%numpw fftd%fd( k, iw, ipos + 1 ) = rcvbuf( k + fftd%numpw * (iw-1) + fftd%numrows * fftd%numpw * ip ) end do end do end if enddo enddo DEALLOCATE( rcvbuf ) DEALLOCATE( sndbuf ) CALL free_memory_polaw( pw ) END SUBROUTINE SUBROUTINE save_fft_data(tf, fftd,debug) ! this subroutine writes the descriptor for the fftw ! on the polaw on disk !data is put on appropiate order for FFT !total period=2*T+T/n !if we are ON TIME: THE ORDER IS REVERSED USE polarization, ONLY : polaw,read_polaw,write_polaw, free_memory_polaw, & &read_polaw_range,write_polaw_range USE io_global, ONLY : stdout USE constants, ONLY : eps8, pi USE mp, ONLY : mp_barrier USE mp_world, ONLY : world_comm, mpime, nproc USE times_gw, ONLY : times_freqs implicit none TYPE(times_freqs), INTENT(in) :: tf!for time frequency grids TYPE(fft_data) :: fftd!structure to be written LOGICAL :: debug!if true formatted files TYPE(polaw) :: pw INTEGER :: label, il, iw, ipos, iil REAL(kind=DP) :: tfcheck, totalperiod LOGICAL, PARAMETER :: direct_access = .true. write(stdout,*) 'VALUE TF', tf%l_fft_timefreq!ATTENZIONE !first dealloacate and set totalperiod=2.d0*fftd%period+2.d0*fftd%period/real(fftd%n) !read in times/frequencies ! do iil=-fftd%n,fftd%n!loop on time/frequency the order is the physical one ! we take advantage of the symmetry t ==> -t do iil=0,fftd%n !the following is in order to avoid same processor working with the same polaw il=mpime+iil ! if(il>fftd%n) il=il-2*fftd%n-1 ! we take advantage of the symmetry t ==> -t if(il>fftd%n) il=il-fftd%n-1 !we take care of the symmetry t ==> -t if(.not.direct_access) then CALL read_polaw(il,pw,debug,.false.) else CALL read_polaw_range(il,pw,debug,fftd%firstrow,fftd%firstrow+fftd%numrows-1,.true.) endif !consistency test if( pw%numpw /= fftd%numpw ) then write(stdout,*) 'routine save_fft_data: consistency failed' stop endif !check if ontime does not correspond if(pw%ontime .NEQV. fftd%ontime) then!update pw%ontime = fftd%ontime if(tf%l_fft_timefreq) then if(pw%ontime) then pw%time=fftd%period/real(fftd%n)*real(il) else pw%time=(2.d0*pi/totalperiod)*real(il) endif else if(pw%ontime) then pw%time=tf%times(il) else pw%time=tf%freqs(il) endif endif endif !put in data at the right position if(tf%l_fft_timefreq) then if(.not.fftd%ontime) then !freqeuncy case if(il>=0) then ipos=il+1 else ipos=2*fftd%n+2+il+1 endif else !time case if(il>0) then ipos=2*fftd%n+2-il+1 else ipos=-il+1 endif endif else !we take care of the t ==> -t symmetry ! ipos=il+tf%n+2 ipos = il +1 endif do iw=1,fftd%numrows pw%pw(1:fftd%numpw,fftd%firstrow+iw-1) = fftd%fd(1:fftd%numpw,iw,ipos) enddo !write on disk if(.not.direct_access) then CALL write_polaw(pw,debug) else CALL write_polaw_range(pw,debug,fftd%firstrow,fftd%firstrow+fftd%numrows-1,.true.) endif call mp_barrier( world_comm ) enddo CALL free_memory_polaw(pw) END SUBROUTINE SUBROUTINE save_fft_data2(tf, fftd,debug) ! this subroutine writes the descriptor for the fftw ! on the polaw on disk !data is put on appropiate order for FFT !total period=2*T+T/n !if we are ON TIME: THE ORDER IS REVERSED USE polarization, ONLY : polaw,read_polaw,write_polaw, free_memory_polaw, & &read_polaw_range,write_polaw_range USE io_global, ONLY : stdout USE constants, ONLY : eps8, pi USE mp, ONLY : mp_barrier USE mp_world, ONLY : mpime, nproc, world_comm!group USE times_gw, ONLY : times_freqs USE parallel_include implicit none TYPE(times_freqs), INTENT(in) :: tf!for time frequency grids TYPE(fft_data) :: fftd!structure to be written LOGICAL :: debug!if true formatted files TYPE(polaw) :: pw INTEGER :: il, iw, ipos, numrows_read, nblk_siz, k, ierr INTEGER :: nbegin, nend, nbegin_ip, nend_ip, ip REAL(kind=DP) :: tfcheck, totalperiod COMPLEX(kind=DP), ALLOCATABLE :: rcvbuf( : ), sndbuf( : ) LOGICAL, PARAMETER :: direct_access = .true. write(stdout,*) 'VALUE TF', tf%l_fft_timefreq!ATTENZIONE !first dealloacate and set totalperiod=2.d0*fftd%period+2.d0*fftd%period/real(fftd%n) numrows_read = fftd%lastrow - fftd%firstrow + 1 nblk_siz = ( fftd%n + 1) / nproc if( MOD( ( fftd%n + 1), nproc ) /= 0 ) nblk_siz = nblk_siz + 1 nbegin = 0 + mpime * nblk_siz nend = nbegin + nblk_siz - 1 ALLOCATE( sndbuf( fftd%numpw * fftd%numrows * nproc ) ) ALLOCATE( rcvbuf( fftd%numpw * fftd%numrows * nproc ) ) ALLOCATE( pw%pw( fftd%numpw, numrows_read ) ) pw%numpw = fftd%numpw DO il = nbegin, nend pw%ontime = fftd%ontime if(tf%l_fft_timefreq) then if(pw%ontime) then pw%time=fftd%period/real(fftd%n)*real(il) else pw%time=(2.d0*pi/totalperiod)*real(il) endif else if(pw%ontime) then pw%time=tf%times(il) else pw%time=tf%freqs(il) endif endif do ip = 0, nproc - 1 nbegin_ip = 0 + ip * nblk_siz ipos = il - nbegin + nbegin_ip if( ipos <= fftd%n ) then do iw = 1, fftd%numrows do k = 1, fftd%numpw sndbuf( k + fftd%numpw * (iw-1) + fftd%numrows * fftd%numpw * ip ) = fftd%fd( k, iw, ipos + 1 ) end do end do else do iw = 1, fftd%numrows do k = 1, fftd%numpw sndbuf( k + fftd%numpw * (iw-1) + fftd%numrows * fftd%numpw * ip ) = 0.0d0 end do end do end if enddo #ifdef __PARA CALL MPI_ALLTOALL( sndbuf, fftd%numrows * fftd%numpw, MPI_DOUBLE_COMPLEX, & rcvbuf, fftd%numrows * fftd%numpw, MPI_DOUBLE_COMPLEX, world_comm, ierr ) #else rcvbuf(:)=sndbuf(:) #endif if( il <= fftd%n ) then do iw = 1, numrows_read do k = 1, fftd%numpw pw%pw( k, iw ) = dble(rcvbuf( k + fftd%numpw * ( iw - 1 ) ) ) end do end do pw%label = il pw%factor=fftd%factor CALL write_polaw_range( pw, debug, fftd%firstrow, fftd%lastrow, .false. ) end if enddo DEALLOCATE( rcvbuf ) DEALLOCATE( sndbuf ) CALL free_memory_polaw( pw ) END SUBROUTINE SUBROUTINE transform_fft_data(fftd) !this subroutine performs a FFT transform from imaginary time !to imaginary frequency and viceversa !uses FFTW machinery !does not reorder data but puts appropriate factors USE constants, ONLY : pi USE fft_scalar, ONLY : cft_1z, good_fft_order implicit none TYPE(fft_data) :: fftd!structure to be transformed INTEGER :: iw,jw, il,kw COMPLEX(kind=DP), DIMENSION(:), ALLOCATABLE :: in,out!temporary arrays INTEGER*8 :: plan REAL(kind=DP) :: omega,time,totalperiod,totalfrequency COMPLEX(kind=DP) :: fact INTEGER :: good_dim good_dim = good_fft_order(2*fftd%n+2) allocate(in(good_dim),out(good_dim)) totalperiod=2.d0*fftd%period+2.d0*fftd%period/real(fftd%n) totalfrequency=(2.d0*pi/totalperiod)*real(2*fftd%n+2) if(fftd%ontime) then!time to frequency transform fftd%ontime=.false. do iw=1,fftd%numrows do jw=1,fftd%numpw in(1:2*fftd%n+2)=fftd%fd(jw,iw,1:2*fftd%n+2) call cft_1z(in,1,2*fftd%n+2,good_dim, -1,out) fftd%fd(jw,iw,1:2*fftd%n+2)=out(1:2*fftd%n+2)*dble(2*fftd%n+2) !ATTENZIONE enddo enddo !set appropriate factors do il=0,2*fftd%n+2-1 if(il <= (2*fftd%n+1)) then omega=(2.d0*pi/totalperiod)*real(il) else omega=(2.d0*pi/totalperiod)*real(il-2*fftd%n-2) endif !fact=exp((0.d0,-1.d0)*omega*totalperiod/2.d0)*(0.d0,-1.d0)*(fftd%period/real(fftd%n)) fact=exp((0.d0,-1.d0)*omega*totalperiod/2.d0)*(fftd%period/real(fftd%n)) fftd%fd(:,:,il+1)=fftd%fd(:,:,il+1)*fact enddo fftd%factor=fftd%factor*(0.d0,-1.d0) else!frequency to time transform !alternative approach fftd%ontime=.true. do iw=1,fftd%numrows do jw=1,fftd%numpw in(1:2*fftd%n+2)=fftd%fd(jw,iw,1:2*fftd%n+2) call cft_1z(in,1,2*fftd%n+2,good_dim, 1,out) fftd%fd(jw,iw,1:2*fftd%n+2)=out(1:2*fftd%n+2) enddo enddo !set appropriate factors do il=0,2*fftd%n+2-1 if(il<= (2*fftd%n+1)) then time=(fftd%period/real(fftd%n))*real(il) else time=(fftd%period/real(fftd%n))*real(il-2*fftd%n-2) endif ! fact=exp((0.d0,+1.d0)*time*totalfrequency/2.d0)*(0.d0,+1.d0)/totalperiod fact=exp((0.d0,+1.d0)*time*totalfrequency/2.d0)/totalperiod fftd%fd(:,:,il+1)=fftd%fd(:,:,il+1)*fact enddo fftd%factor=fftd%factor*(0.d0,+1.d0) endif deallocate(in,out) return END SUBROUTINE SUBROUTINE transform_fft_data_grid(tf, fftd) !this subroutine performs a Fourier transform from imaginary time !to imaginary frequency and viceversa !uses user defined grids USE constants, ONLY : pi USE times_gw, ONLY : times_freqs USE io_global, ONLY : stdout implicit none TYPE(times_freqs) :: tf! time frequency grids and factors TYPE(fft_data) :: fftd!structure to be transformed COMPLEX(kind=DP), DIMENSION(:,:,:), ALLOCATABLE :: fd_new COMPLEX(kind=DP), DIMENSION(:), ALLOCATABLE :: factors COMPLEX(kind=DP), DIMENSION(:,:), ALLOCATABLE :: tmpc INTEGER :: ii,jj, iw, jw INTEGER, PARAMETER :: nmesh=50 INTEGER, PARAMETER :: nmesh_g=50 INTEGER, PARAMETER :: nn=2 REAL(kind=DP) :: b_p,b_m,r_p,r_m COMPLEX(kind=DP) :: a_p,a_m, cor_1,cor_2 REAL(kind=DP), ALLOCATABLE :: x(:),w(:) COMPLEX(kind=DP), DIMENSION(nmesh_g) :: tmpg COMPLEX(kind=DP), ALLOCATABLE :: fij(:,:), fp(:),fm(:) !we take advantage of the t ==> -t symmetry ! allocate(fd_new(fftd%numpw,fftd%numrows,2*fftd%n+1)) allocate(fd_new(fftd%numpw,fftd%numrows,fftd%n+1)) allocate(factors(-tf%n:tf%n), tmpc(fftd%numpw,-tf%n:tf%n)) !check for consistency if(fftd%n /= tf%n) then write(stdout,*) 'Routine transform_fft_data_grid: consistency failed' stop endif if(fftd%ontime) then!time to frequency transform fftd%factor=fftd%factor*(0.d0,-1.d0) else fftd%factor=fftd%factor*(0.d0,+1.d0) endif !we take care of the t ==> -t symmetry ! do ii=-tf%n,tf%n do ii=0,tf%n if(fftd%ontime) then!time to frequency transform do jj=-tf%n,tf%n factors(jj)=tf%weights_time(jj)*exp((0.d0,-1.d0)*tf%freqs(ii)*tf%times(jj)) enddo !factors(:)=factors(:)*(0.d0,-1.d0) else!frequency to time transform do jj=-tf%n,tf%n factors(jj)=tf%weights_freq(jj)*exp((0.d0,1.d0)*tf%times(ii)*tf%freqs(jj)) enddo !factors(:)=factors(:)*(0.d0,1.d0)/(2.d0*pi) factors(:)=factors(:)/(2.d0*pi) endif do jw=1,fftd%numrows !we take care of the t ==> -t symmetry ! do jj=-tf%n,tf%n do jj=0,tf%n ! tmpc(:,jj)=fftd%fd(:,jw,jj+tf%n+2)*factors(jj) tmpc(:,jj)=fftd%fd(:,jw,jj+1)*factors(jj) enddo do jj=-tf%n,-1 ! tmpc(:,jj)=fftd%fd(:,jw,abs(jj)+tf%n+2)*factors(jj) tmpc(:,jj)=fftd%fd(:,jw,abs(jj)+1)*factors(jj) enddo do iw=1,fftd%numpw ! fd_new(iw,jw,ii+tf%n+1)=sum(tmpc(iw,-tf%n:tf%n)) fd_new(iw,jw,ii+1)=sum(tmpc(iw,-tf%n:tf%n)) enddo enddo enddo if(fftd%ontime .and. tf%l_fourier_fit_time) then allocate(fij(-tf%n:tf%n,nmesh)) allocate(fp(nmesh),fm(nmesh)) allocate(x(nmesh),w(nmesh)) x(:)=0.d0 w(:)=0.d0 call legzo(nmesh,x,w) x(:)=x(:)*tf%tau/2.d0 x(:)=x(:)+tf%tau/2.d0 w(:)=w(:)*tf%tau/2.d0 !x(:)=x(:)*(tf%times(tf%n)-tf%tau)/2.d0 !x(:)=x(:)+(tf%times(tf%n)-tf%tau)/2.d0+tf%tau !w(:)=w(:)*(tf%times(tf%n)-tf%tau)/2.d0 do jj=1,nmesh write(stdout,*)'MESH', jj, x(jj),w(jj) enddo do ii=-tf%n,tf%n do jj=1,nmesh fij(ii,jj)=exp((0.d0,-1.d0)*tf%freqs(ii)*x(jj)) enddo enddo do iw=1,fftd%numpw do jw=1,fftd%numrows r_p=dble(fftd%fd(iw,jw,2*tf%n+1)/fftd%fd(iw,jw,2*tf%n+2)) if(r_p <= 1.d0) r_p = tf%g_tau b_p=log(r_p)/(tf%times(tf%n)-tf%times(tf%n-1)) a_p=fftd%fd(iw,jw,2*tf%n+1)/(exp(-b_p*tf%times(tf%n-1))) if(r_p == tf%g_tau) a_p=0.d0 r_m=dble(fftd%fd(iw,jw,3)/fftd%fd(iw,jw,2)) if(r_m <= 1.d0) r_m = tf%g_tau b_m=log(r_m)/(tf%times(-tf%n+1)-tf%times(-tf%n)) a_m=fftd%fd(iw,jw,3)/(exp(b_m*tf%times(-tf%n+1))) if(r_m == tf%g_tau) a_m=0.d0 do jj=1,nmesh fp(jj)=a_p*exp(-b_p*x(jj))*w(jj) fm(jj)=a_m*exp(-b_m*x(jj))*w(jj) enddo do ii=-tf%n,tf%n !cor_1=(0.d0,-1.d0)*(a_p/(b_p+(0.d0,1.d0)*tf%freqs(ii)))+& ! &(0.d0,-1.d0)*(a_m/(b_m-(0.d0,1.d0)*tf%freqs(ii))) cor_1=(0.d0,-1.d0)*2.d0*a_p*b_p/(b_p**2.d0+tf%freqs(ii)**2.d0) cor_2=0.d0 do jj=1,nmesh cor_2=cor_2-fij(ii,jj)*fp(jj) cor_2=cor_2-conjg(fij(ii,jj))*fp(jj) enddo cor_2=cor_2*(0.d0,-1.d0) if(ii==0) write(stdout,*) 'COR', cor_1,cor_2 fd_new(iw,jw,ii+tf%n+1)=fd_new(iw,jw,ii+tf%n+1)+cor_1+cor_2 enddo enddo enddo deallocate(fij,fp,fm) deallocate(x,w) else if(.not.fftd%ontime .and. tf%l_fourier_fit_freq) then allocate(fij(-tf%n:tf%n,nmesh_g)) allocate(fp(nmesh_g),fm(nmesh_g)) allocate(x(nmesh_g),w(nmesh_g)) x(:)=0.d0 w(:)=1.d0 do jj=1,nmesh write(stdout,*)'MESH', jj, x(jj),w(jj) enddo x(:)=0.d0 w(:)=0.d0 call legzo(nmesh_g,x,w) do jj=1,nmesh write(stdout,*)'MESH', jj, x(jj),w(jj) enddo x(:)=x(:)*(tf%omega/2.d0)*dble(nn) x(:)=x(:)+(tf%omega/2.d0)*dble(nn)+tf%omega w(:)=w(:)*(tf%omega/2.d0)*dble(nn) do ii=-tf%n,tf%n do jj=1,nmesh_g fij(ii,jj)=exp((0.d0,1.d0)*tf%times(ii)*x(jj))*w(jj) enddo enddo do jj=1,nmesh write(stdout,*)'MESH', jj, x(jj),w(jj) enddo do iw=1,fftd%numpw do jw=1,fftd%numrows r_p=dble(fftd%fd(iw,jw,2*tf%n+1)/fftd%fd(iw,jw,2*tf%n+2)) b_p=(tf%freqs(tf%n)**2.d0-r_p*tf%freqs(tf%n-1)**2.d0)/(r_p-1.d0) if(b_p < -tf%freqs(tf%n-1)**2.d0) b_p=-tf%g_omega*tf%freqs(tf%n-1)**2.d0 a_p=fftd%fd(iw,jw,2*tf%n+1)*(b_p+tf%freqs(tf%n-1)**2.d0) r_m=dble(fftd%fd(iw,jw,3)/fftd%fd(iw,jw,2)) b_m=(tf%freqs(-tf%n)**2.d0-r_m*tf%freqs(-tf%n+1)**2.d0)/(r_m-1.d0) if(b_m < -tf%freqs(-tf%n+1)**2.d0) b_m=-tf%g_omega*tf%freqs(-tf%n+1)**2.d0 a_m=fftd%fd(iw,jw,3)*(b_m+tf%freqs(-tf%n+1)**2.d0) do jj=1,nmesh_g fp(jj)=a_p/(b_p+x(jj)**2.d0) fm(jj)=a_m/(b_m+x(jj)**2.d0) enddo do ii=-tf%n,tf%n do jj=1,nmesh_g tmpg(jj)=fij(ii,jj)*fp(jj) enddo cor_1=sum(tmpg(:)) do jj=1,nmesh_g tmpg(jj)=conjg(fij(ii,jj))*fm(jj) enddo cor_2=sum(tmpg(:)) cor_1=cor_1*(0.d0,+1.d0)/(2.d0*pi) cor_2=cor_2*(0.d0,+1.d0)/(2.d0*pi) fd_new(iw,jw,ii+tf%n+1)=fd_new(iw,jw,ii+tf%n+1)+cor_1+cor_2 enddo enddo enddo deallocate(x,w) deallocate(fij,fp,fm) endif if(fftd%ontime) then fftd%ontime=.false. else fftd%ontime=.true. endif !we take care of the t ==> -t symmetry ! do jj=-tf%n,tf%n do jj=0,tf%n ! fftd%fd(:,:,jj+tf%n+2)=fd_new(:,:,jj+tf%n+1) fftd%fd(:,:,jj+1)=fd_new(:,:,jj+1) enddo deallocate(fd_new) deallocate(factors) deallocate(tmpc) return END SUBROUTINE transform_fft_data_grid END MODULE fft_gw GWW/gww/lanczos_polarization.f900000644000077300007730000002055212341332532017404 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! MODULE lanczos !this module describes the structures for the calculation !of the polarization and of the self-energy through an !lanczos chain style USE kinds, ONLY : DP TYPE compact_q_lanczos !this structure describes the "compact" term: ! Q^v_in=\sum U_{vv'}V^v'_{i,l}T^v'_{l,n} INTEGER :: ii!corresponding KS state INTEGER :: numpw!dimension of polarization basis INTEGER :: numt!dimension of the basis {t_n} REAL(kind=DP), POINTER, DIMENSION(:,:) :: qlm!matrix Q(numpw,numt) END TYPE compact_q_lanczos TYPE lanczos_matrix !this structure describes the (H-i\alpha)^-1 matrix INTEGER :: iw!corresponding imaginary frequency INTEGER :: numt!dimension of the basis {t_n} COMPLEX(kind=DP), POINTER, DIMENSION(:,:) :: e_mat END TYPE lanczos_matrix CONTAINS SUBROUTINE initialize_compact_q_lanczos(cql) !this subroutine initializes compact_q_lanczos implicit none TYPE(compact_q_lanczos) :: cql nullify(cql%qlm) return END SUBROUTINE initialize_compact_q_lanczos SUBROUTINE free_memory_compact_q_lanczos(cql) !this subroutine initializes compact_q_lanczos implicit none TYPE(compact_q_lanczos) :: cql if(associated(cql%qlm)) deallocate(cql%qlm) nullify(cql%qlm) return END SUBROUTINE free_memory_compact_q_lanczos SUBROUTINE initialize_lanczos_matrix(lm) !this subroutine initializes compact_q_lanczos implicit none TYPE(lanczos_matrix) :: lm nullify(lm%e_mat) return END SUBROUTINE initialize_lanczos_matrix SUBROUTINE free_memory_lanczos_matrix(lm) !this subroutine initializes compact_q_lanczos implicit none TYPE(lanczos_matrix) :: lm if(associated(lm%e_mat)) deallocate(lm%e_mat) nullify(lm%e_mat) return END SUBROUTINE free_memory_lanczos_matrix SUBROUTINE write_compact_q_lanczos(cql) !this subroutine writes the compact_q_lanczos function on disk !the file name is taken from the label USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(compact_q_lanczos) :: cql!the compact_q_lanczos function to be written INTEGER :: iunq, ii CHARACTER(5) :: nfile write(nfile,'(5i1)') & & cql%ii/10000,mod(cql%ii,10000)/1000,mod(cql%ii,1000)/100,mod(cql%ii,100)/10,mod(cql%ii,10) iunq = find_free_unit() open( unit=iunq, file=trim(tmp_dir)//trim(prefix)//'-'//'q_lanczos.'// nfile, status='unknown',form='unformatted') write(iunq) cql%ii write(iunq) cql%numpw write(iunq) cql%numt do ii=1,cql%numt write(iunq) cql%qlm(1:cql%numpw,ii) enddo close(iunq) return END SUBROUTINE write_compact_q_lanczos SUBROUTINE read_compact_q_lanczos(cql, iv) !this subroutine reads the compact_q_lanczos function from disk USE io_files, ONLY : prefix,tmp_dir USE mp, ONLY : mp_barrier,mp_bcast, mp_sum USE mp_world, ONLY : world_comm USE io_global, ONLY : ionode,ionode_id implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(compact_q_lanczos) :: cql!the compact_q_lanczos function to be read INTEGER, INTENT(in) :: iv!the index of the file to be read INTEGER :: iunq, ii CHARACTER(5) :: nfile call free_memory_compact_q_lanczos(cql) cql%ii=iv write(nfile,'(5i1)') & & cql%ii/10000,mod(cql%ii,10000)/1000,mod(cql%ii,1000)/100,mod(cql%ii,100)/10,mod(cql%ii,10) if(ionode) then iunq = find_free_unit() open( unit=iunq, file=trim(tmp_dir)//trim(prefix)//'-'//'q_lanczos.'// nfile, status='old',form='unformatted') read(iunq) cql%ii read(iunq) cql%numpw read(iunq) cql%numt endif call mp_bcast(cql%ii,ionode_id,world_comm) call mp_bcast(cql%numpw,ionode_id,world_comm) call mp_bcast(cql%numt,ionode_id,world_comm) allocate(cql%qlm(cql%numpw,cql%numt)) do ii=1,cql%numt if(ionode) then read(iunq) cql%qlm(1:cql%numpw,ii) else cql%qlm(1:cql%numpw,ii)=0.d0 endif !call mp_barrier !call mp_bcast(cql%qlm(1:cql%numpw,ii),ionode_id,world_comm) !call mp_sum(cql%qlm(1:cql%numpw,ii)) enddo call mp_bcast(cql%qlm(:,:), ionode_id,world_comm) if(ionode) close(iunq) return END SUBROUTINE read_compact_q_lanczos SUBROUTINE do_compact_q_lanczos(vtl,ttl,cql,alpha) !this subroutines performs the calculation: ! Q^v'_in= Q^v'_in +alpha*V^v'_{i,l}T^v'_{l,n} USE kinds, ONLY : DP USE basic_structures, ONLY : tt_mat_lanczos, vt_mat_lanczos USE io_global, ONLY : stdout, ionode, ionode_id implicit none TYPE(vt_mat_lanczos), INTENT(in) :: vtl!V matrix TYPE(tt_mat_lanczos), INTENT(in) :: ttl!T matrix TYPE(compact_q_lanczos), INTENT(out) :: cql!Q matrix to be calculated REAL(kind=DP), INTENT(in) :: alpha!constant alpha INTEGER il,it,ip if(ttl%ii /= vtl%ii) then write(stdout,*) 'Routine do_compact_q_lanczos: state v not equal' call flush_unit(stdout) stop else cql%ii=ttl%ii endif cql%numpw=vtl%numpw cql%numt=ttl%numt call dgemm('N','T',cql%numpw,cql%numt,vtl%numl,alpha,vtl%vt_mat,vtl%numpw,ttl%tt_mat,ttl%numt,1.d0,cql%qlm,cql%numpw) ! cql%qlm(:,:)=0.d0 ! do ip=1,cql%numpw ! do it=1,cql%numt ! do il=1,vtl%numl ! cql%qlm(ip,it)=cql%qlm(ip,it)+vtl%vt_mat(ip,il)*ttl%tt_mat(it,il) ! enddo ! enddo ! enddo return END SUBROUTINE do_compact_q_lanczos SUBROUTINE write_lanczos_matrix(lm) !this subroutine writes the lanczos matrix on disk !the file name is taken from the label USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(lanczos_matrix) :: lm!the matrix to be written INTEGER :: iunm, ii CHARACTER(5) :: nfile if(lm%iw >= 0) then write(nfile,'(5i1)') & & lm%iw/10000,mod(lm%iw,10000)/1000,mod(lm%iw,1000)/100,mod(lm%iw,100)/10,mod(lm%iw,10) iunm = find_free_unit() open( unit=iunm, file=trim(tmp_dir)//trim(prefix)//'-'//'emat_lanczos.'// nfile, status='unknown',form='unformatted') else write(nfile,'(5i1)') & & -lm%iw/10000,mod(-lm%iw,10000)/1000,mod(-lm%iw,1000)/100,mod(-lm%iw,100)/10,mod(-lm%iw,10) iunm = find_free_unit() open( unit=iunm, file=trim(tmp_dir)//trim(prefix)//'-'//'emat_lanczos.-'// nfile, status='unknown',form='unformatted') endif write(iunm) lm%iw write(iunm) lm%numt do ii=1,lm%numt write(iunm) lm%e_mat(1:lm%numt,ii) enddo close(iunm) return end SUBROUTINE write_lanczos_matrix SUBROUTINE read_lanczos_matrix(lm,iw) !this subroutine reads the lanczos matrix from disk !the file name is taken from the label !it does not allocate the matrix USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(lanczos_matrix) :: lm!the matrix to be read INTEGER :: iw!index of matrix to be read INTEGER :: iunm, ii CHARACTER(5) :: nfile lm%iw=iw if(lm%iw >= 0) then write(nfile,'(5i1)') & & lm%iw/10000,mod(lm%iw,10000)/1000,mod(lm%iw,1000)/100,mod(lm%iw,100)/10,mod(lm%iw,10) iunm = find_free_unit() open( unit=iunm, file=trim(tmp_dir)//trim(prefix)//'-'//'emat_lanczos.'// nfile, status='old',form='unformatted') else write(nfile,'(5i1)') & & -lm%iw/10000,mod(-lm%iw,10000)/1000,mod(-lm%iw,1000)/100,mod(-lm%iw,100)/10,mod(-lm%iw,10) iunm = find_free_unit() open( unit=iunm, file=trim(tmp_dir)//trim(prefix)//'-'//'emat_lanczos.-'// nfile, status='unknown',form='unformatted') endif read(iunm) lm%iw read(iunm) lm%numt do ii=1,lm%numt read(iunm) lm%e_mat(1:lm%numt,ii) enddo close(iunm) return END SUBROUTINE read_lanczos_matrix END MODULE lanczos GWW/gww/do_self_lanczos_full.f900000644000077300007730000005215212341332532017327 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! subroutine do_self_lanczos_full(ss, tf ,options,l_real_axis,energy) !this subroutine calculates the self-energy on time using fourier transform with the lanczos scheme USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE input_gw, ONLY : input_options USE basic_structures, ONLY : v_pot,wannier_u,free_memory, initialize_memory,lanczos_chain, vt_mat_lanczos,tt_mat_lanczos,& & semicore,mat_lanczos_full,full_prods USE green_function, ONLY : green, read_green, free_memory_green, initialize_green USE polarization, ONLY : polaw, free_memory_polaw, read_polaw, write_polaw,invert_v_pot, initialize_polaw, & & read_polaw_global USE mp, ONLY : mp_sum, mp_bcast USE mp_world, ONLY : nproc,mpime,world_comm USE times_gw, ONLY : times_freqs USE self_energy_storage, ONLY : self_storage,write_self_storage_ondisk,free_memory_self_storage USE lanczos USE constants, ONLY : tpi,pi USE start_end ! debug USE parallel_include USE io_files, ONLY : prefix, tmp_dir implicit none TYPE(times_freqs), INTENT(in) :: tf!for time frequency grids TYPE(input_options) :: options TYPE(self_storage) :: ss LOGICAL, INTENT(in) :: l_real_axis !if true calculates on real frequency axis at given energy REAL(kind=DP), INTENT(in) :: energy!energy on real axis at which calculating the self-energy (or part of it) !only if l_real_axis == true TYPE(v_pot) :: vp,vpi TYPE(polaw) :: ww!dressed polarization REAL(kind=DP) :: inv_epsi,v_head INTEGER :: l_blk, nbegin,nend, nsize, l_blk_freq, nbegin_freq,nend_freq REAL(kind=DP), ALLOCATABLE:: wtemp(:,:) INTEGER :: iw TYPE(wannier_u) :: uu REAL(kind=DP) :: offset TYPE(lanczos_chain) :: lc COMPLEX(kind=DP), ALLOCATABLE :: e_mat(:,:,:) COMPLEX(kind=DP), ALLOCATABLE :: e_mat_tmp(:,:,:) COMPLEX(kind=DP) :: af(1) REAL(kind=DP), ALLOCATABLE :: pw_mat(:,:,:),pw_mat_t(:,:,:) INTEGER :: numpw,numt,numl,nums INTEGER :: it, ii,jj REAL(kind=DP) :: time,factor COMPLEX(kind=DP) :: cfactor REAL(kind=DP), ALLOCATABLE :: pw_tmp(:,:),pw_dumm(:,:) INTEGER :: iproc_time,ierr TYPE(mat_lanczos_full) :: fli,flj TYPE(full_prods) :: fp COMPLEX(kind=DP), ALLOCATABLE :: g_mat(:,:,:,:), g_mat_t(:,:,:,:),tmp_mat(:,:) REAL(kind=DP), ALLOCATABLE :: tmp_mat1(:,:),tmp_mat2(:,:) REAL(kind=DP), ALLOCATABLE :: g_tmp(:,:), g_dumm(:,:), re_h_mat(:,:),im_h_mat(:,:) REAL(kind=DP), EXTERNAL :: DDOT COMPLEX(kind=DP), EXTERNAL :: zdotc LOGICAL :: l_single=.false.!if true e_mat is saved in single precision REAL(kind=4), ALLOCATABLE :: re_e_mat_single(:,:,:),im_e_mat_single(:,:,:) REAL(kind=DP), ALLOCATABLE :: e_mat_double(:,:) INTEGER :: l_blk_t, nbegin_t,nend_t, nsize_t,in INTEGER, PARAMETER :: ndivt=1!10 INTEGER :: l_blk_g, nbegin_g,nend_g, nsize_g!paremter for optional dedicated frequency grid for G INTEGER :: j_min, j_max, is TYPE(semicore) :: sc REAL(kind=DP), ALLOCATABLE :: tmp_vec_sc(:) COMPLEX(kind=DP), ALLOCATABLE :: tmp_vec(:) INTEGER :: iv_sc LOGICAL, PARAMETER :: l_distribute_sm=.false.!if true the S matrices are distributed among mpi tasks instead of being read from disk !it requires the parameter l_single==false INTEGER :: l_blk_sm, nbegin_sm,nend_sm, nsize_sm,iproc REAL(kind=DP), ALLOCATABLE :: st_save(:,:,:), sl_save(:,:,:) COMPLEX(kind=DP), ALLOCATABLE :: exp_table(:,:) REAL(kind=DP), ALLOCATABLE :: re_e_mat_t(:,:,:),im_e_mat_t(:,:,:)!in time for fourier trasform REAL(kind=DP), ALLOCATABLE :: re_e_mat_part(:,:,:),im_e_mat_part(:,:,:)!in time for storing partial calculations REAL(kind=DP), ALLOCATABLE :: pw_part_t(:,:,:)!in time for storing partial calculations INTEGER :: n_cycles, i_cycles,i_min_cycles,i_max_cycles INTEGER :: n_list(2),iun,iun2 INTEGER, ALLOCATABLE :: i_list(:,:) INTEGER, EXTERNAL :: find_free_unit INTEGER :: ipol,iv,ic if(options%whole_s) then l_single=.false. endif write(stdout,*) 'Routine do_self_lanczos_time' call flush_unit(stdout) if(options%l_big_system) then n_cycles=options%i_max-options%i_min+1 else n_cycles=1 endif if(options%l_list) then if(ionode) then iun = find_free_unit() open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'list_1.dat', status='old') read(iun,*) n_list(1) if(uu%nspin==2) then iun2 = find_free_unit() open( unit=iun2, file=trim(tmp_dir)//trim(prefix)//'-'//'list_2.dat', status='old') read(iun,*) n_list(2) else n_list(2)=0 endif endif call mp_bcast(n_list,ionode_id,world_comm) allocate(i_list(max(n_list(1),n_list(2)),2)) i_list=0 if(ionode) then do ii=1,n_list(1) read(iun,*) i_list(ii,1) enddo close(iun) if(uu%nspin==2) then do ii=1,n_list(2) read(iun2,*) i_list(ii,2) enddo close(iun2) endif endif call mp_bcast(i_list,ionode_id,world_comm) n_cycles=n_list(1) endif !keeps in memory G, P(i\tau) nullify(vp%vmat) nullify(vpi%vmat) call initialize_polaw(ww) call initialize_memory(sc) !calculate offset !read in DFT energies call read_data_pw_u(uu,options%prefix) ss%ontime=.true. ss%max_i=options%max_i ss%i_min=options%i_min ss%i_max=options%i_max ss%n=tf%n ss%tau=options%tau ss%whole_s=options%whole_s ss%n_grid_fit=tf%n_grid_fit if(ss%whole_s) then ss%i_min_whole=options%i_min_whole ss%i_max_whole=options%i_max_whole endif ss%nspin=uu%nspin if(ss%whole_s) then allocate(ss%whole(ss%i_min_whole:ss%i_max_whole,ss%max_i,2*ss%n+1,ss%nspin)) ss%whole(:,:,:,:)=(0.d0,0.d0) allocate(ss%whole_freq_fit(ss%i_min_whole:ss%i_max_whole,ss%max_i,2*ss%n_grid_fit+1,ss%nspin)) ss%whole_freq_fit(:,:,:,:)=(0.d0,0.d0) allocate(ss%diag(ss%max_i,2*ss%n+1,ss%nspin)) ss%diag(:,:,:)=(0.d0,0.d0) allocate(ss%diag_freq_fit(ss%max_i,2*ss%n_grid_fit+1,ss%nspin)) ss%diag_freq_fit(:,:,:)=(0.d0,0.d0) else allocate(ss%diag(ss%max_i,2*ss%n+1,ss%nspin)) ss%diag(:,:,:)=(0.d0,0.d0) nullify(ss%whole) allocate(ss%diag_freq_fit(ss%max_i,2*ss%n_grid_fit+1,ss%nspin)) ss%diag_freq_fit(:,:,:)=(0.d0,0.d0) nullify(ss%whole_freq_fit) endif !for compatibility allocate(ss%ene_remainder(ss%max_i,1)) ss%ene_remainder(:,1)=0.d0 !loop on spin do is=1,ss%nspin !NOT_TO_BE_INCLUDED_START if(options%l_semicore) call read_data_pw_semicore(sc, options%prefix, is) !NOT_TO_BE_INCLUDED_END if(.not.l_real_axis) then if(uu%nums > uu%nums_occ(is)) then offset=-(uu%ene(uu%nums_occ(is)+1,is)+uu%ene(uu%nums_occ(is),is))/2.d0! CUSSI XE GIUSTO DEBUG !offset=-(uu%ene(uu%nums_occ(2)+1,2)+uu%ene(uu%nums_occ(1),1))/2.d0 else offset=-uu%ene(uu%nums_occ(is),is) endif else offset=-energy endif !!!!!!!! l_blk= (tf%n+1)/nproc if(l_blk*nproc < (tf%n+1)) l_blk = l_blk+1 nbegin=mpime*l_blk nend=nbegin+l_blk-1 if(nend > tf%n) nend=tf%n nsize=nend-nbegin+1 !read polarizability matrices if( options%l_verbose) write(stdout,*) 'Read Pgreek' call flush_unit(stdout) do iw=nbegin,nend call read_polaw(iw,ww,options%debug,options%l_verbose) if(iw==nbegin) allocate(pw_mat(ww%numpw,ww%numpw,l_blk)) pw_mat(:,:,iw-nbegin+1)=ww%pw(:,:) call free_memory_polaw(ww) enddo numpw=ww%numpw call mp_bcast(numpw, ionode_id,world_comm) if(nbegin > tf%n) allocate(pw_mat(numpw,numpw,l_blk)) !Fourier trasform reducible polarizability matrices to imaginary time write(stdout,*) 'Fourier trasform Pgreek' call flush_unit(stdout) allocate(pw_tmp(numpw,numpw)) allocate(pw_dumm(numpw,numpw)) allocate(pw_mat_t(numpw,numpw,l_blk)) !loop on time do it=0,tf%n !each procs sums up its matrices in frequency with opportune factor time=tf%times(it) pw_tmp(:,:)=0.d0 do iw=nbegin,nend factor=2.d0*dble(tf%weights_freq(iw)*exp((0.d0,1.d0)*tf%times(it)*tf%freqs_eff(iw)))/(2.d0*pi) pw_tmp(:,:)=pw_tmp(:,:)+pw_mat(:,:,iw-nbegin+1)*factor enddo #ifdef __PARA !the distribution of times on procs is the same of that for frequecies iproc_time=it/l_blk !all processors sums to iproc_time if(iproc_time==mpime) then call MPI_REDUCE(pw_tmp,pw_mat_t(1,1,it-nbegin+1),numpw*numpw,MPI_DOUBLE_PRECISION,MPI_SUM,iproc_time,world_comm,ierr) else call MPI_REDUCE(pw_tmp,pw_dumm,numpw*numpw,MPI_DOUBLE_PRECISION,MPI_SUM,iproc_time,world_comm,ierr) endif #else pw_mat_t(:,:,it+1)=pw_tmp #endif !mp_sum to processer owing that time !this processor put on opportune array enddo deallocate(pw_tmp) deallocate(pw_dumm) deallocate(pw_mat) l_blk_g= (tf%n_g+1)/nproc if(l_blk_g*nproc < (tf%n_g+1)) l_blk_g = l_blk_g+1 nbegin_g=mpime*l_blk_g nend_g=nbegin_g+l_blk_g-1 if(nend_g > tf%n_g) nend_g=tf%n_g nsize_g=nend_g-nbegin_g+1 !allocate and compute table for Fourier trasform allocate(exp_table(tf%n+1,l_blk_g)) do it=0,tf%n do iw=nbegin_g,nend_g exp_table(it+1,iw-nbegin_g+1)=exp((0.d0,1.d0)*tf%times(it)*tf%freqs_g_eff(iw)) enddo enddo call initialize_memory(fp) if(options%n_full>0) call read_data_pw_full_prods(fp, options%prefix) do i_cycles=1,n_cycles !calculates G call initialize_memory(lc) if(.not.options%l_list) then call read_data_pw_lanczos_chain(lc, i_cycles, options%prefix, .false.,is) else call read_data_pw_lanczos_chain(lc, i_list(i_cycles,is), options%prefix, .false.,is) endif write(stdout,*) 'Lanczos dimensions', lc%numt,lc%num_steps,is call flush_unit(stdout) allocate(e_mat(lc%numt,lc%numt,l_blk_g)) do iw=nbegin_g,nbegin_g+l_blk_g-1 if(iw <= tf%n_g) then af(1)=dcmplx(offset,-tf%freqs_g(iw)) call solve_lanczos_complex(1,af,e_mat(1,1,iw-nbegin_g+1),lc) else call solve_lanczos_fake_complex(lc) endif end do !for entire self-energy store !!!!!!!!!!!!!! call initialize_memory(fli) call initialize_memory(flj) !if required read all S matrices and distribute among mpi tasks !loop on KS states if(options%l_big_system) then if(.not.options%l_list) then i_min_cycles=ss%i_min+i_cycles-1 i_max_cycles=i_min_cycles else i_min_cycles=i_list(i_cycles,is) i_max_cycles=i_min_cycles endif else i_min_cycles=ss%i_min i_max_cycles=ss%i_max endif do ii=i_min_cycles,i_max_cycles write(stdout,*) 'Loop on KS:',ii, is call flush_unit(stdout) !calculates G on partial basis !read vtl ttl call read_data_pw_mat_lanczos_full(fli, ii, options%prefix) if(ii==i_min_cycles.and.i_cycles==1) then nums=fli%nums allocate(g_mat(numpw,numpw,l_blk_g,2),g_mat_t(numpw,numpw,l_blk,2)) endif !multiply and put on array !loop on frequency if(.not.ss%whole_s) then j_min=ii j_max=ii else j_min=ss%i_min_whole j_max=ss%i_max_whole endif if( options%l_verbose) write(stdout,*) 'Doing dgemms',nums,numpw do jj=j_min,j_max call read_data_pw_mat_lanczos_full(flj, jj, options%prefix) allocate(tmp_mat(numpw,nums)) do iw=nbegin_g,nend_g if( options%l_verbose) write(stdout,*) 'Doing dgemms',nums,numpw,l_blk,iw call flush_unit(stdout) do ipol=1,2 call ZGEMM('N','N',numpw,nums,nums,(1.d0,0.d0),fli%f_mat(1,1,ipol),numpw,& &e_mat(1,1,iw-nbegin_g+1),nums,(0.d0,0.d0),tmp_mat,numpw) call ZGEMM('N','C',numpw,numpw,nums,(1.d0,0.d0),tmp_mat,numpw,flj%f_mat(1,1,ipol),numpw,& &(0.d0,0.d0),g_mat(1,1,iw-nbegin_g+1,ipol),numpw) enddo enddo deallocate(tmp_mat) write(stdout,*) 'Fourier trasform:' call flush_unit(stdout) !Fourier trasform allocate(g_tmp(numpw,numpw)) allocate(g_dumm(numpw,numpw)) if( options%l_verbose) write(stdout,*) 'ATT1' call flush_unit(stdout) do ipol=1,2 !loop on time do it=0,tf%n !each procs sums up its matrices in frequency with opportune factor time=tf%times(it) g_tmp=0.d0 do iw=nbegin_g,nend_g factor=2.d0*dble(tf%weights_freq_g(iw)*exp_table(it+1,iw-nbegin_g+1))/(2.d0*pi) g_tmp(1:numpw,1:numpw)=g_tmp(1:numpw,1:numpw)+dble(g_mat(1:numpw,1:numpw,iw-nbegin_g+1,ipol))*factor enddo #ifdef __PARA !the distribution of times on procs is the same of that for frequecies iproc_time=it/l_blk !all processors sums to iproc_time if(iproc_time==mpime) then call MPI_REDUCE(g_tmp,g_dumm,numpw*numpw,& &MPI_DOUBLE_PRECISION,MPI_SUM,iproc_time,world_comm,ierr) g_mat_t(1:numpw,1:numpw,it-nbegin+1,ipol)=g_dumm(1:numpw,1:numpw) else call MPI_REDUCE(g_tmp,g_dumm,numpw*numpw,MPI_DOUBLE_PRECISION,& &MPI_SUM,iproc_time,world_comm,ierr) endif #else g_mat_t(1:numpw,1:numpw,it+1,ipol)=g_tmp(1:numpw,1:numpw) #endif g_tmp=0.d0 do iw=nbegin_g,nend_g factor=-2.d0*dimag(tf%weights_freq_g(iw)*exp_table(it+1,iw-nbegin_g+1))/(2.d0*pi) g_tmp(1:numpw,1:numpw)=g_tmp(1:numpw,1:numpw)+dimag(g_mat(1:numpw,1:numpw,iw-nbegin_g+1,ipol))*factor enddo #ifdef __PARA !the distribution of times on procs is the same of that for frequecies iproc_time=it/l_blk !all processors sums to iproc_time if(iproc_time==mpime) then call MPI_REDUCE(g_tmp,g_dumm,numpw*numpw,& &MPI_DOUBLE_PRECISION,MPI_SUM,iproc_time,world_comm,ierr) g_mat_t(1:numpw,1:numpw,it-nbegin+1,ipol)=g_mat_t(1:numpw,1:numpw,it-nbegin+1,ipol)& &+(0.d0,1.d0)*g_dumm(1:numpw,1:numpw) else call MPI_REDUCE(g_tmp,g_dumm,numpw*numpw,MPI_DOUBLE_PRECISION,MPI_SUM,iproc_time,world_comm,ierr) endif #else g_mat_t(1:numpw,1:numpw,it-nbegin+1,ipol)=g_mat_t(1:numpw,1:numpw,it-nbegin+1,ipol)+& &(0.d0,1.d0)*g_tmp(1:numpw,1:numpw) #endif enddo enddo deallocate(g_tmp,g_dumm) if( options%l_verbose) write(stdout,*) 'done' call flush_unit(stdout) !loop on frequency write(stdout,*) 'Products in imaginary time:' call flush_unit(stdout) allocate(re_h_mat(numpw,numpw),im_h_mat(numpw,numpw)) allocate(tmp_mat(numpw,numpw),tmp_vec(numpw)) do it=nbegin,nend !product if(ii==jj) then ss%diag(ii,it+ss%n+1,is)=0.d0 ss%diag(ii,ss%n+1-it,is)=0.d0 do ipol=1,2 re_h_mat(1:numpw,1:numpw)=dble(g_mat_t(1:numpw,1:numpw,it-nbegin+1,ipol)) im_h_mat(1:numpw,1:numpw)=dimag(g_mat_t(1:numpw,1:numpw,it-nbegin+1,ipol)) ss%diag(ii,it+ss%n+1,is)=ss%diag(ii,it+ss%n+1,is)+DDOT(numpw*numpw,re_h_mat,1,pw_mat_t(1,1,it-nbegin+1),1)+& &DDOT(numpw*numpw,im_h_mat,1,pw_mat_t(1,1,it-nbegin+1),1) ss%diag(ii,ss%n+1-it,is)=ss%diag(ii,ss%n+1-it,is)+DDOT(numpw*numpw,re_h_mat,1,pw_mat_t(1,1,it-nbegin+1),1)-& &DDOT(numpw*numpw,im_h_mat,1,pw_mat_t(1,1,it-nbegin+1),1) enddo if(options%n_full>0) then tmp_mat(1:numpw,1:numpw)=pw_mat_t(1:numpw,1:numpw,it-nbegin+1) !first valence states (t>0) do iv=1,fp%numv do ipol=1,2 if(it==0) then factor=0.5d0*exp((offset+fp%ene_ks(iv))*tf%times(it)) else factor=exp((offset+fp%ene_ks(iv))*tf%times(it)) endif call ZGEMV('N',numpw,numpw,(1.d0,0.d0),tmp_mat,numpw,& &fp%gmat(1,ipol,iv,ii),1,(0.d0,0.d0),tmp_vec,1) ss%diag(ii,it+ss%n+1,is)= ss%diag(ii,it+ss%n+1,is)- & &zdotc(numpw,fp%gmat(1,ipol,iv,ii),1,tmp_vec,1)*factor enddo enddo !then conduction states(t<0) do ic=fp%numv+1,options%n_full do ipol=1,2 if(it==0) then factor=0.5d0*exp(-(offset+fp%ene_ks(ic))*tf%times(it)) else factor=exp(-(offset+fp%ene_ks(ic))*tf%times(it)) endif call ZGEMV('N',numpw,numpw,(1.d0,0.d0),tmp_mat,numpw,& &fp%gmat(1,ipol,ic,ii),1,(0.d0,0.d0),tmp_vec,1) ss%diag(ii,ss%n+1-it,is)= ss%diag(ii,ss%n+1-it,is)+ & &zdotc(numpw,tmp_vec,1,fp%gmat(1,ipol,ic,ii),1)*factor enddo enddo endif !if required add semicore terms if(options%l_semicore) then !NOT_TO_BE_INCLUDED_START allocate(tmp_vec_sc(numpw)) do iv_sc=1,sc%n_semicore if(it==0) write(stdout,*) 'SEMICORE PRIMA',iv_sc,ii, ss%diag(ii,it+ss%n+1,is) call dgemv('N',numpw,numpw,1.d0,pw_mat_t(1,1,it-nbegin+1),numpw,& &sc%ppw_mat(1,iv_sc,ii),1,0.d0,tmp_vec_sc,1) ss%diag(ii,it+ss%n+1,is)= ss%diag(ii,it+ss%n+1,is)- &!ATTENZIONE ERA + &DDOT(numpw,tmp_vec_sc,1,sc%ppw_mat(1,iv_sc,ii),1)*exp((offset+sc%en_sc(iv_sc))*tf%times(it)) if(it==0) write(stdout,*) 'SEMICORE',iv_sc,ii, ss%diag(ii,it+ss%n+1,is) if((offset+sc%en_sc(iv_sc))*tf%times(it)>0) write(stdout,*) 'OCIO!!!'!DEBUG ATTENZIONE enddo deallocate(tmp_vec_sc) !NOT_TO_BE_INCLUDED_END endif endif if(ss%whole_s) then !to be done this... ss%whole(jj,ii,it+ss%n+1,is)=DDOT(numpw*numpw,re_h_mat,1,pw_mat_t(1,1,it-nbegin+1),1)+& &DDOT(numpw*numpw,im_h_mat,1,pw_mat_t(1,1,it-nbegin+1),1) ss%whole(jj,ii,ss%n+1-it,is)=DDOT(numpw*numpw,re_h_mat,1,pw_mat_t(1,1,it-nbegin+1),1)-& &DDOT(numpw*numpw,im_h_mat,1,pw_mat_t(1,1,it-nbegin+1),1) !!!!!!! endif enddo deallocate(re_h_mat,im_h_mat) deallocate(tmp_mat,tmp_vec) if( options%l_verbose) write(stdout,*) 'done' call flush_unit(stdout) !mp_sum for distributing on all processors if(ii==jj) then call mp_sum(ss%diag(ii,1:2*ss%n+1,is),world_comm) endif if(ss%whole_s) then call mp_sum(ss%whole(jj,ii,1:2*ss%n+1,is),world_comm) endif !FT of diagonal part of self-nergy !deallocate(re_g_mat_t, im_g_mat_t) call free_memory(flj) enddo !jj call free_memory(fli) enddo!on i_min, i_max enddo!on i_cycles !put factor due to FFT on imaginary axis ss%diag(:,:,is)=ss%diag(:,:,is)*(0.d0,1.d0) if(ss%whole_s) then ss%whole(:,:,:,is)=ss%whole(:,:,:,is)*(0.d0,1.d0) endif deallocate(g_mat) deallocate(g_mat_t) deallocate(pw_mat_t) deallocate(e_mat) deallocate(exp_table) call free_memory(lc) call free_memory(fp) enddo!on spin call free_memory(uu) call free_memory(sc) return end subroutine do_self_lanczos_full GWW/gww/do_self_lanczos_time.f900000644000077300007730000011055312341332532017323 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! subroutine do_reducible_pola(tf ,options) !this subroutine calculates and writes on disk the reducible polarizability from the screen interaction USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE input_gw, ONLY : input_options USE basic_structures, ONLY : v_pot,wannier_u,free_memory, initialize_memory,lanczos_chain, vt_mat_lanczos,tt_mat_lanczos,& & semicore USE green_function, ONLY : green, read_green, free_memory_green, initialize_green USE polarization, ONLY : polaw, free_memory_polaw, read_polaw, write_polaw,invert_v_pot, initialize_polaw, & & read_polaw_global USE mp, ONLY : mp_sum, mp_bcast USE mp_world, ONLY : nproc,mpime,world_comm USE times_gw, ONLY : times_freqs USE self_energy_storage, ONLY : self_storage,write_self_storage_ondisk,free_memory_self_storage USE lanczos USE constants, ONLY : tpi,pi USE start_end ! debug USE parallel_include implicit none TYPE(times_freqs), INTENT(in) :: tf!for time frequency grids TYPE(input_options) :: options TYPE(self_storage) :: ss TYPE(v_pot) :: vp,vpi TYPE(polaw) :: ww!dressed polarization INTEGER :: l_blk, nbegin,nend, nsize REAL(kind=DP), ALLOCATABLE:: wtemp(:,:) INTEGER :: iw REAL(kind=DP) :: v_head nullify(vp%vmat) nullify(vpi%vmat) call initialize_polaw(ww) write(stdout,*) 'Trasform W to Pgreek' call flush_unit(stdout) if(options%w_divergence == 2) then call read_data_pw_v(vp,options%prefix,options%debug,0,.true.) else call read_data_pw_v(vp,options%prefix,options%debug,0,.false.) endif v_head=vp%vmat(vp%numpw,vp%numpw) call invert_v_pot(vp,vpi) call free_memory(vp) l_blk= (tf%n+1)/nproc if(l_blk*nproc < (tf%n+1)) l_blk = l_blk+1 nbegin=mpime*l_blk nend=nbegin+l_blk-1 !loop on imaginary frequency i\omega do iw=nbegin,nbegin+l_blk-1 if(iw <= tf%n) then call read_polaw(iw,ww,options%debug,options%l_verbose) allocate(wtemp(ww%numpw,ww%numpw)) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,vpi%vmat,ww%numpw,ww%pw,ww%numpw,& &0.d0, wtemp,ww%numpw) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,wtemp,ww%numpw,vpi%vmat,ww%numpw,& &0.d0,ww%pw,ww%numpw) deallocate(wtemp) call write_polaw(ww,options%debug) endif enddo call free_memory(vpi) call free_memory_polaw(ww) write(stdout,*) 'Done' call flush_unit(stdout) return end subroutine do_reducible_pola subroutine do_self_lanczos_time(ss, tf ,options,l_real_axis,energy) !this subroutine calculte the self-energy on time using fourier trasfrom using the lanczos scheme USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE input_gw, ONLY : input_options USE basic_structures, ONLY : v_pot,wannier_u,free_memory, initialize_memory,lanczos_chain, vt_mat_lanczos,tt_mat_lanczos,& & semicore USE green_function, ONLY : green, read_green, free_memory_green, initialize_green USE polarization, ONLY : polaw, free_memory_polaw, read_polaw, write_polaw,invert_v_pot, initialize_polaw, & & read_polaw_global USE mp, ONLY : mp_sum, mp_bcast USE mp_world, ONLY : nproc,mpime,world_comm USE times_gw, ONLY : times_freqs USE self_energy_storage, ONLY : self_storage,write_self_storage_ondisk,free_memory_self_storage USE lanczos USE constants, ONLY : tpi,pi USE start_end ! debug USE parallel_include USE io_files, ONLY : prefix, tmp_dir implicit none TYPE(times_freqs), INTENT(in) :: tf!for time frequency grids TYPE(input_options) :: options TYPE(self_storage) :: ss LOGICAL, INTENT(in) :: l_real_axis !if true calculates on real frequency axis at given energy REAL(kind=DP), INTENT(in) :: energy!energy on real axis at which calculating the self-energy (or part of it) !only if l_real_axis == true TYPE(v_pot) :: vp,vpi TYPE(polaw) :: ww!dressed polarization REAL(kind=DP) :: inv_epsi,v_head INTEGER :: l_blk, nbegin,nend, nsize, l_blk_freq, nbegin_freq,nend_freq REAL(kind=DP), ALLOCATABLE:: wtemp(:,:) INTEGER :: iw TYPE(wannier_u) :: uu REAL(kind=DP) :: offset TYPE(lanczos_chain) :: lc REAL(kind=DP), ALLOCATABLE :: re_e_mat(:,:,:),im_e_mat(:,:,:) COMPLEX(kind=DP), ALLOCATABLE :: e_mat_tmp(:,:,:) COMPLEX(kind=DP) :: af(1) REAL(kind=DP), ALLOCATABLE :: pw_mat(:,:,:),pw_mat_t(:,:,:) INTEGER :: numpw,numt,numl INTEGER :: it, ii,jj REAL(kind=DP) :: time,factor COMPLEX(kind=DP) :: cfactor REAL(kind=DP), ALLOCATABLE :: pw_tmp(:,:),pw_dumm(:,:) INTEGER :: iproc_time,ierr TYPE(vt_mat_lanczos) :: vtl,vtl_j TYPE(tt_mat_lanczos) :: ttl,ttl_j REAL(kind=DP), ALLOCATABLE :: re_g_mat(:,:,:), im_g_mat(:,:,:),re_g_mat_t(:,:,:), im_g_mat_t(:,:,:) REAL(kind=DP), ALLOCATABLE :: tmp_mat(:,:),tmp_mat1(:,:),tmp_mat2(:,:) REAL(kind=DP), ALLOCATABLE :: g_tmp(:,:), g_dumm(:,:), re_h_mat(:,:),im_h_mat(:,:) REAL(kind=DP), EXTERNAL :: DDOT LOGICAL :: l_single=.true.!if true e_mat is saved in single precision REAL(kind=4), ALLOCATABLE :: re_e_mat_single(:,:,:),im_e_mat_single(:,:,:) REAL(kind=DP), ALLOCATABLE :: e_mat_double(:,:) INTEGER :: l_blk_t, nbegin_t,nend_t, nsize_t,in INTEGER, PARAMETER :: ndivt=1!10 INTEGER :: l_blk_g, nbegin_g,nend_g, nsize_g!paremter for optional dedicated frequency grid for G INTEGER :: j_min, j_max, is TYPE(semicore) :: sc REAL(kind=DP), ALLOCATABLE :: tmp_vec_sc(:) INTEGER :: iv_sc LOGICAL, PARAMETER :: l_distribute_sm=.true.!if true the S matrices are distributed among mpi tasks instead of being read from disk !it requires the parameter l_single==false INTEGER :: l_blk_sm, nbegin_sm,nend_sm, nsize_sm,iproc REAL(kind=DP), ALLOCATABLE :: st_save(:,:,:), sl_save(:,:,:) COMPLEX(kind=DP), ALLOCATABLE :: exp_table(:,:) REAL(kind=DP), ALLOCATABLE :: re_e_mat_t(:,:,:),im_e_mat_t(:,:,:)!in time for fourier trasform REAL(kind=DP), ALLOCATABLE :: re_e_mat_part(:,:,:),im_e_mat_part(:,:,:)!in time for storing partial calculations REAL(kind=DP), ALLOCATABLE :: pw_part_t(:,:,:)!in time for storing partial calculations INTEGER :: n_cycles, i_cycles,i_min_cycles,i_max_cycles INTEGER :: n_list(2),iun,iun2 INTEGER, ALLOCATABLE :: i_list(:,:) INTEGER, EXTERNAL :: find_free_unit if(options%whole_s) then l_single=.false. endif write(stdout,*) 'Routine do_self_lanczos_time' call flush_unit(stdout) if(options%l_big_system) then n_cycles=options%i_max-options%i_min+1 else n_cycles=1 endif if(options%l_list) then if(ionode) then iun = find_free_unit() open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'list_1.dat', status='old') read(iun,*) n_list(1) if(uu%nspin==2) then iun2 = find_free_unit() open( unit=iun2, file=trim(tmp_dir)//trim(prefix)//'-'//'list_2.dat', status='old') read(iun,*) n_list(2) else n_list(2)=0 endif endif call mp_bcast(n_list,ionode_id,world_comm) allocate(i_list(max(n_list(1),n_list(2)),2)) i_list=0 if(ionode) then do ii=1,n_list(1) read(iun,*) i_list(ii,1) enddo close(iun) if(uu%nspin==2) then do ii=1,n_list(2) read(iun2,*) i_list(ii,2) enddo close(iun2) endif endif call mp_bcast(i_list,ionode_id,world_comm) n_cycles=n_list(1) endif !keeps in memory G, P(i\tau) nullify(vp%vmat) nullify(vpi%vmat) call initialize_polaw(ww) call initialize_memory(sc) !calculate offset !read in DFT energies call read_data_pw_u(uu,options%prefix) ss%ontime=.true. ss%max_i=options%max_i ss%i_min=options%i_min ss%i_max=options%i_max ss%n=tf%n ss%tau=options%tau ss%whole_s=options%whole_s ss%n_grid_fit=tf%n_grid_fit if(ss%whole_s) then ss%i_min_whole=options%i_min_whole ss%i_max_whole=options%i_max_whole endif ss%nspin=uu%nspin if(ss%whole_s) then allocate(ss%whole(ss%i_min_whole:ss%i_max_whole,ss%max_i,2*ss%n+1,ss%nspin)) ss%whole(:,:,:,:)=(0.d0,0.d0) allocate(ss%whole_freq_fit(ss%i_min_whole:ss%i_max_whole,ss%max_i,2*ss%n_grid_fit+1,ss%nspin)) ss%whole_freq_fit(:,:,:,:)=(0.d0,0.d0) allocate(ss%diag(ss%max_i,2*ss%n+1,ss%nspin)) ss%diag(:,:,:)=(0.d0,0.d0) allocate(ss%diag_freq_fit(ss%max_i,2*ss%n_grid_fit+1,ss%nspin)) ss%diag_freq_fit(:,:,:)=(0.d0,0.d0) else allocate(ss%diag(ss%max_i,2*ss%n+1,ss%nspin)) ss%diag(:,:,:)=(0.d0,0.d0) nullify(ss%whole) allocate(ss%diag_freq_fit(ss%max_i,2*ss%n_grid_fit+1,ss%nspin)) ss%diag_freq_fit(:,:,:)=(0.d0,0.d0) nullify(ss%whole_freq_fit) endif !for compatibility allocate(ss%ene_remainder(ss%max_i,1)) ss%ene_remainder(:,1)=0.d0 !loop on spin do is=1,ss%nspin !NOT_TO_BE_INCLUDED_START if(options%l_semicore) call read_data_pw_semicore(sc, options%prefix, is) !NOT_TO_BE_INCLUDED_END if(.not.l_real_axis) then if(uu%nums > uu%nums_occ(is)) then offset=-(uu%ene(uu%nums_occ(is)+1,is)+uu%ene(uu%nums_occ(is),is))/2.d0! CUSSI XE GIUSTO DEBUG !offset=-(uu%ene(uu%nums_occ(2)+1,2)+uu%ene(uu%nums_occ(1),1))/2.d0 else offset=-uu%ene(uu%nums_occ(is),is) endif else offset=-energy endif !!!!!!!! l_blk= (tf%n+1)/nproc if(l_blk*nproc < (tf%n+1)) l_blk = l_blk+1 nbegin=mpime*l_blk nend=nbegin+l_blk-1 if(nend > tf%n) nend=tf%n nsize=nend-nbegin+1 !read polarizability matrices if( options%l_verbose) write(stdout,*) 'Read Pgreek' call flush_unit(stdout) do iw=nbegin,nend call read_polaw(iw,ww,options%debug,options%l_verbose) if(iw==nbegin) allocate(pw_mat(ww%numpw,ww%numpw,l_blk)) pw_mat(:,:,iw-nbegin+1)=ww%pw(:,:) call free_memory_polaw(ww) enddo numpw=ww%numpw call mp_bcast(numpw, ionode_id,world_comm) if(nbegin > tf%n) allocate(pw_mat(numpw,numpw,l_blk)) !Fourier trasform reducible polarizability matrices to imaginary time write(stdout,*) 'Fourier trasform Pgreek' call flush_unit(stdout) allocate(pw_tmp(numpw,numpw)) allocate(pw_dumm(numpw,numpw)) allocate(pw_mat_t(numpw,numpw,l_blk)) !loop on time do it=0,tf%n !each procs sums up its matrices in frequency with opportune factor time=tf%times(it) pw_tmp(:,:)=0.d0 do iw=nbegin,nend factor=2.d0*dble(tf%weights_freq(iw)*exp((0.d0,1.d0)*tf%times(it)*tf%freqs_eff(iw)))/(2.d0*pi) pw_tmp(:,:)=pw_tmp(:,:)+pw_mat(:,:,iw-nbegin+1)*factor enddo #ifdef __PARA !the distribution of times on procs is the same of that for frequecies iproc_time=it/l_blk !all processors sums to iproc_time if(iproc_time==mpime) then call MPI_REDUCE(pw_tmp,pw_mat_t(1,1,it-nbegin+1),numpw*numpw,MPI_DOUBLE_PRECISION,MPI_SUM,iproc_time,world_comm,ierr) else call MPI_REDUCE(pw_tmp,pw_dumm,numpw*numpw,MPI_DOUBLE_PRECISION,MPI_SUM,iproc_time,world_comm,ierr) endif #else pw_mat_t(:,:,it+1)=pw_tmp #endif !mp_sum to processer owing that time !this processor put on opportune array enddo deallocate(pw_tmp) deallocate(pw_dumm) deallocate(pw_mat) l_blk_g= (tf%n_g+1)/nproc if(l_blk_g*nproc < (tf%n_g+1)) l_blk_g = l_blk_g+1 nbegin_g=mpime*l_blk_g nend_g=nbegin_g+l_blk_g-1 if(nend_g > tf%n_g) nend_g=tf%n_g nsize_g=nend_g-nbegin_g+1 !allocate and compute table for Fourier trasform allocate(exp_table(tf%n+1,l_blk_g)) do it=0,tf%n do iw=nbegin_g,nend_g exp_table(it+1,iw-nbegin_g+1)=exp((0.d0,1.d0)*tf%times(it)*tf%freqs_g_eff(iw)) enddo enddo do i_cycles=1,n_cycles !calculates G call initialize_memory(lc) if(.not.options%l_list) then call read_data_pw_lanczos_chain(lc, i_cycles, options%prefix, .false.,is) else call read_data_pw_lanczos_chain(lc, i_list(i_cycles,is), options%prefix, .false.,is) endif write(stdout,*) 'Lanczos dimensions', lc%numt,lc%num_steps,is call flush_unit(stdout) if(.not.l_single) then allocate(re_e_mat(lc%numt,lc%numt,l_blk_g)) allocate(im_e_mat(lc%numt,lc%numt,l_blk_g)) allocate(e_mat_tmp(lc%numt,lc%numt,1)) do iw=nbegin_g,nbegin_g+l_blk_g-1 if(iw <= tf%n_g) then af(1)=dcmplx(offset,-tf%freqs_g(iw)) call solve_lanczos_complex(1,af,e_mat_tmp,lc) re_e_mat(:,:,iw-nbegin_g+1)=dble(e_mat_tmp(:,:,1)) im_e_mat(:,:,iw-nbegin_g+1)=dimag(e_mat_tmp(:,:,1)) else call solve_lanczos_fake_complex(lc) endif end do deallocate(e_mat_tmp) !for entire self-energy store !!!!!!!!!!!!!! if( ss%whole_s .and.l_distribute_sm ) then if( options%l_verbose) write(stdout,*) 'before allocate',lc%numt,l_blk call flush_unit(stdout) allocate(re_e_mat_t(lc%numt,lc%numt,l_blk), im_e_mat_t(lc%numt,lc%numt,l_blk)) if( options%l_verbose) write(stdout,*) 'after ' allocate(g_tmp(lc%numt,lc%numt)) allocate(g_dumm(lc%numt,lc%numt)) if( options%l_verbose) write(stdout,*) 'ATT1' call flush_unit(stdout) numt=lc%numt !loop on time do it=0,tf%n !each procs sums up its matrices in frequency with opportune factor time=tf%times(it) g_tmp(:,:)=0.d0 do iw=nbegin_g,nend_g factor=2.d0*dble(tf%weights_freq_g(iw)*exp_table(it+1,iw-nbegin_g+1))/(2.d0*pi) g_tmp(1:numt,1:numt)=g_tmp(1:numt,1:numt)+re_e_mat(1:numt,1:numt,iw-nbegin_g+1)*factor enddo #ifdef __PARA !the distribution of times on procs is the same of that for frequecies iproc_time=it/l_blk !all processors sums to iproc_time if(iproc_time==mpime) then call MPI_REDUCE(g_tmp,re_e_mat_t(1,1,it-nbegin+1),numt*numt,& &MPI_DOUBLE_PRECISION,MPI_SUM,iproc_time,world_comm,ierr) else call MPI_REDUCE(g_tmp,g_dumm,numt*numt,MPI_DOUBLE_PRECISION,& &MPI_SUM,iproc_time,world_comm,ierr) endif #else re_e_mat_t(1:numt,1:numt,it+1)=g_tmp(1:numt,1:numt) #endif enddo !loop on time do it=0,tf%n !each procs sums up its matrices in frequency with opportune factor time=tf%times(it) g_tmp(:,:)=0.d0 do iw=nbegin_g,nend_g factor=-2.d0*dimag(tf%weights_freq_g(iw)*exp_table(it+1,iw-nbegin_g+1))/(2.d0*pi) g_tmp(1:numt,1:numt)=g_tmp(1:numt,1:numt)+im_e_mat(1:numt,1:numt,iw-nbegin_g+1)*factor enddo #ifdef __PARA !the distribution of times on procs is the same of that for frequecies iproc_time=it/l_blk !all processors sums to iproc_time if(iproc_time==mpime) then call MPI_REDUCE(g_tmp,im_e_mat_t(1,1,it-nbegin+1),numt*numt,& &MPI_DOUBLE_PRECISION,MPI_SUM,iproc_time,world_comm,ierr) else call MPI_REDUCE(g_tmp,g_dumm,numt*numt,MPI_DOUBLE_PRECISION,& &MPI_SUM,iproc_time,world_comm,ierr) endif #else im_e_mat_t(1:numt,1:numt,it+1)=g_tmp(1:numt,1:numt) #endif enddo deallocate(g_tmp,g_dumm) endif if( options%l_verbose) write(stdout,*) 'ATT2' !DEBUG call flush_unit(stdout) else if(i_cycles==1) then allocate(re_e_mat_single(lc%numt,lc%numt,l_blk_g)) allocate(im_e_mat_single(lc%numt,lc%numt,l_blk_g)) endif do iw=nbegin_g,nbegin_g+l_blk_g-1 if(iw <= tf%n_g) then af(1)=dcmplx(offset,-tf%freqs_g(iw)) call solve_lanczos_single(af(1),re_e_mat_single(1,1,iw-nbegin_g+1),im_e_mat_single(1,1,iw-nbegin_g+1),lc) else call solve_lanczos_fake_single(lc) endif end do l_blk_t= (lc%numt)/ndivt if(l_blk_t*ndivt < (lc%numt)) l_blk_t = l_blk_t+1 if(i_cycles==1) allocate(e_mat_double(lc%numt,l_blk_t)) endif if( options%l_verbose) write(stdout,*) 'Done' call flush_unit(stdout) call initialize_memory(vtl) call initialize_memory(ttl) call initialize_memory(vtl_j) call initialize_memory(ttl_j) !if required read all S matrices and distribute among mpi tasks if( ss%whole_s .and.l_distribute_sm ) then l_blk_sm= (ss%max_i)/nproc if(l_blk_sm*nproc < (ss%max_i)) l_blk_sm = l_blk_sm+1 nbegin_sm=mpime*l_blk_sm+1 nend_sm=nbegin_sm+l_blk_sm-1 if(nend_sm > ss%max_i) nend_sm=ss%max_i nsize_sm=nend_sm-nbegin_sm+1 do jj=1,ss%max_i call read_data_pw_vt_mat_lanczos(vtl_j, jj, options%prefix, .false.,is) call read_data_pw_tt_mat_lanczos(ttl_j, jj, options%prefix, .false.,is) if(jj==1) then numt=ttl_j%numt numl=ttl_j%numl allocate(sl_save(numpw,numl,l_blk_sm)) allocate(st_save(numt,numl,l_blk_sm)) endif if(jj>=nbegin_sm .and. jj<=nend_sm) then st_save(1:numt,1:numl,jj-nbegin_sm+1)=ttl_j%tt_mat(1:numt,1:numl) sl_save(1:numpw,1:numl,jj-nbegin_sm+1)=vtl_j%vt_mat(1:numpw,1:numl) endif call free_memory(vtl_j) call free_memory(ttl_j) enddo allocate(re_e_mat_part(numt,numl,l_blk),im_e_mat_part(numt,numl,l_blk)) allocate(pw_part_t(numpw,numl,l_blk)) endif !loop on KS states if(options%l_big_system) then if(.not.options%l_list) then i_min_cycles=ss%i_min+i_cycles-1 i_max_cycles=i_min_cycles else i_min_cycles=i_list(i_cycles,is) i_max_cycles=i_min_cycles endif else i_min_cycles=ss%i_min i_max_cycles=ss%i_max endif do ii=i_min_cycles,i_max_cycles write(stdout,*) 'Loop on KS:',ii, is call flush_unit(stdout) !calculates G on partial basis !read vtl ttl call read_data_pw_vt_mat_lanczos(vtl, ii, options%prefix, .false.,is) call read_data_pw_tt_mat_lanczos(ttl, ii, options%prefix, .false.,is) if(ii==i_min_cycles.and.i_cycles==1) then numt=ttl%numt numl=ttl%numl allocate(re_g_mat(numl,numl,l_blk_g),im_g_mat(numl,numl,l_blk_g)) allocate(re_g_mat_t(numl,numl,l_blk),im_g_mat_t(numl,numl,l_blk)) endif !multiply and put on array !loop on frequency if(.not.ss%whole_s) then j_min=ii j_max=ii else j_min=ss%i_min_whole j_max=ss%i_max_whole endif if( options%l_verbose) write(stdout,*) 'Doing dgemms',numl,numt,numl,numpw if(ss%whole_s .and. l_distribute_sm) then!if required calculates partial products do it=nbegin,nend call dgemm('N','N',numt,numl,numt,1.d0,re_e_mat_t(1,1,it-nbegin+1),numt,& &ttl%tt_mat,numt,0.d0,re_e_mat_part(1,1,it-nbegin+1),numt) call dgemm('N','N',numt,numl,numt,1.d0,im_e_mat_t(1,1,it-nbegin+1),numt,& &ttl%tt_mat,numt,0.d0,im_e_mat_part(1,1,it-nbegin+1),numt) call dgemm('N','N',numpw,numl,numpw,1.d0,pw_mat_t(1,1,it-nbegin+1) ,numpw, & & vtl%vt_mat,numpw,0.d0,pw_part_t(1,1,it-nbegin+1),numpw) enddo endif call flush_unit(stdout) do jj=j_min,j_max if(ss%whole_s .and. l_distribute_sm) then allocate(ttl_j%tt_mat(numt,numl)) allocate(vtl_j%vt_mat(numpw,numl)) if(jj>=nbegin_sm .and. jj<=nend_sm) then vtl_j%vt_mat(1:numpw,1:numl)=sl_save(1:numpw,1:numl,jj-nbegin_sm+1) ttl_j%tt_mat(1:numt,1:numl)=st_save(1:numt,1:numl,jj-nbegin_sm+1) endif iproc=(jj-1)/l_blk_sm call mp_bcast(vtl_j%vt_mat, iproc,world_comm) call mp_bcast(ttl_j%tt_mat, iproc,world_comm) else call read_data_pw_vt_mat_lanczos(vtl_j, jj, options%prefix, .false.,is) call read_data_pw_tt_mat_lanczos(ttl_j, jj, options%prefix, .false.,is) endif if(.not.(ss%whole_s .and. l_distribute_sm)) then allocate(tmp_mat(numl,numt)) do iw=nbegin_g,nend_g if( options%l_verbose) write(stdout,*) 'Doing dgemms',numl,numt,numpw,l_blk,iw call flush_unit(stdout) if(.not.l_single) then call dgemm('T','N',numl,numt,numt,1.d0,ttl_j%tt_mat,numt,re_e_mat(1,1,iw-nbegin_g+1),numt,0.d0,tmp_mat,numl) call dgemm('N','N',numl,numl,numt,1.d0,tmp_mat,numl,ttl%tt_mat,numt,0.d0,re_g_mat(1,1,iw-nbegin_g+1),numl) call dgemm('T','N',numl,numt,numt,1.d0,ttl_j%tt_mat,numt,im_e_mat(1,1,iw-nbegin_g+1),numt,0.d0,tmp_mat,numl) call dgemm('N','N',numl,numl,numt,1.d0,tmp_mat,numl,ttl%tt_mat,numt,0.d0,im_g_mat(1,1,iw-nbegin_g+1),numl) else do in=0,ndivt-1 nbegin_t=in*l_blk_t+1 nend_t=min(nbegin_t+l_blk_t-1,lc%numt) nsize_t=nend_t-nbegin_t+1 if(nsize_t >= 1) then e_mat_double(1:lc%numt, 1:nsize_t)=dble(re_e_mat_single(1:lc%numt, nbegin_t:nend_t, iw-nbegin_g+1)) call dgemm('T','N',numl,nsize_t,numt,1.d0,ttl_j%tt_mat,numt,e_mat_double,numt,0.d0,& &tmp_mat(1,nbegin_t),numl) endif enddo if( options%l_verbose) write(stdout,*) 'ATT1'!DEBUG call flush_unit(stdout) call dgemm('N','N',numl,numl,numt,1.d0,tmp_mat,numl,ttl%tt_mat,numt,0.d0,& &re_g_mat(1,1,iw-nbegin_g+1),numl) if( options%l_verbose) write(stdout,*) 'ATT2'!DEBUG call flush_unit(stdout) do in=0,ndivt-1 nbegin_t=in*l_blk_t+1 nend_t=min(nbegin_t+l_blk_t-1,lc%numt) nsize_t=nend_t-nbegin_t+1 e_mat_double(1:lc%numt, 1:nsize_t)=dble(im_e_mat_single(1:lc%numt, nbegin_t:nend_t, iw-nbegin_g+1)) call dgemm('T','N',numl,nsize_t,numt,1.d0,ttl_j%tt_mat,numt,e_mat_double,numt,0.d0,tmp_mat(1,nbegin_t),numl) enddo if( options%l_verbose) write(stdout,*) 'ATT3'!DEBUG call flush_unit(stdout) call dgemm('N','N',numl,numl,numt,1.d0,tmp_mat,numl,ttl%tt_mat,numt,0.d0,im_g_mat(1,1,iw-nbegin_g+1),numl) endif enddo deallocate(tmp_mat) write(stdout,*) 'Fourier trasform:' call flush_unit(stdout) !Fourier trasform allocate(g_tmp(numl,numl)) allocate(g_dumm(numl,numl)) if( options%l_verbose) write(stdout,*) 'ATT1' call flush_unit(stdout) !loop on time do it=0,tf%n !each procs sums up its matrices in frequency with opportune factor time=tf%times(it) g_tmp(:,:)=0.d0 do iw=nbegin_g,nend_g !factor=2.d0*dble(tf%weights_freq_g(iw)*exp((0.d0,1.d0)*tf%times(it)*tf%freqs_g_eff(iw)))/(2.d0*pi) factor=2.d0*dble(tf%weights_freq_g(iw)*exp_table(it+1,iw-nbegin_g+1))/(2.d0*pi) g_tmp(:,:)=g_tmp(:,:)+re_g_mat(:,:,iw-nbegin_g+1)*factor enddo #ifdef __PARA !the distribution of times on procs is the same of that for frequecies iproc_time=it/l_blk !all processors sums to iproc_time if(iproc_time==mpime) then call MPI_REDUCE(g_tmp,re_g_mat_t(1,1,it-nbegin+1),numl*numl,& &MPI_DOUBLE_PRECISION,MPI_SUM,iproc_time,world_comm,ierr) else call MPI_REDUCE(g_tmp,g_dumm,numl*numl,MPI_DOUBLE_PRECISION,& &MPI_SUM,iproc_time,world_comm,ierr) endif #else re_g_mat_t(:,:,it+1)=g_tmp(:,:) #endif g_tmp(:,:)=0.d0 do iw=nbegin_g,nend_g !factor=-2.d0*dimag(tf%weights_freq_g(iw)*exp((0.d0,1.d0)*tf%times(it)*tf%freqs_g_eff(iw)))/(2.d0*pi) factor=-2.d0*dimag(tf%weights_freq_g(iw)*exp_table(it+1,iw-nbegin_g+1))/(2.d0*pi) g_tmp(:,:)=g_tmp(:,:)+im_g_mat(:,:,iw-nbegin_g+1)*factor enddo #ifdef __PARA !the distribution of times on procs is the same of that for frequecies iproc_time=it/l_blk !all processors sums to iproc_time if(iproc_time==mpime) then call MPI_REDUCE(g_tmp,im_g_mat_t(1,1,it-nbegin+1),numl*numl,& &MPI_DOUBLE_PRECISION,MPI_SUM,iproc_time,world_comm,ierr) else call MPI_REDUCE(g_tmp,g_dumm,numl*numl,MPI_DOUBLE_PRECISION,MPI_SUM,iproc_time,world_comm,ierr) endif #else im_g_mat_t(:,:,it+1)=g_tmp(:,:) #endif enddo deallocate(g_tmp,g_dumm) else!for whole self-energy calculates directly in time domain do it=nbegin,nend call dgemm('T','N',numl,numl,numt,1.d0,ttl_j%tt_mat,numt,re_e_mat_part(1,1,it-nbegin+1),& &numt,0.d0,re_g_mat_t(1,1,it-nbegin+1),numl) call dgemm('T','N',numl,numl,numt,1.d0,ttl_j%tt_mat,numt,im_e_mat_part(1,1,it-nbegin+1),& &numt,0.d0,im_g_mat_t(1,1,it-nbegin+1),numl) enddo endif if( options%l_verbose) write(stdout,*) 'done' call flush_unit(stdout) !loop on frequency write(stdout,*) 'Products in imaginary time:' call flush_unit(stdout) if( .not.(ss%whole_s .and.l_distribute_sm )) then allocate(tmp_mat(numpw,numl),re_h_mat(numpw,numpw),im_h_mat(numpw,numpw)) do it=nbegin,nend !matrix multiply call dgemm('N','N',numpw,numl,numl,1.d0,vtl_j%vt_mat,numpw,re_g_mat_t(1,1,it-nbegin+1),numl,0.d0,tmp_mat,numpw) call dgemm('N','T',numpw,numpw,numl,1.d0,tmp_mat,numpw, vtl%vt_mat,numpw,0.d0,re_h_mat,numpw) call dgemm('N','N',numpw,numl,numl,1.d0,vtl_j%vt_mat,numpw,im_g_mat_t(1,1,it-nbegin+1),numl,0.d0,tmp_mat,numpw) call dgemm('N','T',numpw,numpw,numl,1.d0,tmp_mat,numpw, vtl%vt_mat,numpw,0.d0,im_h_mat,numpw) !product if(ii==jj) then ss%diag(ii,it+ss%n+1,is)=DDOT(numpw*numpw,re_h_mat,1,pw_mat_t(1,1,it-nbegin+1),1)+& &DDOT(numpw*numpw,im_h_mat,1,pw_mat_t(1,1,it-nbegin+1),1) ss%diag(ii,ss%n+1-it,is)=DDOT(numpw*numpw,re_h_mat,1,pw_mat_t(1,1,it-nbegin+1),1)-& &DDOT(numpw*numpw,im_h_mat,1,pw_mat_t(1,1,it-nbegin+1),1) !if required add semicore terms if(options%l_semicore) then !NOT_TO_BE_INCLUDED_START allocate(tmp_vec_sc(numpw)) do iv_sc=1,sc%n_semicore if(it==0) write(stdout,*) 'SEMICORE PRIMA',iv_sc,ii, ss%diag(ii,it+ss%n+1,is) call dgemv('N',numpw,numpw,1.d0,pw_mat_t(1,1,it-nbegin+1),numpw,& &sc%ppw_mat(1,iv_sc,ii),1,0.d0,tmp_vec_sc,1) ss%diag(ii,it+ss%n+1,is)= ss%diag(ii,it+ss%n+1,is)- &!ATTENZIONE ERA + &DDOT(numpw,tmp_vec_sc,1,sc%ppw_mat(1,iv_sc,ii),1)*exp((offset+sc%en_sc(iv_sc))*tf%times(it)) if(it==0) write(stdout,*) 'SEMICORE',iv_sc,ii, ss%diag(ii,it+ss%n+1,is) if((offset+sc%en_sc(iv_sc))*tf%times(it)>0) write(stdout,*) 'OCIO!!!'!DEBUG ATTENZIONE enddo deallocate(tmp_vec_sc) !NOT_TO_BE_INCLUDED_END endif endif if(ss%whole_s) then ss%whole(jj,ii,it+ss%n+1,is)=DDOT(numpw*numpw,re_h_mat,1,pw_mat_t(1,1,it-nbegin+1),1)+& &DDOT(numpw*numpw,im_h_mat,1,pw_mat_t(1,1,it-nbegin+1),1) ss%whole(jj,ii,ss%n+1-it,is)=DDOT(numpw*numpw,re_h_mat,1,pw_mat_t(1,1,it-nbegin+1),1)-& &DDOT(numpw*numpw,im_h_mat,1,pw_mat_t(1,1,it-nbegin+1),1) endif enddo deallocate(re_h_mat,im_h_mat) deallocate(tmp_mat) else allocate(tmp_mat(numl,numl)) do it=nbegin,nend call dgemm('T','N',numl,numl,numpw,1.d0,vtl_j%vt_mat,numpw,pw_part_t(1,1,it-nbegin+1),numpw,0.d0,tmp_mat,numl) if(ii==jj) then ss%diag(ii,it+ss%n+1,is)=DDOT(numl*numl,re_g_mat_t(1,1,it-nbegin+1),1,tmp_mat,1)+& &DDOT(numl*numl,im_g_mat_t(1,1,it-nbegin+1),1,tmp_mat,1) ss%diag(ii,ss%n+1-it,is)=DDOT(numl*numl,re_g_mat_t(1,1,it-nbegin+1),1,tmp_mat,1)-& &DDOT(numl*numl,im_g_mat_t(1,1,it-nbegin+1),1,tmp_mat,1) endif ss%whole(jj,ii,it+ss%n+1,is)=DDOT(numl*numl,re_g_mat_t(1,1,it-nbegin+1),1,tmp_mat,1)+& &DDOT(numl*numl,im_g_mat_t(1,1,it-nbegin+1),1,tmp_mat,1) ss%whole(jj,ii,ss%n+1-it,is)=DDOT(numl*numl,re_g_mat_t(1,1,it-nbegin+1),1,tmp_mat,1)-& &DDOT(numl*numl,im_g_mat_t(1,1,it-nbegin+1),1,tmp_mat,1) enddo deallocate(tmp_mat) endif if( options%l_verbose) write(stdout,*) 'done' call flush_unit(stdout) !mp_sum for distributing on all processors if(ii==jj) then call mp_sum(ss%diag(ii,1:2*ss%n+1,is),world_comm) endif if(ss%whole_s) then call mp_sum(ss%whole(jj,ii,1:2*ss%n+1,is),world_comm) endif !FT of diagonal part of self-nergy !deallocate(re_g_mat_t, im_g_mat_t) call free_memory(vtl_j) call free_memory(ttl_j) enddo !jj call free_memory(vtl) call free_memory(ttl) enddo!on i_min, i_max enddo!on i_cycles !put factor due to FFT on imaginary axis ss%diag(:,:,is)=ss%diag(:,:,is)*(0.d0,1.d0) if(ss%whole_s) then ss%whole(:,:,:,is)=ss%whole(:,:,:,is)*(0.d0,1.d0) endif deallocate(re_g_mat,im_g_mat) deallocate(re_g_mat_t,im_g_mat_t) deallocate(pw_mat_t) if(.not.l_single) then deallocate(re_e_mat,im_e_mat) else deallocate(re_e_mat_single, im_e_mat_single, e_mat_double) endif if( ss%whole_s .and.l_distribute_sm ) then deallocate(st_save,sl_save) if(.not.l_single) deallocate(re_e_mat_t,im_e_mat_t) if(.not.l_single) deallocate(re_e_mat_part,im_e_mat_part,pw_part_t) endif deallocate(exp_table) call free_memory(lc) enddo!on spin call free_memory(uu) call free_memory(sc) return end subroutine do_self_lanczos_time subroutine solve_lanczos_single(alpha,re_e_mat,im_e_mat,lc) !this subroutine sums to the matrix E_{no}= USE kinds, ONLY : DP USE basic_structures, ONLY : lanczos_chain, initialize_memory,free_memory USE io_global, ONLY : stdout USE mp, ONLY : mp_sum,mp_bcast USE mp_world, ONLY : nproc, mpime, world_comm implicit none COMPLEX(kind=DP) :: alpha!constant for Ev+iw TYPE(lanczos_chain) :: lc!lanczos chain descriptor REAL(kind=4) :: re_e_mat(lc%numt,lc%numt) !real part of matrix to be calculated REAL(kind=4) :: im_e_mat(lc%numt,lc%numt) !imaginary part of matrix to be calculated INTEGER :: io,info,ii,jj COMPLEX(kind=DP), ALLOCATABLE :: dl(:),du(:),d(:),t(:) COMPLEX(kind=DP), ALLOCATABLE :: omat(:,:) REAL(kind=DP), ALLOCATABLE :: tmp_mat(:,:) INTEGER :: l_blk,nbegin,nend, iproc COMPLEX(kind=DP), ALLOCATABLE :: e_mat(:) l_blk= (lc%numt)/nproc if(l_blk*nproc < (lc%numt)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 allocate(dl(lc%num_steps-1),du(lc%num_steps-1),d(lc%num_steps),t(lc%num_steps)) re_e_mat(:,:)=0.0 im_e_mat(:,:)=0.0 allocate(omat(lc%numt,lc%num_steps)) allocate(tmp_mat(lc%numt,lc%num_steps)) allocate(e_mat(lc%numt)) !loop on o do io=1,lc%numt !!set up vectors for lapack routine !recover matrix from processor tmp_mat(:,:)=0.d0 if(io >= nbegin .and. io <= nend) then tmp_mat(1:lc%numt,1:lc%num_steps)=lc%o_mat(1:lc%numt,1:lc%num_steps,io-nbegin+1) endif iproc=(io-1)/l_blk call mp_bcast(tmp_mat(:,:), iproc, world_comm) omat(:,:)=dcmplx(tmp_mat(:,:),0.d0) dl(1:lc%num_steps-1)=cmplx(lc%f(1:lc%num_steps-1,io),0.d0) du(1:lc%num_steps-1)=cmplx(lc%f(1:lc%num_steps-1,io),0.d0) d(1:lc%num_steps)=cmplx(lc%d(1:lc%num_steps,io),0.d0)+alpha t(:)=(0.d0,0.d0) t(1)=(1.d0,0.d0) !!call lapack call zgtsv(lc%num_steps,1,dl,d,du,t,lc%num_steps,info) if(info /= 0) then write(stdout,*) 'ZGTSV info:', info call flush_unit(stdout) stop endif !!calculate term call zgemm('N','N',lc%numt,1,lc%num_steps,(1.d0,0.d0),omat,lc%numt,t,lc%num_steps,(0.d0,0.d0),e_mat,lc%numt) re_e_mat(1:lc%numt,io)=re_e_mat(1:lc%numt,io)+real(e_mat(1:lc%numt)) im_e_mat(1:lc%numt,io)=im_e_mat(1:lc%numt,io)+imag(e_mat(1:lc%numt)) enddo do ii=1,lc%numt do jj=ii+1,lc%numt re_e_mat(ii,jj)=0.5*(re_e_mat(ii,jj)+re_e_mat(jj,ii)) re_e_mat(jj,ii)=re_e_mat(ii,jj) im_e_mat(ii,jj)=0.5*(im_e_mat(ii,jj)+im_e_mat(jj,ii)) im_e_mat(jj,ii)=im_e_mat(ii,jj) enddo enddo deallocate(dl,du,d,t) deallocate(omat,tmp_mat) deallocate(e_mat) return end subroutine solve_lanczos_single subroutine solve_lanczos_fake_single(lc) !this subroutine is a parallel fake routine for the solve lanczos routine USE kinds, ONLY : DP USE basic_structures, ONLY : lanczos_chain, initialize_memory,free_memory USE io_global, ONLY : stdout USE mp, ONLY : mp_sum,mp_bcast USE mp_world, ONLY : nproc,mpime,world_comm implicit none TYPE(lanczos_chain) :: lc!lanczos chain descriptor INTEGER :: l_blk,nbegin,nend, iproc REAL(kind=DP), ALLOCATABLE :: o_mat(:,:) INTEGER :: io allocate(o_mat(lc%numt,lc%num_steps)) l_blk= (lc%numt)/nproc if(l_blk*nproc < (lc%numt)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 !loop on io do io=1,lc%numt !recover matrix from processor o_mat(:,:)=0.d0 if(io >= nbegin .and. io <= nend) then o_mat(:,:)=lc%o_mat(:,:,io-nbegin+1) endif iproc=(io-1)/l_blk call mp_bcast(o_mat(:,:), iproc, world_comm) enddo deallocate(o_mat) end subroutine solve_lanczos_fake_single GWW/gww/go_fft.f900000644000077300007730000002100412341332532014375 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! SUBROUTINE go_fft(tf, options) !this subroutine perform FFT on polarization written on disk USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode USE input_gw, ONLY : input_options USE polarization, ONLY : polaw,free_memory_polaw,read_polaw USE fft_gw USE times_gw, ONLY : times_freqs implicit none TYPE(times_freqs) :: tf TYPE(input_options) :: options! for imaginary time range,number of samples and number of rows TYPE(fft_data) :: fftd TYPE(polaw) :: pw INTEGER :: iw INTEGER :: numpw INTEGER :: firstr,lastr !read in polarization for checks if(ionode) then !ATTENZIONE provvisorio call read_polaw(options%n,pw,options%debug,options%l_verbose) numpw=pw%numpw if(numpw < options%num_rows) then write(stdout,*) 'Routine go_fft: num_rows too big' stop endif call free_memory_polaw(pw) !first loop, construct fftd and save on disk do iw=1,ceiling(real(numpw)/real(options%num_rows)) !set limits firstr=(iw-1)*options%num_rows+1 lastr=iw*options%num_rows if(lastr > numpw) lastr=numpw !create fft descriptor call create_fft_data(tf,firstr,lastr,options%tau,options%n,iw,fftd,options%debug) !write on file call write_fft_data(fftd,options%debug) enddo !sencond loop, read fftd, perform fftd, and update polaw's do iw=1,ceiling(real(numpw)/real(options%num_rows)) !set limits firstr=(iw-1)*options%num_rows+1 lastr=iw*options%num_rows if(lastr > numpw) lastr=numpw ! read fftd descriptor call read_fft_data(iw,fftd,options%debug) !do fft call transform_fft_data(fftd) !update polaw's call save_fft_data(tf,fftd,options%debug) call write_fft_data(fftd,options%debug) enddo endif call free_memory_fft_data(fftd) return END SUBROUTINE go_fft SUBROUTINE go_fft_para(tf, options) !this subroutine perform FFT on polarization written on disk USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode USE input_gw, ONLY : input_options USE polarization, ONLY : polaw,free_memory_polaw,read_polaw_range, initialize_polaw,& &fake_polarization_io USE fft_gw USE mp_world, ONLY : world_comm, mpime, nproc USE mp, ONLY : mp_barrier USE times_gw, ONLY : times_freqs implicit none TYPE(times_freqs), INTENT(in) :: tf!for time and frequency grids TYPE(input_options), INTENT(in) :: options! for imaginary time range,number of samples and number of rows TYPE(fft_data) :: fftd TYPE(polaw) :: pw INTEGER :: iw INTEGER :: numpw INTEGER :: firstr,lastr INTEGER :: number_fft LOGICAL, ALLOCATABLE :: is_my_fft(:) INTEGER number_my_fft, done_fft, fft_first INTEGER :: iqq,ndelta, it, ip LOGICAL :: ontime !read in polarization for checks call initialize_polaw(pw) call read_polaw_range(options%n,pw,options%debug,1,1,.true.) numpw = pw%numpw ontime = pw%ontime if(numpw < options%num_rows) then write(stdout,*) 'Routine go_fft: num_rows too big' stop endif write(stdout,*) 'Prima'!ATTENZIONE call free_memory_polaw(pw) number_fft = ceiling(real(numpw)/real(options%num_rows)) number_my_fft=0 ndelta = number_fft / nproc if( nproc*ndelta < number_fft ) ndelta = ndelta + 1 allocate( is_my_fft( 0 : nproc*ndelta ) ) is_my_fft(:)=.false. iqq = 1 fft_first = -1 do ip = 0, nproc - 1 do it = 1, ndelta ! write(stdout,*) 'fft -> ', ip, it, iqq, number_fft if( iqq <= number_fft .and. ( mpime == ip ) ) then if(fft_first == -1) fft_first = iqq is_my_fft( iqq ) = .true. number_my_fft = number_my_fft + 1 endif iqq = iqq + 1 enddo enddo call mp_barrier( world_comm ) !sencond loop, read fftd, perform fftd, and update polaw's done_fft=0 do it = 1, ndelta iw = it + fft_first - 1 if( is_my_fft( iw ) .and. fft_first /= -1 ) then done_fft=done_fft+1 !set limits firstr=(iw-1)*options%num_rows+1 lastr=iw*options%num_rows ! write(stdout,*) 'Continue FFT: ',iw , firstr, lastr, numpw if(lastr > numpw) lastr=numpw ! read fftd descriptor write(stdout,*) 'Create iw = ', iw ! ATTENZIONE call create_fft_data(tf,firstr,lastr,options%tau,options%n,iw,fftd,options%debug) ! avoid reading time/freq parameter from matrix, ! use the one read at the beginning. fftd%ontime = ontime !do fft write(stdout,*) 'Transform'!ATTENZIONE if(options%l_fft_timefreq) then call transform_fft_data(fftd) else call transform_fft_data_grid(tf,fftd) endif !update polaw's write(stdout,*) 'Save'!ATTENZIONE call save_fft_data(tf,fftd,options%debug) else call fake_polarization_io(options%n) endif enddo call free_memory_fft_data(fftd) deallocate(is_my_fft) return END SUBROUTINE go_fft_para SUBROUTINE go_fft_para2(tf, options) !this subroutine perform FFT on polarization written on disk USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode USE input_gw, ONLY : input_options USE polarization, ONLY : polaw,free_memory_polaw,read_polaw_range, initialize_polaw,& &fake_polarization_io USE fft_gw USE mp_world, ONLY : world_comm, mpime, nproc, root USE mp, ONLY : mp_barrier, mp_bcast USE times_gw, ONLY : times_freqs implicit none TYPE(times_freqs), INTENT(in) :: tf!for time and frequency grids TYPE(input_options), INTENT(in) :: options! for imaginary time range,number of samples and number of rows TYPE(fft_data) :: fftd TYPE(polaw) :: pw INTEGER :: iw INTEGER :: numpw INTEGER :: firstr,lastr INTEGER :: number_fft INTEGER number_my_fft, done_fft, fft_first INTEGER :: iqq,ndelta, it, ip, iblk, ipown LOGICAL :: ontime COMPLEX(kind=DP) :: factor !read in polarization for checks call initialize_polaw( pw ) write(stdout,*) 'Routine go_fft_para2'!ATTENZIONE call flush_unit(stdout) ipown = 0 if( mpime == ipown ) then write(stdout,*) 'Prima read_polaw_range'!ATTENZIONE call read_polaw_range( 0, pw, options%debug, 1, 1, .true. ) write(stdout,*) 'Dopo read_polaw_range'!ATTENZIONE end if call mp_bcast( pw%numpw, ipown, world_comm ) call mp_bcast( pw%ontime, ipown, world_comm ) call mp_bcast( pw%factor, ipown, world_comm ) numpw = pw%numpw ontime = pw%ontime factor = pw%factor if( numpw < options%num_rows ) then write(stdout,*) 'Routine go_fft: num_rows too big' stop endif write(stdout,*) 'Prima',factor!ATTENZIONE call free_memory_polaw(pw) ! ! options%num_rows, number of rows to be read by each proc. ! from its own files ! number_fft, number of collective read cycles ! number_fft = ceiling( real(numpw)/ real(options%num_rows) ) call mp_barrier( world_comm ) do iblk = 1, number_fft ! firstr = (iblk-1) * options%num_rows + 1 lastr = (iblk ) * options%num_rows if( lastr > numpw ) lastr = numpw ! fftd%ontime = ontime fftd%numpw = numpw fftd%factor = factor CALL create_fft_data2( tf, firstr, lastr, options%tau, options%n, fftd, options%debug ) write(stdout,*) 'Transform'!ATTENZIONE call flush_unit(stdout) if( options%l_fft_timefreq ) then call transform_fft_data( fftd ) else call transform_fft_data_grid( tf, fftd ) endif write(stdout,*) 'Save'!ATTENZIONE call flush_unit(stdout) call save_fft_data2( tf, fftd, options%debug ) end do call free_memory_fft_data(fftd) return END SUBROUTINE go_fft_para2 GWW/gww/gww_fit.f900000644000077300007730000001352012341332532014603 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! PROGRAM gww_fit USE input_gw, ONLY : input_options, read_input_gww USE io_global, ONLY : stdout, ionode USE self_energy_storage USE expansion USE energies_gww USE start_end USE mp_world, ONLY : mpime USE para_gww USE times_gw USE w_divergence USE constants, ONLY : RYTOEV USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(input_options) :: options TYPE(self_storage) :: ss TYPE(self_expansion) :: se TYPE(self_on_real) :: sr TYPE(quasi_particles) :: qp TYPE(times_freqs) :: tf TYPE(gv_time) :: gt INTEGER :: ii, jj, iun1,iun2,iun,idumm, it REAL(kind=DP) :: rdumm1,rdumm2,rdumm3,ss_r,ss_i,ddumm CHARACTER(5) :: nfile COMPLEX(kind=DP) :: zz, sigmac,dsigmac REAL(kind=DP) :: offset INTEGER :: i_homo INTEGER :: ifil!DEBUG INTEGER, ALLOCATABLE :: order(:) !setup MPI environment call startup write(stdout,*) 'PROGRAM GWW-FIT: Version 0.2' !initialize arrays call initialize_quasi_particle(qp) call initialize_self_storage(ss) call initialize_self_on_real(sr) ! read in input structure call read_input_gww(options) call flush_unit(stdout) call setup_para_gww(options%n, options%max_i, options%i_min, options%i_max) ! setup time/frequency grid if required call setup_timefreq(tf,options) call flush_unit(stdout) ! call test_fft(tf) !read in LDA and HF energies from bands.dat qp%max_i=options%max_i qp%nspin=options%nspin allocate(qp%ene_dft_ks(options%max_i,qp%nspin)) allocate(qp%ene_hf(options%max_i,qp%nspin)) allocate(qp%ene_gw(options%max_i,qp%nspin)) allocate(qp%ene_gw_pert(options%max_i,qp%nspin)) allocate(order(options%max_i)) open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'bands.dat', status='old',form='formatted') read(iun,*) i_homo do ii=1,options%max_i read(iun,*) idumm,qp%ene_dft_ks(ii,1),rdumm1,rdumm2,qp%ene_hf(ii,1) enddo close(iun) qp%ene_dft_ks(:,1)=qp%ene_dft_ks(:,1)/RYTOEV qp%ene_hf(:,1)=qp%ene_hf(:,1)/RYTOEV !setup ss and read in date from fit graphs ss%ontime=.false. ss%whole_s=.false. ss%n=options%n ss%n_grid_fit=options%n_grid_fit ss%max_i=options%max_i ss%i_min=options%i_min ss%i_max=options%i_max ss%tau=options%tau ss%nspin=1 if(options%l_order) then open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'order.dat', status='old',form='formatted') do ii=1,options%max_i read(iun,*) idumm,order(ii),ddumm enddo close(iun) else do ii=1,options%max_i order(ii)=ii enddo endif allocate(ss%diag_freq_fit(ss%max_i,2*ss%n_grid_fit+1,1)) do ii=ss%i_min,ss%i_max write(nfile,'(5i1)') & & order(ii)/10000,mod(order(ii),10000)/1000,mod(order(ii),1000)/100,mod(order(ii),100)/10,mod(order(ii),10) !ifil=ii-4 !write(nfile,'(5i1)') & ! & ifil/10000,mod(ifil,10000)/1000,mod(ifil,1000)/100,mod(ifil,100)/10,mod(ifil,10) iun1 = find_free_unit() open( unit=iun1, file=trim(tmp_dir)//trim(prefix)//'-'//'re_on_im'// nfile, status='old',form='formatted') open( unit=iun2, file=trim(tmp_dir)//trim(prefix)//'-'//'im_on_im'// nfile, status='old',form='formatted') do jj=-ss%n_grid_fit,ss%n_grid_fit read(iun1,*) rdumm1,rdumm2,ss_r,rdumm3 read(iun2,*) rdumm1,rdumm2,ss_i,rdumm3 ss%diag_freq_fit(ii,jj+ss%n_grid_fit+1,1)=cmplx(ss_r,ss_i) enddo close(iun1) close(iun2) enddo if(options%n_real_axis>=0) then call create_self_on_real(options, sr) endif call create_self_energy_fit( tf, se, ss, options,sr,.false.) call free_memory_self_storage(ss) call free_memory_self_on_real(sr) offset=-(qp%ene_dft_ks(i_homo+1,1)+qp%ene_dft_ks(i_homo,1))/2.d0 !offset=-(6.07889+6.75583)/2.d0/13.606d0!DEBUG do ii=options%i_min,options%i_max call value_on_frequency(se,ii,qp%ene_dft_ks(ii,1)+offset,sigmac,1) call derivative_on_frequency(se,ii,qp%ene_dft_ks(ii,1)+offset,dsigmac,1) write(stdout,*) 'value, zeta:',ii,sigmac,dsigmac,offset zz=(1.d0,0.d0)-dsigmac qp%ene_gw(ii,1)=qp%ene_dft_ks(ii,1)+offset +& (sigmac+qp%ene_hf(ii,1)-qp%ene_dft_ks(ii,1))/zz write(stdout,*) 'GW-PERT energy', ii,real(qp%ene_gw(ii,1)-offset)*RYTOEV qp%ene_gw_pert(ii,1)=qp%ene_gw(ii,1)-offset !self-consistency loop do it=1,10 call value_on_frequency_complex(se,ii,qp%ene_gw(ii,1),sigmac,1) write(stdout,*) 'Iteration energy',it,sigmac qp%ene_gw(ii,1)=qp%ene_dft_ks(ii,1)+offset+sigmac+qp%ene_hf(ii,1)-qp%ene_dft_ks(ii,1) enddo qp%ene_gw(ii,1)= qp%ene_gw(ii,1)-offset enddo !call create_quasi_particles(options,qp,se) call free_memory_self_expansion(se) if(ionode) then write(stdout,*) 'QUASI-PARTICLES ENERGIES IN Ev:' do ii=options%i_min,options%i_max write(stdout,'(''State:'',i5,''LDA :'',f10.5,'' GW-PERT :'',f10.5,'' GW :'',f10.5, & & '' HF-pert :'',f10.5)') & & ii,qp%ene_dft_ks(ii,1)*RYTOEV, real(qp%ene_gw_pert(ii,1))*RYTOEV, & & real(qp%ene_gw(ii,1))*RYTOEV,qp%ene_hf(ii,1)*RYTOEV enddo write(stdout,*) 'IMAGINARY ENERGIES IN Ev:' do ii=options%i_min,options%i_max write(stdout,'(''State:'',i5,'' GW (Im) :'',f10.5)') ii,aimag(qp%ene_gw(ii,1))*RYTOEV enddo endif deallocate(order) !stops MPI call free_memory_times_freqs(tf) call free_memory_para_gww call stop_run stop END PROGRAM gww_fit GWW/gww/basic_structures.f900000644000077300007730000004771612341332532016537 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! MODULE basic_structures !this module describes the basis structures !which are obtained from a DFT code USE kinds, ONLY : DP TYPE wannier_u !this structure describes the transformation !from KS to Wannier states together with the KS eigenenergies INTEGER :: nspin!spin multiplicity INTEGER :: nums!number of states INTEGER :: nums_occ(2)!number of occupied states for the two spin channnels REAL(kind=DP), DIMENSION(:,:), POINTER :: ene!KS energies REAL(kind=DP), DIMENSION(:,:), POINTER :: ene_xc!LDA exchange and correlation terms REAL(kind=DP), DIMENSION(:,:), POINTER :: ene_lda_h!LDA exchange and correlation terms COMPLEX(kind=DP), DIMENSION(:,:,:), POINTER :: umat!INVERSE transformation matrix to wannier: Psi_i=U_{i,j}w_j END TYPE wannier_u TYPE wannier_P !this structure described the localized and normalized products of wanniers w_P INTEGER :: numij!number of (unordered)couples of wannier w_i w_j which overlap both with w_P INTEGER, DIMENSION(:,:), POINTER :: ij!array for i,j (ij,:) REAL(kind=DP),DIMENSION(:), POINTER :: o!overlap END TYPE wannier_P TYPE v_pot !this structure describes the coulomb potential on the base of (orthonormalized) !products of wanniers INTEGER :: numpw!number of states(products) REAL(kind=DP),DIMENSION(:,:), POINTER :: vmat!potentail 1/|r-r'| END TYPE v_pot TYPE q_mat !this structures describes the set of overlap of othonormalized products !of wanniers with products of wannier INTEGER :: numpw!number of states(orthonormalized products) !parameters used for parallelization LOGICAL :: is_parallel!if true is a parallel part of the global q_mat matrix INTEGER :: numpw_para!numer of states(orthonormalized products) on this processor INTEGER :: first_para!first state (orthonormalized products, global order)on this processor TYPE(wannier_P), DIMENSION(:), POINTER :: wp!arrays of wannier products descriptors END TYPE q_mat TYPE ortho_polaw !this structure describe the orthonormalization matrix !w^P_i=A_{i,j}\tilde{w^P}_j !it is put here because it's read from a PW file INTEGER :: numpw!number of states (products of wanniers) LOGICAL :: inverse!if true, the inverse transform is stored REAL(kind=DP), DIMENSION(:,:), POINTER :: on_mat!the transformation END TYPE ortho_polaw TYPE wp_psi !this structure describe the product of KS wavefunctions with unorthonormalized !products of wannier \int dr w^P_i(r) w^P_j(r) Psi_v(r) Psi_v(r) INTEGER :: numpw!number of states (products of wanniers) INTEGER :: nums_psi!number of states (KS) REAL(kind=DP), DIMENSION(:,:,:), POINTER :: wwp!terms END TYPE wp_psi TYPE wannier_u_prim !this structure describes the transformation !from KS to Wannier states in the manifold C' INTEGER :: nums!total number of states INTEGER :: nums_occ!number of occupied states INTEGER :: nums_prim!number of states in manifold C' COMPLEX(kind=DP), DIMENSION(:,:), POINTER :: umat!INVERSE transformation matrix to wannier: Psi_c'=U_{c',j}w_j END TYPE wannier_u_prim TYPE v_pot_prim !this structure describes the terms <\tilde{w}^P'_i|V|\tilde{w}^P_j'> INTEGER :: numpw!number of states (products of wanniers) INTEGER :: numpw_prim!number of states in manifold C' (products of wanniers) INTEGER, DIMENSION(:,:), POINTER :: ij!array of dimesion(2,numpw_prim) defining the product of w^C'*w^C REAL(kind=DP), DIMENSION(:,:), POINTER :: vmat!coulumbian matrix LOGICAL :: is_parallel!if true is a parallel part of the global cprim_prod matrix on polarization basis INTEGER :: numpw_para!numer of states(orthonormalized products) on this processor INTEGER :: first_para!first state (orthonormalized products, global order)on this processor END TYPE v_pot_prim TYPE wp_psi_cutoff_index !this structure contains the indices for the description of terms \int Psi_i(r)\tilde{w}^P_i\tilde{w}^P_jPsi_i(r)dr INTEGER :: numpw!number of states (products of wanniers) INTEGER :: nums_psi!number of states (KS) INTEGER :: numpwpw!number of products of wannier products INTEGER, DIMENSION(:,:), POINTER :: index! of dimension (2,numpwpw) indices to wannier products END TYPE wp_psi_cutoff_index TYPE wp_psi_cutoff_data !this structure contains the data for the description of terms \int Psi_i(r)\tilde{w}^P_i\tilde{w}^P_jPsi_i(r)dr INTEGER :: numpw!number of states (products of wanniers) INTEGER :: nums_psi!number of states (KS) INTEGER :: numpwpw!number of products of wannier products REAL(kind=DP), DIMENSION(:,:), POINTER :: wwp! of dimension (numpwpw,nums_psi) END TYPE wp_psi_cutoff_data TYPE head_epsilon !this structure contains the data for the descrpition of the head of the dielectric matrix !calculated accurately with k_points sampling !it also contains the data for the treatment of the wings INTEGER :: n!number of frequency steps REAL(kind=DP) :: omega!frequency range REAL(kind=DP), DIMENSION(:), POINTER :: freqs!frequency steps 2n+1 REAL(kind=DP), DIMENSION(:,:), POINTER :: head!elements G=0,G=0 of the dielectric matrix INTEGER :: numpw!number of products of wanniers REAL(kind=DP), DIMENSION(:), POINTER :: gzero!G=0 elements of non orthogonal products of wanniers \tilde{w^P} REAL(kind=DP), DIMENSION(:,:,:), POINTER :: wing!contains the terms \Sum_G \epsilon(G,G'=0; iw) REAL(kind=DP), DIMENSION(:,:,:), POINTER :: wing_c!contains the terms \Sum_G \epsilon(G=0,G'; iw) END TYPE head_epsilon TYPE cprim_prod !this structure contains the terms \int Psi_c'(r) Psi_c(r) v(r,r') \tilde{w^P_i}dr dr' !it can contain also the terms \int Psi_i(r) Psi_v,c(r) v(r,r') \tilde{w^P_i}dr dr' !it can contain also the terms \int Psi_v(r) Psi_c(r) \tilde{w^P_i} dr INTEGER :: cprim!conduction band considered INTEGER :: nums!total number of states INTEGER :: nums_occ!number of occupied states INTEGER :: nums_cond!total number of conduction states INTEGER :: numpw!number of products of wanniers REAL(kind=DP), DIMENSION(:,:), POINTER :: cpmat!product terms INTEGER :: lda!leading dimension of cpmat important for parallel execution LOGICAL :: is_parallel!if true is a parallel part of the global cprim_prod matrix on polarization basis INTEGER :: numpw_para!numer of states(orthonormalized products) on this processor INTEGER :: first_para!first state (orthonormalized products, global order)on this processor END TYPE cprim_prod TYPE upper_states !this structure contains the data for the reduced upper states INTEGER :: nums!total number of REGULAR states INTEGER :: nums_occ!number of occupied states INTEGER :: nums_reduced!number of reduced states INTEGER :: nums_tot!number of TOTAL states REAL(kind=DP), DIMENSION(:), POINTER :: ene!KS energies of reduced states END TYPE upper_states TYPE vt_mat_lanczos !this structure describes the terms !V^v_{v,l}= !where {z^v_l} is an orthonormal basis set which depends on v INTEGER :: ii!state v INTEGER :: nums_occ!number of valence states INTEGER :: numpw!dimension of polarization basis INTEGER :: numl!number orthonormal states {z^v_l} REAL(kind=DP), DIMENSION(:,:), POINTER :: vt_mat!matrix (numpw, numl) END TYPE vt_mat_lanczos TYPE tt_mat_lanczos !this structure describes the terms !T^v_{i,j}= !where {t_j} is an orthonormal basis set spanning the whole manifold !of the {z^v_l} for all the v INTEGER :: numt!dimension of the basis {t_j} INTEGER :: numl!number orthonormal states {z^v_l} INTEGER :: ii!state v REAL(kind=DP), DIMENSION(:,:), POINTER :: tt_mat!matrix (numt,numl) END TYPE tt_mat_lanczos TYPE mat_lanczos_full !this structures describes the terms !M^{i,s}_{\mu\alpha}=<\psi_{i,s}(v\Phi_\mu)|\svev_\alpha} INTEGER :: ii!state KS INTEGER :: numpw!dimension of polarization basis INTEGER :: nums!number of global s vectors COMPLEX(kind=DP), DIMENSION(:,:,:), POINTER :: f_mat(:,:,:)!(numpw,nums,2) END TYPE mat_lanczos_full TYPE lanczos_chain !this structure described the lanczos chains and relative overlap !starting from a basis set {t_j} INTEGER :: numt!dimension of the basis {t_j} INTEGER :: num_steps!number of lanczos steps INTEGER :: ii!index of corresponding KS state not used for polarization REAL(kind=DP), DIMENSION(:,:,:), POINTER :: o_mat! (numt,num_steps,numt) overlaps !with s^j_l l-th lanczos vector staring from t_j REAL(kind=DP), DIMENSION(:,:), POINTER :: d!diagonal terms of H operator (num_steps,numt) REAL(kind=DP), DIMENSION(:,:), POINTER :: f!upper diagonal terms of H operator (num_steps,numt) END TYPE lanczos_chain TYPE partial_occ !this structure described the date for treating partially occupied states when calculating P INTEGER :: nums_occ!total number of occupied states (also partially) INTEGER :: nums_occ_min!total number of fully occupied states INTEGER :: numpw!dimension of polarizability basis REAL(kind=DP), DIMENSION(:), POINTER :: f_occ!occupations of KS states REAL(kind=DP), DIMENSION(:,:,:), POINTER :: ppp_mat!overlaps psi_v(r)psi_v'(r)phi_mu(r) END TYPE partial_occ TYPE semicore !this structure contains the terms \inr dr psi_i(r)\psi^sc_v(r)\Phi_mu(r) !and the energies of semicore states INTEGER :: numpw!dimension of polarizability basis INTEGER :: n_semicore!number of semicore states INTEGER :: nums!number of KS states REAL(kind=DP), DIMENSION(:), POINTER :: en_sc!semicore energies in Ry REAL(kind=DP), DIMENSION(:,:,:), POINTER :: ppw_mat!overlaps dimension:numpw,n_semicore,nums END TYPE semicore TYPE contour_terms !this structure contains the terms INTEGER :: nums!number of KS states INTEGER :: numt!dimension of global s basis REAL(kind=DP), DIMENSION(:,:),POINTER :: cmat!the overlaps END TYPE contour_terms TYPE full_prods !this structure contains the terms \int dr conjg(\psi_i(r))\psi_j(r)(v\phi_\mu)(r) !for full relativistic calculations INTEGER :: nums!number of KS states of iterest INTEGER :: nbnd!total number of KS states INTEGER :: numpw!dimension of polarizability basis INTEGER :: numv!number of occupied valence states REAL(kind=DP), DIMENSION(:), POINTER :: ene_ks!KS energies (nbnd) COMPLEX(kind=DP), DIMENSION(:,:,:,:), POINTER :: gmat!product terms (numpw,2,nbnd,nums) END TYPE full_prods !these routines deallocate the allocates structures INTERFACE free_memory MODULE PROCEDURE free_wannier_u,free_wannier_P,free_v_pot, free_q_mat, free_memory_ortho_polaw, & &free_memory_wp_psi, free_memory_wannier_u_prim, free_memory_v_pot_prim, free_memory_wp_psi_cutoff_index,& &free_memory_wp_psi_cutoff_data, free_memory_head_epsilon, free_cprim_prod, free_memory_upper_states,& free_memory_vt_mat_lanczos, free_memory_tt_mat_lanczos, free_memory_lanczos_chain, free_memory_partial_occ,& free_memory_semicore,free_memory_contour_terms,free_memory_mat_lanczos_full,free_memory_full_prods END INTERFACE INTERFACE initialize_memory MODULE PROCEDURE initialize_memory_cprim_prod, initialize_memory_upper_states,initialize_memory_vt_mat_lanczos,& initialize_memory_tt_mat_lanczos,initialize_memory_lanczos_chain,initialize_memory_partial_occ,& initialize_memory_semicore,initialize_memory_contour_terms,initialize_memory_mat_lanczos_full,& initialize_memory_full_prods END INTERFACE CONTAINS subroutine free_wannier_u( r) implicit none type(wannier_u) :: r if(associated(r%ene)) deallocate(r%ene) nullify(r%ene) if(associated(r%umat)) deallocate(r%umat) nullify(r%umat) if(associated(r%ene_xc)) deallocate(r%ene_xc) nullify(r%ene_xc) if(associated(r%ene_lda_h)) deallocate(r%ene_lda_h) nullify(r%ene_lda_h) return end subroutine free_wannier_u subroutine free_wannier_P( w_P) implicit none type(wannier_P) :: w_P if(associated(w_P%ij)) deallocate(w_P%ij) nullify(w_P%ij) if(associated(w_P%o)) deallocate(w_P%o) nullify(w_P%o) return end subroutine free_wannier_P subroutine free_v_pot(vp) implicit none type(v_pot) :: vp if(associated(vp%vmat)) deallocate(vp%vmat) nullify(vp%vmat) return end subroutine free_v_pot subroutine free_q_mat( qm) implicit none type(q_mat) :: qm integer :: iw if(associated(qm%wp)) then do iw=1,qm%numpw_para call free_wannier_P(qm%wp(iw)) enddo deallocate(qm%wp) nullify(qm%wp) endif return end subroutine free_q_mat SUBROUTINE free_memory_ortho_polaw(op) !this subroutine deallocates the green descriptor implicit none TYPE(ortho_polaw) op if(associated(op%on_mat)) deallocate(op%on_mat) nullify(op%on_mat) return END SUBROUTINE free_memory_ortho_polaw SUBROUTINE free_memory_wp_psi( wp) implicit none TYPE(wp_psi) :: wp if(associated(wp%wwp)) deallocate(wp%wwp) nullify(wp%wwp) return END SUBROUTINE free_memory_wp_psi SUBROUTINE free_memory_wannier_u_prim( ww) implicit none TYPE(wannier_u_prim) :: ww if(associated(ww%umat)) deallocate(ww%umat) nullify(ww%umat) return END SUBROUTINE free_memory_wannier_u_prim SUBROUTINE free_memory_v_pot_prim(vp) implicit none TYPE(v_pot_prim) :: vp if(associated(vp%ij)) deallocate(vp%ij) nullify(vp%ij) if(associated(vp%vmat)) deallocate(vp%vmat) nullify(vp%vmat) END SUBROUTINE free_memory_v_pot_prim SUBROUTINE free_memory_wp_psi_cutoff_index(wpi) implicit none TYPE(wp_psi_cutoff_index) :: wpi if(associated(wpi%index)) deallocate(wpi%index) nullify(wpi%index) return END SUBROUTINE free_memory_wp_psi_cutoff_index SUBROUTINE free_memory_wp_psi_cutoff_data(wp) implicit none TYPE(wp_psi_cutoff_data) :: wp if(associated(wp%wwp)) deallocate(wp%wwp) nullify(wp%wwp) return END SUBROUTINE free_memory_wp_psi_cutoff_data SUBROUTINE free_memory_head_epsilon(he) implicit none TYPE(head_epsilon) :: he if(associated(he%freqs)) deallocate(he%freqs) nullify(he%freqs) if(associated(he%head)) deallocate(he%head) nullify(he%head) if(associated(he%gzero)) deallocate(he%gzero) nullify(he%gzero) if(associated(he%wing)) deallocate(he%wing) nullify(he%wing) if (associated(he%wing_c)) deallocate(he%wing_c) nullify(he%wing_c) END SUBROUTINE free_memory_head_epsilon SUBROUTINE free_cprim_prod(cpp) implicit none TYPE(cprim_prod) :: cpp if(associated(cpp%cpmat)) deallocate( cpp%cpmat) nullify(cpp%cpmat) return END SUBROUTINE free_cprim_prod SUBROUTINE free_memory_full_prods(fp) implicit none TYPE(full_prods) ::fp if(associated(fp%ene_ks)) deallocate(fp%ene_ks) nullify(fp%ene_ks) if(associated(fp%gmat)) deallocate(fp%gmat) nullify(fp%gmat) return END SUBROUTINE free_memory_full_prods SUBROUTINE initialize_memory_full_prods(fp) implicit none TYPE(full_prods) ::fp nullify(fp%ene_ks) nullify(fp%gmat) return END SUBROUTINE initialize_memory_full_prods SUBROUTINE initialize_memory_cprim_prod(cpp) implicit none TYPE(cprim_prod) :: cpp nullify(cpp%cpmat) return END SUBROUTINE initialize_memory_cprim_prod SUBROUTINE free_memory_upper_states(us) implicit none TYPE(upper_states) :: us if(associated(us%ene)) deallocate(us%ene) nullify(us%ene) END SUBROUTINE free_memory_upper_states SUBROUTINE free_memory_partial_occ(po) implicit none TYPE(partial_occ) :: po if(associated(po%f_occ)) deallocate(po%f_occ) nullify(po%f_occ) if(associated(po%ppp_mat)) deallocate(po%ppp_mat) nullify(po%ppp_mat) END SUBROUTINE free_memory_partial_occ SUBROUTINE free_memory_semicore(sc) implicit none TYPE(semicore) :: sc if(associated(sc%en_sc)) deallocate(sc%en_sc) nullify(sc%en_sc) if(associated(sc%ppw_mat)) deallocate(sc%ppw_mat) nullify(sc%ppw_mat) END SUBROUTINE free_memory_semicore SUBROUTINE initialize_memory_semicore(sc) implicit none TYPE(semicore) :: sc nullify(sc%en_sc) nullify(sc%ppw_mat) END SUBROUTINE initialize_memory_semicore SUBROUTINE free_memory_contour_terms(ct) implicit none TYPE(contour_terms) :: ct if(associated(ct%cmat)) deallocate(ct%cmat) nullify(ct%cmat) END SUBROUTINE free_memory_contour_terms SUBROUTINE initialize_memory_contour_terms(ct) implicit none TYPE(contour_terms) :: ct nullify(ct%cmat) END SUBROUTINE initialize_memory_contour_terms SUBROUTINE initialize_memory_partial_occ(po) implicit none TYPE(partial_occ) :: po nullify(po%f_occ) nullify(po%ppp_mat) END SUBROUTINE initialize_memory_partial_occ SUBROUTINE initialize_memory_upper_states(us) implicit none TYPE(upper_states) :: us nullify(us%ene) END SUBROUTINE initialize_memory_upper_states SUBROUTINE free_memory_vt_mat_lanczos( vtl) implicit none TYPE(vt_mat_lanczos) :: vtl if(associated(vtl%vt_mat)) deallocate(vtl%vt_mat) nullify(vtl%vt_mat) END SUBROUTINE free_memory_vt_mat_lanczos SUBROUTINE initialize_memory_vt_mat_lanczos( vtl) implicit none TYPE(vt_mat_lanczos) :: vtl nullify(vtl%vt_mat) END SUBROUTINE initialize_memory_vt_mat_lanczos SUBROUTINE free_memory_mat_lanczos_full( full) implicit none TYPE(mat_lanczos_full) :: full if(associated(full%f_mat)) deallocate(full%f_mat) nullify(full%f_mat) END SUBROUTINE free_memory_mat_lanczos_full SUBROUTINE initialize_memory_mat_lanczos_full( full) implicit none TYPE(mat_lanczos_full) :: full nullify(full%f_mat) END SUBROUTINE initialize_memory_mat_lanczos_full SUBROUTINE free_memory_tt_mat_lanczos( ttl) implicit none TYPE(tt_mat_lanczos) :: ttl if(associated(ttl%tt_mat)) deallocate(ttl%tt_mat) nullify(ttl%tt_mat) END SUBROUTINE free_memory_tt_mat_lanczos SUBROUTINE initialize_memory_tt_mat_lanczos( ttl) implicit none TYPE(tt_mat_lanczos) :: ttl nullify(ttl%tt_mat) END SUBROUTINE initialize_memory_tt_mat_lanczos SUBROUTINE initialize_memory_lanczos_chain( lc) implicit none TYPE(lanczos_chain) :: lc nullify(lc%o_mat) nullify(lc%d) nullify(lc%f) END SUBROUTINE initialize_memory_lanczos_chain SUBROUTINE free_memory_lanczos_chain( lc) implicit none TYPE(lanczos_chain) :: lc if(associated(lc%o_mat)) deallocate(lc%o_mat) if(associated(lc%d)) deallocate(lc%d) if(associated(lc%f)) deallocate(lc%f) nullify(lc%o_mat) nullify(lc%d) nullify(lc%f) END SUBROUTINE free_memory_lanczos_chain END MODULE basic_structures GWW/gww/green_function.f900000644000077300007730000003720012341332532016143 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! MODULE green_function !this module descibes the green function in imaginary time/frequency !and contains subroutine to read/write from disk and to create USE kinds, ONLY : DP TYPE green !this structure describe a generic green function !usually in the space of wanniers INTEGER :: label!label to read/write to disk LOGICAL :: ontime!if .true. is on imaginary time, otherwise frequency REAL(kind=DP) :: time!imaginary time or frequency INTEGER :: nums!number of states LOGICAL :: zero_time_neg!if .true. the green function at t=0 is calculated as a negative time one COMPLEX(kind=DP), DIMENSION(:,:,:), POINTER :: gf!green function LOGICAL :: l_part!if true the matrix is written as a real matrix times a sign REAL(kind=DP), DIMENSION(:,:,:), POINTER :: gf_p!green function COMPLEX(kind=DP) :: factor !complex factor for gf_p INTEGER ::nspin!spin multiplicity END TYPE green CONTAINS SUBROUTINE initialize_green(gr) implicit none TYPE(green) gr nullify(gr%gf) nullify(gr%gf_p) return END SUBROUTINE SUBROUTINE free_memory_green(gr) !this subroutine deallocates the green descriptor implicit none TYPE(green) gr if(associated(gr%gf)) deallocate(gr%gf) nullify(gr%gf) if(associated(gr%gf_p)) deallocate(gr%gf_p) nullify(gr%gf_p) return END SUBROUTINE SUBROUTINE create_green(gr,wu,time,debug,zero_time_neg,l_hf_energies,ene_hf) !this subroutine creates a green function on imagynary time !on the basis of wanniers: !the KS energies are fixed so that the fermi level is at 0 ! G_{i,j}=i*\sum_v U^{+}_{v,i}*U_{j,v}*exp(e_v*t) t>=0 ! =-i*\sum_c U^{+}_{c,i}*U_{j,c}*exp(e_c*t) t<0 !if required uses HF energies USE kinds, ONLY : DP USE io_global, ONLY : stdout USE basic_structures, ONLY : wannier_u implicit none TYPE(green) :: gr!the green function on output TYPE(wannier_u) :: wu!data on U and e_i REAL(kind=DP) :: time!imaginary time LOGICAL :: debug!if true print debug informations on stdout LOGICAL :: zero_time_neg!if true and time==0, the negative form is forced LOGICAL, INTENT(in) :: l_hf_energies!if true uses HF energies REAL(kind=DP), INTENT(in) :: ene_hf(:) INTEGER iw,jw,kw REAL(kind=DP) :: offset !calculates energy offset gr%nspin=wu%nspin if(gr%nspin==1) then if(.not.l_hf_energies) then if(wu%nums > wu%nums_occ(1)) then offset=-(wu%ene(wu%nums_occ(1)+1,1)+wu%ene(wu%nums_occ(1),1))/2.d0 else offset=-wu%ene(wu%nums_occ(1),1) endif else if(wu%nums > wu%nums_occ(1)) then offset=-(ene_hf(wu%nums_occ(1)+1)+ene_hf(wu%nums_occ(1)))/2.d0 else offset=-ene_hf(wu%nums_occ(1)) endif endif else if(wu%nums > max(wu%nums_occ(1),wu%nums_occ(2))) then offset=-(min(wu%ene(wu%nums_occ(1)+1,1),wu%ene(wu%nums_occ(2)+1,2))+& &max(wu%ene(wu%nums_occ(1),1), wu%ene(wu%nums_occ(2),2)))/2.d0 else offset=-max(wu%ene(wu%nums_occ(1),1), wu%ene(wu%nums_occ(2),2)) endif endif !sets data and allocate ! call free_memory_green(gr) gr%nums=wu%nums allocate(gr%gf(gr%nums,gr%nums,gr%nspin)) gr%gf(:,:,:)=(0.d0,0.d0) gr%ontime=.TRUE. gr%time=time gr%zero_time_neg = zero_time_neg if((time < 0.d0).or. (time==0.d0 .and. zero_time_neg )) then ! only conduction states do iw=1,gr%nums do jw=iw,gr%nums do kw=wu%nums_occ(1)+1,wu%nums if(.not.l_hf_energies) then gr%gf(iw,jw,1)=gr%gf(iw,jw,1)+wu%umat(kw,iw,1)*conjg(wu%umat(kw,jw,1))* & & exp((wu%ene(kw,1)+offset)*time) else gr%gf(iw,jw,1)=gr%gf(iw,jw,1)+wu%umat(kw,iw,1)*conjg(wu%umat(kw,jw,1))* & & exp((ene_hf(kw)+offset)*time) endif if(debug) then write(stdout,*) 'Create green:' ,time,iw,jw,wu%ene(kw,1),wu%nums_occ(1)+1,wu%umat(jw,kw,1) endif enddo gr%gf(jw,iw,1)=conjg(gr%gf(iw,jw,1)) gr%gf(iw,jw,1)=(0.d0,-1.d0)*gr%gf(iw,jw,1) if(iw /= jw) gr%gf(jw,iw,1)=(0.d0,-1.d0)*gr%gf(jw,iw,1) enddo enddo else ! only valence states do iw=1,gr%nums do jw=iw,gr%nums do kw=1,wu%nums_occ(1) if(.not. l_hf_energies) then gr%gf(iw,jw,1)=gr%gf(iw,jw,1)+wu%umat(kw,iw,1)*conjg(wu%umat(kw,jw,1))* & & exp((wu%ene(kw,1)+offset)*time) else gr%gf(iw,jw,1)=gr%gf(iw,jw,1)+wu%umat(kw,iw,1)*conjg(wu%umat(kw,jw,1))* & & exp((ene_hf(kw)+offset)*time) endif if(debug) then write(stdout,*) 'Create green:' ,time,iw,jw,wu%ene(kw,1),wu%umat(kw,iw,1),wu%umat(kw,jw,1) endif enddo gr%gf(jw,iw,1)=conjg(gr%gf(iw,jw,1)) gr%gf(iw,jw,1)=(0.d0,1.d0)*gr%gf(iw,jw,1) if(iw /= jw) gr%gf(jw,iw,1)=(0.d0,1.d0)*gr%gf(jw,iw,1) if(debug) write(stdout,*) 'Create green2:', iw,jw, gr%gf(iw,jw,1), offset enddo enddo endif return END SUBROUTINE SUBROUTINE create_green_part(gr,wu,time,debug,zero_time_neg,l_hf_energies,ene_hf) !this subroutine creates a green function on imagynary time !on the basis of wanniers: !the KS energies are fixed so that the fermi level is at 0 ! G_{i,j}=i*\sum_v U^{+}_{v,i}*U_{j,v}*exp(e_v*t) t>=0 ! =-i*\sum_c U^{+}_{c,i}*U_{j,c}*exp(e_c*t) t<0 !if required uses HF energies !it uses consider a real part plus a factor USE kinds, ONLY : DP USE io_global, ONLY : stdout USE basic_structures, ONLY : wannier_u implicit none TYPE(green) :: gr!the green function on output TYPE(wannier_u) :: wu!data on U and e_i REAL(kind=DP) :: time!imaginary time LOGICAL :: debug!if true print debug informations on stdout LOGICAL :: zero_time_neg!if true and time==0, the negative form is forced LOGICAL, INTENT(in) :: l_hf_energies!if true uses HF energies REAL(kind=DP), INTENT(in) :: ene_hf(:) INTEGER iw,jw,kw REAL(kind=DP) :: offset call free_memory_green(gr) gr%nspin=wu%nspin gr%l_part=.true. !calculates energy offset if(gr%nspin==1) then if(.not.l_hf_energies) then if(wu%nums > wu%nums_occ(1)) then offset=-(wu%ene(wu%nums_occ(1)+1,1)+wu%ene(wu%nums_occ(1),1))/2.d0 else offset=-wu%ene(wu%nums_occ(1),1) endif else if(wu%nums > wu%nums_occ(1)) then offset=-(ene_hf(wu%nums_occ(1)+1)+ene_hf(wu%nums_occ(1)))/2.d0 else offset=-ene_hf(wu%nums_occ(1)) endif endif else if(wu%nums > max(wu%nums_occ(1),wu%nums_occ(2))) then offset=-(min(wu%ene(wu%nums_occ(1)+1,1),wu%ene(wu%nums_occ(2)+1,2))+& &max(wu%ene(wu%nums_occ(1),1), wu%ene(wu%nums_occ(2),2)))/2.d0 else offset=-max(wu%ene(wu%nums_occ(1),1), wu%ene(wu%nums_occ(2),2)) endif endif !sets data and allocate ! call free_memory_green(gr) gr%nums=wu%nums allocate(gr%gf_p(gr%nums,gr%nums,gr%nspin)) gr%gf_p(:,:,:)=0.d0 gr%ontime=.TRUE. gr%time=time gr%zero_time_neg = zero_time_neg if((time < 0.d0).or. (time==0.d0 .and. zero_time_neg )) then ! only conduction states do iw=1,gr%nums do jw=iw,gr%nums do kw=wu%nums_occ(1)+1,wu%nums if(.not.l_hf_energies) then gr%gf_p(iw,jw,1)=gr%gf_p(iw,jw,1)+dble(wu%umat(kw,iw,1))*dble(wu%umat(kw,jw,1))* & & exp((wu%ene(kw,1)+offset)*time) ! if(abs(aimag(wu%umat(kw,iw)) >=1.d-6)) write(stdout,*) 'PROBLEMA' else gr%gf_p(iw,jw,1)=gr%gf_p(iw,jw,1)+dble(wu%umat(kw,iw,1))*dble(wu%umat(kw,jw,1))* & & exp((ene_hf(kw)+offset)*time) endif if(debug) then write(stdout,*) 'Create green:' ,time,iw,jw,wu%ene(kw,1),wu%nums_occ+1,wu%umat(jw,kw,1) endif enddo gr%gf_p(jw,iw,1)=gr%gf_p(iw,jw,1) gr%factor=(0.d0,-1.d0) enddo enddo else ! only valence states do iw=1,gr%nums do jw=iw,gr%nums do kw=1,wu%nums_occ(1) if(.not. l_hf_energies) then gr%gf_p(iw,jw,1)=gr%gf_p(iw,jw,1)+dble(wu%umat(kw,iw,1))*dble(wu%umat(kw,jw,1))* & & exp((wu%ene(kw,1)+offset)*time) else gr%gf_p(iw,jw,1)=gr%gf_p(iw,jw,1)+dble(wu%umat(kw,iw,1))*dble(wu%umat(kw,jw,1))* & & exp((ene_hf(kw)+offset)*time) endif if(debug) then write(stdout,*) 'Create green:' ,time,iw,jw,wu%ene(kw,1),wu%umat(kw,iw,1),wu%umat(kw,jw,1) endif enddo gr%gf_p(jw,iw,1)=gr%gf_p(iw,jw,1) gr%factor=(0.d0,1.d0) if(debug) write(stdout,*) 'Create green2:', iw,jw, gr%gf_p(iw,jw,1), offset enddo enddo endif return END SUBROUTINE create_green_part SUBROUTINE write_green(gr, debug) !this subroutine writes the green function on disk !the file name is taken from the label USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(green) :: gr!the green function to be written LOGICAL :: debug!if true print formatted file INTEGER :: iw, jw, iung,is CHARACTER(5) :: nfile if(gr%label > 0 .or. (gr%label == 0 .and. .not.gr%zero_time_neg)) then write(nfile,'(5i1)') & & gr%label/10000,mod(gr%label,10000)/1000,mod(gr%label,1000)/100,mod(gr%label,100)/10,mod(gr%label,10) iung = find_free_unit() if(.not. debug) then open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'green.'// nfile, status='unknown',form='unformatted') else open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'green.'// nfile, status='unknown',form='formatted') endif else write(nfile,'(5i1)') & & -gr%label/10000,mod(-gr%label,10000)/1000,mod(-gr%label,1000)/100,mod(-gr%label,100)/10,mod(-gr%label,10) iung = find_free_unit() if(.not.debug) then open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'green.-'// nfile, status='unknown',form='unformatted') else open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'green.-'// nfile, status='unknown',form='formatted') endif endif if(.not.debug) then write(iung) gr%label write(iung) gr%ontime write(iung) gr%time write(iung) gr%nspin write(iung) gr%nums write(iung) gr%zero_time_neg write(iung) gr%l_part write(iung) gr%factor do is=1,gr%nspin if(.not.gr%l_part) then do iw=1,gr%nums write(iung) gr%gf(1:gr%nums,iw,is) enddo else do iw=1,gr%nums write(iung) gr%gf_p(1:gr%nums,iw,is) enddo endif enddo else write(iung,*) gr%label write(iung,*) gr%ontime write(iung,*) gr%time write(iung,*) gr%nspin write(iung,*) gr%nums write(iung,*) gr%zero_time_neg write(iung,*) gr%l_part write(iung,*) gr%factor do is=1,gr%nspin if(.not.gr%l_part) then do iw=1,gr%nums do jw=1,gr%nums write(iung,*) gr%gf(jw,iw,is) enddo enddo else do iw=1,gr%nums do jw=1,gr%nums write(iung,*) gr%gf_p(jw,iw,is) enddo enddo endif enddo endif close(iung) return END SUBROUTINE write_green SUBROUTINE read_green(label, gr, debug,zero_time_neg) !this subroutine reads the green function from disk !the file name is taken from the label USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(green) :: gr!the green function to be read INTEGER :: label! the label identifing the required green function LOGICAL :: debug!if true print formatted file LOGICAL :: zero_time_neg !if true and time == 0, a negative kind of green function is considered INTEGER :: iw, jw, iung,is CHARACTER(5) :: nfile !first deallocate call free_memory_green(gr) if(label > 0 .or. (label == 0 .and. .not.zero_time_neg)) then write(nfile,'(5i1)') label/10000,mod(label,10000)/1000,mod(label,1000)/100,mod(label,100)/10,mod(label,10) iung = find_free_unit() if(.not.debug) then open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'green.'// nfile, status='old',form='unformatted') else open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'green.'// nfile, status='old',form='formatted') endif else write(nfile,'(5i1)') -label/10000,mod(-label,10000)/1000,mod(-label,1000)/100,mod(-label,100)/10,mod(-label,10) iung = find_free_unit() if(.not.debug) then open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'green.-'// nfile, status='old',form='unformatted') else open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'green.-'// nfile, status='old',form='formatted') endif endif if(.not.debug) then read(iung) gr%label read(iung) gr%ontime read(iung) gr%time read(iung) gr%nspin read(iung) gr%nums read(iung) gr%zero_time_neg read(iung) gr%l_part read(iung) gr%factor !now allocate if(.not. gr%l_part) then allocate(gr%gf(gr%nums,gr%nums,gr%nspin)) nullify(gr%gf_p) else allocate(gr%gf_p(gr%nums,gr%nums,gr%nspin)) nullify(gr%gf) endif do is=1,gr%nspin if(.not. gr%l_part) then do iw=1,gr%nums read(iung) gr%gf(1:gr%nums,iw,is) enddo else do iw=1,gr%nums read(iung) gr%gf_p(1:gr%nums,iw,is) enddo endif enddo else read(iung,*) gr%label read(iung,*) gr%ontime read(iung,*) gr%time read(iung,*) gr%nspin read(iung,*) gr%nums read(iung,*) gr%zero_time_neg read(iung,*) gr%l_part read(iung,*) gr%factor !now allocate if(.not. gr%l_part) then allocate(gr%gf(gr%nums,gr%nums,gr%nspin)) nullify(gr%gf_p) else allocate(gr%gf_p(gr%nums,gr%nums,gr%nspin)) nullify(gr%gf) endif do is=1,gr%nspin if(.not. gr%l_part) then do iw=1,gr%nums do jw=1,gr%nums read(iung,*) gr%gf(jw,iw,is) enddo enddo else do iw=1,gr%nums do jw=1,gr%nums read(iung,*) gr%gf_p(jw,iw,is) enddo enddo endif enddo endif close(iung) return END SUBROUTINE read_green END MODULE green_function GWW/gww/create_hf.f900000644000077300007730000000625212341332532015061 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! SUBROUTINE create_hf(options, qp) !this subroutine creates the perturbative HF energies !and allocates and sets relevant stuff USE basic_structures, ONLY : wannier_u, free_memory USE input_gw, ONLY : input_options USE constants, ONLY : RYTOEV USE kinds, ONLY : DP USE energies_gww, ONLY : quasi_particles USE io_global, ONLY : stdout implicit none TYPE(input_options) :: options! for prefix TYPE(quasi_particles) :: qp!the descriptor to be build TYPE(wannier_u) :: uu REAL(kind=DP), ALLOCATABLE :: ene_x(:,:), ene_h(:,:) INTEGER :: ii,is call read_data_pw_u(uu, options%prefix) !allocates qp%max_i=options%max_i qp%nspin=uu%nspin qp%whole_s=.false.!if required whole matrix stuff is set elsewhere allocate(qp%ene_dft_ks(qp%max_i,qp%nspin)) allocate(qp%ene_dft_xc(qp%max_i,qp%nspin)) allocate(qp%ene_dft_h(qp%max_i,qp%nspin)) allocate(qp%ene_gw(qp%max_i,qp%nspin)) allocate(qp%ene_gw_pert(qp%max_i,qp%nspin)) allocate(qp%ene_hf(uu%nums,qp%nspin)) if(options%l_hf_energies) then allocate(qp%ene_x(uu%nums,qp%nspin)) allocate(ene_x(uu%nums,qp%nspin)) allocate(ene_h(uu%nums,qp%nspin)) else allocate(qp%ene_x(qp%max_i,qp%nspin)) allocate(ene_x(qp%max_i,qp%nspin)) allocate(ene_h(qp%max_i,qp%nspin)) endif allocate(qp%ene_h(qp%max_i,qp%nspin)) qp%ene_dft_ks(1:qp%max_i,1:qp%nspin) = uu%ene(1:qp%max_i,1:qp%nspin) qp%ene_dft_xc(1:qp%max_i,1:qp%nspin) = uu%ene_xc(1:qp%max_i,1:qp%nspin) qp%ene_dft_h(1:qp%max_i,1:qp%nspin) = uu%ene_lda_h(1:qp%max_i,1:qp%nspin) if(options%l_lda_hartree) then qp%ene_h(1:qp%max_i,1:qp%nspin) = cmplx(uu%ene_lda_h(1:qp%max_i,1:qp%nspin),0.d0) else !here calculate hartree parte endif !calculate exchange part if(options%l_hf_energies) then call go_exchange(options,ene_x(:,1),ene_h(:,1),uu%nums) do ii=1,uu%nums qp%ene_x(ii,1)=ene_x(ii,1) qp%ene_hf(ii,1)=uu%ene(ii,1)-uu%ene_xc(ii,1)+ene_x(ii,1) write(stdout,*) 'ENE HF',ii, qp%ene_hf(ii,1)*RYTOEV enddo else write(stdout,*) 'ENE H', qp%ene_h(1:qp%max_i,1:qp%nspin) if(.not.options%l_lda_exchange) then call go_exchange(options,ene_x(:,1),ene_h(:,1),qp%max_i) else !read from file call read_data_pw_exchange(ene_x,qp%max_i,options%prefix,qp%nspin) ene_h(1:qp%max_i,1:qp%nspin)=uu%ene_lda_h(1:qp%max_i,1:qp%nspin) endif do is=1,qp%nspin do ii=1,qp%max_i qp%ene_x(ii,is)=ene_x(ii,is) if(options%l_lda_hartree) then qp%ene_hf(ii,is)=uu%ene(ii,is)-uu%ene_xc(ii,is)+ene_x(ii,is) else qp%ene_h(ii,is)=cmplx(ene_h(ii,is),0.d0) qp%ene_hf(ii,is)=uu%ene(ii,is)-uu%ene_xc(ii,is)+ene_x(ii,is)-uu%ene_lda_h(ii,is)+ene_h(ii,is) endif enddo enddo endif call free_memory(uu) deallocate(ene_x,ene_h) return END SUBROUTINE create_hf GWW/gww/do_self_lanczos.f900000644000077300007730000010627312341332532016311 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !this subroutines performs the lanczos style calculation of the self-energy subroutine calculate_compact_self_lanczos(options) !this subroutine calculate the compact products for the lanczos calculation !of the self-energy USE kinds, ONLY : DP USE input_gw, ONLY : input_options USE basic_structures, ONLY : wannier_u,vt_mat_lanczos,tt_mat_lanczos,initialize_memory,free_memory USE lanczos, ONLY : compact_q_lanczos,initialize_compact_q_lanczos,& &free_memory_compact_q_lanczos,do_compact_q_lanczos,write_compact_q_lanczos USE mp_world, ONLY : nproc,mpime USE io_global, ONLY : ionode implicit none TYPE(input_options), INTENT(in) :: options TYPE(wannier_u) :: uu!U matrix TYPE(vt_mat_lanczos) :: vtl TYPE(tt_mat_lanczos) :: ttl TYPE(compact_q_lanczos) :: cql INTEGER :: l_blk,nbegin,nend,iv,iu call initialize_memory(vtl) call initialize_memory(ttl) call initialize_compact_q_lanczos(cql) ! !read U matrix call read_data_pw_u(uu,options%prefix) do iu=1,options%max_i !read in V and T call read_data_pw_vt_mat_lanczos(vtl, iu, options%prefix, .false.,1) call read_data_pw_tt_mat_lanczos(ttl, iu, options%prefix, .false.,1) !calculate contribution to Q allocate( cql%qlm(vtl%numpw,ttl%numt)) cql%qlm(:,:)=0.d0 !sum up with factor Uvvi call do_compact_q_lanczos(vtl,ttl,cql,1.d0) !write Q^v on disk cql%ii=iu if(ionode) call write_compact_q_lanczos(cql) deallocate(cql%qlm) enddo call free_memory(vtl) call free_memory(ttl) call free_memory_compact_q_lanczos(cql) call free_memory(uu) return end subroutine calculate_compact_self_lanczos subroutine solve_lanczos_complex(nbuf,alpha,e_mat,lc) !this subroutine sums to the matrix E_{no}= USE kinds, ONLY : DP USE basic_structures, ONLY : lanczos_chain, initialize_memory,free_memory USE io_global, ONLY : stdout USE mp, ONLY : mp_sum,mp_bcast USE mp_world, ONLY : nproc, mpime, world_comm implicit none INTEGER :: nbuf!number of matrices to treat COMPLEX(kind=DP) :: alpha(nbuf)!constant for Ev+iw TYPE(lanczos_chain) :: lc!lanczos chain descriptor COMPLEX(kind=DP) :: e_mat(lc%numt,lc%numt,nbuf)!matrix to be calculated INTEGER :: io,info,ii,jj,il COMPLEX(kind=DP), ALLOCATABLE :: dl(:),du(:),d(:),t(:) COMPLEX(kind=DP), ALLOCATABLE :: omat(:,:) REAL(kind=DP), ALLOCATABLE :: tmp_mat(:,:) INTEGER :: l_blk,nbegin,nend, iproc l_blk= (lc%numt)/nproc if(l_blk*nproc < (lc%numt)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 allocate(dl(lc%num_steps-1),du(lc%num_steps-1),d(lc%num_steps),t(lc%num_steps)) e_mat(:,:,:)=(0.d0,0.d0) allocate(omat(lc%numt,lc%num_steps)) allocate(tmp_mat(lc%numt,lc%num_steps)) !loop on o do io=1,lc%numt !!set up vectors for lapack routine !recover matrix from processor tmp_mat(:,:)=0.d0 if(io >= nbegin .and. io <= nend) then tmp_mat(:,:)=lc%o_mat(:,:,io-nbegin+1) endif !call mp_sum(tmp_mat(:,:),world_comm) iproc=(io-1)/l_blk call mp_bcast(tmp_mat(:,:), iproc, world_comm) omat(:,:)=dcmplx(tmp_mat(:,:),0.d0) do il=1,nbuf dl(1:lc%num_steps-1)=cmplx(lc%f(1:lc%num_steps-1,io),0.d0) du(1:lc%num_steps-1)=cmplx(lc%f(1:lc%num_steps-1,io),0.d0) d(1:lc%num_steps)=cmplx(lc%d(1:lc%num_steps,io),0.d0)+alpha(il) t(:)=(0.d0,0.d0) t(1)=(1.d0,0.d0) !!call lapack call zgtsv(lc%num_steps,1,dl,d,du,t,lc%num_steps,info) if(info /= 0) then write(stdout,*) 'ZGTSV info:', info call flush_unit(stdout) stop endif !ATTENZIONE ! if(io==1) then ! write(stdout,*) 'Solve lanczos first',t(1),t(lc%num_steps) ! write(stdout,*) 'omat', lc%o_mat(1,1,io), lc%o_mat(1,lc%num_steps,io),& ! & lc%o_mat(lc%num_steps,1,io), lc%o_mat(lc%num_steps,lc%num_steps,io) ! endif ! if(io==lc%numt) then ! write(stdout,*) 'Solve lanczos last',t(1),t(lc%num_steps) ! write(stdout,*) 'omat', lc%o_mat(1,1,io), lc%o_mat(1,lc%num_steps,io),& ! & lc%o_mat(lc%num_steps,1,io), lc%o_mat(lc%num_steps,lc%num_steps,io) ! endif !!calculate term !omat(:,:)=dcmplx(lc%o_mat(:,:,io),0.d0) call zgemm('N','N',lc%numt,1,lc%num_steps,(1.d0,0.d0),omat,lc%numt,t,lc%num_steps,(1.d0,0.d0),e_mat(:,io,il),lc%numt) enddo enddo do il=1,nbuf do ii=1,lc%numt do jj=ii+1,lc%numt e_mat(ii,jj,il)=0.5d0*(e_mat(ii,jj,il)+e_mat(jj,ii,il)) e_mat(jj,ii,il)=e_mat(ii,jj,il) enddo enddo enddo deallocate(dl,du,d,t) deallocate(omat,tmp_mat) return end subroutine solve_lanczos_complex !routine do_self_lanczos subroutine do_self_lanczos(ss, tf ,options) !this subroutine calculte the self-energy on the frequency fit grid using the lanczos scheme USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE input_gw, ONLY : input_options USE basic_structures, ONLY : v_pot,wannier_u,free_memory, initialize_memory,lanczos_chain, vt_mat_lanczos,tt_mat_lanczos USE green_function, ONLY : green, read_green, free_memory_green, initialize_green USE polarization, ONLY : polaw, free_memory_polaw, read_polaw, write_polaw,invert_v_pot, initialize_polaw, & & read_polaw_global USE mp, ONLY : mp_sum, mp_bcast USE mp_world, ONLY : nproc,mpime,world_comm USE times_gw, ONLY : times_freqs USE self_energy_storage, ONLY : self_storage,write_self_storage_ondisk,free_memory_self_storage USE lanczos USE constants, ONLY : tpi USE start_end ! debug implicit none TYPE(times_freqs), INTENT(in) :: tf!for time frequency grids TYPE(input_options) :: options TYPE(self_storage) :: ss TYPE(compact_q_lanczos), ALLOCATABLE :: cql(:) TYPE(vt_mat_lanczos), ALLOCATABLE :: vtl(:) TYPE(tt_mat_lanczos), ALLOCATABLE :: ttl(:) TYPE(wannier_u) :: uu TYPE(lanczos_matrix) :: lm !1) !loop on iw (parallelized) !calculate screened polarization !write back on polaw TYPE(v_pot) :: vp,vpi TYPE(polaw) :: ww!dressed polarization TYPE(lanczos_chain) :: lc INTEGER :: l_blk, nbegin,nend, l_blk_freq, nbegin_freq,nend_freq INTEGER :: iw_tot,l_blk_iw, nbegin_iw,nend_iw REAL(kind=DP), ALLOCATABLE:: wtemp(:,:), vtemp(:) INTEGER :: iw,ii, jw, il, kw COMPLEX(kind=DP), ALLOCATABLE :: af(:) REAL(kind=DP), ALLOCATABLE :: re_e_mat(:,:),im_e_mat(:,:) ,tmp_mat(:,:), re_c_mat(:,:,:,:), im_c_mat(:,:,:,:) REAL(kind=DP), ALLOCATABLE :: tmp_mat1(:,:),tmp_mat2(:,:) INTEGER :: n_buf,iw_min,iw_max,iiw,ix,iy,it,ip,ixx REAL(kind=DP), EXTERNAL :: ddot REAL(kind=DP) :: offset COMPLEX(kind=DP), ALLOCATABLE :: gw_tab(:,:), exp_tab(:,:,:), exp_iw(:,:),exp_ix(:,:) LOGICAL :: l_conv!if true do just the convolution LOGICAL :: l_half=.true. REAL(kind=DP), ALLOCATABLE :: re_c_tmp(:,:), im_c_tmp(:,:) INTEGER, ALLOCATABLE :: iw_proc(:) INTEGER :: n_buf_ii, ii_buf, ii_begin,ii_end,ipos LOGICAL :: l_direct=.true.!if true direct way of performing products for each state INTEGER :: numpw COMPLEX(kind=DP), ALLOCATABLE :: e_mat_tmp(:,:,:) INTEGER :: n_dim INTEGER :: iproc COMPLEX(kind=DP) :: csca REAL(kind=DP), ALLOCATABLE :: polaw_store(:,:,:) !to reduce io INTEGER :: io_tot,l_blk_io, nbegin_io,nend_io COMPLEX(kind=DP), ALLOCATABLE :: cterm(:) REAL(kind=DP) :: inv_epsi,v_head INTEGER :: iw1,jw1 INTEGER :: n_max REAL(kind=DP), ALLOCATABLE :: diag_tmp(:) LOGICAL :: l_iw_min REAL(kind=DP), ALLOCATABLE :: mat_tmp(:,:) INTEGER :: i, j !calculate offset !read in DFT energies call read_data_pw_u(uu,options%prefix) if(uu%nums > uu%nums_occ(1)) then offset=-(uu%ene(uu%nums_occ(1)+1,1)+uu%ene(uu%nums_occ(1),1))/2.d0 else offset=-uu%ene(uu%nums_occ(1),1) endif call free_memory(uu) !initialize self_storage ss if(options%l_lanczos_conv) then l_conv=.true. else l_conv=.false. endif ss%ontime=.false. ss%max_i=options%max_i ss%i_min=options%i_min ss%i_max=options%i_max ss%n=tf%n_grid_fit ss%tau=options%tau ss%whole_s=options%whole_s ss%n_grid_fit=tf%n_grid_fit if(ss%whole_s) then allocate(ss%whole(ss%max_i,ss%max_i,2*ss%n+1,1)) ss%whole(:,:,:,:)=(0.d0,0.d0) allocate(ss%whole_freq_fit(ss%max_i,ss%max_i,2*ss%n+1,1)) ss%whole_freq_fit(:,:,:,:)=(0.d0,0.d0) nullify(ss%diag) nullify(ss%diag_freq_fit) else allocate(ss%diag(ss%max_i,2*ss%n+1,1)) ss%diag(:,:,:)=(0.d0,0.d0) nullify(ss%whole) allocate(ss%diag_freq_fit(ss%max_i,2*ss%n+1,1)) ss%diag_freq_fit(:,:,:)=(0.d0,0.d0) nullify(ss%whole_freq_fit) endif !for compatibility allocate(ss%ene_remainder(ss%max_i,1)) ss%ene_remainder(:,:)=0.d0 if(ss%whole_s) then write(stdout,*) 'Whole s not implemented YET' stop endif nullify(vp%vmat) nullify(vpi%vmat) call initialize_polaw(ww) allocate(diag_tmp(options%n_set_ii)) !2) create compact_self_lanczos if(.not.l_direct) call calculate_compact_self_lanczos(options) !3) !read in lanczos chain for self-energy call initialize_memory(lc) call read_data_pw_lanczos_chain(lc, 1, options%prefix, .false.,1) write(stdout,*) 'Lanczos dimensions', lc%numt,lc%num_steps write(stdout,*) 'Lanczos first diagonal', lc%d(1,1),lc%d(lc%num_steps,1) write(stdout,*) 'Lanczos last diagonal', lc%d(1,lc%numt),lc%d(lc%num_steps,lc%numt) write(stdout,*) 'Lanczos first tri', lc%f(1,1),lc%f(lc%num_steps-1,1) write(stdout,*) 'Lanczos last tri', lc%f(1,lc%numt),lc%f(lc%num_steps-1,lc%numt) call flush_unit(stdout) call initialize_lanczos_matrix(lm) lm%numt=lc%numt allocate(lm%e_mat(lm%numt,lm%numt)) allocate(re_e_mat(lc%numt,lc%numt)) allocate(im_e_mat(lc%numt,lc%numt)) !if required allocates table for products and exponents if(.not.l_conv) then allocate(gw_tab(-tf%n:tf%n,-tf%n:tf%n)) l_blk_freq= (2*ss%n+1)/nproc if(l_blk_freq*nproc < (2*ss%n+1)) l_blk_freq = l_blk_freq+1 nbegin_freq=mpime*l_blk_freq-ss%n nend_freq=nbegin_freq+l_blk_freq-1 allocate(exp_tab(-tf%n:tf%n,-tf%n:tf%n,l_blk_freq)) exp_tab(:,:,:)=(0.d0,0.d0) ! allocate(exp_iw(-tf%n:tf%n,-tf%n:tf%n)) ! do iw=-tf%n,tf%n ! do it=-tf%n,tf%n ! exp_iw(it,iw)=exp((0.d0,1.d0)*tf%freqs(iw)*tf%times(it)) ! enddo ! enddo ! allocate(exp_ix(-tf%n:tf%n,l_blk_freq)) ! do ix=nbegin_freq,nbegin_freq+l_blk_freq-1 ! if(ix<=ss%n) then ! do it=-tf%n,tf%n ! exp_ix(it,ix-nbegin_freq+1)=exp((0.d0,-1.d0)*tf%freqs_fit(ix)*tf%times(it)) ! enddo ! endif ! enddo do ix=nbegin_freq,nbegin_freq+l_blk_freq-1 if(ix<=ss%n) then write(stdout,*) 'Exp table:', ix call flush_unit(stdout) do jw=-tf%n,tf%n do iw=-tf%n,tf%n do it=-tf%n,tf%n exp_tab(iw,jw,ix-nbegin_freq+1)=exp_tab(iw,jw,ix-nbegin_freq+1)+tf%weights_freq(iw)*& &tf%weights_freq(jw)*tf%weights_time(it)*& &exp((0.d0,1.d0)*(tf%freqs(iw)+tf%freqs(jw)-tf%freqs_fit(ix))*tf%times(it)) ! *exp_iw(it,iw)*exp_iw(it,jw)*exp_ix(it,ix-nbegin_freq+1) enddo enddo enddo endif enddo !deallocate(exp_iw,exp_ix) endif if(.not.l_direct) then allocate(cql(options%n_set_ii)) do ii=1,options%n_set_ii call initialize_compact_q_lanczos(cql(ii)) enddo else allocate(vtl(options%n_set_ii)) allocate(ttl(options%n_set_ii)) do ii=1,options%n_set_ii call initialize_memory(vtl(ii)) call initialize_memory(ttl(ii)) enddo endif !!calculate (H-iw)^-1 and write on disk (parallel) l_blk= (2*tf%n+1)/nproc if(l_blk*nproc < (2*tf%n+1)) l_blk = l_blk+1 nbegin=mpime*l_blk-tf%n nend=nbegin+l_blk-1 if(nend > tf%n) nend=tf%n allocate(e_mat_tmp(lm%numt,lm%numt,options%n_set_self)) allocate(af(options%n_set_self)) do iw=nbegin,nbegin+l_blk-1,options%n_set_self n_dim=0 do il=1,options%n_set_self if((iw+il-1) <= tf%n) then n_dim=n_dim+1 af(il) = dcmplx(offset,-tf%freqs(iw+il-1)) endif enddo if(n_dim > 0) then write(stdout,*) 'Doing solve_lanczos_complex',iw call flush_unit(stdout) call solve_lanczos_complex(n_dim,af,e_mat_tmp,lc) write(stdout,*) 'Done' call flush_unit(stdout) do il=1,n_dim lm%iw=iw+il-1 lm%e_mat(:,:)=e_mat_tmp(:,:,il) call write_lanczos_matrix(lm) enddo else call solve_lanczos_fake_complex(lc) endif enddo deallocate(e_mat_tmp,af) !if reduced I/O read all polaw in memory if(options%l_reduce_io) then if(.not. tf%grid_freq == 5) then n_max=tf%n/2 else n_max=(tf%n-(1+2*tf%second_grid_i)*tf%second_grid_n)/2+& &(1+2*tf%second_grid_i)*tf%second_grid_n endif l_blk_io= (n_max+1)/nproc if(l_blk_io*nproc < (n_max+1)) l_blk_io = l_blk_io+1 nbegin_io=mpime*l_blk_io nend_io=nbegin_io+l_blk_io-1 if(nend_io > n_max) nend_io=n_max io_tot=nend_io-nbegin_io+1 do jw=nbegin_io,nend_io call read_polaw(jw, ww,options%debug,options%l_verbose) if(jw==nbegin_io) then allocate(polaw_store(ww%numpw,ww%numpw,io_tot)) endif polaw_store(:,:,jw-nbegin_io+1)=ww%pw(:,:) enddo !distribute ww%numpw if(.not.ionode) ww%numpw=0 !call mp_sum(ww%numpw,world_comm) call mp_bcast(ww%numpw, ionode_id,world_comm) if(.not.ionode) ww%factor=(0.d0,0.d0) !call mp_sum(ww%factor,world_comm) call mp_bcast(ww%factor, ionode_id,world_comm) endif !!loop on i KS states !!loop/module n_set on iw' n_buf_ii=(options%i_max-options%i_min+1)/options%n_set_ii if(n_buf_ii*options%n_set_ii < (options%i_max-options%i_min+1)) n_buf_ii=n_buf_ii+1 allocate(cterm(options%n_set_ii)) do ii_buf=1,n_buf_ii ii_begin=options%i_min+(ii_buf-1)*options%n_set_ii ii_end=min(ii_begin+options%n_set_ii-1, options%i_max) ! do ii=options%i_min,options%i_max do ii=ii_begin,ii_end write(stdout,*) 'KS STATE', ii call flush_unit(stdout) !!read in Q^i write(stdout,*) 'Call read_compact_q_lanczos' call flush_unit(stdout) if(.not.l_direct) then call read_compact_q_lanczos(cql(ii-ii_begin+1), ii) else call read_data_pw_vt_mat_lanczos(vtl(ii-ii_begin+1), ii, options%prefix, .false.,1) call read_data_pw_tt_mat_lanczos(ttl(ii-ii_begin+1), ii, options%prefix, .false.,1) endif write(stdout,*) 'Done' call flush_unit(stdout) enddo !!loop/module n_set on iw' n_buf=(2*tf%n+1)/options%n_set if(n_buf*options%n_set < 2*tf%n+1) n_buf=n_buf+1 do iiw=1,n_buf !!build C matrix iw_min=-tf%n+options%n_set*(iiw-1) iw_max=min(iw_min+options%n_set-1,tf%n) write(stdout,*) 'Solve' call flush_unit(stdout) iw_tot=iw_max-iw_min+1 l_blk_iw= (iw_tot)/nproc if(l_blk_iw*nproc < (iw_tot)) l_blk_iw = l_blk_iw+1 nbegin_iw=mpime*l_blk_iw+iw_min nend_iw=nbegin_iw+l_blk_iw-1 if(nend_iw > iw_max) nend_iw = iw_max if(.not.l_direct) then numpw=cql(1)%numpw else numpw=vtl(1)%numpw endif allocate(re_c_mat(numpw,numpw,options%n_set_ii,l_blk_iw)) allocate(im_c_mat(numpw,numpw,options%n_set_ii,l_blk_iw)) re_c_mat(:,:,:,:)=0.d0 im_c_mat(:,:,:,:)=0.d0 if(.not.l_conv) then allocate(re_c_tmp(numpw,numpw)) allocate(im_c_tmp(numpw,numpw)) endif !allocate(iw_proc(iw_tot)) !iw_proc(:)=-1 !do ip=0,nproc-1 ! iw_proc(ip*l_blk_iw+1:min(ip*l_blk_iw+l_blk_iw,iw_tot))=ip !enddo do iw=nbegin_iw,nend_iw !!build C matrices !!!calculate G matrix on {t} basis !!!solve tridiagonal problem for +i\omega !af = dcmplx(offset,-tf%freqs(iw)) !call solve_lanczos_complex(af,lm%e_mat,lc) write(stdout,*) 'Reading lanczos matrix',iw call flush_unit(stdout) call read_lanczos_matrix(lm,iw) write(stdout,*) 'Done' call flush_unit(stdout) !!calculate C^i_lm matrix re_e_mat(:,:)=dble(lm%e_mat(:,:)) im_e_mat(:,:)=dimag(lm%e_mat(:,:)) if(.not.l_direct) then allocate(tmp_mat(cql(1)%numpw,cql(1)%numt)) write(stdout,*) 'Doing dgemms' write(stdout,*) 're_e_mat', re_e_mat(1,1),re_e_mat(1,cql(1)%numt),& &re_e_mat(cql(1)%numt,1),re_e_mat(cql(1)%numt,cql(1)%numt) do ii=ii_begin,ii_end ipos=ii-ii_begin+1 call flush_unit(stdout) call dgemm('N','N',cql(ipos)%numpw,cql(ipos)%numt,cql(ipos)%numt,& &1.d0,cql(ipos)%qlm,cql(ipos)%numpw,re_e_mat,lc%numt,0.d0,tmp_mat,cql(ipos)%numpw) call dgemm('N','T',cql(ipos)%numpw,cql(ipos)%numpw,cql(ipos)%numt,& &1.d0,tmp_mat,cql(ipos)%numpw,cql(ipos)%qlm,cql(ipos)%numpw,0.d0,re_c_mat(1,1,ipos,iw-nbegin_iw+1),cql(ipos)%numpw) call dgemm('N','N',cql(ipos)%numpw,cql(ipos)%numt,cql(ipos)%numt,& &1.d0,cql(ipos)%qlm,cql(ipos)%numpw,im_e_mat,lc%numt,0.d0,tmp_mat,cql(ipos)%numpw) call dgemm('N','T',cql(ipos)%numpw,cql(ipos)%numpw,cql(ipos)%numt,& &1.d0,tmp_mat,cql(ipos)%numpw,cql(ipos)%qlm,cql(ipos)%numpw,0.d0,im_c_mat(1,1,ipos,iw-nbegin_iw+1),cql(ipos)%numpw) enddo write(stdout,*) 'Done' call flush_unit(stdout) deallocate(tmp_mat) else write(stdout,*) 'Doing dgemms',ttl(1)%numl,ttl(1)%numt,vtl(1)%numl,vtl(1)%numpw call flush_unit(stdout) allocate(tmp_mat(ttl(1)%numl,ttl(1)%numt)) allocate(tmp_mat1(ttl(1)%numl,ttl(1)%numl)) allocate(tmp_mat2(numpw,ttl(1)%numl)) do ii=ii_begin,ii_end ipos=ii-ii_begin+1 write(stdout,*) 'ATTENZIONE1', ttl(ipos)%numl,ttl(ipos)%numt,vtl(ipos)%numl,vtl(ipos)%numpw call flush_unit(stdout) call dgemm('T','N',ttl(ipos)%numl,ttl(ipos)%numt,ttl(ipos)%numt,1.d0,ttl(ipos)%tt_mat,ttl(ipos)%numt,& &re_e_mat,lc%numt,0.d0,tmp_mat,ttl(ipos)%numl) write(stdout,*) 'ATTENZIONE2', ii call flush_unit(stdout) call dgemm('N','N',ttl(ipos)%numl,ttl(ipos)%numl,ttl(ipos)%numt,1.d0,tmp_mat,ttl(ipos)%numl,& ttl(ipos)%tt_mat,ttl(ipos)%numt,0.d0,tmp_mat1,ttl(ipos)%numl) write(stdout,*) 'ATTENZIONE3', ii, vtl(ipos)%numpw,vtl(ipos)%numl,vtl(ipos)%numl write(stdout,*) 'ATTENZIONE3', size(vtl(ipos)%vt_mat(:,1)), size(vtl(ipos)%vt_mat(1,:)), ttl(1)%numl, numpw call flush_unit(stdout) call dgemm('N','N',vtl(ipos)%numpw,vtl(ipos)%numl,vtl(ipos)%numl,1.d0,vtl(ipos)%vt_mat,vtl(ipos)%numpw,& &tmp_mat1,vtl(ipos)%numl,0.d0,tmp_mat2,numpw) write(stdout,*) 'ATTENZIONE4', ii call flush_unit(stdout) call dgemm('N','T',vtl(ipos)%numpw,vtl(ipos)%numpw,vtl(ipos)%numl,1.d0,tmp_mat2,numpw,vtl(ipos)%vt_mat,& vtl(ipos)%numpw,0.d0,re_c_mat(:,:,ipos,iw-nbegin_iw+1),numpw) write(stdout,*) 'ATTENZIONE5', ii call flush_unit(stdout) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1 call dgemm('T','N',ttl(ipos)%numl,ttl(ipos)%numt,ttl(ipos)%numt,1.d0,ttl(ipos)%tt_mat,ttl(ipos)%numt,& &im_e_mat,lc%numt,0.d0,tmp_mat,ttl(ipos)%numl) write(stdout,*) 'ATTENZIONE6', ii call flush_unit(stdout) call dgemm('N','N',ttl(ipos)%numl,ttl(ipos)%numl,ttl(ipos)%numt,1.d0,tmp_mat,ttl(ipos)%numl,& ttl(ipos)%tt_mat,ttl(ipos)%numt,0.d0,tmp_mat1,ttl(ipos)%numl) write(stdout,*) 'ATTENZIONE7', ii call flush_unit(stdout) call dgemm('N','N',vtl(ipos)%numpw,vtl(ipos)%numl,vtl(ipos)%numl,1.d0,vtl(ipos)%vt_mat,vtl(ipos)%numpw,& &tmp_mat1,vtl(ipos)%numl,0.d0,tmp_mat2,numpw) write(stdout,*) 'ATTENZIONE8', ii call flush_unit(stdout) call dgemm('N','T',vtl(ipos)%numpw,vtl(ipos)%numpw,vtl(ipos)%numl,1.d0,tmp_mat2,numpw,vtl(ipos)%vt_mat,& vtl(ipos)%numpw,0.d0,im_c_mat(:,:,ipos,iw-nbegin_iw+1),numpw) write(stdout,*) 'ATTENZIONE9', ii call flush_unit(stdout) enddo write(stdout,*) 'Done' call flush_unit(stdout) deallocate(tmp_mat,tmp_mat1,tmp_mat2) endif enddo write(stdout,*) 'Done' call flush_unit(stdout) !!!loop on w' parallelized if(.not.l_half) then l_blk= (tf%n+1)/nproc if(l_blk*nproc < (tf%n+1)) l_blk = l_blk+1 nbegin=mpime*l_blk nend=nbegin+l_blk-1 if(nend > tf%n) nend=tf%n else if(.not. tf%grid_freq == 5) then l_blk= (tf%n/2+1)/nproc if(l_blk*nproc < (tf%n/2+1)) l_blk = l_blk+1 nbegin=mpime*l_blk nend=nbegin+l_blk-1 if(nend > tf%n/2) nend=tf%n/2 else n_max=tf%n/2+1+(1+2*tf%second_grid_i)*tf%second_grid_n l_blk= (n_max)/nproc if(l_blk*nproc < (n_max)) l_blk = l_blk+1 nbegin=mpime*l_blk nend=nbegin+l_blk-1 if(nend > n_max) nend=n_max endif endif if(.not.l_conv) gw_tab(:,:)=(0.d0,0.d0) if(.not. tf%grid_freq == 5) then n_max=tf%n/2 else n_max=(tf%n-(1+2*tf%second_grid_i)*tf%second_grid_n)/2+& &(1+2*tf%second_grid_i)*tf%second_grid_n endif do jw=0,n_max ! do jw=nbegin,nbegin+l_blk-1 if(jw <= tf%n) then write(stdout,*) 'FREQ', jw call flush_unit(stdout) if(.not.options%l_reduce_io) then call read_polaw(jw, ww,options%debug,options%l_verbose) else call free_memory_polaw(ww) allocate(ww%pw(ww%numpw,ww%numpw)) if(jw>=nbegin_io .and. jw <= nend_io) then !ww%pw(:,:)=polaw_store(:,:,jw-nbegin_io+1) call dcopy( SIZE(ww%pw), polaw_store(1,1,jw-nbegin_io+1), 1, ww%pw(1,1), 1 ) else !ww%pw(:,:)=0.d0 do j = 1, SIZE( ww%pw, 2 ) do i = 1, SIZE( ww%pw, 1 ) ww%pw(i,j)=0.d0 end do end do endif iproc=jw/l_blk_io do kw=1,ww%numpw !call mp_sum(ww%pw(:,kw),world_comm) call mp_bcast(ww%pw(:,kw),iproc,world_comm) enddo !call mp_bcast(ww%pw(:,:),iproc,world_comm) endif if(l_conv) then !loop on iw if(tf%grid_freq == 3) then l_iw_min=.false. do iw=nbegin_iw,nend_iw ix=iw+jw ixx=iw-jw if((ix >= -tf%n .and. ix <= tf%n).or.(ixx >= -tf%n .and. ixx <= tf%n)) then if(.not.l_iw_min) then l_iw_min=.true. iw_min=iw endif iw_max=iw endif enddo if(l_iw_min) then allocate(mat_tmp(options%n_set_ii,l_blk_iw)) !the weights are all the same for this kind of grid call dgemv('T',ww%numpw*ww%numpw,options%n_set_ii*(iw_max-iw_min+1),& &tf%weights_freq(1),re_c_mat(1,1,1,iw_min-nbegin_iw+1),& &ww%numpw*ww%numpw,ww%pw,1,0.d0,mat_tmp,1) do iw=iw_min,iw_max ix=iw+jw ixx=iw-jw if(ix >= -tf%n .and. ix <= tf%n) then ss%diag(ii_begin:ii_end,ix+tf%n+1,1)=ss%diag(ii_begin:ii_end,ix+tf%n+1,1)+& &dcmplx(mat_tmp(:,iw-iw_min+1),0.d0)*ww%factor endif if(jw/=0) then if(ixx >= -tf%n .and. ixx <= tf%n) then ss%diag(ii_begin:ii_end,ixx+tf%n+1,1)=ss%diag(ii_begin:ii_end,ixx+tf%n+1,1)+& &dcmplx(mat_tmp(:,iw-iw_min+1),0.d0)*ww%factor endif endif enddo call dgemv('T',ww%numpw*ww%numpw,options%n_set_ii*(iw_max-iw_min+1),tf%weights_freq(1),& &im_c_mat(1,1,1,iw_min-nbegin_iw+1),ww%numpw*ww%numpw,ww%pw,1,0.d0,mat_tmp,1) do iw=iw_min,iw_max ix=iw+jw ixx=iw-jw if(ix >= -tf%n .and. ix <= tf%n) then ss%diag(ii_begin:ii_end,ix+tf%n+1,1)=ss%diag(ii_begin:ii_end,ix+tf%n+1,1)+& &dcmplx(0.d0,mat_tmp(:,iw-iw_min+1))*ww%factor endif if(jw/=0) then if(ixx >= -tf%n .and. ixx <= tf%n) then ss%diag(ii_begin:ii_end,ixx+tf%n+1,1)=ss%diag(ii_begin:ii_end,ixx+tf%n+1,1)+& &dcmplx(0.d0,mat_tmp(:,iw-iw_min+1))*ww%factor endif endif enddo deallocate(mat_tmp) endif else if (tf%grid_freq == 5) then l_iw_min=.false. do iw=nbegin_iw,nend_iw iw1=tf%whois_freq(iw) jw1=tf%whois_freq(jw) ix=iw1+jw1 jw1=tf%whois_freq(-jw) ixx=iw1+jw1 if((ix >= -ss%n .and. ix <= ss%n).or.(ixx >= -ss%n .and. ixx <= ss%n)) then if(.not.l_iw_min) then l_iw_min=.true. iw_min=iw endif iw_max=iw endif enddo if(l_iw_min) then allocate(mat_tmp(options%n_set_ii,l_blk_iw)) !the weights are all the same for this kind of grid call dgemv('T',ww%numpw*ww%numpw,options%n_set_ii*(iw_max-iw_min+1),& &1.d0,re_c_mat(1,1,1,iw_min-nbegin_iw+1),& &ww%numpw*ww%numpw,ww%pw,1,0.d0,mat_tmp,1) do iw=nbegin_iw,nend_iw iw1=tf%whois_freq(iw) jw1=tf%whois_freq(jw) ix=iw1+jw1 if(ix >= -ss%n .and. ix <= ss%n) then ss%diag(ii_begin:ii_end,ix+ss%n+1,1)=ss%diag(ii_begin:ii_end,ix+ss%n+1,1)+& &dcmplx(mat_tmp(:,iw-iw_min+1),0.d0)*tf%weights_freq(jw)*ww%factor*tf%relative_weight(iw)*tf%relative_weight(jw) endif jw1=tf%whois_freq(-jw) ix=iw1+jw1 if(ix >= -ss%n .and. ix <= ss%n) then ss%diag(ii_begin:ii_end,ix+ss%n+1,1)=ss%diag(ii_begin:ii_end,ix+ss%n+1,1)+& &dcmplx(mat_tmp(:,iw-iw_min+1),0.d0)*tf%weights_freq(-jw)*ww%factor*tf%relative_weight(iw)*tf%relative_weight(-jw) endif enddo call dgemv('T',ww%numpw*ww%numpw,options%n_set_ii*(iw_max-iw_min+1),& &1.d0,im_c_mat(1,1,1,iw_min-nbegin_iw+1),ww%numpw*ww%numpw,ww%pw,1,0.d0,mat_tmp,1) do iw=nbegin_iw,nend_iw iw1=tf%whois_freq(iw) jw1=tf%whois_freq(jw) ix=iw1+jw1 if(ix >= -ss%n .and. ix <= ss%n) then ss%diag(ii_begin:ii_end,ix+ss%n+1,1)=ss%diag(ii_begin:ii_end,ix+ss%n+1,1)+& &dcmplx(0.d0,mat_tmp(:,iw-iw_min+1))*tf%weights_freq(jw)*ww%factor*tf%relative_weight(iw)*tf%relative_weight(jw) endif jw1=tf%whois_freq(-jw) ix=iw1+jw1 if(ix >= -ss%n .and. ix <= ss%n) then ss%diag(ii_begin:ii_end,ix+ss%n+1,1)=ss%diag(ii_begin:ii_end,ix+ss%n+1,1)+& &dcmplx(0.d0,mat_tmp(:,iw-iw_min+1))*tf%weights_freq(-jw)*ww%factor*tf%relative_weight(iw)*tf%relative_weight(-jw) endif enddo deallocate(mat_tmp) endif else endif else !here does a explicit convolution do iw=nbegin_iw,nend_iw ! do iw=iw_min,iw_max !distribute re_c_mat and im_c_mat !if(iw_proc(iw-iw_min+1)==mpime) then ! re_c_tmp(:,:)=re_c_mat(:,:,iw-nbegin_iw+1) ! im_c_tmp(:,:)=im_c_mat(:,:,iw-nbegin_iw+1) !endif !call !mp_bcast(re_c_tmp(:,:),iw_proc(iw-iw_min+1),world_comm) !call !mp_bcast(im_c_tmp(:,:),iw_proc(iw-iw_min+1),world_comm) re_c_tmp(:,:)=re_c_mat(:,:,ipos,iw-nbegin_iw+1) im_c_tmp(:,:)=im_c_mat(:,:,ipos,iw-nbegin_iw+1)!ATTENZIONE TUTTO DA FARE gw_tab(iw,jw)=gw_tab(iw,jw)+& &ddot(ww%numpw*ww%numpw,re_c_tmp(:,1),1,ww%pw(:,1),1)*ww%factor gw_tab(iw,jw)=gw_tab(iw,jw)+(0.d0,1.d0)*& &ddot(ww%numpw*ww%numpw,im_c_tmp(:,1),1,ww%pw,1)*ww%factor if(jw/=0)then gw_tab(iw,-jw)=gw_tab(iw,-jw)+& &ddot(ww%numpw*ww%numpw,re_c_tmp(:,1),1,ww%pw(:,1),1)*ww%factor gw_tab(iw,-jw)=gw_tab(iw,-jw)+(0.d0,1.d0)*& &ddot(ww%numpw*ww%numpw,im_c_tmp(:,1),1,ww%pw,1)*ww%factor endif enddo endif else !here global io and parallel routines endif enddo if(.not.l_conv) then call mp_sum(gw_tab(:,:),world_comm) do ix=nbegin_freq,nbegin_freq+l_blk_freq-1 if(ix<=ss%n) then do jw=-tf%n,tf%n do iw=-tf%n,tf%n ss%diag(ii,ix+ss%n+1,1)=ss%diag(ii,ix+ss%n+1,1)+gw_tab(iw,jw)*exp_tab(iw,jw,ix-nbegin_freq+1) enddo enddo endif enddo endif deallocate(re_c_mat,im_c_mat) if(.not.l_conv) deallocate(re_c_tmp,im_c_tmp) !deallocate(iw_proc) enddo if(.not.l_direct) then do ii=1,options%n_set_ii call free_memory_compact_q_lanczos(cql(ii)) enddo else do ii=1,options%n_set_ii call free_memory(vtl(ii)) call free_memory(ttl(ii)) enddo endif call free_memory_polaw(ww) enddo deallocate(cterm) if(options%l_reduce_io) then if(nend_io >= nbegin_io) deallocate(polaw_store) endif if(.not.l_direct) then deallocate(cql) else deallocate(vtl,ttl) endif !set global factor call mp_sum(ss%diag(:,:,:),world_comm) if(l_conv) then ss%diag(:,:,:)=ss%diag(:,:,:)*(1.d0/tpi) else ss%diag(:,:,:)=ss%diag(:,:,:)*(1.d0/tpi**2.d0) endif ss%diag_freq_fit(:,:,:)=ss%diag(:,:,:) call free_memory(lc) deallocate(re_e_mat, im_e_mat) call free_memory_lanczos_matrix(lm) if(.not.l_conv) then deallocate(gw_tab,exp_tab) endif deallocate(diag_tmp) return end subroutine do_self_lanczos subroutine solve_lanczos_fake_complex(lc) !this subroutine is a parallel fake routine for the solve lanczos routine USE kinds, ONLY : DP USE basic_structures, ONLY : lanczos_chain, initialize_memory,free_memory USE io_global, ONLY : stdout USE mp, ONLY : mp_sum,mp_bcast USE mp_world, ONLY : nproc,mpime,world_comm implicit none TYPE(lanczos_chain) :: lc!lanczos chain descriptor INTEGER :: l_blk,nbegin,nend, iproc REAL(kind=DP), ALLOCATABLE :: o_mat(:,:) INTEGER :: io allocate(o_mat(lc%numt,lc%num_steps)) l_blk= (lc%numt)/nproc if(l_blk*nproc < (lc%numt)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 !loop on io do io=1,lc%numt !recover matrix from processor o_mat(:,:)=0.d0 if(io >= nbegin .and. io <= nend) then o_mat(:,:)=lc%o_mat(:,:,io-nbegin+1) endif ! call mp_sum(o_mat(:,:),world_comm)!this should be much faster than mp_bcast iproc=(io-1)/l_blk call mp_bcast(o_mat(:,:), iproc,world_comm) enddo deallocate(o_mat) end subroutine solve_lanczos_fake_complex GWW/gww/Makefile0000644000077300007730000000340712341332532014260 0ustar giannozzgiannozz# Makefile for GWW # Author: G. Stenuit and L. Martin-Samos # include ../../make.sys # location of include files IFLAGS= # location of needed modules MODFLAGS= $(MOD_FLAG)../../iotk/src $(MOD_FLAG)../../Modules \ $(MOD_FLAG)../pw4gww $(MOD_FLAG). #location of needed libraries LIBOBJS= ../../iotk/src/libiotk.a ../../flib/flib.a \ ../../clib/clib.a ../../flib/ptools.a GWWOBJS = \ basic_structures.o \ compact_product.o \ contour.o \ create_hf.o \ create_quasi_particle.o \ create_quasi_particle_off.o \ do_contour.o \ do_polarization_lanczos.o \ do_self_lanczos.o \ do_self_lanczos_time.o \ do_self_lanczos_full.o \ energies_gww.o \ expansion.o \ fft_gw.o \ fit_multipole.o \ fit_polynomial.o \ go_dressed_w.o \ go_exchange.o \ go_fft.o \ go_green.o \ go_polarization.o \ green_function.o \ gv_time.o \ input_gw.o \ lanczos_polarization.o \ para_gww.o \ polarization.o \ read_data_pw.o \ remainder.o \ self_energy.o \ self_energy_storage.o \ start_end.o \ times_gw.o \ vcprim.o QEMODS = ../../Modules/libqemod.a LIBMIN= ../minpack/minpacklib.a TLDEPS=bindir mods libs libiotk all : tldeps gww.x gww_fit.x libgww.a gww.x : gww.o $(GWWOBJS) $(LIBOBJS) $(QEMODS) $(LIBMIN) $(MPIF90) $(LDFLAGS) -o $@ \ gww.o $(GWWOBJS) $(QEMODS) $(LIBOBJS) $(LIBMIN) $(LIBS) - ( cd ../../bin; ln -fs ../GWW/gww/$@ . ) gww_fit.x : gww_fit.o $(GWWOBJS) $(LIBOBJS) $(QEMODS) $(LIBMIN) $(MPIF90) $(LDFLAGS) -o $@ \ gww_fit.o $(GWWOBJS) $(QEMODS) $(LIBOBJS) $(LIBMIN) $(LIBS) - ( cd ../../bin; ln -fs ../GWW/gww/$@ . ) libgww.a : $(GWWOBJS) $(AR) $(ARFLAGS) $@ $(GWWOBJS) tldeps : if test -n "$(TLDEPS)" ; then \ ( cd ../.. ; $(MAKE) $(TLDEPS) || exit 1 ) ; fi clean : - /bin/rm -f -v gww.x gww_fit.x *.o *~ *.F90 *.d *.mod *.i work.pc include make.depend # DO NOT DELETE GWW/gww/expansion.f900000644000077300007730000007504512341332532015153 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! MODULE expansion !this module conatins descriptions and subroutine for a multipole expansion !of the self energy USE kinds, ONLY : DP TYPE self_expansion !all the parameters for the exapnsion !the fit is on the POSITIVE imaginary axes INTEGER :: max_i !number of states considered INTEGER :: i_min!minimum state to be considered INTEGER :: i_max!maximum state to be considered INTEGER :: n_multipoles!number of multipoles considered INTEGER :: nspin!spin multiplicity COMPLEX(kind=DP), DIMENSION(:,:), POINTER :: a_0!parameters a_0 COMPLEX(kind=DP), DIMENSION(:,:,:), POINTER :: a!parameters a (n_multipoles,max_i) COMPLEX(kind=DP), DIMENSION(:,:,:), POINTER :: b!parameters b (n_multipoles,max_i) LOGICAL :: whole_s!if true consider also off diagonal elements INTEGER :: i_min_whole!range for off diagonal elements INTEGER :: i_max_whole COMPLEX(kind=DP), DIMENSION(:,:,:), POINTER :: a_0_off!parameters a_0 for off diagonal COMPLEX(kind=DP), DIMENSION(:,:,:,:), POINTER :: a_off!parameters a (n_multipoles,range,max_i) for off diagonal COMPLEX(kind=DP), DIMENSION(:,:,:,:), POINTER :: b_off!parameters b (n_multipoles,range,max_i) for off diagonal END TYPE self_expansion CONTAINS SUBROUTINE initialize_self_expansion(se) implicit none TYPE(self_expansion) :: se nullify(se%a_0) nullify(se%a) nullify(se%b) nullify(se%a_0_off) nullify(se%a_off) nullify(se%b_off) return END SUBROUTINE initialize_self_expansion SUBROUTINE free_memory_self_expansion(se) !if allocated deallocates implicit none TYPE(self_expansion) :: se if(associated(se%a_0)) then deallocate(se%a_0) nullify(se%a_0) endif if(associated(se%a)) then deallocate(se%a) nullify(se%a) endif if(associated(se%b)) then deallocate(se%b) nullify(se%b) endif if(associated(se%a_0_off)) then deallocate(se%a_0_off) nullify(se%a_0_off) endif if(associated(se%a_off)) then deallocate(se%a_off) nullify(se%a_off) endif if(associated(se%b_off)) then deallocate(se%b_off) nullify(se%b_off) endif return END SUBROUTINE SUBROUTINE write_self_expansion(se) !this subroutine writes the multipole expansion on disk USE io_global, ONLY : stdout, ionode USE input_gw, ONLY : input_options USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(self_expansion), INTENT(in) :: se!object to be written INTEGER :: iun if(ionode) then iun = find_free_unit() open(unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'self_expansion', status='unknown',form='unformatted') write(iun) se%max_i write(iun) se%i_min write(iun) se%i_max write(iun) se%n_multipoles write(iun) se%nspin write(iun) se%whole_s write(iun) se%i_min_whole write(iun) se%i_max_whole write(iun) se%a_0(1:se%max_i,1:se%nspin) write(iun) se%a(1:se%n_multipoles,1:se%max_i,1:se%nspin) write(iun) se%b(1:se%n_multipoles,1:se%max_i,1:se%nspin) if(se%whole_s) then write(iun) se%a_0_off(se%i_min_whole:se%i_max_whole,1:se%max_i,1:se%nspin) write(iun) se%a_off(1:se%n_multipoles,se%i_min_whole:se%i_max_whole,1:se%max_i,1:se%nspin) write(iun) se%b_off(1:se%n_multipoles,se%i_min_whole:se%i_max_whole,1:se%max_i,1:se%nspin) endif close(iun) endif return END SUBROUTINE write_self_expansion SUBROUTINE read_self_expansion(se) !this subroutine reads the multipole expansion from disk USE io_global, ONLY : stdout, ionode, ionode_id USE input_gw, ONLY : input_options USE io_files, ONLY : prefix,tmp_dir USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(self_expansion), INTENT(out) :: se!object to be written INTEGER :: iun if(ionode) then iun = find_free_unit() open(unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'self_expansion', status='old',form='unformatted') read(iun) se%max_i read(iun) se%i_min read(iun) se%i_max read(iun) se%n_multipoles read(iun) se%nspin read(iun) se%whole_s read(iun) se%i_min_whole read(iun) se%i_max_whole endif call mp_bcast(se%max_i, ionode_id,world_comm) call mp_bcast(se%i_min, ionode_id,world_comm) call mp_bcast(se%i_max, ionode_id,world_comm) call mp_bcast(se%n_multipoles, ionode_id,world_comm) call mp_bcast(se%nspin, ionode_id,world_comm) call mp_bcast(se%whole_s, ionode_id,world_comm) call mp_bcast(se%i_min_whole, ionode_id,world_comm) call mp_bcast(se%i_max_whole, ionode_id,world_comm) allocate(se%a_0(se%max_i,se%nspin),se%a(se%n_multipoles,se%max_i,se%nspin)) allocate(se%b(se%n_multipoles,se%max_i,se%nspin)) if(ionode) then read(iun) se%a_0(1:se%max_i,1:se%nspin) read(iun) se%a(1:se%n_multipoles,1:se%max_i,1:se%nspin) read(iun) se%b(1:se%n_multipoles,1:se%max_i,1:se%nspin) endif call mp_bcast(se%a_0,ionode_id,world_comm) call mp_bcast(se%a, ionode_id,world_comm) call mp_bcast(se%b, ionode_id,world_comm) if(se%whole_s) then allocate(se%a_0_off(se%i_min_whole:se%i_max_whole,se%max_i,se%nspin)) allocate( se%a_off(se%n_multipoles,se%i_min_whole:se%i_max_whole,se%max_i,se%nspin)) allocate(se%b_off(se%n_multipoles,se%i_min_whole:se%i_max_whole,se%max_i,se%nspin)) if(ionode) then read(iun) se%a_0_off(se%i_min_whole:se%i_max_whole,1:se%max_i,1:se%nspin) read(iun) se%a_off(1:se%n_multipoles,se%i_min_whole:se%i_max_whole,1:se%max_i,1:se%nspin) read(iun) se%b_off(1:se%n_multipoles,se%i_min_whole:se%i_max_whole,1:se%max_i,1:se%nspin) endif call mp_bcast(se%a_0_off,ionode_id,world_comm) call mp_bcast(se%a_off, ionode_id,world_comm) call mp_bcast(se%b_off, ionode_id,world_comm) else nullify(se%a_0_off) nullify(se%a_off) nullify(se%b_off) endif if(ionode) close(iun) return END SUBROUTINE read_self_expansion SUBROUTINE create_self_energy_fit( tf, se,ss, options,sr,l_real_axis) !this subroutine fit the self energy in the imaginary frequency !with a multipole complex function !parallel on states USE io_global, ONLY : stdout USE input_gw, ONLY : input_options USE constants, ONLY : pi USE self_energy_storage, ONLY : self_storage, self_on_real USE para_gww, ONLY : is_my_state_range USE mp, ONLY : mp_sum,mp_barrier USE mp_world, ONLY : world_comm USE times_gw, ONLY : times_freqs implicit none TYPE(times_freqs), INTENT(in) :: tf!frequency grid TYPE(self_expansion) :: se!fit to be created TYPE(self_storage) :: ss!data on frequency TYPE(input_options) :: options! for number of multipoles TYPE(self_on_real), INTENT(in) :: sr!for self energy on real axis LOGICAL, INTENT(in) :: l_real_axis INTEGER :: ii,jj, kk,is COMPLEX(kind=DP), ALLOCATABLE :: z(:),s(:) REAL(kind=DP) :: df,freq, totalperiod, chi, chi0 INTEGER :: icyc COMPLEX(kind=DP) :: a_0_old, a_0_good COMPLEX(kind=DP), ALLOCATABLE :: a_old(:), b_old(:), a_good(:), b_good(:) INTEGER :: n_sample !sets: se%max_i=options%max_i se%i_min=options%i_min se%i_max=options%i_max se%n_multipoles=options%n_multipoles se%whole_s=options%whole_s se%i_min_whole=options%i_min_whole se%i_max_whole=options%i_max_whole se%nspin=ss%nspin !allocates: ! call free_memory_self_expansion(se) allocate(se%a_0(se%max_i,se%nspin)) allocate(se%a(se%n_multipoles,se%max_i,se%nspin)) allocate(se%b(se%n_multipoles,se%max_i,se%nspin)) if(se%whole_s) then allocate(se%a_0_off(se%i_min_whole:se%i_max_whole,se%max_i,se%nspin)) allocate(se%a_off(se%n_multipoles,se%i_min_whole:se%i_max_whole,se%max_i,se%nspin)) allocate(se%b_off(se%n_multipoles,se%i_min_whole:se%i_max_whole,se%max_i,se%nspin)) else nullify(se%a_0_off) nullify(se%a_off) nullify(se%b_off) endif allocate(a_old(se%n_multipoles)) allocate(b_old(se%n_multipoles)) allocate(a_good(se%n_multipoles)) allocate(b_good(se%n_multipoles)) ! allocate(z(ss%n_grid_fit),s(ss%n_grid_fit)) if(.not.l_real_axis) then allocate(z(options%n_fit),s(options%n_fit)) !allocate and set data arrays totalperiod=2.d0*ss%tau+2.d0*ss%tau/real(ss%n) df=2.d0*pi/totalperiod if(options%offset_fit == 0) then do ii=1,options%n_fit-1 if(tf%l_fft_timefreq) then freq=df*real(ii) else freq=tf%freqs_fit(ii) endif z(ii+1)=cmplx(0.d0,freq) enddo z(1)=(0.d0,0.d0) else do ii=1,options%n_fit if(tf%l_fft_timefreq) then freq=df*real(ii+options%offset_fit-1) else freq=tf%freqs_fit(ii+options%offset_fit-1) endif z(ii)=cmplx(0.d0,freq) enddo endif else allocate(z(options%n_real_axis),s(options%n_real_axis)) z(1:options%n_real_axis)=sr%grid(1:options%n_real_axis) endif !some checks if(ss%ontime .and. tf%grid_fit==0) then write(stdout,*) 'Subroutine self_energy_fit: imaginary frequency required' stop endif if(se%whole_s) then se%a_0_off=(0.d0,0.d0) se%a_off=(0.d0,0.d0) se%b_off=(0.d0,0.d0) endif se%a_0=(0.d0,0.d0) se%a(:,:,:)=(0.d0,0.d0) se%b(:,:,:)=(0.d0,0.d0) !loop on spin do is=1,se%nspin do ii=se%i_min,se%i_max!loop on states chi0=1.d10 !set initial values if(is_my_state_range(ii)) then if(.not.l_real_axis) then if(tf%grid_fit==0) then do jj=1,options%n_fit!ss%n s(jj)=ss%diag(ii,jj+ss%n+1,is) enddo else !do jj=1,ss%n_grid_fit do jj=0+options%offset_fit,options%n_fit+options%offset_fit-1!ATTENZIONE s(jj-options%offset_fit+1)=ss%diag_freq_fit(ii,jj+ss%n_grid_fit+1,is)!ATTENZIONE enddo endif else s(1:options%n_real_axis)=sr%diag(1:options%n_real_axis,ii,1) endif se%a_0(ii,is)=(0.0,0.0d0) do jj=1,options%n_multipoles se%a(jj,ii,is)=cmplx(real(jj)*(0.01d0),0.d0) se%b(jj,ii,is)=cmplx((0.5d0)*real(jj)*(-1.d0)**real(jj),-0.01d0) enddo do icyc=1,options%cyc_minpack write(stdout,*) 'Call fit_multipole' call flush_unit(stdout) if(.not.l_real_axis) then n_sample=options%n_fit else n_sample=options%n_real_axis endif call fit_multipole(n_sample,options%n_multipoles,z,s,se%a_0(ii,is),& &se%a(:,ii,is),se%b(:,ii,is),1.d0,options%fit_thres,options%fit_maxiter) write(stdout,*) 'Done' call flush_unit(stdout) a_0_old=se%a_0(ii,is) do jj=1,options%n_multipoles a_old(jj)=se%a(jj,ii,is) b_old(jj)=se%b(jj,ii,is) enddo if(options%n_max_minpack /= 0) then write(stdout,*) 'Calling minpack'!ATTENZIONE call flush_unit(stdout) call fit_multipole_minpack(n_sample,options%n_multipoles,z,s,se%a_0(ii,is),& &se%a(:,ii,is),se%b(:,ii,is),options%fit_thres, options%n_max_minpack, chi) write(stdout,*) 'Done'!ATTENZIONE call flush_unit(stdout) endif if(chi <= chi0) then a_0_good=se%a_0(ii,is) do jj=1,options%n_multipoles a_good(jj)=se%a(jj,ii,is) b_good(jj)=se%b(jj,ii,is) enddo chi0=chi endif se%a_0(ii,is)=a_0_old do jj=1,options%n_multipoles se%a(jj,ii,is)=a_old(jj) se%b(jj,ii,is)=b_old(jj) enddo enddo se%a_0(ii,is)=a_0_good do jj=1,options%n_multipoles se%a(jj,ii,is)=a_good(jj) se%b(jj,ii,is)=b_good(jj) enddo write(stdout,*) 'FIT state :', ii,is write(stdout,*) 'FIT a_0:', se%a_0(ii,is) do jj=1,options%n_multipoles write(stdout,*) 'FIT a:',jj,se%a(jj,ii,is) write(stdout,*) 'FIT b:',jj,se%b(jj,ii,is) enddo call flush_unit(stdout) endif enddo call mp_sum(se%a_0(:,is),world_comm) call mp_sum(se%a(:,:,is),world_comm) call mp_sum(se%b(:,:,is),world_comm) !!!!!!!!!!!now off diagonal part if(se%whole_s) then do kk=se%i_min_whole,se%i_max_whole do ii=se%i_min,se%i_max!lo chi0=1.d10 !set initial values if(is_my_state_range(ii)) then if(tf%grid_fit==0) then do jj=1,options%n_fit!ss%n s(jj)=ss%whole(kk,ii,jj+ss%n+1,is) enddo else do jj=0+options%offset_fit,options%n_fit+options%offset_fit-1!ATTENZIONE s(jj-options%offset_fit+1)=ss%whole_freq_fit(kk,ii,jj+ss%n_grid_fit+1,is)!ATTENZIONE enddo endif se%a_0_off(kk,ii,is)=(0.0,0.0d0) do jj=1,options%n_multipoles se%a_off(jj,kk,ii,is)=cmplx(real(jj)*(0.01d0),0.d0) se%b_off(jj,kk,ii,is)=cmplx((0.5d0)*real(jj)*(-1.d0)**real(jj),-0.01d0) enddo do icyc=1,options%cyc_minpack call fit_multipole(options%n_fit,options%n_multipoles,z,s,& &se%a_0_off(kk,ii,is),se%a_off(:,kk,ii,is),se%b_off(:,kk,ii,is),& &1.d0,options%fit_thres,options%fit_maxiter) a_0_old=se%a_0_off(kk,ii,is) do jj=1,options%n_multipoles a_old(jj)=se%a_off(jj,kk,ii,is) b_old(jj)=se%b_off(jj,kk,ii,is) enddo if(options%n_max_minpack /= 0) then write(stdout,*) 'Calling minpack'!ATTENZIONE call flush_unit(stdout) call fit_multipole_minpack(options%n_fit,options%n_multipoles,z,s,& &se%a_0_off(kk,ii,is),se%a_off(:,kk,ii,is),se%b_off(:,kk,ii,is),options%fit_thres, options%n_max_minpack, chi) endif if(chi <= chi0) then a_0_good=se%a_0_off(kk,ii,is) do jj=1,options%n_multipoles a_good(jj)=se%a_off(jj,kk,ii,is) b_good(jj)=se%b_off(jj,kk,ii,is) enddo chi0=chi endif se%a_0_off(kk,ii,is)=a_0_old do jj=1,options%n_multipoles se%a_off(jj,kk,ii,is)=a_old(jj) se%b_off(jj,kk,ii,is)=b_old(jj) enddo enddo se%a_0_off(kk,ii,is)=a_0_good do jj=1,options%n_multipoles se%a_off(jj,kk,ii,is)=a_good(jj) se%b_off(jj,kk,ii,is)=b_good(jj) enddo write(stdout,*) 'FIT off diagonal :', ii, kk,is write(stdout,*) 'FIT a_0:', se%a_0_off(kk,ii,is) do jj=1,options%n_multipoles write(stdout,*) 'FIT a:',jj,se%a_off(jj,kk,ii,is) write(stdout,*) 'FIT b:',jj,se%b_off(jj,kk,ii,is) enddo call flush_unit(stdout) endif enddo enddo call mp_sum(se%a_0_off(:,:,is),world_comm) call mp_sum(se%a_off(:,:,:,is),world_comm) call mp_sum(se%b_off(:,:,:,is),world_comm) endif enddo!nspin deallocate(z,s) deallocate(a_old,b_old) deallocate(a_good,b_good) call mp_barrier( world_comm ) write(stdout,*) 'Out of create_self_energy_fit' call flush_unit(stdout) return END SUBROUTINE create_self_energy_fit SUBROUTINE func_fit(se,z,i,fz) !this functions returns the value of the fit at z, !relative to the i-th parameters implicit none TYPE(self_expansion) :: se!parameters of fits COMPLEX(kind=DP) :: z!where INTEGER :: i !which set of parameters COMPLEX(kind=DP) :: fz COMPLEX(kind=DP) :: num, den INTEGER :: jj fz=se%a_0(i,1) do jj=1,se%n_multipoles fz=fz+se%a(jj,i,1)/(z-se%b(jj,i,1)) enddo return END SUBROUTINE SUBROUTINE print_fit_onfile(tf, se,ss) !this subroutines prints the resulta of the fit on file: !real and imaginary part on imaginary frequency, with results self_energy !and real and imaginary part on real frequency !parallel on states USE self_energy_storage, ONLY : self_storage USE constants, ONLY : pi USE io_global, ONLY : ionode USE para_gww, ONLY : is_my_state_range USE times_gw, ONLY : times_freqs USE io_files, ONLY : prefix, tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(times_freqs), INTENT(in) :: tf!for frequency grid TYPE(self_expansion) :: se!parameters of fit TYPE(self_storage) :: ss!self energy data INTEGER :: ii,jj,kk,is INTEGER :: iun CHARACTER(5) :: nfile,mfile REAL(kind=DP) :: totalperiod,df,freq COMPLEX(kind=DP) :: zz COMPLEX(kind=DP) :: fz, gz do is=1,se%nspin do ii=se%i_min,se%i_max!loop on states if(is_my_state_range(ii)) then !set file name write(nfile,'(5i1)') & & ii/10000,mod(ii,10000)/1000,mod(ii,1000)/100,mod(ii,100)/10,mod(ii,10) totalperiod=2.d0*ss%tau+2.d0*ss%tau/real(ss%n) df=2.d0*pi/totalperiod !now real part on imaginary frequency !openfile iun = find_free_unit() if(is==1) then open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'re_on_im'// nfile, status='unknown',form='formatted') else open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'re_on_im2'// nfile, status='unknown',form='formatted') endif do jj=-ss%n_grid_fit,ss%n_grid_fit !allocate and set data arrays if(tf%l_fft_timefreq) then freq=df*real(jj) else freq=tf%freqs_fit(jj) endif zz=cmplx(0.d0,freq) call value_on_frequency(se,ii,freq,gz,is) !call func_fit(se,zz,ii,fz) call value_on_frequency_complex(se,ii,zz,fz,is) if(tf%grid_fit==0) then write(iun,'(4f14.8)') freq, real(fz),real(ss%diag(ii,jj+ss%n,is)),real( gz) else write(iun,'(4f14.8)') freq, real(fz),real(ss%diag_freq_fit(ii,jj+ss%n_grid_fit+1,is)),real( gz) endif enddo close(iun) !now imaginary part on imaginary frequency !openfile iun = find_free_unit() if(is==1) then open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'im_on_im'// nfile, status='unknown',form='formatted') else open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'im_on_im2'// nfile, status='unknown',form='formatted') endif do jj=-ss%n_grid_fit,ss%n_grid_fit !allocate and set data arrays if(tf%l_fft_timefreq) then freq=df*real(jj) else freq=tf%freqs_fit(jj) endif zz=cmplx(0.d0,freq) call value_on_frequency(se,ii,freq,gz,is) !call func_fit(se,zz,ii,fz) call value_on_frequency_complex(se,ii,zz,fz,is) if(tf%grid_fit==0) then write(iun,'(4f14.8)') freq, aimag(fz),aimag(ss%diag(ii,jj+ss%n+1,is)), aimag(gz) else write(iun,'(4f14.8)') freq, aimag(fz),aimag(ss%diag_freq_fit(ii,jj+ss%n_grid_fit+1,is)), aimag(gz) endif enddo close(iun) !now off diagonal terms if(se%whole_s) then !set file name do kk=se%i_min_whole,se%i_max_whole write(nfile,'(5i1)') & & kk/10000,mod(kk,10000)/1000,mod(kk,1000)/100,mod(kk,100)/10,mod(kk,10) write(mfile,'(5i1)') & & ii/10000,mod(ii,10000)/1000,mod(ii,1000)/100,mod(ii,100)/10,mod(ii,10) totalperiod=2.d0*ss%tau+2.d0*ss%tau/real(ss%n) df=2.d0*pi/totalperiod !now real part on imaginary frequency !openfile iun = find_free_unit() if(is==1) then open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'off_re_on_im'// nfile // '_' // mfile, & &status='unknown',form='formatted') else open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'off_re_on_im2'// nfile // '_' // mfile, & &status='unknown',form='formatted') endif do jj=-ss%n_grid_fit,ss%n_grid_fit !allocate and set data arrays if(tf%l_fft_timefreq) then freq=df*real(jj) else freq=tf%freqs_fit(jj) endif zz=cmplx(0.d0,freq) call value_on_frequency_off(se,kk,ii,freq,gz,is) !call func_fit(se,zz,ii,fz) call value_on_frequency_complex_off(se,kk,ii,zz,fz,is) if(tf%grid_fit==0) then write(iun,'(4f12.6)') freq, real(fz),real(ss%whole(kk,ii,jj+ss%n,is)),real( gz) else write(iun,'(4f12.6)') freq, real(fz),real(ss%whole_freq_fit(kk,ii,jj+ss%n_grid_fit+1,is)),real( gz) endif enddo close(iun) !now imaginary part on imaginary frequency !openfile iun = find_free_unit() if(is==1) then open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'off_im_on_im'// nfile // '_' // mfile, & &status='unknown',form='formatted') else open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'off_im_on_im2'// nfile // '_' // mfile, & &status='unknown',form='formatted') endif do jj=-ss%n_grid_fit,ss%n_grid_fit !allocate and set data arrays if(tf%l_fft_timefreq) then freq=df*real(jj) else freq=tf%freqs_fit(jj) endif zz=cmplx(0.d0,freq) call value_on_frequency_off(se,kk,ii,freq,gz,is) !call func_fit(se,zz,ii,fz) call value_on_frequency_complex_off(se,kk,ii,zz,fz,is) if(tf%grid_fit==0) then write(iun,'(4f12.6)') freq, aimag(fz),aimag(ss%whole(kk,ii,jj+ss%n+1,is)), aimag(gz) else write(iun,'(4f12.6)') freq, aimag(fz),aimag(ss%whole_freq_fit(kk,ii,jj+ss%n_grid_fit+1,is)), aimag(gz) endif enddo close(iun) enddo endif endif enddo enddo!loop on spin return END SUBROUTINE print_fit_onfile SUBROUTINE value_on_frequency(se,is,omega,sigma,ispin) !this subroutine calculates the value of the correlation !part of the self-energy on real frequency USE io_global, ONLY : stdout implicit none TYPE(self_expansion),INTENT(in) :: se!self expansion data INTEGER,INTENT(in) :: is!state considered REAL(kind=DP), INTENT(in) :: omega!real frequency considered COMPLEX(kind=DP), INTENT(out) :: sigma! <\Psi_i|\Sigma_c(w)|\Psi_i> INTEGER, INTENT(in) :: ispin!spin channel INTEGER :: ii !control is if(is>se%max_i) then write(stdout,*) 'Routine value_on_frequency is too large' stop endif if(omega >= 0 ) then sigma=se%a_0(is,ispin) do ii=1,se%n_multipoles sigma=sigma+se%a(ii,is,ispin)/(cmplx(omega,0.d0)-se%b(ii,is,ispin)) enddo else sigma=conjg(se%a_0(is,ispin)) do ii=1,se%n_multipoles sigma=sigma+conjg(se%a(ii,is,ispin))/(cmplx(omega,0.d0)-conjg(se%b(ii,is,ispin))) enddo endif return END SUBROUTINE SUBROUTINE value_on_frequency_off(se,is,js,omega,sigma,ispin) !this subroutine calculates the value of the correlation !part of the self-energy on real frequency USE io_global, ONLY : stdout implicit none TYPE(self_expansion),INTENT(in) :: se!self expansion data INTEGER,INTENT(in) :: is,js!state considered REAL(kind=DP), INTENT(in) :: omega!real frequency considered COMPLEX(kind=DP), INTENT(out) :: sigma! <\Psi_i|\Sigma_c(w)|\Psi_i> INTEGER, INTENT(in) :: ispin!spin channel INTEGER :: ii if(omega >= 0 ) then sigma=se%a_0_off(is,js,ispin) do ii=1,se%n_multipoles sigma=sigma+se%a_off(ii,is,js,ispin)/(cmplx(omega,0.d0)-se%b_off(ii,is,js,ispin)) enddo else sigma=conjg(se%a_0_off(is,js,ispin)) do ii=1,se%n_multipoles sigma=sigma+conjg(se%a_off(ii,is,js,ispin))/(cmplx(omega,0.d0)-conjg(se%b_off(ii,is,js,ispin))) enddo endif return END SUBROUTINE value_on_frequency_off SUBROUTINE derivative_on_frequency(se,is,omega,dsigma,ispin) !this subroutine calculates the value of the correlation !part of the self-energy on real frequency USE io_global, ONLY : stdout implicit none TYPE(self_expansion),INTENT(in) :: se!self expansion data INTEGER,INTENT(in) :: is!state considered REAL(kind=DP), INTENT(in) :: omega!real frequency considered COMPLEX(kind=DP), INTENT(out) :: dsigma! (d<\Psi_i|\Sigma_c(w')|\Psi_i>/dw')_w INTEGER, INTENT(in) :: ispin!spin channel INTEGER :: ii !control is if(is>se%max_i) then write(stdout,*) 'Routine value_on_frequency is too large' stop endif if(omega >= 0 ) then dsigma=(0.d0,0.d0) do ii=1,se%n_multipoles dsigma=dsigma-se%a(ii,is,ispin)/((cmplx(omega,0.d0)-se%b(ii,is,ispin))**2.d0) enddo else dsigma=(0.d0,0.d0) do ii=1,se%n_multipoles dsigma=dsigma-conjg(se%a(ii,is,ispin))/((cmplx(omega,0.d0)-conjg(se%b(ii,is,ispin)))**2.d0) enddo endif return END SUBROUTINE SUBROUTINE value_on_frequency_complex(se,is,omega,sigma,ispin) !this subroutine calculates the value of the correlation !part of the self-energy on complex frequency USE io_global, ONLY : stdout implicit none TYPE(self_expansion),INTENT(in) :: se!self expansion data INTEGER,INTENT(in) :: is!state considered COMPLEX(kind=DP), INTENT(in) :: omega!real frequency considered COMPLEX(kind=DP), INTENT(out) :: sigma! <\Psi_i|\Sigma_c(w)|\Psi_i> INTEGER, INTENT(in) :: ispin!spin channel INTEGER :: ii !control is if(is>se%max_i) then write(stdout,*) 'Routine value_on_frequency is too large' stop endif if(real(omega) >= 0 ) then sigma=se%a_0(is,ispin) do ii=1,se%n_multipoles sigma=sigma+se%a(ii,is,ispin)/(omega-se%b(ii,is,ispin)) enddo else sigma=conjg(se%a_0(is,ispin)) do ii=1,se%n_multipoles sigma=sigma+conjg(se%a(ii,is,ispin))/(omega-conjg(se%b(ii,is,ispin)))!ATTENZIONE must be checked!!! enddo endif return END SUBROUTINE SUBROUTINE value_on_frequency_complex_off(se,is,js,omega,sigma,ispin) !this subroutine calculates the value of the correlation !part of the self-energy on complex frequency USE io_global, ONLY : stdout implicit none TYPE(self_expansion),INTENT(in) :: se!self expansion data INTEGER,INTENT(in) :: is,js!state considered COMPLEX(kind=DP), INTENT(in) :: omega!real frequency considered COMPLEX(kind=DP), INTENT(out) :: sigma! <\Psi_i|\Sigma_c(w)|\Psi_i> INTEGER, INTENT(in) :: ispin!spin channel INTEGER :: ii if(real(omega) >= 0 ) then sigma=se%a_0_off(is,js,ispin) do ii=1,se%n_multipoles sigma=sigma+se%a_off(ii,is,js,ispin)/(omega-se%b_off(ii,is,js,ispin)) enddo else sigma=conjg(se%a_0_off(is,js,ispin)) do ii=1,se%n_multipoles sigma=sigma+conjg(se%a_off(ii,is,js,ispin))/(omega-conjg(se%b_off(ii,is,js,ispin))) enddo endif return END SUBROUTINE value_on_frequency_complex_off END MODULE GWW/gww/remainder.f900000644000077300007730000003370012341332532015105 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !Program GWW P. Umari SUBROUTINE remainder(options, qp) !this subroutine calculates the remainder USE constants, ONLY : eps8 USE io_global, ONLY : stdout, ionode, ionode_id USE input_gw, ONLY : input_options USE basic_structures, ONLY : q_mat, wannier_u, wp_psi, wp_psi_cutoff_index,wp_psi_cutoff_data,free_memory USE green_function, ONLY : green,read_green,free_memory_green, initialize_green USE polarization, ONLY : polaw,free_memory_polaw,read_polaw, initialize_polaw USE compact_product USE mp, ONLY : mp_sum, mp_bcast USE mp_world, ONLY : world_comm USE para_gww, ONLY : is_my_time, is_my_pola, is_my_state USE energies_gww, ONLY : quasi_particles USE constants, ONLY : RYTOEV USE energies_gww, ONLY : quasi_particles implicit none INTERFACE SUBROUTINE set_data_wp_psi_cutoff(pw_red,pw,wpi) USE kinds, ONLY : DP USE basic_structures, ONLY : wp_psi_cutoff_index USE polarization, ONLY : polaw COMPLEX(kind=DP), DIMENSION(:), POINTER :: pw_red TYPE(polaw) :: pw!data to be contracted TYPE(wp_psi_cutoff_index) :: wpi !indices END SUBROUTINE set_data_wp_psi_cutoff SUBROUTINE self_energy_remainder_cutoff(state,rem,wp,pw_red) USE kinds, ONLY : DP USE basic_structures, ONLY : wp_psi_cutoff_data INTEGER :: state COMPLEX(kind=DP) :: rem COMPLEX(kind=DP), DIMENSION(:), POINTER :: pw_red TYPE(wp_psi_cutoff_data) :: wp END SUBROUTINE self_energy_remainder_cutoff END INTERFACE TYPE(input_options), INTENT(in) :: options TYPE(quasi_particles), INTENT(inout) :: qp TYPE(green) :: gg,gm!green function TYPE(q_mat) :: qm!overlap of orthonormalized wannier products with wannier products TYPE(polaw) :: ww!dressed interaction TYPE(wannier_u) :: uu!transformation matrix ks to wannier TYPE(contraction) :: cr!to speed up calculation TYPE(wp_psi) :: wp!for remainder calculations TYPE(wp_psi_cutoff_data) :: wpc!for remainder calculations with cutoff TYPE(wp_psi_cutoff_index) :: wpci!for remainder calculations with cutoff, index TYPE(contraction_index) :: cri! index of contraction TYPE(contraction_state) :: crs!state contraction data REAL(kind=DP) :: time INTEGER :: iw,ii,jj REAL(kind=DP) :: offset COMPLEX(kind=DP) :: sca COMPLEX(kind=DP), DIMENSION(:), POINTER :: pw_red write(stdout,*) 'enter remainder COH' !allocates allocate(qp%ene_remainder(options%max_i,qp%nspin)) call initialize_green(gg) call initialize_green(gm) call initialize_polaw(ww) !read U matrix call read_data_pw_u(uu,options%prefix) !read overlap matrix Q call read_data_pw_q(qm,options%prefix,.false.) if(options%use_contractions) then if(.not.options%l_contraction_single_state) then write(stdout,*) 'call do_contraction'!ATTENZIONE call do_contraction(qm,uu,cr, options%max_i) write(stdout,*) 'done do_contraction'!ATTENZIONE call write_contraction(cr,options) write(stdout,*) 'done do_contraction'!ATTENZIONE else !contraction index and states already available on disk call read_contraction_index(cri, options) endif endif write(stdout,*) 'enter remainder COH' if(options%remainder /= 4) then!not needed if calculated through pw if(options%l_remainder_cutoff) then call read_data_pw_wp_psi_cutoff_index(wpci,options%prefix) call read_data_pw_wp_psi_cutoff_data(wpci,wpc, options%prefix) else call read_data_pw_wp_psi(wp,options%prefix) endif endif call read_green(0,gg,options%debug,.false.) call read_green(0,gm,options%debug,.true.) call read_polaw(0,ww,options%debug,options%l_verbose) write(stdout,*) 'POLAW FACTOR', ww%factor!ATTENZIONE if(options%remainder /= 4) then if(options%l_remainder_cutoff) then call set_data_wp_psi_cutoff(pw_red,ww,wpci) WRITE(*,*) 'PW_RED OUT', pw_red(1) endif endif time=0.d0 qp%ene_remainder(:,:) =(0.d0,0.d0) do ii=1,options%max_i if(is_my_state(ii)) then if(.not.options%use_contractions) then call self_energy(ii,ii,sca,time,qm,uu,gg,ww) else if(.not.options%l_contraction_single_state) then call self_energy_contraction(ii,ii,sca,time,cr,gg,ww) else crs%state=ii write(stdout,*) 'Call read_contraction_state' call read_contraction_state(cri,crs,options) call self_energy_contraction_state(ii,ii,sca,time,cri,crs,gg,ww) endif endif !sene changes sign because we are on the negative axes!! qp%ene_remainder(ii,1)=qp%ene_remainder(ii,1)+0.5d0*dble(sca) write(*,*) 'REMAINDER SENE 1', ii, 0.5d0*sca if(.not.options%use_contractions) then call self_energy(ii,ii,sca,time,qm,uu,gm,ww) else if(.not.options%l_contraction_single_state) then call self_energy_contraction(ii,ii,sca,time,cr,gm,ww) else call self_energy_contraction_state(ii,ii,sca,time,cri,crs,gm,ww) write(stdout,*) 'Call free_memory_contraction_state' call free_memory_contraction_state(crs) endif endif qp%ene_remainder(ii,1)=qp%ene_remainder(ii,1)-0.5d0*dble(sca) write(*,*) 'REMAINDER SENE 2', ii, 0.5d0*sca if(options%remainder /= 4) then if(options%l_remainder_cutoff) then call self_energy_remainder_cutoff(ii,sca,wpc,pw_red) else call self_energy_remainder(ii,sca,time,wp,ww) endif qp%ene_remainder(ii,1)=qp%ene_remainder(ii,1)+0.5d0*dble(sca) write(*,*) 'REMAINDER SENE 3', ii, 0.5d0*sca endif endif enddo call free_memory_polaw(ww) call free_memory_green(gg) call free_memory_green(gm) write(*,*) 'in of cycle'!ATTENZIONE if(options%remainder /= 4) then if(options%l_remainder_cutoff) then deallocate(pw_red) call free_memory(wpc) call free_memory(wpci) else call free_memory(wp) endif endif call free_memory(uu) call free_memory(qm) if(.not.options%l_contraction_single_state) then call free_memory_contraction(cr) else call free_memory_contraction_index(cri) endif call mp_sum(qp%ene_remainder(:,1),world_comm) if(options%lconduction) call addconduction_remainder(qp, options) if(ionode) then do ii=1,options%max_i write(stdout,*) 'CORRECTION COH', ii, qp%ene_remainder(ii,1)*RYTOEV enddo endif return end SUBROUTINE remainder SUBROUTINE addconduction_remainder(qp, options) !this subroutine adds to the self_energy of conduction states !on negative imaginary times, the part due to terms \Psi_c'\Psic\w_P USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE input_gw, ONLY : input_options USE basic_structures, ONLY : v_pot,wannier_u_prim, v_pot_prim,free_memory, ortho_polaw USE green_function, ONLY : green, read_green, free_memory_green,initialize_green USE polarization, ONLY : polaw, free_memory_polaw, read_polaw, invert_v_pot, invert_ortho_polaw,& & orthonormalize_inverse, orthonormalize_vpot_para USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE para_gww, ONLY : is_my_pola USE energies_gww, ONLY : quasi_particles implicit none TYPE(input_options) :: options TYPE(quasi_particles) :: qp TYPE(v_pot) :: vp,vpi TYPE(ortho_polaw) :: op,opi TYPE(polaw) :: ww!dressed interaction TYPE(wannier_u_prim) :: wup TYPE(v_pot_prim) :: vpp TYPE(green) :: gg INTEGER iw,jw,kw,it,ii REAL(kind=DP), ALLOCATABLE :: wtemp(:,:) REAL(kind=DP), ALLOCATABLE :: cp(:,:,:) !arrys for contraction c',c, numpw REAL(kind=DP), ALLOCATABLE :: qg(:,:) COMPLEX(kind=DP), ALLOCATABLE :: sene(:) REAL(kind=DP), ALLOCATABLE :: gf_t(:,:) REAL(kind=DP), ALLOCATABLE :: pwcp_t(:,:) REAL(kind=DP), EXTERNAL :: ddot nullify(vp%vmat) nullify(vpi%vmat) nullify(op%on_mat) nullify(opi%on_mat) nullify(ww%pw) nullify(wup%umat) nullify(vpp%ij) nullify(vpp%vmat) call initialize_green(gg) !read coulombian potential and calculate inverse write(stdout,*) 'Routine add_cunduction_remainder' call read_data_pw_u_prim(wup,options%prefix) call read_data_pw_v_pot_prim(vpp, options%prefix,.false.) allocate(sene(options%max_i-wup%nums_occ)) sene(:)=(0.d0,0.d0) !set up contraction array \sum_j U^{C'}_ij Vjkl allocate(cp(vpp%numpw, wup%nums-wup%nums_occ,options%max_i-wup%nums_occ)) cp(:,:,:)=0.d0 do iw=1,vpp%numpw_prim do ii=1,options%max_i-wup%nums_occ do kw=1,vpp%numpw cp(kw,vpp%ij(2,iw)-wup%nums_occ,ii)=cp(kw,vpp%ij(2,iw)-wup%nums_occ,ii)+& &dble(wup%umat(ii,vpp%ij(1,iw)))*vpp%vmat(iw,kw) enddo enddo enddo call free_memory(vpp) call read_data_pw_v(vp,options%prefix,options%debug,0,.false.) call read_data_pw_ortho_polaw(op,options%prefix) call orthonormalize_vpot_para(op,vp) call invert_v_pot(vp,vpi) call free_memory(vp) call invert_ortho_polaw(op,opi) !loop on negative imaginary times if(ionode) then nullify(ww%pw) call read_polaw(0,ww,options%debug,options%l_verbose) call orthonormalize_inverse(opi,ww) allocate(wtemp(ww%numpw,ww%numpw)) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,& & vpi%vmat,ww%numpw,ww%pw,ww%numpw,0.d0,wtemp,ww%numpw) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,& & wtemp,ww%numpw,vpi%vmat,ww%numpw,0.d0,ww%pw,ww%numpw) deallocate(wtemp) call orthonormalize_inverse(op,ww) it=0 call read_green(it,gg,options%debug,.true.) allocate(gf_t(wup%nums-wup%nums_occ,wup%nums-wup%nums_occ)) do iw=1,(wup%nums-wup%nums_occ) do jw=1,(wup%nums-wup%nums_occ) gf_t(jw,iw) = gg%gf_p(jw+wup%nums_occ, iw+wup%nums_occ,1) enddo enddo do ii=1,options%max_i-wup%nums_occ allocate(qg(op%numpw,wup%nums-wup%nums_occ)) call dgemm('N','N',op%numpw,wup%nums-wup%nums_occ,wup%nums-wup%nums_occ,1.d0,cp(1,1,ii),& &op%numpw,gf_t,wup%nums-wup%nums_occ,0.d0, qg, op%numpw) allocate(pwcp_t(op%numpw,wup%nums-wup%nums_occ)) call dgemm('N','N',op%numpw,wup%nums-wup%nums_occ,op%numpw,1.d0,ww%pw,op%numpw,& &cp(1,1,ii),op%numpw,0.d0, pwcp_t,op%numpw) do iw=1,(wup%nums-wup%nums_occ) sene(ii) = sene(ii) + ddot(op%numpw,qg(:,iw),1,pwcp_t(:,iw),1)*gg%factor*ww%factor enddo deallocate(pwcp_t) deallocate(qg) sene(ii)=sene(ii)*(0.d0,1.d0) enddo deallocate(gf_t) endif call mp_bcast(sene, ionode_id, world_comm) do ii=1,options%max_i-wup%nums_occ qp%ene_remainder(ii+wup%nums_occ,1)=qp%ene_remainder(ii+wup%nums_occ,1)-0.5d0*dble(sene(ii)) write(*,*) 'REMAINDER CONDUCTION', ii, 0.5d0*sene(ii) enddo call free_memory(vpi) call free_memory(op) call free_memory(opi) call free_memory_polaw(ww) call free_memory(wup) call free_memory_green(gg) deallocate(cp) deallocate(sene) return END SUBROUTINE addconduction_remainder SUBROUTINE create_dressed_polarization( options) !this subroutine calculates the dressed polarization and saves it !as a polarization with frequency -99999 USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE input_gw, ONLY : input_options USE basic_structures, ONLY : v_pot,free_memory, ortho_polaw USE green_function, ONLY : green, read_green, free_memory_green USE polarization, ONLY : polaw, free_memory_polaw, read_polaw, invert_v_pot, invert_ortho_polaw,& & orthonormalize_inverse, write_polaw, orthonormalize_vpot USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE para_gww, ONLY : is_my_pola implicit none TYPE(input_options) :: options TYPE(v_pot) :: vp,vpi TYPE(ortho_polaw) :: op,opi TYPE(polaw) :: ww!dressed interaction INTEGER iw,jw,kw,it,ii REAL(kind=DP), ALLOCATABLE :: wtemp(:,:) nullify(vp%vmat) nullify(vpi%vmat) nullify(op%on_mat) nullify(opi%on_mat) nullify(ww%pw) !read coulombian potential and calculate inverse write(stdout,*) 'Routine create_dressed_polarization' call read_data_pw_v(vp,options%prefix,options%debug,0,.false.) call read_data_pw_ortho_polaw(op,options%prefix) call orthonormalize_vpot(op,vp) call invert_v_pot(vp,vpi) call free_memory(vp) call invert_ortho_polaw(op,opi) if(ionode) then nullify(ww%pw) call read_polaw(0,ww,options%debug,options%l_verbose) call orthonormalize_inverse(opi,ww) allocate(wtemp(ww%numpw,ww%numpw)) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,& & vpi%vmat,ww%numpw,ww%pw,ww%numpw,0.d0,wtemp,ww%numpw) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,& & wtemp,ww%numpw,vpi%vmat,ww%numpw,0.d0,ww%pw,ww%numpw) deallocate(wtemp) call orthonormalize_inverse(op,ww) ww%label=-99999 call write_polaw(ww,options%debug) endif !!!!!!!!!!! call free_memory(op) call free_memory(opi) call free_memory_polaw(ww) return END SUBROUTINE create_dressed_polarization GWW/gww/create_quasi_particle.f900000644000077300007730000001576212341332532017477 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! SUBROUTINE create_quasi_particles(options,qp,se) !given the expansion coeffcients, calculates in a perturbative !way without self-consistency correction the quasi-particles energies !relavant arrays are already allocates and set by subroutine create USE io_global, ONLY : stdout USE basic_structures, ONLY : wannier_u, free_memory USE expansion, ONLY : self_expansion, value_on_frequency, derivative_on_frequency,value_on_frequency_complex USE input_gw, ONLY : input_options USE constants, ONLY : tpi, RYTOEV USE energies_gww, ONLY : quasi_particles USE kinds, ONLY : DP implicit none TYPE(input_options) :: options! for prefix TYPE(quasi_particles) :: qp!the descriptor to be build TYPE(self_expansion) :: se!the descriptor for the multipole expansion INTEGER :: ii,jj, it,is TYPE(wannier_u) :: uu COMPLEX(kind=DP) :: zz, sigmac,dsigmac REAL(kind=DP) :: offset REAL(kind=DP), ALLOCATABLE :: remainder(:) !read in DFT energies call read_data_pw_u(uu,options%prefix) !loop on spin do is=1,uu%nspin if(.not. options%l_hf_energies) then if(uu%nums_occ(is) == 0) then offset=-2.d0 else if(uu%nums > uu%nums_occ(is)) then if(options%l_lda_hartree) then offset=-(uu%ene(uu%nums_occ(is)+1,is)+uu%ene(uu%nums_occ(is),is))/2.d0 else offset=-(uu%ene(uu%nums_occ(is)+1,is)+dble(qp%ene_h(uu%nums_occ(is)+1,is))-qp%ene_dft_h(uu%nums_occ(is)+1,is)& & +uu%ene(uu%nums_occ(is),is) +dble(qp%ene_h(uu%nums_occ(is),is))-qp%ene_dft_h(uu%nums_occ(is),is))/2.d0 endif else if(options%l_lda_hartree) then offset=-uu%ene(uu%nums_occ(is),is) else offset=-(uu%ene(uu%nums_occ(is),is)+dble(qp%ene_h(uu%nums_occ(is),is))-qp%ene_dft_h(uu%nums_occ(is),is)) endif endif endif else if(uu%nums > uu%nums_occ(is)) then offset=-(qp%ene_hf(uu%nums_occ(is)+1,is)+qp%ene_hf(uu%nums_occ(is),is))/2.d0 else offset=-qp%ene_hf(uu%nums_occ(is),is) endif endif ! call free_memory(uu) !set remainders allocate(remainder(options%max_i)) if(options%remainder==3 .or.options%remainder==4) then remainder(:)=qp%ene_remainder(:,1) else remainder(:)=0.d0 endif do ii=1,qp%max_i if(.not. options%l_hf_energies) then if(options%l_lda_hartree) then call value_on_frequency(se,ii,qp%ene_dft_ks(ii,is)+offset,sigmac,is) call derivative_on_frequency(se,ii,qp%ene_dft_ks(ii,is)+offset,dsigmac,is) else call value_on_frequency(se,ii,qp%ene_dft_ks(ii,is)+offset+dble(qp%ene_h(ii,is))-qp%ene_dft_h(ii,is),sigmac,is) call derivative_on_frequency(se,ii,qp%ene_dft_ks(ii,is)+offset+dble(qp%ene_h(ii,is))-qp%ene_dft_h(ii,is),dsigmac,is) endif else call value_on_frequency(se,ii,qp%ene_hf(ii,is)+offset,sigmac,is) call derivative_on_frequency(se,ii,qp%ene_hf(ii,is)+offset,dsigmac,is) endif write(stdout,*) 'value, zeta:',ii,sigmac,dsigmac,is zz=(1.d0,0.d0)-dsigmac if(.not. options%l_hf_energies) then qp%ene_gw(ii,is)=qp%ene_dft_ks(ii,is)+offset +qp%ene_h(ii,is)-qp%ene_dft_h(ii,is)+& & (sigmac+remainder(ii)+qp%ene_x(ii,is)-qp%ene_dft_xc(ii,is) )/zz else qp%ene_gw(ii,is)=qp%ene_hf(ii,is)+offset+(sigmac+remainder(ii))/zz endif write(stdout,*) 'XC-DFT energy',ii,qp%ene_dft_xc(ii,is) write(stdout,*) 'H-DFT energy',ii,qp%ene_dft_h(ii,is)*RYTOEV,qp%ene_h(ii,is)*RYTOEV write(stdout,*) 'GW-PERT energy', ii,real(qp%ene_gw(ii,is)-offset)*RYTOEV qp%ene_gw_pert(ii,is)=qp%ene_gw(ii,is)-offset !self-consistency loop do it=1,10 call value_on_frequency_complex(se,ii,qp%ene_gw(ii,is),sigmac,is) sigmac=sigmac+remainder(ii) write(stdout,*) 'Iteration energy',it,sigmac if(.not. options%l_hf_energies) then qp%ene_gw(ii,is)=qp%ene_dft_ks(ii,is)+offset+sigmac+qp%ene_x(ii,is)-qp%ene_dft_xc(ii,is) & & +qp%ene_h(ii,is)-qp%ene_dft_h(ii,is) else qp%ene_gw(ii,is)=qp%ene_hf(ii,is)+offset+sigmac endif enddo qp%ene_gw(ii,is)= qp%ene_gw(ii,is)-offset call flush_unit(stdout) enddo deallocate(remainder) enddo!spin call free_memory(uu) return END SUBROUTINE create_quasi_particles SUBROUTINE create_quasi_particle_on_real(options,qp,sr) !given the self-energy on real axis calculate the GW levels USE io_global, ONLY : stdout USE basic_structures, ONLY : wannier_u, free_memory USE self_energy_storage USE input_gw, ONLY : input_options USE constants, ONLY : tpi, RYTOEV USE energies_gww, ONLY : quasi_particles USE kinds, ONLY : DP implicit none TYPE(input_options) :: options! for prefix TYPE(quasi_particles) :: qp!the descriptor to be build TYPE(self_on_real) :: sr!the descriptor for the self_energy INTEGER :: ii,jj, it,is,ierr TYPE(wannier_u) :: uu COMPLEX(kind=DP) :: zz, sigmac,dsigmac,energy !read in DFT energies call read_data_pw_u(uu,options%prefix) !loop on spin do is=1,uu%nspin do ii=sr%i_min,sr%i_max energy=dcmplx(qp%ene_dft_ks(ii,is),0.d0) energy=qp%ene_gw(ii,is)!ATTENZIONE call self_on_real_value(sr,ii,is,energy,sigmac,ierr) if(ierr/=0) then write(stdout,*) 'OUT OF RANGE:self_on_real_value',energy call flush_unit(stdout) !stop!ATTENZIONE endif write(stdout,*) 'Iteration energy 0', dble(qp%ene_gw(ii,is)) qp%ene_gw(ii,is)=qp%ene_dft_ks(ii,is)+sigmac+qp%ene_x(ii,is)-qp%ene_dft_xc(ii,is) write(stdout,*) 'Iteration energy 1', dble(qp%ene_gw(ii,is)) !self-consistency loop do it=1,1000 call self_on_real_value(sr,ii,is, qp%ene_gw(ii,is),sigmac,ierr) if(ierr/=0) then write(stdout,*) 'OUT OF RANGE:self_on_real_value',it,qp%ene_gw(ii,is) call flush_unit(stdout) !stop!ATTENZIONE endif write(stdout,*) 'Iteration energy',it,sigmac,dble(qp%ene_gw(ii,is)) call flush_unit(stdout) qp%ene_gw(ii,is)=qp%ene_dft_ks(ii,is)+sigmac+qp%ene_x(ii,is)-qp%ene_dft_xc(ii,is) enddo enddo enddo return END SUBROUTINE create_quasi_particle_on_real GWW/gww/go_green.f900000644000077300007730000000444612341332532014731 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! SUBROUTINE go_green(tf, options, qp) !this subroutine at every imaginary time, calculate the green function !and save it on file USE kinds, ONLY : DP USE input_gw, ONLY : input_options USE basic_structures, ONLY : wannier_u, free_memory USE green_function, ONLY : green,create_green_part,write_green,free_memory_green,initialize_green USE para_gww, ONLY : is_my_time, is_my_last USE mp, ONLY : mp_barrier USE mp_world, ONLY : world_comm USE io_global, ONLY : stdout USE energies_gww, ONLY : quasi_particles USE times_gw, ONLY : times_freqs implicit none TYPE(times_freqs), INTENT(in) :: tf!time grid TYPE(input_options), INTENT(in) :: options! for imaginary time range and number of samples TYPE(quasi_particles), INTENT(in) :: qp!for the HF energies if required TYPE(wannier_u) :: wu TYPE(green) :: gr INTEGER :: iw REAL(kind=DP) :: time, dt call initialize_green(gr) !read in U tranformation matrix and KS eneregies call read_data_pw_u(wu,options%prefix) !loop on samples dt=options%tau/real(options%n) do iw=-options%n,options%n if(is_my_time(iw)) then write(stdout,*) 'Green: ', iw, time if(options%l_fft_timefreq) then time=dt*real(iw) else time=tf%times(iw) endif call create_green_part(gr,wu,time,options%debug,.false.,options%l_hf_energies, qp%ene_hf(:,1)) gr%label=iw write(stdout,*) 'Green created: ', iw, time call write_green(gr,options%debug) endif enddo !now insert the zero time negative one if(is_my_last) then write(stdout,*) 'green 0' call create_green_part(gr,wu,0.d0,options%debug,.true.,options%l_hf_energies, qp%ene_hf(:,1)) gr%label=0 call write_green(gr,options%debug) write(stdout,*) 'green 0 created' endif call mp_barrier( world_comm ) call free_memory_green(gr) call free_memory(wu) return END SUBROUTINE GWW/gww/go_exchange.f900000644000077300007730000003032612341332532015407 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! SUBROUTINE go_exchange_main( options, qp) !this subroutines does: !1)creates and writes green function a t=0+ !2)if required creates and writes contractions !3)setup qp and its exchange and hf arrays USE energies_gww, ONLY : quasi_particles USE compact_product, ONLY : contraction, free_memory_contraction,do_contraction, write_contraction,& &do_contraction_index_state USE basic_structures, ONLY : q_mat, wannier_u,free_memory USE green_function, ONLY : green, free_memory_green, write_green, create_green_part,initialize_green USE para_gww, ONLY : is_my_time USE mp, ONLY : mp_barrier USE mp_world, ONLY : world_comm USE input_gw, ONLY : input_options USE io_global, ONLY : stdout, ionode USE kinds, ONLY : DP USE constants, ONLY : RYTOEV implicit none TYPE(input_options), INTENT(in) :: options! program options TYPE(quasi_particles), INTENT(out) :: qp!quasi particle structure to be initialized with HF stuff TYPE(contraction) :: cr!to speed up calculation TYPE(green) :: gg!green function TYPE(q_mat) :: qm!overlap of wannier products TYPE(wannier_u) :: uu!transformation matrix ks to wannier REAL(kind=DP) :: dumm(1) nullify(cr%numl) nullify(cr%l) nullify(cr%q) call initialize_green(gg) if(options%l_verbose) write(stdout,*) 'Routine go_exchange main1' call flush_unit(stdout) !read U matrix call read_data_pw_u(uu,options%prefix) !read overlap matrix Q ! call read_data_pw_q(qm,options%prefix,options%l_self_from_pola) if(options%l_verbose) write(stdout,*) 'Routine go_exchange main2' call flush_unit(stdout) if(is_my_time(0)) then call create_green_part(gg,uu,0.d0, options%debug,.false.,.false.,dumm) gg%label=0 call write_green(gg, options%debug) endif call free_memory_green(gg) if(options%use_contractions) then call read_data_pw_q(qm,options%prefix,options%l_self_from_pola) !in the following max_i defines the max number of KS states not appropriate for HF !the contraction qr can be defined HERE in another way wp:w_V w_i if(.not.options%l_contraction_single_state) then call do_contraction(qm,uu,cr, options%max_i) if(options%l_verbose) write(stdout,*) 'Routine go_exchange main2.2' call free_memory(uu) call free_memory(qm) if(options%l_verbose) write(stdout,*) 'Routine go_exchange main2.3' call write_contraction(cr,options) else call do_contraction_index_state(qm,uu,options%max_i, options) call free_memory(uu) call free_memory(qm) endif endif call mp_barrier( world_comm ) if(.not.options%use_contractions) then call free_memory(uu) ! call free_memory(qm) else if(.not.options%l_contraction_single_state) call free_memory_contraction(cr) endif if(options%l_verbose) write(stdout,*) 'Routine go_exchange main3' call create_hf(options, qp) if(options%l_verbose) write(*,*) 'go_exchange main hf_ene', qp%ene_hf(2,1)*RYTOEV!ATTENZIONE return END SUBROUTINE go_exchange_main SUBROUTINE go_exchange(options, ene_x, ene_h, n_max) !this subroutine calculates the terms, in imaginary time=0 !<\Psi_i|\Sigma(it)_HF|\Psi_j> !=O^{P}_n,kl G_{lm}V_{n,o} O^{P}_o,mp U_ki U^{+}_j,p !for n_max states !if required calculates also the hartree terms !<\Psi_i|V_H|\Psi_i> !and displays result on screen USE kinds, ONLY : DP USE io_global, ONLY : stdout USE basic_structures, ONLY : wannier_u, q_mat, v_pot, ortho_polaw,free_memory, v_pot_prim, wannier_u_prim USE green_function, ONLY : green, read_green, free_memory_green, initialize_green USE input_gw, ONLY : input_options USE compact_product USE polarization USE para_gww, ONLY : is_my_state USE mp, ONLY : mp_sum USE mp_world, ONLY : world_comm USE constants, ONLY : RYTOEV implicit none TYPE(input_options) :: options REAL(kind=DP) :: ene_x(n_max)!where to store calculated diagonal values REAL(kind=DP) :: ene_h(n_max)!where to store calculated diagonal values INTEGER :: n_max!max number of states to be considered INTEGER :: i,j !which element of self enrgy to be calculated REAL(kind=DP) :: sene!self energy element TYPE(q_mat) :: qm!descriptors of overlaps of othonormalized wannier producs with wannier products TYPE(wannier_u) :: uu!descriptor of transformation matrix from KS states to wanniers TYPE(green) :: gf!descriptor of green function TYPE(v_pot) :: vp!bare interaction TYPE(contraction) :: cr!for contracted products scheme TYPE(contraction_index) :: cri!for contracted products scheme, index part TYPE(contraction_state) :: crs!for contracted products scheme, state part TYPE(ortho_polaw) :: op!orthonormalization matrix REAL(kind=DP), ALLOCATABLE :: qg(:,:)!for the product Q^{P}_{n,l,i}G{l,m} SUPPOSED TO BE REAL REAL(kind=DP), ALLOCATABLE :: qu(:)!for the product Q^{P}_{m,v,v'}U{v,v'}SUPPOSED TO BE REAL REAL(kind=DP), ALLOCATABLE :: ju(:)!for the product I_{j,m}Q^{P}_{m,v,v'}U{v,v'}SUPPOSED TO BE REAL TYPE(v_pot_prim) :: vp_prim TYPE(wannier_u_prim) :: wu TYPE(v_pot) :: ident INTEGER :: k,l,m,n,o,p,v,vv INTEGER :: nw,ow REAL(kind=DP) :: o_n,o_o call initialize_green(gf) call read_green(0, gf, options%debug,.false.) write(stdout,*) 'GF PART',gf%l_part call read_data_pw_v(vp,options%prefix,options%debug,0,.false.) if(options%use_contractions) then if(.not.options%l_contraction_single_state) then call read_contraction(cr,options) else call read_contraction_index(cri,options) endif endif write(stdout,*) 'contraction read' if(.not.options%use_contractions) then call read_data_pw_u(uu,options%prefix) call read_data_pw_q(qm,options%prefix,.false.) if(gf%nums /= uu%nums) then write(stdout,*) 'Routine self_energy: same nums required' stop endif if(qm%numpw /= vp%numpw) then write(stdout,*) 'Routine self_energy: same numpw required',qm%numpw,vp%numpw stop endif endif write(stdout,*) 'invert potential' if(options%lnonorthogonal) then call read_data_pw_ortho_polaw(op,options%prefix) call orthonormalize_vpot_para(op,vp) call orthonormalize_vpot_inverse_para(op,vp) if(options%l_lda_hartree) call free_memory(op) endif write(stdout,*) 'invert potential inverted' ene_x(:)=0.d0 ene_h(:)=0.d0 if(.not.options%l_lda_hartree) then call read_data_pw_u(uu,options%prefix) call read_data_pw_v_pot_prim(vp_prim,options%prefix,.false.) call read_data_pw_u_prim(wu,options%prefix) allocate(qu(cri%numpw)) qu(:)=0.d0 do v=1,uu%nums_occ(1) crs%state=v call read_contraction_state(cri,crs,options) do m=1,cri%numpw do vv=1,cri%numl(m) qu(m)=qu(m)+crs%q(m,vv)*dble(uu%umat(v,cri%l(vv,m),1))*2.d0!2. is for spin multiplicity enddo enddo call free_memory_contraction_state(crs) enddo ident%numpw=cri%numpw allocate(ident%vmat(ident%numpw,ident%numpw)) ident%vmat(:,:)=0.d0 do m=1,ident%numpw ident%vmat(m,m)=1.d0 enddo call orthonormalize_vpot_inverse_para(op,ident) allocate(ju(vp_prim%numpw)) ju(:)=0.d0 do m=1,vp_prim%numpw do n=1,vp_prim%numpw ju(m)=ju(m)+ident%vmat(m,n)*qu(n) enddo write(*,*) 'JU',ju(m)!ATTENZIONE enddo call free_memory(ident) call free_memory(op) endif if(options%whole_s) then write(stdout,*)'Routine go_exchange: whole_s not implemented yet' stop else do i=1,n_max if(is_my_state(i)) then j=i !check consistency sene=0.d0 if(.not.options%use_contractions) then write(stdout,*) 'ONLY CONTRACTIONS IMPLEMENTED' stop else if(.not.options%l_contraction_single_state) then write(*,*) 'Interno', cr%numpw,cr%nums allocate(qg(cr%numpw,cr%nums)) qg(:,:)=0.d0 do n=1,cr%numpw!loop on orthonormalized wannier products do m=1,cr%nums do l=1,cr%numl(n) qg(n,m)=qg(n,m)+dble(cr%q(n,l,i))*gf%gf_p(cr%l(l,n),m,1) enddo enddo enddo sene=0.d0 do n=1,cr%numpw!loop on orthonormalized wannier products do o=1,cr%numpw!loop on orthonormalized wannier products do m=1,cr%numl(o) sene=sene+qg(n,cr%l(m,o))*vp%vmat(n,o)*dble(cr%q(o,m,j)) enddo enddo enddo deallocate(qg) else crs%state=i write(stdout,*) 'read state', i call read_contraction_state(cri,crs,options) write(stdout,*) 'Interno state', cri%numpw,cri%nums allocate(qg(cri%numpw,cri%nums)) qg(:,:)=0.d0 do n=1,cri%numpw!loop on orthonormalized wannier products do m=1,cri%nums do l=1,cri%numl(n) qg(n,m)=qg(n,m)+crs%q(n,l)*gf%gf_p(cri%l(l,n),m,1) enddo enddo enddo sene=0.d0 do n=1,cri%numpw!loop on orthonormalized wannier products do o=1,cri%numpw!loop on orthonormalized wannier products do m=1,cri%numl(o) sene=sene+qg(n,cri%l(m,o))*vp%vmat(n,o)*crs%q(o,m) enddo enddo enddo deallocate(qg) if(.not.options%l_lda_hartree) then !calculate hartree term ene_h(i)=0.d0 if(i<=uu%nums_occ(1)) then do l=1,cri%numpw do k=1,cri%numl(l) do m=1,cri%numpw ene_h(i)=ene_h(i)+uu%umat(i,cri%l(k,l),1)*crs%q(l,k)*qu(m)*vp%vmat(l,m) enddo enddo enddo else do l=1,vp_prim%numpw_prim do m=1,cri%numpw ene_h(i)=ene_h(i)+wu%umat(i-wu%nums_occ,vp_prim%ij(1,l))*& & uu%umat(i,vp_prim%ij(2,l),1)*vp_prim%vmat(l,m)*ju(m) enddo enddo endif WRITE(STDOUT,*) 'Hartree Energy (ryd) :',i,ene_h(i)*RYTOEV endif call free_memory_contraction_state(crs) endif endif WRITE(STDOUT,*) 'SENE :' ,SENE,gf%factor!ATTENZIONE sene=sene*dble(gf%factor*(0.d0,1.d0)) ene_x(i)=sene write(stdout,*) 'Exchange energies', i,sene endif enddo call mp_sum(ene_x(1:options%max_i),world_comm) if(.not.options%l_lda_hartree) call mp_sum(ene_h(1:options%max_i),world_comm) endif if(.not.options%use_contractions) then call free_memory(qm) call free_memory(uu) else if(.not.options%l_contraction_single_state) then call free_memory_contraction(cr) else call free_memory_contraction_index(cri) endif if(.not.options%l_lda_hartree) then call free_memory(uu) call free_memory(wu) call free_memory(vp_prim) deallocate(qu) deallocate(ju) endif endif call free_memory(vp) call free_memory_green(gf) return END SUBROUTINE go_exchange GWW/gww/fit_polynomial.f900000644000077300007730000000777112341332532016175 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !this contains routines to fit a function on the positive part !of the imaginary axes with a multipole expansion SUBROUTINE fit_polynomial(n,m,z,s,a,b,delta,thres,maxiter,maxcycle) !fits with the function f(z)=(Prod_i(z-a_i)/Prod_j(z-b_j) !the values z_j,s_j USE kinds, ONLY : DP USE io_global, ONLY : stdout implicit none INTEGER, INTENT(in) :: n!numer of sampled values INTEGER, INTENT(in) :: m!number of parameters a COMPLEX(kind=DP), INTENT(in) :: z(n)!where COMPLEX(kind=DP), INTENT(in) :: s(n)!values s(z_j) to be fitted COMPLEX(kind=DP), INTENT(inout) :: a(m) COMPLEX(kind=DP), INTENT(inout) :: b(m) REAL(kind=DP), INTENT(in) :: delta!parameter for steepest descend REAL(kind=DP), INTENT(in) :: thres!threshold for convergence INTEGER, INTENT(in) :: maxiter!maximum number of iterations INTEGER, INTENT(in) :: maxcycle!maximum number of cycles REAL(kind=DP) :: chi0, chi1 INTEGER :: i,j,k,it,ic COMPLEX(kind=DP) :: cc, grad COMPLEX(kind=DP) :: new_a(m), new_b(m), old_a(m),old_b(m) COMPLEX(kind=DP) :: num,den REAL(kind=DP) :: dd dd = delta !calculates initial chi write(*,*) 'a', a write(*,*) 'b', b write(*,*) 'z,s' , z(1),s(1),func(z(1)) write(*,*) 'z,s' , z(n),s(n),func(z(n)) do ic=1,maxcycle !now fit a's chi0=0.d0 do i=1,n cc = func(z(i))-s(i) chi0=chi0+cc*conjg(cc) enddo do it=1,maxiter !updates a(:) do j=1,m grad=(0.d0,0.d0) do i=1,n den=(1.d0,0.d0) do k=1,m den=den*(conjg(z(i))-conjg(b(k))) enddo num=(1.d0,0.d0) do k=1,m if(k/=j) num=num*(conjg(z(i))-conjg(a(k))) enddo grad=grad+(func(z(i))-s(i))*(-1.d0,0.d0)*num/den if(it==1) write(*,*) 'Grad a', grad,num,den!ATTENZIONE enddo new_a(j)=a(j)-grad*dd if(it==1) write(*,*) 'Grad a', grad,num,den!ATTENZIONE enddo !calculates new chi a(:)=new_a(:) chi1=0.d0 do i=1,n cc = func(z(i))-s(i) chi1=chi1+cc*conjg(cc) enddo if(chi1 > chi0) then write(stdout,*) 'Routine fit_multipole: chi1 > chi0 ' !return dd=dd*0.1d0 endif if((chi0-chi1) <= thres) return chi0=chi1 write(*,*) 'chi0',chi0!ATTENZIONE enddo !now fit b's chi0=0.d0 do i=1,n cc = (1.d0/func(z(i)))-(1.d0/s(i)) chi0=chi0+cc*conjg(cc) enddo do it=1,maxiter !updates b(:) do j=1,m grad=(0.d0,0.d0) do i=1,n den=(1.d0,0.d0) do k=1,m den=den*(conjg(z(i))-conjg(a(k))) enddo num=(1.d0,0.d0) do k=1,m if(k/=j) num=num*(conjg(z(i))-conjg(b(k))) enddo grad=grad+((1.d0/func(z(i)))-(1.d0/s(i)))*(-1.d0,0.d0)*num/den enddo new_b(j)=b(j)-grad*dd if(it==1) write(*,*) 'Grad b', grad!ATTENZIONE enddo !calculates new chi old_b(:)=b(:) b(:)=new_b(:) chi1=0.d0 do i=1,n cc = (1.d0/func(z(i)))-(1.d0/s(i)) chi1=chi1+cc*conjg(cc) enddo if(chi1 > chi0) then write(stdout,*) 'Routine fit_multipole: chi1 > chi0 ' !return b(:)=old_b(:) dd=dd*0.1d0 else if((chi0-chi1) <= thres) then return else chi0=chi1 endif write(*,*) 'chi0',chi0!ATTENZIONE enddo enddo write(stdout,*) 'Routine fit_multipole: maxcycle reached ' return CONTAINS FUNCTION func(zz) COMPLEX(kind=DP) :: func COMPLEX(kind=DP) :: n,d COMPLEX(kind=DP) :: zz INTEGER :: ii,kk n=(1.d0,0.d0) do kk=1,m n=n*(zz-a(kk)) enddo d=(1.d0,0.d0) do kk=1,m d=d*(zz-b(kk)) enddo func=n/d return END FUNCTION func END SUBROUTINE fit_polynomial GWW/gww/compact_product.f900000644000077300007730000010244312341332532016326 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! MODULE compact_product !this module describes the contracted products O^{P}_{n,kl}U_{ki}=Q^{P}_{n,l,i} !and of the contracted products O^{P}_{i,km}O^{P}_{j,ln}U^{+}_{vk}U_{lv}U^{+}_{cm}U_{nc} USE kinds, ONLY : DP TYPE contraction !this structure described the localized and normalized products of wanniers w_P INTEGER :: numpw!number of wannier-products INTEGER :: nums!number of KS or wannier states INTEGER :: max_i!maximum number of KS states to be addresses INTEGER, DIMENSION(:), POINTER :: numl!array for number of functionsl (numl,:) INTEGER, DIMENSION(:,:), POINTER :: l !array for l indices (index,:,:) COMPLEX(kind=DP),DIMENSION(:,:,:), POINTER :: q!contraction terms END TYPE contraction !for treating large systems contraction has been split in two parts TYPE contraction_index !this structure described the localized and normalized products of wanniers w_P !index part INTEGER :: numpw!number of wannier-products INTEGER :: nums!number of KS or wannier states INTEGER :: max_i!maximum number of KS states to be addresses INTEGER, DIMENSION(:), POINTER :: numl!array for number of functionsl (numl,:) INTEGER, DIMENSION(:,:), POINTER :: l !array for l indices (index,:,:) END TYPE contraction_index TYPE contraction_state !this structure described the localized and normalized products of wanniers w_P INTEGER :: numpw!number of wannier-products INTEGER :: nums!number of KS or wannier states INTEGER :: max_i!maximum number of KS states to be addresses INTEGER :: state!state for which the contraction corresponds REAL(kind=DP),DIMENSION(:,:), POINTER :: q!contraction terms END TYPE contraction_state TYPE contraction_pola !this structure described the localized and normalized products of wanniers with U matrices INTEGER :: numpw!number of wannier-products INTEGER :: nums!number of KS or wannier states INTEGER :: nums_occ!number of occupied states COMPLEX(kind=DP),DIMENSION(:,:,:), POINTER :: ou!contraction terms END TYPE contraction_pola TYPE contraction_pola_state !this structure described the localized and normalized products of wanniers with U matrices !just for one occupied state INTEGER :: numpw!number of wannier-products INTEGER :: nums!number of KS or wannier states INTEGER :: nums_occ!number of occupied states INTEGER :: state!occupied state relative to this data REAL(kind=DP),DIMENSION(:,:), POINTER :: ou!contraction terms END TYPE contraction_pola_state CONTAINS SUBROUTINE free_memory_contraction_pola(cp) implicit none TYPE(contraction_pola) :: cp if(associated(cp%ou)) then deallocate(cp%ou) nullify(cp%ou) endif return END SUBROUTINE free_memory_contraction_pola SUBROUTINE free_memory_contraction_pola_state(cp) implicit none TYPE(contraction_pola_state) :: cp if(associated(cp%ou)) then deallocate(cp%ou) nullify(cp%ou) endif return END SUBROUTINE free_memory_contraction_pola_state SUBROUTINE free_memory_contraction(cr) implicit none TYPE(contraction) :: cr if(associated(cr%numl)) then deallocate(cr%numl) nullify(cr%numl) endif if(associated(cr%l)) then deallocate(cr%l) nullify(cr%l) endif if(associated(cr%q)) then deallocate(cr%q) nullify(cr%q) endif return END SUBROUTINE SUBROUTINE free_memory_contraction_index(cr) implicit none TYPE(contraction_index) :: cr if(associated(cr%numl)) then deallocate(cr%numl) nullify(cr%numl) endif if(associated(cr%l)) then deallocate(cr%l) nullify(cr%l) endif return END SUBROUTINE SUBROUTINE free_memory_contraction_state(cr) implicit none TYPE(contraction_state) :: cr if(associated(cr%q)) then deallocate(cr%q) nullify(cr%q) endif return END SUBROUTINE SUBROUTINE write_contraction(cr, options) !this subroutine writes the contracted products on disk !in parallel case only ionode writes USE input_gw, ONLY : input_options USE io_global, ONLY : ionode USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(contraction) :: cr!the contraction descriptor to be written on file TYPE(input_options) :: options!for debug flag INTEGER :: iw, jw, kw, iun if(ionode) then iun = find_free_unit() if(.not. options%debug) then open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'contraction', status='unknown',form='unformatted') else open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'contraction', status='unknown',form='formatted') endif if(.not.options%debug) then write(iun) cr%numpw write(iun) cr%nums write(iun) cr%max_i write(iun) cr%numl(1:cr%numpw) do iw=1,cr%numpw write(iun) cr%l(1:cr%numl(iw),iw) enddo do iw=1,cr%numpw write(iun) cr%q(iw,1:cr%numl(iw),1:cr%max_i) enddo else write(iun,*) cr%nums write(iun,*) cr%max_i write(iun,*) cr%numl(1:cr%numpw) do iw=1,cr%numpw do jw=1,cr%numl(iw) write(iun,*) cr%l(jw,iw) enddo enddo do iw=1,cr%numpw do jw=1,cr%numl(iw) do kw=1,cr%max_i write(iun,*) cr%q(iw,jw,kw) enddo enddo enddo endif close(iun) endif return END SUBROUTINE write_contraction SUBROUTINE read_contraction(cr, options) !this subroutine reads the contracted products from disk !in parallel case only ionode reads USE input_gw, ONLY : input_options USE io_global, ONLY : stdout, ionode, ionode_id USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(contraction) :: cr!the contraction descriptor to be written on file TYPE(input_options) :: options!for debug flag INTEGER :: iw, jw, kw, iun, ii INTEGER maxl if(ionode) then iun = find_free_unit() if(.not. options%debug) then open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'contraction', status='old',form='unformatted') else open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'contraction', status='old',form='formatted') endif endif !call free_memory_contraction(cr) if(ionode) then if(.not.options%debug) then read(iun) cr%numpw read(iun) cr%nums read(iun) cr%max_i else read(iun,*) cr%numpw read(iun,*) cr%nums read(iun,*) cr%max_i endif endif call mp_bcast(cr%numpw, ionode_id,world_comm) call mp_bcast(cr%nums, ionode_id,world_comm) call mp_bcast(cr%max_i, ionode_id,world_comm) maxl=cr%numpw!TEMPORARY SOLUTION ATTENZIONE maxl=cr%nums allocate(cr%numl(cr%numpw)) allocate(cr%l(maxl,cr%numpw)) allocate(cr%q(cr%numpw,maxl,cr%max_i)) if(ionode) then write(stdout,*) 'CR-READ',cr%numpw,maxl,cr%max_i if(.not.options%debug) then read(iun) cr%numl(1:cr%numpw) do iw=1,cr%numpw read(iun) cr%l(1:cr%numl(iw),iw) enddo write(stdout,*) 'CR-READ L' do iw=1,cr%numpw read(iun) cr%q(iw,1:cr%numl(iw),1:cr%max_i) write(stdout,*) 'CR-READ Q', iw enddo else read(iun,*) cr%nums read(iun,*) cr%max_i read(iun,*) cr%numl(1:cr%numpw) do iw=1,cr%numpw do jw=1,cr%numl(iw) read(iun,*) cr%l(jw,iw) enddo enddo do iw=1,cr%numpw do jw=1,cr%numl(iw) do kw=1,cr%max_i read(iun,*) cr%q(iw,jw,kw) enddo enddo enddo endif endif call mp_bcast(cr%numl(:), ionode_id,world_comm) call mp_bcast(cr%l(:,:), ionode_id,world_comm) write(stdout,*) 'CR-SEND L' do ii=1,cr%max_i call mp_bcast(cr%q(:,:,ii), ionode_id,world_comm) write(stdout,*) 'CR-SEND Q',ii enddo if(ionode) close(iun) END SUBROUTINE read_contraction SUBROUTINE write_contraction_index(cr, options) !this subroutine writes the contracted products on disk !in parallel case only ionode writes USE input_gw, ONLY : input_options USE io_global, ONLY : ionode USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(contraction_index) :: cr!the contraction index descriptor to be written on file TYPE(input_options) :: options!for debug flag INTEGER :: iw, jw, kw, iun if(ionode) then iun = find_free_unit() if(.not. options%debug) then open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'contraction_index', status='unknown',form='unformatted') else open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'contraction_index', status='unknown',form='formatted') endif if(.not.options%debug) then write(iun) cr%numpw write(iun) cr%nums write(iun) cr%max_i write(iun) cr%numl(1:cr%numpw) do iw=1,cr%numpw write(iun) cr%l(1:cr%numl(iw),iw) enddo else write(iun,*) cr%nums write(iun,*) cr%max_i write(iun,*) cr%numl(1:cr%numpw) do iw=1,cr%numpw do jw=1,cr%numl(iw) write(iun,*) cr%l(jw,iw) enddo enddo endif close(iun) endif return END SUBROUTINE write_contraction_index SUBROUTINE read_contraction_index(cr, options) !this subroutine reads the contracted products from disk !in parallel case only ionode reads USE input_gw, ONLY : input_options USE io_global, ONLY : stdout, ionode, ionode_id USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(contraction_index) :: cr!the contraction descriptor to be written on file TYPE(input_options) :: options!for debug flag INTEGER :: iw, jw, kw, iun, ii INTEGER maxl if(ionode) then iun = find_free_unit() if(.not. options%debug) then open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'contraction_index', status='old',form='unformatted') else open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'contraction_index', status='old',form='formatted') endif endif !call free_memory_contraction(cr) if(ionode) then if(.not.options%debug) then read(iun) cr%numpw read(iun) cr%nums read(iun) cr%max_i else read(iun,*) cr%numpw read(iun,*) cr%nums read(iun,*) cr%max_i endif endif call mp_bcast(cr%numpw, ionode_id,world_comm) call mp_bcast(cr%nums, ionode_id,world_comm) call mp_bcast(cr%max_i, ionode_id,world_comm) maxl=cr%nums allocate(cr%numl(cr%numpw)) allocate(cr%l(maxl,cr%numpw)) if(ionode) then write(stdout,*) 'CR-READ',cr%numpw,maxl,cr%max_i if(.not.options%debug) then read(iun) cr%numl(1:cr%numpw) do iw=1,cr%numpw read(iun) cr%l(1:cr%numl(iw),iw) enddo write(stdout,*) 'CR-READ L' else read(iun,*) cr%nums read(iun,*) cr%max_i read(iun,*) cr%numl(1:cr%numpw) do iw=1,cr%numpw do jw=1,cr%numl(iw) read(iun,*) cr%l(jw,iw) enddo enddo endif endif call mp_bcast(cr%numl(:), ionode_id,world_comm) call mp_bcast(cr%l(:,:), ionode_id,world_comm) write(stdout,*) 'CR-SEND L' if(ionode) close(iun) END SUBROUTINE read_contraction_index SUBROUTINE write_contraction_state(cri,crs, options) !this subroutine writes the contracted products on disk !in parallel case only ionode writes USE input_gw, ONLY : input_options USE io_global, ONLY : ionode USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(contraction_index), INTENT(in) :: cri!the contraction index descriptor TYPE(contraction_state) :: crs!the contraction state to be written on file TYPE(input_options) :: options!for debug flag INTEGER :: iw, jw, kw, iun CHARACTER(5) :: nfile write(nfile,'(5i1)') & & crs%state/10000,mod(crs%state,10000)/1000,mod(crs%state,1000)/100,mod(crs%state,100)/10,mod(crs%state,10) iun = find_free_unit() if(.not. options%debug) then open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'contraction'// nfile, status='unknown',form='unformatted') else open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'contraction'// nfile, status='unknown',form='formatted') endif if(.not.options%debug) then write(iun) crs%numpw write(iun) crs%nums write(iun) crs%max_i write(iun) crs%state do iw=1,crs%nums write(iun) crs%q(1:cri%numpw,iw) enddo else write(iun,*) crs%numpw write(iun,*) crs%nums write(iun,*) crs%max_i write(iun,*) crs%state do iw=1,crs%numpw do jw=1,cri%nums write(iun,*) crs%q(iw,jw) enddo enddo endif close(iun) return END SUBROUTINE write_contraction_state SUBROUTINE read_contraction_state(cri,crs, options) !this subroutine writes the contracted products on disk !in parallel case only ionode writes USE input_gw, ONLY : input_options USE io_global, ONLY : ionode USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(contraction_index), INTENT(in) :: cri!the contraction index descriptor TYPE(contraction_state) :: crs!the contraction state to be read from file TYPE(input_options) :: options!for debug flag INTEGER :: iw, jw, kw, iun CHARACTER(5) :: nfile INTEGER :: maxl write(nfile,'(5i1)') & & crs%state/10000,mod(crs%state,10000)/1000,mod(crs%state,1000)/100,mod(crs%state,100)/10,mod(crs%state,10) iun = find_free_unit() if(.not. options%debug) then open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'contraction'// nfile, status='old',form='unformatted') else open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'contraction'// nfile, status='old',form='formatted') endif if(.not.options%debug) then read(iun) crs%numpw read(iun) crs%nums read(iun) crs%max_i read(iun) crs%state else read(iun,*) crs%numpw read(iun,*) crs%nums read(iun,*) crs%max_i read(iun,*) crs%state endif maxl=crs%nums allocate(crs%q(crs%numpw,maxl)) if(.not.options%debug) then do iw=1,crs%nums read(iun) crs%q(1:cri%numpw, iw) enddo else do iw=1,crs%numpw do jw=1,cri%nums read(iun,*) crs%q(iw,jw) enddo enddo endif close(iun) return END SUBROUTINE read_contraction_state SUBROUTINE do_contraction(qm,uu,cr, max_i) !this subroutine creates the product O*U USE io_global, ONLY : stdout USE basic_structures, ONLY : wannier_u, q_mat implicit none TYPE(q_mat) :: qm!descriptors of overlaps of othonormalized wannier producs with wannier products TYPE(wannier_u) :: uu!descriptor of transformation matrix from KS states to wanniers TYPE(contraction) :: cr! the contraction product descriptor to be calculated INTEGER :: max_i !maximum number of states to be clauclates INTEGER :: ii,jj,kk,maxl, num_l INTEGER, ALLOCATABLE :: posi(:) !free and allocates arrays !call free_memory_contraction(cr) cr%numpw=qm%numpw cr%nums=uu%nums cr%max_i=max_i allocate(posi(cr%nums)) maxl=cr%nums write(stdout,*) 'routine do_contraction allocate dimension', cr%nums,maxl,max_i allocate(cr%numl(cr%numpw)) allocate(cr%l(maxl,cr%numpw)) allocate(cr%q(cr%numpw,maxl,max_i)) !do contractions do ii=1,cr%numpw posi(:)=0 kk=0 cr%q(ii,:,:)=(0.d0,0.d0) do jj=1,qm%wp(ii)%numij !first index if(posi(qm%wp(ii)%ij(1,jj))==0) then kk=kk+1 posi(qm%wp(ii)%ij(1,jj))=kk cr%l(kk,ii)=qm%wp(ii)%ij(1,jj) endif cr%q(ii,posi(qm%wp(ii)%ij(1,jj)),1:max_i) = cr%q(ii,posi(qm%wp(ii)%ij(1,jj)),1:max_i)+& &qm%wp(ii)%o(jj)*conjg(uu%umat( 1:max_i,qm%wp(ii)%ij(2,jj),1)) !second index if(qm%wp(ii)%ij(1,jj)/=qm%wp(ii)%ij(2,jj)) then if(posi(qm%wp(ii)%ij(2,jj))==0) then kk=kk+1 posi(qm%wp(ii)%ij(2,jj))=kk cr%l(kk,ii)=qm%wp(ii)%ij(2,jj) endif cr%q(ii,posi(qm%wp(ii)%ij(2,jj)),1:max_i) = cr%q(ii,posi(qm%wp(ii)%ij(2,jj)),1:max_i)+& &qm%wp(ii)%o(jj)*conjg(uu%umat(1:max_i, qm%wp(ii)%ij(1,jj),1)) endif enddo cr%numl(ii)=kk enddo deallocate(posi) END SUBROUTINE SUBROUTINE do_contraction_index_state(qm,uu, max_i, options) !this subroutine creates the product O*U !writes separately index part and states on disk !is parallel on states USE io_global, ONLY : stdout USE basic_structures, ONLY : wannier_u, q_mat USE para_gww, ONLY : is_my_state USE input_gw, ONLY : input_options implicit none TYPE(q_mat) :: qm!descriptors of overlaps of othonormalized wannier producs with wannier products TYPE(wannier_u) :: uu!descriptor of transformation matrix from KS states to wanniers INTEGER :: max_i !maximum number of states to be clauclates TYPE(input_options) :: options!for calling I/O routines INTEGER :: ii,jj,kk,maxl, num_l, is INTEGER, ALLOCATABLE :: posi(:) TYPE(contraction_index) :: cri! the contraction index descriptor to be calculated TYPE(contraction_state) :: crs!the contraction state to be calculated !free and allocates arrays cri%numpw=qm%numpw cri%nums=uu%nums cri%max_i=max_i crs%numpw=qm%numpw crs%nums=uu%nums crs%max_i=max_i allocate(posi(cri%nums)) maxl=cri%nums write(stdout,*) 'routine do_contraction_state_index allocate dimension', cri%nums,maxl,max_i call flush_unit(stdout) allocate(cri%numl(cri%numpw)) allocate(cri%l(maxl,cri%numpw)) allocate(crs%q(cri%numpw,maxl)) write(stdout,*) 'DO CONT INDEX 1' call flush_unit(stdout) !set index descriptor !do contractions do ii=1,cri%numpw posi(:)=0 kk=0 do jj=1,qm%wp(ii)%numij !first index if(posi(qm%wp(ii)%ij(1,jj))==0) then kk=kk+1 posi(qm%wp(ii)%ij(1,jj))=kk cri%l(kk,ii)=qm%wp(ii)%ij(1,jj) endif !second index if(qm%wp(ii)%ij(1,jj)/=qm%wp(ii)%ij(2,jj)) then if(posi(qm%wp(ii)%ij(2,jj))==0) then kk=kk+1 posi(qm%wp(ii)%ij(2,jj))=kk cri%l(kk,ii)=qm%wp(ii)%ij(2,jj) endif endif enddo cri%numl(ii)=kk enddo !write index descriptor on file call write_contraction_index(cri, options) !do contractions for states do is=1,max_i if(is_my_state(is) )then crs%state=is do ii=1,crs%numpw posi(:)=0 kk=0 crs%q(ii,:)=0.d0 do jj=1,qm%wp(ii)%numij !first index if(posi(qm%wp(ii)%ij(1,jj))==0) then kk=kk+1 posi(qm%wp(ii)%ij(1,jj))=kk endif crs%q(ii,posi(qm%wp(ii)%ij(1,jj))) = crs%q(ii,posi(qm%wp(ii)%ij(1,jj)))+& &qm%wp(ii)%o(jj)*dble(uu%umat( is,qm%wp(ii)%ij(2,jj),1)) !second index if(qm%wp(ii)%ij(1,jj)/=qm%wp(ii)%ij(2,jj)) then if(posi(qm%wp(ii)%ij(2,jj))==0) then kk=kk+1 posi(qm%wp(ii)%ij(2,jj))=kk endif crs%q(ii,posi(qm%wp(ii)%ij(2,jj))) = crs%q(ii,posi(qm%wp(ii)%ij(2,jj)))+& &qm%wp(ii)%o(jj)*dble(uu%umat(is, qm%wp(ii)%ij(1,jj),1)) endif enddo enddo !writes of file call write_contraction_state(cri, crs, options) endif enddo call free_memory_contraction_index(cri) call free_memory_contraction_state(crs) deallocate(posi) END SUBROUTINE do_contraction_index_state SUBROUTINE do_contraction_pola(qm,uu,cp) !this subroutine creates the product O*U USE io_global, ONLY : stdout USE basic_structures, ONLY : wannier_u, q_mat implicit none TYPE(q_mat) :: qm!descriptors of overlaps of othonormalized wannier producs with wannier products TYPE(wannier_u) :: uu!descriptor of transformation matrix from KS states to wanniers TYPE(contraction_pola) :: cp!the contraction product descriptor to be calculated INTEGER :: iw,jw,vv,cc,k,m,l,n,ii,jj INTEGER :: nums_con REAL(kind=DP) :: o_ii,o_jj !free memory and set up parameters ! call free_memory_contraction_pola(cp) cp%numpw=qm%numpw cp%nums=uu%nums cp%nums_occ=uu%nums_occ(1) nums_con=cp%nums-cp%nums_occ allocate(cp%ou(cp%numpw,cp%nums_occ,nums_con)) cp%ou(:,:,:)=(0.d0,0.d0) do iw=1,cp%numpw do vv=1,cp%nums_occ do cc=cp%nums_occ+1,cp%nums do ii=1,qm%wp(iw)%numij k=qm%wp(iw)%ij(1,ii) m=qm%wp(iw)%ij(2,ii) cp%ou(iw,vv,cc-cp%nums_occ)=cp%ou(iw,vv,cc-cp%nums_occ)+qm%wp(iw)%o(ii)*& &uu%umat(vv,k,1)*uu%umat(cc,m,1) if(k /= m) then cp%ou(iw,vv,cc-cp%nums_occ)=cp%ou(iw,vv,cc-cp%nums_occ)+qm%wp(iw)%o(ii)*& &uu%umat(vv,m,1)*uu%umat(cc,k,1) endif enddo enddo enddo enddo ! do iw=1,cp%numpw ! do jw=iw,cp%numpw ! do vv=1,cp%nums_occ ! do cc=cp%nums_occ+1,cp%nums ! do ii=1,qm%wp(iw)%numij ! do jj=1,qm%wp(jw)%numij ! k=qm%wp(iw)%ij(1,ii) ! m=qm%wp(iw)%ij(2,ii) ! l=qm%wp(jw)%ij(1,jj) ! n=qm%wp(jw)%ij(2,jj) ! o_ii=qm%wp(iw)%o(ii) ! o_jj=qm%wp(jw)%o(jj) ! cp%q(iw,jw,vv,cc-cp%nums_occ)=cp%q(iw,jw,vv,cc-cp%nums_occ)+o_ii*o_jj*& ! &conjg(uu%umat(k,vv))*uu%umat(l,vv)*conjg(uu%umat(m,cc))*uu%umat(n,cc) ! if(k /= m) then ! cp%q(iw,jw,vv,cc-cp%nums_occ)=cp%q(iw,jw,vv,cc-cp%nums_occ)+o_ii*o_jj*& ! &conjg(uu%umat(m,vv))*uu%umat(l,vv)*conjg(uu%umat(k,cc))*uu%umat(n,cc) ! endif ! if(l /= n) then ! cp%q(iw,jw,vv,cc-cp%nums_occ)=cp%q(iw,jw,vv,cc-cp%nums_occ)+o_ii*o_jj*& ! &conjg(uu%umat(k,vv))*uu%umat(n,vv)*conjg(uu%umat(m,cc))*uu%umat(l,cc) ! endif ! if( k /= m .and. l /= n) then ! cp%q(iw,jw,vv,cc-cp%nums_occ)=cp%q(iw,jw,vv,cc-cp%nums_occ)+o_ii*o_jj*& ! &conjg(uu%umat(m,vv))*uu%umat(n,vv)*conjg(uu%umat(k,cc))*uu%umat(l,cc) ! endif ! enddo ! enddo ! enddo ! enddo ! cp%q(jw,iw,:,:)=conjg(cp%q(iw,jw,:,:)) ! enddo ! enddo END SUBROUTINE SUBROUTINE do_contraction_pola_state(qm,uu, options) !this routine calculates contraction for all states and writes on disk USE io_global, ONLY : stdout, ionode USE basic_structures, ONLY : wannier_u, q_mat USE input_gw, ONLY : input_options USE mp_world, ONLY : mpime, nproc, world_comm USE mp, ONLY : mp_barrier implicit none TYPE(q_mat) :: qm!descriptors of overlaps of othonormalized wannier producs with wannier products TYPE(wannier_u) :: uu!descriptor of transformation matrix from KS states to wanniers TYPE(input_options) :: options!for i/o purpose INTEGER :: vv TYPE(contraction_pola_state) :: cps do vv=1,uu%nums_occ(1) if(mod(vv,nproc)==mpime) then write(stdout,*) 'Contracting occupied state :', vv call do_contraction_pola_state_single(vv,qm,uu,cps) !if(ionode) call write_contraction_pola_state(cps, options) call write_contraction_pola_state(cps, options) call free_memory_contraction_pola_state(cps) endif enddo call mp_barrier( world_comm ) return END SUBROUTINE do_contraction_pola_state SUBROUTINE do_contraction_pola_state_single(state,qm,uu,cps) !this subroutine creates the product O*U !for state state !parallel USE io_global, ONLY : stdout USE basic_structures, ONLY : wannier_u, q_mat USE mp_world, ONLY : mpime, nproc USE mp, ONLY : mp_sum implicit none INTEGER :: state!state for which the contraction will be calculated TYPE(q_mat) :: qm!descriptors of overlaps of othonormalized wannier producs with wannier products TYPE(wannier_u) :: uu!descriptor of transformation matrix from KS states to wanniers TYPE(contraction_pola_state) :: cps!the contraction product descriptor to be calculated INTEGER :: iw,jw,cc,k,m,l,n,ii,jj INTEGER :: nums_con REAL(kind=DP) :: o_ii,o_jj !free memory and set up parameters ! call free_memory_contraction_pola(cp) cps%numpw=qm%numpw cps%nums=uu%nums cps%nums_occ=uu%nums_occ(1) cps%state=state nums_con=cps%nums-cps%nums_occ allocate(cps%ou(nums_con,cps%numpw)) cps%ou(:,:)=0.d0 do iw=1,cps%numpw ! do cc=cps%nums_occ+1,cps%nums ! if(mod(cc,nproc)==mpime) then do ii=1,qm%wp(iw)%numij k=qm%wp(iw)%ij(1,ii) m=qm%wp(iw)%ij(2,ii) do cc=cps%nums_occ+1,cps%nums cps%ou(cc-cps%nums_occ,iw)=cps%ou(cc-cps%nums_occ,iw)+qm%wp(iw)%o(ii)*& &dble(uu%umat(cps%state,k,1))*dble(uu%umat(cc,m,1)) if(k /= m) then cps%ou(cc-cps%nums_occ,iw)=cps%ou(cc-cps%nums_occ,iw)+qm%wp(iw)%o(ii)*& &dble(uu%umat(cps%state,m,1))*dble(uu%umat(cc,k,1)) endif enddo ! endif enddo ! call mp_sum(cps%ou(:,iw)) enddo END SUBROUTINE do_contraction_pola_state_single SUBROUTINE read_contraction_pola_state(cps, options) !this subroutine writes the contracted pola products on disk !in parallel case only ionode writes USE input_gw, ONLY : input_options USE io_global, ONLY : ionode USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(contraction_pola_state) :: cps!the contraction pola state to be written on file TYPE(input_options) :: options!for debug flag INTEGER :: iw, jw, kw, iun CHARACTER(5) :: nfile write(nfile,'(5i1)') & & cps%state/10000,mod(cps%state,10000)/1000,mod(cps%state,1000)/100,mod(cps%state,100)/10,mod(cps%state,10) iun = find_free_unit() if(.not. options%debug) then open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'contraction_pola'// nfile, status='old',form='unformatted') else open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'contraction_pola'// nfile, status='old',form='formatted') endif if(.not.options%debug) then read(iun) cps%numpw read(iun) cps%nums read(iun) cps%nums_occ read(iun) cps%state else read(iun,*) cps%numpw read(iun,*) cps%nums read(iun,*) cps%nums_occ read(iun,*) cps%state endif allocate(cps%ou(cps%nums-cps%nums_occ,cps%numpw)) if(.not.options%debug) then do iw=1,cps%numpw read(iun) cps%ou(1:(cps%nums-cps%nums_occ),iw) enddo else do iw=1,cps%numpw do jw=1,cps%nums-cps%nums_occ read(iun,*) cps%ou(jw,iw) enddo enddo endif close(iun) return END SUBROUTINE read_contraction_pola_state SUBROUTINE write_contraction_pola_state(cps, options) !this subroutine writes the contracted pola products on disk !in parallel case only ionode writes USE input_gw, ONLY : input_options USE io_global, ONLY : ionode USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(contraction_pola_state) :: cps!the contraction pola state to be written on file TYPE(input_options) :: options!for debug flag INTEGER :: iw, jw, kw, iun CHARACTER(5) :: nfile write(nfile,'(5i1)') & & cps%state/10000,mod(cps%state,10000)/1000,mod(cps%state,1000)/100,mod(cps%state,100)/10,mod(cps%state,10) iun = find_free_unit() if(.not. options%debug) then open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'contraction_pola'// nfile, status='unknown',form='unformatted') else open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'contraction_pola'// nfile, status='unknown',form='formatted') endif if(.not.options%debug) then write(iun) cps%numpw write(iun) cps%nums write(iun) cps%nums_occ write(iun) cps%state do iw=1,cps%numpw write(iun) cps%ou(1:(cps%nums-cps%nums_occ),iw) enddo else write(iun,*) cps%numpw write(iun,*) cps%nums write(iun,*) cps%nums_occ write(iun,*) cps%state do iw=1,cps%numpw do jw=1,cps%nums-cps%nums_occ write(iun,*) cps%ou(jw,iw) enddo enddo endif close(iun) return END SUBROUTINE write_contraction_pola_state SUBROUTINE read_contraction_state_central(cri,crs, options) !this subroutine writes the contracted products on disk !in parallel case only ionode writes USE input_gw, ONLY : input_options USE io_global, ONLY : ionode, ionode_id USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : prefix, tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(contraction_index), INTENT(in) :: cri!the contraction index descriptor TYPE(contraction_state) :: crs!the contraction state to be read from file TYPE(input_options) :: options!for debug flag INTEGER :: iw, jw, kw, iun CHARACTER(5) :: nfile INTEGER :: maxl if(ionode) then write(nfile,'(5i1)') & & crs%state/10000,mod(crs%state,10000)/1000,mod(crs%state,1000)/100,mod(crs%state,100)/10,mod(crs%state,10) iun = find_free_unit() if(.not. options%debug) then open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'contraction'// nfile, status='old',form='unformatted') else open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'contraction'// nfile, status='old',form='formatted') endif if(.not.options%debug) then read(iun) crs%numpw read(iun) crs%nums read(iun) crs%max_i read(iun) crs%state else read(iun,*) crs%numpw read(iun,*) crs%nums read(iun,*) crs%max_i read(iun,*) crs%state endif endif call mp_bcast(crs%numpw, ionode_id,world_comm) call mp_bcast(crs%nums, ionode_id,world_comm) call mp_bcast( crs%max_i, ionode_id,world_comm) call mp_bcast(crs%state, ionode_id,world_comm) maxl=crs%nums allocate(crs%q(crs%numpw,maxl)) if(ionode) then if(.not.options%debug) then do iw=1,crs%numpw read(iun) crs%q(iw,1:cri%numl(iw)) enddo else do iw=1,crs%numpw do jw=1,cri%numl(iw) read(iun,*) crs%q(iw,jw) enddo enddo endif close(iun) endif do iw=1,crs%numpw call mp_bcast( crs%q(iw,1:cri%numl(iw)), ionode_id,world_comm) enddo return END SUBROUTINE read_contraction_state_central END MODULE compact_product GWW/gww/do_polarization_lanczos.f900000644000077300007730000010066212341332532020067 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !this subroutines performs the lanczos style calculation of the polarization subroutine calculate_compact_pola_lanczos(options,ispin) !this subroutine calculate the compact products for the lanczos calculation !of the polarization USE kinds, ONLY : DP USE input_gw, ONLY : input_options USE basic_structures, ONLY : wannier_u,vt_mat_lanczos,tt_mat_lanczos,initialize_memory,free_memory USE lanczos, ONLY : compact_q_lanczos,initialize_compact_q_lanczos,& &free_memory_compact_q_lanczos,do_compact_q_lanczos,write_compact_q_lanczos USE mp_world, ONLY : nproc,mpime USE io_global, ONLY : stdout implicit none TYPE(input_options), INTENT(in) :: options INTEGER, INTENT(in) :: ispin!spin channel TYPE(wannier_u) :: uu!U matrix TYPE(vt_mat_lanczos) :: vtl TYPE(tt_mat_lanczos) :: ttl TYPE(compact_q_lanczos) :: cql INTEGER :: l_blk,nbegin,nend,iv,iu call initialize_memory(vtl) call initialize_memory(ttl) call initialize_compact_q_lanczos(cql) write(stdout,*) 'Routine calculate_compact_pola_lanczos' call flush_unit(stdout) ! !read U matrix call read_data_pw_u(uu,options%prefix) !KS valence state index v distributed on processors l_blk= uu%nums_occ(ispin)/nproc if(l_blk*nproc < uu%nums_occ(ispin)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 if(nend > uu%nums_occ(ispin)) nend = uu%nums_occ(ispin) do iv=nbegin,nbegin+l_blk-1 if(iv <= uu%nums_occ(ispin)) then !loop v' on wannier valence state do iu=1,uu%nums_occ(ispin) !read in V and T call read_data_pw_vt_mat_lanczos(vtl, iu, options%prefix, .true.,ispin) call read_data_pw_tt_mat_lanczos(ttl, iu, options%prefix, .true.,ispin) !calculate contribution to Q if(iu==1) then allocate( cql%qlm(vtl%numpw,ttl%numt)) cql%qlm(:,:)=0.d0 endif !sum up with factor Uvvi call do_compact_q_lanczos(vtl,ttl,cql,dble(uu%umat(iv,iu,ispin))) call free_memory(vtl) call free_memory(ttl) enddo !write Q^v on disk cql%ii=iv call write_compact_q_lanczos(cql) deallocate(cql%qlm) else !put here global routines involving MPI do iu=1,uu%nums_occ(ispin) call read_data_pw_vt_mat_lanczos(vtl, iu, options%prefix, .true.,ispin) call read_data_pw_tt_mat_lanczos(ttl, iu, options%prefix, .true.,ispin) call free_memory(vtl) call free_memory(ttl) enddo endif enddo call free_memory(vtl) call free_memory(ttl) call free_memory_compact_q_lanczos(cql) call free_memory(uu) return end subroutine calculate_compact_pola_lanczos subroutine solve_lanczos(nbuf, alpha,e_mat,lc, l_verbose) !this subroutine sums to the matrix E_{no}= !the matrix lc%o_mat is distributed among the processors USE kinds, ONLY : DP USE basic_structures, ONLY : lanczos_chain, initialize_memory,free_memory USE io_global, ONLY : stdout USE mp, ONLY : mp_sum, mp_bcast USE mp_world, ONLY : nproc,mpime,world_comm implicit none INTEGER :: nbuf!number of matrices to treat COMPLEX(kind=DP) :: alpha(nbuf)!constant for Ev+iw TYPE(lanczos_chain) :: lc!lanczos chain descriptor REAL(kind=DP) :: e_mat(lc%numt,lc%numt,nbuf)!matrix to be calculated LOGICAL, INTENT(in) :: l_verbose!if true a lot of output INTEGER :: io,info COMPLEX(kind=DP), ALLOCATABLE :: dl(:),du(:),d(:),t(:) REAL(kind=DP), ALLOCATABLE :: tr(:,:) INTEGER :: l_blk,nbegin,nend REAL(kind=DP), ALLOCATABLE :: o_mat(:,:,:) INTEGER :: iv, iproc,nsize allocate(dl(lc%num_steps-1),du(lc%num_steps-1),d(lc%num_steps),t(lc%num_steps)) e_mat(:,:,:)=0.d0 l_blk= (lc%numt)/nproc if(l_blk*nproc < (lc%numt)) l_blk = l_blk+1 allocate(o_mat(lc%numt,lc%num_steps,l_blk)) allocate(tr(lc%num_steps,l_blk)) !loop on procs do iproc=0,nproc-1 l_blk= (lc%numt)/nproc if(l_blk*nproc < (lc%numt)) l_blk = l_blk+1 nbegin=iproc*l_blk+1 nend=min(nbegin+l_blk-1,lc%numt) nsize=nend-nbegin+1 if(nbegin<=lc%numt) then if(iproc==mpime) then o_mat(:,:,:)=lc%o_mat(:,:,1:nsize) endif if(l_verbose) write(stdout,*) 'proc:', iproc, lc%numt,lc%num_steps,l_blk,nsize if(l_verbose)call flush_unit(stdout) call mp_bcast(o_mat, iproc, world_comm) if(l_verbose) write(stdout,*) 'mp_bcast done' if(l_verbose)call flush_unit(stdout) do iv=1,nbuf do io=nbegin,nend !!set up vectors for lapack routine dl(1:lc%num_steps-1)=cmplx(lc%f(1:lc%num_steps-1,io),0.d0) du(1:lc%num_steps-1)=cmplx(lc%f(1:lc%num_steps-1,io),0.d0) d(1:lc%num_steps)=cmplx(lc%d(1:lc%num_steps,io),0.d0)+alpha(iv) t(:)=(0.d0,0.d0) t(1)=(1.d0,0.d0) !!call lapack call zgtsv(lc%num_steps,1,dl,d,du,t,lc%num_steps,info) if(info /= 0) then write(stdout,*) 'ZGTSV info:', info call flush_unit(stdout) stop endif !!calculate term tr(:,io-nbegin+1)=dble(t(:)) enddo if(l_verbose) write(stdout,*) 'zgtsv done' if(l_verbose) call flush_unit(stdout) do io=nbegin,nend call dgemv( 'N', lc%numt,lc%num_steps,1.d0, o_mat(1,1,io-nbegin+1), lc%numt,tr(1,io-nbegin+1),1,1.d0,e_mat(1,io,iv),1) ! call dgemm('N','N',lc%numt,1,lc%num_steps,1.d0,o_mat(1,1,io-nbegin+1),lc%numt,tr(1,io-nbegin+1),lc%num_steps,1.d0,e_mat(1,io,iv),lc%numt) enddo if(l_verbose) write(stdout,*) 'dgemv done' if(l_verbose) call flush_unit(stdout) enddo!on iv end if end do deallocate(tr) deallocate(o_mat) return end subroutine solve_lanczos subroutine solve_lanczos_fake(lc,l_verbose) !this subroutine is a parallel fake routine for the solve lanczos routine USE kinds, ONLY : DP USE basic_structures, ONLY : lanczos_chain, initialize_memory,free_memory USE io_global, ONLY : stdout USE mp, ONLY : mp_sum,mp_bcast USE mp_world, ONLY : nproc,mpime,world_comm implicit none TYPE(lanczos_chain) :: lc!lanczos chain descriptor LOGICAL, INTENT(in) :: l_verbose INTEGER :: l_blk,nbegin,nend, iproc REAL(kind=DP), ALLOCATABLE :: o_mat(:,:,:) INTEGER :: io,nsize l_blk= (lc%numt)/nproc if(l_blk*nproc < (lc%numt)) l_blk = l_blk+1 allocate(o_mat(lc%numt,lc%num_steps,l_blk)) do iproc=0,nproc-1 l_blk= (lc%numt)/nproc if(l_blk*nproc < (lc%numt)) l_blk = l_blk+1 nbegin=iproc*l_blk+1 nend=min(nbegin+l_blk-1,lc%numt) nsize=nend-nbegin+1 if(nbegin<=lc%numt) then if(iproc==mpime) then o_mat(:,:,:)=lc%o_mat(:,:,1:nsize) endif if(l_verbose) write(stdout,*) 'proc:', iproc, lc%numt,lc%num_steps,l_blk,nsize if(l_verbose) call flush_unit(stdout) call mp_bcast(o_mat, iproc,world_comm) endif enddo deallocate(o_mat) end subroutine solve_lanczos_fake subroutine do_polarization_lanczos(tf,options,ispin) !this subroutine create polarization descriptor in imaginary frequency using the lanczos scheme USE kinds, ONLY : DP USE input_gw, ONLY : input_options USE lanczos, ONLY : compact_q_lanczos,initialize_compact_q_lanczos,free_memory_compact_q_lanczos,& &read_compact_q_lanczos USE mp_world, ONLY : world_comm, mpime, nproc USE basic_structures, ONLY : wannier_u,lanczos_chain, initialize_memory,free_memory,& &vt_mat_lanczos,tt_mat_lanczos,partial_occ USE io_global, ONLY : stdout,ionode,ionode_id USE times_gw, ONLY : times_freqs USE polarization, ONLY : polaw,initialize_polaw,free_memory_polaw,write_polaw,read_polaw USE mp, ONLY : mp_bcast USE io_files, ONLY : prefix, tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(times_freqs) , INTENT(in) :: tf!for time grid TYPE(input_options), INTENT(in) :: options! for imaginary time range and number of samples INTEGER, INTENT(in) :: ispin!spin channel TYPE(wannier_u) :: uu TYPE(lanczos_chain) :: lc TYPE(partial_occ) :: po INTEGER :: l_blk,nbegin,nend,iv,iw, it,ii,jj,il TYPE(polaw) :: pw ! REAL(kind=DP), ALLOCATABLE :: e_mat(:,:,:) COMPLEX(kind=DP), ALLOCATABLE :: af(:) TYPE(compact_q_lanczos) :: cql REAL(kind=DP), ALLOCATABLE :: tmp_mat(:,:) REAL(kind=DP), ALLOCATABLE :: tmp_mat1(:,:),tmp_mat2(:,:),tmp_mat3(:,:) REAL(kind=DP) :: offset INTEGER :: n_bufv!number of states which are bufferized INTEGER :: n_dim INTEGER :: io_tot,l_blk_io, nbegin_io,nend_io, iproc REAL(kind=DP), ALLOCATABLE :: cql_save(:,:,:) REAL(kind=DP), ALLOCATABLE :: vtl_save(:,:,:) REAL(kind=DP), ALLOCATABLE :: ttl_save(:,:,:) COMPLEX(kind=DP) :: afc TYPE(vt_mat_lanczos) :: vtl TYPE(tt_mat_lanczos) :: ttl INTEGER :: numpw,numl,numt!to be passed to subroutine LOGICAL :: l_reduce_memory=.true. !if true reduces the use of memory, only useful for nprocs==nfreqs LOGICAL :: exst INTEGER :: iw_nbegin, iv_begin, iunrestart,off_nbegin LOGICAL :: l_do_restart REAL(kind=DP), ALLOCATABLE :: occ(:) #ifdef __OPENMP INTEGER :: omp_get_num_threads, omp_get_max_threads EXTERNAL omp_set_num_threads, omp_get_num_threads, omp_get_max_threads #endif write(stdout,*) 'Routine: do_polarization_lanczos' call flush_unit(stdout) call initialize_memory(vtl) call initialize_memory(ttl) call initialize_memory(po) n_bufv=options%n_set_pola ! if(l_reduce_memory) n_bufv=1 OCIO ATTENZIONE !read uu for energies and lanczos chain call read_data_pw_u(uu,options%prefix) if(uu%nums_occ(ispin)==0) then call free_memory(uu) return endif !call free_memory(uu) !i do not need the orthonormalization matrix !if required read partial occupancis stuff if(options%l_frac_occ) then !NOT_TO_BE_INCLUDED_START call read_data_pw_partial_occ(po,options%prefix,ispin) !NOT_TO_BE_INCLUDED_END endif call initialize_memory(lc) call read_data_pw_lanczos_chain(lc, 1, options%prefix, .true.,ispin) write(stdout,*) 'Lanczos dimensions', lc%numt,lc%num_steps do ii=1,lc%numt ! do jj=1,lc%num_steps ! write(stdout,*)' Lanczos elemets:', ii, jj, lc%d(jj,ii), lc%f(jj,ii) ! enddo write(stdout,*)' Lanczos elemets:', ii, lc%d(1,ii), lc%f(1,ii) enddo ! allocate(e_mat(lc%numt,lc%numt,n_bufv)) allocate(af(n_bufv),occ(n_bufv)) occ(:)=1.d0 call initialize_compact_q_lanczos(cql) if(uu%nums > uu%nums_occ(ispin)) then offset=-(uu%ene(uu%nums_occ(ispin)+1,ispin)+uu%ene(uu%nums_occ(ispin),ispin))/2.d0 else offset=-uu%ene(uu%nums_occ(ispin),ispin) endif ! l_blk= (2*tf%n+1)/nproc ! if(l_blk*nproc < (2*tf%n+1)) l_blk = l_blk+1 ! nbegin=mpime*l_blk-tf%n ! nend=nbegin+l_blk-1 l_blk= (tf%n+1)/nproc if(l_blk*nproc < (tf%n+1)) l_blk = l_blk+1 nbegin=mpime*l_blk nend=nbegin+l_blk-1 !if reduce io and l_direct put compact_q_lanczos in memory if(options%l_t_wannier) then l_blk_io= (uu%nums_occ(ispin))/nproc if(l_blk_io*nproc < (uu%nums_occ(ispin))) l_blk_io = l_blk_io+1 nbegin_io=mpime*l_blk_io+1 nend_io=nbegin_io+l_blk_io-1 if(nend_io > uu%nums_occ(ispin)) nend_io=uu%nums_occ(ispin) io_tot=nend_io-nbegin_io+1 if(.not.l_reduce_memory) then do iv=1,uu%nums_occ(ispin) call read_compact_q_lanczos(cql, iv) if(iv==1) allocate(cql_save(cql%numpw,cql%numt,l_blk_io)) if(iv >= nbegin_io .and. iv <= nend_io) then cql_save(:,:,iv-nbegin_io+1)=cql%qlm(:,:) endif enddo else call read_compact_q_lanczos(cql, 1)!just for obtaining numpw,numt...poor man solution allocate(cql_save(1,1,1)) endif else !put all matrices vtl and ttl in memory, distributed according to valence state l_blk_io= (uu%nums_occ(ispin))/nproc if(l_blk_io*nproc < (uu%nums_occ(ispin))) l_blk_io = l_blk_io+1 nbegin_io=mpime*l_blk_io+1 nend_io=nbegin_io+l_blk_io-1 if(nend_io > uu%nums_occ(ispin)) nend_io=uu%nums_occ(ispin) io_tot=nend_io-nbegin_io+1 do iv=1,uu%nums_occ(ispin) call read_data_pw_vt_mat_lanczos(vtl, iv, options%prefix, .true.,ispin) call read_data_pw_tt_mat_lanczos(ttl, iv, options%prefix, .true.,ispin) if(iv==1) then allocate(vtl_save(vtl%numpw,vtl%numl,l_blk_io)) allocate(ttl_save(ttl%numt,ttl%numl,l_blk_io)) endif if(iv >= nbegin_io .and. iv <= nend_io) then vtl_save(:,:,iv-nbegin_io+1)= vtl%vt_mat(:,:) ttl_save(:,:,iv-nbegin_io+1)= ttl%tt_mat(:,:) endif call free_memory(vtl) call free_memory(ttl) enddo endif !sutup parameters for solve_lanczos if(options%l_t_wannier) then numpw=cql%numpw numt=cql%numt pw%numpw=cql%numpw else numpw=vtl%numpw numl=vtl%numl numt=ttl%numt pw%numpw=vtl%numpw endif !loop on imaginary frequency i\omega !check for restart if(ionode) then inquire(file=trim(tmp_dir)//trim(prefix)//'-'//'restart_polaw', exist = exst) if(.not. exst .or. ispin==2) then off_nbegin=0 iv_begin=1 l_do_restart=.false. else iunrestart = find_free_unit() open( unit= iunrestart, file=trim(tmp_dir)//trim(prefix)//'-'//'restart_polaw', status='old') read(iunrestart,*) off_nbegin read(iunrestart,*) iv_begin close(iunrestart) if(off_nbegin<0) off_nbegin=0 if(iv_begin<1 ) then iv_begin=1 l_do_restart=.false. else iv_begin=iv_begin+n_bufv l_do_restart=.true. endif endif endif call mp_bcast(off_nbegin,ionode_id,world_comm) iw_nbegin=nbegin+off_nbegin call mp_bcast(iv_begin, ionode_id,world_comm) call mp_bcast(l_do_restart, ionode_id,world_comm) do iw=iw_nbegin,nbegin+l_blk-1 if(iw <= tf%n) then write(stdout,*) 'do_polarization_lanczos1', iw, l_do_restart call flush_unit(stdout) !!set up polaw descriptor !if required read polaw from disk if(l_do_restart.or.ispin==2) then call initialize_polaw(pw) call read_polaw(iw,pw,.false.,options%l_verbose) l_do_restart=.false. else call initialize_polaw(pw) pw%label=iw pw%ontime=.false. pw%time=tf%freqs(iw) pw%factor=(1.d0,0.d0) endif !!loop on valence states v do iv=iv_begin,uu%nums_occ(ispin),n_bufv write(stdout,*) 'do_polarization_lanczos iv', iv call flush_unit(stdout) !!!solve tridiagonal problem for -E_v+i\omega n_dim=0 do il=1,n_bufv if((iv+il-1) <= uu%nums_occ(ispin)) then af(il) = -uu%ene(iv+il-1,ispin)+dcmplx(0.d0,tf%freqs(iw)) if(.not.options%l_frac_occ) then occ(il)=1.d0 else !NOT_TO_BE_INCLUDED_START occ(il)=po%f_occ(iv+il-1) !NOT_TO_BE_INCLUDED_END endif n_dim=n_dim+1 endif enddo if(options%l_verbose) write(stdout,*) 'Call solve_lanczos' if(options%l_verbose) call flush_unit(stdout) if(iv==1.and.ispin/=2) then ! if(options%l_t_wannier) then ! pw%numpw=cql%numpw ! else ! pw%numpw=vtl%numpw ! endif allocate(pw%pw(pw%numpw,pw%numpw)) pw%pw(:,:)=0.d0 endif !NOT_TO_BE_INCLUDED_START if(iv==1 .and. options%l_frac_occ) then afc=dcmplx(0.d0,tf%freqs(iw)) call add_partial_pola(pw,po,uu,afc,options%nspin,ispin) endif !NOT_TO_BE_INCLUDED_END call solve_lanczos_2(numpw,numt,numl,n_dim,n_bufv,af,lc, iv, uu%nums_occ(ispin),l_blk_io,& &cql_save,pw,n_dim,options%l_t_wannier,vtl_save,ttl_save,l_reduce_memory,uu%nspin,occ,options%l_verbose) if(options%l_verbose) write(stdout,*) 'Done' if(options%l_verbose) call flush_unit(stdout) #ifdef __OPENMP ! write(stdout,*) 'Call dgemms, ntids=', omp_get_max_threads() #else ! write(stdout,*) 'Call dgemms' #endif !restart part, every 10 if(mod(iv-iv_begin,10)==0.or.n_bufv/=1) then call write_polaw(pw,options%debug) if(ionode) then iunrestart = find_free_unit() open( unit= iunrestart, file=trim(tmp_dir)//trim(prefix)//'-'//'restart_polaw', status='unknown') write(iunrestart,*) iw-nbegin write(iunrestart,*) iv close(iunrestart) endif endif enddo !!write polarization on disk if(ionode) then iunrestart = find_free_unit() open( unit= iunrestart, file=trim(tmp_dir)//trim(prefix)//'-'//'restart_polaw', status='unknown') write(iunrestart,*) iw-nbegin write(iunrestart,*) iv close(iunrestart) endif call write_polaw(pw,options%debug) call free_memory_polaw(pw) else !here just global parallel calls do iv=iv_begin,uu%nums_occ(ispin),n_bufv n_dim=0 do il=1,n_bufv if((iv+il-1) <= uu%nums_occ(ispin)) then n_dim=n_dim+1 endif enddo call solve_lanczos_2(numpw,numt,numl,0,n_bufv,af,lc, iv, uu%nums_occ(ispin),l_blk_io,& &cql_save,pw,n_dim,options%l_t_wannier,vtl_save,ttl_save,l_reduce_memory,uu%nspin,occ,.false.) enddo endif iv_begin=1 l_do_restart=.false. enddo if(ionode) then iunrestart = find_free_unit() open( unit= iunrestart, file=trim(tmp_dir)//trim(prefix)//'-'//'restart_polaw', status='unknown') write(iunrestart,*) -1 write(iunrestart,*) -1 close(iunrestart) endif if(options%l_t_wannier) then deallocate(cql_save) call free_memory_compact_q_lanczos(cql) else deallocate(vtl_save,ttl_save) endif ! deallocate(e_mat) deallocate(af,occ) call free_memory(lc) call free_memory(uu) call free_memory(vtl) call free_memory(ttl) call free_memory(po) return end subroutine do_polarization_lanczos subroutine solve_lanczos_2(numpw,numt,numl,nbuf,mbuf, alpha,lc, iv0,nbndv,& &lblkio,cql_save,pw,n_dim,l_t_wannier, vtl_save, ttl_save, l_reduce_memory,nspin,occ,l_verbose) !this subroutine sums to the matrix E_{no}= !the matrix lc%o_mat is distributed among the processors USE kinds, ONLY : DP USE basic_structures, ONLY : lanczos_chain, initialize_memory,free_memory USE io_global, ONLY : stdout USE mp, ONLY : mp_sum, mp_bcast USE mp_world, ONLY : nproc,mpime,world_comm USE parallel_include USE lanczos, ONLY : compact_q_lanczos,initialize_compact_q_lanczos,& free_memory_compact_q_lanczos, & read_compact_q_lanczos USE polarization, ONLY : polaw implicit none INTEGER, INTENT(in) :: numpw!dimension of polarizability basis INTEGER, INTENT(in) :: numt!number of t vectors INTEGER, INTENT(in) :: numl!number of tv vectors INTEGER :: nbuf!number of matrices to treat INTEGER :: mbuf COMPLEX(kind=DP) :: alpha(mbuf)!constant for Ev+iw TYPE(lanczos_chain) :: lc!lanczos chain descriptor INTEGER, INTENT(in) :: iv0 !staring valence energy INTEGER, INTENT(in) :: nbndv!number of valence functions INTEGER, INTENT(in) :: lblkio!for the dimension of the following array REAL(kind=DP), INTENT(in) :: cql_save(numpw,numt,lblkio) TYPE(polaw), INTENT(inout) :: pw INTEGER, INTENT(in) :: n_dim!max dimension of nbuf LOGICAL, INTENT(in) :: l_t_wannier !if true t vectors from products with wannier REAL(kind=DP) :: vtl_save(numpw,numl,lblkio) REAL(kind=DP) :: ttl_save(numt,numl,lblkio) LOGICAL, INTENT(in) :: l_reduce_memory!if true cql_save not used INTEGER, INTENT(in) :: nspin!spin multiplicity REAL(kind=DP), INTENT(in) :: occ(mbuf)!occupancies of KS valence states LOGICAL, INTENT(in) :: l_verbose INTEGER :: io,info COMPLEX(kind=DP), ALLOCATABLE :: dl(:),du(:),d(:),t(:) REAL(kind=DP), ALLOCATABLE :: tr(:,:) INTEGER :: l_blk,nbegin,nend REAL(kind=DP), ALLOCATABLE :: e_mat_ip(:,:) INTEGER :: iv, iproc,nsize, iproc_cql INTEGER :: nbuf_ip COMPLEX(kind=DP), ALLOCATABLE :: alpha_ip(:) INTEGER, ALLOCATABLE :: displ(:), recvcounts(:) INTEGER :: l_blk_io, nbegin_io,nend_io REAL(kind=DP), ALLOCATABLE :: tmp_mat(:,:),tmp_mat1(:,:),tmp_mat2(:,:),tmp_mat3(:,:) REAL(kind=DP), ALLOCATABLE :: pw_ip(:,:),pw_dumm(:,:) REAL(kind=DP), ALLOCATABLE :: qlm_tmp(:,:,:),vtl_tmp(:,:,:),ttl_tmp(:,:,:) INTEGER :: ierr TYPE(compact_q_lanczos) :: cql LOGICAL :: l_qo=.true.!if true perform QO matrix multimplication first (convenient only if nprocs>nlanczos_steps) REAL(kind=DP), ALLOCATABLE :: qo_mat(:,:,:,:) LOGICAL :: l_single=.true.!if true saves qlm_tmp in single precision REAL(kind=4), ALLOCATABLE :: qlm_tmp_single(:,:,:) REAL(kind=DP) :: factor!global prefactor if(nspin==1) then factor=-4.d0 else factor=-2.d0 endif allocate(dl(lc%num_steps-1),du(lc%num_steps-1),d(lc%num_steps),t(lc%num_steps)) ierr=0 l_blk= (lc%numt)/nproc if(l_blk*nproc < (lc%numt)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=min(nbegin+l_blk-1,lc%numt) nsize=nend-nbegin+1 l_blk_io= (nbndv)/nproc if(l_blk_io*nproc < (nbndv)) l_blk_io = l_blk_io+1 nbegin_io=mpime*l_blk_io+1 nend_io=nbegin_io+l_blk_io-1 allocate(tr(lc%num_steps,l_blk)) allocate(displ(nproc),recvcounts(nproc)) allocate(e_mat_ip(lc%numt,l_blk)) if(l_t_wannier) then if(.not.l_reduce_memory) then allocate(qlm_tmp(numpw,numt,n_dim)) do iv=1,n_dim !read compact matrix iproc_cql=(iv0+iv-2)/l_blk_io if(mpime==iproc_cql) qlm_tmp(:,:,iv) = cql_save(:,:,iv0+iv-1-nbegin_io+1) call mp_bcast(qlm_tmp(:,:,iv), iproc_cql,world_comm) enddo else call initialize_compact_q_lanczos(cql) if(.not.l_single) then allocate(qlm_tmp(numpw,numt,n_dim)) do iv=1,n_dim call read_compact_q_lanczos(cql,iv0+iv-1) qlm_tmp(1:numpw,1:numt,iv)=cql%qlm(1:numpw,1:numt) enddo else allocate(qlm_tmp(numpw,numt,1)) allocate(qlm_tmp_single(numpw,numt,n_dim)) do iv=1,n_dim call read_compact_q_lanczos(cql,iv0+iv-1) qlm_tmp_single(1:numpw,1:numt,iv)=real(cql%qlm(1:numpw,1:numt)) enddo endif call free_memory_compact_q_lanczos(cql) endif if(l_qo) then allocate(qo_mat(numpw,lc%num_steps,nsize,n_dim)) do iv=1,n_dim !calculate qo_mat qlm_tmp(1:numpw,1:numt,1)=dble(qlm_tmp_single(1:numpw,1:numt,iv)) do io=nbegin,nend if(.not.l_single) then call dgemm('N','N', numpw,lc%num_steps,numt,1.d0, qlm_tmp(1,1,iv),& &numpw,lc%o_mat(1,1,io-nbegin+1),numt,0.d0,qo_mat(1,1,io-nbegin+1,iv),numpw) else !qlm_tmp(1:numpw,1:numt,1)=dble(qlm_tmp_single(1:numpw,1:numt,iv)) call dgemm('N','N', numpw,lc%num_steps,numt,1.d0, qlm_tmp(1,1,1),numpw,& &lc%o_mat(1,1,io-nbegin+1),numt,0.d0,qo_mat(1,1,io-nbegin+1,iv),numpw) endif enddo !call dgemv( 'N', lc%numt,lc%num_steps,1.d0, lc%o_mat(1,1,io-nbegin+1), lc%numt,tr(1,io-nbegin+1),1,1.d0,e_mat_ip(1,io-nbegin+1),1) enddo endif else allocate(vtl_tmp(numpw,numl,n_dim)) allocate(ttl_tmp(numt,numl,n_dim)) do iv=1,n_dim !read compact matrix iproc_cql=(iv0+iv-2)/l_blk_io if(mpime==iproc_cql) then vtl_tmp(:,:,iv) = vtl_save(:,:,iv0+iv-1-nbegin_io+1) ttl_tmp(:,:,iv) = ttl_save(:,:,iv0+iv-1-nbegin_io+1) endif call mp_bcast(vtl_tmp(:,:,iv), iproc_cql,world_comm) call mp_bcast(ttl_tmp(:,:,iv), iproc_cql,world_comm) enddo endif do iproc=0,nproc-1 displ(iproc+1)=iproc*l_blk if(displ(iproc+1)+l_blk > lc%numt) then recvcounts(iproc+1)=(lc%numt-displ(iproc+1)) else recvcounts(iproc+1)=l_blk endif enddo displ(:)=displ(:)*lc%numt recvcounts(:)=recvcounts(:)*lc%numt if(l_t_wannier) then allocate(tmp_mat(numpw,l_blk)) else allocate(tmp_mat1(numl,l_blk)) allocate(tmp_mat2(numpw,l_blk)) allocate(tmp_mat3(numpw,numl)) endif allocate(pw_ip(numpw,numpw),pw_dumm(numpw,numpw)) !loop on procs do iproc=0,nproc-1 if(iproc==mpime) nbuf_ip=nbuf !distribute number of nbuf !distribute af call mp_bcast(nbuf_ip, iproc,world_comm) if(nbuf_ip >0) then allocate(alpha_ip(nbuf_ip)) if(iproc==mpime) alpha_ip(:)=alpha(:) call mp_bcast(alpha_ip,iproc,world_comm) !loop on freuqency pw_ip(:,:)=0.d0 do iv=1,nbuf_ip if(l_single) then qlm_tmp(1:numpw,1:numt,1)=dble(qlm_tmp_single(1:numpw,1:numt,iv)) endif e_mat_ip(:,:)=0.d0 !calculate part !$OMP PARALLEL SHARED(tr,lc,alpha_ip,iv) PRIVATE(dl,du,d,t,info,io) ! allocate(dl(lc%num_steps-1),du(lc%num_steps-1),d(lc%num_steps),t(lc%num_steps)) !$OMP DO do io=nbegin,nend !!set up vectors for lapack routine dl(1:lc%num_steps-1)=cmplx(lc%f(1:lc%num_steps-1,io),0.d0) du(1:lc%num_steps-1)=cmplx(lc%f(1:lc%num_steps-1,io),0.d0) d(1:lc%num_steps)=cmplx(lc%d(1:lc%num_steps,io),0.d0)+alpha_ip(iv) t(:)=(0.d0,0.d0) t(1)=(1.d0,0.d0) !!call lapack call zgtsv(lc%num_steps,1,dl,d,du,t,lc%num_steps,info) if(info /= 0) then write(stdout,*) 'ZGTSV info:', info call flush_unit(stdout) stop endif !!calculate term tr(1:lc%num_steps,io-nbegin+1)=dble(t(1:lc%num_steps)) enddo !$OMP END DO ! deallocate(dl,du,d,t) !$OMP END PARALLEL if(l_verbose) write(stdout,*) 'zgtsv done' if(l_verbose) call flush_unit(stdout) if(.not.l_qo) then do io=nbegin,nend call dgemv( 'N', lc%numt,lc%num_steps,1.d0, lc%o_mat(1,1,io-nbegin+1), & &lc%numt,tr(1,io-nbegin+1),1,1.d0,e_mat_ip(1,io-nbegin+1),1) enddo endif if(l_verbose) write(stdout,*) 'dgemv done',nsize if(l_verbose) call flush_unit(stdout) if(nbegin <= lc%numt) then if(l_t_wannier) then if(.not.l_qo) then if(.not.l_single) then call dgemm('N','N',numpw,nsize,numt,1.d0,qlm_tmp(1,1,iv),numpw,e_mat_ip,lc%numt,0.d0,tmp_mat,numpw) else call dgemm('N','N',numpw,nsize,numt,1.d0,qlm_tmp(1,1,1),numpw,e_mat_ip,lc%numt,0.d0,tmp_mat,numpw) endif if(l_verbose) write(stdout,*) 'dgemm1 done' if(l_verbose) call flush_unit(stdout) else do io=nbegin,nend call dgemv( 'N', numpw,lc%num_steps,1.d0, qo_mat(1,1,io-nbegin+1,iv), & &numpw,tr(1,io-nbegin+1),1,0.d0,tmp_mat(1,io-nbegin+1),1) enddo endif if(.not.l_single) then call dgemm('N','T',numpw,numpw,nsize,factor*occ(iv),tmp_mat,numpw,qlm_tmp(1,nbegin,iv),numpw,1.d0,pw_ip,numpw) else call dgemm('N','T',numpw,numpw,nsize,factor*occ(iv),tmp_mat,numpw,qlm_tmp(1,nbegin,1),numpw,1.d0,pw_ip,numpw) endif if(l_verbose) write(stdout,*) 'dgemm2 done', pw%numpw, numpw,ierr if(l_verbose) call flush_unit(stdout) else call dgemm('T','N',numl,nsize,numt,1.d0,ttl_tmp(1,1,iv),numt,e_mat_ip,numt,0.d0,tmp_mat1,numl) if(l_verbose) write(stdout,*) 'dgemm1 done' if(l_verbose) call flush_unit(stdout) call dgemm('N','N',numpw,nsize,numl,1.d0,vtl_tmp(1,1,iv),numpw,tmp_mat1,numl,0.d0,tmp_mat2,numpw) if(l_verbose) write(stdout,*) 'dgemm2 done' if(l_verbose) call flush_unit(stdout) call dgemm('N','N', numpw,numl,nsize,1.d0,tmp_mat2,numpw,ttl_tmp(nbegin,1,iv),numt,0.d0,tmp_mat3,numpw) if(l_verbose)write(stdout,*) 'dgemm3 done' if(l_verbose) call flush_unit(stdout) call dgemm('N','T', numpw,numpw,numl,factor*occ(iv),tmp_mat3,numpw,vtl_tmp(1,1,iv),numpw,1.d0,pw_ip,numpw) ! call dgemm('T','N', ttl%numl,ttl%numt,ttl%numt,1.d0,ttl%tt_mat,ttl%numt,e_mat(1,1,il),lc%numt,0.d0,tmp_mat1,ttl%numl) ! call dgemm('N','N', pw%numpw,ttl%numt,ttl%numl,1.d0,vtl%vt_mat,vtl%numpw,tmp_mat1,ttl%numl,0.d0,tmp_mat2,pw%numpw) ! call dgemm('N','N', pw%numpw,ttl%numl,ttl%numt,1.d0,tmp_mat2,pw%numpw,ttl%tt_mat,ttl%numt,0.d0,tmp_mat3,pw%numpw) ! call dgemm('N','T', pw%numpw,pw%numpw,ttl%numl,-4.d0,tmp_mat3,pw%numpw,vtl%vt_mat,pw%numpw,1.d0,pw%pw,pw%numpw) endif endif !gather_collect result ! call mpi_gatherv(e_mat_ip, lc%numt*nsize,MPI_DOUBLE_PRECISION,e_mat(1,1,iv),recvcounts,displ, MPI_DOUBLE_PRECISION,iproc,world_comm) enddo #ifdef __PARA if(iproc==mpime) then pw_ip(:,:)=pw_ip(:,:)+pw%pw(:,:) CALL MPI_REDUCE(pw_ip, pw%pw, pw%numpw*pw%numpw,MPI_DOUBLE_PRECISION,MPI_SUM, iproc,world_comm,ierr) else !ATTENTION pw%numpw could not be initialized in THIS CASE CALL MPI_REDUCE(pw_ip, pw_dumm, numpw*numpw,MPI_DOUBLE_PRECISION,MPI_SUM, iproc,world_comm,ierr) endif if(l_verbose) write(stdout,*) 'mpi_reduce done' if(l_verbose) call flush_unit(stdout) #else pw%pw(:,:)=pw%pw(:,:)+pw_ip(:,:) #endif deallocate(alpha_ip) endif enddo if(l_qo) deallocate(qo_mat) deallocate(displ,recvcounts) deallocate(e_mat_ip) deallocate(dl,du,d,t) deallocate(tr) if(l_t_wannier) then deallocate(tmp_mat) ! if(l_reduce_memory) call free_memory_compact_q_lanczos(cql) else deallocate(tmp_mat1,tmp_mat2,tmp_mat3) endif deallocate(pw_ip,pw_dumm) if(l_t_wannier) then deallocate(qlm_tmp) if(l_single) deallocate(qlm_tmp_single) else deallocate(vtl_tmp, ttl_tmp) endif return end subroutine solve_lanczos_2 subroutine add_partial_pola(pw,po,uu,af,nspin,ispin) !NOT_TO_BE_INCLUDED_START !this subroutine adds the contribution to the irreducible polarizability due to !fractionally occupied states USE kinds, ONLY : DP USE basic_structures, ONLY : partial_occ,wannier_u USE io_global, ONLY : stdout,ionode,ionode_id USE polarization, ONLY : polaw implicit none TYPE(polaw), INTENT(inout) :: pw!polarizability matrix to be modified TYPE(partial_occ), INTENT(in) :: po!fractionary occupaction terms TYPE(wannier_u), INTENT(in) :: uu!for KS energies COMPLEX(kind=DP),INTENT(in) :: af!!complex frequency INTEGER, INTENT(in) :: nspin!spin multiplicity INTEGER, INTENT(in) :: ispin!spin channel REAL(kind=DP) :: fact INTEGER :: iv,jv do iv=po%nums_occ_min+1,po%nums_occ do jv=1,iv-1 fact=-(2.d0/dble(nspin))*(po%f_occ(jv)-po%f_occ(iv))/dble(uu%ene(iv,ispin)-uu%ene(jv,ispin)+af) !invertiti per energie call dgemm('N','T',pw%numpw,pw%numpw,1,fact,po%ppp_mat(1,jv,iv),po%numpw,& &po%ppp_mat(1,jv,iv),po%numpw,1.d0,pw%pw,pw%numpw) enddo enddo return !NOT_TO_BE_INCLUDED_END end subroutine add_partial_pola GWW/gww/start_end.f900000644000077300007730000000253412341332532015123 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! MODULE start_end !this module contains routines to initialize the MPI environment IMPLICIT NONE CHARACTER (len=10), PARAMETER :: code = 'GWW' #ifdef __OPENMP INTEGER, SAVE :: ntids #endif CONTAINS SUBROUTINE startup ! USE io_global, ONLY : stdout, ionode USE mp_world, ONLY : nproc USE mp_global, ONLY : mp_startup USE environment, ONLY: environment_start IMPLICIT NONE #ifdef __PARA CALL mp_startup() #endif CALL environment_start ( code ) #ifdef __PARA if(ionode) then write(stdout,*) 'MPI PARALLEL VERSION' write(stdout,*) 'Number of procs: ', nproc write(stdout,*) 'GWL: Version 1.00' endif #else write(stdout,*) 'GWL: Version 1.00' #endif return END SUBROUTINE startup SUBROUTINE stop_run !this subroutine kills the MPI environment USE io_global, ONLY : stdout, ionode USE mp_global, ONLY : mp_global_end IMPLICIT NONE #ifdef __PARA if(ionode) write(stdout,*) 'Stopping MPI environment' call mp_global_end( ) #endif return END SUBROUTINE stop_run END MODULE start_end GWW/gww/fit_multipole.f900000644000077300007730000005355612341332532016026 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !this contains routines to fit a function on the positive part !of the imaginary axes with a multipole expansion MODULE global_minpack !this module conatins global variables(sigh!) for using old FORTRAN77 ! minpack routine USE kinds, ONLY : DP IMPLICIT NONE SAVE INTEGER, PARAMETER :: maxm=400!max number of samples INTEGER, PARAMETER :: maxpole=30 INTEGER :: n_poles COMPLEX(kind=DP) :: c_target(maxm) REAL(kind=DP) :: freq(maxm) END MODULE SUBROUTINE fit_multipole(n,m,z,s,a_0,a,b,delta,thres,maxiter) !fits with the function f(z)=a_0+\sum_{i=1,m} a_i/(z-b_i) !the values z_j,s_j USE kinds, ONLY : DP USE io_global, ONLY : stdout implicit none INTEGER, INTENT(in) :: n!numer of sampled values INTEGER, INTENT(in) :: m!number of parameters a COMPLEX(kind=DP), INTENT(in) :: z(n)!where COMPLEX(kind=DP), INTENT(in) :: s(n)!values s(z_j) to be fitted COMPLEX(kind=DP), INTENT(inout) :: a_0 COMPLEX(kind=DP), INTENT(inout) :: a(m) COMPLEX(kind=DP), INTENT(inout) :: b(m) REAL(kind=DP), INTENT(in) :: delta!parameter for steepest descend REAL(kind=DP), INTENT(in) :: thres!threshold for convergence INTEGER, INTENT(in) :: maxiter!maximum number of iterations REAL(kind=DP) :: chi0, chi1 INTEGER :: i,j,it COMPLEX(kind=DP) :: cc, grad COMPLEX(kind=DP) :: new_a_0, new_a(m), new_b(m), old_b(m), old_a(m), old_a_0 REAL(kind=DP) :: rr,rc REAL(kind=DP) :: dd,ddb LOGICAL :: random INTEGER :: ip, im ddb= 0.01d0 dd = delta random=.true. ip=1 im=1 !calculates initial chi chi0=0.d0 do i=1,n cc = func(z(i))-s(i) !cc = (func(z(i))-s(i))/s(i) chi0=chi0+cc*conjg(cc) enddo write(stdout,*) 'a_0', a_0!ATTENZIONE write(stdout,*) 'a', a write(stdout,*) 'b', b write(stdout,*) 'z,s' , z(1),s(1),func(z(1)) write(stdout,*) 'z,s' , z(n),s(n),func(z(n)) do it=1,maxiter !updates a_0 grad=(0.d0,0.d0) do i=1,n grad=grad+(func(z(i))-s(i)) enddo new_a_0=a_0-dd*grad if(it==1) write(stdout,*) 'Grad a_0', grad!ATTENZIONE !updates a(:) do j=1,m grad=(0.d0,0.d0) do i=1,n grad=grad+(func(z(i))-s(i))/(conjg(z(i))-conjg(b(j))) enddo new_a(j)=a(j)-grad*dd if(it==1) write(stdout,*) 'Grad a', grad!ATTENZIONE enddo !updates b(:) if(.not.random) then do j=1,m grad=(0.d0,0.d0) do i=1,n grad=grad+(func(z(i))-s(i))*conjg(a(j))/((conjg(z(i))-conjg(b(j)))*(conjg(z(i))-conjg(b(j)))) enddo new_b(j)=b(j)-grad*dd if(it==1) write(stdout,*) 'Grad b', grad!ATTENZIONE enddo endif !calculates new chi old_a_0=a_0 a_0=new_a_0 old_a(:)=a(:) a(:)=new_a(:) if(.not. random) b(:)=new_b(:) chi1=0.d0 do i=1,n cc = func(z(i))-s(i) !cc = (func(z(i))-s(i))/s(i) chi1=chi1+cc*conjg(cc) enddo if(chi1 > chi0) then a_0=old_a_0 a(:)=old_a(:) write(stdout,*) 'Routine fit_multipole: chi1 > chi0 ' !return dd=dd*0.1d0 endif ! if((chi0-chi1) <= thres) then ! write(stdout,*) 'Reached threshold', chi0 ! return ! endif chi0=chi1 if(random) then!minimize b in a random fashion ! if(mod(it,50000) == 1) ddb=ddb*0.1d0 if(mod(ip,10)==0) then ddb=ddb*0.1d0 ip=1 write(stdout,*) 'Random plus' endif if(mod(im,100)==0) then ddb=ddb*10.d0 im=1 write(stdout,*) 'Random minus' endif do j=1,m old_b(:)=b(:) call random_number(rr) call random_number(rc) b(j)=b(j)+ddb*cmplx(rr,rc) if(aimag(b(j)) >= 0.d0) b(j)=cmplx(real(b(j)),-aimag(b(j))) chi1=0.d0 do i=1,n cc = func(z(i))-s(i) !cc = (func(z(i))-s(i))/s(i) chi1=chi1+cc*conjg(cc) enddo if(chi1maxm) then write(stdout,*) 'FCN: MAXN TOO SMALL' stop endif !check number of parameters if(n /= 4*n_poles+2) then write(stdout,*) 'FCN: WRONG NUMBER OF PARAMETERS',n,n_poles stop endif if(n_poles>maxpole) then write(stdout,*) 'FCN: MAXPOLE TOO SMALL' stop endif !set up parameters a_0=cmplx(x(1),x(2)) do i=1,n_poles a(i)=cmplx(x(i*2+1),x(i*2+2)) enddo do i=1,n_poles !b(i)=cmplx(x((i+n_poles)*2+1),-(x((i+n_poles)*2+2))**2.d0) b(i)=cmplx(x((i+n_poles)*2+1),x((i+n_poles)*2+2))!ATTENZIONE enddo !perform calculaation do i=1,m fvec(i)=0.d0 func=a_0 zz=cmplx(0.d0,freq(i)) do j=1,n_poles func=func+a(j)/(zz-b(j)) enddo func=func-c_target(i) !fvec(i)=sqrt(real(func*conjg(func))) fvec(i)=dble(func*conjg(func)) ! do j=1,n_poles ! func=func+a(j)/(zz-b(j)) ! enddo ! func=(func-c_target(i))/c_target(i) ! fvec(i)=real(func*conjg(func)) enddo ! write(*,*) 'fcn', fvec(1) return END SUBROUTINE fcn SUBROUTINE fit_multipole_verlet2(n,m,z,s,a_0,a,b,thres,n_max_iterations, chi, dt, frice) !fits with the function f(z)=a_0+\sum_{i=1,m} a_i/(z-b_i) !the values z_j,s_j USE kinds, ONLY : DP USE io_global, ONLY : stdout implicit none INTEGER, INTENT(in) :: n!numer of sampled values INTEGER, INTENT(in) :: m!number of parameters a COMPLEX(kind=DP), INTENT(in) :: z(n)!where COMPLEX(kind=DP), INTENT(in) :: s(n)!values s(z_j) to be fitted COMPLEX(kind=DP), INTENT(inout) :: a_0 COMPLEX(kind=DP), INTENT(inout) :: a(m) COMPLEX(kind=DP), INTENT(inout) :: b(m) REAL(kind=DP), INTENT(in) :: thres!threshold for convergence INTEGER, INTENT(in) :: n_max_iterations!maximum number of search iterations REAL(kind=DP), INTENT(out) :: chi!the final chi REAL(kind=DP), INTENT(in) :: dt!time step REAL(kind=DP), INTENT(in) :: frice!frice REAL(kind=DP) :: chi0, chi1, dtt INTEGER :: i,j,it COMPLEX(kind=DP) :: cc REAL(kind=DP), ALLOCATABLE :: omegas(:) REAL(kind=DP), ALLOCATABLE :: x0(:),x(:),v(:),f(:),ma(:),x1(:) INTEGER :: iflag INTEGER :: np np=2+4*m!number of parameters allocate(omegas(n)) allocate(x0(np),x(np),v(np),f(np),ma(np),x1(np)) omegas(1:n)=aimag(z(1:n)) !calculates initial chi chi0=0.d0 do i=1,n cc = func(z(i))-s(i) chi0=chi0+cc*conjg(cc) enddo write(stdout,*) 'Chi0 initial:', chi0 !set in variables x(1)=real(a_0) x(2)=aimag(a_0) do i=1,m x(i*2+1)=real(a(i)) x(i*2+2)=aimag(a(i)) x((i+m)*2+1)=real(b(i)) x((i+m)*2+2)=aimag(b(i)) enddo !set up fcn function paramters call fcn_set(n, m, omegas,s) !intial values ma(:)=1.d0 x0(:)=x(:) call fcn_point(n,np,x,chi1,f) write(stdout,*) 'VERLET2', chi1 x(:)=x0(:)+f(:)*dt/ma(:) v(:)=0.d0 chi0=chi1 dtt=dt do it=1,n_max_iterations call fcn_point(n,np,x,chi1,f) if(chi1 >= chi0) dtt=dtt/10.d0 chi0=chi1 if(mod(it,1000)==1) write(stdout,*) 'VERLET2', it, chi1 !x1(:)=2.d0*x(:)-x0(:)+f(:)*(dt**2.d0)/ma(:)-frice*v(:)*(dt**2.d0) x1(:)=x(:)+f(:)*dtt/ma(:) v(:)=(x1(:)-x0(:))/(2.d0*dt) x0(:)=x(:) x(:)=x1(:) enddo !set back parameters a_0=cmplx(x(1),x(2)) do i=1,m a(i)=cmplx(x(i*2+1),x(i*2+2)) enddo do i=1,m !b(i)=cmplx(x((i+m)*2+1),(-1.d0)*((x((i+m)*2+2))**2.d0)) b(i)=cmplx(x((i+m)*2+1),x((i+m)*2+2)) enddo chi=chi1 write(stdout,*) 'FINAL CHI', chi!ATTENZIONE deallocate(x,v,f,x0,ma,x1) return CONTAINS FUNCTION func(zz) COMPLEX(kind=DP) :: func COMPLEX(kind=DP) :: zz INTEGER :: ii func=a_0 do ii=1,m func=func+a(ii)/(zz-b(ii)) enddo return END FUNCTION func END SUBROUTINE fit_multipole_verlet2 SUBROUTINE fit_multipole_minpack(n,m,z,s,a_0,a,b,thres,n_max_iterations, chi) !fits with the function f(z)=a_0+\sum_{i=1,m} a_i/(z-b_i) !the values z_j,s_j USE kinds, ONLY : DP USE io_global, ONLY : stdout implicit none INTEGER, INTENT(in) :: n!numer of sampled values INTEGER, INTENT(in) :: m!number of parameters a COMPLEX(kind=DP), INTENT(in) :: z(n)!where COMPLEX(kind=DP), INTENT(in) :: s(n)!values s(z_j) to be fitted COMPLEX(kind=DP), INTENT(inout) :: a_0 COMPLEX(kind=DP), INTENT(inout) :: a(m) COMPLEX(kind=DP), INTENT(inout) :: b(m) REAL(kind=DP), INTENT(in) :: thres!threshold for convergence INTEGER, INTENT(in) :: n_max_iterations!maximum number of search iterations REAL(kind=DP), INTENT(out) :: chi!the final chi REAL(kind=DP) :: chi0, chi1 INTEGER :: i,j,it COMPLEX(kind=DP) :: cc REAL(kind=DP), ALLOCATABLE :: omegas(:) REAL(kind=DP), ALLOCATABLE :: variables(:) INTEGER :: iflag INTEGER :: info INTEGER :: lwa INTEGER :: np INTEGER, ALLOCATABLE :: iwa(:) INTEGER, ALLOCATABLE :: ipvt(:) REAL(kind=DP), ALLOCATABLE :: wa(:) REAL(kind=DP), ALLOCATABLE :: fvec(:),fjac(:,:) EXTERNAL fcn,fcn2,fcnj INTEGER :: ldfjac ldfjac=n allocate(omegas(n)) allocate(variables(2+4*m)) allocate(iwa(2+4*m)) lwa=n*(2+4*m)+5*(2+4*m)+n allocate(wa(lwa)) allocate(fvec(n)) np=2+4*m allocate(ipvt(np)) allocate(fjac(n,np)) write(stdout,*) 'Allocated' call flush_unit(stdout) omegas(1:n)=aimag(z(1:n)) !calculates initial chi chi0=0.d0 do i=1,n cc = func(z(i))-s(i) chi0=chi0+cc*conjg(cc) enddo ! write(*,*) 'a_0', a_0!ATTENZIONE ! write(*,*) 'a', a ! write(*,*) 'b', b ! write(*,*) 'z,s' , z(1),s(1),func(z(1)) ! write(*,*) 'z,s' , z(n),s(n),func(z(n)) write(stdout,*) 'Chi0 initial:', chi0 call flush_unit(stdout) !set in variables variables(1)=real(a_0) variables(2)=aimag(a_0) do i=1,m variables(i*2+1)=real(a(i)) variables(i*2+2)=aimag(a(i)) variables((i+m)*2+1)=real(b(i)) !variables((i+m)*2+2)=sqrt(abs(aimag(b(i)))) variables((i+m)*2+2)=aimag(b(i))!ATTENZIONE enddo !set up fcn function paramters call fcn_set(n, m, omegas,s) !call minpack driver routine !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! info=1 call fcn(n,np,variables,fvec,info) !write(*,*) 'FVEC', fvec(1:10) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !call lmdif1(fcn,n,np,n_max_iterations,variables,fvec,thres,info,iwa,wa,lwa) call lmder1(fcnj,n,np,variables,fvec,fjac,ldfjac,thres,info,ipvt,wa,lwa,n_max_iterations) write(stdout,*) ' INFO :', info,thres!ATTENZIONE !set back parameters a_0=dcmplx(variables(1),variables(2)) do i=1,m a(i)=dcmplx(variables(i*2+1),variables(i*2+2)) enddo do i=1,m !b(i)=dcmplx(variables((i+m)*2+1),(-1.d0)*((variables((i+m)*2+2))**2.d0)) b(i)=dcmplx(variables((i+m)*2+1),variables((i+m)*2+2)) enddo !recalculate chi and write result on stdout !calculates initial chi chi0=0.d0 do i=1,n cc = (func(z(i))-s(i)) chi0=chi0+cc*conjg(cc) enddo !write(stdout,*) 'a_0', a_0!ATTENZIONE !write(stdout,*) 'a', a !write(stdout,*) 'b', b !write(stdout,*) 'z,s' , z(1),s(1),func(z(1)) !write(stdout,*) 'z,s' , z(n),s(n),func(z(n)) write(stdout,*) 'Minpack fit chi0 :', chi0 chi=chi0 deallocate(omegas) deallocate(variables) deallocate(iwa) deallocate(wa) deallocate(fvec) deallocate(ipvt) deallocate(fjac) return CONTAINS FUNCTION func(zz) COMPLEX(kind=DP) :: func COMPLEX(kind=DP) :: zz INTEGER :: ii func=a_0 do ii=1,m func=func+a(ii)/(zz-b(ii)) enddo return END FUNCTION func END SUBROUTINE fit_multipole_minpack SUBROUTINE fcn2(m,n,x,fvec,iflag) !added internal parmeters to set up function !the parameters are in the order re(a_0),im(a_0),re(a_1)...re(a_n),im(a_1)..im(a_n),re(b_1)..re(b_n), im(b_1)..im(b_n) use kinds, ONLY : DP use io_global, ONLY : stdout implicit none INTEGER :: m !number of variables INTEGER :: n!total number of parameters REAL(kind=DP) :: x(n)!parameters REAL(kind=DP) :: fvec(m)!evaluated error function INTEGER :: iflag!not used fvec(1:m)=0.d0 END SUBROUTINE SUBROUTINE fcnj(m,n,x,fvec,fjac,ldfjac,iflag) !this version calculates also the jacobian !the parameters are in the order re(a_0),im(a_0),re(a_1)...re(a_n),im(a_1)..im(a_n),re(b_1)..re(b_n), im(b_1)..im(b_n) use kinds, ONLY : DP use io_global, ONLY : stdout use global_minpack implicit none INTEGER :: m !number of variables INTEGER :: n!total number of parameters REAL(kind=DP) :: x(n)!parameters REAL(kind=DP) :: fvec(m)!evaluated error function REAL(kind=DP) :: fjac(ldfjac,n) INTEGER :: ldfjac!leading dimension of fjac INTEGER :: iflag! =1 calculate fvec, =2 calculate fjac COMPLEX(kind=DP) a_0, a(maxpole), b(maxpole),g,h INTEGER i,j COMPLEX(kind=DP) :: func,zz if(m>maxm) then write(stdout,*) 'FCN: MAXN TOO SMALL' stop endif !set up parameters a_0=dcmplx(x(1),x(2)) do i=1,n_poles a(i)=dcmplx(x(i*2+1),x(i*2+2)) enddo do i=1,n_poles !b(i)=dcmplx(x((i+n_poles)*2+1),-(x((i+n_poles)*2+2))**2.d0) b(i)=dcmplx(x((i+n_poles)*2+1),x((i+n_poles)*2+2)) enddo if(iflag==1) then !perform calculaation do i=1,m fvec(i)=0.d0 func=a_0 zz=dcmplx(0.d0,freq(i)) do j=1,n_poles func=func+a(j)/(zz-b(j)) enddo func=func-c_target(i) fvec(i)=dble(func*conjg(func)) enddo else if(iflag==2) then do j=1,m fjac(j,:)=0.d0 !calculate g_j g=a_0 zz=cmplx(0.d0,freq(j)) do i=1,n_poles g=g+a(i)/(zz-b(i)) enddo g=g-c_target(j) !now term a_0 fjac(j,1)=2.d0*real(g) fjac(j,2)=2.d0*aimag(g) !now terms a_i do i=1, n_poles h=(1.d0,0.d0)/(zz-b(i)) fjac(j,i*2+1)=2.d0*real(h*conjg(g)) fjac(j,i*2+2)=-2.d0*aimag(h*conjg(g)) enddo !now terms b_i do i=1, n_poles h=a(i)/((zz-b(i))**2.d0) fjac(j,(i+n_poles)*2+1)=2.d0*real(h*conjg(g)) !fjac(j,(i+n_poles)*2+2)=-2.d0*aimag(h*conjg(g))*(-2.d0*x((i+n_poles)*2+2)) fjac(j,(i+n_poles)*2+2)=-2.d0*aimag(h*conjg(g)) enddo enddo endif return END SUBROUTINE fcnj SUBROUTINE fcn_point(m,n,x,value,nabla) !this version calculates also the jacobian !the parameters are in the order re(a_0),im(a_0),re(a_1)...re(a_n),im(a_1)..im(a_n),re(b_1)..re(b_n), im(b_1)..im(b_n) use kinds, ONLY : DP use io_global, ONLY : stdout use global_minpack implicit none INTEGER :: m !number of variables INTEGER :: n!total number of parameters REAL(kind=DP) :: x(n)!parameters REAL(kind=DP) :: value!total error REAL(kind=DP) :: nabla(n)!derivatives of total error respect to parameters COMPLEX(kind=DP) a_0, a(maxpole), b(maxpole),g,h INTEGER i,j COMPLEX(kind=DP) :: func,zz if(m>maxm) then write(stdout,*) 'FCN: MAXN TOO SMALL' stop endif !set up parameters a_0=cmplx(x(1),x(2)) do i=1,n_poles a(i)=cmplx(x(i*2+1),x(i*2+2)) enddo do i=1,n_poles ! b(i)=cmplx(x((i+n_poles)*2+1),-(x((i+n_poles)*2+2))**2.d0) b(i)=cmplx(x((i+n_poles)*2+1),x((i+n_poles)*2+2)) enddo !perform calculation of value value=0.d0 do i=1,m func=a_0 zz=cmplx(0.d0,freq(i)) do j=1,n_poles func=func+a(j)/(zz-b(j)) enddo func=func-c_target(i) value=value + dble(func*conjg(func)) enddo nabla(:)=0.d0 do j=1,m !calculate g_j g=a_0 zz=cmplx(0.d0,freq(j)) do i=1,n_poles g=g+a(i)/(zz-b(i)) enddo g=g-c_target(j) !now term a_0 nabla(1)=nabla(1)+2.d0*real(g) nabla(2)=nabla(2)+2.d0*aimag(g) !now terms a_i do i=1, n_poles h=(1.d0,0.d0)/(zz-b(i)) nabla(i*2+1)=nabla(i*2+1)+2.d0*real(h*conjg(g)) nabla(i*2+2)=nabla(i*2+1)-2.d0*aimag(h*conjg(g)) enddo !now terms b_i do i=1, n_poles h=a(i)/((zz-b(i))**2.d0) nabla((i+n_poles)*2+1)=nabla((i+n_poles)*2+1)+2.d0*real(h*conjg(g)) nabla((i+n_poles)*2+2)=nabla((i+n_poles)*2+2)-2.d0*aimag(h*conjg(g)) enddo enddo nabla(:)=-nabla(:) return END SUBROUTINE fcn_point GWW/gww/energies_gww.f900000644000077300007730000003346112341332532015630 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! MODULE energies_gww !this module contains descriptions and subroutine for final quasi particle energy ! calculations USE kinds, ONLY : DP TYPE quasi_particles !energies relative to quasi particles INTEGER :: max_i !number of states considered INTEGER :: nspin!spin multiplicity LOGICAL :: whole_s!if true consider also off diagonal elements REAL(kind=DP), POINTER, DIMENSION(:,:) :: ene_dft_ks!kohn sham eigenvalues REAL(kind=DP), POINTER, DIMENSION(:,:) :: ene_dft_xc!dft/lda values for exchange and correlation REAL(kind=DP), POINTER, DIMENSION(:,:) :: ene_dft_h!dft/lda values for hartree COMPLEX(kind=DP), POINTER, DIMENSION(:,:) :: ene_x!effective exchange part COMPLEX(kind=DP), POINTER, DIMENSION(:,:) :: ene_h!effective hartree part COMPLEX(kind=DP), POINTER, DIMENSION(:,:) :: ene_gw!quasi particle GW eigenenergies COMPLEX(kind=DP), POINTER, DIMENSION(:,:) :: ene_gw_pert!perturbative quasi particle GW eigenenergies REAL(kind=DP), POINTER, DIMENSION(:,:) :: ene_hf!perturbative hf energies REAL(kind=DP), POINTER, DIMENSION(:,:) :: ene_remainder!for storing remainders COMPLEX(kind=DP), POINTER, DIMENSION(:,:) :: ene_gw_off!quasi-particle energies considering the whole Self-energy COMPLEX(kind=DP), POINTER, DIMENSION(:,:,:) :: eigen_gw_off!quasi-particle amplitudes considering the whole Self-energy REAL(kind=DP), POINTER, DIMENSION(:,:,:) :: ene_dft_xc_off!off diagonal elements of KS potential REAL(kind=DP), POINTER, DIMENSION(:,:,:) :: ene_x_off!off diagonal elements of Fock potential END TYPE quasi_particles CONTAINS SUBROUTINE write_quasi_particles( qp, options,l_remainder) !this subroutine write quasi-particles on disk !ATTENZIONE HF energies not implemented YET USE io_global, ONLY : stdout, ionode USE input_gw, ONLY : input_options USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(quasi_particles) :: qp!object to be written TYPE(input_options) :: options!for i/o purposes LOGICAL :: l_remainder!if true write also the remainder part INTEGER iun INTEGER i,j,is if(ionode) then iun = find_free_unit() if(.not. options%debug) then open(unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'quasi_particles', status='unknown',form='unformatted') else open(unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'quasi_particles', status='unknown',form='formatted') endif if(.not. options%debug) then write(iun) qp%max_i write(iun) qp%nspin write(iun) qp%whole_s do is=1,qp%nspin write(iun) qp%ene_dft_ks(1:qp%max_i,is) write(iun) qp%ene_dft_xc(1:qp%max_i,is) write(iun) qp%ene_dft_h(1:qp%max_i,is) write(iun) qp%ene_x(1:qp%max_i,is) write(iun) qp%ene_h(1:qp%max_i,is) write(iun) qp%ene_gw(1:qp%max_i,is) write(iun) qp%ene_gw_pert(1:qp%max_i,is) write(iun) qp%ene_hf(1:qp%max_i,is) if(l_remainder) write(iun) qp%ene_remainder(1:qp%max_i,is) enddo else write(iun,*) qp%max_i write(iun,*) qp%nspin write(iun,*) qp%whole_s do is=1,qp%nspin do i=1,qp%max_i write(iun,*) qp%ene_dft_ks(i,is) write(iun,*) qp%ene_dft_xc(i,is) write(iun,*) qp%ene_dft_h(i,is) write(iun,*) qp%ene_x(i,is) write(iun,*) qp%ene_h(i,is) write(iun,*) qp%ene_gw(i,is) write(iun,*) qp%ene_gw_pert(i,is) write(iun,*) qp%ene_hf(i,is) if(l_remainder)write(iun,*) qp%ene_remainder(i,is) enddo enddo endif close(iun) endif return END SUBROUTINE write_quasi_particles SUBROUTINE read_quasi_particles( qp, options, l_remainder) !this subroutine write quasi-particles on disk !HF energies not implemented YET USE io_global, ONLY : stdout, ionode, ionode_id USE input_gw, ONLY : input_options USE io_files, ONLY : prefix,tmp_dir USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(quasi_particles) :: qp!object to be read TYPE(input_options) :: options!for i/o purposes LOGICAL :: l_remainder !if true read also remainder part REAL(kind=DP), ALLOCATABLE :: energies_x(:,:) INTEGER iun INTEGER i,j,is if(ionode) then iun = find_free_unit() if(.not. options%debug) then open(unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'quasi_particles', status='old',form='unformatted') else open(unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'quasi_particles', status='old',form='formatted') endif if(.not. options%debug) then read(iun) qp%max_i read(iun) qp%nspin read(iun) qp%whole_s else read(iun,*) qp%max_i read(iun,*) qp%nspin read(iun,*) qp%whole_s endif endif call mp_bcast(qp%max_i, ionode_id,world_comm) call mp_bcast(qp%nspin, ionode_id,world_comm) call mp_bcast(qp%whole_s, ionode_id,world_comm) allocate(qp%ene_dft_ks(qp%max_i,qp%nspin)) allocate(qp%ene_dft_xc(qp%max_i,qp%nspin)) allocate(qp%ene_dft_h(qp%max_i,qp%nspin)) allocate(qp%ene_x(qp%max_i,qp%nspin)) allocate(qp%ene_h(qp%max_i,qp%nspin)) allocate(qp%ene_gw(qp%max_i,qp%nspin)) allocate(qp%ene_gw_pert(qp%max_i,qp%nspin)) allocate(qp%ene_hf(qp%max_i,qp%nspin)) if(l_remainder) then allocate(qp%ene_remainder(qp%max_i,qp%nspin)) else nullify(qp%ene_remainder) endif if(ionode) then do is=1,qp%nspin if(.not.options%debug) then read(iun) qp%ene_dft_ks(1:qp%max_i,is) read(iun) qp%ene_dft_xc(1:qp%max_i,is) read(iun) qp%ene_dft_h(1:qp%max_i,is) read(iun) qp%ene_x(1:qp%max_i,is) read(iun) qp%ene_h(1:qp%max_i,is) read(iun) qp%ene_gw(1:qp%max_i,is) read(iun) qp%ene_gw_pert(1:qp%max_i,is) read(iun) qp%ene_hf(1:qp%max_i,is) if(l_remainder) read(iun) qp%ene_remainder(1:qp%max_i,is) else do i=1,qp%max_i read(iun,*) qp%ene_dft_ks(i,is) read(iun,*) qp%ene_dft_xc(i,is) read(iun,*) qp%ene_dft_h(i,is) read(iun,*) qp%ene_x(i,is) read(iun,*) qp%ene_h(i,is) read(iun,*) qp%ene_gw(i,is) read(iun,*) qp%ene_gw_pert(i,is) read(iun,*) qp%ene_hf(i,is) if(l_remainder) read(iun,*) qp%ene_remainder(i,is) enddo endif enddo close(iun) endif call mp_bcast(qp%ene_dft_ks(:,:),ionode_id,world_comm) call mp_bcast(qp%ene_dft_xc(:,:),ionode_id,world_comm) call mp_bcast(qp%ene_dft_h(:,:),ionode_id,world_comm) call mp_bcast(qp%ene_x(:,:),ionode_id,world_comm) call mp_bcast(qp%ene_h(:,:),ionode_id,world_comm) call mp_bcast(qp%ene_gw(:,:),ionode_id,world_comm) call mp_bcast(qp%ene_gw_pert(:,:),ionode_id,world_comm) call mp_bcast(qp%ene_hf(:,:),ionode_id,world_comm) if(l_remainder) call mp_bcast(qp%ene_remainder(:,:),ionode_id,world_comm) !if required re-read exchange energies if(options%l_read_exchange) then allocate(energies_x(qp%max_i,qp%nspin)) call read_data_pw_exchange(energies_x,qp%max_i,options%prefix,qp%nspin) qp%ene_hf(1:qp%max_i,1:qp%nspin)=qp%ene_hf(1:qp%max_i,1:qp%nspin)-qp%ene_x(1:qp%max_i,1:qp%nspin)& &+energies_x(1:qp%max_i,1:qp%nspin) qp%ene_gw(1:qp%max_i,1:qp%nspin)=qp%ene_gw(1:qp%max_i,1:qp%nspin)-qp%ene_x(1:qp%max_i,1:qp%nspin)& &+energies_x(1:qp%max_i,1:qp%nspin) qp%ene_gw_pert(1:qp%max_i,1:qp%nspin)=qp%ene_gw_pert(1:qp%max_i,1:qp%nspin)& &-qp%ene_x(1:qp%max_i,1:qp%nspin)+energies_x(1:qp%max_i,1:qp%nspin) qp%ene_x(1:qp%max_i,1:qp%nspin)=cmplx(energies_x(1:qp%max_i,1:qp%nspin),0.d0) deallocate(energies_x) endif !if required re-read XC LDA energies if(options%l_dft_xc_file) then call read_data_pw_dft_xc(qp%ene_dft_xc(:,1),qp%max_i,options%prefix) endif return END SUBROUTINE read_quasi_particles SUBROUTINE initialize_quasi_particle(qp) !this subroutine nullify all arrays implicit none TYPE(quasi_particles) :: qp nullify(qp%ene_dft_ks) nullify(qp%ene_dft_xc) nullify(qp%ene_dft_h) nullify(qp%ene_x) nullify(qp%ene_h) nullify(qp%ene_gw) nullify(qp%ene_gw_pert) nullify(qp%ene_hf) nullify(qp%ene_remainder) nullify(qp%ene_gw_off) nullify(qp%eigen_gw_off) nullify(qp%ene_dft_xc_off) nullify(qp%ene_x_off) return END SUBROUTINE initialize_quasi_particle SUBROUTINE free_memory_quasi_particles(qp) !deallocates if allocated implicit none TYPE(quasi_particles) :: qp if(associated(qp%ene_dft_ks)) then deallocate(qp%ene_dft_ks) nullify(qp%ene_dft_ks) endif if(associated(qp%ene_dft_xc)) then deallocate(qp%ene_dft_xc) nullify(qp%ene_dft_xc) endif if(associated(qp%ene_dft_h)) then deallocate(qp%ene_dft_h) nullify(qp%ene_dft_h) endif if(associated(qp%ene_x)) then deallocate(qp%ene_x) nullify(qp%ene_x) endif if(associated(qp%ene_h)) then deallocate(qp%ene_h) nullify(qp%ene_h) endif if(associated(qp%ene_gw)) then deallocate(qp%ene_gw) nullify(qp%ene_gw) endif if(associated(qp%ene_gw_pert)) then deallocate(qp%ene_gw_pert) nullify(qp%ene_gw_pert) endif if(associated(qp%ene_hf)) then deallocate(qp%ene_hf) nullify(qp%ene_hf) endif if(associated(qp%ene_remainder)) then deallocate(qp%ene_remainder) nullify(qp%ene_remainder) endif if(associated(qp%ene_gw_off)) then deallocate(qp%ene_gw_off) nullify(qp%ene_gw_off) endif if(associated(qp%eigen_gw_off)) then deallocate(qp%eigen_gw_off) nullify(qp%eigen_gw_off) endif if(associated(qp%ene_dft_xc_off)) then deallocate(qp%ene_dft_xc_off) nullify(qp%ene_dft_xc_off) endif if(associated(qp%ene_x_off)) then deallocate(qp%ene_x_off) nullify(qp%ene_x_off) endif return END SUBROUTINE free_memory_quasi_particles SUBROUTINE printout_quasi_particles(qp) !this subroutine prints out the lda and gw energies USE io_global, ONLY : stdout, ionode USE constants, ONLY : RYTOEV USE mp, ONLY : mp_barrier USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(quasi_particles) :: qp INTEGER :: ii,iun,is if(ionode) then do is=1,qp%nspin write(stdout,*) 'QUASI-PARTICLES ENERGIES IN Ev, Spin:', is, qp%nspin do ii=1,qp%max_i write(stdout,'(''State:'',i5,''DFT :'',f10.5,'' GW-PERT :'',f10.5,'' GW :'',f10.5, '' HF-pert :'',f10.5)') & & ii,qp%ene_dft_ks(ii,is)*RYTOEV, real(qp%ene_gw_pert(ii,is))*RYTOEV, & & real(qp%ene_gw(ii,is))*RYTOEV,qp%ene_hf(ii,is)*RYTOEV enddo write(stdout,*) 'IMAGINARY ENERGIES IN Ev:' do ii=1,qp%max_i write(stdout,'(''State:'',i5,'' GW (Im) :'',f10.5)') ii,aimag(qp%ene_gw(ii,is))*RYTOEV enddo enddo !write bands.dat file iun = find_free_unit() open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'bands.dat', status='unknown',form='formatted') write(iun,'(i8)') qp%max_i write(iun,'(i8)') qp%nspin do is=1,qp%nspin do ii=1,qp%max_i write(iun,'(i5,4f10.5)') ii,qp%ene_dft_ks(ii,is)*RYTOEV, real(qp%ene_gw_pert(ii,is))*RYTOEV, & & real(qp%ene_gw(ii,is))*RYTOEV,qp%ene_hf(ii,is)*RYTOEV enddo enddo close(iun) endif return END SUBROUTINE SUBROUTINE printout_quasi_particles_off(qp) !this subroutine prints out the lda and gw energies !where the whole self energy matrix has been considered USE io_global, ONLY : stdout, ionode USE constants, ONLY : RYTOEV USE mp, ONLY : mp_barrier implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(quasi_particles) :: qp INTEGER :: ii,iun,is if(ionode) then if(qp%whole_s) then write(stdout,*) 'RESULTS FROM WHOLE SE MATRIX:' do is=1,qp%nspin write(stdout,*) 'QUASI-PARTICLES ENERGIES IN Ev, Spin:', is, qp%nspin do ii=1,qp%max_i write(stdout,'(''State:'',i5,''DFT :'',f10.5,'' GW :'',f10.5, '' HF-pert :'',f10.5)') & & ii,qp%ene_dft_ks(ii,is)*RYTOEV, & & real(qp%ene_gw_off(ii,is))*RYTOEV,qp%ene_hf(ii,is)*RYTOEV enddo write(stdout,*) 'IMAGINARY ENERGIES IN Ev:' do ii=1,qp%max_i write(stdout,'(''State:'',i5,'' GW (Im) :'',f10.5)') ii,aimag(qp%ene_gw_off(ii,is))*RYTOEV enddo enddo else write(stdout,*) 'OFF DIAGONAL ELEMENTS OF SE NOT AVAILABLE' endif endif return END SUBROUTINE printout_quasi_particles_off END MODULE energies_gww GWW/gww/times_gw.f900000644000077300007730000006176612341332532014772 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !this module contains date which defines grids in time and in frequency MODULE times_gw USE kinds, only : DP TYPE times_freqs INTEGER :: grid_time!0=Gauss Legendre 1=Gauss Laguerre INTEGER :: grid_freq!0=Gauss Legendre 1=Gauss Laguerre INTEGER :: n!number of grid points (total of 2n+1 ) REAL(kind=DP) :: tau!max time REAL(kind=DP) :: omega!max frequency REAL(kind=DP), POINTER :: times(:)!time grid REAL(kind=DP), POINTER :: weights_time(:)!weights on time REAL(kind=DP), POINTER :: freqs(:)!frequency grid REAL(kind=DP), POINTER :: weights_freq(:)!weights on frequency LOGICAL :: l_fft_timefreq!if true uses fft old-style and not grids LOGICAL :: l_fourier_fit_time!if true fits the tails in time LOGICAL :: l_fourier_fit_freq!if true fits the tails in freq REAL(kind=DP) :: r_tau!ratio for finding outer time point REAL(kind=DP) :: r_omega!ratio for finding outer frequency point REAL(kind=DP) :: g_tau!ratio for treating bad cases in time REAL(kind=DP) :: g_omega!ration for treating bad cases in frequency INTEGER :: grid_fit!grid for self energy ON FREQUENCY: uses the same as for P,W, 1 equally spaced, 2 GL REAL(kind=DP) :: omega_fit!max frequency to be considered INTEGER :: n_grid_fit!number of grid points on half-axes REAL(kind=DP), POINTER :: freqs_fit(:)!frequency grid fot fit INTEGER, POINTER :: whois_freq(:)!correspondence for multipoint integration REAL (kind=DP), POINTER :: relative_weight(:)!relative weight for multipoint integration !options for grid_freq=5 INTEGER :: second_grid_n=10!sub spacing for second grid INTEGER :: second_grid_i=1!max regular step using the second grid !variable for second frequency grid (for G) LOGICAL :: l_g_grid!if true use a dedicated grid on frequency for G REAL(kind=DP) :: omega_g! for G: max frequency INTEGER :: n_g!for G grid REAL(kind=DP), POINTER :: freqs_g(:)!frequency grid REAL(kind=DP), POINTER :: weights_freq_g(:)!weights on frequency REAL (kind=DP), POINTER :: relative_weight_g(:)!relative weight for multipoint integration INTEGER :: grid_freq_g!for G grid INTEGER :: second_grid_n_g!for G grid INTEGER :: second_grid_i_g!for G grid INTEGER, POINTER :: whois_freq_g(:)! for G grid REAL(kind=DP), POINTER :: freqs_eff(:)!effective frequency grid REAL(kind=DP), POINTER :: freqs_g_eff(:)!effective frequency grid for G INTEGER :: grid_levels!for grids of type 4 END TYPE times_freqs CONTAINS SUBROUTINE free_memory_times_freqs( tf) implicit none TYPE(times_freqs) :: tf if(associated(tf%times)) deallocate(tf%times) if(associated(tf%weights_time)) deallocate(tf%weights_time) if(associated(tf%freqs)) deallocate(tf%freqs) if(associated(tf%weights_freq)) deallocate(tf%weights_freq) if(associated(tf%freqs_fit)) deallocate(tf%freqs_fit) if(associated(tf%whois_freq)) deallocate(tf%whois_freq) if(associated(tf%relative_weight)) deallocate(tf%relative_weight) if(associated(tf%freqs_g)) deallocate(tf%freqs_g) if(associated(tf%relative_weight_g)) deallocate(tf%relative_weight_g) if(associated(tf%weights_freq_g)) deallocate(tf%weights_freq_g) if(associated(tf%freqs_eff)) deallocate(tf%freqs_eff) if(associated(tf%freqs_g_eff)) deallocate(tf%freqs_g_eff) return END SUBROUTINE free_memory_times_freqs SUBROUTINE setup_timefreq(tf,options) !sets up and allocates arrays for grids in time and frequency USE input_gw, ONLY : input_options USE io_global, ONLY : stdout USE constants, ONLY : pi implicit none TYPE(input_options) :: options TYPE(times_freqs) :: tf REAL(kind=DP), ALLOCATABLE :: x(:),w(:) INTEGER :: i,j,k,l,ii,nn REAL(kind=DP) :: delta tf%n = options%n tf%grid_time=options%grid_time tf%grid_freq=options%grid_freq tf%tau=options%tau tf%omega=options%omega tf%l_fft_timefreq=options%l_fft_timefreq !fit options available only for Gauss-Legendre grid tf%l_fourier_fit_time=options%l_fourier_fit_time tf%l_fourier_fit_freq=options%l_fourier_fit_freq tf%r_tau=options%r_tau tf%r_omega=options%r_omega tf%g_tau=options%g_tau tf%g_omega=options%g_omega !options for grid_freq=5 tf%second_grid_n=options%second_grid_n tf%second_grid_i=options%second_grid_i !options for grid_freq=6 tf%grid_levels=options%grid_levels write(stdout,*) 'DB1',tf%n ! allocate(tf%times(-tf%n:tf%n),tf%weights_time(-tf%n:tf%n)) write(stdout,*) 'DB2' if(tf%grid_freq/=5.and.tf%grid_freq/=6) then allocate(tf%freqs(-tf%n:tf%n),tf%weights_freq(-tf%n:tf%n),tf%freqs_eff(-tf%n:tf%n)) nullify(tf%whois_freq) !nullify(tf%relative_weight) allocate(tf%relative_weight(-nn:nn)) else if (tf%grid_freq==5) then nn=tf%n+tf%second_grid_n*(1+tf%second_grid_i*2) allocate(tf%freqs(-nn:nn),tf%weights_freq(-nn:nn)) allocate(tf%whois_freq(-nn:nn)) allocate(tf%relative_weight(-nn:nn)) allocate(tf%freqs_eff(-nn:nn)) else!grid of type 6 if(tf%second_grid_i/=0)then nn=tf%n-tf%second_grid_i+(tf%second_grid_i*tf%second_grid_n-tf%second_grid_i)*tf%grid_levels+tf%second_grid_i else nn=tf%n endif allocate(tf%freqs(-nn:nn),tf%weights_freq(-nn:nn)) allocate(tf%whois_freq(-nn:nn)) allocate(tf%relative_weight(-nn:nn)) allocate(tf%freqs_eff(-nn:nn)) endif write(stdout,*) 'DB3' allocate(x(2*tf%n+1),w(2*tf%n+1)) x(:)=0.d0 w(:)=0.d0 !frequency grid if(tf%grid_freq==0) then!Gauss Legendre if(.not.tf%l_fourier_fit_freq) then call legzo(tf%n*2+1,x,w) tf%freqs(-tf%n:tf%n)=-x(1:2*tf%n+1)*tf%omega tf%weights_freq(-tf%n:tf%n)=w(1:2*tf%n+1)*tf%omega else call legzo(tf%n*2-1,x,w) tf%freqs(-tf%n+1:tf%n-1)=-x(1:2*tf%n-1)*tf%omega tf%weights_freq(-tf%n+1:tf%n-1)=w(1:2*tf%n-1)*tf%omega tf%freqs(-tf%n)=-tf%r_omega*tf%omega tf%freqs(tf%n)=tf%r_omega*tf%omega tf%weights_freq(-tf%n)=0.d0 tf%weights_freq(tf%n) =0.d0 endif tf%freqs_eff(-tf%n:tf%n)=tf%freqs(-tf%n:tf%n) else if(tf%grid_freq==1) then!Gaus Laguerre call lagzo(tf%n,x,w) tf%freqs(1:tf%n)=x(1:tf%n) do i=1,tf%n tf%freqs(-i)=-tf%freqs(i) enddo tf%freqs(0)=0.d0 tf%weights_freq(1:tf%n)=w(1:tf%n)*exp(x(1:tf%n)) do i=1,tf%n tf%weights_freq(-i)=tf%weights_freq(i) enddo tf%weights_freq(0)=0.d0 tf%freqs_eff(-tf%n:tf%n)=tf%freqs(-tf%n:tf%n) else if(tf%grid_freq==2) then call legzo(tf%n,x,w) tf%freqs(0)=0.d0 tf%freqs(1:tf%n)=(1.d0-x(1:tf%n))*tf%omega/2.d0 tf%freqs(-tf%n:-1)=(-1.d0-x(1:tf%n))*tf%omega/2.d0 tf%weights_freq(0)=0.d0 tf%weights_freq(1:tf%n)=w(1:tf%n)*tf%omega/2.d0 tf%weights_freq(-tf%n:-1)=w(1:tf%n)*tf%omega/2.d0 tf%freqs_eff(-tf%n:tf%n)=tf%freqs(-tf%n:tf%n) else if (tf%grid_freq==3) then do i=0,tf%n tf%freqs(i)=(tf%omega/dble(tf%n))*dble(i) tf%freqs(-i)=-tf%freqs(i) enddo tf%weights_freq(:)=tf%omega/dble(tf%n) tf%weights_freq(0)=tf%omega/dble(tf%n)/2.d0 tf%freqs_eff(-tf%n:tf%n)=tf%freqs(-tf%n:tf%n) else if(tf%grid_freq==4) then do i=1,tf%n tf%freqs(i)=(tf%omega/dble(tf%n))*dble(i)-(0.5d0*tf%omega/dble(tf%n)) tf%freqs(-i)=-tf%freqs(i) enddo tf%freqs(0)=0.d0 tf%weights_freq(:)=(tf%omega/dble(tf%n)) tf%weights_freq(0)=0.d0 tf%freqs_eff(-tf%n:tf%n)=tf%freqs(-tf%n:tf%n) else if(tf%grid_freq==5) then tf%freqs(0)=0.d0 tf%relative_weight(0)=0.d0 tf%whois_freq(0)=0 ii=1 do i=1,tf%second_grid_n tf%freqs(ii)=(tf%omega/dble(2*tf%second_grid_n*tf%n))*dble(i)-0.5d0*tf%omega/dble(2*tf%second_grid_n*tf%n) tf%relative_weight(ii)=1.d0/dble(2*tf%second_grid_n) tf%whois_freq(ii)=0 tf%freqs_eff(ii)=0.d0 ii=ii+1 enddo do j=1,tf%second_grid_i do i=1,tf%second_grid_n tf%freqs(ii)=(tf%omega/dble(2*tf%second_grid_n*tf%n))*& &dble(i+tf%second_grid_n+2*tf%second_grid_n*(j-1))-0.5d0*tf%omega/dble(2*tf%second_grid_n*tf%n) tf%relative_weight(ii)=1.d0/dble(2*tf%second_grid_n) tf%whois_freq(ii)=j tf%freqs_eff(ii)=tf%omega/dble(tf%n)*dble(j) ii=ii+1 enddo tf%freqs(ii)=tf%omega/dble(tf%n)*dble(j) tf%relative_weight(ii)=0.d0 tf%whois_freq(ii)=j tf%freqs_eff(ii)=tf%omega/dble(tf%n)*dble(j) ii=ii+1 do i=1,tf%second_grid_n tf%freqs(ii)=(tf%omega/dble(2*tf%second_grid_n*tf%n))*dble(i+2*tf%second_grid_n*j)-& &0.5d0*tf%omega/dble(2*tf%second_grid_n*tf%n) tf%relative_weight(ii)=1.d0/dble(2*tf%second_grid_n) tf%whois_freq(ii)=j tf%freqs_eff(ii)=tf%omega/dble(tf%n)*dble(j) ii=ii+1 enddo enddo do i=tf%second_grid_i+1,tf%n tf%freqs(ii)=tf%omega/dble(tf%n)*dble(i) tf%relative_weight(ii)=1.d0 tf%whois_freq(ii)=i tf%freqs_eff(ii)=tf%omega/dble(tf%n)*dble(i) ii=ii+1 enddo ii=ii-1 if(ii/=nn) then write(stdout,*) 'ERROR ',nn,ii stop endif do i=1,ii tf%freqs(-i)=-tf%freqs(i) tf%relative_weight(-i)=tf%relative_weight(i) tf%whois_freq(-i)=-tf%whois_freq(i) tf%freqs_eff(-i)=-tf%freqs_eff(i) enddo if(.not.options%l_self_time) then tf%weights_freq(:)=tf%omega/dble(tf%n) else tf%weights_freq(0)=0.d0 ii=1 do i=1,tf%second_grid_n tf%weights_freq(ii)=tf%omega/dble(tf%n)/dble(2*tf%second_grid_n) ii=ii+1 enddo do j=1,tf%second_grid_i do i=1,tf%second_grid_n tf%weights_freq(ii)=tf%omega/dble(tf%n)/dble(2*tf%second_grid_n) ii=ii+1 enddo tf%weights_freq(ii)=0.d0 ii=ii+1 do i=1,tf%second_grid_n tf%weights_freq(ii)=tf%omega/dble(tf%n)/dble(2*tf%second_grid_n) ii=ii+1 enddo enddo do i=tf%second_grid_i+1,tf%n tf%weights_freq(ii)=tf%omega/dble(tf%n) ii=ii+1 enddo do i=1,nn tf%weights_freq(-i)=tf%weights_freq(i) tf%freqs(-i)=-tf%freqs(i) enddo endif else if(tf%grid_freq==6) then tf%freqs(0)=0.d0 tf%weights_freq(0)=0.d0 tf%relative_weight(0)=0.d0 tf%whois_freq(0)=0 ii=1 do l=1,tf%grid_levels if(l==1) then k=1 else k=tf%second_grid_i+1 endif do j=k,tf%second_grid_n*tf%second_grid_i delta=(tf%omega/dble(tf%n))/(dble(tf%second_grid_n)**(tf%grid_levels-l+1)) tf%freqs(ii)=delta*dble(j)-delta/2.d0 tf%weights_freq(ii)=delta ii=ii+1 enddo enddo delta=(tf%omega/dble(tf%n)) if(tf%grid_levels==0) then j=1 else j=tf%second_grid_i+1 endif do i=j,tf%n tf%freqs(ii)=delta*dble(i)-delta/2.d0 tf%weights_freq(ii)=delta ii=ii+1 enddo ii=ii-1 if(ii/=nn) then write(stdout,*) 'ERROR ',nn,ii stop endif do i=1,nn tf%weights_freq(-i)=tf%weights_freq(i) tf%freqs(-i)=-tf%freqs(i) enddo tf%freqs_eff(-nn:nn)=tf%freqs(-nn:nn) else if(tf%grid_freq==7) then do i=1,tf%n tf%freqs(i)=tf%omega*tan(pi/2.d0/dble(tf%n+1)*dble(i-1)+pi/4.d0/dble(tf%n+1)) tf%weights_freq(i)=tf%omega*tan(pi/2.d0/dble(tf%n+1)*dble(i))-tf%omega*tan(pi/2.d0/dble(tf%n+1)*dble(i-1)) tf%freqs(-i)=-tf%freqs(i) tf%weights_freq(-i)=tf%weights_freq(i) enddo tf%freqs(0)=0.d0 tf%weights_freq(0)=0.d0 tf%freqs_eff(-tf%n:tf%n)=tf%freqs(-tf%n:tf%n) endif deallocate(x,w) !setup frequency grid for fit if(.not.(options%l_self_lanczos .and. options%l_lanczos_conv.and. .not.options%l_self_time)) then tf%grid_fit=options%grid_fit tf%omega_fit=options%omega_fit tf%n_grid_fit=options%n_grid_fit else tf%grid_fit=1 tf%omega_fit=tf%omega tf%n_grid_fit=tf%n endif if(tf%grid_fit==0) then tf%omega_fit=tf%omega tf%n_grid_fit=tf%n endif allocate(tf%freqs_fit(-tf%n_grid_fit:tf%n_grid_fit)) if(tf%grid_fit==0) then tf%freqs_fit(:)=tf%freqs(:) else if(tf%grid_fit==1) then do i=-tf%n_grid_fit,tf%n_grid_fit tf%freqs_fit(i)=(tf%omega_fit/dble(tf%n_grid_fit))*dble(i) enddo else if(tf%grid_fit==2) then allocate(x(2*tf%n_grid_fit+1),w(2*tf%n_grid_fit+1)) x(:)=0.d0 w(:)=0.d0 write(stdout,*) 'CALL LEGZO', tf%n_grid_fit*2+1 call legzo(tf%n_grid_fit*2+1,x,w) write(stdout,*) 'CALLED LEGZO' tf%freqs_fit(-tf%n_grid_fit:tf%n_grid_fit)=-x(1:2*tf%n_grid_fit+1)*tf%omega_fit deallocate(x,w) endif !IN CASE 5 REDEFINE THE TOTAL NUMBER OF FREQUENCIES: if(tf%grid_freq==5.or.tf%grid_freq==6) then tf%n=nn options%n=nn endif !time grid allocate(x(2*tf%n+1),w(2*tf%n+1)) x(:)=0.d0 w(:)=0.d0 allocate(tf%times(-tf%n:tf%n),tf%weights_time(-tf%n:tf%n)) if(tf%grid_time==0) then!Gauss Legendre if(.not.tf%l_fourier_fit_time) then call legzo(tf%n*2+1,x,w) tf%times(-tf%n:tf%n)=-x(1:2*tf%n+1)*tf%tau tf%weights_time(-tf%n:tf%n)=w(1:2*tf%n+1)*tf%tau else call legzo(tf%n*2+1-2,x,w) tf%times(-tf%n+1:tf%n-1)=-x(1:2*tf%n-1)*tf%tau tf%weights_time(-tf%n+1:tf%n-1)=w(1:2*tf%n-1)*tf%tau tf%times(-tf%n)=-tf%r_tau*tf%tau tf%times(tf%n)=tf%r_tau*tf%tau tf%weights_time(-tf%n)=0.d0 tf%weights_time(tf%n)=0.d0 endif do i=-tf%n,tf%n write(stdout,*) 'TIME:',i, tf%times(i),tf%weights_time(i) enddo else if(tf%grid_time==1) then!Gaus Laguerre call lagzo(tf%n,x,w) tf%times(1:tf%n)=x(1:tf%n) do i=1,tf%n tf%times(-i)=-tf%times(i) enddo tf%times(0)=0.d0 tf%weights_time(1:tf%n)=w(1:tf%n)*exp(x(1:tf%n)) do i=1,tf%n tf%weights_time(-i)=tf%weights_time(i) enddo tf%weights_time(0)=0.d0 else if(tf%grid_time==2) then call legzo(tf%n,x,w) tf%times(0)=0.d0 tf%times(1:tf%n)=(1.d0-x(1:tf%n))*tf%tau/2.d0 tf%times(-tf%n:-1)=(-1.d0-x(1:tf%n))*tf%tau/2.d0 tf%weights_time(0)=0.d0 tf%weights_time(1:tf%n)=w(1:tf%n)*tf%tau/2.d0 tf%weights_time(-tf%n:-1)=w(1:tf%n)*tf%tau/2.d0 else if(tf%grid_time==3) then do i=0,tf%n tf%times(i)=(tf%tau/dble(tf%n))*dble(i) tf%times(-i)=-tf%times(i) enddo tf%weights_time(:)=tf%tau/dble(tf%n) else if(tf%grid_time==4) then do i=1,tf%n tf%times(i)=tf%tau/dble(tf%n)*dble(i)-(0.5d0*tf%tau/dble(tf%n)) tf%times(-i)=-tf%times(i) enddo tf%times(0)=0.d0 tf%weights_time(:)=(tf%tau/dble(tf%n)) tf%weights_time(0)=0.d0 endif deallocate(x,w) !options for G grid tf%l_g_grid=options%l_g_grid if(tf%l_g_grid) then tf%n_g=options%n_g tf%grid_freq_g=options%grid_freq_g tf%second_grid_n_g=options%second_grid_n_g tf%second_grid_i_g=options%second_grid_i_g tf%omega_g=options%omega_g if(tf%grid_freq_g/=5) then allocate(tf%freqs_g(-tf%n_g:tf%n_g),tf%weights_freq(-tf%n_g:tf%n_g),tf%freqs_g_eff(-tf%n_g:tf%n_g)) nullify(tf%whois_freq_g) nullify(tf%relative_weight_g) else nn=tf%n_g+tf%second_grid_n_g*(1+tf%second_grid_i_g*2) allocate(tf%freqs_g(-nn:nn),tf%weights_freq_g(-nn:nn)) allocate(tf%whois_freq_g(-nn:nn)) allocate(tf%relative_weight_g(-nn:nn)) allocate(tf%freqs_g_eff(-nn:nn)) endif allocate(x(2*tf%n_g+1),w(2*tf%n_g+1)) x(:)=0.d0 w(:)=0.d0 if(tf%grid_freq_g==0) then!Gauss Legendre call legzo(tf%n_g*2+1,x,w) tf%freqs_g(-tf%n_g:tf%n_g)=-x(1:2*tf%n_g+1)*tf%omega_g tf%weights_freq_g(-tf%n_g:tf%n_g)=w(1:2*tf%n_g+1)*tf%omega_g tf%freqs_g_eff(-tf%n_g:tf%n_g)=tf%freqs_g(-tf%n_g:tf%n_g) else if(tf%grid_freq_g==1) then!Gaus Laguerre call lagzo(tf%n_g,x,w) tf%freqs_g(1:tf%n_g)=x(1:tf%n_g) do i=1,tf%n_g tf%freqs_g(-i)=-tf%freqs_g(i) enddo tf%freqs_g(0)=0.d0 tf%weights_freq_g(1:tf%n_g)=w(1:tf%n_g)*exp(x(1:tf%n_g)) do i=1,tf%n_g tf%weights_freq_g(-i)=tf%weights_freq_g(i) enddo tf%weights_freq_g(0)=0.d0 tf%freqs_g_eff(-tf%n_g:tf%n_g)=tf%freqs_g(-tf%n_g:tf%n_g) else if(tf%grid_freq_g==2) then call legzo(tf%n_g,x,w) tf%freqs_g(0)=0.d0 tf%freqs_g(1:tf%n_g)=(1.d0-x(1:tf%n_g))*tf%omega_g/2.d0 tf%freqs_g(-tf%n_g:-1)=(-1.d0-x(1:tf%n_g))*tf%omega_g/2.d0 tf%weights_freq_g(0)=0.d0 tf%weights_freq_g(1:tf%n_g)=w(1:tf%n_g)*tf%omega_g/2.d0 tf%weights_freq_g(-tf%n_g:1)=w(1:tf%n_g)*tf%omega_g/2.d0 tf%freqs_g_eff(-tf%n_g:tf%n_g)=tf%freqs_g(-tf%n_g:tf%n_g) else if (tf%grid_freq_g==3) then do i=0,tf%n_g tf%freqs_g(i)=(tf%omega_g/dble(tf%n_g))*dble(i) tf%freqs_g(-i)=-tf%freqs_g(i) enddo tf%weights_freq_g(:)=tf%omega_g/dble(tf%n_g) tf%freqs_g_eff(-tf%n_g:tf%n_g)=tf%freqs_g(-tf%n_g:tf%n_g) else if(tf%grid_freq_g==4) then do i=1,tf%n_g tf%freqs_g(i)=(tf%omega_g/dble(tf%n_g))*dble(i)-(0.5d0*tf%omega_g/dble(tf%n_g)) tf%freqs_g(-i)=-tf%freqs_g(i) enddo tf%freqs_g(0)=0.d0 tf%weights_freq_g(:)=(tf%omega_g/dble(tf%n_g)) tf%weights_freq_g(0)=0.d0 tf%freqs_g_eff(-tf%n_g:tf%n_g)=tf%freqs_g(-tf%n_g:tf%n_g) else if(tf%grid_freq_g==5) then tf%freqs_g(0)=0.d0 tf%relative_weight_g(0)=0.d0 tf%whois_freq_g(0)=0 ii=1 do i=1,tf%second_grid_n_g tf%freqs_g(ii)=(tf%omega_g/dble(2*tf%second_grid_n_g*tf%n_g))*dble(i)-& &0.5d0*tf%omega_g/dble(2*tf%second_grid_n_g*tf%n_g) tf%relative_weight_g(ii)=1.d0/dble(2*tf%second_grid_n_g) tf%whois_freq_g(ii)=0 tf%freqs_g_eff(ii)=0.d0 ii=ii+1 enddo do j=1,tf%second_grid_i_g do i=1,tf%second_grid_n_g tf%freqs_g(ii)=(tf%omega_g/dble(2*tf%second_grid_n_g*tf%n_g))*& &dble(i+tf%second_grid_n_g+2*tf%second_grid_n_g*(j-1))-0.5d0*tf%omega_g/dble(2*tf%second_grid_n_g*tf%n_g) tf%relative_weight_g(ii)=1.d0/dble(2*tf%second_grid_n_g) tf%whois_freq_g(ii)=j tf%freqs_g_eff(ii)=tf%omega_g/dble(tf%n_g)*dble(j) ii=ii+1 enddo tf%freqs_g(ii)=tf%omega_g/dble(tf%n_g)*dble(j) tf%relative_weight_g(ii)=0.d0 tf%whois_freq_g(ii)=j tf%freqs_g_eff(ii)=tf%omega_g/dble(tf%n_g)*dble(j) ii=ii+1 do i=1,tf%second_grid_n_g tf%freqs_g(ii)=(tf%omega_g/dble(2*tf%second_grid_n_g*tf%n_g))*& &dble(i+2*tf%second_grid_n_g*j)-0.5d0*tf%omega_g/dble(2*tf%second_grid_n_g*tf%n_g) tf%relative_weight_g(ii)=1.d0/dble(2*tf%second_grid_n_g) tf%whois_freq_g(ii)=j tf%freqs_g_eff(ii)=tf%omega_g/dble(tf%n_g)*dble(j) ii=ii+1 enddo enddo do i=tf%second_grid_i_g+1,tf%n_g tf%freqs_g(ii)=tf%omega_g/dble(tf%n_g)*dble(i) tf%relative_weight_g(ii)=1.d0 tf%whois_freq_g(ii)=i tf%freqs_g_eff(ii)=tf%omega_g/dble(tf%n_g)*dble(i) ii=ii+1 enddo ii=ii-1 if(ii/=nn) then write(stdout,*) 'ERROR ',nn,ii stop endif do i=1,ii tf%freqs_g(-i)=-tf%freqs_g(i) tf%relative_weight_g(-i)=tf%relative_weight_g(i) tf%whois_freq_g(-i)=-tf%whois_freq_g(i) tf%freqs_g_eff(-i)= tf%freqs_g_eff(i) enddo if(.not.options%l_self_time) then tf%weights_freq_g(:)=tf%omega_g/dble(tf%n_g) else tf%weights_freq_g(0)=0.d0 ii=1 do i=1,tf%second_grid_n_g tf%weights_freq_g(ii)=tf%omega_g/dble(tf%n_g)/dble(2*tf%second_grid_n_g) ii=ii+1 enddo do j=1,tf%second_grid_i_g do i=1,tf%second_grid_n_g tf%weights_freq_g(ii)=tf%omega_g/dble(tf%n_g)/dble(2*tf%second_grid_n_g) ii=ii+1 enddo tf%weights_freq_g(ii)=0.d0 ii=ii+1 do i=1,tf%second_grid_n_g tf%weights_freq_g(ii)=tf%omega_g/dble(tf%n_g)/dble(2*tf%second_grid_n_g) ii=ii+1 enddo enddo do i=tf%second_grid_i_g+1,tf%n_g tf%weights_freq_g(ii)=tf%omega_g/dble(tf%n_g) ii=ii+1 enddo do i=1,nn tf%weights_freq_g(-i)=tf%weights_freq_g(i) tf%freqs_g(-i)=-tf%freqs_g(i) enddo endif tf%n_g=nn endif deallocate(x,w) else allocate(tf%freqs_g(-tf%n:tf%n),tf%weights_freq_g(-tf%n:tf%n),tf%freqs_g_eff(-tf%n:tf%n)) allocate(tf%whois_freq_g(-tf%n:tf%n)) allocate(tf%relative_weight_g(-tf%n:tf%n)) tf%freqs_g(-tf%n:tf%n)= tf%freqs(-tf%n:tf%n) tf%freqs_g_eff(-tf%n:tf%n)= tf%freqs_eff(-tf%n:tf%n) tf%weights_freq_g(-tf%n:tf%n)=tf%weights_freq(-tf%n:tf%n) tf%relative_weight_g(-tf%n:tf%n)=tf%relative_weight(-tf%n:tf%n) tf%omega_g=tf%omega tf%n_g=tf%n tf%grid_freq_g=tf%grid_freq tf%second_grid_n_g=tf%second_grid_n tf%second_grid_i_g=tf%second_grid_i endif write(stdout,*) 'N:', tf%n,tf%n_g write(stdout,*) 'Omega:', tf%omega,tf%omega_g call flush_unit(stdout) do i=-tf%n,tf%n write(stdout,*)'freq:',i, tf%freqs(i),tf%freqs_g(i) write(stdout,*)'weight:',i, tf%weights_freq(i),tf%weights_freq_g(i) call flush_unit(stdout) enddo return END SUBROUTINE setup_timefreq END MODULE times_gw GWW/gww/self_energy_storage.f900000644000077300007730000023732612341332532017177 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! MODULE self_energy_storage !this modules contains the structure and subroutines !to store the expectation values of the self-energy !and to perform ffts and fits !in parallel version the calculations on times are parallelized USE kinds, ONLY : DP TYPE self_storage !descriptor of LOGICAL :: ontime!if .true. data is on imaginary time , otherwise imaginary frequency LOGICAL :: whole_s!if .true. also the off-diagonal elements are considered INTEGER :: n!number of sample on positive and on negative times (total of 2*n+1 samples) INTEGER :: n_grid_fit!number of sample on positive and on negative frequencies for fit (total of 2*n+1 samples) INTEGER :: max_i!number of states considered INTEGER :: i_min!minimum state to be calculated INTEGER :: i_max!maximum state to be calculated INTEGER :: nspin!spin multiplicity REAL(kind=DP) :: tau!max time (on imaginary axes) COMPLEX(kind=DP), DIMENSION(:,:,:), POINTER :: diag !values ,time_j COMPLEX(kind=DP), DIMENSION(:,:,:,:), POINTER :: whole !values ,time_k COMPLEX(kind=DP), DIMENSION(:,:,:), POINTER :: diag_freq_fit !values ,on frequency for fit COMPLEX(kind=DP), DIMENSION(:,:,:,:), POINTER :: whole_freq_fit !values , on frequency for fit REAL(kind=DP), POINTER, DIMENSION(:,:) :: ene_remainder!for storing remainders INTEGER :: i_min_whole!minimum state to be calculated for off-diagonal elements INTEGER :: i_max_whole!maximum state to be calculated for off-diagonal elements END TYPE self_storage TYPE self_on_real !descriptor of on an arbitrary grid on the real self_energy axis (inside HOMO-LUMO gap) !or in general on an arbitrary grid in complex plane INTEGER :: n!number of samples INTEGER :: max_i!number of states considered INTEGER :: i_min!minimum state to be calculated INTEGER :: i_max!maximum state to be calculated INTEGER :: nspin!spin multiplicity COMPLEX(kind=DP), DIMENSION(:), POINTER :: grid!grid point COMPLEX(kind=DP), DIMENSION(:,:,:), POINTER :: diag!diagonal expectation values END TYPE self_on_real CONTAINS SUBROUTINE initialize_self_on_real(sr) implicit none TYPE(self_on_real) :: sr nullify(sr%grid) nullify(sr%diag) return END SUBROUTINE initialize_self_on_real SUBROUTINE free_memory_self_on_real(sr) implicit none TYPE(self_on_real) :: sr if(associated(sr%grid)) deallocate(sr%grid) nullify(sr%grid) if(associated(sr%diag)) deallocate(sr%diag) nullify(sr%diag) END SUBROUTINE free_memory_self_on_real SUBROUTINE initialize_self_storage(ss) implicit none TYPE(self_storage) :: ss nullify(ss%diag) nullify(ss%whole) nullify(ss%ene_remainder) nullify(ss%diag_freq_fit) nullify(ss%whole_freq_fit) return END SUBROUTINE initialize_self_storage SUBROUTINE create_self_on_real(options, sr) !this subroutine create the object self_on_real reading the data from disk USE io_global, ONLY : stdout, ionode,ionode_id USE input_gw, ONLY : input_options USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(input_options) :: options TYPE(self_on_real) :: sr INTEGER :: ii,iw,iun CHARACTER(5) :: nfile REAL(kind=DP) :: x, y1, y2 sr%max_i=options%max_i sr%i_min=options%i_min sr%i_max=options%i_max sr%n = options%n_real_axis sr%nspin=1 call initialize_self_on_real(sr) allocate(sr%grid(options%n_real_axis)) allocate(sr%diag(options%n_real_axis,options%max_i,1)) sr%grid(:)=(0.d0,0.d0) sr%diag(:,:,:)=(0.d0,0.d0) do ii=options%i_min, options%i_max write(nfile,'(5i1)') & & ii/10000,mod(ii,10000)/1000,mod(ii,1000)/100,mod(ii,100)/10,mod(ii,10) if(ionode) then iun = find_free_unit() open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'self_on_real'// nfile, status='unknown',form='formatted') do iw=1,options%n_real_axis read(iun,*) x, y1, y2 if(x<-0.315) y1=y1+0.266184-0.004408 sr%grid(iw)=dcmplx(x,0.d0) sr%diag(iw,ii,1)=dcmplx(y1,y2) enddo close(iun) endif call mp_bcast(sr%diag(:,ii,1),ionode_id,world_comm) enddo call mp_bcast(sr%grid,ionode_id,world_comm) return END SUBROUTINE create_self_on_real SUBROUTINE write_self_storage_ondisk(ss, options) !this subroutine writes the green function on disk !the file name is taken from the label USE io_global, ONLY : stdout, ionode USE input_gw, ONLY : input_options USE mp, ONLY : mp_barrier USE mp_world, ONLY : world_comm USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(self_storage) :: ss!the self_energy descriptor to be written on file TYPE(input_options) :: options!for debug flag INTEGER :: iw, jw, kw, iun, is if(ionode) then iun = find_free_unit() open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'storage', status='unknown',form='unformatted') write(iun) ss%ontime write(iun) ss%whole_s write(iun) ss%n write(iun) ss%max_i write(iun) ss%i_min write(iun) ss%i_max write(iun) ss%tau write(iun) ss%n_grid_fit write(iun) ss%i_min_whole write(iun) ss%i_max_whole write(iun) ss%nspin do is=1,ss%nspin do iw=1,2*ss%n+1 write(iun) ss%diag(1:ss%max_i,iw,is) end do if(ss%whole_s) then do iw=1,2*ss%n+1 write(iun) ss%whole(ss%i_min_whole:ss%i_max_whole,1:ss%max_i,iw,is) end do endif do iw=1,2*ss%n_grid_fit+1 write(iun) ss%diag_freq_fit(1:ss%max_i,iw,is) end do if(ss%whole_s) then do iw=1,2*ss%n_grid_fit+1 write(iun) ss%whole_freq_fit(ss%i_min_whole:ss%i_max_whole,1:ss%max_i,iw,is) end do endif enddo close(iun) endif call mp_barrier( world_comm ) END SUBROUTINE write_self_storage_ondisk SUBROUTINE read_self_storage_ondisk(ss, options) !this subroutine writes the green function on disk !the file name is taken from the label USE io_global, ONLY : stdout, ionode, ionode_id USE input_gw, ONLY : input_options USE mp, ONLY : mp_barrier, mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(self_storage) :: ss!the self_energy descriptor to be read from file TYPE(input_options) :: options!for debug flag INTEGER :: iw, jw, kw, iun,is if(ionode) then iun = find_free_unit() open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'storage', status='old',form='unformatted') endif ! call free_memory_self_storage(ss) if(ionode) then read(iun) ss%ontime read(iun) ss%whole_s read(iun) ss%n read(iun) ss%max_i read(iun) ss%i_min read(iun) ss%i_max read(iun) ss%tau read(iun) ss%n_grid_fit read(iun) ss%i_min_whole read(iun) ss%i_max_whole read(iun) ss%nspin endif call mp_bcast(ss%ontime, ionode_id,world_comm) call mp_bcast(ss%whole_s, ionode_id,world_comm) call mp_bcast(ss%n, ionode_id,world_comm) call mp_bcast(ss%max_i, ionode_id,world_comm) call mp_bcast(ss%i_min, ionode_id,world_comm) call mp_bcast(ss%i_max, ionode_id,world_comm) call mp_bcast(ss%tau, ionode_id,world_comm) call mp_bcast(ss%n_grid_fit, ionode_id,world_comm) call mp_bcast(ss%i_min_whole, ionode_id,world_comm) call mp_bcast(ss%i_max_whole, ionode_id,world_comm) call mp_bcast(ss%nspin, ionode_id,world_comm) !check for consistency if(ss%max_i/=options%max_i) then write(stdout,*) 'Routine read_self_storage_ondisk max_i wrong' stop endif !allocates if(ss%whole_s) then allocate(ss%whole(ss%i_min_whole:ss%i_max_whole,ss%max_i,2*ss%n+1,ss%nspin)) else nullify(ss%whole) endif allocate(ss%diag(ss%max_i,2*ss%n+1,ss%nspin)) allocate(ss%ene_remainder(ss%max_i,ss%nspin)) if(ss%whole_s) then allocate(ss%whole_freq_fit(ss%i_min_whole:ss%i_max_whole,ss%max_i,2*ss%n_grid_fit+1,ss%nspin)) else nullify(ss%whole_freq_fit) endif allocate(ss%diag_freq_fit(ss%max_i,2*ss%n_grid_fit+1,ss%nspin)) if(ionode) then do is=1,ss%nspin do iw=1,2*ss%n+1 read(iun) ss%diag(1:ss%max_i,iw,is) end do if(ss%whole_s) then do iw=1,2*ss%n+1 read(iun) ss%whole(ss%i_min_whole:ss%i_max_whole,1:ss%max_i,iw,is) end do endif do iw=1,2*ss%n_grid_fit+1 read(iun) ss%diag_freq_fit(1:ss%max_i,iw,is) end do if(ss%whole_s) then do iw=1,2*ss%n_grid_fit+1 read(iun) ss%whole_freq_fit(ss%i_min_whole:ss%i_max_whole,1:ss%max_i,iw,is) end do endif enddo close(iun) endif call mp_bcast(ss%diag, ionode_id,world_comm) if(ss%whole_s) then call mp_bcast(ss%whole, ionode_id,world_comm) endif call mp_bcast(ss%diag_freq_fit, ionode_id,world_comm) if(ss%whole_s) then call mp_bcast(ss%whole_freq_fit, ionode_id,world_comm) endif return END SUBROUTINE read_self_storage_ondisk SUBROUTINE free_memory_self_storage(ss) !deallocate if allocated implicit none TYPE(self_storage) :: ss if(associated(ss%diag)) deallocate(ss%diag) nullify(ss%diag) if(associated(ss%whole)) deallocate(ss%whole) nullify(ss%whole) if(associated(ss%ene_remainder)) deallocate(ss%ene_remainder) nullify(ss%ene_remainder) if(associated(ss%diag_freq_fit)) deallocate(ss%diag_freq_fit) nullify(ss%diag_freq_fit) if(associated(ss%whole_freq_fit)) deallocate(ss%whole_freq_fit) nullify(ss%whole_freq_fit) END SUBROUTINE subroutine write_self_on_real(sr,ifile) !this subroutine writes the self-energy function on disk !the file name is taken from the label USE io_global, ONLY : stdout, ionode USE mp, ONLY : mp_barrier USE mp_world, ONLY : world_comm USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(self_on_real),INTENT(in) :: sr!the self_energy descriptor to be written on file INTEGER,INTENT(in) :: ifile!0 for integration part 1 for total part INTEGER :: iun if(ionode) then iun = find_free_unit() if(ifile==0) then open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'self_on_realA', status='unknown',form='unformatted') else open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'self_on_realB', status='unknown',form='unformatted') endif write(iun) sr%n write(iun) sr%max_i write(iun) sr%i_min write(iun) sr%i_max write(iun) sr%nspin write(iun) sr%grid(1:sr%n) write(iun) sr%diag(1:sr%n,1:sr%max_i,1:sr%nspin) close(iun) endif return end subroutine write_self_on_real subroutine read_self_on_real(sr,ifile) !this subroutine reads the self-energy function on disk !the file name is taken from the label USE io_global, ONLY : stdout, ionode, ionode_id USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(self_on_real),INTENT(out) :: sr!the self_energy descriptor to be written on file INTEGER,INTENT(in) :: ifile!0 for integration part 1 for total part INTEGER :: iun if(ionode) then iun = find_free_unit() if(ifile==0) then open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'self_on_realA', status='old',form='unformatted') else open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'self_on_realB', status='old',form='unformatted') endif read(iun) sr%n read(iun) sr%max_i read(iun) sr%i_min read(iun) sr%i_max read(iun) sr%nspin endif call mp_bcast(sr%n, ionode_id,world_comm) call mp_bcast(sr%max_i,ionode_id,world_comm) call mp_bcast(sr%i_min,ionode_id,world_comm) call mp_bcast(sr%i_max,ionode_id,world_comm) call mp_bcast(sr%nspin,ionode_id,world_comm) allocate(sr%grid(sr%n)) allocate(sr%diag(sr%n,sr%max_i,sr%nspin)) if(ionode) then read(iun) sr%grid(1:sr%n) read(iun) sr%diag(1:sr%n,1:sr%max_i,1:sr%nspin) close(iun) endif call mp_bcast(sr%grid,ionode_id,world_comm) call mp_bcast(sr%diag,ionode_id,world_comm) return end subroutine read_self_on_real subroutine do_self_on_real(options,tf,ss,sr) !this subroutine calculate the integral part of the self energy on real frequency axis !at the end it calculates also the self_eenergy on imaginary axis USE io_global, ONLY : stdout USE input_gw, ONLY : input_options USE times_gw, ONLY : times_freqs implicit none TYPE(input_options) :: options TYPE(times_freqs) :: tf TYPE(self_storage) :: ss TYPE(self_on_real) :: sr INTEGER :: is,ii,iw REAL(kind=DP) :: freq,energy !set up sr sr%n=options%n_real_axis sr%max_i=options%max_i sr%i_min=options%i_min sr%i_max=options%i_max sr%nspin=options%nspin allocate(sr%grid(sr%n)) allocate(sr%diag(sr%n,sr%max_i,sr%nspin)) do iw=0,sr%n-1 freq=(options%real_energy_max-options%real_energy_min)/dble(sr%n)*dble(iw)+options%real_energy_min sr%grid(iw+1)=dcmplx(freq,0.d0) enddo !loop on frequencies do iw=1,sr%n energy=dble(sr%grid(iw)) call do_self_lanczos_time(ss, tf ,options,.true.,energy) !do fft call fft_storage_grid_fit(tf, ss) !extract data from ss do is=1,sr%nspin do ii=sr%i_min,sr%i_max sr%diag(iw,ii,is)=ss%diag_freq_fit(ii,ss%n_grid_fit+1,is) enddo enddo call free_memory_self_storage(ss) enddo !anlytic continuation case !energy should be at the middle of homo-lumo gap call do_self_lanczos_time(ss, tf ,options,.false.,energy) call fft_storage_grid_fit(tf, ss) return end subroutine do_self_on_real SUBROUTINE set_remainder(ss, qp) !this subroutine simply copy the self-energy remainders !from ss to qp, in order to allow restarting USE energies_gww, ONLY : quasi_particles implicit none TYPE(self_storage) :: ss TYPE(quasi_particles) :: qp if(.not.associated(qp%ene_remainder)) allocate(qp%ene_remainder(ss%max_i,1)) qp%ene_remainder(:,1)=ss%ene_remainder(:,1) return END SUBROUTINE set_remainder SUBROUTINE create_self_ontime(tf, ss,options,qp) !this subroutine creates the structure self_storege !on imaginary time USE constants, ONLY : eps8 USE io_global, ONLY : stdout, ionode USE input_gw, ONLY : input_options USE basic_structures, ONLY : q_mat, wannier_u, wp_psi,v_pot,free_memory USE green_function, ONLY : green,read_green,free_memory_green, initialize_green USE polarization, ONLY : polaw,free_memory_polaw,read_polaw, initialize_polaw, & &invert_v_pot,distribute_v_pot, collect_v_pot USE compact_product USE mp, ONLY : mp_sum, mp_barrier USE para_gww, ONLY : is_my_time, is_my_pola USE energies_gww, ONLY : quasi_particles USE times_gw, ONLY : times_freqs USE w_divergence USE mp_world, ONLY : world_comm,nproc,mpime implicit none TYPE(times_freqs), INTENT(in) :: tf!for times grid TYPE(input_options), INTENT(in) :: options! for imaginary time range and number of samples TYPE(self_storage) :: ss! TYPE(quasi_particles), INTENT(in) :: qp!for the HF energies if required TYPE(green) :: gg,gm!green function TYPE(q_mat) :: qm!overlap of orthonormalized wannier products with wannier products TYPE(polaw) :: ww!dressed interaction TYPE(wannier_u) :: uu!transformation matrix ks to wannier TYPE(contraction) :: cr!to speed up calculation TYPE(contraction_index) :: cri! index of contraction TYPE(contraction_state) :: crs!state contraction data TYPE(wp_psi) :: wp!for remainder calculations TYPE(gv_time) :: gt!for the treatment of the G=0,G=0 divergence of W TYPE(v_pot) :: vp,vpi,vpid REAL(kind=DP) :: time,dt INTEGER :: iw,ii,jj REAL(kind=DP) :: offset COMPLEX(kind=DP) :: sene INTEGER :: l_blk, nbegin,nend REAL(kind=DP), ALLOCATABLE :: wtemp(:,:) nullify(vp%vmat) nullify(vpi%vmat) nullify(vpid%vmat) if(options%l_self_from_pola .or. options%l_self_beta) then if(options%w_divergence == 2) then call read_data_pw_v(vp,options%prefix,options%debug,0,.true.) else call read_data_pw_v(vp,options%prefix,options%debug,0,.false.) endif call invert_v_pot(vp,vpi) call free_memory(vp) call distribute_v_pot(vpi,vpid) call free_memory(vpi) endif !set self_energy descriptor ! call free_memory_self_storage(ss) ss%ontime=.true. ss%max_i=options%max_i ss%i_min=options%i_min ss%i_max=options%i_max ss%n=options%n ss%tau=options%tau ss%whole_s=options%whole_s ss%nspin=1 if(tf%grid_fit/=0) then ss%n_grid_fit=tf%n_grid_fit else ss%n_grid_fit=tf%n endif if(ss%whole_s) then allocate(ss%whole(ss%max_i,ss%max_i,2*ss%n+1,1)) ss%whole(:,:,:,:)=(0.d0,0.d0) allocate(ss%whole_freq_fit(ss%max_i,ss%max_i,2*ss%n_grid_fit+1,1)) ss%whole_freq_fit(:,:,:,:)=(0.d0,0.d0) nullify(ss%diag) nullify(ss%diag_freq_fit) else allocate(ss%diag(ss%max_i,2*ss%n+1,1)) ss%diag(:,:,:)=(0.d0,0.d0) nullify(ss%whole) allocate(ss%diag_freq_fit(ss%max_i,2*ss%n_grid_fit+1,1)) ss%diag_freq_fit(:,:,:)=(0.d0,0.d0) nullify(ss%whole_freq_fit) endif !set up self-energy remainders allocate(ss%ene_remainder(ss%max_i,1)) if(options%remainder == 3 .or. options%remainder == 4) then ss%ene_remainder(:,1)=qp%ene_remainder(:,1) else ss%ene_remainder(:,1)=0.d0 endif if(.not.options%lvcprim_file .and. .not.options%l_self_beta) then !read U matrix call read_data_pw_u(uu,options%prefix) !read overlap matrix Q call read_data_pw_q(qm,options%prefix, options%l_self_from_pola) dt = ss%tau/real(ss%n) if(options%use_contractions) then if(.not.options%l_contraction_single_state) then write(stdout,*) 'call do_contraction'!ATTENZIONE call do_contraction(qm,uu,cr, options%max_i) write(stdout,*) 'done do_contraction'!ATTENZIONE call write_contraction(cr,options) write(stdout,*) 'done do_contraction'!ATTENZIONE else !contraction index and states already available on disk call read_contraction_index(cri, options) endif endif !loop call initialize_green(gg) call initialize_polaw(ww) l_blk= (2*ss%n+1)/nproc if(l_blk*nproc < (2*ss%n+1)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 -(ss%n+1) nend=nbegin+l_blk-1 if(nend > ss%n) nend = ss%n ! do iw=-ss%n,ss%n ! if(is_my_time(iw)) then do iw=nbegin,nbegin+l_blk-1 if(iw <= ss%n) then write(stdout,*) 'Time :',iw!ATTENZIONE call flush_unit(stdout) time=dt*real(iw) !read dressed interaction !we take care of the symmetry t ==> -t call read_polaw(abs(iw),ww,options%debug,options%l_verbose) !some controls if(.not. ww%ontime) then write(stdout,*) 'Routine create_self_ontime: imaginary time required' stop endif if(tf%l_fft_timefreq) then if(abs(time-ww%time) >= eps8) then write(stdout,*) 'Routine create_self_ontime: imaginary time does not correspond' stop endif endif if(options%l_self_from_pola) then !if required obtains the dressed polarization call collect_v_pot(vpi,vpid) allocate(wtemp(ww%numpw,ww%numpw)) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,vpi%vmat,ww%numpw,ww%pw,ww%numpw,& &0.d0, wtemp,ww%numpw) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,wtemp,ww%numpw,vpi%vmat,ww%numpw,& &0.d0,ww%pw,ww%numpw) call free_memory(vpi) deallocate(wtemp) endif call read_green(iw,gg,options%debug,.false.) !some controls if(.not. gg%ontime) then write(*,*) 'Routine create_self_ontime: imaginary time required' stop endif if(tf%l_fft_timefreq) then if(abs(time-gg%time) >= eps8) then write(*,*) 'Routine create_self_ontime: imaginary time does not correspond' stop endif endif !calculate elements if(ss%whole_s) then do ii=ss%i_min,ss%i_max do jj=ss%i_min,ss%i_max if(.not.options%use_contractions) then call self_energy(ii,jj,ss%whole(ii,jj,iw+ss%n+1,1),time,qm,uu,gg,ww) else call self_energy_contraction(ii,jj,ss%whole(ii,jj,iw+ss%n+1,1),time,cr,gg,ww) endif enddo enddo else do ii=ss%i_min,ss%i_max write(stdout,*) 'State:', ii call flush_unit(stdout) if(.not.options%use_contractions) then call self_energy(ii,ii,ss%diag(ii,iw+ss%n+1,1),time,qm,uu,gg,ww) else if(.not.options%l_contraction_single_state) then call self_energy_contraction(ii,ii,ss%diag(ii,iw+ss%n+1,1),time,cr,gg,ww) else crs%state=ii call read_contraction_state(cri,crs,options) call self_energy_contraction_state(ii,ii,ss%diag(ii,iw+ss%n+1,1),time,cri,crs,gg,ww) call free_memory_contraction_state(crs) endif endif enddo endif !at zero time 1/2 positive G and 1/2 negative if(iw==0) then do ii=1,ss%max_i ss%diag(ii,iw+ss%n+1,1)=0.5d0*ss%diag(ii,iw+ss%n+1,1) enddo call read_green(iw,gg,options%debug,.true.) do ii=ss%i_min,ss%i_max write(stdout,*) 'State:', ii call flush_unit(stdout) if(.not.options%use_contractions) then call self_energy(ii,ii,sene,time,qm,uu,gg,ww) else if(.not.options%l_contraction_single_state) then call self_energy_contraction(ii,ii,sene,time,cr,gg,ww) else crs%state=ii call read_contraction_state(cri,crs,options) call self_energy_contraction_state(ii,ii,sene,time,cri,crs,gg,ww) call free_memory_contraction_state(crs) endif endif ss%diag(ii,iw+ss%n+1,1)=ss%diag(ii,iw+ss%n+1,1)+0.5d0*sene enddo endif else if(options%l_self_from_pola) then call collect_v_pot(vpi,vpid) call free_memory(vpi) endif endif!on is_my_time enddo call free_memory(vpid) !if required add remainder time to negative ones if(options%remainder==1 .or. options%remainder==2) then write(stdout,*) 'enter remainder' call read_data_pw_wp_psi(wp,options%prefix) if(.not.options%l_hf_energies) then if(uu%nums > uu%nums_occ(1)) then offset=-(uu%ene(uu%nums_occ(1)+1,1)+uu%ene(uu%nums_occ(1),1))/2.d0 else offset=-uu%ene(uu%nums_occ(1),1) endif else if(uu%nums > uu%nums_occ(1)) then offset=-(qp%ene_hf(uu%nums_occ(1)+1,1)+qp%ene_hf(uu%nums_occ(1),1))/2.d0 else offset=-qp%ene_hf(uu%nums_occ(1),1) endif endif call read_green(0,gg,options%debug,.false.) call read_green(0,gm,options%debug,.true.) do iw=-ss%n,0 if(is_my_pola(-iw)) then write(stdout,*) 'Remainder time:', iw if(ss%whole_s) then write(stdout,*) 'Routine create_self_ontime: remainder and whole matrix not implemented YET' stop else if(tf%l_fft_timefreq) then time=dt*real(iw) else time=tf%times(iw) endif call read_polaw(iw,ww,options%debug,options%l_verbose) do ii=ss%i_min,ss%i_max if(options%l_contraction_single_state) then crs%state=ii call read_contraction_state(cri,crs,options) endif if(.not.options%use_contractions) then call self_energy(ii,ii,sene,time,qm,uu,gg,ww) else if(.not.options%l_contraction_single_state) then call self_energy_contraction(ii,ii,sene,time,cr,gg,ww) else call self_energy_contraction_state(ii,ii,sene,time,cri,crs,gg,ww) endif endif if(options%remainder==1) then if(.not.options%l_hf_energies) then sene=sene*exp((uu%ene(uu%nums,1)+offset)*time) else sene=sene*exp((qp%ene_hf(qp%max_i,1)+offset)*time) endif endif !sene changes sign because we are on the negative axes!! if(iw==0) sene=sene*0.5d0 ss%diag(ii,iw+ss%n+1,1)=ss%diag(ii,iw+ss%n+1,1)+sene write(stdout,*) 'SENE 0', iw, sene if(.not.options%use_contractions) then call self_energy(ii,ii,sene,time,qm,uu,gm,ww) else if(.not.options%l_contraction_single_state) then call self_energy_contraction(ii,ii,sene,time,cr,gg,ww) else call self_energy_contraction_state(ii,ii,sene,time,cri,crs,gg,ww) endif endif if(options%remainder==1) then if(.not.options%l_hf_energies) then sene=sene*exp((uu%ene(uu%nums,1)+offset)*time) else sene=sene*exp((qp%ene_hf(qp%max_i,1)+offset)*time) endif endif if(iw==0) sene=sene*0.5d0 ss%diag(ii,iw+ss%n+1,1)=ss%diag(ii,iw+ss%n+1,1)-sene write(stdout,*) 'SENE 1', iw, sene call self_energy_remainder(ii,sene,time,wp,ww) if(options%remainder==1) then if(.not.options%l_hf_energies) then sene=sene*exp((uu%ene(uu%nums,1)+offset)*time) else sene=sene*exp((qp%ene_hf(qp%max_i,1)+offset)*time) endif endif if(iw==0) sene=sene*0.5d0 ss%diag(ii,iw+ss%n+1,1)=ss%diag(ii,iw+ss%n+1,1)+sene write(stdout,*) 'SENE 2', iw, sene if(options%l_contraction_single_state) & & call free_memory_contraction_state(crs) enddo endif endif enddo call free_memory(wp) endif if(ss%whole_s) then call mp_sum(ss%whole(:,:,:,:),world_comm) else call mp_sum(ss%diag(:,:,:),world_comm) end if call free_memory(uu) call free_memory(qm) call free_memory_polaw(ww) call free_memory_green(gg) if(.not.options%l_contraction_single_state) & & call free_memory_contraction(cr) else !FROM VCPRIM FILE call selfenergy_ontime_file(ss,tf,options) endif !if required add coulomb-like term for the treatment of the (G=0,G=0) divergence of W if(options%w_divergence == 2 ) then call initialize_gv_time(gt) call read_gv_time(gt) !consistency check if(options%max_i /= gt%max_i) then write(stdout,*) 'max_i not correct' stop endif call setup_gv_time(gt) do iw=1,2*gt%n+1 ss%diag(:,iw,1)=ss%diag(:,iw,1)+gt%ex(:,iw) enddo call free_memory_gv_time(gt) endif return END SUBROUTINE create_self_ontime SUBROUTINE write_storage(tf,ss) !this subroutine write on standard output !the values of write_storage USE io_global, ONLY : stdout, ionode USE constants, ONLY : pi USE mp, ONLY : mp_barrier USE mp_world, ONLY : world_comm USE times_gw, ONLY : times_freqs implicit none TYPE(times_freqs), INTENT(in) :: tf!for time grid TYPE(self_storage), INTENT(in) :: ss INTEGER :: iw,ii,jj REAL(kind=DP) :: time,dt,totalfrequency,totalperiod,omega if(ionode) then if(ss%ontime) then write(stdout,*) '--------Sigma on imaginary time----------' dt=ss%tau/real(ss%n) do iw=-ss%n,ss%n if(tf%l_fft_timefreq) then time=dt*real(iw) else time=tf%times(iw) endif if(ss%whole_s) then do ii=1,ss%max_i do jj=1,ss%max_i write(stdout,*) time,ii,jj,ss%whole(ii,jj,iw+ss%n+1,1) enddo enddo else do ii=1,ss%max_i write(stdout,*) iw, time,ii, ss%diag(ii,iw+ss%n+1,1) enddo endif enddo else write(stdout,*) '--------Sigma on imaginary frequency----------' totalperiod=2.d0*ss%tau+2.d0*ss%tau/real(ss%n) totalfrequency=(2.d0*pi/totalperiod) do iw=-ss%n,ss%n if(tf%l_fft_timefreq) then omega=totalfrequency*real(iw) else omega=tf%freqs(iw) endif if(ss%whole_s) then do ii=1,ss%max_i do jj=1,ss%max_i write(stdout,*) omega,ii,jj,ss%whole(ii,jj,iw+ss%n+1,1) enddo enddo else do ii=1,ss%max_i write(stdout,*) omega,ii, ss%diag(ii,iw+ss%n+1,1) enddo endif enddo endif endif return END SUBROUTINE write_storage SUBROUTINE fft_storage_grid(tf,ss) !this subroutine performs a FFT on the storage data !inverse or direct determined by ontime !uses grid USE io_global, ONLY : stdout USE constants, ONLY : pi USE times_gw, ONLY : times_freqs implicit none TYPE(times_freqs), INTENT(in) :: tf!for time frequency grids TYPE(self_storage), INTENT(inout) :: ss!input data COMPLEX(kind=DP), DIMENSION(:), ALLOCATABLE :: ss_old, tmpc COMPLEX(kind=DP), DIMENSION(:,:), ALLOCATABLE :: factors INTEGER :: ii,jj, is,js,kk INTEGER, PARAMETER :: nmesh=30 REAL(kind=DP) :: b_p,b_m,r_p,r_m COMPLEX(kind=DP) :: a_p,a_m, cor_1,cor_2 REAL(kind=DP), ALLOCATABLE :: x(:),w(:) COMPLEX(kind=DP), ALLOCATABLE :: fij(:,:), fp(:),fm(:) allocate(ss_old(2*tf%n+1), tmpc(2*tf%n+1)) allocate(factors(-tf%n:tf%n, -tf%n:tf%n)) !setup factors for every time posistion do ii=-tf%n, tf%n if(ss%ontime) then!time to frequency transform do jj=-tf%n,tf%n factors(jj,ii)=tf%weights_time(jj)*exp((0.d0,-1.d0)*tf%freqs(ii)*tf%times(jj)) enddo factors(:,ii)=factors(:,ii)*(0.d0,-1.d0) else!frequency to time transform do jj=-tf%n,tf%n factors(jj,ii)=tf%weights_freq(jj)*exp((0.d0,1.d0)*tf%times(ii)*tf%freqs(jj)) enddo factors(:,ii)=factors(:,ii)*(0.d0,1.d0)/(2.d0*pi) endif enddo if(ss%whole_s) then!full matrix do is=1,ss%max_i do js=1,ss%max_i !copy array to be transformed ss_old(:)=ss%whole(is,js,:,1) !transform do ii=-tf%n,tf%n do kk=-tf%n,tf%n tmpc(kk+tf%n+1)=ss_old(kk+tf%n+1)*factors(kk,ii) enddo ss%whole(is,js,ii+tf%n+1,1)=sum(tmpc(1:2*tf%n+1)) enddo enddo enddo else if(tf%l_fourier_fit_time .and. ss%ontime) then allocate(fij(-tf%n:tf%n,nmesh)) allocate(fp(nmesh),fm(nmesh)) allocate(x(nmesh),w(nmesh)) x(:)=0.d0 w(:)=0.d0 call legzo(nmesh,x,w) !x(:)=x(:)*tf%tau/2.d0 !x(:)=x(:)+tf%tau/2.d0 !w(:)=w(:)*tf%tau/2.d0 x(:)=x(:)*(tf%times(tf%n)-tf%tau)/2.d0 x(:)=x(:)+(tf%times(tf%n)-tf%tau)/2.d0+tf%tau w(:)=w(:)*(tf%times(tf%n)-tf%tau)/2.d0 do ii=-tf%n,tf%n do jj=1,nmesh fij(ii,jj)=exp((0.d0,-1.d0)*tf%freqs(ii)*x(jj)) enddo enddo endif do is=1,ss%max_i !copy array to be transformed ss_old(:)=ss%diag(is,:,1) !transform do ii=-tf%n,tf%n do kk=-tf%n,tf%n tmpc(kk+tf%n+1)=ss_old(kk+tf%n+1)*factors(kk,ii) enddo ss%diag(is,ii+tf%n+1,1)=sum(tmpc(1:2*tf%n+1)) enddo if(tf%l_fourier_fit_time .and. ss%ontime) then r_p=dble(ss_old(2*tf%n)/ss_old(2*tf%n+1)) write(stdout,*) 'RP',ss_old(2*tf%n),ss_old(2*tf%n-5) if(r_p <= 1.d0) r_p = tf%g_tau b_p=log(r_p)/(tf%times(tf%n)-tf%times(tf%n-1)) a_p=ss_old(2*tf%n)/(exp(-b_p*tf%times(tf%n-1))) if(r_p == tf%g_tau) a_p=0.d0 if(abs(ss_old(2)) > 1.d-10 .and. abs(ss_old(1)) > 1.d-10) then r_m=dble(ss_old(2)/ss_old(1)) if(r_m <= 1.d0) r_m = tf%g_tau b_m=log(r_m)/(tf%times(-tf%n+1)-tf%times(-tf%n)) a_m=ss_old(2)/(exp(b_m*tf%times(-tf%n+1))) if(r_m == tf%g_tau) a_m=0.d0 else r_m=0.d0 a_m=(0.d0,0.d0) b_m=0.d0 endif do jj=1,nmesh fp(jj)=a_p*exp(-b_p*x(jj))*w(jj) enddo if(r_m /=0.d0) then do jj=1,nmesh fm(jj)=a_m*exp(-b_m*x(jj))*w(jj) enddo endif do ii=-tf%n,tf%n ! cor_1=(0.d0,-1.d0)*(a_p/(b_p+(0.d0,1.d0)*tf%freqs(ii))) ! if(r_m /= 0.d0) then ! cor_1=cor_1+(0.d0,-1.d0)*(a_m/(b_m-(0.d0,1.d0)*tf%freqs(ii))) ! endif cor_2=0.d0 do jj=1,nmesh cor_2=cor_2-fij(ii,jj)*fp(jj) if(r_m /=0.d0) then cor_2=cor_2-conjg(fij(ii,jj))*fm(jj) endif enddo cor_2=cor_2*(0.d0,-1.d0) ss%diag(is,ii+tf%n+1,1)=ss%diag(is,ii+tf%n+1,1)!-cor_2!+cor_1+cor_2 write(stdout,*) 'COR2' , cor_2 enddo endif enddo if(tf%l_fourier_fit_time .and.ss%ontime) deallocate(fij,fp,fm,x,w) endif if(ss%ontime) then ss%ontime=.false. else ss%ontime=.true. endif deallocate(ss_old,tmpc) deallocate(factors) return END SUBROUTINE fft_storage_grid SUBROUTINE fft_storage(ss) !this subroutine performs a FFT on the storage data !inverse or direct determined by ontime USE io_global, ONLY : stdout USE constants, ONLY : pi USE fft_scalar, ONLY : cft_1z implicit none TYPE(self_storage) :: ss!input data REAL(kind=DP) :: totalperiod,omega,time,totalfrequency INTEGER :: iw,ii,ipos COMPLEX(kind=DP), ALLOCATABLE :: inz(:),outz(:) COMPLEX(kind=DP) :: fact INTEGER*8 :: plan totalperiod=2.d0*ss%tau+2.d0*ss%tau/real(ss%n) totalfrequency=(2.d0*pi/totalperiod)*real(2*ss%n+2) allocate(inz(2*ss%n+2),outz(2*ss%n+2)) if(.not.ss%whole_s) then if(ss%ontime) then!time to frequency transformation ss%ontime=.false. !loop on states do ii=1,ss%max_i inz(:)=(0.d0,0.d0) do iw=-ss%n,ss%n ipos=iw+ss%n+2 inz(ipos)=ss%diag(ii,iw+ss%n+1,1) enddo inz(1)=inz(2) call cft_1z(inz,1,2*ss%n+2,2*ss%n+2, -1,outz) outz(:)=outz(:)*dble(2*ss%n+2) do iw=0,2*ss%n+2-1 if(iw <= (2*ss%n+1)) then omega=(2.d0*pi/totalperiod)*real(iw) else omega=(2.d0*pi/totalperiod)*real(iw-2*ss%n-2) endif fact=exp((0.d0,-1.d0)*omega*totalperiod/2.d0)*(0.d0,-1.d0)*(ss%tau/real(ss%n)) outz(iw+1)=outz(iw+1)*fact enddo do iw=0,2*ss%n+1 if(iw/=(ss%n+1)) then if(iw < (ss%n+1)) then ss%diag(ii,ss%n+iw+1,1)=outz(iw+1) else ss%diag(ii,iw-ss%n-2+1,1)=outz(iw+1) endif endif enddo write(*,*) 'ELIMINATO:', outz(ss%n+1) enddo else !frequency to time transform ss%ontime=.true. !loop on states do ii=1,ss%max_i inz(:)=(0.d0,0.d0) do iw=-ss%n,ss%n ipos=iw+ss%n+2 inz(ipos)=ss%diag(ii,iw+ss%n+1,1) enddo call cft_1z(inz,1,2*ss%n+2,2*ss%n+2, 1,outz) do iw=0,2*ss%n+2-1 if(iw <= (2*ss%n+1)) then time=(ss%tau/real(ss%n))*real(iw) else time=(ss%tau/real(ss%n))*real(iw-2*ss%n-2) endif fact=exp((0.d0,+1.d0)*time*totalfrequency/2.d0)*(0.d0,+1.d0)/totalperiod outz(iw+1)=outz(iw+1)*fact enddo do iw=0,2*ss%n+1 if(iw/=(ss%n+1)) then if(iw < (ss%n+1)) then ss%diag(ii,ss%n+iw+1,1)=outz(iw+1) else ss%diag(ii,iw-ss%n-2+1,1)=outz(iw+1) endif endif enddo enddo endif else write(stdout,*) 'ENTIRE SIGMA NOT IMPLEMENTED YET' endif deallocate(inz,outz) return END SUBROUTINE SUBROUTINE test_fft(tf) !just a fft test USE times_gw, ONLY : times_freqs implicit none TYPE(times_freqs), INTENT(in) :: tf TYPE(self_storage) :: ss INTEGER :: n,iw REAL(kind=DP) :: tau, lambda n=100 tau=25. lambda=2. ss%ontime=.true. ss%whole_s=.false. ss%n=tf%n ss%tau=tf%tau ss%max_i=1 n=tf%n allocate(ss%diag(1,2*n+1,1)) nullify(ss%whole) do iw=-n,n ss%diag(1,iw+n+1,1)=exp(-(real(iw)*tau/real(n)/lambda)**2.) enddo call write_storage(tf,ss) call fft_storage(ss) call write_storage(tf,ss) call fft_storage(ss) call write_storage(tf,ss) call free_memory_self_storage(ss) return END SUBROUTINE SUBROUTINE addconduction_self_ontime(ss, options) !this subroutine adds to the self_energy of conduction states !on negative imaginary times, the part due to terms \Psi_c'\Psic\w_P USE io_global, ONLY : stdout, ionode USE input_gw, ONLY : input_options USE basic_structures, ONLY : v_pot,wannier_u_prim, v_pot_prim,free_memory, ortho_polaw USE green_function, ONLY : green, read_green, free_memory_green, initialize_green USE polarization, ONLY : polaw, free_memory_polaw, read_polaw, invert_v_pot, invert_ortho_polaw,& & orthonormalize_inverse, initialize_polaw, orthonormalize_vpot, distribute_ortho_polaw, collect_ortho_polaw,& & distribute_v_pot, collect_v_pot USE mp, ONLY : mp_sum USE para_gww, ONLY : is_my_pola USE mp_world, ONLY : world_comm,nproc,mpime implicit none TYPE(input_options) :: options TYPE(self_storage) :: ss TYPE(v_pot) :: vp,vpi,vpid TYPE(ortho_polaw) :: op,opi, opd, opid TYPE(polaw) :: ww!dressed interaction TYPE(wannier_u_prim) :: wup TYPE(v_pot_prim) :: vpp TYPE(green) :: gg INTEGER iw,jw,kw,it,ii REAL(kind=DP), ALLOCATABLE :: wtemp(:,:) REAL(kind=DP), ALLOCATABLE :: cp(:,:,:) !arrys for contraction c',c, numpw REAL(kind=DP), ALLOCATABLE :: qg(:,:) COMPLEX(kind=DP), ALLOCATABLE :: sene(:,:) REAL(kind=DP), ALLOCATABLE :: gf_t(:,:) REAL(kind=DP), ALLOCATABLE :: pwcp_t(:,:) REAL(kind=DP), EXTERNAL :: ddot INTEGER :: l_blk, nbegin,nend INTEGER :: i_first nullify(vp%vmat) nullify(vpi%vmat) nullify(op%on_mat) nullify(opi%on_mat) nullify(wup%umat) nullify(vpp%ij) nullify(vpp%vmat) nullify(opd%on_mat) nullify(opid%on_mat) nullify(vpid%vmat) call initialize_green(gg) call initialize_polaw(ww) write(stdout,*) 'addconduction_self_ontime OLD 1'!ATTENZIONE call flush_unit(stdout) !read coulombian potential and calculate inverse if(ss%whole_s) then write(stdout,*) 'Whole s not implemented YET' stop endif call read_data_pw_u_prim(wup,options%prefix) i_first=max(ss%i_min,wup%nums_occ+1) write(stdout,*) 'addconduction_self_ontime1_2'!ATTENZIONE call flush_unit(stdout) if(options%w_divergence==2) then call read_data_pw_v_pot_prim(vpp, options%prefix,.true.) else call read_data_pw_v_pot_prim(vpp, options%prefix,.false.) endif write(stdout,*) 'addconduction_self_ontime1_3'!ATTENZIONE call flush_unit(stdout) allocate(sene(-ss%n:0,ss%i_max-wup%nums_occ)) sene(:,:)=(0.d0,0.d0) !set up contraction array \sum_j U^{C'}_ij Vjkl ! allocate(cp(vpp%numpw, wup%nums-wup%nums_occ,options%max_i-wup%nums_occ)) allocate(cp(vpp%numpw, wup%nums-wup%nums_occ,i_first:ss%i_max)) cp(:,:,:)=0.d0 do iw=1,vpp%numpw_prim do ii=i_first,ss%i_max do kw=1,vpp%numpw cp(kw,vpp%ij(2,iw)-wup%nums_occ,ii)=cp(kw,vpp%ij(2,iw)-wup%nums_occ,ii)+& &dble(wup%umat(ii-wup%nums_occ,vpp%ij(1,iw)))*vpp%vmat(iw,kw) enddo enddo enddo call free_memory(vpp) call free_memory(wup)!in this way only the data is deallocated write(stdout,*) 'addconduction_self_ontime1_4'!ATTENZIONE call flush_unit(stdout) if(options%w_divergence == 2) then call read_data_pw_v(vp,options%prefix,options%debug,0,.true.) else call read_data_pw_v(vp,options%prefix,options%debug,0,.false.) endif if(options%lnonorthogonal) then call read_data_pw_ortho_polaw(op,options%prefix) call orthonormalize_vpot(op,vp) endif call invert_v_pot(vp,vpi) call free_memory(vp) write(stdout,*) 'addconduction_self_ontime1_45' call distribute_v_pot(vpi,vpid) call free_memory(vpi) if(options%lnonorthogonal) then call invert_ortho_polaw(op,opi) write(stdout,*) 'addconduction_self_ontime1_5 op',op%numpw!ATTENZIONE call distribute_ortho_polaw(op,opd) call free_memory(op) write(stdout,*) 'addconduction_self_ontime1_6 opd',opd%numpw!ATTENZIONE call distribute_ortho_polaw(opi,opid) call free_memory(opi) endif l_blk= (ss%n+1)/nproc if(l_blk*nproc < (ss%n+1)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 -(ss%n+1) nend=nbegin+l_blk-1 if(nend > 0) nend = 0 write(stdout,*) 'addconduction_self_ontime5',nbegin,l_blk!ATTENZIONE call flush_unit(stdout) !loop on negative imaginary times do it=nbegin,nbegin+l_blk-1 if(it <= 0) then write(stdout,*) 'addconduction_self_ontime time', it!ATTENZIONE call flush_unit(stdout) !we take care of the symmetru t ==> -t call read_polaw(abs(it),ww,options%debug,options%l_verbose) write(stdout,*) 'addconduction_self_ontime6 ww', ww%numpw!ATTENZIONE if(options%lnonorthogonal) then call collect_ortho_polaw(opi,opid) write(stdout,*) 'dimensions', opi%numpw, opid%numpw call orthonormalize_inverse(opi,ww) call free_memory(opi) endif write(stdout,*) 'addconduction_self_ontime7'!ATTENZIONE allocate(wtemp(ww%numpw,ww%numpw)) call collect_v_pot(vpi,vpid) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,vpi%vmat,ww%numpw,ww%pw,ww%numpw,& &0.d0, wtemp,ww%numpw) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,wtemp,ww%numpw,vpi%vmat,ww%numpw,& &0.d0,ww%pw,ww%numpw) call free_memory(vpi) deallocate(wtemp) if(options%lnonorthogonal) then call collect_ortho_polaw(op,opd) call orthonormalize_inverse(op,ww) call free_memory(op) endif write(stdout,*) 'addconduction_self_ontime8'!ATTENZIONE call flush_unit(stdout) call read_green(it,gg,options%debug,.true.) allocate(gf_t(wup%nums-wup%nums_occ,wup%nums-wup%nums_occ)) do iw=1,(wup%nums-wup%nums_occ) do jw=1,(wup%nums-wup%nums_occ) gf_t(jw,iw)=gg%gf_p(jw+wup%nums_occ, iw+wup%nums_occ,1) enddo enddo do ii=i_first,ss%i_max write(stdout,*) 'II' , ii call flush_unit(stdout) allocate(qg(ww%numpw,wup%nums-wup%nums_occ)) call dgemm('N','N',ww%numpw,wup%nums-wup%nums_occ,wup%nums-wup%nums_occ,1.d0,& & cp(:,:,ii),ww%numpw,gf_t,wup%nums-wup%nums_occ,0.d0,qg,ww%numpw) allocate(pwcp_t(ww%numpw,wup%nums-wup%nums_occ)) call dgemm('N','N',ww%numpw,wup%nums-wup%nums_occ,ww%numpw,1.d0,& &ww%pw,ww%numpw,cp(:,:,ii),ww%numpw,0.d0,pwcp_t,ww%numpw) do iw=1,(wup%nums-wup%nums_occ) sene(it,ii-wup%nums_occ)=sene(it,ii-wup%nums_occ)+& &ddot(ww%numpw,qg(:,iw),1,pwcp_t(:,iw),1)*gg%factor*ww%factor enddo deallocate(pwcp_t) deallocate(qg) sene(it,ii-wup%nums_occ)=sene(it,ii-wup%nums_occ)*(0.d0,1.d0) if(it==0) sene(it,ii-wup%nums_occ)=sene(it,ii-wup%nums_occ)*0.5d0 write(stdout,*) 'Conduction contribution', it,ii, sene(it,ii-wup%nums_occ) enddo deallocate(gf_t) else if(options%lnonorthogonal) then call collect_ortho_polaw(opi,opid) call free_memory(opi) endif call collect_v_pot(vpi,vpid) call free_memory(vpi) if(options%lnonorthogonal) then call collect_ortho_polaw(op,opd) call free_memory(op) endif endif enddo call mp_sum(sene(-ss%n:0,:),world_comm) do ii=1,ss%i_max-wup%nums_occ do it=-ss%n,0 ss%diag(ii+wup%nums_occ,it+ss%n+1,1)=ss%diag(ii+wup%nums_occ, it+ss%n+1,1)+sene(it,ii) enddo enddo !!!!!!!!!!! call free_memory(vpid) if(options%lnonorthogonal) then call free_memory(opd) call free_memory(opi) call free_memory(opid) endif call free_memory_polaw(ww) call free_memory_green(gg) deallocate(cp) deallocate(sene) return END SUBROUTINE addconduction_self_ontime SUBROUTINE fft_storage_grid_fit(tf,ss) !this subroutine performs a FFT from time to frequency on the storage data !from W,P grid to fit grid !in case also for diagonal elements USE io_global, ONLY : stdout USE constants, ONLY : pi USE times_gw, ONLY : times_freqs implicit none TYPE(times_freqs), INTENT(in) :: tf!for time frequency grids TYPE(self_storage), INTENT(inout) :: ss!input data COMPLEX(kind=DP), DIMENSION(:), ALLOCATABLE :: tmpc COMPLEX(kind=DP), DIMENSION(:,:), ALLOCATABLE :: factors INTEGER :: ii,jj, is,js,kk INTEGER, PARAMETER :: nmesh=30 REAL(kind=DP) :: b_p,b_m,r_p,r_m COMPLEX(kind=DP) :: a_p,a_m, cor_1,cor_2 REAL(kind=DP), ALLOCATABLE :: x(:),w(:) COMPLEX(kind=DP), ALLOCATABLE :: fij(:,:), fp(:),fm(:) INTEGER :: ispin allocate(tmpc(2*tf%n+1)) allocate(factors(-tf%n:tf%n, -tf%n_grid_fit:tf%n_grid_fit)) !setup factors for every time position do ii=-tf%n_grid_fit, tf%n_grid_fit do jj=-tf%n,tf%n factors(jj,ii)=tf%weights_time(jj)*exp((0.d0,-1.d0)*tf%freqs_fit(ii)*tf%times(jj)) enddo factors(:,ii)=factors(:,ii)*(0.d0,-1.d0) enddo if(tf%l_fourier_fit_time .and. ss%ontime) then allocate(fij(-tf%n_grid_fit:tf%n_grid_fit,nmesh)) allocate(fp(nmesh),fm(nmesh)) allocate(x(nmesh),w(nmesh)) x(:)=0.d0 w(:)=0.d0 call legzo(nmesh,x,w) x(:)=x(:)*(tf%times(tf%n)-tf%tau)/2.d0 x(:)=x(:)+(tf%times(tf%n)-tf%tau)/2.d0+tf%tau w(:)=w(:)*(tf%times(tf%n)-tf%tau)/2.d0 do ii=-tf%n_grid_fit,tf%n_grid_fit do jj=1,nmesh fij(ii,jj)=exp((0.d0,-1.d0)*tf%freqs_fit(ii)*x(jj)) enddo enddo endif do ispin=1,ss%nspin do is=1,ss%max_i !transform do ii=-tf%n_grid_fit,tf%n_grid_fit do kk=-tf%n,tf%n tmpc(kk+tf%n+1)=ss%diag(is,kk+tf%n+1,ispin)*factors(kk,ii) enddo ss%diag_freq_fit(is,ii+tf%n_grid_fit+1,ispin)=sum(tmpc(1:2*tf%n+1)) enddo if(ss%whole_s) then do js=ss%i_min_whole,ss%i_max_whole do ii=-tf%n_grid_fit,tf%n_grid_fit do kk=-tf%n,tf%n tmpc(kk+tf%n+1)=ss%whole(js,is,kk+tf%n+1,ispin)*factors(kk,ii) enddo ss%whole_freq_fit(js,is,ii+tf%n_grid_fit+1,ispin)=sum(tmpc(1:2*tf%n+1)) enddo enddo endif if(tf%l_fourier_fit_time .and. ss%ontime) then r_p=dble(ss%diag(is,2*tf%n,1)/ss%diag(is,2*tf%n+1,1)) if(r_p <= 1.d0) r_p = tf%g_tau b_p=log(r_p)/(tf%times(tf%n)-tf%times(tf%n-1)) a_p=ss%diag(is,2*tf%n,1)/(exp(-b_p*tf%times(tf%n-1))) if(r_p == tf%g_tau) a_p=0.d0 if(abs(ss%diag(is,2,1)) > 1.d-10 .and. abs(ss%diag(is,1,1)) > 1.d-10) then r_m=dble(ss%diag(is,2,1)/ss%diag(is,1,1)) if(r_m <= 1.d0) r_m = tf%g_tau b_m=log(r_m)/(tf%times(-tf%n+1)-tf%times(-tf%n)) a_m=ss%diag(is,2,1)/(exp(b_m*tf%times(-tf%n+1))) if(r_m == tf%g_tau) a_m=0.d0 else r_m=0.d0 a_m=(0.d0,0.d0) b_m=0.d0 endif do jj=1,nmesh fp(jj)=a_p*exp(-b_p*x(jj))*w(jj) enddo if(r_m /=0.d0) then do jj=1,nmesh fm(jj)=a_m*exp(-b_m*x(jj))*w(jj) enddo endif do ii=-tf%n_grid_fit,tf%n_grid_fit cor_2=0.d0 do jj=1,nmesh cor_2=cor_2-fij(ii,jj)*fp(jj) if(r_m /=0.d0) then cor_2=cor_2-conjg(fij(ii,jj))*fm(jj) endif enddo cor_2=cor_2*(0.d0,-1.d0) ss%diag_freq_fit(is,ii+tf%n_grid_fit+1,1)=ss%diag_freq_fit(is,ii+tf%n_grid_fit+1,1)!-cor_2!+cor_1+cor_2 enddo endif enddo enddo if(tf%l_fourier_fit_time .and.ss%ontime) deallocate(fij,fp,fm,x,w) deallocate(tmpc) deallocate(factors) return END SUBROUTINE fft_storage_grid_fit SUBROUTINE addconduction_self_ontime_file(ss, tf ,options) !this subroutine adds to the self_energy of conduction states !on negative imaginary times, the part due to terms \Psi_c'\Psic\w_P !using terms from file USE io_global, ONLY : stdout, ionode USE input_gw, ONLY : input_options USE basic_structures, ONLY : v_pot,wannier_u,free_memory, ortho_polaw,initialize_memory,cprim_prod USE green_function, ONLY : green, read_green, free_memory_green, initialize_green USE polarization, ONLY : polaw, free_memory_polaw, read_polaw, invert_v_pot, invert_ortho_polaw,& & orthonormalize_inverse, initialize_polaw, orthonormalize_vpot, distribute_ortho_polaw, collect_ortho_polaw,& & distribute_v_pot, collect_v_pot USE mp, ONLY : mp_sum USE para_gww, ONLY : is_my_pola USE mp_world, ONLY : world_comm,nproc,mpime USE times_gw, ONLY : times_freqs implicit none TYPE(times_freqs), INTENT(in) :: tf!for time frequency grids TYPE(input_options) :: options TYPE(self_storage) :: ss TYPE(v_pot) :: vp,vpi,vpid TYPE(ortho_polaw) :: op,opi, opd, opid TYPE(polaw) :: ww!dressed interaction TYPE(wannier_u) :: wu!structure to be read and initialized TYPE(cprim_prod) :: cpp!the producs c' c' v wp INTEGER iw,jw,kw,it,ii,jj INTEGER :: l_blk, nbegin,nend REAL(kind=DP) :: offset COMPLEX(kind=DP), ALLOCATABLE :: sene(:,:) REAL(kind=DP), ALLOCATABLE:: wtemp(:,:), vtemp(:) REAL(kind=DP), EXTERNAL :: ddot LOGICAL :: ok_read nullify(vp%vmat) nullify(vpi%vmat) nullify(op%on_mat) nullify(opi%on_mat) nullify(opd%on_mat) nullify(opid%on_mat) nullify(vpid%vmat) nullify(wu%umat) call initialize_memory(cpp) call read_data_pw_u(wu, options%prefix) deallocate(wu%umat) if(.not.options%l_hf_energies) then if(wu%nums > wu%nums_occ(1)) then offset=-(wu%ene(wu%nums_occ(1)+1,1)+wu%ene(wu%nums_occ(1),1))/2.d0 else offset=-wu%ene(wu%nums_occ(1),1) endif else write(stdout,*) 'HF energies to be implemented YET' stop !if(wu%nums > wu%nums_occ(1)) then ! offset=-(ene_hf(wu%nums_occ(1)+1)+ene_hf(wu%nums_occ(1)))/2.d0 !else ! offset=-ene_hf(wu%nums_occ(1)) !endif endif call initialize_polaw(ww) write(stdout,*) 'addconduction_self_ontime_file1'!ATTENZIONE !read coulombian potential and calculate inverse if(ss%whole_s) then write(stdout,*) 'Whole s not implemented YET' stop endif if(options%w_divergence == 2) then call read_data_pw_v(vp,options%prefix,options%debug,0,.true.) else call read_data_pw_v(vp,options%prefix,options%debug,0,.false.) endif call read_data_pw_ortho_polaw(op,options%prefix) call orthonormalize_vpot(op,vp) call invert_v_pot(vp,vpi) call free_memory(vp) write(stdout,*) 'addconduction_self_ontime1_45' call distribute_v_pot(vpi,vpid) call free_memory(vpi) call invert_ortho_polaw(op,opi) write(stdout,*) 'addconduction_self_ontime1_5 op',op%numpw!ATTENZIONE call distribute_ortho_polaw(op,opd) call free_memory(op) write(stdout,*) 'addconduction_self_ontime1_6 opd',opd%numpw!ATTENZIONE call distribute_ortho_polaw(opi,opid) call free_memory(opi) l_blk= (ss%n+1)/nproc if(l_blk*nproc < (ss%n+1)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 -(ss%n+1) nend=nbegin+l_blk-1 if(nend > 0) nend = 0 write(stdout,*) 'addconduction_self_ontime5',nbegin,l_blk!ATTENZIONE call flush_unit(stdout) allocate(sene(-ss%n:0,options%i_min:options%i_max)) sene(:,:)=(0.d0,0.d0) !loop on negative imaginary times do it=nbegin,nbegin+l_blk-1 if(it <= 0) then write(stdout,*) 'addconduction_self_ontime time', it!ATTENZIONE !we take care of the symmetru t ==> -t call read_polaw(abs(it),ww,options%debug,options%l_verbose) write(stdout,*) 'addconduction_self_ontime6'!ATTENZIONE call flush_unit(stdout) call collect_ortho_polaw(opi,opid) write(stdout,*) 'addconduction_self_ontime6.1'!ATTENZIONE call orthonormalize_inverse(opi,ww) write(stdout,*) 'addconduction_self_ontime6.2'!ATTENZIONE call free_memory(opi) write(stdout,*) 'addconduction_self_ontime7'!ATTENZIONE call flush_unit(stdout) allocate(wtemp(ww%numpw,ww%numpw)) call collect_v_pot(vpi,vpid) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,vpi%vmat,ww%numpw,ww%pw,ww%numpw,& &0.d0, wtemp,ww%numpw) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,wtemp,ww%numpw,vpi%vmat,ww%numpw,& &0.d0,ww%pw,ww%numpw) call free_memory(vpi) deallocate(wtemp) call collect_ortho_polaw(op,opd) call orthonormalize_inverse(op,ww) call free_memory(op) !!now ww contains \tilde{ww} write(stdout,*) 'addconduction_self_ontime8'!ATTENZIONE call flush_unit(stdout) !read in cprim_prod !first multiplication !second multiplication !copy on sene !loop on c' states do ii=max(options%i_min,wu%nums_occ(1)+1),options%i_max cpp%cprim=ii call read_data_pw_cprim_prod(cpp, options%prefix,.false.,ok_read,.false.,.false.) !loop on c allocate(vtemp(cpp%numpw)) do jj=1,cpp%nums_cond !multiply W_ijS_jc =T_ic call dgemv('N',ww%numpw,ww%numpw,1.d0,ww%pw,ww%numpw,cpp%cpmat(:,jj),1,0.d0,vtemp,1) !multiply S_icTi_c sene(it,ii)=sene(it,ii)+ddot(cpp%numpw,vtemp,1,cpp%cpmat(:,jj),1)*& & exp((wu%ene(jj+wu%nums_occ(1),1)+offset)*tf%times(it))*ww%factor*(0.d0,-1.d0) enddo sene(it,ii)=sene(it,ii)*(0.d0,1.d0) if(it==0) sene(it,ii)=sene(it,ii)*0.5d0 write(stdout,*) 'Conduction contribution', it,ii, sene(it,ii) call flush_unit(stdout) deallocate(vtemp) enddo else call collect_ortho_polaw(opi,opid) call free_memory(opi) call collect_v_pot(vpi,vpid) call free_memory(vpi) call collect_ortho_polaw(op,opd) call free_memory(op) do ii=max(options%i_min,wu%nums_occ(1)+1),options%i_max cpp%cprim=ii call read_data_pw_cprim_prod(cpp, options%prefix,.false.,ok_read,.false.,.false.) enddo endif enddo call mp_sum(sene(-ss%n:0,:),world_comm) do ii=max(options%i_min,wu%nums_occ(1)+1),options%i_max do it=-ss%n,0 ss%diag(ii,it+ss%n+1,1)=ss%diag(ii, it+ss%n+1,1)+sene(it,ii) enddo enddo !copy sene results on ss with opportune factors !!!!!!!!!!! call free_memory(vpid) call free_memory(opd) call free_memory(opi) call free_memory(opid) call free_memory_polaw(ww) call free_memory( cpp) deallocate(sene) return END SUBROUTINE addconduction_self_ontime_file SUBROUTINE selfenergy_ontime_file(ss, tf ,options) !this subroutine calculates the self_energy of selected states !using terms from file or from strategy BETA USE io_global, ONLY : stdout, ionode USE input_gw, ONLY : input_options USE basic_structures, ONLY : v_pot,wannier_u,free_memory, ortho_polaw,initialize_memory,cprim_prod,q_mat,& & wannier_u_prim,v_pot_prim USE green_function, ONLY : green, read_green, free_memory_green, initialize_green USE polarization, ONLY : polaw, free_memory_polaw, read_polaw, invert_v_pot, invert_ortho_polaw,& & orthonormalize_inverse, initialize_polaw, orthonormalize_vpot, distribute_ortho_polaw, collect_ortho_polaw,& & distribute_v_pot, collect_v_pot USE mp, ONLY : mp_sum, mp_barrier USE para_gww, ONLY : is_my_pola USE mp_world, ONLY : world_comm,nproc,mpime USE times_gw, ONLY : times_freqs implicit none TYPE(times_freqs), INTENT(in) :: tf!for time frequency grids TYPE(input_options) :: options TYPE(self_storage) :: ss TYPE(v_pot) :: vp,vpi,vpid TYPE(ortho_polaw) :: op,opi, opd, opid TYPE(polaw) :: ww!dressed interaction TYPE(wannier_u) :: wu!structure to be read and initialized TYPE(cprim_prod) :: cpp,cppd!the producs c' c' v wp TYPE(q_mat) :: qm, qmd!for strategy beta TYPE(wannier_u_prim) :: wup!for strategy beta TYPE(v_pot_prim) :: vpp,vppd!for strategy beta INTEGER iw,jw,kw,it,ii,jj INTEGER :: l_blk, nbegin,nend REAL(kind=DP) :: offset COMPLEX(kind=DP), ALLOCATABLE :: sene(:,:) REAL(kind=DP), ALLOCATABLE:: wtemp(:,:), vtemp(:,:) REAL(kind=DP), EXTERNAL :: ddot LOGICAL :: ok_read nullify(vp%vmat) nullify(vpi%vmat) nullify(op%on_mat) nullify(opi%on_mat) nullify(opd%on_mat) nullify(opid%on_mat) nullify(vpid%vmat) nullify(wu%umat) nullify(wup%umat) nullify(vpp%vmat) call initialize_memory(cpp) call initialize_memory(cppd) if(options%l_self_beta) ok_read=.true. call read_data_pw_u(wu, options%prefix) if(.not.options%l_self_beta) deallocate(wu%umat) if(.not.options%l_hf_energies) then if(wu%nums > wu%nums_occ(1)) then offset=-(wu%ene(wu%nums_occ(1)+1,1)+wu%ene(wu%nums_occ(1),1))/2.d0 else offset=-wu%ene(wu%nums_occ(1),1) endif else write(stdout,*) 'HF energies to be implemented YET' stop !if(wu%nums > wu%nums_occ(1)) then ! offset=-(ene_hf(wu%nums_occ(1)+1)+ene_hf(wu%nums_occ(1)))/2.d0 !else ! offset=-ene_hf(wu%nums_occ(1)) !endif endif call initialize_polaw(ww) write(stdout,*) 'addconduction_self_ontime1'!ATTENZIONE call flush_unit(stdout) !read coulombian potential and calculate inverse if(ss%whole_s) then write(stdout,*) 'Whole s not implemented YET' stop endif if(options%w_divergence == 2) then call read_data_pw_v(vp,options%prefix,options%debug,0,.true.) else call read_data_pw_v(vp,options%prefix,options%debug,0,.false.) endif if(options%lnonorthogonal) then call read_data_pw_ortho_polaw(op,options%prefix) call orthonormalize_vpot(op,vp) endif call invert_v_pot(vp,vpi) call free_memory(vp) write(stdout,*) 'addconduction_self_ontime1_45' call flush_unit(stdout) call distribute_v_pot(vpi,vpid) call free_memory(vpi) if(options%lnonorthogonal) then call invert_ortho_polaw(op,opi) endif write(stdout,*) 'addconduction_self_ontime1_5 op',op%numpw!ATTENZIONE call flush_unit(stdout) if(options%lnonorthogonal) then call distribute_ortho_polaw(op,opd) call free_memory(op) write(stdout,*) 'addconduction_self_ontime1_6 opd',opd%numpw!ATTENZIONE call flush_unit(stdout) call distribute_ortho_polaw(opi,opid) call free_memory(opi) endif l_blk= (2*ss%n+1)/nproc if(l_blk*nproc < (2*ss%n+1)) l_blk = l_blk+1 nbegin=mpime*l_blk+1 -(ss%n+1) nend=nbegin+l_blk-1 if(nend > ss%n) nend = ss%n write(stdout,*) 'addconduction_self_ontime5',nbegin,l_blk!ATTENZIONE call flush_unit(stdout) allocate(sene(-ss%n:ss%n,options%i_min:options%i_max)) sene(:,:)=(0.d0,0.d0) !if required read and distribute q_mat if(options%l_self_beta) then call read_data_pw_q(qm,options%prefix,.true.) call distribute_qmat(qm,qmd) call free_memory(qm) if(options%i_max > wu%nums_occ(1)) then if(options%w_divergence == 2) then call read_data_pw_v_pot_prim(vpp,options%prefix, .true.) else call read_data_pw_v_pot_prim(vpp,options%prefix, .false.) endif call distribute_v_pot_prim(vpp,vppd) call free_memory(vpp) call read_data_pw_u_prim(wup,options%prefix) endif endif !loop on negative imaginary times do it=nbegin,nbegin+l_blk-1 if(it <= ss%n) then write(stdout,*) 'addconduction_self_ontime time', it!ATTENZIONE call flush_unit(stdout) !we take care of the symmetru t ==> -t call read_polaw(abs(it),ww,options%debug,options%l_verbose) write(stdout,*) 'addconduction_self_ontime6'!ATTENZIONE call flush_unit(stdout) if(options%lnonorthogonal) then call collect_ortho_polaw(opi,opid) write(stdout,*) 'addconduction_self_ontime6.1'!ATTENZIONE call orthonormalize_inverse(opi,ww) write(stdout,*) 'addconduction_self_ontime6.2'!ATTENZIONE call free_memory(opi) endif write(stdout,*) 'addconduction_self_ontime7'!ATTENZIONE call flush_unit(stdout) allocate(wtemp(ww%numpw,ww%numpw)) call collect_v_pot(vpi,vpid) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,vpi%vmat,ww%numpw,ww%pw,ww%numpw,& &0.d0, wtemp,ww%numpw) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,wtemp,ww%numpw,vpi%vmat,ww%numpw,& &0.d0,ww%pw,ww%numpw) call free_memory(vpi) deallocate(wtemp) if(options%lnonorthogonal) then call collect_ortho_polaw(op,opd) call orthonormalize_inverse(op,ww) call free_memory(op) endif !!now ww contains \tilde{ww} write(stdout,*) 'addconduction_self_ontime8'!ATTENZIONE call flush_unit(stdout) !read in cprim_prod !first multiplication !second multiplication !copy on sene !loop on c' states do ii=options%i_min,options%i_max cpp%cprim=ii call mp_barrier( world_comm ) if(.not.options%l_self_beta) then call read_data_pw_cprim_prod(cpp, options%prefix,.true.,ok_read,.false.,.false.) else !read qmat call create_vcprim(cppd, ii ,wu, qmd) if(ii>wu%nums_occ(1)) then !if required adds the conduction term call add_vcprim_conduction(cppd, wu, wup, vppd) end if call collect_cprim_prod(cpp,cppd) call free_memory(cppd) endif if(ok_read) then !loop on c allocate(vtemp(cpp%numpw,max(cpp%nums_occ,cpp%nums-cpp%nums_occ))) if(it <= 0) then call dgemm('N','N',ww%numpw,cpp%nums-cpp%nums_occ,ww%numpw,1.d0,ww%pw,ww%numpw,& & cpp%cpmat(:,cpp%nums_occ+1:cpp%nums),cpp%lda,0.d0,vtemp,ww%numpw) do jj=cpp%nums_occ+1,cpp%nums !multiply W_ijS_jc =T_ic ! call dgemv('N',ww%numpw,ww%numpw,1.d0,ww%pw,ww%numpw,cpp%cpmat(:,jj),1,0.d0,vtemp,1) !multiply S_icTi_c sene(it,ii)=sene(it,ii)+ddot(cpp%numpw,vtemp(:,jj-cpp%nums_occ),1,cpp%cpmat(:,jj),1)*& & exp((wu%ene(jj,1)+offset)*tf%times(it))*ww%factor*(0.d0,-1.d0) enddo sene(it,ii)=sene(it,ii)*(0.d0,1.d0) write(stdout,*) 'Conduction contribution', it,ii, sene(it,ii) call flush_unit(stdout) endif if(it >= 0) then call dgemm('N','N',ww%numpw,cpp%nums_occ,ww%numpw,1.d0,ww%pw,ww%numpw,& &cpp%cpmat(:,1:cpp%nums_occ),cpp%lda,0.d0,vtemp,ww%numpw) do jj=1,cpp%nums_occ !multiply W_ijS_jc =T_ic ! call dgemv('N',ww%numpw,ww%numpw,1.d0,ww%pw,ww%numpw,cpp%cpmat(:,jj),1,0.d0,vtemp,1) !multiply S_icTi_c sene(it,ii)=sene(it,ii)+ddot(cpp%numpw,vtemp(:,jj),1,cpp%cpmat(:,jj),1)*& & exp((wu%ene(jj,1)+offset)*tf%times(it))*ww%factor*(0.d0,+1.d0) enddo sene(it,ii)=sene(it,ii)*(0.d0,1.d0) write(stdout,*) 'Conduction contribution', it,ii, sene(it,ii) call flush_unit(stdout) endif if(it==0) sene(it,ii)=sene(it,ii)*0.5d0 deallocate(vtemp) endif enddo else if(options%lnonorthogonal) then call collect_ortho_polaw(opi,opid) call free_memory(opi) endif call collect_v_pot(vpi,vpid) call free_memory(vpi) if(options%lnonorthogonal) then call collect_ortho_polaw(op,opd) call free_memory(op) endif do ii=options%i_min,options%i_max cpp%cprim=ii call mp_barrier( world_comm ) if(.not.options%l_self_beta) then call read_data_pw_cprim_prod(cpp, options%prefix,.true.,ok_read,.false.,.false.) else !read qmat call create_vcprim(cppd, ii ,wu, qmd) if(ii>wu%nums_occ(1)) then !if required adds the conduction term call add_vcprim_conduction(cppd, wu, wup, vppd) end if call collect_cprim_prod(cpp,cppd) call free_memory(cppd) endif enddo endif enddo call mp_sum(sene(-ss%n:ss%n,:),world_comm) do ii=options%i_min,options%i_max do it=-ss%n,ss%n ss%diag(ii,it+ss%n+1,1)=ss%diag(ii, it+ss%n+1,1)+sene(it,ii) enddo enddo !copy sene results on ss with opportune factors !!!!!!!!!!! if(options%l_self_beta) call free_memory(qmd) if(options%l_self_beta .and. options%i_max > wu%nums_occ(1) ) then call free_memory(vppd) call free_memory(wup) endif call free_memory(vpid) if(options%lnonorthogonal) then call free_memory(opd) call free_memory(opi) call free_memory(opid) endif call free_memory_polaw(ww) call free_memory( cpp) call free_memory(cppd) call free_memory( wu) deallocate(sene) return END SUBROUTINE selfenergy_ontime_file SUBROUTINE selfenergy_ontime_upper(ss, tf ,options) !this subroutine calculates the self_energy of selected states USE io_global, ONLY : stdout, ionode USE input_gw, ONLY : input_options USE basic_structures, ONLY : v_pot,wannier_u,free_memory, ortho_polaw,initialize_memory,cprim_prod,q_mat,& & wannier_u_prim,v_pot_prim, upper_states USE green_function, ONLY : green, read_green, free_memory_green, initialize_green USE polarization, ONLY : polaw, free_memory_polaw, read_polaw, invert_v_pot, invert_ortho_polaw,& & orthonormalize_inverse, initialize_polaw, orthonormalize_vpot, distribute_ortho_polaw, collect_ortho_polaw,& & distribute_v_pot, collect_v_pot USE mp, ONLY : mp_sum USE para_gww, ONLY : is_my_pola USE mp_world, ONLY : world_comm,nproc,mpime USE times_gw, ONLY : times_freqs implicit none TYPE(times_freqs), INTENT(in) :: tf!for time frequency grids TYPE(input_options) :: options TYPE(self_storage) :: ss TYPE(v_pot) :: vp,vpi,vpid TYPE(ortho_polaw) :: op,opi, opd, opid TYPE(polaw) :: ww!dressed interaction TYPE(wannier_u) :: wu!structure to be read and initialized TYPE(cprim_prod) :: cpp,cppd!the producs c' c' v wp TYPE(upper_states) :: us INTEGER iw,jw,kw,it,ii,jj INTEGER :: l_blk, nbegin,nend REAL(kind=DP) :: offset COMPLEX(kind=DP), ALLOCATABLE :: sene(:,:) REAL(kind=DP), ALLOCATABLE:: wtemp(:,:), vtemp(:,:) REAL(kind=DP), EXTERNAL :: ddot LOGICAL :: ok_read nullify(vp%vmat) nullify(vpi%vmat) nullify(op%on_mat) nullify(opi%on_mat) nullify(opd%on_mat) nullify(opid%on_mat) nullify(vpid%vmat) nullify(wu%umat) call initialize_memory(cpp) call initialize_memory(cppd) call read_data_pw_u(wu, options%prefix) deallocate(wu%umat) call initialize_memory(us) call read_data_pw_upper_states(us,options%prefix) if(.not.options%l_hf_energies) then if(wu%nums > wu%nums_occ(1)) then offset=-(wu%ene(wu%nums_occ(1)+1,1)+wu%ene(wu%nums_occ(1),1))/2.d0 else offset=-wu%ene(wu%nums_occ(1),1) endif else write(stdout,*) 'HF energies to be implemented YET' stop !if(wu%nums > wu%nums_occ(1)) then ! offset=-(ene_hf(wu%nums_occ(1)+1)+ene_hf(wu%nums_occ(1)))/2.d0 !else ! offset=-ene_hf(wu%nums_occ(1)) !endif endif call initialize_polaw(ww) write(stdout,*) 'addconduction_self_upper1'!ATTENZIONE call flush_unit(stdout) !read coulombian potential and calculate inverse if(ss%whole_s) then write(stdout,*) 'Whole s not implemented YET' stop endif if(options%w_divergence == 2) then call read_data_pw_v(vp,options%prefix,options%debug,0,.true.) else call read_data_pw_v(vp,options%prefix,options%debug,0,.false.) endif if(options%lnonorthogonal) then call read_data_pw_ortho_polaw(op,options%prefix) call orthonormalize_vpot(op,vp) endif call invert_v_pot(vp,vpi) call free_memory(vp) write(stdout,*) 'addconduction_self_upper1_45' call flush_unit(stdout) call distribute_v_pot(vpi,vpid) call free_memory(vpi) if(options%lnonorthogonal) then call invert_ortho_polaw(op,opi) endif write(stdout,*) 'addconduction_self_upper1_5 op',op%numpw!ATTENZIONE call flush_unit(stdout) if(options%lnonorthogonal) then call distribute_ortho_polaw(op,opd) call free_memory(op) write(stdout,*) 'addconduction_self_upper_6 opd',opd%numpw!ATTENZIONE call flush_unit(stdout) call distribute_ortho_polaw(opi,opid) call free_memory(opi) endif l_blk= (ss%n+1)/nproc if(l_blk*nproc < (ss%n+1)) l_blk = l_blk+1 nbegin=mpime*l_blk + 1 - (ss%n+1) nend=nbegin+l_blk-1 if(nend > 0) nend = 0 write(stdout,*) 'addconduction_self_upper5',nbegin,l_blk!ATTENZIONE call flush_unit(stdout) allocate(sene(-ss%n:ss%n,options%i_min:options%i_max)) sene(:,:)=(0.d0,0.d0) !loop on negative imaginary times do it=nbegin,nbegin+l_blk-1 if(it <= ss%n) then write(stdout,*) 'addconduction_self_ontime time', it!ATTENZIONE call flush_unit(stdout) !we take care of the symmetru t ==> -t call read_polaw(abs(it),ww,options%debug,options%l_verbose) write(stdout,*) 'addconduction_self_upper6'!ATTENZIONE call flush_unit(stdout) if(options%lnonorthogonal) then call collect_ortho_polaw(opi,opid) write(stdout,*) 'addconduction_self_ontime6.1'!ATTENZIONE call orthonormalize_inverse(opi,ww) write(stdout,*) 'addconduction_self_ontime6.2'!ATTENZIONE call free_memory(opi) endif write(stdout,*) 'addconduction_self_upper7'!ATTENZIONE call flush_unit(stdout) allocate(wtemp(ww%numpw,ww%numpw)) call collect_v_pot(vpi,vpid) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,vpi%vmat,ww%numpw,ww%pw,ww%numpw,& &0.d0, wtemp,ww%numpw) call dgemm('N','N',ww%numpw,ww%numpw,ww%numpw,1.d0,wtemp,ww%numpw,vpi%vmat,ww%numpw,& &0.d0,ww%pw,ww%numpw) call free_memory(vpi) deallocate(wtemp) if(options%lnonorthogonal) then call collect_ortho_polaw(op,opd) call orthonormalize_inverse(op,ww) call free_memory(op) endif !!now ww contains \tilde{ww} write(stdout,*) 'addconduction_self_ontime8'!ATTENZIONE call flush_unit(stdout) !read in cprim_prod !first multiplication !second multiplication !copy on sene !loop on c' states do ii=options%i_min,options%i_max cpp%cprim=ii call read_data_pw_cprim_prod(cpp, options%prefix,.true.,ok_read,.false.,.true.) if(ok_read) then !loop on c allocate(vtemp(cpp%numpw,us%nums_reduced)) if(it <= 0) then call dgemm('N','N',ww%numpw,us%nums_reduced,ww%numpw,1.d0,ww%pw,ww%numpw,& & cpp%cpmat,cpp%lda,0.d0,vtemp,ww%numpw) do jj=1,us%nums_reduced !multiply W_ijS_jc =T_ic ! call dgemv('N',ww%numpw,ww%numpw,1.d0,ww%pw,ww%numpw,cpp%cpmat(:,jj),1,0.d0,vtemp,1) !multiply S_icTi_c sene(it,ii)=sene(it,ii)+ddot(cpp%numpw,vtemp(:,jj),1,cpp%cpmat(:,jj),1)*& & exp((us%ene(jj)+offset)*tf%times(it))*ww%factor*(0.d0,-1.d0) enddo sene(it,ii)=sene(it,ii)*(0.d0,1.d0) write(stdout,*) 'Conduction contribution', it,ii, sene(it,ii) call flush_unit(stdout) endif if(it >= 0) then endif if(it==0) sene(it,ii)=sene(it,ii)*0.5d0 deallocate(vtemp) endif enddo else if(options%lnonorthogonal) then call collect_ortho_polaw(opi,opid) call free_memory(opi) endif call collect_v_pot(vpi,vpid) call free_memory(vpi) if(options%lnonorthogonal) then call collect_ortho_polaw(op,opd) call free_memory(op) endif do ii=options%i_min,options%i_max cpp%cprim=ii call read_data_pw_cprim_prod(cpp, options%prefix,.true.,ok_read,.false.,.true.) enddo endif enddo call mp_sum(sene(-ss%n:ss%n,:),world_comm) do ii=options%i_min,options%i_max do it=-ss%n,ss%n ss%diag(ii,it+ss%n+1,1)=ss%diag(ii, it+ss%n+1,1)+sene(it,ii) enddo enddo !copy sene results on ss with opportune factors !!!!!!!!!!! call free_memory(vpid) if(options%lnonorthogonal) then call free_memory(opd) call free_memory(opi) call free_memory(opid) endif call free_memory_polaw(ww) call free_memory( cpp) call free_memory(cppd) call free_memory( wu) call free_memory(us) deallocate(sene) return END SUBROUTINE selfenergy_ontime_upper SUBROUTINE self_on_real_print(sr) !this subroutine writes on charcter file the !self energy on real axis USE io_global, ONLY : ionode USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(self_on_real) :: sr INTEGER :: is ,ii,ie,iun CHARACTER(5) :: nfile if(ionode) then !loop on spin do is=1,sr%nspin !loop on states do ii=sr%i_min,sr%i_max write(nfile,'(5i1)') & & ii/10000,mod(ii,10000)/1000,mod(ii,1000)/100,mod(ii,100)/10,mod(ii,10) !openfile iun = find_free_unit() if(is==1) then open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'self_on_real'// nfile, status='unknown',form='formatted') else open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'self_on_real'// nfile, status='unknown',form='formatted') endif do ie=1,sr%n write(iun,*) dble(sr%grid(ie)),dble(sr%diag(ie,ii,is)),dimag(sr%diag(ie,ii,is)) enddo close(iun) enddo enddo endif return END SUBROUTINE self_on_real_print SUBROUTINE self_on_real_value(sr,ii,ispin,energy,value,ierr) !this subroutine gives the self_energy at point energy (complex) using !linear extrapolation of real part only implicit none TYPE(self_on_real) :: sr INTEGER, INTENT(in) :: ii!KS state INTEGER, INTENT(in) :: ispin!spin channel COMPLEX(kind=DP), INTENT(in) :: energy COMPLEX(kind=DP), INTENT(out) :: value INTEGER, INTENT(out) :: ierr INTEGER :: ie REAL(kind=DP) :: delta,lun ierr=0 if(dble(sr%grid(1))>dble(energy) .or. dble(sr%grid(sr%n))uu%nums_occ(1)) then do iw=1,cpp%numpw_para v_mat(iw,i)=v_mat(iw,i)+qm%wp(iw)%o(ip)*dble(uu%umat(cpp%cprim,j,1)) enddo endif enddo endif !calculate Z_{\alpha j}=v_{\alpha, j'}U_{j,j'} allocate(u_mat(uu%nums,uu%nums)) u_mat(:,:)=dble(uu%umat(:,:,1)) call dgemm('N','T',cpp%numpw_para,uu%nums,uu%nums,1.d0,v_mat,cpp%numpw_para,u_mat,uu%nums,0.d0,cpp%cpmat,cpp%numpw_para) deallocate(u_mat,v_mat) return END SUBROUTINE create_vcprim SUBROUTINE add_vcprim_conduction(cpp, uu, up, vp) !this subroutine adds to the (v)cprim structure !the contribution from conduction states !starting from the strategy beta ! Z_{\alpha,iv}+=v_{\alpha,i'j'}U'_{i,i'}U_{j, j'} USE kinds, ONLY : DP USE basic_structures, ONLY : cprim_prod,wannier_u,wannier_u_prim,v_pot_prim USE io_global, ONLY : stdout implicit none TYPE(cprim_prod), INTENT(inout) :: cpp!the structure to be calaculated TYPE(wannier_u), INTENT(in) :: uu!for the energies and trasformation matrix TYPE(wannier_u_prim), INTENT(in) :: up!for the U'_{cc'} trasform TYPE(v_pot_prim), INTENT(in) :: vp! INTEGER :: i,j,k,ip, iw REAL(kind=DP), ALLOCATABLE :: v_mat(:,:),u_mat(:,:) if(cpp%cprim <= cpp%nums_occ) return if(cpp%numpw_para /= vp%numpw_para) then write(stdout,*) 'add_vcprim_conduction NOT CORRESPONDING' call flush_unit(stdout) stop endif !calculate V_{\alpha,v'}=\sum_i' v_{\alpha,i'v'}U_{i,i'} allocate(v_mat(cpp%numpw_para,cpp%nums)) v_mat(:,:)=0.d0 !WE ASSUME SAME ORDER do ip=1,vp%numpw_prim i=vp%ij(1,ip)! on c' j=vp%ij(2,ip)! on c do iw=1,cpp%numpw_para v_mat(iw,j)=v_mat(iw,j)+vp%vmat(ip,iw)*dble(up%umat(cpp%cprim-cpp%nums_occ,i)) enddo enddo !calculate Z_{\alpha j}+=v_{\alpha, j'}U_{j,j'} allocate(u_mat(uu%nums,uu%nums)) u_mat(:,:)=dble(uu%umat(:,:,1)) call dgemm('N','T',cpp%numpw_para,uu%nums,uu%nums,1.d0,v_mat,cpp%numpw_para,u_mat,uu%nums,1.d0,cpp%cpmat,cpp%numpw_para) deallocate(u_mat,v_mat) return END SUBROUTINE add_vcprim_conduction SUBROUTINE distribute_qmat(qm,qmd) !this subroutine distributes q_mat on parallel processors USE kinds, ONLY : DP USE basic_structures, ONLY : q_mat,wannier_P USE mp_world, ONLY : nproc,mpime implicit none TYPE(q_mat), INTENT(in) :: qm ! input q_mat TYPE(q_mat), INTENT(out) :: qmd ! output distributed q_mat INTEGER :: l_blk,nbegin,nend,ii !set up qmd qmd%numpw=qm%numpw qmd%is_parallel=.true. l_blk= qm%numpw/nproc if(l_blk*nproc < qm%numpw) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 if(nend > qm%numpw) nend = qm%numpw qmd%numpw_para=nend-nbegin+1 qmd%first_para=nbegin if(qmd%numpw_para>1) then allocate(qmd%wp(qmd%numpw_para)) do ii=1,qmd%numpw_para qmd%wp(ii)%numij=qm%wp(ii+qmd%first_para-1)%numij allocate(qmd%wp(ii)%ij(2,qmd%wp(ii)%numij)) qmd%wp(ii)%ij(:,:)=qm%wp(ii+qmd%first_para-1)%ij(:,:) allocate(qmd%wp(ii)%o(qmd%wp(ii)%numij)) qmd%wp(ii)%o(:)=qm%wp(ii+qmd%first_para-1)%o(:) enddo endif return END SUBROUTINE distribute_qmat SUBROUTINE collect_cprim_prod(cpp,cppd) !this subroutine collects the cprim structures from parallel processor USE kinds, ONLY : DP USE basic_structures, ONLY : cprim_prod, free_memory USE mp_world, ONLY : nproc,mpime, world_comm!group USE io_global, ONLY : stdout USE parallel_include implicit none TYPE(cprim_prod), INTENT(out) :: cpp!structure to be collected TYPE(cprim_prod), INTENT(in) :: cppd!distributed structures REAL(kind=DP), ALLOCATABLE :: sndbuf(:) INTEGER :: l_blk,ii, ierr !initializations call free_memory(cpp) cpp%cprim=cppd%cprim cpp%nums=cppd%nums cpp%nums_occ=cppd%nums_occ cpp%nums_cond=cpp%nums-cpp%nums_occ cpp%numpw=cppd%numpw cpp%is_parallel=.false. cpp%numpw_para=cpp%numpw cpp%first_para=1 if(.not.cppd%is_parallel) then write(stdout,*) 'collect_cprim_prod: NOT CORRESPONDING' call flush_unit(stdout) stop endif l_blk= cpp%numpw/nproc if(l_blk*nproc < cpp%numpw) l_blk = l_blk+1 allocate(cpp%cpmat(nproc*l_blk,cpp%nums)) cpp%lda=nproc*l_blk allocate(sndbuf(l_blk)) do ii=1,cpp%nums sndbuf(:)=0.d0 sndbuf(1:cppd%numpw_para)=cppd%cpmat(1:cppd%numpw_para,ii) #ifdef __PARA call MPI_ALLGATHER(sndbuf,l_blk,MPI_DOUBLE_PRECISION,cpp%cpmat(:,ii),l_blk,MPI_DOUBLE_PRECISION,& world_comm, ierr) #else cpp%cpmat(:,ii)=cppd%cpmat(:,ii) #endif enddo deallocate(sndbuf) return END SUBROUTINE collect_cprim_prod SUBROUTINE distribute_v_pot_prim(vp,vpd) !this subroutine distributes the structure v_pot_prim among processors !on the basis of the polarization USE kinds, ONLY : DP USE basic_structures, ONLY : v_pot_prim, free_memory USE mp_world, ONLY : nproc,mpime, world_comm!group USE io_global, ONLY : stdout USE parallel_include implicit none TYPE(v_pot_prim), INTENT(in) :: vp!structure to be distribute TYPE(v_pot_prim), INTENT(out) :: vpd!distribute structure INTEGER :: l_blk,nbegin,nend,ii !initializations vpd%numpw=vp%numpw vpd%numpw_prim=vp%numpw_prim vpd%is_parallel=.true. l_blk= vp%numpw/nproc if(l_blk*nproc < vp%numpw) l_blk = l_blk+1 nbegin=mpime*l_blk+1 nend=nbegin+l_blk-1 if(nend > vp%numpw) nend = vp%numpw vpd%numpw_para=nend-nbegin+1 vpd%first_para=nbegin allocate(vpd%ij(2,vp%numpw_prim)) vpd%ij(:,:)=vp%ij(:,:) allocate(vpd%vmat(vpd%numpw_prim,vpd%numpw_para)) do ii=1,vpd%numpw_para vpd%vmat(:,ii)=vp%vmat(:,ii+vpd%first_para-1) enddo return END SUBROUTINE distribute_v_pot_prim GWW/gww/input_gw.f900000644000077300007730000005472112341332532015001 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! MODULE input_gw !thsi module contain the definition and routines to read !input parameters from file USE kinds, ONLY: DP TYPE input_options !structure defining all the inputs required INTEGER :: n!number of time intervals in the positive or negative range, total of 2n+1 samples REAL(kind=DP) :: tau=0.d0!imaginary positive time interval LOGICAL :: whole_s=.false.!if .true. also off-diagonal elements of self energy are calculated INTEGER :: max_i!maximum state to be calculated CHARACTER(len=256) :: prefix = 'prefix'!prefix to designate the files same as in PW CHARACTER(len=256) :: outdir = './'!outdir to designate the files same as in PW INTEGER :: num_rows=50!number of rows of polarization to be taken together for FFT LOGICAL :: xc_together=.false.!if true exchange and correlation treated together, usually NOT LOGICAL :: debug=.false.!if .true. debug output is considered !the following options are for the fit INTEGER :: n_multipoles=2!number of poles used in the fit REAL(kind=DP) :: fit_dt!delta for verlet REAL(kind=DP) :: fit_thres=1.d-5!threshold for convergence REAL(kind=DP) :: fit_ma_0!mass paremeter for verlet REAL(kind=DP) :: fit_ma!mass paremeter for verlet REAL(kind=DP) :: fit_mb!mass paremeter for verlet REAL(kind=DP) :: fit_frice!frice for verlet INTEGER :: fit_maxiter=5000 !max number of iterations INTEGER :: starting_point=1!defines the starting point: 1-all 2-from polarization 3-from W 4-from Sigma !5-from fit... HAS BEEN CHANGED A BIT INTEGER :: ending_point=7!defines the ending point for faster remainder calculation LOGICAL :: use_contractions=.false.!if true perform contraction for calculating the self energy LOGICAL :: lnonorthogonal=.false.!if true a non orthogonal basis set is considered LOGICAL :: l_hf_energies=.false.! if true uses perturbative HF energies for calculating G and W INTEGER :: n_fit!number of time intervals in the positive or negative range to be used for fit INTEGER :: remainder=0!if 0 not remainder if 1,2 our remainders , 3 Chelikowsky COH remainder, 4 Chelikowsky !reaminder calculated in PW LOGICAL :: lconduction=.true.!if true accurate calculation of self_energy for conduction states LOGICAL :: l_remainder_cutoff=.false.!if true uses the reduced based for the remainder description LOGICAL :: l_contraction_single_state=.true.!if true write the contractions on disk state by state for saving memory !the following options are for the treatment of time/frequency with user defined grids LOGICAL :: l_fft_timefreq=.false.!if true performs usual fft treatment of time/frequency INTEGER :: grid_time=3!0 = Gauss Legendre 1 = Gauss Laguerre 2 Gauss Legendre 0-T 3 = equally spaced 0 centered 4 = equally spaced INTEGER :: grid_freq=3!0 = Gauss Legendre 1 = Gauss Laguerre 2 Gauss Legendre 0-T 3 = equally spaced 0 centered 4 = equally spaced 5=double equally spaced grid REAL(kind=DP) :: omega!max frequency if required ! the following for fitting tails LOGICAL :: l_fourier_fit_time=.false.!if true fits the tails in time LOGICAL :: l_fourier_fit_freq=.false.!if true fits the tails in frequency REAL(kind=DP) :: r_tau=0.d0!ratio for finding outer time point REAL(kind=DP) :: r_omega=0.d0!ratio for finding outer frequency point REAL(kind=DP) :: g_tau=0.d0!ratio for treating bad cases in time REAL(kind=DP) :: g_omega=0.d0!ration for treating bad cases in frequency !the following for defining the grid for fitting the self energy INTEGER :: grid_fit=1!grid for self energy ON FREQUENCY: 0 uses the same as for P,W, 1 equally spaced, 2 GL REAL(kind=DP) :: omega_fit!max frequency to be considered INTEGER :: n_grid_fit!number of grid points on half-axes !the following defines the range of states we want to studi INTEGER :: i_min!minimum state INTEGER :: i_max!maximum state INTEGER :: n_max_minpack=20000!maximum number of minpack iterations INTEGER :: cyc_minpack=1!number of minpack cycles LOGICAL :: l_lda_hartree=.true.!if true uses LDA previously calculated hartree, otherwise recalculate LOGICAL :: l_lda_exchange=.true.!if true uses LDA previously calculated exchange, otherwise recalculate LOGICAL :: l_read_exchange=.false.!force to read again exchange energies from disk LOGICAL :: l_symm_epsilon=.true.!if true calculates the symmetrized dielectric matrix for calculating W LOGICAL :: l_head_epsilon=.true.!if true the head of the symmetrized dielectric matrix is taken from !a RPA external calculation, OTHERWISE it's set to zero INTEGER :: w_divergence!treatment of G=0,G=0 divergence of W: 0 no treatment potentially wrong !1 W=v^1/2 Epsi^-1 v^1/2 with v truncated, 2 calculates terms from external file !3 Lanczos chain and Gygi Baldereschi algorithm LOGICAL :: l_wing_epsilon=.true.!if true the wings of the symmetrized dielectric matrix are taken from !a RPA external calculation, OTHERWISE it's set to zero INTEGER :: offset_fit=2!offset for fit from 0 LOGICAL :: lcprim_file=.false. !if true read S_{ c' c i} terms from file LOGICAL :: lvcprim_file=.true. !if truem read S_{ i, v,c i} terms from file LOGICAL :: l_dft_xc_file=.false.!if true read dft exchange and correlation energies from file LOGICAL :: lpola_file=.true.!if true calculates the polarization directly from the psi_v psi_c \tilde{w}^P_i file LOGICAL :: l_self_from_pola=.false.!if true calculates the self energies terms directly from the dresses polarization !and not from dress interaction NOW ONLY FOR polarization analysis, it requires !the wp_v file LOGICAL :: l_pola_beta=.false.!if true calculate the polarization with beta strategy (optimized) LOGICAL :: l_self_beta=.false.!if true calculate the self-energy with beta strategy (optimized) LOGICAL :: l_pola_upper=.false.!if true uses reduced conduction states for calculating the polarization LOGICAL :: l_self_upper=.false.!if true uses reduced conduction states for calculating the self-energy LOGICAL :: l_pola_lanczos=.true.!if true calculate the polarization through a lanczos scheme LOGICAL :: l_self_lanczos=.true.!if true calculate the self-energy through a lanczos scheme LOGICAL :: l_lanczos_conv=.true.!if the convolution is done analytically INTEGER :: n_set=100!block length over frequency in do_self_lanczos INTEGER :: n_set_ii=5!block length over KS states in do_self_lanczos INTEGER :: n_set_pola=4!block length over valence states in do_pola_lanczos INTEGER :: n_set_self=1!block length over frequency states in do_self_lanczos LOGICAL :: l_yet_pola=.false.!if true it assumes that (restarting at point 6) the !polaw's contain already the dress polarization LOGICAL :: l_reduce_io=.true. !if true reduces disk I/O !options for grid_freq=5 INTEGER :: second_grid_n=10!sub spacing for second grid INTEGER :: second_grid_i=1!max regular step using the second grid INTEGER :: grid_levels=1!for grid type = 6 LOGICAL :: l_t_wannier=.true.!if true t vectors have been constructed from wannier valence functions LOGICAL :: l_truncated_coulomb=.true.!if true the system is finite otherwise is extended (with head and wings) LOGICAL :: l_self_time=.true.!if true calculates the self energy in imaginary time LOGICAL :: l_g_grid=.false.!if true use a dedicated grid on frequency for G INTEGER :: grid_freq_g=3!for G grid:0 = Gauss Legendre 1 = Gauss Laguerre 2 Gauss Legendre 0-T 3 = equally spaced 0 centered 4 = equally spaced 5=double spaced grid INTEGER :: n_g!for G grid: number of time intervals in the positive or negative range, total of 2n+1 samples INTEGER :: second_grid_n_g=10!for G grid: sub spacing for second grid INTEGER :: second_grid_i_g=1!for G grid: max regular step using the second grid REAL(kind=DP) :: omega_g! for G: max frequency INTEGER :: i_min_whole=0!set the minimum of range for off diagonal elements of self-energy INTEGER :: i_max_whole=0!set the maximum of range for off diagonal elements of self-energy INTEGER :: nspin=1!spin multiplicity LOGICAL :: l_frac_occ=.false.!if true uses routines for fractional occupancy LOGICAL :: l_semicore=.false.!if true add to the self energy semicore terms LOGICAL :: l_order=.false.!just for gww_fit if true from file order.dat takes the right order of the self_energies LOGICAL :: l_verbose=.false. REAL(kind=DP) :: real_energy_min=-1.0!minimum energy on real frequency axis REAL(kind=DP) :: real_energy_max=1.0!maximum energy on real frequency axis INTEGER :: n_real_axis=0!number of grid points on real frequency axis LOGICAL :: l_big_system=.false.!if true calculate the self-energy state by state only through local s vectors LOGICAL :: l_list=.false.!if true uses startegy for large systems from list of states included in i_min im_max LOGICAL :: l_full=.false.!if true in points 6 calls routine for full relativistic calculations EXPERTS only INTEGER :: n_full=0!number of KS states with explicit treatment in G END TYPE input_options CONTAINS SUBROUTINE read_input_gww( ggwin ) !this subroutines reads the input structure from file !a namelist scheme is used USE io_global, ONLY : stdout, ionode, ionode_id USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : tmp_dir,outdir,prefix implicit none CHARACTER(LEN=256), EXTERNAL :: trimcheck INTEGER, EXTERNAL :: find_free_unit TYPE(input_options) :: ggwin!in output the input parameters INTEGER :: iun NAMELIST/inputgww/ ggwin !read namelist if(ionode) then iun=find_free_unit() !open(iun,file='inputgww') !read(iun, NML=inputgww) !close(iun) read(*, NML=inputgww) !OBM: file handling in a more QE manner IF ( TRIM( ggwin%outdir ) == ' ' ) ggwin%outdir = './' outdir = trimcheck(ggwin%outdir) tmp_dir = outdir prefix = trim(ggwin%prefix) !set up parameter for calculation with Lanczos scheme if(ggwin%l_self_lanczos.and.ggwin%l_lanczos_conv.and. .not. ggwin%l_self_time) then ggwin%grid_fit=1 ggwin%omega_fit=ggwin%omega ggwin%n_grid_fit=ggwin%n endif !writes on screen write(stdout,*) 'Number of intervals: ', ggwin%n write(stdout,*) 'Number of intervals for fit:', ggwin%n_fit if(ggwin%tau==0.d0) ggwin%tau=2.d0/ggwin%omega*dble(ggwin%n) write(stdout,*) 'Maximum imaginary time: ',ggwin%tau write(stdout,*) 'Print whole Sigma: ', ggwin%whole_s write(stdout,*) 'Maximum state considered:', ggwin%max_i write(stdout,*) 'Prefix:', trim(ggwin%prefix) write(stdout,*) 'Rows together in FFT:',ggwin%num_rows if(ggwin%use_contractions) write(stdout,*) 'Uses contraction' if(ggwin%lnonorthogonal) write(stdout,*) 'Ultralocalized generalized Wanniers are assumed' if(ggwin%l_hf_energies) write(stdout, *) ' Uses perturbative HF energies for G and W' if(ggwin%remainder == 1) write(stdout, *) ' Uses remainder for self-energy' if(ggwin%lconduction) write(stdout, *) 'Accurate treatment of conduction states' if(ggwin%l_remainder_cutoff) write(stdout,*) 'Uses reduced set for remainder' if(ggwin%l_contraction_single_state) write(stdout,*) 'Uses contractions on single states' if(.not.ggwin%l_fft_timefreq) then write(stdout,*) 'Uses no fft grid for time/space integrations' write(stdout,*) 'Time grid :', ggwin%grid_time write(stdout,*) 'Frequency grid :', ggwin%grid_freq write(stdout,*) 'Max frequency :', ggwin%omega if(ggwin%l_fourier_fit_time) then write(stdout,*) 'Uses fit of long tails in time' write(stdout,*) 'Ratio: Time', ggwin%r_tau write(stdout,*) 'Ratio recover: Time', ggwin%g_tau endif if(ggwin%l_fourier_fit_freq) then write(stdout,*) 'Uses fit of long tails in frequency' write(stdout,*) 'Ratio: Freq', ggwin%r_omega write(stdout,*) 'Ratio recover: Freq', ggwin%g_omega endif endif write(stdout,*) 'Consider states from:', ggwin%i_min, ' to ', ggwin%i_max write(stdout,*) 'Maximum number of iterations in minpack: ', ggwin%n_max_minpack write(stdout,*) 'Number of cycles over minpack: ', ggwin%cyc_minpack write(stdout,*) 'Uses LDA Hartree :', ggwin%l_lda_hartree write(stdout,*) 'Uses LDA Exchange :', ggwin%l_lda_exchange if(ggwin%l_read_exchange) write(stdout,*) 'ReREAD EXCHANGE FROM DISK' if(ggwin%l_symm_epsilon) write(stdout,*) 'Uses SYMMETRIZED DIELECTRIC MATRIX' if(ggwin%l_head_epsilon) write(stdout,*) 'Head of dielectric matrix from file' write(stdout,*) 'Treatment of W divergence:', ggwin%w_divergence if(ggwin%l_wing_epsilon) write(stdout,*) 'Wings of dielectric matrix from file' write(stdout,*) 'Offset fit :', ggwin%offset_fit if(ggwin%lcprim_file) write(stdout,*) 'Read cprim terms from file' if(ggwin%lvcprim_file) write(stdout,*) 'Read vcprim terms from file' if(ggwin%l_dft_xc_file) write(stdout,*) 'Read DFT XC from file' if(ggwin%lpola_file) write(stdout,*) 'Calculates the polarization directly from the overlaps' if(ggwin%l_self_from_pola) write(stdout,*) 'Calculates Self Energy from Dresses Polarization' if(ggwin%l_pola_beta) write(stdout,*) 'Calculate polarization with BETA strategy' if(ggwin%l_self_beta) write(stdout,*) 'Calculate self-energy with BETA strategy' if(ggwin%l_pola_upper) write(stdout,*) 'Reduced Upper states for Polarization' if(ggwin%l_self_upper) write(stdout,*) 'Reduced Upper states for Self-Energy' if(ggwin%l_pola_lanczos) write(stdout,*) 'Polarization Calculated through Lanczos scheme' if(ggwin%l_self_lanczos) write(stdout,*) 'Self-energy Calculated through Lanczos scheme' if(ggwin%l_lanczos_conv) write(stdout,*) 'Convolution done analytically' if(ggwin%l_self_lanczos) write(stdout,*) 'Block length fequency', ggwin%n_set if(ggwin%l_self_lanczos) write(stdout,*) 'Block length states', ggwin%n_set_ii if(ggwin%l_pola_lanczos) write(stdout,*) 'Block length valence states', ggwin%n_set_pola if(ggwin%l_self_lanczos) write(stdout,*) 'Block length fequency lc', ggwin%n_set_self if(ggwin%starting_point < 6 ) then ggwin%l_yet_pola=.false. else if(ggwin%l_self_lanczos) write(stdout,*) 'Dressed polarization already calculated' endif if(ggwin%l_reduce_io) write(stdout,*) 'Reduced disk I/O' if(ggwin%grid_freq==5) then write(stdout,*) 'Uses double grid, subdivisions:', ggwin%second_grid_n,' till :', ggwin%second_grid_i endif if(ggwin%l_t_wannier) write(stdout,*) 't vectors from Wannier products' if(ggwin%l_truncated_coulomb) then write(stdout,*) 'Use truncated Coulomb interaction' ggwin%w_divergence=0 ggwin%l_head_epsilon=.false. ggwin%l_wing_epsilon=.false. else write(stdout,*) 'Use truncated Extended interaction' ggwin%w_divergence=3 endif if(ggwin%l_self_time) write(stdout,*) 'Calculate Self-energy through FT' if(ggwin%l_g_grid) write(stdout,*) 'Uses dedicated grid for G' if(ggwin%whole_s) then if(ggwin%i_min_whole==0) ggwin%i_min_whole=ggwin%i_min if(ggwin%i_max_whole==0) ggwin%i_max_whole=ggwin%i_max write(stdout,*) 'Calculate off-diagonal elements in range:', ggwin%i_min_whole,ggwin%i_max_whole endif write(stdout,*) 'Spin multiplicity:', ggwin%nspin write(stdout,*) 'Partiallly occpuied states:', ggwin%l_frac_occ if(ggwin%l_semicore) write(stdout,*) 'Add semicore terms to self-energy' if(ggwin%n_real_axis /=0) then write(stdout,*) 'N of grid points on REAL frequency:', ggwin%n_real_axis write(stdout,*) 'REAL frequency range:', ggwin%real_energy_min,ggwin%real_energy_max endif if(ggwin%l_big_system) write(stdout,*) 'USING ONLY LOCAL S VECTORS' if(ggwin%l_list) write(stdout,*) 'FROM LIST' if(ggwin%l_full) write(stdout,*) 'FULL RELATIVISTIC CALCULATION with:', ggwin%n_full endif #ifdef __PARA CALL mp_bcast( outdir,ionode_id, world_comm ) CALL mp_bcast( tmp_dir,ionode_id, world_comm ) CALL mp_bcast( prefix,ionode_id, world_comm ) call mp_bcast(ggwin%n,ionode_id,world_comm) call mp_bcast(ggwin%tau,ionode_id,world_comm) call mp_bcast(ggwin%whole_s,ionode_id,world_comm) call mp_bcast(ggwin%max_i,ionode_id,world_comm) call mp_bcast(ggwin%prefix,ionode_id,world_comm) call mp_bcast(ggwin%num_rows,ionode_id,world_comm) call mp_bcast(ggwin%xc_together,ionode_id,world_comm) call mp_bcast(ggwin%debug, ionode_id,world_comm) call mp_bcast(ggwin%n_multipoles,ionode_id,world_comm) call mp_bcast(ggwin%fit_dt,ionode_id,world_comm) call mp_bcast(ggwin%fit_thres,ionode_id,world_comm) call mp_bcast(ggwin%fit_ma_0,ionode_id,world_comm) call mp_bcast(ggwin%fit_ma,ionode_id,world_comm) call mp_bcast(ggwin%fit_mb,ionode_id,world_comm) call mp_bcast(ggwin%fit_frice,ionode_id,world_comm) call mp_bcast(ggwin%fit_maxiter,ionode_id,world_comm) call mp_bcast(ggwin%starting_point, ionode_id,world_comm) call mp_bcast(ggwin%ending_point, ionode_id,world_comm) call mp_bcast(ggwin%use_contractions,ionode_id,world_comm) call mp_bcast(ggwin%lnonorthogonal, ionode_id,world_comm) call mp_bcast(ggwin%n_fit, ionode_id,world_comm) call mp_bcast(ggwin%l_hf_energies, ionode_id,world_comm) call mp_bcast(ggwin%remainder, ionode_id,world_comm) call mp_bcast(ggwin%lconduction, ionode_id,world_comm) call mp_bcast(ggwin%l_remainder_cutoff, ionode_id,world_comm) call mp_bcast(ggwin%l_contraction_single_state, ionode_id,world_comm) call mp_bcast(ggwin%l_fft_timefreq, ionode_id,world_comm) call mp_bcast(ggwin%grid_time, ionode_id,world_comm) call mp_bcast(ggwin%grid_freq, ionode_id,world_comm) call mp_bcast(ggwin%omega, ionode_id,world_comm) call mp_bcast(ggwin%l_fourier_fit_time, ionode_id,world_comm) call mp_bcast(ggwin%l_fourier_fit_freq, ionode_id,world_comm) call mp_bcast(ggwin%r_tau, ionode_id,world_comm) call mp_bcast(ggwin%r_omega, ionode_id,world_comm) call mp_bcast(ggwin%g_tau, ionode_id,world_comm) call mp_bcast(ggwin%g_omega, ionode_id,world_comm) call mp_bcast(ggwin%grid_fit, ionode_id,world_comm) call mp_bcast(ggwin%omega_fit, ionode_id,world_comm) call mp_bcast(ggwin%n_grid_fit, ionode_id,world_comm) call mp_bcast(ggwin%i_min, ionode_id,world_comm) call mp_bcast(ggwin%i_max, ionode_id,world_comm) call mp_bcast(ggwin%n_max_minpack, ionode_id,world_comm) call mp_bcast(ggwin%cyc_minpack, ionode_id,world_comm) call mp_bcast(ggwin%l_lda_hartree, ionode_id,world_comm) call mp_bcast(ggwin%l_lda_exchange, ionode_id,world_comm) call mp_bcast(ggwin%l_read_exchange, ionode_id,world_comm) call mp_bcast(ggwin%l_symm_epsilon, ionode_id,world_comm) call mp_bcast(ggwin%l_head_epsilon, ionode_id,world_comm) call mp_bcast(ggwin%w_divergence, ionode_id,world_comm) call mp_bcast(ggwin%l_wing_epsilon, ionode_id,world_comm) call mp_bcast(ggwin%offset_fit, ionode_id,world_comm) call mp_bcast(ggwin%lcprim_file, ionode_id,world_comm) call mp_bcast(ggwin%lvcprim_file, ionode_id,world_comm) call mp_bcast(ggwin%l_dft_xc_file, ionode_id,world_comm) call mp_bcast(ggwin%lpola_file, ionode_id,world_comm) call mp_bcast(ggwin%l_self_from_pola, ionode_id,world_comm) call mp_bcast(ggwin%l_pola_beta, ionode_id,world_comm) call mp_bcast(ggwin%l_self_beta, ionode_id,world_comm) call mp_bcast(ggwin%l_pola_upper, ionode_id,world_comm) call mp_bcast(ggwin%l_self_upper, ionode_id,world_comm) call mp_bcast(ggwin%l_pola_lanczos, ionode_id,world_comm) call mp_bcast(ggwin%l_self_lanczos, ionode_id,world_comm) call mp_bcast(ggwin%l_lanczos_conv, ionode_id,world_comm) call mp_bcast(ggwin%n_set, ionode_id,world_comm) call mp_bcast(ggwin%n_set_ii, ionode_id,world_comm) call mp_bcast(ggwin%n_set_pola, ionode_id,world_comm) call mp_bcast(ggwin%n_set_self, ionode_id,world_comm) call mp_bcast(ggwin%l_yet_pola, ionode_id,world_comm) call mp_bcast(ggwin%l_reduce_io, ionode_id,world_comm) call mp_bcast(ggwin%second_grid_n, ionode_id,world_comm) call mp_bcast(ggwin%second_grid_i, ionode_id,world_comm) call mp_bcast(ggwin%l_t_wannier, ionode_id,world_comm) call mp_bcast(ggwin%l_truncated_coulomb, ionode_id,world_comm) call mp_bcast(ggwin%l_self_time, ionode_id,world_comm) call mp_bcast(ggwin%l_g_grid, ionode_id,world_comm) call mp_bcast(ggwin%grid_freq_g, ionode_id,world_comm) call mp_bcast(ggwin%n_g, ionode_id,world_comm) call mp_bcast(ggwin%second_grid_n_g, ionode_id,world_comm) call mp_bcast(ggwin%second_grid_i_g, ionode_id,world_comm) call mp_bcast(ggwin%omega_g, ionode_id,world_comm) call mp_bcast(ggwin%i_min_whole, ionode_id,world_comm) call mp_bcast(ggwin%i_max_whole, ionode_id,world_comm) call mp_bcast(ggwin%nspin, ionode_id,world_comm) call mp_bcast(ggwin%l_frac_occ, ionode_id,world_comm) call mp_bcast(ggwin%l_semicore, ionode_id,world_comm) call mp_bcast(ggwin%l_order, ionode_id,world_comm) call mp_bcast(ggwin%l_verbose, ionode_id,world_comm) call mp_bcast(ggwin%n_real_axis, ionode_id,world_comm) call mp_bcast(ggwin%real_energy_min, ionode_id,world_comm) call mp_bcast(ggwin%real_energy_max, ionode_id,world_comm) call mp_bcast(ggwin%grid_levels, ionode_id,world_comm) call mp_bcast(ggwin%l_big_system, ionode_id,world_comm) call mp_bcast(ggwin%l_list, ionode_id,world_comm) call mp_bcast(ggwin%l_full, ionode_id,world_comm) call mp_bcast(ggwin%n_full, ionode_id,world_comm) #endif return END SUBROUTINE read_input_gww END MODULE GWW/gww/do_contour.f900000644000077300007730000000403512341332532015311 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !this subroutine add to the integral part of the self-energy the poles part SUBROUTINE do_contour(sr,wp,options) !NOT_TO_BE_INCLUDED_START USE contour, ONLY : w_poles, w_poles_value USE kinds, ONLY : DP USE self_energy_storage, ONLY : self_on_real USE basic_structures, ONLY : wannier_u,free_memory, initialize_memory USE input_gw, ONLY : input_options implicit none TYPE(self_on_real), INTENT(inout) :: sr TYPE(w_poles), INTENT(in) :: wp TYPE(input_options), INTENT(in) :: options TYPE(wannier_u) :: uu INTEGER :: ie,jj,ii,is COMPLEX(kind=DP) :: energy !reads KS eigen-energies call read_data_pw_u(uu,options%prefix) !loop on spin do is=1,sr%nspin !loop on real energy grid do ie=1,sr%n energy=sr%grid(ie) !divide by in valence and in conduction case if(dble(energy) <= uu%ene(uu%nums_occ(is),is)) then !consider valece states do jj=sr%i_min,uu%nums_occ(is)!ATTENZIONE !loop on poles !for selected poles add terms if(uu%ene(jj,is)>=dble(energy) )then do ii=sr%i_min,sr%i_max sr%diag(ie,ii,is)=sr%diag(ie,ii,is)-w_poles_value(uu%ene(jj,is)-energy,wp,jj,ii,is)!GIUSTO CUSSI' enddo endif enddo else do jj=uu%nums_occ(is)+1,sr%i_max !loop on poles !for selected poles add terms if(uu%ene(jj,is)<=dble(energy) )then do ii=sr%i_min,sr%i_max sr%diag(ie,ii,is)=sr%diag(ie,ii,is)+w_poles_value(uu%ene(jj,is)-energy,wp,jj,ii,is) enddo endif enddo endif enddo enddo call free_memory(uu) return !NOT_TO_BE_INCLUDED_END END SUBROUTINE do_contour GWW/gww/gww.f900000644000077300007730000002410112341332532013736 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !this is the main part of the GWW program PROGRAM gww USE input_gw, ONLY : input_options, read_input_gww USE io_global, ONLY : stdout, ionode USE self_energy_storage USE expansion USE energies_gww USE start_end USE mp_world, ONLY : mpime, world_comm USE para_gww USE times_gw USE w_divergence USE mp, ONLY : mp_barrier USE contour USE io_files, ONLY : prefix, tmp_dir implicit none TYPE(input_options) :: options TYPE(self_storage) :: ss TYPE(self_expansion) :: se TYPE(self_on_real) :: sr TYPE(quasi_particles) :: qp TYPE(times_freqs) :: tf TYPE(gv_time) :: gt TYPE(w_expectation) :: we TYPE(w_poles) :: wp INTEGER :: ispin CHARACTER(5) :: name_proc INTEGER :: ie REAL(kind=DP) :: energy #ifdef __OPENMP INTEGER :: omp_get_num_threads, omp_get_max_threads EXTERNAL omp_set_num_threads, omp_get_num_threads, omp_get_max_threads #endif tmp_dir='' !setup MPI environment call startup !CALL remove_stack_limit ( ) #ifdef __OPENMP ntids=omp_get_max_threads() ! call omp_set_num_threads(1) #endif #ifdef __OPENMP write(stdout,*) 'ntids = ', ntids #endif !initialize arrays call initialize_quasi_particle(qp) ! read in input structure call read_input_gww(options) #ifdef __MPI if(options%l_verbose) then write(name_proc,'(5i1)') & & (mpime+1)/10000,mod(mpime+1,10000)/1000,mod(mpime+1,1000)/100,mod(mpime+1,100)/10,mod(mpime+1,10) OPEN( UNIT = stdout, FILE = trim(tmp_dir)//trim(prefix)//'-out_'//name_proc, STATUS = 'UNKNOWN' ) else if(.not.ionode) OPEN ( unit = stdout, file='/dev/null', status='unknown' ) endif #endif call flush_unit(stdout) if(options%grid_freq/=5.and.options%grid_freq/=6) then call setup_para_gww(options%n, options%max_i, options%i_min, options%i_max) else call setup_para_gww(options%n+(1+2*options%second_grid_i)*options%second_grid_n, options%max_i, options%i_min, options%i_max) endif call flush_unit(stdout) ! setup time/frequency grid if required call setup_timefreq(tf,options) !Step 0 !calculates the exchange energies if(options%starting_point <=1) then call go_exchange_main( options, qp) call write_quasi_particles(qp, options,.false.) else if(options%starting_point >= 6 .and. (options%remainder==3 .or. options%remainder==4)) then call read_quasi_particles(qp,options,.true.) else call read_quasi_particles(qp,options,.false.) endif endif !Step 1 !create the Green function G_0 in imaginary time and save on file !it also calculates here the exchage energies if(options%starting_point <= 1 .and. options%ending_point >= 1) then if(.not.options%lpola_file .and. .not. options%lvcprim_file) then call go_green(tf,options, qp) endif endif !Step 2 !create the polarization in imaginary time and save on file !loop on spin do ispin=1,options%nspin if(options%starting_point <= 2 .and. options%ending_point >=2 ) then if(options%l_t_wannier) then call calculate_compact_pola_lanczos(options,ispin) endif endif if(options%starting_point <= 3 .and. options%ending_point >= 3 ) then write(stdout,*) "*******************************" write(stdout,*) " RESTART FROM POINT 3" write(stdout,*) "*******************************" !Step 3 !FFT of polarization to imaginary frequency and save on file call do_polarization_lanczos(tf,options,ispin) endif enddo if(options%starting_point<=4 .and. options%ending_point >= 4) then !Step 3.1 !calculate dresses interaction W, and save on file write(stdout,*) 'Call go_dressed_w' call go_dressed_w(options) if(options%remainder==4) call create_dressed_polarization( options) if(options%remainder==3 .or. options%remainder==4) then call remainder(options, qp) call write_quasi_particles(qp,options,.true.) else call write_quasi_particles(qp,options,.false.) endif endif !Step 3.2 !FFT of W to imaginary time and save on file if(options%starting_point<=5 .and. options%ending_point >= 5) then if(options%remainder==3.or.options%remainder==4) then call read_quasi_particles(qp,options,.true.) else call read_quasi_particles(qp,options,.false.) endif if(.not. options%l_self_lanczos) then write(stdout,*) 'Call FFT' call go_fft_para2(tf, options) !if required do fft of gt structure if(options%w_divergence==2) then write(stdout,*) 'Go fft gt' call initialize_gv_time(gt) write(stdout,*) 'Go fft gt 1' call read_gv_time(gt) write(stdout,*) 'Go fft gt 1.5' call fft_gv_time(gt,tf) write(stdout,*) 'Go fft gt2' call write_gv_time(gt) write(stdout,*) 'Go fft gt3' call free_memory_gv_time(gt) endif else call do_reducible_pola(tf ,options) endif endif if(options%starting_point <= 6 .and. options%ending_point >= 6) then !Step 4 write(stdout,*) '*******************************' write(stdout,*) ' RESTART FROM POINT 6' write(stdout,*) '*******************************' if(options%n_real_axis>0) then call initialize_w_expectation(we) call create_w_expectation(we, tf, options) call write_w_expectation(we) call free_memory_w_expectation(we) endif if(.not. options%l_self_lanczos) then !calculate the expectation value of Sigma in imaginary time and save on file call create_self_ontime(tf, ss,options,qp) if(options%lconduction.and. .not.options%lvcprim_file .and. .not.options%l_self_beta) then if(.not.options%lcprim_file) then call addconduction_self_ontime(ss, options) else call addconduction_self_ontime_file(ss, tf, options) endif endif if(options%l_self_upper) then call selfenergy_ontime_upper(ss, tf ,options) endif if(options%debug) call write_storage(tf,ss) if(options%l_fft_timefreq) then call fft_storage(ss) else if(tf%grid_fit==0) then call fft_storage_grid(tf,ss) else call fft_storage_grid_fit(tf, ss) endif endif if(options%debug) call write_storage(tf,ss) call write_self_storage_ondisk(ss, options) else !lanczos calculation of self-energy if(options%n_real_axis==0) then if(.not.options%l_self_time) then call do_self_lanczos(ss, tf ,options) else if(.not.options%l_full) then call do_self_lanczos_time(ss, tf ,options,.false.,0.d0) else call do_self_lanczos_full(ss, tf ,options,.false.,0.d0) endif call fft_storage_grid_fit(tf, ss) endif call write_self_storage_ondisk(ss, options) else call do_self_on_real(options,tf,ss,sr) call write_self_on_real(sr,0) call free_memory_self_on_real(sr) endif call write_self_storage_ondisk(ss, options) endif endif if(options%starting_point <= 7 .and. options%ending_point >= 7) then !Step 7 ! fit self_energy with a multipole expansion call read_self_storage_ondisk(ss, options) !call set_remainder(ss, qp) call create_self_energy_fit( tf, se, ss, options,sr,.false.) call mp_barrier( world_comm ) call print_fit_onfile(tf, se,ss) call mp_barrier( world_comm ) call free_memory_self_storage(ss) call mp_barrier( world_comm ) call create_quasi_particles(options,qp,se) call mp_barrier( world_comm ) call write_self_expansion(se) call free_memory_self_expansion(se) call mp_barrier( world_comm ) call printout_quasi_particles(qp) endif if(options%starting_point <= 8 .and. options%ending_point >= 8) then !if the whole self_energy matrix has been calculate do use it for obtaining QPEs and QPAs if(options%whole_s) then call initialize_self_expansion(se) call read_self_expansion(se) call create_quasi_particles_off(options,qp,se) call printout_quasi_particles_off(qp) call free_memory_self_expansion(se) endif endif if(options%starting_point <= 9 .and. options%ending_point >= 9) then !here does analytic continuation for contour integration call initialize_w_expectation(we) call initialize_w_poles(wp) call read_w_expectation(we) call create_w_poles(we,wp,options) call write_w_poles(wp) call free_memory_w_expectation(we) call free_memory_w_poles(wp) endif if(options%starting_point <= 10 .and. options%ending_point >= 10) then !adds poles call initialize_w_poles(wp) call initialize_self_on_real(sr) call read_w_poles(wp) call read_self_on_real(sr,0) !call self_on_real_print(sr) !NOT_TO_BE_INCLUDED_START call do_contour(sr,wp,options) !NOT_TO_BE_INCLUDED_END call write_self_on_real(sr,1) call self_on_real_print(sr) call free_memory_w_poles(wp) call free_memory_self_on_real(sr) endif if(options%starting_point <= 11 .and. options%ending_point >= 11) then call initialize_self_on_real(sr) call read_self_on_real(sr,1) call create_quasi_particle_on_real(options,qp,sr) call printout_quasi_particles(qp) call free_memory_self_on_real(sr) endif !stops MPI call free_memory_times_freqs(tf) call free_memory_para_gww call stop_run stop END PROGRAM gww GWW/gww/create_quasi_particle_off.f900000644000077300007730000001631512341332532020324 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! SUBROUTINE create_quasi_particles_off(options,qp,se) !given the expansion coeffcients, calculates in a perturbative !way without self-consistency correction the quasi-particles energies !using the whole self_energy matrix included the off-diagonal terms !relavant arrays are already allocates and set by subroutine create USE io_global, ONLY : stdout USE basic_structures, ONLY : wannier_u, free_memory USE expansion, ONLY : self_expansion, value_on_frequency, derivative_on_frequency,value_on_frequency_complex_off USE input_gw, ONLY : input_options USE constants, ONLY : tpi, RYTOEV USE energies_gww, ONLY : quasi_particles USE kinds, ONLY : DP implicit none TYPE(input_options) :: options! for prefix TYPE(quasi_particles) :: qp!the descriptor to be build TYPE(self_expansion) :: se!the descriptor for the multipole expansion INTEGER :: ii,jj,kk, it,is TYPE(wannier_u) :: uu COMPLEX(kind=DP) :: om REAL(kind=DP) :: offset,sca,norm COMPLEX(kind=DP), ALLOCATABLE :: amp(:),hmat(:,:),hval(:),hvec(:,:) INTEGER :: lwork,info COMPLEX(kind=DP), ALLOCATABLE :: work(:) REAL(kind=DP), ALLOCATABLE :: rwork(:) INTEGER :: ivec INTEGER :: ilo,ihi REAL(kind=DP), ALLOCATABLE :: scale(:),rconde(:),rcondv(:) REAL(kind=DP) :: abnrm if(.not.options%whole_s) return !allocate and set up off diagonal arrays qp%whole_s=.true. allocate(qp%ene_gw_off(qp%max_i,qp%nspin)) allocate(qp%eigen_gw_off(qp%max_i,qp%max_i,qp%nspin)) allocate(qp%ene_dft_xc_off(qp%max_i,qp%max_i,qp%nspin)) allocate(qp%ene_x_off(qp%max_i,qp%max_i,qp%nspin)) !read in DFT energies !read in whole dft xc and Fock X matrices call read_data_pw_u(uu,options%prefix) call read_data_pw_exchange_off(qp%ene_x_off,qp%max_i,options%prefix,qp%nspin) do is=1,qp%nspin call read_data_pw_dft_xc_off(qp%ene_dft_xc_off(1,1,is),qp%max_i,options%prefix,is) enddo !allocate arrays allocate(amp(qp%max_i)) allocate(hmat(qp%max_i,qp%max_i),hvec(qp%max_i,qp%max_i),hval(qp%max_i)) !loop on spin do is=1,uu%nspin if(uu%nums > uu%nums_occ(is)) then offset=-(uu%ene(uu%nums_occ(is)+1,is)+uu%ene(uu%nums_occ(is),is))/2.d0 else offset=-uu%ene(uu%nums_occ(is),is) endif ! call free_memory(uu) do ii=1,qp%max_i !set up starting complex energy and amplitude om=dcmplx(qp%ene_dft_ks(ii,is)+offset,0.d0) amp(:)=(0.d0,0.d0) amp(ii)=(1.d0,0.d0) !self-consistency loop do it=1,10 !set up hamiltonian like matrix !self_energy hmat=(0.d0,0.d0) do jj=1,qp%max_i do kk=1,qp%max_i call value_on_frequency_complex_off(se,kk,jj,om,hmat(kk,jj),is) enddo enddo !H0 do jj=1,qp%max_i hmat(jj,jj)=hmat(jj,jj)+qp%ene_dft_ks(jj,is)+offset enddo hmat(1:qp%max_i,1:qp%max_i)=hmat(1:qp%max_i,1:qp%max_i)-qp%ene_dft_xc_off(1:qp%max_i,1:qp%max_i,is) hmat(1:qp%max_i,1:qp%max_i)=hmat(1:qp%max_i,1:qp%max_i)+qp%ene_x_off(1:qp%max_i,1:qp%max_i,is) !find eigenvalues/vectors !for compatibility with essl on aix it must use zgeevx instead (sigh) ! allocate(rwork(2*qp%max_i)) ! allocate(work(1)) ! call ZGEEV('N','V',qp%max_i,hmat,qp%max_i,hval,hvec,qp%max_i,hvec,qp%max_i,work,-1,rwork,info) ! if(info/=0) then ! write(stdout,*) 'Problems with ZGEEV:', info ! call flush_unit(stdout) ! stop ! endif ! lwork=int(work(1)) ! deallocate(work) ! allocate(work(lwork)) ! call ZGEEV('N','V',qp%max_i,hmat,qp%max_i,hval,hvec,qp%max_i,hvec,qp%max_i,work,lwork,rwork,info) ! if(info/=0) then ! write(stdout,*) 'Problems with ZGEEV:', info ! call flush_unit(stdout) ! stop ! endif ! deallocate(work) ! deallocate(rwork) allocate(scale(qp%max_i),rconde(qp%max_i),rcondv(qp%max_i)) allocate(rwork(2*qp%max_i)) allocate(work(1)) call zgeevx('N','N','V','N',qp%max_i,hmat,qp%max_i,hval,hvec,qp%max_i,hvec,qp%max_i,ilo,ihi,scale,& &abnrm,rconde,rcondv,work,-1,rwork,info) if(info/=0) then write(stdout,*) 'Problems with ZGEEVX:', info call flush_unit(stdout) stop endif lwork=int(work(1)) deallocate(work) allocate(work(lwork)) call zgeevx('N','N','V','N',qp%max_i,hmat,qp%max_i,hval,hvec,qp%max_i,hvec,qp%max_i,ilo,ihi,scale,& &abnrm,rconde,rcondv,work,lwork,rwork,info) if(info/=0) then write(stdout,*) 'Problems with ZGEEVX:', info call flush_unit(stdout) stop endif deallocate(work) deallocate(rwork) deallocate(scale,rconde,rcondv) !print eigenvalues do jj=1,qp%max_i write(stdout,*) 'COMPLEX EN:',jj,is,it,hval(jj) enddo call flush_unit(stdout) !find the vector most close to the previous one norm=0.d0 ivec=1 do jj=1,qp%max_i sca=0.d0 do kk=1,qp%max_i sca=sca+conjg(hvec(kk,jj))*amp(kk)+hvec(kk,jj)*conjg(amp(kk)) enddo if(sca>norm) then norm=sca ivec=jj endif enddo !update energy and amplitude write(stdout,*) 'NEW VECTOR INDEX', ivec om=hval(ivec) amp(1:qp%max_i)=hvec(1:qp%max_i,ivec) enddo!iterations !put final results on qp object qp%ene_gw_off(ii,is)=om-offset qp%eigen_gw_off(1:qp%max_i,ii,is)=amp(1:qp%max_i) enddo!states enddo!spin call free_memory(uu) deallocate(amp,hmat,hval,hvec) return END SUBROUTINE create_quasi_particles_off GWW/gww/self_energy.f900000644000077300007730000003042512341332532015442 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! SUBROUTINE self_energy(i,j,sene,time,qm,uu,gf,ww) !this subroutine calculates the terms, in imaginary time !<\Psi_i|\Sigma(it)|\Psi_j> !=O^{P}_n,kl G_{lm}W_{n,o} O^{P}_o,mp U_ki U^{+}_j,p USE kinds, ONLY : DP USE io_global, ONLY : stdout USE basic_structures, ONLY : wannier_u, q_mat USE green_function, ONLY : green USE polarization, ONLY : polaw implicit none INTEGER :: i,j !which element of self enrgy to be calculated COMPLEX(kind=DP) :: sene!self energy element REAL(kind=DP) :: time!in output time correspondig to the calculated self energy TYPE(q_mat) :: qm!descriptors of overlaps of othonormalized wannier producs with wannier products TYPE(wannier_u) :: uu!descriptor of transformation matrix from KS states to wanniers TYPE(green) :: gf!descriptor of green function TYPE(polaw) :: ww!descriptor of dressed interaction INTEGER :: k,l,m,n,o,p INTEGER :: nw,ow REAL(kind=DP) :: o_n,o_o !check consistency if(.not.gf%ontime ) then write(stdout,*) 'Routine self_energy: imaginary times GF required' stop endif if(.not.ww%ontime) then write(stdout,*) 'Routine self_energy: imaginary times WW required' ! stop endif !the following has been commented for using with remainder calculation ! if(gf%time /= ww%time) then ! write(stdout,*) 'Routine self_energy: same imaginary times required' ! stop ! endif if(gf%nums /= uu%nums) then write(stdout,*) 'Routine self_energy: same nums required' stop endif if(qm%numpw /= ww%numpw) then write(stdout,*) 'Routine self_energy: same numpw required' stop endif time=ww%time sene=(0.d0,0.d0) do n=1,ww%numpw!loop on orthonormalized wannier products do o=1,ww%numpw!loop on orthonormalized wannier products do nw=1,qm%wp(n)%numij do ow=1,qm%wp(o)%numij k=qm%wp(n)%ij(1,nw) l=qm%wp(n)%ij(2,nw) m=qm%wp(o)%ij(1,ow) p=qm%wp(o)%ij(2,ow) o_n=qm%wp(n)%o(nw) o_o=qm%wp(o)%o(ow) sene=sene+o_n*gf%gf(l,m,1)*ww%pw(n,o)*o_o*conjg(uu%umat(i,k,1))*uu%umat(j,p,1) if(k/=l) then sene=sene+o_n*gf%gf(k,m,1)*ww%pw(n,o)*o_o*conjg(uu%umat(i,l,1))*uu%umat(j,p,1) endif if(m/=p) then sene=sene+o_n*gf%gf(l,p,1)*ww%pw(n,o)*o_o*conjg(uu%umat(i,k,1))*uu%umat(j,m,1) endif if(m/=p .AND. k/=l ) then sene=sene+o_n*gf%gf(k,p,1)*ww%pw(n,o)*o_o*conjg(uu%umat(i,l,1))*uu%umat(j,m,1) endif end do enddo enddo enddo sene=sene*(0.d0,1.d0) return END SUBROUTINE SUBROUTINE self_energy_contraction(i,j,sene,time,cr,gf,ww) !this subroutine calculates the terms, in imaginary time using contraction array !<\Psi_i|\Sigma(it)|\Psi_j> !G_{lm}W_{n,o} Q^{P}_{n,l,i}*conjg(Q^{P}_{o,m,j} USE kinds, ONLY : DP USE io_global, ONLY : stdout USE compact_product USE green_function, ONLY : green USE polarization, ONLY : polaw implicit none INTEGER :: i,j !which element of self enrgy to be calculated COMPLEX(kind=DP) :: sene!self energy element REAL(kind=DP) :: time!in output time correspondig to the calculated self energy TYPE(contraction) :: cr!description of contracted terms TYPE(green) :: gf!descriptor of green function TYPE(polaw) :: ww!descriptor of dressed interaction COMPLEX(kind=DP), ALLOCATABLE :: qg(:,:)!for the product Q^{P}_{n,l,i}G{l,m} INTEGER :: k,l,m,n,o,p !check consistency if(.not.gf%ontime) then write(stdout,*) 'Routine self_energy: imaginary times GF required' stop endif if(.not.ww%ontime) then write(stdout,*) 'Routine self_energy: imaginary times WW required' ! stop endif !the following has been commented for remainder calculation ! if(gf%time /= ww%time) then ! write(stdout,*) 'Routine self_energy: same imaginary times required' ! stop ! endif if(gf%nums /= cr%nums) then write(stdout,*) 'Routine self_energy: same nums required' stop endif if(cr%numpw /= ww%numpw) then write(stdout,*) 'Routine self_energy: same numpw required' stop endif allocate(qg(cr%numpw,cr%nums)) qg(:,:)=(0.d0,0.d0) do n=1,cr%numpw!loop on orthonormalized wannier products do m=1,cr%nums do l=1,cr%numl(n) qg(n,m)=qg(n,m)+cr%q(n,l,i)*gf%gf(cr%l(l,n),m,1) enddo enddo enddo sene=(0.d0,0.d0) do n=1,cr%numpw!loop on orthonormalized wannier products do o=1,cr%numpw!loop on orthonormalized wannier products do m=1,cr%numl(o) sene=sene+qg(n,cr%l(m,o))*ww%pw(n,o)*conjg(cr%q(o,m,j)) enddo enddo enddo ! if(sene==0.d0) write(*,*) 'OPS', i time=ww%time sene=sene*(0.d0,1.d0) deallocate(qg) return END SUBROUTINE SUBROUTINE self_energy_remainder(i,rem,time,wp,ww) !this subroutine calculates the remainders for negative imaginary time !<\Psi_i|\Sigma(it)|\Psi_j> !=Sigma^R_v(it)=\sum wwp(i,j,v)ww(i,j,it) USE kinds, ONLY : DP USE io_global, ONLY : stdout USE basic_structures, ONLY : wp_psi USE polarization, ONLY : polaw implicit none INTEGER :: i!which element of self energy remainder to be calculated COMPLEX(kind=DP) :: rem!self energy remainder element REAL(kind=DP) :: time!in output time correspondig to the calculated self energy, just for control TYPE(wp_psi) :: wp!descriptor of product wp wp psi psi TYPE(polaw) :: ww!descriptor of dressed interaction INTEGER :: iw,jw if(.not.ww%ontime) then write(stdout,*) 'Routine self_energy_remainder: imaginary times required' ! stop endif if(wp%numpw /= ww%numpw) then write(stdout,*) 'Routine self_energy_remainder: same numpw required' stop endif if(i > wp%nums_psi) then write(stdout,*) 'Routine self_energy_remainder: i too large',i,wp%nums_psi stop endif rem=(0.d0,0.d0) do iw=1,ww%numpw do jw=1,ww%numpw rem=rem+ww%pw(iw,jw)*wp%wwp(iw,jw,i) enddo enddo return END SUBROUTINE self_energy_remainder SUBROUTINE set_data_wp_psi_cutoff(pw_red,pw,wpi) !this subroutine allocates and set the array pw_red !which contains the corresponding elements of wpwp_psi USE kinds, ONLY : DP USE io_global, ONLY : stdout USE basic_structures, ONLY : wp_psi_cutoff_index USE polarization, ONLY : polaw implicit none COMPLEX(kind=DP), DIMENSION(:), POINTER :: pw_red!array for contracted data TYPE(polaw) :: pw!data to be contracted TYPE(wp_psi_cutoff_index) :: wpi !indices INTEGER i,j allocate(pw_red(wpi%numpwpw)) write(stdout,*) 'Number NUMPWPW', wpi%numpwpw do i=1,wpi%numpwpw if(wpi%index(1,i) /= wpi%index(2,i)) then pw_red(i)=pw%pw(wpi%index(1,i),wpi%index(2,i))+pw%pw(wpi%index(2,i),wpi%index(1,i)) else pw_red(i)=pw%pw(wpi%index(1,i),wpi%index(1,i)) endif enddo WRITE(stdout,*) 'PW_RED OUT', pw_red(1) return END SUBROUTINE set_data_wp_psi_cutoff SUBROUTINE self_energy_remainder_cutoff(state,rem,wp,pw_red) !this subroutine calculates the remainders for negative imaginary time !<\Psi_i|\Sigma(it)|\Psi_j> !=Sigma^R_v(it)=\sum wwp(i,j,v)ww(i,j,it) !using a reduced set of data USE kinds, ONLY : DP USE io_global, ONLY : stdout USE basic_structures, ONLY : wp_psi_cutoff_data implicit none INTEGER :: state!which element of self energy remainder to be calculated COMPLEX(kind=DP) :: rem!self energy remainder element COMPLEX(kind=DP), DIMENSION(:), POINTER :: pw_red!contracted polarization/interaction array TYPE(wp_psi_cutoff_data) :: wp!descriptor of product wp wp psi psi INTEGER :: i rem=(0.d0,0.d0) do i=1,wp%numpwpw rem=rem+pw_red(i)*wp%wwp(i,state) enddo return END SUBROUTINE self_energy_remainder_cutoff SUBROUTINE self_energy_contraction_state(i,j,sene,time,cri,crs,gf,ww) !this subroutine calculates the terms, in imaginary time using contraction array !<\Psi_i|\Sigma(it)|\Psi_j> !G_{lm}W_{n,o} Q^{P}_{n,l,i}*conjg(Q^{P}_{o,m,j} !uses state contractions !ONLY DIAGONAL TERMS IMPLEMENTED YET USE kinds, ONLY : DP USE io_global, ONLY : stdout USE compact_product USE green_function, ONLY : green USE polarization, ONLY : polaw implicit none INTEGER :: i,j !which element of self enrgy to be calculated COMPLEX(kind=DP) :: sene!self energy element REAL(kind=DP) :: time!in output time correspondig to the calculated self energy TYPE(contraction_index) :: cri!index description of contracted terms TYPE(contraction_state) :: crs!state contraction TYPE(green) :: gf!descriptor of green function TYPE(polaw) :: ww!descriptor of dressed interaction REAL(kind=DP), ALLOCATABLE :: qg(:,:)!for the product Q^{P}_{n,l,i}G{l,m} REAL(kind=DP), ALLOCATABLE :: qg_t(:,:) REAL(kind=DP), ALLOCATABLE :: gf_t(:,:) REAL(kind=DP), ALLOCATABLE :: crsq_t(:,:) REAL(kind=DP), ALLOCATABLE :: tmp_q(:), tmp_m(:), tmp_w(:),tmp_m2(:) INTEGER, ALLOCATABLE :: cri_index(:) INTEGER :: k,l,m,n,o,p !check consistency if(.not.gf%ontime) then write(stdout,*) 'Routine self_energy: imaginary times GF required' stop endif if(.not.ww%ontime) then write(stdout,*) 'Routine self_energy: imaginary times WW required' ! stop endif if( i/=j) then write(stdout,*) 'Routine self_energy: ONLY DIAGONAL TERMS IMPLEMETED YET' stop endif if(gf%nums /= cri%nums) then write(stdout,*) 'Routine self_energy: same nums required' stop endif if(cri%numpw /= ww%numpw) then write(stdout,*) 'Routine self_energy: same numpw required' stop endif write(stdout,*) 'Self-energy 0',gf%factor,ww%factor call flush_unit(stdout) allocate( qg ( cri%numpw, cri%nums) ) allocate( qg_t( cri%nums, cri%numpw ) ) allocate( gf_t( cri%nums, cri%nums ) ) CALL mytranspose( gf%gf_p, cri%nums, gf_t, cri%nums, cri%nums, cri%nums ) qg_t(:,:)=0.d0 do n=1,cri%numpw!loop on orthonormalized wannier products do l=1,cri%numl(n) !do m=1,cri%nums ! qg_t(m,n)=qg_t(m,n)+crs%q(n,l)*gf_t(m,cri%l(l,n)) !enddo CALL daxpy( cri%nums, crs%q(n,l), gf_t( 1, cri%l(l,n) ), 1, qg_t(1,n), 1 ) enddo enddo CALL mytranspose( qg_t, cri%nums, qg, cri%numpw, cri%nums, cri%numpw ) !do n=1,cri%nums ! do m=1,cri%numpw ! qg( m, n ) = qg_t( n, m ) ! end do !end do DEALLOCATE( qg_t, gf_t ) write(stdout,*) 'Self-energy 1' call flush_unit(stdout) sene=(0.d0,0.d0) allocate(tmp_w(cri%numpw)) ! allocate(tmp_qq(cri%numpw, cri%nums)) allocate(crsq_t(cri%nums,cri%numpw)) ! do o=1,cri%numpw ! do m=1,cri%numl(o) ! crsq_t(m,o)=cmplx(crs%q(o,m),0.d0) ! enddo ! enddo call mytranspose(crs%q,cri%numpw,crsq_t,cri%nums,cri%numpw,cri%nums) do o=1,cri%numpw tmp_w(:)=0.d0 call daxpy(cri%numpw,1.d0,ww%pw(:,o),1,tmp_w,1) allocate(tmp_m(cri%nums)) call dgemv('T',cri%numpw,cri%nums,1.d0,qg,cri%numpw,tmp_w,1,0.d0,tmp_m,1) allocate(tmp_m2(cri%numl(o))) tmp_m2(1:cri%numl(o))=crsq_t(1:cri%numl(o),o) allocate(tmp_q(cri%numl(o))) allocate(cri_index(cri%numl(o))) do m=1,cri%numl(o) cri_index(m)=cri%l(m,o) enddo do m=1,cri%numl(o) tmp_q(m)=tmp_m(cri_index(m))*tmp_m2(m) enddo sene=sene+sum(tmp_q(1:cri%numl(o)))*gf%factor*ww%factor deallocate(tmp_q) deallocate(tmp_m2) deallocate(cri_index) deallocate(tmp_m) enddo write(stdout,*) 'Self-energy 3', gf%factor,ww%factor call flush_unit(stdout) deallocate(crsq_t) deallocate(tmp_w) time=ww%time sene=sene*(0.d0,1.d0) deallocate(qg) return END SUBROUTINE self_energy_contraction_state GWW/gww/contour.f900000644000077300007730000003763312341332532014641 0ustar giannozzgiannozz! ! Copyright (C) 2001-2013 Quantum ESPRESSO group ! This file is distributed under the terms of the ! GNU General Public License. See the file `License' ! in the root directory of the present distribution, ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !this modules contain the routine for the contour integration MODULE contour USE kinds, ONLY : DP TYPE w_expectation !descriptor for INTEGER ::n!number of steps INTEGER :: max_i!number of states considered INTEGER :: i_min!minimum state to be calculated INTEGER :: i_max!maximum state to be calculated INTEGER :: nspin!spin multiplicity COMPLEX(kind=DP), DIMENSION(:), POINTER :: grid COMPLEX(kind=DP), DIMENSION(:,:,:,:), POINTER :: diag(:,:,:,:) END TYPE w_expectation TYPE w_poles !descriptor for the analytic continuation of INTEGER :: max_i!number of states considered INTEGER :: i_min!minimum state to be calculated INTEGER :: i_max!maximum state to be calculated INTEGER :: nspin!spin multiplicity INTEGER :: n_multipoles!number of multipoles considered COMPLEX(kind=DP), DIMENSION(:,:,:), POINTER :: a_0!parameters a_0 COMPLEX(kind=DP), DIMENSION(:,:,:,:), POINTER :: a!parameters a (n_multipoles,max_i(poles),max_i(KS states),nspin) COMPLEX(kind=DP), DIMENSION(:,:,:,:), POINTER :: b!parameters b (n_multipoles,max_i(poles),max_i(KS states),nspin) END TYPE w_poles CONTAINS SUBROUTINE initialize_w_expectation(we) implicit none TYPE(w_expectation) :: we nullify(we%grid) nullify(we%diag) return END SUBROUTINE initialize_w_expectation SUBROUTINE initialize_w_poles(wp) implicit none TYPE(w_poles) :: wp nullify(wp%a_0) nullify(wp%a) nullify(wp%b) return END SUBROUTINE initialize_w_poles SUBROUTINE free_memory_w_poles(wp) implicit none TYPE(w_poles) :: wp if(associated(wp%a_0)) deallocate (wp%a_0) nullify(wp%a_0) if(associated(wp%a)) deallocate (wp%a) nullify(wp%a) if(associated(wp%b)) deallocate (wp%b) nullify(wp%b) return END SUBROUTINE free_memory_w_poles SUBROUTINE free_memory_w_expectation(we) implicit none TYPE(w_expectation) :: we if(associated(we%grid)) deallocate(we%grid) nullify(we%grid) if(associated(we%diag)) deallocate(we%diag) nullify(we%diag) return END SUBROUTINE free_memory_w_expectation SUBROUTINE write_w_poles(wp) USE io_global, ONLY : stdout, ionode USE input_gw, ONLY : input_options USE mp, ONLY : mp_barrier USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(w_poles) :: wp!the structure to be written INTEGER :: iun,is if(ionode) then iun = find_free_unit() open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'wpoles', status='unknown',form='unformatted') write(iun) wp%max_i write(iun) wp%i_min write(iun) wp%i_max write(iun) wp%nspin write(iun) wp%n_multipoles write(iun) wp%a_0(1:wp%max_i,1:wp%max_i,1:wp%nspin) write(iun) wp%a(1:wp%n_multipoles,1:wp%max_i,1:wp%max_i,1:wp%nspin) write(iun) wp%b(1:wp%n_multipoles,1:wp%max_i,1:wp%max_i,1:wp%nspin) close(iun) endif return END SUBROUTINE write_w_poles SUBROUTINE read_w_poles(wp) USE io_global, ONLY : stdout, ionode,ionode_id USE input_gw, ONLY : input_options USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : prefix,tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(w_poles) :: wp!the structure to be read INTEGER :: iun,is if(ionode) then iun = find_free_unit() open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'wpoles', status='old',form='unformatted') read(iun) wp%max_i read(iun) wp%i_min read(iun) wp%i_max read(iun) wp%nspin read(iun) wp%n_multipoles endif call mp_bcast(wp%max_i,ionode_id,world_comm) call mp_bcast(wp%i_min,ionode_id,world_comm) call mp_bcast(wp%i_max,ionode_id,world_comm) call mp_bcast(wp%nspin,ionode_id,world_comm) call mp_bcast(wp%n_multipoles,ionode_id,world_comm) allocate(wp%a_0(wp%max_i,wp%max_i,wp%nspin)) allocate(wp%a(wp%n_multipoles,wp%max_i,wp%max_i,wp%nspin)) allocate(wp%b(wp%n_multipoles,wp%max_i,wp%max_i,wp%nspin)) if(ionode) then read(iun) wp%a_0(1:wp%max_i,1:wp%max_i,1:wp%nspin) read(iun) wp%a(1:wp%n_multipoles,1:wp%max_i,1:wp%max_i,1:wp%nspin) read(iun) wp%b(1:wp%n_multipoles,1:wp%max_i,1:wp%max_i,1:wp%nspin) close(iun) endif call mp_bcast(wp%a_0,ionode_id,world_comm) call mp_bcast(wp%a,ionode_id,world_comm) call mp_bcast(wp%b,ionode_id,world_comm) return END SUBROUTINE read_w_poles SUBROUTINE write_w_expectation(we) USE io_global, ONLY : stdout, ionode USE input_gw, ONLY : input_options USE mp, ONLY : mp_barrier USE io_files, ONLY : prefix, tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(w_expectation) :: we!the structure to be written INTEGER :: iun,is if(ionode) then iun = find_free_unit() open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'wexpectation', status='unknown',form='unformatted') write(iun) we%n write(iun) we%max_i write(iun) we%i_min write(iun) we%i_max write(iun) we%nspin write(iun) we%grid(1:we%n) do is=1,we%nspin write(iun) we%diag(1:we%n,1:we%max_i, 1:we%max_i,is) enddo close(iun) endif return END SUBROUTINE write_w_expectation SUBROUTINE read_w_expectation(we) USE io_global, ONLY : stdout, ionode,ionode_id USE input_gw, ONLY : input_options USE mp, ONLY : mp_bcast USE mp_world, ONLY : world_comm USE io_files, ONLY : prefix, tmp_dir implicit none INTEGER, EXTERNAL :: find_free_unit TYPE(w_expectation),INTENT(out) :: we!the structure to be written INTEGER :: iun,is if(ionode) then iun = find_free_unit() open( unit=iun, file=trim(tmp_dir)//trim(prefix)//'-'//'wexpectation', status='old',form='unformatted') read(iun) we%n read(iun) we%max_i read(iun) we%i_min read(iun) we%i_max read(iun) we%nspin endif call mp_bcast(we%n,ionode_id,world_comm) call mp_bcast(we%max_i,ionode_id,world_comm) call mp_bcast(we%i_min,ionode_id,world_comm) call mp_bcast(we%i_max,ionode_id,world_comm) call mp_bcast(we%nspin,ionode_id,world_comm) allocate(we%grid(we%n),we%diag(we%n,we%max_i,we%max_i,we%nspin)) if(ionode) then read(iun) we%grid(1:we%n) do is=1,we%nspin read(iun) we%diag(1:we%n,1:we%max_i, 1:we%max_i,is) enddo close(iun) endif call mp_bcast(we%grid,ionode_id,world_comm) call mp_bcast(we%diag,ionode_id,world_comm) return END SUBROUTINE read_w_expectation SUBROUTINE create_w_expectation(we, tf, options) !this subroutine create the diagonal elements of W starting from Pgreek read from disk USE kinds, ONLY : DP USE io_global, ONLY : stdout, ionode, ionode_id USE input_gw, ONLY : input_options USE basic_structures, ONLY : v_pot,wannier_u,free_memory, initialize_memory,lanczos_chain, vt_mat_lanczos,tt_mat_lanczos,& & contour_terms USE green_function, ONLY : green, read_green, free_memory_green, initialize_green USE polarization, ONLY : polaw, free_memory_polaw, read_polaw, write_polaw,invert_v_pot, initialize_polaw, & & read_polaw_global USE mp, ONLY : mp_sum, mp_bcast USE mp_world, ONLY : nproc,mpime,world_comm USE times_gw, ONLY : times_freqs USE self_energy_storage, ONLY : self_storage,write_self_storage_ondisk,free_memory_self_storage USE lanczos USE constants, ONLY : tpi,pi USE para_gww, ONLY : is_my_pola implicit none TYPE(w_expectation) :: we TYPE(times_freqs), INTENT(in) :: tf!for time frequency grids TYPE(input_options) :: options TYPE(polaw) :: pp!dressed polarization TYPE(tt_mat_lanczos) :: sg!overlap TYPE(vt_mat_lanczos) :: sl!overlap TYPE(contour_terms) :: ct INTEGER :: iw, ii,is,jj REAL(kind=DP), ALLOCATABLE :: cs_mat(:,:),tmp_mat(:,:),tmp_mat2(:,:),tmp_mat3(:,:) INTEGER :: jmin, jmax call initialize_memory(ct) call initialize_memory(sg) call initialize_memory(sl) call initialize_polaw(pp) !allocate we%nspin=options%nspin we%n=options%n+1 we%max_i=options%max_i we%i_min=options%i_min we%i_max=options%i_max allocate(we%grid(we%n)) allocate(we%diag(we%n,we%max_i,we%max_i,we%nspin)) we%diag(:,:,:,:)=(0.d0,0.d0) !loop on spin if(.not.options%l_big_system) then jmin=1 jmax=options%i_max else jmin=options%i_min jmax=options%i_max endif do is=1,we%nspin !read in contour terms if(.not.options%l_big_system) call read_data_pw_contour(ct,options%prefix,is,1) !loop on KS states , poles do jj=jmin,jmax if(options%l_big_system) call read_data_pw_contour(ct,options%prefix,is,jj) call read_data_pw_tt_mat_lanczos(sg, jj, options%prefix,.false.,is) call read_data_pw_vt_mat_lanczos(sl, jj, options%prefix,.false., is) allocate(cs_mat(ct%nums,sl%numpw)) allocate(tmp_mat(ct%nums,sg%numl)) call dgemm('T','N',ct%nums,sg%numl,sg%numt,1.d0,ct%cmat,ct%numt,sg%tt_mat,sg%numt,0.d0,tmp_mat,ct%nums) call dgemm('N','T',ct%nums,sl%numpw,sl%numl,1.d0,tmp_mat,ct%nums,sl%vt_mat,sl%numpw,0.d0,cs_mat,ct%nums) allocate(tmp_mat2(ct%nums,sl%numpw),tmp_mat3(ct%nums,ct%nums)) !loop on frequencies do iw=0,options%n if(is_my_pola(iw)) then call read_polaw(iw,pp,options%debug,options%l_verbose) call dgemm('N','N',ct%nums,pp%numpw,pp%numpw,1.d0,cs_mat,ct%nums,pp%pw,pp%numpw,0.d0,tmp_mat2,ct%nums) !also off-diagonal elements are calculated although not necessary call dgemm('N','T',ct%nums,ct%nums,pp%numpw,1.d0,tmp_mat2,ct%nums,cs_mat,ct%nums,0.d0,tmp_mat3,ct%nums) do ii=1,ct%nums we%diag(iw+1,jj,ii,is)=tmp_mat3(ii,ii) !GIUSTO CUSSI enddo call free_memory_polaw(pp) endif enddo call free_memory(sg) call free_memory(sl) deallocate(cs_mat,tmp_mat) deallocate(tmp_mat2,tmp_mat3) if(options%l_big_system) call free_memory(ct) enddo if(.not.options%l_big_system) call free_memory(ct) enddo call mp_sum(we%diag,world_comm) !now set up frequency grid we%grid(1:we%n)=dcmplx(0.d0,tf%freqs(0:tf%n)) call free_memory_polaw(pp) call free_memory(ct) call free_memory(sg) call free_memory(sl) return END SUBROUTINE create_w_expectation SUBROUTINE create_w_poles(we,wp,options) !this subroutine perform non-linar fits for finding the expansion !of the terms for the contour integration !the sum over poles is distributed among processors USE io_global, ONLY : stdout USE input_gw, ONLY : input_options USE para_gww, ONLY : is_my_state_range USE mp, ONLY : mp_sum USE mp_world, ONLY : world_comm implicit none TYPE(w_expectation), INTENT(in) :: we!data on imaginary frequency TYPE(w_poles), INTENT(out) :: wp!poles to be found TYPE(input_options), INTENT(in) :: options INTEGER :: ii,jj, kk,is,mm COMPLEX(kind=DP), ALLOCATABLE :: z(:),s(:) REAL(kind=DP) :: chi, chi0 COMPLEX(kind=DP) :: a_0_old COMPLEX(kind=DP), ALLOCATABLE :: a_old(:), b_old(:) !set up wp call initialize_w_poles(wp) wp%nspin=we%nspin wp%max_i=we%max_i wp%i_max=we%i_max wp%i_min=we%i_min wp%n_multipoles=options%n_multipoles !allocate allocate(wp%a_0(wp%max_i,wp%max_i,wp%nspin)) allocate(wp%a(wp%n_multipoles,wp%max_i,wp%max_i,wp%nspin)) allocate(wp%b(wp%n_multipoles,wp%max_i,wp%max_i,wp%nspin)) allocate(a_old(wp%n_multipoles),b_old(wp%n_multipoles)) wp%a_0(:,:,:)=(0.d0,0.d0) wp%a(:,:,:,:)=(0.d0,0.d0) wp%b(:,:,:,:)=(0.d0,0.d0) allocate(z(we%n),s(we%n)) z(1:we%n)=we%grid(1:we%n) do is=1,wp%nspin do ii=wp%i_min,wp%i_max ! do jj=1,wp%max_i do jj=wp%i_min,wp%i_max!ATTENZIONE if(is_my_state_range(jj)) then s(1:we%n)=we%diag(1:we%n,jj,ii,is) wp%a_0(jj,ii,is)=(0.0,0.0d0) do mm=1,options%n_multipoles wp%a(mm,jj,ii,is)=cmplx(real(mm)*(0.01d0),0.d0) wp%b(mm,jj,ii,is)=cmplx((0.5d0)*real(mm)*(-1.d0)**real(mm),-0.01d0) enddo write(stdout,*) 'Call fit_multipole' call flush_unit(stdout) call fit_multipole(we%n,wp%n_multipoles,z,s,wp%a_0(jj,ii,is),& &wp%a(:,jj,ii,is),wp%b(:,jj,ii,is),1.d0,options%fit_thres,options%fit_maxiter) write(stdout,*) 'Done' call flush_unit(stdout) a_0_old=wp%a_0(jj,ii,is) do mm=1,wp%n_multipoles a_old(mm)=wp%a(mm,jj,ii,is) b_old(mm)=wp%b(mm,jj,ii,is) enddo call flush_unit(stdout) call fit_multipole_minpack(we%n,wp%n_multipoles,z,s,wp%a_0(jj,ii,is),& &wp%a(:,jj,ii,is),wp%b(:,jj,ii,is),options%fit_thres, options%n_max_minpack, chi) write(stdout,*) 'FIT pole :', jj, ii,is write(stdout,*) 'FIT a_0:', wp%a_0(jj,ii,is) do mm=1,wp%n_multipoles write(stdout,*) 'FIT a:',mm,wp%a(mm,jj,ii,is) write(stdout,*) 'FIT b:',mm,wp%b(mm,jj,ii,is) enddo call flush_unit(stdout) endif enddo call mp_sum(wp%a_0(:,ii,is),world_comm) call mp_sum(wp%a(:,:,ii,is),world_comm) call mp_sum(wp%b(:,:,ii,is),world_comm) enddo enddo deallocate(a_old,b_old) deallocate(z,s) return END SUBROUTINE create_w_poles FUNCTION w_poles_value(energy,wp,jj,ii,ispin) implicit none COMPLEX(kind=DP) :: w_poles_value!the value of the pole jj, for the KS states ii with spin is COMPLEX(kind=DP), INTENT(in) :: energy !frequency considered TYPE(w_poles), INTENT(in) :: wp INTEGER, INTENT(in) :: jj INTEGER, INTENT(in) :: ii INTEGER, INTENT(in) :: ispin COMPLEX(kind=DP) :: fz INTEGER :: ip if(dble(energy) >= 0.d0 ) then fz=wp%a_0(jj,ii,ispin) do ip=1,wp%n_multipoles fz=fz+wp%a(ip,jj,ii,ispin)/(energy-wp%b(ip,jj,ii,ispin)) enddo else fz=conjg(wp%a_0(jj,ii,ispin)) do ip=1,wp%n_multipoles fz=fz+conjg(wp%a(ip,jj,ii,ispin))/(energy-conjg(wp%b(ip,jj,ii,ispin))) enddo endif w_poles_value=fz return END FUNCTION w_poles_value END MODULE contour GWW/gww/make.depend0000644000077300007730000002571412341332532014723 0ustar giannozzgiannozzbasic_structures.o : ../../Modules/kind.o compact_product.o : ../../Modules/io_files.o compact_product.o : ../../Modules/io_global.o compact_product.o : ../../Modules/kind.o compact_product.o : ../../Modules/mp.o compact_product.o : ../../Modules/mp_world.o compact_product.o : basic_structures.o compact_product.o : input_gw.o compact_product.o : para_gww.o contour.o : ../../Modules/constants.o contour.o : ../../Modules/io_files.o contour.o : ../../Modules/io_global.o contour.o : ../../Modules/kind.o contour.o : ../../Modules/mp.o contour.o : ../../Modules/mp_world.o contour.o : basic_structures.o contour.o : green_function.o contour.o : input_gw.o contour.o : lanczos_polarization.o contour.o : para_gww.o contour.o : polarization.o contour.o : self_energy_storage.o contour.o : times_gw.o create_hf.o : ../../Modules/constants.o create_hf.o : ../../Modules/io_global.o create_hf.o : ../../Modules/kind.o create_hf.o : basic_structures.o create_hf.o : energies_gww.o create_hf.o : input_gw.o create_quasi_particle.o : ../../Modules/constants.o create_quasi_particle.o : ../../Modules/io_global.o create_quasi_particle.o : ../../Modules/kind.o create_quasi_particle.o : basic_structures.o create_quasi_particle.o : energies_gww.o create_quasi_particle.o : expansion.o create_quasi_particle.o : input_gw.o create_quasi_particle.o : self_energy_storage.o create_quasi_particle_off.o : ../../Modules/constants.o create_quasi_particle_off.o : ../../Modules/io_global.o create_quasi_particle_off.o : ../../Modules/kind.o create_quasi_particle_off.o : basic_structures.o create_quasi_particle_off.o : energies_gww.o create_quasi_particle_off.o : expansion.o create_quasi_particle_off.o : input_gw.o do_contour.o : ../../Modules/kind.o do_contour.o : basic_structures.o do_contour.o : contour.o do_contour.o : input_gw.o do_contour.o : self_energy_storage.o do_polarization_lanczos.o : ../../Modules/io_files.o do_polarization_lanczos.o : ../../Modules/io_global.o do_polarization_lanczos.o : ../../Modules/kind.o do_polarization_lanczos.o : ../../Modules/mp.o do_polarization_lanczos.o : ../../Modules/mp_world.o do_polarization_lanczos.o : ../../Modules/parallel_include.o do_polarization_lanczos.o : basic_structures.o do_polarization_lanczos.o : input_gw.o do_polarization_lanczos.o : lanczos_polarization.o do_polarization_lanczos.o : polarization.o do_polarization_lanczos.o : times_gw.o do_self_lanczos.o : ../../Modules/constants.o do_self_lanczos.o : ../../Modules/io_global.o do_self_lanczos.o : ../../Modules/kind.o do_self_lanczos.o : ../../Modules/mp.o do_self_lanczos.o : ../../Modules/mp_world.o do_self_lanczos.o : basic_structures.o do_self_lanczos.o : green_function.o do_self_lanczos.o : input_gw.o do_self_lanczos.o : lanczos_polarization.o do_self_lanczos.o : polarization.o do_self_lanczos.o : self_energy_storage.o do_self_lanczos.o : start_end.o do_self_lanczos.o : times_gw.o do_self_lanczos_full.o : ../../Modules/constants.o do_self_lanczos_full.o : ../../Modules/io_files.o do_self_lanczos_full.o : ../../Modules/io_global.o do_self_lanczos_full.o : ../../Modules/kind.o do_self_lanczos_full.o : ../../Modules/mp.o do_self_lanczos_full.o : ../../Modules/mp_world.o do_self_lanczos_full.o : ../../Modules/parallel_include.o do_self_lanczos_full.o : basic_structures.o do_self_lanczos_full.o : green_function.o do_self_lanczos_full.o : input_gw.o do_self_lanczos_full.o : lanczos_polarization.o do_self_lanczos_full.o : polarization.o do_self_lanczos_full.o : self_energy_storage.o do_self_lanczos_full.o : start_end.o do_self_lanczos_full.o : times_gw.o do_self_lanczos_time.o : ../../Modules/constants.o do_self_lanczos_time.o : ../../Modules/io_files.o do_self_lanczos_time.o : ../../Modules/io_global.o do_self_lanczos_time.o : ../../Modules/kind.o do_self_lanczos_time.o : ../../Modules/mp.o do_self_lanczos_time.o : ../../Modules/mp_world.o do_self_lanczos_time.o : ../../Modules/parallel_include.o do_self_lanczos_time.o : basic_structures.o do_self_lanczos_time.o : green_function.o do_self_lanczos_time.o : input_gw.o do_self_lanczos_time.o : lanczos_polarization.o do_self_lanczos_time.o : polarization.o do_self_lanczos_time.o : self_energy_storage.o do_self_lanczos_time.o : start_end.o do_self_lanczos_time.o : times_gw.o energies_gww.o : ../../Modules/constants.o energies_gww.o : ../../Modules/io_files.o energies_gww.o : ../../Modules/io_global.o energies_gww.o : ../../Modules/kind.o energies_gww.o : ../../Modules/mp.o energies_gww.o : ../../Modules/mp_world.o energies_gww.o : input_gw.o expansion.o : ../../Modules/constants.o expansion.o : ../../Modules/io_files.o expansion.o : ../../Modules/io_global.o expansion.o : ../../Modules/kind.o expansion.o : ../../Modules/mp.o expansion.o : ../../Modules/mp_world.o expansion.o : input_gw.o expansion.o : para_gww.o expansion.o : self_energy_storage.o expansion.o : times_gw.o fft_gw.o : ../../Modules/constants.o fft_gw.o : ../../Modules/fft_scalar.o fft_gw.o : ../../Modules/io_files.o fft_gw.o : ../../Modules/io_global.o fft_gw.o : ../../Modules/kind.o fft_gw.o : ../../Modules/mp.o fft_gw.o : ../../Modules/mp_world.o fft_gw.o : ../../Modules/parallel_include.o fft_gw.o : polarization.o fft_gw.o : times_gw.o fit_multipole.o : ../../Modules/io_global.o fit_multipole.o : ../../Modules/kind.o fit_polynomial.o : ../../Modules/io_global.o fit_polynomial.o : ../../Modules/kind.o go_dressed_w.o : ../../Modules/io_global.o go_dressed_w.o : ../../Modules/kind.o go_dressed_w.o : ../../Modules/mp.o go_dressed_w.o : ../../Modules/mp_world.o go_dressed_w.o : basic_structures.o go_dressed_w.o : gv_time.o go_dressed_w.o : input_gw.o go_dressed_w.o : para_gww.o go_dressed_w.o : polarization.o go_dressed_w.o : start_end.o go_exchange.o : ../../Modules/constants.o go_exchange.o : ../../Modules/io_global.o go_exchange.o : ../../Modules/kind.o go_exchange.o : ../../Modules/mp.o go_exchange.o : ../../Modules/mp_world.o go_exchange.o : basic_structures.o go_exchange.o : compact_product.o go_exchange.o : energies_gww.o go_exchange.o : green_function.o go_exchange.o : input_gw.o go_exchange.o : para_gww.o go_exchange.o : polarization.o go_fft.o : ../../Modules/io_global.o go_fft.o : ../../Modules/kind.o go_fft.o : ../../Modules/mp.o go_fft.o : ../../Modules/mp_world.o go_fft.o : fft_gw.o go_fft.o : input_gw.o go_fft.o : polarization.o go_fft.o : times_gw.o go_green.o : ../../Modules/io_global.o go_green.o : ../../Modules/kind.o go_green.o : ../../Modules/mp.o go_green.o : ../../Modules/mp_world.o go_green.o : basic_structures.o go_green.o : energies_gww.o go_green.o : green_function.o go_green.o : input_gw.o go_green.o : para_gww.o go_green.o : times_gw.o go_polarization.o : ../../Modules/io_global.o go_polarization.o : ../../Modules/kind.o go_polarization.o : ../../Modules/mp.o go_polarization.o : ../../Modules/mp_world.o go_polarization.o : basic_structures.o go_polarization.o : compact_product.o go_polarization.o : energies_gww.o go_polarization.o : green_function.o go_polarization.o : input_gw.o go_polarization.o : para_gww.o go_polarization.o : polarization.o go_polarization.o : times_gw.o green_function.o : ../../Modules/io_files.o green_function.o : ../../Modules/io_global.o green_function.o : ../../Modules/kind.o green_function.o : basic_structures.o gv_time.o : ../../Modules/constants.o gv_time.o : ../../Modules/io_files.o gv_time.o : ../../Modules/io_global.o gv_time.o : ../../Modules/kind.o gv_time.o : ../../Modules/mp.o gv_time.o : ../../Modules/mp_world.o gv_time.o : times_gw.o gww.o : ../../Modules/io_files.o gww.o : ../../Modules/io_global.o gww.o : ../../Modules/mp.o gww.o : ../../Modules/mp_world.o gww.o : contour.o gww.o : energies_gww.o gww.o : expansion.o gww.o : gv_time.o gww.o : input_gw.o gww.o : para_gww.o gww.o : self_energy_storage.o gww.o : start_end.o gww.o : times_gw.o gww_fit.o : ../../Modules/constants.o gww_fit.o : ../../Modules/io_files.o gww_fit.o : ../../Modules/io_global.o gww_fit.o : ../../Modules/mp_world.o gww_fit.o : energies_gww.o gww_fit.o : expansion.o gww_fit.o : gv_time.o gww_fit.o : input_gw.o gww_fit.o : para_gww.o gww_fit.o : self_energy_storage.o gww_fit.o : start_end.o gww_fit.o : times_gw.o input_gw.o : ../../Modules/io_files.o input_gw.o : ../../Modules/io_global.o input_gw.o : ../../Modules/kind.o input_gw.o : ../../Modules/mp.o input_gw.o : ../../Modules/mp_world.o lanczos_polarization.o : ../../Modules/io_files.o lanczos_polarization.o : ../../Modules/io_global.o lanczos_polarization.o : ../../Modules/kind.o lanczos_polarization.o : ../../Modules/mp.o lanczos_polarization.o : ../../Modules/mp_world.o lanczos_polarization.o : basic_structures.o para_gww.o : ../../Modules/io_global.o para_gww.o : ../../Modules/mp_world.o polarization.o : ../../Modules/constants.o polarization.o : ../../Modules/io_files.o polarization.o : ../../Modules/io_global.o polarization.o : ../../Modules/kind.o polarization.o : ../../Modules/mp.o polarization.o : ../../Modules/mp_world.o polarization.o : ../../Modules/parallel_include.o polarization.o : basic_structures.o polarization.o : compact_product.o polarization.o : green_function.o polarization.o : input_gw.o polarization.o : times_gw.o read_data_pw.o : ../../Modules/constants.o read_data_pw.o : ../../Modules/io_files.o read_data_pw.o : ../../Modules/io_global.o read_data_pw.o : ../../Modules/kind.o read_data_pw.o : ../../Modules/mp.o read_data_pw.o : ../../Modules/mp_world.o read_data_pw.o : basic_structures.o remainder.o : ../../Modules/constants.o remainder.o : ../../Modules/io_global.o remainder.o : ../../Modules/kind.o remainder.o : ../../Modules/mp.o remainder.o : ../../Modules/mp_world.o remainder.o : basic_structures.o remainder.o : compact_product.o remainder.o : energies_gww.o remainder.o : green_function.o remainder.o : input_gw.o remainder.o : para_gww.o remainder.o : polarization.o self_energy.o : ../../Modules/io_global.o self_energy.o : ../../Modules/kind.o self_energy.o : basic_structures.o self_energy.o : compact_product.o self_energy.o : green_function.o self_energy.o : polarization.o self_energy_storage.o : ../../Modules/constants.o self_energy_storage.o : ../../Modules/fft_scalar.o self_energy_storage.o : ../../Modules/io_files.o self_energy_storage.o : ../../Modules/io_global.o self_energy_storage.o : ../../Modules/kind.o self_energy_storage.o : ../../Modules/mp.o self_energy_storage.o : ../../Modules/mp_world.o self_energy_storage.o : basic_structures.o self_energy_storage.o : compact_product.o self_energy_storage.o : energies_gww.o self_energy_storage.o : green_function.o self_energy_storage.o : gv_time.o self_energy_storage.o : input_gw.o self_energy_storage.o : para_gww.o self_energy_storage.o : polarization.o self_energy_storage.o : times_gw.o start_end.o : ../../Modules/environment.o start_end.o : ../../Modules/io_global.o start_end.o : ../../Modules/mp_global.o start_end.o : ../../Modules/mp_world.o times_gw.o : ../../Modules/constants.o times_gw.o : ../../Modules/io_global.o times_gw.o : ../../Modules/kind.o times_gw.o : input_gw.o vcprim.o : ../../Modules/io_global.o vcprim.o : ../../Modules/kind.o vcprim.o : ../../Modules/mp_world.o vcprim.o : ../../Modules/parallel_include.o vcprim.o : basic_structures.o