diff --git a/config/gfortran.cfg b/config/gfortran.cfg index 60e32235..c0aa875f 100644 --- a/config/gfortran.cfg +++ b/config/gfortran.cfg @@ -35,14 +35,14 @@ OPENMP : 1 ; Append OpenMP flags # -ffast-math and the Fortran-specific # -fno-protect-parens and -fstack-arrays. [OPT] -FCFLAGS : +FCFLAGS : -Ofast # Profiling flags ################# # [PROFILE] FC : -p -g -FCFLAGS : +FCFLAGS : -Ofast # Debugging flags ################# diff --git a/config/ifort.cfg b/config/ifort.cfg index ed3108c5..843e887b 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -58,6 +58,6 @@ FCFLAGS : -xSSE2 -C -fpe0 ################# # [OPENMP] -FC : -openmp +FC : -qopenmp IRPF90_FLAGS : --openmp diff --git a/plugins/All_singles/.gitignore b/plugins/All_singles/.gitignore deleted file mode 100644 index 7ac9fbf6..00000000 --- a/plugins/All_singles/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -IRPF90_temp/ -IRPF90_man/ -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/CAS_SD_ZMQ/selection.irp.f b/plugins/CAS_SD_ZMQ/selection.irp.f index f18ba774..3692710d 100644 --- a/plugins/CAS_SD_ZMQ/selection.irp.f +++ b/plugins/CAS_SD_ZMQ/selection.irp.f @@ -1332,4 +1332,3 @@ subroutine selection_collector(b, pt2) call sort_selection_buffer(b) end subroutine - diff --git a/plugins/DDCI_selected/NEEDED_CHILDREN_MODULES b/plugins/DDCI_selected/NEEDED_CHILDREN_MODULES index d212e150..0b7ce8a9 100644 --- a/plugins/DDCI_selected/NEEDED_CHILDREN_MODULES +++ b/plugins/DDCI_selected/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_CAS Davidson Psiref_CAS +Perturbation Selectors_full Generators_CAS Davidson diff --git a/plugins/DDCI_selected/ddci.irp.f b/plugins/DDCI_selected/ddci.irp.f index a1824857..0bfb324f 100644 --- a/plugins/DDCI_selected/ddci.irp.f +++ b/plugins/DDCI_selected/ddci.irp.f @@ -5,7 +5,7 @@ program ddci double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:),E_before(:) integer :: N_st, degree - N_st = N_states + N_st = N_states_diag allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st)) character*(64) :: perturbation diff --git a/plugins/DFT_Utils/EZFIO.cfg b/plugins/DFT_Utils/EZFIO.cfg new file mode 100644 index 00000000..21cc5b98 --- /dev/null +++ b/plugins/DFT_Utils/EZFIO.cfg @@ -0,0 +1,4 @@ +[energy] +type: double precision +doc: Calculated energy +interface: ezfio diff --git a/plugins/DFT_Utils/angular.f b/plugins/DFT_Utils/angular.f deleted file mode 100644 index a5052a32..00000000 --- a/plugins/DFT_Utils/angular.f +++ /dev/null @@ -1,6951 +0,0 @@ - subroutine gen_oh(code, num, x, y, z, w, a, b, v) - implicit logical(a-z) - double precision x(*),y(*),z(*),w(*) - double precision a,b,v - integer code - integer num - double precision c -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated from C to fortran77 by hand. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd -cvw -cvw Given a point on a sphere (specified by a and b), generate all -cvw the equivalent points under Oh symmetry, making grid points with -cvw weight v. -cvw The variable num is increased by the number of different points -cvw generated. -cvw -cvw Depending on code, there are 6...48 different but equivalent -cvw points. -cvw -cvw code=1: (0,0,1) etc ( 6 points) -cvw code=2: (0,a,a) etc, a=1/sqrt(2) ( 12 points) -cvw code=3: (a,a,a) etc, a=1/sqrt(3) ( 8 points) -cvw code=4: (a,a,b) etc, b=sqrt(1-2 a^2) ( 24 points) -cvw code=5: (a,b,0) etc, b=sqrt(1-a^2), a input ( 24 points) -cvw code=6: (a,b,c) etc, c=sqrt(1-a^2-b^2), a/b input ( 48 points) -cvw - goto (1,2,3,4,5,6) code - write (6,*) 'Gen_Oh: Invalid Code' - stop - 1 continue - a=1.0d0 - x(1) = a - y(1) = 0.0d0 - z(1) = 0.0d0 - w(1) = v - x(2) = -a - y(2) = 0.0d0 - z(2) = 0.0d0 - w(2) = v - x(3) = 0.0d0 - y(3) = a - z(3) = 0.0d0 - w(3) = v - x(4) = 0.0d0 - y(4) = -a - z(4) = 0.0d0 - w(4) = v - x(5) = 0.0d0 - y(5) = 0.0d0 - z(5) = a - w(5) = v - x(6) = 0.0d0 - y(6) = 0.0d0 - z(6) = -a - w(6) = v - num=num+6 - return -cvw - 2 continue - a=sqrt(0.5d0) - x( 1) = 0d0 - y( 1) = a - z( 1) = a - w( 1) = v - x( 2) = 0d0 - y( 2) = -a - z( 2) = a - w( 2) = v - x( 3) = 0d0 - y( 3) = a - z( 3) = -a - w( 3) = v - x( 4) = 0d0 - y( 4) = -a - z( 4) = -a - w( 4) = v - x( 5) = a - y( 5) = 0d0 - z( 5) = a - w( 5) = v - x( 6) = -a - y( 6) = 0d0 - z( 6) = a - w( 6) = v - x( 7) = a - y( 7) = 0d0 - z( 7) = -a - w( 7) = v - x( 8) = -a - y( 8) = 0d0 - z( 8) = -a - w( 8) = v - x( 9) = a - y( 9) = a - z( 9) = 0d0 - w( 9) = v - x(10) = -a - y(10) = a - z(10) = 0d0 - w(10) = v - x(11) = a - y(11) = -a - z(11) = 0d0 - w(11) = v - x(12) = -a - y(12) = -a - z(12) = 0d0 - w(12) = v - num=num+12 - return -cvw - 3 continue - a = sqrt(1d0/3d0) - x(1) = a - y(1) = a - z(1) = a - w(1) = v - x(2) = -a - y(2) = a - z(2) = a - w(2) = v - x(3) = a - y(3) = -a - z(3) = a - w(3) = v - x(4) = -a - y(4) = -a - z(4) = a - w(4) = v - x(5) = a - y(5) = a - z(5) = -a - w(5) = v - x(6) = -a - y(6) = a - z(6) = -a - w(6) = v - x(7) = a - y(7) = -a - z(7) = -a - w(7) = v - x(8) = -a - y(8) = -a - z(8) = -a - w(8) = v - num=num+8 - return -cvw - 4 continue - b = sqrt(1d0 - 2d0*a*a) - x( 1) = a - y( 1) = a - z( 1) = b - w( 1) = v - x( 2) = -a - y( 2) = a - z( 2) = b - w( 2) = v - x( 3) = a - y( 3) = -a - z( 3) = b - w( 3) = v - x( 4) = -a - y( 4) = -a - z( 4) = b - w( 4) = v - x( 5) = a - y( 5) = a - z( 5) = -b - w( 5) = v - x( 6) = -a - y( 6) = a - z( 6) = -b - w( 6) = v - x( 7) = a - y( 7) = -a - z( 7) = -b - w( 7) = v - x( 8) = -a - y( 8) = -a - z( 8) = -b - w( 8) = v - x( 9) = a - y( 9) = b - z( 9) = a - w( 9) = v - x(10) = -a - y(10) = b - z(10) = a - w(10) = v - x(11) = a - y(11) = -b - z(11) = a - w(11) = v - x(12) = -a - y(12) = -b - z(12) = a - w(12) = v - x(13) = a - y(13) = b - z(13) = -a - w(13) = v - x(14) = -a - y(14) = b - z(14) = -a - w(14) = v - x(15) = a - y(15) = -b - z(15) = -a - w(15) = v - x(16) = -a - y(16) = -b - z(16) = -a - w(16) = v - x(17) = b - y(17) = a - z(17) = a - w(17) = v - x(18) = -b - y(18) = a - z(18) = a - w(18) = v - x(19) = b - y(19) = -a - z(19) = a - w(19) = v - x(20) = -b - y(20) = -a - z(20) = a - w(20) = v - x(21) = b - y(21) = a - z(21) = -a - w(21) = v - x(22) = -b - y(22) = a - z(22) = -a - w(22) = v - x(23) = b - y(23) = -a - z(23) = -a - w(23) = v - x(24) = -b - y(24) = -a - z(24) = -a - w(24) = v - num=num+24 - return -cvw - 5 continue - b=sqrt(1d0-a*a) - x( 1) = a - y( 1) = b - z( 1) = 0d0 - w( 1) = v - x( 2) = -a - y( 2) = b - z( 2) = 0d0 - w( 2) = v - x( 3) = a - y( 3) = -b - z( 3) = 0d0 - w( 3) = v - x( 4) = -a - y( 4) = -b - z( 4) = 0d0 - w( 4) = v - x( 5) = b - y( 5) = a - z( 5) = 0d0 - w( 5) = v - x( 6) = -b - y( 6) = a - z( 6) = 0d0 - w( 6) = v - x( 7) = b - y( 7) = -a - z( 7) = 0d0 - w( 7) = v - x( 8) = -b - y( 8) = -a - z( 8) = 0d0 - w( 8) = v - x( 9) = a - y( 9) = 0d0 - z( 9) = b - w( 9) = v - x(10) = -a - y(10) = 0d0 - z(10) = b - w(10) = v - x(11) = a - y(11) = 0d0 - z(11) = -b - w(11) = v - x(12) = -a - y(12) = 0d0 - z(12) = -b - w(12) = v - x(13) = b - y(13) = 0d0 - z(13) = a - w(13) = v - x(14) = -b - y(14) = 0d0 - z(14) = a - w(14) = v - x(15) = b - y(15) = 0d0 - z(15) = -a - w(15) = v - x(16) = -b - y(16) = 0d0 - z(16) = -a - w(16) = v - x(17) = 0d0 - y(17) = a - z(17) = b - w(17) = v - x(18) = 0d0 - y(18) = -a - z(18) = b - w(18) = v - x(19) = 0d0 - y(19) = a - z(19) = -b - w(19) = v - x(20) = 0d0 - y(20) = -a - z(20) = -b - w(20) = v - x(21) = 0d0 - y(21) = b - z(21) = a - w(21) = v - x(22) = 0d0 - y(22) = -b - z(22) = a - w(22) = v - x(23) = 0d0 - y(23) = b - z(23) = -a - w(23) = v - x(24) = 0d0 - y(24) = -b - z(24) = -a - w(24) = v - num=num+24 - return -cvw - 6 continue - c=sqrt(1d0 - a*a - b*b) - x( 1) = a - y( 1) = b - z( 1) = c - w( 1) = v - x( 2) = -a - y( 2) = b - z( 2) = c - w( 2) = v - x( 3) = a - y( 3) = -b - z( 3) = c - w( 3) = v - x( 4) = -a - y( 4) = -b - z( 4) = c - w( 4) = v - x( 5) = a - y( 5) = b - z( 5) = -c - w( 5) = v - x( 6) = -a - y( 6) = b - z( 6) = -c - w( 6) = v - x( 7) = a - y( 7) = -b - z( 7) = -c - w( 7) = v - x( 8) = -a - y( 8) = -b - z( 8) = -c - w( 8) = v - x( 9) = a - y( 9) = c - z( 9) = b - w( 9) = v - x(10) = -a - y(10) = c - z(10) = b - w(10) = v - x(11) = a - y(11) = -c - z(11) = b - w(11) = v - x(12) = -a - y(12) = -c - z(12) = b - w(12) = v - x(13) = a - y(13) = c - z(13) = -b - w(13) = v - x(14) = -a - y(14) = c - z(14) = -b - w(14) = v - x(15) = a - y(15) = -c - z(15) = -b - w(15) = v - x(16) = -a - y(16) = -c - z(16) = -b - w(16) = v - x(17) = b - y(17) = a - z(17) = c - w(17) = v - x(18) = -b - y(18) = a - z(18) = c - w(18) = v - x(19) = b - y(19) = -a - z(19) = c - w(19) = v - x(20) = -b - y(20) = -a - z(20) = c - w(20) = v - x(21) = b - y(21) = a - z(21) = -c - w(21) = v - x(22) = -b - y(22) = a - z(22) = -c - w(22) = v - x(23) = b - y(23) = -a - z(23) = -c - w(23) = v - x(24) = -b - y(24) = -a - z(24) = -c - w(24) = v - x(25) = b - y(25) = c - z(25) = a - w(25) = v - x(26) = -b - y(26) = c - z(26) = a - w(26) = v - x(27) = b - y(27) = -c - z(27) = a - w(27) = v - x(28) = -b - y(28) = -c - z(28) = a - w(28) = v - x(29) = b - y(29) = c - z(29) = -a - w(29) = v - x(30) = -b - y(30) = c - z(30) = -a - w(30) = v - x(31) = b - y(31) = -c - z(31) = -a - w(31) = v - x(32) = -b - y(32) = -c - z(32) = -a - w(32) = v - x(33) = c - y(33) = a - z(33) = b - w(33) = v - x(34) = -c - y(34) = a - z(34) = b - w(34) = v - x(35) = c - y(35) = -a - z(35) = b - w(35) = v - x(36) = -c - y(36) = -a - z(36) = b - w(36) = v - x(37) = c - y(37) = a - z(37) = -b - w(37) = v - x(38) = -c - y(38) = a - z(38) = -b - w(38) = v - x(39) = c - y(39) = -a - z(39) = -b - w(39) = v - x(40) = -c - y(40) = -a - z(40) = -b - w(40) = v - x(41) = c - y(41) = b - z(41) = a - w(41) = v - x(42) = -c - y(42) = b - z(42) = a - w(42) = v - x(43) = c - y(43) = -b - z(43) = a - w(43) = v - x(44) = -c - y(44) = -b - z(44) = a - w(44) = v - x(45) = c - y(45) = b - z(45) = -a - w(45) = v - x(46) = -c - y(46) = b - z(46) = -a - w(46) = v - x(47) = c - y(47) = -b - z(47) = -a - w(47) = v - x(48) = -c - y(48) = -b - z(48) = -a - w(48) = v - num=num+48 - return - end - SUBROUTINE LD0006(X,Y,Z,W,N) - DOUBLE PRECISION X( 6) - DOUBLE PRECISION Y( 6) - DOUBLE PRECISION Z( 6) - DOUBLE PRECISION W( 6) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 6-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.1666666666666667D+0 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0014(X,Y,Z,W,N) - DOUBLE PRECISION X( 14) - DOUBLE PRECISION Y( 14) - DOUBLE PRECISION Z( 14) - DOUBLE PRECISION W( 14) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 14-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.6666666666666667D-1 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.7500000000000000D-1 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0026(X,Y,Z,W,N) - DOUBLE PRECISION X( 26) - DOUBLE PRECISION Y( 26) - DOUBLE PRECISION Z( 26) - DOUBLE PRECISION W( 26) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 26-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.4761904761904762D-1 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.3809523809523810D-1 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.3214285714285714D-1 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0038(X,Y,Z,W,N) - DOUBLE PRECISION X( 38) - DOUBLE PRECISION Y( 38) - DOUBLE PRECISION Z( 38) - DOUBLE PRECISION W( 38) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 38-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.9523809523809524D-2 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.3214285714285714D-1 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4597008433809831D+0 - V=0.2857142857142857D-1 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0050(X,Y,Z,W,N) - DOUBLE PRECISION X( 50) - DOUBLE PRECISION Y( 50) - DOUBLE PRECISION Z( 50) - DOUBLE PRECISION W( 50) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 50-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.1269841269841270D-1 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2257495590828924D-1 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2109375000000000D-1 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3015113445777636D+0 - V=0.2017333553791887D-1 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0074(X,Y,Z,W,N) - DOUBLE PRECISION X( 74) - DOUBLE PRECISION Y( 74) - DOUBLE PRECISION Z( 74) - DOUBLE PRECISION W( 74) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 74-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.5130671797338464D-3 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.1660406956574204D-1 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=-0.2958603896103896D-1 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4803844614152614D+0 - V=0.2657620708215946D-1 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3207726489807764D+0 - V=0.1652217099371571D-1 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0086(X,Y,Z,W,N) - DOUBLE PRECISION X( 86) - DOUBLE PRECISION Y( 86) - DOUBLE PRECISION Z( 86) - DOUBLE PRECISION W( 86) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 86-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.1154401154401154D-1 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.1194390908585628D-1 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3696028464541502D+0 - V=0.1111055571060340D-1 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6943540066026664D+0 - V=0.1187650129453714D-1 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3742430390903412D+0 - V=0.1181230374690448D-1 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0110(X,Y,Z,W,N) - DOUBLE PRECISION X( 110) - DOUBLE PRECISION Y( 110) - DOUBLE PRECISION Z( 110) - DOUBLE PRECISION W( 110) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 110-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.3828270494937162D-2 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.9793737512487512D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1851156353447362D+0 - V=0.8211737283191111D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6904210483822922D+0 - V=0.9942814891178103D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3956894730559419D+0 - V=0.9595471336070963D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4783690288121502D+0 - V=0.9694996361663028D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0146(X,Y,Z,W,N) - DOUBLE PRECISION X( 146) - DOUBLE PRECISION Y( 146) - DOUBLE PRECISION Z( 146) - DOUBLE PRECISION W( 146) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 146-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.5996313688621381D-3 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.7372999718620756D-2 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.7210515360144488D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6764410400114264D+0 - V=0.7116355493117555D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4174961227965453D+0 - V=0.6753829486314477D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1574676672039082D+0 - V=0.7574394159054034D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1403553811713183D+0 - B=0.4493328323269557D+0 - V=0.6991087353303262D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0170(X,Y,Z,W,N) - DOUBLE PRECISION X( 170) - DOUBLE PRECISION Y( 170) - DOUBLE PRECISION Z( 170) - DOUBLE PRECISION W( 170) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 170-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.5544842902037365D-2 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.6071332770670752D-2 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.6383674773515093D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2551252621114134D+0 - V=0.5183387587747790D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6743601460362766D+0 - V=0.6317929009813725D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4318910696719410D+0 - V=0.6201670006589077D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2613931360335988D+0 - V=0.5477143385137348D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4990453161796037D+0 - B=0.1446630744325115D+0 - V=0.5968383987681156D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0194(X,Y,Z,W,N) - DOUBLE PRECISION X( 194) - DOUBLE PRECISION Y( 194) - DOUBLE PRECISION Z( 194) - DOUBLE PRECISION W( 194) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 194-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.1782340447244611D-2 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.5716905949977102D-2 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.5573383178848738D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6712973442695226D+0 - V=0.5608704082587997D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2892465627575439D+0 - V=0.5158237711805383D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4446933178717437D+0 - V=0.5518771467273614D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1299335447650067D+0 - V=0.4106777028169394D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3457702197611283D+0 - V=0.5051846064614808D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1590417105383530D+0 - B=0.8360360154824589D+0 - V=0.5530248916233094D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0230(X,Y,Z,W,N) - DOUBLE PRECISION X( 230) - DOUBLE PRECISION Y( 230) - DOUBLE PRECISION Z( 230) - DOUBLE PRECISION W( 230) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 230-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=-0.5522639919727325D-1 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.4450274607445226D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4492044687397611D+0 - V=0.4496841067921404D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2520419490210201D+0 - V=0.5049153450478750D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6981906658447242D+0 - V=0.3976408018051883D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6587405243460960D+0 - V=0.4401400650381014D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4038544050097660D-1 - V=0.1724544350544401D-1 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5823842309715585D+0 - V=0.4231083095357343D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3545877390518688D+0 - V=0.5198069864064399D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2272181808998187D+0 - B=0.4864661535886647D+0 - V=0.4695720972568883D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0266(X,Y,Z,W,N) - DOUBLE PRECISION X( 266) - DOUBLE PRECISION Y( 266) - DOUBLE PRECISION Z( 266) - DOUBLE PRECISION W( 266) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 266-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=-0.1313769127326952D-2 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=-0.2522728704859336D-2 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.4186853881700583D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7039373391585475D+0 - V=0.5315167977810885D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1012526248572414D+0 - V=0.4047142377086219D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4647448726420539D+0 - V=0.4112482394406990D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3277420654971629D+0 - V=0.3595584899758782D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6620338663699974D+0 - V=0.4256131351428158D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8506508083520399D+0 - V=0.4229582700647240D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3233484542692899D+0 - B=0.1153112011009701D+0 - V=0.4080914225780505D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2314790158712601D+0 - B=0.5244939240922365D+0 - V=0.4071467593830964D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0302(X,Y,Z,W,N) - DOUBLE PRECISION X( 302) - DOUBLE PRECISION Y( 302) - DOUBLE PRECISION Z( 302) - DOUBLE PRECISION W( 302) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 302-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.8545911725128148D-3 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.3599119285025571D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3515640345570105D+0 - V=0.3449788424305883D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6566329410219612D+0 - V=0.3604822601419882D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4729054132581005D+0 - V=0.3576729661743367D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9618308522614784D-1 - V=0.2352101413689164D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2219645236294178D+0 - V=0.3108953122413675D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7011766416089545D+0 - V=0.3650045807677255D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2644152887060663D+0 - V=0.2982344963171804D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5718955891878961D+0 - V=0.3600820932216460D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2510034751770465D+0 - B=0.8000727494073952D+0 - V=0.3571540554273387D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1233548532583327D+0 - B=0.4127724083168531D+0 - V=0.3392312205006170D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0350(X,Y,Z,W,N) - DOUBLE PRECISION X( 350) - DOUBLE PRECISION Y( 350) - DOUBLE PRECISION Z( 350) - DOUBLE PRECISION W( 350) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 350-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.3006796749453936D-2 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.3050627745650771D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7068965463912316D+0 - V=0.1621104600288991D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4794682625712025D+0 - V=0.3005701484901752D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1927533154878019D+0 - V=0.2990992529653774D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6930357961327123D+0 - V=0.2982170644107595D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3608302115520091D+0 - V=0.2721564237310992D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6498486161496169D+0 - V=0.3033513795811141D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1932945013230339D+0 - V=0.3007949555218533D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3800494919899303D+0 - V=0.2881964603055307D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2899558825499574D+0 - B=0.7934537856582316D+0 - V=0.2958357626535696D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9684121455103957D-1 - B=0.8280801506686862D+0 - V=0.3036020026407088D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1833434647041659D+0 - B=0.9074658265305127D+0 - V=0.2832187403926303D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0434(X,Y,Z,W,N) - DOUBLE PRECISION X( 434) - DOUBLE PRECISION Y( 434) - DOUBLE PRECISION Z( 434) - DOUBLE PRECISION W( 434) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 434-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.5265897968224436D-3 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2548219972002607D-2 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2512317418927307D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6909346307509111D+0 - V=0.2530403801186355D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1774836054609158D+0 - V=0.2014279020918528D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4914342637784746D+0 - V=0.2501725168402936D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6456664707424256D+0 - V=0.2513267174597564D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2861289010307638D+0 - V=0.2302694782227416D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7568084367178018D-1 - V=0.1462495621594614D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3927259763368002D+0 - V=0.2445373437312980D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8818132877794288D+0 - V=0.2417442375638981D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9776428111182649D+0 - V=0.1910951282179532D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2054823696403044D+0 - B=0.8689460322872412D+0 - V=0.2416930044324775D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5905157048925271D+0 - B=0.7999278543857286D+0 - V=0.2512236854563495D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5550152361076807D+0 - B=0.7717462626915901D+0 - V=0.2496644054553086D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9371809858553722D+0 - B=0.3344363145343455D+0 - V=0.2236607760437849D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0590(X,Y,Z,W,N) - DOUBLE PRECISION X( 590) - DOUBLE PRECISION Y( 590) - DOUBLE PRECISION Z( 590) - DOUBLE PRECISION W( 590) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 590-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.3095121295306187D-3 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.1852379698597489D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7040954938227469D+0 - V=0.1871790639277744D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6807744066455243D+0 - V=0.1858812585438317D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6372546939258752D+0 - V=0.1852028828296213D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5044419707800358D+0 - V=0.1846715956151242D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4215761784010967D+0 - V=0.1818471778162769D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3317920736472123D+0 - V=0.1749564657281154D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2384736701421887D+0 - V=0.1617210647254411D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1459036449157763D+0 - V=0.1384737234851692D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6095034115507196D-1 - V=0.9764331165051050D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6116843442009876D+0 - V=0.1857161196774078D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3964755348199858D+0 - V=0.1705153996395864D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1724782009907724D+0 - V=0.1300321685886048D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5610263808622060D+0 - B=0.3518280927733519D+0 - V=0.1842866472905286D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4742392842551980D+0 - B=0.2634716655937950D+0 - V=0.1802658934377451D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5984126497885380D+0 - B=0.1816640840360209D+0 - V=0.1849830560443660D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3791035407695563D+0 - B=0.1720795225656878D+0 - V=0.1713904507106709D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2778673190586244D+0 - B=0.8213021581932511D-1 - V=0.1555213603396808D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5033564271075117D+0 - B=0.8999205842074875D-1 - V=0.1802239128008525D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0770(X,Y,Z,W,N) - DOUBLE PRECISION X( 770) - DOUBLE PRECISION Y( 770) - DOUBLE PRECISION Z( 770) - DOUBLE PRECISION W( 770) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 770-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.2192942088181184D-3 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.1436433617319080D-2 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.1421940344335877D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5087204410502360D-1 - V=0.6798123511050502D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1228198790178831D+0 - V=0.9913184235294912D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2026890814408786D+0 - V=0.1180207833238949D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2847745156464294D+0 - V=0.1296599602080921D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3656719078978026D+0 - V=0.1365871427428316D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4428264886713469D+0 - V=0.1402988604775325D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5140619627249735D+0 - V=0.1418645563595609D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6306401219166803D+0 - V=0.1421376741851662D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6716883332022612D+0 - V=0.1423996475490962D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6979792685336881D+0 - V=0.1431554042178567D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1446865674195309D+0 - V=0.9254401499865368D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3390263475411216D+0 - V=0.1250239995053509D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5335804651263506D+0 - V=0.1394365843329230D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6944024393349413D-1 - B=0.2355187894242326D+0 - V=0.1127089094671749D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2269004109529460D+0 - B=0.4102182474045730D+0 - V=0.1345753760910670D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8025574607775339D-1 - B=0.6214302417481605D+0 - V=0.1424957283316783D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1467999527896572D+0 - B=0.3245284345717394D+0 - V=0.1261523341237750D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1571507769824727D+0 - B=0.5224482189696630D+0 - V=0.1392547106052696D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2365702993157246D+0 - B=0.6017546634089558D+0 - V=0.1418761677877656D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7714815866765732D-1 - B=0.4346575516141163D+0 - V=0.1338366684479554D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3062936666210730D+0 - B=0.4908826589037616D+0 - V=0.1393700862676131D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3822477379524787D+0 - B=0.5648768149099500D+0 - V=0.1415914757466932D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0974(X,Y,Z,W,N) - DOUBLE PRECISION X( 974) - DOUBLE PRECISION Y( 974) - DOUBLE PRECISION Z( 974) - DOUBLE PRECISION W( 974) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 974-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.1438294190527431D-3 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.1125772288287004D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4292963545341347D-1 - V=0.4948029341949241D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1051426854086404D+0 - V=0.7357990109125470D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1750024867623087D+0 - V=0.8889132771304384D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2477653379650257D+0 - V=0.9888347838921435D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3206567123955957D+0 - V=0.1053299681709471D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3916520749849983D+0 - V=0.1092778807014578D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4590825874187624D+0 - V=0.1114389394063227D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5214563888415861D+0 - V=0.1123724788051555D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6253170244654199D+0 - V=0.1125239325243814D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6637926744523170D+0 - V=0.1126153271815905D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6910410398498301D+0 - V=0.1130286931123841D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7052907007457760D+0 - V=0.1134986534363955D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1236686762657990D+0 - V=0.6823367927109931D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2940777114468387D+0 - V=0.9454158160447096D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4697753849207649D+0 - V=0.1074429975385679D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6334563241139567D+0 - V=0.1129300086569132D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5974048614181342D-1 - B=0.2029128752777523D+0 - V=0.8436884500901954D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1375760408473636D+0 - B=0.4602621942484054D+0 - V=0.1075255720448885D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3391016526336286D+0 - B=0.5030673999662036D+0 - V=0.1108577236864462D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1271675191439820D+0 - B=0.2817606422442134D+0 - V=0.9566475323783357D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2693120740413512D+0 - B=0.4331561291720157D+0 - V=0.1080663250717391D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1419786452601918D+0 - B=0.6256167358580814D+0 - V=0.1126797131196295D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6709284600738255D-1 - B=0.3798395216859157D+0 - V=0.1022568715358061D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7057738183256172D-1 - B=0.5517505421423520D+0 - V=0.1108960267713108D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2783888477882155D+0 - B=0.6029619156159187D+0 - V=0.1122790653435766D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1979578938917407D+0 - B=0.3589606329589096D+0 - V=0.1032401847117460D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2087307061103274D+0 - B=0.5348666438135476D+0 - V=0.1107249382283854D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4055122137872836D+0 - B=0.5674997546074373D+0 - V=0.1121780048519972D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD1202(X,Y,Z,W,N) - DOUBLE PRECISION X(1202) - DOUBLE PRECISION Y(1202) - DOUBLE PRECISION Z(1202) - DOUBLE PRECISION W(1202) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 1202-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.1105189233267572D-3 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.9205232738090741D-3 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.9133159786443561D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3712636449657089D-1 - V=0.3690421898017899D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9140060412262223D-1 - V=0.5603990928680660D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1531077852469906D+0 - V=0.6865297629282609D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2180928891660612D+0 - V=0.7720338551145630D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2839874532200175D+0 - V=0.8301545958894795D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3491177600963764D+0 - V=0.8686692550179628D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4121431461444309D+0 - V=0.8927076285846890D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4718993627149127D+0 - V=0.9060820238568219D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5273145452842337D+0 - V=0.9119777254940867D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6209475332444019D+0 - V=0.9128720138604181D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6569722711857291D+0 - V=0.9130714935691735D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6841788309070143D+0 - V=0.9152873784554116D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7012604330123631D+0 - V=0.9187436274321654D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1072382215478166D+0 - V=0.5176977312965694D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2582068959496968D+0 - V=0.7331143682101417D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4172752955306717D+0 - V=0.8463232836379928D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5700366911792503D+0 - V=0.9031122694253992D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9827986018263947D+0 - B=0.1771774022615325D+0 - V=0.6485778453163257D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9624249230326228D+0 - B=0.2475716463426288D+0 - V=0.7435030910982369D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9402007994128811D+0 - B=0.3354616289066489D+0 - V=0.7998527891839054D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9320822040143202D+0 - B=0.3173615246611977D+0 - V=0.8101731497468018D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9043674199393299D+0 - B=0.4090268427085357D+0 - V=0.8483389574594331D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8912407560074747D+0 - B=0.3854291150669224D+0 - V=0.8556299257311812D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8676435628462708D+0 - B=0.4932221184851285D+0 - V=0.8803208679738260D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8581979986041619D+0 - B=0.4785320675922435D+0 - V=0.8811048182425720D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8396753624049856D+0 - B=0.4507422593157064D+0 - V=0.8850282341265444D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8165288564022188D+0 - B=0.5632123020762100D+0 - V=0.9021342299040653D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8015469370783529D+0 - B=0.5434303569693900D+0 - V=0.9010091677105086D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7773563069070351D+0 - B=0.5123518486419871D+0 - V=0.9022692938426915D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7661621213900394D+0 - B=0.6394279634749102D+0 - V=0.9158016174693465D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7553584143533510D+0 - B=0.6269805509024392D+0 - V=0.9131578003189435D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7344305757559503D+0 - B=0.6031161693096310D+0 - V=0.9107813579482705D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7043837184021765D+0 - B=0.5693702498468441D+0 - V=0.9105760258970126D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD1454(X,Y,Z,W,N) - DOUBLE PRECISION X(1454) - DOUBLE PRECISION Y(1454) - DOUBLE PRECISION Z(1454) - DOUBLE PRECISION W(1454) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 1454-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.7777160743261247D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.7557646413004701D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3229290663413854D-1 - V=0.2841633806090617D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8036733271462222D-1 - V=0.4374419127053555D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1354289960531653D+0 - V=0.5417174740872172D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1938963861114426D+0 - V=0.6148000891358593D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2537343715011275D+0 - V=0.6664394485800705D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3135251434752570D+0 - V=0.7025039356923220D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3721558339375338D+0 - V=0.7268511789249627D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4286809575195696D+0 - V=0.7422637534208629D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4822510128282994D+0 - V=0.7509545035841214D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5320679333566263D+0 - V=0.7548535057718401D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6172998195394274D+0 - V=0.7554088969774001D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6510679849127481D+0 - V=0.7553147174442808D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6777315251687360D+0 - V=0.7564767653292297D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6963109410648741D+0 - V=0.7587991808518730D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7058935009831749D+0 - V=0.7608261832033027D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9955546194091857D+0 - V=0.4021680447874916D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9734115901794209D+0 - V=0.5804871793945964D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9275693732388626D+0 - V=0.6792151955945159D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8568022422795103D+0 - V=0.7336741211286294D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7623495553719372D+0 - V=0.7581866300989608D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5707522908892223D+0 - B=0.4387028039889501D+0 - V=0.7538257859800743D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5196463388403083D+0 - B=0.3858908414762617D+0 - V=0.7483517247053123D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4646337531215351D+0 - B=0.3301937372343854D+0 - V=0.7371763661112059D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4063901697557691D+0 - B=0.2725423573563777D+0 - V=0.7183448895756934D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3456329466643087D+0 - B=0.2139510237495250D+0 - V=0.6895815529822191D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2831395121050332D+0 - B=0.1555922309786647D+0 - V=0.6480105801792886D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2197682022925330D+0 - B=0.9892878979686097D-1 - V=0.5897558896594636D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1564696098650355D+0 - B=0.4598642910675510D-1 - V=0.5095708849247346D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6027356673721295D+0 - B=0.3376625140173426D+0 - V=0.7536906428909755D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5496032320255096D+0 - B=0.2822301309727988D+0 - V=0.7472505965575118D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4921707755234567D+0 - B=0.2248632342592540D+0 - V=0.7343017132279698D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4309422998598483D+0 - B=0.1666224723456479D+0 - V=0.7130871582177445D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3664108182313672D+0 - B=0.1086964901822169D+0 - V=0.6817022032112776D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2990189057758436D+0 - B=0.5251989784120085D-1 - V=0.6380941145604121D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6268724013144998D+0 - B=0.2297523657550023D+0 - V=0.7550381377920310D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5707324144834607D+0 - B=0.1723080607093800D+0 - V=0.7478646640144802D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5096360901960365D+0 - B=0.1140238465390513D+0 - V=0.7335918720601220D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4438729938312456D+0 - B=0.5611522095882537D-1 - V=0.7110120527658118D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6419978471082389D+0 - B=0.1164174423140873D+0 - V=0.7571363978689501D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5817218061802611D+0 - B=0.5797589531445219D-1 - V=0.7489908329079234D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD1730(X,Y,Z,W,N) - DOUBLE PRECISION X(1730) - DOUBLE PRECISION Y(1730) - DOUBLE PRECISION Z(1730) - DOUBLE PRECISION W(1730) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 1730-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.6309049437420976D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.6398287705571748D-3 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.6357185073530720D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2860923126194662D-1 - V=0.2221207162188168D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7142556767711522D-1 - V=0.3475784022286848D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1209199540995559D+0 - V=0.4350742443589804D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1738673106594379D+0 - V=0.4978569136522127D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2284645438467734D+0 - V=0.5435036221998053D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2834807671701512D+0 - V=0.5765913388219542D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3379680145467339D+0 - V=0.6001200359226003D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3911355454819537D+0 - V=0.6162178172717512D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4422860353001403D+0 - V=0.6265218152438485D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4907781568726057D+0 - V=0.6323987160974212D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5360006153211468D+0 - V=0.6350767851540569D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6142105973596603D+0 - V=0.6354362775297107D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6459300387977504D+0 - V=0.6352302462706235D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6718056125089225D+0 - V=0.6358117881417972D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6910888533186254D+0 - V=0.6373101590310117D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7030467416823252D+0 - V=0.6390428961368665D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8354951166354646D-1 - V=0.3186913449946576D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2050143009099486D+0 - V=0.4678028558591711D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3370208290706637D+0 - V=0.5538829697598626D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4689051484233963D+0 - V=0.6044475907190476D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5939400424557334D+0 - V=0.6313575103509012D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1394983311832261D+0 - B=0.4097581162050343D-1 - V=0.4078626431855630D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1967999180485014D+0 - B=0.8851987391293348D-1 - V=0.4759933057812725D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2546183732548967D+0 - B=0.1397680182969819D+0 - V=0.5268151186413440D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3121281074713875D+0 - B=0.1929452542226526D+0 - V=0.5643048560507316D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3685981078502492D+0 - B=0.2467898337061562D+0 - V=0.5914501076613073D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4233760321547856D+0 - B=0.3003104124785409D+0 - V=0.6104561257874195D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4758671236059246D+0 - B=0.3526684328175033D+0 - V=0.6230252860707806D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5255178579796463D+0 - B=0.4031134861145713D+0 - V=0.6305618761760796D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5718025633734589D+0 - B=0.4509426448342351D+0 - V=0.6343092767597889D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2686927772723415D+0 - B=0.4711322502423248D-1 - V=0.5176268945737826D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3306006819904809D+0 - B=0.9784487303942695D-1 - V=0.5564840313313692D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3904906850594983D+0 - B=0.1505395810025273D+0 - V=0.5856426671038980D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4479957951904390D+0 - B=0.2039728156296050D+0 - V=0.6066386925777091D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5027076848919780D+0 - B=0.2571529941121107D+0 - V=0.6208824962234458D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5542087392260217D+0 - B=0.3092191375815670D+0 - V=0.6296314297822907D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6020850887375187D+0 - B=0.3593807506130276D+0 - V=0.6340423756791859D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4019851409179594D+0 - B=0.5063389934378671D-1 - V=0.5829627677107342D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4635614567449800D+0 - B=0.1032422269160612D+0 - V=0.6048693376081110D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5215860931591575D+0 - B=0.1566322094006254D+0 - V=0.6202362317732461D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5758202499099271D+0 - B=0.2098082827491099D+0 - V=0.6299005328403779D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6259893683876795D+0 - B=0.2618824114553391D+0 - V=0.6347722390609353D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5313795124811891D+0 - B=0.5263245019338556D-1 - V=0.6203778981238834D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5893317955931995D+0 - B=0.1061059730982005D+0 - V=0.6308414671239979D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6426246321215801D+0 - B=0.1594171564034221D+0 - V=0.6362706466959498D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6511904367376113D+0 - B=0.5354789536565540D-1 - V=0.6375414170333233D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD2030(X,Y,Z,W,N) - DOUBLE PRECISION X(2030) - DOUBLE PRECISION Y(2030) - DOUBLE PRECISION Z(2030) - DOUBLE PRECISION W(2030) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 2030-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.4656031899197431D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.5421549195295507D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2540835336814348D-1 - V=0.1778522133346553D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6399322800504915D-1 - V=0.2811325405682796D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1088269469804125D+0 - V=0.3548896312631459D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1570670798818287D+0 - V=0.4090310897173364D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2071163932282514D+0 - V=0.4493286134169965D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2578914044450844D+0 - V=0.4793728447962723D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3085687558169623D+0 - V=0.5015415319164265D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3584719706267024D+0 - V=0.5175127372677937D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4070135594428709D+0 - V=0.5285522262081019D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4536618626222638D+0 - V=0.5356832703713962D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4979195686463577D+0 - V=0.5397914736175170D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5393075111126999D+0 - V=0.5416899441599930D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6115617676843916D+0 - V=0.5419308476889938D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6414308435160159D+0 - V=0.5416936902030596D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6664099412721607D+0 - V=0.5419544338703164D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6859161771214913D+0 - V=0.5428983656630975D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6993625593503890D+0 - V=0.5442286500098193D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7062393387719380D+0 - V=0.5452250345057301D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7479028168349763D-1 - V=0.2568002497728530D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1848951153969366D+0 - V=0.3827211700292145D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3059529066581305D+0 - V=0.4579491561917824D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4285556101021362D+0 - V=0.5042003969083574D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5468758653496526D+0 - V=0.5312708889976025D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6565821978343439D+0 - V=0.5438401790747117D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1253901572367117D+0 - B=0.3681917226439641D-1 - V=0.3316041873197344D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1775721510383941D+0 - B=0.7982487607213301D-1 - V=0.3899113567153771D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2305693358216114D+0 - B=0.1264640966592335D+0 - V=0.4343343327201309D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2836502845992063D+0 - B=0.1751585683418957D+0 - V=0.4679415262318919D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3361794746232590D+0 - B=0.2247995907632670D+0 - V=0.4930847981631031D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3875979172264824D+0 - B=0.2745299257422246D+0 - V=0.5115031867540091D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4374019316999074D+0 - B=0.3236373482441118D+0 - V=0.5245217148457367D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4851275843340022D+0 - B=0.3714967859436741D+0 - V=0.5332041499895321D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5303391803806868D+0 - B=0.4175353646321745D+0 - V=0.5384583126021542D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5726197380596287D+0 - B=0.4612084406355461D+0 - V=0.5411067210798852D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2431520732564863D+0 - B=0.4258040133043952D-1 - V=0.4259797391468714D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3002096800895869D+0 - B=0.8869424306722721D-1 - V=0.4604931368460021D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3558554457457432D+0 - B=0.1368811706510655D+0 - V=0.4871814878255202D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4097782537048887D+0 - B=0.1860739985015033D+0 - V=0.5072242910074885D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4616337666067458D+0 - B=0.2354235077395853D+0 - V=0.5217069845235350D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5110707008417874D+0 - B=0.2842074921347011D+0 - V=0.5315785966280310D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5577415286163795D+0 - B=0.3317784414984102D+0 - V=0.5376833708758905D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6013060431366950D+0 - B=0.3775299002040700D+0 - V=0.5408032092069521D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3661596767261781D+0 - B=0.4599367887164592D-1 - V=0.4842744917904866D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4237633153506581D+0 - B=0.9404893773654421D-1 - V=0.5048926076188130D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4786328454658452D+0 - B=0.1431377109091971D+0 - V=0.5202607980478373D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5305702076789774D+0 - B=0.1924186388843570D+0 - V=0.5309932388325743D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5793436224231788D+0 - B=0.2411590944775190D+0 - V=0.5377419770895208D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6247069017094747D+0 - B=0.2886871491583605D+0 - V=0.5411696331677717D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4874315552535204D+0 - B=0.4804978774953206D-1 - V=0.5197996293282420D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5427337322059053D+0 - B=0.9716857199366665D-1 - V=0.5311120836622945D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5943493747246700D+0 - B=0.1465205839795055D+0 - V=0.5384309319956951D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6421314033564943D+0 - B=0.1953579449803574D+0 - V=0.5421859504051886D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6020628374713980D+0 - B=0.4916375015738108D-1 - V=0.5390948355046314D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6529222529856881D+0 - B=0.9861621540127005D-1 - V=0.5433312705027845D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD2354(X,Y,Z,W,N) - DOUBLE PRECISION X(2354) - DOUBLE PRECISION Y(2354) - DOUBLE PRECISION Z(2354) - DOUBLE PRECISION W(2354) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 2354-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.3922616270665292D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.4703831750854424D-3 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.4678202801282136D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2290024646530589D-1 - V=0.1437832228979900D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5779086652271284D-1 - V=0.2303572493577644D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9863103576375984D-1 - V=0.2933110752447454D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1428155792982185D+0 - V=0.3402905998359838D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1888978116601463D+0 - V=0.3759138466870372D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2359091682970210D+0 - V=0.4030638447899798D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2831228833706171D+0 - V=0.4236591432242211D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3299495857966693D+0 - V=0.4390522656946746D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3758840802660796D+0 - V=0.4502523466626247D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4204751831009480D+0 - V=0.4580577727783541D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4633068518751051D+0 - V=0.4631391616615899D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5039849474507313D+0 - V=0.4660928953698676D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5421265793440747D+0 - V=0.4674751807936953D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6092660230557310D+0 - V=0.4676414903932920D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6374654204984869D+0 - V=0.4674086492347870D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6615136472609892D+0 - V=0.4674928539483207D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6809487285958127D+0 - V=0.4680748979686447D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6952980021665196D+0 - V=0.4690449806389040D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7041245497695400D+0 - V=0.4699877075860818D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6744033088306065D-1 - V=0.2099942281069176D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1678684485334166D+0 - V=0.3172269150712804D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2793559049539613D+0 - V=0.3832051358546523D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3935264218057639D+0 - V=0.4252193818146985D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5052629268232558D+0 - V=0.4513807963755000D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6107905315437531D+0 - V=0.4657797469114178D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1135081039843524D+0 - B=0.3331954884662588D-1 - V=0.2733362800522836D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1612866626099378D+0 - B=0.7247167465436538D-1 - V=0.3235485368463559D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2100786550168205D+0 - B=0.1151539110849745D+0 - V=0.3624908726013453D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2592282009459942D+0 - B=0.1599491097143677D+0 - V=0.3925540070712828D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3081740561320203D+0 - B=0.2058699956028027D+0 - V=0.4156129781116235D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3564289781578164D+0 - B=0.2521624953502911D+0 - V=0.4330644984623263D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4035587288240703D+0 - B=0.2982090785797674D+0 - V=0.4459677725921312D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4491671196373903D+0 - B=0.3434762087235733D+0 - V=0.4551593004456795D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4928854782917489D+0 - B=0.3874831357203437D+0 - V=0.4613341462749918D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5343646791958988D+0 - B=0.4297814821746926D+0 - V=0.4651019618269806D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5732683216530990D+0 - B=0.4699402260943537D+0 - V=0.4670249536100625D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2214131583218986D+0 - B=0.3873602040643895D-1 - V=0.3549555576441708D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2741796504750071D+0 - B=0.8089496256902013D-1 - V=0.3856108245249010D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3259797439149485D+0 - B=0.1251732177620872D+0 - V=0.4098622845756882D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3765441148826891D+0 - B=0.1706260286403185D+0 - V=0.4286328604268950D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4255773574530558D+0 - B=0.2165115147300408D+0 - V=0.4427802198993945D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4727795117058430D+0 - B=0.2622089812225259D+0 - V=0.4530473511488561D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5178546895819012D+0 - B=0.3071721431296201D+0 - V=0.4600805475703138D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5605141192097460D+0 - B=0.3508998998801138D+0 - V=0.4644599059958017D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6004763319352512D+0 - B=0.3929160876166931D+0 - V=0.4667274455712508D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3352842634946949D+0 - B=0.4202563457288019D-1 - V=0.4069360518020356D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3891971629814670D+0 - B=0.8614309758870850D-1 - V=0.4260442819919195D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4409875565542281D+0 - B=0.1314500879380001D+0 - V=0.4408678508029063D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4904893058592484D+0 - B=0.1772189657383859D+0 - V=0.4518748115548597D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5375056138769549D+0 - B=0.2228277110050294D+0 - V=0.4595564875375116D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5818255708669969D+0 - B=0.2677179935014386D+0 - V=0.4643988774315846D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6232334858144959D+0 - B=0.3113675035544165D+0 - V=0.4668827491646946D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4489485354492058D+0 - B=0.4409162378368174D-1 - V=0.4400541823741973D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5015136875933150D+0 - B=0.8939009917748489D-1 - V=0.4514512890193797D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5511300550512623D+0 - B=0.1351806029383365D+0 - V=0.4596198627347549D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5976720409858000D+0 - B=0.1808370355053196D+0 - V=0.4648659016801781D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6409956378989354D+0 - B=0.2257852192301602D+0 - V=0.4675502017157673D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5581222330827514D+0 - B=0.4532173421637160D-1 - V=0.4598494476455523D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6074705984161695D+0 - B=0.9117488031840314D-1 - V=0.4654916955152048D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6532272537379033D+0 - B=0.1369294213140155D+0 - V=0.4684709779505137D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6594761494500487D+0 - B=0.4589901487275583D-1 - V=0.4691445539106986D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD2702(X,Y,Z,W,N) - DOUBLE PRECISION X(2702) - DOUBLE PRECISION Y(2702) - DOUBLE PRECISION Z(2702) - DOUBLE PRECISION W(2702) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 2702-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.2998675149888161D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.4077860529495355D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2065562538818703D-1 - V=0.1185349192520667D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5250918173022379D-1 - V=0.1913408643425751D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8993480082038376D-1 - V=0.2452886577209897D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1306023924436019D+0 - V=0.2862408183288702D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1732060388531418D+0 - V=0.3178032258257357D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2168727084820249D+0 - V=0.3422945667633690D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2609528309173586D+0 - V=0.3612790520235922D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3049252927938952D+0 - V=0.3758638229818521D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3483484138084404D+0 - V=0.3868711798859953D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3908321549106406D+0 - V=0.3949429933189938D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4320210071894814D+0 - V=0.4006068107541156D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4715824795890053D+0 - V=0.4043192149672723D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5091984794078453D+0 - V=0.4064947495808078D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5445580145650803D+0 - V=0.4075245619813152D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6072575796841768D+0 - V=0.4076423540893566D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6339484505755803D+0 - V=0.4074280862251555D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6570718257486958D+0 - V=0.4074163756012244D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6762557330090709D+0 - V=0.4077647795071246D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6911161696923790D+0 - V=0.4084517552782530D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7012841911659961D+0 - V=0.4092468459224052D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7064559272410020D+0 - V=0.4097872687240906D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6123554989894765D-1 - V=0.1738986811745028D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1533070348312393D+0 - V=0.2659616045280191D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2563902605244206D+0 - V=0.3240596008171533D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3629346991663361D+0 - V=0.3621195964432943D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4683949968987538D+0 - V=0.3868838330760539D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5694479240657952D+0 - V=0.4018911532693111D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6634465430993955D+0 - V=0.4089929432983252D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1033958573552305D+0 - B=0.3034544009063584D-1 - V=0.2279907527706409D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1473521412414395D+0 - B=0.6618803044247135D-1 - V=0.2715205490578897D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1924552158705967D+0 - B=0.1054431128987715D+0 - V=0.3057917896703976D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2381094362890328D+0 - B=0.1468263551238858D+0 - V=0.3326913052452555D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2838121707936760D+0 - B=0.1894486108187886D+0 - V=0.3537334711890037D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3291323133373415D+0 - B=0.2326374238761579D+0 - V=0.3700567500783129D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3736896978741460D+0 - B=0.2758485808485768D+0 - V=0.3825245372589122D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4171406040760013D+0 - B=0.3186179331996921D+0 - V=0.3918125171518296D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4591677985256915D+0 - B=0.3605329796303794D+0 - V=0.3984720419937579D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4994733831718418D+0 - B=0.4012147253586509D+0 - V=0.4029746003338211D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5377731830445096D+0 - B=0.4403050025570692D+0 - V=0.4057428632156627D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5737917830001331D+0 - B=0.4774565904277483D+0 - V=0.4071719274114857D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2027323586271389D+0 - B=0.3544122504976147D-1 - V=0.2990236950664119D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2516942375187273D+0 - B=0.7418304388646328D-1 - V=0.3262951734212878D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3000227995257181D+0 - B=0.1150502745727186D+0 - V=0.3482634608242413D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3474806691046342D+0 - B=0.1571963371209364D+0 - V=0.3656596681700892D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3938103180359209D+0 - B=0.1999631877247100D+0 - V=0.3791740467794218D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4387519590455703D+0 - B=0.2428073457846535D+0 - V=0.3894034450156905D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4820503960077787D+0 - B=0.2852575132906155D+0 - V=0.3968600245508371D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5234573778475101D+0 - B=0.3268884208674639D+0 - V=0.4019931351420050D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5627318647235282D+0 - B=0.3673033321675939D+0 - V=0.4052108801278599D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5996390607156954D+0 - B=0.4061211551830290D+0 - V=0.4068978613940934D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3084780753791947D+0 - B=0.3860125523100059D-1 - V=0.3454275351319704D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3589988275920223D+0 - B=0.7928938987104867D-1 - V=0.3629963537007920D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4078628415881973D+0 - B=0.1212614643030087D+0 - V=0.3770187233889873D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4549287258889735D+0 - B=0.1638770827382693D+0 - V=0.3878608613694378D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5000278512957279D+0 - B=0.2065965798260176D+0 - V=0.3959065270221274D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5429785044928199D+0 - B=0.2489436378852235D+0 - V=0.4015286975463570D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5835939850491711D+0 - B=0.2904811368946891D+0 - V=0.4050866785614717D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6216870353444856D+0 - B=0.3307941957666609D+0 - V=0.4069320185051913D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4151104662709091D+0 - B=0.4064829146052554D-1 - V=0.3760120964062763D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4649804275009218D+0 - B=0.8258424547294755D-1 - V=0.3870969564418064D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5124695757009662D+0 - B=0.1251841962027289D+0 - V=0.3955287790534055D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5574711100606224D+0 - B=0.1679107505976331D+0 - V=0.4015361911302668D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5998597333287227D+0 - B=0.2102805057358715D+0 - V=0.4053836986719548D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6395007148516600D+0 - B=0.2518418087774107D+0 - V=0.4073578673299117D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5188456224746252D+0 - B=0.4194321676077518D-1 - V=0.3954628379231406D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5664190707942778D+0 - B=0.8457661551921499D-1 - V=0.4017645508847530D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6110464353283153D+0 - B=0.1273652932519396D+0 - V=0.4059030348651293D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6526430302051563D+0 - B=0.1698173239076354D+0 - V=0.4080565809484880D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6167551880377548D+0 - B=0.4266398851548864D-1 - V=0.4063018753664651D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6607195418355383D+0 - B=0.8551925814238349D-1 - V=0.4087191292799671D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD3074(X,Y,Z,W,N) - DOUBLE PRECISION X(3074) - DOUBLE PRECISION Y(3074) - DOUBLE PRECISION Z(3074) - DOUBLE PRECISION W(3074) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 3074-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.2599095953754734D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.3603134089687541D-3 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.3586067974412447D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1886108518723392D-1 - V=0.9831528474385880D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4800217244625303D-1 - V=0.1605023107954450D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8244922058397242D-1 - V=0.2072200131464099D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1200408362484023D+0 - V=0.2431297618814187D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1595773530809965D+0 - V=0.2711819064496707D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2002635973434064D+0 - V=0.2932762038321116D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2415127590139982D+0 - V=0.3107032514197368D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2828584158458477D+0 - V=0.3243808058921213D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3239091015338138D+0 - V=0.3349899091374030D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3643225097962194D+0 - V=0.3430580688505218D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4037897083691802D+0 - V=0.3490124109290343D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4420247515194127D+0 - V=0.3532148948561955D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4787572538464938D+0 - V=0.3559862669062833D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5137265251275234D+0 - V=0.3576224317551411D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5466764056654611D+0 - V=0.3584050533086076D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6054859420813535D+0 - V=0.3584903581373224D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6308106701764562D+0 - V=0.3582991879040586D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6530369230179584D+0 - V=0.3582371187963125D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6718609524611158D+0 - V=0.3584353631122350D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6869676499894013D+0 - V=0.3589120166517785D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6980467077240748D+0 - V=0.3595445704531601D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7048241721250522D+0 - V=0.3600943557111074D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5591105222058232D-1 - V=0.1456447096742039D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1407384078513916D+0 - V=0.2252370188283782D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2364035438976309D+0 - V=0.2766135443474897D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3360602737818170D+0 - V=0.3110729491500851D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4356292630054665D+0 - V=0.3342506712303391D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5321569415256174D+0 - V=0.3491981834026860D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6232956305040554D+0 - V=0.3576003604348932D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9469870086838469D-1 - B=0.2778748387309470D-1 - V=0.1921921305788564D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1353170300568141D+0 - B=0.6076569878628364D-1 - V=0.2301458216495632D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1771679481726077D+0 - B=0.9703072762711040D-1 - V=0.2604248549522893D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2197066664231751D+0 - B=0.1354112458524762D+0 - V=0.2845275425870697D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2624783557374927D+0 - B=0.1750996479744100D+0 - V=0.3036870897974840D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3050969521214442D+0 - B=0.2154896907449802D+0 - V=0.3188414832298066D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3472252637196021D+0 - B=0.2560954625740152D+0 - V=0.3307046414722089D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3885610219026360D+0 - B=0.2965070050624096D+0 - V=0.3398330969031360D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4288273776062765D+0 - B=0.3363641488734497D+0 - V=0.3466757899705373D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4677662471302948D+0 - B=0.3753400029836788D+0 - V=0.3516095923230054D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5051333589553359D+0 - B=0.4131297522144286D+0 - V=0.3549645184048486D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5406942145810492D+0 - B=0.4494423776081795D+0 - V=0.3570415969441392D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5742204122576457D+0 - B=0.4839938958841502D+0 - V=0.3581251798496118D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1865407027225188D+0 - B=0.3259144851070796D-1 - V=0.2543491329913348D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2321186453689432D+0 - B=0.6835679505297343D-1 - V=0.2786711051330776D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2773159142523882D+0 - B=0.1062284864451989D+0 - V=0.2985552361083679D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3219200192237254D+0 - B=0.1454404409323047D+0 - V=0.3145867929154039D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3657032593944029D+0 - B=0.1854018282582510D+0 - V=0.3273290662067609D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4084376778363622D+0 - B=0.2256297412014750D+0 - V=0.3372705511943501D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4499004945751427D+0 - B=0.2657104425000896D+0 - V=0.3448274437851510D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4898758141326335D+0 - B=0.3052755487631557D+0 - V=0.3503592783048583D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5281547442266309D+0 - B=0.3439863920645423D+0 - V=0.3541854792663162D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5645346989813992D+0 - B=0.3815229456121914D+0 - V=0.3565995517909428D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5988181252159848D+0 - B=0.4175752420966734D+0 - V=0.3578802078302898D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2850425424471603D+0 - B=0.3562149509862536D-1 - V=0.2958644592860982D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3324619433027876D+0 - B=0.7330318886871096D-1 - V=0.3119548129116835D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3785848333076282D+0 - B=0.1123226296008472D+0 - V=0.3250745225005984D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4232891028562115D+0 - B=0.1521084193337708D+0 - V=0.3355153415935208D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4664287050829722D+0 - B=0.1921844459223610D+0 - V=0.3435847568549328D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5078458493735726D+0 - B=0.2321360989678303D+0 - V=0.3495786831622488D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5473779816204180D+0 - B=0.2715886486360520D+0 - V=0.3537767805534621D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5848617133811376D+0 - B=0.3101924707571355D+0 - V=0.3564459815421428D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6201348281584888D+0 - B=0.3476121052890973D+0 - V=0.3578464061225468D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3852191185387871D+0 - B=0.3763224880035108D-1 - V=0.3239748762836212D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4325025061073423D+0 - B=0.7659581935637135D-1 - V=0.3345491784174287D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4778486229734490D+0 - B=0.1163381306083900D+0 - V=0.3429126177301782D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5211663693009000D+0 - B=0.1563890598752899D+0 - V=0.3492420343097421D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5623469504853703D+0 - B=0.1963320810149200D+0 - V=0.3537399050235257D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6012718188659246D+0 - B=0.2357847407258738D+0 - V=0.3566209152659172D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6378179206390117D+0 - B=0.2743846121244060D+0 - V=0.3581084321919782D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4836936460214534D+0 - B=0.3895902610739024D-1 - V=0.3426522117591512D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5293792562683797D+0 - B=0.7871246819312640D-1 - V=0.3491848770121379D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5726281253100033D+0 - B=0.1187963808202981D+0 - V=0.3539318235231476D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6133658776169068D+0 - B=0.1587914708061787D+0 - V=0.3570231438458694D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6515085491865307D+0 - B=0.1983058575227646D+0 - V=0.3586207335051714D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5778692716064976D+0 - B=0.3977209689791542D-1 - V=0.3541196205164025D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6207904288086192D+0 - B=0.7990157592981152D-1 - V=0.3574296911573953D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6608688171046802D+0 - B=0.1199671308754309D+0 - V=0.3591993279818963D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6656263089489130D+0 - B=0.4015955957805969D-1 - V=0.3595855034661997D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD3470(X,Y,Z,W,N) - DOUBLE PRECISION X(3470) - DOUBLE PRECISION Y(3470) - DOUBLE PRECISION Z(3470) - DOUBLE PRECISION W(3470) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 3470-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.2040382730826330D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.3178149703889544D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1721420832906233D-1 - V=0.8288115128076110D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4408875374981770D-1 - V=0.1360883192522954D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7594680813878681D-1 - V=0.1766854454542662D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1108335359204799D+0 - V=0.2083153161230153D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1476517054388567D+0 - V=0.2333279544657158D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1856731870860615D+0 - V=0.2532809539930247D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2243634099428821D+0 - V=0.2692472184211158D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2633006881662727D+0 - V=0.2819949946811885D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3021340904916283D+0 - V=0.2920953593973030D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3405594048030089D+0 - V=0.2999889782948352D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3783044434007372D+0 - V=0.3060292120496902D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4151194767407910D+0 - V=0.3105109167522192D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4507705766443257D+0 - V=0.3136902387550312D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4850346056573187D+0 - V=0.3157984652454632D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5176950817792470D+0 - V=0.3170516518425422D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5485384240820989D+0 - V=0.3176568425633755D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6039117238943308D+0 - V=0.3177198411207062D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6279956655573113D+0 - V=0.3175519492394733D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6493636169568952D+0 - V=0.3174654952634756D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6677644117704504D+0 - V=0.3175676415467654D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6829368572115624D+0 - V=0.3178923417835410D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6946195818184121D+0 - V=0.3183788287531909D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7025711542057026D+0 - V=0.3188755151918807D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7066004767140119D+0 - V=0.3191916889313849D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5132537689946062D-1 - V=0.1231779611744508D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1297994661331225D+0 - V=0.1924661373839880D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2188852049401307D+0 - V=0.2380881867403424D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3123174824903457D+0 - V=0.2693100663037885D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4064037620738195D+0 - V=0.2908673382834366D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4984958396944782D+0 - V=0.3053914619381535D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5864975046021365D+0 - V=0.3143916684147777D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6686711634580175D+0 - V=0.3187042244055363D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8715738780835950D-1 - B=0.2557175233367578D-1 - V=0.1635219535869790D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1248383123134007D+0 - B=0.5604823383376681D-1 - V=0.1968109917696070D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1638062693383378D+0 - B=0.8968568601900765D-1 - V=0.2236754342249974D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2035586203373176D+0 - B=0.1254086651976279D+0 - V=0.2453186687017181D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2436798975293774D+0 - B=0.1624780150162012D+0 - V=0.2627551791580541D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2838207507773806D+0 - B=0.2003422342683208D+0 - V=0.2767654860152220D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3236787502217692D+0 - B=0.2385628026255263D+0 - V=0.2879467027765895D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3629849554840691D+0 - B=0.2767731148783578D+0 - V=0.2967639918918702D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4014948081992087D+0 - B=0.3146542308245309D+0 - V=0.3035900684660351D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4389818379260225D+0 - B=0.3519196415895088D+0 - V=0.3087338237298308D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4752331143674377D+0 - B=0.3883050984023654D+0 - V=0.3124608838860167D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5100457318374018D+0 - B=0.4235613423908649D+0 - V=0.3150084294226743D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5432238388954868D+0 - B=0.4574484717196220D+0 - V=0.3165958398598402D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5745758685072442D+0 - B=0.4897311639255524D+0 - V=0.3174320440957372D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1723981437592809D+0 - B=0.3010630597881105D-1 - V=0.2182188909812599D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2149553257844597D+0 - B=0.6326031554204694D-1 - V=0.2399727933921445D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2573256081247422D+0 - B=0.9848566980258631D-1 - V=0.2579796133514652D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2993163751238106D+0 - B=0.1350835952384266D+0 - V=0.2727114052623535D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3407238005148000D+0 - B=0.1725184055442181D+0 - V=0.2846327656281355D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3813454978483264D+0 - B=0.2103559279730725D+0 - V=0.2941491102051334D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4209848104423343D+0 - B=0.2482278774554860D+0 - V=0.3016049492136107D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4594519699996300D+0 - B=0.2858099509982883D+0 - V=0.3072949726175648D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4965640166185930D+0 - B=0.3228075659915428D+0 - V=0.3114768142886460D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5321441655571562D+0 - B=0.3589459907204151D+0 - V=0.3143823673666223D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5660208438582166D+0 - B=0.3939630088864310D+0 - V=0.3162269764661535D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5980264315964364D+0 - B=0.4276029922949089D+0 - V=0.3172164663759821D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2644215852350733D+0 - B=0.3300939429072552D-1 - V=0.2554575398967435D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3090113743443063D+0 - B=0.6803887650078501D-1 - V=0.2701704069135677D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3525871079197808D+0 - B=0.1044326136206709D+0 - V=0.2823693413468940D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3950418005354029D+0 - B=0.1416751597517679D+0 - V=0.2922898463214289D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4362475663430163D+0 - B=0.1793408610504821D+0 - V=0.3001829062162428D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4760661812145854D+0 - B=0.2170630750175722D+0 - V=0.3062890864542953D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5143551042512103D+0 - B=0.2545145157815807D+0 - V=0.3108328279264746D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5509709026935597D+0 - B=0.2913940101706601D+0 - V=0.3140243146201245D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5857711030329428D+0 - B=0.3274169910910705D+0 - V=0.3160638030977130D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6186149917404392D+0 - B=0.3623081329317265D+0 - V=0.3171462882206275D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3586894569557064D+0 - B=0.3497354386450040D-1 - V=0.2812388416031796D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4035266610019441D+0 - B=0.7129736739757095D-1 - V=0.2912137500288045D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4467775312332510D+0 - B=0.1084758620193165D+0 - V=0.2993241256502206D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4883638346608543D+0 - B=0.1460915689241772D+0 - V=0.3057101738983822D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5281908348434601D+0 - B=0.1837790832369980D+0 - V=0.3105319326251432D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5661542687149311D+0 - B=0.2212075390874021D+0 - V=0.3139565514428167D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6021450102031452D+0 - B=0.2580682841160985D+0 - V=0.3161543006806366D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6360520783610050D+0 - B=0.2940656362094121D+0 - V=0.3172985960613294D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4521611065087196D+0 - B=0.3631055365867002D-1 - V=0.2989400336901431D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4959365651560963D+0 - B=0.7348318468484350D-1 - V=0.3054555883947677D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5376815804038283D+0 - B=0.1111087643812648D+0 - V=0.3104764960807702D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5773314480243768D+0 - B=0.1488226085145408D+0 - V=0.3141015825977616D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6148113245575056D+0 - B=0.1862892274135151D+0 - V=0.3164520621159896D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6500407462842380D+0 - B=0.2231909701714456D+0 - V=0.3176652305912204D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5425151448707213D+0 - B=0.3718201306118944D-1 - V=0.3105097161023939D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5841860556907931D+0 - B=0.7483616335067346D-1 - V=0.3143014117890550D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6234632186851500D+0 - B=0.1125990834266120D+0 - V=0.3168172866287200D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6602934551848843D+0 - B=0.1501303813157619D+0 - V=0.3181401865570968D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6278573968375105D+0 - B=0.3767559930245720D-1 - V=0.3170663659156037D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6665611711264577D+0 - B=0.7548443301360158D-1 - V=0.3185447944625510D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD3890(X,Y,Z,W,N) - DOUBLE PRECISION X(3890) - DOUBLE PRECISION Y(3890) - DOUBLE PRECISION Z(3890) - DOUBLE PRECISION W(3890) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 3890-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.1807395252196920D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2848008782238827D-3 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2836065837530581D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1587876419858352D-1 - V=0.7013149266673816D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4069193593751206D-1 - V=0.1162798021956766D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7025888115257997D-1 - V=0.1518728583972105D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1027495450028704D+0 - V=0.1798796108216934D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1371457730893426D+0 - V=0.2022593385972785D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1727758532671953D+0 - V=0.2203093105575464D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2091492038929037D+0 - V=0.2349294234299855D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2458813281751915D+0 - V=0.2467682058747003D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2826545859450066D+0 - V=0.2563092683572224D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3191957291799622D+0 - V=0.2639253896763318D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3552621469299578D+0 - V=0.2699137479265108D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3906329503406230D+0 - V=0.2745196420166739D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4251028614093031D+0 - V=0.2779529197397593D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4584777520111870D+0 - V=0.2803996086684265D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4905711358710193D+0 - V=0.2820302356715842D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5212011669847385D+0 - V=0.2830056747491068D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5501878488737995D+0 - V=0.2834808950776839D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6025037877479342D+0 - V=0.2835282339078929D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6254572689549016D+0 - V=0.2833819267065800D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6460107179528248D+0 - V=0.2832858336906784D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6639541138154251D+0 - V=0.2833268235451244D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6790688515667495D+0 - V=0.2835432677029253D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6911338580371512D+0 - V=0.2839091722743049D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6999385956126490D+0 - V=0.2843308178875841D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7053037748656896D+0 - V=0.2846703550533846D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4732224387180115D-1 - V=0.1051193406971900D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1202100529326803D+0 - V=0.1657871838796974D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2034304820664855D+0 - V=0.2064648113714232D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2912285643573002D+0 - V=0.2347942745819741D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3802361792726768D+0 - V=0.2547775326597726D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4680598511056146D+0 - V=0.2686876684847025D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5528151052155599D+0 - V=0.2778665755515867D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6329386307803041D+0 - V=0.2830996616782929D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8056516651369069D-1 - B=0.2363454684003124D-1 - V=0.1403063340168372D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1156476077139389D+0 - B=0.5191291632545936D-1 - V=0.1696504125939477D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1520473382760421D+0 - B=0.8322715736994519D-1 - V=0.1935787242745390D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1892986699745931D+0 - B=0.1165855667993712D+0 - V=0.2130614510521968D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2270194446777792D+0 - B=0.1513077167409504D+0 - V=0.2289381265931048D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2648908185093273D+0 - B=0.1868882025807859D+0 - V=0.2418630292816186D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3026389259574136D+0 - B=0.2229277629776224D+0 - V=0.2523400495631193D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3400220296151384D+0 - B=0.2590951840746235D+0 - V=0.2607623973449605D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3768217953335510D+0 - B=0.2951047291750847D+0 - V=0.2674441032689209D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4128372900921884D+0 - B=0.3307019714169930D+0 - V=0.2726432360343356D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4478807131815630D+0 - B=0.3656544101087634D+0 - V=0.2765787685924545D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4817742034089257D+0 - B=0.3997448951939695D+0 - V=0.2794428690642224D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5143472814653344D+0 - B=0.4327667110812024D+0 - V=0.2814099002062895D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5454346213905650D+0 - B=0.4645196123532293D+0 - V=0.2826429531578994D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5748739313170252D+0 - B=0.4948063555703345D+0 - V=0.2832983542550884D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1599598738286342D+0 - B=0.2792357590048985D-1 - V=0.1886695565284976D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1998097412500951D+0 - B=0.5877141038139065D-1 - V=0.2081867882748234D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2396228952566202D+0 - B=0.9164573914691377D-1 - V=0.2245148680600796D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2792228341097746D+0 - B=0.1259049641962687D+0 - V=0.2380370491511872D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3184251107546741D+0 - B=0.1610594823400863D+0 - V=0.2491398041852455D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3570481164426244D+0 - B=0.1967151653460898D+0 - V=0.2581632405881230D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3949164710492144D+0 - B=0.2325404606175168D+0 - V=0.2653965506227417D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4318617293970503D+0 - B=0.2682461141151439D+0 - V=0.2710857216747087D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4677221009931678D+0 - B=0.3035720116011973D+0 - V=0.2754434093903659D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5023417939270955D+0 - B=0.3382781859197439D+0 - V=0.2786579932519380D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5355701836636128D+0 - B=0.3721383065625942D+0 - V=0.2809011080679474D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5672608451328771D+0 - B=0.4049346360466055D+0 - V=0.2823336184560987D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5972704202540162D+0 - B=0.4364538098633802D+0 - V=0.2831101175806309D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2461687022333596D+0 - B=0.3070423166833368D-1 - V=0.2221679970354546D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2881774566286831D+0 - B=0.6338034669281885D-1 - V=0.2356185734270703D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3293963604116978D+0 - B=0.9742862487067941D-1 - V=0.2469228344805590D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3697303822241377D+0 - B=0.1323799532282290D+0 - V=0.2562726348642046D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4090663023135127D+0 - B=0.1678497018129336D+0 - V=0.2638756726753028D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4472819355411712D+0 - B=0.2035095105326114D+0 - V=0.2699311157390862D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4842513377231437D+0 - B=0.2390692566672091D+0 - V=0.2746233268403837D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5198477629962928D+0 - B=0.2742649818076149D+0 - V=0.2781225674454771D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5539453011883145D+0 - B=0.3088503806580094D+0 - V=0.2805881254045684D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5864196762401251D+0 - B=0.3425904245906614D+0 - V=0.2821719877004913D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6171484466668390D+0 - B=0.3752562294789468D+0 - V=0.2830222502333124D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3350337830565727D+0 - B=0.3261589934634747D-1 - V=0.2457995956744870D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3775773224758284D+0 - B=0.6658438928081572D-1 - V=0.2551474407503706D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4188155229848973D+0 - B=0.1014565797157954D+0 - V=0.2629065335195311D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4586805892009344D+0 - B=0.1368573320843822D+0 - V=0.2691900449925075D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4970895714224235D+0 - B=0.1724614851951608D+0 - V=0.2741275485754276D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5339505133960747D+0 - B=0.2079779381416412D+0 - V=0.2778530970122595D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5691665792531440D+0 - B=0.2431385788322288D+0 - V=0.2805010567646741D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6026387682680377D+0 - B=0.2776901883049853D+0 - V=0.2822055834031040D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6342676150163307D+0 - B=0.3113881356386632D+0 - V=0.2831016901243473D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4237951119537067D+0 - B=0.3394877848664351D-1 - V=0.2624474901131803D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4656918683234929D+0 - B=0.6880219556291447D-1 - V=0.2688034163039377D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5058857069185980D+0 - B=0.1041946859721635D+0 - V=0.2738932751287636D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5443204666713996D+0 - B=0.1398039738736393D+0 - V=0.2777944791242523D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5809298813759742D+0 - B=0.1753373381196155D+0 - V=0.2806011661660987D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6156416039447128D+0 - B=0.2105215793514010D+0 - V=0.2824181456597460D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6483801351066604D+0 - B=0.2450953312157051D+0 - V=0.2833585216577828D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5103616577251688D+0 - B=0.3485560643800719D-1 - V=0.2738165236962878D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5506738792580681D+0 - B=0.7026308631512033D-1 - V=0.2778365208203180D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5889573040995292D+0 - B=0.1059035061296403D+0 - V=0.2807852940418966D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6251641589516930D+0 - B=0.1414823925236026D+0 - V=0.2827245949674705D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6592414921570178D+0 - B=0.1767207908214530D+0 - V=0.2837342344829828D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5930314017533384D+0 - B=0.3542189339561672D-1 - V=0.2809233907610981D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6309812253390175D+0 - B=0.7109574040369549D-1 - V=0.2829930809742694D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6666296011353230D+0 - B=0.1067259792282730D+0 - V=0.2841097874111479D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6703715271049922D+0 - B=0.3569455268820809D-1 - V=0.2843455206008783D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD4334(X,Y,Z,W,N) - DOUBLE PRECISION X(4334) - DOUBLE PRECISION Y(4334) - DOUBLE PRECISION Z(4334) - DOUBLE PRECISION W(4334) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 4334-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.1449063022537883D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2546377329828424D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1462896151831013D-1 - V=0.6018432961087496D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3769840812493139D-1 - V=0.1002286583263673D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6524701904096891D-1 - V=0.1315222931028093D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9560543416134648D-1 - V=0.1564213746876724D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1278335898929198D+0 - V=0.1765118841507736D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1613096104466031D+0 - V=0.1928737099311080D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1955806225745371D+0 - V=0.2062658534263270D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2302935218498028D+0 - V=0.2172395445953787D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2651584344113027D+0 - V=0.2262076188876047D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2999276825183209D+0 - V=0.2334885699462397D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3343828669718798D+0 - V=0.2393355273179203D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3683265013750518D+0 - V=0.2439559200468863D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4015763206518108D+0 - V=0.2475251866060002D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4339612026399770D+0 - V=0.2501965558158773D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4653180651114582D+0 - V=0.2521081407925925D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4954893331080803D+0 - V=0.2533881002388081D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5243207068924930D+0 - V=0.2541582900848261D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5516590479041704D+0 - V=0.2545365737525860D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6012371927804176D+0 - V=0.2545726993066799D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6231574466449819D+0 - V=0.2544456197465555D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6429416514181271D+0 - V=0.2543481596881064D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6604124272943595D+0 - V=0.2543506451429194D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6753851470408250D+0 - V=0.2544905675493763D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6876717970626160D+0 - V=0.2547611407344429D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6970895061319234D+0 - V=0.2551060375448869D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7034746912553310D+0 - V=0.2554291933816039D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7067017217542295D+0 - V=0.2556255710686343D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4382223501131123D-1 - V=0.9041339695118195D-4 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1117474077400006D+0 - V=0.1438426330079022D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1897153252911440D+0 - V=0.1802523089820518D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2724023009910331D+0 - V=0.2060052290565496D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3567163308709902D+0 - V=0.2245002248967466D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4404784483028087D+0 - V=0.2377059847731150D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5219833154161411D+0 - V=0.2468118955882525D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5998179868977553D+0 - V=0.2525410872966528D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6727803154548222D+0 - V=0.2553101409933397D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7476563943166086D-1 - B=0.2193168509461185D-1 - V=0.1212879733668632D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1075341482001416D+0 - B=0.4826419281533887D-1 - V=0.1472872881270931D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1416344885203259D+0 - B=0.7751191883575742D-1 - V=0.1686846601010828D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1766325315388586D+0 - B=0.1087558139247680D+0 - V=0.1862698414660208D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2121744174481514D+0 - B=0.1413661374253096D+0 - V=0.2007430956991861D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2479669443408145D+0 - B=0.1748768214258880D+0 - V=0.2126568125394796D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2837600452294113D+0 - B=0.2089216406612073D+0 - V=0.2224394603372113D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3193344933193984D+0 - B=0.2431987685545972D+0 - V=0.2304264522673135D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3544935442438745D+0 - B=0.2774497054377770D+0 - V=0.2368854288424087D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3890571932288154D+0 - B=0.3114460356156915D+0 - V=0.2420352089461772D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4228581214259090D+0 - B=0.3449806851913012D+0 - V=0.2460597113081295D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4557387211304052D+0 - B=0.3778618641248256D+0 - V=0.2491181912257687D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4875487950541643D+0 - B=0.4099086391698978D+0 - V=0.2513528194205857D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5181436529962997D+0 - B=0.4409474925853973D+0 - V=0.2528943096693220D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5473824095600661D+0 - B=0.4708094517711291D+0 - V=0.2538660368488136D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5751263398976174D+0 - B=0.4993275140354637D+0 - V=0.2543868648299022D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1489515746840028D+0 - B=0.2599381993267017D-1 - V=0.1642595537825183D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1863656444351767D+0 - B=0.5479286532462190D-1 - V=0.1818246659849308D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2238602880356348D+0 - B=0.8556763251425254D-1 - V=0.1966565649492420D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2612723375728160D+0 - B=0.1177257802267011D+0 - V=0.2090677905657991D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2984332990206190D+0 - B=0.1508168456192700D+0 - V=0.2193820409510504D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3351786584663333D+0 - B=0.1844801892177727D+0 - V=0.2278870827661928D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3713505522209120D+0 - B=0.2184145236087598D+0 - V=0.2348283192282090D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4067981098954663D+0 - B=0.2523590641486229D+0 - V=0.2404139755581477D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4413769993687534D+0 - B=0.2860812976901373D+0 - V=0.2448227407760734D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4749487182516394D+0 - B=0.3193686757808996D+0 - V=0.2482110455592573D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5073798105075426D+0 - B=0.3520226949547602D+0 - V=0.2507192397774103D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5385410448878654D+0 - B=0.3838544395667890D+0 - V=0.2524765968534880D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5683065353670530D+0 - B=0.4146810037640963D+0 - V=0.2536052388539425D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5965527620663510D+0 - B=0.4443224094681121D+0 - V=0.2542230588033068D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2299227700856157D+0 - B=0.2865757664057584D-1 - V=0.1944817013047896D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2695752998553267D+0 - B=0.5923421684485993D-1 - V=0.2067862362746635D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3086178716611389D+0 - B=0.9117817776057715D-1 - V=0.2172440734649114D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3469649871659077D+0 - B=0.1240593814082605D+0 - V=0.2260125991723423D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3845153566319655D+0 - B=0.1575272058259175D+0 - V=0.2332655008689523D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4211600033403215D+0 - B=0.1912845163525413D+0 - V=0.2391699681532458D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4567867834329882D+0 - B=0.2250710177858171D+0 - V=0.2438801528273928D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4912829319232061D+0 - B=0.2586521303440910D+0 - V=0.2475370504260665D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5245364793303812D+0 - B=0.2918112242865407D+0 - V=0.2502707235640574D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5564369788915756D+0 - B=0.3243439239067890D+0 - V=0.2522031701054241D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5868757697775287D+0 - B=0.3560536787835351D+0 - V=0.2534511269978784D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6157458853519617D+0 - B=0.3867480821242581D+0 - V=0.2541284914955151D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3138461110672113D+0 - B=0.3051374637507278D-1 - V=0.2161509250688394D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3542495872050569D+0 - B=0.6237111233730755D-1 - V=0.2248778513437852D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3935751553120181D+0 - B=0.9516223952401907D-1 - V=0.2322388803404617D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4317634668111147D+0 - B=0.1285467341508517D+0 - V=0.2383265471001355D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4687413842250821D+0 - B=0.1622318931656033D+0 - V=0.2432476675019525D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5044274237060283D+0 - B=0.1959581153836453D+0 - V=0.2471122223750674D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5387354077925727D+0 - B=0.2294888081183837D+0 - V=0.2500291752486870D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5715768898356105D+0 - B=0.2626031152713945D+0 - V=0.2521055942764682D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6028627200136111D+0 - B=0.2950904075286713D+0 - V=0.2534472785575503D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6325039812653463D+0 - B=0.3267458451113286D+0 - V=0.2541599713080121D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3981986708423407D+0 - B=0.3183291458749821D-1 - V=0.2317380975862936D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4382791182133300D+0 - B=0.6459548193880908D-1 - V=0.2378550733719775D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4769233057218166D+0 - B=0.9795757037087952D-1 - V=0.2428884456739118D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5140823911194238D+0 - B=0.1316307235126655D+0 - V=0.2469002655757292D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5496977833862983D+0 - B=0.1653556486358704D+0 - V=0.2499657574265851D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5837047306512727D+0 - B=0.1988931724126510D+0 - V=0.2521676168486082D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6160349566926879D+0 - B=0.2320174581438950D+0 - V=0.2535935662645334D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6466185353209440D+0 - B=0.2645106562168662D+0 - V=0.2543356743363214D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4810835158795404D+0 - B=0.3275917807743992D-1 - V=0.2427353285201535D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5199925041324341D+0 - B=0.6612546183967181D-1 - V=0.2468258039744386D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5571717692207494D+0 - B=0.9981498331474143D-1 - V=0.2500060956440310D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5925789250836378D+0 - B=0.1335687001410374D+0 - V=0.2523238365420979D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6261658523859670D+0 - B=0.1671444402896463D+0 - V=0.2538399260252846D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6578811126669331D+0 - B=0.2003106382156076D+0 - V=0.2546255927268069D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5609624612998100D+0 - B=0.3337500940231335D-1 - V=0.2500583360048449D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5979959659984670D+0 - B=0.6708750335901803D-1 - V=0.2524777638260203D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6330523711054002D+0 - B=0.1008792126424850D+0 - V=0.2540951193860656D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6660960998103972D+0 - B=0.1345050343171794D+0 - V=0.2549524085027472D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6365384364585819D+0 - B=0.3372799460737052D-1 - V=0.2542569507009158D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6710994302899275D+0 - B=0.6755249309678028D-1 - V=0.2552114127580376D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD4802(X,Y,Z,W,N) - DOUBLE PRECISION X(4802) - DOUBLE PRECISION Y(4802) - DOUBLE PRECISION Z(4802) - DOUBLE PRECISION W(4802) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 4802-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.9687521879420705D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2307897895367918D-3 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2297310852498558D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2335728608887064D-1 - V=0.7386265944001919D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4352987836550653D-1 - V=0.8257977698542210D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6439200521088801D-1 - V=0.9706044762057630D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9003943631993181D-1 - V=0.1302393847117003D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1196706615548473D+0 - V=0.1541957004600968D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1511715412838134D+0 - V=0.1704459770092199D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1835982828503801D+0 - V=0.1827374890942906D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2165081259155405D+0 - V=0.1926360817436107D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2496208720417563D+0 - V=0.2008010239494833D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2827200673567900D+0 - V=0.2075635983209175D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3156190823994346D+0 - V=0.2131306638690909D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3481476793749115D+0 - V=0.2176562329937335D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3801466086947226D+0 - V=0.2212682262991018D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4114652119634011D+0 - V=0.2240799515668565D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4419598786519751D+0 - V=0.2261959816187525D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4714925949329543D+0 - V=0.2277156368808855D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4999293972879466D+0 - V=0.2287351772128336D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5271387221431248D+0 - V=0.2293490814084085D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5529896780837761D+0 - V=0.2296505312376273D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6000856099481712D+0 - V=0.2296793832318756D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6210562192785175D+0 - V=0.2295785443842974D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6401165879934240D+0 - V=0.2295017931529102D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6571144029244334D+0 - V=0.2295059638184868D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6718910821718863D+0 - V=0.2296232343237362D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6842845591099010D+0 - V=0.2298530178740771D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6941353476269816D+0 - V=0.2301579790280501D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7012965242212991D+0 - V=0.2304690404996513D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7056471428242644D+0 - V=0.2307027995907102D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4595557643585895D-1 - V=0.9312274696671092D-4 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1049316742435023D+0 - V=0.1199919385876926D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1773548879549274D+0 - V=0.1598039138877690D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2559071411236127D+0 - V=0.1822253763574900D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3358156837985898D+0 - V=0.1988579593655040D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4155835743763893D+0 - V=0.2112620102533307D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4937894296167472D+0 - V=0.2201594887699007D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5691569694793316D+0 - V=0.2261622590895036D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6405840854894251D+0 - V=0.2296458453435705D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7345133894143348D-1 - B=0.2177844081486067D-1 - V=0.1006006990267000D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1009859834044931D+0 - B=0.4590362185775188D-1 - V=0.1227676689635876D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1324289619748758D+0 - B=0.7255063095690877D-1 - V=0.1467864280270117D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1654272109607127D+0 - B=0.1017825451960684D+0 - V=0.1644178912101232D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1990767186776461D+0 - B=0.1325652320980364D+0 - V=0.1777664890718961D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2330125945523278D+0 - B=0.1642765374496765D+0 - V=0.1884825664516690D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2670080611108287D+0 - B=0.1965360374337889D+0 - V=0.1973269246453848D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3008753376294316D+0 - B=0.2290726770542238D+0 - V=0.2046767775855328D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3344475596167860D+0 - B=0.2616645495370823D+0 - V=0.2107600125918040D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3675709724070786D+0 - B=0.2941150728843141D+0 - V=0.2157416362266829D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4001000887587812D+0 - B=0.3262440400919066D+0 - V=0.2197557816920721D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4318956350436028D+0 - B=0.3578835350611916D+0 - V=0.2229192611835437D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4628239056795531D+0 - B=0.3888751854043678D+0 - V=0.2253385110212775D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4927563229773636D+0 - B=0.4190678003222840D+0 - V=0.2271137107548774D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5215687136707969D+0 - B=0.4483151836883852D+0 - V=0.2283414092917525D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5491402346984905D+0 - B=0.4764740676087880D+0 - V=0.2291161673130077D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5753520160126075D+0 - B=0.5034021310998277D+0 - V=0.2295313908576598D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1388326356417754D+0 - B=0.2435436510372806D-1 - V=0.1438204721359031D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1743686900537244D+0 - B=0.5118897057342652D-1 - V=0.1607738025495257D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2099737037950268D+0 - B=0.8014695048539634D-1 - V=0.1741483853528379D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2454492590908548D+0 - B=0.1105117874155699D+0 - V=0.1851918467519151D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2807219257864278D+0 - B=0.1417950531570966D+0 - V=0.1944628638070613D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3156842271975842D+0 - B=0.1736604945719597D+0 - V=0.2022495446275152D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3502090945177752D+0 - B=0.2058466324693981D+0 - V=0.2087462382438514D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3841684849519686D+0 - B=0.2381284261195919D+0 - V=0.2141074754818308D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4174372367906016D+0 - B=0.2703031270422569D+0 - V=0.2184640913748162D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4498926465011892D+0 - B=0.3021845683091309D+0 - V=0.2219309165220329D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4814146229807701D+0 - B=0.3335993355165720D+0 - V=0.2246123118340624D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5118863625734701D+0 - B=0.3643833735518232D+0 - V=0.2266062766915125D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5411947455119144D+0 - B=0.3943789541958179D+0 - V=0.2280072952230796D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5692301500357246D+0 - B=0.4234320144403542D+0 - V=0.2289082025202583D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5958857204139576D+0 - B=0.4513897947419260D+0 - V=0.2294012695120025D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2156270284785766D+0 - B=0.2681225755444491D-1 - V=0.1722434488736947D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2532385054909710D+0 - B=0.5557495747805614D-1 - V=0.1830237421455091D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2902564617771537D+0 - B=0.8569368062950249D-1 - V=0.1923855349997633D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3266979823143256D+0 - B=0.1167367450324135D+0 - V=0.2004067861936271D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3625039627493614D+0 - B=0.1483861994003304D+0 - V=0.2071817297354263D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3975838937548699D+0 - B=0.1803821503011405D+0 - V=0.2128250834102103D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4318396099009774D+0 - B=0.2124962965666424D+0 - V=0.2174513719440102D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4651706555732742D+0 - B=0.2445221837805913D+0 - V=0.2211661839150214D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4974752649620969D+0 - B=0.2762701224322987D+0 - V=0.2240665257813102D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5286517579627517D+0 - B=0.3075627775211328D+0 - V=0.2262439516632620D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5586001195731895D+0 - B=0.3382311089826877D+0 - V=0.2277874557231869D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5872229902021319D+0 - B=0.3681108834741399D+0 - V=0.2287854314454994D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6144258616235123D+0 - B=0.3970397446872839D+0 - V=0.2293268499615575D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2951676508064861D+0 - B=0.2867499538750441D-1 - V=0.1912628201529828D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3335085485472725D+0 - B=0.5867879341903510D-1 - V=0.1992499672238701D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3709561760636381D+0 - B=0.8961099205022284D-1 - V=0.2061275533454027D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4074722861667498D+0 - B=0.1211627927626297D+0 - V=0.2119318215968572D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4429923648839117D+0 - B=0.1530748903554898D+0 - V=0.2167416581882652D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4774428052721736D+0 - B=0.1851176436721877D+0 - V=0.2206430730516600D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5107446539535904D+0 - B=0.2170829107658179D+0 - V=0.2237186938699523D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5428151370542935D+0 - B=0.2487786689026271D+0 - V=0.2260480075032884D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5735699292556964D+0 - B=0.2800239952795016D+0 - V=0.2277098884558542D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6029253794562866D+0 - B=0.3106445702878119D+0 - V=0.2287845715109671D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6307998987073145D+0 - B=0.3404689500841194D+0 - V=0.2293547268236294D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3752652273692719D+0 - B=0.2997145098184479D-1 - V=0.2056073839852528D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4135383879344028D+0 - B=0.6086725898678011D-1 - V=0.2114235865831876D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4506113885153907D+0 - B=0.9238849548435643D-1 - V=0.2163175629770551D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4864401554606072D+0 - B=0.1242786603851851D+0 - V=0.2203392158111650D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5209708076611709D+0 - B=0.1563086731483386D+0 - V=0.2235473176847839D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5541422135830122D+0 - B=0.1882696509388506D+0 - V=0.2260024141501235D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5858880915113817D+0 - B=0.2199672979126059D+0 - V=0.2277675929329182D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6161399390603444D+0 - B=0.2512165482924867D+0 - V=0.2289102112284834D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6448296482255090D+0 - B=0.2818368701871888D+0 - V=0.2295027954625118D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4544796274917948D+0 - B=0.3088970405060312D-1 - V=0.2161281589879992D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4919389072146628D+0 - B=0.6240947677636835D-1 - V=0.2201980477395102D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5279313026985183D+0 - B=0.9430706144280313D-1 - V=0.2234952066593166D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5624169925571135D+0 - B=0.1263547818770374D+0 - V=0.2260540098520838D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5953484627093287D+0 - B=0.1583430788822594D+0 - V=0.2279157981899988D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6266730715339185D+0 - B=0.1900748462555988D+0 - V=0.2291296918565571D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6563363204278871D+0 - B=0.2213599519592567D+0 - V=0.2297533752536649D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5314574716585696D+0 - B=0.3152508811515374D-1 - V=0.2234927356465995D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5674614932298185D+0 - B=0.6343865291465561D-1 - V=0.2261288012985219D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6017706004970264D+0 - B=0.9551503504223951D-1 - V=0.2280818160923688D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6343471270264178D+0 - B=0.1275440099801196D+0 - V=0.2293773295180159D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6651494599127802D+0 - B=0.1593252037671960D+0 - V=0.2300528767338634D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6050184986005704D+0 - B=0.3192538338496105D-1 - V=0.2281893855065666D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6390163550880400D+0 - B=0.6402824353962306D-1 - V=0.2295720444840727D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6711199107088448D+0 - B=0.9609805077002909D-1 - V=0.2303227649026753D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6741354429572275D+0 - B=0.3211853196273233D-1 - V=0.2304831913227114D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD5294(X,Y,Z,W,N) - DOUBLE PRECISION X(5294) - DOUBLE PRECISION Y(5294) - DOUBLE PRECISION Z(5294) - DOUBLE PRECISION W(5294) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 5294-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.9080510764308163D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2084824361987793D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2303261686261450D-1 - V=0.5011105657239616D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3757208620162394D-1 - V=0.5942520409683854D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5821912033821852D-1 - V=0.9564394826109721D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8403127529194872D-1 - V=0.1185530657126338D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1122927798060578D+0 - V=0.1364510114230331D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1420125319192987D+0 - V=0.1505828825605415D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1726396437341978D+0 - V=0.1619298749867023D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2038170058115696D+0 - V=0.1712450504267789D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2352849892876508D+0 - V=0.1789891098164999D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2668363354312461D+0 - V=0.1854474955629795D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2982941279900452D+0 - V=0.1908148636673661D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3295002922087076D+0 - V=0.1952377405281833D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3603094918363593D+0 - V=0.1988349254282232D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3905857895173920D+0 - V=0.2017079807160050D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4202005758160837D+0 - V=0.2039473082709094D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4490310061597227D+0 - V=0.2056360279288953D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4769586160311491D+0 - V=0.2068525823066865D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5038679887049750D+0 - V=0.2076724877534488D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5296454286519961D+0 - V=0.2081694278237885D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5541776207164850D+0 - V=0.2084157631219326D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5990467321921213D+0 - V=0.2084381531128593D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6191467096294587D+0 - V=0.2083476277129307D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6375251212901849D+0 - V=0.2082686194459732D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6540514381131168D+0 - V=0.2082475686112415D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6685899064391510D+0 - V=0.2083139860289915D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6810013009681648D+0 - V=0.2084745561831237D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6911469578730340D+0 - V=0.2087091313375890D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6988956915141736D+0 - V=0.2089718413297697D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7041335794868720D+0 - V=0.2092003303479793D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7067754398018567D+0 - V=0.2093336148263241D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3840368707853623D-1 - V=0.7591708117365267D-4 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9835485954117399D-1 - V=0.1083383968169186D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1665774947612998D+0 - V=0.1403019395292510D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2405702335362910D+0 - V=0.1615970179286436D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3165270770189046D+0 - V=0.1771144187504911D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3927386145645443D+0 - V=0.1887760022988168D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4678825918374656D+0 - V=0.1973474670768214D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5408022024266935D+0 - V=0.2033787661234659D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6104967445752438D+0 - V=0.2072343626517331D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6760910702685738D+0 - V=0.2091177834226918D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6655644120217392D-1 - B=0.1936508874588424D-1 - V=0.9316684484675566D-4 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9446246161270182D-1 - B=0.4252442002115869D-1 - V=0.1116193688682976D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1242651925452509D+0 - B=0.6806529315354374D-1 - V=0.1298623551559414D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1553438064846751D+0 - B=0.9560957491205369D-1 - V=0.1450236832456426D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1871137110542670D+0 - B=0.1245931657452888D+0 - V=0.1572719958149914D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2192612628836257D+0 - B=0.1545385828778978D+0 - V=0.1673234785867195D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2515682807206955D+0 - B=0.1851004249723368D+0 - V=0.1756860118725188D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2838535866287290D+0 - B=0.2160182608272384D+0 - V=0.1826776290439367D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3159578817528521D+0 - B=0.2470799012277111D+0 - V=0.1885116347992865D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3477370882791392D+0 - B=0.2781014208986402D+0 - V=0.1933457860170574D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3790576960890540D+0 - B=0.3089172523515731D+0 - V=0.1973060671902064D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4097938317810200D+0 - B=0.3393750055472244D+0 - V=0.2004987099616311D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4398256572859637D+0 - B=0.3693322470987730D+0 - V=0.2030170909281499D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4690384114718480D+0 - B=0.3986541005609877D+0 - V=0.2049461460119080D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4973216048301053D+0 - B=0.4272112491408562D+0 - V=0.2063653565200186D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5245681526132446D+0 - B=0.4548781735309936D+0 - V=0.2073507927381027D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5506733911803888D+0 - B=0.4815315355023251D+0 - V=0.2079764593256122D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5755339829522475D+0 - B=0.5070486445801855D+0 - V=0.2083150534968778D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1305472386056362D+0 - B=0.2284970375722366D-1 - V=0.1262715121590664D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1637327908216477D+0 - B=0.4812254338288384D-1 - V=0.1414386128545972D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1972734634149637D+0 - B=0.7531734457511935D-1 - V=0.1538740401313898D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2308694653110130D+0 - B=0.1039043639882017D+0 - V=0.1642434942331432D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2643899218338160D+0 - B=0.1334526587117626D+0 - V=0.1729790609237496D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2977171599622171D+0 - B=0.1636414868936382D+0 - V=0.1803505190260828D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3307293903032310D+0 - B=0.1942195406166568D+0 - V=0.1865475350079657D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3633069198219073D+0 - B=0.2249752879943753D+0 - V=0.1917182669679069D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3953346955922727D+0 - B=0.2557218821820032D+0 - V=0.1959851709034382D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4267018394184914D+0 - B=0.2862897925213193D+0 - V=0.1994529548117882D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4573009622571704D+0 - B=0.3165224536636518D+0 - V=0.2022138911146548D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4870279559856109D+0 - B=0.3462730221636496D+0 - V=0.2043518024208592D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5157819581450322D+0 - B=0.3754016870282835D+0 - V=0.2059450313018110D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5434651666465393D+0 - B=0.4037733784993613D+0 - V=0.2070685715318472D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5699823887764627D+0 - B=0.4312557784139123D+0 - V=0.2077955310694373D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5952403350947741D+0 - B=0.4577175367122110D+0 - V=0.2081980387824712D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2025152599210369D+0 - B=0.2520253617719557D-1 - V=0.1521318610377956D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2381066653274425D+0 - B=0.5223254506119000D-1 - V=0.1622772720185755D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2732823383651612D+0 - B=0.8060669688588620D-1 - V=0.1710498139420709D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3080137692611118D+0 - B=0.1099335754081255D+0 - V=0.1785911149448736D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3422405614587601D+0 - B=0.1399120955959857D+0 - V=0.1850125313687736D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3758808773890420D+0 - B=0.1702977801651705D+0 - V=0.1904229703933298D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4088458383438932D+0 - B=0.2008799256601680D+0 - V=0.1949259956121987D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4410450550841152D+0 - B=0.2314703052180836D+0 - V=0.1986161545363960D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4723879420561312D+0 - B=0.2618972111375892D+0 - V=0.2015790585641370D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5027843561874343D+0 - B=0.2920013195600270D+0 - V=0.2038934198707418D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5321453674452458D+0 - B=0.3216322555190551D+0 - V=0.2056334060538251D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5603839113834030D+0 - B=0.3506456615934198D+0 - V=0.2068705959462289D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5874150706875146D+0 - B=0.3789007181306267D+0 - V=0.2076753906106002D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6131559381660038D+0 - B=0.4062580170572782D+0 - V=0.2081179391734803D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2778497016394506D+0 - B=0.2696271276876226D-1 - V=0.1700345216228943D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3143733562261912D+0 - B=0.5523469316960465D-1 - V=0.1774906779990410D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3501485810261827D+0 - B=0.8445193201626464D-1 - V=0.1839659377002642D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3851430322303653D+0 - B=0.1143263119336083D+0 - V=0.1894987462975169D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4193013979470415D+0 - B=0.1446177898344475D+0 - V=0.1941548809452595D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4525585960458567D+0 - B=0.1751165438438091D+0 - V=0.1980078427252384D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4848447779622947D+0 - B=0.2056338306745660D+0 - V=0.2011296284744488D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5160871208276894D+0 - B=0.2359965487229226D+0 - V=0.2035888456966776D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5462112185696926D+0 - B=0.2660430223139146D+0 - V=0.2054516325352142D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5751425068101757D+0 - B=0.2956193664498032D+0 - V=0.2067831033092635D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6028073872853596D+0 - B=0.3245763905312779D+0 - V=0.2076485320284876D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6291338275278409D+0 - B=0.3527670026206972D+0 - V=0.2081141439525255D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3541797528439391D+0 - B=0.2823853479435550D-1 - V=0.1834383015469222D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3908234972074657D+0 - B=0.5741296374713106D-1 - V=0.1889540591777677D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4264408450107590D+0 - B=0.8724646633650199D-1 - V=0.1936677023597375D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4609949666553286D+0 - B=0.1175034422915616D+0 - V=0.1976176495066504D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4944389496536006D+0 - B=0.1479755652628428D+0 - V=0.2008536004560983D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5267194884346086D+0 - B=0.1784740659484352D+0 - V=0.2034280351712291D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5577787810220990D+0 - B=0.2088245700431244D+0 - V=0.2053944466027758D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5875563763536670D+0 - B=0.2388628136570763D+0 - V=0.2068077642882360D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6159910016391269D+0 - B=0.2684308928769185D+0 - V=0.2077250949661599D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6430219602956268D+0 - B=0.2973740761960252D+0 - V=0.2082062440705320D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4300647036213646D+0 - B=0.2916399920493977D-1 - V=0.1934374486546626D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4661486308935531D+0 - B=0.5898803024755659D-1 - V=0.1974107010484300D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5009658555287261D+0 - B=0.8924162698525409D-1 - V=0.2007129290388658D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5344824270447704D+0 - B=0.1197185199637321D+0 - V=0.2033736947471293D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5666575997416371D+0 - B=0.1502300756161382D+0 - V=0.2054287125902493D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5974457471404752D+0 - B=0.1806004191913564D+0 - V=0.2069184936818894D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6267984444116886D+0 - B=0.2106621764786252D+0 - V=0.2078883689808782D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6546664713575417D+0 - B=0.2402526932671914D+0 - V=0.2083886366116359D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5042711004437253D+0 - B=0.2982529203607657D-1 - V=0.2006593275470817D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5392127456774380D+0 - B=0.6008728062339922D-1 - V=0.2033728426135397D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5726819437668618D+0 - B=0.9058227674571398D-1 - V=0.2055008781377608D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6046469254207278D+0 - B=0.1211219235803400D+0 - V=0.2070651783518502D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6350716157434952D+0 - B=0.1515286404791580D+0 - V=0.2080953335094320D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6639177679185454D+0 - B=0.1816314681255552D+0 - V=0.2086284998988521D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5757276040972253D+0 - B=0.3026991752575440D-1 - V=0.2055549387644668D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6090265823139755D+0 - B=0.6078402297870770D-1 - V=0.2071871850267654D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6406735344387661D+0 - B=0.9135459984176636D-1 - V=0.2082856600431965D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6706397927793709D+0 - B=0.1218024155966590D+0 - V=0.2088705858819358D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6435019674426665D+0 - B=0.3052608357660639D-1 - V=0.2083995867536322D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6747218676375681D+0 - B=0.6112185773983089D-1 - V=0.2090509712889637D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD5810(X,Y,Z,W,N) - DOUBLE PRECISION X(5810) - DOUBLE PRECISION Y(5810) - DOUBLE PRECISION Z(5810) - DOUBLE PRECISION W(5810) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 5810-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.9735347946175486D-5 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.1907581241803167D-3 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.1901059546737578D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1182361662400277D-1 - V=0.3926424538919212D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3062145009138958D-1 - V=0.6667905467294382D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5329794036834243D-1 - V=0.8868891315019135D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7848165532862220D-1 - V=0.1066306000958872D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1054038157636201D+0 - V=0.1214506743336128D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1335577797766211D+0 - V=0.1338054681640871D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1625769955502252D+0 - V=0.1441677023628504D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1921787193412792D+0 - V=0.1528880200826557D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2221340534690548D+0 - V=0.1602330623773609D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2522504912791132D+0 - V=0.1664102653445244D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2823610860679697D+0 - V=0.1715845854011323D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3123173966267560D+0 - V=0.1758901000133069D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3419847036953789D+0 - V=0.1794382485256736D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3712386456999758D+0 - V=0.1823238106757407D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3999627649876828D+0 - V=0.1846293252959976D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4280466458648093D+0 - V=0.1864284079323098D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4553844360185711D+0 - V=0.1877882694626914D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4818736094437834D+0 - V=0.1887716321852025D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5074138709260629D+0 - V=0.1894381638175673D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5319061304570707D+0 - V=0.1898454899533629D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5552514978677286D+0 - V=0.1900497929577815D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5981009025246183D+0 - V=0.1900671501924092D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6173990192228116D+0 - V=0.1899837555533510D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6351365239411131D+0 - V=0.1899014113156229D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6512010228227200D+0 - V=0.1898581257705106D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6654758363948120D+0 - V=0.1898804756095753D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6778410414853370D+0 - V=0.1899793610426402D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6881760887484110D+0 - V=0.1901464554844117D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6963645267094598D+0 - V=0.1903533246259542D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7023010617153579D+0 - V=0.1905556158463228D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7059004636628753D+0 - V=0.1907037155663528D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3552470312472575D-1 - V=0.5992997844249967D-4 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9151176620841283D-1 - V=0.9749059382456978D-4 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1566197930068980D+0 - V=0.1241680804599158D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2265467599271907D+0 - V=0.1437626154299360D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2988242318581361D+0 - V=0.1584200054793902D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3717482419703886D+0 - V=0.1694436550982744D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4440094491758889D+0 - V=0.1776617014018108D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5145337096756642D+0 - V=0.1836132434440077D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5824053672860230D+0 - V=0.1876494727075983D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6468283961043370D+0 - V=0.1899906535336482D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6095964259104373D-1 - B=0.1787828275342931D-1 - V=0.8143252820767350D-4 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8811962270959388D-1 - B=0.3953888740792096D-1 - V=0.9998859890887728D-4 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1165936722428831D+0 - B=0.6378121797722990D-1 - V=0.1156199403068359D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1460232857031785D+0 - B=0.8985890813745037D-1 - V=0.1287632092635513D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1761197110181755D+0 - B=0.1172606510576162D+0 - V=0.1398378643365139D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2066471190463718D+0 - B=0.1456102876970995D+0 - V=0.1491876468417391D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2374076026328152D+0 - B=0.1746153823011775D+0 - V=0.1570855679175456D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2682305474337051D+0 - B=0.2040383070295584D+0 - V=0.1637483948103775D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2989653312142369D+0 - B=0.2336788634003698D+0 - V=0.1693500566632843D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3294762752772209D+0 - B=0.2633632752654219D+0 - V=0.1740322769393633D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3596390887276086D+0 - B=0.2929369098051601D+0 - V=0.1779126637278296D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3893383046398812D+0 - B=0.3222592785275512D+0 - V=0.1810908108835412D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4184653789358347D+0 - B=0.3512004791195743D+0 - V=0.1836529132600190D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4469172319076166D+0 - B=0.3796385677684537D+0 - V=0.1856752841777379D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4745950813276976D+0 - B=0.4074575378263879D+0 - V=0.1872270566606832D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5014034601410262D+0 - B=0.4345456906027828D+0 - V=0.1883722645591307D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5272493404551239D+0 - B=0.4607942515205134D+0 - V=0.1891714324525297D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5520413051846366D+0 - B=0.4860961284181720D+0 - V=0.1896827480450146D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5756887237503077D+0 - B=0.5103447395342790D+0 - V=0.1899628417059528D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1225039430588352D+0 - B=0.2136455922655793D-1 - V=0.1123301829001669D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1539113217321372D+0 - B=0.4520926166137188D-1 - V=0.1253698826711277D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1856213098637712D+0 - B=0.7086468177864818D-1 - V=0.1366266117678531D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2174998728035131D+0 - B=0.9785239488772918D-1 - V=0.1462736856106918D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2494128336938330D+0 - B=0.1258106396267210D+0 - V=0.1545076466685412D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2812321562143480D+0 - B=0.1544529125047001D+0 - V=0.1615096280814007D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3128372276456111D+0 - B=0.1835433512202753D+0 - V=0.1674366639741759D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3441145160177973D+0 - B=0.2128813258619585D+0 - V=0.1724225002437900D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3749567714853510D+0 - B=0.2422913734880829D+0 - V=0.1765810822987288D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4052621732015610D+0 - B=0.2716163748391453D+0 - V=0.1800104126010751D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4349335453522385D+0 - B=0.3007127671240280D+0 - V=0.1827960437331284D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4638776641524965D+0 - B=0.3294470677216479D+0 - V=0.1850140300716308D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4920046410462687D+0 - B=0.3576932543699155D+0 - V=0.1867333507394938D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5192273554861704D+0 - B=0.3853307059757764D+0 - V=0.1880178688638289D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5454609081136522D+0 - B=0.4122425044452694D+0 - V=0.1889278925654758D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5706220661424140D+0 - B=0.4383139587781027D+0 - V=0.1895213832507346D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5946286755181518D+0 - B=0.4634312536300553D+0 - V=0.1898548277397420D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1905370790924295D+0 - B=0.2371311537781979D-1 - V=0.1349105935937341D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2242518717748009D+0 - B=0.4917878059254806D-1 - V=0.1444060068369326D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2577190808025936D+0 - B=0.7595498960495142D-1 - V=0.1526797390930008D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2908724534927187D+0 - B=0.1036991083191100D+0 - V=0.1598208771406474D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3236354020056219D+0 - B=0.1321348584450234D+0 - V=0.1659354368615331D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3559267359304543D+0 - B=0.1610316571314789D+0 - V=0.1711279910946440D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3876637123676956D+0 - B=0.1901912080395707D+0 - V=0.1754952725601440D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4187636705218842D+0 - B=0.2194384950137950D+0 - V=0.1791247850802529D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4491449019883107D+0 - B=0.2486155334763858D+0 - V=0.1820954300877716D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4787270932425445D+0 - B=0.2775768931812335D+0 - V=0.1844788524548449D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5074315153055574D+0 - B=0.3061863786591120D+0 - V=0.1863409481706220D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5351810507738336D+0 - B=0.3343144718152556D+0 - V=0.1877433008795068D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5619001025975381D+0 - B=0.3618362729028427D+0 - V=0.1887444543705232D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5875144035268046D+0 - B=0.3886297583620408D+0 - V=0.1894009829375006D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6119507308734495D+0 - B=0.4145742277792031D+0 - V=0.1897683345035198D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2619733870119463D+0 - B=0.2540047186389353D-1 - V=0.1517327037467653D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2968149743237949D+0 - B=0.5208107018543989D-1 - V=0.1587740557483543D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3310451504860488D+0 - B=0.7971828470885599D-1 - V=0.1649093382274097D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3646215567376676D+0 - B=0.1080465999177927D+0 - V=0.1701915216193265D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3974916785279360D+0 - B=0.1368413849366629D+0 - V=0.1746847753144065D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4295967403772029D+0 - B=0.1659073184763559D+0 - V=0.1784555512007570D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4608742854473447D+0 - B=0.1950703730454614D+0 - V=0.1815687562112174D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4912598858949903D+0 - B=0.2241721144376724D+0 - V=0.1840864370663302D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5206882758945558D+0 - B=0.2530655255406489D+0 - V=0.1860676785390006D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5490940914019819D+0 - B=0.2816118409731066D+0 - V=0.1875690583743703D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5764123302025542D+0 - B=0.3096780504593238D+0 - V=0.1886453236347225D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6025786004213506D+0 - B=0.3371348366394987D+0 - V=0.1893501123329645D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6275291964794956D+0 - B=0.3638547827694396D+0 - V=0.1897366184519868D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3348189479861771D+0 - B=0.2664841935537443D-1 - V=0.1643908815152736D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3699515545855295D+0 - B=0.5424000066843495D-1 - V=0.1696300350907768D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4042003071474669D+0 - B=0.8251992715430854D-1 - V=0.1741553103844483D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4375320100182624D+0 - B=0.1112695182483710D+0 - V=0.1780015282386092D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4699054490335947D+0 - B=0.1402964116467816D+0 - V=0.1812116787077125D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5012739879431952D+0 - B=0.1694275117584291D+0 - V=0.1838323158085421D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5315874883754966D+0 - B=0.1985038235312689D+0 - V=0.1859113119837737D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5607937109622117D+0 - B=0.2273765660020893D+0 - V=0.1874969220221698D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5888393223495521D+0 - B=0.2559041492849764D+0 - V=0.1886375612681076D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6156705979160163D+0 - B=0.2839497251976899D+0 - V=0.1893819575809276D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6412338809078123D+0 - B=0.3113791060500690D+0 - V=0.1897794748256767D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4076051259257167D+0 - B=0.2757792290858463D-1 - V=0.1738963926584846D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4423788125791520D+0 - B=0.5584136834984293D-1 - V=0.1777442359873466D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4760480917328258D+0 - B=0.8457772087727143D-1 - V=0.1810010815068719D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5085838725946297D+0 - B=0.1135975846359248D+0 - V=0.1836920318248129D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5399513637391218D+0 - B=0.1427286904765053D+0 - V=0.1858489473214328D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5701118433636380D+0 - B=0.1718112740057635D+0 - V=0.1875079342496592D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5990240530606021D+0 - B=0.2006944855985351D+0 - V=0.1887080239102310D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6266452685139695D+0 - B=0.2292335090598907D+0 - V=0.1894905752176822D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6529320971415942D+0 - B=0.2572871512353714D+0 - V=0.1898991061200695D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4791583834610126D+0 - B=0.2826094197735932D-1 - V=0.1809065016458791D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5130373952796940D+0 - B=0.5699871359683649D-1 - V=0.1836297121596799D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5456252429628476D+0 - B=0.8602712528554394D-1 - V=0.1858426916241869D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5768956329682385D+0 - B=0.1151748137221281D+0 - V=0.1875654101134641D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6068186944699046D+0 - B=0.1442811654136362D+0 - V=0.1888240751833503D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6353622248024907D+0 - B=0.1731930321657680D+0 - V=0.1896497383866979D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6624927035731797D+0 - B=0.2017619958756061D+0 - V=0.1900775530219121D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5484933508028488D+0 - B=0.2874219755907391D-1 - V=0.1858525041478814D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5810207682142106D+0 - B=0.5778312123713695D-1 - V=0.1876248690077947D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6120955197181352D+0 - B=0.8695262371439526D-1 - V=0.1889404439064607D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6416944284294319D+0 - B=0.1160893767057166D+0 - V=0.1898168539265290D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6697926391731260D+0 - B=0.1450378826743251D+0 - V=0.1902779940661772D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6147594390585488D+0 - B=0.2904957622341456D-1 - V=0.1890125641731815D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6455390026356783D+0 - B=0.5823809152617197D-1 - V=0.1899434637795751D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6747258588365477D+0 - B=0.8740384899884715D-1 - V=0.1904520856831751D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6772135750395347D+0 - B=0.2919946135808105D-1 - V=0.1905534498734563D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - - diff --git a/plugins/DFT_Utils/functional.irp.f b/plugins/DFT_Utils/functional.irp.f deleted file mode 100644 index e034a244..00000000 --- a/plugins/DFT_Utils/functional.irp.f +++ /dev/null @@ -1,54 +0,0 @@ -subroutine ex_lda(rho_a,rho_b,ex,vx_a,vx_b) - include 'constants.include.F' - implicit none - double precision, intent(in) :: rho_a,rho_b - double precision, intent(out) :: ex,vx_a,vx_b - double precision :: tmp_a,tmp_b - tmp_a = rho_a**(c_1_3) - tmp_b = rho_b**(c_1_3) - ex = cst_lda * (tmp_a*tmp_a*tmp_a*tmp_a + tmp_b*tmp_b*tmp_b*tmp_b) - vx_a = cst_lda * c_4_3 * tmp_a - vx_b = cst_lda * c_4_3 * tmp_b - -end - - BEGIN_PROVIDER [double precision, lda_exchange, (N_states)] -&BEGIN_PROVIDER [double precision, lda_ex_potential_alpha_ao,(ao_num_align,ao_num,N_states)] -&BEGIN_PROVIDER [double precision, lda_ex_potential_beta_ao,(ao_num_align,ao_num,N_states)] - - implicit none - integer :: i,j,k,l - integer :: m,n - double precision :: aos_array(ao_num) - double precision :: r(3) - lda_ex_potential_alpha_ao = 0.d0 - lda_ex_potential_beta_ao = 0.d0 - do l = 1, N_states - lda_exchange(l) = 0.d0 - do j = 1, nucl_num - do i = 1, n_points_radial_grid - do k = 1, n_points_integration_angular - double precision :: rho_a,rho_b,ex - double precision :: vx_a,vx_b - rho_a = one_body_dm_mo_alpha_at_grid_points(k,i,j,l) - rho_b = one_body_dm_mo_beta_at_grid_points(k,i,j,l) - call ex_lda(rho_a,rho_b,ex,vx_a,vx_b) - lda_exchange(l) += final_weight_functions_at_grid_points(k,i,j) * ex - r(1) = grid_points_per_atom(1,k,i,j) - r(2) = grid_points_per_atom(2,k,i,j) - r(3) = grid_points_per_atom(3,k,i,j) - call give_all_aos_at_r(r,aos_array) - do m = 1, ao_num -! lda_ex_potential_ao(m,m,l) += (vx_a + vx_b) * aos_array(m)*aos_array(m) - do n = 1, ao_num - lda_ex_potential_alpha_ao(m,n,l) += (vx_a ) * aos_array(m)*aos_array(n) * final_weight_functions_at_grid_points(k,i,j) - lda_ex_potential_beta_ao(m,n,l) += (vx_b) * aos_array(m)*aos_array(n) * final_weight_functions_at_grid_points(k,i,j) - enddo - enddo - enddo - enddo - enddo - enddo - -END_PROVIDER - diff --git a/plugins/DFT_Utils/grid_density.irp.f b/plugins/DFT_Utils/grid_density.irp.f index 7c9d2c05..6071a18b 100644 --- a/plugins/DFT_Utils/grid_density.irp.f +++ b/plugins/DFT_Utils/grid_density.irp.f @@ -1,60 +1,42 @@ - BEGIN_PROVIDER [integer, n_points_integration_angular] +BEGIN_PROVIDER [integer, n_points_angular_grid] implicit none - n_points_integration_angular = 110 - END_PROVIDER + n_points_angular_grid = 50 +END_PROVIDER BEGIN_PROVIDER [integer, n_points_radial_grid] implicit none - n_points_radial_grid = 100 + n_points_radial_grid = 10000 END_PROVIDER - BEGIN_PROVIDER [double precision, angular_quadrature_points, (n_points_integration_angular,3) ] -&BEGIN_PROVIDER [double precision, weights_angular_points, (n_points_integration_angular)] + BEGIN_PROVIDER [double precision, angular_quadrature_points, (n_points_angular_grid,3) ] +&BEGIN_PROVIDER [double precision, weights_angular_points, (n_points_angular_grid)] implicit none BEGIN_DOC ! weights and grid points for the integration on the angular variables on ! the unit sphere centered on (0,0,0) ! According to the LEBEDEV scheme END_DOC - angular_quadrature_points = 0.d0 - weights_angular_points = 0.d0 -!call cal_quad(n_points_integration_angular, angular_quadrature_points,weights_angular_points) + call cal_quad(n_points_angular_grid, angular_quadrature_points,weights_angular_points) include 'constants.include.F' - integer :: i,n + integer :: i double precision :: accu double precision :: degre_rad - degre_rad = pi/180.d0 - accu = 0.d0 - double precision :: x(n_points_integration_angular),y(n_points_integration_angular),z(n_points_integration_angular),w(n_points_integration_angular) - call LD0110(X,Y,Z,W,N) - do i = 1, n_points_integration_angular - angular_quadrature_points(i,1) = x(i) - angular_quadrature_points(i,2) = y(i) - angular_quadrature_points(i,3) = z(i) - weights_angular_points(i) = w(i) * 4.d0 * pi - accu += w(i) - enddo -!do i = 1, n_points_integration_angular +!degre_rad = 180.d0/pi +!accu = 0.d0 +!do i = 1, n_points_integration_angular_lebedev ! accu += weights_angular_integration_lebedev(i) -! weights_angular_points(i) = weights_angular_integration_lebedev(i) * 4.d0 * pi +! weights_angular_points(i) = weights_angular_integration_lebedev(i) * 2.d0 * pi ! angular_quadrature_points(i,1) = dcos ( degre_rad * theta_angular_integration_lebedev(i)) & ! * dsin ( degre_rad * phi_angular_integration_lebedev(i)) ! angular_quadrature_points(i,2) = dsin ( degre_rad * theta_angular_integration_lebedev(i)) & ! * dsin ( degre_rad * phi_angular_integration_lebedev(i)) ! angular_quadrature_points(i,3) = dcos ( degre_rad * phi_angular_integration_lebedev(i)) - -!!weights_angular_points(i) = weights_angular_integration_lebedev(i) -!!angular_quadrature_points(i,1) = dcos ( degre_rad * phi_angular_integration_lebedev(i)) & -!! * dsin ( degre_rad * theta_angular_integration_lebedev(i)) -!!angular_quadrature_points(i,2) = dsin ( degre_rad * phi_angular_integration_lebedev(i)) & -!! * dsin ( degre_rad * theta_angular_integration_lebedev(i)) -!!angular_quadrature_points(i,3) = dcos ( degre_rad * theta_angular_integration_lebedev(i)) !enddo - print*,'ANGULAR' - print*,'' - print*,'accu = ',accu - ASSERT( dabs(accu - 1.D0) < 1.d-10) +!print*,'ANGULAR' +!print*,'' +!print*,'accu = ',accu +!ASSERT( dabs(accu - 1.D0) < 1.d-10) END_PROVIDER @@ -81,7 +63,7 @@ END_PROVIDER END_PROVIDER -BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_angular,n_points_radial_grid,nucl_num)] +BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_angular_grid,n_points_radial_grid,nucl_num)] BEGIN_DOC ! points for integration over space END_DOC @@ -97,7 +79,7 @@ BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_ double precision :: x,r x = grid_points_radial(j) ! x value for the mapping of the [0, +\infty] to [0,1] r = knowles_function(alpha_knowles(int(nucl_charge(i))),m_knowles,x) ! value of the radial coordinate for the integration - do k = 1, n_points_integration_angular ! explicit values of the grid points centered around each atom + do k = 1, n_points_angular_grid ! explicit values of the grid points centered around each atom grid_points_per_atom(1,k,j,i) = x_ref + angular_quadrature_points(k,1) * r grid_points_per_atom(2,k,j,i) = y_ref + angular_quadrature_points(k,2) * r grid_points_per_atom(3,k,j,i) = z_ref + angular_quadrature_points(k,3) * r @@ -106,7 +88,7 @@ BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_ enddo END_PROVIDER -BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num) ] +BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ] BEGIN_DOC ! Weight function at grid points : w_n(r) according to the equation (22) of Becke original paper (JCP, 88, 1988) ! the "n" discrete variable represents the nucleis which in this array is represented by the last dimension @@ -120,7 +102,7 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_int ! run over all points in space do j = 1, nucl_num ! that are referred to each atom do k = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom - do l = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom + do l = 1, n_points_angular_grid ! for each angular point attached to the "jth" atom r(1) = grid_points_per_atom(1,l,k,j) r(2) = grid_points_per_atom(2,l,k,j) r(3) = grid_points_per_atom(3,l,k,j) @@ -133,6 +115,7 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_int enddo accu = 1.d0/accu weight_functions_at_grid_points(l,k,j) = tmp_array(j) * accu +! print*,weight_functions_at_grid_points(l,k,j) enddo enddo enddo @@ -140,65 +123,43 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_int END_PROVIDER -BEGIN_PROVIDER [double precision, final_weight_functions_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num) ] - BEGIN_DOC -! Weight function at grid points : w_n(r) according to the equation (22) of Becke original paper (JCP, 88, 1988) -! the "n" discrete variable represents the nucleis which in this array is represented by the last dimension -! and the points are labelled by the other dimensions - END_DOC + BEGIN_PROVIDER [double precision, one_body_dm_mo_alpha_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ] +&BEGIN_PROVIDER [double precision, one_body_dm_mo_beta_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ] implicit none integer :: i,j,k,l,m - double precision :: r(3) - double precision :: accu,cell_function_becke - double precision :: tmp_array(nucl_num) - double precision :: contrib_integration,x - double precision :: derivative_knowles_function,knowles_function - ! run over all points in space - do j = 1, nucl_num ! that are referred to each atom - do i = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom - x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1] - do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom - contrib_integration = derivative_knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x) & - *knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x)**2 - final_weight_functions_at_grid_points(k,i,j) = weights_angular_points(k) * weight_functions_at_grid_points(k,i,j) * contrib_integration * dr_radial_integral - enddo - enddo - enddo - -END_PROVIDER - - - BEGIN_PROVIDER [double precision, one_body_dm_mo_alpha_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ] -&BEGIN_PROVIDER [double precision, one_body_dm_mo_beta_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ] - implicit none - integer :: i,j,k,l,m,i_state double precision :: contrib double precision :: r(3) double precision :: aos_array(ao_num),mos_array(mo_tot_num) - do i_state = 1, N_states do j = 1, nucl_num - do k = 1, n_points_radial_grid - do l = 1, n_points_integration_angular - one_body_dm_mo_alpha_at_grid_points(l,k,j,i_state) = 0.d0 - one_body_dm_mo_beta_at_grid_points(l,k,j,i_state) = 0.d0 + do k = 1, n_points_radial_grid -1 + do l = 1, n_points_angular_grid + one_body_dm_mo_alpha_at_grid_points(l,k,j) = 0.d0 + one_body_dm_mo_beta_at_grid_points(l,k,j) = 0.d0 r(1) = grid_points_per_atom(1,l,k,j) r(2) = grid_points_per_atom(2,l,k,j) r(3) = grid_points_per_atom(3,l,k,j) +! call give_all_aos_at_r(r,aos_array) +! do i = 1, ao_num +! do m = 1, ao_num +! contrib = aos_array(i) * aos_array(m) +! one_body_dm_mo_alpha_at_grid_points(l,k,j) += one_body_dm_ao_alpha(i,m) * contrib +! one_body_dm_mo_beta_at_grid_points(l,k,j) += one_body_dm_ao_beta(i,m) * contrib +! enddo +! enddo + call give_all_mos_at_r(r,mos_array) - do m = 1, mo_tot_num - do i = 1, mo_tot_num - if(dabs(one_body_dm_mo_alpha(i,m,i_state)).lt.1.d-10)cycle + do i = 1, mo_tot_num + do m = 1, mo_tot_num contrib = mos_array(i) * mos_array(m) - one_body_dm_mo_alpha_at_grid_points(l,k,j,i_state) += one_body_dm_mo_alpha(i,m,i_state) * contrib - one_body_dm_mo_beta_at_grid_points(l,k,j,i_state) += one_body_dm_mo_beta(i,m,i_state) * contrib + one_body_dm_mo_alpha_at_grid_points(l,k,j) += one_body_dm_mo_alpha(i,m) * contrib + one_body_dm_mo_beta_at_grid_points(l,k,j) += one_body_dm_mo_beta(i,m) * contrib enddo enddo enddo enddo enddo - enddo END_PROVIDER diff --git a/plugins/DFT_Utils/integration_3d.irp.f b/plugins/DFT_Utils/integration_3d.irp.f index a665349a..43eb1ab8 100644 --- a/plugins/DFT_Utils/integration_3d.irp.f +++ b/plugins/DFT_Utils/integration_3d.irp.f @@ -4,11 +4,18 @@ double precision function step_function_becke(x) double precision :: f_function_becke integer :: i,n_max_becke +!if(x.lt.-1.d0)then +! step_function_becke = 0.d0 +!else if (x .gt.1)then +! step_function_becke = 0.d0 +!else step_function_becke = f_function_becke(x) - do i = 1,5 +!!n_max_becke = 1 + do i = 1, 4 step_function_becke = f_function_becke(step_function_becke) enddo step_function_becke = 0.5d0*(1.d0 - step_function_becke) +!endif end double precision function f_function_becke(x) diff --git a/plugins/DFT_Utils/integration_radial.irp.f b/plugins/DFT_Utils/integration_radial.irp.f index 0708658f..4943783b 100644 --- a/plugins/DFT_Utils/integration_radial.irp.f +++ b/plugins/DFT_Utils/integration_radial.irp.f @@ -4,7 +4,7 @@ double precision :: accu integer :: i,j,k,l double precision :: x - double precision :: integrand(n_points_integration_angular), weights(n_points_integration_angular) + double precision :: integrand(n_points_angular_grid), weights(n_points_angular_grid) double precision :: f_average_angular_alpha,f_average_angular_beta double precision :: derivative_knowles_function,knowles_function @@ -12,7 +12,7 @@ ! according ot equation (6) of the paper of Becke (JCP, (88), 1988) ! Here the m index is referred to the w_m(r) weight functions of equation (22) ! Run over all points of integrations : there are - ! n_points_radial_grid (i) * n_points_integration_angular (k) + ! n_points_radial_grid (i) * n_points_angular_grid (k) do j = 1, nucl_num integral_density_alpha_knowles_becke_per_atom(j) = 0.d0 integral_density_beta_knowles_becke_per_atom(j) = 0.d0 @@ -20,13 +20,14 @@ ! Angular integration over the solid angle Omega for a FIXED angular coordinate "r" f_average_angular_alpha = 0.d0 f_average_angular_beta = 0.d0 - do k = 1, n_points_integration_angular - f_average_angular_alpha += weights_angular_points(k) * one_body_dm_mo_alpha_at_grid_points(k,i,j,1) * weight_functions_at_grid_points(k,i,j) - f_average_angular_beta += weights_angular_points(k) * one_body_dm_mo_beta_at_grid_points(k,i,j,1) * weight_functions_at_grid_points(k,i,j) + do k = 1, n_points_angular_grid + f_average_angular_alpha += weights_angular_points(k) * one_body_dm_mo_alpha_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j) + f_average_angular_beta += weights_angular_points(k) * one_body_dm_mo_beta_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j) enddo ! x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1] double precision :: contrib_integration +! print*,m_knowles contrib_integration = derivative_knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x) & *knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x)**2 integral_density_alpha_knowles_becke_per_atom(j) += contrib_integration *f_average_angular_alpha diff --git a/plugins/DFT_Utils/test_integration_3d_density.irp.f b/plugins/DFT_Utils/test_integration_3d_density.irp.f index dba02805..93ce58f4 100644 --- a/plugins/DFT_Utils/test_integration_3d_density.irp.f +++ b/plugins/DFT_Utils/test_integration_3d_density.irp.f @@ -4,55 +4,13 @@ program pouet touch read_wf print*,'m_knowles = ',m_knowles call routine - call routine3 end - - - -subroutine routine3 - implicit none - integer :: i,j,k,l - double precision :: accu - accu = 0.d0 - do j = 1, nucl_num ! that are referred to each atom - do i = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom - do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom - accu += final_weight_functions_at_grid_points(k,i,j) * one_body_dm_mo_alpha_at_grid_points(k,i,j,1) - enddo - enddo - enddo - print*, accu - print*, 'lda_exchange',lda_exchange - -end -subroutine routine2 - implicit none - integer :: i,j,k,l - double precision :: x,y,z - double precision :: r - double precision :: accu - accu = 0.d0 - r = 1.d0 - do k = 1, n_points_integration_angular - x = angular_quadrature_points(k,1) * r - y = angular_quadrature_points(k,2) * r - z = angular_quadrature_points(k,3) * r - accu += weights_angular_points(k) * (x**2 + y**2 + z**2) - enddo - print*, accu - -end - - subroutine routine implicit none integer :: i double precision :: accu(2) accu = 0.d0 - do i = 1, N_det - call debug_det(psi_det(1,1,i),N_int) - enddo do i = 1, nucl_num accu(1) += integral_density_alpha_knowles_becke_per_atom(i) accu(2) += integral_density_beta_knowles_becke_per_atom(i) @@ -61,18 +19,6 @@ subroutine routine print*,'Nalpha = ',elec_alpha_num print*,'accu(2) = ',accu(2) print*,'Nalpha = ',elec_beta_num - - accu = 0.d0 - do i = 1, mo_tot_num - accu(1) += one_body_dm_mo_alpha_average(i,i) - accu(2) += one_body_dm_mo_beta_average(i,i) - enddo - - - print*,' ' - print*,' ' - print*,'accu(1) = ',accu(1) - print*,'accu(2) = ',accu(2) end diff --git a/plugins/FCIdump/NEEDED_CHILDREN_MODULES b/plugins/FCIdump/NEEDED_CHILDREN_MODULES index 8d60d3c7..34de8ddb 100644 --- a/plugins/FCIdump/NEEDED_CHILDREN_MODULES +++ b/plugins/FCIdump/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Determinants Davidson core_integrals +Determinants Davidson diff --git a/plugins/FCIdump/fcidump.irp.f b/plugins/FCIdump/fcidump.irp.f index 8d334fc5..f93c1128 100644 --- a/plugins/FCIdump/fcidump.irp.f +++ b/plugins/FCIdump/fcidump.irp.f @@ -1,25 +1,21 @@ program fcidump implicit none - character*(128) :: output - integer :: i_unit_output,getUnitAndOpen - output=trim(ezfio_filename)//'.FCIDUMP' - i_unit_output = getUnitAndOpen(output,'w') integer :: i,j,k,l - integer :: i1,j1,k1,l1 - integer :: i2,j2,k2,l2 + integer :: ii(8), jj(8), kk(8),ll(8) integer*8 :: m character*(2), allocatable :: A(:) - write(i_unit_output,*) '&FCI NORB=', n_act_orb, ', NELEC=', elec_num-n_core_orb*2, & + print *, '&FCI NORB=', mo_tot_num, ', NELEC=', elec_num, & ', MS2=', (elec_alpha_num-elec_beta_num), ',' - allocate (A(n_act_orb)) + allocate (A(mo_tot_num)) A = '1,' - write(i_unit_output,*) 'ORBSYM=', (A(i), i=1,n_act_orb) - write(i_unit_output,*) 'ISYM=0,' - write(i_unit_output,*) '/' + print *, 'ORBSYM=', (A(i), i=1,mo_tot_num) + print *,'ISYM=0,' + print *,'/' deallocate(A) + integer*8 :: i8, k1 integer(key_kind), allocatable :: keys(:) double precision, allocatable :: values(:) integer(cache_map_size_kind) :: n_elements, n_elements_max @@ -27,18 +23,14 @@ program fcidump double precision :: get_mo_bielec_integral, integral - do l=1,n_act_orb - l1 = list_act(l) - do k=1,n_act_orb - k1 = list_act(k) - do j=l,n_act_orb - j1 = list_act(j) - do i=k,n_act_orb - i1 = list_act(i) - if (i1>=j1) then - integral = get_mo_bielec_integral(i1,j1,k1,l1,mo_integrals_map) + do l=1,mo_tot_num + do k=1,mo_tot_num + do j=l,mo_tot_num + do i=k,mo_tot_num + if (i>=j) then + integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) if (dabs(integral) > mo_integrals_threshold) then - write(i_unit_output,*) integral, i,k,j,l + print *, integral, i,k,j,l endif end if enddo @@ -46,15 +38,13 @@ program fcidump enddo enddo - do j=1,n_act_orb - j1 = list_act(j) - do i=j,n_act_orb - i1 = list_act(i) - integral = mo_mono_elec_integral(i1,j1) + core_fock_operator(i1,j1) + do j=1,mo_tot_num + do i=j,mo_tot_num + integral = mo_mono_elec_integral(i,j) if (dabs(integral) > mo_integrals_threshold) then - write(i_unit_output,*) integral, i,j,0,0 + print *, integral, i,j,0,0 endif enddo enddo - write(i_unit_output,*) core_energy, 0, 0, 0, 0 + print *, 0.d0, 0, 0, 0, 0 end diff --git a/plugins/FOBOCI/NEEDED_CHILDREN_MODULES b/plugins/FOBOCI/NEEDED_CHILDREN_MODULES index 25d61c69..16fce081 100644 --- a/plugins/FOBOCI/NEEDED_CHILDREN_MODULES +++ b/plugins/FOBOCI/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_no_sorted SCF_density Davidson CISD +Perturbation Selectors_no_sorted Hartree_Fock Davidson CISD diff --git a/plugins/FOBOCI/SC2_1h1p.irp.f b/plugins/FOBOCI/SC2_1h1p.irp.f index a6e7e506..7733831c 100644 --- a/plugins/FOBOCI/SC2_1h1p.irp.f +++ b/plugins/FOBOCI/SC2_1h1p.irp.f @@ -356,7 +356,7 @@ subroutine dressing_1h1p_by_2h2p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Ni c_ref = 1.d0/u_in(index_hf,1) do k = 1, n_singles l = index_singles(k) - diag_H_elements(1) -= diag_H_elements(l) + diag_H_elements(0) -= diag_H_elements(l) enddo ! do k = 1, n_doubles ! l = index_doubles(k) diff --git a/plugins/FOBOCI/all_singles.irp.f b/plugins/FOBOCI/all_singles.irp.f index 7c321b72..65d81e07 100644 --- a/plugins/FOBOCI/all_singles.irp.f +++ b/plugins/FOBOCI/all_singles.irp.f @@ -48,7 +48,6 @@ subroutine all_single(e_pt2) print*,'-----------------------' print*,'i = ',i call H_apply_just_mono(pt2, norm_pert, H_pert_diag, N_st) - call make_s2_eigenfunction_first_order call diagonalize_CI print*,'N_det = ',N_det print*,'E = ',CI_energy(1) diff --git a/plugins/FOBOCI/create_1h_or_1p.irp.f b/plugins/FOBOCI/create_1h_or_1p.irp.f index c5205903..41ec7b6c 100644 --- a/plugins/FOBOCI/create_1h_or_1p.irp.f +++ b/plugins/FOBOCI/create_1h_or_1p.irp.f @@ -29,13 +29,21 @@ subroutine create_restart_and_1h(i_hole) enddo enddo enddo - integer :: N_det_old N_det_old = N_det - - logical, allocatable :: duplicate(:) - allocate (new_det(N_int,2,n_new_det),duplicate(n_new_det)) + N_det += n_new_det + allocate (new_det(N_int,2,n_new_det)) + if (psi_det_size < N_det) then + psi_det_size = N_det + TOUCH psi_det_size + endif + do i = 1, N_det_old + do k = 1, N_int + psi_det(k,1,i) = old_psi_det(k,1,i) + psi_det(k,2,i) = old_psi_det(k,2,i) + enddo + enddo n_new_det = 0 do j = 1, n_act_orb @@ -50,56 +58,19 @@ subroutine create_restart_and_1h(i_hole) if(i_ok .ne. 1)cycle n_new_det +=1 do k = 1, N_int - new_det(k,1,n_new_det) = key_tmp(k,1) - new_det(k,2,n_new_det) = key_tmp(k,2) + psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1) + psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2) enddo + psi_coef(n_det_old+n_new_det,:) = 0.d0 enddo enddo enddo - integer :: i_test - duplicate = .False. - do i = 1, n_new_det - if(duplicate(i))cycle - do j = i+1, n_new_det - i_test = 0 - do ispin =1 ,2 - do k = 1, N_int - i_test += popcnt(xor(new_det(k,ispin,i),new_det(k,ispin,j))) - enddo - enddo - if(i_test.eq.0)then - duplicate(j) = .True. - endif - enddo - enddo - - integer :: n_new_det_unique - n_new_det_unique = 0 - print*, 'uniq det' - do i = 1, n_new_det - if(.not.duplicate(i))then - n_new_det_unique += 1 - endif - enddo - print*, n_new_det_unique - N_det += n_new_det_unique - if (psi_det_size < N_det) then - psi_det_size = N_det - TOUCH psi_det_size - endif - do i = 1, n_new_det_unique - do ispin = 1, 2 - do k = 1, N_int - psi_det(k,ispin,N_det_old+i) = new_det(k,ispin,i) - enddo - enddo - psi_coef(N_det_old+i,:) = 0.d0 - enddo - - SOFT_TOUCH N_det psi_det psi_coef - deallocate (new_det,duplicate) + logical :: found_duplicates + if(n_act_orb.gt.1)then + call remove_duplicates_in_psi_det(found_duplicates) + endif end subroutine create_restart_and_1p(i_particle) @@ -136,8 +107,18 @@ subroutine create_restart_and_1p(i_particle) integer :: N_det_old N_det_old = N_det - logical, allocatable :: duplicate(:) - allocate (new_det(N_int,2,n_new_det),duplicate(n_new_det)) + N_det += n_new_det + allocate (new_det(N_int,2,n_new_det)) + if (psi_det_size < N_det) then + psi_det_size = N_det + TOUCH psi_det_size + endif + do i = 1, N_det_old + do k = 1, N_int + psi_det(k,1,i) = old_psi_det(k,1,i) + psi_det(k,2,i) = old_psi_det(k,2,i) + enddo + enddo n_new_det = 0 do j = 1, n_act_orb @@ -152,59 +133,17 @@ subroutine create_restart_and_1p(i_particle) if(i_ok .ne. 1)cycle n_new_det +=1 do k = 1, N_int - new_det(k,1,n_new_det) = key_tmp(k,1) - new_Det(k,2,n_new_det) = key_tmp(k,2) + psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1) + psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2) enddo + psi_coef(n_det_old+n_new_det,:) = 0.d0 enddo enddo enddo - integer :: i_test - duplicate = .False. - do i = 1, n_new_det - if(duplicate(i))cycle - call debug_det(new_det(1,1,i),N_int) - do j = i+1, n_new_det - i_test = 0 - call debug_det(new_det(1,1,j),N_int) - do ispin =1 ,2 - do k = 1, N_int - i_test += popcnt(xor(new_det(k,ispin,i),new_det(k,ispin,j))) - enddo - enddo - if(i_test.eq.0)then - duplicate(j) = .True. - endif - enddo - enddo - - integer :: n_new_det_unique - n_new_det_unique = 0 - print*, 'uniq det' - do i = 1, n_new_det - if(.not.duplicate(i))then - n_new_det_unique += 1 - endif - enddo - print*, n_new_det_unique - - N_det += n_new_det_unique - if (psi_det_size < N_det) then - psi_det_size = N_det - TOUCH psi_det_size - endif - do i = 1, n_new_det_unique - do ispin = 1, 2 - do k = 1, N_int - psi_det(k,ispin,N_det_old+i) = new_det(k,ispin,i) - enddo - enddo - psi_coef(N_det_old+i,:) = 0.d0 - enddo - SOFT_TOUCH N_det psi_det psi_coef - deallocate (new_det,duplicate) - + logical :: found_duplicates + call remove_duplicates_in_psi_det(found_duplicates) end subroutine create_restart_1h_1p(i_hole,i_part) diff --git a/plugins/FOBOCI/density.irp.f b/plugins/FOBOCI/density.irp.f deleted file mode 100644 index 4a988134..00000000 --- a/plugins/FOBOCI/density.irp.f +++ /dev/null @@ -1,16 +0,0 @@ -BEGIN_PROVIDER [double precision, mo_general_density_alpha, (mo_tot_num_align,mo_tot_num)] - implicit none - integer :: i,j,k,l - mo_general_density_alpha = one_body_dm_mo_alpha_generators_restart - -END_PROVIDER - - -BEGIN_PROVIDER [double precision, mo_general_density_beta, (mo_tot_num_align,mo_tot_num)] - implicit none - integer :: i,j,k,l - mo_general_density_beta = one_body_dm_mo_beta_generators_restart - -END_PROVIDER - - diff --git a/plugins/FOBOCI/density_matrix.irp.f b/plugins/FOBOCI/density_matrix.irp.f index 14a2fefa..aaf80c4f 100644 --- a/plugins/FOBOCI/density_matrix.irp.f +++ b/plugins/FOBOCI/density_matrix.irp.f @@ -1,12 +1,12 @@ BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_generators_restart, (mo_tot_num_align,mo_tot_num) ] &BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_generators_restart, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, norm_generators_restart, (N_states)] +&BEGIN_PROVIDER [ double precision, norm_generators_restart] implicit none BEGIN_DOC ! Alpha and beta one-body density matrix for the generators restart END_DOC - integer :: j,k,l,m,istate + integer :: j,k,l,m integer :: occ(N_int*bit_kind_size,2) double precision :: ck, cl, ckl double precision :: phase @@ -14,37 +14,23 @@ integer :: exc(0:2,2,2),n_occ_alpha double precision, allocatable :: tmp_a(:,:), tmp_b(:,:) integer :: degree_respect_to_HF_k - integer :: degree_respect_to_HF_l,index_ref_generators_restart(N_states) - double precision :: inv_coef_ref_generators_restart(N_states) + integer :: degree_respect_to_HF_l,index_ref_generators_restart + double precision :: inv_coef_ref_generators_restart integer :: i - print*, 'providing the one_body_dm_mo_alpha_generators_restart' - do istate = 1, N_states - do i = 1, N_det_generators_restart - ! Find the reference determinant for intermediate normalization - call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det_generators_restart(1,1,i),degree,N_int) - if(degree == 0)then - index_ref_generators_restart(istate) = i - inv_coef_ref_generators_restart(istate) = 1.d0/psi_coef_generators_restart(i,istate) - exit - endif - enddo + do i = 1, N_det_generators_restart + ! Find the reference determinant for intermediate normalization + call get_excitation_degree(ref_generators_restart,psi_det_generators_restart(1,1,i),degree,N_int) + if(degree == 0)then + index_ref_generators_restart = i + inv_coef_ref_generators_restart = 1.d0/psi_coef_generators_restart(i,1) + exit + endif enddo norm_generators_restart = 0.d0 - do istate = 1, N_states - do i = 1, N_det_generators_restart - psi_coef_generators_restart(i,istate) = psi_coef_generators_restart(i,istate) * inv_coef_ref_generators_restart(istate) - norm_generators_restart(istate) += psi_coef_generators_restart(i,istate)**2 - enddo - enddo - double precision :: inv_norm(N_States) - do istate = 1, N_states - inv_norm(istate) = 1.d0/dsqrt(norm_generators_restart(istate)) - enddo - do istate = 1, N_states - do i = 1, N_det_generators_restart - psi_coef_generators_restart(i,istate) = psi_coef_generators_restart(i,istate) * inv_norm(istate) - enddo + do i = 1, N_det_generators_restart + psi_coef_generators_restart(i,1) = psi_coef_generators_restart(i,1) * inv_coef_ref_generators_restart + norm_generators_restart += psi_coef_generators_restart(i,1)**2 enddo diff --git a/plugins/FOBOCI/dress_simple.irp.f b/plugins/FOBOCI/dress_simple.irp.f index c74d08e7..dd1ed221 100644 --- a/plugins/FOBOCI/dress_simple.irp.f +++ b/plugins/FOBOCI/dress_simple.irp.f @@ -107,6 +107,7 @@ subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_per !enddo !soft_touch psi_selectors psi_selectors_coef !if(do_it_perturbative)then + print*, 'is_ok_perturbative',is_ok_perturbative if(is_ok.or.is_ok_perturbative)then N_det = N_det_generators do m = 1, N_states @@ -116,6 +117,7 @@ subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_per psi_det(l,2,k) = psi_det_generators_input(l,2,k) enddo psi_coef(k,m) = psi_coef_diagonalized_tmp(k,m) + print*, 'psi_coef(k,m)',psi_coef(k,m) enddo enddo soft_touch psi_det psi_coef N_det @@ -148,7 +150,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener double precision, intent(inout) :: dressed_H_matrix(Ndet_generators, Ndet_generators) - integer :: i,j,degree,index_ref_generators_restart(N_states),i_count,k,i_det_no_ref + integer :: i,j,degree,index_ref_generators_restart,i_count,k,i_det_no_ref double precision :: eigvalues(Ndet_generators), eigvectors(Ndet_generators,Ndet_generators),hij double precision :: psi_coef_ref(Ndet_generators,N_states),diag_h_mat_average,diag_h_mat_no_ref_average logical :: is_a_ref_det(Ndet_generators) @@ -166,17 +168,11 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener enddo - integer :: istate - do istate = 1, N_states - do i = 1, Ndet_generators - call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det_generators_input(1,1,i),degree,N_int) - if(degree == 0)then - index_ref_generators_restart(istate) = i - exit - endif - enddo - enddo do i = 1, Ndet_generators + call get_excitation_degree(ref_generators_restart,psi_det_generators_input(1,1,i),degree,N_int) + if(degree == 0)then + index_ref_generators_restart = i + endif do j = 1, Ndet_generators call i_h_j(psi_det_generators_input(1,1,j),psi_det_generators_input(1,1,i),N_int,hij) ! Fill the zeroth order H matrix dressed_H_matrix(i,j) = hij @@ -189,21 +185,15 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener i_det_no_ref +=1 diag_h_mat_average+=dressed_H_matrix(i,i) enddo - double precision :: average_ref_h_mat - average_ref_h_mat = 0.d0 - do istate = 1, N_states - average_ref_h_mat += dressed_H_matrix(index_ref_generators_restart(istate),index_ref_generators_restart(istate)) - enddo - average_ref_h_mat = 1.d0/dble(N_states) diag_h_mat_average = diag_h_mat_average/dble(i_det_no_ref) print*,'diag_h_mat_average = ',diag_h_mat_average - print*,'ref h_mat average = ',average_ref_h_mat + print*,'ref h_mat = ',dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) integer :: number_of_particles, number_of_holes ! Filter the the MLCT that are higher than 27.2 eV in energy with respect to the reference determinant do i = 1, Ndet_generators if(is_a_ref_det(i))cycle if(number_of_holes(psi_det_generators_input(1,1,i)).eq.0 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.1)then - if(diag_h_mat_average - average_ref_h_mat .gt.2.d0)then + if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then is_ok = .False. exit_loop = .True. return @@ -212,7 +202,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener ! Filter the the LMCT that are higher than 54.4 eV in energy with respect to the reference determinant if(number_of_holes(psi_det_generators_input(1,1,i)).eq.1 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.0)then - if(diag_h_mat_average - average_ref_h_mat .gt.1.d0)then + if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then is_ok = .False. return endif @@ -220,7 +210,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener exit enddo - call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the naked matrix + call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the Dressed_H_matrix double precision :: s2(N_det_generators),E_ref(N_states) integer :: i_state(N_states) @@ -246,10 +236,15 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener E_ref(i) = eigvalues(i) enddo endif + do i = 1,N_states + print*,'i_state = ',i_state(i) + enddo do k = 1, N_states + print*,'state ',k do i = 1, Ndet_generators - psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart(k),i_state(k)) + psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart,i_state(k)) psi_coef_ref(i,k) = eigvectors(i,i_state(k)) + print*,'psi_coef_ref(i) = ',psi_coef_ref(i,k) enddo enddo if(verbose)then @@ -262,7 +257,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener do k = 1, N_states print*,'state ',k do i = 1, Ndet_generators - print*,'coef, = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart(k),index_ref_generators_restart(k)),is_a_ref_det(i) + print*,'coef, = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart),is_a_ref_det(i) enddo enddo endif @@ -283,20 +278,18 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the Dressed_H_matrix integer :: i_good_state(0:N_states) i_good_state(0) = 0 - do k = 1, N_states -! print*,'state',k - do i = 1, Ndet_generators + do i = 1, Ndet_generators ! State following + do k = 1, N_states accu = 0.d0 do j =1, Ndet_generators + print*,'',eigvectors(j,i) , psi_coef_ref(j,k) accu += eigvectors(j,i) * psi_coef_ref(j,k) enddo -! print*,i,accu - if(dabs(accu).ge.0.60d0)then + print*,'accu = ',accu + if(dabs(accu).ge.0.72d0)then i_good_state(0) +=1 i_good_state(i_good_state(0)) = i - print*, 'state, ovrlap',k,i,accu - exit endif enddo if(i_good_state(0)==N_states)then @@ -311,14 +304,14 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener accu = 0.d0 do k = 1, N_states do i = 1, Ndet_generators - psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart(k),i_state(k)) + psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart,i_state(k)) enddo enddo if(verbose)then do k = 1, N_states print*,'state ',k do i = 1, Ndet_generators - print*,'coef, = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart(k),index_ref_generators_restart(k)),is_a_ref_det(i) + print*,'coef, = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart),is_a_ref_det(i) enddo enddo endif @@ -340,7 +333,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener do i = 1, Ndet_generators if(is_a_ref_det(i))cycle do k = 1, N_states -! print*, psi_coef_diagonalized_tmp(i,k),threshold_perturbative + print*, psi_coef_diagonalized_tmp(i,k),threshold_perturbative if(dabs(psi_coef_diagonalized_tmp(i,k)) .gt.threshold_perturbative)then is_ok_perturbative = .False. exit diff --git a/plugins/FOBOCI/fobo_scf.irp.f b/plugins/FOBOCI/fobo_scf.irp.f index 3860493c..8a709154 100644 --- a/plugins/FOBOCI/fobo_scf.irp.f +++ b/plugins/FOBOCI/fobo_scf.irp.f @@ -15,6 +15,8 @@ end subroutine run_prepare implicit none +! no_oa_or_av_opt = .False. +! touch no_oa_or_av_opt call damping_SCF call diag_inactive_virt_and_update_mos end @@ -26,8 +28,7 @@ subroutine routine_fobo_scf print*,'' character*(64) :: label label = "Natural" - do i = 1, 10 - call initialize_mo_coef_begin_iteration + do i = 1, 5 print*,'*******************************************************************************' print*,'*******************************************************************************' print*,'FOBO-SCF Iteration ',i @@ -55,8 +56,6 @@ subroutine routine_fobo_scf call save_osoci_natural_mos call damping_SCF call diag_inactive_virt_and_update_mos - call reorder_active_orb - call save_mos call clear_mo_map call provide_properties enddo diff --git a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f index 746704c2..46ca9662 100644 --- a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f +++ b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f @@ -40,13 +40,11 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) logical :: lmct double precision, allocatable :: psi_singles_coef(:,:) logical :: exit_loop - call update_generators_restart_coef allocate( zero_bitmask(N_int,2) ) do i = 1, n_inact_orb lmct = .True. integer :: i_hole_osoci i_hole_osoci = list_inact(i) -! if(i_hole_osoci.ne.26)cycle print*,'--------------------------' ! First set the current generators to the one of restart call check_symetry(i_hole_osoci,thr,test_sym) @@ -56,6 +54,7 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) print*,'i_hole_osoci = ',i_hole_osoci call create_restart_and_1h(i_hole_osoci) call set_generators_to_psi_det + print*,'Passed set generators' call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask) double precision :: e_pt2 @@ -83,10 +82,10 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask) call all_single(e_pt2) -! call make_s2_eigenfunction_first_order -! threshold_davidson = 1.d-6 -! soft_touch threshold_davidson davidson_criterion -! call diagonalize_ci + call make_s2_eigenfunction_first_order + threshold_davidson = 1.d-6 + soft_touch threshold_davidson davidson_criterion + call diagonalize_ci double precision :: hkl call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators) hkl = dressing_matrix(1,1) @@ -119,7 +118,6 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) do i = 1, n_virt_orb integer :: i_particl_osoci i_particl_osoci = list_virt(i) -! cycle print*,'--------------------------' ! First set the current generators to the one of restart @@ -154,11 +152,11 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) enddo enddo call all_single(e_pt2) -! call make_s2_eigenfunction_first_order -! threshold_davidson = 1.d-6 -! soft_touch threshold_davidson davidson_criterion -! -! call diagonalize_ci + call make_s2_eigenfunction_first_order + threshold_davidson = 1.d-6 + soft_touch threshold_davidson davidson_criterion + + call diagonalize_ci deallocate(dressing_matrix) else if(exit_loop)then @@ -543,6 +541,7 @@ subroutine FOBOCI_lmct_mlct_old_thr_restart(iter) call print_generators_bitmasks_holes ! Impose that only the active part can be reached call set_bitmask_hole_as_input(unpaired_bitmask) +!!! call all_single_h_core call create_restart_and_1p(i_particl_osoci) !!! ! Update the generators call set_generators_to_psi_det diff --git a/plugins/FOBOCI/generators_restart_save.irp.f b/plugins/FOBOCI/generators_restart_save.irp.f index 6ec528cf..eba9f0ad 100644 --- a/plugins/FOBOCI/generators_restart_save.irp.f +++ b/plugins/FOBOCI/generators_restart_save.irp.f @@ -21,19 +21,23 @@ END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators_restart, (N_int,2,N_det_generators_restart) ] -&BEGIN_PROVIDER [ integer(bit_kind), ref_generators_restart, (N_int,2,N_states) ] +&BEGIN_PROVIDER [ integer(bit_kind), ref_generators_restart, (N_int,2) ] &BEGIN_PROVIDER [ double precision, psi_coef_generators_restart, (N_det_generators_restart,N_states) ] implicit none BEGIN_DOC ! read wf ! END_DOC - integer :: i, k,j + integer :: i, k integer, save :: ifirst = 0 double precision, allocatable :: psi_coef_read(:,:) print*, ' Providing psi_det_generators_restart' if(ifirst == 0)then call read_dets(psi_det_generators_restart,N_int,N_det_generators_restart) + do k = 1, N_int + ref_generators_restart(k,1) = psi_det_generators_restart(k,1,1) + ref_generators_restart(k,2) = psi_det_generators_restart(k,2,1) + enddo allocate (psi_coef_read(N_det_generators_restart,N_states)) call ezfio_get_determinants_psi_coef(psi_coef_read) do k = 1, N_states @@ -41,18 +45,6 @@ END_PROVIDER psi_coef_generators_restart(i,k) = psi_coef_read(i,k) enddo enddo - do k = 1, N_states - do i = 1, N_det_generators_restart - if(dabs(psi_coef_generators_restart(i,k)).gt.0.5d0)then - do j = 1, N_int - ref_generators_restart(j,1,k) = psi_det_generators_restart(j,1,i) - ref_generators_restart(j,2,k) = psi_det_generators_restart(j,2,i) - enddo - exit - endif - enddo - call debug_det(ref_generators_restart(1,1,k),N_int) - enddo ifirst = 1 deallocate(psi_coef_read) else @@ -82,18 +74,3 @@ END_PROVIDER &BEGIN_PROVIDER [ double precision, psi_coef_generators, (10000,N_states) ] END_PROVIDER - -subroutine update_generators_restart_coef - implicit none - call set_generators_to_generators_restart - call set_psi_det_to_generators - call diagonalize_CI - integer :: i,j,k,l - do i = 1, N_det_generators_restart - do j = 1, N_states - psi_coef_generators_restart(i,j) = psi_coef(i,j) - enddo - enddo - soft_touch psi_coef_generators_restart - provide one_body_dm_mo_alpha_generators_restart -end diff --git a/plugins/FOBOCI/routines_foboci.irp.f b/plugins/FOBOCI/routines_foboci.irp.f index db683c96..7d194a54 100644 --- a/plugins/FOBOCI/routines_foboci.irp.f +++ b/plugins/FOBOCI/routines_foboci.irp.f @@ -2,7 +2,7 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole) implicit none integer, intent(in) :: i_hole double precision, intent(out) :: norm(N_states) - integer :: i,j,degree,index_ref_generators_restart(N_states),k + integer :: i,j,degree,index_ref_generators_restart,k integer:: number_of_holes,n_h, number_of_particles,n_p integer, allocatable :: index_one_hole(:),index_one_hole_one_p(:),index_two_hole_one_p(:),index_two_hole(:) integer, allocatable :: index_one_p(:) @@ -13,8 +13,6 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole) integer :: n_good_hole logical,allocatable :: is_a_ref_det(:) allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det)) - double precision, allocatable :: local_norm(:) - allocate(local_norm(N_states)) n_one_hole = 0 n_one_hole_one_p = 0 @@ -24,18 +22,17 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole) n_good_hole = 0 ! Find the one holes and one hole one particle is_a_ref_det = .False. - integer :: istate - do istate = 1, N_States - do i = 1, N_det - ! Find the reference determinant for intermediate normalization - call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det(1,1,i),degree,N_int) - if(degree == 0)then - index_ref_generators_restart(istate) = i - inv_coef_ref_generators_restart(istate) = 1.d0/psi_coef(i,istate) - endif - enddo - enddo do i = 1, N_det + ! Find the reference determinant for intermediate normalization + call get_excitation_degree(ref_generators_restart,psi_det(1,1,i),degree,N_int) + if(degree == 0)then + index_ref_generators_restart = i + do k = 1, N_states + inv_coef_ref_generators_restart(k) = 1.d0/psi_coef(i,k) + enddo +! cycle + endif + ! Find all the determinants present in the reference wave function do j = 1, N_det_generators_restart call get_excitation_degree(psi_det(1,1,i),psi_det_generators_restart(1,1,j),degree,N_int) @@ -62,48 +59,40 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole) enddo endif enddo - - +!do k = 1, N_det +! call debug_det(psi_det(1,1,k),N_int) +! print*,'k,coef = ',k,psi_coef(k,1)/psi_coef(index_ref_generators_restart,1) +!enddo print*,'' print*,'n_good_hole = ',n_good_hole do k = 1,N_states print*,'state ',k do i = 1, n_good_hole - print*,'psi_coef(index_good_hole) = ',psi_coef(index_good_hole(i),k)/psi_coef(index_ref_generators_restart(k),k) + print*,'psi_coef(index_good_hole) = ',psi_coef(index_good_hole(i),k)/psi_coef(index_ref_generators_restart,k) enddo print*,'' enddo + norm = 0.d0 - ! Set the wave function to the intermediate normalization + ! Set the wave function to the intermediate normalization do k = 1, N_states do i = 1, N_det psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k) enddo enddo - - - norm = 0.d0 do k = 1,N_states print*,'state ',k do i = 1, N_det +!! print*,'psi_coef(i_ref) = ',psi_coef(i,1) if (is_a_ref_det(i))then print*,'i,psi_coef_ref = ',psi_coef(i,k) + cycle endif norm(k) += psi_coef(i,k) * psi_coef(i,k) enddo print*,'norm = ',norm(k) enddo - do k =1, N_states - local_norm(k) = 1.d0 / dsqrt(norm(k)) - enddo - do k = 1,N_states - do i = 1, N_det - psi_coef(i,k) = psi_coef(i,k) * local_norm(k) - enddo - enddo - deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det) - deallocate(local_norm) soft_touch psi_coef end @@ -112,7 +101,7 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl) implicit none integer, intent(in) :: i_particl double precision, intent(out) :: norm(N_states) - integer :: i,j,degree,index_ref_generators_restart(N_states),k + integer :: i,j,degree,index_ref_generators_restart,k integer:: number_of_holes,n_h, number_of_particles,n_p integer, allocatable :: index_one_hole(:),index_one_hole_one_p(:),index_two_hole_one_p(:),index_two_hole(:) integer, allocatable :: index_one_p(:),index_one_hole_two_p(:) @@ -128,8 +117,6 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl) integer :: i_count allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det)) allocate(index_one_hole_two_p(n_det)) - double precision, allocatable :: local_norm(:) - allocate(local_norm(N_states)) n_one_hole = 0 n_one_hole_one_p = 0 @@ -141,18 +128,16 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl) ! Find the one holes and one hole one particle i_count = 0 is_a_ref_det = .False. - integer :: istate - do istate = 1, N_states - do i = 1, N_det - call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det(1,1,i),degree,N_int) - if(degree == 0)then - index_ref_generators_restart(istate) = i - inv_coef_ref_generators_restart(istate) = 1.d0/psi_coef(i,istate) - endif - enddo - enddo - do i = 1, N_det + call get_excitation_degree(ref_generators_restart,psi_det(1,1,i),degree,N_int) + if(degree == 0)then + index_ref_generators_restart = i + do k = 1, N_states + inv_coef_ref_generators_restart(k) = 1.d0/psi_coef(i,k) + enddo +! cycle + endif + ! Find all the determinants present in the reference wave function do j = 1, N_det_generators_restart call get_excitation_degree(psi_det(1,1,i),psi_det_generators_restart(1,1,j),degree,N_int) @@ -188,7 +173,7 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl) do k = 1, N_states print*,'state ',k do i = 1, n_good_particl - print*,'psi_coef(index_good_particl,1) = ',psi_coef(index_good_particl(i),k)/psi_coef(index_ref_generators_restart(k),k) + print*,'psi_coef(index_good_particl,1) = ',psi_coef(index_good_particl(i),k)/psi_coef(index_ref_generators_restart,k) enddo print*,'' enddo @@ -200,29 +185,20 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl) psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k) enddo enddo - - norm = 0.d0 - do k = 1,N_states + do k = 1, N_states print*,'state ',k do i = 1, N_det +!! print*,'i = ',i, psi_coef(i,1) if (is_a_ref_det(i))then print*,'i,psi_coef_ref = ',psi_coef(i,k) + cycle endif norm(k) += psi_coef(i,k) * psi_coef(i,k) enddo - print*,'norm = ',norm(k) - enddo - do k =1, N_states - local_norm(k) = 1.d0 / dsqrt(norm(k)) - enddo - do k = 1,N_states - do i = 1, N_det - psi_coef(i,k) = psi_coef(i,k) * local_norm(k) - enddo + print*,'norm = ',norm enddo soft_touch psi_coef deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det) - deallocate(local_norm) end @@ -234,60 +210,12 @@ subroutine update_density_matrix_osoci END_DOC integer :: i,j integer :: iorb,jorb - ! active <--> inactive block do i = 1, mo_tot_num do j = 1, mo_tot_num - one_body_dm_mo_alpha_osoci(i,j) += one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j) - one_body_dm_mo_beta_osoci(i,j) += one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j) + one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j)) + one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j)) enddo enddo -!do i = 1, n_act_orb -! iorb = list_act(i) -! do j = 1, n_inact_orb -! jorb = list_inact(j) -! one_body_dm_mo_alpha_osoci(iorb,jorb)+= one_body_dm_mo_alpha_average(iorb,jorb) -! one_body_dm_mo_alpha_osoci(jorb,iorb)+= one_body_dm_mo_alpha_average(jorb,iorb) -! one_body_dm_mo_beta_osoci(iorb,jorb) += one_body_dm_mo_beta_average(iorb,jorb) -! one_body_dm_mo_beta_osoci(jorb,iorb) += one_body_dm_mo_beta_average(jorb,iorb) -! enddo -!enddo - -!! active <--> virt block -!do i = 1, n_act_orb -! iorb = list_act(i) -! do j = 1, n_virt_orb -! jorb = list_virt(j) -! one_body_dm_mo_alpha_osoci(iorb,jorb)+= one_body_dm_mo_alpha_average(iorb,jorb) -! one_body_dm_mo_alpha_osoci(jorb,iorb)+= one_body_dm_mo_alpha_average(jorb,iorb) -! one_body_dm_mo_beta_osoci(iorb,jorb) += one_body_dm_mo_beta_average(iorb,jorb) -! one_body_dm_mo_beta_osoci(jorb,iorb) += one_body_dm_mo_beta_average(jorb,iorb) -! enddo -!enddo - -!! virt <--> virt block -!do j = 1, n_virt_orb -! jorb = list_virt(j) -! one_body_dm_mo_alpha_osoci(jorb,jorb)+= one_body_dm_mo_alpha_average(jorb,jorb) -! one_body_dm_mo_beta_osoci(jorb,jorb) += one_body_dm_mo_beta_average(jorb,jorb) -!enddo - -!! inact <--> inact block -!do j = 1, n_inact_orb -! jorb = list_inact(j) -! one_body_dm_mo_alpha_osoci(jorb,jorb) -= one_body_dm_mo_alpha_average(jorb,jorb) -! one_body_dm_mo_beta_osoci(jorb,jorb) -= one_body_dm_mo_beta_average(jorb,jorb) -!enddo - double precision :: accu_alpha, accu_beta - accu_alpha = 0.d0 - accu_beta = 0.d0 - do i = 1, mo_tot_num - accu_alpha += one_body_dm_mo_alpha_osoci(i,i) - accu_beta += one_body_dm_mo_beta_osoci(i,i) -! write(*,'(I3,X,100(F16.10,X))') i,one_body_dm_mo_alpha_osoci(i,i),one_body_dm_mo_beta_osoci(i,i),one_body_dm_mo_alpha_osoci(i,i)+one_body_dm_mo_beta_osoci(i,i) - enddo - print*, 'accu_alpha/beta',accu_alpha,accu_beta - - end @@ -333,18 +261,8 @@ end subroutine initialize_density_matrix_osoci implicit none - call set_generators_to_generators_restart - call set_psi_det_to_generators - call diagonalize_CI - one_body_dm_mo_alpha_osoci = one_body_dm_mo_alpha_generators_restart one_body_dm_mo_beta_osoci = one_body_dm_mo_beta_generators_restart - integer :: i - print*, '8*********************' - print*, 'initialize_density_matrix_osoci' - do i = 1, mo_tot_num - print*,one_body_dm_mo_alpha_osoci(i,i),one_body_dm_mo_alpha_generators_restart(i,i) - enddo end subroutine rescale_density_matrix_osoci(norm) @@ -520,10 +438,6 @@ subroutine save_osoci_natural_mos endif enddo enddo - print*, 'test' - print*, 'test' - print*, 'test' - print*, 'test' do i = 1, mo_tot_num do j = i+1, mo_tot_num if(dabs(tmp(i,j)).le.threshold_fobo_dm)then @@ -531,9 +445,7 @@ subroutine save_osoci_natural_mos tmp(j,i) = 0.d0 endif enddo - print*, tmp(i,i) enddo - label = "Natural" diff --git a/plugins/FOBOCI/track_orb.irp.f b/plugins/FOBOCI/track_orb.irp.f deleted file mode 100644 index 7f01fe6a..00000000 --- a/plugins/FOBOCI/track_orb.irp.f +++ /dev/null @@ -1,57 +0,0 @@ - BEGIN_PROVIDER [ double precision, mo_coef_begin_iteration, (ao_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! Alpha and beta one-body density matrix that will be used for the 1h1p approach - END_DOC -END_PROVIDER - -subroutine initialize_mo_coef_begin_iteration - implicit none - mo_coef_begin_iteration = mo_coef - -end - -subroutine reorder_active_orb - implicit none - integer :: i,j,iorb - integer :: k,l - double precision, allocatable :: accu(:) - integer, allocatable :: index_active_orb(:),iorder(:) - double precision, allocatable :: mo_coef_tmp(:,:) - allocate(accu(mo_tot_num),index_active_orb(n_act_orb),iorder(mo_tot_num)) - allocate(mo_coef_tmp(ao_num_align,mo_Tot_num)) - - - do i = 1, n_act_orb - iorb = list_act(i) - do j = 1, mo_tot_num - accu(j) = 0.d0 - iorder(j) = j - do k = 1, ao_num - do l = 1, ao_num - accu(j) += mo_coef_begin_iteration(k,iorb) * mo_coef(l,j) * ao_overlap(k,l) - enddo - enddo - accu(j) = -dabs(accu(j)) - enddo - call dsort(accu,iorder,mo_tot_num) - index_active_orb(i) = iorder(1) - enddo - - double precision :: x - integer :: i1,i2 - print*, 'swapping the active MOs' - do j = 1, n_act_orb - i1 = list_act(j) - i2 = index_active_orb(j) - print*, i1,i2 - do i=1,ao_num_align - x = mo_coef(i,i1) - mo_coef(i,i1) = mo_coef(i,i2) - mo_coef(i,i2) = x - enddo - enddo - - deallocate(accu,index_active_orb, iorder) -end - diff --git a/plugins/Full_CI/H_apply.irp.f b/plugins/Full_CI/H_apply.irp.f index 8977b7fd..79599065 100644 --- a/plugins/Full_CI/H_apply.irp.f +++ b/plugins/Full_CI/H_apply.irp.f @@ -12,6 +12,11 @@ s.set_perturbation("epstein_nesbet_2x2") s.unset_openmp() print s +s = H_apply("FCI_PT2_new") +s.set_perturbation("decontracted") +s.unset_openmp() +print s + s = H_apply("FCI_no_skip") s.set_selection_pt2("epstein_nesbet_2x2") diff --git a/plugins/Full_CI/NEEDED_CHILDREN_MODULES b/plugins/Full_CI/NEEDED_CHILDREN_MODULES index 2f1e40a1..ad5f053f 100644 --- a/plugins/Full_CI/NEEDED_CHILDREN_MODULES +++ b/plugins/Full_CI/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full Davidson +Perturbation Selectors_full Generators_full Davidson diff --git a/plugins/Full_CI_ZMQ/.gitignore b/plugins/Full_CI_ZMQ/.gitignore deleted file mode 100644 index 7ac9fbf6..00000000 --- a/plugins/Full_CI_ZMQ/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -IRPF90_temp/ -IRPF90_man/ -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index 6fd4fd5e..47c8fa26 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -1,1116 +1,3 @@ -use bitmasks - -BEGIN_PROVIDER [ integer, fragment_count ] - implicit none - BEGIN_DOC - ! Number of fragments for the deterministic part - END_DOC - fragment_count = (elec_alpha_num-n_core_orb)**2 -END_PROVIDER - - -double precision function integral8(i,j,k,l) - implicit none - - integer, intent(in) :: i,j,k,l - double precision, external :: get_mo_bielec_integral - integer :: ii - ii = l-mo_integrals_cache_min - ii = ior(ii, k-mo_integrals_cache_min) - ii = ior(ii, j-mo_integrals_cache_min) - ii = ior(ii, i-mo_integrals_cache_min) - if (iand(ii, -64) /= 0) then - integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) - else - ii = l-mo_integrals_cache_min - ii = ior( ishft(ii,6), k-mo_integrals_cache_min) - ii = ior( ishft(ii,6), j-mo_integrals_cache_min) - ii = ior( ishft(ii,6), i-mo_integrals_cache_min) - integral8 = mo_integrals_cache(ii) - endif -end function - - -BEGIN_PROVIDER [ integer(1), psi_phasemask, (N_int*bit_kind_size, 2, N_det)] - use bitmasks - implicit none - - integer :: i - do i=1, N_det - call get_mask_phase(psi_det_sorted(1,1,i), psi_phasemask(1,1,i)) - end do -END_PROVIDER - - -subroutine assert(cond, msg) - character(*), intent(in) :: msg - logical, intent(in) :: cond - - if(.not. cond) then - print *, "assert failed: "//msg - stop - end if -end - - -subroutine get_mask_phase(det, phasemask) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: det(N_int, 2) - integer(1), intent(out) :: phasemask(2,N_int*bit_kind_size) - integer :: s, ni, i - logical :: change - - phasemask = 0_1 - do s=1,2 - change = .false. - do ni=1,N_int - do i=0,bit_kind_size-1 - if(BTEST(det(ni, s), i)) change = .not. change - if(change) phasemask(s, (ni-1)*bit_kind_size + i + 1) = 1_1 - end do - end do - end do -end - - -subroutine select_connected(i_generator,E0,pt2,b,subset) - use bitmasks - use selection_types - implicit none - integer, intent(in) :: i_generator, subset - type(selection_buffer), intent(inout) :: b - double precision, intent(inout) :: pt2(N_states) - integer :: k,l - double precision, intent(in) :: E0(N_states) - - integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision :: fock_diag_tmp(2,mo_tot_num+1) - - call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) - - do l=1,N_generators_bitmask - do k=1,N_int - hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator)) - hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole,l), psi_det_generators(k,2,i_generator)) - particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) ) - particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) ) - - enddo - call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b,subset) - enddo -end - - -double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) - use bitmasks - implicit none - - integer(1), intent(in) :: phasemask(2,*) - integer, intent(in) :: s1, s2, h1, h2, p1, p2 - logical :: change - integer(1) :: np1 - integer :: np - double precision, save :: res(0:1) = (/1d0, -1d0/) - - np1 = phasemask(s1,h1) + phasemask(s1,p1) + phasemask(s2,h2) + phasemask(s2,p2) - np = np1 - if(p1 < h1) np = np + 1 - if(p2 < h2) np = np + 1 - - if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1 - get_phase_bi = res(iand(np,1)) -end - - - -subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti - double precision :: hij - double precision, external :: get_phase_bi, integral8 - - integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - integer, parameter :: turn2(2) = (/2,1/) - - if(h(0,sp) == 2) then - h1 = h(1, sp) - h2 = h(2, sp) - do i=1,3 - puti = p(i, sp) - if(bannedOrb(puti)) cycle - p1 = p(turn3_2(1,i), sp) - p2 = p(turn3_2(2,i), sp) - hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) - hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) - vect(:, puti) += hij * coefs - end do - else if(h(0,sp) == 1) then - sfix = turn2(sp) - hfix = h(1,sfix) - pfix = p(1,sfix) - hmob = h(1,sp) - do j=1,2 - puti = p(j, sp) - if(bannedOrb(puti)) cycle - pmob = p(turn2(j), sp) - hij = integral8(pfix, pmob, hfix, hmob) - hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) - vect(:, puti) += hij * coefs - end do - else - puti = p(1,sp) - if(.not. bannedOrb(puti)) then - sfix = turn2(sp) - p1 = p(1,sfix) - p2 = p(2,sfix) - h1 = h(1,sfix) - h2 = h(2,sfix) - hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) - hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) - vect(:, puti) += hij * coefs - end if - end if -end - - - -subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i, hole, p1, p2, sh - logical :: ok, lbanned(mo_tot_num) - integer(bit_kind) :: det(N_int, 2) - double precision :: hij - double precision, external :: get_phase_bi, integral8 - - lbanned = bannedOrb - sh = 1 - if(h(0,2) == 1) sh = 2 - hole = h(1, sh) - lbanned(p(1,sp)) = .true. - if(p(0,sp) == 2) lbanned(p(2,sp)) = .true. - !print *, "SPm1", sp, sh - - p1 = p(1, sp) - - if(sp == sh) then - p2 = p(2, sp) - lbanned(p2) = .true. - - do i=1,hole-1 - if(lbanned(i)) cycle - hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) - hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) - vect(:,i) += hij * coefs - end do - do i=hole+1,mo_tot_num - if(lbanned(i)) cycle - hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) - hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) - vect(:,i) += hij * coefs - end do - - call apply_particle(mask, sp, p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, p2) += hij * coefs - else - p2 = p(1, sh) - do i=1,mo_tot_num - if(lbanned(i)) cycle - hij = integral8(p1, p2, i, hole) - hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) - vect(:,i) += hij * coefs - end do - end if - - call apply_particle(mask, sp, p1, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, p1) += hij * coefs -end - - -subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i - logical :: ok, lbanned(mo_tot_num) - integer(bit_kind) :: det(N_int, 2) - double precision :: hij - - lbanned = bannedOrb - lbanned(p(1,sp)) = .true. - do i=1,mo_tot_num - if(lbanned(i)) cycle - call apply_particle(mask, sp, i, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, i) += hij * coefs - end do -end - -subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf,subset) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator, subset - integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - - double precision :: mat(N_states, mo_tot_num, mo_tot_num) - integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii - integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) - logical :: fullMatch, ok - - integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) - integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) - integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) - - logical :: monoAdo, monoBdo; - integer :: maskInd - - PROVIDE fragment_count - - monoAdo = .true. - monoBdo = .true. - - allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) - allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) - - do k=1,N_int - hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) - hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) - particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) - particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) - enddo - - integer :: N_holes(2), N_particles(2) - integer :: hole_list(N_int*bit_kind_size,2) - integer :: particle_list(N_int*bit_kind_size,2) - - call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) - call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - -! ! ====== -! ! If the subset doesn't exist, return -! logical :: will_compute -! will_compute = subset == 0 -! -! if (.not.will_compute) then -! maskInd = N_holes(1)*N_holes(2) + N_holes(2)*((N_holes(2)-1)/2) + N_holes(1)*((N_holes(1)-1)/2) -! will_compute = (maskInd >= subset) -! if (.not.will_compute) then -! return -! endif -! endif -! ! ====== - - - integer(bit_kind), allocatable:: preinteresting_det(:,:,:) - allocate (preinteresting_det(N_int,2,N_det)) - - preinteresting(0) = 0 - prefullinteresting(0) = 0 - - do i=1,N_int - negMask(i,1) = not(psi_det_generators(i,1,i_generator)) - negMask(i,2) = not(psi_det_generators(i,2,i_generator)) - end do - - do i=1,N_det - mobMask(1,1) = iand(negMask(1,1), psi_det_sorted(1,1,i)) - mobMask(1,2) = iand(negMask(1,2), psi_det_sorted(1,2,i)) - nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) - do j=2,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt = nt + popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 4) then - if(i <= N_det_selectors) then - preinteresting(0) += 1 - preinteresting(preinteresting(0)) = i - do j=1,N_int - preinteresting_det(j,1,preinteresting(0)) = psi_det_sorted(j,1,i) - preinteresting_det(j,2,preinteresting(0)) = psi_det_sorted(j,2,i) - enddo - else if(nt <= 2) then - prefullinteresting(0) += 1 - prefullinteresting(prefullinteresting(0)) = i - end if - end if - end do - - - maskInd = -1 - integer :: nb_count - do s1=1,2 - do i1=N_holes(s1),1,-1 ! Generate low excitations first - - h1 = hole_list(i1,s1) - call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) - - negMask = not(pmask) - - interesting(0) = 0 - fullinteresting(0) = 0 - - do ii=1,preinteresting(0) - i = preinteresting(ii) - mobMask(1,1) = iand(negMask(1,1), preinteresting_det(1,1,ii)) - mobMask(1,2) = iand(negMask(1,2), preinteresting_det(1,2,ii)) - nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) - do j=2,N_int - mobMask(j,1) = iand(negMask(j,1), preinteresting_det(j,1,ii)) - mobMask(j,2) = iand(negMask(j,2), preinteresting_det(j,2,ii)) - nt = nt+ popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 4) then - interesting(0) += 1 - interesting(interesting(0)) = i - minilist(1,1,interesting(0)) = preinteresting_det(1,1,ii) - minilist(1,2,interesting(0)) = preinteresting_det(1,2,ii) - do j=2,N_int - minilist(j,1,interesting(0)) = preinteresting_det(j,1,ii) - minilist(j,2,interesting(0)) = preinteresting_det(j,2,ii) - enddo - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(1,1,fullinteresting(0)) = preinteresting_det(1,1,ii) - fullminilist(1,2,fullinteresting(0)) = preinteresting_det(1,2,ii) - do j=2,N_int - fullminilist(j,1,fullinteresting(0)) = preinteresting_det(j,1,ii) - fullminilist(j,2,fullinteresting(0)) = preinteresting_det(j,2,ii) - enddo - end if - end if - end do - - do ii=1,prefullinteresting(0) - i = prefullinteresting(ii) - nt = 0 - mobMask(1,1) = iand(negMask(1,1), psi_det_sorted(1,1,i)) - mobMask(1,2) = iand(negMask(1,2), psi_det_sorted(1,2,i)) - nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) - do j=2,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt = nt+ popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(1,1,fullinteresting(0)) = psi_det_sorted(1,1,i) - fullminilist(1,2,fullinteresting(0)) = psi_det_sorted(1,2,i) - do j=2,N_int - fullminilist(j,1,fullinteresting(0)) = psi_det_sorted(j,1,i) - fullminilist(j,2,fullinteresting(0)) = psi_det_sorted(j,2,i) - enddo - end if - end do - - - - do s2=s1,2 - sp = s1 - - if(s1 /= s2) sp = 3 - - ib = 1 - if(s1 == s2) ib = i1+1 - monoAdo = .true. - do i2=N_holes(s2),ib,-1 ! Generate low excitations first - logical :: banned(mo_tot_num, mo_tot_num,2) - logical :: bannedOrb(mo_tot_num, 2) - - h2 = hole_list(i2,s2) - call apply_hole(pmask, s2,h2, mask, ok, N_int) - banned = .false. - do j=1,mo_tot_num - bannedOrb(j, 1) = .true. - bannedOrb(j, 2) = .true. - enddo - do s3=1,2 - do i=1,N_particles(s3) - bannedOrb(particle_list(i,s3), s3) = .false. - enddo - enddo - if(s1 /= s2) then - if(monoBdo) then - bannedOrb(h1,s1) = .false. - end if - if(monoAdo) then - bannedOrb(h2,s2) = .false. - monoAdo = .false. - end if - end if - - maskInd += 1 - if(subset == 0 .or. mod(maskInd, fragment_count) == (subset-1)) then - - call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) - if(fullMatch) cycle - - mat = 0d0 - call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) - - call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) - end if - enddo - if(s1 /= s2) monoBdo = .false. - enddo - enddo - enddo -end - - - -subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator, sp, h1, h2 - double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - logical :: ok - integer :: s1, s2, p1, p2, ib, j, istate - integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) - double precision :: e_pert, delta_E, val, Hii, max_e_pert,tmp - double precision, external :: diag_H_mat_elem_fock - - logical, external :: detEq - - - if(sp == 3) then - s1 = 1 - s2 = 2 - else - s1 = sp - s2 = sp - end if - - call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) - - do p1=1,mo_tot_num - if(bannedOrb(p1, s1)) cycle - ib = 1 - if(sp /= 3) ib = p1+1 - do p2=ib,mo_tot_num - if(bannedOrb(p2, s2)) cycle - if(banned(p1,p2)) cycle - if(mat(1, p1, p2) == 0d0) cycle - call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) - - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) - max_e_pert = 0d0 - - do istate=1,N_states - delta_E = E0(istate) - Hii - val = mat(istate, p1, p2) + mat(istate, p1, p2) - tmp = dsqrt(delta_E * delta_E + val * val) - if (delta_E < 0.d0) then - tmp = -tmp - endif - e_pert = 0.5d0 * ( tmp - delta_E) - pt2(istate) = pt2(istate) + e_pert - max_e_pert = min(e_pert,max_e_pert) -! ci(istate) = e_pert / mat(istate, p1, p2) - end do - - if(dabs(max_e_pert) > buf%mini) then - call add_to_selection_buffer(buf, det, max_e_pert) - end if - end do - end do -end - - -subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) - use bitmasks - implicit none - - integer, intent(in) :: interesting(0:N_sel) - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) - integer, intent(in) :: sp, i_gen, N_sel - logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - - integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt - integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) -! logical :: bandon -! -! bandon = .false. - PROVIDE psi_phasemask psi_selectors_coef_transp - mat = 0d0 - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - do i=1, N_sel ! interesting(0) - !i = interesting(ii) - if (interesting(i) < 0) then - stop 'prefetch interesting(i)' - endif - - - mobMask(1,1) = iand(negMask(1,1), det(1,1,i)) - mobMask(1,2) = iand(negMask(1,2), det(1,2,i)) - nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) - - if(nt > 4) cycle - - do j=2,N_int - mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) - nt = nt + popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt > 4) cycle - - if (interesting(i) == i_gen) then - if(sp == 3) then - do j=1,mo_tot_num - do k=1,mo_tot_num - banned(j,k,2) = banned(k,j,1) - enddo - enddo - else - do k=1,mo_tot_num - do l=k+1,mo_tot_num - banned(l,k,1) = banned(k,l,1) - end do - end do - end if - end if - - call bitstring_to_list_in_selection(mobMask(1,1), p(1,1), p(0,1), N_int) - call bitstring_to_list_in_selection(mobMask(1,2), p(1,2), p(0,2), N_int) - - perMask(1,1) = iand(mask(1,1), not(det(1,1,i))) - perMask(1,2) = iand(mask(1,2), not(det(1,2,i))) - do j=2,N_int - perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) - perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) - end do - - call bitstring_to_list_in_selection(perMask(1,1), h(1,1), h(0,1), N_int) - call bitstring_to_list_in_selection(perMask(1,2), h(1,2), h(0,2), N_int) - - if (interesting(i) >= i_gen) then - if(nt == 4) then - call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else if(nt == 3) then - call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else - call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - end if - else - if(nt == 4) call past_d2(banned, p, sp) - if(nt == 3) call past_d1(bannedOrb, p) - end if - end do -end - - -subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - double precision, external :: get_phase_bi, integral8 - - integer :: i, j, tip, ma, mi, puti, putj - integer :: h1, h2, p1, p2, i1, i2 - double precision :: hij, phase - - integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) - integer, parameter :: turn2(2) = (/2, 1/) - integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - - integer :: bant - bant = 1 - - tip = p(0,1) * p(0,2) - - ma = sp - if(p(0,1) > p(0,2)) ma = 1 - if(p(0,1) < p(0,2)) ma = 2 - mi = mod(ma, 2) + 1 - - if(sp == 3) then - if(ma == 2) bant = 2 - - if(tip == 3) then - puti = p(1, mi) - do i = 1, 3 - putj = p(i, ma) - if(banned(putj,puti,bant)) cycle - i1 = turn3(1,i) - i2 = turn3(2,i) - p1 = p(i1, ma) - p2 = p(i2, ma) - h1 = h(1, ma) - h2 = h(2, ma) - - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - if(ma == 1) then - mat(:, putj, puti) += coefs * hij - else - mat(:, puti, putj) += coefs * hij - end if - end do - else - h1 = h(1,1) - h2 = h(1,2) - do j = 1,2 - putj = p(j, 2) - p2 = p(turn2(j), 2) - do i = 1,2 - puti = p(i, 1) - - if(banned(puti,putj,bant)) cycle - p1 = p(turn2(i), 1) - - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end do - end do - end if - - else - if(tip == 0) then - h1 = h(1, ma) - h2 = h(2, ma) - do i=1,3 - puti = p(i, ma) - do j=i+1,4 - putj = p(j, ma) - if(banned(puti,putj,1)) cycle - - i1 = turn2d(1, i, j) - i2 = turn2d(2, i, j) - p1 = p(i1, ma) - p2 = p(i2, ma) - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end do - end do - else if(tip == 3) then - h1 = h(1, mi) - h2 = h(1, ma) - p1 = p(1, mi) - do i=1,3 - puti = p(turn3(1,i), ma) - putj = p(turn3(2,i), ma) - if(banned(puti,putj,1)) cycle - p2 = p(i, ma) - - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) - mat(:, min(puti, putj), max(puti, putj)) += coefs * hij - end do - else ! tip == 4 - puti = p(1, sp) - putj = p(2, sp) - if(.not. banned(puti,putj,1)) then - p1 = p(1, mi) - p2 = p(2, mi) - h1 = h(1, mi) - h2 = h(2, mi) - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end if - end if - end if -end - - -subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1),intent(in) :: phasemask(2,N_int*bit_kind_size) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - integer(bit_kind) :: det(N_int, 2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) - double precision, external :: get_phase_bi, integral8 - - logical :: lbanned(mo_tot_num, 2), ok - integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib - - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - integer, parameter :: turn2(2) = (/2,1/) - integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - - integer :: bant - - - lbanned = bannedOrb - - do i=1, p(0,1) - lbanned(p(i,1), 1) = .true. - end do - do i=1, p(0,2) - lbanned(p(i,2), 2) = .true. - end do - - ma = 1 - if(p(0,2) >= 2) ma = 2 - mi = turn2(ma) - - bant = 1 - - if(sp == 3) then - !move MA - if(ma == 2) bant = 2 - puti = p(1,mi) - hfix = h(1,ma) - p1 = p(1,ma) - p2 = p(2,ma) - if(.not. bannedOrb(puti, mi)) then - tmp_row = 0d0 - do putj=1, hfix-1 - if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - tmp_row(1:N_states,putj) += hij * coefs(1:N_states) - end do - do putj=hfix+1, mo_tot_num - if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - tmp_row(1:N_states,putj) += hij * coefs(1:N_states) - end do - - if(ma == 1) then - mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) - else - mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) - end if - end if - - !MOVE MI - pfix = p(1,mi) - tmp_row = 0d0 - tmp_row2 = 0d0 - do puti=1,mo_tot_num - if(lbanned(puti,mi)) cycle - !p1 fixed - putj = p1 - if(.not. banned(putj,puti,bant)) then - hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) - tmp_row(:,puti) += hij * coefs - end if - - putj = p2 - if(.not. banned(putj,puti,bant)) then - hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) - tmp_row2(:,puti) += hij * coefs - end if - end do - - if(mi == 1) then - mat(:,:,p1) += tmp_row(:,:) - mat(:,:,p2) += tmp_row2(:,:) - else - mat(:,p1,:) += tmp_row(:,:) - mat(:,p2,:) += tmp_row2(:,:) - end if - else - if(p(0,ma) == 3) then - do i=1,3 - hfix = h(1,ma) - puti = p(i, ma) - p1 = p(turn3(1,i), ma) - p2 = p(turn3(2,i), ma) - tmp_row = 0d0 - do putj=1,hfix-1 - if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - tmp_row(:,putj) += hij * coefs - end do - do putj=hfix+1,mo_tot_num - if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - tmp_row(:,putj) += hij * coefs - end do - - mat(:, :puti-1, puti) += tmp_row(:,:puti-1) - mat(:, puti, puti:) += tmp_row(:,puti:) - end do - else - hfix = h(1,mi) - pfix = p(1,mi) - p1 = p(1,ma) - p2 = p(2,ma) - tmp_row = 0d0 - tmp_row2 = 0d0 - do puti=1,mo_tot_num - if(lbanned(puti,ma)) cycle - putj = p2 - if(.not. banned(puti,putj,1)) then - hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) - tmp_row(:,puti) += hij * coefs - end if - - putj = p1 - if(.not. banned(puti,putj,1)) then - hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) - tmp_row2(:,puti) += hij * coefs - end if - end do - mat(:,:p2-1,p2) += tmp_row(:,:p2-1) - mat(:,p2,p2:) += tmp_row(:,p2:) - mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) - mat(:,p1,p1:) += tmp_row2(:,p1:) - end if - end if - - !! MONO - if(sp == 3) then - s1 = 1 - s2 = 2 - else - s1 = sp - s2 = sp - end if - - do i1=1,p(0,s1) - ib = 1 - if(s1 == s2) ib = i1+1 - do i2=ib,p(0,s2) - p1 = p(i1,s1) - p2 = p(i2,s2) - if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle - call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - mat(:, p1, p2) += coefs * hij - end do - end do -end - - - - -subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - integer(bit_kind) :: det(N_int, 2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - integer :: i, j, s, h1, h2, p1, p2, puti, putj - double precision :: hij, phase - double precision, external :: get_phase_bi, integral8 - logical :: ok - - integer :: bant - bant = 1 - - - if(sp == 3) then ! AB - h1 = p(1,1) - h2 = p(1,2) - do p1=1, mo_tot_num - if(bannedOrb(p1, 1)) cycle - do p2=1, mo_tot_num - if(bannedOrb(p2,2)) cycle - if(banned(p1, p2, bant)) cycle ! rentable? - if(p1 == h1 .or. p2 == h2) then - call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - else - phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - hij = integral8(p1, p2, h1, h2) * phase - end if - mat(:, p1, p2) += coefs(:) * hij - end do - end do - else ! AA BB - p1 = p(1,sp) - p2 = p(2,sp) - do puti=1, mo_tot_num - if(bannedOrb(puti, sp)) cycle - do putj=puti+1, mo_tot_num - if(bannedOrb(putj, sp)) cycle - if(banned(puti, putj, bant)) cycle ! rentable? - if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then - call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - else - hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) - end if - mat(:, puti, putj) += coefs(:) * hij - end do - end do - end if -end - - -subroutine past_d1(bannedOrb, p) - use bitmasks - implicit none - - logical, intent(inout) :: bannedOrb(mo_tot_num, 2) - integer, intent(in) :: p(0:4, 2) - integer :: i,s - - do s = 1, 2 - do i = 1, p(0, s) - bannedOrb(p(i, s), s) = .true. - end do - end do -end - - -subroutine past_d2(banned, p, sp) - use bitmasks - implicit none - - logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) - integer, intent(in) :: p(0:4, 2), sp - integer :: i,j - - if(sp == 3) then - do i=1,p(0,1) - do j=1,p(0,2) - banned(p(i,1), p(j,2)) = .true. - end do - end do - else - do i=1,p(0, sp) - do j=1,i-1 - banned(p(j,sp), p(i,sp)) = .true. - banned(p(i,sp), p(j,sp)) = .true. - end do - end do - end if -end - - - -subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) - use bitmasks - implicit none - - integer, intent(in) :: interesting(0:N) - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) - integer, intent(in) :: i_gen, N - logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) - logical, intent(out) :: fullMatch - - - integer :: i, j, na, nb, list(3) - integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) - - fullMatch = .false. - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - genl : do i=1, N - do j=1, N_int - if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl - if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl - end do - - if(interesting(i) < i_gen) then - fullMatch = .true. - return - end if - - do j=1, N_int - myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) - myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) - end do - - call bitstring_to_list_in_selection(myMask(1,1), list(1), na, N_int) - call bitstring_to_list_in_selection(myMask(1,2), list(na+1), nb, N_int) - banned(list(1), list(2)) = .true. - end do genl -end - - -subroutine bitstring_to_list_in_selection( string, list, n_elements, Nint) - use bitmasks - implicit none - BEGIN_DOC - ! Gives the inidices(+1) of the bits set to 1 in the bit string - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: string(Nint) - integer, intent(out) :: list(Nint*bit_kind_size) - integer, intent(out) :: n_elements - - integer :: i, ishift - integer(bit_kind) :: l - - n_elements = 0 - ishift = 2 - do i=1,Nint - l = string(i) - do while (l /= 0_bit_kind) - n_elements = n_elements+1 - list(n_elements) = ishift+popcnt(l-1_bit_kind) - popcnt(l) - l = iand(l,l-1_bit_kind) - enddo - ishift = ishift + bit_kind_size - enddo - -end -======= use bitmasks BEGIN_PROVIDER [ integer, fragment_count ] diff --git a/plugins/Generators_CAS/Generators_full/.gitignore b/plugins/Generators_CAS/Generators_full/.gitignore deleted file mode 100644 index 8d85dede..00000000 --- a/plugins/Generators_CAS/Generators_full/.gitignore +++ /dev/null @@ -1,25 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Ezfio_files -Determinants -Integrals_Monoelec -MO_Basis -Utils -Pseudo -Bitmask -AO_Basis -Electrons -MOGuess -Nuclei -Hartree_Fock -Integrals_Bielec \ No newline at end of file diff --git a/plugins/Generators_CAS/Generators_full/NEEDED_CHILDREN_MODULES b/plugins/Generators_CAS/Generators_full/NEEDED_CHILDREN_MODULES deleted file mode 100644 index 54f54203..00000000 --- a/plugins/Generators_CAS/Generators_full/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Determinants Hartree_Fock diff --git a/plugins/Generators_CAS/Generators_full/README.rst b/plugins/Generators_CAS/Generators_full/README.rst deleted file mode 100644 index c30193a2..00000000 --- a/plugins/Generators_CAS/Generators_full/README.rst +++ /dev/null @@ -1,61 +0,0 @@ -====================== -Generators_full Module -====================== - -All the determinants of the wave function are generators. In this way, the Full CI -space is explored. - -Needed Modules -============== - -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. - -.. image:: tree_dependency.png - -* `Determinants `_ -* `Hartree_Fock `_ - -Needed Modules -============== -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. - - -.. image:: tree_dependency.png - -* `Determinants `_ -* `Hartree_Fock `_ - -Documentation -============= -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. - - -`degree_max_generators `_ - Max degree of excitation (respect to HF) of the generators - - -`n_det_generators `_ - For Single reference wave functions, the number of generators is 1 : the - Hartree-Fock determinant - - -`psi_coef_generators `_ - For Single reference wave functions, the generator is the - Hartree-Fock determinant - - -`psi_det_generators `_ - For Single reference wave functions, the generator is the - Hartree-Fock determinant - - -`select_max `_ - Memo to skip useless selectors - - -`size_select_max `_ - Size of the select_max array - diff --git a/plugins/Generators_CAS/Generators_full/generators.irp.f b/plugins/Generators_CAS/Generators_full/generators.irp.f deleted file mode 100644 index eea5821b..00000000 --- a/plugins/Generators_CAS/Generators_full/generators.irp.f +++ /dev/null @@ -1,75 +0,0 @@ -use bitmasks - -BEGIN_PROVIDER [ integer, N_det_generators ] - implicit none - BEGIN_DOC - ! For Single reference wave functions, the number of generators is 1 : the - ! Hartree-Fock determinant - END_DOC - integer :: i - double precision :: norm - call write_time(output_determinants) - norm = 0.d0 - N_det_generators = N_det - do i=1,N_det - norm = norm + psi_average_norm_contrib_sorted(i) - if (norm >= threshold_generators) then - N_det_generators = i - exit - endif - enddo - N_det_generators = max(N_det_generators,1) - call write_int(output_determinants,N_det_generators,'Number of generators') -END_PROVIDER - - BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ] - implicit none - BEGIN_DOC - ! For Single reference wave functions, the generator is the - ! Hartree-Fock determinant - END_DOC - integer :: i, k - psi_coef_generators = 0.d0 - psi_det_generators = 0_bit_kind - do i=1,N_det_generators - do k=1,N_int - psi_det_generators(k,1,i) = psi_det_sorted(k,1,i) - psi_det_generators(k,2,i) = psi_det_sorted(k,2,i) - enddo - psi_coef_generators(i,:) = psi_coef_sorted(i,:) - enddo - -END_PROVIDER - -BEGIN_PROVIDER [integer, degree_max_generators] - implicit none - BEGIN_DOC -! Max degree of excitation (respect to HF) of the generators - END_DOC - integer :: i,degree - degree_max_generators = 0 - do i = 1, N_det_generators - call get_excitation_degree(HF_bitmask,psi_det_generators(1,1,i),degree,N_int) - if(degree .gt. degree_max_generators)then - degree_max_generators = degree - endif - enddo -END_PROVIDER - -BEGIN_PROVIDER [ integer, size_select_max] - implicit none - BEGIN_DOC - ! Size of the select_max array - END_DOC - size_select_max = 10000 -END_PROVIDER - -BEGIN_PROVIDER [ double precision, select_max, (size_select_max) ] - implicit none - BEGIN_DOC - ! Memo to skip useless selectors - END_DOC - select_max = huge(1.d0) -END_PROVIDER - diff --git a/plugins/Generators_CAS/Generators_full/tree_dependency.png b/plugins/Generators_CAS/Generators_full/tree_dependency.png deleted file mode 100644 index eed76866..00000000 Binary files a/plugins/Generators_CAS/Generators_full/tree_dependency.png and /dev/null differ diff --git a/plugins/Generators_CAS/generators.irp.f b/plugins/Generators_CAS/generators.irp.f index 10fbfaee..f47341de 100644 --- a/plugins/Generators_CAS/generators.irp.f +++ b/plugins/Generators_CAS/generators.irp.f @@ -9,14 +9,14 @@ BEGIN_PROVIDER [ integer, N_det_generators ] logical :: good call write_time(output_determinants) N_det_generators = 0 - do i=1,N_det_ref + do i=1,N_det do l=1,n_cas_bitmask good = .True. do k=1,N_int good = good .and. ( & - iand(not(cas_bitmask(k,1,l)), psi_ref(k,1,i)) == & + iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == & iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) ) .and. ( & - iand(not(cas_bitmask(k,2,l)), psi_ref(k,2,i)) == & + iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == & iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2)) ) enddo if (good) then @@ -41,14 +41,14 @@ END_PROVIDER integer :: i, k, l, m logical :: good m=0 - do i=1,N_det_ref + do i=1,N_det do l=1,n_cas_bitmask good = .True. do k=1,N_int good = good .and. ( & - iand(not(cas_bitmask(k,1,l)), psi_ref(k,1,i)) == & + iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == & iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) .and. ( & - iand(not(cas_bitmask(k,2,l)), psi_ref(k,2,i)) == & + iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == & iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2) )) ) enddo if (good) then @@ -58,8 +58,8 @@ END_PROVIDER if (good) then m = m+1 do k=1,N_int - psi_det_generators(k,1,m) = psi_ref(k,1,i) - psi_det_generators(k,2,m) = psi_ref(k,2,i) + psi_det_generators(k,1,m) = psi_det(k,1,i) + psi_det_generators(k,2,m) = psi_det(k,2,i) enddo psi_coef_generators(m,:) = psi_coef(m,:) endif diff --git a/plugins/Integrals_erf/EZFIO.cfg b/plugins/Integrals_erf/EZFIO.cfg deleted file mode 100644 index 916bcd34..00000000 --- a/plugins/Integrals_erf/EZFIO.cfg +++ /dev/null @@ -1,34 +0,0 @@ -[disk_access_ao_integrals_erf] -type: Disk_access -doc: Read/Write AO integrals with the long range interaction from/to disk [ Write | Read | None ] -interface: ezfio,provider,ocaml -default: None - - -[disk_access_mo_integrals_erf] -type: Disk_access -doc: Read/Write MO integrals with the long range interaction from/to disk [ Write | Read | None ] -interface: ezfio,provider,ocaml -default: None - -[ao_integrals_threshold] -type: Threshold -doc: If || < ao_integrals_threshold then is zero -interface: ezfio,provider,ocaml -default: 1.e-15 -ezfio_name: threshold_ao - -[mo_integrals_threshold] -type: Threshold -doc: If || < ao_integrals_threshold then is zero -interface: ezfio,provider,ocaml -default: 1.e-15 -ezfio_name: threshold_mo - -[mu_erf] -type: double precision -doc: cutting of the interaction in the range separated model -interface: ezfio,provider,ocaml -default: 0.5 -ezfio_name: mu_erf - diff --git a/plugins/Integrals_erf/NEEDED_CHILDREN_MODULES b/plugins/Integrals_erf/NEEDED_CHILDREN_MODULES deleted file mode 100644 index 8361b2eb..00000000 --- a/plugins/Integrals_erf/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Pseudo Bitmask ZMQ Integrals_Bielec diff --git a/plugins/Integrals_erf/ao_bi_integrals_erf.irp.f b/plugins/Integrals_erf/ao_bi_integrals_erf.irp.f deleted file mode 100644 index 2b4b2fad..00000000 --- a/plugins/Integrals_erf/ao_bi_integrals_erf.irp.f +++ /dev/null @@ -1,570 +0,0 @@ -double precision function ao_bielec_integral_erf(i,j,k,l) - implicit none - BEGIN_DOC - ! integral of the AO basis or (ij|kl) - ! i(r1) j(r1) 1/r12 k(r2) l(r2) - END_DOC - - integer,intent(in) :: i,j,k,l - integer :: p,q,r,s - double precision :: I_center(3),J_center(3),K_center(3),L_center(3) - integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3) - double precision :: integral - include 'Utils/constants.include.F' - double precision :: P_new(0:max_dim,3),P_center(3),fact_p,pp - double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq - integer :: iorder_p(3), iorder_q(3) - double precision :: ao_bielec_integral_schwartz_accel_erf - - if (ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then - ao_bielec_integral_erf = ao_bielec_integral_schwartz_accel_erf(i,j,k,l) - return - endif - - dim1 = n_pt_max_integrals - - num_i = ao_nucl(i) - num_j = ao_nucl(j) - num_k = ao_nucl(k) - num_l = ao_nucl(l) - ao_bielec_integral_erf = 0.d0 - - if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then - do p = 1, 3 - I_power(p) = ao_power(i,p) - J_power(p) = ao_power(j,p) - K_power(p) = ao_power(k,p) - L_power(p) = ao_power(l,p) - I_center(p) = nucl_coord(num_i,p) - J_center(p) = nucl_coord(num_j,p) - K_center(p) = nucl_coord(num_k,p) - L_center(p) = nucl_coord(num_l,p) - enddo - - double precision :: coef1, coef2, coef3, coef4 - double precision :: p_inv,q_inv - double precision :: general_primitive_integral_erf - - do p = 1, ao_prim_num(i) - coef1 = ao_coef_normalized_ordered_transp(p,i) - do q = 1, ao_prim_num(j) - coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) - call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,& - ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), & - I_power,J_power,I_center,J_center,dim1) - p_inv = 1.d0/pp - do r = 1, ao_prim_num(k) - coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) - do s = 1, ao_prim_num(l) - coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) - call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,& - ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), & - K_power,L_power,K_center,L_center,dim1) - q_inv = 1.d0/qq - integral = general_primitive_integral_erf(dim1, & - P_new,P_center,fact_p,pp,p_inv,iorder_p, & - Q_new,Q_center,fact_q,qq,q_inv,iorder_q) - ao_bielec_integral_erf = ao_bielec_integral_erf + coef4 * integral - enddo ! s - enddo ! r - enddo ! q - enddo ! p - - else - - do p = 1, 3 - I_power(p) = ao_power(i,p) - J_power(p) = ao_power(j,p) - K_power(p) = ao_power(k,p) - L_power(p) = ao_power(l,p) - enddo - double precision :: ERI_erf - - do p = 1, ao_prim_num(i) - coef1 = ao_coef_normalized_ordered_transp(p,i) - do q = 1, ao_prim_num(j) - coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) - do r = 1, ao_prim_num(k) - coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) - do s = 1, ao_prim_num(l) - coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) - integral = ERI_erf( & - ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),& - I_power(1),J_power(1),K_power(1),L_power(1), & - I_power(2),J_power(2),K_power(2),L_power(2), & - I_power(3),J_power(3),K_power(3),L_power(3)) - ao_bielec_integral_erf = ao_bielec_integral_erf + coef4 * integral - enddo ! s - enddo ! r - enddo ! q - enddo ! p - - endif - -end - -double precision function ao_bielec_integral_schwartz_accel_erf(i,j,k,l) - implicit none - BEGIN_DOC - ! integral of the AO basis or (ij|kl) - ! i(r1) j(r1) 1/r12 k(r2) l(r2) - END_DOC - integer,intent(in) :: i,j,k,l - integer :: p,q,r,s - double precision :: I_center(3),J_center(3),K_center(3),L_center(3) - integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3) - double precision :: integral - include 'Utils/constants.include.F' - double precision :: P_new(0:max_dim,3),P_center(3),fact_p,pp - double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq - integer :: iorder_p(3), iorder_q(3) - double precision, allocatable :: schwartz_kl(:,:) - double precision :: schwartz_ij - - dim1 = n_pt_max_integrals - - num_i = ao_nucl(i) - num_j = ao_nucl(j) - num_k = ao_nucl(k) - num_l = ao_nucl(l) - ao_bielec_integral_schwartz_accel_erf = 0.d0 - double precision :: thr - thr = ao_integrals_threshold*ao_integrals_threshold - - allocate(schwartz_kl(0:ao_prim_num(l),0:ao_prim_num(k))) - - - if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then - do p = 1, 3 - I_power(p) = ao_power(i,p) - J_power(p) = ao_power(j,p) - K_power(p) = ao_power(k,p) - L_power(p) = ao_power(l,p) - I_center(p) = nucl_coord(num_i,p) - J_center(p) = nucl_coord(num_j,p) - K_center(p) = nucl_coord(num_k,p) - L_center(p) = nucl_coord(num_l,p) - enddo - - schwartz_kl(0,0) = 0.d0 - do r = 1, ao_prim_num(k) - coef1 = ao_coef_normalized_ordered_transp(r,k)*ao_coef_normalized_ordered_transp(r,k) - schwartz_kl(0,r) = 0.d0 - do s = 1, ao_prim_num(l) - coef2 = coef1 * ao_coef_normalized_ordered_transp(s,l) * ao_coef_normalized_ordered_transp(s,l) - call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,& - ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), & - K_power,L_power,K_center,L_center,dim1) - q_inv = 1.d0/qq - schwartz_kl(s,r) = general_primitive_integral_erf(dim1, & - Q_new,Q_center,fact_q,qq,q_inv,iorder_q, & - Q_new,Q_center,fact_q,qq,q_inv,iorder_q) & - * coef2 - schwartz_kl(0,r) = max(schwartz_kl(0,r),schwartz_kl(s,r)) - enddo - schwartz_kl(0,0) = max(schwartz_kl(0,r),schwartz_kl(0,0)) - enddo - - do p = 1, ao_prim_num(i) - double precision :: coef1 - coef1 = ao_coef_normalized_ordered_transp(p,i) - do q = 1, ao_prim_num(j) - double precision :: coef2 - coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) - double precision :: p_inv,q_inv - call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,& - ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), & - I_power,J_power,I_center,J_center,dim1) - p_inv = 1.d0/pp - schwartz_ij = general_primitive_integral_erf(dim1, & - P_new,P_center,fact_p,pp,p_inv,iorder_p, & - P_new,P_center,fact_p,pp,p_inv,iorder_p) * & - coef2*coef2 - if (schwartz_kl(0,0)*schwartz_ij < thr) then - cycle - endif - do r = 1, ao_prim_num(k) - if (schwartz_kl(0,r)*schwartz_ij < thr) then - cycle - endif - double precision :: coef3 - coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) - do s = 1, ao_prim_num(l) - double precision :: coef4 - if (schwartz_kl(s,r)*schwartz_ij < thr) then - cycle - endif - coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) - double precision :: general_primitive_integral_erf - call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,& - ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), & - K_power,L_power,K_center,L_center,dim1) - q_inv = 1.d0/qq - integral = general_primitive_integral_erf(dim1, & - P_new,P_center,fact_p,pp,p_inv,iorder_p, & - Q_new,Q_center,fact_q,qq,q_inv,iorder_q) - ao_bielec_integral_schwartz_accel_erf = ao_bielec_integral_schwartz_accel_erf + coef4 * integral - enddo ! s - enddo ! r - enddo ! q - enddo ! p - - else - - do p = 1, 3 - I_power(p) = ao_power(i,p) - J_power(p) = ao_power(j,p) - K_power(p) = ao_power(k,p) - L_power(p) = ao_power(l,p) - enddo - double precision :: ERI_erf - - schwartz_kl(0,0) = 0.d0 - do r = 1, ao_prim_num(k) - coef1 = ao_coef_normalized_ordered_transp(r,k)*ao_coef_normalized_ordered_transp(r,k) - schwartz_kl(0,r) = 0.d0 - do s = 1, ao_prim_num(l) - coef2 = coef1*ao_coef_normalized_ordered_transp(s,l)*ao_coef_normalized_ordered_transp(s,l) - schwartz_kl(s,r) = ERI_erf( & - ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),& - K_power(1),L_power(1),K_power(1),L_power(1), & - K_power(2),L_power(2),K_power(2),L_power(2), & - K_power(3),L_power(3),K_power(3),L_power(3)) * & - coef2 - schwartz_kl(0,r) = max(schwartz_kl(0,r),schwartz_kl(s,r)) - enddo - schwartz_kl(0,0) = max(schwartz_kl(0,r),schwartz_kl(0,0)) - enddo - - do p = 1, ao_prim_num(i) - coef1 = ao_coef_normalized_ordered_transp(p,i) - do q = 1, ao_prim_num(j) - coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) - schwartz_ij = ERI_erf( & - ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),& - I_power(1),J_power(1),I_power(1),J_power(1), & - I_power(2),J_power(2),I_power(2),J_power(2), & - I_power(3),J_power(3),I_power(3),J_power(3))*coef2*coef2 - if (schwartz_kl(0,0)*schwartz_ij < thr) then - cycle - endif - do r = 1, ao_prim_num(k) - if (schwartz_kl(0,r)*schwartz_ij < thr) then - cycle - endif - coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) - do s = 1, ao_prim_num(l) - if (schwartz_kl(s,r)*schwartz_ij < thr) then - cycle - endif - coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) - integral = ERI_erf( & - ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),& - I_power(1),J_power(1),K_power(1),L_power(1), & - I_power(2),J_power(2),K_power(2),L_power(2), & - I_power(3),J_power(3),K_power(3),L_power(3)) - ao_bielec_integral_schwartz_accel_erf = ao_bielec_integral_schwartz_accel_erf + coef4 * integral - enddo ! s - enddo ! r - enddo ! q - enddo ! p - - endif - deallocate (schwartz_kl) - -end - - -subroutine compute_ao_bielec_integrals_erf(j,k,l,sze,buffer_value) - implicit none - use map_module - - BEGIN_DOC - ! Compute AO 1/r12 integrals for all i and fixed j,k,l - END_DOC - - include 'Utils/constants.include.F' - integer, intent(in) :: j,k,l,sze - real(integral_kind), intent(out) :: buffer_value(sze) - double precision :: ao_bielec_integral_erf - - integer :: i - - if (ao_overlap_abs(j,l) < thresh) then - buffer_value = 0._integral_kind - return - endif - if (ao_bielec_integral_erf_schwartz(j,l) < thresh ) then - buffer_value = 0._integral_kind - return - endif - - do i = 1, ao_num - if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < thresh) then - buffer_value(i) = 0._integral_kind - cycle - endif - if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < thresh ) then - buffer_value(i) = 0._integral_kind - cycle - endif - !DIR$ FORCEINLINE - buffer_value(i) = ao_bielec_integral_erf(i,k,j,l) - enddo - -end - -double precision function general_primitive_integral_erf(dim, & - P_new,P_center,fact_p,p,p_inv,iorder_p, & - Q_new,Q_center,fact_q,q,q_inv,iorder_q) - implicit none - BEGIN_DOC - ! Computes the integral where p,q,r,s are Gaussian primitives - END_DOC - integer,intent(in) :: dim - include 'Utils/constants.include.F' - double precision, intent(in) :: P_new(0:max_dim,3),P_center(3),fact_p,p,p_inv - double precision, intent(in) :: Q_new(0:max_dim,3),Q_center(3),fact_q,q,q_inv - integer, intent(in) :: iorder_p(3) - integer, intent(in) :: iorder_q(3) - - double precision :: r_cut,gama_r_cut,rho,dist - double precision :: dx(0:max_dim),Ix_pol(0:max_dim),dy(0:max_dim),Iy_pol(0:max_dim),dz(0:max_dim),Iz_pol(0:max_dim) - integer :: n_Ix,n_Iy,n_Iz,nx,ny,nz - double precision :: bla - integer :: ix,iy,iz,jx,jy,jz,i - double precision :: a,b,c,d,e,f,accu,pq,const - double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2,pq_inv_2 - integer :: n_pt_tmp,n_pt_out, iorder - double precision :: d1(0:max_dim),d_poly(0:max_dim),rint,d1_screened(0:max_dim) - - general_primitive_integral_erf = 0.d0 - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx,Ix_pol,dy,Iy_pol,dz,Iz_pol - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly - - ! Gaussian Product - ! ---------------- - double precision :: p_plus_q - p_plus_q = (p+q) * ((p*q)/(p+q) + mu_erf*mu_erf)/(mu_erf*mu_erf) - pq = p_inv*0.5d0*q_inv - - pq_inv = 0.5d0/p_plus_q - p10_1 = q*pq ! 1/(2p) - p01_1 = p*pq ! 1/(2q) - pq_inv_2 = pq_inv+pq_inv - p10_2 = pq_inv_2 * p10_1*q !0.5d0*q/(pq + p*p) - p01_2 = pq_inv_2 * p01_1*p !0.5d0*p/(q*q + pq) - - - accu = 0.d0 - iorder = iorder_p(1)+iorder_q(1)+iorder_p(1)+iorder_q(1) - !DIR$ VECTOR ALIGNED - do ix=0,iorder - Ix_pol(ix) = 0.d0 - enddo - n_Ix = 0 - do ix = 0, iorder_p(1) - if (abs(P_new(ix,1)) < thresh) cycle - a = P_new(ix,1) - do jx = 0, iorder_q(1) - d = a*Q_new(jx,1) - if (abs(d) < thresh) cycle - !DEC$ FORCEINLINE - call give_polynom_mult_center_x(P_center(1),Q_center(1),ix,jx,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dx,nx) - !DEC$ FORCEINLINE - call add_poly_multiply(dx,nx,d,Ix_pol,n_Ix) - enddo - enddo - if (n_Ix == -1) then - return - endif - iorder = iorder_p(2)+iorder_q(2)+iorder_p(2)+iorder_q(2) - !DIR$ VECTOR ALIGNED - do ix=0, iorder - Iy_pol(ix) = 0.d0 - enddo - n_Iy = 0 - do iy = 0, iorder_p(2) - if (abs(P_new(iy,2)) > thresh) then - b = P_new(iy,2) - do jy = 0, iorder_q(2) - e = b*Q_new(jy,2) - if (abs(e) < thresh) cycle - !DEC$ FORCEINLINE - call give_polynom_mult_center_x(P_center(2),Q_center(2),iy,jy,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dy,ny) - !DEC$ FORCEINLINE - call add_poly_multiply(dy,ny,e,Iy_pol,n_Iy) - enddo - endif - enddo - if (n_Iy == -1) then - return - endif - - iorder = iorder_p(3)+iorder_q(3)+iorder_p(3)+iorder_q(3) - do ix=0,iorder - Iz_pol(ix) = 0.d0 - enddo - n_Iz = 0 - do iz = 0, iorder_p(3) - if (abs(P_new(iz,3)) > thresh) then - c = P_new(iz,3) - do jz = 0, iorder_q(3) - f = c*Q_new(jz,3) - if (abs(f) < thresh) cycle - !DEC$ FORCEINLINE - call give_polynom_mult_center_x(P_center(3),Q_center(3),iz,jz,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dz,nz) - !DEC$ FORCEINLINE - call add_poly_multiply(dz,nz,f,Iz_pol,n_Iz) - enddo - endif - enddo - if (n_Iz == -1) then - return - endif - - rho = p*q *pq_inv_2 ! le rho qui va bien - dist = (P_center(1) - Q_center(1))*(P_center(1) - Q_center(1)) + & - (P_center(2) - Q_center(2))*(P_center(2) - Q_center(2)) + & - (P_center(3) - Q_center(3))*(P_center(3) - Q_center(3)) - const = dist*rho - - n_pt_tmp = n_Ix+n_Iy - do i=0,n_pt_tmp - d_poly(i)=0.d0 - enddo - - !DEC$ FORCEINLINE - call multiply_poly(Ix_pol,n_Ix,Iy_pol,n_Iy,d_poly,n_pt_tmp) - if (n_pt_tmp == -1) then - return - endif - n_pt_out = n_pt_tmp+n_Iz - do i=0,n_pt_out - d1(i)=0.d0 - enddo - - !DEC$ FORCEINLINE - call multiply_poly(d_poly ,n_pt_tmp ,Iz_pol,n_Iz,d1,n_pt_out) - double precision :: rint_sum - accu = accu + rint_sum(n_pt_out,const,d1) - - ! change p+q in dsqrt - general_primitive_integral_erf = fact_p * fact_q * accu *pi_5_2*p_inv*q_inv/dsqrt(p_plus_q) -end - - -double precision function ERI_erf(alpha,beta,delta,gama,a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z) - implicit none - BEGIN_DOC - ! ATOMIC PRIMTIVE bielectronic integral between the 4 primitives :: - ! primitive_1 = x1**(a_x) y1**(a_y) z1**(a_z) exp(-alpha * r1**2) - ! primitive_2 = x1**(b_x) y1**(b_y) z1**(b_z) exp(- beta * r1**2) - ! primitive_3 = x2**(c_x) y2**(c_y) z2**(c_z) exp(-delta * r2**2) - ! primitive_4 = x2**(d_x) y2**(d_y) z2**(d_z) exp(- gama * r2**2) - END_DOC - double precision, intent(in) :: delta,gama,alpha,beta - integer, intent(in) :: a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z - integer :: a_x_2,b_x_2,c_x_2,d_x_2,a_y_2,b_y_2,c_y_2,d_y_2,a_z_2,b_z_2,c_z_2,d_z_2 - integer :: i,j,k,l,n_pt - integer :: n_pt_sup - double precision :: p,q,denom,coeff - double precision :: I_f - integer :: nx,ny,nz - include 'Utils/constants.include.F' - nx = a_x+b_x+c_x+d_x - if(iand(nx,1) == 1) then - ERI_erf = 0.d0 - return - endif - - ny = a_y+b_y+c_y+d_y - if(iand(ny,1) == 1) then - ERI_erf = 0.d0 - return - endif - - nz = a_z+b_z+c_z+d_z - if(iand(nz,1) == 1) then - ERI_erf = 0.d0 - return - endif - - ASSERT (alpha >= 0.d0) - ASSERT (beta >= 0.d0) - ASSERT (delta >= 0.d0) - ASSERT (gama >= 0.d0) - p = alpha + beta - q = delta + gama - double precision :: p_plus_q - p_plus_q = (p+q) * ((p*q)/(p+q) + mu_erf*mu_erf)/(mu_erf*mu_erf) - ASSERT (p+q >= 0.d0) - n_pt = ishft( nx+ny+nz,1 ) - - coeff = pi_5_2 / (p * q * dsqrt(p_plus_q)) - if (n_pt == 0) then - ERI_erf = coeff - return - endif - - call integrale_new(I_f,a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z,p,q,n_pt) - - ERI_erf = I_f * coeff -end - - - - -subroutine compute_ao_integrals_erf_jl(j,l,n_integrals,buffer_i,buffer_value) - implicit none - use map_module - BEGIN_DOC - ! Parallel client for AO integrals - END_DOC - - integer, intent(in) :: j,l - integer,intent(out) :: n_integrals - integer(key_kind),intent(out) :: buffer_i(ao_num*ao_num) - real(integral_kind),intent(out) :: buffer_value(ao_num*ao_num) - - integer :: i,k - double precision :: ao_bielec_integral_erf,cpu_1,cpu_2, wall_1, wall_2 - double precision :: integral, wall_0 - double precision :: thr - integer :: kk, m, j1, i1 - - thr = ao_integrals_threshold - - n_integrals = 0 - - j1 = j+ishft(l*l-l,-1) - do k = 1, ao_num ! r1 - i1 = ishft(k*k-k,-1) - if (i1 > j1) then - exit - endif - do i = 1, k - i1 += 1 - if (i1 > j1) then - exit - endif - if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < thr) then - cycle - endif - if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < thr ) then - cycle - endif - !DIR$ FORCEINLINE - integral = ao_bielec_integral_erf(i,k,j,l) ! i,k : r1 j,l : r2 - if (abs(integral) < thr) then - cycle - endif - n_integrals += 1 - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,buffer_i(n_integrals)) - buffer_value(n_integrals) = integral - enddo - enddo - -end diff --git a/plugins/Integrals_erf/ao_bielec_integrals_erf_in_map_slave.irp.f b/plugins/Integrals_erf/ao_bielec_integrals_erf_in_map_slave.irp.f deleted file mode 100644 index 36f0e492..00000000 --- a/plugins/Integrals_erf/ao_bielec_integrals_erf_in_map_slave.irp.f +++ /dev/null @@ -1,175 +0,0 @@ -subroutine ao_bielec_integrals_erf_in_map_slave_tcp(i) - implicit none - integer, intent(in) :: i - BEGIN_DOC -! Computes a buffer of integrals. i is the ID of the current thread. - END_DOC - call ao_bielec_integrals_erf_in_map_slave(0,i) -end - - -subroutine ao_bielec_integrals_erf_in_map_slave_inproc(i) - implicit none - integer, intent(in) :: i - BEGIN_DOC -! Computes a buffer of integrals. i is the ID of the current thread. - END_DOC - call ao_bielec_integrals_erf_in_map_slave(1,i) -end - - - -subroutine ao_bielec_integrals_erf_in_map_slave(thread,iproc) - use map_module - use f77_zmq - implicit none - BEGIN_DOC -! Computes a buffer of integrals - END_DOC - - integer, intent(in) :: thread, iproc - - integer :: j,l,n_integrals - integer :: rc - real(integral_kind), allocatable :: buffer_value(:) - integer(key_kind), allocatable :: buffer_i(:) - - integer :: worker_id, task_id - character*(512) :: task - - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - integer(ZMQ_PTR), external :: new_zmq_push_socket - integer(ZMQ_PTR) :: zmq_socket_push - - character*(64) :: state - - zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - zmq_socket_push = new_zmq_push_socket(thread) - - allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) ) - - call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) - - do - call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) - if (task_id == 0) exit - read(task,*) j, l - call compute_ao_integrals_erf_jl(j,l,n_integrals,buffer_i,buffer_value) - call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) - call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id) - enddo - - - call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) - deallocate( buffer_i, buffer_value ) - call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) - call end_zmq_push_socket(zmq_socket_push,thread) - -end - - -subroutine ao_bielec_integrals_erf_in_map_collector - use map_module - use f77_zmq - implicit none - BEGIN_DOC -! Collects results from the AO integral calculation - END_DOC - - integer :: j,l,n_integrals - integer :: rc - - real(integral_kind), allocatable :: buffer_value(:) - integer(key_kind), allocatable :: buffer_i(:) - - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - integer(ZMQ_PTR), external :: new_zmq_pull_socket - integer(ZMQ_PTR) :: zmq_socket_pull - - integer*8 :: control, accu - integer :: task_id, more, sze - - zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - zmq_socket_pull = new_zmq_pull_socket() - - sze = ao_num*ao_num - allocate ( buffer_i(sze), buffer_value(sze) ) - - accu = 0_8 - more = 1 - do while (more == 1) - - rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0) - if (rc == -1) then - n_integrals = 0 - return - endif - if (rc /= 4) then - print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)' - stop 'error' - endif - - if (n_integrals >= 0) then - - if (n_integrals > sze) then - deallocate (buffer_value, buffer_i) - sze = n_integrals - allocate (buffer_value(sze), buffer_i(sze)) - endif - - rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0) - if (rc /= key_kind*n_integrals) then - print *, rc, key_kind, n_integrals - print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)' - stop 'error' - endif - - rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0) - if (rc /= integral_kind*n_integrals) then - print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)' - stop 'error' - endif - - rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0) - -! Activate if zmq_socket_pull is a REP - rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0) - if (rc /= 4) then - print *, irp_here, ' : f77_zmq_send (zmq_socket_pull,...' - stop 'error' - endif - - - call insert_into_ao_integrals_erf_map(n_integrals,buffer_i,buffer_value) - accu += n_integrals - if (task_id /= 0) then - call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) - endif - endif - - enddo - - deallocate( buffer_i, buffer_value ) - - integer (map_size_kind) :: get_ao_erf_map_size - control = get_ao_erf_map_size(ao_integrals_erf_map) - - if (control /= accu) then - print *, '' - print *, irp_here - print *, 'Control : ', control - print *, 'Accu : ', accu - print *, 'Some integrals were lost during the parallel computation.' - print *, 'Try to reduce the number of threads.' - stop - endif - - call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) - call end_zmq_pull_socket(zmq_socket_pull) - -end - diff --git a/plugins/Integrals_erf/integrals_3_index_erf.irp.f b/plugins/Integrals_erf/integrals_3_index_erf.irp.f deleted file mode 100644 index d9b1e9f7..00000000 --- a/plugins/Integrals_erf/integrals_3_index_erf.irp.f +++ /dev/null @@ -1,22 +0,0 @@ - BEGIN_PROVIDER [double precision, big_array_coulomb_integrals_erf, (mo_tot_num_align,mo_tot_num, mo_tot_num)] -&BEGIN_PROVIDER [double precision, big_array_exchange_integrals_erf,(mo_tot_num_align,mo_tot_num, mo_tot_num)] - implicit none - integer :: i,j,k,l - double precision :: get_mo_bielec_integral_erf - double precision :: integral - - do k = 1, mo_tot_num - do i = 1, mo_tot_num - do j = 1, mo_tot_num - l = j - integral = get_mo_bielec_integral_erf(i,j,k,l,mo_integrals_erf_map) - big_array_coulomb_integrals_erf(j,i,k) = integral - l = j - integral = get_mo_bielec_integral_erf(i,j,l,k,mo_integrals_erf_map) - big_array_exchange_integrals_erf(j,i,k) = integral - enddo - enddo - enddo - - -END_PROVIDER diff --git a/plugins/Integrals_erf/map_integrals_erf.irp.f b/plugins/Integrals_erf/map_integrals_erf.irp.f deleted file mode 100644 index ecf72282..00000000 --- a/plugins/Integrals_erf/map_integrals_erf.irp.f +++ /dev/null @@ -1,626 +0,0 @@ -use map_module - -!! AO Map -!! ====== - -BEGIN_PROVIDER [ type(map_type), ao_integrals_erf_map ] - implicit none - BEGIN_DOC - ! AO integrals - END_DOC - integer(key_kind) :: key_max - integer(map_size_kind) :: sze - call bielec_integrals_index(ao_num,ao_num,ao_num,ao_num,key_max) - sze = key_max - call map_init(ao_integrals_erf_map,sze) - print*, 'AO map initialized : ', sze -END_PROVIDER - - BEGIN_PROVIDER [ integer, ao_integrals_erf_cache_min ] -&BEGIN_PROVIDER [ integer, ao_integrals_erf_cache_max ] - implicit none - BEGIN_DOC - ! Min and max values of the AOs for which the integrals are in the cache - END_DOC - ao_integrals_erf_cache_min = max(1,ao_num - 63) - ao_integrals_erf_cache_max = ao_num - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, ao_integrals_erf_cache, (0:64*64*64*64) ] - use map_module - implicit none - BEGIN_DOC - ! Cache of AO integrals for fast access - END_DOC - PROVIDE ao_bielec_integrals_erf_in_map - integer :: i,j,k,l,ii - integer(key_kind) :: idx - real(integral_kind) :: integral - !$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral) - do l=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max - do k=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max - do j=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max - do i=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,idx) - !DIR$ FORCEINLINE - call map_get(ao_integrals_erf_map,idx,integral) - ii = l-ao_integrals_erf_cache_min - ii = ior( ishft(ii,6), k-ao_integrals_erf_cache_min) - ii = ior( ishft(ii,6), j-ao_integrals_erf_cache_min) - ii = ior( ishft(ii,6), i-ao_integrals_erf_cache_min) - ao_integrals_erf_cache(ii) = integral - enddo - enddo - enddo - enddo - !$OMP END PARALLEL DO - -END_PROVIDER - - -double precision function get_ao_bielec_integral_erf(i,j,k,l,map) result(result) - use map_module - implicit none - BEGIN_DOC - ! Gets one AO bi-electronic integral from the AO map - END_DOC - integer, intent(in) :: i,j,k,l - integer(key_kind) :: idx - type(map_type), intent(inout) :: map - integer :: ii - real(integral_kind) :: tmp - PROVIDE ao_bielec_integrals_erf_in_map ao_integrals_erf_cache ao_integrals_erf_cache_min - !DIR$ FORCEINLINE - if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < ao_integrals_threshold ) then - tmp = 0.d0 - else if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < ao_integrals_threshold) then - tmp = 0.d0 - else - ii = l-ao_integrals_erf_cache_min - ii = ior(ii, k-ao_integrals_erf_cache_min) - ii = ior(ii, j-ao_integrals_erf_cache_min) - ii = ior(ii, i-ao_integrals_erf_cache_min) - if (iand(ii, -64) /= 0) then - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,idx) - !DIR$ FORCEINLINE - call map_get(map,idx,tmp) - tmp = tmp - else - ii = l-ao_integrals_erf_cache_min - ii = ior( ishft(ii,6), k-ao_integrals_erf_cache_min) - ii = ior( ishft(ii,6), j-ao_integrals_erf_cache_min) - ii = ior( ishft(ii,6), i-ao_integrals_erf_cache_min) - tmp = ao_integrals_erf_cache(ii) - endif - endif - result = tmp -end - - -subroutine get_ao_bielec_integrals_erf(j,k,l,sze,out_val) - use map_module - BEGIN_DOC - ! Gets multiple AO bi-electronic integral from the AO map . - ! All i are retrieved for j,k,l fixed. - END_DOC - implicit none - integer, intent(in) :: j,k,l, sze - real(integral_kind), intent(out) :: out_val(sze) - - integer :: i - integer(key_kind) :: hash - double precision :: thresh - PROVIDE ao_bielec_integrals_erf_in_map ao_integrals_erf_map - thresh = ao_integrals_threshold - - if (ao_overlap_abs(j,l) < thresh) then - out_val = 0.d0 - return - endif - - double precision :: get_ao_bielec_integral_erf - do i=1,sze - out_val(i) = get_ao_bielec_integral_erf(i,j,k,l,ao_integrals_erf_map) - enddo - -end - -subroutine get_ao_bielec_integrals_erf_non_zero(j,k,l,sze,out_val,out_val_index,non_zero_int) - use map_module - implicit none - BEGIN_DOC - ! Gets multiple AO bi-electronic integral from the AO map . - ! All non-zero i are retrieved for j,k,l fixed. - END_DOC - integer, intent(in) :: j,k,l, sze - real(integral_kind), intent(out) :: out_val(sze) - integer, intent(out) :: out_val_index(sze),non_zero_int - - integer :: i - integer(key_kind) :: hash - double precision :: thresh,tmp - PROVIDE ao_bielec_integrals_erf_in_map - thresh = ao_integrals_threshold - - non_zero_int = 0 - if (ao_overlap_abs(j,l) < thresh) then - out_val = 0.d0 - return - endif - - non_zero_int = 0 - do i=1,sze - integer, external :: ao_l4 - double precision, external :: ao_bielec_integral_erf - !DIR$ FORCEINLINE - if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < thresh) then - cycle - endif - call bielec_integrals_index(i,j,k,l,hash) - call map_get(ao_integrals_erf_map, hash,tmp) - if (dabs(tmp) < thresh ) cycle - non_zero_int = non_zero_int+1 - out_val_index(non_zero_int) = i - out_val(non_zero_int) = tmp - enddo - -end - - -function get_ao_erf_map_size() - implicit none - integer (map_size_kind) :: get_ao_erf_map_size - BEGIN_DOC - ! Returns the number of elements in the AO map - END_DOC - get_ao_erf_map_size = ao_integrals_erf_map % n_elements -end - -subroutine clear_ao_erf_map - implicit none - BEGIN_DOC - ! Frees the memory of the AO map - END_DOC - call map_deinit(ao_integrals_erf_map) - FREE ao_integrals_erf_map -end - - - -BEGIN_TEMPLATE - -subroutine dump_$ao_integrals(filename) - use map_module - implicit none - BEGIN_DOC - ! Save to disk the $ao integrals - END_DOC - character*(*), intent(in) :: filename - integer(cache_key_kind), pointer :: key(:) - real(integral_kind), pointer :: val(:) - integer*8 :: i,j, n - call ezfio_set_work_empty(.False.) - open(unit=66,file=filename,FORM='unformatted') - write(66) integral_kind, key_kind - write(66) $ao_integrals_map%sorted, $ao_integrals_map%map_size, & - $ao_integrals_map%n_elements - do i=0_8,$ao_integrals_map%map_size - write(66) $ao_integrals_map%map(i)%sorted, $ao_integrals_map%map(i)%map_size,& - $ao_integrals_map%map(i)%n_elements - enddo - do i=0_8,$ao_integrals_map%map_size - key => $ao_integrals_map%map(i)%key - val => $ao_integrals_map%map(i)%value - n = $ao_integrals_map%map(i)%n_elements - write(66) (key(j), j=1,n), (val(j), j=1,n) - enddo - close(66) - -end - -IRP_IF COARRAY -subroutine communicate_$ao_integrals() - use map_module - implicit none - BEGIN_DOC - ! Communicate the $ao integrals with co-array - END_DOC - integer(cache_key_kind), pointer :: key(:) - real(integral_kind), pointer :: val(:) - integer*8 :: i,j, k, nmax - integer*8, save :: n[*] - integer :: copy_n - - real(integral_kind), allocatable :: buffer_val(:)[:] - integer(cache_key_kind), allocatable :: buffer_key(:)[:] - real(integral_kind), allocatable :: copy_val(:) - integer(key_kind), allocatable :: copy_key(:) - - n = 0_8 - do i=0_8,$ao_integrals_map%map_size - n = max(n,$ao_integrals_map%map(i)%n_elements) - enddo - sync all - nmax = 0_8 - do j=1,num_images() - nmax = max(nmax,n[j]) - enddo - allocate( buffer_key(nmax)[*], buffer_val(nmax)[*]) - allocate( copy_key(nmax), copy_val(nmax)) - do i=0_8,$ao_integrals_map%map_size - key => $ao_integrals_map%map(i)%key - val => $ao_integrals_map%map(i)%value - n = $ao_integrals_map%map(i)%n_elements - do j=1,n - buffer_key(j) = key(j) - buffer_val(j) = val(j) - enddo - sync all - do j=1,num_images() - if (j /= this_image()) then - copy_n = n[j] - do k=1,copy_n - copy_val(k) = buffer_val(k)[j] - copy_key(k) = buffer_key(k)[j] - copy_key(k) = copy_key(k)+ishft(i,-map_shift) - enddo - call map_append($ao_integrals_map, copy_key, copy_val, copy_n ) - endif - enddo - sync all - enddo - deallocate( buffer_key, buffer_val, copy_val, copy_key) - -end -IRP_ENDIF - - -integer function load_$ao_integrals(filename) - implicit none - BEGIN_DOC - ! Read from disk the $ao integrals - END_DOC - character*(*), intent(in) :: filename - integer*8 :: i - integer(cache_key_kind), pointer :: key(:) - real(integral_kind), pointer :: val(:) - integer :: iknd, kknd - integer*8 :: n, j - load_$ao_integrals = 1 - open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN') - read(66,err=98,end=98) iknd, kknd - if (iknd /= integral_kind) then - print *, 'Wrong integrals kind in file :', iknd - stop 1 - endif - if (kknd /= key_kind) then - print *, 'Wrong key kind in file :', kknd - stop 1 - endif - read(66,err=98,end=98) $ao_integrals_map%sorted, $ao_integrals_map%map_size,& - $ao_integrals_map%n_elements - do i=0_8, $ao_integrals_map%map_size - read(66,err=99,end=99) $ao_integrals_map%map(i)%sorted, & - $ao_integrals_map%map(i)%map_size, $ao_integrals_map%map(i)%n_elements - call cache_map_reallocate($ao_integrals_map%map(i),$ao_integrals_map%map(i)%map_size) - enddo - do i=0_8, $ao_integrals_map%map_size - key => $ao_integrals_map%map(i)%key - val => $ao_integrals_map%map(i)%value - n = $ao_integrals_map%map(i)%n_elements - read(66,err=99,end=99) (key(j), j=1,n), (val(j), j=1,n) - enddo - call map_sort($ao_integrals_map) - load_$ao_integrals = 0 - return - 99 continue - call map_deinit($ao_integrals_map) - 98 continue - stop 'Problem reading $ao_integrals_map file in work/' - -end - -SUBST [ ao_integrals_map, ao_integrals, ao_num ] -ao_integrals_erf_map ; ao_integrals_erf ; ao_num ;; -mo_integrals_erf_map ; mo_integrals_erf ; mo_tot_num;; -END_TEMPLATE - - - - -BEGIN_PROVIDER [ type(map_type), mo_integrals_erf_map ] - implicit none - BEGIN_DOC - ! MO integrals - END_DOC - integer(key_kind) :: key_max - integer(map_size_kind) :: sze - call bielec_integrals_index(mo_tot_num,mo_tot_num,mo_tot_num,mo_tot_num,key_max) - sze = key_max - call map_init(mo_integrals_erf_map,sze) - print*, 'MO map initialized' -END_PROVIDER - -subroutine insert_into_ao_integrals_erf_map(n_integrals,buffer_i, buffer_values) - use map_module - implicit none - BEGIN_DOC - ! Create new entry into AO map - END_DOC - - integer, intent(in) :: n_integrals - integer(key_kind), intent(inout) :: buffer_i(n_integrals) - real(integral_kind), intent(inout) :: buffer_values(n_integrals) - - call map_append(ao_integrals_erf_map, buffer_i, buffer_values, n_integrals) -end - -subroutine insert_into_mo_integrals_erf_map(n_integrals, & - buffer_i, buffer_values, thr) - use map_module - implicit none - - BEGIN_DOC - ! Create new entry into MO map, or accumulate in an existing entry - END_DOC - - integer, intent(in) :: n_integrals - integer(key_kind), intent(inout) :: buffer_i(n_integrals) - real(integral_kind), intent(inout) :: buffer_values(n_integrals) - real(integral_kind), intent(in) :: thr - call map_update(mo_integrals_erf_map, buffer_i, buffer_values, n_integrals, thr) -end - - BEGIN_PROVIDER [ integer, mo_integrals_erf_cache_min ] -&BEGIN_PROVIDER [ integer, mo_integrals_erf_cache_max ] - implicit none - BEGIN_DOC - ! Min and max values of the MOs for which the integrals are in the cache - END_DOC - mo_integrals_erf_cache_min = max(1,elec_alpha_num - 31) - mo_integrals_erf_cache_max = min(mo_tot_num,mo_integrals_erf_cache_min+63) - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, mo_integrals_erf_cache, (0:64*64*64*64) ] - implicit none - BEGIN_DOC - ! Cache of MO integrals for fast access - END_DOC - PROVIDE mo_bielec_integrals_erf_in_map - integer :: i,j,k,l - integer :: ii - integer(key_kind) :: idx - real(integral_kind) :: integral - FREE ao_integrals_erf_cache - !$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral) - do l=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max - do k=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max - do j=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max - do i=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,idx) - !DIR$ FORCEINLINE - call map_get(mo_integrals_erf_map,idx,integral) - ii = l-mo_integrals_erf_cache_min - ii = ior( ishft(ii,6), k-mo_integrals_erf_cache_min) - ii = ior( ishft(ii,6), j-mo_integrals_erf_cache_min) - ii = ior( ishft(ii,6), i-mo_integrals_erf_cache_min) - mo_integrals_erf_cache(ii) = integral - enddo - enddo - enddo - enddo - !$OMP END PARALLEL DO - -END_PROVIDER - - -double precision function get_mo_bielec_integral_erf(i,j,k,l,map) - use map_module - implicit none - BEGIN_DOC - ! Returns one integral in the MO basis - END_DOC - integer, intent(in) :: i,j,k,l - integer(key_kind) :: idx - integer :: ii - type(map_type), intent(inout) :: map - real(integral_kind) :: tmp - PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_cache - ii = l-mo_integrals_erf_cache_min - ii = ior(ii, k-mo_integrals_erf_cache_min) - ii = ior(ii, j-mo_integrals_erf_cache_min) - ii = ior(ii, i-mo_integrals_erf_cache_min) - if (iand(ii, -64) /= 0) then - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,idx) - !DIR$ FORCEINLINE - call map_get(map,idx,tmp) - get_mo_bielec_integral_erf = dble(tmp) - else - ii = l-mo_integrals_erf_cache_min - ii = ior( ishft(ii,6), k-mo_integrals_erf_cache_min) - ii = ior( ishft(ii,6), j-mo_integrals_erf_cache_min) - ii = ior( ishft(ii,6), i-mo_integrals_erf_cache_min) - get_mo_bielec_integral_erf = mo_integrals_erf_cache(ii) - endif -end - - -double precision function mo_bielec_integral_erf(i,j,k,l) - implicit none - BEGIN_DOC - ! Returns one integral in the MO basis - END_DOC - integer, intent(in) :: i,j,k,l - double precision :: get_mo_bielec_integral_erf - PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_cache - !DIR$ FORCEINLINE - PROVIDE mo_bielec_integrals_erf_in_map - mo_bielec_integral_erf = get_mo_bielec_integral_erf(i,j,k,l,mo_integrals_erf_map) - return -end - -subroutine get_mo_bielec_integrals_erf(j,k,l,sze,out_val,map) - use map_module - implicit none - BEGIN_DOC - ! Returns multiple integrals in the MO basis, all - ! i for j,k,l fixed. - END_DOC - integer, intent(in) :: j,k,l, sze - double precision, intent(out) :: out_val(sze) - type(map_type), intent(inout) :: map - integer :: i - integer(key_kind) :: hash(sze) - real(integral_kind) :: tmp_val(sze) - PROVIDE mo_bielec_integrals_erf_in_map - - do i=1,sze - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,hash(i)) - enddo - - if (key_kind == 8) then - call map_get_many(map, hash, out_val, sze) - else - call map_get_many(map, hash, tmp_val, sze) - ! Conversion to double precision - do i=1,sze - out_val(i) = dble(tmp_val(i)) - enddo - endif -end - -subroutine get_mo_bielec_integrals_erf_ij(k,l,sze,out_array,map) - use map_module - implicit none - BEGIN_DOC - ! Returns multiple integrals in the MO basis, all - ! i(1)j(2) 1/r12 k(1)l(2) - ! i, j for k,l fixed. - END_DOC - integer, intent(in) :: k,l, sze - double precision, intent(out) :: out_array(sze,sze) - type(map_type), intent(inout) :: map - integer :: i,j,kk,ll,m - integer(key_kind),allocatable :: hash(:) - integer ,allocatable :: pairs(:,:), iorder(:) - real(integral_kind), allocatable :: tmp_val(:) - - PROVIDE mo_bielec_integrals_erf_in_map - allocate (hash(sze*sze), pairs(2,sze*sze),iorder(sze*sze), & - tmp_val(sze*sze)) - - kk=0 - out_array = 0.d0 - do j=1,sze - do i=1,sze - kk += 1 - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,hash(kk)) - pairs(1,kk) = i - pairs(2,kk) = j - iorder(kk) = kk - enddo - enddo - - logical :: integral_is_in_map - if (key_kind == 8) then - call i8radix_sort(hash,iorder,kk,-1) - else if (key_kind == 4) then - call iradix_sort(hash,iorder,kk,-1) - else if (key_kind == 2) then - call i2radix_sort(hash,iorder,kk,-1) - endif - - call map_get_many(mo_integrals_erf_map, hash, tmp_val, kk) - - do ll=1,kk - m = iorder(ll) - i=pairs(1,m) - j=pairs(2,m) - out_array(i,j) = tmp_val(ll) - enddo - - deallocate(pairs,hash,iorder,tmp_val) -end - -subroutine get_mo_bielec_integrals_erf_coulomb_ii(k,l,sze,out_val,map) - use map_module - implicit none - BEGIN_DOC - ! Returns multiple integrals - ! k(1)i(2) 1/r12 l(1)i(2) :: out_val(i1) - ! for k,l fixed. - END_DOC - integer, intent(in) :: k,l, sze - double precision, intent(out) :: out_val(sze) - type(map_type), intent(inout) :: map - integer :: i - integer(key_kind) :: hash(sze) - real(integral_kind) :: tmp_val(sze) - PROVIDE mo_bielec_integrals_erf_in_map - - integer :: kk - do i=1,sze - !DIR$ FORCEINLINE - call bielec_integrals_index(k,i,l,i,hash(i)) - enddo - - if (key_kind == 8) then - call map_get_many(map, hash, out_val, sze) - else - call map_get_many(map, hash, tmp_val, sze) - ! Conversion to double precision - do i=1,sze - out_val(i) = dble(tmp_val(i)) - enddo - endif -end - -subroutine get_mo_bielec_integrals_erf_exch_ii(k,l,sze,out_val,map) - use map_module - implicit none - BEGIN_DOC - ! Returns multiple integrals - ! k(1)i(2) 1/r12 i(1)l(2) :: out_val(i1) - ! for k,l fixed. - END_DOC - integer, intent(in) :: k,l, sze - double precision, intent(out) :: out_val(sze) - type(map_type), intent(inout) :: map - integer :: i - integer(key_kind) :: hash(sze) - real(integral_kind) :: tmp_val(sze) - PROVIDE mo_bielec_integrals_erf_in_map - - integer :: kk - do i=1,sze - !DIR$ FORCEINLINE - call bielec_integrals_index(k,i,i,l,hash(i)) - enddo - - if (key_kind == 8) then - call map_get_many(map, hash, out_val, sze) - else - call map_get_many(map, hash, tmp_val, sze) - ! Conversion to double precision - do i=1,sze - out_val(i) = dble(tmp_val(i)) - enddo - endif -end - - -integer*8 function get_mo_erf_map_size() - implicit none - BEGIN_DOC - ! Return the number of elements in the MO map - END_DOC - get_mo_erf_map_size = mo_integrals_erf_map % n_elements -end diff --git a/plugins/Integrals_erf/mo_bi_integrals_erf.irp.f b/plugins/Integrals_erf/mo_bi_integrals_erf.irp.f deleted file mode 100644 index b0c954c1..00000000 --- a/plugins/Integrals_erf/mo_bi_integrals_erf.irp.f +++ /dev/null @@ -1,616 +0,0 @@ -subroutine mo_bielec_integrals_erf_index(i,j,k,l,i1) - use map_module - implicit none - BEGIN_DOC - ! Computes an unique index for i,j,k,l integrals - END_DOC - integer, intent(in) :: i,j,k,l - integer(key_kind), intent(out) :: i1 - integer(key_kind) :: p,q,r,s,i2 - p = min(i,k) - r = max(i,k) - p = p+ishft(r*r-r,-1) - q = min(j,l) - s = max(j,l) - q = q+ishft(s*s-s,-1) - i1 = min(p,q) - i2 = max(p,q) - i1 = i1+ishft(i2*i2-i2,-1) -end - - -BEGIN_PROVIDER [ logical, mo_bielec_integrals_erf_in_map ] - use map_module - implicit none - integer(bit_kind) :: mask_ijkl(N_int,4) - integer(bit_kind) :: mask_ijk(N_int,3) - - BEGIN_DOC - ! If True, the map of MO bielectronic integrals is provided - END_DOC - - mo_bielec_integrals_erf_in_map = .True. - if (read_mo_integrals_erf) then - print*,'Reading the MO integrals_erf' - call map_load_from_disk(trim(ezfio_filename)//'/work/mo_ints_erf',mo_integrals_erf_map) - print*, 'MO integrals_erf provided' - return - else - PROVIDE ao_bielec_integrals_erf_in_map - endif - - !if(no_vvvv_integrals)then - ! integer :: i,j,k,l - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I I !!!!!!!!!!!!!!!!!!!! - ! ! (core+inact+act) ^ 4 - ! ! - ! print*, '' - ! print*, '' - ! do i = 1,N_int - ! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,4) = core_inact_act_bitmask_4(i,1) - ! enddo - ! call add_integrals_to_map(mask_ijkl) - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I V V !!!!!!!!!!!!!!!!!!!! - ! ! (core+inact+act) ^ 2 (virt) ^2 - ! ! = J_iv - ! print*, '' - ! print*, '' - ! do i = 1,N_int - ! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,2) = virt_bitmask(i,1) - ! mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,4) = virt_bitmask(i,1) - ! enddo - ! call add_integrals_to_map(mask_ijkl) - ! - ! ! (core+inact+act) ^ 2 (virt) ^2 - ! ! = (iv|iv) - ! print*, '' - ! print*, '' - ! do i = 1,N_int - ! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,3) = virt_bitmask(i,1) - ! mask_ijkl(i,4) = virt_bitmask(i,1) - ! enddo - ! call add_integrals_to_map(mask_ijkl) - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! V V V !!!!!!!!!!!!!!!!!!!!!!! - ! if(.not.no_vvv_integrals)then - ! print*, '' - ! print*, ' and ' - ! do i = 1,N_int - ! mask_ijk(i,1) = virt_bitmask(i,1) - ! mask_ijk(i,2) = virt_bitmask(i,1) - ! mask_ijk(i,3) = virt_bitmask(i,1) - ! enddo - ! call add_integrals_to_map_three_indices(mask_ijk) - ! endif - ! - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I V !!!!!!!!!!!!!!!!!!!! - ! ! (core+inact+act) ^ 3 (virt) ^1 - ! ! - ! print*, '' - ! print*, '' - ! do i = 1,N_int - ! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,4) = virt_bitmask(i,1) - ! enddo - ! call add_integrals_to_map(mask_ijkl) - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I V V V !!!!!!!!!!!!!!!!!!!! - ! ! (core+inact+act) ^ 1 (virt) ^3 - ! ! - ! if(.not.no_ivvv_integrals)then - ! print*, '' - ! print*, '' - ! do i = 1,N_int - ! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,2) = virt_bitmask(i,1) - ! mask_ijkl(i,3) = virt_bitmask(i,1) - ! mask_ijkl(i,4) = virt_bitmask(i,1) - ! enddo - ! call add_integrals_to_map_no_exit_34(mask_ijkl) - ! endif - ! - !else - call add_integrals_erf_to_map(full_ijkl_bitmask_4) - !endif - if (write_mo_integrals_erf) then - call ezfio_set_work_empty(.False.) - call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints_erf',mo_integrals_erf_map) - call ezfio_set_integrals_erf_disk_access_mo_integrals_erf("Read") - endif - -END_PROVIDER - -subroutine add_integrals_erf_to_map(mask_ijkl) - use bitmasks - implicit none - - BEGIN_DOC - ! Adds integrals to tha MO map according to some bitmask - END_DOC - - integer(bit_kind), intent(in) :: mask_ijkl(N_int,4) - - integer :: i,j,k,l - integer :: i0,j0,k0,l0 - double precision :: c, cpu_1, cpu_2, wall_1, wall_2, wall_0 - - integer, allocatable :: list_ijkl(:,:) - integer :: n_i, n_j, n_k, n_l - integer, allocatable :: bielec_tmp_0_idx(:) - real(integral_kind), allocatable :: bielec_tmp_0(:,:) - double precision, allocatable :: bielec_tmp_1(:) - double precision, allocatable :: bielec_tmp_2(:,:) - double precision, allocatable :: bielec_tmp_3(:,:,:) - !DEC$ ATTRIBUTES ALIGN : 64 :: bielec_tmp_1, bielec_tmp_2, bielec_tmp_3 - - integer :: n_integrals - integer :: size_buffer - integer(key_kind),allocatable :: buffer_i(:) - real(integral_kind),allocatable :: buffer_value(:) - real :: map_mb - - integer :: i1,j1,k1,l1, ii1, kmax, thread_num - integer :: i2,i3,i4 - double precision,parameter :: thr_coef = 1.d-10 - - PROVIDE ao_bielec_integrals_erf_in_map mo_coef - - !Get list of MOs for i,j,k and l - !------------------------------- - - allocate(list_ijkl(mo_tot_num,4)) - call bitstring_to_list( mask_ijkl(1,1), list_ijkl(1,1), n_i, N_int ) - call bitstring_to_list( mask_ijkl(1,2), list_ijkl(1,2), n_j, N_int ) - call bitstring_to_list( mask_ijkl(1,3), list_ijkl(1,3), n_k, N_int ) - call bitstring_to_list( mask_ijkl(1,4), list_ijkl(1,4), n_l, N_int ) - character*(2048) :: output(1) - print*, 'i' - call bitstring_to_str( output(1), mask_ijkl(1,1), N_int ) - print *, trim(output(1)) - j = 0 - do i = 1, N_int - j += popcnt(mask_ijkl(i,1)) - enddo - if(j==0)then - return - endif - - print*, 'j' - call bitstring_to_str( output(1), mask_ijkl(1,2), N_int ) - print *, trim(output(1)) - j = 0 - do i = 1, N_int - j += popcnt(mask_ijkl(i,2)) - enddo - if(j==0)then - return - endif - - print*, 'k' - call bitstring_to_str( output(1), mask_ijkl(1,3), N_int ) - print *, trim(output(1)) - j = 0 - do i = 1, N_int - j += popcnt(mask_ijkl(i,3)) - enddo - if(j==0)then - return - endif - - print*, 'l' - call bitstring_to_str( output(1), mask_ijkl(1,4), N_int ) - print *, trim(output(1)) - j = 0 - do i = 1, N_int - j += popcnt(mask_ijkl(i,4)) - enddo - if(j==0)then - return - endif - - size_buffer = min(ao_num*ao_num*ao_num,16000000) - print*, 'Providing the molecular integrals ' - print*, 'Buffers : ', 8.*(mo_tot_num_align*(n_j)*(n_k+1) + mo_tot_num_align +& - ao_num+ao_num*ao_num+ size_buffer*3)/(1024*1024), 'MB / core' - - call wall_time(wall_1) - call cpu_time(cpu_1) - double precision :: accu_bis - accu_bis = 0.d0 - - !$OMP PARALLEL PRIVATE(l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, & - !$OMP bielec_tmp_0_idx, bielec_tmp_0, bielec_tmp_1,bielec_tmp_2,bielec_tmp_3,& - !$OMP buffer_i,buffer_value,n_integrals,wall_2,i0,j0,k0,l0, & - !$OMP wall_0,thread_num,accu_bis) & - !$OMP DEFAULT(NONE) & - !$OMP SHARED(size_buffer,ao_num,mo_tot_num,n_i,n_j,n_k,n_l,mo_tot_num_align,& - !$OMP mo_coef_transp, & - !$OMP mo_coef_transp_is_built, list_ijkl, & - !$OMP mo_coef_is_built, wall_1, & - !$OMP mo_coef,mo_integrals_threshold,mo_integrals_erf_map) - n_integrals = 0 - wall_0 = wall_1 - allocate(bielec_tmp_3(mo_tot_num_align, n_j, n_k), & - bielec_tmp_1(mo_tot_num_align), & - bielec_tmp_0(ao_num,ao_num), & - bielec_tmp_0_idx(ao_num), & - bielec_tmp_2(mo_tot_num_align, n_j), & - buffer_i(size_buffer), & - buffer_value(size_buffer) ) - - thread_num = 0 - !$ thread_num = omp_get_thread_num() - !$OMP DO SCHEDULE(guided) - do l1 = 1,ao_num - !DEC$ VECTOR ALIGNED - bielec_tmp_3 = 0.d0 - do k1 = 1,ao_num - !DEC$ VECTOR ALIGNED - bielec_tmp_2 = 0.d0 - do j1 = 1,ao_num - call get_ao_bielec_integrals_erf(j1,k1,l1,ao_num,bielec_tmp_0(1,j1)) - ! call compute_ao_bielec_integrals(j1,k1,l1,ao_num,bielec_tmp_0(1,j1)) - enddo - do j1 = 1,ao_num - kmax = 0 - do i1 = 1,ao_num - c = bielec_tmp_0(i1,j1) - if (c == 0.d0) then - cycle - endif - kmax += 1 - bielec_tmp_0(kmax,j1) = c - bielec_tmp_0_idx(kmax) = i1 - enddo - - if (kmax==0) then - cycle - endif - - !DEC$ VECTOR ALIGNED - bielec_tmp_1 = 0.d0 - ii1=1 - do ii1 = 1,kmax-4,4 - i1 = bielec_tmp_0_idx(ii1) - i2 = bielec_tmp_0_idx(ii1+1) - i3 = bielec_tmp_0_idx(ii1+2) - i4 = bielec_tmp_0_idx(ii1+3) - do i = list_ijkl(1,1), list_ijkl(n_i,1) - bielec_tmp_1(i) = bielec_tmp_1(i) + & - mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1) + & - mo_coef_transp(i,i2) * bielec_tmp_0(ii1+1,j1) + & - mo_coef_transp(i,i3) * bielec_tmp_0(ii1+2,j1) + & - mo_coef_transp(i,i4) * bielec_tmp_0(ii1+3,j1) - enddo ! i - enddo ! ii1 - - i2 = ii1 - do ii1 = i2,kmax - i1 = bielec_tmp_0_idx(ii1) - do i = list_ijkl(1,1), list_ijkl(n_i,1) - bielec_tmp_1(i) = bielec_tmp_1(i) + mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1) - enddo ! i - enddo ! ii1 - c = 0.d0 - - do i = list_ijkl(1,1), list_ijkl(n_i,1) - c = max(c,abs(bielec_tmp_1(i))) - if (c>mo_integrals_threshold) exit - enddo - if ( c < mo_integrals_threshold ) then - cycle - endif - - do j0 = 1, n_j - j = list_ijkl(j0,2) - c = mo_coef_transp(j,j1) - if (abs(c) < thr_coef) then - cycle - endif - do i = list_ijkl(1,1), list_ijkl(n_i,1) - bielec_tmp_2(i,j0) = bielec_tmp_2(i,j0) + c * bielec_tmp_1(i) - enddo ! i - enddo ! j - enddo !j1 - if ( maxval(abs(bielec_tmp_2)) < mo_integrals_threshold ) then - cycle - endif - - - do k0 = 1, n_k - k = list_ijkl(k0,3) - c = mo_coef_transp(k,k1) - if (abs(c) < thr_coef) then - cycle - endif - - do j0 = 1, n_j - j = list_ijkl(j0,2) - do i = list_ijkl(1,1), k - bielec_tmp_3(i,j0,k0) = bielec_tmp_3(i,j0,k0) + c* bielec_tmp_2(i,j0) - enddo!i - enddo !j - - enddo !k - enddo !k1 - - - - do l0 = 1,n_l - l = list_ijkl(l0,4) - c = mo_coef_transp(l,l1) - if (abs(c) < thr_coef) then - cycle - endif - j1 = ishft((l*l-l),-1) - do j0 = 1, n_j - j = list_ijkl(j0,2) - if (j > l) then - exit - endif - j1 += 1 - do k0 = 1, n_k - k = list_ijkl(k0,3) - i1 = ishft((k*k-k),-1) - if (i1<=j1) then - continue - else - exit - endif - bielec_tmp_1 = 0.d0 - do i0 = 1, n_i - i = list_ijkl(i0,1) - if (i>k) then - exit - endif - bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0) - ! i1+=1 - enddo - - do i0 = 1, n_i - i = list_ijkl(i0,1) - if(i> min(k,j1-i1+list_ijkl(1,1)-1))then - exit - endif - if (abs(bielec_tmp_1(i)) < mo_integrals_threshold) then - cycle - endif - n_integrals += 1 - buffer_value(n_integrals) = bielec_tmp_1(i) - !DEC$ FORCEINLINE - call mo_bielec_integrals_erf_index(i,j,k,l,buffer_i(n_integrals)) - if (n_integrals == size_buffer) then - call insert_into_mo_integrals_erf_map(n_integrals,buffer_i,buffer_value,& - real(mo_integrals_threshold,integral_kind)) - n_integrals = 0 - endif - enddo - enddo - enddo - enddo - - call wall_time(wall_2) - if (thread_num == 0) then - if (wall_2 - wall_0 > 1.d0) then - wall_0 = wall_2 - print*, 100.*float(l1)/float(ao_num), '% in ', & - wall_2-wall_1, 's', map_mb(mo_integrals_erf_map) ,'MB' - endif - endif - enddo - !$OMP END DO NOWAIT - deallocate (bielec_tmp_1,bielec_tmp_2,bielec_tmp_3) - - integer :: index_needed - - call insert_into_mo_integrals_erf_map(n_integrals,buffer_i,buffer_value,& - real(mo_integrals_threshold,integral_kind)) - deallocate(buffer_i, buffer_value) - !$OMP END PARALLEL - call map_unique(mo_integrals_erf_map) - - call wall_time(wall_2) - call cpu_time(cpu_2) - integer*8 :: get_mo_erf_map_size, mo_erf_map_size - mo_erf_map_size = get_mo_erf_map_size() - - deallocate(list_ijkl) - - - print*,'Molecular integrals provided:' - print*,' Size of MO map ', map_mb(mo_integrals_erf_map) ,'MB' - print*,' Number of MO integrals: ', mo_erf_map_size - print*,' cpu time :',cpu_2 - cpu_1, 's' - print*,' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')' - -end - - - - BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_from_ao, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_exchange_from_ao, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_anti_from_ao, (mo_tot_num_align,mo_tot_num) ] - BEGIN_DOC - ! mo_bielec_integral_jj_from_ao(i,j) = J_ij - ! mo_bielec_integral_jj_exchange_from_ao(i,j) = J_ij - ! mo_bielec_integral_jj_anti_from_ao(i,j) = J_ij - K_ij - END_DOC - implicit none - integer :: i,j,p,q,r,s - double precision :: c - real(integral_kind) :: integral - integer :: n, pp - real(integral_kind), allocatable :: int_value(:) - integer, allocatable :: int_idx(:) - - double precision, allocatable :: iqrs(:,:), iqsr(:,:), iqis(:), iqri(:) - - if (.not.do_direct_integrals) then - PROVIDE ao_bielec_integrals_erf_in_map mo_coef - endif - - mo_bielec_integral_erf_jj_from_ao = 0.d0 - mo_bielec_integral_erf_jj_exchange_from_ao = 0.d0 - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: iqrs, iqsr - - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE (i,j,p,q,r,s,integral,c,n,pp,int_value,int_idx, & - !$OMP iqrs, iqsr,iqri,iqis) & - !$OMP SHARED(mo_tot_num,mo_coef_transp,mo_tot_num_align,ao_num,& - !$OMP ao_integrals_threshold,do_direct_integrals) & - !$OMP REDUCTION(+:mo_bielec_integral_erf_jj_from_ao,mo_bielec_integral_erf_jj_exchange_from_ao) - - allocate( int_value(ao_num), int_idx(ao_num), & - iqrs(mo_tot_num_align,ao_num), iqis(mo_tot_num), iqri(mo_tot_num),& - iqsr(mo_tot_num_align,ao_num) ) - - !$OMP DO SCHEDULE (guided) - do s=1,ao_num - do q=1,ao_num - - do j=1,ao_num - !DIR$ VECTOR ALIGNED - do i=1,mo_tot_num - iqrs(i,j) = 0.d0 - iqsr(i,j) = 0.d0 - enddo - enddo - - if (do_direct_integrals) then - double precision :: ao_bielec_integral_erf - do r=1,ao_num - call compute_ao_bielec_integrals_erf(q,r,s,ao_num,int_value) - do p=1,ao_num - integral = int_value(p) - if (abs(integral) > ao_integrals_threshold) then - !DIR$ VECTOR ALIGNED - do i=1,mo_tot_num - iqrs(i,r) += mo_coef_transp(i,p) * integral - enddo - endif - enddo - call compute_ao_bielec_integrals_erf(q,s,r,ao_num,int_value) - do p=1,ao_num - integral = int_value(p) - if (abs(integral) > ao_integrals_threshold) then - !DIR$ VECTOR ALIGNED - do i=1,mo_tot_num - iqsr(i,r) += mo_coef_transp(i,p) * integral - enddo - endif - enddo - enddo - - else - - do r=1,ao_num - call get_ao_bielec_integrals_erf_non_zero(q,r,s,ao_num,int_value,int_idx,n) - do pp=1,n - p = int_idx(pp) - integral = int_value(pp) - if (abs(integral) > ao_integrals_threshold) then - !DIR$ VECTOR ALIGNED - do i=1,mo_tot_num - iqrs(i,r) += mo_coef_transp(i,p) * integral - enddo - endif - enddo - call get_ao_bielec_integrals_erf_non_zero(q,s,r,ao_num,int_value,int_idx,n) - do pp=1,n - p = int_idx(pp) - integral = int_value(pp) - if (abs(integral) > ao_integrals_threshold) then - !DIR$ VECTOR ALIGNED - do i=1,mo_tot_num - iqsr(i,r) += mo_coef_transp(i,p) * integral - enddo - endif - enddo - enddo - endif - iqis = 0.d0 - iqri = 0.d0 - do r=1,ao_num - !DIR$ VECTOR ALIGNED - do i=1,mo_tot_num - iqis(i) += mo_coef_transp(i,r) * iqrs(i,r) - iqri(i) += mo_coef_transp(i,r) * iqsr(i,r) - enddo - enddo - do i=1,mo_tot_num - !DIR$ VECTOR ALIGNED - do j=1,mo_tot_num - c = mo_coef_transp(j,q)*mo_coef_transp(j,s) - mo_bielec_integral_erf_jj_from_ao(j,i) += c * iqis(i) - mo_bielec_integral_erf_jj_exchange_from_ao(j,i) += c * iqri(i) - enddo - enddo - - enddo - enddo - !$OMP END DO NOWAIT - deallocate(iqrs,iqsr,int_value,int_idx) - !$OMP END PARALLEL - - mo_bielec_integral_erf_jj_anti_from_ao = mo_bielec_integral_erf_jj_from_ao - mo_bielec_integral_erf_jj_exchange_from_ao - - -! end -END_PROVIDER - - - BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_exchange, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_anti, (mo_tot_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! mo_bielec_integral_jj(i,j) = J_ij - ! mo_bielec_integral_jj_exchange(i,j) = K_ij - ! mo_bielec_integral_jj_anti(i,j) = J_ij - K_ij - END_DOC - - integer :: i,j - double precision :: get_mo_bielec_integral_erf - - PROVIDE mo_bielec_integrals_erf_in_map - mo_bielec_integral_erf_jj = 0.d0 - mo_bielec_integral_erf_jj_exchange = 0.d0 - - do j=1,mo_tot_num - do i=1,mo_tot_num - mo_bielec_integral_erf_jj(i,j) = get_mo_bielec_integral_erf(i,j,i,j,mo_integrals_erf_map) - mo_bielec_integral_erf_jj_exchange(i,j) = get_mo_bielec_integral_erf(i,j,j,i,mo_integrals_erf_map) - mo_bielec_integral_erf_jj_anti(i,j) = mo_bielec_integral_erf_jj(i,j) - mo_bielec_integral_erf_jj_exchange(i,j) - enddo - enddo - -END_PROVIDER - - -subroutine clear_mo_erf_map - implicit none - BEGIN_DOC - ! Frees the memory of the MO map - END_DOC - call map_deinit(mo_integrals_erf_map) - FREE mo_integrals_erf_map mo_bielec_integral_erf_jj mo_bielec_integral_erf_jj_anti - FREE mo_bielec_integral_Erf_jj_exchange mo_bielec_integrals_erf_in_map - - -end - -subroutine provide_all_mo_integrals_erf - implicit none - provide mo_integrals_erf_map mo_bielec_integral_erf_jj mo_bielec_integral_erf_jj_anti - provide mo_bielec_integral_erf_jj_exchange mo_bielec_integrals_erf_in_map - -end diff --git a/plugins/Integrals_erf/providers_ao_erf.irp.f b/plugins/Integrals_erf/providers_ao_erf.irp.f deleted file mode 100644 index 1507d1be..00000000 --- a/plugins/Integrals_erf/providers_ao_erf.irp.f +++ /dev/null @@ -1,119 +0,0 @@ - -BEGIN_PROVIDER [ logical, ao_bielec_integrals_erf_in_map ] - implicit none - use f77_zmq - use map_module - BEGIN_DOC - ! Map of Atomic integrals - ! i(r1) j(r2) 1/r12 k(r1) l(r2) - END_DOC - - integer :: i,j,k,l - double precision :: ao_bielec_integral_erf,cpu_1,cpu_2, wall_1, wall_2 - double precision :: integral, wall_0 - include 'Utils/constants.include.F' - - ! For integrals file - integer(key_kind),allocatable :: buffer_i(:) - integer,parameter :: size_buffer = 1024*64 - real(integral_kind),allocatable :: buffer_value(:) - - integer :: n_integrals, rc - integer :: kk, m, j1, i1, lmax - character*(64) :: fmt - - integral = ao_bielec_integral_erf(1,1,1,1) - - real :: map_mb - PROVIDE read_ao_integrals_erf disk_access_ao_integrals_erf - if (read_ao_integrals_erf) then - print*,'Reading the AO integrals_erf' - call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints_erf',ao_integrals_erf_map) - print*, 'AO integrals_erf provided' - ao_bielec_integrals_erf_in_map = .True. - return - endif - - print*, 'Providing the AO integrals_erf' - call wall_time(wall_0) - call wall_time(wall_1) - call cpu_time(cpu_1) - - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - call new_parallel_job(zmq_to_qp_run_socket,'ao_integrals_erf') - - character(len=:), allocatable :: task - allocate(character(len=ao_num*12) :: task) - write(fmt,*) '(', ao_num, '(I5,X,I5,''|''))' - do l=1,ao_num - write(task,fmt) (i,l, i=1,l) - call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) - enddo - deallocate(task) - - call zmq_set_running(zmq_to_qp_run_socket) - - PROVIDE nproc - !$OMP PARALLEL DEFAULT(private) num_threads(nproc+1) - i = omp_get_thread_num() - if (i==0) then - call ao_bielec_integrals_erf_in_map_collector(i) - else - call ao_bielec_integrals_erf_in_map_slave_inproc(i) - endif - !$OMP END PARALLEL - - call end_parallel_job(zmq_to_qp_run_socket, 'ao_integrals_erf') - - - print*, 'Sorting the map' - call map_sort(ao_integrals_erf_map) - call cpu_time(cpu_2) - call wall_time(wall_2) - integer(map_size_kind) :: get_ao_erf_map_size, ao_erf_map_size - ao_erf_map_size = get_ao_erf_map_size() - - print*, 'AO integrals provided:' - print*, ' Size of AO map : ', map_mb(ao_integrals_erf_map) ,'MB' - print*, ' Number of AO integrals :', ao_erf_map_size - print*, ' cpu time :',cpu_2 - cpu_1, 's' - print*, ' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1+tiny(1.d0)), ' )' - - ao_bielec_integrals_erf_in_map = .True. - - if (write_ao_integrals_erf) then - call ezfio_set_work_empty(.False.) - call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints_erf',ao_integrals_erf_map) - call ezfio_set_integrals_erf_disk_access_ao_integrals_erf("Read") - endif - -END_PROVIDER - - - - -BEGIN_PROVIDER [ double precision, ao_bielec_integral_erf_schwartz,(ao_num,ao_num) ] - implicit none - BEGIN_DOC - ! Needed to compute Schwartz inequalities - END_DOC - - integer :: i,k - double precision :: ao_bielec_integral_erf,cpu_1,cpu_2, wall_1, wall_2 - - ao_bielec_integral_erf_schwartz(1,1) = ao_bielec_integral_erf(1,1,1,1) - !$OMP PARALLEL DO PRIVATE(i,k) & - !$OMP DEFAULT(NONE) & - !$OMP SHARED (ao_num,ao_bielec_integral_erf_schwartz) & - !$OMP SCHEDULE(dynamic) - do i=1,ao_num - do k=1,i - ao_bielec_integral_erf_schwartz(i,k) = dsqrt(ao_bielec_integral_erf(i,k,i,k)) - ao_bielec_integral_erf_schwartz(k,i) = ao_bielec_integral_erf_schwartz(i,k) - enddo - enddo - !$OMP END PARALLEL DO - -END_PROVIDER - - diff --git a/plugins/Integrals_erf/qp_ao_erf_ints.irp.f b/plugins/Integrals_erf/qp_ao_erf_ints.irp.f deleted file mode 100644 index df6d8d16..00000000 --- a/plugins/Integrals_erf/qp_ao_erf_ints.irp.f +++ /dev/null @@ -1,32 +0,0 @@ -program qp_ao_ints - use omp_lib - implicit none - BEGIN_DOC -! Increments a running calculation to compute AO integral_erfs - END_DOC - integer :: i - - call switch_qp_run_to_master - - zmq_context = f77_zmq_ctx_new () - - ! Set the state of the ZMQ - zmq_state = 'ao_integral_erfs' - - ! Provide everything needed - double precision :: integral_erf, ao_bielec_integral_erf - integral_erf = ao_bielec_integral_erf(1,1,1,1) - - character*(64) :: state - call wait_for_state(zmq_state,state) - do while (state /= 'Stopped') - !$OMP PARALLEL DEFAULT(PRIVATE) PRIVATE(i) - i = omp_get_thread_num() - call ao_bielec_integrals_erf_in_map_slave_tcp(i) - !$OMP END PARALLEL - call wait_for_state(zmq_state,state) - enddo - - print *, 'Done' -end - diff --git a/plugins/Integrals_erf/read_write.irp.f b/plugins/Integrals_erf/read_write.irp.f deleted file mode 100644 index 12bbf0bc..00000000 --- a/plugins/Integrals_erf/read_write.irp.f +++ /dev/null @@ -1,47 +0,0 @@ -BEGIN_PROVIDER [ logical, read_ao_integrals_erf ] -&BEGIN_PROVIDER [ logical, read_mo_integrals_erf ] -&BEGIN_PROVIDER [ logical, write_ao_integrals_erf ] -&BEGIN_PROVIDER [ logical, write_mo_integrals_erf ] - - BEGIN_DOC -! One level of abstraction for disk_access_ao_integrals_erf and disk_access_mo_integrals_erf - END_DOC -implicit none - - if (disk_access_ao_integrals_erf.EQ.'Read') then - read_ao_integrals_erf = .True. - write_ao_integrals_erf = .False. - - else if (disk_access_ao_integrals_erf.EQ.'Write') then - read_ao_integrals_erf = .False. - write_ao_integrals_erf = .True. - - else if (disk_access_ao_integrals_erf.EQ.'None') then - read_ao_integrals_erf = .False. - write_ao_integrals_erf = .False. - - else - print *, 'bielec_integrals_erf/disk_access_ao_integrals_erf has a wrong type' - stop 1 - - endif - - if (disk_access_mo_integrals_erf.EQ.'Read') then - read_mo_integrals_erf = .True. - write_mo_integrals_erf = .False. - - else if (disk_access_mo_integrals_erf.EQ.'Write') then - read_mo_integrals_erf = .False. - write_mo_integrals_erf = .True. - - else if (disk_access_mo_integrals_erf.EQ.'None') then - read_mo_integrals_erf = .False. - write_mo_integrals_erf = .False. - - else - print *, 'bielec_integrals_erf/disk_access_mo_integrals_erf has a wrong type' - stop 1 - - endif - -END_PROVIDER diff --git a/plugins/Integrals_restart_DFT/NEEDED_CHILDREN_MODULES b/plugins/Integrals_restart_DFT/NEEDED_CHILDREN_MODULES deleted file mode 100644 index 08317b5e..00000000 --- a/plugins/Integrals_restart_DFT/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Integrals_Monoelec Integrals_erf Determinants DFT_Utils diff --git a/plugins/Integrals_restart_DFT/README.rst b/plugins/Integrals_restart_DFT/README.rst deleted file mode 100644 index 589e0a00..00000000 --- a/plugins/Integrals_restart_DFT/README.rst +++ /dev/null @@ -1,12 +0,0 @@ -============== -core_integrals -============== - -Needed Modules -============== -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. -Documentation -============= -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. diff --git a/plugins/Integrals_restart_DFT/short_range_coulomb.irp.f b/plugins/Integrals_restart_DFT/short_range_coulomb.irp.f deleted file mode 100644 index aeb2589c..00000000 --- a/plugins/Integrals_restart_DFT/short_range_coulomb.irp.f +++ /dev/null @@ -1,79 +0,0 @@ -BEGIN_PROVIDER [double precision, density_matrix_read, (mo_tot_num, mo_tot_num)] - implicit none - integer :: i,j,k,l - logical :: exists - call ezfio_has_determinants_density_matrix_mo_disk(exists) - if(exists)then - print*, 'reading the density matrix from input' - call ezfio_get_determinants_density_matrix_mo_disk(exists) - print*, 'reading done' - else - print*, 'no density matrix found in EZFIO file ...' - print*, 'stopping ..' - stop - endif - -END_PROVIDER - - -BEGIN_PROVIDER [double precision, effective_short_range_operator, (mo_tot_num,mo_tot_num)] - implicit none - integer :: i,j,k,l,m,n - double precision :: get_mo_bielec_integral,get_mo_bielec_integral_erf - double precision :: integral, integral_erf - effective_short_range_operator = 0.d0 - do i = 1, mo_tot_num - do j = 1, mo_tot_num - if(dabs(one_body_dm_mo(i,j)).le.1.d-10)cycle - do k = 1, mo_tot_num - do l = 1, mo_tot_num - integral = get_mo_bielec_integral(i,k,j,l,mo_integrals_map) -! integral_erf = get_mo_bielec_integral_erf(i,k,j,l,mo_integrals_erf_map) - effective_short_range_operator(l,k) += one_body_dm_mo(i,j) * integral - enddo - enddo - enddo - enddo -END_PROVIDER - - -BEGIN_PROVIDER [double precision, effective_one_e_potential, (mo_tot_num_align, mo_tot_num,N_states)] - implicit none - integer :: i,j,i_state - effective_one_e_potential = 0.d0 - do i_state = 1, N_states - do i = 1, mo_tot_num - do j = 1, mo_tot_num - effective_one_e_potential(i,j,i_state) = effective_short_range_operator(i,j) + mo_nucl_elec_integral(i,j) + mo_kinetic_integral(i,j) & - + 0.5d0 * (lda_ex_potential_alpha_ao(i,j,i_state) + lda_ex_potential_beta_ao(i,j,i_state)) - enddo - enddo - enddo - -END_PROVIDER - -subroutine save_one_e_effective_potential - implicit none - double precision, allocatable :: tmp(:,:) - allocate(tmp(size(effective_one_e_potential,1),size(effective_one_e_potential,2))) - integer :: i,j - do i = 1, mo_tot_num - do j = 1, mo_tot_num - tmp(i,j) = effective_one_e_potential(i,j,1) - enddo - enddo - call write_one_e_integrals('mo_one_integral', tmp, & - size(tmp,1), size(tmp,2)) - call ezfio_set_integrals_monoelec_disk_access_only_mo_one_integrals("Read") - deallocate(tmp) - -end - -subroutine save_erf_bi_elec_integrals - implicit none - integer :: i,j,k,l - PROVIDE mo_bielec_integrals_erf_in_map - call ezfio_set_work_empty(.False.) - call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_erf_map) - call ezfio_set_integrals_bielec_disk_access_mo_integrals("Read") -end diff --git a/plugins/Integrals_restart_DFT/write_integrals_restart_dft.irp.f b/plugins/Integrals_restart_DFT/write_integrals_restart_dft.irp.f deleted file mode 100644 index d89b965d..00000000 --- a/plugins/Integrals_restart_DFT/write_integrals_restart_dft.irp.f +++ /dev/null @@ -1,18 +0,0 @@ -program write_integrals - implicit none - read_wf = .true. - touch read_wf - disk_access_only_mo_one_integrals = "None" - touch disk_access_only_mo_one_integrals - disk_access_mo_integrals = "None" - touch disk_access_mo_integrals - call routine - -end - -subroutine routine - implicit none - call save_one_e_effective_potential - call save_erf_bi_elec_integrals - -end diff --git a/plugins/Kohn_Sham/EZFIO.cfg b/plugins/Kohn_Sham/EZFIO.cfg deleted file mode 100644 index 33d3a793..00000000 --- a/plugins/Kohn_Sham/EZFIO.cfg +++ /dev/null @@ -1,54 +0,0 @@ -[thresh_scf] -type: Threshold -doc: Threshold on the convergence of the Hartree Fock energy -interface: ezfio,provider,ocaml -default: 1.e-10 - -[exchange_functional] -type: character*(256) -doc: name of the exchange functional -interface: ezfio, provider, ocaml -default: "LDA" - - -[correlation_functional] -type: character*(256) -doc: name of the correlation functional -interface: ezfio, provider, ocaml -default: "LDA" - -[HF_exchange] -type: double precision -doc: Percentage of HF exchange in the DFT model -interface: ezfio,provider,ocaml -default: 0. - -[n_it_scf_max] -type: Strictly_positive_int -doc: Maximum number of SCF iterations -interface: ezfio,provider,ocaml -default: 200 - -[level_shift] -type: Positive_float -doc: Energy shift on the virtual MOs to improve SCF convergence -interface: ezfio,provider,ocaml -default: 0.5 - -[mo_guess_type] -type: MO_guess -doc: Initial MO guess. Can be [ Huckel | HCore ] -interface: ezfio,provider,ocaml -default: Huckel - -[energy] -type: double precision -doc: Calculated HF energy -interface: ezfio - -[no_oa_or_av_opt] -type: logical -doc: If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure -interface: ezfio,provider,ocaml -default: False - diff --git a/plugins/Kohn_Sham/Fock_matrix.irp.f b/plugins/Kohn_Sham/Fock_matrix.irp.f deleted file mode 100644 index 9c91ddc9..00000000 --- a/plugins/Kohn_Sham/Fock_matrix.irp.f +++ /dev/null @@ -1,468 +0,0 @@ - BEGIN_PROVIDER [ double precision, Fock_matrix_mo, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, Fock_matrix_diag_mo, (mo_tot_num)] - implicit none - BEGIN_DOC - ! Fock matrix on the MO basis. - ! For open shells, the ROHF Fock Matrix is - ! - ! | F-K | F + K/2 | F | - ! |---------------------------------| - ! | F + K/2 | F | F - K/2 | - ! |---------------------------------| - ! | F | F - K/2 | F + K | - ! - ! F = 1/2 (Fa + Fb) - ! - ! K = Fb - Fa - ! - END_DOC - integer :: i,j,n - if (elec_alpha_num == elec_beta_num) then - Fock_matrix_mo = Fock_matrix_alpha_mo - else - - do j=1,elec_beta_num - ! F-K - do i=1,elec_beta_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - - (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - ! F+K/2 - do i=elec_beta_num+1,elec_alpha_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - + 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - ! F - do i=elec_alpha_num+1, mo_tot_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) - enddo - enddo - - do j=elec_beta_num+1,elec_alpha_num - ! F+K/2 - do i=1,elec_beta_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - + 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - ! F - do i=elec_beta_num+1,elec_alpha_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) - enddo - ! F-K/2 - do i=elec_alpha_num+1, mo_tot_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - - 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - enddo - - do j=elec_alpha_num+1, mo_tot_num - ! F - do i=1,elec_beta_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) - enddo - ! F-K/2 - do i=elec_beta_num+1,elec_alpha_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - - 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - ! F+K - do i=elec_alpha_num+1,mo_tot_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) & - + (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - enddo - - endif - - do i = 1, mo_tot_num - Fock_matrix_diag_mo(i) = Fock_matrix_mo(i,i) - enddo -END_PROVIDER - - - - BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_ao, (ao_num_align, ao_num) ] -&BEGIN_PROVIDER [ double precision, Fock_matrix_beta_ao, (ao_num_align, ao_num) ] - implicit none - BEGIN_DOC - ! Alpha Fock matrix in AO basis set - END_DOC - - integer :: i,j - do j=1,ao_num - !DIR$ VECTOR ALIGNED - do i=1,ao_num - Fock_matrix_alpha_ao(i,j) = Fock_matrix_alpha_no_xc_ao(i,j) + ao_potential_alpha_xc(i,j) - Fock_matrix_beta_ao (i,j) = Fock_matrix_beta_no_xc_ao(i,j) + ao_potential_beta_xc(i,j) - enddo - enddo - -END_PROVIDER - - - BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_no_xc_ao, (ao_num_align, ao_num) ] -&BEGIN_PROVIDER [ double precision, Fock_matrix_beta_no_xc_ao, (ao_num_align, ao_num) ] - implicit none - BEGIN_DOC - ! Mono electronic an Coulomb matrix in AO basis set - END_DOC - - integer :: i,j - do j=1,ao_num - !DIR$ VECTOR ALIGNED - do i=1,ao_num - Fock_matrix_alpha_no_xc_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_alpha(i,j) - Fock_matrix_beta_no_xc_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_beta (i,j) - enddo - enddo - -END_PROVIDER - - - - BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_alpha, (ao_num_align, ao_num) ] -&BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_beta , (ao_num_align, ao_num) ] - use map_module - implicit none - BEGIN_DOC - ! Alpha Fock matrix in AO basis set - END_DOC - - integer :: i,j,k,l,k1,r,s - integer :: i0,j0,k0,l0 - integer*8 :: p,q - double precision :: integral, c0, c1, c2 - double precision :: ao_bielec_integral, local_threshold - double precision, allocatable :: ao_bi_elec_integral_alpha_tmp(:,:) - double precision, allocatable :: ao_bi_elec_integral_beta_tmp(:,:) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_beta_tmp - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_alpha_tmp - - ao_bi_elec_integral_alpha = 0.d0 - ao_bi_elec_integral_beta = 0.d0 - if (do_direct_integrals) then - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,p,q,r,s,i0,j0,k0,l0, & - !$OMP ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp, c0, c1, c2, & - !$OMP local_threshold)& - !$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,& - !$OMP ao_integrals_map,ao_integrals_threshold, ao_bielec_integral_schwartz, & - !$OMP ao_overlap_abs, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta) - - allocate(keys(1), values(1)) - allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), & - ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num)) - ao_bi_elec_integral_alpha_tmp = 0.d0 - ao_bi_elec_integral_beta_tmp = 0.d0 - - q = ao_num*ao_num*ao_num*ao_num - !$OMP DO SCHEDULE(dynamic) - do p=1_8,q - call bielec_integrals_index_reverse(kk,ii,ll,jj,p) - if ( (kk(1)>ao_num).or. & - (ii(1)>ao_num).or. & - (jj(1)>ao_num).or. & - (ll(1)>ao_num) ) then - cycle - endif - k = kk(1) - i = ii(1) - l = ll(1) - j = jj(1) - - if (ao_overlap_abs(k,l)*ao_overlap_abs(i,j) & - < ao_integrals_threshold) then - cycle - endif - local_threshold = ao_bielec_integral_schwartz(k,l)*ao_bielec_integral_schwartz(i,j) - if (local_threshold < ao_integrals_threshold) then - cycle - endif - i0 = i - j0 = j - k0 = k - l0 = l - values(1) = 0.d0 - local_threshold = ao_integrals_threshold/local_threshold - do k2=1,8 - if (kk(k2)==0) then - cycle - endif - i = ii(k2) - j = jj(k2) - k = kk(k2) - l = ll(k2) - c0 = HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l) - c1 = HF_density_matrix_ao_alpha(k,i) - c2 = HF_density_matrix_ao_beta(k,i) - if ( dabs(c0)+dabs(c1)+dabs(c2) < local_threshold) then - cycle - endif - if (values(1) == 0.d0) then - values(1) = ao_bielec_integral(k0,l0,i0,j0) - endif - integral = c0 * values(1) - ao_bi_elec_integral_alpha_tmp(i,j) += integral - ao_bi_elec_integral_beta_tmp (i,j) += integral - integral = values(1) - ao_bi_elec_integral_alpha_tmp(l,j) -= c1 * integral - ao_bi_elec_integral_beta_tmp (l,j) -= c2 * integral - enddo - enddo - !$OMP END DO NOWAIT - !$OMP CRITICAL - ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp - !$OMP END CRITICAL - !$OMP CRITICAL - ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp - !$OMP END CRITICAL - deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp) - !$OMP END PARALLEL - else - PROVIDE ao_bielec_integrals_in_map - - integer(omp_lock_kind) :: lck(ao_num) - integer*8 :: i8 - integer :: ii(8), jj(8), kk(8), ll(8), k2 - integer(cache_map_size_kind) :: n_elements_max, n_elements - integer(key_kind), allocatable :: keys(:) - double precision, allocatable :: values(:) - -! !$OMP PARALLEL DEFAULT(NONE) & -! !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,n_elements_max, & -! !$OMP n_elements,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)& -! !$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,& -! !$OMP ao_integrals_map, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta,HF_exchange) - - call get_cache_map_n_elements_max(ao_integrals_map,n_elements_max) - allocate(keys(n_elements_max), values(n_elements_max)) - allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), & - ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num)) - ao_bi_elec_integral_alpha_tmp = 0.d0 - ao_bi_elec_integral_beta_tmp = 0.d0 - -! !OMP DO SCHEDULE(dynamic) -! !DIR$ NOVECTOR - do i8=0_8,ao_integrals_map%map_size - n_elements = n_elements_max - call get_cache_map(ao_integrals_map,i8,keys,values,n_elements) - do k1=1,n_elements - call bielec_integrals_index_reverse(kk,ii,ll,jj,keys(k1)) - - do k2=1,8 - if (kk(k2)==0) then - cycle - endif - i = ii(k2) - j = jj(k2) - k = kk(k2) - l = ll(k2) - integral = (HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l)) * values(k1) - ao_bi_elec_integral_alpha_tmp(i,j) += integral - ao_bi_elec_integral_beta_tmp (i,j) += integral - integral = values(k1) - ao_bi_elec_integral_alpha_tmp(l,j) -= HF_exchange * (HF_density_matrix_ao_alpha(k,i) * integral) - ao_bi_elec_integral_beta_tmp (l,j) -= HF_exchange * (HF_density_matrix_ao_beta (k,i) * integral) - enddo - enddo - enddo -! !$OMP END DO NOWAIT -! !$OMP CRITICAL - ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp -! !$OMP END CRITICAL -! !$OMP CRITICAL - ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp -! !$OMP END CRITICAL - deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp) -! !$OMP END PARALLEL - - endif - -END_PROVIDER - - - - - - -BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_mo, (mo_tot_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! Fock matrix on the MO basis - END_DOC - double precision, allocatable :: T(:,:) - allocate ( T(ao_num_align,mo_tot_num) ) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T - call dgemm('N','N', ao_num, mo_tot_num, ao_num, & - 1.d0, Fock_matrix_alpha_ao,size(Fock_matrix_alpha_ao,1), & - mo_coef, size(mo_coef,1), & - 0.d0, T, ao_num_align) - call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, & - 1.d0, mo_coef,size(mo_coef,1), & - T, size(T,1), & - 0.d0, Fock_matrix_alpha_mo, mo_tot_num_align) - deallocate(T) -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, Fock_matrix_beta_mo, (mo_tot_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! Fock matrix on the MO basis - END_DOC - double precision, allocatable :: T(:,:) - allocate ( T(ao_num_align,mo_tot_num) ) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T - call dgemm('N','N', ao_num, mo_tot_num, ao_num, & - 1.d0, Fock_matrix_beta_ao,size(Fock_matrix_beta_ao,1), & - mo_coef, size(mo_coef,1), & - 0.d0, T, ao_num_align) - call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, & - 1.d0, mo_coef,size(mo_coef,1), & - T, size(T,1), & - 0.d0, Fock_matrix_beta_mo, mo_tot_num_align) - deallocate(T) -END_PROVIDER - - BEGIN_PROVIDER [ double precision, HF_energy ] -&BEGIN_PROVIDER [ double precision, two_electron_energy] -&BEGIN_PROVIDER [ double precision, one_electron_energy] - implicit none - BEGIN_DOC - ! Hartree-Fock energy - END_DOC - HF_energy = nuclear_repulsion - - integer :: i,j - double precision :: accu_mono,accu_fock - one_electron_energy = 0.d0 - two_electron_energy = 0.d0 - do j=1,ao_num - do i=1,ao_num - two_electron_energy += 0.5d0 * ( ao_bi_elec_integral_alpha(i,j) * HF_density_matrix_ao_alpha(i,j) & - +ao_bi_elec_integral_beta(i,j) * HF_density_matrix_ao_beta(i,j) ) - one_electron_energy += ao_mono_elec_integral(i,j) * (HF_density_matrix_ao_alpha(i,j) + HF_density_matrix_ao_beta (i,j) ) - enddo - enddo - print*, 'one_electron_energy = ',one_electron_energy - print*, 'two_electron_energy = ',two_electron_energy - print*, 'e_exchange_dft = ',(1.d0 - HF_exchange) * e_exchange_dft -!print*, 'accu_cor = ',e_correlation_dft - HF_energy += (1.d0 - HF_exchange) * e_exchange_dft + e_correlation_dft + one_electron_energy + two_electron_energy -!print*, 'HF_energy ' - -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, Fock_matrix_ao, (ao_num_align, ao_num) ] - implicit none - BEGIN_DOC - ! Fock matrix in AO basis set - END_DOC - - if ( (elec_alpha_num == elec_beta_num).and. & - (level_shift == 0.) ) & - then - integer :: i,j - do j=1,ao_num - !DIR$ VECTOR ALIGNED - do i=1,ao_num_align - Fock_matrix_ao(i,j) = Fock_matrix_alpha_ao(i,j) - enddo - enddo - else - double precision, allocatable :: T(:,:), M(:,:) - integer :: ierr - ! F_ao = S C F_mo C^t S - allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr) - if (ierr /=0 ) then - print *, irp_here, ' : allocation failed' - endif - -! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num) -! -> M(ao_num,mo_tot_num) - call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, & - ao_overlap, size(ao_overlap,1), & - mo_coef, size(mo_coef,1), & - 0.d0, & - M, size(M,1)) - -! M(ao_num,mo_tot_num) . Fock_matrix_mo (mo_tot_num,mo_tot_num) -! -> T(ao_num,mo_tot_num) - call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, & - M, size(M,1), & - Fock_matrix_mo, size(Fock_matrix_mo,1), & - 0.d0, & - T, size(T,1)) - -! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num) -! -> M(ao_num,ao_num) - call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, & - T, size(T,1), & - mo_coef, size(mo_coef,1), & - 0.d0, & - M, size(M,1)) - -! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num) -! -> Fock_matrix_ao(ao_num,ao_num) - call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, & - M, size(M,1), & - ao_overlap, size(ao_overlap,1), & - 0.d0, & - Fock_matrix_ao, size(Fock_matrix_ao,1)) - - - deallocate(T) - endif -END_PROVIDER - -subroutine Fock_mo_to_ao(FMO,LDFMO,FAO,LDFAO) - implicit none - integer, intent(in) :: LDFMO ! size(FMO,1) - integer, intent(in) :: LDFAO ! size(FAO,1) - double precision, intent(in) :: FMO(LDFMO,*) - double precision, intent(out) :: FAO(LDFAO,*) - - double precision, allocatable :: T(:,:), M(:,:) - integer :: ierr - ! F_ao = S C F_mo C^t S - allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr) - if (ierr /=0 ) then - print *, irp_here, ' : allocation failed' - endif - -! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num) -! -> M(ao_num,mo_tot_num) - call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, & - ao_overlap, size(ao_overlap,1), & - mo_coef, size(mo_coef,1), & - 0.d0, & - M, size(M,1)) - -! M(ao_num,mo_tot_num) . FMO (mo_tot_num,mo_tot_num) -! -> T(ao_num,mo_tot_num) - call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, & - M, size(M,1), & - FMO, size(FMO,1), & - 0.d0, & - T, size(T,1)) - -! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num) -! -> M(ao_num,ao_num) - call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, & - T, size(T,1), & - mo_coef, size(mo_coef,1), & - 0.d0, & - M, size(M,1)) - -! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num) -! -> Fock_matrix_ao(ao_num,ao_num) - call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, & - M, size(M,1), & - ao_overlap, size(ao_overlap,1), & - 0.d0, & - FAO, size(FAO,1)) - deallocate(T,M) -end - diff --git a/plugins/Kohn_Sham/HF_density_matrix_ao.irp.f b/plugins/Kohn_Sham/HF_density_matrix_ao.irp.f deleted file mode 100644 index e8585f59..00000000 --- a/plugins/Kohn_Sham/HF_density_matrix_ao.irp.f +++ /dev/null @@ -1,41 +0,0 @@ -BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_alpha, (ao_num_align,ao_num) ] - implicit none - BEGIN_DOC - ! S^-1 x Alpha density matrix in the AO basis x S^-1 - END_DOC - - call dgemm('N','T',ao_num,ao_num,elec_alpha_num,1.d0, & - mo_coef, size(mo_coef,1), & - mo_coef, size(mo_coef,1), 0.d0, & - HF_density_matrix_ao_alpha, size(HF_density_matrix_ao_alpha,1)) - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_beta, (ao_num_align,ao_num) ] - implicit none - BEGIN_DOC - ! S^-1 Beta density matrix in the AO basis x S^-1 - END_DOC - - call dgemm('N','T',ao_num,ao_num,elec_beta_num,1.d0, & - mo_coef, size(mo_coef,1), & - mo_coef, size(mo_coef,1), 0.d0, & - HF_density_matrix_ao_beta, size(HF_density_matrix_ao_beta,1)) - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, HF_density_matrix_ao, (ao_num_align,ao_num) ] - implicit none - BEGIN_DOC - ! S^-1 Density matrix in the AO basis S^-1 - END_DOC - ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_alpha,1)) - if (elec_alpha_num== elec_beta_num) then - HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_alpha - else - ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_beta ,1)) - HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_beta - endif - -END_PROVIDER - diff --git a/plugins/Kohn_Sham/KS_SCF.irp.f b/plugins/Kohn_Sham/KS_SCF.irp.f deleted file mode 100644 index dead61ee..00000000 --- a/plugins/Kohn_Sham/KS_SCF.irp.f +++ /dev/null @@ -1,54 +0,0 @@ -program scf - BEGIN_DOC -! Produce `Hartree_Fock` MO orbital -! output: mo_basis.mo_tot_num mo_basis.mo_label mo_basis.ao_md5 mo_basis.mo_coef mo_basis.mo_occ -! output: hartree_fock.energy -! optional: mo_basis.mo_coef - END_DOC - call create_guess - call orthonormalize_mos - call run -end - -subroutine create_guess - implicit none - BEGIN_DOC -! Create an MO guess if no MOs are present in the EZFIO directory - END_DOC - logical :: exists - PROVIDE ezfio_filename - call ezfio_has_mo_basis_mo_coef(exists) - if (.not.exists) then - if (mo_guess_type == "HCore") then - mo_coef = ao_ortho_lowdin_coef - TOUCH mo_coef - mo_label = 'Guess' - call mo_as_eigvectors_of_mo_matrix(mo_mono_elec_integral,size(mo_mono_elec_integral,1),size(mo_mono_elec_integral,2),mo_label) - SOFT_TOUCH mo_coef mo_label - else if (mo_guess_type == "Huckel") then - call huckel_guess - else - print *, 'Unrecognized MO guess type : '//mo_guess_type - stop 1 - endif - endif -end - - -subroutine run - - use bitmasks - implicit none - BEGIN_DOC -! Run SCF calculation - END_DOC - double precision :: SCF_energy_before,SCF_energy_after,diag_H_mat_elem - double precision :: E0 - integer :: i_it, i, j, k - - E0 = HF_energy - - mo_label = "Canonical" - call damping_SCF - -end diff --git a/plugins/Kohn_Sham/NEEDED_CHILDREN_MODULES b/plugins/Kohn_Sham/NEEDED_CHILDREN_MODULES deleted file mode 100644 index d8c28b56..00000000 --- a/plugins/Kohn_Sham/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Integrals_Bielec MOGuess Bitmask DFT_Utils diff --git a/plugins/Kohn_Sham/damping_SCF.irp.f b/plugins/Kohn_Sham/damping_SCF.irp.f deleted file mode 100644 index aa6f02b0..00000000 --- a/plugins/Kohn_Sham/damping_SCF.irp.f +++ /dev/null @@ -1,132 +0,0 @@ -subroutine damping_SCF - implicit none - double precision :: E - double precision, allocatable :: D_alpha(:,:), D_beta(:,:) - double precision :: E_new - double precision, allocatable :: D_new_alpha(:,:), D_new_beta(:,:), F_new(:,:) - double precision, allocatable :: delta_alpha(:,:), delta_beta(:,:) - double precision :: lambda, E_half, a, b, delta_D, delta_E, E_min - - integer :: i,j,k - logical :: saving - character :: save_char - - allocate( & - D_alpha( ao_num_align, ao_num ), & - D_beta( ao_num_align, ao_num ), & - F_new( ao_num_align, ao_num ), & - D_new_alpha( ao_num_align, ao_num ), & - D_new_beta( ao_num_align, ao_num ), & - delta_alpha( ao_num_align, ao_num ), & - delta_beta( ao_num_align, ao_num )) - - do j=1,ao_num - do i=1,ao_num - D_alpha(i,j) = HF_density_matrix_ao_alpha(i,j) - D_beta (i,j) = HF_density_matrix_ao_beta (i,j) - enddo - enddo - - - call write_time(output_hartree_fock) - - write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & - '====','================','================','================', '====' - write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & - ' N ', 'Energy ', 'Energy diff ', 'Density diff ', 'Save' - write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & - '====','================','================','================', '====' - - E = HF_energy + 1.d0 - E_min = HF_energy - delta_D = 0.d0 - do k=1,n_it_scf_max - - delta_E = HF_energy - E - E = HF_energy - - if ( (delta_E < 0.d0).and.(dabs(delta_E) < thresh_scf) ) then - exit - endif - - saving = E < E_min - if (saving) then - call save_mos - save_char = 'X' - E_min = E - else - save_char = ' ' - endif - - write(output_hartree_fock,'(I4,1X,F16.10, 1X, F16.10, 1X, F16.10, 3X, A )') & - k, E, delta_E, delta_D, save_char - - D_alpha = HF_density_matrix_ao_alpha - D_beta = HF_density_matrix_ao_beta - mo_coef = eigenvectors_fock_matrix_mo - TOUCH mo_coef - - D_new_alpha = HF_density_matrix_ao_alpha - D_new_beta = HF_density_matrix_ao_beta - F_new = Fock_matrix_ao - E_new = HF_energy - - delta_alpha = D_new_alpha - D_alpha - delta_beta = D_new_beta - D_beta - - lambda = .5d0 - E_half = 0.d0 - do while (E_half > E) - HF_density_matrix_ao_alpha = D_alpha + lambda * delta_alpha - HF_density_matrix_ao_beta = D_beta + lambda * delta_beta - TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta - mo_coef = eigenvectors_fock_matrix_mo - TOUCH mo_coef - E_half = HF_energy - if ((E_half > E).and.(E_new < E)) then - lambda = 1.d0 - exit - else if ((E_half > E).and.(lambda > 5.d-4)) then - lambda = 0.5d0 * lambda - E_new = E_half - else - exit - endif - enddo - - a = (E_new + E - 2.d0*E_half)*2.d0 - b = -E_new - 3.d0*E + 4.d0*E_half - lambda = -lambda*b/(a+1.d-16) - D_alpha = (1.d0-lambda) * D_alpha + lambda * D_new_alpha - D_beta = (1.d0-lambda) * D_beta + lambda * D_new_beta - delta_E = HF_energy - E - do j=1,ao_num - do i=1,ao_num - delta_D = delta_D + & - (D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j))*(D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j)) + & - (D_beta (i,j) - HF_density_matrix_ao_beta (i,j))*(D_beta (i,j) - HF_density_matrix_ao_beta (i,j)) - enddo - enddo - delta_D = dsqrt(delta_D/dble(ao_num)**2) - HF_density_matrix_ao_alpha = D_alpha - HF_density_matrix_ao_beta = D_beta - TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta - mo_coef = eigenvectors_fock_matrix_mo - TOUCH mo_coef - - - enddo - write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') '====','================','================','================', '====' - write(output_hartree_fock,*) - - if(.not.no_oa_or_av_opt)then - call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label,1) - endif - - call write_double(output_hartree_fock, E_min, 'Hartree-Fock energy') - call ezfio_set_hartree_fock_energy(E_min) - - call write_time(output_hartree_fock) - - deallocate(D_alpha,D_beta,F_new,D_new_alpha,D_new_beta,delta_alpha,delta_beta) -end diff --git a/plugins/Kohn_Sham/diagonalize_fock.irp.f b/plugins/Kohn_Sham/diagonalize_fock.irp.f deleted file mode 100644 index c80077b3..00000000 --- a/plugins/Kohn_Sham/diagonalize_fock.irp.f +++ /dev/null @@ -1,119 +0,0 @@ - BEGIN_PROVIDER [ double precision, diagonal_Fock_matrix_mo, (ao_num) ] -&BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! Diagonal Fock matrix in the MO basis - END_DOC - - integer :: i,j - integer :: liwork, lwork, n, info - integer, allocatable :: iwork(:) - double precision, allocatable :: work(:), F(:,:), S(:,:) - - - allocate( F(mo_tot_num_align,mo_tot_num) ) - do j=1,mo_tot_num - do i=1,mo_tot_num - F(i,j) = Fock_matrix_mo(i,j) - enddo - enddo - if(no_oa_or_av_opt)then - integer :: iorb,jorb - do i = 1, n_act_orb - iorb = list_act(i) - do j = 1, n_inact_orb - jorb = list_inact(j) - F(iorb,jorb) = 0.d0 - F(jorb,iorb) = 0.d0 - enddo - do j = 1, n_virt_orb - jorb = list_virt(j) - F(iorb,jorb) = 0.d0 - F(jorb,iorb) = 0.d0 - enddo - do j = 1, n_core_orb - jorb = list_core(j) - F(iorb,jorb) = 0.d0 - F(jorb,iorb) = 0.d0 - enddo - enddo - endif - - - - - ! Insert level shift here - do i = elec_beta_num+1, elec_alpha_num - F(i,i) += 0.5d0*level_shift - enddo - - do i = elec_alpha_num+1, mo_tot_num - F(i,i) += level_shift - enddo - - n = mo_tot_num - lwork = 1+6*n + 2*n*n - liwork = 3 + 5*n - - allocate(work(lwork), iwork(liwork) ) - - lwork = -1 - liwork = -1 - - call dsyevd( 'V', 'U', mo_tot_num, F, & - size(F,1), diagonal_Fock_matrix_mo, & - work, lwork, iwork, liwork, info) - - if (info /= 0) then - print *, irp_here//' failed : ', info - stop 1 - endif - lwork = int(work(1)) - liwork = iwork(1) - deallocate(work,iwork) - allocate(work(lwork), iwork(liwork) ) - - call dsyevd( 'V', 'U', mo_tot_num, F, & - size(F,1), diagonal_Fock_matrix_mo, & - work, lwork, iwork, liwork, info) - - if (info /= 0) then - print *, irp_here//' failed : ', info - stop 1 - endif - - call dgemm('N','N',ao_num,mo_tot_num,mo_tot_num, 1.d0, & - mo_coef, size(mo_coef,1), F, size(F,1), & - 0.d0, eigenvectors_Fock_matrix_mo, size(eigenvectors_Fock_matrix_mo,1)) - deallocate(work, iwork, F) - - -! endif - -END_PROVIDER - -BEGIN_PROVIDER [double precision, diagonal_Fock_matrix_mo_sum, (mo_tot_num)] - implicit none - BEGIN_DOC - ! diagonal element of the fock matrix calculated as the sum over all the interactions - ! with all the electrons in the RHF determinant - ! diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij - END_DOC - integer :: i,j - double precision :: accu - do j = 1,elec_alpha_num - accu = 0.d0 - do i = 1, elec_alpha_num - accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j) - enddo - diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j) - enddo - do j = elec_alpha_num+1,mo_tot_num - accu = 0.d0 - do i = 1, elec_alpha_num - accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j) - enddo - diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j) - enddo - -END_PROVIDER diff --git a/plugins/Kohn_Sham/potential_functional.irp.f b/plugins/Kohn_Sham/potential_functional.irp.f deleted file mode 100644 index 3502581b..00000000 --- a/plugins/Kohn_Sham/potential_functional.irp.f +++ /dev/null @@ -1,31 +0,0 @@ - BEGIN_PROVIDER [double precision, ao_potential_alpha_xc, (ao_num_align, ao_num)] -&BEGIN_PROVIDER [double precision, ao_potential_beta_xc, (ao_num_align, ao_num)] - implicit none - integer :: i,j,k,l - ao_potential_alpha_xc = 0.d0 - ao_potential_beta_xc = 0.d0 -!if(exchange_functional == "LDA")then - do i = 1, ao_num - do j = 1, ao_num - ao_potential_alpha_xc(i,j) = (1.d0 - HF_exchange) * lda_ex_potential_alpha_ao(i,j,1) - ao_potential_beta_xc(i,j) = (1.d0 - HF_exchange) * lda_ex_potential_beta_ao(i,j,1) - enddo - enddo -!endif -END_PROVIDER - -BEGIN_PROVIDER [double precision, e_exchange_dft] - implicit none -!if(exchange_functional == "LDA")then - e_exchange_dft = lda_exchange(1) -!endif - -END_PROVIDER - -BEGIN_PROVIDER [double precision, e_correlation_dft] - implicit none -!if(correlation_functional == "LDA")then - e_correlation_dft = 0.d0 -!endif - -END_PROVIDER diff --git a/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES b/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES index 3dc21fd0..801d2f51 100644 --- a/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES +++ b/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS MRPT_Utils +Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index ccbe700d..1dcf2a2b 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -121,8 +121,7 @@ END_PROVIDER double precision :: phase logical :: ok integer, external :: searchDet - - PROVIDE psi_non_ref_sorted_idx psi_ref_coef + !$OMP PARALLEL default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int,& !$OMP active_excitation_to_determinants_val, active_excitation_to_determinants_idx)& @@ -159,7 +158,6 @@ END_PROVIDER wk += 1 do s=1,N_states active_excitation_to_determinants_val(s,wk, ppp) = psi_ref_coef(lref(i), s) - enddo active_excitation_to_determinants_idx(wk, ppp) = i else if(lref(i) < 0) then @@ -192,7 +190,7 @@ END_PROVIDER double precision, allocatable :: t(:), A_val_mwen(:,:), As2_val_mwen(:,:) integer, allocatable :: A_ind_mwen(:) double precision :: sij - PROVIDE psi_non_ref active_excitation_to_determinants_val + PROVIDE psi_non_ref mrcc_AtA_ind(:) = 0 mrcc_AtA_val(:,:) = 0.d0 @@ -200,6 +198,7 @@ END_PROVIDER mrcc_N_col(:) = 0 AtA_size = 0 + !$OMP PARALLEL default(none) shared(k, active_excitation_to_determinants_idx,& !$OMP active_excitation_to_determinants_val, hh_nex) & !$OMP private(at_row, a_col, t, i, r1, r2, wk, A_ind_mwen, A_val_mwen,& diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 7ba210ca..41435688 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -678,53 +678,6 @@ END_PROVIDER call sort_det(psi_non_ref_sorted, psi_non_ref_sorted_idx, N_det_non_ref, N_int) END_PROVIDER - BEGIN_PROVIDER [ double precision, rho_mrpt, (N_det_non_ref, N_states) ] - implicit none - integer :: i, j, k - double precision :: coef_mrpt(N_States),coef_array(N_states),hij,delta_e(N_states) - double precision :: hij_array(N_det_Ref),delta_e_array(N_det_ref,N_states) - integer :: number_of_holes, number_of_particles,nh,np - do i = 1, N_det_non_ref - print*,'i',i - nh = number_of_holes(psi_non_ref(1,1,i)) - np = number_of_particles(psi_non_ref(1,1,i)) - do j = 1, N_det_ref - do k = 1, N_States - coef_array(k) = psi_ref_coef(j,k) - enddo - call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,i), N_int, Hij_array(j)) - call get_delta_e_dyall(psi_ref(1,1,j),psi_non_ref(1,1,i),coef_array,hij_array(j),delta_e) -! write(*,'(A7,x,100(F16.10,x))')'delta_e',delta_e(:) - do k = 1, N_states - delta_e_Array(j,k) = delta_e(k) - enddo - enddo - coef_mrpt = 0.d0 - do k = 1, N_states - do j = 1, N_det_Ref - coef_mrpt(k) += psi_ref_coef(j,k) * hij_array(j) / delta_e_array(j,k) - enddo - enddo - - write(*,'(A7,X,100(F16.10,x))')'coef ',psi_non_ref_coef(i,1) , coef_mrpt(1),psi_non_ref_coef(i,2) , coef_mrpt(2) - print*, nh,np - do k = 1, N_States - if(dabs(coef_mrpt(k)) .le.1.d-10)then - rho_mrpt(i,k) = 0.d0 - exit - endif - if(psi_non_ref_coef(i,k) / coef_mrpt(k) .lt.0d0)then - rho_mrpt(i,k) = 1.d0 - else - rho_mrpt(i,k) = psi_non_ref_coef(i,k) / coef_mrpt(k) - endif - enddo - print*,'rho',rho_mrpt(i,:) - write(33,*)i,rho_mrpt(i,:) - enddo - - END_PROVIDER - BEGIN_PROVIDER [ double precision, dIj_unique, (hh_nex, N_states) ] &BEGIN_PROVIDER [ double precision, rho_mrcc, (N_det_non_ref, N_states) ] @@ -1004,7 +957,7 @@ END_PROVIDER double precision function get_dij_index(II, i, s, Nint) integer, intent(in) :: II, i, s, Nint double precision, external :: get_dij - double precision :: HIi, phase,delta_e_final(N_states) + double precision :: HIi, phase if(lambda_type == 0) then call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) @@ -1016,11 +969,7 @@ double precision function get_dij_index(II, i, s, Nint) else if(lambda_type == 2) then call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase - get_dij_index = get_dij_index - else if(lambda_type == 3) then - call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi) - call get_delta_e_dyall(psi_ref(1,1,II),psi_non_ref(1,1,i),delta_e_final) - get_dij_index = HIi * rho_mrpt(i, s) / delta_e_final(s) + get_dij_index = get_dij_index * rho_mrcc(i,s) end if end function diff --git a/plugins/MRPT/MRPT_Utils.main.irp.f b/plugins/MRPT/MRPT_Utils.main.irp.f index 1b6efb4f..13c8228a 100644 --- a/plugins/MRPT/MRPT_Utils.main.irp.f +++ b/plugins/MRPT/MRPT_Utils.main.irp.f @@ -10,42 +10,34 @@ end subroutine routine_3 implicit none - integer :: i,j !provide fock_virt_total_spin_trace provide delta_ij print *, 'N_det = ', N_det print *, 'N_states = ', N_states - do i = 1, N_States - print*,'State',i - write(*,'(A12,X,I3,A3,XX,F20.16)') ' PT2 ', i,' = ', second_order_pt_new(i) - write(*,'(A12,X,I3,A3,XX,F22.16)') ' E ', i,' = ', psi_ref_average_value(i) - write(*,'(A12,X,I3,A3,XX,F22.16)') ' E+PT2 ', i,' = ', psi_ref_average_value(i)+second_order_pt_new(i) - write(*,'(A12,X,I3,A3,XX,F22.16)') ' E dressed ', i,' = ', CI_dressed_pt2_new_energy(i) - write(*,'(A12,X,I3,A3,XX,F20.16)') ' S^2 ', i,' = ', CI_dressed_pt2_new_eigenvectors_s2(i) - print*,'coef before and after' - do j = 1, N_det_ref - print*,psi_ref_coef(j,i),CI_dressed_pt2_new_eigenvectors(j,i) - enddo - enddo - if(save_heff_eigenvectors)then - call save_wavefunction_general(N_det_ref,N_states,psi_ref,N_det_ref,CI_dressed_pt2_new_eigenvectors) - endif - if(N_states.gt.1)then - print*, 'Energy differences : E(i) - E(0)' - do i = 2, N_States - print*,'State',i - write(*,'(A12,X,I3,A3,XX,F20.16)') ' S^2 ', i,' = ', CI_dressed_pt2_new_eigenvectors_s2(i) - write(*,'(A12,X,I3,A3,XX,F20.16)') 'Variational ', i,' = ', -(psi_ref_average_value(1) - psi_ref_average_value(i)) - write(*,'(A12,X,I3,A3,XX,F20.16)') 'Perturbative', i,' = ', -(psi_ref_average_value(1)+second_order_pt_new(1) - (psi_ref_average_value(i)+second_order_pt_new(i))) - write(*,'(A12,X,I3,A3,XX,F20.16)') 'Dressed ', i,' = ', -( CI_dressed_pt2_new_energy(1) - CI_dressed_pt2_new_energy(i) ) - enddo - endif + print *, 'PT2 = ', second_order_pt_new(1) + print *, 'E = ', CI_energy(1) + print *, 'E+PT2 = ', CI_energy(1)+second_order_pt_new(1) + print *,'****** DIAGONALIZATION OF DRESSED MATRIX ******' + print *, 'E dressed= ', CI_dressed_pt2_new_energy(1) end subroutine routine_2 implicit none - provide electronic_psi_ref_average_value + integer :: i + do i = 1, n_core_inact_orb + print*,fock_core_inactive_total(i,1,1),fock_core_inactive(i) + enddo + double precision :: accu + accu = 0.d0 + do i = 1, n_act_orb + integer :: j_act_orb + j_act_orb = list_act(i) + accu += one_body_dm_mo_alpha(j_act_orb,j_act_orb,1) + print*,one_body_dm_mo_alpha(j_act_orb,j_act_orb,1),one_body_dm_mo_beta(j_act_orb,j_act_orb,1) + enddo + print*,'accu = ',accu + end diff --git a/plugins/MRPT/NEEDED_CHILDREN_MODULES b/plugins/MRPT/NEEDED_CHILDREN_MODULES index 041b0136..7340c609 100644 --- a/plugins/MRPT/NEEDED_CHILDREN_MODULES +++ b/plugins/MRPT/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -MRPT_Utils Selectors_full Psiref_CAS Generators_CAS +MRPT_Utils Selectors_full Generators_full diff --git a/plugins/MRPT/print_1h2p.irp.f b/plugins/MRPT/print_1h2p.irp.f index f20f12b6..d10e1fb5 100644 --- a/plugins/MRPT/print_1h2p.irp.f +++ b/plugins/MRPT/print_1h2p.irp.f @@ -6,53 +6,46 @@ program print_1h2p end subroutine routine - implicit none - provide one_anhil_one_creat_inact_virt - -end - -subroutine routine_2 - implicit none - integer :: i,j,degree - double precision :: hij - do i =1, n_core_inact_orb - write(*,'(I3,x,100(F16.10,X))')list_core_inact(i),fock_core_inactive_total_spin_trace(list_core_inact(i),1) - enddo - print*,'' - do i =1, n_virt_orb - write(*,'(I3,x,100(F16.10,X))')list_virt(i),fock_virt_total_spin_trace(list_virt(i),1) - enddo - stop - do i = 1, n_virt_orb - do j = 1, n_inact_orb - if(dabs(one_anhil_one_creat_inact_virt(j,i,1)) .lt. 1.d-10)cycle - write(*,'(I3,x,I3,X,100(F16.10,X))')list_virt(i),list_inact(j),one_anhil_one_creat_inact_virt(j,i,1) - enddo - enddo - - -end - -subroutine routine_3 implicit none double precision,allocatable :: matrix_1h2p(:,:,:) - double precision :: accu(2) - allocate (matrix_1h2p(N_det_ref,N_det_ref,N_states)) + allocate (matrix_1h2p(N_det,N_det,N_states)) integer :: i,j,istate - accu = 0.d0 - matrix_1h2p = 0.d0 -!call H_apply_mrpt_1h2p(matrix_1h2p,N_det_ref) - call give_1h2p_contrib(matrix_1h2p) - do istate = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(istate) += matrix_1h2p(i,j,istate) * psi_coef(i,istate) * psi_coef(j,istate) + do i = 1, N_det + do j = 1, N_det + do istate = 1, N_states + matrix_1h2p(i,j,istate) = 0.d0 enddo enddo - print*,accu(istate) enddo - call contrib_1h2p_dm_based(accu) - print*,accu(:) + if(.False.)then + call give_1h2p_contrib(matrix_1h2p) + double precision :: accu + accu = 0.d0 + do i = 1, N_det + do j = 1, N_det + accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1) + enddo + enddo + print*, 'second order ', accu + endif + + if(.True.)then + do i = 1, N_det + do j = 1, N_det + do istate = 1, N_states + matrix_1h2p(i,j,istate) = 0.d0 + enddo + enddo + enddo + call give_1h2p_new(matrix_1h2p) + accu = 0.d0 + do i = 1, N_det + do j = 1, N_det + accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1) + enddo + enddo + endif + print*, 'third order ', accu deallocate (matrix_1h2p) end diff --git a/plugins/MRPT_Utils/EZFIO.cfg b/plugins/MRPT_Utils/EZFIO.cfg index cb16fcea..2fcc26ad 100644 --- a/plugins/MRPT_Utils/EZFIO.cfg +++ b/plugins/MRPT_Utils/EZFIO.cfg @@ -5,10 +5,3 @@ interface: ezfio,provider,ocaml default: True -[save_heff_eigenvectors] -type: logical -doc: If true, save the eigenvectors of the dressed matrix at the end of the MRPT calculation -interface: ezfio,provider,ocaml -default: False - - diff --git a/plugins/MRPT_Utils/H_apply.irp.f b/plugins/MRPT_Utils/H_apply.irp.f index a7adc480..6f17ab05 100644 --- a/plugins/MRPT_Utils/H_apply.irp.f +++ b/plugins/MRPT_Utils/H_apply.irp.f @@ -23,7 +23,6 @@ print s s = H_apply("mrpt_1h") s.filter_only_1h() -s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -44,7 +43,6 @@ print s s = H_apply("mrpt_1p") s.filter_only_1p() -s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -65,7 +63,6 @@ print s s = H_apply("mrpt_1h1p") s.filter_only_1h1p() -s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -86,7 +83,6 @@ print s s = H_apply("mrpt_2p") s.filter_only_2p() -s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -107,7 +103,6 @@ print s s = H_apply("mrpt_2h") s.filter_only_2h() -s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -129,7 +124,6 @@ print s s = H_apply("mrpt_1h2p") s.filter_only_1h2p() -s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -150,7 +144,6 @@ print s s = H_apply("mrpt_2h1p") s.filter_only_2h1p() -s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -171,7 +164,6 @@ print s s = H_apply("mrpt_2h2p") s.filter_only_2h2p() -s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet diff --git a/plugins/MRPT_Utils/MRMP2_density.irp.f b/plugins/MRPT_Utils/MRMP2_density.irp.f deleted file mode 100644 index 1051edf9..00000000 --- a/plugins/MRPT_Utils/MRMP2_density.irp.f +++ /dev/null @@ -1,46 +0,0 @@ -BEGIN_PROVIDER [double precision, MRMP2_density, (mo_tot_num_align, mo_tot_num)] - implicit none - integer :: i,j,k,l - double precision :: accu, mp2_dm(mo_tot_num) - MRMP2_density = one_body_dm_mo - call give_2h2p_density(mp2_dm) - accu = 0.d0 - do i = 1, n_virt_orb - j = list_virt(i) - accu += mp2_dm(j) - MRMP2_density(j,j)+= mp2_dm(j) - enddo - -END_PROVIDER - -subroutine give_2h2p_density(mp2_density_diag_alpha_beta) - implicit none - double precision, intent(out) :: mp2_density_diag_alpha_beta(mo_tot_num) - integer :: i,j,k,l,m - integer :: iorb,jorb,korb,lorb - - double precision :: get_mo_bielec_integral - double precision :: direct_int - double precision :: coef_double - - mp2_density_diag_alpha_beta = 0.d0 - do k = 1, n_virt_orb - korb = list_virt(k) - do i = 1, n_inact_orb - iorb = list_inact(i) - do j = 1, n_inact_orb - jorb = list_inact(j) - do l = 1, n_virt_orb - lorb = list_virt(l) - direct_int = get_mo_bielec_integral(iorb,jorb,korb,lorb ,mo_integrals_map) - coef_double = direct_int/(fock_core_inactive_total_spin_trace(iorb,1) + fock_core_inactive_total_spin_trace(jorb,1) & - -fock_virt_total_spin_trace(korb,1) - fock_virt_total_spin_trace(lorb,1)) - mp2_density_diag_alpha_beta(korb) += coef_double * coef_double - enddo - enddo - enddo - print*, mp2_density_diag_alpha_beta(korb) - enddo - -end - diff --git a/plugins/MRPT_Utils/density_matrix_based.irp.f b/plugins/MRPT_Utils/density_matrix_based.irp.f deleted file mode 100644 index ac135807..00000000 --- a/plugins/MRPT_Utils/density_matrix_based.irp.f +++ /dev/null @@ -1,193 +0,0 @@ -subroutine contrib_1h2p_dm_based(accu) - implicit none - integer :: i_i,i_r,i_v,i_a,i_b - integer :: i,r,v,a,b - integer :: ispin,jspin - integer :: istate - double precision, intent(out) :: accu(N_states) - double precision :: active_int(n_act_orb,2) - double precision :: delta_e(n_act_orb,2,N_states) - double precision :: get_mo_bielec_integral - accu = 0.d0 -!do i_i = 1, 1 - do i_i = 1, n_inact_orb - i = list_inact(i_i) -! do i_r = 1, 1 - do i_r = 1, n_virt_orb - r = list_virt(i_r) -! do i_v = 1, 1 - do i_v = 1, n_virt_orb - v = list_virt(i_v) - do i_a = 1, n_act_orb - a = list_act(i_a) - active_int(i_a,1) = get_mo_bielec_integral(i,a,r,v,mo_integrals_map) ! direct - active_int(i_a,2) = get_mo_bielec_integral(i,a,v,r,mo_integrals_map) ! exchange - do istate = 1, N_states - do jspin=1, 2 - delta_e(i_a,jspin,istate) = one_anhil(i_a,jspin,istate) & - - fock_virt_total_spin_trace(r,istate) & - - fock_virt_total_spin_trace(v,istate) & - + fock_core_inactive_total_spin_trace(i,istate) - delta_e(i_a,jspin,istate) = 1.d0/delta_e(i_a,jspin,istate) - enddo - enddo - enddo - do i_a = 1, n_act_orb - a = list_act(i_a) - do i_b = 1, n_act_orb -! do i_b = i_a, i_a - b = list_act(i_b) - do ispin = 1, 2 ! spin of (i --> r) - do jspin = 1, 2 ! spin of (a --> v) - if(ispin == jspin .and. r.le.v)cycle ! condition not to double count - do istate = 1, N_states - if(ispin == jspin)then - accu(istate) += (active_int(i_a,1) - active_int(i_a,2)) * one_body_dm_mo_spin_index(a,b,istate,ispin) & - * (active_int(i_b,1) - active_int(i_b,2)) & - * delta_e(i_a,jspin,istate) - else - accu(istate) += active_int(i_a,1) * one_body_dm_mo_spin_index(a,b,istate,ispin) * delta_e(i_a,ispin,istate) & - * active_int(i_b,1) - endif - enddo - enddo - enddo - enddo - enddo - enddo - enddo - enddo - - -end - -subroutine contrib_2h1p_dm_based(accu) - implicit none - integer :: i_i,i_j,i_v,i_a,i_b - integer :: i,j,v,a,b - integer :: ispin,jspin - integer :: istate - double precision, intent(out) :: accu(N_states) - double precision :: active_int(n_act_orb,2) - double precision :: delta_e(n_act_orb,2,N_states) - double precision :: get_mo_bielec_integral - accu = 0.d0 - do i_i = 1, n_inact_orb - i = list_inact(i_i) - do i_j = 1, n_inact_orb - j = list_inact(i_j) - do i_v = 1, n_virt_orb - v = list_virt(i_v) - do i_a = 1, n_act_orb - a = list_act(i_a) - active_int(i_a,1) = get_mo_bielec_integral(i,j,v,a,mo_integrals_map) ! direct - active_int(i_a,2) = get_mo_bielec_integral(i,j,a,v,mo_integrals_map) ! exchange - do istate = 1, N_states - do jspin=1, 2 -! delta_e(i_a,jspin,istate) = -! - delta_e(i_a,jspin,istate) = one_creat(i_a,jspin,istate) - fock_virt_total_spin_trace(v,istate) & - + fock_core_inactive_total_spin_trace(i,istate) & - + fock_core_inactive_total_spin_trace(j,istate) - delta_e(i_a,jspin,istate) = 1.d0/delta_e(i_a,jspin,istate) - enddo - enddo - enddo - do i_a = 1, n_act_orb - a = list_act(i_a) - do i_b = 1, n_act_orb -! do i_b = i_a, i_a - b = list_act(i_b) - do ispin = 1, 2 ! spin of (i --> v) - do jspin = 1, 2 ! spin of (j --> a) - if(ispin == jspin .and. i.le.j)cycle ! condition not to double count - do istate = 1, N_states - if(ispin == jspin)then - accu(istate) += (active_int(i_a,1) - active_int(i_a,2)) * one_body_dm_dagger_mo_spin_index(a,b,istate,ispin) & - * (active_int(i_b,1) - active_int(i_b,2)) & - * delta_e(i_a,jspin,istate) - else - accu(istate) += active_int(i_a,1) * one_body_dm_dagger_mo_spin_index(a,b,istate,ispin) * delta_e(i_a,ispin,istate) & - * active_int(i_b,1) - endif - enddo - enddo - enddo - enddo - enddo - enddo - enddo - enddo - - -end - - -subroutine contrib_2p_dm_based(accu) - implicit none - integer :: i_r,i_v,i_a,i_b,i_c,i_d - integer :: r,v,a,b,c,d - integer :: ispin,jspin - integer :: istate - double precision, intent(out) :: accu(N_states) - double precision :: active_int(n_act_orb,n_act_orb,2) - double precision :: delta_e(n_act_orb,n_act_orb,2,2,N_states) - double precision :: get_mo_bielec_integral - accu = 0.d0 - do i_r = 1, n_virt_orb - r = list_virt(i_r) - do i_v = 1, n_virt_orb - v = list_virt(i_v) - do i_a = 1, n_act_orb - a = list_act(i_a) - do i_b = 1, n_act_orb - b = list_act(i_b) - active_int(i_a,i_b,1) = get_mo_bielec_integral(a,b,r,v,mo_integrals_map) ! direct - active_int(i_a,i_b,2) = get_mo_bielec_integral(a,b,v,r,mo_integrals_map) ! direct - do istate = 1, N_states - do jspin=1, 2 ! spin of i_a - do ispin = 1, 2 ! spin of i_b - delta_e(i_a,i_b,jspin,ispin,istate) = two_anhil(i_a,i_b,jspin,ispin,istate) & - - fock_virt_total_spin_trace(r,istate) & - - fock_virt_total_spin_trace(v,istate) - delta_e(i_a,i_b,jspin,ispin,istate) = 1.d0/delta_e(i_a,i_b,jspin,ispin,istate) - enddo - enddo - enddo - enddo - enddo - ! diagonal terms - do i_a = 1, n_act_orb - a = list_act(i_a) - do i_b = 1, n_act_orb - b = list_act(i_b) - do ispin = 1, 2 ! spin of (a --> r) - do jspin = 1, 2 ! spin of (b --> v) - if(ispin == jspin .and. r.le.v)cycle ! condition not to double count - if(ispin == jspin .and. a.le.b)cycle ! condition not to double count - do istate = 1, N_states - if(ispin == jspin)then - double precision :: contrib_spin - if(ispin == 1)then - contrib_spin = two_body_dm_aa_diag_act(i_a,i_b) - else - contrib_spin = two_body_dm_bb_diag_act(i_a,i_b) - endif - accu(istate) += (active_int(i_a,i_b,1) - active_int(i_a,i_b,2)) * contrib_spin & - * (active_int(i_a,i_b,1) - active_int(i_a,i_b,2)) & - * delta_e(i_a,i_b,ispin,jspin,istate) - else - accu(istate) += 0.5d0 * active_int(i_a,i_b,1) * two_body_dm_ab_diag_act(i_a,i_b) * delta_e(i_a,i_b,ispin,jspin,istate) & - * active_int(i_a,i_b,1) - endif - enddo - enddo - enddo - enddo - enddo - enddo - enddo - - -end - diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f index e8d19166..dd79edbe 100644 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -1,9 +1,9 @@ BEGIN_PROVIDER [ double precision, energy_cas_dyall, (N_states)] implicit none integer :: i - double precision :: energies(N_states) + double precision :: energies(N_states_diag) do i = 1, N_states - call u0_H_dyall_u0(energies,psi_active,psi_ref_coef,n_det_ref,psi_det_size,psi_det_size,N_states,i) + call u0_H_dyall_u0(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i) energy_cas_dyall(i) = energies(i) print*, 'energy_cas_dyall(i)', energy_cas_dyall(i) enddo @@ -13,72 +13,38 @@ END_PROVIDER BEGIN_PROVIDER [ double precision, energy_cas_dyall_no_exchange, (N_states)] implicit none integer :: i - double precision :: energies(N_states) + double precision :: energies(N_states_diag) do i = 1, N_states - call u0_H_dyall_u0_no_exchange(energies,psi_active,psi_ref_coef,n_det_ref,psi_det_size,psi_det_size,N_states,i) + call u0_H_dyall_u0_no_exchange(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i) energy_cas_dyall_no_exchange(i) = energies(i) print*, 'energy_cas_dyall(i)_no_exchange', energy_cas_dyall_no_exchange(i) enddo END_PROVIDER -BEGIN_PROVIDER [ double precision, energy_cas_dyall_no_exchange_bis, (N_states)] - implicit none - integer :: i,j - double precision :: energies(N_states) - integer(bit_kind), allocatable :: psi_in_ref(:,:,:) - allocate (psi_in_ref(N_int,2,n_det_ref)) - integer(bit_kind), allocatable :: psi_in_active(:,:,:) - allocate (psi_in_active(N_int,2,n_det_ref)) - double precision, allocatable :: psi_ref_coef_in(:, :) - allocate(psi_ref_coef_in(N_det_ref, N_states)) - - do i = 1, N_det_ref - do j = 1, N_int - psi_in_ref(j,1,i) = psi_ref(j,1,i) - psi_in_ref(j,2,i) = psi_ref(j,2,i) - - psi_in_active(j,1,i) = psi_active(j,1,i) - psi_in_active(j,2,i) = psi_active(j,2,i) - enddo - do j = 1, N_states - psi_ref_coef_in(i,j) = psi_ref_coef(i,j) - enddo - enddo - do i = 1, N_states - call u0_H_dyall_u0_no_exchange_bis(energies,psi_in_ref,psi_ref_coef_in,n_det_ref,n_det_ref,n_det_ref,N_states,i) - energy_cas_dyall_no_exchange_bis(i) = energies(i) - print*, 'energy_cas_dyall(i)_no_exchange_bis', energy_cas_dyall_no_exchange_bis(i) - enddo - deallocate (psi_in_ref) - deallocate (psi_in_active) - deallocate(psi_ref_coef_in) -END_PROVIDER - - BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] implicit none integer :: i,j integer :: ispin integer :: orb, hole_particle,spin_exc - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) use bitmasks integer :: iorb integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb = list_act(iorb) hole_particle = 1 spin_exc = ispin - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -87,9 +53,9 @@ BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] enddo do state_target = 1,N_states call apply_exc_to_psi(orb,hole_particle,spin_exc, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - one_creat(iorb,ispin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + one_creat(iorb,ispin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -102,23 +68,23 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] integer :: i,j integer :: ispin integer :: orb, hole_particle,spin_exc - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb = list_act(iorb) hole_particle = -1 spin_exc = ispin - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -127,9 +93,9 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] enddo do state_target = 1, N_states call apply_exc_to_psi(orb,hole_particle,spin_exc, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - one_anhil(iorb,ispin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + one_anhil(iorb,ispin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -143,15 +109,15 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) integer :: ispin,jspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -162,9 +128,9 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) orb_j = list_act(jorb) hole_particle_j = 1 spin_exc_j = jspin - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -173,11 +139,11 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) enddo do state_target = 1 , N_states call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - two_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + two_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -193,16 +159,16 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) integer :: ispin,jspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: state_target state_target = 1 - double precision :: energies(n_states) + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -213,23 +179,21 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) orb_j = list_act(jorb) hole_particle_j = -1 spin_exc_j = jspin - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) psi_in_out(j,2,i) = psi_active(j,2,i) enddo enddo - do state_target = 1 , N_states - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - two_anhil(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) - enddo + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + two_anhil(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -244,15 +208,15 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 integer :: ispin,jspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -263,9 +227,9 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 orb_j = list_act(jorb) hole_particle_j = -1 spin_exc_j = jspin - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -274,16 +238,16 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 enddo do state_target = 1, N_states call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - !if(orb_i == orb_j .and. ispin .ne. jspin)then - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + if(orb_i == orb_j .and. ispin .ne. jspin)then + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) - !else - ! call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - ! one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) - !endif + else + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + endif enddo enddo enddo @@ -293,24 +257,23 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 END_PROVIDER - BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] -&BEGIN_PROVIDER [ double precision, two_anhil_one_creat_norm, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] +BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] implicit none integer :: i,j integer :: ispin,jspin,kspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -326,9 +289,9 @@ END_PROVIDER orb_k = list_act(korb) hole_particle_k = -1 spin_exc_k = kspin - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -338,14 +301,13 @@ END_PROVIDER do state_target = 1, N_states call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - two_anhil_one_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) - two_anhil_one_creat_norm(iorb,jorb,korb,ispin,jspin,kspin,state_target) = norm_out(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + two_anhil_one_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -357,70 +319,23 @@ END_PROVIDER END_PROVIDER - - BEGIN_PROVIDER [ double precision, two_anhil_one_creat_spin_average, (n_act_orb,n_act_orb,n_act_orb,N_states)] +BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] implicit none integer :: i,j integer :: ispin,jspin,kspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states) - double precision :: accu - do iorb = 1,n_act_orb - orb_i = list_act(iorb) - do jorb = 1, n_act_orb - orb_j = list_act(jorb) - do korb = 1, n_act_orb - orb_k = list_act(korb) - do state_target = 1, N_states - accu = 0.d0 - do ispin = 1,2 - do jspin = 1,2 - do kspin = 1,2 - two_anhil_one_creat_spin_average(iorb,jorb,korb,state_target) += two_anhil_one_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target)* & - two_anhil_one_creat_norm(iorb,jorb,korb,ispin,jspin,kspin,state_target) - accu += two_anhil_one_creat_norm(iorb,jorb,korb,ispin,jspin,kspin,state_target) - enddo - enddo - enddo - two_anhil_one_creat_spin_average(iorb,jorb,korb,state_target) = two_anhil_one_creat_spin_average(iorb,jorb,korb,state_target) /accu - enddo - enddo - enddo - enddo - deallocate(psi_in_out,psi_in_out_coef) - -END_PROVIDER - - - BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] -&BEGIN_PROVIDER [ double precision, two_creat_one_anhil_norm, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] -implicit none - integer :: i,j - integer :: ispin,jspin,kspin - integer :: orb_i, hole_particle_i,spin_exc_i - integer :: orb_j, hole_particle_j,spin_exc_j - integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) - - integer :: iorb,jorb - integer :: korb - integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -436,27 +351,24 @@ implicit none orb_k = list_act(korb) hole_particle_k = -1 spin_exc_k = kspin - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) psi_in_out(j,2,i) = psi_active(j,2,i) enddo enddo - - do state_target = 1, N_states - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + do state_target = 1, N_states call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) - two_creat_one_anhil_norm(iorb,jorb,korb,ispin,jspin,kspin,state_target) = norm_out(state_target) -! print*, norm_out(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -468,136 +380,6 @@ implicit none END_PROVIDER - - BEGIN_PROVIDER [ double precision, two_creat_one_anhil_spin_average, (n_act_orb,n_act_orb,n_act_orb,N_states)] -implicit none - integer :: i,j - integer :: ispin,jspin,kspin - integer :: orb_i, hole_particle_i,spin_exc_i - integer :: orb_j, hole_particle_j,spin_exc_j - integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) - - integer :: iorb,jorb - integer :: korb - integer :: state_target - double precision :: energies(n_states),accu - do iorb = 1,n_act_orb - orb_i = list_act(iorb) - do jorb = 1, n_act_orb - orb_j = list_act(jorb) - do korb = 1, n_act_orb - orb_k = list_act(korb) - do state_target = 1, N_states - accu = 0.d0 - do ispin = 1,2 - do jspin = 1,2 - do kspin = 1,2 - two_creat_one_anhil_spin_average(iorb,jorb,korb,state_target) += two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) * & - two_creat_one_anhil_norm(iorb,jorb,korb,ispin,jspin,kspin,state_target) - accu += two_creat_one_anhil_norm(iorb,jorb,korb,ispin,jspin,kspin,state_target) - print*, accu - enddo - enddo - enddo - two_creat_one_anhil_spin_average(iorb,jorb,korb,state_target) = two_creat_one_anhil_spin_average(iorb,jorb,korb,state_target) / accu - enddo - enddo - enddo - enddo - deallocate(psi_in_out,psi_in_out_coef) - -END_PROVIDER - -!BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_act_orb,N_states)] -!implicit none -!integer :: i,j -!integer :: ispin,jspin,kspin -!integer :: orb_i, hole_particle_i,spin_exc_i -!integer :: orb_j, hole_particle_j,spin_exc_j -!integer :: orb_k, hole_particle_k,spin_exc_k -!double precision :: norm_out(N_states) -!integer(bit_kind), allocatable :: psi_in_out(:,:,:) -!double precision, allocatable :: psi_in_out_coef(:,:) -!use bitmasks -!allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) - -!integer :: iorb,jorb -!integer :: korb -!integer :: state_target -!double precision :: energies(n_states) -!double precision :: norm_spins(2,2,N_states), energies_spins(2,2,N_states) -!double precision :: thresh_norm -!thresh_norm = 1.d-10 -!do iorb = 1,n_act_orb -! orb_i = list_act(iorb) -! hole_particle_i = 1 -! do jorb = 1, n_act_orb -! orb_j = list_act(jorb) -! hole_particle_j = 1 -! do korb = 1, n_act_orb -! orb_k = list_act(korb) -! hole_particle_k = -1 - -! ! loop on the spins -! ! By definition, orb_i is the particle of spin ispin -! ! a^+_{ispin , orb_i} -! do ispin = 1, 2 -! do jspin = 1, 2 -! ! By definition, orb_j and orb_k are the couple of particle/hole of spin jspin -! ! a^+_{jspin , orb_j} a_{jspin , orb_k} -! ! norm_spins(ispin,jspin) :: norm of the wave function a^+_{ispin , orb_i} a^+_{jspin , orb_j} a_{jspin , orb_k} | Psi > -! ! energies_spins(ispin,jspin) :: Dyall energu of the wave function a^+_{ispin , orb_i} a^+_{jspin , orb_j} a_{jspin , orb_k} | Psi > -! do i = 1, n_det_ref -! do j = 1, n_states -! psi_in_out_coef(i,j) = psi_ref_coef(i,j) -! enddo -! do j = 1, N_int -! psi_in_out(j,1,i) = psi_active(j,1,i) -! psi_in_out(j,2,i) = psi_active(j,2,i) -! enddo -! enddo -! do state_target = 1, N_states -! ! hole :: hole_particle_k, jspin -! call apply_exc_to_psi(orb_k,hole_particle_k,jspin, & -! norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) -! call apply_exc_to_psi(orb_j,hole_particle_j,jspin, & -! norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) -! call apply_exc_to_psi(orb_i,hole_particle_i,ispin, & -! norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) -! if(dabs(norm_out(state_target)).lt.thresh_norm)then -! norm_spins(ispin,jspin,state_target) = 0.d0 -! else -! norm_spins(ispin,jspin,state_target) = 1.d0 -! endif -! call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) -! energies_spins(ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) -! enddo -! enddo -! enddo -! integer :: icount -! ! averaging over all possible spin permutations with Heaviside norm -! do state_target = 1, N_states -! icount = 0 -! do jspin = 1, 2 -! do ispin = 1, 2 -! icount += 1 -! two_creat_one_anhil(iorb,jorb,korb,state_target) = energies_spins(ispin,jspin,state_target) * norm_spins(ispin,jspin,state_target) -! enddo -! enddo -! two_creat_one_anhil(iorb,jorb,korb,state_target) = two_creat_one_anhil(iorb,jorb,korb,state_target) / dble(icount) -! enddo -! enddo -! enddo -!enddo -!deallocate(psi_in_out,psi_in_out_coef) - -!END_PROVIDER - BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] implicit none integer :: i,j @@ -605,16 +387,16 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -630,9 +412,9 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 orb_k = list_act(korb) hole_particle_k = 1 spin_exc_k = kspin - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -641,13 +423,13 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 enddo do state_target = 1, N_states call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - three_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + three_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -666,16 +448,16 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -691,9 +473,9 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 orb_k = list_act(korb) hole_particle_k = -1 spin_exc_k = kspin - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -702,13 +484,13 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 enddo do state_target = 1, N_states call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - three_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + three_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -729,32 +511,24 @@ END_PROVIDER integer :: ispin,jspin integer :: orb_i, hole_particle_i integer :: orb_v - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) - integer(bit_kind), allocatable :: psi_in_active(:,:,:) - allocate (psi_in_active(N_int,2,n_det_ref)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb,i_ok integer :: state_target - double precision :: energies(n_states) - double precision :: hij,hij_test + double precision :: energies(n_states_diag) + double precision :: hij double precision :: norm(N_states,2),norm_no_inv(N_states,2),norm_bis(N_states,2) double precision :: energies_alpha_beta(N_states,2) double precision :: thresh_norm - integer :: other_spin(2) - other_spin(1) = 2 - other_spin(2) = 1 - thresh_norm = 1.d-20 + thresh_norm = 1.d-10 -!do i = 1, N_det_ref -! print*, psi_ref_coef(i,1) -!enddo do vorb = 1,n_virt_orb @@ -767,10 +541,10 @@ END_PROVIDER do state_target =1 , N_states one_anhil_one_creat_inact_virt_norm(iorb,vorb,state_target,ispin) = 0.d0 enddo - do i = 1, n_det_ref + do i = 1, n_det do j = 1, N_int - psi_in_out(j,1,i) = psi_ref(j,1,i) - psi_in_out(j,2,i) = psi_ref(j,2,i) + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) if(i_ok.ne.1)then @@ -778,12 +552,11 @@ END_PROVIDER call debug_det(psi_in_out,N_int) print*, 'pb, i_ok ne 0 !!!' endif - call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij) - integer :: exc(0:2,2,2) - double precision :: phase - call get_mono_excitation(psi_in_out(1,1,i),psi_ref(1,1,i),exc,phase,N_int) + call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j)* hij * phase + double precision :: coef,contrib + coef = psi_coef(i,j) !* psi_coef(i,j) + psi_in_out_coef(i,j) = sign(coef,psi_coef(i,j)) * hij norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) enddo enddo @@ -794,36 +567,38 @@ END_PROVIDER one_anhil_one_creat_inact_virt_norm(iorb,vorb,j,ispin) = 0.d0 else norm_no_inv(j,ispin) = norm(j,ispin) + one_anhil_one_creat_inact_virt_norm(iorb,vorb,j,ispin) = 1.d0 / norm(j,ispin) norm(j,ispin) = 1.d0/dsqrt(norm(j,ispin)) endif enddo - integer :: iorb_annil,hole_particle,spin_exc,orb - double precision :: norm_out_bis(N_states) - do i = 1, N_det_ref + do i = 1, N_det do j = 1, N_states psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm(j,ispin) norm_bis(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) enddo - enddo - - do i = 1, N_det_ref do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) psi_in_out(j,2,i) = psi_active(j,2,i) enddo enddo do state_target = 1, N_states - energies_alpha_beta(state_target, ispin) = 0.d0 + energies_alpha_beta(state_target, ispin) = - mo_bielec_integral_jj_exchange(orb_i,orb_v) +! energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif enddo enddo ! ispin do state_target = 1, N_states if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then - one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = energy_cas_dyall_no_exchange(state_target) - & - ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & +! one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = 0.5d0 * & +! ( energy_cas_dyall(state_target) - energies_alpha_beta(state_target,1) + & +! energy_cas_dyall(state_target) - energies_alpha_beta(state_target,2) ) +! print*, energies_alpha_beta(state_target,1) , energies_alpha_beta(state_target,2) +! print*, norm_bis(state_target,1) , norm_bis(state_target,2) + one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = energy_cas_dyall(state_target) - & + ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & /( norm_bis(state_target,1) + norm_bis(state_target,2) ) else one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = 0.d0 @@ -841,15 +616,15 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta integer :: i,iorb,j integer :: ispin,jspin integer :: orb_i, hole_particle_i - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: jorb,i_ok,aorb,orb_a integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) double precision :: hij double precision :: norm(N_states,2),norm_no_inv(N_states,2) double precision :: energies_alpha_beta(N_states,2) @@ -857,7 +632,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta double precision :: thresh_norm - thresh_norm = 1.d-20 + thresh_norm = 1.d-10 do aorb = 1,n_act_orb orb_a = list_act(aorb) @@ -870,10 +645,10 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta norm = 0.d0 norm_bis = 0.d0 do ispin = 1,2 - do i = 1, n_det_ref + do i = 1, n_det do j = 1, N_int - psi_in_out(j,1,i) = psi_ref(j,1,i) - psi_in_out(j,2,i) = psi_ref(j,2,i) + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_a,ispin,i_ok) if(i_ok.ne.1)then @@ -881,11 +656,11 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta psi_in_out_coef(i,j) = 0.d0 enddo else - call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij) + call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) do j = 1, n_states double precision :: coef,contrib - coef = psi_ref_coef(i,j) !* psi_ref_coef(i,j) - psi_in_out_coef(i,j) = sign(coef,psi_ref_coef(i,j)) * hij + coef = psi_coef(i,j) !* psi_coef(i,j) + psi_in_out_coef(i,j) = sign(coef,psi_coef(i,j)) * hij norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) enddo endif @@ -900,7 +675,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta endif enddo double precision :: norm_bis(N_states,2) - do i = 1, N_det_ref + do i = 1, N_det do j = 1, N_states psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm(j,ispin) norm_bis(j,ispin) += psi_in_out_coef(i,j)* psi_in_out_coef(i,j) @@ -913,20 +688,24 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta do state_target = 1, N_states energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif enddo enddo ! ispin do state_target = 1, N_states if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then -! one_anhil_inact(iorb,aorb,state_target) = energy_cas_dyall(state_target) - & - one_anhil_inact(iorb,aorb,state_target) = energy_cas_dyall_no_exchange(state_target) - & + one_anhil_inact(iorb,aorb,state_target) = energy_cas_dyall(state_target) - & ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & /( norm_bis(state_target,1) + norm_bis(state_target,2) ) else one_anhil_inact(iorb,aorb,state_target) = 0.d0 endif +! print*, '********' +! print*, energies_alpha_beta(state_target,1) , energies_alpha_beta(state_target,2) +! print*, norm_bis(state_target,1) , norm_bis(state_target,2) +! print*, one_anhil_inact(iorb,aorb,state_target) +! print*, one_creat(aorb,1,state_target) enddo enddo enddo @@ -940,15 +719,15 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State integer :: ispin,jspin integer :: orb_i, hole_particle_i integer :: orb_v - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb,i_ok,aorb,orb_a integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) double precision :: hij double precision :: norm(N_states,2),norm_no_inv(N_states,2) double precision :: energies_alpha_beta(N_states,2) @@ -956,7 +735,7 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State double precision :: thresh_norm - thresh_norm = 1.d-20 + thresh_norm = 1.d-10 do aorb = 1,n_act_orb orb_a = list_act(aorb) @@ -969,10 +748,10 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State norm = 0.d0 norm_bis = 0.d0 do ispin = 1,2 - do i = 1, n_det_ref + do i = 1, n_det do j = 1, N_int - psi_in_out(j,1,i) = psi_ref(j,1,i) - psi_in_out(j,2,i) = psi_ref(j,2,i) + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_a,orb_v,ispin,i_ok) if(i_ok.ne.1)then @@ -980,21 +759,16 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State psi_in_out_coef(i,j) = 0.d0 enddo else - call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij) + call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) do j = 1, n_states - double precision :: contrib - psi_in_out_coef(i,j) = psi_ref_coef(i,j) * hij + double precision :: coef,contrib + coef = psi_coef(i,j) !* psi_coef(i,j) + psi_in_out_coef(i,j) = sign(coef,psi_coef(i,j)) * hij norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) - !if(orb_a == 6 .and. orb_v == 12)then - ! print*, j,psi_ref_coef(i,j),psi_in_out_coef(i,j) - !endif enddo endif enddo do j = 1, N_states -! if(orb_a == 6 .and. orb_v == 12)then -! print*, 'norm',norm(j,ispin) -! endif if (dabs(norm(j,ispin)) .le. thresh_norm)then norm(j,ispin) = 0.d0 norm_no_inv(j,ispin) = norm(j,ispin) @@ -1004,7 +778,7 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State endif enddo double precision :: norm_bis(N_states,2) - do i = 1, N_det_ref + do i = 1, N_det do j = 1, N_states psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm(j,ispin) norm_bis(j,ispin) += psi_in_out_coef(i,j)* psi_in_out_coef(i,j) @@ -1017,18 +791,18 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State do state_target = 1, N_states energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) +! print*, energies(state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif enddo enddo ! ispin do state_target = 1, N_states if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then - one_creat_virt(aorb,vorb,state_target) = energy_cas_dyall_no_exchange(state_target) - & + one_creat_virt(aorb,vorb,state_target) = energy_cas_dyall(state_target) - & ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & /( norm_bis(state_target,1) + norm_bis(state_target,2) ) else -! one_creat_virt(aorb,vorb,state_target) = 0.5d0 * (one_anhil(aorb, 1,state_target) + one_anhil(aorb, 2,state_target) ) one_creat_virt(aorb,vorb,state_target) = 0.d0 endif ! print*, '********' @@ -1043,54 +817,50 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State END_PROVIDER -subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from_1h1p_singles) + + BEGIN_PROVIDER [ double precision, one_anhil_one_creat_inact_virt_bis, (n_inact_orb,n_virt_orb,N_det,N_States)] +&BEGIN_PROVIDER [ double precision, corr_e_from_1h1p, (N_States)] implicit none - double precision , intent(inout) :: matrix_1h1p(N_det_ref,N_det_ref,N_states) - double precision , intent(out) :: e_corr_from_1h1p_singles(N_states) integer :: i,vorb,j integer :: ispin,jspin integer :: orb_i, hole_particle_i integer :: orb_v - double precision :: norm_out(N_states),diag_elem(N_det_ref),interact_psi0(N_det_ref) + double precision :: norm_out(N_states_diag),diag_elem(N_det),interact_psi0(N_det) double precision :: delta_e_inact_virt(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) - double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:),interact_cas(:,:) - double precision, allocatable :: delta_e_det(:,:) + double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states),H_matrix(N_det_ref+1,N_det_ref+1)) - allocate (eigenvectors(size(H_matrix,1),N_det_ref+1)) - allocate (eigenvalues(N_det_ref+1),interact_cas(N_det_ref,N_det_ref)) - allocate (delta_e_det(N_det_ref,N_det_ref)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag),H_matrix(N_det+1,N_det+1)) + allocate (eigenvectors(size(H_matrix,1),N_det+1)) + allocate (eigenvalues(N_det+1)) integer :: iorb,jorb,i_ok integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) double precision :: hij double precision :: energies_alpha_beta(N_states,2) - double precision :: lamda_pt2(N_det_ref) double precision :: accu(N_states),norm - double precision :: amplitudes_alpha_beta(N_det_ref,2) - double precision :: delta_e_alpha_beta(N_det_ref,2) - double precision :: coef_array(N_states) - double precision :: coef_perturb(N_det_ref) - double precision :: coef_perturb_bis(N_det_ref) + double precision :: amplitudes_alpha_beta(N_det,2) + double precision :: delta_e_alpha_beta(N_det,2) + corr_e_from_1h1p = 0.d0 do vorb = 1,n_virt_orb orb_v = list_virt(vorb) do iorb = 1, n_inact_orb orb_i = list_inact(iorb) +! print*, '---------------------------------------------------------------------------' do j = 1, N_states delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(orb_i,j) & - fock_virt_total_spin_trace(orb_v,j) enddo do ispin = 1,2 - do i = 1, n_det_ref + do i = 1, n_det do j = 1, N_int - psi_in_out(j,1,i) = psi_ref(j,1,i) - psi_in_out(j,2,i) = psi_ref(j,2,i) + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) if(i_ok.ne.1)then @@ -1099,11 +869,9 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from print*, 'pb, i_ok ne 0 !!!' endif interact_psi0(i) = 0.d0 - do j = 1 , N_det_ref - call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,j),N_int,hij) - call get_delta_e_dyall(psi_ref(1,1,j),psi_in_out(1,1,i),coef_array,hij,delta_e_det(i,j)) - interact_cas(i,j) = hij - interact_psi0(i) += hij * psi_ref_coef(j,1) + do j = 1 , N_det + call i_H_j(psi_in_out(1,1,i),psi_det(1,1,j),N_int,hij) + interact_psi0(i) += hij * psi_coef(j,1) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -1115,27 +883,181 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from do state_target = 1, N_states ! Building the Hamiltonian matrix H_matrix(1,1) = energy_cas_dyall(state_target) - do i = 1, N_det_ref + do i = 1, N_det ! interaction with psi0 - H_matrix(1,i+1) = interact_psi0(i)!* psi_ref_coef(i,state_target) - H_matrix(i+1,1) = interact_psi0(i)!* psi_ref_coef(i,state_target) + H_matrix(1,i+1) = interact_psi0(i)!* psi_coef(i,state_target) + H_matrix(i+1,1) = interact_psi0(i)!* psi_coef(i,state_target) ! diagonal elements H_matrix(i+1,i+1) = diag_elem(i) - delta_e_inact_virt(state_target) ! print*, 'H_matrix(i+1,i+1)',H_matrix(i+1,i+1) - do j = i+1, N_det_ref + do j = i+1, N_det call i_H_j_dyall(psi_in_out(1,1,i),psi_in_out(1,1,j),N_int,hij) H_matrix(i+1,j+1) = hij !0.d0 ! H_matrix(j+1,i+1) = hij !0.d0 ! enddo enddo - call lapack_diag(eigenvalues,eigenvectors,H_matrix,size(H_matrix,1),N_det_ref+1) + print*, '***' + do i = 1, N_det+1 + write(*,'(100(F16.10,1X))')H_matrix(i,:) + enddo + call lapack_diag(eigenvalues,eigenvectors,H_matrix,size(H_matrix,1),N_det+1) + corr_e_from_1h1p(state_target) += eigenvalues(1) - energy_cas_dyall(state_target) + norm = 0.d0 + do i = 1, N_det + psi_in_out_coef(i,state_target) = eigenvectors(i+1,1)/eigenvectors(1,1) +!! if(dabs(psi_coef(i,state_target)*) .gt. 1.d-8)then + if(dabs(psi_in_out_coef(i,state_target)) .gt. 1.d-8)then +! if(dabs(interact_psi0(i)) .gt. 1.d-8)then + delta_e_alpha_beta(i,ispin) = H_matrix(1,i+1) / psi_in_out_coef(i,state_target) +! delta_e_alpha_beta(i,ispin) = interact_psi0(i) / psi_in_out_coef(i,state_target) + amplitudes_alpha_beta(i,ispin) = psi_in_out_coef(i,state_target) / psi_coef(i,state_target) + else + amplitudes_alpha_beta(i,ispin) = 0.d0 + delta_e_alpha_beta(i,ispin) = delta_e_inact_virt(state_target) + endif +!! one_anhil_one_creat_inact_virt_bis(iorb,vorb,i,ispin,state_target) = amplitudes_alpha_beta(i,ispin) + norm += psi_in_out_coef(i,state_target) * psi_in_out_coef(i,state_target) + enddo + print*, 'Coef ' + write(*,'(100(1X,F16.10))')psi_coef(1:N_det,state_target) + write(*,'(100(1X,F16.10))')psi_in_out_coef(:,state_target) + double precision :: coef_tmp(N_det) + do i = 1, N_det + coef_tmp(i) = psi_coef(i,1) * interact_psi0(i) / delta_e_alpha_beta(i,ispin) + enddo + write(*,'(100(1X,F16.10))')coef_tmp(:) + print*, 'naked interactions' + write(*,'(100(1X,F16.10))')interact_psi0(:) + print*, '' + + print*, 'norm ',norm + norm = 1.d0/(norm) + accu(state_target) = 0.d0 + do i = 1, N_det + accu(state_target) += psi_in_out_coef(i,state_target) * psi_in_out_coef(i,state_target) * H_matrix(i+1,i+1) + do j = i+1, N_det + accu(state_target) += 2.d0 * psi_in_out_coef(i,state_target) * psi_in_out_coef(j,state_target) * H_matrix(i+1,j+1) + enddo + enddo + accu(state_target) = accu(state_target) * norm + print*, delta_e_inact_virt(state_target) + print*, eigenvalues(1),accu(state_target),eigenvectors(1,1) + print*, energy_cas_dyall(state_target) - accu(state_target), one_anhil_one_creat_inact_virt(iorb,vorb,state_target) + delta_e_inact_virt(state_target) + + enddo + enddo ! ispin + do state_target = 1, N_states + do i = 1, N_det + one_anhil_one_creat_inact_virt_bis(iorb,vorb,i,state_target) = 0.5d0 * & + ( delta_e_alpha_beta(i,1) + delta_e_alpha_beta(i,1)) + enddo + enddo + print*, '***' + write(*,'(100(1X,F16.10))') + write(*,'(100(1X,F16.10))')delta_e_alpha_beta(:,2) + ! write(*,'(100(1X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,1,:) + ! write(*,'(100(1X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,2,:) + print*, '---------------------------------------------------------------------------' + enddo + enddo + deallocate(psi_in_out,psi_in_out_coef,H_matrix,eigenvectors,eigenvalues) + print*, 'corr_e_from_1h1p,',corr_e_from_1h1p(:) + +END_PROVIDER + +subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from_1h1p_singles) + implicit none + double precision , intent(inout) :: matrix_1h1p(N_det,N_det,N_states) + double precision , intent(out) :: e_corr_from_1h1p_singles(N_states) + integer :: i,vorb,j + integer :: ispin,jspin + integer :: orb_i, hole_particle_i + integer :: orb_v + double precision :: norm_out(N_states_diag),diag_elem(N_det),interact_psi0(N_det) + double precision :: delta_e_inact_virt(N_states) + integer(bit_kind), allocatable :: psi_in_out(:,:,:) + double precision, allocatable :: psi_in_out_coef(:,:) + double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:),interact_cas(:,:) + double precision, allocatable :: delta_e_det(:,:) + use bitmasks + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag),H_matrix(N_det+1,N_det+1)) + allocate (eigenvectors(size(H_matrix,1),N_det+1)) + allocate (eigenvalues(N_det+1),interact_cas(N_det,N_det)) + allocate (delta_e_det(N_det,N_det)) + + integer :: iorb,jorb,i_ok + integer :: state_target + double precision :: energies(n_states_diag) + double precision :: hij + double precision :: energies_alpha_beta(N_states,2) + double precision :: lamda_pt2(N_det) + + + double precision :: accu(N_states),norm + double precision :: amplitudes_alpha_beta(N_det,2) + double precision :: delta_e_alpha_beta(N_det,2) + double precision :: coef_array(N_states) + double precision :: coef_perturb(N_det) + double precision :: coef_perturb_bis(N_det) + + do vorb = 1,n_virt_orb + orb_v = list_virt(vorb) + do iorb = 1, n_inact_orb + orb_i = list_inact(iorb) + do j = 1, N_states + delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(orb_i,j) & + - fock_virt_total_spin_trace(orb_v,j) + enddo + do ispin = 1,2 + do i = 1, n_det + do j = 1, N_int + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) + enddo + call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) + if(i_ok.ne.1)then + print*, orb_i,orb_v + call debug_det(psi_in_out,N_int) + print*, 'pb, i_ok ne 0 !!!' + endif + interact_psi0(i) = 0.d0 + do j = 1 , N_det + call i_H_j(psi_in_out(1,1,i),psi_det(1,1,j),N_int,hij) + call get_delta_e_dyall(psi_det(1,1,j),psi_in_out(1,1,i),coef_array,hij,delta_e_det(i,j)) + interact_cas(i,j) = hij + interact_psi0(i) += hij * psi_coef(j,1) + enddo + do j = 1, N_int + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,2,i) = psi_active(j,2,i) + enddo + call i_H_j_dyall(psi_active(1,1,i),psi_active(1,1,i),N_int,hij) + diag_elem(i) = hij + enddo + do state_target = 1, N_states + ! Building the Hamiltonian matrix + H_matrix(1,1) = energy_cas_dyall(state_target) + do i = 1, N_det + ! interaction with psi0 + H_matrix(1,i+1) = interact_psi0(i)!* psi_coef(i,state_target) + H_matrix(i+1,1) = interact_psi0(i)!* psi_coef(i,state_target) + ! diagonal elements + H_matrix(i+1,i+1) = diag_elem(i) - delta_e_inact_virt(state_target) +! print*, 'H_matrix(i+1,i+1)',H_matrix(i+1,i+1) + do j = i+1, N_det + call i_H_j_dyall(psi_in_out(1,1,i),psi_in_out(1,1,j),N_int,hij) + H_matrix(i+1,j+1) = hij !0.d0 ! + H_matrix(j+1,i+1) = hij !0.d0 ! + enddo + enddo + call lapack_diag(eigenvalues,eigenvectors,H_matrix,size(H_matrix,1),N_det+1) e_corr_from_1h1p_singles(state_target) += eigenvalues(1) - energy_cas_dyall(state_target) - do i = 1, N_det_ref + do i = 1, N_det psi_in_out_coef(i,state_target) = eigenvectors(i+1,1)/eigenvectors(1,1) coef_perturb(i) = 0.d0 - do j = 1, N_det_ref - coef_perturb(i) += psi_ref_coef(j,state_target) * interact_cas(i,j) *1.d0/delta_e_det(i,j) + do j = 1, N_det + coef_perturb(i) += psi_coef(j,state_target) * interact_cas(i,j) *1.d0/delta_e_det(i,j) enddo coef_perturb_bis(i) = interact_psi0(i) / (eigenvalues(1) - H_matrix(i+1,i+1)) if(dabs(interact_psi0(i)) .gt. 1.d-12)then @@ -1146,22 +1068,22 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from enddo if(dabs(eigenvalues(1) - energy_cas_dyall(state_target)).gt.1.d-10)then print*, '' - do i = 1, N_det_ref+1 + do i = 1, N_det+1 write(*,'(100(F16.10))') H_matrix(i,:) enddo accu = 0.d0 - do i = 1, N_det_ref + do i = 1, N_det accu(state_target) += psi_in_out_coef(i,state_target) * interact_psi0(i) enddo print*, '' print*, 'e corr diagonal ',accu(state_target) accu = 0.d0 - do i = 1, N_det_ref + do i = 1, N_det accu(state_target) += coef_perturb(i) * interact_psi0(i) enddo print*, 'e corr perturb ',accu(state_target) accu = 0.d0 - do i = 1, N_det_ref + do i = 1, N_det accu(state_target) += coef_perturb_bis(i) * interact_psi0(i) enddo print*, 'e corr perturb EN',accu(state_target) @@ -1174,10 +1096,10 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from write(*,'(100(F16.10,1X))')coef_perturb_bis(:) endif integer :: k - do k = 1, N_det_ref - do i = 1, N_det_ref + do k = 1, N_det + do i = 1, N_det matrix_1h1p(i,i,state_target) += interact_cas(k,i) * interact_cas(k,i) * lamda_pt2(k) - do j = i+1, N_det_ref + do j = i+1, N_det matrix_1h1p(i,j,state_target) += interact_cas(k,i) * interact_cas(k,j) * lamda_pt2(k) matrix_1h1p(j,i,state_target) += interact_cas(k,i) * interact_cas(k,j) * lamda_pt2(k) enddo diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f index 9376e0cc..491cda58 100644 --- a/plugins/MRPT_Utils/excitations_cas.irp.f +++ b/plugins/MRPT_Utils/excitations_cas.irp.f @@ -25,7 +25,6 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & integer(bit_kind) :: det_tmp(N_int), det_tmp_bis(N_int) double precision :: phase double precision :: norm_factor -! print*, orb,hole_particle,spin_exc elec_num_tab_local = 0 do i = 1, ndet @@ -37,7 +36,6 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & exit endif enddo -! print*, elec_num_tab_local(1),elec_num_tab_local(2) if(hole_particle == 1)then do i = 1, ndet call set_bit_to_integer(orb,psi_in_out(1,spin_exc,i),N_int) @@ -214,97 +212,52 @@ double precision function diag_H_mat_elem_no_elec_check(det_in,Nint) core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb) enddo enddo - -end +! print*,'core_act = ',core_act +! print*,'alpha_alpha = ',alpha_alpha +! print*,'alpha_beta = ',alpha_beta +! print*,'beta_beta = ',beta_beta +! print*,'mono_elec = ',mono_elec + +! do i = 1, n_core_inact_orb +! iorb = list_core_inact(i) +! diag_H_mat_elem_no_elec_check += 2.d0 * fock_core_inactive_total_spin_trace(iorb,1) +! enddo +!!!!!!!!!!!! +return +!!!!!!!!!!!! -double precision function diag_H_mat_elem_no_elec_check_no_spin(det_in,Nint) - implicit none - BEGIN_DOC - ! Computes - END_DOC - integer,intent(in) :: Nint - integer(bit_kind),intent(in) :: det_in(Nint,2) - - integer :: i, j, iorb, jorb - integer :: occ(Nint*bit_kind_size,2) - integer :: elec_num_tab_local(2) - - double precision :: core_act - double precision :: alpha_alpha - double precision :: alpha_beta - double precision :: beta_beta - double precision :: mono_elec - core_act = 0.d0 - alpha_alpha = 0.d0 - alpha_beta = 0.d0 - beta_beta = 0.d0 - mono_elec = 0.d0 - - diag_H_mat_elem_no_elec_check_no_spin = 0.d0 - call bitstring_to_list(det_in(1,1), occ(1,1), elec_num_tab_local(1), N_int) - call bitstring_to_list(det_in(1,2), occ(1,2), elec_num_tab_local(2), N_int) - ! alpha - alpha - do i = 1, elec_num_tab_local(1) - iorb = occ(i,1) - diag_H_mat_elem_no_elec_check_no_spin += mo_mono_elec_integral(iorb,iorb) - mono_elec += mo_mono_elec_integral(iorb,iorb) - do j = i+1, elec_num_tab_local(1) - jorb = occ(j,1) - diag_H_mat_elem_no_elec_check_no_spin += mo_bielec_integral_jj(jorb,iorb) - alpha_alpha += mo_bielec_integral_jj(jorb,iorb) + ! alpha - alpha + do i = 1, n_core_inact_orb + iorb = list_core_inact(i) + diag_H_mat_elem_no_elec_check += 1.d0 * mo_mono_elec_integral(iorb,iorb) + do j = i+1, n_core_inact_orb + jorb = list_core_inact(j) + diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - 1.d0 * mo_bielec_integral_jj_exchange(jorb,iorb) enddo - enddo + enddo - ! beta - beta - do i = 1, elec_num_tab_local(2) - iorb = occ(i,2) - diag_H_mat_elem_no_elec_check_no_spin += mo_mono_elec_integral(iorb,iorb) - mono_elec += mo_mono_elec_integral(iorb,iorb) - do j = i+1, elec_num_tab_local(2) - jorb = occ(j,2) - diag_H_mat_elem_no_elec_check_no_spin += mo_bielec_integral_jj(jorb,iorb) - beta_beta += mo_bielec_integral_jj(jorb,iorb) + do i = 1, n_core_inact_orb + iorb = list_core_inact(i) + diag_H_mat_elem_no_elec_check += 1.d0 * mo_mono_elec_integral(iorb,iorb) + do j = i+1, n_core_inact_orb + jorb = list_core_inact(j) + diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - 1.d0 * mo_bielec_integral_jj_exchange(jorb,iorb) enddo - enddo - + enddo - ! alpha - beta - do i = 1, elec_num_tab_local(2) - iorb = occ(i,2) - do j = 1, elec_num_tab_local(1) - jorb = occ(j,1) - diag_H_mat_elem_no_elec_check_no_spin += mo_bielec_integral_jj(jorb,iorb) - alpha_beta += mo_bielec_integral_jj(jorb,iorb) - enddo - enddo - - - ! alpha - core-act - do i = 1, elec_num_tab_local(1) - iorb = occ(i,1) + do i = 1, n_core_inact_orb + iorb = list_core_inact(i) do j = 1, n_core_inact_orb jorb = list_core_inact(j) - diag_H_mat_elem_no_elec_check_no_spin += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) + diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) enddo - enddo - - ! beta - core-act - do i = 1, elec_num_tab_local(2) - iorb = occ(i,2) - do j = 1, n_core_inact_orb - jorb = list_core_inact(j) - diag_H_mat_elem_no_elec_check_no_spin += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - enddo - enddo + enddo end - subroutine i_H_j_dyall(key_i,key_j,Nint,hij) use bitmasks implicit none @@ -436,133 +389,6 @@ subroutine i_H_j_dyall(key_i,key_j,Nint,hij) end -subroutine i_H_j_dyall_no_spin(key_i,key_j,Nint,hij) - use bitmasks - implicit none - BEGIN_DOC - ! Returns where i and j are determinants - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) - double precision, intent(out) :: hij - - integer :: exc(0:2,2,2) - integer :: degree - double precision :: get_mo_bielec_integral - integer :: m,n,p,q - integer :: i,j,k - integer :: occ(Nint*bit_kind_size,2) - double precision :: diag_H_mat_elem_no_elec_check, phase,phase_2 - integer :: n_occ_ab(2) - logical :: has_mipi(Nint*bit_kind_size) - double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size) - PROVIDE mo_bielec_integrals_in_map mo_integrals_map - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - - hij = 0.d0 - !DIR$ FORCEINLINE - call get_excitation_degree(key_i,key_j,degree,Nint) - select case (degree) - case (2) - call get_double_excitation(key_i,key_j,exc,phase,Nint) - if (exc(0,1,1) == 1) then - ! Mono alpha, mono beta - if(exc(1,1,1) == exc(1,1,2) .and. exc(1,1,2) == exc(1,2,1) )then - hij = 0.d0 - else - hij = phase*get_mo_bielec_integral( & - exc(1,1,1), & - exc(1,1,2), & - exc(1,2,1), & - exc(1,2,2) ,mo_integrals_map) - endif - else if (exc(0,1,1) == 2) then - ! Double alpha - hij = phase*get_mo_bielec_integral( & - exc(1,1,1), & - exc(2,1,1), & - exc(1,2,1), & - exc(2,2,1) ,mo_integrals_map) - else if (exc(0,1,2) == 2) then - ! Double beta - hij = phase*get_mo_bielec_integral( & - exc(1,1,2), & - exc(2,1,2), & - exc(1,2,2), & - exc(2,2,2) ,mo_integrals_map) - endif - case (1) - call get_mono_excitation(key_i,key_j,exc,phase,Nint) - !DIR$ FORCEINLINE - call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) - has_mipi = .False. - if (exc(0,1,1) == 1) then - ! Mono alpha - m = exc(1,1,1) - p = exc(1,2,1) - do k = 1, n_occ_ab(1) - i = occ(k,1) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - do k = 1, n_occ_ab(2) - i = occ(k,2) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - - do k = 1, n_occ_ab(1) - hij = hij + mipi(occ(k,1)) !- miip(occ(k,1)) - enddo - do k = 1, n_occ_ab(2) - hij = hij + mipi(occ(k,2)) - enddo - - else - ! Mono beta - m = exc(1,1,2) - p = exc(1,2,2) - do k = 1, n_occ_ab(2) - i = occ(k,2) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - do k = 1, n_occ_ab(1) - i = occ(k,1) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - - do k = 1, n_occ_ab(1) - hij = hij + mipi(occ(k,1)) - enddo - do k = 1, n_occ_ab(2) - hij = hij + mipi(occ(k,2)) !- miip(occ(k,2)) - enddo - - endif - hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) ) - - case (0) - double precision :: diag_H_mat_elem_no_elec_check_no_spin - hij = diag_H_mat_elem_no_elec_check_no_spin(key_i,Nint) - end select -end - - - subroutine u0_H_dyall_u0(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target) use bitmasks implicit none @@ -588,7 +414,6 @@ subroutine u0_H_dyall_u0(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coe do j = 1, ndet if(psi_coef_tmp(j)==0.d0)cycle call i_H_j_dyall(psi_in(1,1,i),psi_in(1,1,j),N_int,hij) -! call i_H_j_dyall_no_spin(psi_in(1,1,i),psi_in(1,1,j),N_int,hij) accu += psi_coef_tmp(i) * psi_coef_tmp(j) * hij enddo enddo @@ -677,7 +502,6 @@ subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij) integer :: n_occ_ab(2) logical :: has_mipi(Nint*bit_kind_size) double precision :: mipi(Nint*bit_kind_size) - double precision :: diag_H_mat_elem PROVIDE mo_bielec_integrals_in_map mo_integrals_map ASSERT (Nint > 0) @@ -774,12 +598,9 @@ subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij) endif hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) ) -! hij = phase*(hij + mo_mono_elec_integral(m,p) ) case (0) hij = diag_H_mat_elem_no_elec_check_no_exchange(key_i,Nint) -! hij = diag_H_mat_elem(key_i,Nint) -! hij = 0.d0 end select end @@ -804,7 +625,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) ! alpha - alpha do i = 1, elec_num_tab_local(1) iorb = occ(i,1) - diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) !+ fock_operator_active_from_core_inact(iorb,iorb) + diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) do j = i+1, elec_num_tab_local(1) jorb = occ(j,1) diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb) @@ -814,7 +635,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) ! beta - beta do i = 1, elec_num_tab_local(2) iorb = occ(i,2) - diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) !+ fock_operator_active_from_core_inact(iorb,iorb) + diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) do j = i+1, elec_num_tab_local(2) jorb = occ(j,2) diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb) @@ -832,16 +653,13 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) enddo -! return - ! alpha - core-act do i = 1, elec_num_tab_local(1) iorb = occ(i,1) do j = 1, n_core_inact_orb jorb = list_core_inact(j) diag_H_mat_elem_no_elec_check_no_exchange += 2.d0 * mo_bielec_integral_jj(jorb,iorb) -! core_act_exchange(1) += - mo_bielec_integral_jj_exchange(jorb,iorb) -! diag_H_mat_elem_no_elec_check_no_exchange += core_act_exchange(1) + core_act_exchange(1) += - mo_bielec_integral_jj_exchange(jorb,iorb) enddo enddo @@ -851,8 +669,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) do j = 1, n_core_inact_orb jorb = list_core_inact(j) diag_H_mat_elem_no_elec_check_no_exchange += 2.d0 * mo_bielec_integral_jj(jorb,iorb) -! core_act_exchange(2) += - mo_bielec_integral_jj_exchange(jorb,iorb) -! diag_H_mat_elem_no_elec_check_no_exchange += core_act_exchange(2) + core_act_exchange(2) += - mo_bielec_integral_jj_exchange(jorb,iorb) enddo enddo @@ -889,45 +706,3 @@ subroutine u0_H_dyall_u0_no_exchange(energies,psi_in,psi_in_coef,ndet,dim_psi_in energies(state_target) = accu deallocate(psi_coef_tmp) end - - - -!subroutine u0_H_dyall_u0_no_exchange_bis(energies,psi_in,psi_in_active,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target) -subroutine u0_H_dyall_u0_no_exchange_bis(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target) - use bitmasks - implicit none - integer, intent(in) :: N_states_in,ndet,dim_psi_in,dim_psi_coef,state_target -!integer(bit_kind), intent(in) :: psi_in(N_int,2,dim_psi_in),psi_in_active(N_int,2,dim_psi_in) - integer(bit_kind), intent(in) :: psi_in(N_int,2,dim_psi_in) - double precision, intent(in) :: psi_in_coef(dim_psi_coef,N_states_in) - double precision, intent(out) :: energies(N_states_in) - - integer :: i,j - double precision :: hij,accu - energies = 0.d0 - accu = 0.d0 - double precision, allocatable :: psi_coef_tmp(:) - allocate(psi_coef_tmp(ndet)) - - do i = 1, ndet - psi_coef_tmp(i) = psi_in_coef(i,state_target) - enddo - - double precision :: hij_bis,diag_H_mat_elem - do i = 1, ndet - if(psi_coef_tmp(i)==0.d0)cycle - do j = i+1, ndet - if(psi_coef_tmp(j)==0.d0)cycle -! call i_H_j_dyall_no_exchange(psi_in_active(1,1,i),psi_in_active(1,1,j),N_int,hij) - call i_H_j(psi_in(1,1,i),psi_in(1,1,j),N_int,hij) - accu += 2.d0 * psi_coef_tmp(i) * psi_coef_tmp(j) * hij - enddo - enddo - do i = 1, N_det - if(psi_coef_tmp(i)==0.d0)cycle - accu += psi_coef_tmp(i) * psi_coef_tmp(i) * diag_H_mat_elem(psi_in(1,1,i),N_int) - enddo - energies(state_target) = accu - deallocate(psi_coef_tmp) -end - diff --git a/plugins/MRPT_Utils/fock_like_operators.irp.f b/plugins/MRPT_Utils/fock_like_operators.irp.f index f16aba26..d4ce0661 100644 --- a/plugins/MRPT_Utils/fock_like_operators.irp.f +++ b/plugins/MRPT_Utils/fock_like_operators.irp.f @@ -197,7 +197,7 @@ k_inact_core_orb = list_core_inact(k) coulomb = get_mo_bielec_integral(k_inact_core_orb,iorb,k_inact_core_orb,jorb,mo_integrals_map) exchange = get_mo_bielec_integral(k_inact_core_orb,jorb,iorb,k_inact_core_orb,mo_integrals_map) - accu += 2.d0 * coulomb - exchange + accu += 2.d0 * coulomb - exchange enddo fock_operator_active_from_core_inact(iorb,jorb) = accu enddo diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f index a08b6108..275af0e4 100644 --- a/plugins/MRPT_Utils/mrpt_dress.irp.f +++ b/plugins/MRPT_Utils/mrpt_dress.irp.f @@ -44,11 +44,11 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip integer :: N_miniList, leng double precision :: delta_e(N_states),hij_tmp integer :: index_i,index_j - double precision :: phase_array(N_det_ref),phase + double precision :: phase_array(N_det),phase integer :: exc(0:2,2,2),degree - leng = max(N_det_generators, N_det_generators) + leng = max(N_det_generators, N_det) allocate(miniList(Nint, 2, leng), idx_miniList(leng)) !create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint) @@ -59,81 +59,35 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip end if - call find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) + call find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) if(N_tq > 0) then - call create_minilist(key_mask, psi_ref, miniList, idx_miniList, N_det_ref, N_minilist, Nint) + call create_minilist(key_mask, psi_det, miniList, idx_miniList, N_det, N_minilist, Nint) end if - double precision :: coef_array(N_states) do i_alpha=1,N_tq -! do i = 1, N_det_ref -! do i_state = 1, N_states -! coef_array(i_state) = psi_ref_coef(i,i_state) -! enddo -! call i_H_j(psi_ref(1,1,i),tq(1,1,i_alpha),n_int,hialpha) -! if(dabs(hialpha).le.1.d-20)then -! do i_state = 1, N_states -! delta_e(i_state) = 1.d+20 -! enddo -! else -! call get_delta_e_dyall(psi_ref(1,1,i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) -! endif -! hij_array(i) = hialpha -! do i_state = 1,N_states -! delta_e_inv_array(i,i_state) = 1.d0/delta_e(i_state) -! enddo -! enddo -! do i = 1, N_det_ref -! do j = 1, N_det_ref -! do i_state = 1, N_states -! delta_ij_(i,j,i_state) += hij_array(i) * hij_array(j)* delta_e_inv_array(j,i_state) -! enddo -! enddo -! enddo -! cycle - - - - ! call get_excitation_degree_vector(psi_ref,tq(1,1,i_alpha),degree_alpha,Nint,N_det_ref,idx_alpha) call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha) do j=1,idx_alpha(0) idx_alpha(j) = idx_miniList(idx_alpha(j)) enddo +! double precision :: ihpsi0,coef_pert +! ihpsi0 = 0.d0 +! coef_pert = 0.d0 phase_array =0.d0 do i = 1,idx_alpha(0) index_i = idx_alpha(i) - call i_h_j(tq(1,1,i_alpha),psi_ref(1,1,index_i),Nint,hialpha) + call i_h_j(tq(1,1,i_alpha),psi_det(1,1,index_i),Nint,hialpha) + double precision :: coef_array(N_states) do i_state = 1, N_states - coef_array(i_state) = psi_ref_coef(index_i,i_state) + coef_array(i_state) = psi_coef(index_i,i_state) enddo - integer :: degree_scalar - - call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,index_i),degree_scalar,N_int) -! if(degree_scalar == 2)then -! hialpha = 0.d0 -! endif - if(dabs(hialpha).le.1.d-20)then - do i_state = 1, N_states - delta_e(i_state) = 1.d+20 - enddo - else - call get_delta_e_dyall(psi_ref(1,1,index_i),tq(1,1,i_alpha),delta_e) - if(degree_scalar.eq.1)then - delta_e = 1.d+20 - endif -! print*, 'delta_e',delta_e - !!!!!!!!!!!!! SHIFTED BK -! double precision :: hjj -! call i_h_j(tq(1,1,i_alpha),tq(1,1,i_alpha),Nint,hjj) -! delta_e(1) = electronic_psi_ref_average_value(1) - hjj -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - endif + call get_delta_e_dyall(psi_det(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) hij_array(index_i) = hialpha -! print*, 'hialpha ',hialpha + call get_excitation(psi_det(1,1,index_i),tq(1,1,i_alpha),exc,degree,phase,N_int) +! phase_array(index_i) = phase do i_state = 1,N_states delta_e_inv_array(index_i,i_state) = 1.d0/delta_e(i_state) enddo @@ -145,14 +99,18 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip call omp_set_lock( psi_ref_bis_lock(index_i) ) do j = 1, idx_alpha(0) index_j = idx_alpha(j) - !!!!!!!!!!!!!!!!!! WARNING TEST - !!!!!!!!!!!!!!!!!! WARNING TEST -! if(index_j .ne. index_i)cycle - !!!!!!!!!!!!!!!!!! WARNING TEST - !!!!!!!!!!!!!!!!!! WARNING TEST - !!!!!!!!!!!!!!!!!! WARNING TEST +! call get_excitation(psi_det(1,1,index_i),psi_det(1,1,index_i),exc,degree,phase,N_int) +! if(index_j.ne.index_i)then +! if(phase_array(index_j) * phase_array(index_i) .ne. phase)then +! print*, phase_array(index_j) , phase_array(index_i) ,phase +! call debug_det(psi_det(1,1,index_i),N_int) +! call debug_det(psi_det(1,1,index_j),N_int) +! call debug_det(tq(1,1,i_alpha),N_int) +! stop +! endif +! endif do i_state=1,N_states - ! standard dressing first order +! standard dressing first order delta_ij_(index_i,index_j,i_state) += hij_array(index_j) * hij_tmp * delta_e_inv_array(index_j,i_state) enddo enddo @@ -164,23 +122,23 @@ end - BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted, (N_int,2,N_det_ref,2) ] -&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_ref,2) ] -&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_ref,2) ] -&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_ref,2) ] - gen_det_sorted(:,:,:,1) = psi_ref(:,:,:N_det_ref) - gen_det_sorted(:,:,:,2) = psi_ref(:,:,:N_det_ref) - call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_ref, N_int) - call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_ref, N_int) + BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted, (N_int,2,N_det_generators,2) ] +&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_generators,2) ] +&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_generators,2) ] +&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_generators,2) ] + gen_det_sorted(:,:,:,1) = psi_det_generators(:,:,:N_det_generators) + gen_det_sorted(:,:,:,2) = psi_det_generators(:,:,:N_det_generators) + call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_generators, N_int) + call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_generators, N_int) END_PROVIDER -subroutine find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList) +subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList) use bitmasks implicit none - integer, intent(in) :: n_selected, Nint + integer, intent(in) :: i_generator,n_selected, Nint integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) integer :: i,j,k,m @@ -197,7 +155,7 @@ subroutine find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList logical, external :: is_connected_to - integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_ref) + integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_generators) integer,intent(in) :: N_miniList @@ -210,7 +168,7 @@ subroutine find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList cycle end if - if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det_ref)) then + if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det)) then N_tq += 1 do k=1,N_int tq(k,1,N_tq) = det_buffer(k,1,i) @@ -221,3 +179,8 @@ subroutine find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList end + + + + + diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f index 79aa624f..d7b1f0f6 100644 --- a/plugins/MRPT_Utils/mrpt_utils.irp.f +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -34,44 +34,43 @@ accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo - write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) enddo second_order_pt_new_1h(i_state) = accu(i_state) enddo print*, '1h = ',accu -!! 1p -!delta_ij_tmp = 0.d0 -!call H_apply_mrpt_1p(delta_ij_tmp,N_det) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det -! do j = 1, N_det -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) -!enddo -!second_order_pt_new_1p(i_state) = accu(i_state) -!enddo -!print*, '1p = ',accu + ! 1p + delta_ij_tmp = 0.d0 + call H_apply_mrpt_1p(delta_ij_tmp,N_det) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det + do j = 1, N_det + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_1p(i_state) = accu(i_state) + enddo + print*, '1p = ',accu ! 1h1p -!delta_ij_tmp = 0.d0 -!call H_apply_mrpt_1h1p(delta_ij_tmp,N_det) -!double precision :: e_corr_from_1h1p_singles(N_states) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det -! do j = 1, N_det -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) -!enddo -!second_order_pt_new_1h1p(i_state) = accu(i_state) -!enddo -!print*, '1h1p = ',accu + delta_ij_tmp = 0.d0 + call H_apply_mrpt_1h1p(delta_ij_tmp,N_det) + double precision :: e_corr_from_1h1p_singles(N_states) +!call give_singles_and_partial_doubles_1h1p_contrib(delta_ij_tmp,e_corr_from_1h1p_singles) +!call give_1h1p_only_doubles_spin_cross(delta_ij_tmp) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det + do j = 1, N_det + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_1h1p(i_state) = accu(i_state) + enddo + print*, '1h1p = ',accu ! 1h1p third order if(do_third_order_1h1p)then @@ -84,80 +83,75 @@ accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo - write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) enddo second_order_pt_new_1h1p(i_state) = accu(i_state) enddo print*, '1h1p(3)',accu endif -!! 2h -!delta_ij_tmp = 0.d0 -!call H_apply_mrpt_2h(delta_ij_tmp,N_det) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det -! do j = 1, N_det -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) -!enddo -!second_order_pt_new_2h(i_state) = accu(i_state) -!enddo -!print*, '2h = ',accu + ! 2h + delta_ij_tmp = 0.d0 + call H_apply_mrpt_2h(delta_ij_tmp,N_det) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det + do j = 1, N_det + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_2h(i_state) = accu(i_state) + enddo + print*, '2h = ',accu -!! 2p -!delta_ij_tmp = 0.d0 -!call H_apply_mrpt_2p(delta_ij_tmp,N_det) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det -! do j = 1, N_det -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) -!enddo -!second_order_pt_new_2p(i_state) = accu(i_state) -!enddo -!print*, '2p = ',accu + ! 2p + delta_ij_tmp = 0.d0 + call H_apply_mrpt_2p(delta_ij_tmp,N_det) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det + do j = 1, N_det + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_2p(i_state) = accu(i_state) + enddo + print*, '2p = ',accu ! 1h2p delta_ij_tmp = 0.d0 !call give_1h2p_contrib(delta_ij_tmp) -!call H_apply_mrpt_1h2p(delta_ij_tmp,N_det) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det -! do j = 1, N_det -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) -!enddo -!second_order_pt_new_1h2p(i_state) = accu(i_state) -!enddo -!print*, '1h2p = ',accu + call H_apply_mrpt_1h2p(delta_ij_tmp,N_det) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det + do j = 1, N_det + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_1h2p(i_state) = accu(i_state) + enddo + print*, '1h2p = ',accu -!! 2h1p -!delta_ij_tmp = 0.d0 + ! 2h1p + delta_ij_tmp = 0.d0 !call give_2h1p_contrib(delta_ij_tmp) -!call H_apply_mrpt_2h1p(delta_ij_tmp,N_det) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det -! do j = 1, N_det -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) -!enddo -!second_order_pt_new_2h1p(i_state) = accu(i_state) -!enddo -!print*, '2h1p = ',accu + call H_apply_mrpt_2h1p(delta_ij_tmp,N_det) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det + do j = 1, N_det + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_2h1p(i_state) = accu(i_state) + enddo + print*, '2h1p = ',accu -!! 2h2p + ! 2h2p !delta_ij_tmp = 0.d0 !call H_apply_mrpt_2h2p(delta_ij_tmp,N_det) !accu = 0.d0 @@ -184,13 +178,10 @@ ! total - print*, '' - print*, 'total dressing' - print*, '' accu = 0.d0 do i_state = 1, N_states do i = 1, N_det - write(*,'(1000(F16.10,x))')delta_ij(i,:,:) +! write(*,'(1000(F16.10,x))')delta_ij(i,:,:) do j = i_state, N_det accu(i_state) += delta_ij(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) enddo @@ -232,7 +223,7 @@ END_PROVIDER enddo END_PROVIDER - BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_electronic_energy, (N_states_diag) ] + BEGIN_PROVIDER [ double precision, CI_electronic_dressed_pt2_new_energy, (N_states_diag) ] &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors, (N_det,N_states_diag) ] &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors_s2, (N_states_diag) ] BEGIN_DOC @@ -254,7 +245,7 @@ END_PROVIDER integer, allocatable :: iorder(:) ! Guess values for the "N_states_diag" states of the CI_dressed_pt2_new_eigenvectors - do j=1,min(N_states,N_det) + do j=1,min(N_states_diag,N_det) do i=1,N_det CI_dressed_pt2_new_eigenvectors(i,j) = psi_coef(i,j) enddo @@ -276,7 +267,7 @@ END_PROVIDER allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) allocate (eigenvalues(N_det)) call lapack_diag(eigenvalues,eigenvectors, & - Hmatrix_dressed_pt2_new_symmetrized,size(H_matrix_all_dets,1),N_det) + H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) CI_electronic_energy(:) = 0.d0 if (s2_eig) then i_state = 0 @@ -285,10 +276,8 @@ END_PROVIDER good_state_array = .False. call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,& N_det,size(eigenvectors,1)) - print*,'N_det',N_det do j=1,N_det ! Select at least n_states states with S^2 values closed to "expected_s2" - print*, s2_eigvalues(j),expected_s2 if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then i_state +=1 index_good_state_array(i_state) = j @@ -302,10 +291,10 @@ END_PROVIDER ! Fill the first "i_state" states that have a correct S^2 value do j = 1, i_state do i=1,N_det - CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j)) + CI_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j)) enddo - CI_dressed_pt2_new_electronic_energy(j) = eigenvalues(index_good_state_array(j)) - CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j)) + CI_electronic_energy(j) = eigenvalues(index_good_state_array(j)) + CI_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j)) enddo i_other_state = 0 do j = 1, N_det @@ -315,10 +304,10 @@ END_PROVIDER exit endif do i=1,N_det - CI_dressed_pt2_new_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) + CI_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) enddo - CI_dressed_pt2_new_electronic_energy(i_state+i_other_state) = eigenvalues(j) - CI_dressed_pt2_new_eigenvectors_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) + CI_electronic_energy(i_state+i_other_state) = eigenvalues(j) + CI_eigenvectors_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) enddo else @@ -333,10 +322,10 @@ END_PROVIDER print*,'' do j=1,min(N_states_diag,N_det) do i=1,N_det - CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) + CI_eigenvectors(i,j) = eigenvectors(i,j) enddo - CI_dressed_pt2_new_electronic_energy(j) = eigenvalues(j) - CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(j) + CI_electronic_energy(j) = eigenvalues(j) + CI_eigenvectors_s2(j) = s2_eigvalues(j) enddo endif deallocate(index_good_state_array,good_state_array) @@ -347,9 +336,9 @@ END_PROVIDER ! Select the "N_states_diag" states of lowest energy do j=1,min(N_det,N_states_diag) do i=1,N_det - CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) + CI_eigenvectors(i,j) = eigenvectors(i,j) enddo - CI_dressed_pt2_new_electronic_energy(j) = eigenvalues(j) + CI_electronic_energy(j) = eigenvalues(j) enddo endif deallocate(eigenvectors,eigenvalues) @@ -369,7 +358,7 @@ BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states_diag) ] character*(8) :: st call write_time(output_determinants) do j=1,N_states_diag - CI_dressed_pt2_new_energy(j) = CI_dressed_pt2_new_electronic_energy(j) + nuclear_repulsion + CI_dressed_pt2_new_energy(j) = CI_electronic_dressed_pt2_new_energy(j) + nuclear_repulsion write(st,'(I4)') j call write_double(output_determinants,CI_dressed_pt2_new_energy(j),'Energy of state '//trim(st)) call write_double(output_determinants,CI_eigenvectors_s2(j),'S^2 of state '//trim(st)) diff --git a/plugins/MRPT_Utils/new_way.irp.f b/plugins/MRPT_Utils/new_way.irp.f index a007e761..fa5812e1 100644 --- a/plugins/MRPT_Utils/new_way.irp.f +++ b/plugins/MRPT_Utils/new_way.irp.f @@ -1,7 +1,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) use bitmasks implicit none - double precision , intent(inout) :: matrix_2h1p(N_det_ref,N_det_ref,*) + double precision , intent(inout) :: matrix_2h1p(N_det,N_det,*) integer :: i,j,r,a,b integer :: iorb, jorb, rorb, aorb, borb integer :: ispin,jspin @@ -22,8 +22,8 @@ subroutine give_2h1p_contrib(matrix_2h1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) enddo do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) @@ -38,14 +38,14 @@ subroutine give_2h1p_contrib(matrix_2h1p) active_int(a,2) = get_mo_bielec_integral(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange enddo - integer :: degree(N_det_ref) - integer :: idx(0:N_det_ref) + integer :: degree(N_det) + integer :: idx(0:N_det) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate - integer :: index_orb_act_mono(N_det_ref,3) + integer :: index_orb_act_mono(N_det,3) - do idet = 1, N_det_ref - call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) + do idet = 1, N_det + call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) do jspin = 1, 2 ! spin of the couple z-a^dagger (j,a) @@ -53,8 +53,8 @@ subroutine give_2h1p_contrib(matrix_2h1p) do a = 1, n_act_orb ! First active aorb = list_act(a) do inint = 1, N_int - det_tmp(inint,1) = psi_ref(inint,1,idet) - det_tmp(inint,2) = psi_ref(inint,2,idet) + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) enddo ! Do the excitation inactive -- > virtual call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin @@ -64,7 +64,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int) ! hole in "jorb" of spin Jspin call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin - ! Check if the excitation is possible or not on psi_ref(idet) + ! Check if the excitation is possible or not on psi_det(idet) accu_elec= 0 do inint = 1, N_int accu_elec+= popcnt(det_tmp(inint,jspin)) @@ -81,7 +81,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) enddo - call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) perturb_dets_phase(a,jspin,ispin) = phase do istate = 1, N_states delta_e(a,jspin,istate) = one_creat(a,jspin,istate) & @@ -109,7 +109,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) !!!!!!!!!!!!!!!!!!!!!!!!!!!! do jdet = 1, idx(0) if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) + call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_a @@ -129,7 +129,6 @@ subroutine give_2h1p_contrib(matrix_2h1p) integer :: kspin do jdet = 1, idx(0) if(idx(jdet).ne.idet)then -! cycle ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator ! are connected by the presence of the perturbers determinants |det_tmp> aorb = index_orb_act_mono(idx(jdet),1) ! a^{\dagger}_{aorb} @@ -151,7 +150,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) ! you determine the interaction between the excited determinant and the other parent | Jdet > ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet > ! hja = < det_tmp | H | Jdet > - call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) if(kspin == ispin)then hja = phase * (active_int(borb,2) - active_int(borb,1) ) else @@ -196,7 +195,7 @@ end subroutine give_1h2p_contrib(matrix_1h2p) use bitmasks implicit none - double precision , intent(inout) :: matrix_1h2p(N_det_ref,N_det_ref,*) + double precision , intent(inout) :: matrix_1h2p(N_det,N_det,*) integer :: i,v,r,a,b integer :: iorb, vorb, rorb, aorb, borb integer :: ispin,jspin @@ -214,18 +213,16 @@ subroutine give_1h2p_contrib(matrix_1h2p) double precision :: active_int(n_act_orb,2) double precision :: hij,phase !matrix_1h2p = 0.d0 + elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) enddo -!do i = 1, 1 ! First inactive do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) -! do v = 1, 1 do v = 1, n_virt_orb ! First virtual vorb = list_virt(v) -! do r = 1, 1 do r = 1, n_virt_orb ! Second virtual rorb = list_virt(r) ! take all the integral you will need for i,j,r fixed @@ -235,14 +232,14 @@ subroutine give_1h2p_contrib(matrix_1h2p) active_int(a,2) = get_mo_bielec_integral(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange enddo - integer :: degree(N_det_ref) - integer :: idx(0:N_det_ref) + integer :: degree(N_det) + integer :: idx(0:N_det) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate - integer :: index_orb_act_mono(N_det_ref,3) + integer :: index_orb_act_mono(N_det,3) - do idet = 1, N_det_ref - call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) + do idet = 1, N_det + call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements do ispin = 1, 2 ! spin of the couple a-a^dagger (iorb,rorb) do jspin = 1, 2 ! spin of the couple a-a^dagger (aorb,vorb) @@ -250,8 +247,8 @@ subroutine give_1h2p_contrib(matrix_1h2p) aorb = list_act(a) if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count do inint = 1, N_int - det_tmp(inint,1) = psi_ref(inint,1,idet) - det_tmp(inint,2) = psi_ref(inint,2,idet) + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) enddo ! Do the excitation inactive -- > virtual call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin @@ -261,7 +258,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! hole in "aorb" of spin Jspin call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin - ! Check if the excitation is possible or not on psi_ref(idet) + ! Check if the excitation is possible or not on psi_det(idet) accu_elec= 0 do inint = 1, N_int accu_elec+= popcnt(det_tmp(inint,jspin)) @@ -283,7 +280,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) det_tmp(inint,2) = perturb_dets(inint,2,a,jspin,ispin) enddo - call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) perturb_dets_phase(a,jspin,ispin) = phase do istate = 1, N_states delta_e(a,jspin,istate) = one_anhil(a,jspin,istate) & @@ -311,7 +308,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) !!!!!!!!!!!!!!!!!!!!!!!!!!!! do jdet = 1, idx(0) if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) + call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a @@ -353,7 +350,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{borb,kspin} a_{iorb,ispin} | Jdet > ! hja = < det_tmp | H | Jdet > - call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) if(kspin == ispin)then hja = phase * (active_int(borb,1) - active_int(borb,2) ) else @@ -396,10 +393,130 @@ subroutine give_1h2p_contrib(matrix_1h2p) end +subroutine give_1h1p_contrib(matrix_1h1p) + use bitmasks + implicit none + double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*) + integer :: i,j,r,a,b + integer :: iorb, jorb, rorb, aorb, borb + integer :: ispin,jspin + integer :: idet,jdet + integer :: inint + integer :: elec_num_tab_local(2),acu_elec + integer(bit_kind) :: det_tmp(N_int,2) + integer :: exc(0:2,2,2) + integer :: accu_elec + double precision :: get_mo_bielec_integral + double precision :: active_int(n_act_orb,2) + double precision :: hij,phase + integer :: degree(N_det) + integer :: idx(0:N_det) + integer :: istate + double precision :: hja,delta_e_inact_virt(N_states) + integer :: kspin,degree_scalar +!matrix_1h1p = 0.d0 + + elec_num_tab_local = 0 + do inint = 1, N_int + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + enddo + do i = 1, n_inact_orb ! First inactive + iorb = list_inact(i) + do r = 1, n_virt_orb ! First virtual + rorb = list_virt(r) + do j = 1, N_states + delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) & + - fock_virt_total_spin_trace(rorb,j) + enddo + do idet = 1, N_det + call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations + do jdet = 1, idx(0) + do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) + do inint = 1, N_int + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) + enddo + ! Do the excitation inactive -- > virtual + double precision :: himono,delta_e(N_states),coef_mono(N_states) + call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin + call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin + call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) + + do state_target = 1, N_states +! delta_e(state_target) = one_anhil_one_creat_inact_virt(i,r,state_target) + delta_e_inact_virt(state_target) + delta_e(state_target) = one_anhil_one_creat_inact_virt_bis(i,r,idet,state_target) + coef_mono(state_target) = himono / delta_e(state_target) + enddo + if(idx(jdet).ne.idet)then + call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + aorb = (exc(1,2,1)) !!! a^{\dagger}_a + borb = (exc(1,1,1)) !!! a_{b} + jspin = 1 + else + ! Mono beta + aorb = (exc(1,2,2)) !!! a^{\dagger}_a + borb = (exc(1,1,2)) !!! a_{b} + jspin = 2 + endif + + call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) + if(degree_scalar .ne. 2)then + print*, 'pb !!!' + print*, degree_scalar + call debug_det(psi_det(1,1,idx(jdet)),N_int) + call debug_det(det_tmp,N_int) + stop + endif + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + if(ispin == jspin )then + hij = -get_mo_bielec_integral(iorb,aorb,rorb,borb,mo_integrals_map) & + + get_mo_bielec_integral(iorb,aorb,borb,rorb,mo_integrals_map) + else + hij = get_mo_bielec_integral(iorb,borb,rorb,aorb,mo_integrals_map) + endif + hij = hij * phase + double precision :: hij_test + integer :: state_target + call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) + if(dabs(hij - hij_test).gt.1.d-10)then + print*, 'ahah pb !!' + print*, 'hij .ne. hij_test' + print*, hij,hij_test + call debug_det(psi_det(1,1,idx(jdet)),N_int) + call debug_det(det_tmp,N_int) + print*, ispin, jspin + print*,iorb,borb,rorb,aorb + print*, phase + call i_H_j_verbose(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) + stop + endif + do state_target = 1, N_states + matrix_1h1p(idx(jdet),idet,state_target) += hij* coef_mono(state_target) + enddo + else + do state_target = 1, N_states + matrix_1h1p(idet,idet,state_target) += himono * coef_mono(state_target) + enddo + endif + enddo + enddo + + + + enddo + enddo + enddo +end + subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) use bitmasks implicit none - double precision , intent(inout) :: matrix_1h1p(N_det_ref,N_det_ref,*) + double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*) integer :: i,j,r,a,b integer :: iorb, jorb, rorb, aorb, borb,s,sorb integer :: ispin,jspin @@ -416,8 +533,8 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,2) double precision :: hij,phase - integer :: degree(N_det_ref) - integer :: idx(0:N_det_ref) + integer :: degree(N_det) + integer :: idx(0:N_det) integer :: istate double precision :: hja,delta_e_inact_virt(N_states) integer :: kspin,degree_scalar @@ -425,13 +542,13 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) enddo double precision :: himono,delta_e(N_states),coef_mono(N_states) integer :: state_target - do idet = 1, N_det_ref - call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) + do idet = 1, N_det + call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) do r = 1, n_virt_orb ! First virtual @@ -446,13 +563,13 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) - fock_virt_total_spin_trace(rorb,j) enddo do inint = 1, N_int - det_tmp(inint,1) = psi_ref(inint,1,idet) - det_tmp(inint,2) = psi_ref(inint,2,idet) + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) enddo ! Do the excitation inactive -- > virtual call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin - call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,himono) + call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) do inint = 1, N_int det_pert(inint,1,i,r,ispin) = det_tmp(inint,1) det_pert(inint,2,i,r,ispin) = det_tmp(inint,2) @@ -502,9 +619,9 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) do r = 1, n_virt_orb ! First virtual rorb = list_virt(r) do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) - !do state_target = 1, N_states - ! coef_det_pert(i,r,ispin,state_target,1) += coef_det_pert(i,r,ispin,state_target,2) - !enddo + do state_target = 1, N_states + coef_det_pert(i,r,ispin,state_target,1) += coef_det_pert(i,r,ispin,state_target,2) + enddo do inint = 1, N_int det_tmp(inint,1) = det_pert(inint,1,i,r,ispin) @@ -512,37 +629,37 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) enddo do jdet = 1, idx(0) ! - double precision :: hij_test if(idx(jdet).ne.idet)then - ! call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) - ! if (exc(0,1,1) == 1) then - ! ! Mono alpha - ! aorb = (exc(1,2,1)) !!! a^{\dagger}_a - ! borb = (exc(1,1,1)) !!! a_{b} - ! jspin = 1 - ! else - ! aorb = (exc(1,2,2)) !!! a^{\dagger}_a - ! borb = (exc(1,1,2)) !!! a_{b} - ! jspin = 2 - ! endif - ! - ! call get_excitation_degree(psi_ref(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) - ! if(degree_scalar .ne. 2)then - ! print*, 'pb !!!' - ! print*, degree_scalar - ! call debug_det(psi_ref(1,1,idx(jdet)),N_int) - ! call debug_det(det_tmp,N_int) - ! stop - ! endif - ! call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) - ! hij_test = 0.d0 - ! call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hij_test) - ! do state_target = 1, N_states - ! matrix_1h1p(idx(jdet),idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2) - ! enddo + call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + aorb = (exc(1,2,1)) !!! a^{\dagger}_a + borb = (exc(1,1,1)) !!! a_{b} + jspin = 1 + else + aorb = (exc(1,2,2)) !!! a^{\dagger}_a + borb = (exc(1,1,2)) !!! a_{b} + jspin = 2 + endif + + call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) + if(degree_scalar .ne. 2)then + print*, 'pb !!!' + print*, degree_scalar + call debug_det(psi_det(1,1,idx(jdet)),N_int) + call debug_det(det_tmp,N_int) + stop + endif + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + double precision :: hij_test + hij_test = 0.d0 + call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) + do state_target = 1, N_states + matrix_1h1p(idx(jdet),idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2) + enddo else hij_test = 0.d0 - call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,hij_test) + call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hij_test) do state_target = 1, N_states matrix_1h1p(idet,idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2) enddo @@ -559,7 +676,7 @@ end subroutine give_1p_sec_order_singles_contrib(matrix_1p) use bitmasks implicit none - double precision , intent(inout) :: matrix_1p(N_det_ref,N_det_ref,*) + double precision , intent(inout) :: matrix_1p(N_det,N_det,*) integer :: i,j,r,a,b integer :: iorb, jorb, rorb, aorb, borb,s,sorb integer :: ispin,jspin @@ -575,8 +692,8 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) integer :: accu_elec double precision :: get_mo_bielec_integral double precision :: hij,phase - integer :: degree(N_det_ref) - integer :: idx(0:N_det_ref) + integer :: degree(N_det) + integer :: idx(0:N_det) integer :: istate double precision :: hja,delta_e_act_virt(N_states) integer :: kspin,degree_scalar @@ -584,13 +701,13 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) enddo double precision :: himono,delta_e(N_states),coef_mono(N_states) integer :: state_target - do idet = 1, N_det_ref - call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) + do idet = 1, N_det + call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) do i = 1, n_act_orb ! First active iorb = list_act(i) do r = 1, n_virt_orb ! First virtual @@ -604,8 +721,8 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) delta_e_act_virt(j) = - fock_virt_total_spin_trace(rorb,j) enddo do inint = 1, N_int - det_tmp(inint,1) = psi_ref(inint,1,idet) - det_tmp(inint,2) = psi_ref(inint,2,idet) + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) enddo ! Do the excitation active -- > virtual call do_mono_excitation(det_tmp,iorb,rorb,ispin,i_ok) @@ -622,7 +739,7 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) enddo cycle endif - call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,himono) + call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) do inint = 1, N_int det_pert(inint,1,i,r,ispin) = det_tmp(inint,1) det_pert(inint,2,i,r,ispin) = det_tmp(inint,2) @@ -684,10 +801,10 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) det_tmp(inint,1) = det_pert(inint,1,i,r,ispin) det_tmp(inint,2) = det_pert(inint,2,i,r,ispin) enddo - do jdet = 1,N_det_ref + do jdet = 1,N_det double precision :: coef_array(N_states),hij_test - call i_H_j(det_tmp,psi_ref(1,1,jdet),N_int,himono) - call get_delta_e_dyall(psi_ref(1,1,jdet),det_tmp,coef_array,hij_test,delta_e) + call i_H_j(det_tmp,psi_det(1,1,jdet),N_int,himono) + call get_delta_e_dyall(psi_det(1,1,jdet),det_tmp,coef_array,hij_test,delta_e) do state_target = 1, N_states ! matrix_1p(idet,jdet,state_target) += himono * coef_det_pert(i,r,ispin,state_target,1) matrix_1p(idet,jdet,state_target) += himono * hij_det_pert(i,r,ispin) / delta_e(state_target) @@ -705,7 +822,7 @@ end subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) use bitmasks implicit none - double precision , intent(inout) :: matrix_1h1p(N_det_ref,N_det_ref,*) + double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*) integer :: i,j,r,a,b integer :: iorb, jorb, rorb, aorb, borb integer :: ispin,jspin @@ -718,8 +835,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,2) double precision :: hij,phase - integer :: degree(N_det_ref) - integer :: idx(0:N_det_ref) + integer :: degree(N_det) + integer :: idx(0:N_det) integer :: istate double precision :: hja,delta_e_inact_virt(N_states) integer(bit_kind) :: pert_det(N_int,2,n_act_orb,n_act_orb,2) @@ -733,8 +850,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) enddo do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) @@ -744,8 +861,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) & - fock_virt_total_spin_trace(rorb,j) enddo - do idet = 1, N_det_ref - call get_excitation_degree_vector_double_alpha_beta(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) + do idet = 1, N_det + call get_excitation_degree_vector_double_alpha_beta(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations do ispin = 1, 2 @@ -755,8 +872,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) do b = 1, n_act_orb borb = list_act(b) do inint = 1, N_int - det_tmp(inint,1) = psi_ref(inint,1,idet) - det_tmp(inint,2) = psi_ref(inint,2,idet) + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) enddo ! Do the excitation (i-->a)(ispin) + (b-->r)(other_spin(ispin)) integer :: i_ok,corb,dorb @@ -787,7 +904,7 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) pert_det(inint,2,a,b,ispin) = det_tmp(inint,2) enddo - call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,hidouble) + call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hidouble) do state_target = 1, N_states delta_e(state_target) = one_anhil_one_creat(a,b,ispin,jspin,state_target) + delta_e_inact_virt(state_target) pert_det_coef(a,b,ispin,state_target) = hidouble / delta_e(state_target) @@ -798,7 +915,7 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) enddo do jdet = 1, idx(0) if(idx(jdet).ne.idet)then - call get_double_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) + call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) integer :: c,d,state_target integer(bit_kind) :: det_tmp_bis(N_int,2) ! excitation from I --> J @@ -818,8 +935,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) det_tmp_bis(inint,2) = pert_det(inint,2,c,d,2) enddo double precision :: hjdouble_1,hjdouble_2 - call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hjdouble_1) - call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp_bis,N_int,hjdouble_2) + call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hjdouble_1) + call i_H_j(psi_det(1,1,idx(jdet)),det_tmp_bis,N_int,hjdouble_2) do state_target = 1, N_states matrix_1h1p(idx(jdet),idet,state_target) += (pert_det_coef(c,d,1,state_target) * hjdouble_1 + pert_det_coef(c,d,2,state_target) * hjdouble_2 ) enddo diff --git a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f index b67f7498..781be55b 100644 --- a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f +++ b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f @@ -44,8 +44,8 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) perturb_dets_phase(a,2,1) = -1000.d0 enddo - integer :: degree(N_det_Ref) - integer :: idx(0:N_det_Ref) + integer :: degree(N_det) + integer :: idx(0:N_det) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate @@ -376,8 +376,8 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) double precision :: active_int(n_act_orb,2) double precision :: hij,phase double precision :: accu_contrib - integer :: degree(N_det_Ref) - integer :: idx(0:N_det_Ref) + integer :: degree(N_det) + integer :: idx(0:N_det) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate integer :: index_orb_act_mono(N_det,6) diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index f86947d8..794742b4 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -152,7 +152,7 @@ subroutine give_particles_in_virt_space(det_1,n_particles_spin,n_particles,parti end -subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) +subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) BEGIN_DOC ! routine that returns the delta_e with the Moller Plesset and Dyall operators ! @@ -170,6 +170,7 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) use bitmasks double precision, intent(out) :: delta_e_final(N_states) integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: coef_array(N_states),hij integer :: i,j,k,l integer :: i_state @@ -354,8 +355,7 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) kspin = particle_list_practical(1,1) i_particle_act = particle_list_practical(2,1) do i_state = 1, N_states -! delta_e_act(i_state) += two_anhil_one_creat(i_particle_act,i_hole_act,j_hole_act,kspin,ispin,jspin,i_state) - delta_e_act(i_state) += two_anhil_one_creat_spin_average(i_particle_act,i_hole_act,j_hole_act,i_state) + delta_e_act(i_state) += two_anhil_one_creat(i_particle_act,i_hole_act,j_hole_act,kspin,ispin,jspin,i_state) enddo else if (n_holes_act == 1 .and. n_particles_act == 2) then @@ -370,9 +370,7 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) j_particle_act = particle_list_practical(2,2) do i_state = 1, N_states -! delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,jspin,kspin,ispin,i_state) - delta_e_act(i_state) += 0.5d0 * (two_creat_one_anhil_spin_average(i_particle_act,j_particle_act,i_hole_act,i_state) & - +two_creat_one_anhil_spin_average(j_particle_act,i_particle_act,i_hole_act,i_state)) + delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,jspin,kspin,ispin,i_state) enddo else if (n_holes_act == 3 .and. n_particles_act == 0) then @@ -435,4 +433,3 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) end - diff --git a/plugins/MRPT_Utils/second_order_new.irp.f b/plugins/MRPT_Utils/second_order_new.irp.f index 2a61eece..ba3b421b 100644 --- a/plugins/MRPT_Utils/second_order_new.irp.f +++ b/plugins/MRPT_Utils/second_order_new.irp.f @@ -22,8 +22,8 @@ subroutine give_1h2p_new(matrix_1h2p) double precision :: active_int(n_act_orb,2) double precision :: hij,phase double precision :: accu_contrib(N_states) - integer :: degree(N_det_Ref) - integer :: idx(0:N_det_Ref) + integer :: degree(N_det) + integer :: idx(0:N_det) double precision :: delta_e(n_act_orb,2,N_states) double precision :: delta_e_inv(n_act_orb,2,N_states) double precision :: delta_e_inactive_virt(N_states) @@ -502,8 +502,8 @@ subroutine give_2h1p_new(matrix_2h1p) double precision :: delta_e_inv(n_act_orb,2,N_states) double precision :: fock_operator_local(n_act_orb,n_act_orb,2) double precision :: delta_e_inactive_virt(N_states) - integer :: degree(N_det_Ref) - integer :: idx(0:N_det_Ref) + integer :: degree(N_det) + integer :: idx(0:N_det) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate integer :: index_orb_act_mono(N_det,3) diff --git a/plugins/MRPT_Utils/second_order_new_2p.irp.f b/plugins/MRPT_Utils/second_order_new_2p.irp.f index d086b6c5..11ae18da 100644 --- a/plugins/MRPT_Utils/second_order_new_2p.irp.f +++ b/plugins/MRPT_Utils/second_order_new_2p.irp.f @@ -21,8 +21,8 @@ subroutine give_2p_new(matrix_2p) double precision :: active_int(n_act_orb,n_act_orb,2) double precision :: hij,phase double precision :: accu_contrib(N_states) - integer :: degree(N_det_Ref) - integer :: idx(0:N_det_Ref) + integer :: degree(N_det) + integer :: idx(0:N_det) double precision :: delta_e(n_act_orb,n_act_orb,2,2,N_states) double precision :: delta_e_inv(n_act_orb,n_act_orb,2,2,N_states) double precision :: delta_e_inactive_virt(N_states) diff --git a/plugins/Perturbation/NEEDED_CHILDREN_MODULES b/plugins/Perturbation/NEEDED_CHILDREN_MODULES index f7999340..25b89c5f 100644 --- a/plugins/Perturbation/NEEDED_CHILDREN_MODULES +++ b/plugins/Perturbation/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Determinants Properties Hartree_Fock Davidson +Determinants Properties Hartree_Fock Davidson MRPT_Utils diff --git a/plugins/Perturbation/pt2_equations.irp.f b/plugins/Perturbation/pt2_equations.irp.f index 5839c20c..b29e130f 100644 --- a/plugins/Perturbation/pt2_equations.irp.f +++ b/plugins/Perturbation/pt2_equations.irp.f @@ -46,6 +46,36 @@ subroutine pt2_epstein_nesbet ($arguments) end +subroutine pt2_decontracted ($arguments) + use bitmasks + implicit none + $declarations + + BEGIN_DOC + END_DOC + + integer :: i,j + double precision :: diag_H_mat_elem_fock, h + double precision :: i_H_psi_array(N_st) + double precision :: coef_pert + PROVIDE selection_criterion + + ASSERT (Nint == N_int) + ASSERT (Nint > 0) + !call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) + call i_H_psi_pert_new_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array,coef_pert) + H_pert_diag = 0.d0 + + + c_pert(1) = coef_pert + e_2_pert(1) = coef_pert * i_H_psi_array(1) +! print*,coef_pert,i_H_psi_array(1) + +end + + + + subroutine pt2_epstein_nesbet_2x2 ($arguments) use bitmasks implicit none diff --git a/plugins/MRPT_Utils/pt2_new.irp.f b/plugins/Perturbation/pt2_new.irp.f similarity index 100% rename from plugins/MRPT_Utils/pt2_new.irp.f rename to plugins/Perturbation/pt2_new.irp.f diff --git a/plugins/Psiref_CAS/psi_ref.irp.f b/plugins/Psiref_CAS/psi_ref.irp.f index 8380d668..87439764 100644 --- a/plugins/Psiref_CAS/psi_ref.irp.f +++ b/plugins/Psiref_CAS/psi_ref.irp.f @@ -67,27 +67,6 @@ END_PROVIDER END_PROVIDER - - BEGIN_PROVIDER [double precision, electronic_psi_ref_average_value, (N_states)] -&BEGIN_PROVIDER [double precision, psi_ref_average_value, (N_states)] - implicit none - integer :: i,j - electronic_psi_ref_average_value = psi_energy - do i = 1, N_states - psi_ref_average_value(i) = psi_energy(i) + nuclear_repulsion - enddo - double precision :: accu,hij - accu = 0.d0 - do i = 1, N_det_ref - do j = 1, N_det_ref - call i_H_j(psi_ref(1,1,i),psi_ref(1,1,j),N_int,hij) - accu += psi_ref_coef(i,1) * psi_ref_coef(j,1) * hij - enddo - enddo - electronic_psi_ref_average_value(1) = accu - psi_ref_average_value(1) = electronic_psi_ref_average_value(1) + nuclear_repulsion - -END_PROVIDER BEGIN_PROVIDER [double precision, norm_psi_ref, (N_states)] &BEGIN_PROVIDER [double precision, inv_norm_psi_ref, (N_states)] implicit none diff --git a/plugins/SCF_density/.gitignore b/plugins/SCF_density/.gitignore deleted file mode 100644 index 9f1c0929..00000000 --- a/plugins/SCF_density/.gitignore +++ /dev/null @@ -1,25 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Electrons -Ezfio_files -Huckel_guess -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -SCF -Utils -ZMQ -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/SCF_density/EZFIO.cfg b/plugins/SCF_density/EZFIO.cfg deleted file mode 100644 index 2fa29cf0..00000000 --- a/plugins/SCF_density/EZFIO.cfg +++ /dev/null @@ -1,35 +0,0 @@ -[thresh_scf] -type: Threshold -doc: Threshold on the convergence of the Hartree Fock energy -interface: ezfio,provider,ocaml -default: 1.e-10 - -[n_it_scf_max] -type: Strictly_positive_int -doc: Maximum number of SCF iterations -interface: ezfio,provider,ocaml -default: 200 - -[level_shift] -type: Positive_float -doc: Energy shift on the virtual MOs to improve SCF convergence -interface: ezfio,provider,ocaml -default: 0.5 - -[mo_guess_type] -type: MO_guess -doc: Initial MO guess. Can be [ Huckel | HCore ] -interface: ezfio,provider,ocaml -default: Huckel - -[energy] -type: double precision -doc: Calculated HF energy -interface: ezfio - -[no_oa_or_av_opt] -type: logical -doc: If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure -interface: ezfio,provider,ocaml -default: False - diff --git a/plugins/SCF_density/Fock_matrix.irp.f b/plugins/SCF_density/Fock_matrix.irp.f deleted file mode 100644 index af9255c8..00000000 --- a/plugins/SCF_density/Fock_matrix.irp.f +++ /dev/null @@ -1,437 +0,0 @@ - BEGIN_PROVIDER [ double precision, Fock_matrix_mo, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, Fock_matrix_diag_mo, (mo_tot_num)] - implicit none - BEGIN_DOC - ! Fock matrix on the MO basis. - ! For open shells, the ROHF Fock Matrix is - ! - ! | F-K | F + K/2 | F | - ! |---------------------------------| - ! | F + K/2 | F | F - K/2 | - ! |---------------------------------| - ! | F | F - K/2 | F + K | - ! - ! F = 1/2 (Fa + Fb) - ! - ! K = Fb - Fa - ! - END_DOC - integer :: i,j,n - if (elec_alpha_num == elec_beta_num) then - Fock_matrix_mo = Fock_matrix_alpha_mo - else - - do j=1,elec_beta_num - ! F-K - do i=1,elec_beta_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - - (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - ! F+K/2 - do i=elec_beta_num+1,elec_alpha_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - + 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - ! F - do i=elec_alpha_num+1, mo_tot_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) - enddo - enddo - - do j=elec_beta_num+1,elec_alpha_num - ! F+K/2 - do i=1,elec_beta_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - + 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - ! F - do i=elec_beta_num+1,elec_alpha_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) - enddo - ! F-K/2 - do i=elec_alpha_num+1, mo_tot_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - - 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - enddo - - do j=elec_alpha_num+1, mo_tot_num - ! F - do i=1,elec_beta_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) - enddo - ! F-K/2 - do i=elec_beta_num+1,elec_alpha_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - - 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - ! F+K - do i=elec_alpha_num+1,mo_tot_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) & - + (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - enddo - - endif - - do i = 1, mo_tot_num - Fock_matrix_diag_mo(i) = Fock_matrix_mo(i,i) - enddo -END_PROVIDER - - - - BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_ao, (ao_num_align, ao_num) ] -&BEGIN_PROVIDER [ double precision, Fock_matrix_beta_ao, (ao_num_align, ao_num) ] - implicit none - BEGIN_DOC - ! Alpha Fock matrix in AO basis set - END_DOC - - integer :: i,j - do j=1,ao_num - !DIR$ VECTOR ALIGNED - do i=1,ao_num - Fock_matrix_alpha_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_alpha(i,j) - Fock_matrix_beta_ao (i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_beta (i,j) - enddo - enddo - -END_PROVIDER - - - BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_alpha, (ao_num_align, ao_num) ] -&BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_beta , (ao_num_align, ao_num) ] - use map_module - implicit none - BEGIN_DOC - ! Alpha Fock matrix in AO basis set - END_DOC - - integer :: i,j,k,l,k1,r,s - integer :: i0,j0,k0,l0 - integer*8 :: p,q - double precision :: integral, c0, c1, c2 - double precision :: ao_bielec_integral, local_threshold - double precision, allocatable :: ao_bi_elec_integral_alpha_tmp(:,:) - double precision, allocatable :: ao_bi_elec_integral_beta_tmp(:,:) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_beta_tmp - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_alpha_tmp - - ao_bi_elec_integral_alpha = 0.d0 - ao_bi_elec_integral_beta = 0.d0 - if (do_direct_integrals) then - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,p,q,r,s,i0,j0,k0,l0, & - !$OMP ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp, c0, c1, c2, & - !$OMP local_threshold)& - !$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,& - !$OMP ao_integrals_map,ao_integrals_threshold, ao_bielec_integral_schwartz, & - !$OMP ao_overlap_abs, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta) - - allocate(keys(1), values(1)) - allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), & - ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num)) - ao_bi_elec_integral_alpha_tmp = 0.d0 - ao_bi_elec_integral_beta_tmp = 0.d0 - - q = ao_num*ao_num*ao_num*ao_num - !$OMP DO SCHEDULE(dynamic) - do p=1_8,q - call bielec_integrals_index_reverse(kk,ii,ll,jj,p) - if ( (kk(1)>ao_num).or. & - (ii(1)>ao_num).or. & - (jj(1)>ao_num).or. & - (ll(1)>ao_num) ) then - cycle - endif - k = kk(1) - i = ii(1) - l = ll(1) - j = jj(1) - - if (ao_overlap_abs(k,l)*ao_overlap_abs(i,j) & - < ao_integrals_threshold) then - cycle - endif - local_threshold = ao_bielec_integral_schwartz(k,l)*ao_bielec_integral_schwartz(i,j) - if (local_threshold < ao_integrals_threshold) then - cycle - endif - i0 = i - j0 = j - k0 = k - l0 = l - values(1) = 0.d0 - local_threshold = ao_integrals_threshold/local_threshold - do k2=1,8 - if (kk(k2)==0) then - cycle - endif - i = ii(k2) - j = jj(k2) - k = kk(k2) - l = ll(k2) - c0 = HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l) - c1 = HF_density_matrix_ao_alpha(k,i) - c2 = HF_density_matrix_ao_beta(k,i) - if ( dabs(c0)+dabs(c1)+dabs(c2) < local_threshold) then - cycle - endif - if (values(1) == 0.d0) then - values(1) = ao_bielec_integral(k0,l0,i0,j0) - endif - integral = c0 * values(1) - ao_bi_elec_integral_alpha_tmp(i,j) += integral - ao_bi_elec_integral_beta_tmp (i,j) += integral - integral = values(1) - ao_bi_elec_integral_alpha_tmp(l,j) -= c1 * integral - ao_bi_elec_integral_beta_tmp (l,j) -= c2 * integral - enddo - enddo - !$OMP END DO NOWAIT - !$OMP CRITICAL - ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp - !$OMP END CRITICAL - !$OMP CRITICAL - ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp - !$OMP END CRITICAL - deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp) - !$OMP END PARALLEL - else - PROVIDE ao_bielec_integrals_in_map - - integer(omp_lock_kind) :: lck(ao_num) - integer*8 :: i8 - integer :: ii(8), jj(8), kk(8), ll(8), k2 - integer(cache_map_size_kind) :: n_elements_max, n_elements - integer(key_kind), allocatable :: keys(:) - double precision, allocatable :: values(:) - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,n_elements_max, & - !$OMP n_elements,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)& - !$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,& - !$OMP ao_integrals_map, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta) - - call get_cache_map_n_elements_max(ao_integrals_map,n_elements_max) - allocate(keys(n_elements_max), values(n_elements_max)) - allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), & - ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num)) - ao_bi_elec_integral_alpha_tmp = 0.d0 - ao_bi_elec_integral_beta_tmp = 0.d0 - - !$OMP DO SCHEDULE(dynamic) - !DIR$ NOVECTOR - do i8=0_8,ao_integrals_map%map_size - n_elements = n_elements_max - call get_cache_map(ao_integrals_map,i8,keys,values,n_elements) - do k1=1,n_elements - call bielec_integrals_index_reverse(kk,ii,ll,jj,keys(k1)) - - do k2=1,8 - if (kk(k2)==0) then - cycle - endif - i = ii(k2) - j = jj(k2) - k = kk(k2) - l = ll(k2) - integral = (HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l)) * values(k1) - ao_bi_elec_integral_alpha_tmp(i,j) += integral - ao_bi_elec_integral_beta_tmp (i,j) += integral - integral = values(k1) - ao_bi_elec_integral_alpha_tmp(l,j) -= HF_density_matrix_ao_alpha(k,i) * integral - ao_bi_elec_integral_beta_tmp (l,j) -= HF_density_matrix_ao_beta (k,i) * integral - enddo - enddo - enddo - !$OMP END DO NOWAIT - !$OMP CRITICAL - ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp - !$OMP END CRITICAL - !$OMP CRITICAL - ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp - !$OMP END CRITICAL - deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp) - !$OMP END PARALLEL - - endif - -END_PROVIDER - - - - - - -BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_mo, (mo_tot_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! Fock matrix on the MO basis - END_DOC - double precision, allocatable :: T(:,:) - allocate ( T(ao_num_align,mo_tot_num) ) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T - call dgemm('N','N', ao_num, mo_tot_num, ao_num, & - 1.d0, Fock_matrix_alpha_ao,size(Fock_matrix_alpha_ao,1), & - mo_coef, size(mo_coef,1), & - 0.d0, T, ao_num_align) - call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, & - 1.d0, mo_coef,size(mo_coef,1), & - T, size(T,1), & - 0.d0, Fock_matrix_alpha_mo, mo_tot_num_align) - deallocate(T) -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, Fock_matrix_beta_mo, (mo_tot_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! Fock matrix on the MO basis - END_DOC - double precision, allocatable :: T(:,:) - allocate ( T(ao_num_align,mo_tot_num) ) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T - call dgemm('N','N', ao_num, mo_tot_num, ao_num, & - 1.d0, Fock_matrix_beta_ao,size(Fock_matrix_beta_ao,1), & - mo_coef, size(mo_coef,1), & - 0.d0, T, ao_num_align) - call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, & - 1.d0, mo_coef,size(mo_coef,1), & - T, size(T,1), & - 0.d0, Fock_matrix_beta_mo, mo_tot_num_align) - deallocate(T) -END_PROVIDER - -BEGIN_PROVIDER [ double precision, HF_energy ] - implicit none - BEGIN_DOC - ! Hartree-Fock energy - END_DOC - HF_energy = nuclear_repulsion - - integer :: i,j - do j=1,ao_num - do i=1,ao_num - HF_energy += 0.5d0 * ( & - (ao_mono_elec_integral(i,j) + Fock_matrix_alpha_ao(i,j) ) * HF_density_matrix_ao_alpha(i,j) +& - (ao_mono_elec_integral(i,j) + Fock_matrix_beta_ao (i,j) ) * HF_density_matrix_ao_beta (i,j) ) - enddo - enddo - -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, Fock_matrix_ao, (ao_num_align, ao_num) ] - implicit none - BEGIN_DOC - ! Fock matrix in AO basis set - END_DOC - - if ( (elec_alpha_num == elec_beta_num).and. & - (level_shift == 0.) ) & - then - integer :: i,j - do j=1,ao_num - !DIR$ VECTOR ALIGNED - do i=1,ao_num_align - Fock_matrix_ao(i,j) = Fock_matrix_alpha_ao(i,j) - enddo - enddo - else - double precision, allocatable :: T(:,:), M(:,:) - integer :: ierr - ! F_ao = S C F_mo C^t S - allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr) - if (ierr /=0 ) then - print *, irp_here, ' : allocation failed' - endif - -! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num) -! -> M(ao_num,mo_tot_num) - call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, & - ao_overlap, size(ao_overlap,1), & - mo_coef, size(mo_coef,1), & - 0.d0, & - M, size(M,1)) - -! M(ao_num,mo_tot_num) . Fock_matrix_mo (mo_tot_num,mo_tot_num) -! -> T(ao_num,mo_tot_num) - call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, & - M, size(M,1), & - Fock_matrix_mo, size(Fock_matrix_mo,1), & - 0.d0, & - T, size(T,1)) - -! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num) -! -> M(ao_num,ao_num) - call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, & - T, size(T,1), & - mo_coef, size(mo_coef,1), & - 0.d0, & - M, size(M,1)) - -! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num) -! -> Fock_matrix_ao(ao_num,ao_num) - call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, & - M, size(M,1), & - ao_overlap, size(ao_overlap,1), & - 0.d0, & - Fock_matrix_ao, size(Fock_matrix_ao,1)) - - - deallocate(T) - endif -END_PROVIDER - -subroutine Fock_mo_to_ao(FMO,LDFMO,FAO,LDFAO) - implicit none - integer, intent(in) :: LDFMO ! size(FMO,1) - integer, intent(in) :: LDFAO ! size(FAO,1) - double precision, intent(in) :: FMO(LDFMO,*) - double precision, intent(out) :: FAO(LDFAO,*) - - double precision, allocatable :: T(:,:), M(:,:) - integer :: ierr - ! F_ao = S C F_mo C^t S - allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr) - if (ierr /=0 ) then - print *, irp_here, ' : allocation failed' - endif - -! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num) -! -> M(ao_num,mo_tot_num) - call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, & - ao_overlap, size(ao_overlap,1), & - mo_coef, size(mo_coef,1), & - 0.d0, & - M, size(M,1)) - -! M(ao_num,mo_tot_num) . FMO (mo_tot_num,mo_tot_num) -! -> T(ao_num,mo_tot_num) - call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, & - M, size(M,1), & - FMO, size(FMO,1), & - 0.d0, & - T, size(T,1)) - -! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num) -! -> M(ao_num,ao_num) - call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, & - T, size(T,1), & - mo_coef, size(mo_coef,1), & - 0.d0, & - M, size(M,1)) - -! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num) -! -> Fock_matrix_ao(ao_num,ao_num) - call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, & - M, size(M,1), & - ao_overlap, size(ao_overlap,1), & - 0.d0, & - FAO, size(FAO,1)) - deallocate(T,M) -end - diff --git a/plugins/SCF_density/HF_density_matrix_ao.irp.f b/plugins/SCF_density/HF_density_matrix_ao.irp.f deleted file mode 100644 index a9d601c7..00000000 --- a/plugins/SCF_density/HF_density_matrix_ao.irp.f +++ /dev/null @@ -1,66 +0,0 @@ -BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_alpha, (ao_num_align,ao_num) ] - implicit none - BEGIN_DOC - ! S^-1 x Alpha density matrix in the AO basis x S^-1 - END_DOC - -! call dgemm('N','T',ao_num,ao_num,elec_alpha_num,1.d0, & -! mo_coef, size(mo_coef,1), & -! mo_coef, size(mo_coef,1), 0.d0, & -! HF_density_matrix_ao_alpha, size(HF_density_matrix_ao_alpha,1)) - integer :: i,j,k,l - double precision :: test_alpha - HF_density_matrix_ao_alpha = 0.d0 - do i = 1, mo_tot_num - do j = 1, mo_tot_num - if(dabs(mo_general_density_alpha(i,j)).le.1.d-10)cycle - do k = 1, ao_num - do l = 1, ao_num - HF_density_matrix_ao_alpha(k,l) += mo_coef(k,i) * mo_coef(l,j) * mo_general_density_alpha(i,j) - enddo - enddo - enddo - enddo - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_beta, (ao_num_align,ao_num) ] - implicit none - BEGIN_DOC - ! S^-1 Beta density matrix in the AO basis x S^-1 - END_DOC - -! call dgemm('N','T',ao_num,ao_num,elec_beta_num,1.d0, & -! mo_coef, size(mo_coef,1), & -! mo_coef, size(mo_coef,1), 0.d0, & -! HF_density_matrix_ao_beta, size(HF_density_matrix_ao_beta,1)) - integer :: i,j,k,l - double precision :: test_beta - HF_density_matrix_ao_beta = 0.d0 - do i = 1, mo_tot_num - do j = 1, mo_tot_num - do k = 1, ao_num - do l = 1, ao_num - HF_density_matrix_ao_beta(k,l) += mo_coef(k,i) * mo_coef(l,j) * mo_general_density_beta(i,j) - enddo - enddo - enddo - enddo - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, HF_density_matrix_ao, (ao_num_align,ao_num) ] - implicit none - BEGIN_DOC - ! S^-1 Density matrix in the AO basis S^-1 - END_DOC - ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_alpha,1)) - if (elec_alpha_num== elec_beta_num) then - HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_alpha - else - ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_beta ,1)) - HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_beta - endif - -END_PROVIDER - diff --git a/plugins/SCF_density/NEEDED_CHILDREN_MODULES b/plugins/SCF_density/NEEDED_CHILDREN_MODULES deleted file mode 100644 index a52d6e8e..00000000 --- a/plugins/SCF_density/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Integrals_Bielec MOGuess Bitmask diff --git a/plugins/SCF_density/README.rst b/plugins/SCF_density/README.rst deleted file mode 100644 index 0699bf28..00000000 --- a/plugins/SCF_density/README.rst +++ /dev/null @@ -1,175 +0,0 @@ -=================== -SCF_density Module -=================== - -From the 140 molecules of the G2 set, only LiO, ONa don't converge well. - -Needed Modules -============== - -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. - -.. image:: tree_dependency.png - -* `Integrals_Bielec `_ -* `MOGuess `_ - -Needed Modules -============== -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. - - -.. image:: tree_dependency.png - -* `Integrals_Bielec `_ -* `MOGuess `_ -* `Bitmask `_ - -Documentation -============= -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. - - -`ao_bi_elec_integral_alpha `_ - Alpha Fock matrix in AO basis set - - -`ao_bi_elec_integral_beta `_ - Alpha Fock matrix in AO basis set - - -`create_guess `_ - Create an MO guess if no MOs are present in the EZFIO directory - - -`damping_scf `_ - Undocumented - - -`diagonal_fock_matrix_mo `_ - Diagonal Fock matrix in the MO basis - - -`diagonal_fock_matrix_mo_sum `_ - diagonal element of the fock matrix calculated as the sum over all the interactions - with all the electrons in the RHF determinant - diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij - - -`eigenvectors_fock_matrix_mo `_ - Diagonal Fock matrix in the MO basis - - -`fock_matrix_alpha_ao `_ - Alpha Fock matrix in AO basis set - - -`fock_matrix_alpha_mo `_ - Fock matrix on the MO basis - - -`fock_matrix_ao `_ - Fock matrix in AO basis set - - -`fock_matrix_beta_ao `_ - Alpha Fock matrix in AO basis set - - -`fock_matrix_beta_mo `_ - Fock matrix on the MO basis - - -`fock_matrix_diag_mo `_ - Fock matrix on the MO basis. - For open shells, the ROHF Fock Matrix is - .br - | F-K | F + K/2 | F | - |---------------------------------| - | F + K/2 | F | F - K/2 | - |---------------------------------| - | F | F - K/2 | F + K | - .br - F = 1/2 (Fa + Fb) - .br - K = Fb - Fa - .br - - -`fock_matrix_mo `_ - Fock matrix on the MO basis. - For open shells, the ROHF Fock Matrix is - .br - | F-K | F + K/2 | F | - |---------------------------------| - | F + K/2 | F | F - K/2 | - |---------------------------------| - | F | F - K/2 | F + K | - .br - F = 1/2 (Fa + Fb) - .br - K = Fb - Fa - .br - - -`fock_mo_to_ao `_ - Undocumented - - -`guess `_ - Undocumented - - -`hf_density_matrix_ao `_ - S^-1 Density matrix in the AO basis S^-1 - - -`hf_density_matrix_ao_alpha `_ - S^-1 x Alpha density matrix in the AO basis x S^-1 - - -`hf_density_matrix_ao_beta `_ - S^-1 Beta density matrix in the AO basis x S^-1 - - -`hf_energy `_ - Hartree-Fock energy - - -`huckel_guess `_ - Build the MOs using the extended Huckel model - - -`level_shift `_ - Energy shift on the virtual MOs to improve SCF convergence - - -`mo_guess_type `_ - Initial MO guess. Can be [ Huckel | HCore ] - - -`n_it_scf_max `_ - Maximum number of SCF iterations - - -`no_oa_or_av_opt `_ - If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure - - -`run `_ - Run SCF calculation - - -`scf `_ - Produce `Hartree_Fock` MO orbital - output: mo_basis.mo_tot_num mo_basis.mo_label mo_basis.ao_md5 mo_basis.mo_coef mo_basis.mo_occ - output: hartree_fock.energy - optional: mo_basis.mo_coef - - -`thresh_scf `_ - Threshold on the convergence of the Hartree Fock energy - diff --git a/plugins/SCF_density/damping_SCF.irp.f b/plugins/SCF_density/damping_SCF.irp.f deleted file mode 100644 index aa6f02b0..00000000 --- a/plugins/SCF_density/damping_SCF.irp.f +++ /dev/null @@ -1,132 +0,0 @@ -subroutine damping_SCF - implicit none - double precision :: E - double precision, allocatable :: D_alpha(:,:), D_beta(:,:) - double precision :: E_new - double precision, allocatable :: D_new_alpha(:,:), D_new_beta(:,:), F_new(:,:) - double precision, allocatable :: delta_alpha(:,:), delta_beta(:,:) - double precision :: lambda, E_half, a, b, delta_D, delta_E, E_min - - integer :: i,j,k - logical :: saving - character :: save_char - - allocate( & - D_alpha( ao_num_align, ao_num ), & - D_beta( ao_num_align, ao_num ), & - F_new( ao_num_align, ao_num ), & - D_new_alpha( ao_num_align, ao_num ), & - D_new_beta( ao_num_align, ao_num ), & - delta_alpha( ao_num_align, ao_num ), & - delta_beta( ao_num_align, ao_num )) - - do j=1,ao_num - do i=1,ao_num - D_alpha(i,j) = HF_density_matrix_ao_alpha(i,j) - D_beta (i,j) = HF_density_matrix_ao_beta (i,j) - enddo - enddo - - - call write_time(output_hartree_fock) - - write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & - '====','================','================','================', '====' - write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & - ' N ', 'Energy ', 'Energy diff ', 'Density diff ', 'Save' - write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & - '====','================','================','================', '====' - - E = HF_energy + 1.d0 - E_min = HF_energy - delta_D = 0.d0 - do k=1,n_it_scf_max - - delta_E = HF_energy - E - E = HF_energy - - if ( (delta_E < 0.d0).and.(dabs(delta_E) < thresh_scf) ) then - exit - endif - - saving = E < E_min - if (saving) then - call save_mos - save_char = 'X' - E_min = E - else - save_char = ' ' - endif - - write(output_hartree_fock,'(I4,1X,F16.10, 1X, F16.10, 1X, F16.10, 3X, A )') & - k, E, delta_E, delta_D, save_char - - D_alpha = HF_density_matrix_ao_alpha - D_beta = HF_density_matrix_ao_beta - mo_coef = eigenvectors_fock_matrix_mo - TOUCH mo_coef - - D_new_alpha = HF_density_matrix_ao_alpha - D_new_beta = HF_density_matrix_ao_beta - F_new = Fock_matrix_ao - E_new = HF_energy - - delta_alpha = D_new_alpha - D_alpha - delta_beta = D_new_beta - D_beta - - lambda = .5d0 - E_half = 0.d0 - do while (E_half > E) - HF_density_matrix_ao_alpha = D_alpha + lambda * delta_alpha - HF_density_matrix_ao_beta = D_beta + lambda * delta_beta - TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta - mo_coef = eigenvectors_fock_matrix_mo - TOUCH mo_coef - E_half = HF_energy - if ((E_half > E).and.(E_new < E)) then - lambda = 1.d0 - exit - else if ((E_half > E).and.(lambda > 5.d-4)) then - lambda = 0.5d0 * lambda - E_new = E_half - else - exit - endif - enddo - - a = (E_new + E - 2.d0*E_half)*2.d0 - b = -E_new - 3.d0*E + 4.d0*E_half - lambda = -lambda*b/(a+1.d-16) - D_alpha = (1.d0-lambda) * D_alpha + lambda * D_new_alpha - D_beta = (1.d0-lambda) * D_beta + lambda * D_new_beta - delta_E = HF_energy - E - do j=1,ao_num - do i=1,ao_num - delta_D = delta_D + & - (D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j))*(D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j)) + & - (D_beta (i,j) - HF_density_matrix_ao_beta (i,j))*(D_beta (i,j) - HF_density_matrix_ao_beta (i,j)) - enddo - enddo - delta_D = dsqrt(delta_D/dble(ao_num)**2) - HF_density_matrix_ao_alpha = D_alpha - HF_density_matrix_ao_beta = D_beta - TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta - mo_coef = eigenvectors_fock_matrix_mo - TOUCH mo_coef - - - enddo - write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') '====','================','================','================', '====' - write(output_hartree_fock,*) - - if(.not.no_oa_or_av_opt)then - call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label,1) - endif - - call write_double(output_hartree_fock, E_min, 'Hartree-Fock energy') - call ezfio_set_hartree_fock_energy(E_min) - - call write_time(output_hartree_fock) - - deallocate(D_alpha,D_beta,F_new,D_new_alpha,D_new_beta,delta_alpha,delta_beta) -end diff --git a/plugins/SCF_density/diagonalize_fock.irp.f b/plugins/SCF_density/diagonalize_fock.irp.f deleted file mode 100644 index 2983abeb..00000000 --- a/plugins/SCF_density/diagonalize_fock.irp.f +++ /dev/null @@ -1,124 +0,0 @@ - BEGIN_PROVIDER [ double precision, diagonal_Fock_matrix_mo, (ao_num) ] -&BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! Diagonal Fock matrix in the MO basis - END_DOC - - integer :: i,j - integer :: liwork, lwork, n, info - integer, allocatable :: iwork(:) - double precision, allocatable :: work(:), F(:,:), S(:,:) - - - allocate( F(mo_tot_num_align,mo_tot_num) ) - do j=1,mo_tot_num - do i=1,mo_tot_num - F(i,j) = Fock_matrix_mo(i,j) - enddo - enddo -! print*, no_oa_or_av_opt - if(no_oa_or_av_opt)then - integer :: iorb,jorb - do i = 1, n_act_orb - iorb = list_act(i) - do j = 1, n_inact_orb - jorb = list_inact(j) - F(iorb,jorb) = 0.d0 - F(jorb,iorb) = 0.d0 - enddo - do j = 1, n_virt_orb - jorb = list_virt(j) - F(iorb,jorb) = 0.d0 - F(jorb,iorb) = 0.d0 - enddo - do j = 1, n_core_orb - jorb = list_core(j) - F(iorb,jorb) = 0.d0 - F(jorb,iorb) = 0.d0 - enddo - enddo -! do i = 1, n_act_orb -! iorb = list_act(i) -! write(*,'(100(F16.10,X))')F(iorb,:) -! enddo - endif - - - - - ! Insert level shift here - do i = elec_beta_num+1, elec_alpha_num - F(i,i) += 0.5d0*level_shift - enddo - - do i = elec_alpha_num+1, mo_tot_num - F(i,i) += level_shift - enddo - - n = mo_tot_num - lwork = 1+6*n + 2*n*n - liwork = 3 + 5*n - - allocate(work(lwork), iwork(liwork) ) - - lwork = -1 - liwork = -1 - - call dsyevd( 'V', 'U', mo_tot_num, F, & - size(F,1), diagonal_Fock_matrix_mo, & - work, lwork, iwork, liwork, info) - - if (info /= 0) then - print *, irp_here//' failed : ', info - stop 1 - endif - lwork = int(work(1)) - liwork = iwork(1) - deallocate(work,iwork) - allocate(work(lwork), iwork(liwork) ) - - call dsyevd( 'V', 'U', mo_tot_num, F, & - size(F,1), diagonal_Fock_matrix_mo, & - work, lwork, iwork, liwork, info) - - if (info /= 0) then - print *, irp_here//' failed : ', info - stop 1 - endif - - call dgemm('N','N',ao_num,mo_tot_num,mo_tot_num, 1.d0, & - mo_coef, size(mo_coef,1), F, size(F,1), & - 0.d0, eigenvectors_Fock_matrix_mo, size(eigenvectors_Fock_matrix_mo,1)) - deallocate(work, iwork, F) - - -! endif - -END_PROVIDER - -BEGIN_PROVIDER [double precision, diagonal_Fock_matrix_mo_sum, (mo_tot_num)] - implicit none - BEGIN_DOC - ! diagonal element of the fock matrix calculated as the sum over all the interactions - ! with all the electrons in the RHF determinant - ! diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij - END_DOC - integer :: i,j - double precision :: accu - do j = 1,elec_alpha_num - accu = 0.d0 - do i = 1, elec_alpha_num - accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j) - enddo - diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j) - enddo - do j = elec_alpha_num+1,mo_tot_num - accu = 0.d0 - do i = 1, elec_alpha_num - accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j) - enddo - diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j) - enddo - -END_PROVIDER diff --git a/plugins/SCF_density/huckel.irp.f b/plugins/SCF_density/huckel.irp.f deleted file mode 100644 index 103de83a..00000000 --- a/plugins/SCF_density/huckel.irp.f +++ /dev/null @@ -1,32 +0,0 @@ -subroutine huckel_guess - implicit none - BEGIN_DOC -! Build the MOs using the extended Huckel model - END_DOC - integer :: i,j - double precision :: accu - double precision :: c - character*(64) :: label - - label = "Guess" - call mo_as_eigvectors_of_mo_matrix(mo_mono_elec_integral, & - size(mo_mono_elec_integral,1), & - size(mo_mono_elec_integral,2),label,1) - TOUCH mo_coef - - c = 0.5d0 * 1.75d0 - - do j=1,ao_num - !DIR$ VECTOR ALIGNED - do i=1,ao_num - Fock_matrix_ao(i,j) = c*ao_overlap(i,j)*(ao_mono_elec_integral_diag(i) + & - ao_mono_elec_integral_diag(j)) - enddo - Fock_matrix_ao(j,j) = Fock_matrix_alpha_ao(j,j) - enddo - TOUCH Fock_matrix_ao - mo_coef = eigenvectors_fock_matrix_mo - SOFT_TOUCH mo_coef - call save_mos - -end diff --git a/plugins/Slater_rules_DFT/NEEDED_CHILDREN_MODULES b/plugins/Slater_rules_DFT/NEEDED_CHILDREN_MODULES deleted file mode 100644 index 994f4bf6..00000000 --- a/plugins/Slater_rules_DFT/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Determinants Integrals_restart_DFT Davidson diff --git a/plugins/Slater_rules_DFT/README.rst b/plugins/Slater_rules_DFT/README.rst deleted file mode 100644 index f492095e..00000000 --- a/plugins/Slater_rules_DFT/README.rst +++ /dev/null @@ -1,12 +0,0 @@ -================ -Slater_rules_DFT -================ - -Needed Modules -============== -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. -Documentation -============= -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. diff --git a/plugins/Slater_rules_DFT/Slater_rules_DFT.main.irp.f b/plugins/Slater_rules_DFT/Slater_rules_DFT.main.irp.f deleted file mode 100644 index 3d99e376..00000000 --- a/plugins/Slater_rules_DFT/Slater_rules_DFT.main.irp.f +++ /dev/null @@ -1,38 +0,0 @@ -program Slater_rules_DFT - implicit none - BEGIN_DOC -! TODO - END_DOC - print *, ' _/ ' - print *, ' -:\_?, _Jm####La ' - print *, 'J"(:" > _]#AZ#Z#UUZ##, ' - print *, '_,::./ %(|i%12XmX1*1XL _?, ' - print *, ' \..\ _\(vmWQwodY+ia%lnL _",/ ( ' - print *, ' .:< ]J=mQD?WXn|,)nr" ' - print *, ' 4XZ#Xov1v}=)vnXAX1nnv;1n" ' - print *, ' ]XX#ZXoovvvivnnnlvvo2*i7 ' - print *, ' "23Z#1S2oo2XXSnnnoSo2>v" ' - print *, ' miX#L -~`""!!1}oSoe|i7 ' - print *, ' 4cn#m, v221=|v[ ' - print *, ' ]hI3Zma,;..__wXSe=+vo ' - print *, ' ]Zov*XSUXXZXZXSe||vo2 ' - print *, ' ]Z#>=|< ' - print *, ' -ziiiii||||||+||==+> ' - print *, ' -%|+++||=|=+|=|==/ ' - print *, ' -a>====+|====-:- ' - print *, ' "~,- -- /- ' - print *, ' -. )> ' - print *, ' .~ +- ' - print *, ' . .... : . ' - print *, ' -------~ ' - print *, '' -end diff --git a/plugins/Slater_rules_DFT/energy.irp.f b/plugins/Slater_rules_DFT/energy.irp.f deleted file mode 100644 index 7734d73e..00000000 --- a/plugins/Slater_rules_DFT/energy.irp.f +++ /dev/null @@ -1,7 +0,0 @@ -! BEGIN_PROVIDER [double precision, energy_total] -!&BEGIN_PROVIDER [double precision, energy_one_electron] -!&BEGIN_PROVIDER [double precision, energy_hartree] -!&BEGIN_PROVIDER [double precision, energy] -! implicit none -! -!END_PROVIDER diff --git a/plugins/Slater_rules_DFT/slater_rules_erf.irp.f b/plugins/Slater_rules_DFT/slater_rules_erf.irp.f deleted file mode 100644 index 64d5d217..00000000 --- a/plugins/Slater_rules_DFT/slater_rules_erf.irp.f +++ /dev/null @@ -1,445 +0,0 @@ - -subroutine i_H_j_erf(key_i,key_j,Nint,hij) - use bitmasks - implicit none - BEGIN_DOC - ! Returns where i and j are determinants - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) - double precision, intent(out) :: hij - - integer :: exc(0:2,2,2) - integer :: degree - double precision :: get_mo_bielec_integral_erf - integer :: m,n,p,q - integer :: i,j,k - integer :: occ(Nint*bit_kind_size,2) - double precision :: diag_H_mat_elem_erf, phase,phase_2 - integer :: n_occ_ab(2) - PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_map big_array_exchange_integrals_erf - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num) - ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) - - hij = 0.d0 - !DIR$ FORCEINLINE - call get_excitation_degree(key_i,key_j,degree,Nint) - integer :: spin - select case (degree) - case (2) - call get_double_excitation(key_i,key_j,exc,phase,Nint) - if (exc(0,1,1) == 1) then - ! Mono alpha, mono beta - if(exc(1,1,1) == exc(1,2,2) )then - hij = phase * big_array_exchange_integrals(exc(1,1,1),exc(1,1,2),exc(1,2,1)) - else if (exc(1,2,1) ==exc(1,1,2))then - hij = phase * big_array_exchange_integrals(exc(1,2,1),exc(1,1,1),exc(1,2,2)) - else - hij = phase*get_mo_bielec_integral_erf( & - exc(1,1,1), & - exc(1,1,2), & - exc(1,2,1), & - exc(1,2,2) ,mo_integrals_erf_map) - endif - else if (exc(0,1,1) == 2) then - ! Double alpha - hij = phase*(get_mo_bielec_integral_erf( & - exc(1,1,1), & - exc(2,1,1), & - exc(1,2,1), & - exc(2,2,1) ,mo_integrals_erf_map) - & - get_mo_bielec_integral_erf( & - exc(1,1,1), & - exc(2,1,1), & - exc(2,2,1), & - exc(1,2,1) ,mo_integrals_erf_map) ) - else if (exc(0,1,2) == 2) then - ! Double beta - hij = phase*(get_mo_bielec_integral_erf( & - exc(1,1,2), & - exc(2,1,2), & - exc(1,2,2), & - exc(2,2,2) ,mo_integrals_erf_map) - & - get_mo_bielec_integral_erf( & - exc(1,1,2), & - exc(2,1,2), & - exc(2,2,2), & - exc(1,2,2) ,mo_integrals_erf_map) ) - endif - case (1) - call get_mono_excitation(key_i,key_j,exc,phase,Nint) - !DIR$ FORCEINLINE - call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) - if (exc(0,1,1) == 1) then - ! Mono alpha - m = exc(1,1,1) - p = exc(1,2,1) - spin = 1 - do i = 1, n_occ_ab(1) - hij += -big_array_exchange_integrals_erf(occ(i,1),m,p) + big_array_coulomb_integrals_erf(occ(i,1),m,p) - enddo - do i = 1, n_occ_ab(2) - hij += big_array_coulomb_integrals_erf(occ(i,2),m,p) - enddo - else - ! Mono beta - m = exc(1,1,2) - p = exc(1,2,2) - spin = 2 - do i = 1, n_occ_ab(2) - hij += -big_array_exchange_integrals_erf(occ(i,2),m,p) + big_array_coulomb_integrals_erf(occ(i,2),m,p) - enddo - do i = 1, n_occ_ab(1) - hij += big_array_coulomb_integrals_erf(occ(i,1),m,p) - enddo - endif - hij = hij + mo_nucl_elec_integral(m,p) + mo_kinetic_integral(m,p) - hij = hij * phase - case (0) - hij = diag_H_mat_elem_erf(key_i,Nint) - end select -end - -double precision function diag_H_mat_elem_erf(key_i,Nint) - implicit none - integer(bit_kind), intent(in) :: key_i(N_int,2) - integer, intent(in) :: Nint - integer :: i,j - integer :: occ(Nint*bit_kind_size,2) - integer :: n_occ_ab(2) - call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) - diag_H_mat_elem_erf = 0.d0 - ! alpha - alpha - do i = 1, n_occ_ab(1) - diag_H_mat_elem_erf += mo_nucl_elec_integral(occ(i,1),mo_nucl_elec_integral(i,1)) - do j = i+1, n_occ_ab(1) - diag_H_mat_elem_erf += mo_bielec_integral_erf_jj_anti(occ(i,1),occ(j,1)) - enddo - enddo - - ! beta - beta - do i = 1, n_occ_ab(2) - diag_H_mat_elem_erf += mo_nucl_elec_integral(occ(i,2),mo_nucl_elec_integral(i,2)) - do j = i+1, n_occ_ab(2) - diag_H_mat_elem_erf += mo_bielec_integral_erf_jj_anti(occ(i,2),occ(j,2)) - enddo - enddo - - ! alpha - beta - do i = 1, n_occ_ab(1) - do j = 1, n_occ_ab(2) - diag_H_mat_elem_erf += mo_bielec_integral_erf_jj(occ(i,1),occ(j,2)) - enddo - enddo - -end - - - -subroutine i_H_j_erf_and_short_coulomb(key_i,key_j,Nint,hij) - use bitmasks - implicit none - BEGIN_DOC - ! Returns where i and j are determinants - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) - double precision, intent(out) :: hij - - integer :: exc(0:2,2,2) - integer :: degree - double precision :: get_mo_bielec_integral_erf - integer :: m,n,p,q - integer :: i,j,k - integer :: occ(Nint*bit_kind_size,2) - double precision :: diag_H_mat_elem_erf, phase,phase_2 - integer :: n_occ_ab(2) - PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_map big_array_exchange_integrals_erf - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num) - ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) - - hij = 0.d0 - !DIR$ FORCEINLINE - call get_excitation_degree(key_i,key_j,degree,Nint) - integer :: spin - select case (degree) - case (2) - call get_double_excitation(key_i,key_j,exc,phase,Nint) - if (exc(0,1,1) == 1) then - ! Mono alpha, mono beta - if(exc(1,1,1) == exc(1,2,2) )then - hij = phase * big_array_exchange_integrals(exc(1,1,1),exc(1,1,2),exc(1,2,1)) - else if (exc(1,2,1) ==exc(1,1,2))then - hij = phase * big_array_exchange_integrals(exc(1,2,1),exc(1,1,1),exc(1,2,2)) - else - hij = phase*get_mo_bielec_integral_erf( & - exc(1,1,1), & - exc(1,1,2), & - exc(1,2,1), & - exc(1,2,2) ,mo_integrals_erf_map) - endif - else if (exc(0,1,1) == 2) then - ! Double alpha - hij = phase*(get_mo_bielec_integral_erf( & - exc(1,1,1), & - exc(2,1,1), & - exc(1,2,1), & - exc(2,2,1) ,mo_integrals_erf_map) - & - get_mo_bielec_integral_erf( & - exc(1,1,1), & - exc(2,1,1), & - exc(2,2,1), & - exc(1,2,1) ,mo_integrals_erf_map) ) - else if (exc(0,1,2) == 2) then - ! Double beta - hij = phase*(get_mo_bielec_integral_erf( & - exc(1,1,2), & - exc(2,1,2), & - exc(1,2,2), & - exc(2,2,2) ,mo_integrals_erf_map) - & - get_mo_bielec_integral_erf( & - exc(1,1,2), & - exc(2,1,2), & - exc(2,2,2), & - exc(1,2,2) ,mo_integrals_erf_map) ) - endif - case (1) - call get_mono_excitation(key_i,key_j,exc,phase,Nint) - !DIR$ FORCEINLINE - call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) - if (exc(0,1,1) == 1) then - ! Mono alpha - m = exc(1,1,1) - p = exc(1,2,1) - spin = 1 - do i = 1, n_occ_ab(1) - hij += -big_array_exchange_integrals_erf(occ(i,1),m,p) + big_array_coulomb_integrals_erf(occ(i,1),m,p) - enddo - do i = 1, n_occ_ab(2) - hij += big_array_coulomb_integrals_erf(occ(i,2),m,p) - enddo - else - ! Mono beta - m = exc(1,1,2) - p = exc(1,2,2) - spin = 2 - do i = 1, n_occ_ab(2) - hij += -big_array_exchange_integrals_erf(occ(i,2),m,p) + big_array_coulomb_integrals_erf(occ(i,2),m,p) - enddo - do i = 1, n_occ_ab(1) - hij += big_array_coulomb_integrals_erf(occ(i,1),m,p) - enddo - endif - hij = hij + mo_nucl_elec_integral(m,p) + mo_kinetic_integral(m,p) + effective_short_range_operator(m,p) - hij = hij * phase - case (0) - hij = diag_H_mat_elem_erf(key_i,Nint) - end select -end - -double precision function diag_H_mat_elem_erf_and_short_coulomb(key_i,Nint) - implicit none - integer(bit_kind), intent(in) :: key_i(N_int,2) - integer, intent(in) :: Nint - integer :: i,j - integer :: occ(Nint*bit_kind_size,2) - integer :: n_occ_ab(2) - - call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) - diag_H_mat_elem_erf_and_short_coulomb = 0.d0 - ! alpha - alpha - do i = 1, n_occ_ab(1) - diag_H_mat_elem_erf_and_short_coulomb += mo_nucl_elec_integral(occ(i,1),mo_nucl_elec_integral(i,1)) + mo_kinetic_integral(occ(i,1),mo_nucl_elec_integral(i,1)) & - + effective_short_range_operator(occ(i,1),occ(i,1)) - do j = i+1, n_occ_ab(1) - diag_H_mat_elem_erf_and_short_coulomb += mo_bielec_integral_erf_jj_anti(occ(i,1),occ(j,1)) - enddo - enddo - - ! beta - beta - do i = 1, n_occ_ab(2) - diag_H_mat_elem_erf_and_short_coulomb += mo_nucl_elec_integral(occ(i,2),mo_nucl_elec_integral(i,2)) + mo_kinetic_integral(occ(i,2),mo_nucl_elec_integral(i,2)) & - + effective_short_range_operator(occ(i,2),occ(i,2)) - do j = i+1, n_occ_ab(2) - diag_H_mat_elem_erf_and_short_coulomb += mo_bielec_integral_erf_jj_anti(occ(i,2),occ(j,2)) - enddo - enddo - - ! alpha - beta - do i = 1, n_occ_ab(1) - do j = 1, n_occ_ab(2) - diag_H_mat_elem_erf_and_short_coulomb += mo_bielec_integral_erf_jj(occ(i,1),occ(j,2)) - enddo - enddo - -end - - -subroutine i_H_j_erf_component(key_i,key_j,Nint,hij_core,hij_hartree,hij_erf,hij_total) - use bitmasks - implicit none - BEGIN_DOC - ! Returns where i and j are determinants - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) - double precision, intent(out) :: hij_core - double precision, intent(out) :: hij_hartree - double precision, intent(out) :: hij_erf - double precision, intent(out) :: hij_total - - integer :: exc(0:2,2,2) - integer :: degree - double precision :: get_mo_bielec_integral_erf - integer :: m,n,p,q - integer :: i,j,k - integer :: occ(Nint*bit_kind_size,2) - double precision :: diag_H_mat_elem_erf, phase,phase_2 - integer :: n_occ_ab(2) - PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_map big_array_exchange_integrals_erf - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num) - ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) - - hij_core = 0.d0 - hij_hartree = 0.d0 - hij_erf = 0.d0 - - !DIR$ FORCEINLINE - call get_excitation_degree(key_i,key_j,degree,Nint) - integer :: spin - select case (degree) - case (2) - call get_double_excitation(key_i,key_j,exc,phase,Nint) - if (exc(0,1,1) == 1) then - ! Mono alpha, mono beta - if(exc(1,1,1) == exc(1,2,2) )then - hij_erf = phase * big_array_exchange_integrals(exc(1,1,1),exc(1,1,2),exc(1,2,1)) - else if (exc(1,2,1) ==exc(1,1,2))then - hij_erf = phase * big_array_exchange_integrals(exc(1,2,1),exc(1,1,1),exc(1,2,2)) - else - hij_erf = phase*get_mo_bielec_integral_erf( & - exc(1,1,1), & - exc(1,1,2), & - exc(1,2,1), & - exc(1,2,2) ,mo_integrals_erf_map) - endif - else if (exc(0,1,1) == 2) then - ! Double alpha - hij_erf = phase*(get_mo_bielec_integral_erf( & - exc(1,1,1), & - exc(2,1,1), & - exc(1,2,1), & - exc(2,2,1) ,mo_integrals_erf_map) - & - get_mo_bielec_integral_erf( & - exc(1,1,1), & - exc(2,1,1), & - exc(2,2,1), & - exc(1,2,1) ,mo_integrals_erf_map) ) - else if (exc(0,1,2) == 2) then - ! Double beta - hij_erf = phase*(get_mo_bielec_integral_erf( & - exc(1,1,2), & - exc(2,1,2), & - exc(1,2,2), & - exc(2,2,2) ,mo_integrals_erf_map) - & - get_mo_bielec_integral_erf( & - exc(1,1,2), & - exc(2,1,2), & - exc(2,2,2), & - exc(1,2,2) ,mo_integrals_erf_map) ) - endif - case (1) - call get_mono_excitation(key_i,key_j,exc,phase,Nint) - !DIR$ FORCEINLINE - call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) - if (exc(0,1,1) == 1) then - ! Mono alpha - m = exc(1,1,1) - p = exc(1,2,1) - spin = 1 - do i = 1, n_occ_ab(1) - hij_erf += -big_array_exchange_integrals_erf(occ(i,1),m,p) + big_array_coulomb_integrals_erf(occ(i,1),m,p) - enddo - do i = 1, n_occ_ab(2) - hij_erf += big_array_coulomb_integrals_erf(occ(i,2),m,p) - enddo - else - ! Mono beta - m = exc(1,1,2) - p = exc(1,2,2) - spin = 2 - do i = 1, n_occ_ab(2) - hij_erf += -big_array_exchange_integrals_erf(occ(i,2),m,p) + big_array_coulomb_integrals_erf(occ(i,2),m,p) - enddo - do i = 1, n_occ_ab(1) - hij_erf += big_array_coulomb_integrals_erf(occ(i,1),m,p) - enddo - endif - hij_core = mo_nucl_elec_integral(m,p) + mo_kinetic_integral(m,p) - hij_hartree = effective_short_range_operator(m,p) - hij_total = (hij_erf + hij_core + hij_hartree) * phase - case (0) - call diag_H_mat_elem_erf_component(key_i,hij_core,hij_hartree,hij_erf,hij_total,Nint) - end select -end - -subroutine diag_H_mat_elem_erf_component(key_i,hij_core,hij_hartree,hij_erf,hij_total,Nint) - implicit none - integer(bit_kind), intent(in) :: key_i(N_int,2) - integer, intent(in) :: Nint - double precision, intent(out) :: hij_core - double precision, intent(out) :: hij_hartree - double precision, intent(out) :: hij_erf - double precision, intent(out) :: hij_total - integer :: i,j - integer :: occ(Nint*bit_kind_size,2) - integer :: n_occ_ab(2) - - call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) - hij_core = 0.d0 - hij_hartree = 0.d0 - hij_erf = 0.d0 - ! alpha - alpha - do i = 1, n_occ_ab(1) - hij_core += mo_nucl_elec_integral(occ(i,1),mo_nucl_elec_integral(i,1)) + mo_kinetic_integral(occ(i,1),mo_nucl_elec_integral(i,1)) - hij_hartree += effective_short_range_operator(occ(i,1),occ(i,1)) - do j = i+1, n_occ_ab(1) - hij_erf += mo_bielec_integral_erf_jj_anti(occ(i,1),occ(j,1)) - enddo - enddo - - ! beta - beta - do i = 1, n_occ_ab(2) - hij_core += mo_nucl_elec_integral(occ(i,2),mo_nucl_elec_integral(i,2)) + mo_kinetic_integral(occ(i,2),mo_nucl_elec_integral(i,2)) - hij_hartree += effective_short_range_operator(occ(i,2),occ(i,2)) - do j = i+1, n_occ_ab(2) - hij_erf += mo_bielec_integral_erf_jj_anti(occ(i,2),occ(j,2)) - enddo - enddo - - ! alpha - beta - do i = 1, n_occ_ab(1) - do j = 1, n_occ_ab(2) - hij_erf += mo_bielec_integral_erf_jj(occ(i,1),occ(j,2)) - enddo - enddo - hij_total = hij_erf + hij_hartree + hij_core - -end - - diff --git a/plugins/core_integrals/.gitignore b/plugins/core_integrals/.gitignore deleted file mode 100644 index 7ac9fbf6..00000000 --- a/plugins/core_integrals/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -IRPF90_temp/ -IRPF90_man/ -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/core_integrals/NEEDED_CHILDREN_MODULES b/plugins/core_integrals/NEEDED_CHILDREN_MODULES deleted file mode 100644 index 6a4d0040..00000000 --- a/plugins/core_integrals/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Integrals_Monoelec Integrals_Bielec Bitmask diff --git a/plugins/core_integrals/README.rst b/plugins/core_integrals/README.rst deleted file mode 100644 index 589e0a00..00000000 --- a/plugins/core_integrals/README.rst +++ /dev/null @@ -1,12 +0,0 @@ -============== -core_integrals -============== - -Needed Modules -============== -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. -Documentation -============= -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. diff --git a/plugins/core_integrals/core_integrals.main.irp.f b/plugins/core_integrals/core_integrals.main.irp.f deleted file mode 100644 index f5e9fd1b..00000000 --- a/plugins/core_integrals/core_integrals.main.irp.f +++ /dev/null @@ -1,7 +0,0 @@ -program core_integrals - implicit none - BEGIN_DOC -! TODO - END_DOC - print*,'core energy = ',core_energy -end diff --git a/plugins/core_integrals/core_quantities.irp.f b/plugins/core_integrals/core_quantities.irp.f deleted file mode 100644 index ac547d2f..00000000 --- a/plugins/core_integrals/core_quantities.irp.f +++ /dev/null @@ -1,32 +0,0 @@ -BEGIN_PROVIDER [double precision, core_energy] - implicit none - integer :: i,j,k,l - core_energy = 0.d0 - do i = 1, n_core_orb - j = list_core(i) - core_energy += 2.d0 * mo_mono_elec_integral(j,j) + mo_bielec_integral_jj(j,j) - do k = i+1, n_core_orb - l = list_core(k) - core_energy += 2.d0 * (2.d0 * mo_bielec_integral_jj(j,l) - mo_bielec_integral_jj_exchange(j,l)) - enddo - enddo - core_energy += nuclear_repulsion - -END_PROVIDER - -BEGIN_PROVIDER [double precision, core_fock_operator, (mo_tot_num,mo_tot_num)] - implicit none - integer :: i,j,k,l,m,n - double precision :: get_mo_bielec_integral - core_fock_operator = 0.d0 - do i = 1, n_act_orb - j = list_act(i) - do k = 1, n_act_orb - l = list_act(k) - do m = 1, n_core_orb - n = list_core(m) - core_fock_operator(j,l) += 2.d0 * get_mo_bielec_integral(j,n,l,n,mo_integrals_map) - get_mo_bielec_integral(j,n,n,l,mo_integrals_map) - enddo - enddo - enddo -END_PROVIDER diff --git a/plugins/loc_cele/loc.f b/plugins/loc_cele/loc.f index ed8b9a76..edc3aa7a 100644 --- a/plugins/loc_cele/loc.f +++ b/plugins/loc_cele/loc.f @@ -18,7 +18,7 @@ C zprt=.true. niter=1000000 - conv=1.d-10 + conv=1.d-8 C niter=1000000 C conv=1.d-6 diff --git a/plugins/loc_cele/loc_cele.irp.f b/plugins/loc_cele/loc_cele.irp.f index 67e74f08..2d47c633 100644 --- a/plugins/loc_cele/loc_cele.irp.f +++ b/plugins/loc_cele/loc_cele.irp.f @@ -101,29 +101,10 @@ cmoref = 0.d0 irot = 0 - irot(1,1) = 14 - irot(2,1) = 15 -! cmoref(6,1,1) = 1.d0 -! cmoref(26,2,1) = 1.d0 - cmoref(36,1,1) = 1.d0 - cmoref(56,2,1) = 1.d0 - -! !!! H2O -! irot(1,1) = 4 -! irot(2,1) = 5 -! irot(3,1) = 6 -! irot(4,1) = 7 -! ! O pz -! cmoref(5,1,1) = 1.55362d0 -! cmoref(6,1,1) = 1.07578d0 - -! cmoref(5,2,1) = 1.55362d0 -! cmoref(6,2,1) = -1.07578d0 -! ! O px - pz -! ! H1 -! cmoref(16,3,1) = 1.d0 -! ! H1 -! cmoref(21,4,1) = 1.d0 + irot(1,1) = 11 + irot(2,1) = 12 + cmoref(15,1,1) = 1.d0 ! + cmoref(14,2,1) = 1.d0 ! ! ESATRIENE with 3 bonding and anti bonding orbitals ! First bonding orbital for esa @@ -169,19 +150,19 @@ ! ESATRIENE with 1 central bonding and anti bonding orbitals ! AND 4 radical orbitals ! First radical orbital -! cmoref(7,1,1) = 1.d0 ! + cmoref(7,1,1) = 1.d0 ! ! Second radical orbital -! cmoref(26,2,1) = 1.d0 ! + cmoref(26,2,1) = 1.d0 ! ! First bonding orbital -! cmoref(45,3,1) = 1.d0 ! -! cmoref(64,3,1) = 1.d0 ! + cmoref(45,3,1) = 1.d0 ! + cmoref(64,3,1) = 1.d0 ! ! Third radical orbital for esa -! cmoref(83,4,1) = 1.d0 ! + cmoref(83,4,1) = 1.d0 ! ! Fourth radical orbital for esa -! cmoref(102,5,1) = 1.d0 ! + cmoref(102,5,1) = 1.d0 ! ! First anti bonding orbital -! cmoref(45,6,1) = 1.d0 ! -! cmoref(64,6,1) =-1.d0 ! + cmoref(45,6,1) = 1.d0 ! + cmoref(64,6,1) =-1.d0 ! do i = 1, nrot(1) diff --git a/plugins/loc_cele/loc_exchange_int.irp.f b/plugins/loc_cele/loc_exchange_int.irp.f index eabdf35c..8bb47d89 100644 --- a/plugins/loc_cele/loc_exchange_int.irp.f +++ b/plugins/loc_cele/loc_exchange_int.irp.f @@ -18,17 +18,16 @@ program loc_int do j = i+1, n_core_inact_orb jorb = list_core_inact(j) iorder(jorb) = jorb - if(list_core_inact_check(jorb) == .False.)then - exchange_int(jorb) = 0.d0 - else - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) - endif + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) enddo n_rot += 1 call dsort(exchange_int,iorder,mo_tot_num) indices(n_rot,1) = iorb indices(n_rot,2) = iorder(1) list_core_inact_check(iorder(1)) = .False. + print*,indices(n_rot,1),indices(n_rot,2) + print*,'' + print*,'' enddo print*,'****************************' print*,'-+++++++++++++++++++++++++' @@ -51,17 +50,16 @@ program loc_int do j = i+1, n_act_orb jorb = list_act(j) iorder(jorb) = jorb - if(list_core_inact_check(jorb) == .False.)then - exchange_int(jorb) = 0.d0 - else - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) - endif + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) enddo n_rot += 1 call dsort(exchange_int,iorder,mo_tot_num) indices(n_rot,1) = iorb indices(n_rot,2) = iorder(1) list_core_inact_check(iorder(1)) = .False. + print*,indices(n_rot,1),indices(n_rot,2) + print*,'' + print*,'' enddo print*,'****************************' print*,'-+++++++++++++++++++++++++' @@ -84,17 +82,16 @@ program loc_int do j = i+1, n_virt_orb jorb = list_virt(j) iorder(jorb) = jorb - if(list_core_inact_check(jorb) == .False.)then - exchange_int(jorb) = 0.d0 - else - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) - endif + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) enddo n_rot += 1 call dsort(exchange_int,iorder,mo_tot_num) indices(n_rot,1) = iorb indices(n_rot,2) = iorder(1) list_core_inact_check(iorder(1)) = .False. + print*,indices(n_rot,1),indices(n_rot,2) + print*,'' + print*,'' enddo print*,'****************************' print*,'-+++++++++++++++++++++++++' diff --git a/plugins/loc_cele/loc_exchange_int_act.irp.f b/plugins/loc_cele/loc_exchange_int_act.irp.f index c4dcf75c..f332dd5d 100644 --- a/plugins/loc_cele/loc_exchange_int_act.irp.f +++ b/plugins/loc_cele/loc_exchange_int_act.irp.f @@ -19,17 +19,16 @@ program loc_int do j = i+1, n_act_orb jorb = list_act(j) iorder(jorb) = jorb - if(list_core_inact_check(jorb) == .False.)then - exchange_int(jorb) = 0.d0 - else - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) - endif + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) enddo n_rot += 1 call dsort(exchange_int,iorder,mo_tot_num) indices(n_rot,1) = iorb indices(n_rot,2) = iorder(1) list_core_inact_check(iorder(1)) = .False. + print*,indices(n_rot,1),indices(n_rot,2) + print*,'' + print*,'' enddo print*,'****************************' print*,'-+++++++++++++++++++++++++' diff --git a/plugins/mrcepa0/.gitignore b/plugins/mrcepa0/.gitignore deleted file mode 100644 index 7ac9fbf6..00000000 --- a/plugins/mrcepa0/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -IRPF90_temp/ -IRPF90_man/ -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/mrcepa0/NEEDED_CHILDREN_MODULES b/plugins/mrcepa0/NEEDED_CHILDREN_MODULES index fe8255d1..8b6c5a18 100644 --- a/plugins/mrcepa0/NEEDED_CHILDREN_MODULES +++ b/plugins/mrcepa0/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full Psiref_CAS MRCC_Utils ZMQ +Perturbation Selectors_full Generators_full Psiref_CAS MRCC_Utils ZMQ diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index d2311676..2820750f 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -684,7 +684,7 @@ subroutine getHP(a,h,p,Nint) end do lh h = deg !isInCassd = .true. -end subroutine +end function BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij, (N_det_ref,N_det_non_ref,N_states) ] @@ -709,9 +709,6 @@ end subroutine integer :: II, blok integer*8, save :: notf = 0 - - PROVIDE psi_ref_coef psi_non_ref_coef - call wall_time(wall) allocate(idx_sorted_bit(N_det), sortRef(N_int,2,N_det_ref)) @@ -835,7 +832,8 @@ END_PROVIDER delta_sub_ij(:,:,:) = 0d0 delta_sub_ii(:,:) = 0d0 - provide mo_bielec_integrals_in_map N_det_non_ref psi_ref_coef psi_non_ref_coef + provide mo_bielec_integrals_in_map + !$OMP PARALLEL DO default(none) schedule(dynamic,10) shared(delta_sub_ij, delta_sub_ii) & !$OMP private(i, J, k, degree, degree2, l, deg, ni) & diff --git a/scripts/compilation/qp_create_ninja.py b/scripts/compilation/qp_create_ninja.py index 780a7a91..b495019a 100755 --- a/scripts/compilation/qp_create_ninja.py +++ b/scripts/compilation/qp_create_ninja.py @@ -476,7 +476,7 @@ def ninja_irpf90_make_build(path_module, l_needed_molule, d_irp): # ~#~#~#~#~#~ # l_creation = [join(path_module.abs, i) - for i in ["irpf90_entities", "tags", + for i in ["irpf90.make", "irpf90_entities", "tags", "IRPF90_temp/build.ninja"]] str_creation = " ".join(l_creation) diff --git a/scripts/ezfio_interface/qp_convert_output_to_ezfio.py b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py index 0c5e1b37..946cbe35 100755 --- a/scripts/ezfio_interface/qp_convert_output_to_ezfio.py +++ b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py @@ -20,18 +20,17 @@ from functools import reduce # Add to the path # # ~#~#~#~#~#~#~#~ # + try: QP_ROOT = os.environ["QP_ROOT"] except: print "Error: QP_ROOT environment variable not found." sys.exit(1) else: - sys.path = [ QP_ROOT + "/install/EZFIO/Python", QP_ROOT + "/resultsFile", QP_ROOT + "/scripts"] + sys.path - # ~#~#~#~#~#~ # # I m p o r t # # ~#~#~#~#~#~ # @@ -365,17 +364,20 @@ def write_ezfio(res, filename): pseudo_str = "\n".join(pseudo_str) matrix, array_l_max_block, array_z_remove = parse_str(pseudo_str) + array_z_remove = map(float,array_z_remove) except: ezfio.set_pseudo_do_pseudo(False) else: ezfio.set_pseudo_do_pseudo(True) - + # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # # Z _ e f f , a l p h a / b e t a _ e l e c # # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # - ezfio.pseudo_charge_remove = array_z_remove - ezfio.nuclei_nucl_charge = [i - j for i, j in zip(ezfio.nuclei_nucl_charge, array_z_remove)] + ezfio.set_pseudo_nucl_charge_remove(array_z_remove) + charge = ezfio.get_nuclei_nucl_charge() + charge = [ i - j for i, j in zip(charge, array_z_remove) ] + ezfio.set_nuclei_nucl_charge (charge) import math num_elec_diff = sum(array_z_remove)/2 diff --git a/scripts/generate_h_apply.py b/scripts/generate_h_apply.py index 5dd1e4f3..c7714e8a 100755 --- a/scripts/generate_h_apply.py +++ b/scripts/generate_h_apply.py @@ -343,7 +343,7 @@ class H_apply(object): """ self.data["size_max"] = "8192" self.data["initialization"] = """ -! PROVIDE psi_selectors_coef psi_selectors E_corr_per_selectors psi_det_sorted_bit + PROVIDE psi_selectors_coef psi_selectors E_corr_per_selectors psi_det_sorted_bit """ if self.do_double_exc == True: self.data["keys_work"] = """ @@ -370,7 +370,7 @@ class H_apply(object): double precision, intent(inout):: norm_pert(N_st) double precision, intent(inout):: H_pert_diag(N_st) double precision :: delta_pt2(N_st), norm_psi(N_st), pt2_old(N_st) -! PROVIDE N_det_generators + PROVIDE N_det_generators do k=1,N_st pt2(k) = 0.d0 norm_pert(k) = 0.d0 @@ -478,7 +478,7 @@ class H_apply_zmq(H_apply): double precision, intent(inout):: norm_pert(N_st) double precision, intent(inout):: H_pert_diag(N_st) double precision :: delta_pt2(N_st), norm_psi(N_st), pt2_old(N_st) -! PROVIDE N_det_generators + PROVIDE N_det_generators do k=1,N_st pt2(k) = 0.d0 norm_pert(k) = 0.d0 diff --git a/scripts/module/module_handler.py b/scripts/module/module_handler.py index 7c729827..0667c376 100755 --- a/scripts/module/module_handler.py +++ b/scripts/module/module_handler.py @@ -253,9 +253,6 @@ if __name__ == '__main__': m.create_png(l_module) except RuntimeError: pass - except SyntaxError: - print "Warning: The graphviz API drop support of python 2.6." - pass if arguments["clean"] or arguments["create_git_ignore"]: @@ -301,7 +298,6 @@ if __name__ == '__main__': # Don't update if we are not in the main repository from is_master_repository import is_master_repository if not is_master_repository: - print >> sys.stderr, 'Not in the master repo' sys.exit() path = os.path.join(module_abs, ".gitignore") diff --git a/src/AO_Basis/ao_overlap.irp.f b/src/AO_Basis/ao_overlap.irp.f index 08e57f73..edf48b25 100644 --- a/src/AO_Basis/ao_overlap.irp.f +++ b/src/AO_Basis/ao_overlap.irp.f @@ -129,48 +129,3 @@ BEGIN_PROVIDER [ double precision, ao_overlap_abs,(ao_num_align,ao_num) ] !$OMP END PARALLEL DO END_PROVIDER -BEGIN_PROVIDER [ double precision, ao_overlap_inv, (ao_num_align, ao_num) ] - implicit none - BEGIN_DOC - ! Inverse of the overlap matrix - END_DOC - call invert_matrix(ao_overlap, size(ao_overlap,1), ao_num, ao_overlap_inv, size(ao_overlap_inv,1)) -END_PROVIDER - -BEGIN_PROVIDER [double precision, ao_overlap_inv_1_2, (ao_num_align,ao_num)] - implicit none - integer :: i,j,k,l - double precision :: eigvalues(ao_num),eigvectors(ao_num_align, ao_num) - call lapack_diag(eigvalues,eigvectors,ao_overlap,ao_num_align,ao_num) - ao_overlap_inv_1_2 = 0.d0 - double precision :: a_n - do i = 1, ao_num - a_n = 1.d0/dsqrt(eigvalues(i)) - if(a_n.le.1.d-10)cycle - do j = 1, ao_num - do k = 1, ao_num - ao_overlap_inv_1_2(k,j) += eigvectors(k,i) * eigvectors(j,i) * a_n - enddo - enddo - enddo - -END_PROVIDER - - -BEGIN_PROVIDER [double precision, ao_overlap_1_2, (ao_num_align,ao_num)] - implicit none - integer :: i,j,k,l - double precision :: eigvalues(ao_num),eigvectors(ao_num_align, ao_num) - call lapack_diag(eigvalues,eigvectors,ao_overlap,ao_num_align,ao_num) - ao_overlap_1_2 = 0.d0 - double precision :: a_n - do i = 1, ao_num - a_n = dsqrt(eigvalues(i)) - do j = 1, ao_num - do k = 1, ao_num - ao_overlap_1_2(k,j) += eigvectors(k,i) * eigvectors(j,i) * a_n - enddo - enddo - enddo - -END_PROVIDER diff --git a/src/AO_Basis/aos_value.irp.f b/src/AO_Basis/aos_value.irp.f index 4876844c..a531ce50 100644 --- a/src/AO_Basis/aos_value.irp.f +++ b/src/AO_Basis/aos_value.irp.f @@ -26,7 +26,6 @@ double precision function ao_value(i,r) do m=1,ao_prim_num(i) beta = ao_expo_ordered_transp(m,i) accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2) -! accu += ao_coef_transp(m,i) * dexp(-beta*r2) enddo ao_value = accu * dx * dy * dz diff --git a/src/Bitmask/bitmask_cas_routines.irp.f b/src/Bitmask/bitmask_cas_routines.irp.f index 5c170632..87a02d10 100644 --- a/src/Bitmask/bitmask_cas_routines.irp.f +++ b/src/Bitmask/bitmask_cas_routines.irp.f @@ -560,24 +560,3 @@ logical function is_i_in_virtual(i) endif end - -logical function is_i_in_active(i) - implicit none - integer,intent(in) :: i - integer(bit_kind) :: key(N_int) - integer :: k,j - integer :: accu - is_i_in_active = .False. - key= 0_bit_kind - k = ishft(i-1,-bit_kind_shift)+1 - j = i-ishft(k-1,bit_kind_shift)-1 - key(k) = ibset(key(k),j) - accu = 0 - do k = 1, N_int - accu += popcnt(iand(key(k),cas_bitmask(k,1,1))) - enddo - if(accu .ne. 0)then - is_i_in_active= .True. - endif - -end diff --git a/src/Davidson/diagonalize_restart_and_save_all_nstates_diag.irp.f b/src/Davidson/diagonalize_restart_and_save_all_nstates_diag.irp.f deleted file mode 100644 index 3bdc37c5..00000000 --- a/src/Davidson/diagonalize_restart_and_save_all_nstates_diag.irp.f +++ /dev/null @@ -1,16 +0,0 @@ -program diag_and_save - implicit none - read_wf = .True. - touch read_wf - call routine -end - -subroutine routine - implicit none - call diagonalize_CI - print*,'N_det = ',N_det - call save_wavefunction_general(N_det,N_states_diag,psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted) - - - -end diff --git a/src/Davidson/diagonalize_restart_and_save_all_states.irp.f b/src/Davidson/diagonalize_restart_and_save_all_states.irp.f index 393ff63a..3bdc37c5 100644 --- a/src/Davidson/diagonalize_restart_and_save_all_states.irp.f +++ b/src/Davidson/diagonalize_restart_and_save_all_states.irp.f @@ -9,7 +9,7 @@ subroutine routine implicit none call diagonalize_CI print*,'N_det = ',N_det - call save_wavefunction_general(N_det,N_states,psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted) + call save_wavefunction_general(N_det,N_states_diag,psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted) diff --git a/src/Determinants/EZFIO.cfg b/src/Determinants/EZFIO.cfg index a9ecd806..a68a61a5 100644 --- a/src/Determinants/EZFIO.cfg +++ b/src/Determinants/EZFIO.cfg @@ -119,9 +119,3 @@ doc: Maximum number of determinants for which the full H matrix is stored. Be ca interface: ezfio,provider,ocaml default: 90000 -[density_matrix_mo_disk] -type: double precision -doc: coefficient of the ith ao on the jth mo -interface: ezfio -size: (mo_basis.mo_tot_num,mo_basis.mo_tot_num) - diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index 561f7e89..a6a7310f 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -195,7 +195,6 @@ subroutine copy_H_apply_buffer_to_wf !call remove_duplicates_in_psi_det(found_duplicates) end - subroutine remove_duplicates_in_psi_det(found_duplicates) implicit none logical, intent(out) :: found_duplicates @@ -271,81 +270,6 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) deallocate (duplicate,bit_tmp) end -subroutine remove_duplicates_in_psi_det_new(found_duplicates) - implicit none - logical, intent(out) :: found_duplicates - BEGIN_DOC -! Removes duplicate determinants in the wave function. - END_DOC - integer :: i,j,k - integer(bit_kind), allocatable :: bit_tmp(:) - logical,allocatable :: duplicate(:) - - allocate (duplicate(N_det), bit_tmp(N_det)) - - do i=1,N_det - integer, external :: det_search_key - !$DIR FORCEINLINE - bit_tmp(i) = det_search_key(psi_det_sorted_bit(1,1,i),N_int) - duplicate(i) = .False. - enddo - - do i=1,N_det-1 - if (duplicate(i)) then - cycle - endif - j = i+1 - do while (bit_tmp(j)==bit_tmp(i)) - if (duplicate(j)) then - j += 1 - if (j > N_det) then - exit - else - cycle - endif - endif - duplicate(j) = .True. - do k=1,N_int - if ( (psi_det_sorted_bit(k,1,i) /= psi_det_sorted_bit(k,1,j) ) & - .or. (psi_det_sorted_bit(k,2,i) /= psi_det_sorted_bit(k,2,j) ) ) then - duplicate(j) = .False. - exit - endif - enddo - j += 1 - if (j > N_det) then - exit - endif - enddo - enddo - - found_duplicates = .False. - do i=1,N_det - if (duplicate(i)) then - found_duplicates = .True. - exit - endif - enddo - - if (found_duplicates) then - k=0 - do i=1,N_det - if (.not.duplicate(i)) then - k += 1 - psi_det(:,:,k) = psi_det_sorted_bit (:,:,i) - psi_coef(k,:) = psi_coef_sorted_bit(i,:) - else - psi_det(:,:,k) = 0_bit_kind - psi_coef(k,:) = 0.d0 - endif - enddo - N_det = k - call write_bool(output_determinants,found_duplicates,'Found duplicate determinants') - SOFT_TOUCH N_det psi_det psi_coef - endif - deallocate (duplicate,bit_tmp) -end - subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc) use bitmasks diff --git a/src/Determinants/H_apply_nozmq.template.f b/src/Determinants/H_apply_nozmq.template.f index 5550d9d1..0c319fe3 100644 --- a/src/Determinants/H_apply_nozmq.template.f +++ b/src/Determinants/H_apply_nozmq.template.f @@ -17,7 +17,7 @@ subroutine $subroutine($params_main) double precision, allocatable :: fock_diag_tmp(:,:) $initialization - PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map !psi_det_generators psi_coef_generators + PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators nmax = mod( N_det_generators,nproc ) diff --git a/src/Determinants/H_apply_zmq.template.f b/src/Determinants/H_apply_zmq.template.f index 97f225b4..ddedc5a2 100644 --- a/src/Determinants/H_apply_zmq.template.f +++ b/src/Determinants/H_apply_zmq.template.f @@ -20,7 +20,7 @@ subroutine $subroutine($params_main) double precision, allocatable :: fock_diag_tmp(:,:) $initialization -! PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators + PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators integer(ZMQ_PTR), external :: new_zmq_pair_socket integer(ZMQ_PTR) :: zmq_socket_pair diff --git a/src/Determinants/density_matrix.irp.f b/src/Determinants/density_matrix.irp.f index 541cfcb4..923318bc 100644 --- a/src/Determinants/density_matrix.irp.f +++ b/src/Determinants/density_matrix.irp.f @@ -15,72 +15,6 @@ enddo END_PROVIDER - -subroutine save_density_matrix_mo - implicit none - double precision, allocatable :: dm(:,:) - allocate(dm(mo_tot_num,mo_tot_num)) - integer :: i,j - do i = 1, mo_tot_num - do j = 1, mo_tot_num - dm(i,j) = one_body_dm_mo_alpha_average(i,j) - enddo - enddo - call ezfio_set_determinants_density_matrix_mo_disk(dm) - -end - - BEGIN_PROVIDER [ double precision, one_body_dm_mo_spin_index, (mo_tot_num_align,mo_tot_num,N_states,2) ] - implicit none - integer :: i,j,ispin,istate - ispin = 1 - do istate = 1, N_states - do j = 1, mo_tot_num - do i = 1, mo_tot_num - one_body_dm_mo_spin_index(i,j,istate,ispin) = one_body_dm_mo_alpha(i,j,istate) - enddo - enddo - enddo - - ispin = 2 - do istate = 1, N_states - do j = 1, mo_tot_num - do i = 1, mo_tot_num - one_body_dm_mo_spin_index(i,j,istate,ispin) = one_body_dm_mo_beta(i,j,istate) - enddo - enddo - enddo - - END_PROVIDER - - - BEGIN_PROVIDER [ double precision, one_body_dm_dagger_mo_spin_index, (mo_tot_num_align,mo_tot_num,N_states,2) ] - implicit none - integer :: i,j,ispin,istate - ispin = 1 - do istate = 1, N_states - do j = 1, mo_tot_num - one_body_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_body_dm_mo_alpha(j,j,istate) - do i = j+1, mo_tot_num - one_body_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_body_dm_mo_alpha(i,j,istate) - one_body_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_body_dm_mo_alpha(i,j,istate) - enddo - enddo - enddo - - ispin = 2 - do istate = 1, N_states - do j = 1, mo_tot_num - one_body_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_body_dm_mo_beta(j,j,istate) - do i = j+1, mo_tot_num - one_body_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_body_dm_mo_beta(i,j,istate) - one_body_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_body_dm_mo_beta(i,j,istate) - enddo - enddo - enddo - - END_PROVIDER - BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha, (mo_tot_num_align,mo_tot_num,N_states) ] &BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta, (mo_tot_num_align,mo_tot_num,N_states) ] implicit none @@ -156,16 +90,39 @@ end lcol = psi_bilinear_matrix_columns(l) enddo - enddo - !$OMP END DO NOWAIT - !$OMP CRITICAL - one_body_dm_mo_alpha(:,:,:) = one_body_dm_mo_alpha(:,:,:) + tmp_a(:,:,:) - !$OMP END CRITICAL - !$OMP CRITICAL - one_body_dm_mo_beta(:,:,:) = one_body_dm_mo_beta(:,:,:) + tmp_b(:,:,:) - !$OMP END CRITICAL - deallocate(tmp_a,tmp_b) - !$OMP END PARALLEL + l = psi_bilinear_matrix_order_reverse(k)+1 + ! Fix alpha determinant, loop over betas + lrow = psi_bilinear_matrix_transp_rows(l) + lcol = psi_bilinear_matrix_transp_columns(l) + do while ( lrow == krow ) + tmp_det2(:) = psi_det_beta_unique (:, lcol) + call get_excitation_degree_spin(tmp_det(1,2),tmp_det2,degree,N_int) + if (degree == 1) then + call get_mono_excitation_spin(tmp_det(1,2),tmp_det2,exc,phase,N_int) + call decode_exc_spin(exc,h1,p1,h2,p2) + do m=1,N_states + ckl = psi_bilinear_matrix_values(k,m)*psi_bilinear_matrix_transp_values(l,m) * phase + tmp_b(h1,p1,m) += ckl + tmp_b(p1,h1,m) += ckl + enddo + endif + l = l+1 + if (l>N_det) exit + lrow = psi_bilinear_matrix_transp_rows(l) + lcol = psi_bilinear_matrix_transp_columns(l) + enddo + + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + one_body_dm_mo_alpha(:,:,:) = one_body_dm_mo_alpha(:,:,:) + tmp_a(:,:,:) + !$OMP END CRITICAL + !$OMP CRITICAL + one_body_dm_mo_beta(:,:,:) = one_body_dm_mo_beta(:,:,:) + tmp_b(:,:,:) + !$OMP END CRITICAL + deallocate(tmp_a,tmp_b) + !$OMP END PARALLEL + END_PROVIDER BEGIN_PROVIDER [ double precision, one_body_single_double_dm_mo_alpha, (mo_tot_num_align,mo_tot_num) ] diff --git a/src/Determinants/diagonalize_restart_and_save_two_states.irp.f b/src/Determinants/diagonalize_restart_and_save_two_states.irp.f new file mode 100644 index 00000000..97fed531 --- /dev/null +++ b/src/Determinants/diagonalize_restart_and_save_two_states.irp.f @@ -0,0 +1,27 @@ +program diag_and_save + implicit none + read_wf = .True. + touch read_wf + call routine +end + +subroutine routine + implicit none + integer :: igood_state_1,igood_state_2 + double precision, allocatable :: psi_coef_tmp(:,:) + integer :: i + print*,'N_det = ',N_det +!call diagonalize_CI + write(*,*)'Which couple of states would you like to save ?' + read(5,*)igood_state_1,igood_state_2 + allocate(psi_coef_tmp(n_det,2)) + do i = 1, N_det + psi_coef_tmp(i,1) = psi_coef(i,igood_state_1) + psi_coef_tmp(i,2) = psi_coef(i,igood_state_2) + enddo + call save_wavefunction_general(N_det,2,psi_det,n_det,psi_coef_tmp) + deallocate(psi_coef_tmp) + + + +end diff --git a/src/Determinants/print_wf.irp.f b/src/Determinants/print_wf.irp.f index 2120a512..737e4d3e 100644 --- a/src/Determinants/print_wf.irp.f +++ b/src/Determinants/print_wf.irp.f @@ -32,28 +32,29 @@ subroutine routine call get_excitation(psi_det(1,1,1),psi_det(1,1,i),exc,degree,phase,N_int) call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) print*,'phase = ',phase - if(degree == 1)then - print*,'s1',s1 - print*,'h1,p1 = ',h1,p1 - if(s1 == 1)then - norm_mono_a += dabs(psi_coef(i,1)/psi_coef(1,1)) - else - norm_mono_b += dabs(psi_coef(i,1)/psi_coef(1,1)) - endif +! if(degree == 1)then +! print*,'s1',s1 +! print*,'h1,p1 = ',h1,p1 +! if(s1 == 1)then +! norm_mono_a += dabs(psi_coef(i,1)/psi_coef(1,1)) +! else +! norm_mono_b += dabs(psi_coef(i,1)/psi_coef(1,1)) +! endif ! print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,list_act(1),list_act(1),p1,mo_integrals_map) - double precision :: hmono,hdouble - call i_H_j_verbose(psi_det(1,1,1),psi_det(1,1,i),N_int,hij,hmono,hdouble) - print*,'hmono = ',hmono - print*,'hdouble = ',hdouble - print*,'hmono+hdouble = ',hmono+hdouble - print*,'hij = ',hij - else if (degree == 2)then - print*,'s1',s1 - print*,'h1,p1 = ',h1,p1 - print*,'s2',s2 - print*,'h2,p2 = ',h2,p2 +! double precision :: hmono,hdouble +! call i_H_j_verbose(psi_det(1,1,1),psi_det(1,1,i),N_int,hij,hmono,hdouble) +! print*,'hmono = ',hmono +! print*,'hdouble = ',hdouble +! print*,'hmono+hdouble = ',hmono+hdouble +! print*,'hij = ',hij +! else +! print*,'s1',s1 +! print*,'h1,p1 = ',h1,p1 +! print*,'s2',s2 +! print*,'h2,p2 = ',h2,p2 ! print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map) - endif +! endif + print*,' = ',hij endif print*,'amplitude = ',psi_coef(i,1)/psi_coef(1,1) diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 78a35689..4d5b1bd3 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -2144,27 +2144,9 @@ subroutine H_u_0_stored(v_0,u_0,hmatrix,sze) double precision, intent(in) :: u_0(sze) v_0 = 0.d0 call matrix_vector_product(u_0,v_0,hmatrix,sze,sze) -end -subroutine H_s2_u_0_stored(v_0,u_0,hmatrix,s2matrix,sze) - use bitmasks - implicit none - BEGIN_DOC - ! Computes v_0 = H|u_0> - ! - ! n : number of determinants - ! - ! uses the big_matrix_stored array - END_DOC - integer, intent(in) :: sze - double precision, intent(in) :: hmatrix(sze,sze),s2matrix(sze,sze) - double precision, intent(out) :: v_0(sze) - double precision, intent(in) :: u_0(sze) - v_0 = 0.d0 - call matrix_vector_product(u_0,v_0,hmatrix,sze,sze) end - subroutine u_0_H_u_0_stored(e_0,u_0,hmatrix,sze) use bitmasks implicit none diff --git a/src/Determinants/truncate_wf.irp.f b/src/Determinants/truncate_wf.irp.f index 49b5e70a..aba16fa7 100644 --- a/src/Determinants/truncate_wf.irp.f +++ b/src/Determinants/truncate_wf.irp.f @@ -1,52 +1,8 @@ program s2_eig_restart implicit none read_wf = .True. - call routine_2 + call routine end - -subroutine routine_2 - implicit none - integer :: i,j,k,l - use bitmasks - integer :: n_det_restart,degree - integer(bit_kind),allocatable :: psi_det_tmp(:,:,:) - double precision ,allocatable :: psi_coef_tmp(:,:),accu(:) - integer, allocatable :: index_restart(:) - allocate(index_restart(N_det)) - print*, 'How many Slater determinants would ou like ?' - read(5,*)N_det_restart - do i = 1, N_det_restart - index_restart(i) = i - enddo - allocate (psi_det_tmp(N_int,2,N_det_restart),psi_coef_tmp(N_det_restart,N_states),accu(N_states)) - accu = 0.d0 - do i = 1, N_det_restart - do j = 1, N_int - psi_det_tmp(j,1,i) = psi_det(j,1,index_restart(i)) - psi_det_tmp(j,2,i) = psi_det(j,2,index_restart(i)) - enddo - do j = 1,N_states - psi_coef_tmp(i,j) = psi_coef(index_restart(i),j) - accu(j) += psi_coef_tmp(i,j) * psi_coef_tmp(i,j) - enddo - enddo - do j = 1, N_states - accu(j) = 1.d0/dsqrt(accu(j)) - enddo - do j = 1,N_states - do i = 1, N_det_restart - psi_coef_tmp(i,j) = psi_coef_tmp(i,j) * accu(j) - enddo - enddo - call save_wavefunction_general(N_det_restart,N_states,psi_det_tmp,N_det_restart,psi_coef_tmp) - - deallocate (psi_det_tmp,psi_coef_tmp,accu,index_restart) - - - -end - - subroutine routine implicit none call make_s2_eigenfunction diff --git a/src/Determinants/two_body_dm_map.irp.f b/src/Determinants/two_body_dm_map.irp.f index bb1a341e..aa8f630b 100644 --- a/src/Determinants/two_body_dm_map.irp.f +++ b/src/Determinants/two_body_dm_map.irp.f @@ -194,8 +194,6 @@ subroutine add_values_to_two_body_dm_map(mask_ijkl) end BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_act, (n_act_orb, n_act_orb)] -&BEGIN_PROVIDER [double precision, two_body_dm_aa_diag_act, (n_act_orb, n_act_orb)] -&BEGIN_PROVIDER [double precision, two_body_dm_bb_diag_act, (n_act_orb, n_act_orb)] &BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_inact, (n_inact_orb_allocate, n_inact_orb_allocate)] &BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_core, (n_core_orb_allocate, n_core_orb_allocate)] &BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_all, (mo_tot_num, mo_tot_num)] @@ -236,8 +234,6 @@ end two_body_dm_ab_diag_all = 0.d0 two_body_dm_ab_diag_act = 0.d0 - two_body_dm_aa_diag_act = 0.d0 - two_body_dm_bb_diag_act = 0.d0 two_body_dm_ab_diag_core = 0.d0 two_body_dm_ab_diag_inact = 0.d0 two_body_dm_diag_core_a_act_b = 0.d0 @@ -273,20 +269,8 @@ end two_body_dm_ab_diag_act(k,m) += 0.5d0 * contrib two_body_dm_ab_diag_act(m,k) += 0.5d0 * contrib enddo - do l = 1, n_occ_ab_act(2) - m = list_act_reverse(occ_act(l,2)) - two_body_dm_bb_diag_act(k,m) += 0.5d0 * contrib - two_body_dm_bb_diag_act(m,k) += 0.5d0 * contrib - enddo - enddo - do j = 1,n_occ_ab_act(1) - k = list_act_reverse(occ_act(j,1)) - do l = 1, n_occ_ab_act(1) - m = list_act_reverse(occ_act(l,1)) - two_body_dm_aa_diag_act(k,m) += 0.5d0 * contrib - two_body_dm_aa_diag_act(m,k) += 0.5d0 * contrib - enddo enddo + ! CORE PART of the diagonal part of the two body dm do j = 1, N_int key_tmp_core(j,1) = psi_det(j,1,i) @@ -341,8 +325,6 @@ end END_PROVIDER BEGIN_PROVIDER [double precision, two_body_dm_ab_big_array_act, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] -&BEGIN_PROVIDER [double precision, two_body_dm_aa_big_array_act, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] -&BEGIN_PROVIDER [double precision, two_body_dm_bb_big_array_act, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] &BEGIN_PROVIDER [double precision, two_body_dm_ab_big_array_core_act, (n_core_orb_allocate,n_act_orb,n_act_orb)] implicit none use bitmasks @@ -412,22 +394,14 @@ END_PROVIDER call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) contrib = 0.5d0 * psi_coef(i,1) * psi_coef(j,1) * phase if(degree==2)then ! case of the DOUBLE EXCITATIONS ************************************ + if(s1==s2)cycle ! Only the alpha/beta two body density matrix ! * c_I * c_J h1 = list_act_reverse(h1) h2 = list_act_reverse(h2) p1 = list_act_reverse(p1) p2 = list_act_reverse(p2) - if(s1==s2)then - if(s1==1)then - call insert_into_two_body_dm_big_array( two_body_dm_aa_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) -! call insert_into_two_body_dm_big_array( two_body_dm_aa_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,-contrib,h1,p2,h2,p1) - else - call insert_into_two_body_dm_big_array( two_body_dm_bb_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) -! call insert_into_two_body_dm_big_array( two_body_dm_bb_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,-contrib,h1,p2,h2,p1) - endif - else ! alpha/beta two body density matrix - call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) - endif + call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) + else if(degree==1)then! case of the SINGLE EXCITATIONS *************************************************** print*,'h1 = ',h1 h1 = list_act_reverse(h1) @@ -443,12 +417,6 @@ END_PROVIDER ! * c_I * c_J call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) enddo - do k = 1, n_occ_ab(1) - m = list_act_reverse(occ(k,1)) - ! * c_I * c_J - call insert_into_two_body_dm_big_array( two_body_dm_aa_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) -! call insert_into_two_body_dm_big_array( two_body_dm_aa_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,-contrib,h1,m,p1,m) - enddo ! core <-> active part of the extra diagonal two body dm do k = 1, n_occ_ab_core(2) @@ -464,12 +432,6 @@ END_PROVIDER ! * c_I * c_J call insert_into_two_body_dm_big_array(two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) enddo - do k = 1, n_occ_ab(2) - m = list_act_reverse(occ(k,2)) - ! * c_I * c_J - call insert_into_two_body_dm_big_array(two_body_dm_bb_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) -! call insert_into_two_body_dm_big_array(two_body_dm_bb_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,-contrib,h1,m,p1,m) - enddo ! core <-> active part of the extra diagonal two body dm do k = 1, n_occ_ab_core(1) @@ -502,3 +464,156 @@ subroutine insert_into_two_body_dm_big_array(big_array,dim1,dim2,dim3,dim4,contr end + +double precision function compute_extra_diag_two_body_dm_ab(r1,r2) + implicit none + BEGIN_DOC +! compute the extra diagonal contribution to the alpha/bet two body density at r1, r2 + END_DOC + double precision :: r1(3), r2(3) + double precision :: compute_extra_diag_two_body_dm_ab_act,compute_extra_diag_two_body_dm_ab_core_act + compute_extra_diag_two_body_dm_ab = compute_extra_diag_two_body_dm_ab_act(r1,r2)+compute_extra_diag_two_body_dm_ab_core_act(r1,r2) +end + +double precision function compute_extra_diag_two_body_dm_ab_act(r1,r2) + implicit none + BEGIN_DOC +! compute the extra diagonal contribution to the two body density at r1, r2 +! involving ONLY THE ACTIVE PART, which means that the four index of the excitations +! involved in the two body density matrix are ACTIVE + END_DOC + PROVIDE n_act_orb + double precision, intent(in) :: r1(3),r2(3) + integer :: i,j,k,l + double precision :: mos_array_r1(n_act_orb),mos_array_r2(n_act_orb) + double precision :: contrib + double precision :: contrib_tmp +!print*,'n_act_orb = ',n_act_orb + compute_extra_diag_two_body_dm_ab_act = 0.d0 + call give_all_act_mos_at_r(r1,mos_array_r1) + call give_all_act_mos_at_r(r2,mos_array_r2) + do l = 1, n_act_orb ! p2 + do k = 1, n_act_orb ! h2 + do j = 1, n_act_orb ! p1 + do i = 1,n_act_orb ! h1 + contrib_tmp = mos_array_r1(i) * mos_array_r1(j) * mos_array_r2(k) * mos_array_r2(l) + compute_extra_diag_two_body_dm_ab_act += two_body_dm_ab_big_array_act(i,j,k,l) * contrib_tmp + enddo + enddo + enddo + enddo + +end + +double precision function compute_extra_diag_two_body_dm_ab_core_act(r1,r2) + implicit none + BEGIN_DOC +! compute the extra diagonal contribution to the two body density at r1, r2 +! involving ONLY THE ACTIVE PART, which means that the four index of the excitations +! involved in the two body density matrix are ACTIVE + END_DOC + double precision, intent(in) :: r1(3),r2(3) + integer :: i,j,k,l + double precision :: mos_array_act_r1(n_act_orb),mos_array_act_r2(n_act_orb) + double precision :: mos_array_core_r1(n_core_orb),mos_array_core_r2(n_core_orb) + double precision :: contrib_core_1,contrib_core_2 + double precision :: contrib_act_1,contrib_act_2 + double precision :: contrib_tmp + compute_extra_diag_two_body_dm_ab_core_act = 0.d0 + call give_all_act_mos_at_r(r1,mos_array_act_r1) + call give_all_act_mos_at_r(r2,mos_array_act_r2) + call give_all_core_mos_at_r(r1,mos_array_core_r1) + call give_all_core_mos_at_r(r2,mos_array_core_r2) + do i = 1, n_act_orb ! h1 + do j = 1, n_act_orb ! p1 + contrib_act_1 = mos_array_act_r1(i) * mos_array_act_r1(j) + contrib_act_2 = mos_array_act_r2(i) * mos_array_act_r2(j) + do k = 1,n_core_orb ! h2 + contrib_core_1 = mos_array_core_r1(k) * mos_array_core_r1(k) + contrib_core_2 = mos_array_core_r2(k) * mos_array_core_r2(k) + contrib_tmp = 0.5d0 * (contrib_act_1 * contrib_core_2 + contrib_act_2 * contrib_core_1) + compute_extra_diag_two_body_dm_ab_core_act += two_body_dm_ab_big_array_core_act(k,i,j) * contrib_tmp + enddo + enddo + enddo + +end + +double precision function compute_diag_two_body_dm_ab_core(r1,r2) + implicit none + double precision :: r1(3),r2(3) + integer :: i,j,k,l + double precision :: mos_array_r1(n_core_orb_allocate),mos_array_r2(n_core_orb_allocate) + double precision :: contrib,contrib_tmp + compute_diag_two_body_dm_ab_core = 0.d0 + call give_all_core_mos_at_r(r1,mos_array_r1) + call give_all_core_mos_at_r(r2,mos_array_r2) + do l = 1, n_core_orb ! + contrib = mos_array_r2(l)*mos_array_r2(l) +! if(dabs(contrib).lt.threshld_two_bod_dm)cycle + do k = 1, n_core_orb ! + contrib_tmp = contrib * mos_array_r1(k)*mos_array_r1(k) +! if(dabs(contrib).lt.threshld_two_bod_dm)cycle + compute_diag_two_body_dm_ab_core += two_body_dm_ab_diag_core(k,l) * contrib_tmp + enddo + enddo + +end + + +double precision function compute_diag_two_body_dm_ab_act(r1,r2) + implicit none + double precision :: r1(3),r2(3) + integer :: i,j,k,l + double precision :: mos_array_r1(n_act_orb),mos_array_r2(n_act_orb) + double precision :: contrib,contrib_tmp + compute_diag_two_body_dm_ab_act = 0.d0 + call give_all_act_mos_at_r(r1,mos_array_r1) + call give_all_act_mos_at_r(r2,mos_array_r2) + do l = 1, n_act_orb ! + contrib = mos_array_r2(l)*mos_array_r2(l) +! if(dabs(contrib).lt.threshld_two_bod_dm)cycle + do k = 1, n_act_orb ! + contrib_tmp = contrib * mos_array_r1(k)*mos_array_r1(k) +! if(dabs(contrib).lt.threshld_two_bod_dm)cycle + compute_diag_two_body_dm_ab_act += two_body_dm_ab_diag_act(k,l) * contrib_tmp + enddo + enddo +end + +double precision function compute_diag_two_body_dm_ab_core_act(r1,r2) + implicit none + double precision :: r1(3),r2(3) + integer :: i,j,k,l + double precision :: mos_array_core_r1(n_core_orb_allocate),mos_array_core_r2(n_core_orb_allocate) + double precision :: mos_array_act_r1(n_act_orb),mos_array_act_r2(n_act_orb) + double precision :: contrib_core_1,contrib_core_2 + double precision :: contrib_act_1,contrib_act_2 + double precision :: contrib_tmp + compute_diag_two_body_dm_ab_core_act = 0.d0 + call give_all_act_mos_at_r(r1,mos_array_act_r1) + call give_all_act_mos_at_r(r2,mos_array_act_r2) + call give_all_core_mos_at_r(r1,mos_array_core_r1) + call give_all_core_mos_at_r(r2,mos_array_core_r2) +! if(dabs(contrib).lt.threshld_two_bod_dm)cycle + do k = 1, n_act_orb ! + contrib_act_1 = mos_array_act_r1(k) * mos_array_act_r1(k) + contrib_act_2 = mos_array_act_r2(k) * mos_array_act_r2(k) + contrib_tmp = 0.5d0 * (contrib_act_1 * contrib_act_2 + contrib_act_2 * contrib_act_1) +! if(dabs(contrib).lt.threshld_two_bod_dm)cycle + do l = 1, n_core_orb ! + contrib_core_1 = mos_array_core_r1(l) * mos_array_core_r1(l) + contrib_core_2 = mos_array_core_r2(l) * mos_array_core_r2(l) + compute_diag_two_body_dm_ab_core_act += two_body_dm_diag_core_act(l,k) * contrib_tmp + enddo + enddo +end + +double precision function compute_diag_two_body_dm_ab(r1,r2) + implicit none + double precision,intent(in) :: r1(3),r2(3) + double precision :: compute_diag_two_body_dm_ab_act,compute_diag_two_body_dm_ab_core + double precision :: compute_diag_two_body_dm_ab_core_act + compute_diag_two_body_dm_ab = compute_diag_two_body_dm_ab_act(r1,r2)+compute_diag_two_body_dm_ab_core(r1,r2) & + + compute_diag_two_body_dm_ab_core_act(r1,r2) +end diff --git a/src/Integrals_Bielec/EZFIO.cfg b/src/Integrals_Bielec/EZFIO.cfg index 0576b811..4e7e494f 100644 --- a/src/Integrals_Bielec/EZFIO.cfg +++ b/src/Integrals_Bielec/EZFIO.cfg @@ -51,4 +51,3 @@ doc: If || < ao_integrals_threshold then is zero interface: ezfio,provider,ocaml default: 1.e-15 ezfio_name: threshold_mo - diff --git a/src/Integrals_Monoelec/EZFIO.cfg b/src/Integrals_Monoelec/EZFIO.cfg index c8a8eaef..04e49ec1 100644 --- a/src/Integrals_Monoelec/EZFIO.cfg +++ b/src/Integrals_Monoelec/EZFIO.cfg @@ -4,14 +4,6 @@ doc: Read/Write MO one-electron integrals from/to disk [ Write | Read | None ] interface: ezfio,provider,ocaml default: None - -[disk_access_only_mo_one_integrals] -type: Disk_access -doc: Read/Write MO for only the total one-electron integrals which can be anything [ Write | Read | None ] -interface: ezfio,provider,ocaml -default: None - - [disk_access_ao_one_integrals] type: Disk_access doc: Read/Write AO one-electron integrals from/to disk [ Write | Read | None ] diff --git a/src/Integrals_Monoelec/mo_mono_ints.irp.f b/src/Integrals_Monoelec/mo_mono_ints.irp.f index 816dd277..50ab7ffa 100644 --- a/src/Integrals_Monoelec/mo_mono_ints.irp.f +++ b/src/Integrals_Monoelec/mo_mono_ints.irp.f @@ -6,24 +6,10 @@ BEGIN_PROVIDER [ double precision, mo_mono_elec_integral,(mo_tot_num_align,mo_to ! sum of the kinetic and nuclear electronic potential END_DOC print*,'Providing the mono electronic integrals' - if (read_only_mo_one_integrals) then - print*, 'Reading the mono electronic integrals from disk' - call read_one_e_integrals('mo_one_integral', mo_mono_elec_integral, & - size(mo_mono_elec_integral,1), size(mo_mono_elec_integral,2)) - print *, 'MO N-e integrals read from disk' - else - do j = 1, mo_tot_num - do i = 1, mo_tot_num - mo_mono_elec_integral(i,j) = mo_nucl_elec_integral(i,j) + & - mo_kinetic_integral(i,j) + mo_pseudo_integral(i,j) - enddo - enddo - endif - -! if (write_mo_one_integrals) then -! call write_one_e_integrals('mo_one_integral', mo_mono_elec_integral, & -! size(mo_mono_elec_integral,1), size(mo_mono_elec_integral,2)) -! print *, 'MO N-e integrals written to disk' -! endif - + do j = 1, mo_tot_num + do i = 1, mo_tot_num + mo_mono_elec_integral(i,j) = mo_nucl_elec_integral(i,j) + & + mo_kinetic_integral(i,j) + mo_pseudo_integral(i,j) + enddo + enddo END_PROVIDER diff --git a/src/Integrals_Monoelec/pot_ao_ints.irp.f b/src/Integrals_Monoelec/pot_ao_ints.irp.f index aef8a060..7116d2c7 100644 --- a/src/Integrals_Monoelec/pot_ao_ints.irp.f +++ b/src/Integrals_Monoelec/pot_ao_ints.irp.f @@ -185,7 +185,7 @@ include 'Utils/constants.include.F' enddo const_factor = dist*rho const = p * dist_integral - if(const_factor > 1000.d0)then + if(const_factor > 80.d0)then NAI_pol_mult = 0.d0 return endif diff --git a/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f b/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f index bfe10b91..22cceab9 100644 --- a/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f +++ b/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f @@ -3,7 +3,7 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral, (ao_num_align,ao_num)] BEGIN_DOC ! Pseudo-potential integrals END_DOC - + if (read_ao_one_integrals) then call read_one_e_integrals('ao_pseudo_integral', ao_pseudo_integral,& size(ao_pseudo_integral,1), size(ao_pseudo_integral,2)) @@ -53,6 +53,7 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu call wall_time(wall_1) call cpu_time(cpu_1) + thread_num = 0 !$OMP PARALLEL & !$OMP DEFAULT (NONE) & diff --git a/src/Integrals_Monoelec/read_write.irp.f b/src/Integrals_Monoelec/read_write.irp.f index 0e758740..697bf356 100644 --- a/src/Integrals_Monoelec/read_write.irp.f +++ b/src/Integrals_Monoelec/read_write.irp.f @@ -1,6 +1,5 @@ BEGIN_PROVIDER [ logical, read_ao_one_integrals ] &BEGIN_PROVIDER [ logical, read_mo_one_integrals ] -&BEGIN_PROVIDER [ logical, read_only_mo_one_integrals ] &BEGIN_PROVIDER [ logical, write_ao_one_integrals ] &BEGIN_PROVIDER [ logical, write_mo_one_integrals ] @@ -22,14 +21,10 @@ write_ao_one_integrals = .False. else - print *, 'monoelec_integrals/disk_access_ao_integrals has a wrong type' + print *, 'bielec_integrals/disk_access_ao_integrals has a wrong type' stop 1 endif - - if (disk_access_only_mo_one_integrals.EQ.'Read')then - read_only_mo_one_integrals = .True. - endif if (disk_access_mo_one_integrals.EQ.'Read') then read_mo_one_integrals = .True. @@ -44,7 +39,7 @@ write_mo_one_integrals = .False. else - print *, 'monoelec_integrals/disk_access_mo_integrals has a wrong type' + print *, 'bielec_integrals/disk_access_mo_integrals has a wrong type' stop 1 endif diff --git a/src/MO_Basis/cholesky_mo.irp.f b/src/MO_Basis/cholesky_mo.irp.f index 774198a3..65184c1e 100644 --- a/src/MO_Basis/cholesky_mo.irp.f +++ b/src/MO_Basis/cholesky_mo.irp.f @@ -50,9 +50,9 @@ subroutine cholesky_mo(n,m,P,LDP,C,LDC,tol_in,rank) deallocate(W,work) end -!subroutine svd_mo(n,m,P,LDP,C,LDC) -!implicit none -!BEGIN_DOC +subroutine svd_mo(n,m,P,LDP,C,LDC) + implicit none + BEGIN_DOC ! Singular value decomposition of the AO Density matrix ! ! n : Number of AOs @@ -66,36 +66,6 @@ end ! tol_in : tolerance ! ! rank : Nomber of local MOs (output) -! -!END_DOC -!integer, intent(in) :: n,m, LDC, LDP -!double precision, intent(in) :: P(LDP,n) -!double precision, intent(out) :: C(LDC,m) - -!integer :: info -!integer :: i,k -!integer :: ipiv(n) -!double precision:: tol -!double precision, allocatable :: W(:,:), work(:) - -!allocate(W(LDC,n),work(2*n)) -!call svd(P,LDP,C,LDC,W,size(W,1),m,n) - -!deallocate(W,work) -!end - -subroutine svd_mo(n,m,P,LDP,C,LDC) - implicit none - BEGIN_DOC -! Singular value decomposition of the AO Density matrix -! -! n : Number of AOs -! -! m : Number of MOs -! -! P(LDP,n) : Density matrix in AO basis -! -! C(LDC,m) : MOs ! END_DOC integer, intent(in) :: n,m, LDC, LDP @@ -106,64 +76,10 @@ subroutine svd_mo(n,m,P,LDP,C,LDC) integer :: i,k integer :: ipiv(n) double precision:: tol - double precision, allocatable :: W(:,:), work(:), D(:) + double precision, allocatable :: W(:,:), work(:) - allocate(W(LDC,n),work(2*n),D(n)) - print*, '' - do i = 1, n - print*, P(i,i) - enddo - call svd(P,LDP,C,LDC,D,W,size(W,1),m,n) - double precision :: accu - accu = 0.d0 - print*, 'm',m - do i = 1, m - print*, D(i) - accu += D(i) - enddo - print*,'Sum of D',accu - - deallocate(W,work) -end - -subroutine svd_mo_new(n,m,m_physical,P,LDP,C,LDC) - implicit none - BEGIN_DOC -! Singular value decomposition of the AO Density matrix -! -! n : Number of AOs - -! m : Number of MOs -! -! P(LDP,n) : Density matrix in AO basis -! -! C(LDC,m) : MOs -! -! tol_in : tolerance -! -! rank : Nomber of local MOs (output) -! - END_DOC - integer, intent(in) :: n,m,m_physical, LDC, LDP - double precision, intent(in) :: P(LDP,n) - double precision, intent(out) :: C(LDC,m) - - integer :: info - integer :: i,k - integer :: ipiv(n) - double precision:: tol - double precision, allocatable :: W(:,:), work(:), D(:) - - allocate(W(LDC,n),work(2*n),D(n)) - call svd(P,LDP,C,LDC,D,W,size(W,1),m_physical,n) - double precision :: accu - accu = 0.d0 - print*, 'm',m_physical - do i = 1, m_physical - print*, D(i) - accu += D(i) - enddo - print*,'Sum of D',accu + allocate(W(LDC,n),work(2*n)) + call svd(P,LDP,C,LDC,W,size(W,1),m,n) deallocate(W,work) end diff --git a/src/MO_Basis/mos.irp.f b/src/MO_Basis/mos.irp.f index 56ab8d2f..19835395 100644 --- a/src/MO_Basis/mos.irp.f +++ b/src/MO_Basis/mos.irp.f @@ -181,146 +181,24 @@ subroutine mo_to_ao(A_mo,LDA_mo,A_ao,LDA_ao) allocate ( T(mo_tot_num_align,ao_num) ) !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T -! SC call dgemm('N','N', ao_num, mo_tot_num, ao_num, & 1.d0, ao_overlap,size(ao_overlap,1), & mo_coef, size(mo_coef,1), & 0.d0, SC, ao_num_align) -! A.CS call dgemm('N','T', mo_tot_num, ao_num, mo_tot_num, & 1.d0, A_mo,LDA_mo, & SC, size(SC,1), & 0.d0, T, mo_tot_num_align) -! SC.A.CS call dgemm('N','N', ao_num, ao_num, mo_tot_num, & 1.d0, SC,size(SC,1), & T, mo_tot_num_align, & 0.d0, A_ao, LDA_ao) -! C(S.A.S)C -! SC.A.CS deallocate(T,SC) end - -subroutine mo_to_ao_s_inv_1_2(A_mo,LDA_mo,A_ao,LDA_ao) - implicit none - BEGIN_DOC - ! Transform A from the MO basis to the AO basis using the S^{-1} matrix - ! S^{-1} C A C^{+} S^{-1} - END_DOC - integer, intent(in) :: LDA_ao,LDA_mo - double precision, intent(in) :: A_mo(LDA_mo) - double precision, intent(out) :: A_ao(LDA_ao) - double precision, allocatable :: T(:,:), SC_inv_1_2(:,:) - - allocate ( SC_inv_1_2(ao_num_align,mo_tot_num) ) - allocate ( T(mo_tot_num_align,ao_num) ) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T - -! SC_inv_1_2 = S^{-1}C - call dgemm('N','N', ao_num, mo_tot_num, ao_num, & - 1.d0, ao_overlap_inv_1_2,size(ao_overlap_inv_1_2,1), & - mo_coef, size(mo_coef,1), & - 0.d0, SC_inv_1_2, ao_num_align) - -! T = A.(SC_inv_1_2)^{+} - call dgemm('N','T', mo_tot_num, ao_num, mo_tot_num, & - 1.d0, A_mo,LDA_mo, & - SC_inv_1_2, size(SC_inv_1_2,1), & - 0.d0, T, mo_tot_num_align) - -! SC_inv_1_2.A.CS - call dgemm('N','N', ao_num, ao_num, mo_tot_num, & - 1.d0, SC_inv_1_2,size(SC_inv_1_2,1), & - T, mo_tot_num_align, & - 0.d0, A_ao, LDA_ao) - -! C(S.A.S)C -! SC_inv_1_2.A.CS - deallocate(T,SC_inv_1_2) -end - -subroutine mo_to_ao_s_1_2(A_mo,LDA_mo,A_ao,LDA_ao) - implicit none - BEGIN_DOC - ! Transform A from the MO basis to the AO basis using the S^{-1} matrix - ! S^{-1} C A C^{+} S^{-1} - END_DOC - integer, intent(in) :: LDA_ao,LDA_mo - double precision, intent(in) :: A_mo(LDA_mo) - double precision, intent(out) :: A_ao(LDA_ao) - double precision, allocatable :: T(:,:), SC_1_2(:,:) - - allocate ( SC_1_2(ao_num_align,mo_tot_num) ) - allocate ( T(mo_tot_num_align,ao_num) ) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T - -! SC_1_2 = S^{-1}C - call dgemm('N','N', ao_num, mo_tot_num, ao_num, & - 1.d0, ao_overlap_1_2,size(ao_overlap_1_2,1), & - mo_coef, size(mo_coef,1), & - 0.d0, SC_1_2, ao_num_align) - -! T = A.(SC_1_2)^{+} - call dgemm('N','T', mo_tot_num, ao_num, mo_tot_num, & - 1.d0, A_mo,LDA_mo, & - SC_1_2, size(SC_1_2,1), & - 0.d0, T, mo_tot_num_align) - -! SC_1_2.A.CS - call dgemm('N','N', ao_num, ao_num, mo_tot_num, & - 1.d0, SC_1_2,size(SC_1_2,1), & - T, mo_tot_num_align, & - 0.d0, A_ao, LDA_ao) - -! C(S.A.S)C -! SC_1_2.A.CS - deallocate(T,SC_1_2) -end - - -subroutine mo_to_ao_s_inv(A_mo,LDA_mo,A_ao,LDA_ao) - implicit none - BEGIN_DOC - ! Transform A from the MO basis to the AO basis using the S^{-1} matrix - ! S^{-1} C A C^{+} S^{-1} - END_DOC - integer, intent(in) :: LDA_ao,LDA_mo - double precision, intent(in) :: A_mo(LDA_mo) - double precision, intent(out) :: A_ao(LDA_ao) - double precision, allocatable :: T(:,:), SC_inv(:,:) - - allocate ( SC_inv(ao_num_align,mo_tot_num) ) - allocate ( T(mo_tot_num_align,ao_num) ) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T - -! SC_inv = S^{-1}C - call dgemm('N','N', ao_num, mo_tot_num, ao_num, & - 1.d0, ao_overlap_inv,size(ao_overlap_inv,1), & - mo_coef, size(mo_coef,1), & - 0.d0, SC_inv, ao_num_align) - -! T = A.(SC_inv)^{+} - call dgemm('N','T', mo_tot_num, ao_num, mo_tot_num, & - 1.d0, A_mo,LDA_mo, & - SC_inv, size(SC_inv,1), & - 0.d0, T, mo_tot_num_align) - -! SC_inv.A.CS - call dgemm('N','N', ao_num, ao_num, mo_tot_num, & - 1.d0, SC_inv,size(SC_inv,1), & - T, mo_tot_num_align, & - 0.d0, A_ao, LDA_ao) - -! C(S.A.S)C -! SC_inv.A.CS - deallocate(T,SC_inv) -end - - subroutine mo_to_ao_no_overlap(A_mo,LDA_mo,A_ao,LDA_ao) implicit none BEGIN_DOC diff --git a/src/MO_Basis/rotate_mos.irp.f b/src/MO_Basis/rotate_mos.irp.f deleted file mode 100644 index a1c03bcd..00000000 --- a/src/MO_Basis/rotate_mos.irp.f +++ /dev/null @@ -1,8 +0,0 @@ -program rotate - implicit none - integer :: iorb,jorb - print*, 'which mos would you like to rotate' - read(5,*)iorb,jorb - call mix_mo_jk(iorb,jorb) - call save_mos -end diff --git a/src/MO_Basis/utils.irp.f b/src/MO_Basis/utils.irp.f index 8afa8744..750e3420 100644 --- a/src/MO_Basis/utils.irp.f +++ b/src/MO_Basis/utils.irp.f @@ -272,13 +272,21 @@ subroutine give_all_mos_at_r(r,mos_array) implicit none double precision, intent(in) :: r(3) double precision, intent(out) :: mos_array(mo_tot_num) + call give_specific_mos_at_r(r,mos_array, mo_coef) +end + +subroutine give_specific_mos_at_r(r,mos_array, mo_coef_specific) + implicit none + double precision, intent(in) :: r(3) + double precision, intent(in) :: mo_coef_specific(ao_num_align, mo_tot_num) + double precision, intent(out) :: mos_array(mo_tot_num) double precision :: aos_array(ao_num),accu integer :: i,j call give_all_aos_at_r(r,aos_array) do i = 1, mo_tot_num accu = 0.d0 do j = 1, ao_num - accu += mo_coef(j,i) * aos_array(j) + accu += mo_coef_specific(j,i) * aos_array(j) enddo mos_array(i) = accu enddo diff --git a/src/Pseudo/EZFIO.cfg b/src/Pseudo/EZFIO.cfg index 04eea7c6..fc23b678 100644 --- a/src/Pseudo/EZFIO.cfg +++ b/src/Pseudo/EZFIO.cfg @@ -86,16 +86,4 @@ doc: QMC grid interface: ezfio size: (ao_basis.ao_num,-pseudo.pseudo_lmax:pseudo.pseudo_lmax,0:pseudo.pseudo_lmax,nuclei.nucl_num,pseudo.pseudo_grid_size) -[disk_access_pseudo_local_integrals] -type: Disk_access -doc: Read/Write the local ntegrals from/to disk [ Write | Read | None ] -interface: ezfio,provider,ocaml -default: None - -[disk_access_pseudo_no_local_integrals] -type: Disk_access -doc: Read/Write the no-local ntegrals from/to disk [ Write | Read | None ] -interface: ezfio,provider,ocaml -default: None - diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index 32090f01..9f94bb62 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -19,10 +19,6 @@ subroutine svd(A,LDA,U,LDU,D,Vt,LDVt,m,n) double precision,allocatable :: A_tmp(:,:) allocate (A_tmp(LDA,n)) - print*, '' - do i = 1, n - print*, A(i,i) - enddo A_tmp = A ! Find optimal size for temp arrays diff --git a/src/Utils/angular_integration.irp.f b/src/Utils/angular_integration.irp.f index 757508a1..1efd4abc 100644 --- a/src/Utils/angular_integration.irp.f +++ b/src/Utils/angular_integration.irp.f @@ -4,7 +4,7 @@ BEGIN_PROVIDER [integer, degree_max_integration_lebedev] ! needed for the angular integration according to LEBEDEV formulae END_DOC implicit none - degree_max_integration_lebedev= 13 + degree_max_integration_lebedev= 15 END_PROVIDER @@ -644,14 +644,14 @@ END_PROVIDER weights_angular_integration_lebedev(16) = 0.016604069565742d0 weights_angular_integration_lebedev(17) = 0.016604069565742d0 weights_angular_integration_lebedev(18) = 0.016604069565742d0 - weights_angular_integration_lebedev(19) = 0.029586038961039d0 - weights_angular_integration_lebedev(20) = 0.029586038961039d0 - weights_angular_integration_lebedev(21) = 0.029586038961039d0 - weights_angular_integration_lebedev(22) = 0.029586038961039d0 - weights_angular_integration_lebedev(23) = 0.029586038961039d0 - weights_angular_integration_lebedev(24) = 0.029586038961039d0 - weights_angular_integration_lebedev(25) = 0.029586038961039d0 - weights_angular_integration_lebedev(26) = 0.029586038961039d0 + weights_angular_integration_lebedev(19) = -0.029586038961039d0 + weights_angular_integration_lebedev(20) = -0.029586038961039d0 + weights_angular_integration_lebedev(21) = -0.029586038961039d0 + weights_angular_integration_lebedev(22) = -0.029586038961039d0 + weights_angular_integration_lebedev(23) = -0.029586038961039d0 + weights_angular_integration_lebedev(24) = -0.029586038961039d0 + weights_angular_integration_lebedev(25) = -0.029586038961039d0 + weights_angular_integration_lebedev(26) = -0.029586038961039d0 weights_angular_integration_lebedev(27) = 0.026576207082159d0 weights_angular_integration_lebedev(28) = 0.026576207082159d0 weights_angular_integration_lebedev(29) = 0.026576207082159d0 diff --git a/src/Utils/constants.include.F b/src/Utils/constants.include.F index 4655a4fc..4974fd8e 100644 --- a/src/Utils/constants.include.F +++ b/src/Utils/constants.include.F @@ -10,8 +10,3 @@ double precision, parameter :: dtwo_pi = 2.d0*dacos(-1.d0) double precision, parameter :: inv_sq_pi = 1.d0/dsqrt(dacos(-1.d0)) double precision, parameter :: inv_sq_pi_2 = 0.5d0/dsqrt(dacos(-1.d0)) double precision, parameter :: thresh = 1.d-15 -double precision, parameter :: cx_lda = -0.73855876638202234d0 -double precision, parameter :: c_2_4_3 = 2.5198420997897464d0 -double precision, parameter :: cst_lda = -0.93052573634909996d0 -double precision, parameter :: c_4_3 = 1.3333333333333333d0 -double precision, parameter :: c_1_3 = 0.3333333333333333d0 diff --git a/src/Utils/invert.irp.f b/src/Utils/invert.irp.f deleted file mode 100644 index 4c626cca..00000000 --- a/src/Utils/invert.irp.f +++ /dev/null @@ -1,19 +0,0 @@ -subroutine invert_matrix(A,LDA,na,A_inv,LDA_inv) -implicit none -double precision, intent(in) :: A (LDA,na) -integer, intent(in) :: LDA, LDA_inv -integer, intent(in) :: na -double precision, intent(out) :: A_inv (LDA_inv,na) - - double precision :: work(LDA_inv*max(na,64)) -!DIR$ ATTRIBUTES ALIGN: $IRP_ALIGN :: work - integer :: inf - integer :: ipiv(LDA_inv) -!DIR$ ATTRIBUTES ALIGN: $IRP_ALIGN :: ipiv - integer :: lwork - A_inv(1:na,1:na) = A(1:na,1:na) - call dgetrf(na, na, A_inv, LDA_inv, ipiv, inf ) - lwork = SIZE(work) - call dgetri(na, A_inv, LDA_inv, ipiv, work, lwork, inf ) -end - diff --git a/tests/input/h2o.xyz b/tests/input/h2o.xyz index 99268e5d..e8cd039b 100644 --- a/tests/input/h2o.xyz +++ b/tests/input/h2o.xyz @@ -1,6 +1,6 @@ 3 XYZ file: coordinates in Angstrom -O 0.0000000000 -0.3880000000 0.0000000000 H 0.7510000000 0.1940000000 0.0000000000 +O 0.0000000000 -0.3880000000 0.0000000000 H -0.7510000000 0.1940000000 0.0000000000