From c577924b2c4c9928d31828ef0b765aa415d321ea Mon Sep 17 00:00:00 2001 From: jacharrym2 Date: Tue, 13 Aug 2024 00:33:33 +0200 Subject: [PATCH 1/4] Reorganizing CI code in modules. Cleaning old parts. --- src/CI/CI.f90 | 15 +- src/CI/CIDiag.f90 | 253 ++ src/CI/CIFullMatrix.f90 | 400 ++ src/CI/CIInitial.f90 | 533 +++ src/CI/CIJadamilu.f90 | 1364 +++++++ src/CI/CIOrder.f90 | 354 ++ src/CI/CIStrings.f90 | 262 ++ src/CI/CIcore.f90 | 355 ++ src/CI/CImod.f90 | 1553 ++++++++ src/CI/CImolpro | 311 ++ src/CI/ConfigurationInteraction.f90 | 5202 --------------------------- 11 files changed, 5393 insertions(+), 5209 deletions(-) create mode 100644 src/CI/CIDiag.f90 create mode 100644 src/CI/CIFullMatrix.f90 create mode 100644 src/CI/CIInitial.f90 create mode 100644 src/CI/CIJadamilu.f90 create mode 100644 src/CI/CIOrder.f90 create mode 100644 src/CI/CIStrings.f90 create mode 100644 src/CI/CIcore.f90 create mode 100644 src/CI/CImod.f90 create mode 100644 src/CI/CImolpro delete mode 100644 src/CI/ConfigurationInteraction.f90 diff --git a/src/CI/CI.f90 b/src/CI/CI.f90 index 8aa13b62..587ec088 100644 --- a/src/CI/CI.f90 +++ b/src/CI/CI.f90 @@ -30,9 +30,10 @@ program CI use CONTROL_ use MolecularSystem_ use Exception_ - use ConfigurationInteraction_ + use CIcore_ use String_ use InputCI_ + use CImod_ implicit none character(50) :: job @@ -65,12 +66,12 @@ program CI else call InputCI_load( MolecularSystem_getNumberOfQuantumSpecies() ) end if - call ConfigurationInteraction_constructor(CONTROL_instance%CONFIGURATION_INTERACTION_LEVEL ) - call ConfigurationInteraction_run() - call ConfigurationInteraction_show() - call ConfigurationInteraction_showEigenVectors() - call ConfigurationInteraction_densityMatrices() - call ConfigurationInteraction_destructor() + call CIcore_constructor(CONTROL_instance%CONFIGURATION_INTERACTION_LEVEL ) + call CImod_run() + call CImod_show() + call CImod_showEigenVectors() + call CImod_densityMatrices() + call CImod_destructor() !!stop time call Stopwatch_stop(lowdin_stopwatch) diff --git a/src/CI/CIDiag.f90 b/src/CI/CIDiag.f90 new file mode 100644 index 00000000..58627b96 --- /dev/null +++ b/src/CI/CIDiag.f90 @@ -0,0 +1,253 @@ +module CIDiag_ + use Exception_ + use Matrix_ + use Vector_ + use MolecularSystem_ + use Configuration_ + use MolecularSystem_ + use String_ + use IndexMap_ + use InputCI_ + use omp_lib + use CIcore_ + +contains + + !> + !! @brief Muestra informacion del objeto + !! + !! @param this + !< + subroutine CIcore_buildDiagonal() + implicit none + + integer(8) :: a,b,c + integer :: u,v + integer :: ci + integer :: i, j, ii, jj + integer :: s, numberOfSpecies, auxnumberOfSpecies + integer :: size1, size2 + real(8) :: timeA, timeB + integer(1) :: coupling + integer(8) :: numberOfConfigurations + real(8) :: CIenergy + integer(8), allocatable :: indexConf(:) + integer, allocatable :: cilevel(:), auxcilevel(:), dd(:) + +!$ timeA = omp_get_wtime() + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + coupling = 0 + CIenergy = 0 + s = 0 + c = 0 + numberOfConfigurations = 0 + + allocate ( ciLevel ( numberOfSpecies ) ) + allocate ( auxciLevel ( numberOfSpecies ) ) + allocate ( dd ( numberOfSpecies ) ) + + ciLevel = 0 + auxciLevel = 0 + + !!auxnumberOfSpecies = CIcore_numberOfConfigurationsRecursion2(s, numberOfSpecies, numberOfConfigurations, ciLevel) + + numberOfConfigurations = 0 + ciLevel = 0 + + !! call recursion to get the number of configurations... + do ci = 1, CIcore_instance%sizeCiOrderList + + cilevel(:) = CIcore_instance%ciOrderList( CIcore_instance%auxciOrderList(ci), :) + s = 0 + auxnumberOfSpecies = CIcore_numberOfConfigurationsRecursion(s, numberOfSpecies, numberOfConfigurations, ciLevel) + + end do + + call Vector_constructor8 ( CIcore_instance%diagonalHamiltonianMatrix2, & + numberOfConfigurations, 0.0_8 ) + + CIcore_instance%numberOfConfigurations = numberOfConfigurations + + write (*,*) "Number Of Configurations: ", numberOfConfigurations + + allocate ( indexConf ( numberOfSpecies ) ) + indexConf = 0 + + !! calculate the diagonal + s = 0 + c = 0 + ciLevel = 0 + + do ci = 1, CIcore_instance%sizeCiOrderList + + cilevel(:) = CIcore_instance%ciOrderList( CIcore_instance%auxciOrderList(ci), :) + s = 0 + dd = 0 + + u = CIcore_instance%auxciOrderList(ci) + auxnumberOfSpecies = CIcore_buildDiagonalRecursion( s, numberOfSpecies, indexConf, c, dd, u, cilevel, auxcilevel ) + end do + !stop + + deallocate ( dd ) + deallocate ( indexConf ) + deallocate ( ciLevel ) + deallocate ( auxciLevel ) + +!$ timeB = omp_get_wtime() +!$ write(*,"(A,E10.3,A4)") "** TOTAL Elapsed Time for Building diagonal of CI matrix : ", timeB - timeA ," (s)" + + write (*,*) "Reference energy, H_0: ", CIcore_instance%diagonalHamiltonianMatrix2%values(1) + + end subroutine CIcore_buildDiagonal + +recursive function CIcore_numberOfConfigurationsRecursion(s, numberOfSpecies, c, cilevel) result (os) + implicit none + + integer(8) :: a,b,c + integer :: u,v + integer :: i, j, ii, jj + integer :: s, numberOfSpecies + integer :: os,is + integer :: cilevel(:) + + is = s + 1 + if ( is < numberOfSpecies ) then + i = cilevel(is) + 1 + do a = 1, CIcore_instance%numberOfStrings(is)%values(i) + os = CIcore_numberOfConfigurationsRecursion( is, numberOfSpecies, c, cilevel ) + end do + else + os = is + + i = cilevel(is) + 1 + do a = 1, CIcore_instance%numberOfStrings(is)%values(i) + c = c + 1 + end do + end if + + end function CIcore_numberOfConfigurationsRecursion + + +recursive function CIcore_buildDiagonalRecursion(s, numberOfSpecies, indexConf, c, dd, u, cilevel, auxcilevel) result (os) + implicit none + + integer(8) :: a,b,c,cc,d + integer :: u,v + integer :: i, j, ii, jj + integer :: s, numberOfSpecies + integer :: os,is + integer :: size1, size2 + integer(8) :: indexConf(:) + real(8) :: timeA, timeB + integer(1) :: coupling + integer(8) :: numberOfConfigurations + real(8) :: CIenergy + integer :: ssize + integer :: cilevel(:), auxcilevel(:), dd(:) + + is = s + 1 + if ( is < numberOfSpecies ) then + i = cilevel(is) + 1 + ssize = CIcore_instance%numberOfStrings2(is)%values(i) + do a = 1, CIcore_instance%numberOfStrings(is)%values(i) + indexConf(is) = ssize + a + + dd(is) =(a + CIcore_instance%ciOrderSize1(u,is))* CIcore_instance%ciOrderSize2(u,is) + os = CIcore_buildDiagonalRecursion( is, numberOfSpecies, indexConf, c, dd, u, cilevel, auxcilevel ) + end do + else + os = is + i = cilevel(is) + 1 + ssize = CIcore_instance%numberOfStrings2(is)%values(i) + do a = 1, CIcore_instance%numberOfStrings(is)%values(i) + c = c + 1 + indexConf(is) = ssize + a + !print *, indexConf + dd(is) =(a + CIcore_instance%ciOrderSize1(u,is))* CIcore_instance%ciOrderSize2(u,is) + d = sum(dd) + + CIcore_instance%diagonalHamiltonianMatrix2%values(c) = & + CIcore_calculateEnergyZero ( indexConf ) + + end do + end if + + end function CIcore_buildDiagonalRecursion + + function CIcore_calculateEnergyZero( this ) result (auxCIenergy) + implicit none + + integer(8) :: this(:) + integer(8) :: a, b + integer :: i,j,s + integer :: l,k,z,kk,ll + integer :: factor + integer(2) :: numberOfDiffOrbitals + integer :: auxnumberOfOtherSpecieSpatialOrbitals + integer(8) :: auxIndex1, auxIndex2, auxIndex + real(8) :: auxCIenergy + + auxCIenergy = 0.0_8 + + do i = 1, MolecularSystem_instance%numberOfQuantumSpecies + a = this(i) + do kk=1, CIcore_instance%occupationNumber( i ) !! 1 is from a and 2 from b + + k = CIcore_instance%strings(i)%values(kk,a) + + !One particle terms + auxCIenergy = auxCIenergy + & + CIcore_instance%twoCenterIntegrals(i)%values( k, k ) + + !Two particles, same specie + auxIndex1 = CIcore_instance%twoIndexArray(i)%values(k,k) + + do ll = kk + 1, CIcore_instance%occupationNumber( i ) !! 1 is from a and 2 from b + + l = CIcore_instance%strings(i)%values(ll,a) + auxIndex2 = CIcore_instance%twoIndexArray(i)%values(l,l) + auxIndex = CIcore_instance%fourIndexArray(i)%values(auxIndex1,auxIndex2) + + !Coulomb + auxCIenergy = auxCIenergy + & + CIcore_instance%fourCenterIntegrals(i,i)%values(auxIndex, 1) + + !Exchange, depends on spin + + auxIndex = CIcore_instance%fourIndexArray(i)%values( & + CIcore_instance%twoIndexArray(i)%values(k,l), & + CIcore_instance%twoIndexArray(i)%values(l,k) ) + + auxCIenergy = auxCIenergy + & + MolecularSystem_instance%species(i)%kappa*CIcore_instance%fourCenterIntegrals(i,i)%values(auxIndex, 1) + end do + + !!Two particles, different species + do j = i + 1, MolecularSystem_instance%numberOfQuantumSpecies + b = this(j) + auxnumberOfOtherSpecieSpatialOrbitals = CIcore_instance%numberOfSpatialOrbitals2%values(j) + + do ll = 1, CIcore_instance%occupationNumber( j ) !! 1 is from a and 2 from b + l = CIcore_instance%strings(j)%values(ll,b) + + auxIndex2= CIcore_instance%twoIndexArray(j)%values(l,l) + auxIndex = auxnumberOfOtherSpecieSpatialOrbitals * (auxIndex1 - 1 ) + auxIndex2 + + auxCIenergy = auxCIenergy + &!couplingEnergy + CIcore_instance%fourCenterIntegrals(i,j)%values(auxIndex, 1) + + end do + + end do + + end do + end do + + auxCIenergy= auxCIenergy + HartreeFock_instance%puntualInteractionEnergy + + end function CIcore_calculateEnergyZero + + +end module CIDiag_ diff --git a/src/CI/CIFullMatrix.f90 b/src/CI/CIFullMatrix.f90 new file mode 100644 index 00000000..ac78c16d --- /dev/null +++ b/src/CI/CIFullMatrix.f90 @@ -0,0 +1,400 @@ + module CIFullMatrix_ + use Exception_ + use Matrix_ + use Vector_ + use MolecularSystem_ + use Configuration_ + use MolecularSystem_ + use String_ + use IndexMap_ + use InputCI_ + use omp_lib + use CIcore_ + +contains + +!> + !! @brief Muestra informacion del objeto + !! + !! @param this + !< + subroutine CIcore_buildHamiltonianMatrix() + implicit none + + integer(8) :: a,b,c + integer :: u,v,p + integer :: ci + integer :: i, j, ii, jj + integer :: s, numberOfSpecies, auxnumberOfSpecies + integer :: size1, size2 + real(8) :: timeA, timeB + integer(1) :: coupling + integer(8) :: numberOfConfigurations + real(8) :: CIenergy + integer(8), allocatable :: indexConf(:) + integer(8), allocatable :: pindexConf(:,:) + integer, allocatable :: cilevel(:), auxcilevel(:), dd(:) + integer(8), allocatable :: indexConfA(:,:) + integer(8), allocatable :: indexConfB(:,:) + integer, allocatable :: stringAinB(:) + integer(1), allocatable :: couplingSpecies(:,:) + integer :: n,nproc + + +!$ timeA = omp_get_wtime() + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + + numberOfConfigurations = CIcore_instance%numberOfConfigurations + + allocate ( CIcore_instance%allIndexConf( numberOfSpecies, numberOfConfigurations ) ) + allocate ( ciLevel ( numberOfSpecies ) ) + allocate ( indexConf ( numberOfSpecies ) ) + ciLevel = 0 + CIcore_instance%allIndexConf = 0 + indexConf = 0 + + !! gather all configurations + s = 0 + c = 0 + ciLevel = 0 + + do ci = 1, CIcore_instance%sizeCiOrderList + + cilevel(:) = CIcore_instance%ciOrderList( CIcore_instance%auxciOrderList(ci), :) + s = 0 + auxnumberOfSpecies = CIcore_gatherConfRecursion( s, numberOfSpecies, indexConf, c, cilevel ) + end do + !stop + + deallocate ( indexConf ) + deallocate ( ciLevel ) + + !! allocate the hamiltonian matrix + call Matrix_constructor ( CIcore_instance%hamiltonianMatrix, & + int(CIcore_instance%numberOfConfigurations,8), & + int(CIcore_instance%numberOfConfigurations,8), 0.0_8) + + + nproc = omp_get_max_threads() + !! calculate the matrix elements + allocate ( indexConfA ( numberOfSpecies, nproc ) ) + allocate ( indexConfB ( numberOfSpecies, nproc ) ) + allocate ( pindexConf ( numberOfSpecies, nproc ) ) + allocate ( couplingSpecies ( numberOfSpecies, nproc ) ) + + indexConfA = 0 + indexConfB = 0 + pindexConf = 0 + couplingSpecies = 0 + +!$omp parallel & +!$omp& private(a,b,coupling,i,p,stringAinB,n),& +!$omp& shared(CIcore_instance, HartreeFock_instance) + n = omp_get_thread_num() + 1 +!$omp do schedule (dynamic) + do a = 1, numberOfConfigurations + indexConfA(:,n) = CIcore_instance%allIndexConf(:,a) + do b = a, numberOfConfigurations + + indexConfB(:,n) = CIcore_instance%allIndexConf(:,b) + + do i = 1, numberOfSpecies + if ( pindexConf(i,n) /= indexConfB(i,n) ) then + allocate (stringAinB (CIcore_instance%numberOfOccupiedOrbitals%values(i) )) + stringAinB = 0 + do p = 1, CIcore_instance%numberOfOccupiedOrbitals%values(i) + stringAinB(p) = CIcore_instance%orbitals(i)%values( & + CIcore_instance%strings(i)%values(p,indexConfA(i,n) ), indexConfB(i,n) ) + end do + couplingSpecies(i,n) = CIcore_instance%numberOfOccupiedOrbitals%values(i) - sum ( stringAinB ) + deallocate (stringAinB ) + end if + end do + coupling = sum(couplingSpecies(:,n)) + + if ( coupling == 0 ) then + CIcore_instance%hamiltonianMatrix%values(a,b) = & + CIcore_instance%diagonalHamiltonianMatrix2%values(a) + + else if ( coupling == 1 ) then + + CIcore_instance%hamiltonianMatrix%values(a,b) = & + CIcore_calculateEnergyOne ( n, indexConfA(:,n), indexConfB(:,n) ) + + else if ( coupling == 2 ) then + + CIcore_instance%hamiltonianMatrix%values(a,b) = & + CIcore_calculateEnergyTwo ( n, indexConfA(:,n), indexConfB(:,n) ) + + end if + + pindexConf(:,n) = indexConfB(:,n) + + end do + pindexConf(:,n) = 0 + end do + !$omp end do nowait + !$omp end parallel + + deallocate ( pindexConf ) + deallocate ( couplingSpecies ) + deallocate ( indexConfB ) + deallocate ( indexConfA ) + + !! symmetrize + do a = 1, numberOfConfigurations + do b = a, numberOfConfigurations + CIcore_instance%hamiltonianMatrix%values(b,a) = & + CIcore_instance%hamiltonianMatrix%values(a,b) + end do + end do + + deallocate ( CIcore_instance%allIndexConf ) + +!$ timeB = omp_get_wtime() +!$ write(*,"(A,E10.3,A4)") "** TOTAL Elapsed Time for building Hamiltonian Matrix : ", timeB - timeA ," (s)" + + end subroutine CIcore_buildHamiltonianMatrix + + function CIcore_calculateEnergyOne( n, thisA, thisB ) result (auxCIenergy) + implicit none + integer(8) :: thisA(:), thisB(:) + integer(8) :: a, b + integer :: i,j,s,n, nn + integer :: l,k,z,kk,ll + integer :: factor + integer :: auxnumberOfOtherSpecieSpatialOrbitals + integer(8) :: auxIndex1, auxIndex2, auxIndex + integer :: diffOrb(2), otherdiffOrb(2) !! to avoid confusions + real(8) :: auxCIenergy + integer :: auxOcc + + auxCIenergy = 0.0_8 + + factor = 1 + + !! copy a + do i = 1, MolecularSystem_instance%numberOfQuantumSpecies + a = thisA(i) + + CIcore_instance%auxstring(n,i)%values(:) = CIcore_instance%strings(i)%values(:,a) + end do + + !! set at maximum coincidence + + do s = 1, MolecularSystem_instance%numberOfQuantumSpecies + a = thisA(s) + b = thisB(s) + + do i = 1, CIcore_instance%numberOfOccupiedOrbitals%values(s) !b + do j = 1, CIcore_instance%numberOfOccupiedOrbitals%values(s) !a + if ( CIcore_instance%auxstring(n,s)%values(j) == & + CIcore_instance%strings(s)%values(i,b) ) then + + auxOcc = CIcore_instance%auxstring(n,s)%values(i) + CIcore_instance%auxstring(n,s)%values(i) = CIcore_instance%strings(s)%values(i,b) + CIcore_instance%auxstring(n,s)%values(j) = auxOcc + if ( i /= j ) factor = -1*factor + exit + end if + end do + end do + end do + + !! calculate + do i = 1, MolecularSystem_instance%numberOfQuantumSpecies + + a = thisA(i) + b = thisB(i) + diffOrb = 0 + + do kk = 1, CIcore_instance%occupationNumber( i) !! 1 is from a and 2 from b + + if ( CIcore_instance%auxstring(n,i)%values(kk) .ne. & + CIcore_instance%strings(i)%values(kk,b) ) then + diffOrb(1) = CIcore_instance%auxstring(n,i)%values(kk) + diffOrb(2) = CIcore_instance%strings(i)%values(kk,b) + exit + end if + + end do + if ( diffOrb(2) > 0 ) then + + !One particle terms + auxCIenergy= auxCIenergy + CIcore_instance%twoCenterIntegrals(i)%values( & + diffOrb(1), diffOrb(2) ) + + auxIndex1= CIcore_instance%twoIndexArray(i)%values( & + diffOrb(1), diffOrb(2)) + + do ll = 1, CIcore_instance%occupationNumber( i ) !! 1 is from a and 2 from b + + if ( CIcore_instance%auxstring(n,i)%values(ll) .eq. & + CIcore_instance%strings(i)%values(ll,b) ) then + + l = CIcore_instance%auxstring(n,i)%values(ll) !! or b + + auxIndex2 = CIcore_instance%twoIndexArray(i)%values( l,l) + + auxIndex = CIcore_instance%fourIndexArray(i)%values( auxIndex1, auxIndex2 ) + + auxCIenergy = auxCIenergy + & + CIcore_instance%fourCenterIntegrals(i,i)%values(auxIndex, 1) + + + auxIndex = CIcore_instance%fourIndexArray(i)%values( & + CIcore_instance%twoIndexArray(i)%values(diffOrb(1),l), & + CIcore_instance%twoIndexArray(i)%values(l,diffOrb(2)) ) + + auxCIenergy = auxCIenergy + & + MolecularSystem_instance%species(i)%kappa*CIcore_instance%fourCenterIntegrals(i,i)%values(auxIndex, 1) + + end if + end do + if (MolecularSystem_instance%numberOfQuantumSpecies .gt. 1 ) then !.and. spin(1) .eq. spin(2) ) then + do j=1, MolecularSystem_instance%numberOfQuantumSpecies + + if (i .ne. j) then + + auxnumberOfOtherSpecieSpatialOrbitals = CIcore_instance%numberOfSpatialOrbitals2%values(j) + + do ll=1, CIcore_instance%occupationNumber( j ) !! 1 is from a and 2 from b + l = CIcore_instance%auxstring(n,j)%values(ll) !! or b? + + auxIndex2 = CIcore_instance%twoIndexArray(j)%values( l,l) + auxIndex = auxnumberOfOtherSpecieSpatialOrbitals * (auxIndex1 - 1 ) + auxIndex2 + + auxCIenergy = auxCIenergy + & + CIcore_instance%fourCenterIntegrals(i,j)%values(auxIndex, 1) + end do + end if + end do + end if + end if + end do + + auxCIenergy= auxCIenergy * factor + + + end function CIcore_calculateEnergyOne + + function CIcore_calculateEnergyTwo( n, thisA, thisB ) result (auxCIenergy) + implicit none + integer(8) :: thisA(:), thisB(:) + integer(8) :: a, b + integer :: i,j,s,n + integer :: l,k,z,kk,ll + integer :: factor + integer :: auxnumberOfOtherSpecieSpatialOrbitals + integer(8) :: auxIndex1, auxIndex2, auxIndex + integer :: diffOrb(4), otherdiffOrb(4) !! to avoid confusions + real(8) :: auxCIenergy + integer :: auxOcc + + auxCIenergy = 0.0_8 + factor = 1 + + !! copy a + do i = 1, MolecularSystem_instance%numberOfQuantumSpecies + a = thisA(i) + CIcore_instance%auxstring(n,i)%values(:) = CIcore_instance%strings(i)%values(:,a) + end do + + !! set at maximum coincidence + + do s = 1, MolecularSystem_instance%numberOfQuantumSpecies + a = thisA(s) + b = thisB(s) + + do i = 1, CIcore_instance%numberOfOccupiedOrbitals%values(s) !b + do j = 1, CIcore_instance%numberOfOccupiedOrbitals%values(s) !a + if ( CIcore_instance%auxstring(n,s)%values(j) == & + CIcore_instance%strings(s)%values(i,b) ) then + + auxOcc = CIcore_instance%auxstring(n,s)%values(i) + CIcore_instance%auxstring(n,s)%values(i) = CIcore_instance%strings(s)%values(i,b) + CIcore_instance%auxstring(n,s)%values(j) = auxOcc + if ( i /= j ) factor = -1*factor + exit + end if + end do + end do + end do + + !!calculate + do i=1, MolecularSystem_instance%numberOfQuantumSpecies + + a = thisA(i) + b = thisB(i) + diffOrb = 0 + z = 1 + do k = 1, CIcore_instance%numberOfOccupiedOrbitals%values(i) + + if ( CIcore_instance%auxstring(n,i)%values(k) .ne. & + CIcore_instance%strings(i)%values(k,b) ) then + diffOrb(z) = CIcore_instance%auxstring(n,i)%values(k) + diffOrb(z+2) = CIcore_instance%strings(i)%values(k,b) + z = z + 1 + cycle + end if + end do + if ( diffOrb(2) > 0 ) then + + !Coulomb + auxIndex = CIcore_instance%fourIndexArray(i)%values( & + CIcore_instance%twoIndexArray(i)%values(& + diffOrb(1),diffOrb(3)),& + CIcore_instance%twoIndexArray(i)%values(& + diffOrb(2),diffOrb(4)) ) + + auxCIenergy = auxCIenergy + & + CIcore_instance%fourCenterIntegrals(i,i)%values(auxIndex, 1) + + auxIndex = CIcore_instance%fourIndexArray(i)%values( & + CIcore_instance%twoIndexArray(i)%values(& + diffOrb(1),diffOrb(4)),& + CIcore_instance%twoIndexArray(i)%values(& + diffOrb(2),diffOrb(3)) ) + + auxCIenergy = auxCIenergy + & + MolecularSystem_instance%species(i)%kappa*CIcore_instance%fourCenterIntegrals(i,i)%values(auxIndex, 1) + + end if + !! different species + do j = i + 1, MolecularSystem_instance%numberOfQuantumSpecies + auxnumberOfOtherSpecieSpatialOrbitals = CIcore_instance%numberOfSpatialOrbitals2%values(j) + otherdiffOrb = 0 + a = thisA(j) + b = thisB(j) + + do k = 1, CIcore_instance%numberOfOccupiedOrbitals%values(j) + if ( CIcore_instance%auxstring(n,j)%values(k) .ne. & + CIcore_instance%strings(j)%values(k,b) ) then + otherdiffOrb(1) = CIcore_instance%auxstring(n,j)%values(k) + otherdiffOrb(3) = CIcore_instance%strings(j)%values(k,b) + exit + end if + + end do + + if ( diffOrb(3) .gt. 0 .and. otherdiffOrb(3) .gt. 0 ) then + auxIndex1 = CIcore_instance%twoIndexArray(i)%values(& + diffOrb(1),diffOrb(3) ) + auxIndex2 = CIcore_instance%twoIndexArray(j)%values(& + otherdiffOrb(1),otherdiffOrb(3) ) + auxIndex = auxnumberOfOtherSpecieSpatialOrbitals * (auxIndex1 - 1 ) + auxIndex2 + + auxCIenergy = auxCIenergy + & + CIcore_instance%fourCenterIntegrals(i,j)%values(auxIndex, 1) + + end if + end do + end do + + auxCIenergy= auxCIenergy * factor + + end function CIcore_calculateEnergyTwo + + + end module CIFullMatrix_ diff --git a/src/CI/CIInitial.f90 b/src/CI/CIInitial.f90 new file mode 100644 index 00000000..e630c032 --- /dev/null +++ b/src/CI/CIInitial.f90 @@ -0,0 +1,533 @@ +module CIInitial_ + use Exception_ + use Matrix_ + use Vector_ + use MolecularSystem_ + use Configuration_ + use MolecularSystem_ + use String_ + use IndexMap_ + use InputCI_ + use omp_lib + use CIcore_ + +contains + + + subroutine CIcore_buildInitialCIMatrix2() + implicit none + + type(Configuration) :: auxConfigurationA, auxConfigurationB + type (Vector8) :: diagonalHamiltonianMatrix + integer :: a,b,c,aa,bb,i + real(8) :: timeA, timeB + real(8) :: CIenergy + integer :: initialCIMatrixSize + integer :: nproc + + !$ timeA = omp_get_wtime() + initialCIMatrixSize = CONTROL_instance%CI_SIZE_OF_GUESS_MATRIX + if ( CIcore_instance%numberOfConfigurations < CONTROL_instance%CI_SIZE_OF_GUESS_MATRIX ) then + CONTROL_instance%CI_SIZE_OF_GUESS_MATRIX = CIcore_instance%numberOfConfigurations !! assign to an internal variable + end if + + call Vector_constructorInteger8 ( CIcore_instance%auxIndexCIMatrix, & + CIcore_instance%numberOfConfigurations, 0_8 ) !hmm + + do a = 1, CIcore_instance%numberOfConfigurations + CIcore_instance%auxIndexCIMatrix%values(a)= a + end do + + !! save the unsorted diagonal Matrix + call Vector_constructor8 ( CIcore_instance%diagonalHamiltonianMatrix, & + CIcore_instance%numberOfConfigurations, 0.0_8 ) + + + CIcore_instance%diagonalHamiltonianMatrix%values = CIcore_instance%diagonalHamiltonianMatrix2%values + + !! To get only the lowest 300 values. + call Vector_reverseSortElements8( CIcore_instance%diagonalHamiltonianMatrix2, & + CIcore_instance%auxIndexCIMatrix, int(initialCIMatrixSize,8)) + + call Matrix_constructor ( CIcore_instance%initialHamiltonianMatrix, int(initialCIMatrixSize,8) , & + int(initialCIMatrixSize,8) , 0.0_8 ) + + !! get the configurations for the initial hamiltonian matrix + call CIcore_getInitialIndexes() + + call CIcore_calculateInitialCIMatrix() + + !! diagonalize the initial matrix + call Vector_constructor8 ( CIcore_instance%initialEigenValues, int(CONTROL_instance%NUMBER_OF_CI_STATES,8), 0.0_8) + + call Matrix_constructor (CIcore_instance%initialEigenVectors, & + int(initialCIMatrixSize,8), & + int(CONTROL_instance%NUMBER_OF_CI_STATES,8), 0.0_8) + + call Matrix_eigen_select ( CIcore_instance%initialHamiltonianMatrix, & + CIcore_instance%initialEigenValues, & + 1, int(CONTROL_instance%NUMBER_OF_CI_STATES,4), & + eigenVectors = CIcore_instance%initialEigenVectors, & + flags = int(SYMMETRIC,4)) + + write(*,*) "Initial eigenValues" + do i = 1, CONTROL_instance%NUMBER_OF_CI_STATES + write (*,*) i, CIcore_instance%initialEigenValues%values(i) + end do + + call Vector_destructor8 ( CIcore_instance%diagonalHamiltonianMatrix2 ) + +!$ timeB = omp_get_wtime() +!$ write(*,"(A,F10.3,A4)") "** TOTAL Elapsed Time for Solving Initial CI : ", timeB - timeA ," (s)" + + end subroutine CIcore_buildInitialCIMatrix2 + + !> + !! @brief Muestra informacion del objeto + !! + !! @param this + !< + !! Map the indexes of initial CI matrix to the complete matrix. + subroutine CIcore_getInitialIndexes() + implicit none + + integer(8) :: a,b,c + integer :: u,v + integer :: ci + integer :: i, j, ii, jj + integer :: s, numberOfSpecies, auxnumberOfSpecies + integer :: size1, size2 + real(8) :: timeA, timeB + integer(1) :: coupling + integer(8) :: numberOfConfigurations + real(8) :: CIenergy + integer(8), allocatable :: indexConf(:) + integer, allocatable :: cilevel(:) + +!$ timeA = omp_get_wtime() + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + + s = 0 + c = 0 + + call Matrix_constructorInteger ( CIcore_instance%auxConfigurations, int( numberOfSpecies,8), & + int(CONTROL_instance%CI_SIZE_OF_GUESS_MATRIX,8), 0 ) + + !! call recursion + + allocate ( cilevel ( numberOfSpecies ) ) + allocate ( indexConf ( numberOfSpecies ) ) + + s = 0 + c = 0 + indexConf = 0 + cilevel = 0 + + do ci = 1, CIcore_instance%sizeCiOrderList + cilevel(:) = CIcore_instance%ciOrderList( CIcore_instance%auxciOrderList(ci), :) + s = 0 + auxnumberOfSpecies = CIcore_getIndexesRecursion( s, numberOfSpecies, indexConf, c, cilevel ) + end do + + deallocate ( indexConf ) + deallocate ( cilevel ) + +!$ timeB = omp_get_wtime() + +!$ write(*,"(A,E10.3,A4)") "** TOTAL Elapsed Time for getting initial indexes : ", timeB - timeA ," (s)" + + end subroutine CIcore_getInitialIndexes + + +recursive function CIcore_getIndexesRecursion(s, numberOfSpecies, indexConf, c, cilevel) result (os) + implicit none + + integer(8) :: a,b,c + integer :: u,v + integer :: i, j, ii, jj + integer :: s, ss, numberOfSpecies + integer :: os,is + integer :: size1, size2 + integer(8) :: indexConf(:) + integer(1) :: coupling + integer :: ssize + integer :: cilevel(:) + + is = s + 1 + if ( is < numberOfSpecies ) then + i = cilevel(is) + 1 + ssize = CIcore_instance%numberOfStrings2(is)%values(i) + + do a = 1, CIcore_instance%numberOfStrings(is)%values(i) + indexConf(is) = ssize + a + os = CIcore_getIndexesRecursion( is, numberOfSpecies, indexConf, c, cilevel) + end do + else + os = is + i = cilevel(is) + 1 + ssize = CIcore_instance%numberOfStrings2(is)%values(i) + + do a = 1, CIcore_instance%numberOfStrings(is)%values(i) + c = c + 1 + indexConf(is) = ssize + a + do u = 1, CONTROL_instance%CI_SIZE_OF_GUESS_MATRIX + if ( c == CIcore_instance%auxIndexCIMatrix%values(u) ) then + do ss = 1, numberOfSpecies + CIcore_instance%auxConfigurations%values(ss,u) = indexConf(ss) + end do + end if + end do + end do + end if + + end function CIcore_getIndexesRecursion + + !> + !! @brief Muestra informacion del objeto + !! + !! @param this + !< + subroutine CIcore_calculateInitialCIMatrix() + implicit none + + integer(8) :: a,b,aa,bb + integer :: u,v + integer :: i + integer :: numberOfSpecies + real(8) :: timeA1, timeB1 + integer(1) :: coupling + integer(1), allocatable :: orbitalsA(:), orbitalsB(:) + integer :: initialCIMatrixSize + integer :: nproc + integer(8), allocatable :: indexConfA(:) + integer(8), allocatable :: indexConfB(:) + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + + initialCIMatrixSize = CONTROL_instance%CI_SIZE_OF_GUESS_MATRIX + + allocate ( indexConfA ( numberOfSpecies ) ) + allocate ( indexConfB ( numberOfSpecies ) ) + +!$ timeA1 = omp_get_wtime() + + do a = 1, initialCIMatrixSize + aa = CIcore_instance%auxIndexCIMatrix%values(a) + do b = a, initialCIMatrixSize + bb = CIcore_instance%auxIndexCIMatrix%values(b) + coupling = 0 + + indexConfA = 0 + indexConfB = 0 + + do i = 1, numberOfSpecies + + allocate (orbitalsA ( CIcore_instance%numberOfOrbitals%values(i) )) + allocate (orbitalsB ( CIcore_instance%numberOfOrbitals%values(i) )) + orbitalsA = 0 + orbitalsB = 0 + + indexConfA(i) = CIcore_instance%auxConfigurations%values(i,a) + indexConfB(i) = CIcore_instance%auxConfigurations%values(i,b) + + do u = 1, CIcore_instance%numberOfOccupiedOrbitals%values(i) + orbitalsA( CIcore_instance%strings(i)%values(u,indexConfA(i) ) ) = 1 + end do + do v = 1, CIcore_instance%numberOfOccupiedOrbitals%values(i) + orbitalsB( CIcore_instance%strings(i)%values(v,indexConfB(i) ) ) = 1 + end do + coupling = coupling + & + CIcore_instance%numberOfOccupiedOrbitals%values(i) - sum ( orbitalsA * orbitalsB ) + + deallocate (orbitalsA ) + deallocate (orbitalsB ) + + end do + if ( coupling == 0 ) then + CIcore_instance%initialHamiltonianMatrix%values(a,b) = & + CIcore_instance%diagonalHamiltonianMatrix2%values(a) + + else if ( coupling == 1 ) then + + CIcore_instance%initialHamiltonianMatrix%values(a,b) = & + CI_Initial_calculateEnergyOne ( 1, indexConfA, indexConfB ) + + else if ( coupling == 2 ) then + + CIcore_instance%initialHamiltonianMatrix%values(a,b) = & + CI_Initial_calculateEnergyTwo ( 1, indexConfA, indexConfB ) + + end if + + + end do + + + end do + + deallocate ( indexConfB ) + deallocate ( indexConfA ) + +!$ timeB1 = omp_get_wtime() + !! symmetrize + do a = 1, initialCIMatrixSize + do b = a, initialCIMatrixSize + + CIcore_instance%initialHamiltonianMatrix%values(b,a) = & + CIcore_instance%initialHamiltonianMatrix%values(a,b) + end do + end do + + !!open(unit=318, file="cimatrix.dat", action = "write", form="formatted") + !!do a = 1, initialCIMatrixSize + !! do b = 1, initialCIMatrixSize + !! write (318,*) a,b, CIcore_instance%initialHamiltonianMatrix%values(a,b) + !! end do + !! write (318,*) " " + !!end do + !!close(318) +!$ write(*,"(A,E10.3,A4)") "** TOTAL Elapsed Time for Calculating initial CI matrix : ", timeB1 - timeA1 ," (s)" + + end subroutine CIcore_calculateInitialCIMatrix + + function CI_Initial_calculateEnergyOne( n, thisA, thisB ) result (auxCIenergy) + implicit none + integer(8) :: thisA(:), thisB(:) + integer(8) :: a, b + integer :: i,j,s,n, nn + integer :: l,k,z,kk,ll + integer :: factor + integer :: auxnumberOfOtherSpecieSpatialOrbitals + integer(8) :: auxIndex1, auxIndex2, auxIndex + integer :: diffOrb(2), otherdiffOrb(2) !! to avoid confusions + real(8) :: auxCIenergy + integer :: auxOcc + + auxCIenergy = 0.0_8 + + factor = 1 + + !! copy a + do i = 1, MolecularSystem_instance%numberOfQuantumSpecies + a = thisA(i) + + CIcore_instance%auxstring(n,i)%values(:) = CIcore_instance%strings(i)%values(:,a) + end do + + !! set at maximum coincidence + + do s = 1, MolecularSystem_instance%numberOfQuantumSpecies + a = thisA(s) + b = thisB(s) + + do i = 1, CIcore_instance%numberOfOccupiedOrbitals%values(s) !b + do j = 1, CIcore_instance%numberOfOccupiedOrbitals%values(s) !a + if ( CIcore_instance%auxstring(n,s)%values(j) == & + CIcore_instance%strings(s)%values(i,b) ) then + + auxOcc = CIcore_instance%auxstring(n,s)%values(i) + CIcore_instance%auxstring(n,s)%values(i) = CIcore_instance%strings(s)%values(i,b) + CIcore_instance%auxstring(n,s)%values(j) = auxOcc + if ( i /= j ) factor = -1*factor + exit + end if + end do + end do + end do + + !! calculate + do i = 1, MolecularSystem_instance%numberOfQuantumSpecies + + a = thisA(i) + b = thisB(i) + diffOrb = 0 + + do kk = 1, CIcore_instance%occupationNumber( i) !! 1 is from a and 2 from b + + if ( CIcore_instance%auxstring(n,i)%values(kk) .ne. & + CIcore_instance%strings(i)%values(kk,b) ) then + diffOrb(1) = CIcore_instance%auxstring(n,i)%values(kk) + diffOrb(2) = CIcore_instance%strings(i)%values(kk,b) + exit + end if + + end do + if ( diffOrb(2) > 0 ) then + + !One particle terms + auxCIenergy= auxCIenergy + CIcore_instance%twoCenterIntegrals(i)%values( & + diffOrb(1), diffOrb(2) ) + + auxIndex1= CIcore_instance%twoIndexArray(i)%values( & + diffOrb(1), diffOrb(2)) + + do ll = 1, CIcore_instance%occupationNumber( i ) !! 1 is from a and 2 from b + + if ( CIcore_instance%auxstring(n,i)%values(ll) .eq. & + CIcore_instance%strings(i)%values(ll,b) ) then + + l = CIcore_instance%auxstring(n,i)%values(ll) !! or b + + auxIndex2 = CIcore_instance%twoIndexArray(i)%values( l,l) + + auxIndex = CIcore_instance%fourIndexArray(i)%values( auxIndex1, auxIndex2 ) + + auxCIenergy = auxCIenergy + & + CIcore_instance%fourCenterIntegrals(i,i)%values(auxIndex, 1) + + + auxIndex = CIcore_instance%fourIndexArray(i)%values( & + CIcore_instance%twoIndexArray(i)%values(diffOrb(1),l), & + CIcore_instance%twoIndexArray(i)%values(l,diffOrb(2)) ) + + auxCIenergy = auxCIenergy + & + MolecularSystem_instance%species(i)%kappa*CIcore_instance%fourCenterIntegrals(i,i)%values(auxIndex, 1) + + end if + end do + if (MolecularSystem_instance%numberOfQuantumSpecies .gt. 1 ) then !.and. spin(1) .eq. spin(2) ) then + do j=1, MolecularSystem_instance%numberOfQuantumSpecies + + if (i .ne. j) then + + auxnumberOfOtherSpecieSpatialOrbitals = CIcore_instance%numberOfSpatialOrbitals2%values(j) + + do ll=1, CIcore_instance%occupationNumber( j ) !! 1 is from a and 2 from b + l = CIcore_instance%auxstring(n,j)%values(ll) !! or b? + + auxIndex2 = CIcore_instance%twoIndexArray(j)%values( l,l) + auxIndex = auxnumberOfOtherSpecieSpatialOrbitals * (auxIndex1 - 1 ) + auxIndex2 + + auxCIenergy = auxCIenergy + & + CIcore_instance%fourCenterIntegrals(i,j)%values(auxIndex, 1) + end do + end if + end do + end if + end if + end do + + auxCIenergy= auxCIenergy * factor + + + end function CI_Initial_calculateEnergyOne + + function CI_Initial_calculateEnergyTwo( n, thisA, thisB ) result (auxCIenergy) + implicit none + integer(8) :: thisA(:), thisB(:) + integer(8) :: a, b + integer :: i,j,s,n + integer :: l,k,z,kk,ll + integer :: factor + integer :: auxnumberOfOtherSpecieSpatialOrbitals + integer(8) :: auxIndex1, auxIndex2, auxIndex + integer :: diffOrb(4), otherdiffOrb(4) !! to avoid confusions + real(8) :: auxCIenergy + integer :: auxOcc + + auxCIenergy = 0.0_8 + factor = 1 + + !! copy a + do i = 1, MolecularSystem_instance%numberOfQuantumSpecies + a = thisA(i) + CIcore_instance%auxstring(n,i)%values(:) = CIcore_instance%strings(i)%values(:,a) + end do + + !! set at maximum coincidence + + do s = 1, MolecularSystem_instance%numberOfQuantumSpecies + a = thisA(s) + b = thisB(s) + + do i = 1, CIcore_instance%numberOfOccupiedOrbitals%values(s) !b + do j = 1, CIcore_instance%numberOfOccupiedOrbitals%values(s) !a + if ( CIcore_instance%auxstring(n,s)%values(j) == & + CIcore_instance%strings(s)%values(i,b) ) then + + auxOcc = CIcore_instance%auxstring(n,s)%values(i) + CIcore_instance%auxstring(n,s)%values(i) = CIcore_instance%strings(s)%values(i,b) + CIcore_instance%auxstring(n,s)%values(j) = auxOcc + if ( i /= j ) factor = -1*factor + exit + end if + end do + end do + end do + + !!calculate + do i=1, MolecularSystem_instance%numberOfQuantumSpecies + + a = thisA(i) + b = thisB(i) + diffOrb = 0 + z = 1 + do k = 1, CIcore_instance%numberOfOccupiedOrbitals%values(i) + + if ( CIcore_instance%auxstring(n,i)%values(k) .ne. & + CIcore_instance%strings(i)%values(k,b) ) then + diffOrb(z) = CIcore_instance%auxstring(n,i)%values(k) + diffOrb(z+2) = CIcore_instance%strings(i)%values(k,b) + z = z + 1 + cycle + end if + end do + if ( diffOrb(2) > 0 ) then + + !Coulomb + auxIndex = CIcore_instance%fourIndexArray(i)%values( & + CIcore_instance%twoIndexArray(i)%values(& + diffOrb(1),diffOrb(3)),& + CIcore_instance%twoIndexArray(i)%values(& + diffOrb(2),diffOrb(4)) ) + + auxCIenergy = auxCIenergy + & + CIcore_instance%fourCenterIntegrals(i,i)%values(auxIndex, 1) + + auxIndex = CIcore_instance%fourIndexArray(i)%values( & + CIcore_instance%twoIndexArray(i)%values(& + diffOrb(1),diffOrb(4)),& + CIcore_instance%twoIndexArray(i)%values(& + diffOrb(2),diffOrb(3)) ) + + auxCIenergy = auxCIenergy + & + MolecularSystem_instance%species(i)%kappa*CIcore_instance%fourCenterIntegrals(i,i)%values(auxIndex, 1) + + end if + !! different species + do j = i + 1, MolecularSystem_instance%numberOfQuantumSpecies + auxnumberOfOtherSpecieSpatialOrbitals = CIcore_instance%numberOfSpatialOrbitals2%values(j) + otherdiffOrb = 0 + a = thisA(j) + b = thisB(j) + + do k = 1, CIcore_instance%numberOfOccupiedOrbitals%values(j) + if ( CIcore_instance%auxstring(n,j)%values(k) .ne. & + CIcore_instance%strings(j)%values(k,b) ) then + otherdiffOrb(1) = CIcore_instance%auxstring(n,j)%values(k) + otherdiffOrb(3) = CIcore_instance%strings(j)%values(k,b) + exit + end if + + end do + + if ( diffOrb(3) .gt. 0 .and. otherdiffOrb(3) .gt. 0 ) then + auxIndex1 = CIcore_instance%twoIndexArray(i)%values(& + diffOrb(1),diffOrb(3) ) + auxIndex2 = CIcore_instance%twoIndexArray(j)%values(& + otherdiffOrb(1),otherdiffOrb(3) ) + auxIndex = auxnumberOfOtherSpecieSpatialOrbitals * (auxIndex1 - 1 ) + auxIndex2 + + auxCIenergy = auxCIenergy + & + CIcore_instance%fourCenterIntegrals(i,j)%values(auxIndex, 1) + + end if + end do + end do + + auxCIenergy= auxCIenergy * factor + + end function CI_Initial_calculateEnergyTwo + +end module CIInitial_ diff --git a/src/CI/CIJadamilu.f90 b/src/CI/CIJadamilu.f90 new file mode 100644 index 00000000..4da6fd01 --- /dev/null +++ b/src/CI/CIJadamilu.f90 @@ -0,0 +1,1364 @@ + module CIJadamilu_ + use Exception_ + use Matrix_ + use Vector_ + use MolecularSystem_ + use Configuration_ + use MolecularSystem_ + use String_ + use IndexMap_ + use InputCI_ + use omp_lib + use CIcore_ + +contains + + !> + !! @brief Muestra informacion del objeto + !! + !! @param this + !< + subroutine CIcore_buildCouplingMatrix() + implicit none + + integer(8) :: a,b,c1,c2 + integer :: u,v,p + integer :: i,n + integer :: auxis,auxos + integer :: numberOfSpecies + real(8) :: timeA, timeB + integer(1) :: coupling + integer(1), allocatable :: orbitalsA(:), orbitalsB(:) + integer(8), allocatable :: indexConfA(:) + integer(8), allocatable :: indexConfB(:) + integer(1), allocatable :: couplingOrder(:) + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + coupling = 0 + + !! allocate arrays + do n = 1, CIcore_instance%nproc + do i = 1, numberOfSpecies + + call Matrix_constructorInteger ( CIcore_instance%couplingMatrix(i,n), & + sum(CIcore_instance%numberOfStrings(i)%values), 3_8 , 0) + + call Matrix_constructorInteger(CIcore_instance%nCouplingOneTwo(i,n), & + 3_8, int(size(CIcore_instance%numberOfStrings(i)%values, dim=1),8), 0 ) + + call Matrix_constructorInteger(CIcore_instance%nCouplingSize(i,n), & + 3_8, int(size(CIcore_instance%numberOfStrings(i)%values, dim=1) + 1 ,8), 0 ) + + call Vector_constructor(CIcore_instance%couplingMatrixEnergyOne(i,n), & + int(sum(CIcore_instance%numberOfStrings(i)%values),4), 0.0_8 ) + + call Vector_constructorInteger(CIcore_instance%couplingMatrixFactorOne(i,n), & + int(sum(CIcore_instance%numberOfStrings(i)%values),4), 2 ) + + call Vector_constructorInteger( CIcore_instance%couplingMatrixOrbOne(i,n), & + int(sum(CIcore_instance%numberOfStrings(i)%values),4), 0 ) + + end do + end do + + end subroutine CIcore_buildCouplingMatrix + +!! Build a list with all possible combinations of number of different orbitals from all quantum species, coupling (0,1,2) + subroutine CIcore_buildCouplingOrderList() + implicit none + + integer(8) :: a,b,c,c1,c2,aa,d + integer :: u,uu,vv, p, nn,z + integer :: i + integer :: numberOfSpecies, auxnumberOfSpecies,s + integer(1), allocatable :: couplingOrder(:) + integer(1) :: coupling + real(8) :: timeA, timeB + integer :: ncouplingOrderOne + integer :: ncouplingOrderTwo + integer :: ssize + integer, allocatable :: cilevel(:) + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + + ssize = 1 + do i = 1, numberOfSpecies + ssize = ssize * 3 !! ( 0,1,2) different orbitals + end do + + allocate ( CIcore_instance%couplingOrderList( 3, ssize ) ) !! one, two same, two diff + allocate ( CIcore_instance%couplingOrderIndex( 3, ssize ) ) !! one, two same, two diff + + do a = 1, 3 + do b = 1, ssize + call Vector_constructorInteger1( CIcore_instance%couplingOrderList(a,b), & + int( numberOfSpecies,8), int(0,1) ) + + end do + end do + + !! same species + do b = 1, ssize + call Vector_constructorInteger1( CIcore_instance%couplingOrderIndex(1,b), 1_8, int(0,1) ) + call Vector_constructorInteger1( CIcore_instance%couplingOrderIndex(2,b), 1_8, int(0,1) ) + end do + + !! diff species + do b = 1, ssize + call Vector_constructorInteger1( CIcore_instance%couplingOrderIndex(3,b), 2_8, int(0,1) ) + end do + + + allocate ( couplingOrder ( numberOfSpecies )) !! 0, 1, 2 + couplingOrder = 0 + + !! call recursion + s = 0 + CIcore_instance%ncouplingOrderOne = 0 + CIcore_instance%ncouplingOrderTwo = 0 + CIcore_instance%ncouplingOrderTwoDiff = 0 + + allocate ( ciLevel ( numberOfSpecies ) ) + ciLevel = 0 + + !! get all combinations + auxnumberOfSpecies = CIcore_buildCouplingOrderRecursion( s, numberOfSpecies, couplingOrder, cilevel ) + + !! save the index for species (speciesID) just to avoid a lot of conditionals later! + + do u = 1, CIcore_instance%ncouplingOrderOne + do i = 1, numberOfSpecies + if ( CIcore_instance%couplingOrderList(1,u)%values(i) == 1 ) then + CIcore_instance%couplingOrderIndex(1,u)%values(1) = i + end if + end do + end do + + do u = 1, CIcore_instance%ncouplingOrderTwo + do i = 1, numberOfSpecies + if ( CIcore_instance%couplingOrderList(2,u)%values(i) == 2 ) then + CIcore_instance%couplingOrderIndex(2,u)%values(1) = i + end if + end do + end do + + do u = 1, CIcore_instance%ncouplingOrderTwoDiff + z = 0 + do i = 1, numberOfSpecies + if ( CIcore_instance%couplingOrderList(3,u)%values(i) == 1 ) then + z = z + 1 + CIcore_instance%couplingOrderIndex(3,u)%values(z) = i + end if + end do + end do + + + deallocate ( ciLevel ) + deallocate ( couplingOrder ) + + end subroutine CIcore_buildCouplingOrderList + + +!! Get all possible combinations of number of different orbitals from all quantum species. +recursive function CIcore_buildCouplingOrderRecursion( s, numberOfSpecies, couplingOrder, cilevel ) result (os) + implicit none + + integer(8) :: a,b,c,d + integer :: u,v + integer :: i, j, ii, jj, nn + integer :: s, numberOfSpecies + integer :: os,is,auxis, auxos + integer(1) :: couplingOrder(:) + logical :: same + integer :: cilevel(:) + + is = s + 1 + if ( is < numberOfSpecies ) then + if ( sum ( couplingOrder) <= 2 ) then + do i = 1, 3 - sum ( couplingOrder ) !! 0,1,2 + couplingOrder(is) = i-1 + couplingOrder(is+1:) = 0 + os = CIcore_buildCouplingOrderRecursion( is, numberOfSpecies, couplingOrder, cilevel ) + end do + end if + else + if ( sum ( couplingOrder) <= 2 ) then + do i = 1, 3 - sum ( couplingOrder ) !! 0,1,2 + couplingOrder(is) = i-1 + couplingOrder(is+1:) = 0 + os = is + if ( sum ( couplingOrder ) == 1 ) then + + auxis = 0 + CIcore_instance%ncouplingOrderOne = CIcore_instance%ncouplingOrderOne + 1 + b = CIcore_instance%ncouplingOrderOne + CIcore_instance%couplingOrderList(1,b)%values = couplingOrder + + else if ( sum ( couplingOrder ) == 2 ) then + + same = .false. + + do j = 1, numberOfSpecies + if ( couplingOrder(j) == 2 ) same = .true. + end do + + if ( same ) then + auxis = 0 + CIcore_instance%ncouplingOrderTwo = CIcore_instance%ncouplingOrderTwo + 1 + b = CIcore_instance%ncouplingOrderTwo + CIcore_instance%couplingOrderList(2,b)%values = couplingOrder + else + auxis = 0 + CIcore_instance%ncouplingOrderTwoDiff = CIcore_instance%ncouplingOrderTwoDiff + 1 + b = CIcore_instance%ncouplingOrderTwoDiff + CIcore_instance%couplingOrderList(3,b)%values = couplingOrder + end if + + end if + end do + end if + end if + + end function CIcore_buildCouplingOrderRecursion + + subroutine CIcore_jadamiluInterface(n, maxeig, eigenValues, eigenVectors) + implicit none + external DPJDREVCOM + integer(8) :: maxnev + real(8) :: CIenergy + integer(8) :: nproc + type(Vector8), intent(inout) :: eigenValues + type(Matrix), intent(inout) :: eigenVectors + +! N: size of the problem +! MAXEIG: max. number of wanteg eig (NEIG<=MAXEIG) +! MAXSP: max. value of MADSPACE + integer(8) :: n, maxeig, MAXSP + integer(8) :: LX + real(8), allocatable :: EIGS(:), RES(:), X(:)!, D(:) +! arguments to pass to the routines + integer(8) :: NEIG, MADSPACE, ISEARCH, NINIT + integer(8) :: JA(1), IA(1) + integer(8) :: ICNTL(5) + integer(8) :: ITER, IPRINT, INFO + real(8) :: SIGMA, TOL, GAP, MEM, DROPTOL, SHIFT + integer(8) :: NDX1, NDX2, NDX3 + integer(8) :: IJOB! some local variables + integer(8) :: auxSize + integer(4) :: size1,size2 + integer(8) :: I,J,K,ii,jj,jjj + integer(4) :: iiter + logical :: fullMatrix + + maxsp = CONTROL_instance%CI_MADSPACE + !!if ( CONTROL_instance%CI_JACOBI ) then + + LX = N*(3*MAXSP+MAXEIG+1)+4*MAXSP*MAXSP + + if ( allocated ( eigs ) ) deallocate ( eigs ) + allocate ( eigs ( maxeig ) ) + eigs = 0.0_8 + if ( allocated ( res ) ) deallocate ( res ) + allocate ( res ( maxeig ) ) + res = 0.0_8 + if ( allocated ( x ) ) deallocate ( x ) + allocate ( x ( lx ) ) + x = 0.0_8 + + +! set input variables +! the matrix is already in the required format + + IPRINT = 0 ! standard report on standard output + ISEARCH = 1 ! we want the smallest eigenvalues + NEIG = maxeig ! number of wanted eigenvalues + !NINIT = 0 ! no initial approximate eigenvectors + NINIT = NEIG ! initial approximate eigenvectors + MADSPACE = maxsp ! desired size of the search space + ITER = 1000*NEIG ! maximum number of iteration steps + TOL = CONTROL_instance%CI_CONVERGENCE !1.0d-4 ! tolerance for the eigenvector residual + + NDX1 = 0 + NDX2 = 0 + MEM = 0 + +! additional parameters set to default + ICNTL(1)=0 + ICNTL(2)=0 + ICNTL(3)=0 + ICNTL(4)=0 + ICNTL(5)=1 + + IJOB=0 + + JA(1) = -1 + IA(1) = -1 + + ! set initial eigenpairs + if ( CONTROL_instance%CI_LOAD_EIGENVECTOR ) then + print *, "Loading the eigenvector to the initial guess" + do j = 1, n + X(j) = eigenVectors%values(j,1) + end do + + do i = 1, CONTROL_instance%NUMBER_OF_CI_STATES + EIGS(i) = eigenValues%values(i) + end do + else + jj = 0 + do i = 1, CONTROL_instance%NUMBER_OF_CI_STATES + jj = (i - 1) * n + do j = 1, CONTROL_instance%CI_SIZE_OF_GUESS_MATRIX + X(jj + CIcore_instance%auxIndexCIMatrix%values(j)) = CIcore_instance%initialEigenVectors%values(j,i) + end do + end do + + do i = 1, CONTROL_instance%NUMBER_OF_CI_STATES + EIGS(i) = CIcore_instance%initialEigenValues%values(i) + end do + end if + + DROPTOL = 0 + + SIGMA = EIGS(1) + gap = 0 + SHIFT = EIGS(1) + + do i = 1, CONTROL_instance%NUMBER_OF_CI_STATES + write(6,"(T2,A5,I4,2X,A10,F20.10,2X,A11,F20.10)") "State", i, "Eigenvalue", eigs( i ), "Eigenvector", x((i-1)*n + i) + end do + + iiter = 0 + +!10 CALL DPJDREVCOM( N, A, JA, IA,EIGS, RES, X, LX, NEIG, & +! SIGMA, ISEARCH, NINIT, MADSPACE, ITER, TOL, & +! SHIFT, DROPTOL, MEM, ICNTL, & +! IJOB, NDX1, NDX2, IPRINT, INFO, GAP) +10 CALL DPJDREVCOM( N, CIcore_instance%diagonalHamiltonianMatrix%values , JA, IA, EIGS, RES, X, LX, NEIG, & + SIGMA, ISEARCH, NINIT, MADSPACE, ITER, TOL, & + SHIFT, DROPTOL, MEM, ICNTL, & + IJOB, NDX1, NDX2, IPRINT, INFO, GAP) + if (CONTROL_instance%CI_JACOBI ) then + fullMatrix = .false. + else + fullMatrix = .true. + end if +!! your private matrix-vector multiplication + + iiter = iiter +1 + IF (IJOB.EQ.1) THEN + if ( CONTROL_instance%CI_BUILD_FULL_MATRIX ) then + call av ( n, x(ndx1), x(ndx2)) + else + call matvec2 ( N, X(NDX1), X(NDX2), iiter) + end if + + GOTO 10 + END IF + + !! saving the eigenvalues + eigenValues%values = EIGS + + !! saving the eigenvectors + k = 0 + do j = 1, maxeig + do i = 1, N + k = k + 1 + eigenVectors%values(i,j) = X(k) + end do + end do + +! release internal memory and discard preconditioner + CALL PJDCLEANUP + if ( allocated ( x ) ) deallocate ( x ) + + end subroutine CIcore_jadamiluInterface + + subroutine matvec2 ( nx, v, w, iter) + + !******************************************************************************* + !! AV computes w <- A * V where A is a discretized Laplacian. + ! Parameters: + ! Input, integer NX, the length of the vectors. + ! Input, real V(NX), the vector to be operated on by A. + ! Output, real W(NX), the result of A*V. + ! + implicit none + + integer(8) nx + real(8) v(nx) + real(8) w(nx) + real(8) :: CIEnergy + integer(8) :: nonzero + integer(8) :: i, j, ia, ib, ii, jj, iii, jjj + integer(4) :: nproc, n, nn + real(8) :: wi + real(8) :: timeA, timeB + real(8) :: tol + integer(4) :: iter, size1, size2 + !integer(8), allocatable :: indexArray(:) + logical :: fullMatrix + integer :: ci + integer :: auxSize + integer(8) :: a,b,c + integer :: s, numberOfSpecies, auxnumberOfSpecies + integer(1) :: coupling + integer(8) :: numberOfConfigurations + integer(8), allocatable :: cc(:) !! ncore + integer(8), allocatable :: indexConf(:,:) !! ncore, species + integer(8), allocatable :: auxindexConf(:,:) !! ncore, species + integer, allocatable :: cilevel(:,:), auxcilevel(:,:) + + call omp_set_num_threads(omp_get_max_threads()) + nproc = omp_get_max_threads() + + + allocate( cc ( nproc ) ) + cc = 0 + + nonzero = 0 + w = 0 + tol = CONTROL_instance%CI_MATVEC_TOLERANCE + + do i = 1 , nx + if ( abs(v(i) ) >= tol) nonzero = nonzero + 1 + end do + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + + allocate ( indexConf ( numberOfSpecies, nproc ) ) + allocate ( auxindexConf ( numberOfSpecies, nproc ) ) + allocate ( cilevel ( numberOfSpecies, nproc ) ) + allocate ( auxcilevel ( numberOfSpecies, nproc ) ) + + cilevel = 0 + auxcilevel = 0 + indexConf = 0 + auxindexConf = 0 + !! call recursion + s = 0 + c = 0 + n = 1 +!$ timeA = omp_get_wtime() + do ci = 1, CIcore_instance%sizeCiOrderList + do nn = n, nproc + cilevel(:,nn) = CIcore_instance%ciOrderList( CIcore_instance%auxciOrderList(ci), :) + end do + s = 0 + auxnumberOfSpecies = CIcore_buildMatrixRecursion(nproc, s, indexConf, auxindexConf,cc, c, n, v, w, & + cilevel, auxcilevel ) + + end do + + if ( n > 1 ) then + do nn = 1, n-1 + + call CIcore_buildRow( nn, auxindexConf(:,nn), cc(nn), w, v(cc(nn)), auxcilevel(:,nn)) + end do + end if + + CIcore_instance%pindexConf = 0 + +!$ timeB = omp_get_wtime() + deallocate ( cilevel ) + deallocate ( auxindexConf ) + deallocate ( indexConf ) + deallocate ( cc ) +!$ write(*,"(A,I2,A,E10.3,A2,I12)") " ", iter, " ", timeB -timeA ," ", nonzero +! stop + return + + end subroutine matvec2 + + subroutine av ( nx, v, w) + + !******************************************************************************* + !! AV computes w <- A * V where A is a discretized Laplacian. + ! Parameters: + ! Input, integer NX, the length of the vectors. + ! Input, real V(NX), the vector to be operated on by A. + ! Output, real W(NX), the result of A*V. + ! + implicit none + + integer(8) nx + real(8) v(nx) + real(8) w(nx) + character(50) :: CIFile + integer :: CIUnit + integer, allocatable :: jj(:) + real(8), allocatable :: CIEnergy(:) + integer :: nonzero,ii, kk + integer :: maxStackSize, i, ia, ib + + CIFile = "lowdin.ci" + CIUnit = 20 + nonzero = 0 + maxStackSize = CONTROL_instance%CI_STACK_SIZE + + w = 0 +#ifdef intel + open(unit=CIUnit, file=trim(CIFile), action = "read", form="unformatted", BUFFERED="YES") +#else + open(unit=CIUnit, file=trim(CIFile), action = "read", form="unformatted") +#endif + + readmatrix : do + read (CIUnit) nonzero + if (nonzero > 0 ) then + + read (CIUnit) ii + + if ( allocated(jj)) deallocate (jj) + allocate (jj(nonzero)) + jj = 0 + + if ( allocated(CIEnergy)) deallocate (CIEnergy) + allocate (CIEnergy(nonzero)) + CIEnergy = 0 + + do i = 1, ceiling(real(nonZero) / real(maxStackSize) ) + + ib = maxStackSize * i + ia = ib - maxStackSize + 1 + if ( ib > nonZero ) ib = nonZero + read (CIUnit) jj(ia:ib) + + end do + + do i = 1, ceiling(real(nonZero) / real(maxStackSize) ) + + ib = maxStackSize * i + ia = ib - maxStackSize + 1 + if ( ib > nonZero ) ib = nonZero + read (CIUnit) CIEnergy(ia:ib) + + end do + + w(ii) = w(ii) + CIEnergy(1)*v(jj(1)) !! disk + do kk = 2, nonzero + !w(ii) = w(ii) + CIcore_calculateCIenergy(ii,jj(kk))*v(jj(kk)) !! direct + w(ii) = w(ii) + CIEnergy(kk)*v(jj(kk)) !! disk + w(jj(kk)) = w(jj(kk)) + CIEnergy(kk)*v(ii) !! disk + end do + + else if ( nonzero == -1 ) then + exit readmatrix + end if + end do readmatrix + +!! memory +! do i = 1, nx +! w(:) = w(:) + CIcore_instance%hamiltonianMatrix%values(:,i)*v(i) +! end do + + close(CIUnit) + + return + end subroutine av + +recursive function CIcore_buildMatrixRecursion(nproc, s, indexConf, auxindexConf, cc, c, n, v, w, & + cilevel, auxcilevel) result (os) + implicit none + + integer(8) :: a,c,aa + integer :: i, n, nn, nproc + integer :: s, numberOfSpecies + integer :: os,is,ss,ssize + integer(8) :: cc(:) + integer(8) :: indexConf(:,:) + integer(8) :: auxindexConf(:,:) + real(8) :: v(:) + real(8) :: w(:) + integer :: cilevel(:,:) + integer :: auxcilevel(:,:) + + is = s + 1 + !if ( is < numberOfSpecies ) then + do ss = 1, CIcore_instance%recursionVector1(is) + i = cilevel(is,n) + 1 + ssize = CIcore_instance%numberOfStrings2(is)%values(i) + + do a = 1, CIcore_instance%numberOfStrings(is)%values(i) + indexConf(is,n:) = ssize + a + os = CIcore_buildMatrixRecursion( nproc, is, indexConf, auxindexConf, cc, c, n, v, w, cilevel, auxcilevel ) + end do + end do + !else + do ss = 1, CIcore_instance%recursionVector2(is) + os = is + i = cilevel(is,n) + 1 + ssize = CIcore_instance%numberOfStrings2(is)%values(i) + + do a = 1, CIcore_instance%numberOfStrings(is)%values(i) + c = c + 1 + + if ( abs(v(c)) > CONTROL_instance%CI_MATVEC_TOLERANCE ) then + cc(n) = c + indexConf(is,n:) = ssize + a + + auxindexConf = indexConf + auxcilevel = cilevel + + if ( n == nproc ) then + + !$omp parallel & + !$omp& private(nn),& + !$omp& shared(v,w, indexConf, cc, nproc, cilevel) + !$omp do schedule (static) + do nn = 1, nproc + call CIcore_buildRow( nn, indexConf(:,nn), cc(nn), w, v(cc(nn)), cilevel(:,nn)) + end do + !$omp end do nowait + !$omp end parallel + n = 0 + + do nn = 1, nproc + indexConf(:,nn) = indexConf(:,nproc) + cilevel(:,nn) = cilevel(:,nproc) + end do + end if + + n = n + 1 + + end if + + end do + end do + !end if + + + end function CIcore_buildMatrixRecursion + + !! Alternative option to the recursion with the same computational cost... However, it may be helpul some day. + + function CIcore_buildMatrixRecursion2(nproc, s, indexConf, auxindexConf, cc, c, n, v, w, & + cilevel, auxcilevel) result (os) + implicit none + + integer(8) :: a,c,aa, x + integer :: i, j, n, nn, nproc, ci + integer :: s, numberOfSpecies + integer :: os,is,ss,ssize + integer(8) :: cc(:) + integer(8) :: indexConf(:,:) + integer(8) :: auxindexConf(:,:) + real(8) :: v(:) + real(8) :: w(:) + integer :: cilevel(:,:) + integer(8) :: totalsize, auxtotalsize + integer :: auxcilevel(:,:) + integer, allocatable :: counter(:) + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + + allocate (counter(numberOfSpecies)) + counter = 0 + + totalsize = 1 + do i = 1 , numberOfSpecies + totalsize = totalsize * CIcore_instance%numberOfStrings(i)%values(cilevel(i,n) + 1) + end do + + do i = 1 , numberOfSpecies + ci = cilevel(i,n) + 1 + ssize = CIcore_instance%numberOfStrings2(i)%values(ci) + indexConf(i,n:) = ssize + 1 + end do + + indexConf(numberOfSpecies,n:) = indexConf(numberOfSpecies,n:) -1 + + do x = 1, totalsize + + indexConf(numberOfSpecies,n:) = indexConf(numberOfSpecies,n:) + 1 + + do i = numberOfSpecies, 1 + 1, -1 + auxtotalsize = 1 + do j = i, numberOfSpecies + auxtotalsize = auxtotalsize * CIcore_instance%numberOfStrings(j)%values(cilevel(j,n) + 1) + end do + if (counter(i) == auxtotalsize) then + do j = i, numberOfSpecies + ci = cilevel(j,n) + 1 + ssize = CIcore_instance%numberOfStrings2(j)%values(ci) + indexConf(j,n:) = ssize + 1 + end do + counter(i) = 0 + indexConf(i-1,n:) = indexConf(i-1,n:) + 1 + end if + counter(i) = counter(i) + 1 + + end do + !print *, indexConf(:,1) + end do + + deallocate (counter) + + end function CIcore_buildMatrixRecursion2 + + subroutine CIcore_buildRow( nn, indexConfA, c, w, vc, cilevelA) + implicit none + + integer(8) :: a,b,c,bb,ci,d,cj + integer :: u,v,uu,vv, p, nn + integer :: i, j, auxis,auxos,is, ii, aa + integer :: numberOfSpecies, s + integer, allocatable :: stringAinB(:) + integer(4) :: coupling + integer(4) :: ssize,auxcoupling(3) !! 0,1,2 + integer(8) :: indexConfA(:) + integer(8), allocatable :: indexConfB(:) + integer(8), allocatable :: dd(:) + real(8) :: vc, CIenergy + real(8) :: w(:) + integer :: cilevelA(:) + integer, allocatable :: cilevel(:) + + + !CIcore_instance%pindexConf = 0 + + !!$ CIcore_instance%timeA(1) = omp_get_wtime() + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + + do i = 1, numberOfSpecies + + if ( CIcore_instance%pindexConf(i,nn) /= indexConfA(i) ) then + + CIcore_instance%nCouplingOneTwo(i,nn)%values = 0 + auxcoupling = 0 + + !allocate (stringBinA (CIcore_instance%numberOfOccupiedOrbitals%values(i) )) + allocate (stringAinB (CIcore_instance%numberOfOccupiedOrbitals%values(i) )) + + stringAinB = 0 + !stringBinA = 0 + + a = indexConfA(i) + + !!$ CIcore_instance%timeA(2) = omp_get_wtime() + + ssize = 0 + do ci = 1, size(CIcore_instance%numberOfStrings(i)%values, dim = 1) + do b = 1 + ssize , CIcore_instance%numberOfStrings(i)%values(ci) + ssize + + !b = ssize + bb + do p = CIcore_instance%numberOfCoreOrbitals%values(i)+1, & + CIcore_instance%numberOfOccupiedOrbitals%values(i) + !do p = 1, & + ! CIcore_instance%numberOfOccupiedOrbitals%values(i) + + stringAinB(p) = CIcore_instance%orbitals(i)%values( & + CIcore_instance%strings(i)%values(p,a),b) + + !stringBinA(p) = CIcore_instance%orbitals(i)%values( & + ! CIcore_instance%strings(i)%values(p,b),a) + end do + + coupling = CIcore_instance%numberOfOccupiedOrbitals%values(i) - sum ( stringAinB ) - & + CIcore_instance%numberOfCoreOrbitals%values(i) + + ! coupling = CIcore_instance%numberOfOccupiedOrbitals%values(i) - sum ( stringAinB ) + + if ( coupling <= 2 ) then + + coupling = coupling + 1 + + auxcoupling(coupling) = auxcoupling(coupling) + 1 + + CIcore_instance%nCouplingOneTwo(i,nn)%values( coupling, ci) = & + CIcore_instance%nCouplingOneTwo(i,nn)%values( coupling, ci) + 1 + + CIcore_instance%couplingMatrix(i,nn)%values( auxcoupling(coupling), coupling ) = b + end if + + end do + + ssize = ssize + CIcore_instance%numberOfStrings(i)%values(ci) + + end do + + deallocate (stringAinB) + !deallocate (stringBinA) + end if + + end do + + !!$ CIcore_instance%timeB(1) = omp_get_wtime() + + do is = 1, numberOfSpecies + do i = 1, 3 !! 0,1,2 + ssize = 0 + do ci = 1, size(CIcore_instance%numberOfStrings(is)%values, dim = 1) !! 1 is always zero + ssize = ssize + CIcore_instance%nCouplingOneTwo(is,nn)%values( i,ci ) + CIcore_instance%nCouplingSize(is,nn)%values( i,ci+1 ) = ssize + end do + CIcore_instance%nCouplingSize(is,nn)%values( i,1 ) = 0 !0? + end do + end do + + + !!$ CIcore_instance%timeA(2) = omp_get_wtime() + allocate ( indexConfB ( numberOfSpecies ) ) + allocate ( cilevel ( numberOfSpecies ) ) + allocate ( dd ( numberOfSpecies ) ) + indexConfB = 0 + + !!$ CIcore_instance%timeB(2) = omp_get_wtime() + !!$ CIcore_instance%timeA(3) = omp_get_wtime() + + !!one diff same species + do i = 1, numberOfSpecies + + if ( CIcore_instance%pindexConf(i,nn) /= indexConfA(i) ) then + cilevel(:) = 0 + indexConfB = indexConfA + + cilevel = cilevelA + + do ci = 1, size(CIcore_instance%numberOfStrings(i)%values, dim = 1) !! 1 is always zero + cilevel(i) = ci - 1 + + auxos = CIcore_buildRowRecursionFirstOne( i, indexConfA, indexConfB, nn, cilevel ) + + end do + end if + end do + + !!$ CIcore_instance%timeB(3) = omp_get_wtime() + + !!$ CIcore_instance%timeA(4) = omp_get_wtime() + + !$omp atomic + w(c) = w(c) + vc*CIcore_instance%diagonalHamiltonianMatrix%values(c) + !$omp end atomic + + !!$ CIcore_instance%timeB(4) = omp_get_wtime() + + !!$ CIcore_instance%timeA(5) = omp_get_wtime() + !! one diff + do i = 1, numberOfSpecies + cilevel(:) = 0 + indexConfB = indexConfA + + cilevel = cilevelA + + do ci = 1, size(CIcore_instance%numberOfStrings(i)%values, dim = 1) !! 1 is always zero + cilevel(i) = ci - 1 + + do u = 1, CIcore_instance%sizeciorderlist + if ( sum(abs(cilevel - & + CIcore_instance%ciorderlist( CIcore_instance%auxciorderlist(u), :))) == 0 ) then + + uu = CIcore_instance%auxciorderlist(u) + dd = 0 + + auxos = CIcore_buildRowRecursionSecondOne( i, indexConfB, w, vc, dd, nn, cilevel, uu ) + exit + + end if + end do + end do + end do + + !!$ CIcore_instance%timeB(5) = omp_get_wtime() + !!$ CIcore_instance%timeA(6) = omp_get_wtime() + + !! two diff same species + do i = 1, numberOfSpecies + + cilevel(:) = 0 + indexConfB = indexConfA + cilevel = cilevelA + + do ci = 1, size(CIcore_instance%numberOfStrings(i)%values, dim = 1) !! 1 is always zero + cilevel(i) = ci - 1 + + do u = 1, CIcore_instance%sizeCiOrderList + if ( sum(abs(cilevel - & + CIcore_instance%ciOrderList( CIcore_instance%auxciOrderList(u), :))) == 0 ) then + uu = CIcore_instance%auxciOrderList(u) + dd = 0 + + if ( CIcore_instance%pindexConf(i,nn) /= indexConfA(i) ) then + auxos = CIcore_buildRowRecursionSecondTwoCal( i, indexConfA, indexConfB, w, vc, dd, nn, cilevel, uu ) + else + auxos = CIcore_buildRowRecursionSecondTwoGet( i, indexConfA, indexConfB, w, vc, dd, nn, cilevel, uu ) + end if + + exit + + end if + end do + end do + end do + + !!$ CIcore_instance%timeB(6) = omp_get_wtime() + !!$ CIcore_instance%timeA(7) = omp_get_wtime() + + !! two diff diff species + do v = 1, CIcore_instance%ncouplingOrderTwoDiff + + i = CIcore_instance%couplingOrderIndex(3,v)%values(1) + j = CIcore_instance%couplingOrderIndex(3,v)%values(2) + + indexConfB = indexConfA + cilevel = cilevelA + + do ci = 1, size(CIcore_instance%numberOfStrings(i)%values, dim = 1) !! 1 is always zero + cilevel(i) = ci - 1 + do cj = 1, size(CIcore_instance%numberOfStrings(j)%values, dim = 1) !! 1 is always zero + cilevel(j) = cj - 1 + do u = 1, CIcore_instance%sizeCiOrderList + if ( sum(abs(cilevel - & + CIcore_instance%ciOrderList( CIcore_instance%auxciOrderList(u), :))) == 0 ) then + + uu = CIcore_instance%auxciOrderList(u) + dd = 0 + auxos = CIcore_buildRowRecursionSecondTwoDiff( i, j, indexConfB, w, vc, dd, nn, cilevel, uu ) + exit + end if + end do + end do + end do + end do + + !!$ CIcore_instance%timeB(7) = omp_get_wtime() + + !!$ print *, "omptime" + !!$ print *, "1", CIcore_instance%timeB(1) - CIcore_instance%timeA(1) + !!$ print *, "2", CIcore_instance%timeB(2) - CIcore_instance%timeA(2) + !!$ print *, "3", CIcore_instance%timeB(3) - CIcore_instance%timeA(3) + !!$ print *, "4", CIcore_instance%timeB(4) - CIcore_instance%timeA(4) + !!$ print *, "5", CIcore_instance%timeB(5) - CIcore_instance%timeA(5) + !!$ print *, "6", CIcore_instance%timeB(6) - CIcore_instance%timeA(6) + !!$ print *, "7", CIcore_instance%timeB(7) - CIcore_instance%timeA(7) + + CIcore_instance%pindexConf(:,nn) = indexConfA(:) + + deallocate ( dd ) + deallocate ( cilevel ) + deallocate ( indexConfB ) + + end subroutine CIcore_buildRow + +recursive function CIcore_buildRowRecursionFirstOne( ii, indexConfA, indexConfB, nn, cilevel ) result (os) + implicit none + + integer(8) :: a, aa + integer :: ii, nn, ci + integer :: os, ssize + integer(8) :: indexConfA(:) + integer(8) :: indexConfB(:) + real(8) :: CIenergy + integer :: cilevel(:) + + ci = cilevel(ii) + 1 + ssize = CIcore_instance%nCouplingSize(ii,nn)%values( 2,ci ) + do aa = 1, CIcore_instance%nCouplingOneTwo(ii,nn)%values( 2,ci ) + a = ssize + aa + + indexConfB(ii) = CIcore_instance%couplingMatrix(ii,nn)%values(a, 2) + CIenergy = CIcore_calculateEnergyOneSame ( nn, ii, indexConfA, indexConfB ) + CIcore_instance%couplingMatrixEnergyOne(ii,nn)%values(indexConfB(ii)) = CIenergy + + end do + + end function CIcore_buildRowRecursionFirstOne + +recursive function CIcore_buildRowRecursionSecondOne( ii, indexConfB, w, vc, dd, nn, cilevel, u ) result (os) + implicit none + + integer(8) :: a,d, aa + integer :: ii, nn, ci, u, j + integer :: ssize + integer :: os,numberOfSpecies + integer(8) :: indexConfB(:) + integer(8) :: dd(:) + real(8) :: vc + real(8) :: w(:) + real(8) :: CIenergy + integer :: cilevel(:) + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + ci = cilevel(ii) + 1 + ssize = CIcore_instance%nCouplingSize(ii,nn)%values( 2,ci ) + + do j = 1, numberOfSpecies + dd(j) = (indexConfB(j) - CIcore_instance%numberOfStrings2(j)%values(cilevel(j)+1) + & + CIcore_instance%ciOrderSize1(u,j) )* CIcore_instance%ciOrderSize2(u,j) + end do + + do aa = 1, CIcore_instance%nCouplingOneTwo(ii,nn)%values( 2,ci ) + a = ssize + aa + + indexConfB(ii) = CIcore_instance%couplingMatrix(ii,nn)%values(a, 2) + + dd(ii) = (indexConfB(ii) - CIcore_instance%numberOfStrings2(ii)%values(ci) + & + CIcore_instance%ciOrderSize1(u,ii) )* CIcore_instance%ciOrderSize2(u,ii) + + d = sum(dd) + + CIenergy = CIcore_instance%couplingMatrixEnergyOne(ii,nn)%values(indexConfB(ii)) + CIenergy = CIenergy + CIcore_calculateEnergyOneDiff ( ii, indexConfB, nn ) + CIenergy = vc*CIenergy + + !$omp atomic + w(d) = w(d) + CIenergy + !$omp end atomic + end do + + end function CIcore_buildRowRecursionSecondOne + + + function CIcore_buildRowRecursionSecondTwoCal( ii, indexConfA, indexConfB, w, vc, dd, nn, cilevel, u ) result (os) + implicit none + + integer(8) :: a,d, aa + integer :: i, ii, nn, ci, u, j + integer :: s, ssize + integer :: os,numberOfSpecies + integer(8) :: indexConfA(:) + integer(8) :: indexConfB(:) + integer(8) :: dd(:) + real(8) :: vc + real(8) :: w(:) + real(8) :: CIenergy + integer :: cilevel(:) + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + ci = cilevel(ii) + 1 + ssize = CIcore_instance%nCouplingSize(ii,nn)%values( 3,ci ) + + do j = 1, numberOfSpecies + dd(j) = (indexConfB(j) - CIcore_instance%numberOfStrings2(j)%values(cilevel(j)+1) + & + CIcore_instance%ciOrderSize1(u,j) )* CIcore_instance%ciOrderSize2(u,j) + end do + + do aa = 1, CIcore_instance%nCouplingOneTwo(ii,nn)%values( 3,ci ) + a = ssize + aa + + indexConfB(ii) = CIcore_instance%couplingMatrix(ii,nn)%values(a, 3) + dd(ii) = (indexConfB(ii) - CIcore_instance%numberOfStrings2(ii)%values(ci) + & + CIcore_instance%ciOrderSize1(u,ii) )* CIcore_instance%ciOrderSize2(u,ii) + + d = sum(dd) + + !CIenergy = CIcore_instance%couplingMatrixEnergyOne(ii,nn)%values(indexConfB(ii)) + CIenergy = CIcore_calculateEnergyTwoSame ( ii, indexConfA(ii), indexConfB(ii) ) + CIcore_instance%couplingMatrixEnergyOne(ii,nn)%values(indexConfB(ii)) = CIenergy + CIenergy = vc*CIenergy + + !$omp atomic + w(d) = w(d) + CIenergy + !$omp end atomic + end do + + end function CIcore_buildRowRecursionSecondTwoCal + + function CIcore_buildRowRecursionSecondTwoGet( ii, indexConfA, indexConfB, w, vc, dd, nn, cilevel, u ) result (os) + implicit none + + integer(8) :: a,d, aa + integer :: i, ii, nn, ci, u, j + integer :: s, ssize + integer :: os,numberOfSpecies + integer(8) :: indexConfA(:) + integer(8) :: indexConfB(:) + integer(8) :: dd(:) + real(8) :: vc + real(8) :: w(:) + real(8) :: CIenergy + integer :: cilevel(:) + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + ci = cilevel(ii) + 1 + ssize = CIcore_instance%nCouplingSize(ii,nn)%values( 3,ci ) + + do j = 1, numberOfSpecies + dd(j) = (indexConfB(j) - CIcore_instance%numberOfStrings2(j)%values(cilevel(j)+1) + & + CIcore_instance%ciOrderSize1(u,j) )* CIcore_instance%ciOrderSize2(u,j) + end do + + do aa = 1, CIcore_instance%nCouplingOneTwo(ii,nn)%values( 3,ci ) + a = ssize + aa + + indexConfB(ii) = CIcore_instance%couplingMatrix(ii,nn)%values(a, 3) + dd(ii) = (indexConfB(ii) - CIcore_instance%numberOfStrings2(ii)%values(ci) + & + CIcore_instance%ciOrderSize1(u,ii) )* CIcore_instance%ciOrderSize2(u,ii) + + d = sum(dd) + + CIenergy = CIcore_instance%couplingMatrixEnergyOne(ii,nn)%values(indexConfB(ii)) + !CIenergy = CIcore_calculateEnergyTwoSame ( ii, indexConfA(ii), indexConfB(ii) ) + CIenergy = vc*CIenergy + + !$omp atomic + w(d) = w(d) + CIenergy + !$omp end atomic + end do + + end function CIcore_buildRowRecursionSecondTwoGet + + function CIcore_buildRowRecursionSecondTwoDiff( ii, jj, indexConfB, w, vc, dd, nn, cilevel, u ) result (os) + implicit none + + integer(8) :: ai,aj,d, aai, aaj + integer :: ii, nn, ci, u, k, jj, cj + integer :: ssizei, ssizej + integer :: bi, bj, factor, factori + integer :: auxIndex1, auxIndex2, auxIndex + integer :: os,numberOfSpecies + integer(8) :: indexConfB(:) + integer(8) :: dd(:) + real(8) :: vc + real(8) :: w(:) + real(8) :: CIenergy + integer :: cilevel(:) + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + ci = cilevel(ii) + 1 + cj = cilevel(jj) + 1 + ssizei = CIcore_instance%nCouplingSize(ii,nn)%values( 2,ci ) + ssizej = CIcore_instance%nCouplingSize(jj,nn)%values( 2,cj ) + + do k = 1, numberOfSpecies + dd(k) = (indexConfB(k) - CIcore_instance%numberOfStrings2(k)%values(cilevel(k)+1) + & + CIcore_instance%ciOrderSize1(u,k) )* CIcore_instance%ciOrderSize2(u,k) + end do + + do aai = 1, CIcore_instance%nCouplingOneTwo(ii,nn)%values( 2,ci ) + ai = ssizei + aai + indexConfB(ii) = CIcore_instance%couplingMatrix(ii,nn)%values(ai, 2) + dd(ii) = (indexConfB(ii) - CIcore_instance%numberOfStrings2(ii)%values(ci) + & + CIcore_instance%ciOrderSize1(u,ii) )* CIcore_instance%ciOrderSize2(u,ii) + + bi = indexConfB(ii) + factori = CIcore_instance%couplingMatrixFactorOne(ii,nn)%values(bi) + auxIndex1 = CIcore_instance%couplingMatrixOrbOne(ii,nn)%values(bi) + auxIndex1 = CIcore_instance%numberOfSpatialOrbitals2%values(jj) * (auxIndex1 - 1 ) + + do aaj = 1, CIcore_instance%nCouplingOneTwo(jj,nn)%values( 2,cj ) + aj = ssizej + aaj + indexConfB(jj) = CIcore_instance%couplingMatrix(jj,nn)%values(aj, 2) + + dd(jj) = (indexConfB(jj) - CIcore_instance%numberOfStrings2(jj)%values(cj) + & + CIcore_instance%ciOrderSize1(u,jj) )* CIcore_instance%ciOrderSize2(u,jj) + + d = sum(dd) + !CIenergy = vc*CIcore_calculateEnergyTwoDiff ( ii, jj, indexConfB, nn ) + + bj = indexConfB(jj) + factor = factori * CIcore_instance%couplingMatrixFactorOne(jj,nn)%values(bj) + auxIndex2 = CIcore_instance%couplingMatrixOrbOne(jj,nn)%values(bj) + auxIndex = auxIndex1 + auxIndex2 + + CIenergy = vc * factor *CIcore_instance%fourCenterIntegrals(ii,jj)%values(auxIndex, 1) + !CIenergy = vc*CIenergy + + !$omp atomic + w(d) = w(d) + CIenergy + !$omp end atomic + end do + end do + + end function CIcore_buildRowRecursionSecondTwoDiff + + + function CIcore_calculateEnergyOneSame( n, ii, thisA, thisB ) result (auxCIenergy) + implicit none + integer(8) :: thisA(:), thisB(:) + integer(8) :: a, b + integer :: i,j,s,n, nn,ii + integer :: l,k,z,kk,ll + integer :: factor, factor2, auxOcc, AA, BB + logical(1) :: equalA, equalB + integer :: auxnumberOfOtherSpecieSpatialOrbitals + integer(8) :: auxIndex1, auxIndex2, auxIndex + integer :: diffOrb(2), otherdiffOrb(2) !! to avoid confusions + real(8) :: auxCIenergy + + auxCIenergy = 0.0_8 + factor = 1 + + !! copy a + a = thisA(ii) + b = thisB(ii) + + diffOrb = 0 + + do kk = 1, CIcore_instance%occupationNumber(ii) + if ( CIcore_instance%orbitals(ii)%values( & + CIcore_instance%strings(ii)%values(kk,a),b) == 0 ) then + diffOrb(1) = CIcore_instance%strings(ii)%values(kk,a) + AA = kk + exit + end if + end do + + do kk = 1, CIcore_instance%occupationNumber(ii) + if ( CIcore_instance%orbitals(ii)%values( & + CIcore_instance%strings(ii)%values(kk,b),a) == 0 ) then + diffOrb(2) = CIcore_instance%strings(ii)%values(kk,b) + BB = kk + exit + end if + end do + + factor = (-1)**(AA-BB) + + CIcore_instance%couplingMatrixFactorOne(ii,n)%values(b) = factor + + !One particle terms + + auxCIenergy= auxCIenergy + CIcore_instance%twoCenterIntegrals(ii)%values( diffOrb(1), diffOrb(2) ) + + !! save the different orbitals + + auxIndex1= CIcore_instance%twoIndexArray(ii)%values( diffOrb(1), diffOrb(2)) + CIcore_instance%couplingMatrixOrbOne(ii,n)%values(b) = auxIndex1 + + do ll=1, CIcore_instance%occupationNumber( ii ) !! the same orbitals pair are excluded by the exchange + + l = CIcore_instance%strings(ii)%values(ll,b) !! or a + + auxIndex2 = CIcore_instance%twoIndexArray(ii)%values( l,l) + auxIndex = CIcore_instance%fourIndexArray(ii)%values( auxIndex1, auxIndex2 ) + + auxCIenergy = auxCIenergy + CIcore_instance%fourCenterIntegrals(ii,ii)%values(auxIndex, 1) + + auxIndex = CIcore_instance%fourIndexArray(ii)%values( & + CIcore_instance%twoIndexArray(ii)%values(diffOrb(1),l), & + CIcore_instance%twoIndexArray(ii)%values(l,diffOrb(2)) ) + + auxCIenergy = auxCIenergy + & + MolecularSystem_instance%species(ii)%kappa*CIcore_instance%fourCenterIntegrals(ii,ii)%values(auxIndex, 1) + + end do + + !end if + + auxCIenergy= auxCIenergy * factor + + end function CIcore_calculateEnergyOneSame + + function CIcore_calculateEnergyOneDiff( ii, thisB, nn ) result (auxCIenergy) + implicit none + integer(8) :: thisB(:) + integer(8) :: b + integer :: i,j,ii, nn + integer :: l,ll + integer :: factor + integer :: auxnumberOfOtherSpecieSpatialOrbitals + integer :: auxIndex1, auxIndex11, auxIndex + real(8) :: auxCIenergy + + auxCIenergy = 0.0_8 + + b = thisB(ii) + + auxIndex1 = CIcore_instance%couplingMatrixOrbOne(ii,nn)%values(b) + factor = CIcore_instance%couplingMatrixFactorOne(ii,nn)%values(b) + + do j=1, ii - 1 !! avoid ii, same species + + b = thisB(j) + + auxnumberOfOtherSpecieSpatialOrbitals = CIcore_instance%numberOfSpatialOrbitals2%values(j) + auxIndex11 = auxnumberOfOtherSpecieSpatialOrbitals * (auxIndex1 - 1 ) + + do ll=1, CIcore_instance%occupationNumber( j ) + + l = CIcore_instance%strings(j)%values(ll,b) + + auxIndex = auxIndex11 + CIcore_instance%twoIndexArray(j)%values( l,l) + + auxCIenergy = auxCIenergy + & + CIcore_instance%fourCenterIntegrals(ii,j)%values(auxIndex, 1) + + end do + + end do + + do j= ii + 1, MolecularSystem_instance%numberOfQuantumSpecies!! avoid ii, same species + + b = thisB(j) + + auxnumberOfOtherSpecieSpatialOrbitals = CIcore_instance%numberOfSpatialOrbitals2%values(j) + + auxIndex11 = auxnumberOfOtherSpecieSpatialOrbitals * (auxIndex1 - 1 ) + + do ll=1, CIcore_instance%occupationNumber( j ) + + l = CIcore_instance%strings(j)%values(ll,b) + + auxIndex = auxIndex11 + CIcore_instance%twoIndexArray(j)%values( l,l) + + auxCIenergy = auxCIenergy + & + CIcore_instance%fourCenterIntegrals(ii,j)%values(auxIndex, 1) + end do + + end do + + auxCIenergy= auxCIenergy * factor + + end function CIcore_calculateEnergyOneDiff + + + function CIcore_calculateEnergyTwoSame( ii, a, b ) result (auxCIenergy) + implicit none + integer(8) :: a, b + integer :: ii + integer :: kk,z + integer :: factor, AA(2), BB(2) + integer(8) :: auxIndex + integer :: diffOrbA(2), diffOrbB(2) !! to avoid confusions + real(8) :: auxCIenergy + + !diffOrbA = 0 + !diffOrbB = 0 + z = 0 + + do kk = 1, CIcore_instance%occupationNumber(ii) + if ( CIcore_instance%orbitals(ii)%values( & + CIcore_instance%strings(ii)%values(kk,a),b) == 0 ) then + z = z + 1 + diffOrbA(z) = CIcore_instance%strings(ii)%values(kk,a) + AA(z) = kk + if ( z == 2 ) exit + end if + end do + + z = 0 + do kk = 1, CIcore_instance%occupationNumber(ii) + if ( CIcore_instance%orbitals(ii)%values( & + CIcore_instance%strings(ii)%values(kk,b),a) == 0 ) then + z = z + 1 + diffOrbB(z) = CIcore_instance%strings(ii)%values(kk,b) + BB(z) = kk + if ( z == 2 ) exit + end if + end do + + factor = (-1)**(AA(1)-BB(1) + AA(2) - BB(2) ) + auxIndex = CIcore_instance%fourIndexArray(ii)%values( & + CIcore_instance%twoIndexArray(ii)%values(& + diffOrbA(1),diffOrbB(1)),& + CIcore_instance%twoIndexArray(ii)%values(& + diffOrbA(2),diffOrbB(2)) ) + + auxCIenergy = CIcore_instance%fourCenterIntegrals(ii,ii)%values(auxIndex, 1) + + auxIndex = CIcore_instance%fourIndexArray(ii)%values( & + CIcore_instance%twoIndexArray(ii)%values(& + diffOrbA(1),diffOrbB(2)),& + CIcore_instance%twoIndexArray(ii)%values(& + diffOrbA(2),diffOrbB(1)) ) + auxCIenergy = auxCIenergy + & + MolecularSystem_instance%species(ii)%kappa*CIcore_instance%fourCenterIntegrals(ii,ii)%values(auxIndex, 1) + + auxCIenergy= auxCIenergy * factor + + end function CIcore_calculateEnergyTwoSame + +end module CIJadamilu_ diff --git a/src/CI/CIOrder.f90 b/src/CI/CIOrder.f90 new file mode 100644 index 00000000..b0fc84d0 --- /dev/null +++ b/src/CI/CIOrder.f90 @@ -0,0 +1,354 @@ +module CIOrder_ + use Exception_ + use Matrix_ + use Vector_ + use MolecularSystem_ + use Configuration_ + use MolecularSystem_ + use String_ + use IndexMap_ + use InputCI_ + use omp_lib + use CIcore_ + +contains + + !> + !! @brief Muestra informacion del objeto + !! + !! @param this + !< + subroutine CIcore_settingCILevel() + implicit none + + integer :: numberOfSpecies + integer :: i,ii,j,k,l,m,n,p,q,a,b,d,r,s + integer(8) :: c, cc + integer :: ma,mb,mc,md,me,pa,pb,pc,pd,pe + integer :: isLambdaEqual1 + type(ivector) :: order + type(vector), allocatable :: occupiedCode(:) + type(vector), allocatable :: unoccupiedCode(:) + integer, allocatable :: auxArray(:,:), auxvector(:),auxvectorA(:) + integer :: lambda, otherlambda + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + + if ( allocated( occupiedCode ) ) deallocate( occupiedCode ) + allocate (occupiedCode ( numberOfSpecies ) ) + if ( allocated( unoccupiedCode ) ) deallocate( unoccupiedCode ) + allocate (unoccupiedCode ( numberOfSpecies ) ) + + !1 auxiliary string for omp paralelization + do n = 1, CIcore_instance%nproc + do i = 1, numberOfSpecies + call Vector_constructorInteger( CIcore_instance%auxstring(n,i), & + int(CIcore_instance%numberOfOccupiedOrbitals%values(i),4), int(0,4)) + end do + end do + + select case ( trim(CIcore_instance%level) ) + + case ( "FCI" ) + + do i=1, numberOfSpecies + CIcore_instance%CILevel(i) = CIcore_instance%numberOfOccupiedOrbitals%values(i) + end do + + CIcore_instance%maxCILevel = sum(CIcore_instance%CILevel) + + case ( "CIS" ) + + do i=1, numberOfSpecies + CIcore_instance%CILevel(i) = 1 + end do + CIcore_instance%maxCILevel = 1 + + case ( "CISD" ) + + do i=1, numberOfSpecies + CIcore_instance%CILevel(i) = 2 + if ( CIcore_instance%numberOfOccupiedOrbitals%values(i) < 2 ) & + CIcore_instance%CILevel(i) = CIcore_instance%numberOfOccupiedOrbitals%values(i) + end do + CIcore_instance%maxCILevel = 2 + + case ( "CISD+" ) + + if ( .not. numberOfSpecies == 3 ) call CIcore_exception( ERROR, "CIOrder setting CI level ", "CISD+ is specific for three quantum species") + + do i=1, numberOfSpecies + CIcore_instance%CILevel(i) = 2 + if ( CIcore_instance%numberOfOccupiedOrbitals%values(i) < 2 ) & + CIcore_instance%CILevel(i) = CIcore_instance%numberOfOccupiedOrbitals%values(i) + end do + CIcore_instance%maxCILevel = 2 + + case ( "CISD+2" ) + + if ( .not. numberOfSpecies == 4 ) call CIcore_exception( ERROR, "CIOrder setting CI level", "CISD+2 is specific for three quantum species") + do i=1, numberOfSpecies + CIcore_instance%CILevel(i) = 2 + if ( CIcore_instance%numberOfOccupiedOrbitals%values(i) < 2 ) & + CIcore_instance%CILevel(i) = CIcore_instance%numberOfOccupiedOrbitals%values(i) + end do + CIcore_instance%maxCILevel = 2 + + case ("CISDT") + + do i=1, numberOfSpecies + CIcore_instance%CILevel(i) = 3 + if ( CIcore_instance%numberOfOccupiedOrbitals%values(i) < 3 ) & + CIcore_instance%CILevel(i) = CIcore_instance%numberOfOccupiedOrbitals%values(i) + end do + CIcore_instance%maxCILevel = 3 + + case ("CISDTQ") + + do i=1, numberOfSpecies + CIcore_instance%CILevel(i) = 4 + if ( CIcore_instance%numberOfOccupiedOrbitals%values(i) < 4 ) & + CIcore_instance%CILevel(i) = CIcore_instance%numberOfOccupiedOrbitals%values(i) + end do + CIcore_instance%maxCILevel = 4 + + case ("CISDTQQ") + + do i=1, numberOfSpecies + CIcore_instance%CILevel(i) = 5 + if ( CIcore_instance%numberOfOccupiedOrbitals%values(i) < 5 ) & + CIcore_instance%CILevel(i) = CIcore_instance%numberOfOccupiedOrbitals%values(i) + end do + CIcore_instance%maxCILevel = 5 + + case default + + call CIcore_exception( ERROR, "Configuration interactor constructor", "Correction level not implemented") + + end select + + + end subroutine CIcore_settingCILevel + + + + +!! Build the CI table with all combinations of excitations between quantum species. + subroutine CIcore_buildCIOrderList() + implicit none + + integer :: c + integer :: i,j, u,v + integer :: ci, ii, jj + integer(8) :: output, auxsize + integer :: numberOfSpecies, auxnumberOfSpecies,s + integer(1) :: coupling + real(8) :: timeA, timeB + integer :: ncouplingOrderOne + integer :: ncouplingOrderTwo + logical :: includecilevel, same + integer(8) :: ssize, auxssize + integer, allocatable :: cilevel(:), auxcilevel(:) + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + + !! Allocate size considering all possible combinations, FCI. + ssize = 1 + do i = 1, numberOfSpecies + ssize = ssize * (CIcore_instance%CILevel(i) + 1) + end do + + allocate ( CIcore_instance%ciOrderList( ssize, numberOfSpecies ) ) + allocate ( CIcore_instance%ciOrderSize1( ssize, numberOfSpecies ) ) + allocate ( CIcore_instance%ciOrderSize2( ssize, numberOfSpecies ) ) + allocate ( CIcore_instance%auxciOrderList( ssize ) ) + + CIcore_instance%ciOrderList = 0 + CIcore_instance%auxciOrderList = 0 + + CIcore_instance%ciOrderSize1 = -1 !! I have reasons... -1 for all species except the last one + CIcore_instance%ciOrderSize2 = 1 !! and 1 for the last species + + CIcore_instance%sizeCiOrderList = 0 + + allocate ( ciLevel ( numberOfSpecies ) ) + allocate ( auxciLevel ( numberOfSpecies ) ) + ciLevel = 0 + auxciLevel = 0 + s = 0 + c = 0 + !! Search which combinations of excitations satifies the desired CI level. + auxnumberOfSpecies = CIcore_buildCIOrderRecursion( s, numberOfSpecies, c, cilevel ) + + + !! Print list + write (6,"(T2,A)") "--------------------------" + write (6,"(T2,A)") "CI level \ Species" + write (6,"(T2,A)") "--------------------------" + do u = 1, CIcore_instance%sizeCiOrderList + do i = 1, numberOfSpecies + write (6,"(T2,I4)",advance="no") CIcore_instance%ciOrderList( CIcore_instance%auxciOrderList(u), i) + end do + write (6,"(A)") "" + end do + write (6,"(T2,A)") "--------------------------" + + !! Calculates the three required factors in order to get the position of any given configuration. + !! position = S1 + (indexConf(i,u) - numberOfStrings2(i) -1 )*S2(i,u) + !! i: speciesID, u: cilevelID + + !! Factor S1 + ssize = 0 + do u = 1, CIcore_instance%sizeCiOrderList + + cilevel(:) = CIcore_instance%ciOrderList( CIcore_instance%auxciOrderList(u), :) + + ssize = 0 + do v = 1, u-1 + + auxcilevel(:) = CIcore_instance%ciOrderList( CIcore_instance%auxciOrderList(v), :) + auxnumberOfSpecies = CIcore_getIndexSize(0, ssize, auxcilevel) + + end do + + CIcore_instance%ciOrderSize1(CIcore_instance%auxciOrderList(u),:) = -1 + CIcore_instance%ciOrderSize1(CIcore_instance%auxciOrderList(u),numberOfSpecies) = ssize !!just the last + + end do + + !! Factor S2 + do i = 1, numberOfSpecies-1 + do u = 1, CIcore_instance%sizeCiOrderList + + cilevel(:) = CIcore_instance%ciOrderList( CIcore_instance%auxciOrderList(u), :) + ssize = 1 + do j = i+1, numberOfSpecies + ssize = ssize * CIcore_instance%numberOfStrings(j)%values(cilevel(j)+1) + end do + + CIcore_instance%ciOrderSize2(CIcore_instance%auxciOrderList(u),i) = ssize + + end do + end do + + CIcore_instance%ciOrderSize2(:,numberOfSpecies) = 1 + + deallocate ( auxcilevel ) + deallocate ( cilevel ) + + end subroutine CIcore_buildCIOrderList + + !! Search which combinations of excitations satifies the desired CI level. +recursive function CIcore_buildCIOrderRecursion( s, numberOfSpecies, c, cilevel ) result (os) + implicit none + + integer :: u,v,c + integer :: i, j, ii, jj, nn, k, l + integer :: s, numberOfSpecies + integer :: os,is,auxis, auxos + integer :: cilevel(:) + integer :: plusOne(3,3) , plusTwo(4,6) + + is = s + 1 + if ( is < numberOfSpecies ) then + do i = 1, size(CIcore_instance%numberOfStrings(is)%values, dim = 1) + cilevel(is) = i - 1 + os = CIcore_buildCIOrderRecursion( is, numberOfSpecies, c, cilevel ) + end do + cilevel(is) = 0 + else + do i = 1, size(CIcore_instance%numberOfStrings(is)%values, dim = 1) + cilevel(is) = i - 1 + c = c + 1 + + CIcore_instance%ciOrderList( c, : ) = cilevel(:) + if ( sum(cilevel) <= CIcore_instance%maxCIlevel ) then + CIcore_instance%sizeCiOrderList = CIcore_instance%sizeCiOrderList + 1 + CIcore_instance%auxciOrderList( CIcore_instance%sizeCiOrderList ) = c + end if + + if ( trim(CIcore_instance%level) == "CISD+" ) then !!special case. + plusOne(:,1) = (/1,1,1/) + plusOne(:,2) = (/2,0,1/) + plusOne(:,3) = (/0,2,1/) + + do k = 1, 3 + if ( sum( abs(cilevel(:) - plusOne(:,k)) ) == 0 ) then + CIcore_instance%sizeCiOrderList = CIcore_instance%sizeCiOrderList + 1 + CIcore_instance%auxciOrderList( CIcore_instance%sizeCiOrderList ) = c + end if + end do + + end if + + if ( trim(CIcore_instance%level) == "CISD+2" ) then !!special case. + plusTwo(:,1) = (/1,1,1,0/) + plusTwo(:,2) = (/1,1,0,1/) + plusTwo(:,3) = (/2,0,1,0/) + plusTwo(:,4) = (/2,0,0,1/) + plusTwo(:,5) = (/0,2,1,0/) + plusTwo(:,6) = (/0,2,0,1/) + + do k = 1, 6 + if ( sum( abs(cilevel(:) - plusTwo(:,k)) ) == 0 ) then + CIcore_instance%sizeCiOrderList = CIcore_instance%sizeCiOrderList + 1 + CIcore_instance%auxciOrderList( CIcore_instance%sizeCiOrderList ) = c + end if + end do + + end if + + end do + cilevel(is) = 0 + end if + + end function CIcore_buildCIOrderRecursion + +recursive function CIcore_getIndexSize(s, c, auxcilevel) result (os) + implicit none + + integer(8) :: a,b,c + integer :: u,v + integer :: i, j, ii, jj, ss + integer :: s, numberOfSpecies + integer :: os,is,cc, ssize + integer :: auxcilevel(:) + + is = s + 1 + do ss = 1, CIcore_instance%recursionVector1(is) + i = auxcilevel(is) + 1 + ssize = CIcore_instance%numberOfStrings2(is)%values(i) + do a = 1, CIcore_instance%numberOfStrings(is)%values(i) + os = CIcore_getIndexSize( is, c, auxcilevel ) + end do + end do + do ss = 1, CIcore_instance%recursionVector2(is) + os = is + i = auxcilevel(is) + 1 + ssize = CIcore_instance%numberOfStrings2(is)%values(i) + c = c + CIcore_instance%numberOfStrings(is)%values(i) + end do + + end function CIcore_getIndexSize + + !> + !! @brief Maneja excepciones de la clase + !< + subroutine CIcore_exception( typeMessage, description, debugDescription) + implicit none + integer :: typeMessage + character(*) :: description + character(*) :: debugDescription + + type(Exception) :: ex + + call Exception_constructor( ex , typeMessage ) + call Exception_setDebugDescription( ex, debugDescription ) + call Exception_setDescription( ex, description ) + call Exception_show( ex ) + call Exception_destructor( ex ) + + end subroutine CIcore_exception + + +end module CIOrder_ diff --git a/src/CI/CIStrings.f90 b/src/CI/CIStrings.f90 new file mode 100644 index 00000000..526b61ee --- /dev/null +++ b/src/CI/CIStrings.f90 @@ -0,0 +1,262 @@ +module CIStrings_ + use Exception_ + use Matrix_ + use Vector_ + use MolecularSystem_ + use Configuration_ + use MolecularSystem_ + use String_ + use IndexMap_ + use InputCI_ + use omp_lib + use CIcore_ + +contains + + subroutine CIcore_buildStrings() + implicit none + + integer(8) :: a,b,c,c1,c2,aa,d + integer :: ci, oci, cilevel,maxcilevel + integer :: u,uu,vv, p, nn,z + integer :: i,j + integer :: numberOfSpecies, auxnumberOfSpecies,s + type(ivector) :: order + integer(8) :: ssize + real(8) :: timeA, timeB + type(vector), allocatable :: occupiedCode(:) + type(vector), allocatable :: unoccupiedCode(:) + + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + + if ( allocated( occupiedCode ) ) deallocate( occupiedCode ) + allocate (occupiedCode ( numberOfSpecies ) ) + if ( allocated( unoccupiedCode ) ) deallocate( unoccupiedCode ) + allocate (unoccupiedCode ( numberOfSpecies ) ) + + call Vector_constructorInteger (order, numberOfSpecies, 0 ) + order%values = 0 + + s = 0 + do i = 1, numberOfSpecies + + call Vector_constructorInteger8 (CIcore_instance%numberOfStrings(i), & + int(CIcore_instance%CILevel(i) + 1,8), 0_8) + + CIcore_instance%numberOfStrings(i)%values(1) = 1 !! ground + + write (*,"(A,A)") " ", MolecularSystem_getNameOfSpecie(i) + + do cilevel = 1,CIcore_instance%CILevel(i) + + call Vector_constructor (occupiedCode(i), cilevel, real(CIcore_instance%numberOfCoreOrbitals%values(i),8) ) + call Vector_constructor (unoccupiedCode(i), cilevel, 0.0_8) + + unoccupiedCode(i)%values = CIcore_instance%numberOfOccupiedOrbitals%values(i) ! it's also a lower bound in a for loop + + if ( cilevel <= CIcore_instance%numberOfOccupiedOrbitals%values(i) ) then + + !! just get the number of strings... + ci = 0 + oci = CIcore_buildStringsRecursion( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel) + + write (*,"(A,I4,I8)") " ", cilevel, CIcore_instance%numberOfStrings(i)%values(cilevel+1) + + end if + end do + write (*,"(A,I8)") " Total:", sum(CIcore_instance%numberOfStrings(i)%values) + write (*,"(A)") "" + + !! allocate the strings arrays + if ( CIcore_instance%numberOfOccupiedOrbitals%values(i) > 0 ) then + call Matrix_constructorInteger( CIcore_instance%strings(i), & + int(CIcore_instance%numberOfOccupiedOrbitals%values(i),8), & + sum(CIcore_instance%numberOfStrings(i)%values), int(0,4)) + + call Matrix_constructorInteger1( CIcore_instance%orbitals(i), & + int(CIcore_instance%numberOfOrbitals%values(i),8), & + sum(CIcore_instance%numberOfStrings(i)%values), 0_1) + + else + call Matrix_constructorInteger( CIcore_instance%strings(i), & + 1_8, 1_8, int(0,4)) + call Matrix_constructorInteger1( CIcore_instance%orbitals(i), & + 1_8, 1_8, 0_1) + + end if + + !! zero, build the reference + call Vector_constructorInteger (order, numberOfSpecies, 0 ) + + call Vector_constructor (occupiedCode(i), 1, 0.0_8) !! initialize in zero + call Vector_constructor (unoccupiedCode(i), 1, 0.0_8) + + c = 0 + c = c + 1 + call Configuration_constructorB(CIcore_instance%strings(i), CIcore_instance%orbitals(i), & + occupiedCode, unoccupiedCode, i, c, order) + + !! now build the strings + do cilevel = 1,CIcore_instance%CILevel(i) + + call Vector_constructorInteger (order, numberOfSpecies, 0 ) + order%values(i) = cilevel + + call Vector_constructor (occupiedCode(i), cilevel, real(CIcore_instance%numberOfCoreOrbitals%values(i),8) ) + call Vector_constructor (unoccupiedCode(i), cilevel, 0.0_8) + + unoccupiedCode(i)%values = CIcore_instance%numberOfOccupiedOrbitals%values(i) ! it's also a lower bound in a for loop + + if ( cilevel <= CIcore_instance%numberOfOccupiedOrbitals%values(i) ) then + + !! recursion to build the strings + ci = 0 + oci = CIcore_buildStringsRecursion2( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel, order, c) + + end if + end do + + end do + + !! useful array + do i = 1, numberOfSpecies + CIcore_instance%sumstrings(i) = sum(CIcore_instance%numberOfStrings(i)%values) + end do + + !! useful array, save the total number of string for a previous CI level. + do i = 1, numberOfSpecies + call Vector_constructorInteger8 (CIcore_instance%numberOfStrings2(i), & + int(size(CIcore_instance%numberOfStrings(i)%values, dim = 1) + 1,8), 0_8) + + ssize = 0 + do j = 1, size(CIcore_instance%numberOfStrings(i)%values, dim = 1) ! + ssize = ssize + CIcore_instance%numberOfStrings(i)%values(j) + CIcore_instance%numberOfStrings2(i)%values(j+1) = ssize + end do + CIcore_instance%numberOfStrings2(i)%values(1) = 0 + end do + + + end subroutine CIcore_buildStrings + +!! This is just to get the total number of strings... +recursive function CIcore_buildStringsRecursion( i, numberOfSpecies, occupiedCode, unoccupiedCode, ici, cilevel ) result (oci) + implicit none + + integer :: i, numberOfSpecies + integer :: ci, ici, oci, cilevel + integer :: m, a + type(vector), allocatable :: occupiedCode(:) + type(vector), allocatable :: unoccupiedCode(:) + + ci = ici + 1 + + if ( ci == 1 .and. ci < cilevel ) then ! first + do m = int(occupiedCode(i)%values(ci)) + 1, int(CIcore_instance%numberOfOccupiedOrbitals%values(i)) + do a = int(unoccupiedCode(i)%values(ci)) + 1, int(CIcore_instance%numberOfOrbitals%values(i) ) + occupiedCode(i)%values(ci) = m + unoccupiedCode(i)%values(ci) = a + oci = CIcore_buildStringsRecursion( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel ) + end do + unoccupiedCode(i)%values = CIcore_instance%numberOfOccupiedOrbitals%values(i) + end do + else if ( ci > 1 .and. ci < cilevel ) then ! mid + do m = int(occupiedCode(i)%values(ci-1)) + 1, int(CIcore_instance%numberOfOccupiedOrbitals%values(i)) + do a = int(unoccupiedCode(i)%values(ci-1)) + 1, int(CIcore_instance%numberOfOrbitals%values(i) ) + occupiedCode(i)%values(ci) = m + unoccupiedCode(i)%values(ci) = a + oci = CIcore_buildStringsRecursion( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel ) + end do + end do + + else if ( ci == 1 .and. ci == cilevel ) then ! mid + do m = int(occupiedCode(i)%values(ci)) + 1, int(CIcore_instance%numberOfOccupiedOrbitals%values(i)) + do a = int(unoccupiedCode(i)%values(ci)) + 1, int(CIcore_instance%numberOfOrbitals%values(i) ) + occupiedCode(i)%values(ci) = m + unoccupiedCode(i)%values(ci) = a + CIcore_instance%numberOfStrings(i)%values(ci+1) = & + CIcore_instance%numberOfStrings(i)%values(ci+1) + 1 + end do + if ( ci == 1 ) unoccupiedCode(i)%values = CIcore_instance%numberOfOccupiedOrbitals%values(i) + end do + + else !final + + do m = int(occupiedCode(i)%values(ci-1)) + 1, int(CIcore_instance%numberOfOccupiedOrbitals%values(i)) + do a = int(unoccupiedCode(i)%values(ci-1)) + 1, int(CIcore_instance%numberOfOrbitals%values(i) ) + occupiedCode(i)%values(ci) = m + unoccupiedCode(i)%values(ci) = a + CIcore_instance%numberOfStrings(i)%values(ci+1) = & + CIcore_instance%numberOfStrings(i)%values(ci+1) + 1 + end do + if ( ci == 1 ) unoccupiedCode(i)%values = CIcore_instance%numberOfOccupiedOrbitals%values(i) + end do + end if + + end function CIcore_buildStringsRecursion + +!! and this is for building the strings +recursive function CIcore_buildStringsRecursion2( i, numberOfSpecies, occupiedCode, unoccupiedCode, & + ici, cilevel, order, c ) result (oci) + implicit none + + integer :: i, numberOfSpecies + integer :: ci, ici, oci, cilevel + integer(8) :: c + integer :: m, a + type(ivector) :: order + type(vector), allocatable :: occupiedCode(:) + type(vector), allocatable :: unoccupiedCode(:) + + ci = ici + 1 + + if ( ci == 1 .and. ci < cilevel ) then ! first + do m = int(occupiedCode(i)%values(ci)) + 1, int(CIcore_instance%numberOfOccupiedOrbitals%values(i)) + do a = int(unoccupiedCode(i)%values(ci)) + 1, int(CIcore_instance%numberOfOrbitals%values(i) ) + occupiedCode(i)%values(ci) = m + unoccupiedCode(i)%values(ci) = a + oci = CIcore_buildStringsRecursion2( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel, order, c ) + end do + unoccupiedCode(i)%values = CIcore_instance%numberOfOccupiedOrbitals%values(i) + end do + else if ( ci > 1 .and. ci < cilevel ) then ! mid + do m = int(occupiedCode(i)%values(ci-1)) + 1, int(CIcore_instance%numberOfOccupiedOrbitals%values(i)) + do a = int(unoccupiedCode(i)%values(ci-1)) + 1, int(CIcore_instance%numberOfOrbitals%values(i) ) + occupiedCode(i)%values(ci) = m + unoccupiedCode(i)%values(ci) = a + oci = CIcore_buildStringsRecursion2( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel, order, c ) + end do + end do + + else if ( ci == 1 .and. ci == cilevel ) then ! mid + do m = int(occupiedCode(i)%values(ci)) + 1, int(CIcore_instance%numberOfOccupiedOrbitals%values(i)) + do a = int(unoccupiedCode(i)%values(ci)) + 1, int(CIcore_instance%numberOfOrbitals%values(i) ) + occupiedCode(i)%values(ci) = m + unoccupiedCode(i)%values(ci) = a + + c = c + 1 + call Configuration_constructorB(CIcore_instance%strings(i), CIcore_instance%orbitals(i), & + occupiedCode, unoccupiedCode, i, c, order) + end do + if ( ci == 1 ) unoccupiedCode(i)%values = CIcore_instance%numberOfOccupiedOrbitals%values(i) + end do + + else !final + + do m = int(occupiedCode(i)%values(ci-1)) + 1, int(CIcore_instance%numberOfOccupiedOrbitals%values(i)) + do a = int(unoccupiedCode(i)%values(ci-1)) + 1, int(CIcore_instance%numberOfOrbitals%values(i) ) + occupiedCode(i)%values(ci) = m + unoccupiedCode(i)%values(ci) = a + c = c + 1 + call Configuration_constructorB(CIcore_instance%strings(i), CIcore_instance%orbitals(i), & + occupiedCode, unoccupiedCode, i, c, order) + end do + if ( ci == 1 ) unoccupiedCode(i)%values = CIcore_instance%numberOfOccupiedOrbitals%values(i) + end do + end if + + + end function CIcore_buildStringsRecursion2 + +end module CIStrings_ diff --git a/src/CI/CIcore.f90 b/src/CI/CIcore.f90 new file mode 100644 index 00000000..8a115080 --- /dev/null +++ b/src/CI/CIcore.f90 @@ -0,0 +1,355 @@ + module CIcore_ + use Exception_ + use Matrix_ + use Vector_ + use MolecularSystem_ + use Configuration_ + use MolecularSystem_ + use String_ + use IndexMap_ + use InputCI_ + use omp_lib + implicit none + + type, public :: CIcore + logical :: isInstanced + integer :: numberOfSpecies + type(matrix) :: hamiltonianMatrix + type(ivector8) :: auxIndexCIMatrix + type(matrix) :: eigenVectors + type(matrix) :: initialEigenVectors + type(vector8) :: initialEigenValues + integer(8) :: numberOfConfigurations + integer :: nproc + type(ivector) :: numberOfCoreOrbitals + type(ivector) :: numberOfOccupiedOrbitals + type(ivector) :: numberOfOrbitals + type(vector) :: numberOfSpatialOrbitals2 + type(vector8) :: eigenvalues + type(vector) :: lambda !!Number of particles per orbital, module only works for 1 or 2 particles per orbital + type(matrix), allocatable :: fourCenterIntegrals(:,:) + type(matrix), allocatable :: twoCenterIntegrals(:) + type(imatrix8), allocatable :: twoIndexArray(:) + type(imatrix8), allocatable :: fourIndexArray(:) + type(imatrix), allocatable :: strings(:) !! species, conf, occupations + type(imatrix1), allocatable :: orbitals(:) !! species, conf, occupations + integer, allocatable :: sumstrings(:) !! species + type(ivector), allocatable :: auxstring(:,:) !! species, occupations + type(ivector8), allocatable :: numberOfStrings(:) !! species, excitation level, number of strings + type(ivector8), allocatable :: numberOfStrings2(:) !! species, excitation level, number of strings + + !! species, threads + type(imatrix), allocatable :: couplingMatrix(:,:) + type(Vector), allocatable :: couplingMatrixEnergyOne(:,:) +! type(matrix), allocatable :: couplingMatrixEnergyTwo(:) + type(ivector), allocatable :: couplingMatrixFactorOne(:,:) + type(ivector), allocatable :: couplingMatrixOrbOne(:,:) + type(imatrix), allocatable :: nCouplingOneTwo(:,:) + type(imatrix), allocatable :: nCouplingSize(:,:) + + type(ivector1), allocatable :: couplingOrderList(:,:) + type(ivector1), allocatable :: couplingOrderIndex(:,:) + + integer, allocatable :: ciOrderList(:,:) + integer, allocatable :: auxciOrderList(:) + integer :: sizeCiOrderList + integer(8), allocatable :: ciOrderSize1(:,:) + integer(8), allocatable :: ciOrderSize2(:,:) + integer(4), allocatable :: allIndexConf(:,:) !! species, total number of configurations + + integer :: ncouplingOrderOne + integer :: ncouplingOrderTwo + integer :: ncouplingOrderTwoDiff + + type(imatrix) :: auxConfigurations !! species, configurations for initial hamiltonian + type(configuration), allocatable :: configurations(:) + integer(2), allocatable :: auxconfs(:,:,:) ! nconf, species, occupation + type (Vector8) :: diagonalHamiltonianMatrix + type (Vector8) :: diagonalHamiltonianMatrix2 + real(8) :: totalEnergy + integer, allocatable :: totalNumberOfContractions(:) + integer, allocatable :: occupationNumber(:) + integer, allocatable :: recursionVector1(:) + integer, allocatable :: recursionVector2(:) + integer, allocatable :: CILevel(:) + integer, allocatable :: pindexConf(:,:) + integer :: maxCILevel + type (Matrix) :: initialHamiltonianMatrix + type (Matrix) :: initialHamiltonianMatrix2 + character(20) :: level + real(8) :: timeA(7) + real(8) :: timeB(7) + + end type CIcore + + type, public :: HartreeFock + real(8) :: totalEnergy + real(8) :: puntualInteractionEnergy + type(matrix) :: coefficientsofcombination + type(matrix) :: HcoreMatrix + end type HartreeFock + + integer, allocatable :: Conf_occupationNumber(:) + type(HartreeFock) :: HartreeFock_instance + type(CIcore) :: CIcore_instance + + public :: & + CIcore_constructor + + +contains + + !> + !! @brief Constructor por omision + !! + !! @param this + !< + subroutine CIcore_constructor(level) + implicit none + character(*) :: level + + integer :: numberOfSpecies + integer :: i,j,k,l,m,n,p,q,cc,r,s,el, nproc + integer(8) :: c + integer :: ma,mb,mc,md,me,pa,pb,pc,pd,pe + integer :: isLambdaEqual1,lambda,otherlambda + type(vector) :: occupiedCode + type(vector) :: unoccupiedCode + real(8) :: totalEnergy + + character(50) :: wfnFile + integer :: wfnUnit + character(50) :: nameOfSpecie + integer :: numberOfContractions + character(50) :: arguments(2) + + wfnFile = "lowdin.wfn" + wfnUnit = 20 + + !! Open file for wavefunction + open(unit=wfnUnit, file=trim(wfnFile), status="old", form="unformatted") + + !! Load results... + call Vector_getFromFile(unit=wfnUnit, binary=.true., value=HartreeFock_instance%totalEnergy, & + arguments=["TOTALENERGY"]) + call Vector_getFromFile(unit=wfnUnit, binary=.true., value=HartreeFock_instance%puntualInteractionEnergy, & + arguments=["PUNTUALINTERACTIONENERGY"]) + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + CIcore_instance%numberOfSpecies = numberOfSpecies + + + do i=1, numberOfSpecies + nameOfSpecie= trim( MolecularSystem_getNameOfSpecie( i ) ) + numberOfContractions = MolecularSystem_getTotalNumberOfContractions( i ) + + arguments(2) = nameOfSpecie + arguments(1) = "HCORE" + HartreeFock_instance%HcoreMatrix = & + Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfContractions,4), & + columns= int(numberOfContractions,4), binary=.true., arguments=arguments(1:2)) + + arguments(1) = "COEFFICIENTS" + HartreeFock_instance%coefficientsofcombination = & + Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfContractions,4), & + columns= int(numberOfContractions,4), binary=.true., arguments=arguments(1:2)) + end do + + CIcore_instance%isInstanced=.true. + CIcore_instance%level=level + CIcore_instance%numberOfConfigurations=0 + + call Vector_constructorInteger (CIcore_instance%numberOfCoreOrbitals, numberOfSpecies) + call Vector_constructorInteger (CIcore_instance%numberOfOccupiedOrbitals, numberOfSpecies) + call Vector_constructorInteger (CIcore_instance%numberOfOrbitals, numberOfSpecies) + call Vector_constructor (CIcore_instance%lambda, numberOfSpecies) + call Vector_constructor (CIcore_instance%numberOfSpatialOrbitals2, numberOfSpecies) + + CIcore_instance%nproc = omp_get_max_threads() + + if ( allocated (CIcore_instance%strings ) ) & + deallocate ( CIcore_instance%strings ) + allocate ( CIcore_instance%strings ( numberOfSpecies ) ) + + if ( allocated (CIcore_instance%orbitals ) ) & + deallocate ( CIcore_instance%orbitals ) + allocate ( CIcore_instance%orbitals ( numberOfSpecies ) ) + + if ( allocated (CIcore_instance%auxstring ) ) & + deallocate ( CIcore_instance%auxstring ) + allocate ( CIcore_instance%auxstring ( CIcore_instance%nproc, numberOfSpecies ) ) + + if ( allocated (CIcore_instance%couplingMatrix ) ) & + deallocate ( CIcore_instance%couplingMatrix ) + allocate ( CIcore_instance%couplingMatrix ( numberOfSpecies, CIcore_instance%nproc ) ) + + if ( allocated (CIcore_instance%couplingMatrixEnergyOne ) ) & + deallocate ( CIcore_instance%couplingMatrixEnergyOne ) + allocate ( CIcore_instance%couplingMatrixEnergyOne ( numberOfSpecies, CIcore_instance%nproc ) ) + + if ( allocated (CIcore_instance%couplingMatrixFactorOne ) ) & + deallocate ( CIcore_instance%couplingMatrixFactorOne ) + allocate ( CIcore_instance%couplingMatrixFactorOne ( numberOfSpecies, CIcore_instance%nproc ) ) + + if ( allocated (CIcore_instance%couplingMatrixOrbOne ) ) & + deallocate ( CIcore_instance%couplingMatrixOrbOne ) + allocate ( CIcore_instance%couplingMatrixOrbOne ( numberOfSpecies, CIcore_instance%nproc ) ) + + if ( allocated (CIcore_instance%nCouplingOneTwo ) ) & + deallocate ( CIcore_instance%nCouplingOneTwo ) + allocate ( CIcore_instance%nCouplingOneTwo ( numberOfSpecies, CIcore_instance%nproc ) ) + + if ( allocated (CIcore_instance%nCouplingSize ) ) & + deallocate ( CIcore_instance%nCouplingSize ) + allocate ( CIcore_instance%nCouplingSize ( numberOfSpecies, CIcore_instance%nproc ) ) + + if ( allocated (CIcore_instance%numberOfStrings ) ) & + deallocate ( CIcore_instance%numberOfStrings ) + allocate ( CIcore_instance%numberOfStrings ( numberOfSpecies ) ) + + if ( allocated (CIcore_instance%numberOfStrings2 ) ) & + deallocate ( CIcore_instance%numberOfStrings2 ) + allocate ( CIcore_instance%numberOfStrings2 ( numberOfSpecies ) ) + + if ( allocated (CIcore_instance%sumstrings ) ) & + deallocate ( CIcore_instance%sumstrings ) + allocate ( CIcore_instance%sumstrings ( numberOfSpecies ) ) + + if ( allocated ( CIcore_instance%totalNumberOfContractions ) ) & + deallocate ( CIcore_instance%totalNumberOfContractions ) + allocate ( CIcore_instance%totalNumberOfContractions (numberOfSpecies ) ) + + if ( allocated ( CIcore_instance%occupationNumber ) ) & + deallocate ( CIcore_instance%occupationNumber ) + allocate ( CIcore_instance%occupationNumber (numberOfSpecies ) ) + + if ( allocated ( CIcore_instance%recursionVector1 ) ) & + deallocate ( CIcore_instance%recursionVector1 ) + allocate ( CIcore_instance%recursionVector1 (numberOfSpecies ) ) + + if ( allocated ( CIcore_instance%recursionVector2 ) ) & + deallocate ( CIcore_instance%recursionVector2 ) + allocate ( CIcore_instance%recursionVector2 (numberOfSpecies ) ) + + if ( allocated ( CIcore_instance%CILevel) ) & + deallocate ( CIcore_instance%CILevel ) + allocate ( CIcore_instance%CILevel (numberOfSpecies ) ) + + if ( allocated ( CIcore_instance%pindexConf) ) & + deallocate ( CIcore_instance%pindexConf ) + allocate ( CIcore_instance%pindexConf (numberOfSpecies, CIcore_instance%nproc ) ) + + if ( allocated ( Conf_occupationNumber ) ) & + deallocate ( Conf_occupationNumber ) + allocate ( Conf_occupationNumber (numberOfSpecies ) ) + + + CIcore_instance%recursionVector1 = 1 + CIcore_instance%recursionVector2 = 0 + + CIcore_instance%recursionVector1(numberOfSpecies) = 0 + CIcore_instance%recursionVector2(numberOfSpecies) = 1 + + CIcore_instance%pindexConf = 0 + + do i=1, numberOfSpecies + !! We are working in spin orbitals not in spatial orbitals! + CIcore_instance%lambda%values(i) = MolecularSystem_getLambda( i ) + CIcore_instance%numberOfCoreOrbitals%values(i) = 0 + CIcore_instance%numberOfOccupiedOrbitals%values(i) = int (MolecularSystem_getOcupationNumber( i )* & + CIcore_instance%lambda%values(i)) + CIcore_instance%numberOfOrbitals%values(i) = MolecularSystem_getTotalNumberOfContractions( i )* & + CIcore_instance%lambda%values(i) + CIcore_instance%numberOfSpatialOrbitals2%values(i) = MolecularSystem_getTotalNumberOfContractions( i ) + CIcore_instance%numberOfSpatialOrbitals2%values(i) = & + CIcore_instance%numberOfSpatialOrbitals2%values(i) * ( & + CIcore_instance%numberOfSpatialOrbitals2%values(i) + 1 ) / 2 + + + CIcore_instance%totalNumberOfContractions( i ) = MolecularSystem_getTotalNumberOfContractions( i ) + CIcore_instance%occupationNumber( i ) = int( MolecularSystem_instance%species(i)%ocupationNumber ) + Conf_occupationNumber( i ) = MolecularSystem_instance%species(i)%ocupationNumber + + + !! Take the active space from input + if ( InputCI_Instance(i)%coreOrbitals /= 0 ) then + CIcore_instance%numberOfCoreOrbitals%values(i) = InputCI_Instance(i)%coreOrbitals + end if + if ( InputCI_Instance(i)%activeOrbitals /= 0 ) then + CIcore_instance%numberOfOrbitals%values(i) = InputCI_Instance(i)%activeOrbitals * & + CIcore_instance%lambda%values(i) + & + CIcore_instance%numberOfCoreOrbitals%values(i) + end if + + !!Uneven occupation number = alpha + !!Even occupation number = beta + end do + + + call Configuration_globalConstructor() + + close(wfnUnit) + + end subroutine CIcore_constructor + +recursive function CIcore_gatherConfRecursion(s, numberOfSpecies, indexConf, c, cilevel ) result (os) + implicit none + + integer(8) :: a,b,c,cc,d + integer :: i, j, ii, jj + integer :: s, numberOfSpecies + integer :: os,is + integer :: size1, size2 + integer(8) :: indexConf(:) + integer(1) :: coupling + integer(8) :: numberOfConfigurations + real(8) :: CIenergy + integer :: ssize + integer :: cilevel(:) + + is = s + 1 + if ( is < numberOfSpecies ) then + i = cilevel(is) + 1 + ssize = CIcore_instance%numberOfStrings2(is)%values(i) + do a = 1, CIcore_instance%numberOfStrings(is)%values(i) + indexConf(is) = ssize + a + os = CIcore_gatherConfRecursion( is, numberOfSpecies, indexConf, c, cilevel ) + end do + else + os = is + i = cilevel(is) + 1 + ssize = CIcore_instance%numberOfStrings2(is)%values(i) + do a = 1, CIcore_instance%numberOfStrings(is)%values(i) + c = c + 1 + indexConf(is) = ssize + a + CIcore_instance%allIndexConf(:,c) = indexConf + + end do + end if + + end function CIcore_gatherConfRecursion + + + function CIcore_getIndex ( indexConf ) result ( output ) + implicit none + integer(8) :: indexConf(:) + integer(8) :: output, ssize + integer :: i,j, numberOfSpecies + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + output = 0 + !! simplify!! + do i = 1, numberOfSpecies + ssize = 1 + do j = i + 1, numberOfSpecies + ssize = ssize * CIcore_instance%sumstrings(j) + !ssize = ssize * sum(CIcore_instance%numberOfStrings(j)%values(1:2)) + end do + output = output + ( indexConf(i) - 1 ) * ssize + end do + output = output + 1 + + end function CIcore_getIndex + +end module CIcore_ + diff --git a/src/CI/CImod.f90 b/src/CI/CImod.f90 new file mode 100644 index 00000000..92606243 --- /dev/null +++ b/src/CI/CImod.f90 @@ -0,0 +1,1553 @@ +!****************************************************************************** +!! This code is part of LOWDIN Quantum chemistry package +!! +!! this program has been developed under direction of: +!! +!! UNIVERSIDAD NACIONAL DE COLOMBIA" +!! PROF. ANDRES REYES GROUP" +!! http://www.qcc.unal.edu.co" +!! +!! UNIVERSIDAD DE GUADALAJARA" +!! PROF. ROBERTO FLORES GROUP" +!! http://www.cucei.udg.mx/~robertof" +!! +!! AUTHORS +!! E.F. POSADA. UNIVERSIDAD NACIONAL DE COLOMBIA +!! S.A. GONZALEZ. UNIVERSIDAD NACIONAL DE COLOMBIA +!! F.S. MONCADA. UNIVERSIDAD NACIONAL DE COLOMBIA +!! J. ROMERO. UNIVERSIDAD NACIONAL DE COLOMBIA +!! +!! CONTRIBUTORS +!! N.F.AGUIRRE. UNIVERSIDAD NACIONAL DE COLOMBIA +!! GABRIEL MERINO. UNIVERSIDAD DE GUANAJUATO +!! J.A. CHARRY UNIVERSIDAD NACIONAL DE COLOMBIA +!! +!! +!! Todos los derechos reservados, 2011 +!! +!!****************************************************************************** + +module CImod_ + use Exception_ + use Matrix_ + use Vector_ + use MolecularSystem_ + use Configuration_ + use ReadTransformedIntegrals_ + use MolecularSystem_ + use String_ + use IndexMap_ + use InputCI_ + use omp_lib + use JadamiluInterface_ + use CIcore_ + use CIDiag_ + use CIFullMatrix_ + use CIInitial_ + use CIJadamilu_ + use CIOrder_ + use CIStrings_ + + ! use ArpackInterface_ + implicit none + + !> + !! @brief Configuration Interaction Module, works in spin orbitals + !! + !! @author felix + !! + !! Creation data : 07-24-12 + !! + !! History change: + !! + !! - 07-24-12 : Felix Moncada ( fsmoncadaa@unal.edu.co ) + !! -# description. + !! - 07-09-16 : Jorge Charry ( jacharrym@unal.edu.co ) + !! -# Add CIS, and Fix CISD. + !! - MM-DD-YYYY : authorOfChange ( email@server ) + !! -# description + !! + !< + + + public :: & +! CIcore_constructor, & + CImod_destructor, & + CImod_getTotalEnergy, & + CImod_run, & + CImod_showEigenVectors, & + CImod_densityMatrices, & + CImod_show + + private + +contains + + + !> + !! @brief Muestra informacion del objeto + !! + !! @param this + !< + subroutine CImod_run() + implicit none + integer :: i,j,m, numberOfSpecies + real(8), allocatable :: eigenValues(:) + +! select case ( trim(CIcore_instance%level) ) + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + + write (*,*) "" + write (*,*) "===============================================" + write (*,*) " BEGIN ", trim(CIcore_instance%level)," CALCULATION" + write (*,*) " J. Charry, F. Moncada " + write (*,*) "-----------------------------------------------" + write (*,*) "" + + write (*,"(A32)",advance="no") "Number of orbitals for species: " + do i = 1, numberOfSpecies-1 + write (*,"(A)",advance="no") trim(MolecularSystem_getNameOfSpecie(i))//", " + end do + write (*,"(A)",advance="no") trim(MolecularSystem_getNameOfSpecie(numberOfSpecies)) + write (*,*) "" + + write (*,"(A28)",advance="no") " occupied orbitals: " + do i = 1, numberOfSpecies + write (*,"(I5)", advance="no") CIcore_instance%numberOfOccupiedOrbitals%values(i) + end do + write (*,*) "" + + write (*,"(A28)",advance="no") " virtual orbitals: " + do i = 1, numberOfSpecies + write (*,"(I5)",advance="no") int(MolecularSystem_getTotalNumberOfContractions( i )* & + CIcore_instance%lambda%values(i) - & + CIcore_instance%numberOfOccupiedOrbitals%values(i) ) + end do + write (*,*) "" + + write (*,"(A28)",advance="no") " total number of orbitals: " + do i = 1, numberOfSpecies + write (*,"(I5)",advance="no") int(MolecularSystem_getTotalNumberOfContractions( i )* & + CIcore_instance%lambda%values(i) ) + end do + write (*,*) "" + + + write (*,"(A28)",advance="no") " frozen core orbitals: " + do i = 1, numberOfSpecies + write (*,"(I5)",advance="no") CIcore_instance%numberOfCoreOrbitals%values(i) + end do + write (*,*) "" + + write (*,"(A28)",advance="no") " active occupied orbitals: " + do i = 1, numberOfSpecies + write (*,"(I5)",advance="no") CIcore_instance%numberOfOccupiedOrbitals%values(i) - & + CIcore_instance%numberOfCoreOrbitals%values(i) + end do + write (*,*) "" + + write (*,"(A28)",advance="no") " active virtual orbitals: " + do i = 1, numberOfSpecies + write (*,"(I5)",advance="no") CIcore_instance%numberOfOrbitals%values(i) - & + CIcore_instance%numberOfOccupiedOrbitals%values(i) + end do + write (*,*) "" + + write (*,"(A28)",advance="no") " total active orbitals: " + do i = 1, numberOfSpecies + write (*,"(I5)",advance="no") CIcore_instance%numberOfOrbitals%values(i) - & + CIcore_instance%numberOfCoreOrbitals%values(i) + end do + write (*,*) "" + write (*,*) " " + + write (*,*) "Getting transformed integrals..." + call CImod_getTransformedIntegrals() + write (*,*) " " + + !write (*,*) CIcore_instance%fourCenterIntegrals(1,1)%values(171, 1) a bug... + write (*,*) "Setting CI level..." + + call CIcore_settingCILevel() + + !! write (*,*) "Total number of configurations", CIcore_instance%numberOfConfigurations + write (*,*) "" + call Vector_constructor8 ( CIcore_instance%eigenvalues, & + int(CONTROL_instance%NUMBER_OF_CI_STATES,8), 0.0_8 ) + + select case (trim(String_getUppercase(CONTROL_instance%CI_DIAGONALIZATION_METHOD))) + + ! case ("ARPACK") + + ! write (*,*) "This method was removed" + + case ("JADAMILU") + + write (*,*) "Building Strings..." + call CIcore_buildStrings() + + write (*,*) "Building CI level table..." + call CIcore_buildCIOrderList() + + call CIcore_buildCouplingMatrix() + call CIcore_buildCouplingOrderList() + + write (*,*) "Building diagonal..." + call CIcore_buildDiagonal() + + write (*,*) "Building initial hamiltonian..." + call CIcore_buildInitialCIMatrix2() + !!call CIcore_buildHamiltonianMatrix() This should be modified to build the CI matrix in memory + + call Matrix_constructor (CIcore_instance%eigenVectors, & + int(CIcore_instance%numberOfConfigurations,8), & + int(CONTROL_instance%NUMBER_OF_CI_STATES,8), 0.0_8) + + if ( CONTROL_instance%CI_LOAD_EIGENVECTOR ) then + call CImod_loadEigenVector (CIcore_instance%eigenvalues, & + CIcore_instance%eigenVectors) + end if + + write(*,*) "" + write(*,*) "Diagonalizing hamiltonian..." + write(*,*) " Using : ", trim(String_getUppercase((CONTROL_instance%CI_DIAGONALIZATION_METHOD))) + write(*,*) "=============================================================" + write(*,*) "M. BOLLHÖFER AND Y. NOTAY, JADAMILU:" + write(*,*) " a software code for computing selected eigenvalues of " + write(*,*) " large sparse symmetric matrices, " + write(*,*) "Computer Physics Communications, vol. 177, pp. 951-964, 2007." + write(*,*) "=============================================================" + + + call CIcore_jadamiluInterface(CIcore_instance%numberOfConfigurations, & + int(CONTROL_instance%NUMBER_OF_CI_STATES,8), & + CIcore_instance%eigenvalues, & + CIcore_instance%eigenVectors ) + + if ( CONTROL_instance%CI_SAVE_EIGENVECTOR ) then + call CImod_saveEigenVector () + end if + case ("DSYEVX") + + write (*,*) "Building Strings..." + call CIcore_buildStrings() + + write (*,*) "Building CI level table..." + call CIcore_buildCIOrderList() + + write (*,*) "Building diagonal..." + call CIcore_buildDiagonal() + + write (*,*) "Building Hamiltonian..." + call CIcore_buildHamiltonianMatrix() + + call Matrix_constructor (CIcore_instance%eigenVectors, & + int(CIcore_instance%numberOfConfigurations,8), & + int(CONTROL_instance%NUMBER_OF_CI_STATES,8), 0.0_8) + + !! deallocate transformed integrals + deallocate(CIcore_instance%twoCenterIntegrals) + deallocate(CIcore_instance%fourCenterIntegrals) + + write(*,*) "" + write(*,*) "Diagonalizing hamiltonian..." + write(*,*) " Using : ", trim(String_getUppercase((CONTROL_instance%CI_DIAGONALIZATION_METHOD))) + + call Matrix_eigen_select (CIcore_instance%hamiltonianMatrix, CIcore_instance%eigenvalues, & + int(1), int(CONTROL_instance%NUMBER_OF_CI_STATES), & + eigenVectors = CIcore_instance%eigenVectors, & + flags = int(SYMMETRIC,4)) + +! call Matrix_eigen_select (CIcore_instance%hamiltonianMatrix, CIcore_instance%eigenvalues, & +! 1, CONTROL_instance%NUMBER_OF_CI_STATES, & +! flags = SYMMETRIC, dm = CIcore_instance%numberOfConfigurations ) + + + case ("DSYEVR") + + write (*,*) "Building Strings..." + call CIcore_buildStrings() + + write (*,*) "Building CI level table..." + call CIcore_buildCIOrderList() + + write (*,*) "Building diagonal..." + call CIcore_buildDiagonal() + + write (*,*) "Building Hamiltonian..." + call CIcore_buildHamiltonianMatrix() + + call Matrix_constructor (CIcore_instance%eigenVectors, & + int(CIcore_instance%numberOfConfigurations,8), & + int(CONTROL_instance%NUMBER_OF_CI_STATES,8), 0.0_8) + + !! deallocate transformed integrals + deallocate(CIcore_instance%twoCenterIntegrals) + deallocate(CIcore_instance%fourCenterIntegrals) + + call Matrix_eigen_dsyevr (CIcore_instance%hamiltonianMatrix, CIcore_instance%eigenvalues, & + 1, CONTROL_instance%NUMBER_OF_CI_STATES, & + eigenVectors = CIcore_instance%eigenVectors, & + flags = SYMMETRIC) + +! call Matrix_eigen_dsyevr (CIcore_instance%hamiltonianMatrix, CIcore_instance%eigenvalues, & +! 1, CONTROL_instance%NUMBER_OF_CI_STATES, & +! flags = SYMMETRIC, dm = CIcore_instance%numberOfConfigurations ) + + case default + + call CImod_exception( ERROR, "CImod run", "Diagonalization method not implemented") + + + end select + + write(*,*) "" + write(*,*) "-----------------------------------------------" + write(*,*) " END ", trim(CIcore_instance%level)," CALCULATION" + write(*,*) "===============================================" + write(*,*) "" + +! case ( "FCI-oneSpecie" ) +! +! print *, "" +! print *, "" +! print *, "===============================================" +! print *, "| Full CI for one specie calculation |" +! print *, "| Use fci program to perform the calculation |" +! print *, "-----------------------------------------------" +! print *, "" +! ! call CIcore_getTransformedIntegrals() +! !call CIcore_printTransformedIntegralsToFile() +! + + end subroutine CImod_run + + !> + !! @brief Muestra informacion del objeto + !! + !! @param this + !< + subroutine CImod_getTransformedIntegrals() + implicit none + + integer :: numberOfSpecies + integer :: i,j,m,n,mu,nu,a,b + integer(8) :: c + integer :: specieID + integer :: otherSpecieID + character(10) :: nameOfSpecie + character(10) :: nameOfOtherSpecie + integer :: ocupationNumber + integer :: ocupationNumberOfOtherSpecie + integer :: numberOfContractions + integer :: numberOfContractionsOfOtherSpecie + type(Matrix) :: hcoreMatrix + type(Matrix) :: coefficients + real(8) :: charge + real(8) :: otherSpecieCharge + + integer :: ssize1, ssize2 + type(Matrix) :: externalPotential + + character(50) :: wfnFile + character(50) :: arguments(20) + integer :: wfnUnit + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + allocate(CIcore_instance%twoCenterIntegrals(numberOfSpecies)) + allocate(CIcore_instance%fourCenterIntegrals(numberOfSpecies,numberOfSpecies)) + + allocate(CIcore_instance%twoIndexArray(numberOfSpecies)) + allocate(CIcore_instance%fourIndexArray(numberOfSpecies)) + + do i=1, numberOfSpecies + nameOfSpecie= trim( MolecularSystem_getNameOfSpecie( i ) ) + specieID = MolecularSystem_getSpecieID( nameOfSpecie=nameOfSpecie ) + ocupationNumber = MolecularSystem_getOcupationNumber( i ) + numberOfContractions = MolecularSystem_getTotalNumberOfContractions( i ) + charge=MolecularSystem_getCharge(i) + +! write (6,"(T10,A)")"ONE PARTICLE INTEGRALS TRANSFORMATION FOR: "//trim(nameOfSpecie) + call Matrix_constructor (CIcore_instance%twoCenterIntegrals(i), & + int(numberOfContractions,8), int(numberOfContractions,8), 0.0_8 ) + + call Matrix_constructor (hcoreMatrix,int(numberOfContractions,8), int(numberOfContractions,8), 0.0_8) + + !! Open file for wavefunction + + wfnFile = "lowdin.wfn" + wfnUnit = 20 + + open(unit=wfnUnit, file=trim(wfnFile), status="old", form="unformatted") + + arguments(2) = MolecularSystem_getNameOfSpecie(i) + arguments(1) = "COEFFICIENTS" + + coefficients = & + Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfContractions,4), & + columns= int(numberOfContractions,4), binary=.true., arguments=arguments(1:2)) + + arguments(1) = "HCORE" + + hcoreMatrix = & + Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfContractions,4), & + columns= int(numberOfContractions,4), binary=.true., arguments=arguments(1:2)) + + !! transform two center integrals (one body operators) + do m=1,numberOfContractions + do n=m, numberOfContractions + do mu=1, numberOfContractions + do nu=1, numberOfContractions + CIcore_instance%twoCenterIntegrals(i)%values(m,n) = & + CIcore_instance%twoCenterIntegrals(i)%values(m,n) + & + coefficients%values(mu,m)* & + coefficients%values(nu,n)* & + hcoreMatrix%values(mu,nu) + end do + end do + end do + end do + + !! symmetrization + do m = 1,numberOfContractions + do n = m, numberOfContractions + CIcore_instance%twoCenterIntegrals(i)%values(n,m)=& + CIcore_instance%twoCenterIntegrals(i)%values(m,n) + end do + end do + + !! auxilary 2-index array + call Matrix_constructorInteger8(CIcore_instance%twoIndexArray(i), & + int( numberOfContractions,8), int( numberOfContractions,8) , 0_8 ) + + c = 0 + do a=1,numberOfContractions + do b = a, numberOfContractions + c = c + 1 + CIcore_instance%twoIndexArray(i)%values(a,b) = c !IndexMap_tensorR2ToVectorC( a, b, numberOfContractions ) + CIcore_instance%twoIndexArray(i)%values(b,a) = CIcore_instance%twoIndexArray(i)%values(a,b) + end do + end do + + + !! auxilary 4-index array + ssize1 = MolecularSystem_getTotalNumberOfContractions( i ) + ssize1 = ( ssize1 * ( ssize1 + 1 ) ) / 2 + + call Matrix_constructorInteger8(CIcore_instance%fourIndexArray(i), & + int( ssize1,8), int( ssize1,8) , 0_8 ) + c = 0 + do a = 1, ssize1 + do b = a, ssize1 + c = c + 1 + CIcore_instance%fourIndexArray(i)%values(a,b) = c! IndexMap_tensorR2ToVectorC( a, b, numberOfContractions ) + CIcore_instance%fourIndexArray(i)%values(b,a) = & + CIcore_instance%fourIndexArray(i)%values(a,b) + end do + end do + + + call ReadTransformedIntegrals_readOneSpecies( specieID, CIcore_instance%fourCenterIntegrals(i,i) ) + CIcore_instance%fourCenterIntegrals(i,i)%values = & + CIcore_instance%fourCenterIntegrals(i,i)%values * charge * charge + + if ( numberOfSpecies > 1 ) then + do j = 1 , numberOfSpecies + if ( i .ne. j) then + nameOfOtherSpecie = trim( MolecularSystem_getNameOfSpecie( j ) ) + otherSpecieID = MolecularSystem_getSpecieID( nameOfSpecie=nameOfOtherSpecie ) + ocupationNumberOfOtherSpecie = MolecularSystem_getOcupationNumber( j ) + numberOfContractionsOfOtherSpecie = MolecularSystem_getTotalNumberOfContractions( j ) + otherSpecieCharge = MolecularSystem_getCharge(j) + + call ReadTransformedIntegrals_readTwoSpecies( specieID, otherSpecieID, & + CIcore_instance%fourCenterIntegrals(i,j) ) + CIcore_instance%fourCenterIntegrals(i,j)%values = & + CIcore_instance%fourCenterIntegrals(i,j)%values * charge * otherSpeciecharge + + + end if + end do + end if + end do + close (wfnUnit) + call Matrix_destructor (hcoreMatrix) + + end subroutine CImod_getTransformedIntegrals + + + !** + ! @ Retorna la energia final com correccion Moller-Plesset de orrden dado + !** + function CImod_getTotalEnergy() result(output) + implicit none + real(8) :: output + + output = CIcore_instance%totalEnergy + + end function CImod_getTotalEnergy + + + subroutine CImod_saveEigenVector () + implicit none + character(50) :: nameFile + integer :: unitFile + integer(8) :: i, ia + integer :: ib, nonzero + integer, allocatable :: auxIndexArray(:) + real(8), allocatable :: auxArray(:) + integer :: maxStackSize + + maxStackSize = CONTROL_instance%CI_STACK_SIZE + nameFile = "lowdin.civec" + unitFile = 20 + + nonzero = 0 + do i = 1, CIcore_instance%numberOfConfigurations + if ( abs(CIcore_instance%eigenVectors%values(i,1) ) >= 1E-12 ) nonzero = nonzero + 1 + end do + + write (*,*) "nonzero", nonzero + + allocate(auxArray(nonzero)) + allocate(auxIndexArray(nonzero)) + + ia = 0 + do i = 1, CIcore_instance%numberOfConfigurations + if ( abs(CIcore_instance%eigenVectors%values(i,1) ) >= 1E-12 ) then + ia = ia + 1 + auxIndexArray(ia) = i + auxArray(ia) = CIcore_instance%eigenVectors%values(i,1) + end if + end do + + open(unit=unitFile, file=trim(nameFile), status="replace", form="unformatted") + + write(unitFile) CIcore_instance%eigenValues%values(1) + write(unitFile) nonzero + + do i = 1, ceiling(real(nonzero) / real(maxStackSize) ) + ib = maxStackSize * i + ia = ib - maxStackSize + 1 + if ( ib > nonzero ) ib = nonzero + write(unitFile) auxIndexArray(ia:ib) + end do + deallocate(auxIndexArray) + + do i = 1, ceiling(real(nonzero) / real(maxStackSize) ) + ib = maxStackSize * i + ia = ib - maxStackSize + 1 + if ( ib > nonzero ) ib = nonzero + write(unitFile) auxArray(ia:ib) + end do + deallocate(auxArray) + + close(unitFile) + + end subroutine CImod_saveEigenVector + + subroutine CImod_loadEigenVector (eigenValues,eigenVectors) + implicit none + type(Vector8) :: eigenValues + type(Matrix) :: eigenVectors + character(50) :: nameFile + integer :: unitFile + integer :: i, ia, ib, nonzero + real(8) :: eigenValue + integer, allocatable :: auxIndexArray(:) + real(8), allocatable :: auxArray(:) + integer :: maxStackSize + + maxStackSize = CONTROL_instance%CI_STACK_SIZE + + + nameFile = "lowdin.civec" + unitFile = 20 + + + open(unit=unitFile, file=trim(nameFile), status="old", action="read", form="unformatted") + + readvectors : do + read (unitFile) eigenValue + read (unitFile) nonzero + write (*,*) "eigenValue", eigenValue + write (*,*) "nonzero", nonzero + + allocate (auxIndexArray(nonzero)) + auxIndexArray = 0 + + do i = 1, ceiling(real(nonZero) / real(maxStackSize) ) + ib = maxStackSize * i + ia = ib - maxStackSize + 1 + if ( ib > nonZero ) ib = nonZero + read (unitFile) auxIndexArray(ia:ib) + end do + + allocate (auxArray(nonzero)) + auxArray = 0 + + do i = 1, ceiling(real(nonZero) / real(maxStackSize) ) + ib = maxStackSize * i + ia = ib - maxStackSize + 1 + if ( ib > nonZero ) ib = nonZero + read (unitFile) auxArray(ia:ib) + end do + exit readvectors + end do readvectors + + eigenValues%values(1) = eigenValue + do i = 1, nonzero + eigenVectors%values(auxIndexArray(i),1) = auxArray(i) + end do + + deallocate (auxIndexArray ) + deallocate (auxArray ) + + + close(unitFile) + + end subroutine CImod_loadEigenVector + + !> + !! @brief Muestra informacion del objeto + !! + !! @param this + !< + subroutine CImod_show() + implicit none + type(CIcore) :: this + integer :: i + real(8) :: davidsonCorrection, HFcoefficient, CIcorrection + integer numberOfSpecies + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + + if ( CIcore_instance%isInstanced ) then + + write(*,"(A)") "" + write(*,"(A)") " POST HARTREE-FOCK CALCULATION" + write(*,"(A)") " CONFIGURATION INTERACTION THEORY:" + write(*,"(A)") "==============================" + write(*,"(A)") "" + write (6,"(T8,A30, A5)") "LEVEL = ", CIcore_instance%level + write (6,"(T8,A30, I8)") "NUMBER OF CONFIGURATIONS = ", CIcore_instance%numberOfConfigurations + do i = 1, CONTROL_instance%NUMBER_OF_CI_STATES + write (6,"(T8,A17,I3,A10, F25.12)") "STATE: ", i, " ENERGY = ", CIcore_instance%eigenvalues%values(i) + end do + write(*,"(A)") "" + CIcorrection = CIcore_instance%eigenvalues%values(1) - & + HartreeFock_instance%totalEnergy + + write (6,"(T4,A34, F25.12)") "GROUND STATE CORRELATION ENERGY = ", CIcorrection + + if ( CIcore_instance%level == "CISD" ) then + write(*,"(A)") "" + write (6,"(T2,A34)") "RENORMALIZED DAVIDSON CORRECTION:" + write(*,"(A)") "" + write (6,"(T8,A54)") "E(CISDTQ) \approx E(CISD) + \delta E(Q) " + write (6,"(T8,A54)") "\delta E(Q) = (1 - c_0^2) * \delta E(CISD) / c_0^2 " + write (*,*) "" + HFcoefficient = CIcore_instance%eigenVectors%values(1,1) + davidsonCorrection = ( 1 - HFcoefficient*HFcoefficient) * CIcorrection / (HFcoefficient*HFcoefficient) + + + write (6,"(T8,A19, F25.12)") "HF COEFFICIENT = ", HFcoefficient + write (6,"(T8,A19, F25.12)") "\delta E(Q) = ", davidsonCorrection + write (6,"(T8,A19, F25.12)") "E(CISDTQ) ESTIMATE ", HartreeFock_instance%totalEnergy +& + CIcorrection + davidsonCorrection + else + + write(*,"(A)") "" + HFcoefficient = CIcore_instance%eigenVectors%values(1,1) + write (6,"(T8,A19, F25.12)") "HF COEFFICIENT = ", HFcoefficient + + end if + + else + + end if + + end subroutine CImod_show + + subroutine CImod_showEigenVectors() + implicit none + + integer(8) :: a,b,c + integer :: u,v,p + integer :: ci + integer :: i, j, ii, jj + integer :: s, numberOfSpecies, auxnumberOfSpecies + integer :: size1, size2 + real(8) :: timeA, timeB + integer(1) :: coupling + integer(8) :: numberOfConfigurations + real(8) :: CIenergy + integer(8), allocatable :: indexConf(:) + integer, allocatable :: cilevel(:), auxcilevel(:), dd(:) + + + if ( CONTROL_instance%CI_PRINT_EIGENVECTORS_FORMAT == "NONE" ) return + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + numberOfConfigurations = CIcore_instance%numberOfConfigurations + + allocate ( CIcore_instance%allIndexConf( numberOfSpecies, numberOfConfigurations ) ) + allocate ( ciLevel ( numberOfSpecies ) ) + allocate ( indexConf ( numberOfSpecies ) ) + ciLevel = 0 + CIcore_instance%allIndexConf = 0 + indexConf = 0 + + !! gather all configurations + s = 0 + c = 0 + ciLevel = 0 + + do ci = 1, CIcore_instance%sizeCiOrderList + + cilevel(:) = CIcore_instance%ciOrderList( CIcore_instance%auxciOrderList(ci), :) + s = 0 + auxnumberOfSpecies = CIcore_gatherConfRecursion( s, numberOfSpecies, indexConf, c, cilevel ) + end do + !stop + + deallocate ( ciLevel ) + + if ( CONTROL_instance%CI_PRINT_EIGENVECTORS_FORMAT == "ORBITALS" ) then + write (*,*) "" + write (*, "(T1,A)") "Eigenvectors" + write (*,*) "" + + do c = 1, CONTROL_instance%NUMBER_OF_CI_STATES + write (*, "(T1,A,I4,A,F25.12)") "State: ", c, " Energy: ", CIcore_instance%eigenValues%values(c) + write (*, "(T1,A)") "Conf, orbital occupation per species, coefficient" + write (*,*) "" + do a = 1, numberOfConfigurations + if ( abs(CIcore_instance%eigenVectors%values(a,c)) > CONTROL_instance%CI_PRINT_THRESHOLD ) then + indexConf(:) = CIcore_instance%allIndexConf(:,a) + + write (*, "(T1,I8,A1)", advance="no") a, " " + do i = 1, numberOfSpecies + do p = 1, CIcore_instance%numberOfOrbitals%values(i) + write (*, "(I1)", advance="no") CIcore_instance%orbitals(i)%values(p,indexConf(i)) + end do + write (*, "(A1)", advance="no") " " + end do + write (*, "(F11.8)") CIcore_instance%eigenVectors%values(a,c) + end if + end do + write (*,*) "" + end do + + + else if ( CONTROL_instance%CI_PRINT_EIGENVECTORS_FORMAT == "OCCUPIED" ) then + write (*,*) "" + write (*, "(T1,A)") "Eigenvectors" + write (*,*) "" + + do c = 1, CONTROL_instance%NUMBER_OF_CI_STATES + write (*, "(T1,A,I4,A,F25.12)") "State: ", c, " Energy: ", CIcore_instance%eigenValues%values(c) + write (*, "(T1,A)") "Conf, occupied orbitals per species, coefficient" + write (*,*) "" + do a = 1, numberOfConfigurations + if ( abs(CIcore_instance%eigenVectors%values(a,c)) > CONTROL_instance%CI_PRINT_THRESHOLD ) then + indexConf(:) = CIcore_instance%allIndexConf(:,a) + + write (*, "(T1,I8,A1)", advance="no") a, " " + do i = 1, numberOfSpecies + do p = 1, CIcore_instance%numberOfOccupiedOrbitals%values(i) + write (*, "(I3,A1)", advance="no") CIcore_instance%strings(i)%values(p,indexConf(i) ), " " + end do + write (*, "(A1)", advance="no") "|" + end do + write (*, "(A,F11.8)") " ", CIcore_instance%eigenVectors%values(a,c) + end if + end do + write (*,*) "" + end do + + end if + + deallocate ( indexConf ) + deallocate ( CIcore_instance%allIndexConf ) + + end subroutine CImod_showEigenVectors + + + !FELIX IS HERE + subroutine CImod_densityMatrices() + implicit none + type(CIcore) :: this + type(Configuration) :: auxthisA, auxthisB + integer :: i, j, k, l, mu, nu, n + integer :: factor + integer :: unit, wfnunit + integer :: numberOfOrbitals, numberOfContractions, numberOfOccupiedOrbitals + integer :: state, species, orbital, orbitalA, orbitalB + character(50) :: file, wfnfile, speciesName, auxstring + character(50) :: arguments(2) + type(matrix), allocatable :: coefficients(:), atomicDensityMatrix(:,:), ciDensityMatrix(:,:), auxDensMatrix(:,:) + type(matrix), allocatable :: kineticMatrix(:), attractionMatrix(:), externalPotMatrix(:) + integer numberOfSpecies + + type(matrix) :: auxdensityEigenVectors + type(matrix) :: densityEigenVectors + type(vector) :: auxdensityEigenValues + type(vector) :: densityEigenValues + integer, allocatable :: cilevel(:), cilevelA(:) + integer(8) :: numberOfConfigurations, c + integer(8), allocatable :: indexConf(:) + type(ivector), allocatable :: stringAinB(:) + integer :: s, ss, ci, auxnumberOfSpecies + integer, allocatable :: coupling(:) + integer :: a, b, AA, BB, bj + integer :: u, uu, ssize + integer(8), allocatable :: indexConfA(:) + integer(8), allocatable :: indexConfB(:) + integer(8), allocatable :: jj(:) + real(8) :: timeDA + real(8) :: timeDB + + + ! type(Vector) :: eigenValues + ! type(Matrix) :: eigenVectors, auxMatrix + ! real(8) :: sumaPrueba + + !!Iterators: i,j - Configurations .... k,l - molecular orbitals .... mu,nu - atomic orbitals ... n - threads + if ( CIcore_instance%isInstanced .and. CONTROL_instance%CI_STATES_TO_PRINT .gt. 0 ) then + !$ timeDA = omp_get_wtime() + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + + numberOfConfigurations = CIcore_instance%numberOfConfigurations + + allocate (stringAinB ( numberOfSpecies )) + + do i = 1, numberOfSpecies + call Vector_constructorInteger (stringAinB(i), CIcore_instance%numberOfOccupiedOrbitals%values(i), 0) + end do + + allocate ( CIcore_instance%allIndexConf( numberOfSpecies, numberOfConfigurations ) ) + allocate ( ciLevelA ( numberOfSpecies ) ) + allocate ( ciLevel ( numberOfSpecies ) ) + allocate ( indexConf ( numberOfSpecies ) ) + ciLevelA = 0 + ciLevel = 0 + CIcore_instance%allIndexConf = 0 + indexConf = 0 + + !! gather all configurations + s = 0 + c = 0 + ciLevel = 0 + + do ci = 1, CIcore_instance%sizeCiOrderList + + cilevel(:) = CIcore_instance%ciOrderList( CIcore_instance%auxciOrderList(ci), :) + s = 0 + auxnumberOfSpecies = CIcore_gatherConfRecursion( s, numberOfSpecies, indexConf, c, cilevel ) + end do + !stop + + deallocate ( indexConf ) + allocate ( coupling ( numberOfSpecies ) ) + + + write (*,*) "" + write (*,*) "==============================" + write (*,*) "BUILDING CI DENSITY MATRICES" + write (*,*) "==============================" + write (*,*) "" + + allocate( coefficients(numberOfSpecies), & + kineticMatrix(numberOfSpecies), & + attractionMatrix(numberOfSpecies), & + externalPotMatrix(numberOfSpecies), & + atomicDensityMatrix(numberOfSpecies,CONTROL_instance%CI_STATES_TO_PRINT), & + ciDensityMatrix(numberOfSpecies,CONTROL_instance%CI_STATES_TO_PRINT), & + auxDensMatrix(numberOfSpecies,CIcore_instance%nproc) ) + + wfnFile = "lowdin.wfn" + wfnUnit = 20 + open(unit=wfnUnit, file=trim(wfnFile), status="old", form="unformatted") + + !Inicializando las matrices + do species=1, numberOfSpecies + speciesName = MolecularSystem_getNameOfSpecie(species) + + numberOfContractions = MolecularSystem_getTotalNumberOfContractions( species ) + ! numberOfOrbitals = CIcore_instance%numberOfOrbitals%values(species) + numberOfOccupiedOrbitals = CIcore_instance%numberOfOccupiedOrbitals%values(species) + + arguments(2) = speciesName + ! print *, "trolo", numberOfOrbitals, numberOfContractions, numberOfOccupiedOrbitals + + arguments(1) = "COEFFICIENTS" + coefficients(species) = Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfContractions,4), & + columns= int(numberOfContractions,4), binary=.true., arguments=arguments(1:2)) + + arguments(1) = "KINETIC" + kineticMatrix(species) = Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfContractions,4), & + columns= int(numberOfContractions,4), binary=.true., arguments=arguments(1:2)) + + arguments(1) = "ATTRACTION" + attractionMatrix(species) = Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfContractions,4), & + columns= int(numberOfContractions,4), binary=.true., arguments=arguments(1:2)) + + arguments(1) = "EXTERNAL_POTENTIAL" + if( CONTROL_instance%IS_THERE_EXTERNAL_POTENTIAL) & + externalPotMatrix(species) = Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfContractions,4), & + columns= int(numberOfContractions,4), binary=.true., arguments=arguments(1:2)) + ! print *, "trololo" + + do state=1, CONTROL_instance%CI_STATES_TO_PRINT + + call Matrix_constructor ( ciDensityMatrix(species,state) , & + int(numberOfContractions,8), & + int(numberOfContractions,8), 0.0_8 ) + + do k=1, numberOfOccupiedOrbitals + ciDensityMatrix(species,state)%values( k, k)=1.0_8 + end do + + end do + + do n=1, CIcore_instance%nproc + + call Matrix_constructor ( auxDensMatrix(species,n) , & + int(numberOfContractions,8), & + int(numberOfContractions,8), 0.0_8 ) + end do + end do + + close(wfnUnit) + + allocate ( indexConfA ( numberOfSpecies ) ) + allocate ( indexConfB ( numberOfSpecies ) ) + allocate ( jj ( numberOfSpecies ) ) + + indexConfA = 0 + indexConfB = 0 + jj = 0 + + !! Building the CI reduced density matrix in the molecular orbital representation in parallel + ! call Matrix_show (CIcore_instance%eigenVectors) + + !!print *, " State, Progress" + + do state=1, CONTROL_instance%CI_STATES_TO_PRINT + + !$omp parallel & + !$omp& firstprivate (stringAinB,indexConfA,indexConfB, jj) & + !$omp& private(i,j, species, s, numberOfOccupiedOrbitals, k, coupling, orbital, orbitalA, orbitalB, AA, BB, a, b, factor, n, cilevelA, ss, ssize, cilevel, ci, u, uu, bj),& + !$omp& shared(CIcore_instance, auxDensMatrix ) + n = omp_get_thread_num() + 1 + !$omp do schedule (dynamic) + do i=1, CIcore_instance%numberOfConfigurations + + !!if( mod( i , 50000 ) .eq. 0 ) print *, state, floor(real(100*i/CIcore_instance%numberOfConfigurations)), "%" + !!Filter very small coefficients + if( abs(CIcore_instance%eigenVectors%values(i,state)) .ge. 1E-10) then + + indexConfA(:) = CIcore_instance%allIndexConf(:,i) + + !print *, "==", indexConfA , "|", i + + + !!Diagonal contributions + do species=1, numberOfSpecies + numberOfOccupiedOrbitals = CIcore_instance%numberOfOccupiedOrbitals%values(species) + + do k=1, numberOfOccupiedOrbitals + + !!Occupied orbitals + auxDensMatrix(species,n)%values(k,k)=auxDensMatrix(species,n)%values(k,k) - CIcore_instance%eigenVectors%values(i,state)**2 + ! ciDensityMatrix(species,state)%values( k, k) = ciDensityMatrix(species,state)%values( k, k) - & + ! CIcore_instance%eigenVectors%values(i,state)**2 + + !print *, i, j, k, species + !orbital = CIcore_instance%configurations(i)%occupations(k,species) + orbital = CIcore_instance%strings(species)%values(k,indexConfA(species)) + !!Unoccupied orbitals + + auxDensMatrix(species,n)%values(orbital,orbital)=auxDensMatrix(species,n)%values(orbital,orbital) + CIcore_instance%eigenVectors%values(i,state)**2 + ! ciDensityMatrix(species,state)%values( orbital, orbital)= ciDensityMatrix(species,state)%values( orbital, orbital) + & + ! CIcore_instance%eigenVectors%values(i,state)**2 + + end do + end do + + !!Off Diagonal contributions + cilevelA = 0 + do ss = 1, numberOfSpecies + stringAinB(ss)%values = 0 + do k = 1, CIcore_instance%numberOfOccupiedOrbitals%values(ss) + + stringAinB(ss)%values(k) = CIcore_instance%orbitals(ss)%values( & + CIcore_instance%strings(ss)%values(k, CIcore_instance%allIndexConf(ss,1)), indexConfA(ss)) + end do + cilevelA(ss) = CIcore_instance%numberOfOccupiedOrbitals%values(ss) - sum ( stringAinB(ss)%values ) + end do + + jj = 0 + coupling = 0 + do ss = 1, numberOfSpecies + ssize = 0 + + indexConfB(:) = indexConfA(:) + cilevel = cilevelA + + do ci = 1, size(CIcore_instance%numberOfStrings(ss)%values, dim = 1) + cilevel(ss) = ci - 1 + do u = 1, CIcore_instance%sizeCiOrderList + if ( sum(abs(cilevel - & + CIcore_instance%ciOrderList( CIcore_instance%auxciOrderList(u), :))) == 0 ) then + uu = CIcore_instance%auxciOrderList(u) + do bj = 1 + ssize , CIcore_instance%numberOfStrings(ss)%values(ci) + ssize + indexConfB(ss) = bj + + do s=1, numberOfSpecies + jj(s) = (indexConfB(s) - CIcore_instance%numberOfStrings2(s)%values(cilevel(s)+1) + & + CIcore_instance%ciOrderSize1(uu,s) )* CIcore_instance%ciOrderSize2(uu,s) + end do + + j = sum(jj) + !print *, " ", indexConfB , "|", j, CIcore_instance%eigenVectors%values(j,state) + if ( j > i ) then + if( abs(CIcore_instance%eigenVectors%values(j,state)) .ge. 1E-10) then + + coupling = 0 + do s=1, numberOfSpecies + stringAinB(s)%values = 0 + do k = 1, CIcore_instance%numberOfOccupiedOrbitals%values(s) + stringAinB(s)%values(k) = CIcore_instance%orbitals(s)%values( & + CIcore_instance%strings(s)%values(k,indexConfA(s) ), indexConfB(s) ) + end do + coupling(s) = CIcore_instance%numberOfOccupiedOrbitals%values(s) - sum ( stringAinB(s)%values ) + end do + if (sum(coupling) == 1) then + + do s = 1, numberOfSpecies + + if ( coupling(s) == 1) then !!hmm + + !print *, " ", coupling + orbitalA = 0 + orbitalB = 0 + AA = 0 + BB = 0 + a = indexConfA(s) + b = indexConfB(s) + + do k = 1, CIcore_instance%occupationNumber(s) + if ( CIcore_instance%orbitals(s)%values( & + CIcore_instance%strings(s)%values(k,a),b) == 0 ) then + orbitalA = CIcore_instance%strings(s)%values(k,a) + AA = k + exit + end if + end do + do k = 1, CIcore_instance%occupationNumber(s) + if ( CIcore_instance%orbitals(s)%values( & + CIcore_instance%strings(s)%values(k,b),a) == 0 ) then + orbitalB = CIcore_instance%strings(s)%values(k,b) + BB = k + exit + end if + end do + + factor = (-1)**(AA-BB) + + numberOfOccupiedOrbitals = CIcore_instance%numberOfOccupiedOrbitals%values(s) + + ! print *, i, j, CIcore_instance%configurations(i)%occupations(:,specie), CIcore_instance%configurations(j)%occupations(:,specie) + ! print *, i, j, auxthisA%occupations(:,specie), auxthisB%occupations(:,specie) + ! print *, i, j, orbitalA, orbitalB, factor*CIcore_instance%eigenVectors%values(i,1)*CIcore_instance%eigenVectors%values(j,1) + + auxDensMatrix(s,n)%values( orbitalA,orbitalB)= auxDensMatrix(s,n)%values( orbitalA, orbitalB) + & + factor*CIcore_instance%eigenVectors%values(i,state)* & + CIcore_instance%eigenVectors%values(j,state) + auxDensMatrix(s,n)%values( orbitalB,orbitalA)= auxDensMatrix(s,n)%values( orbitalB, orbitalA) + & + factor*CIcore_instance%eigenVectors%values(i,state)* & + CIcore_instance%eigenVectors%values(j,state) + end if + end do + end if + end if + end if + !! here + end do + ssize = ssize + CIcore_instance%numberOfStrings(ss)%values(ci) + !exit + end if + + end do + end do + + end do + +! do j=i+1, CIcore_instance%numberOfConfigurations +! if( abs(CIcore_instance%eigenVectors%values(j,state)) .ge. 1E-12) then + +! indexConfB(:) = CIcore_instance%allIndexConf(:,j) + +! coupling = 0 +! do s=1, numberOfSpecies +! stringAinB(s)%values = 0 +! do k = 1, CIcore_instance%numberOfOccupiedOrbitals%values(s) +! stringAinB(s)%values(k) = CIcore_instance%orbitals(s)%values( & +! CIcore_instance%strings(s)%values(k,indexConfA(s) ), indexConfB(s) ) +! end do +! coupling(s) = CIcore_instance%numberOfOccupiedOrbitals%values(s) - sum ( stringAinB(s)%values ) +! end do +! +! if (sum(coupling) == 1) then +! +! do s = 1, numberOfSpecies +! +! if ( coupling(s) == 1) then +! orbitalA = 0 +! orbitalB = 0 +! AA = 0 +! BB = 0 +! a = indexConfA(s) +! b = indexConfB(s) +! +! do k = 1, CIcore_instance%occupationNumber(s) +! if ( CIcore_instance%orbitals(s)%values( & +! CIcore_instance%strings(s)%values(k,a),b) == 0 ) then +! orbitalA = CIcore_instance%strings(s)%values(k,a) +! AA = k +! exit +! end if +! end do +! do k = 1, CIcore_instance%occupationNumber(s) +! if ( CIcore_instance%orbitals(s)%values( & +! CIcore_instance%strings(s)%values(k,b),a) == 0 ) then +! orbitalB = CIcore_instance%strings(s)%values(k,b) +! BB = k +! exit +! end if +! end do +! +! factor = (-1)**(AA-BB) +! +! numberOfOccupiedOrbitals = CIcore_instance%numberOfOccupiedOrbitals%values(s) +! +! ! print *, i, j, CIcore_instance%configurations(i)%occupations(:,specie), CIcore_instance%configurations(j)%occupations(:,specie) +! ! print *, i, j, auxthisA%occupations(:,specie), auxthisB%occupations(:,specie) +! +! ! print *, i, j, orbitalA, orbitalB, factor*CIcore_instance%eigenVectors%values(i,1)*CIcore_instance%eigenVectors%values(j,1) +! +! auxDensMatrix(s,n)%values( orbitalA,orbitalB)= auxDensMatrix(s,n)%values( orbitalA, orbitalB) + & +! factor*CIcore_instance%eigenVectors%values(i,state)* & +! CIcore_instance%eigenVectors%values(j,state) +! ! ciDensityMatrix(s,state)%values( orbitalA,orbitalB)= ciDensityMatrix(s,state)%values( orbitalA, orbitalB) + & +! ! factor*CIcore_instance%eigenVectors%values(i,state)* & +! ! CIcore_instance%eigenVectors%values(j,state) +! +! auxDensMatrix(s,n)%values( orbitalB,orbitalA)= auxDensMatrix(s,n)%values( orbitalB, orbitalA) + & +! factor*CIcore_instance%eigenVectors%values(i,state)* & +! CIcore_instance%eigenVectors%values(j,state) +! +! ! ciDensityMatrix(s,state)%values( orbitalB, orbitalA)= ciDensityMatrix(s,state)%values( orbitalB, orbitalA) + & +! ! factor*CIcore_instance%eigenVectors%values(i,state)* & +! ! CIcore_instance%eigenVectors%values(j,state) +! +! end if +! end do +! end if +! end if +! end do + + end if + end do + !$omp end do nowait + !$omp end parallel + + !! Gather the parallel results + do species=1, numberOfSpecies + do n=1, CIcore_instance%nproc + ciDensityMatrix(species,state)%values = ciDensityMatrix(species,state)%values + auxDensMatrix(species,n)%values + auxDensMatrix(species,n)%values=0.0 + end do + end do + + end do + + + !! Open file - to write density matrices + unit = 29 + + file = trim(CONTROL_instance%INPUT_FILE)//"Matrices.ci" + open(unit = unit, file=trim(file), status="new", form="formatted") + + !! Building the CI reduced density matrix in the atomic orbital representation + do species=1, numberOfSpecies + speciesName = MolecularSystem_getNameOfSpecie(species) + numberOfContractions = MolecularSystem_getTotalNumberOfContractions( species ) + + do state=1, CONTROL_instance%CI_STATES_TO_PRINT + + ! print *, "CI density matrix ", trim(speciesName), state + ! call Matrix_show ( ciDensityMatrix(species,state)) + + call Matrix_constructor ( atomicDensityMatrix(species,state) , & + int(numberOfContractions,8), & + int(numberOfContractions,8), 0.0_8 ) + + do mu=1, numberOfContractions + do nu=1, numberOfContractions + do k=1, numberOfContractions + atomicDensityMatrix(species,state)%values(mu,nu) = & + atomicDensityMatrix(species,state)%values(mu,nu) + & + ciDensityMatrix(species,state)%values(k,k) *& + coefficients(species)%values(mu,k)*coefficients(species)%values(nu,k) + + do l=k+1, numberOfContractions + + atomicDensityMatrix(species,state)%values(mu,nu) = & + atomicDensityMatrix(species,state)%values(mu,nu) + & + ciDensityMatrix(species,state)%values(k,l) *& + (coefficients(species)%values(mu,k)*coefficients(species)%values(nu,l) + & + coefficients(species)%values(mu,l)*coefficients(species)%values(nu,k)) + + end do + end do + end do + end do + + ! print *, "atomic density matrix ", trim(speciesName), state + ! call Matrix_show ( atomicDensityMatrix(species,state)) + + write(auxstring,*) state + arguments(2) = speciesName + arguments(1) = "DENSITYMATRIX"//trim(adjustl(auxstring)) + + call Matrix_writeToFile ( atomicDensityMatrix(species,state), unit , arguments=arguments(1:2) ) + + end do + end do + + write(*,*) "" + write(*,*) "===============================" + write(*,*) " ONE BODY ENERGY CONTRIBUTIONS:" + write(*,*) "" + do state=1, CONTROL_instance%CI_STATES_TO_PRINT + write(*,*) " STATE: ", state + do species=1, molecularSystem_instance%numberOfQuantumSpecies + write(*,"(A38,F25.12)") trim( MolecularSystem_instance%species(species)%name ) // & + " Kinetic energy = ", sum(transpose(atomicDensityMatrix(species,state)%values)*kineticMatrix(species)%values) + write(*,"(A38,F25.12)") trim( MolecularSystem_instance%species(species)%name ) // & + "/Fixed interact. energy = ", sum(transpose(atomicDensityMatrix(species,state)%values)*attractionMatrix(species)%values) + if( CONTROL_instance%IS_THERE_EXTERNAL_POTENTIAL) & + write(*,"(A38,F25.12)") trim( MolecularSystem_instance%species(species)%name) // & + " Ext Pot energy = ", sum(transpose(atomicDensityMatrix(species,state)%values)*externalPotMatrix(species)%values) + print *, "" + end do + print *, "" + end do + + !! Natural orbitals + + if (CONTROL_instance%CI_NATURAL_ORBITALS) then + + write(*,*) "" + write(*,*) "==============================" + write(*,*) " NATURAL ORBITALS: " + write(*,*) "" + + do state=1, CONTROL_instance%CI_STATES_TO_PRINT + + write(*,*) " STATE: ", state + + do species=1, numberOfSpecies + + write(*,*) "" + write(*,*) " Natural Orbitals in state: ", state, " for: ", trim( MolecularSystem_instance%species(species)%name ) + write(*,*) "-----------------" + + numberOfContractions = MolecularSystem_getTotalNumberOfContractions( species ) + speciesName = MolecularSystem_getNameOfSpecie(species) + + + call Vector_constructor ( auxdensityEigenValues, & + int(numberOfContractions,4), 0.0_8 ) + + call Matrix_constructor ( auxdensityEigenVectors, & + int(numberOfContractions,8), & + int(numberOfContractions,8), 0.0_8 ) + + call Vector_constructor ( densityEigenValues, & + int(numberOfContractions,4), 0.0_8 ) + + call Matrix_constructor ( densityEigenVectors, & + int(numberOfContractions,8), & + int(numberOfContractions,8), 0.0_8 ) + + call Matrix_eigen ( ciDensityMatrix(species,state), auxdensityEigenValues, auxdensityEigenVectors, SYMMETRIC ) + + ! reorder and count significant occupations + k=0 + do u = 1, numberOfContractions + densityEigenValues%values(u) = auxdensityEigenValues%values(numberOfContractions - u + 1) + densityEigenVectors%values(:,u) = auxdensityEigenVectors%values(:,numberOfContractions - u + 1) + if(densityEigenValues%values(u) .ge. 5.0E-5 ) k=k+1 + end do + + !! Transform to atomic basis + densityEigenVectors%values = matmul( coefficients(species)%values, densityEigenVectors%values ) + + ! Print eigenvectors with occupation larger than 5.0E-5 + call Matrix_constructor(auxdensityEigenVectors,int(numberOfContractions,8),int(k,8),0.0_8) + do u=1, numberOfContractions + do j=1, k + auxdensityEigenVectors%values(u,j)=densityEigenVectors%values(u,j) + end do + end do + call Matrix_show( auxdensityEigenVectors, & + rowkeys = MolecularSystem_getlabelsofcontractions( species ), & + columnkeys = string_convertvectorofrealstostring( densityEigenValues ),& + flags=WITH_BOTH_KEYS) + + write(auxstring,*) state + arguments(2) = speciesName + arguments(1) = "NATURALORBITALS"//trim(adjustl(auxstring)) + + call Matrix_writeToFile ( densityEigenVectors, unit , arguments=arguments(1:2) ) + arguments(1) = "OCCUPATIONS"//trim(adjustl(auxstring)) + + call Vector_writeToFile( densityEigenValues, unit, arguments=arguments(1:2) ) + !! it's the same + !!auxdensityEigenVectors%values = 0 + + !!do mu=1, numberOfContractions + !! do nu=1, numberOfContractions + !! do k=1, numberOfContractions + !! auxdensityEigenVectors%values(mu,nu) = auxdensityEigenVectors%values(mu,nu) + & + !! densityEigenVectors%values(mu,k) * densityEigenVectors%values(nu,k)*densityEigenValues%values(k) + !! end do + !! end do + !!end do + !!print *, "atomic density matrix from natural orbitals" + !!call Matrix_show ( auxdensityEigenVectors) + write(*,"(A10,A10,A40,F17.12)") "sum of ", trim(speciesName) , "natural orbital occupations", sum(densityEigenValues%values) + + write(*,*) " End of natural orbitals in state: ", state, " for: ", trim(speciesName) + end do + end do + + + + write(*,*) "" + write(*,*) " END OF NATURAL ORBITALS" + write(*,*) "==============================" + write(*,*) "" + + end if + + close(unit) + + deallocate ( jj ) + deallocate ( indexConfB ) + deallocate ( indexConfA ) + deallocate ( coupling ) + deallocate ( cilevel ) + deallocate ( cilevelA ) + deallocate ( CIcore_instance%allIndexConf ) + deallocate ( stringAinB ) + + deallocate( coefficients, atomicDensityMatrix, ciDensityMatrix ) + + !$ timeDB = omp_get_wtime() + !$ write(*,"(A,F10.4,A4)") "** TOTAL Elapsed Time for Building density matrices: ", timeDB - timeDA ," (s)" + + + end if + + ! print *, i, i, orbital, orbital, CIcore_instance%eigenVectors%values(i,1)**2 + + ! do mu = 1 , numberOfOrbitals + ! do nu = 1 , numberOfOrbitals + + ! densityMatrix%values(mu,nu) = & + ! densityMatrix%values(mu,nu) + & + ! CIcore_instance%eigenVectors%values(i,state)**2 *& + ! coefficients%values(mu,orbital)*coefficients%values(nu,orbital) + ! end do + ! end do + + !!off-Diagonal ground state + + ! do mu = 1 , numberOfOrbitals + ! do nu = 1 , numberOfOrbitals + + ! densityMatrix%values(mu,nu) = & + ! densityMatrix%values(mu,nu) + & + ! factor *& + ! CIcore_instance%eigenVectors%values(i,state) *& + ! CIcore_instance%eigenVectors%values(j,state) *& + ! (coefficients%values(mu,orbitalA)*coefficients%values(nu,orbitalB) + coefficients%values(mu,orbitalB)*coefficients%values(nu,orbitalA)) + ! end do + ! end do + + ! call Vector_constructor(eigenValues, numberOfOrbitals) + ! call Matrix_constructor(eigenVectors, int(numberOfOrbitals,8), int(numberOfOrbitals,8)) + ! call Matrix_eigen(ciOccupationMatrix, eigenValues, eigenVectors, SYMMETRIC) + + ! print *, "Diagonal sum", sum(eigenValues%values) + ! call Vector_show(eigenValues) + + ! call Matrix_show(eigenVectors) + ! print *, arguments(1:2) + ! call Matrix_show ( densityMatrix ) + + ! call Matrix_constructor ( ciOccupationNumbers , int(numberOfOrbitals,8) , & + ! int(CONTROL_instance%CI_STATES_TO_PRINT,8), 0.0_8 ) + + ! do state=1, CONTROL_instance%CI_STATES_TO_PRINT + ! sumaPrueba=0 + ! do j=1, numberOfOccupiedOrbitals + ! ciOccupationNumbers%values(j,state) = 1.0 + ! end do + + ! ! !Get occupation numbers from each configuration contribution + + ! do i=1, CIcore_instance%numberOfConfigurations + ! do j=1, numberOfOccupiedOrbitals + + ! !! Occupied orbitals + ! ciOccupationNumbers%values( j, state)= ciOccupationNumbers%values( j, state) - & + ! CIcore_instance%eigenVectors%values(i,state)**2 + ! !! Unoccupied orbitals + ! orbital = CIcore_instance%configurations(i)%occupations(j,specie) + + ! ciOccupationNumbers%values( orbital, state)= ciOccupationNumbers%values( orbital, state) + & + ! CIcore_instance%eigenVectors%values(i,state)**2 + + ! ! print *, j, orbital, CIcore_instance%eigenVectors%values(i,state)**2 + ! ! sumaPrueba=sumaPrueba+CIcore_instance%eigenVectors%values(i,state)**2 + ! end do + ! ! end if + + ! end do + + ! ! print *, "suma", sumaPrueba + ! !Build a new density matrix (P) in atomic orbitals + + ! call Matrix_constructor ( densityMatrix , & + ! int(numberOfOrbitals,8), & + ! int(numberOfOrbitals,8), 0.0_8 ) + + ! wfnFile = "lowdin.wfn" + ! wfnUnit = 20 + + ! open(unit=wfnUnit, file=trim(wfnFile), status="old", form="unformatted") + + ! arguments(2) = speciesName + ! arguments(1) = "COEFFICIENTS" + + ! coefficients = Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfOrbitals,4), & + ! columns= int(numberOfOrbitals,4), binary=.true., arguments=arguments(1:2)) + + ! close(wfnUnit) + + ! do mu = 1 , numberOfOrbitals + ! do nu = 1 , numberOfOrbitals + ! do k = 1 , numberOfOrbitals + + ! densityMatrix%values(mu,nu) = & + ! densityMatrix%values(mu,nu) + & + ! ciOccupationNumbers%values(k, state)**2* & + ! coefficients%values(mu,k)*coefficients%values(nu,k) + ! end do + ! end do + ! end do + + ! write(auxstring,*) state + ! arguments(2) = speciesName + ! arguments(1) = "DENSITYMATRIX"//trim(adjustl(auxstring)) + + ! call Matrix_writeToFile ( densityMatrix, unit , arguments=arguments(1:2) ) + + ! print *, arguments(1:2) + ! call Matrix_show ( densityMatrix ) + + ! call Matrix_destructor(coefficients) + ! call Matrix_destructor(densityMatrix) + + + ! end do + + ! !Write occupation numbers to file + ! write (6,"(T8,A10,A20)") trim(MolecularSystem_getNameOfSpecie(specie)),"OCCUPATIONS:" + + ! call Matrix_show ( ciOccupationNumbers ) + + ! arguments(2) = speciesName + ! arguments(1) = "OCCUPATIONS" + + ! call Matrix_writeToFile ( ciOccupationNumbers, unit , arguments=arguments(1:2) ) + + ! call Matrix_destructor(ciOccupationNumbers) + + end subroutine CImod_densityMatrices + + !> + !! @brief Maneja excepciones de la clase + !< + subroutine CImod_exception( typeMessage, description, debugDescription) + implicit none + integer :: typeMessage + character(*) :: description + character(*) :: debugDescription + + type(Exception) :: ex + + call Exception_constructor( ex , typeMessage ) + call Exception_setDebugDescription( ex, debugDescription ) + call Exception_setDescription( ex, description ) + call Exception_show( ex ) + call Exception_destructor( ex ) + + end subroutine CImod_exception + + !> + !! @brief Destructor por omision + !! + !! @param this + !< + subroutine CImod_destructor() + implicit none + integer i,j,m,n,p,q,c + integer numberOfSpecies + integer :: isLambdaEqual1 + + numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() + + !!Destroy configurations + !!Ground State + if (allocated(CIcore_instance%configurations)) then + c=1 + call Configuration_destructor(CIcore_instance%configurations(c) ) + + do c=2, CIcore_instance%numberOfConfigurations + call Configuration_destructor(CIcore_instance%configurations(c) ) + end do + + if (allocated(CIcore_instance%configurations)) deallocate(CIcore_instance%configurations) + end if + + call Matrix_destructor(CIcore_instance%hamiltonianMatrix) + call Vector_destructorInteger (CIcore_instance%numberOfOccupiedOrbitals) + call Vector_destructorInteger (CIcore_instance%numberOfOrbitals) + call Vector_destructor (CIcore_instance%lambda) + + CIcore_instance%isInstanced=.false. + + end subroutine CImod_destructor + + +end module CImod_ + + diff --git a/src/CI/CImolpro b/src/CI/CImolpro new file mode 100644 index 00000000..647a9ad1 --- /dev/null +++ b/src/CI/CImolpro @@ -0,0 +1,311 @@ + !> + !! @brief Muestra informacion del objeto + !! + !! @param this + !< +! subroutine CI_core_printTransformedIntegralsToFile() +! implicit none +! +!! type(TransformIntegrals) :: repulsionTransformer +! integer :: numberOfSpecies +! integer :: i,j,m,n,mu,nu +! integer :: a,b,r,s,u, auxIndex +! integer :: z +! integer :: stats, recNum +! character(10) :: nameOfSpecie, auxNameOfSpecie +! character(10) :: nameOfOtherSpecie +! integer :: ocupationNumber +! integer :: ocupationNumberOfOtherSpecie +! integer :: numberOfContractions +! integer :: numberOfContractionsOfOtherSpecie +! type(Matrix) :: auxMatrix +! type(Matrix) :: molecularCouplingMatrix +! type(Matrix) :: molecularExtPotentialMatrix +! +! integer :: spin +! +! real(8) :: totalCoupEnergy +! real(8) :: fixedPotEnergy +! real(8) :: fixedIntEnergy +! real(8) :: KineticEnergy +! real(8) :: RepulsionEnergy +! real(8) :: couplingEnergy + + +! numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() +! +! print *,"" +! print *,"BEGIN INTEGRALS TRANFORMATION:" +! print *,"========================================" +! print *,"" +! print *,"--------------------------------------------------" +! print *," Algorithm Four-index integral tranformation" +! print *," Yamamoto, Shigeyoshi; Nagashima, Umpei. " +! print *," Computer Physics Communications, 2005, 166, 58-65" +! print *,"--------------------------------------------------" +! print *,"" +! +! totalCoupEnergy = 0.0_8 +! fixedPotEnergy = 0.0_8 +! fixedIntEnergy = 0.0_8 +! KineticEnergy = 0.0_8 +! RepulsionEnergy = 0.0_8 +! couplingEnergy = 0.0_8 +! spin = 0 +! +! do i=1, numberOfSpecies +! nameOfSpecie= trim( MolecularSystem_getNameOfSpecie( i ) ) +! numberOfContractions = MolecularSystem_getTotalNumberOfContractions( i ) +! spin = MolecularSystem_getMultiplicity(i) - 1 +! +! if(trim(nameOfSpecie) /= "E-BETA" ) then +! +! if(trim(nameOfSpecie) /= "U-" ) then +! +! open(unit=35, file="FCIDUMP-"//trim(nameOfSpecie)//".com", form="formatted", status="replace") +! +! write(35,"(A)")"gprint basis" +! write(35,"(A)")"memory 1000 M" +! write(35,"(A)")"cartesian" +! write(35,"(A)")"gthresh twoint=1e-12 prefac=1e-14 energy=1e-10 edens=1e-10 zero=1e-12" +! write(35,"(A)")"basis={" +! call CI_core_printBasisSetToFile(35) +! write(35,"(A)")"}" +! +! write(35,"(A)")"symmetry nosym" +! write(35,"(A)")"angstrom" +! write(35,"(A)")"geometry={" +! call CI_core_printGeometryToFile(35) +! write(35,"(A)")"}" +! +! write(35,"(A)")"import 21500.2 "//trim(trim(CONTROL_instance%INPUT_FILE)//trim(nameOfSpecie)//"."//"jcoup") +! write(35,"(A)")"import 21510.2 "//trim(trim(CONTROL_instance%INPUT_FILE)//trim(nameOfSpecie)//"."//"icoup") +! write(35,"(A)")"import 21520.2 "//trim(trim(CONTROL_instance%INPUT_FILE)//trim(nameOfSpecie)//"."//"kin") +! write(35,"(A)")"import 21530.2 "//trim(trim(CONTROL_instance%INPUT_FILE)//trim(nameOfSpecie)//"."//"coeff") +! +! if(trim(nameOfSpecie) == "E-ALPHA") then +! +! write(35,"(A)")"import 21550.2 "//trim(trim(CONTROL_instance%INPUT_FILE)//"E-BETA"//"."//"coeff") +! +! end if +! +! write(35,"(A)")"import 21540.2 "//trim(trim(CONTROL_instance%INPUT_FILE)//trim(nameOfSpecie)//"."//"dens") +! !write(35,"(A)")"import 21560.2 "//trim(trim(CONTROL_instance%INPUT_FILE)//trim(nameOfSpecie)//"."//"pot") +! +! write(35,"(A)")"{matrop" +! write(35,"(A)")"load Jcoup, SQUARE 21500.2" +! write(35,"(A)")"load Icoup, SQUARE 21510.2" +! write(35,"(A)")"load K, SQUARE 21520.2" +! !write(35,"(A)")"load Pot, SQUARE 21560.2" +! write(35,"(A)")"add H01, K Icoup Jcoup"! Pot" +! write(35,"(A)")"save H01, 21511.2 H0" +! write(35,"(A)")"}" +! +! if(trim(nameOfSpecie) == "E-ALPHA") then +! write(35,"(A)")"{matrop" +! write(35,"(A)")"load Ca, SQUARE 21530.2" +! write(35,"(A)")"load Cb, SQUARE 21550.2" +! write(35,"(A)")"save Ca, 2100.1 ORBITALS alpha" +! write(35,"(A)")"save Cb, 2100.1 ORBITALS beta" +! write(35,"(A)")"}" +! else +! write(35,"(A)")"{matrop" +! write(35,"(A)")"load C, SQUARE 21530.2" +! write(35,"(A)")"save C, 2100.1 ORBITALS" +! write(35,"(A)")"}" +! end if +! +! write(35,"(A)")"{matrop" +! write(35,"(A)")"load D, SQUARE 21540.2" +! write(35,"(A)")"save D, 21400.1 DENSITY" +! write(35,"(A)")"}" +! +! +! ! write(35,"(A,I3,A,I3,A,I3,A1)")"$FCI NORB=",numberOfContractions, ",NELEC=", MolecularSystem_getNumberOfParticles(i)-spin, ", MS2=", spin,"," +! ! +! ! write(35,"(A)",advance="no") "ORBSYM=" +! ! do z=1, numberOfContractions +! ! write(35,"(I1,A1)",advance="no") 1,"," +! ! end do +! ! write(35,"(A)") "" +! ! +! ! write(35, "(A,I3,A,I9)") "ISYM=",1, ",MEMORY=", 200000000 +! ! +! ! write(35, "(A)") "$" +! ! +! ! print *, "FOUR CENTER INTEGRALS FOR SPECIE: ", trim(nameOfSpecie) +! ! +! ! recNum = 0 +! ! do a = 1, numberOfContractions +! ! n = a +! ! do b=a, numberOfContractions +! ! u = b +! ! do r = n, numberOfContractions +! ! do s = u, numberOfContractions +! ! +! ! auxIndex = IndexMap_tensorR4ToVector( a, b, r, s, numberOfContractions ) +! ! write(35,"(F20.10,4I3)") CI_core_instance%fourCenterIntegrals(i,i)%values(auxIndex, 1), a, b, r, s +! ! +! ! end do +! ! u=r+1 +! ! end do +! ! end do +! ! end do +! ! +! ! +! ! print *, "TWO CENTER TRANSFORMED INTEGRALS FOR SPECIE: ", trim(nameOfSpecie) +! ! +! ! do m=1,numberOfContractions +! ! do n=1, m +! ! write(35,"(F20.10,4I3)") CI_core_instance%twoCenterIntegrals(i)%values(m,n), m, n, 0, 0 +! ! end do +! ! end do +! +! !!Calculating the core energy.... +! +! +! +! totalCoupEnergy = MolecularSystem_instance%totalCouplingEnergy +! fixedPotEnergy = MolecularSystem_instance%puntualInteractionEnergy +! +! do j = 1, numberOfSpecies +! +! auxNameOfSpecie= trim( MolecularSystem_getNameOfSpecie( j ) ) +! +! if(trim(auxNameOfSpecie) == "E-ALPHA" .or. trim(auxNameOfSpecie) == "E-BETA" .or. trim(auxNameOfSpecie) == "e-") cycle +! +! fixedIntEnergy = fixedIntEnergy + MolecularSystem_instance%quantumPuntualInteractionEnergy(j) +! KineticEnergy = KineticEnergy + MolecularSystem_instance%kineticEnergy(j) +! RepulsionEnergy = RepulsionEnergy + MolecularSystem_instance%repulsionEnergy(j) +! couplingEnergy = couplingEnergy + MolecularSystem_instance%couplingEnergy(j) +! +! end do +! +! !!COMO SEA QUE SE META LA ENERGIA DE CORE +! !write(35,"(F20.10,4I3)") (couplingEnergy-totalCoupEnergy+fixedPotEnergy+fixedIntEnergy+KineticEnergy+RepulsionEnergy), 0, 0, 0, 0 +! +! print*, "COREENERGY ", (couplingEnergy-totalCoupEnergy+fixedPotEnergy+fixedIntEnergy+KineticEnergy+RepulsionEnergy) +! +! write(35,"(A)")"{hf" +! write(35,"(A)")"maxit 250" +! write(35,"(A10,I2,A1,A6,I2,A1,A6,I3)")"wf spin=", spin, ",", "charge=",0, ",", "elec=", MolecularSystem_getNumberOfParticles(i)-spin +! write(35,"(A)")"start 2100.1" +! write(35,"(A)")"}" +! +! +! write(35,"(A)")"{fci" +! write(35,"(A)")"maxit 250" +! write(35,"(A)")"dm 21400.1, IGNORE_ERROR" +! write(35,"(A)")"orbit 2100.1, IGNORE_ERROR" +! write(35,"(A10,I2,A1,A6,I2,A1,A6,I3)")"wf spin=", spin, ",", "charge=",0, ",", "elec=", MolecularSystem_getNumberOfParticles(i)-spin +! ! write(35,"(A)")"print, orbital=2 integral = 2" +! ! write(35,"(A)")"CORE" +! write(35,"(A)")"}" +! +! write(35,"(A)")"{matrop" +! write(35,"(A)")"load D, DEN, 21400.1" +! ! write(35,"(A)")"print D" +! write(35,"(A)")"natorb Norb, D" +! write(35,"(A)")"save Norb, 21570.2" +! ! write(35,"(A)")"print Norb" +! write(35,"(A)")"}" +! +! write(35,"(A)")"put molden "//trim(trim(CONTROL_instance%INPUT_FILE)//trim(nameOfSpecie)//"."//"molden")//"; orb, 21570.2" +! +! close(35) +! +! print*, "" +! +! stats = system("molpro "//"FCIDUMP-"//trim(nameOfSpecie)//".com ") +! stats = system("cat "//"FCIDUMP-"//trim(nameOfSpecie)//".out ") +! +! print*, "" +! +! print *,"END" +! +! end if +! +! end if +! +! end do + +! end subroutine CI_core_printTransformedIntegralsToFile + +! subroutine CI_core_printGeometryToFile(unit) +! implicit none +! integer :: unit +! +! integer :: i +! integer :: from, to +! real(8) :: origin(3) +! character(50) :: auxString +! +! +! do i = 1, MolecularSystem_getTotalNumberOfParticles() +! +! origin = MolecularSystem_getOrigin( iterator = i ) * AMSTRONG +! auxString = trim( MolecularSystem_getNickName( iterator = i ) ) +! +! if( String_findSubstring( trim( auxString ), "e-") == 1 ) then +! if( String_findSubstring( trim( auxString ), "BETA") > 1 ) then +! cycle +! end if +! +! from =String_findSubstring( trim(auxString), "[") +! to = String_findSubstring( trim(auxString), "]") +! auxString = auxString(from+1:to-1) +! +! else if( String_findSubstring( trim( auxString ), "_") /= 0 ) then +! cycle +! end if +! +! +! write (unit,"(A10,3F20.10)") trim( auxString ), origin(1), origin(2), origin(3) +! +! end do + +! end subroutine CI_core_printGeometryToFile + + +! subroutine CI_core_printBasisSetToFile(unit) +! implicit none +! +! integer :: unit +! +! integer :: i, j +! character(16) :: auxString +! +! +! do i =1, MolecularSystem_instance%numberOfQuantumSpecies +! +! auxString=trim( Map_getKey( MolecularSystem_instance%speciesID, iterator=i ) ) +! +! if( String_findSubstring( trim(auxString), "e-") == 1 ) then +! +! if( String_findSubstring( trim(auxString), "BETA") > 1 ) then +! +! cycle +! +! end if +! +! +! end if +! +! if(trim(auxString)=="U-") cycle +! +! do j =1, size(MolecularSystem_instance%particlesPtr) +! +! if ( trim(MolecularSystem_instance%particlesPtr(j)%symbol) == trim( Map_getKey( MolecularSystem_instance%speciesID, iterator=i ) ) & +! .and. MolecularSystem_instance%particlesPtr(j)%isQuantum ) then +! +! call BasisSet_showInMolproForm( MolecularSystem_instance%particlesPtr(j)%basis, trim(MolecularSystem_instance%particlesPtr(j)%nickname), unit=unit ) +! +! end if +! +! end do +! +! end do + +! end subroutine CI_core_printBasisSetToFile + + diff --git a/src/CI/ConfigurationInteraction.f90 b/src/CI/ConfigurationInteraction.f90 deleted file mode 100644 index 10457a9d..00000000 --- a/src/CI/ConfigurationInteraction.f90 +++ /dev/null @@ -1,5202 +0,0 @@ -!****************************************************************************** -!! This code is part of LOWDIN Quantum chemistry package -!! -!! this program has been developed under direction of: -!! -!! UNIVERSIDAD NACIONAL DE COLOMBIA" -!! PROF. ANDRES REYES GROUP" -!! http://www.qcc.unal.edu.co" -!! -!! UNIVERSIDAD DE GUADALAJARA" -!! PROF. ROBERTO FLORES GROUP" -!! http://www.cucei.udg.mx/~robertof" -!! -!! AUTHORS -!! E.F. POSADA. UNIVERSIDAD NACIONAL DE COLOMBIA -!! S.A. GONZALEZ. UNIVERSIDAD NACIONAL DE COLOMBIA -!! F.S. MONCADA. UNIVERSIDAD NACIONAL DE COLOMBIA -!! J. ROMERO. UNIVERSIDAD NACIONAL DE COLOMBIA -!! -!! CONTRIBUTORS -!! N.F.AGUIRRE. UNIVERSIDAD NACIONAL DE COLOMBIA -!! GABRIEL MERINO. UNIVERSIDAD DE GUANAJUATO -!! J.A. CHARRY UNIVERSIDAD NACIONAL DE COLOMBIA -!! -!! -!! Todos los derechos reservados, 2011 -!! -!!****************************************************************************** - -module ConfigurationInteraction_ - use Exception_ - use Matrix_ - use Vector_ - use MolecularSystem_ - use Configuration_ - use ReadTransformedIntegrals_ - use MolecularSystem_ - use String_ - use IndexMap_ - use InputCI_ - use omp_lib - ! use ArpackInterface_ - use JadamiluInterface_ - implicit none - - !> - !! @brief Configuration Interaction Module, works in spin orbitals - !! - !! @author felix - !! - !! Creation data : 07-24-12 - !! - !! History change: - !! - !! - 07-24-12 : Felix Moncada ( fsmoncadaa@unal.edu.co ) - !! -# description. - !! - 07-09-16 : Jorge Charry ( jacharrym@unal.edu.co ) - !! -# Add CIS, and Fix CISD. - !! - MM-DD-YYYY : authorOfChange ( email@server ) - !! -# description - !! - !< - - type, public :: ConfigurationInteraction - logical :: isInstanced - integer :: numberOfSpecies - type(matrix) :: hamiltonianMatrix - type(ivector8) :: auxIndexCIMatrix - type(matrix) :: eigenVectors - type(matrix) :: initialEigenVectors - type(vector8) :: initialEigenValues - integer(8) :: numberOfConfigurations - integer :: nproc - type(ivector) :: numberOfCoreOrbitals - type(ivector) :: numberOfOccupiedOrbitals - type(ivector) :: numberOfOrbitals - type(vector) :: numberOfSpatialOrbitals2 - type(vector8) :: eigenvalues - type(vector) :: lambda !!Number of particles per orbital, module only works for 1 or 2 particles per orbital - type(matrix), allocatable :: fourCenterIntegrals(:,:) - type(matrix), allocatable :: twoCenterIntegrals(:) - type(imatrix8), allocatable :: twoIndexArray(:) - type(imatrix8), allocatable :: fourIndexArray(:) - type(imatrix), allocatable :: strings(:) !! species, conf, occupations - type(imatrix1), allocatable :: orbitals(:) !! species, conf, occupations - integer, allocatable :: sumstrings(:) !! species - type(ivector), allocatable :: auxstring(:,:) !! species, occupations - type(ivector8), allocatable :: numberOfStrings(:) !! species, excitation level, number of strings - type(ivector8), allocatable :: numberOfStrings2(:) !! species, excitation level, number of strings - - !! species, threads - type(imatrix), allocatable :: couplingMatrix(:,:) - type(Vector), allocatable :: couplingMatrixEnergyOne(:,:) -! type(matrix), allocatable :: couplingMatrixEnergyTwo(:) - type(ivector), allocatable :: couplingMatrixFactorOne(:,:) - type(ivector), allocatable :: couplingMatrixOrbOne(:,:) - type(imatrix), allocatable :: nCouplingOneTwo(:,:) - type(imatrix), allocatable :: nCouplingSize(:,:) - - type(ivector1), allocatable :: couplingOrderList(:,:) - type(ivector1), allocatable :: couplingOrderIndex(:,:) - - integer, allocatable :: ciOrderList(:,:) - integer, allocatable :: auxciOrderList(:) - integer :: sizeCiOrderList - integer(8), allocatable :: ciOrderSize1(:,:) - integer(8), allocatable :: ciOrderSize2(:,:) - integer(4), allocatable :: allIndexConf(:,:) !! species, total number of configurations - - integer :: ncouplingOrderOne - integer :: ncouplingOrderTwo - integer :: ncouplingOrderTwoDiff - - type(imatrix) :: auxConfigurations !! species, configurations for initial hamiltonian - type(configuration), allocatable :: configurations(:) - integer(2), allocatable :: auxconfs(:,:,:) ! nconf, species, occupation - type (Vector8) :: diagonalHamiltonianMatrix - type (Vector8) :: diagonalHamiltonianMatrix2 - real(8) :: totalEnergy - integer, allocatable :: totalNumberOfContractions(:) - integer, allocatable :: occupationNumber(:) - integer, allocatable :: recursionVector1(:) - integer, allocatable :: recursionVector2(:) - integer, allocatable :: CILevel(:) - integer, allocatable :: pindexConf(:,:) - integer :: maxCILevel - type (Matrix) :: initialHamiltonianMatrix - type (Matrix) :: initialHamiltonianMatrix2 - character(20) :: level - real(8) :: timeA(7) - real(8) :: timeB(7) - - end type ConfigurationInteraction - - type, public :: HartreeFock - real(8) :: totalEnergy - real(8) :: puntualInteractionEnergy - type(matrix) :: coefficientsofcombination - type(matrix) :: HcoreMatrix - end type HartreeFock - - integer, allocatable :: Conf_occupationNumber(:) - type(ConfigurationInteraction) :: ConfigurationInteraction_instance - type(HartreeFock) :: HartreeFock_instance - - public :: & - ConfigurationInteraction_constructor, & - ConfigurationInteraction_destructor, & - ConfigurationInteraction_getTotalEnergy, & - ConfigurationInteraction_run, & - ConfigurationInteraction_showEigenVectors, & - ConfigurationInteraction_densityMatrices, & - ConfigurationInteraction_show - - private - -contains - - - !> - !! @brief Constructor por omision - !! - !! @param this - !< - subroutine ConfigurationInteraction_constructor(level) - implicit none - character(*) :: level - - integer :: numberOfSpecies - integer :: i,j,k,l,m,n,p,q,cc,r,s,el, nproc - integer(8) :: c - integer :: ma,mb,mc,md,me,pa,pb,pc,pd,pe - integer :: isLambdaEqual1,lambda,otherlambda - type(vector) :: occupiedCode - type(vector) :: unoccupiedCode - real(8) :: totalEnergy - - character(50) :: wfnFile - integer :: wfnUnit - character(50) :: nameOfSpecie - integer :: numberOfContractions - character(50) :: arguments(2) - - wfnFile = "lowdin.wfn" - wfnUnit = 20 - - !! Open file for wavefunction - open(unit=wfnUnit, file=trim(wfnFile), status="old", form="unformatted") - - !! Load results... - call Vector_getFromFile(unit=wfnUnit, binary=.true., value=HartreeFock_instance%totalEnergy, & - arguments=["TOTALENERGY"]) - call Vector_getFromFile(unit=wfnUnit, binary=.true., value=HartreeFock_instance%puntualInteractionEnergy, & - arguments=["PUNTUALINTERACTIONENERGY"]) - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - ConfigurationInteraction_instance%numberOfSpecies = numberOfSpecies - - - do i=1, numberOfSpecies - nameOfSpecie= trim( MolecularSystem_getNameOfSpecie( i ) ) - numberOfContractions = MolecularSystem_getTotalNumberOfContractions( i ) - - arguments(2) = nameOfSpecie - arguments(1) = "HCORE" - HartreeFock_instance%HcoreMatrix = & - Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfContractions,4), & - columns= int(numberOfContractions,4), binary=.true., arguments=arguments(1:2)) - - arguments(1) = "COEFFICIENTS" - HartreeFock_instance%coefficientsofcombination = & - Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfContractions,4), & - columns= int(numberOfContractions,4), binary=.true., arguments=arguments(1:2)) - end do - - ConfigurationInteraction_instance%isInstanced=.true. - ConfigurationInteraction_instance%level=level - ConfigurationInteraction_instance%numberOfConfigurations=0 - - call Vector_constructorInteger (ConfigurationInteraction_instance%numberOfCoreOrbitals, numberOfSpecies) - call Vector_constructorInteger (ConfigurationInteraction_instance%numberOfOccupiedOrbitals, numberOfSpecies) - call Vector_constructorInteger (ConfigurationInteraction_instance%numberOfOrbitals, numberOfSpecies) - call Vector_constructor (ConfigurationInteraction_instance%lambda, numberOfSpecies) - call Vector_constructor (ConfigurationInteraction_instance%numberOfSpatialOrbitals2, numberOfSpecies) - - ConfigurationInteraction_instance%nproc = omp_get_max_threads() - - if ( allocated (ConfigurationInteraction_instance%strings ) ) & - deallocate ( ConfigurationInteraction_instance%strings ) - allocate ( ConfigurationInteraction_instance%strings ( numberOfSpecies ) ) - - if ( allocated (ConfigurationInteraction_instance%orbitals ) ) & - deallocate ( ConfigurationInteraction_instance%orbitals ) - allocate ( ConfigurationInteraction_instance%orbitals ( numberOfSpecies ) ) - - if ( allocated (ConfigurationInteraction_instance%auxstring ) ) & - deallocate ( ConfigurationInteraction_instance%auxstring ) - allocate ( ConfigurationInteraction_instance%auxstring ( ConfigurationInteraction_instance%nproc, numberOfSpecies ) ) - - if ( allocated (ConfigurationInteraction_instance%couplingMatrix ) ) & - deallocate ( ConfigurationInteraction_instance%couplingMatrix ) - allocate ( ConfigurationInteraction_instance%couplingMatrix ( numberOfSpecies, ConfigurationInteraction_instance%nproc ) ) - - if ( allocated (ConfigurationInteraction_instance%couplingMatrixEnergyOne ) ) & - deallocate ( ConfigurationInteraction_instance%couplingMatrixEnergyOne ) - allocate ( ConfigurationInteraction_instance%couplingMatrixEnergyOne ( numberOfSpecies, ConfigurationInteraction_instance%nproc ) ) - - if ( allocated (ConfigurationInteraction_instance%couplingMatrixFactorOne ) ) & - deallocate ( ConfigurationInteraction_instance%couplingMatrixFactorOne ) - allocate ( ConfigurationInteraction_instance%couplingMatrixFactorOne ( numberOfSpecies, ConfigurationInteraction_instance%nproc ) ) - - if ( allocated (ConfigurationInteraction_instance%couplingMatrixOrbOne ) ) & - deallocate ( ConfigurationInteraction_instance%couplingMatrixOrbOne ) - allocate ( ConfigurationInteraction_instance%couplingMatrixOrbOne ( numberOfSpecies, ConfigurationInteraction_instance%nproc ) ) - - if ( allocated (ConfigurationInteraction_instance%nCouplingOneTwo ) ) & - deallocate ( ConfigurationInteraction_instance%nCouplingOneTwo ) - allocate ( ConfigurationInteraction_instance%nCouplingOneTwo ( numberOfSpecies, ConfigurationInteraction_instance%nproc ) ) - - if ( allocated (ConfigurationInteraction_instance%nCouplingSize ) ) & - deallocate ( ConfigurationInteraction_instance%nCouplingSize ) - allocate ( ConfigurationInteraction_instance%nCouplingSize ( numberOfSpecies, ConfigurationInteraction_instance%nproc ) ) - - if ( allocated (ConfigurationInteraction_instance%numberOfStrings ) ) & - deallocate ( ConfigurationInteraction_instance%numberOfStrings ) - allocate ( ConfigurationInteraction_instance%numberOfStrings ( numberOfSpecies ) ) - - if ( allocated (ConfigurationInteraction_instance%numberOfStrings2 ) ) & - deallocate ( ConfigurationInteraction_instance%numberOfStrings2 ) - allocate ( ConfigurationInteraction_instance%numberOfStrings2 ( numberOfSpecies ) ) - - if ( allocated (ConfigurationInteraction_instance%sumstrings ) ) & - deallocate ( ConfigurationInteraction_instance%sumstrings ) - allocate ( ConfigurationInteraction_instance%sumstrings ( numberOfSpecies ) ) - - if ( allocated ( ConfigurationInteraction_instance%totalNumberOfContractions ) ) & - deallocate ( ConfigurationInteraction_instance%totalNumberOfContractions ) - allocate ( ConfigurationInteraction_instance%totalNumberOfContractions (numberOfSpecies ) ) - - if ( allocated ( ConfigurationInteraction_instance%occupationNumber ) ) & - deallocate ( ConfigurationInteraction_instance%occupationNumber ) - allocate ( ConfigurationInteraction_instance%occupationNumber (numberOfSpecies ) ) - - if ( allocated ( ConfigurationInteraction_instance%recursionVector1 ) ) & - deallocate ( ConfigurationInteraction_instance%recursionVector1 ) - allocate ( ConfigurationInteraction_instance%recursionVector1 (numberOfSpecies ) ) - - if ( allocated ( ConfigurationInteraction_instance%recursionVector2 ) ) & - deallocate ( ConfigurationInteraction_instance%recursionVector2 ) - allocate ( ConfigurationInteraction_instance%recursionVector2 (numberOfSpecies ) ) - - if ( allocated ( ConfigurationInteraction_instance%CILevel) ) & - deallocate ( ConfigurationInteraction_instance%CILevel ) - allocate ( ConfigurationInteraction_instance%CILevel (numberOfSpecies ) ) - - if ( allocated ( ConfigurationInteraction_instance%pindexConf) ) & - deallocate ( ConfigurationInteraction_instance%pindexConf ) - allocate ( ConfigurationInteraction_instance%pindexConf (numberOfSpecies, ConfigurationInteraction_instance%nproc ) ) - - if ( allocated ( Conf_occupationNumber ) ) & - deallocate ( Conf_occupationNumber ) - allocate ( Conf_occupationNumber (numberOfSpecies ) ) - - - ConfigurationInteraction_instance%recursionVector1 = 1 - ConfigurationInteraction_instance%recursionVector2 = 0 - - ConfigurationInteraction_instance%recursionVector1(numberOfSpecies) = 0 - ConfigurationInteraction_instance%recursionVector2(numberOfSpecies) = 1 - - ConfigurationInteraction_instance%pindexConf = 0 - - do i=1, numberOfSpecies - !! We are working in spin orbitals not in spatial orbitals! - ConfigurationInteraction_instance%lambda%values(i) = MolecularSystem_getLambda( i ) - ConfigurationInteraction_instance%numberOfCoreOrbitals%values(i) = 0 - ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) = int (MolecularSystem_getOcupationNumber( i )* & - ConfigurationInteraction_instance%lambda%values(i)) - ConfigurationInteraction_instance%numberOfOrbitals%values(i) = MolecularSystem_getTotalNumberOfContractions( i )* & - ConfigurationInteraction_instance%lambda%values(i) - ConfigurationInteraction_instance%numberOfSpatialOrbitals2%values(i) = MolecularSystem_getTotalNumberOfContractions( i ) - ConfigurationInteraction_instance%numberOfSpatialOrbitals2%values(i) = & - ConfigurationInteraction_instance%numberOfSpatialOrbitals2%values(i) * ( & - ConfigurationInteraction_instance%numberOfSpatialOrbitals2%values(i) + 1 ) / 2 - - - ConfigurationInteraction_instance%totalNumberOfContractions( i ) = MolecularSystem_getTotalNumberOfContractions( i ) - ConfigurationInteraction_instance%occupationNumber( i ) = int( MolecularSystem_instance%species(i)%ocupationNumber ) - Conf_occupationNumber( i ) = MolecularSystem_instance%species(i)%ocupationNumber - - - !! Take the active space from input - if ( InputCI_Instance(i)%coreOrbitals /= 0 ) then - ConfigurationInteraction_instance%numberOfCoreOrbitals%values(i) = InputCI_Instance(i)%coreOrbitals - end if - if ( InputCI_Instance(i)%activeOrbitals /= 0 ) then - ConfigurationInteraction_instance%numberOfOrbitals%values(i) = InputCI_Instance(i)%activeOrbitals * & - ConfigurationInteraction_instance%lambda%values(i) + & - ConfigurationInteraction_instance%numberOfCoreOrbitals%values(i) - end if - - !!Uneven occupation number = alpha - !!Even occupation number = beta - end do - - - call Configuration_globalConstructor() - - close(wfnUnit) - - end subroutine ConfigurationInteraction_constructor - - subroutine ConfigurationInteraction_buildStrings() - implicit none - - integer(8) :: a,b,c,c1,c2,aa,d - integer :: ci, oci, cilevel,maxcilevel - integer :: u,uu,vv, p, nn,z - integer :: i,j - integer :: numberOfSpecies, auxnumberOfSpecies,s - type(ivector) :: order - integer(8) :: ssize - real(8) :: timeA, timeB - type(vector), allocatable :: occupiedCode(:) - type(vector), allocatable :: unoccupiedCode(:) - - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - - if ( allocated( occupiedCode ) ) deallocate( occupiedCode ) - allocate (occupiedCode ( numberOfSpecies ) ) - if ( allocated( unoccupiedCode ) ) deallocate( unoccupiedCode ) - allocate (unoccupiedCode ( numberOfSpecies ) ) - - call Vector_constructorInteger (order, numberOfSpecies, 0 ) - order%values = 0 - - s = 0 - do i = 1, numberOfSpecies - - call Vector_constructorInteger8 (ConfigurationInteraction_instance%numberOfStrings(i), & - int(ConfigurationInteraction_instance%CILevel(i) + 1,8), 0_8) - - ConfigurationInteraction_instance%numberOfStrings(i)%values(1) = 1 !! ground - - write (*,"(A,A)") " ", MolecularSystem_getNameOfSpecie(i) - - do cilevel = 1,ConfigurationInteraction_instance%CILevel(i) - - call Vector_constructor (occupiedCode(i), cilevel, real(ConfigurationInteraction_instance%numberOfCoreOrbitals%values(i),8) ) - call Vector_constructor (unoccupiedCode(i), cilevel, 0.0_8) - - unoccupiedCode(i)%values = ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) ! it's also a lower bound in a for loop - - if ( cilevel <= ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) ) then - - !! just get the number of strings... - ci = 0 - oci = ConfigurationInteraction_buildStringsRecursion( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel) - - write (*,"(A,I4,I8)") " ", cilevel, ConfigurationInteraction_instance%numberOfStrings(i)%values(cilevel+1) - - end if - end do - write (*,"(A,I8)") " Total:", sum(ConfigurationInteraction_instance%numberOfStrings(i)%values) - write (*,"(A)") "" - - !! allocate the strings arrays - if ( ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) > 0 ) then - call Matrix_constructorInteger( ConfigurationInteraction_instance%strings(i), & - int(ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i),8), & - sum(ConfigurationInteraction_instance%numberOfStrings(i)%values), int(0,4)) - - call Matrix_constructorInteger1( ConfigurationInteraction_instance%orbitals(i), & - int(ConfigurationInteraction_instance%numberOfOrbitals%values(i),8), & - sum(ConfigurationInteraction_instance%numberOfStrings(i)%values), 0_1) - - else - call Matrix_constructorInteger( ConfigurationInteraction_instance%strings(i), & - 1_8, 1_8, int(0,4)) - call Matrix_constructorInteger1( ConfigurationInteraction_instance%orbitals(i), & - 1_8, 1_8, 0_1) - - end if - - !! zero, build the reference - call Vector_constructorInteger (order, numberOfSpecies, 0 ) - - call Vector_constructor (occupiedCode(i), 1, 0.0_8) !! initialize in zero - call Vector_constructor (unoccupiedCode(i), 1, 0.0_8) - - c = 0 - c = c + 1 - call Configuration_constructorB(ConfigurationInteraction_instance%strings(i), ConfigurationInteraction_instance%orbitals(i), & - occupiedCode, unoccupiedCode, i, c, order) - - !! now build the strings - do cilevel = 1,ConfigurationInteraction_instance%CILevel(i) - - call Vector_constructorInteger (order, numberOfSpecies, 0 ) - order%values(i) = cilevel - - call Vector_constructor (occupiedCode(i), cilevel, real(ConfigurationInteraction_instance%numberOfCoreOrbitals%values(i),8) ) - call Vector_constructor (unoccupiedCode(i), cilevel, 0.0_8) - - unoccupiedCode(i)%values = ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) ! it's also a lower bound in a for loop - - if ( cilevel <= ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) ) then - - !! recursion to build the strings - ci = 0 - oci = ConfigurationInteraction_buildStringsRecursion2( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel, order, c) - - end if - end do - - end do - - !! useful array - do i = 1, numberOfSpecies - ConfigurationInteraction_instance%sumstrings(i) = sum(ConfigurationInteraction_instance%numberOfStrings(i)%values) - end do - - !! useful array, save the total number of string for a previous CI level. - do i = 1, numberOfSpecies - call Vector_constructorInteger8 (ConfigurationInteraction_instance%numberOfStrings2(i), & - int(size(ConfigurationInteraction_instance%numberOfStrings(i)%values, dim = 1) + 1,8), 0_8) - - ssize = 0 - do j = 1, size(ConfigurationInteraction_instance%numberOfStrings(i)%values, dim = 1) ! - ssize = ssize + ConfigurationInteraction_instance%numberOfStrings(i)%values(j) - ConfigurationInteraction_instance%numberOfStrings2(i)%values(j+1) = ssize - end do - ConfigurationInteraction_instance%numberOfStrings2(i)%values(1) = 0 - end do - - - end subroutine ConfigurationInteraction_buildStrings - -!! This is just to get the total number of strings... - -recursive function ConfigurationInteraction_buildStringsRecursion( i, numberOfSpecies, occupiedCode, unoccupiedCode, ici, cilevel ) result (oci) - implicit none - - integer :: i, numberOfSpecies - integer :: ci, ici, oci, cilevel - integer :: m, a - type(vector), allocatable :: occupiedCode(:) - type(vector), allocatable :: unoccupiedCode(:) - - ci = ici + 1 - - if ( ci == 1 .and. ci < cilevel ) then ! first - do m = int(occupiedCode(i)%values(ci)) + 1, int(ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i)) - do a = int(unoccupiedCode(i)%values(ci)) + 1, int(ConfigurationInteraction_instance%numberOfOrbitals%values(i) ) - occupiedCode(i)%values(ci) = m - unoccupiedCode(i)%values(ci) = a - oci = ConfigurationInteraction_buildStringsRecursion( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel ) - end do - unoccupiedCode(i)%values = ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - end do - else if ( ci > 1 .and. ci < cilevel ) then ! mid - do m = int(occupiedCode(i)%values(ci-1)) + 1, int(ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i)) - do a = int(unoccupiedCode(i)%values(ci-1)) + 1, int(ConfigurationInteraction_instance%numberOfOrbitals%values(i) ) - occupiedCode(i)%values(ci) = m - unoccupiedCode(i)%values(ci) = a - oci = ConfigurationInteraction_buildStringsRecursion( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel ) - end do - end do - - else if ( ci == 1 .and. ci == cilevel ) then ! mid - do m = int(occupiedCode(i)%values(ci)) + 1, int(ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i)) - do a = int(unoccupiedCode(i)%values(ci)) + 1, int(ConfigurationInteraction_instance%numberOfOrbitals%values(i) ) - occupiedCode(i)%values(ci) = m - unoccupiedCode(i)%values(ci) = a - ConfigurationInteraction_instance%numberOfStrings(i)%values(ci+1) = & - ConfigurationInteraction_instance%numberOfStrings(i)%values(ci+1) + 1 - end do - if ( ci == 1 ) unoccupiedCode(i)%values = ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - end do - - else !final - - do m = int(occupiedCode(i)%values(ci-1)) + 1, int(ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i)) - do a = int(unoccupiedCode(i)%values(ci-1)) + 1, int(ConfigurationInteraction_instance%numberOfOrbitals%values(i) ) - occupiedCode(i)%values(ci) = m - unoccupiedCode(i)%values(ci) = a - ConfigurationInteraction_instance%numberOfStrings(i)%values(ci+1) = & - ConfigurationInteraction_instance%numberOfStrings(i)%values(ci+1) + 1 - end do - if ( ci == 1 ) unoccupiedCode(i)%values = ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - end do - end if - - end function ConfigurationInteraction_buildStringsRecursion - -!! and this is for building the strings -recursive function ConfigurationInteraction_buildStringsRecursion2( i, numberOfSpecies, occupiedCode, unoccupiedCode, & - ici, cilevel, order, c ) result (oci) - implicit none - - integer :: i, numberOfSpecies - integer :: ci, ici, oci, cilevel - integer(8) :: c - integer :: m, a - type(ivector) :: order - type(vector), allocatable :: occupiedCode(:) - type(vector), allocatable :: unoccupiedCode(:) - - ci = ici + 1 - - if ( ci == 1 .and. ci < cilevel ) then ! first - do m = int(occupiedCode(i)%values(ci)) + 1, int(ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i)) - do a = int(unoccupiedCode(i)%values(ci)) + 1, int(ConfigurationInteraction_instance%numberOfOrbitals%values(i) ) - occupiedCode(i)%values(ci) = m - unoccupiedCode(i)%values(ci) = a - oci = ConfigurationInteraction_buildStringsRecursion2( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel, order, c ) - end do - unoccupiedCode(i)%values = ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - end do - else if ( ci > 1 .and. ci < cilevel ) then ! mid - do m = int(occupiedCode(i)%values(ci-1)) + 1, int(ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i)) - do a = int(unoccupiedCode(i)%values(ci-1)) + 1, int(ConfigurationInteraction_instance%numberOfOrbitals%values(i) ) - occupiedCode(i)%values(ci) = m - unoccupiedCode(i)%values(ci) = a - oci = ConfigurationInteraction_buildStringsRecursion2( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel, order, c ) - end do - end do - - else if ( ci == 1 .and. ci == cilevel ) then ! mid - do m = int(occupiedCode(i)%values(ci)) + 1, int(ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i)) - do a = int(unoccupiedCode(i)%values(ci)) + 1, int(ConfigurationInteraction_instance%numberOfOrbitals%values(i) ) - occupiedCode(i)%values(ci) = m - unoccupiedCode(i)%values(ci) = a - - c = c + 1 - call Configuration_constructorB(ConfigurationInteraction_instance%strings(i), ConfigurationInteraction_instance%orbitals(i), & - occupiedCode, unoccupiedCode, i, c, order) - end do - if ( ci == 1 ) unoccupiedCode(i)%values = ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - end do - - else !final - - do m = int(occupiedCode(i)%values(ci-1)) + 1, int(ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i)) - do a = int(unoccupiedCode(i)%values(ci-1)) + 1, int(ConfigurationInteraction_instance%numberOfOrbitals%values(i) ) - occupiedCode(i)%values(ci) = m - unoccupiedCode(i)%values(ci) = a - c = c + 1 - call Configuration_constructorB(ConfigurationInteraction_instance%strings(i), ConfigurationInteraction_instance%orbitals(i), & - occupiedCode, unoccupiedCode, i, c, order) - end do - if ( ci == 1 ) unoccupiedCode(i)%values = ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - end do - end if - - - end function ConfigurationInteraction_buildStringsRecursion2 - -!! Build the CI table with all combinations of excitations between quantum species. - - subroutine ConfigurationInteraction_buildCIOrderList() - implicit none - - integer :: c - integer :: i,j, u,v - integer :: ci, ii, jj - integer(8) :: output, auxsize - integer :: numberOfSpecies, auxnumberOfSpecies,s - integer(1) :: coupling - real(8) :: timeA, timeB - integer :: ncouplingOrderOne - integer :: ncouplingOrderTwo - logical :: includecilevel, same - integer(8) :: ssize, auxssize - integer, allocatable :: cilevel(:), auxcilevel(:) - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - - !! Allocate size considering all possible combinations, FCI. - ssize = 1 - do i = 1, numberOfSpecies - ssize = ssize * (ConfigurationInteraction_instance%CILevel(i) + 1) - end do - - allocate ( ConfigurationInteraction_instance%ciOrderList( ssize, numberOfSpecies ) ) - allocate ( ConfigurationInteraction_instance%ciOrderSize1( ssize, numberOfSpecies ) ) - allocate ( ConfigurationInteraction_instance%ciOrderSize2( ssize, numberOfSpecies ) ) - allocate ( ConfigurationInteraction_instance%auxciOrderList( ssize ) ) - - ConfigurationInteraction_instance%ciOrderList = 0 - ConfigurationInteraction_instance%auxciOrderList = 0 - - ConfigurationInteraction_instance%ciOrderSize1 = -1 !! I have reasons... -1 for all species except the last one - ConfigurationInteraction_instance%ciOrderSize2 = 1 !! and 1 for the last species - - ConfigurationInteraction_instance%sizeCiOrderList = 0 - - allocate ( ciLevel ( numberOfSpecies ) ) - allocate ( auxciLevel ( numberOfSpecies ) ) - ciLevel = 0 - auxciLevel = 0 - s = 0 - c = 0 - !! Search which combinations of excitations satifies the desired CI level. - auxnumberOfSpecies = ConfigurationInteraction_buildCIOrderRecursion( s, numberOfSpecies, c, cilevel ) - - - !! Print list - write (6,"(T2,A)") "--------------------------" - write (6,"(T2,A)") "CI level \ Species" - write (6,"(T2,A)") "--------------------------" - do u = 1, ConfigurationInteraction_instance%sizeCiOrderList - do i = 1, numberOfSpecies - write (6,"(T2,I4)",advance="no") ConfigurationInteraction_instance%ciOrderList( ConfigurationInteraction_instance%auxciOrderList(u), i) - end do - write (6,"(A)") "" - end do - write (6,"(T2,A)") "--------------------------" - - !! Calculates the three required factors in order to get the position of any given configuration. - !! position = S1 + (indexConf(i,u) - numberOfStrings2(i) -1 )*S2(i,u) - !! i: speciesID, u: cilevelID - - !! Factor S1 - ssize = 0 - do u = 1, ConfigurationInteraction_instance%sizeCiOrderList - - cilevel(:) = ConfigurationInteraction_instance%ciOrderList( ConfigurationInteraction_instance%auxciOrderList(u), :) - - ssize = 0 - do v = 1, u-1 - - auxcilevel(:) = ConfigurationInteraction_instance%ciOrderList( ConfigurationInteraction_instance%auxciOrderList(v), :) - auxnumberOfSpecies = ConfigurationInteraction_getIndexSize(0, ssize, auxcilevel) - - end do - - ConfigurationInteraction_instance%ciOrderSize1(ConfigurationInteraction_instance%auxciOrderList(u),:) = -1 - ConfigurationInteraction_instance%ciOrderSize1(ConfigurationInteraction_instance%auxciOrderList(u),numberOfSpecies) = ssize !!just the last - - end do - - !! Factor S2 - do i = 1, numberOfSpecies-1 - do u = 1, ConfigurationInteraction_instance%sizeCiOrderList - - cilevel(:) = ConfigurationInteraction_instance%ciOrderList( ConfigurationInteraction_instance%auxciOrderList(u), :) - ssize = 1 - do j = i+1, numberOfSpecies - ssize = ssize * ConfigurationInteraction_instance%numberOfStrings(j)%values(cilevel(j)+1) - end do - - ConfigurationInteraction_instance%ciOrderSize2(ConfigurationInteraction_instance%auxciOrderList(u),i) = ssize - - end do - end do - - ConfigurationInteraction_instance%ciOrderSize2(:,numberOfSpecies) = 1 - - deallocate ( auxcilevel ) - deallocate ( cilevel ) - - end subroutine ConfigurationInteraction_buildCIOrderList - - !! Search which combinations of excitations satifies the desired CI level. -recursive function ConfigurationInteraction_buildCIOrderRecursion( s, numberOfSpecies, c, cilevel ) result (os) - implicit none - - integer :: u,v,c - integer :: i, j, ii, jj, nn, k, l - integer :: s, numberOfSpecies - integer :: os,is,auxis, auxos - integer :: cilevel(:) - integer :: plusOne(3,3) , plusTwo(4,6) - - is = s + 1 - if ( is < numberOfSpecies ) then - do i = 1, size(ConfigurationInteraction_instance%numberOfStrings(is)%values, dim = 1) - cilevel(is) = i - 1 - os = ConfigurationInteraction_buildCIOrderRecursion( is, numberOfSpecies, c, cilevel ) - end do - cilevel(is) = 0 - else - do i = 1, size(ConfigurationInteraction_instance%numberOfStrings(is)%values, dim = 1) - cilevel(is) = i - 1 - c = c + 1 - - ConfigurationInteraction_instance%ciOrderList( c, : ) = cilevel(:) - if ( sum(cilevel) <= ConfigurationInteraction_instance%maxCIlevel ) then - ConfigurationInteraction_instance%sizeCiOrderList = ConfigurationInteraction_instance%sizeCiOrderList + 1 - ConfigurationInteraction_instance%auxciOrderList( ConfigurationInteraction_instance%sizeCiOrderList ) = c - end if - - if ( trim(ConfigurationInteraction_instance%level) == "CISD+" ) then !!special case. - plusOne(:,1) = (/1,1,1/) - plusOne(:,2) = (/2,0,1/) - plusOne(:,3) = (/0,2,1/) - - do k = 1, 3 - if ( sum( abs(cilevel(:) - plusOne(:,k)) ) == 0 ) then - ConfigurationInteraction_instance%sizeCiOrderList = ConfigurationInteraction_instance%sizeCiOrderList + 1 - ConfigurationInteraction_instance%auxciOrderList( ConfigurationInteraction_instance%sizeCiOrderList ) = c - end if - end do - - end if - - if ( trim(ConfigurationInteraction_instance%level) == "CISD+2" ) then !!special case. - plusTwo(:,1) = (/1,1,1,0/) - plusTwo(:,2) = (/1,1,0,1/) - plusTwo(:,3) = (/2,0,1,0/) - plusTwo(:,4) = (/2,0,0,1/) - plusTwo(:,5) = (/0,2,1,0/) - plusTwo(:,6) = (/0,2,0,1/) - - do k = 1, 6 - if ( sum( abs(cilevel(:) - plusTwo(:,k)) ) == 0 ) then - ConfigurationInteraction_instance%sizeCiOrderList = ConfigurationInteraction_instance%sizeCiOrderList + 1 - ConfigurationInteraction_instance%auxciOrderList( ConfigurationInteraction_instance%sizeCiOrderList ) = c - end if - end do - - end if - - end do - cilevel(is) = 0 - end if - - end function ConfigurationInteraction_buildCIOrderRecursion - -!! Build a list with all possible combinations of number of different orbitals from all quantum species, coupling (0,1,2) - - subroutine ConfigurationInteraction_buildCouplingOrderList() - implicit none - - integer(8) :: a,b,c,c1,c2,aa,d - integer :: u,uu,vv, p, nn,z - integer :: i - integer :: numberOfSpecies, auxnumberOfSpecies,s - integer(1), allocatable :: couplingOrder(:) - integer(1) :: coupling - real(8) :: timeA, timeB - integer :: ncouplingOrderOne - integer :: ncouplingOrderTwo - integer :: ssize - integer, allocatable :: cilevel(:) - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - - ssize = 1 - do i = 1, numberOfSpecies - ssize = ssize * 3 !! ( 0,1,2) different orbitals - end do - - allocate ( ConfigurationInteraction_instance%couplingOrderList( 3, ssize ) ) !! one, two same, two diff - allocate ( ConfigurationInteraction_instance%couplingOrderIndex( 3, ssize ) ) !! one, two same, two diff - - do a = 1, 3 - do b = 1, ssize - call Vector_constructorInteger1( ConfigurationInteraction_instance%couplingOrderList(a,b), & - int( numberOfSpecies,8), int(0,1) ) - - end do - end do - - !! same species - do b = 1, ssize - call Vector_constructorInteger1( ConfigurationInteraction_instance%couplingOrderIndex(1,b), 1_8, int(0,1) ) - call Vector_constructorInteger1( ConfigurationInteraction_instance%couplingOrderIndex(2,b), 1_8, int(0,1) ) - end do - - !! diff species - do b = 1, ssize - call Vector_constructorInteger1( ConfigurationInteraction_instance%couplingOrderIndex(3,b), 2_8, int(0,1) ) - end do - - - allocate ( couplingOrder ( numberOfSpecies )) !! 0, 1, 2 - couplingOrder = 0 - - !! call recursion - s = 0 - ConfigurationInteraction_instance%ncouplingOrderOne = 0 - ConfigurationInteraction_instance%ncouplingOrderTwo = 0 - ConfigurationInteraction_instance%ncouplingOrderTwoDiff = 0 - - allocate ( ciLevel ( numberOfSpecies ) ) - ciLevel = 0 - - !! get all combinations - auxnumberOfSpecies = ConfigurationInteraction_buildCouplingOrderRecursion( s, numberOfSpecies, couplingOrder, cilevel ) - - !! save the index for species (speciesID) just to avoid a lot of conditionals later! - - do u = 1, ConfigurationInteraction_instance%ncouplingOrderOne - do i = 1, numberOfSpecies - if ( ConfigurationInteraction_instance%couplingOrderList(1,u)%values(i) == 1 ) then - ConfigurationInteraction_instance%couplingOrderIndex(1,u)%values(1) = i - end if - end do - end do - - do u = 1, ConfigurationInteraction_instance%ncouplingOrderTwo - do i = 1, numberOfSpecies - if ( ConfigurationInteraction_instance%couplingOrderList(2,u)%values(i) == 2 ) then - ConfigurationInteraction_instance%couplingOrderIndex(2,u)%values(1) = i - end if - end do - end do - - do u = 1, ConfigurationInteraction_instance%ncouplingOrderTwoDiff - z = 0 - do i = 1, numberOfSpecies - if ( ConfigurationInteraction_instance%couplingOrderList(3,u)%values(i) == 1 ) then - z = z + 1 - ConfigurationInteraction_instance%couplingOrderIndex(3,u)%values(z) = i - end if - end do - end do - - - deallocate ( ciLevel ) - deallocate ( couplingOrder ) - - end subroutine ConfigurationInteraction_buildCouplingOrderList - -!! Get all possible combinations of number of different orbitals from all quantum species. -recursive function ConfigurationInteraction_buildCouplingOrderRecursion( s, numberOfSpecies, couplingOrder, cilevel ) result (os) - implicit none - - integer(8) :: a,b,c,d - integer :: u,v - integer :: i, j, ii, jj, nn - integer :: s, numberOfSpecies - integer :: os,is,auxis, auxos - integer(1) :: couplingOrder(:) - logical :: same - integer :: cilevel(:) - - is = s + 1 - if ( is < numberOfSpecies ) then - if ( sum ( couplingOrder) <= 2 ) then - do i = 1, 3 - sum ( couplingOrder ) !! 0,1,2 - couplingOrder(is) = i-1 - couplingOrder(is+1:) = 0 - os = ConfigurationInteraction_buildCouplingOrderRecursion( is, numberOfSpecies, couplingOrder, cilevel ) - end do - end if - else - if ( sum ( couplingOrder) <= 2 ) then - do i = 1, 3 - sum ( couplingOrder ) !! 0,1,2 - couplingOrder(is) = i-1 - couplingOrder(is+1:) = 0 - os = is - if ( sum ( couplingOrder ) == 1 ) then - - auxis = 0 - ConfigurationInteraction_instance%ncouplingOrderOne = ConfigurationInteraction_instance%ncouplingOrderOne + 1 - b = ConfigurationInteraction_instance%ncouplingOrderOne - ConfigurationInteraction_instance%couplingOrderList(1,b)%values = couplingOrder - - else if ( sum ( couplingOrder ) == 2 ) then - - same = .false. - - do j = 1, numberOfSpecies - if ( couplingOrder(j) == 2 ) same = .true. - end do - - if ( same ) then - auxis = 0 - ConfigurationInteraction_instance%ncouplingOrderTwo = ConfigurationInteraction_instance%ncouplingOrderTwo + 1 - b = ConfigurationInteraction_instance%ncouplingOrderTwo - ConfigurationInteraction_instance%couplingOrderList(2,b)%values = couplingOrder - else - auxis = 0 - ConfigurationInteraction_instance%ncouplingOrderTwoDiff = ConfigurationInteraction_instance%ncouplingOrderTwoDiff + 1 - b = ConfigurationInteraction_instance%ncouplingOrderTwoDiff - ConfigurationInteraction_instance%couplingOrderList(3,b)%values = couplingOrder - end if - - end if - end do - end if - end if - - end function ConfigurationInteraction_buildCouplingOrderRecursion - - - !> - !! @brief Destructor por omision - !! - !! @param this - !< - subroutine ConfigurationInteraction_destructor() - implicit none - integer i,j,m,n,p,q,c - integer numberOfSpecies - integer :: isLambdaEqual1 - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - - !!Destroy configurations - !!Ground State - if (allocated(ConfigurationInteraction_instance%configurations)) then - c=1 - call Configuration_destructor(ConfigurationInteraction_instance%configurations(c) ) - - do c=2, ConfigurationInteraction_instance%numberOfConfigurations - call Configuration_destructor(ConfigurationInteraction_instance%configurations(c) ) - end do - - if (allocated(ConfigurationInteraction_instance%configurations)) deallocate(ConfigurationInteraction_instance%configurations) - end if - - call Matrix_destructor(ConfigurationInteraction_instance%hamiltonianMatrix) - call Vector_destructorInteger (ConfigurationInteraction_instance%numberOfOccupiedOrbitals) - call Vector_destructorInteger (ConfigurationInteraction_instance%numberOfOrbitals) - call Vector_destructor (ConfigurationInteraction_instance%lambda) - - ConfigurationInteraction_instance%isInstanced=.false. - - end subroutine ConfigurationInteraction_destructor - - !> - !! @brief Muestra informacion del objeto - !! - !! @param this - !< - subroutine ConfigurationInteraction_show() - implicit none - type(ConfigurationInteraction) :: this - integer :: i - real(8) :: davidsonCorrection, HFcoefficient, CIcorrection - integer numberOfSpecies - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - - if ( ConfigurationInteraction_instance%isInstanced ) then - - write(*,"(A)") "" - write(*,"(A)") " POST HARTREE-FOCK CALCULATION" - write(*,"(A)") " CONFIGURATION INTERACTION THEORY:" - write(*,"(A)") "==============================" - write(*,"(A)") "" - write (6,"(T8,A30, A5)") "LEVEL = ", ConfigurationInteraction_instance%level - write (6,"(T8,A30, I8)") "NUMBER OF CONFIGURATIONS = ", ConfigurationInteraction_instance%numberOfConfigurations - do i = 1, CONTROL_instance%NUMBER_OF_CI_STATES - write (6,"(T8,A17,I3,A10, F25.12)") "STATE: ", i, " ENERGY = ", ConfigurationInteraction_instance%eigenvalues%values(i) - end do - write(*,"(A)") "" - CIcorrection = ConfigurationInteraction_instance%eigenvalues%values(1) - & - HartreeFock_instance%totalEnergy - - write (6,"(T4,A34, F25.12)") "GROUND STATE CORRELATION ENERGY = ", CIcorrection - - if ( ConfigurationInteraction_instance%level == "CISD" ) then - write(*,"(A)") "" - write (6,"(T2,A34)") "RENORMALIZED DAVIDSON CORRECTION:" - write(*,"(A)") "" - write (6,"(T8,A54)") "E(CISDTQ) \approx E(CISD) + \delta E(Q) " - write (6,"(T8,A54)") "\delta E(Q) = (1 - c_0^2) * \delta E(CISD) / c_0^2 " - write (*,*) "" - HFcoefficient = ConfigurationInteraction_instance%eigenVectors%values(1,1) - davidsonCorrection = ( 1 - HFcoefficient*HFcoefficient) * CIcorrection / (HFcoefficient*HFcoefficient) - - - write (6,"(T8,A19, F25.12)") "HF COEFFICIENT = ", HFcoefficient - write (6,"(T8,A19, F25.12)") "\delta E(Q) = ", davidsonCorrection - write (6,"(T8,A19, F25.12)") "E(CISDTQ) ESTIMATE ", HartreeFock_instance%totalEnergy +& - CIcorrection + davidsonCorrection - else - - write(*,"(A)") "" - HFcoefficient = ConfigurationInteraction_instance%eigenVectors%values(1,1) - write (6,"(T8,A19, F25.12)") "HF COEFFICIENT = ", HFcoefficient - - end if - - else - - end if - - end subroutine ConfigurationInteraction_show - - subroutine ConfigurationInteraction_showEigenVectors() - implicit none - - integer(8) :: a,b,c - integer :: u,v,p - integer :: ci - integer :: i, j, ii, jj - integer :: s, numberOfSpecies, auxnumberOfSpecies - integer :: size1, size2 - real(8) :: timeA, timeB - integer(1) :: coupling - integer(8) :: numberOfConfigurations - real(8) :: CIenergy - integer(8), allocatable :: indexConf(:) - integer, allocatable :: cilevel(:), auxcilevel(:), dd(:) - - - if ( CONTROL_instance%CI_PRINT_EIGENVECTORS_FORMAT == "NONE" ) return - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - numberOfConfigurations = ConfigurationInteraction_instance%numberOfConfigurations - - allocate ( ConfigurationInteraction_instance%allIndexConf( numberOfSpecies, numberOfConfigurations ) ) - allocate ( ciLevel ( numberOfSpecies ) ) - allocate ( indexConf ( numberOfSpecies ) ) - ciLevel = 0 - ConfigurationInteraction_instance%allIndexConf = 0 - indexConf = 0 - - !! gather all configurations - s = 0 - c = 0 - ciLevel = 0 - - do ci = 1, ConfigurationInteraction_instance%sizeCiOrderList - - cilevel(:) = ConfigurationInteraction_instance%ciOrderList( ConfigurationInteraction_instance%auxciOrderList(ci), :) - s = 0 - auxnumberOfSpecies = ConfigurationInteraction_gatherConfRecursion( s, numberOfSpecies, indexConf, c, cilevel ) - end do - !stop - - deallocate ( ciLevel ) - - if ( CONTROL_instance%CI_PRINT_EIGENVECTORS_FORMAT == "ORBITALS" ) then - write (*,*) "" - write (*, "(T1,A)") "Eigenvectors" - write (*,*) "" - - do c = 1, CONTROL_instance%NUMBER_OF_CI_STATES - write (*, "(T1,A,I4,A,F25.12)") "State: ", c, " Energy: ", ConfigurationInteraction_instance%eigenValues%values(c) - write (*, "(T1,A)") "Conf, orbital occupation per species, coefficient" - write (*,*) "" - do a = 1, numberOfConfigurations - if ( abs(ConfigurationInteraction_instance%eigenVectors%values(a,c)) > CONTROL_instance%CI_PRINT_THRESHOLD ) then - indexConf(:) = ConfigurationInteraction_instance%allIndexConf(:,a) - - write (*, "(T1,I8,A1)", advance="no") a, " " - do i = 1, numberOfSpecies - do p = 1, ConfigurationInteraction_instance%numberOfOrbitals%values(i) - write (*, "(I1)", advance="no") ConfigurationInteraction_instance%orbitals(i)%values(p,indexConf(i)) - end do - write (*, "(A1)", advance="no") " " - end do - write (*, "(F11.8)") ConfigurationInteraction_instance%eigenVectors%values(a,c) - end if - end do - write (*,*) "" - end do - - - else if ( CONTROL_instance%CI_PRINT_EIGENVECTORS_FORMAT == "OCCUPIED" ) then - write (*,*) "" - write (*, "(T1,A)") "Eigenvectors" - write (*,*) "" - - do c = 1, CONTROL_instance%NUMBER_OF_CI_STATES - write (*, "(T1,A,I4,A,F25.12)") "State: ", c, " Energy: ", ConfigurationInteraction_instance%eigenValues%values(c) - write (*, "(T1,A)") "Conf, occupied orbitals per species, coefficient" - write (*,*) "" - do a = 1, numberOfConfigurations - if ( abs(ConfigurationInteraction_instance%eigenVectors%values(a,c)) > CONTROL_instance%CI_PRINT_THRESHOLD ) then - indexConf(:) = ConfigurationInteraction_instance%allIndexConf(:,a) - - write (*, "(T1,I8,A1)", advance="no") a, " " - do i = 1, numberOfSpecies - do p = 1, ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - write (*, "(I3,A1)", advance="no") ConfigurationInteraction_instance%strings(i)%values(p,indexConf(i) ), " " - end do - write (*, "(A1)", advance="no") "|" - end do - write (*, "(A,F11.8)") " ", ConfigurationInteraction_instance%eigenVectors%values(a,c) - end if - end do - write (*,*) "" - end do - - end if - - deallocate ( indexConf ) - deallocate ( ConfigurationInteraction_instance%allIndexConf ) - - end subroutine ConfigurationInteraction_showEigenVectors - - - !FELIX IS HERE - subroutine ConfigurationInteraction_densityMatrices() - implicit none - type(ConfigurationInteraction) :: this - type(Configuration) :: auxthisA, auxthisB - integer :: i, j, k, l, mu, nu, n - integer :: factor - integer :: unit, wfnunit - integer :: numberOfOrbitals, numberOfContractions, numberOfOccupiedOrbitals - integer :: state, species, orbital, orbitalA, orbitalB - character(50) :: file, wfnfile, speciesName, auxstring - character(50) :: arguments(2) - type(matrix), allocatable :: coefficients(:), atomicDensityMatrix(:,:), ciDensityMatrix(:,:), auxDensMatrix(:,:) - type(matrix), allocatable :: kineticMatrix(:), attractionMatrix(:), externalPotMatrix(:) - integer numberOfSpecies - - type(matrix) :: auxdensityEigenVectors - type(matrix) :: densityEigenVectors - type(vector) :: auxdensityEigenValues - type(vector) :: densityEigenValues - integer, allocatable :: cilevel(:), cilevelA(:) - integer(8) :: numberOfConfigurations, c - integer(8), allocatable :: indexConf(:) - type(ivector), allocatable :: stringAinB(:) - integer :: s, ss, ci, auxnumberOfSpecies - integer, allocatable :: coupling(:) - integer :: a, b, AA, BB, bj - integer :: u, uu, ssize - integer(8), allocatable :: indexConfA(:) - integer(8), allocatable :: indexConfB(:) - integer(8), allocatable :: jj(:) - real(8) :: timeDA - real(8) :: timeDB - - - ! type(Vector) :: eigenValues - ! type(Matrix) :: eigenVectors, auxMatrix - ! real(8) :: sumaPrueba - - !!Iterators: i,j - Configurations .... k,l - molecular orbitals .... mu,nu - atomic orbitals ... n - threads - if ( ConfigurationInteraction_instance%isInstanced .and. CONTROL_instance%CI_STATES_TO_PRINT .gt. 0 ) then - !$ timeDA = omp_get_wtime() - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - - numberOfConfigurations = ConfigurationInteraction_instance%numberOfConfigurations - - allocate (stringAinB ( numberOfSpecies )) - - do i = 1, numberOfSpecies - call Vector_constructorInteger (stringAinB(i), ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i), 0) - end do - - allocate ( ConfigurationInteraction_instance%allIndexConf( numberOfSpecies, numberOfConfigurations ) ) - allocate ( ciLevelA ( numberOfSpecies ) ) - allocate ( ciLevel ( numberOfSpecies ) ) - allocate ( indexConf ( numberOfSpecies ) ) - ciLevelA = 0 - ciLevel = 0 - ConfigurationInteraction_instance%allIndexConf = 0 - indexConf = 0 - - !! gather all configurations - s = 0 - c = 0 - ciLevel = 0 - - do ci = 1, ConfigurationInteraction_instance%sizeCiOrderList - - cilevel(:) = ConfigurationInteraction_instance%ciOrderList( ConfigurationInteraction_instance%auxciOrderList(ci), :) - s = 0 - auxnumberOfSpecies = ConfigurationInteraction_gatherConfRecursion( s, numberOfSpecies, indexConf, c, cilevel ) - end do - !stop - - deallocate ( indexConf ) - allocate ( coupling ( numberOfSpecies ) ) - - - write (*,*) "" - write (*,*) "==============================" - write (*,*) "BUILDING CI DENSITY MATRICES" - write (*,*) "==============================" - write (*,*) "" - - allocate( coefficients(numberOfSpecies), & - kineticMatrix(numberOfSpecies), & - attractionMatrix(numberOfSpecies), & - externalPotMatrix(numberOfSpecies), & - atomicDensityMatrix(numberOfSpecies,CONTROL_instance%CI_STATES_TO_PRINT), & - ciDensityMatrix(numberOfSpecies,CONTROL_instance%CI_STATES_TO_PRINT), & - auxDensMatrix(numberOfSpecies,ConfigurationInteraction_instance%nproc) ) - - wfnFile = "lowdin.wfn" - wfnUnit = 20 - open(unit=wfnUnit, file=trim(wfnFile), status="old", form="unformatted") - - !Inicializando las matrices - do species=1, numberOfSpecies - speciesName = MolecularSystem_getNameOfSpecie(species) - - numberOfContractions = MolecularSystem_getTotalNumberOfContractions( species ) - ! numberOfOrbitals = ConfigurationInteraction_instance%numberOfOrbitals%values(species) - numberOfOccupiedOrbitals = ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(species) - - arguments(2) = speciesName - ! print *, "trolo", numberOfOrbitals, numberOfContractions, numberOfOccupiedOrbitals - - arguments(1) = "COEFFICIENTS" - coefficients(species) = Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfContractions,4), & - columns= int(numberOfContractions,4), binary=.true., arguments=arguments(1:2)) - - arguments(1) = "KINETIC" - kineticMatrix(species) = Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfContractions,4), & - columns= int(numberOfContractions,4), binary=.true., arguments=arguments(1:2)) - - arguments(1) = "ATTRACTION" - attractionMatrix(species) = Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfContractions,4), & - columns= int(numberOfContractions,4), binary=.true., arguments=arguments(1:2)) - - arguments(1) = "EXTERNAL_POTENTIAL" - if( CONTROL_instance%IS_THERE_EXTERNAL_POTENTIAL) & - externalPotMatrix(species) = Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfContractions,4), & - columns= int(numberOfContractions,4), binary=.true., arguments=arguments(1:2)) - ! print *, "trololo" - - do state=1, CONTROL_instance%CI_STATES_TO_PRINT - - call Matrix_constructor ( ciDensityMatrix(species,state) , & - int(numberOfContractions,8), & - int(numberOfContractions,8), 0.0_8 ) - - do k=1, numberOfOccupiedOrbitals - ciDensityMatrix(species,state)%values( k, k)=1.0_8 - end do - - end do - - do n=1, ConfigurationInteraction_instance%nproc - - call Matrix_constructor ( auxDensMatrix(species,n) , & - int(numberOfContractions,8), & - int(numberOfContractions,8), 0.0_8 ) - end do - end do - - close(wfnUnit) - - allocate ( indexConfA ( numberOfSpecies ) ) - allocate ( indexConfB ( numberOfSpecies ) ) - allocate ( jj ( numberOfSpecies ) ) - - indexConfA = 0 - indexConfB = 0 - jj = 0 - - !! Building the CI reduced density matrix in the molecular orbital representation in parallel - ! call Matrix_show (ConfigurationInteraction_instance%eigenVectors) - - !!print *, " State, Progress" - - do state=1, CONTROL_instance%CI_STATES_TO_PRINT - - !$omp parallel & - !$omp& firstprivate (stringAinB,indexConfA,indexConfB, jj) & - !$omp& private(i,j, species, s, numberOfOccupiedOrbitals, k, coupling, orbital, orbitalA, orbitalB, AA, BB, a, b, factor, n, cilevelA, ss, ssize, cilevel, ci, u, uu, bj),& - !$omp& shared(ConfigurationInteraction_instance, auxDensMatrix ) - n = omp_get_thread_num() + 1 - !$omp do schedule (dynamic) - do i=1, ConfigurationInteraction_instance%numberOfConfigurations - - !!if( mod( i , 50000 ) .eq. 0 ) print *, state, floor(real(100*i/ConfigurationInteraction_instance%numberOfConfigurations)), "%" - !!Filter very small coefficients - if( abs(ConfigurationInteraction_instance%eigenVectors%values(i,state)) .ge. 1E-10) then - - indexConfA(:) = ConfigurationInteraction_instance%allIndexConf(:,i) - - !print *, "==", indexConfA , "|", i - - - !!Diagonal contributions - do species=1, numberOfSpecies - numberOfOccupiedOrbitals = ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(species) - - do k=1, numberOfOccupiedOrbitals - - !!Occupied orbitals - auxDensMatrix(species,n)%values(k,k)=auxDensMatrix(species,n)%values(k,k) - ConfigurationInteraction_instance%eigenVectors%values(i,state)**2 - ! ciDensityMatrix(species,state)%values( k, k) = ciDensityMatrix(species,state)%values( k, k) - & - ! ConfigurationInteraction_instance%eigenVectors%values(i,state)**2 - - !print *, i, j, k, species - !orbital = ConfigurationInteraction_instance%configurations(i)%occupations(k,species) - orbital = ConfigurationInteraction_instance%strings(species)%values(k,indexConfA(species)) - !!Unoccupied orbitals - - auxDensMatrix(species,n)%values(orbital,orbital)=auxDensMatrix(species,n)%values(orbital,orbital) + ConfigurationInteraction_instance%eigenVectors%values(i,state)**2 - ! ciDensityMatrix(species,state)%values( orbital, orbital)= ciDensityMatrix(species,state)%values( orbital, orbital) + & - ! ConfigurationInteraction_instance%eigenVectors%values(i,state)**2 - - end do - end do - - !!Off Diagonal contributions - cilevelA = 0 - do ss = 1, numberOfSpecies - stringAinB(ss)%values = 0 - do k = 1, ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(ss) - - stringAinB(ss)%values(k) = ConfigurationInteraction_instance%orbitals(ss)%values( & - ConfigurationInteraction_instance%strings(ss)%values(k, ConfigurationInteraction_instance%allIndexConf(ss,1)), indexConfA(ss)) - end do - cilevelA(ss) = configurationinteraction_instance%numberOfOccupiedOrbitals%values(ss) - sum ( stringAinB(ss)%values ) - end do - - jj = 0 - coupling = 0 - do ss = 1, numberOfSpecies - ssize = 0 - - indexConfB(:) = indexConfA(:) - cilevel = cilevelA - - do ci = 1, size(ConfigurationInteraction_instance%numberOfStrings(ss)%values, dim = 1) - cilevel(ss) = ci - 1 - do u = 1, ConfigurationInteraction_instance%sizeCiOrderList - if ( sum(abs(cilevel - & - ConfigurationInteraction_instance%ciOrderList( ConfigurationInteraction_instance%auxciOrderList(u), :))) == 0 ) then - uu = ConfigurationInteraction_instance%auxciOrderList(u) - do bj = 1 + ssize , ConfigurationInteraction_instance%numberOfStrings(ss)%values(ci) + ssize - indexConfB(ss) = bj - - do s=1, numberOfSpecies - jj(s) = (indexConfB(s) - ConfigurationInteraction_instance%numberOfStrings2(s)%values(cilevel(s)+1) + & - ConfigurationInteraction_instance%ciOrderSize1(uu,s) )* ConfigurationInteraction_instance%ciOrderSize2(uu,s) - end do - - j = sum(jj) - !print *, " ", indexConfB , "|", j, ConfigurationInteraction_instance%eigenVectors%values(j,state) - if ( j > i ) then - if( abs(ConfigurationInteraction_instance%eigenVectors%values(j,state)) .ge. 1E-10) then - - coupling = 0 - do s=1, numberOfSpecies - stringAinB(s)%values = 0 - do k = 1, ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(s) - stringAinB(s)%values(k) = ConfigurationInteraction_instance%orbitals(s)%values( & - ConfigurationInteraction_instance%strings(s)%values(k,indexConfA(s) ), indexConfB(s) ) - end do - coupling(s) = configurationinteraction_instance%numberOfOccupiedOrbitals%values(s) - sum ( stringAinB(s)%values ) - end do - if (sum(coupling) == 1) then - - do s = 1, numberOfSpecies - - if ( coupling(s) == 1) then !!hmm - - !print *, " ", coupling - orbitalA = 0 - orbitalB = 0 - AA = 0 - BB = 0 - a = indexConfA(s) - b = indexConfB(s) - - do k = 1, ConfigurationInteraction_instance%occupationNumber(s) - if ( ConfigurationInteraction_instance%orbitals(s)%values( & - ConfigurationInteraction_instance%strings(s)%values(k,a),b) == 0 ) then - orbitalA = ConfigurationInteraction_instance%strings(s)%values(k,a) - AA = k - exit - end if - end do - do k = 1, ConfigurationInteraction_instance%occupationNumber(s) - if ( ConfigurationInteraction_instance%orbitals(s)%values( & - ConfigurationInteraction_instance%strings(s)%values(k,b),a) == 0 ) then - orbitalB = ConfigurationInteraction_instance%strings(s)%values(k,b) - BB = k - exit - end if - end do - - factor = (-1)**(AA-BB) - - numberOfOccupiedOrbitals = ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(s) - - ! print *, i, j, ConfigurationInteraction_instance%configurations(i)%occupations(:,specie), ConfigurationInteraction_instance%configurations(j)%occupations(:,specie) - ! print *, i, j, auxthisA%occupations(:,specie), auxthisB%occupations(:,specie) - ! print *, i, j, orbitalA, orbitalB, factor*ConfigurationInteraction_instance%eigenVectors%values(i,1)*ConfigurationInteraction_instance%eigenVectors%values(j,1) - - auxDensMatrix(s,n)%values( orbitalA,orbitalB)= auxDensMatrix(s,n)%values( orbitalA, orbitalB) + & - factor*ConfigurationInteraction_instance%eigenVectors%values(i,state)* & - ConfigurationInteraction_instance%eigenVectors%values(j,state) - auxDensMatrix(s,n)%values( orbitalB,orbitalA)= auxDensMatrix(s,n)%values( orbitalB, orbitalA) + & - factor*ConfigurationInteraction_instance%eigenVectors%values(i,state)* & - ConfigurationInteraction_instance%eigenVectors%values(j,state) - end if - end do - end if - end if - end if - !! here - end do - ssize = ssize + ConfigurationInteraction_instance%numberOfStrings(ss)%values(ci) - !exit - end if - - end do - end do - - end do - -! do j=i+1, ConfigurationInteraction_instance%numberOfConfigurations -! if( abs(ConfigurationInteraction_instance%eigenVectors%values(j,state)) .ge. 1E-12) then - -! indexConfB(:) = ConfigurationInteraction_instance%allIndexConf(:,j) - -! coupling = 0 -! do s=1, numberOfSpecies -! stringAinB(s)%values = 0 -! do k = 1, ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(s) -! stringAinB(s)%values(k) = ConfigurationInteraction_instance%orbitals(s)%values( & -! ConfigurationInteraction_instance%strings(s)%values(k,indexConfA(s) ), indexConfB(s) ) -! end do -! coupling(s) = configurationinteraction_instance%numberOfOccupiedOrbitals%values(s) - sum ( stringAinB(s)%values ) -! end do -! -! if (sum(coupling) == 1) then -! -! do s = 1, numberOfSpecies -! -! if ( coupling(s) == 1) then -! orbitalA = 0 -! orbitalB = 0 -! AA = 0 -! BB = 0 -! a = indexConfA(s) -! b = indexConfB(s) -! -! do k = 1, ConfigurationInteraction_instance%occupationNumber(s) -! if ( ConfigurationInteraction_instance%orbitals(s)%values( & -! ConfigurationInteraction_instance%strings(s)%values(k,a),b) == 0 ) then -! orbitalA = ConfigurationInteraction_instance%strings(s)%values(k,a) -! AA = k -! exit -! end if -! end do -! do k = 1, ConfigurationInteraction_instance%occupationNumber(s) -! if ( ConfigurationInteraction_instance%orbitals(s)%values( & -! ConfigurationInteraction_instance%strings(s)%values(k,b),a) == 0 ) then -! orbitalB = ConfigurationInteraction_instance%strings(s)%values(k,b) -! BB = k -! exit -! end if -! end do -! -! factor = (-1)**(AA-BB) -! -! numberOfOccupiedOrbitals = ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(s) -! -! ! print *, i, j, ConfigurationInteraction_instance%configurations(i)%occupations(:,specie), ConfigurationInteraction_instance%configurations(j)%occupations(:,specie) -! ! print *, i, j, auxthisA%occupations(:,specie), auxthisB%occupations(:,specie) -! -! ! print *, i, j, orbitalA, orbitalB, factor*ConfigurationInteraction_instance%eigenVectors%values(i,1)*ConfigurationInteraction_instance%eigenVectors%values(j,1) -! -! auxDensMatrix(s,n)%values( orbitalA,orbitalB)= auxDensMatrix(s,n)%values( orbitalA, orbitalB) + & -! factor*ConfigurationInteraction_instance%eigenVectors%values(i,state)* & -! ConfigurationInteraction_instance%eigenVectors%values(j,state) -! ! ciDensityMatrix(s,state)%values( orbitalA,orbitalB)= ciDensityMatrix(s,state)%values( orbitalA, orbitalB) + & -! ! factor*ConfigurationInteraction_instance%eigenVectors%values(i,state)* & -! ! ConfigurationInteraction_instance%eigenVectors%values(j,state) -! -! auxDensMatrix(s,n)%values( orbitalB,orbitalA)= auxDensMatrix(s,n)%values( orbitalB, orbitalA) + & -! factor*ConfigurationInteraction_instance%eigenVectors%values(i,state)* & -! ConfigurationInteraction_instance%eigenVectors%values(j,state) -! -! ! ciDensityMatrix(s,state)%values( orbitalB, orbitalA)= ciDensityMatrix(s,state)%values( orbitalB, orbitalA) + & -! ! factor*ConfigurationInteraction_instance%eigenVectors%values(i,state)* & -! ! ConfigurationInteraction_instance%eigenVectors%values(j,state) -! -! end if -! end do -! end if -! end if -! end do - - end if - end do - !$omp end do nowait - !$omp end parallel - - !! Gather the parallel results - do species=1, numberOfSpecies - do n=1, ConfigurationInteraction_instance%nproc - ciDensityMatrix(species,state)%values = ciDensityMatrix(species,state)%values + auxDensMatrix(species,n)%values - auxDensMatrix(species,n)%values=0.0 - end do - end do - - end do - - - !! Open file - to write density matrices - unit = 29 - - file = trim(CONTROL_instance%INPUT_FILE)//"Matrices.ci" - open(unit = unit, file=trim(file), status="new", form="formatted") - - !! Building the CI reduced density matrix in the atomic orbital representation - do species=1, numberOfSpecies - speciesName = MolecularSystem_getNameOfSpecie(species) - numberOfContractions = MolecularSystem_getTotalNumberOfContractions( species ) - - do state=1, CONTROL_instance%CI_STATES_TO_PRINT - - ! print *, "CI density matrix ", trim(speciesName), state - ! call Matrix_show ( ciDensityMatrix(species,state)) - - call Matrix_constructor ( atomicDensityMatrix(species,state) , & - int(numberOfContractions,8), & - int(numberOfContractions,8), 0.0_8 ) - - do mu=1, numberOfContractions - do nu=1, numberOfContractions - do k=1, numberOfContractions - atomicDensityMatrix(species,state)%values(mu,nu) = & - atomicDensityMatrix(species,state)%values(mu,nu) + & - ciDensityMatrix(species,state)%values(k,k) *& - coefficients(species)%values(mu,k)*coefficients(species)%values(nu,k) - - do l=k+1, numberOfContractions - - atomicDensityMatrix(species,state)%values(mu,nu) = & - atomicDensityMatrix(species,state)%values(mu,nu) + & - ciDensityMatrix(species,state)%values(k,l) *& - (coefficients(species)%values(mu,k)*coefficients(species)%values(nu,l) + & - coefficients(species)%values(mu,l)*coefficients(species)%values(nu,k)) - - end do - end do - end do - end do - - ! print *, "atomic density matrix ", trim(speciesName), state - ! call Matrix_show ( atomicDensityMatrix(species,state)) - - write(auxstring,*) state - arguments(2) = speciesName - arguments(1) = "DENSITYMATRIX"//trim(adjustl(auxstring)) - - call Matrix_writeToFile ( atomicDensityMatrix(species,state), unit , arguments=arguments(1:2) ) - - end do - end do - - write(*,*) "" - write(*,*) "===============================" - write(*,*) " ONE BODY ENERGY CONTRIBUTIONS:" - write(*,*) "" - do state=1, CONTROL_instance%CI_STATES_TO_PRINT - write(*,*) " STATE: ", state - do species=1, molecularSystem_instance%numberOfQuantumSpecies - write(*,"(A38,F25.12)") trim( MolecularSystem_instance%species(species)%name ) // & - " Kinetic energy = ", sum(transpose(atomicDensityMatrix(species,state)%values)*kineticMatrix(species)%values) - write(*,"(A38,F25.12)") trim( MolecularSystem_instance%species(species)%name ) // & - "/Fixed interact. energy = ", sum(transpose(atomicDensityMatrix(species,state)%values)*attractionMatrix(species)%values) - if( CONTROL_instance%IS_THERE_EXTERNAL_POTENTIAL) & - write(*,"(A38,F25.12)") trim( MolecularSystem_instance%species(species)%name) // & - " Ext Pot energy = ", sum(transpose(atomicDensityMatrix(species,state)%values)*externalPotMatrix(species)%values) - print *, "" - end do - print *, "" - end do - - !! Natural orbitals - - if (CONTROL_instance%CI_NATURAL_ORBITALS) then - - write(*,*) "" - write(*,*) "==============================" - write(*,*) " NATURAL ORBITALS: " - write(*,*) "" - - do state=1, CONTROL_instance%CI_STATES_TO_PRINT - - write(*,*) " STATE: ", state - - do species=1, numberOfSpecies - - write(*,*) "" - write(*,*) " Natural Orbitals in state: ", state, " for: ", trim( MolecularSystem_instance%species(species)%name ) - write(*,*) "-----------------" - - numberOfContractions = MolecularSystem_getTotalNumberOfContractions( species ) - speciesName = MolecularSystem_getNameOfSpecie(species) - - - call Vector_constructor ( auxdensityEigenValues, & - int(numberOfContractions,4), 0.0_8 ) - - call Matrix_constructor ( auxdensityEigenVectors, & - int(numberOfContractions,8), & - int(numberOfContractions,8), 0.0_8 ) - - call Vector_constructor ( densityEigenValues, & - int(numberOfContractions,4), 0.0_8 ) - - call Matrix_constructor ( densityEigenVectors, & - int(numberOfContractions,8), & - int(numberOfContractions,8), 0.0_8 ) - - call Matrix_eigen ( ciDensityMatrix(species,state), auxdensityEigenValues, auxdensityEigenVectors, SYMMETRIC ) - - ! reorder and count significant occupations - k=0 - do u = 1, numberOfContractions - densityEigenValues%values(u) = auxdensityEigenValues%values(numberOfContractions - u + 1) - densityEigenVectors%values(:,u) = auxdensityEigenVectors%values(:,numberOfContractions - u + 1) - if(densityEigenValues%values(u) .ge. 5.0E-5 ) k=k+1 - end do - - !! Transform to atomic basis - densityEigenVectors%values = matmul( coefficients(species)%values, densityEigenVectors%values ) - - ! Print eigenvectors with occupation larger than 5.0E-5 - call Matrix_constructor(auxdensityEigenVectors,int(numberOfContractions,8),int(k,8),0.0_8) - do u=1, numberOfContractions - do j=1, k - auxdensityEigenVectors%values(u,j)=densityEigenVectors%values(u,j) - end do - end do - call Matrix_show( auxdensityEigenVectors, & - rowkeys = MolecularSystem_getlabelsofcontractions( species ), & - columnkeys = string_convertvectorofrealstostring( densityEigenValues ),& - flags=WITH_BOTH_KEYS) - - write(auxstring,*) state - arguments(2) = speciesName - arguments(1) = "NATURALORBITALS"//trim(adjustl(auxstring)) - - call Matrix_writeToFile ( densityEigenVectors, unit , arguments=arguments(1:2) ) - arguments(1) = "OCCUPATIONS"//trim(adjustl(auxstring)) - - call Vector_writeToFile( densityEigenValues, unit, arguments=arguments(1:2) ) - !! it's the same - !!auxdensityEigenVectors%values = 0 - - !!do mu=1, numberOfContractions - !! do nu=1, numberOfContractions - !! do k=1, numberOfContractions - !! auxdensityEigenVectors%values(mu,nu) = auxdensityEigenVectors%values(mu,nu) + & - !! densityEigenVectors%values(mu,k) * densityEigenVectors%values(nu,k)*densityEigenValues%values(k) - !! end do - !! end do - !!end do - !!print *, "atomic density matrix from natural orbitals" - !!call Matrix_show ( auxdensityEigenVectors) - write(*,"(A10,A10,A40,F17.12)") "sum of ", trim(speciesName) , "natural orbital occupations", sum(densityEigenValues%values) - - write(*,*) " End of natural orbitals in state: ", state, " for: ", trim(speciesName) - end do - end do - - - - write(*,*) "" - write(*,*) " END OF NATURAL ORBITALS" - write(*,*) "==============================" - write(*,*) "" - - end if - - close(unit) - - deallocate ( jj ) - deallocate ( indexConfB ) - deallocate ( indexConfA ) - deallocate ( coupling ) - deallocate ( cilevel ) - deallocate ( cilevelA ) - deallocate ( ConfigurationInteraction_instance%allIndexConf ) - deallocate ( stringAinB ) - - deallocate( coefficients, atomicDensityMatrix, ciDensityMatrix ) - - !$ timeDB = omp_get_wtime() - !$ write(*,"(A,F10.4,A4)") "** TOTAL Elapsed Time for Building density matrices: ", timeDB - timeDA ," (s)" - - - end if - - ! print *, i, i, orbital, orbital, ConfigurationInteraction_instance%eigenVectors%values(i,1)**2 - - ! do mu = 1 , numberOfOrbitals - ! do nu = 1 , numberOfOrbitals - - ! densityMatrix%values(mu,nu) = & - ! densityMatrix%values(mu,nu) + & - ! ConfigurationInteraction_instance%eigenVectors%values(i,state)**2 *& - ! coefficients%values(mu,orbital)*coefficients%values(nu,orbital) - ! end do - ! end do - - !!off-Diagonal ground state - - ! do mu = 1 , numberOfOrbitals - ! do nu = 1 , numberOfOrbitals - - ! densityMatrix%values(mu,nu) = & - ! densityMatrix%values(mu,nu) + & - ! factor *& - ! ConfigurationInteraction_instance%eigenVectors%values(i,state) *& - ! ConfigurationInteraction_instance%eigenVectors%values(j,state) *& - ! (coefficients%values(mu,orbitalA)*coefficients%values(nu,orbitalB) + coefficients%values(mu,orbitalB)*coefficients%values(nu,orbitalA)) - ! end do - ! end do - - ! call Vector_constructor(eigenValues, numberOfOrbitals) - ! call Matrix_constructor(eigenVectors, int(numberOfOrbitals,8), int(numberOfOrbitals,8)) - ! call Matrix_eigen(ciOccupationMatrix, eigenValues, eigenVectors, SYMMETRIC) - - ! print *, "Diagonal sum", sum(eigenValues%values) - ! call Vector_show(eigenValues) - - ! call Matrix_show(eigenVectors) - ! print *, arguments(1:2) - ! call Matrix_show ( densityMatrix ) - - ! call Matrix_constructor ( ciOccupationNumbers , int(numberOfOrbitals,8) , & - ! int(CONTROL_instance%CI_STATES_TO_PRINT,8), 0.0_8 ) - - ! do state=1, CONTROL_instance%CI_STATES_TO_PRINT - ! sumaPrueba=0 - ! do j=1, numberOfOccupiedOrbitals - ! ciOccupationNumbers%values(j,state) = 1.0 - ! end do - - ! ! !Get occupation numbers from each configuration contribution - - ! do i=1, ConfigurationInteraction_instance%numberOfConfigurations - ! do j=1, numberOfOccupiedOrbitals - - ! !! Occupied orbitals - ! ciOccupationNumbers%values( j, state)= ciOccupationNumbers%values( j, state) - & - ! ConfigurationInteraction_instance%eigenVectors%values(i,state)**2 - ! !! Unoccupied orbitals - ! orbital = ConfigurationInteraction_instance%configurations(i)%occupations(j,specie) - - ! ciOccupationNumbers%values( orbital, state)= ciOccupationNumbers%values( orbital, state) + & - ! ConfigurationInteraction_instance%eigenVectors%values(i,state)**2 - - ! ! print *, j, orbital, ConfigurationInteraction_instance%eigenVectors%values(i,state)**2 - ! ! sumaPrueba=sumaPrueba+ConfigurationInteraction_instance%eigenVectors%values(i,state)**2 - ! end do - ! ! end if - - ! end do - - ! ! print *, "suma", sumaPrueba - ! !Build a new density matrix (P) in atomic orbitals - - ! call Matrix_constructor ( densityMatrix , & - ! int(numberOfOrbitals,8), & - ! int(numberOfOrbitals,8), 0.0_8 ) - - ! wfnFile = "lowdin.wfn" - ! wfnUnit = 20 - - ! open(unit=wfnUnit, file=trim(wfnFile), status="old", form="unformatted") - - ! arguments(2) = speciesName - ! arguments(1) = "COEFFICIENTS" - - ! coefficients = Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfOrbitals,4), & - ! columns= int(numberOfOrbitals,4), binary=.true., arguments=arguments(1:2)) - - ! close(wfnUnit) - - ! do mu = 1 , numberOfOrbitals - ! do nu = 1 , numberOfOrbitals - ! do k = 1 , numberOfOrbitals - - ! densityMatrix%values(mu,nu) = & - ! densityMatrix%values(mu,nu) + & - ! ciOccupationNumbers%values(k, state)**2* & - ! coefficients%values(mu,k)*coefficients%values(nu,k) - ! end do - ! end do - ! end do - - ! write(auxstring,*) state - ! arguments(2) = speciesName - ! arguments(1) = "DENSITYMATRIX"//trim(adjustl(auxstring)) - - ! call Matrix_writeToFile ( densityMatrix, unit , arguments=arguments(1:2) ) - - ! print *, arguments(1:2) - ! call Matrix_show ( densityMatrix ) - - ! call Matrix_destructor(coefficients) - ! call Matrix_destructor(densityMatrix) - - - ! end do - - ! !Write occupation numbers to file - ! write (6,"(T8,A10,A20)") trim(MolecularSystem_getNameOfSpecie(specie)),"OCCUPATIONS:" - - ! call Matrix_show ( ciOccupationNumbers ) - - ! arguments(2) = speciesName - ! arguments(1) = "OCCUPATIONS" - - ! call Matrix_writeToFile ( ciOccupationNumbers, unit , arguments=arguments(1:2) ) - - ! call Matrix_destructor(ciOccupationNumbers) - - - - end subroutine ConfigurationInteraction_densityMatrices - - !> - !! @brief Muestra informacion del objeto - !! - !! @param this - !< - subroutine ConfigurationInteraction_run() - implicit none - integer :: i,j,m, numberOfSpecies - real(8), allocatable :: eigenValues(:) - -! select case ( trim(ConfigurationInteraction_instance%level) ) - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - - write (*,*) "" - write (*,*) "===============================================" - write (*,*) " BEGIN ", trim(ConfigurationInteraction_instance%level)," CALCULATION" - write (*,*) " J. Charry, F. Moncada " - write (*,*) "-----------------------------------------------" - write (*,*) "" - - write (*,"(A32)",advance="no") "Number of orbitals for species: " - do i = 1, numberOfSpecies-1 - write (*,"(A)",advance="no") trim(MolecularSystem_getNameOfSpecie(i))//", " - end do - write (*,"(A)",advance="no") trim(MolecularSystem_getNameOfSpecie(numberOfSpecies)) - write (*,*) "" - - write (*,"(A28)",advance="no") " occupied orbitals: " - do i = 1, numberOfSpecies - write (*,"(I5)", advance="no") ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - end do - write (*,*) "" - - write (*,"(A28)",advance="no") " virtual orbitals: " - do i = 1, numberOfSpecies - write (*,"(I5)",advance="no") int(MolecularSystem_getTotalNumberOfContractions( i )* & - ConfigurationInteraction_instance%lambda%values(i) - & - ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) ) - end do - write (*,*) "" - - write (*,"(A28)",advance="no") " total number of orbitals: " - do i = 1, numberOfSpecies - write (*,"(I5)",advance="no") int(MolecularSystem_getTotalNumberOfContractions( i )* & - ConfigurationInteraction_instance%lambda%values(i) ) - end do - write (*,*) "" - - - write (*,"(A28)",advance="no") " frozen core orbitals: " - do i = 1, numberOfSpecies - write (*,"(I5)",advance="no") ConfigurationInteraction_instance%numberOfCoreOrbitals%values(i) - end do - write (*,*) "" - - write (*,"(A28)",advance="no") " active occupied orbitals: " - do i = 1, numberOfSpecies - write (*,"(I5)",advance="no") ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - & - ConfigurationInteraction_instance%numberOfCoreOrbitals%values(i) - end do - write (*,*) "" - - write (*,"(A28)",advance="no") " active virtual orbitals: " - do i = 1, numberOfSpecies - write (*,"(I5)",advance="no") ConfigurationInteraction_instance%numberOfOrbitals%values(i) - & - ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - end do - write (*,*) "" - - write (*,"(A28)",advance="no") " total active orbitals: " - do i = 1, numberOfSpecies - write (*,"(I5)",advance="no") ConfigurationInteraction_instance%numberOfOrbitals%values(i) - & - ConfigurationInteraction_instance%numberOfCoreOrbitals%values(i) - end do - write (*,*) "" - write (*,*) " " - - write (*,*) "Getting transformed integrals..." - call ConfigurationInteraction_getTransformedIntegrals() - write (*,*) " " - - !write (*,*) ConfigurationInteraction_instance%fourCenterIntegrals(1,1)%values(171, 1) a bug... - write (*,*) "Setting CI level..." - - call ConfigurationInteraction_settingCILevel() - - !! write (*,*) "Total number of configurations", ConfigurationInteraction_instance%numberOfConfigurations - write (*,*) "" - call Vector_constructor8 ( ConfigurationInteraction_instance%eigenvalues, & - int(CONTROL_instance%NUMBER_OF_CI_STATES,8), 0.0_8 ) - - select case (trim(String_getUppercase(CONTROL_instance%CI_DIAGONALIZATION_METHOD))) - - ! case ("ARPACK") - - ! write (*,*) "This method was removed" - - case ("JADAMILU") - - write (*,*) "Building Strings..." - call ConfigurationInteraction_buildStrings() - - write (*,*) "Building CI level table..." - call ConfigurationInteraction_buildCIOrderList() - - call ConfigurationInteraction_buildCouplingMatrix() - call ConfigurationInteraction_buildCouplingOrderList() - - write (*,*) "Building diagonal..." - call ConfigurationInteraction_buildDiagonal() - - write (*,*) "Building initial hamiltonian..." - call ConfigurationInteraction_buildInitialCIMatrix2() - !!call ConfigurationInteraction_buildHamiltonianMatrix() This should be modified to build the CI matrix in memory - - call Matrix_constructor (ConfigurationInteraction_instance%eigenVectors, & - int(ConfigurationInteraction_instance%numberOfConfigurations,8), & - int(CONTROL_instance%NUMBER_OF_CI_STATES,8), 0.0_8) - - if ( CONTROL_instance%CI_LOAD_EIGENVECTOR ) then - call ConfigurationInteraction_loadEigenVector (ConfigurationInteraction_instance%eigenvalues, & - ConfigurationInteraction_instance%eigenVectors) - end if - - if ( CONTROL_instance%CI_BUILD_FULL_MATRIX ) then - write (*,*) "Building and saving hamiltonian..." - call ConfigurationInteraction_buildAndSaveCIMatrix() - end if - - write(*,*) "" - write(*,*) "Diagonalizing hamiltonian..." - write(*,*) " Using : ", trim(String_getUppercase((CONTROL_instance%CI_DIAGONALIZATION_METHOD))) - write(*,*) "=============================================================" - write(*,*) "M. BOLLHÖFER AND Y. NOTAY, JADAMILU:" - write(*,*) " a software code for computing selected eigenvalues of " - write(*,*) " large sparse symmetric matrices, " - write(*,*) "Computer Physics Communications, vol. 177, pp. 951-964, 2007." - write(*,*) "=============================================================" - - - call ConfigurationInteraction_jadamiluInterface(ConfigurationInteraction_instance%numberOfConfigurations, & - int(CONTROL_instance%NUMBER_OF_CI_STATES,8), & - ConfigurationInteraction_instance%eigenvalues, & - ConfigurationInteraction_instance%eigenVectors ) - - if ( CONTROL_instance%CI_SAVE_EIGENVECTOR ) then - call ConfigurationInteraction_saveEigenVector () - end if - case ("DSYEVX") - - write (*,*) "Building Strings..." - call ConfigurationInteraction_buildStrings() - - write (*,*) "Building CI level table..." - call ConfigurationInteraction_buildCIOrderList() - - write (*,*) "Building diagonal..." - call ConfigurationInteraction_buildDiagonal() - - write (*,*) "Building Hamiltonian..." - call ConfigurationInteraction_buildHamiltonianMatrix() - - call Matrix_constructor (ConfigurationInteraction_instance%eigenVectors, & - int(ConfigurationInteraction_instance%numberOfConfigurations,8), & - int(CONTROL_instance%NUMBER_OF_CI_STATES,8), 0.0_8) - - !! deallocate transformed integrals - deallocate(ConfigurationInteraction_instance%twoCenterIntegrals) - deallocate(ConfigurationInteraction_instance%fourCenterIntegrals) - - write(*,*) "" - write(*,*) "Diagonalizing hamiltonian..." - write(*,*) " Using : ", trim(String_getUppercase((CONTROL_instance%CI_DIAGONALIZATION_METHOD))) - - call Matrix_eigen_select (ConfigurationInteraction_instance%hamiltonianMatrix, ConfigurationInteraction_instance%eigenvalues, & - int(1), int(CONTROL_instance%NUMBER_OF_CI_STATES), & - eigenVectors = ConfigurationInteraction_instance%eigenVectors, & - flags = int(SYMMETRIC,4)) - -! call Matrix_eigen_select (ConfigurationInteraction_instance%hamiltonianMatrix, ConfigurationInteraction_instance%eigenvalues, & -! 1, CONTROL_instance%NUMBER_OF_CI_STATES, & -! flags = SYMMETRIC, dm = ConfigurationInteraction_instance%numberOfConfigurations ) - - - case ("DSYEVR") - - write (*,*) "Building Strings..." - call ConfigurationInteraction_buildStrings() - - write (*,*) "Building CI level table..." - call ConfigurationInteraction_buildCIOrderList() - - write (*,*) "Building diagonal..." - call ConfigurationInteraction_buildDiagonal() - - write (*,*) "Building Hamiltonian..." - call ConfigurationInteraction_buildHamiltonianMatrix() - - call Matrix_constructor (ConfigurationInteraction_instance%eigenVectors, & - int(ConfigurationInteraction_instance%numberOfConfigurations,8), & - int(CONTROL_instance%NUMBER_OF_CI_STATES,8), 0.0_8) - - !! deallocate transformed integrals - deallocate(ConfigurationInteraction_instance%twoCenterIntegrals) - deallocate(ConfigurationInteraction_instance%fourCenterIntegrals) - - call Matrix_eigen_dsyevr (ConfigurationInteraction_instance%hamiltonianMatrix, ConfigurationInteraction_instance%eigenvalues, & - 1, CONTROL_instance%NUMBER_OF_CI_STATES, & - eigenVectors = ConfigurationInteraction_instance%eigenVectors, & - flags = SYMMETRIC) - -! call Matrix_eigen_dsyevr (ConfigurationInteraction_instance%hamiltonianMatrix, ConfigurationInteraction_instance%eigenvalues, & -! 1, CONTROL_instance%NUMBER_OF_CI_STATES, & -! flags = SYMMETRIC, dm = ConfigurationInteraction_instance%numberOfConfigurations ) - - case default - - call ConfigurationInteraction_exception( ERROR, "Configuration interactor constructor", "Diagonalization method not implemented") - - - end select - - write(*,*) "" - write(*,*) "-----------------------------------------------" - write(*,*) " END ", trim(ConfigurationInteraction_instance%level)," CALCULATION" - write(*,*) "===============================================" - write(*,*) "" - -! case ( "FCI-oneSpecie" ) -! -! print *, "" -! print *, "" -! print *, "===============================================" -! print *, "| Full CI for one specie calculation |" -! print *, "| Use fci program to perform the calculation |" -! print *, "-----------------------------------------------" -! print *, "" -! ! call ConfigurationInteraction_getTransformedIntegrals() -! !call ConfigurationInteraction_printTransformedIntegralsToFile() -! - - end subroutine ConfigurationInteraction_run - - !> - !! @brief Muestra informacion del objeto - !! - !! @param this - !< - subroutine ConfigurationInteraction_settingCILevel() - implicit none - - integer :: numberOfSpecies - integer :: i,ii,j,k,l,m,n,p,q,a,b,d,r,s - integer(8) :: c, cc - integer :: ma,mb,mc,md,me,pa,pb,pc,pd,pe - integer :: isLambdaEqual1 - type(ivector) :: order - type(vector), allocatable :: occupiedCode(:) - type(vector), allocatable :: unoccupiedCode(:) - integer, allocatable :: auxArray(:,:), auxvector(:),auxvectorA(:) - integer :: lambda, otherlambda - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - - if ( allocated( occupiedCode ) ) deallocate( occupiedCode ) - allocate (occupiedCode ( numberOfSpecies ) ) - if ( allocated( unoccupiedCode ) ) deallocate( unoccupiedCode ) - allocate (unoccupiedCode ( numberOfSpecies ) ) - - !1 auxiliary string for omp paralelization - do n = 1, ConfigurationInteraction_instance%nproc - do i = 1, numberOfSpecies - call Vector_constructorInteger( ConfigurationInteraction_instance%auxstring(n,i), & - int(ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i),4), int(0,4)) - end do - end do - - select case ( trim(ConfigurationInteraction_instance%level) ) - - case ( "FCI" ) - - do i=1, numberOfSpecies - ConfigurationInteraction_instance%CILevel(i) = ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - end do - - ConfigurationInteraction_instance%maxCILevel = sum(ConfigurationInteraction_instance%CILevel) - - case ( "CIS" ) - - do i=1, numberOfSpecies - ConfigurationInteraction_instance%CILevel(i) = 1 - end do - ConfigurationInteraction_instance%maxCILevel = 1 - - case ( "CISD" ) - - do i=1, numberOfSpecies - ConfigurationInteraction_instance%CILevel(i) = 2 - if ( ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) < 2 ) & - ConfigurationInteraction_instance%CILevel(i) = ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - end do - ConfigurationInteraction_instance%maxCILevel = 2 - - case ( "CISD+" ) - - if ( .not. numberOfSpecies == 3 ) call ConfigurationInteraction_exception( ERROR, "Configuration interactor constructor", "CISD+ is specific for three quantum species") - - do i=1, numberOfSpecies - ConfigurationInteraction_instance%CILevel(i) = 2 - if ( ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) < 2 ) & - ConfigurationInteraction_instance%CILevel(i) = ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - end do - ConfigurationInteraction_instance%maxCILevel = 2 - - case ( "CISD+2" ) - - if ( .not. numberOfSpecies == 4 ) call ConfigurationInteraction_exception( ERROR, "Configuration interactor constructor", "CISD+2 is specific for three quantum species") - do i=1, numberOfSpecies - ConfigurationInteraction_instance%CILevel(i) = 2 - if ( ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) < 2 ) & - ConfigurationInteraction_instance%CILevel(i) = ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - end do - ConfigurationInteraction_instance%maxCILevel = 2 - - case ("CISDT") - - do i=1, numberOfSpecies - ConfigurationInteraction_instance%CILevel(i) = 3 - if ( ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) < 3 ) & - ConfigurationInteraction_instance%CILevel(i) = ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - end do - ConfigurationInteraction_instance%maxCILevel = 3 - - case ("CISDTQ") - - do i=1, numberOfSpecies - ConfigurationInteraction_instance%CILevel(i) = 4 - if ( ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) < 4 ) & - ConfigurationInteraction_instance%CILevel(i) = ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - end do - ConfigurationInteraction_instance%maxCILevel = 4 - - case ("CISDTQQ") - - do i=1, numberOfSpecies - ConfigurationInteraction_instance%CILevel(i) = 5 - if ( ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) < 5 ) & - ConfigurationInteraction_instance%CILevel(i) = ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - end do - ConfigurationInteraction_instance%maxCILevel = 5 - - case default - - call ConfigurationInteraction_exception( ERROR, "Configuration interactor constructor", "Correction level not implemented") - - end select - - - end subroutine ConfigurationInteraction_settingCILevel - - !> - !! @brief Muestra informacion del objeto - !! - !! @param this - !< - subroutine ConfigurationInteraction_buildCouplingMatrix() - implicit none - - integer(8) :: a,b,c1,c2 - integer :: u,v,p - integer :: i,n - integer :: auxis,auxos - integer :: numberOfSpecies - real(8) :: timeA, timeB - integer(1) :: coupling - integer(1), allocatable :: orbitalsA(:), orbitalsB(:) - integer(8), allocatable :: indexConfA(:) - integer(8), allocatable :: indexConfB(:) - integer(1), allocatable :: couplingOrder(:) - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - coupling = 0 - - !! allocate arrays - do n = 1, ConfigurationInteraction_instance%nproc - do i = 1, numberOfSpecies - - call Matrix_constructorInteger ( ConfigurationInteraction_instance%couplingMatrix(i,n), & - sum(ConfigurationInteraction_instance%numberOfStrings(i)%values), 3_8 , 0) - - call Matrix_constructorInteger(ConfigurationInteraction_instance%nCouplingOneTwo(i,n), & - 3_8, int(size(ConfigurationInteraction_instance%numberOfStrings(i)%values, dim=1),8), 0 ) - - call Matrix_constructorInteger(ConfigurationInteraction_instance%nCouplingSize(i,n), & - 3_8, int(size(ConfigurationInteraction_instance%numberOfStrings(i)%values, dim=1) + 1 ,8), 0 ) - - call Vector_constructor(ConfigurationInteraction_instance%couplingMatrixEnergyOne(i,n), & - int(sum(ConfigurationInteraction_instance%numberOfStrings(i)%values),4), 0.0_8 ) - - call Vector_constructorInteger(ConfigurationInteraction_instance%couplingMatrixFactorOne(i,n), & - int(sum(ConfigurationInteraction_instance%numberOfStrings(i)%values),4), 2 ) - - call Vector_constructorInteger( ConfigurationInteraction_instance%couplingMatrixOrbOne(i,n), & - int(sum(ConfigurationInteraction_instance%numberOfStrings(i)%values),4), 0 ) - - end do - end do - - end subroutine ConfigurationInteraction_buildCouplingMatrix - - function ConfigurationInteraction_calculateEnergyOneSame( n, ii, thisA, thisB ) result (auxCIenergy) - implicit none - integer(8) :: thisA(:), thisB(:) - integer(8) :: a, b - integer :: i,j,s,n, nn,ii - integer :: l,k,z,kk,ll - integer :: factor, factor2, auxOcc, AA, BB - logical(1) :: equalA, equalB - integer :: auxnumberOfOtherSpecieSpatialOrbitals - integer(8) :: auxIndex1, auxIndex2, auxIndex - integer :: diffOrb(2), otherdiffOrb(2) !! to avoid confusions - real(8) :: auxCIenergy - - auxCIenergy = 0.0_8 - factor = 1 - - !! copy a - a = thisA(ii) - b = thisB(ii) - - diffOrb = 0 - - do kk = 1, ConfigurationInteraction_instance%occupationNumber(ii) - if ( ConfigurationInteraction_instance%orbitals(ii)%values( & - ConfigurationInteraction_instance%strings(ii)%values(kk,a),b) == 0 ) then - diffOrb(1) = ConfigurationInteraction_instance%strings(ii)%values(kk,a) - AA = kk - exit - end if - end do - - do kk = 1, ConfigurationInteraction_instance%occupationNumber(ii) - if ( ConfigurationInteraction_instance%orbitals(ii)%values( & - ConfigurationInteraction_instance%strings(ii)%values(kk,b),a) == 0 ) then - diffOrb(2) = ConfigurationInteraction_instance%strings(ii)%values(kk,b) - BB = kk - exit - end if - end do - - factor = (-1)**(AA-BB) - - configurationInteraction_instance%couplingMatrixFactorOne(ii,n)%values(b) = factor - - !One particle terms - - auxCIenergy= auxCIenergy + ConfigurationInteraction_instance%twoCenterIntegrals(ii)%values( diffOrb(1), diffOrb(2) ) - - !! save the different orbitals - - auxIndex1= ConfigurationInteraction_instance%twoIndexArray(ii)%values( diffOrb(1), diffOrb(2)) - ConfigurationInteraction_instance%couplingMatrixOrbOne(ii,n)%values(b) = auxIndex1 - - do ll=1, ConfigurationInteraction_instance%occupationNumber( ii ) !! the same orbitals pair are excluded by the exchange - - l = ConfigurationInteraction_instance%strings(ii)%values(ll,b) !! or a - - auxIndex2 = ConfigurationInteraction_instance%twoIndexArray(ii)%values( l,l) - auxIndex = ConfigurationInteraction_instance%fourIndexArray(ii)%values( auxIndex1, auxIndex2 ) - - auxCIenergy = auxCIenergy + ConfigurationInteraction_instance%fourCenterIntegrals(ii,ii)%values(auxIndex, 1) - - auxIndex = ConfigurationInteraction_instance%fourIndexArray(ii)%values( & - ConfigurationInteraction_instance%twoIndexArray(ii)%values(diffOrb(1),l), & - ConfigurationInteraction_instance%twoIndexArray(ii)%values(l,diffOrb(2)) ) - - auxCIenergy = auxCIenergy + & - MolecularSystem_instance%species(ii)%kappa*ConfigurationInteraction_instance%fourCenterIntegrals(ii,ii)%values(auxIndex, 1) - - end do - - !end if - - auxCIenergy= auxCIenergy * factor - - end function ConfigurationInteraction_calculateEnergyOneSame - - function ConfigurationInteraction_calculateEnergyOneDiff( ii, thisB, nn ) result (auxCIenergy) - implicit none - integer(8) :: thisB(:) - integer(8) :: b - integer :: i,j,ii, nn - integer :: l,ll - integer :: factor - integer :: auxnumberOfOtherSpecieSpatialOrbitals - integer :: auxIndex1, auxIndex11, auxIndex - real(8) :: auxCIenergy - - auxCIenergy = 0.0_8 - - b = thisB(ii) - - auxIndex1 = ConfigurationInteraction_instance%couplingMatrixOrbOne(ii,nn)%values(b) - factor = ConfigurationInteraction_instance%couplingMatrixFactorOne(ii,nn)%values(b) - - do j=1, ii - 1 !! avoid ii, same species - - b = thisB(j) - - auxnumberOfOtherSpecieSpatialOrbitals = ConfigurationInteraction_instance%numberOfSpatialOrbitals2%values(j) - auxIndex11 = auxnumberOfOtherSpecieSpatialOrbitals * (auxIndex1 - 1 ) - - do ll=1, ConfigurationInteraction_instance%occupationNumber( j ) - - l = ConfigurationInteraction_instance%strings(j)%values(ll,b) - - auxIndex = auxIndex11 + ConfigurationInteraction_instance%twoIndexArray(j)%values( l,l) - - auxCIenergy = auxCIenergy + & - ConfigurationInteraction_instance%fourCenterIntegrals(ii,j)%values(auxIndex, 1) - - end do - - end do - - do j= ii + 1, MolecularSystem_instance%numberOfQuantumSpecies!! avoid ii, same species - - b = thisB(j) - - auxnumberOfOtherSpecieSpatialOrbitals = ConfigurationInteraction_instance%numberOfSpatialOrbitals2%values(j) - - auxIndex11 = auxnumberOfOtherSpecieSpatialOrbitals * (auxIndex1 - 1 ) - - do ll=1, ConfigurationInteraction_instance%occupationNumber( j ) - - l = ConfigurationInteraction_instance%strings(j)%values(ll,b) - - auxIndex = auxIndex11 + ConfigurationInteraction_instance%twoIndexArray(j)%values( l,l) - - auxCIenergy = auxCIenergy + & - ConfigurationInteraction_instance%fourCenterIntegrals(ii,j)%values(auxIndex, 1) - end do - - end do - - auxCIenergy= auxCIenergy * factor - - end function ConfigurationInteraction_calculateEnergyOneDiff - - - function ConfigurationInteraction_calculateEnergyTwoSame( ii, a, b ) result (auxCIenergy) - implicit none - integer(8) :: a, b - integer :: ii - integer :: kk,z - integer :: factor, AA(2), BB(2) - integer(8) :: auxIndex - integer :: diffOrbA(2), diffOrbB(2) !! to avoid confusions - real(8) :: auxCIenergy - - !diffOrbA = 0 - !diffOrbB = 0 - z = 0 - - do kk = 1, ConfigurationInteraction_instance%occupationNumber(ii) - if ( configurationinteraction_instance%orbitals(ii)%values( & - configurationinteraction_instance%strings(ii)%values(kk,a),b) == 0 ) then - z = z + 1 - diffOrbA(z) = ConfigurationInteraction_instance%strings(ii)%values(kk,a) - AA(z) = kk - if ( z == 2 ) exit - end if - end do - - z = 0 - do kk = 1, ConfigurationInteraction_instance%occupationNumber(ii) - if ( ConfigurationInteraction_instance%orbitals(ii)%values( & - ConfigurationInteraction_instance%strings(ii)%values(kk,b),a) == 0 ) then - z = z + 1 - diffOrbB(z) = ConfigurationInteraction_instance%strings(ii)%values(kk,b) - BB(z) = kk - if ( z == 2 ) exit - end if - end do - - factor = (-1)**(AA(1)-BB(1) + AA(2) - BB(2) ) - auxIndex = ConfigurationInteraction_instance%fourIndexArray(ii)%values( & - ConfigurationInteraction_instance%twoIndexArray(ii)%values(& - diffOrbA(1),diffOrbB(1)),& - ConfigurationInteraction_instance%twoIndexArray(ii)%values(& - diffOrbA(2),diffOrbB(2)) ) - - auxCIenergy = ConfigurationInteraction_instance%fourCenterIntegrals(ii,ii)%values(auxIndex, 1) - - auxIndex = ConfigurationInteraction_instance%fourIndexArray(ii)%values( & - ConfigurationInteraction_instance%twoIndexArray(ii)%values(& - diffOrbA(1),diffOrbB(2)),& - ConfigurationInteraction_instance%twoIndexArray(ii)%values(& - diffOrbA(2),diffOrbB(1)) ) - auxCIenergy = auxCIenergy + & - MolecularSystem_instance%species(ii)%kappa*ConfigurationInteraction_instance%fourCenterIntegrals(ii,ii)%values(auxIndex, 1) - - auxCIenergy= auxCIenergy * factor - - end function ConfigurationInteraction_calculateEnergyTwoSame - - !> - !! @brief Muestra informacion del objeto - !! - !! @param this - !< - subroutine ConfigurationInteraction_buildDiagonal() - implicit none - - integer(8) :: a,b,c - integer :: u,v - integer :: ci - integer :: i, j, ii, jj - integer :: s, numberOfSpecies, auxnumberOfSpecies - integer :: size1, size2 - real(8) :: timeA, timeB - integer(1) :: coupling - integer(8) :: numberOfConfigurations - real(8) :: CIenergy - integer(8), allocatable :: indexConf(:) - integer, allocatable :: cilevel(:), auxcilevel(:), dd(:) - -!$ timeA = omp_get_wtime() - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - coupling = 0 - CIenergy = 0 - s = 0 - c = 0 - numberOfConfigurations = 0 - - allocate ( ciLevel ( numberOfSpecies ) ) - allocate ( auxciLevel ( numberOfSpecies ) ) - allocate ( dd ( numberOfSpecies ) ) - - ciLevel = 0 - auxciLevel = 0 - - !!auxnumberOfSpecies = ConfigurationInteraction_numberOfConfigurationsRecursion2(s, numberOfSpecies, numberOfConfigurations, ciLevel) - - numberOfConfigurations = 0 - ciLevel = 0 - - !! call recursion to get the number of configurations... - do ci = 1, ConfigurationInteraction_instance%sizeCiOrderList - - cilevel(:) = ConfigurationInteraction_instance%ciOrderList( ConfigurationInteraction_instance%auxciOrderList(ci), :) - s = 0 - auxnumberOfSpecies = ConfigurationInteraction_numberOfConfigurationsRecursion(s, numberOfSpecies, numberOfConfigurations, ciLevel) - - end do - - call Vector_constructor8 ( ConfigurationInteraction_instance%diagonalHamiltonianMatrix2, & - numberOfConfigurations, 0.0_8 ) - - ConfigurationInteraction_instance%numberOfConfigurations = numberOfConfigurations - - write (*,*) "Number Of Configurations: ", numberOfConfigurations - - allocate ( indexConf ( numberOfSpecies ) ) - indexConf = 0 - - !! calculate the diagonal - s = 0 - c = 0 - ciLevel = 0 - - do ci = 1, ConfigurationInteraction_instance%sizeCiOrderList - - cilevel(:) = ConfigurationInteraction_instance%ciOrderList( ConfigurationInteraction_instance%auxciOrderList(ci), :) - s = 0 - dd = 0 - - u = ConfigurationInteraction_instance%auxciOrderList(ci) - auxnumberOfSpecies = ConfigurationInteraction_buildDiagonalRecursion( s, numberOfSpecies, indexConf, c, dd, u, cilevel, auxcilevel ) - end do - !stop - - deallocate ( dd ) - deallocate ( indexConf ) - deallocate ( ciLevel ) - deallocate ( auxciLevel ) - -!$ timeB = omp_get_wtime() -!$ write(*,"(A,E10.3,A4)") "** TOTAL Elapsed Time for Building diagonal of CI matrix : ", timeB - timeA ," (s)" - - write (*,*) "Reference energy, H_0: ", ConfigurationInteraction_instance%diagonalHamiltonianMatrix2%values(1) - - end subroutine ConfigurationInteraction_buildDiagonal - -recursive function ConfigurationInteraction_numberOfConfigurationsRecursion(s, numberOfSpecies, c, cilevel) result (os) - implicit none - - integer(8) :: a,b,c - integer :: u,v - integer :: i, j, ii, jj - integer :: s, numberOfSpecies - integer :: os,is - integer :: cilevel(:) - - is = s + 1 - if ( is < numberOfSpecies ) then - i = cilevel(is) + 1 - do a = 1, ConfigurationInteraction_instance%numberOfStrings(is)%values(i) - os = ConfigurationInteraction_numberOfConfigurationsRecursion( is, numberOfSpecies, c, cilevel ) - end do - else - os = is - - i = cilevel(is) + 1 - do a = 1, ConfigurationInteraction_instance%numberOfStrings(is)%values(i) - c = c + 1 - end do - end if - - end function ConfigurationInteraction_numberOfConfigurationsRecursion - -recursive function ConfigurationInteraction_buildDiagonalRecursion(s, numberOfSpecies, indexConf, c, dd, u, cilevel, auxcilevel) result (os) - implicit none - - integer(8) :: a,b,c,cc,d - integer :: u,v - integer :: i, j, ii, jj - integer :: s, numberOfSpecies - integer :: os,is - integer :: size1, size2 - integer(8) :: indexConf(:) - real(8) :: timeA, timeB - integer(1) :: coupling - integer(8) :: numberOfConfigurations - real(8) :: CIenergy - integer :: ssize - integer :: cilevel(:), auxcilevel(:), dd(:) - - is = s + 1 - if ( is < numberOfSpecies ) then - i = cilevel(is) + 1 - ssize = ConfigurationInteraction_instance%numberOfStrings2(is)%values(i) - do a = 1, ConfigurationInteraction_instance%numberOfStrings(is)%values(i) - indexConf(is) = ssize + a - - dd(is) =(a + ConfigurationInteraction_instance%ciOrderSize1(u,is))* ConfigurationInteraction_instance%ciOrderSize2(u,is) - os = ConfigurationInteraction_buildDiagonalRecursion( is, numberOfSpecies, indexConf, c, dd, u, cilevel, auxcilevel ) - end do - else - os = is - i = cilevel(is) + 1 - ssize = ConfigurationInteraction_instance%numberOfStrings2(is)%values(i) - do a = 1, ConfigurationInteraction_instance%numberOfStrings(is)%values(i) - c = c + 1 - indexConf(is) = ssize + a - !print *, indexConf - dd(is) =(a + ConfigurationInteraction_instance%ciOrderSize1(u,is))* ConfigurationInteraction_instance%ciOrderSize2(u,is) - d = sum(dd) - - ConfigurationInteraction_instance%diagonalHamiltonianMatrix2%values(c) = & - ConfigurationInteraction_calculateEnergyZero ( indexConf ) - - end do - end if - - end function ConfigurationInteraction_buildDiagonalRecursion - - !> - !! @brief Muestra informacion del objeto - !! - !! @param this - !< - - !! Map the indexes of initial CI matrix to the complete matrix. - subroutine ConfigurationInteraction_getInitialIndexes() - implicit none - - integer(8) :: a,b,c - integer :: u,v - integer :: ci - integer :: i, j, ii, jj - integer :: s, numberOfSpecies, auxnumberOfSpecies - integer :: size1, size2 - real(8) :: timeA, timeB - integer(1) :: coupling - integer(8) :: numberOfConfigurations - real(8) :: CIenergy - integer(8), allocatable :: indexConf(:) - integer, allocatable :: cilevel(:) - -!$ timeA = omp_get_wtime() - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - - s = 0 - c = 0 - - call Matrix_constructorInteger ( ConfigurationInteraction_instance%auxConfigurations, int( numberOfSpecies,8), & - int(CONTROL_instance%CI_SIZE_OF_GUESS_MATRIX,8), 0 ) - - !! call recursion - - allocate ( cilevel ( numberOfSpecies ) ) - allocate ( indexConf ( numberOfSpecies ) ) - - s = 0 - c = 0 - indexConf = 0 - cilevel = 0 - - do ci = 1, ConfigurationInteraction_instance%sizeCiOrderList - cilevel(:) = ConfigurationInteraction_instance%ciOrderList( ConfigurationInteraction_instance%auxciOrderList(ci), :) - s = 0 - auxnumberOfSpecies = ConfigurationInteraction_getIndexesRecursion( s, numberOfSpecies, indexConf, c, cilevel ) - end do - - deallocate ( indexConf ) - deallocate ( cilevel ) - -!$ timeB = omp_get_wtime() - -!$ write(*,"(A,E10.3,A4)") "** TOTAL Elapsed Time for getting initial indexes : ", timeB - timeA ," (s)" - - end subroutine ConfigurationInteraction_getInitialIndexes - -recursive function ConfigurationInteraction_getIndexesRecursion(s, numberOfSpecies, indexConf, c, cilevel) result (os) - implicit none - - integer(8) :: a,b,c - integer :: u,v - integer :: i, j, ii, jj - integer :: s, ss, numberOfSpecies - integer :: os,is - integer :: size1, size2 - integer(8) :: indexConf(:) - integer(1) :: coupling - integer :: ssize - integer :: cilevel(:) - - is = s + 1 - if ( is < numberOfSpecies ) then - i = cilevel(is) + 1 - ssize = ConfigurationInteraction_instance%numberOfStrings2(is)%values(i) - - do a = 1, ConfigurationInteraction_instance%numberOfStrings(is)%values(i) - indexConf(is) = ssize + a - os = ConfigurationInteraction_getIndexesRecursion( is, numberOfSpecies, indexConf, c, cilevel) - end do - else - os = is - i = cilevel(is) + 1 - ssize = ConfigurationInteraction_instance%numberOfStrings2(is)%values(i) - - do a = 1, ConfigurationInteraction_instance%numberOfStrings(is)%values(i) - c = c + 1 - indexConf(is) = ssize + a - do u = 1, CONTROL_instance%CI_SIZE_OF_GUESS_MATRIX - if ( c == ConfigurationInteraction_instance%auxIndexCIMatrix%values(u) ) then - do ss = 1, numberOfSpecies - ConfigurationInteraction_instance%auxConfigurations%values(ss,u) = indexConf(ss) - end do - end if - end do - end do - end if - - end function ConfigurationInteraction_getIndexesRecursion - - !> - !! @brief Muestra informacion del objeto - !! - !! @param this - !< - subroutine ConfigurationInteraction_calculateInitialCIMatrix() - implicit none - - integer(8) :: a,b,aa,bb - integer :: u,v - integer :: i - integer :: numberOfSpecies - real(8) :: timeA1, timeB1 - integer(1) :: coupling - integer(1), allocatable :: orbitalsA(:), orbitalsB(:) - integer :: initialCIMatrixSize - integer :: nproc - integer(8), allocatable :: indexConfA(:) - integer(8), allocatable :: indexConfB(:) - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - - initialCIMatrixSize = CONTROL_instance%CI_SIZE_OF_GUESS_MATRIX - - allocate ( indexConfA ( numberOfSpecies ) ) - allocate ( indexConfB ( numberOfSpecies ) ) - -!$ timeA1 = omp_get_wtime() - - do a = 1, initialCIMatrixSize - aa = ConfigurationInteraction_instance%auxIndexCIMatrix%values(a) - do b = a, initialCIMatrixSize - bb = ConfigurationInteraction_instance%auxIndexCIMatrix%values(b) - coupling = 0 - - indexConfA = 0 - indexConfB = 0 - - do i = 1, numberOfSpecies - - allocate (orbitalsA ( ConfigurationInteraction_instance%numberOfOrbitals%values(i) )) - allocate (orbitalsB ( ConfigurationInteraction_instance%numberOfOrbitals%values(i) )) - orbitalsA = 0 - orbitalsB = 0 - - indexConfA(i) = ConfigurationInteraction_instance%auxConfigurations%values(i,a) - indexConfB(i) = ConfigurationInteraction_instance%auxConfigurations%values(i,b) - - do u = 1, ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - orbitalsA( ConfigurationInteraction_instance%strings(i)%values(u,indexConfA(i) ) ) = 1 - end do - do v = 1, ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - orbitalsB( ConfigurationInteraction_instance%strings(i)%values(v,indexConfB(i) ) ) = 1 - end do - coupling = coupling + & - ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - sum ( orbitalsA * orbitalsB ) - - deallocate (orbitalsA ) - deallocate (orbitalsB ) - - end do - if ( coupling == 0 ) then - ConfigurationInteraction_instance%initialHamiltonianMatrix%values(a,b) = & - ConfigurationInteraction_instance%diagonalHamiltonianMatrix2%values(a) - - else if ( coupling == 1 ) then - - ConfigurationInteraction_instance%initialHamiltonianMatrix%values(a,b) = & - ConfigurationInteraction_calculateEnergyOne ( 1, indexConfA, indexConfB ) - - else if ( coupling == 2 ) then - - ConfigurationInteraction_instance%initialHamiltonianMatrix%values(a,b) = & - ConfigurationInteraction_calculateEnergyTwo ( 1, indexConfA, indexConfB ) - - end if - - - end do - - - end do - - deallocate ( indexConfB ) - deallocate ( indexConfA ) - -!$ timeB1 = omp_get_wtime() - !! symmetrize - do a = 1, initialCIMatrixSize - do b = a, initialCIMatrixSize - - ConfigurationInteraction_instance%initialHamiltonianMatrix%values(b,a) = & - ConfigurationInteraction_instance%initialHamiltonianMatrix%values(a,b) - end do - end do - - !!open(unit=318, file="cimatrix.dat", action = "write", form="formatted") - !!do a = 1, initialCIMatrixSize - !! do b = 1, initialCIMatrixSize - !! write (318,*) a,b, ConfigurationInteraction_instance%initialHamiltonianMatrix%values(a,b) - !! end do - !! write (318,*) " " - !!end do - !!close(318) -!$ write(*,"(A,E10.3,A4)") "** TOTAL Elapsed Time for Calculating initial CI matrix : ", timeB1 - timeA1 ," (s)" - - end subroutine ConfigurationInteraction_calculateInitialCIMatrix - - - subroutine ConfigurationInteraction_buildInitialCIMatrix2() - implicit none - - type(Configuration) :: auxConfigurationA, auxConfigurationB - type (Vector8) :: diagonalHamiltonianMatrix - integer :: a,b,c,aa,bb,i - real(8) :: timeA, timeB - real(8) :: CIenergy - integer :: initialCIMatrixSize - integer :: nproc - - !$ timeA = omp_get_wtime() - initialCIMatrixSize = CONTROL_instance%CI_SIZE_OF_GUESS_MATRIX - if ( ConfigurationInteraction_instance%numberOfConfigurations < CONTROL_instance%CI_SIZE_OF_GUESS_MATRIX ) then - CONTROL_instance%CI_SIZE_OF_GUESS_MATRIX = ConfigurationInteraction_instance%numberOfConfigurations !! assign to an internal variable - end if - - call Vector_constructorInteger8 ( ConfigurationInteraction_instance%auxIndexCIMatrix, & - ConfigurationInteraction_instance%numberOfConfigurations, 0_8 ) !hmm - - do a = 1, ConfigurationInteraction_instance%numberOfConfigurations - ConfigurationInteraction_instance%auxIndexCIMatrix%values(a)= a - end do - - !! save the unsorted diagonal Matrix - call Vector_constructor8 ( ConfigurationInteraction_instance%diagonalHamiltonianMatrix, & - ConfigurationInteraction_instance%numberOfConfigurations, 0.0_8 ) - - - ConfigurationInteraction_instance%diagonalHamiltonianMatrix%values = ConfigurationInteraction_instance%diagonalHamiltonianMatrix2%values - - !! To get only the lowest 300 values. - call Vector_reverseSortElements8( ConfigurationInteraction_instance%diagonalHamiltonianMatrix2, & - ConfigurationInteraction_instance%auxIndexCIMatrix, int(initialCIMatrixSize,8)) - - call Matrix_constructor ( ConfigurationInteraction_instance%initialHamiltonianMatrix, int(initialCIMatrixSize,8) , & - int(initialCIMatrixSize,8) , 0.0_8 ) - - !! get the configurations for the initial hamiltonian matrix - call ConfigurationInteraction_getInitialIndexes() - - call ConfigurationInteraction_calculateInitialCIMatrix() - - !! diagonalize the initial matrix - call Vector_constructor8 ( ConfigurationInteraction_instance%initialEigenValues, int(CONTROL_instance%NUMBER_OF_CI_STATES,8), 0.0_8) - - call Matrix_constructor (ConfigurationInteraction_instance%initialEigenVectors, & - int(initialCIMatrixSize,8), & - int(CONTROL_instance%NUMBER_OF_CI_STATES,8), 0.0_8) - - call Matrix_eigen_select ( ConfigurationInteraction_instance%initialHamiltonianMatrix, & - ConfigurationInteraction_instance%initialEigenValues, & - 1, int(CONTROL_instance%NUMBER_OF_CI_STATES,4), & - eigenVectors = ConfigurationInteraction_instance%initialEigenVectors, & - flags = int(SYMMETRIC,4)) - - write(*,*) "Initial eigenValues" - do i = 1, CONTROL_instance%NUMBER_OF_CI_STATES - write (*,*) i, ConfigurationInteraction_instance%initialEigenValues%values(i) - end do - - call Vector_destructor8 ( ConfigurationInteraction_instance%diagonalHamiltonianMatrix2 ) - -!$ timeB = omp_get_wtime() -!$ write(*,"(A,F10.3,A4)") "** TOTAL Elapsed Time for Solving Initial CI : ", timeB - timeA ," (s)" - - end subroutine ConfigurationInteraction_buildInitialCIMatrix2 - - - !> - !! @brief Muestra informacion del objeto - !! - !! @param this - !< - subroutine ConfigurationInteraction_buildHamiltonianMatrix() - implicit none - - integer(8) :: a,b,c - integer :: u,v,p - integer :: ci - integer :: i, j, ii, jj - integer :: s, numberOfSpecies, auxnumberOfSpecies - integer :: size1, size2 - real(8) :: timeA, timeB - integer(1) :: coupling - integer(8) :: numberOfConfigurations - real(8) :: CIenergy - integer(8), allocatable :: indexConf(:) - integer(8), allocatable :: pindexConf(:,:) - integer, allocatable :: cilevel(:), auxcilevel(:), dd(:) - integer(8), allocatable :: indexConfA(:,:) - integer(8), allocatable :: indexConfB(:,:) - integer, allocatable :: stringAinB(:) - integer(1), allocatable :: couplingSpecies(:,:) - integer :: n,nproc - - -!$ timeA = omp_get_wtime() - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - - numberOfConfigurations = ConfigurationInteraction_instance%numberOfConfigurations - - allocate ( ConfigurationInteraction_instance%allIndexConf( numberOfSpecies, numberOfConfigurations ) ) - allocate ( ciLevel ( numberOfSpecies ) ) - allocate ( indexConf ( numberOfSpecies ) ) - ciLevel = 0 - ConfigurationInteraction_instance%allIndexConf = 0 - indexConf = 0 - - !! gather all configurations - s = 0 - c = 0 - ciLevel = 0 - - do ci = 1, ConfigurationInteraction_instance%sizeCiOrderList - - cilevel(:) = ConfigurationInteraction_instance%ciOrderList( ConfigurationInteraction_instance%auxciOrderList(ci), :) - s = 0 - auxnumberOfSpecies = ConfigurationInteraction_gatherConfRecursion( s, numberOfSpecies, indexConf, c, cilevel ) - end do - !stop - - deallocate ( indexConf ) - deallocate ( ciLevel ) - - !! allocate the hamiltonian matrix - call Matrix_constructor ( ConfigurationInteraction_instance%hamiltonianMatrix, & - int(ConfigurationInteraction_instance%numberOfConfigurations,8), & - int(ConfigurationInteraction_instance%numberOfConfigurations,8), 0.0_8) - - - nproc = omp_get_max_threads() - !! calculate the matrix elements - allocate ( indexConfA ( numberOfSpecies, nproc ) ) - allocate ( indexConfB ( numberOfSpecies, nproc ) ) - allocate ( pindexConf ( numberOfSpecies, nproc ) ) - allocate ( couplingSpecies ( numberOfSpecies, nproc ) ) - - indexConfA = 0 - indexConfB = 0 - pindexConf = 0 - couplingSpecies = 0 - -!$omp parallel & -!$omp& private(a,b,coupling,i,p,stringAinB,n),& -!$omp& shared(ConfigurationInteraction_instance, HartreeFock_instance) - n = omp_get_thread_num() + 1 -!$omp do schedule (dynamic) - do a = 1, numberOfConfigurations - indexConfA(:,n) = ConfigurationInteraction_instance%allIndexConf(:,a) - do b = a, numberOfConfigurations - - indexConfB(:,n) = ConfigurationInteraction_instance%allIndexConf(:,b) - - do i = 1, numberOfSpecies - if ( pindexConf(i,n) /= indexConfB(i,n) ) then - allocate (stringAinB (ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) )) - stringAinB = 0 - do p = 1, ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - stringAinB(p) = ConfigurationInteraction_instance%orbitals(i)%values( & - ConfigurationInteraction_instance%strings(i)%values(p,indexConfA(i,n) ), indexConfB(i,n) ) - end do - couplingSpecies(i,n) = configurationinteraction_instance%numberOfOccupiedOrbitals%values(i) - sum ( stringAinB ) - deallocate (stringAinB ) - end if - end do - coupling = sum(couplingSpecies(:,n)) - - if ( coupling == 0 ) then - ConfigurationInteraction_instance%hamiltonianMatrix%values(a,b) = & - ConfigurationInteraction_instance%diagonalHamiltonianMatrix2%values(a) - - else if ( coupling == 1 ) then - - ConfigurationInteraction_instance%hamiltonianMatrix%values(a,b) = & - ConfigurationInteraction_calculateEnergyOne ( n, indexConfA(:,n), indexConfB(:,n) ) - - else if ( coupling == 2 ) then - - ConfigurationInteraction_instance%hamiltonianMatrix%values(a,b) = & - ConfigurationInteraction_calculateEnergyTwo ( n, indexConfA(:,n), indexConfB(:,n) ) - - end if - - pindexConf(:,n) = indexConfB(:,n) - - end do - pindexConf(:,n) = 0 - end do - !$omp end do nowait - !$omp end parallel - - deallocate ( pindexConf ) - deallocate ( couplingSpecies ) - deallocate ( indexConfB ) - deallocate ( indexConfA ) - - !! symmetrize - do a = 1, numberOfConfigurations - do b = a, numberOfConfigurations - ConfigurationInteraction_instance%hamiltonianMatrix%values(b,a) = & - ConfigurationInteraction_instance%hamiltonianMatrix%values(a,b) - end do - end do - - deallocate ( ConfigurationInteraction_instance%allIndexConf ) - -!$ timeB = omp_get_wtime() -!$ write(*,"(A,E10.3,A4)") "** TOTAL Elapsed Time for building Hamiltonian Matrix : ", timeB - timeA ," (s)" - - end subroutine ConfigurationInteraction_buildHamiltonianMatrix - -recursive function ConfigurationInteraction_gatherConfRecursion(s, numberOfSpecies, indexConf, c, cilevel ) result (os) - implicit none - - integer(8) :: a,b,c,cc,d - integer :: i, j, ii, jj - integer :: s, numberOfSpecies - integer :: os,is - integer :: size1, size2 - integer(8) :: indexConf(:) - integer(1) :: coupling - integer(8) :: numberOfConfigurations - real(8) :: CIenergy - integer :: ssize - integer :: cilevel(:) - - is = s + 1 - if ( is < numberOfSpecies ) then - i = cilevel(is) + 1 - ssize = ConfigurationInteraction_instance%numberOfStrings2(is)%values(i) - do a = 1, ConfigurationInteraction_instance%numberOfStrings(is)%values(i) - indexConf(is) = ssize + a - os = ConfigurationInteraction_gatherConfRecursion( is, numberOfSpecies, indexConf, c, cilevel ) - end do - else - os = is - i = cilevel(is) + 1 - ssize = ConfigurationInteraction_instance%numberOfStrings2(is)%values(i) - do a = 1, ConfigurationInteraction_instance%numberOfStrings(is)%values(i) - c = c + 1 - indexConf(is) = ssize + a - ConfigurationInteraction_instance%allIndexConf(:,c) = indexConf - - end do - end if - - end function ConfigurationInteraction_gatherConfRecursion - -recursive function ConfigurationInteraction_buildMatrixRecursion(nproc, s, indexConf, auxindexConf, cc, c, n, v, w, & - cilevel, auxcilevel) result (os) - implicit none - - integer(8) :: a,c,aa - integer :: i, n, nn, nproc - integer :: s, numberOfSpecies - integer :: os,is,ss,ssize - integer(8) :: cc(:) - integer(8) :: indexConf(:,:) - integer(8) :: auxindexConf(:,:) - real(8) :: v(:) - real(8) :: w(:) - integer :: cilevel(:,:) - integer :: auxcilevel(:,:) - - is = s + 1 - !if ( is < numberOfSpecies ) then - do ss = 1, ConfigurationInteraction_instance%recursionVector1(is) - i = cilevel(is,n) + 1 - ssize = ConfigurationInteraction_instance%numberOfStrings2(is)%values(i) - - do a = 1, ConfigurationInteraction_instance%numberOfStrings(is)%values(i) - indexConf(is,n:) = ssize + a - os = ConfigurationInteraction_buildMatrixRecursion( nproc, is, indexConf, auxindexConf, cc, c, n, v, w, cilevel, auxcilevel ) - end do - end do - !else - do ss = 1, ConfigurationInteraction_instance%recursionVector2(is) - os = is - i = cilevel(is,n) + 1 - ssize = ConfigurationInteraction_instance%numberOfStrings2(is)%values(i) - - do a = 1, ConfigurationInteraction_instance%numberOfStrings(is)%values(i) - c = c + 1 - - if ( abs(v(c)) > CONTROL_instance%CI_MATVEC_TOLERANCE ) then - cc(n) = c - indexConf(is,n:) = ssize + a - - auxindexConf = indexConf - auxcilevel = cilevel - - if ( n == nproc ) then - - !$omp parallel & - !$omp& private(nn),& - !$omp& shared(v,w, indexConf, cc, nproc, cilevel) - !$omp do schedule (static) - do nn = 1, nproc - call ConfigurationInteraction_buildRow( nn, indexConf(:,nn), cc(nn), w, v(cc(nn)), cilevel(:,nn)) - end do - !$omp end do nowait - !$omp end parallel - n = 0 - - do nn = 1, nproc - indexConf(:,nn) = indexConf(:,nproc) - cilevel(:,nn) = cilevel(:,nproc) - end do - end if - - n = n + 1 - - end if - - end do - end do - !end if - - - end function ConfigurationInteraction_buildMatrixRecursion - - !! Alternative option to the recursion with the same computational cost... However, it may be helpul some day. - - function ConfigurationInteraction_buildMatrixRecursion2(nproc, s, indexConf, auxindexConf, cc, c, n, v, w, & - cilevel, auxcilevel) result (os) - implicit none - - integer(8) :: a,c,aa, x - integer :: i, j, n, nn, nproc, ci - integer :: s, numberOfSpecies - integer :: os,is,ss,ssize - integer(8) :: cc(:) - integer(8) :: indexConf(:,:) - integer(8) :: auxindexConf(:,:) - real(8) :: v(:) - real(8) :: w(:) - integer :: cilevel(:,:) - integer(8) :: totalsize, auxtotalsize - integer :: auxcilevel(:,:) - integer, allocatable :: counter(:) - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - - allocate (counter(numberOfSpecies)) - counter = 0 - - totalsize = 1 - do i = 1 , numberOfSpecies - totalsize = totalsize * ConfigurationInteraction_instance%numberOfStrings(i)%values(cilevel(i,n) + 1) - end do - - do i = 1 , numberOfSpecies - ci = cilevel(i,n) + 1 - ssize = ConfigurationInteraction_instance%numberOfStrings2(i)%values(ci) - indexConf(i,n:) = ssize + 1 - end do - - indexConf(numberOfSpecies,n:) = indexConf(numberOfSpecies,n:) -1 - - do x = 1, totalsize - - indexConf(numberOfSpecies,n:) = indexConf(numberOfSpecies,n:) + 1 - - do i = numberOfSpecies, 1 + 1, -1 - auxtotalsize = 1 - do j = i, numberOfSpecies - auxtotalsize = auxtotalsize * ConfigurationInteraction_instance%numberOfStrings(j)%values(cilevel(j,n) + 1) - end do - if (counter(i) == auxtotalsize) then - do j = i, numberOfSpecies - ci = cilevel(j,n) + 1 - ssize = ConfigurationInteraction_instance%numberOfStrings2(j)%values(ci) - indexConf(j,n:) = ssize + 1 - end do - counter(i) = 0 - indexConf(i-1,n:) = indexConf(i-1,n:) + 1 - end if - counter(i) = counter(i) + 1 - - end do - !print *, indexConf(:,1) - end do - - deallocate (counter) - - end function ConfigurationInteraction_buildMatrixRecursion2 - - - subroutine ConfigurationInteraction_buildRow( nn, indexConfA, c, w, vc, cilevelA) - implicit none - - integer(8) :: a,b,c,bb,ci,d,cj - integer :: u,v,uu,vv, p, nn - integer :: i, j, auxis,auxos,is, ii, aa - integer :: numberOfSpecies, s - integer, allocatable :: stringAinB(:) - integer(4) :: coupling - integer(4) :: ssize,auxcoupling(3) !! 0,1,2 - integer(8) :: indexConfA(:) - integer(8), allocatable :: indexConfB(:) - integer(8), allocatable :: dd(:) - real(8) :: vc, CIenergy - real(8) :: w(:) - integer :: cilevelA(:) - integer, allocatable :: cilevel(:) - - - !ConfigurationInteraction_instance%pindexConf = 0 - - !!$ ConfigurationInteraction_instance%timeA(1) = omp_get_wtime() - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - - do i = 1, numberOfSpecies - - if ( ConfigurationInteraction_instance%pindexConf(i,nn) /= indexConfA(i) ) then - - ConfigurationInteraction_instance%nCouplingOneTwo(i,nn)%values = 0 - auxcoupling = 0 - - !allocate (stringBinA (ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) )) - allocate (stringAinB (ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) )) - - stringAinB = 0 - !stringBinA = 0 - - a = indexConfA(i) - - !!$ ConfigurationInteraction_instance%timeA(2) = omp_get_wtime() - - ssize = 0 - do ci = 1, size(ConfigurationInteraction_instance%numberOfStrings(i)%values, dim = 1) - do b = 1 + ssize , ConfigurationInteraction_instance%numberOfStrings(i)%values(ci) + ssize - - !b = ssize + bb - do p = ConfigurationInteraction_instance%numberOfCoreOrbitals%values(i)+1, & - ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - !do p = 1, & - ! ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - - stringAinB(p) = ConfigurationInteraction_instance%orbitals(i)%values( & - ConfigurationInteraction_instance%strings(i)%values(p,a),b) - - !stringBinA(p) = ConfigurationInteraction_instance%orbitals(i)%values( & - ! ConfigurationInteraction_instance%strings(i)%values(p,b),a) - end do - - coupling = configurationinteraction_instance%numberOfOccupiedOrbitals%values(i) - sum ( stringAinB ) - & - ConfigurationInteraction_instance%numberOfCoreOrbitals%values(i) - - ! coupling = configurationinteraction_instance%numberOfOccupiedOrbitals%values(i) - sum ( stringAinB ) - - if ( coupling <= 2 ) then - - coupling = coupling + 1 - - auxcoupling(coupling) = auxcoupling(coupling) + 1 - - ConfigurationInteraction_instance%nCouplingOneTwo(i,nn)%values( coupling, ci) = & - ConfigurationInteraction_instance%nCouplingOneTwo(i,nn)%values( coupling, ci) + 1 - - ConfigurationInteraction_instance%couplingMatrix(i,nn)%values( auxcoupling(coupling), coupling ) = b - end if - - end do - - ssize = ssize + ConfigurationInteraction_instance%numberOfStrings(i)%values(ci) - - end do - - deallocate (stringAinB) - !deallocate (stringBinA) - end if - - end do - - !!$ ConfigurationInteraction_instance%timeB(1) = omp_get_wtime() - - do is = 1, numberOfSpecies - do i = 1, 3 !! 0,1,2 - ssize = 0 - do ci = 1, size(ConfigurationInteraction_instance%numberOfStrings(is)%values, dim = 1) !! 1 is always zero - ssize = ssize + ConfigurationInteraction_instance%nCouplingOneTwo(is,nn)%values( i,ci ) - ConfigurationInteraction_instance%nCouplingSize(is,nn)%values( i,ci+1 ) = ssize - end do - ConfigurationInteraction_instance%nCouplingSize(is,nn)%values( i,1 ) = 0 !0? - end do - end do - - - !!$ ConfigurationInteraction_instance%timeA(2) = omp_get_wtime() - allocate ( indexConfB ( numberOfSpecies ) ) - allocate ( cilevel ( numberOfSpecies ) ) - allocate ( dd ( numberOfSpecies ) ) - indexConfB = 0 - - !!$ ConfigurationInteraction_instance%timeB(2) = omp_get_wtime() - !!$ ConfigurationInteraction_instance%timeA(3) = omp_get_wtime() - - !!one diff same species - do i = 1, numberOfSpecies - - if ( ConfigurationInteraction_instance%pindexConf(i,nn) /= indexConfA(i) ) then - cilevel(:) = 0 - indexConfB = indexConfA - - cilevel = cilevelA - - do ci = 1, size(ConfigurationInteraction_instance%numberOfStrings(i)%values, dim = 1) !! 1 is always zero - cilevel(i) = ci - 1 - - auxos = ConfigurationInteraction_buildRowRecursionFirstOne( i, indexConfA, indexConfB, nn, cilevel ) - - end do - end if - end do - - !!$ ConfigurationInteraction_instance%timeB(3) = omp_get_wtime() - - !!$ ConfigurationInteraction_instance%timeA(4) = omp_get_wtime() - - !$omp atomic - w(c) = w(c) + vc*ConfigurationInteraction_instance%diagonalHamiltonianMatrix%values(c) - !$omp end atomic - - !!$ ConfigurationInteraction_instance%timeB(4) = omp_get_wtime() - - !!$ ConfigurationInteraction_instance%timeA(5) = omp_get_wtime() - !! one diff - do i = 1, numberOfSpecies - cilevel(:) = 0 - indexConfB = indexConfA - - cilevel = cilevelA - - do ci = 1, size(ConfigurationInteraction_instance%numberOfStrings(i)%values, dim = 1) !! 1 is always zero - cilevel(i) = ci - 1 - - do u = 1, configurationinteraction_instance%sizeciorderlist - if ( sum(abs(cilevel - & - configurationinteraction_instance%ciorderlist( configurationinteraction_instance%auxciorderlist(u), :))) == 0 ) then - - uu = configurationinteraction_instance%auxciorderlist(u) - dd = 0 - - auxos = ConfigurationInteraction_buildRowRecursionSecondOne( i, indexConfB, w, vc, dd, nn, cilevel, uu ) - exit - - end if - end do - end do - end do - - !!$ ConfigurationInteraction_instance%timeB(5) = omp_get_wtime() - !!$ ConfigurationInteraction_instance%timeA(6) = omp_get_wtime() - - !! two diff same species - do i = 1, numberOfSpecies - - cilevel(:) = 0 - indexConfB = indexConfA - cilevel = cilevelA - - do ci = 1, size(ConfigurationInteraction_instance%numberOfStrings(i)%values, dim = 1) !! 1 is always zero - cilevel(i) = ci - 1 - - do u = 1, ConfigurationInteraction_instance%sizeCiOrderList - if ( sum(abs(cilevel - & - ConfigurationInteraction_instance%ciOrderList( ConfigurationInteraction_instance%auxciOrderList(u), :))) == 0 ) then - uu = ConfigurationInteraction_instance%auxciOrderList(u) - dd = 0 - - if ( ConfigurationInteraction_instance%pindexConf(i,nn) /= indexConfA(i) ) then - auxos = ConfigurationInteraction_buildRowRecursionSecondTwoCal( i, indexConfA, indexConfB, w, vc, dd, nn, cilevel, uu ) - else - auxos = ConfigurationInteraction_buildRowRecursionSecondTwoGet( i, indexConfA, indexConfB, w, vc, dd, nn, cilevel, uu ) - end if - - exit - - end if - end do - end do - end do - - !!$ ConfigurationInteraction_instance%timeB(6) = omp_get_wtime() - !!$ ConfigurationInteraction_instance%timeA(7) = omp_get_wtime() - - !! two diff diff species - do v = 1, ConfigurationInteraction_instance%ncouplingOrderTwoDiff - - i = ConfigurationInteraction_instance%couplingOrderIndex(3,v)%values(1) - j = ConfigurationInteraction_instance%couplingOrderIndex(3,v)%values(2) - - indexConfB = indexConfA - cilevel = cilevelA - - do ci = 1, size(ConfigurationInteraction_instance%numberOfStrings(i)%values, dim = 1) !! 1 is always zero - cilevel(i) = ci - 1 - do cj = 1, size(ConfigurationInteraction_instance%numberOfStrings(j)%values, dim = 1) !! 1 is always zero - cilevel(j) = cj - 1 - do u = 1, ConfigurationInteraction_instance%sizeCiOrderList - if ( sum(abs(cilevel - & - ConfigurationInteraction_instance%ciOrderList( ConfigurationInteraction_instance%auxciOrderList(u), :))) == 0 ) then - - uu = ConfigurationInteraction_instance%auxciOrderList(u) - dd = 0 - auxos = ConfigurationInteraction_buildRowRecursionSecondTwoDiff( i, j, indexConfB, w, vc, dd, nn, cilevel, uu ) - exit - end if - end do - end do - end do - end do - - !!$ ConfigurationInteraction_instance%timeB(7) = omp_get_wtime() - - !!$ print *, "omptime" - !!$ print *, "1", ConfigurationInteraction_instance%timeB(1) - ConfigurationInteraction_instance%timeA(1) - !!$ print *, "2", ConfigurationInteraction_instance%timeB(2) - ConfigurationInteraction_instance%timeA(2) - !!$ print *, "3", ConfigurationInteraction_instance%timeB(3) - ConfigurationInteraction_instance%timeA(3) - !!$ print *, "4", ConfigurationInteraction_instance%timeB(4) - ConfigurationInteraction_instance%timeA(4) - !!$ print *, "5", ConfigurationInteraction_instance%timeB(5) - ConfigurationInteraction_instance%timeA(5) - !!$ print *, "6", ConfigurationInteraction_instance%timeB(6) - ConfigurationInteraction_instance%timeA(6) - !!$ print *, "7", ConfigurationInteraction_instance%timeB(7) - ConfigurationInteraction_instance%timeA(7) - - ConfigurationInteraction_instance%pindexConf(:,nn) = indexConfA(:) - - deallocate ( dd ) - deallocate ( cilevel ) - deallocate ( indexConfB ) - - end subroutine ConfigurationInteraction_buildRow - -recursive function ConfigurationInteraction_buildRowRecursionFirstOne( ii, indexConfA, indexConfB, nn, cilevel ) result (os) - implicit none - - integer(8) :: a, aa - integer :: ii, nn, ci - integer :: os, ssize - integer(8) :: indexConfA(:) - integer(8) :: indexConfB(:) - real(8) :: CIenergy - integer :: cilevel(:) - - ci = cilevel(ii) + 1 - ssize = ConfigurationInteraction_instance%nCouplingSize(ii,nn)%values( 2,ci ) - do aa = 1, ConfigurationInteraction_instance%nCouplingOneTwo(ii,nn)%values( 2,ci ) - a = ssize + aa - - indexConfB(ii) = ConfigurationInteraction_instance%couplingMatrix(ii,nn)%values(a, 2) - CIenergy = ConfigurationInteraction_calculateEnergyOneSame ( nn, ii, indexConfA, indexConfB ) - ConfigurationInteraction_instance%couplingMatrixEnergyOne(ii,nn)%values(indexConfB(ii)) = CIenergy - - end do - - end function ConfigurationInteraction_buildRowRecursionFirstOne - -recursive function ConfigurationInteraction_buildRowRecursionSecondOne( ii, indexConfB, w, vc, dd, nn, cilevel, u ) result (os) - implicit none - - integer(8) :: a,d, aa - integer :: ii, nn, ci, u, j - integer :: ssize - integer :: os,numberOfSpecies - integer(8) :: indexConfB(:) - integer(8) :: dd(:) - real(8) :: vc - real(8) :: w(:) - real(8) :: CIenergy - integer :: cilevel(:) - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - ci = cilevel(ii) + 1 - ssize = ConfigurationInteraction_instance%nCouplingSize(ii,nn)%values( 2,ci ) - - do j = 1, numberOfSpecies - dd(j) = (indexConfB(j) - ConfigurationInteraction_instance%numberOfStrings2(j)%values(cilevel(j)+1) + & - ConfigurationInteraction_instance%ciOrderSize1(u,j) )* ConfigurationInteraction_instance%ciOrderSize2(u,j) - end do - - do aa = 1, ConfigurationInteraction_instance%nCouplingOneTwo(ii,nn)%values( 2,ci ) - a = ssize + aa - - indexConfB(ii) = ConfigurationInteraction_instance%couplingMatrix(ii,nn)%values(a, 2) - - dd(ii) = (indexConfB(ii) - ConfigurationInteraction_instance%numberOfStrings2(ii)%values(ci) + & - ConfigurationInteraction_instance%ciOrderSize1(u,ii) )* ConfigurationInteraction_instance%ciOrderSize2(u,ii) - - d = sum(dd) - - CIenergy = ConfigurationInteraction_instance%couplingMatrixEnergyOne(ii,nn)%values(indexConfB(ii)) - CIenergy = CIenergy + ConfigurationInteraction_calculateEnergyOneDiff ( ii, indexConfB, nn ) - CIenergy = vc*CIenergy - - !$omp atomic - w(d) = w(d) + CIenergy - !$omp end atomic - end do - - end function ConfigurationInteraction_buildRowRecursionSecondOne - - function ConfigurationInteraction_buildRowRecursionSecondTwoCal( ii, indexConfA, indexConfB, w, vc, dd, nn, cilevel, u ) result (os) - implicit none - - integer(8) :: a,d, aa - integer :: i, ii, nn, ci, u, j - integer :: s, ssize - integer :: os,numberOfSpecies - integer(8) :: indexConfA(:) - integer(8) :: indexConfB(:) - integer(8) :: dd(:) - real(8) :: vc - real(8) :: w(:) - real(8) :: CIenergy - integer :: cilevel(:) - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - ci = cilevel(ii) + 1 - ssize = ConfigurationInteraction_instance%nCouplingSize(ii,nn)%values( 3,ci ) - - do j = 1, numberOfSpecies - dd(j) = (indexConfB(j) - ConfigurationInteraction_instance%numberOfStrings2(j)%values(cilevel(j)+1) + & - ConfigurationInteraction_instance%ciOrderSize1(u,j) )* ConfigurationInteraction_instance%ciOrderSize2(u,j) - end do - - do aa = 1, ConfigurationInteraction_instance%nCouplingOneTwo(ii,nn)%values( 3,ci ) - a = ssize + aa - - indexConfB(ii) = ConfigurationInteraction_instance%couplingMatrix(ii,nn)%values(a, 3) - dd(ii) = (indexConfB(ii) - ConfigurationInteraction_instance%numberOfStrings2(ii)%values(ci) + & - ConfigurationInteraction_instance%ciOrderSize1(u,ii) )* ConfigurationInteraction_instance%ciOrderSize2(u,ii) - - d = sum(dd) - - !CIenergy = ConfigurationInteraction_instance%couplingMatrixEnergyOne(ii,nn)%values(indexConfB(ii)) - CIenergy = ConfigurationInteraction_calculateEnergyTwoSame ( ii, indexConfA(ii), indexConfB(ii) ) - ConfigurationInteraction_instance%couplingMatrixEnergyOne(ii,nn)%values(indexConfB(ii)) = CIenergy - CIenergy = vc*CIenergy - - !$omp atomic - w(d) = w(d) + CIenergy - !$omp end atomic - end do - - end function ConfigurationInteraction_buildRowRecursionSecondTwoCal - - function ConfigurationInteraction_buildRowRecursionSecondTwoGet( ii, indexConfA, indexConfB, w, vc, dd, nn, cilevel, u ) result (os) - implicit none - - integer(8) :: a,d, aa - integer :: i, ii, nn, ci, u, j - integer :: s, ssize - integer :: os,numberOfSpecies - integer(8) :: indexConfA(:) - integer(8) :: indexConfB(:) - integer(8) :: dd(:) - real(8) :: vc - real(8) :: w(:) - real(8) :: CIenergy - integer :: cilevel(:) - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - ci = cilevel(ii) + 1 - ssize = ConfigurationInteraction_instance%nCouplingSize(ii,nn)%values( 3,ci ) - - do j = 1, numberOfSpecies - dd(j) = (indexConfB(j) - ConfigurationInteraction_instance%numberOfStrings2(j)%values(cilevel(j)+1) + & - ConfigurationInteraction_instance%ciOrderSize1(u,j) )* ConfigurationInteraction_instance%ciOrderSize2(u,j) - end do - - do aa = 1, ConfigurationInteraction_instance%nCouplingOneTwo(ii,nn)%values( 3,ci ) - a = ssize + aa - - indexConfB(ii) = ConfigurationInteraction_instance%couplingMatrix(ii,nn)%values(a, 3) - dd(ii) = (indexConfB(ii) - ConfigurationInteraction_instance%numberOfStrings2(ii)%values(ci) + & - ConfigurationInteraction_instance%ciOrderSize1(u,ii) )* ConfigurationInteraction_instance%ciOrderSize2(u,ii) - - d = sum(dd) - - CIenergy = ConfigurationInteraction_instance%couplingMatrixEnergyOne(ii,nn)%values(indexConfB(ii)) - !CIenergy = ConfigurationInteraction_calculateEnergyTwoSame ( ii, indexConfA(ii), indexConfB(ii) ) - CIenergy = vc*CIenergy - - !$omp atomic - w(d) = w(d) + CIenergy - !$omp end atomic - end do - - end function ConfigurationInteraction_buildRowRecursionSecondTwoGet - - function ConfigurationInteraction_buildRowRecursionSecondTwoDiff( ii, jj, indexConfB, w, vc, dd, nn, cilevel, u ) result (os) - implicit none - - integer(8) :: ai,aj,d, aai, aaj - integer :: ii, nn, ci, u, k, jj, cj - integer :: ssizei, ssizej - integer :: bi, bj, factor, factori - integer :: auxIndex1, auxIndex2, auxIndex - integer :: os,numberOfSpecies - integer(8) :: indexConfB(:) - integer(8) :: dd(:) - real(8) :: vc - real(8) :: w(:) - real(8) :: CIenergy - integer :: cilevel(:) - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - ci = cilevel(ii) + 1 - cj = cilevel(jj) + 1 - ssizei = ConfigurationInteraction_instance%nCouplingSize(ii,nn)%values( 2,ci ) - ssizej = ConfigurationInteraction_instance%nCouplingSize(jj,nn)%values( 2,cj ) - - do k = 1, numberOfSpecies - dd(k) = (indexConfB(k) - ConfigurationInteraction_instance%numberOfStrings2(k)%values(cilevel(k)+1) + & - ConfigurationInteraction_instance%ciOrderSize1(u,k) )* ConfigurationInteraction_instance%ciOrderSize2(u,k) - end do - - do aai = 1, ConfigurationInteraction_instance%nCouplingOneTwo(ii,nn)%values( 2,ci ) - ai = ssizei + aai - indexConfB(ii) = ConfigurationInteraction_instance%couplingMatrix(ii,nn)%values(ai, 2) - dd(ii) = (indexConfB(ii) - ConfigurationInteraction_instance%numberOfStrings2(ii)%values(ci) + & - ConfigurationInteraction_instance%ciOrderSize1(u,ii) )* ConfigurationInteraction_instance%ciOrderSize2(u,ii) - - bi = indexConfB(ii) - factori = ConfigurationInteraction_instance%couplingMatrixFactorOne(ii,nn)%values(bi) - auxIndex1 = ConfigurationInteraction_instance%couplingMatrixOrbOne(ii,nn)%values(bi) - auxIndex1 = ConfigurationInteraction_instance%numberOfSpatialOrbitals2%values(jj) * (auxIndex1 - 1 ) - - do aaj = 1, ConfigurationInteraction_instance%nCouplingOneTwo(jj,nn)%values( 2,cj ) - aj = ssizej + aaj - indexConfB(jj) = ConfigurationInteraction_instance%couplingMatrix(jj,nn)%values(aj, 2) - - dd(jj) = (indexConfB(jj) - ConfigurationInteraction_instance%numberOfStrings2(jj)%values(cj) + & - ConfigurationInteraction_instance%ciOrderSize1(u,jj) )* ConfigurationInteraction_instance%ciOrderSize2(u,jj) - - d = sum(dd) - !CIenergy = vc*ConfigurationInteraction_calculateEnergyTwoDiff ( ii, jj, indexConfB, nn ) - - bj = indexConfB(jj) - factor = factori * ConfigurationInteraction_instance%couplingMatrixFactorOne(jj,nn)%values(bj) - auxIndex2 = ConfigurationInteraction_instance%couplingMatrixOrbOne(jj,nn)%values(bj) - auxIndex = auxIndex1 + auxIndex2 - - CIenergy = vc * factor *ConfigurationInteraction_instance%fourCenterIntegrals(ii,jj)%values(auxIndex, 1) - !CIenergy = vc*CIenergy - - !$omp atomic - w(d) = w(d) + CIenergy - !$omp end atomic - end do - end do - - end function ConfigurationInteraction_buildRowRecursionSecondTwoDiff - - - - function ConfigurationInteraction_getIndex ( indexConf ) result ( output ) - implicit none - integer(8) :: indexConf(:) - integer(8) :: output, ssize - integer :: i,j, numberOfSpecies - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - output = 0 - !! simplify!! - do i = 1, numberOfSpecies - ssize = 1 - do j = i + 1, numberOfSpecies - ssize = ssize * ConfigurationInteraction_instance%sumstrings(j) - !ssize = ssize * sum(ConfigurationInteraction_instance%numberOfStrings(j)%values(1:2)) - end do - output = output + ( indexConf(i) - 1 ) * ssize - end do - output = output + 1 - - end function ConfigurationInteraction_getIndex - -recursive function ConfigurationInteraction_getIndexSize(s, c, auxcilevel) result (os) - implicit none - - integer(8) :: a,b,c - integer :: u,v - integer :: i, j, ii, jj, ss - integer :: s, numberOfSpecies - integer :: os,is,cc, ssize - integer :: auxcilevel(:) - - is = s + 1 - do ss = 1, ConfigurationInteraction_instance%recursionVector1(is) - i = auxcilevel(is) + 1 - ssize = ConfigurationInteraction_instance%numberOfStrings2(is)%values(i) - do a = 1, ConfigurationInteraction_instance%numberOfStrings(is)%values(i) - os = ConfigurationInteraction_getIndexSize( is, c, auxcilevel ) - end do - end do - do ss = 1, ConfigurationInteraction_instance%recursionVector2(is) - os = is - i = auxcilevel(is) + 1 - ssize = ConfigurationInteraction_instance%numberOfStrings2(is)%values(i) - c = c + ConfigurationInteraction_instance%numberOfStrings(is)%values(i) - end do - - end function ConfigurationInteraction_getIndexSize - - !> - !! @brief Muestra informacion del objeto - !! - !! @param this - !< - subroutine ConfigurationInteraction_buildAndSaveCIMatrix() - implicit none - type(Configuration) :: auxConfigurationA, auxConfigurationB - integer(8) :: a,b,c,d,n, nproc,cc - real(8) :: timeA, timeB - character(50) :: CIFile - integer :: CIUnit - real(8) :: CIenergy - integer, allocatable :: indexArray(:),auxIndexArray(:) - real(8), allocatable :: energyArray(:),auxEnergyArray(:) - integer :: starting, ending, step, maxConfigurations - character(50) :: fileNumberA, fileNumberB - integer :: cmax - integer :: maxStackSize, i, ia, ib, ssize, ci,cj, size1, size2 - integer :: nblocks - - size1 = size(ConfigurationInteraction_instance%configurations(1)%occupations, dim=1) - size2 = size(ConfigurationInteraction_instance%configurations(1)%occupations, dim=2) - - maxStackSize = CONTROL_instance%CI_STACK_SIZE - - allocate (ConfigurationInteraction_instance%auxconfs (size1,size2, ConfigurationInteraction_instance%numberOfConfigurations )) - - do a=1, ConfigurationInteraction_instance%numberOfConfigurations - ConfigurationInteraction_instance%auxconfs(:,:,a) = ConfigurationInteraction_instance%configurations(a)%occupations - end do - - - timeA = omp_get_wtime() - - CIFile = "lowdin.ci" - CIUnit = 4 - -#ifdef intel - open(unit=CIUnit, file=trim(CIFile), action = "write", form="unformatted", BUFFERED="YES") -#else - open(unit=CIUnit, file=trim(CIFile), action = "write", form="unformatted") -#endif - - print *, " OMP Number of threads: " , omp_get_max_threads() - nproc = omp_get_max_threads() - - !call omp_set_num_threads(omp_get_max_threads()) - !call omp_set_num_threads(nproc) - - !if (allocated(cmax)) deallocate(cmax) - !allocate(cmax(nproc)) - cmax = 0 - - maxConfigurations = ConfigurationInteraction_instance%numberOfConfigurations - if (allocated(indexArray )) deallocate(indexArray) - allocate (indexArray(maxConfigurations)) - indexArray = 0 - if (allocated(energyArray )) deallocate(energyArray) - allocate (energyArray(maxConfigurations)) - energyArray = 0 - - do a=1, ConfigurationInteraction_instance%numberOfConfigurations - - !indexArray = 0 - energyArray = 0 - c = 0 - -!$omp parallel & -!$omp& private(b,CIenergy),& -!$omp& shared(indexArray,energyArray, HartreeFock_instance),& -!$omp& shared(ConfigurationInteraction_instance) reduction (+:c) -!$omp do schedule(guided) - do b= a, ConfigurationInteraction_instance%numberOfConfigurations -! CIenergy = ConfigurationInteraction_calculateCoupling( a, b, size1, size2 ) - - if ( abs(CIenergy) > 1E-9 ) then - c = c +1 - !indexArray(b) = b - energyArray(b) = CIenergy - end if - end do -!$omp end do nowait -!$omp end parallel - - - cmax = cmax + c - - write(CIUnit) c - write(CIUnit) a - - allocate (auxEnergyArray(c)) - allocate (auxIndexArray(c)) - - cj = 0 - do ci = a, ConfigurationInteraction_instance%numberOfConfigurations - !if ( indexArray(ci) > 0 ) then - if ( abs(energyArray(ci)) > 1E-9 ) then - cj = cj + 1 - auxIndexArray(cj) =(ci) - auxEnergyArray(cj) = energyArray(ci) - end if - end do - nblocks = ceiling(real(c) / real(maxStackSize) ) - - do i = 1, nblocks - 1 - ib = maxStackSize * i - ia = ib - maxStackSize + 1 - write(CIUnit) auxIndexArray(ia:ib) - end do - - ia = maxStackSize * (nblocks - 1) + 1 - write(CIUnit) auxIndexArray(ia:c) - - deallocate(auxIndexArray) - - do i = 1, nblocks - 1 - ib = maxStackSize * i - ia = ib - maxStackSize + 1 - write(CIUnit) auxEnergyArray(ia:ib) - end do - - ia = maxStackSize * (nblocks - 1) + 1 - write(CIUnit) auxEnergyArray(ia:c) - - deallocate (auxEnergyArray) - - end do - - write(CIUnit) -1 - - close(CIUnit) - - deallocate(indexArray) - deallocate(energyArray) - - timeB = omp_get_wtime() - write(*,"(A,F10.3,A4)") "** TOTAL Elapsed Time for Building CI matrix : ", timeB - timeA ," (s)" - print *, "Nonzero elements", cmax - - end subroutine ConfigurationInteraction_buildAndSaveCIMatrix - - function ConfigurationInteraction_calculateEnergyZero( this ) result (auxCIenergy) - implicit none - - integer(8) :: this(:) - integer(8) :: a, b - integer :: i,j,s - integer :: l,k,z,kk,ll - integer :: factor - integer(2) :: numberOfDiffOrbitals - integer :: auxnumberOfOtherSpecieSpatialOrbitals - integer(8) :: auxIndex1, auxIndex2, auxIndex - real(8) :: auxCIenergy - - auxCIenergy = 0.0_8 - - do i = 1, MolecularSystem_instance%numberOfQuantumSpecies - a = this(i) - do kk=1, ConfigurationInteraction_instance%occupationNumber( i ) !! 1 is from a and 2 from b - - k = ConfigurationInteraction_instance%strings(i)%values(kk,a) - - !One particle terms - auxCIenergy = auxCIenergy + & - ConfigurationInteraction_instance%twoCenterIntegrals(i)%values( k, k ) - - !Two particles, same specie - auxIndex1 = ConfigurationInteraction_instance%twoIndexArray(i)%values(k,k) - - do ll = kk + 1, ConfigurationInteraction_instance%occupationNumber( i ) !! 1 is from a and 2 from b - - l = ConfigurationInteraction_instance%strings(i)%values(ll,a) - auxIndex2 = ConfigurationInteraction_instance%twoIndexArray(i)%values(l,l) - auxIndex = ConfigurationInteraction_instance%fourIndexArray(i)%values(auxIndex1,auxIndex2) - - !Coulomb - auxCIenergy = auxCIenergy + & - ConfigurationInteraction_instance%fourCenterIntegrals(i,i)%values(auxIndex, 1) - - !Exchange, depends on spin - - auxIndex = ConfigurationInteraction_instance%fourIndexArray(i)%values( & - ConfigurationInteraction_instance%twoIndexArray(i)%values(k,l), & - ConfigurationInteraction_instance%twoIndexArray(i)%values(l,k) ) - - auxCIenergy = auxCIenergy + & - MolecularSystem_instance%species(i)%kappa*ConfigurationInteraction_instance%fourCenterIntegrals(i,i)%values(auxIndex, 1) - end do - - !!Two particles, different species - do j = i + 1, MolecularSystem_instance%numberOfQuantumSpecies - b = this(j) - auxnumberOfOtherSpecieSpatialOrbitals = ConfigurationInteraction_instance%numberOfSpatialOrbitals2%values(j) - - do ll = 1, ConfigurationInteraction_instance%occupationNumber( j ) !! 1 is from a and 2 from b - l = ConfigurationInteraction_instance%strings(j)%values(ll,b) - - auxIndex2= ConfigurationInteraction_instance%twoIndexArray(j)%values(l,l) - auxIndex = auxnumberOfOtherSpecieSpatialOrbitals * (auxIndex1 - 1 ) + auxIndex2 - - auxCIenergy = auxCIenergy + &!couplingEnergy - ConfigurationInteraction_instance%fourCenterIntegrals(i,j)%values(auxIndex, 1) - - end do - - end do - - end do - end do - - auxCIenergy= auxCIenergy + HartreeFock_instance%puntualInteractionEnergy - - end function ConfigurationInteraction_calculateEnergyZero - - function ConfigurationInteraction_calculateEnergyOne( n, thisA, thisB ) result (auxCIenergy) - implicit none - integer(8) :: thisA(:), thisB(:) - integer(8) :: a, b - integer :: i,j,s,n, nn - integer :: l,k,z,kk,ll - integer :: factor - integer :: auxnumberOfOtherSpecieSpatialOrbitals - integer(8) :: auxIndex1, auxIndex2, auxIndex - integer :: diffOrb(2), otherdiffOrb(2) !! to avoid confusions - real(8) :: auxCIenergy - integer :: auxOcc - - auxCIenergy = 0.0_8 - - factor = 1 - - !! copy a - do i = 1, MolecularSystem_instance%numberOfQuantumSpecies - a = thisA(i) - - ConfigurationInteraction_instance%auxstring(n,i)%values(:) = ConfigurationInteraction_instance%strings(i)%values(:,a) - end do - - !! set at maximum coincidence - - do s = 1, MolecularSystem_instance%numberOfQuantumSpecies - a = thisA(s) - b = thisB(s) - - do i = 1, ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(s) !b - do j = 1, ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(s) !a - if ( ConfigurationInteraction_instance%auxstring(n,s)%values(j) == & - ConfigurationInteraction_instance%strings(s)%values(i,b) ) then - - auxOcc = ConfigurationInteraction_instance%auxstring(n,s)%values(i) - ConfigurationInteraction_instance%auxstring(n,s)%values(i) = ConfigurationInteraction_instance%strings(s)%values(i,b) - ConfigurationInteraction_instance%auxstring(n,s)%values(j) = auxOcc - if ( i /= j ) factor = -1*factor - exit - end if - end do - end do - end do - - !! calculate - do i = 1, MolecularSystem_instance%numberOfQuantumSpecies - - a = thisA(i) - b = thisB(i) - diffOrb = 0 - - do kk = 1, ConfigurationInteraction_instance%occupationNumber( i) !! 1 is from a and 2 from b - - if ( ConfigurationInteraction_instance%auxstring(n,i)%values(kk) .ne. & - ConfigurationInteraction_instance%strings(i)%values(kk,b) ) then - diffOrb(1) = ConfigurationInteraction_instance%auxstring(n,i)%values(kk) - diffOrb(2) = ConfigurationInteraction_instance%strings(i)%values(kk,b) - exit - end if - - end do - if ( diffOrb(2) > 0 ) then - - !One particle terms - auxCIenergy= auxCIenergy + ConfigurationInteraction_instance%twoCenterIntegrals(i)%values( & - diffOrb(1), diffOrb(2) ) - - auxIndex1= ConfigurationInteraction_instance%twoIndexArray(i)%values( & - diffOrb(1), diffOrb(2)) - - do ll = 1, ConfigurationInteraction_instance%occupationNumber( i ) !! 1 is from a and 2 from b - - if ( ConfigurationInteraction_instance%auxstring(n,i)%values(ll) .eq. & - ConfigurationInteraction_instance%strings(i)%values(ll,b) ) then - - l = ConfigurationInteraction_instance%auxstring(n,i)%values(ll) !! or b - - auxIndex2 = ConfigurationInteraction_instance%twoIndexArray(i)%values( l,l) - - auxIndex = ConfigurationInteraction_instance%fourIndexArray(i)%values( auxIndex1, auxIndex2 ) - - auxCIenergy = auxCIenergy + & - ConfigurationInteraction_instance%fourCenterIntegrals(i,i)%values(auxIndex, 1) - - - auxIndex = ConfigurationInteraction_instance%fourIndexArray(i)%values( & - ConfigurationInteraction_instance%twoIndexArray(i)%values(diffOrb(1),l), & - ConfigurationInteraction_instance%twoIndexArray(i)%values(l,diffOrb(2)) ) - - auxCIenergy = auxCIenergy + & - MolecularSystem_instance%species(i)%kappa*ConfigurationInteraction_instance%fourCenterIntegrals(i,i)%values(auxIndex, 1) - - end if - end do - if (MolecularSystem_instance%numberOfQuantumSpecies .gt. 1 ) then !.and. spin(1) .eq. spin(2) ) then - do j=1, MolecularSystem_instance%numberOfQuantumSpecies - - if (i .ne. j) then - - auxnumberOfOtherSpecieSpatialOrbitals = ConfigurationInteraction_instance%numberOfSpatialOrbitals2%values(j) - - do ll=1, ConfigurationInteraction_instance%occupationNumber( j ) !! 1 is from a and 2 from b - l = ConfigurationInteraction_instance%auxstring(n,j)%values(ll) !! or b? - - auxIndex2 = ConfigurationInteraction_instance%twoIndexArray(j)%values( l,l) - auxIndex = auxnumberOfOtherSpecieSpatialOrbitals * (auxIndex1 - 1 ) + auxIndex2 - - auxCIenergy = auxCIenergy + & - ConfigurationInteraction_instance%fourCenterIntegrals(i,j)%values(auxIndex, 1) - end do - end if - end do - end if - end if - end do - - auxCIenergy= auxCIenergy * factor - - - end function ConfigurationInteraction_calculateEnergyOne - - - function ConfigurationInteraction_calculateEnergyTwo( n, thisA, thisB ) result (auxCIenergy) - implicit none - integer(8) :: thisA(:), thisB(:) - integer(8) :: a, b - integer :: i,j,s,n - integer :: l,k,z,kk,ll - integer :: factor - integer :: auxnumberOfOtherSpecieSpatialOrbitals - integer(8) :: auxIndex1, auxIndex2, auxIndex - integer :: diffOrb(4), otherdiffOrb(4) !! to avoid confusions - real(8) :: auxCIenergy - integer :: auxOcc - - auxCIenergy = 0.0_8 - factor = 1 - - !! copy a - do i = 1, MolecularSystem_instance%numberOfQuantumSpecies - a = thisA(i) - ConfigurationInteraction_instance%auxstring(n,i)%values(:) = ConfigurationInteraction_instance%strings(i)%values(:,a) - end do - - !! set at maximum coincidence - - do s = 1, MolecularSystem_instance%numberOfQuantumSpecies - a = thisA(s) - b = thisB(s) - - do i = 1, ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(s) !b - do j = 1, ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(s) !a - if ( ConfigurationInteraction_instance%auxstring(n,s)%values(j) == & - ConfigurationInteraction_instance%strings(s)%values(i,b) ) then - - auxOcc = ConfigurationInteraction_instance%auxstring(n,s)%values(i) - ConfigurationInteraction_instance%auxstring(n,s)%values(i) = ConfigurationInteraction_instance%strings(s)%values(i,b) - ConfigurationInteraction_instance%auxstring(n,s)%values(j) = auxOcc - if ( i /= j ) factor = -1*factor - exit - end if - end do - end do - end do - - !!calculate - do i=1, MolecularSystem_instance%numberOfQuantumSpecies - - a = thisA(i) - b = thisB(i) - diffOrb = 0 - z = 1 - do k = 1, ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(i) - - if ( ConfigurationInteraction_instance%auxstring(n,i)%values(k) .ne. & - ConfigurationInteraction_instance%strings(i)%values(k,b) ) then - diffOrb(z) = ConfigurationInteraction_instance%auxstring(n,i)%values(k) - diffOrb(z+2) = ConfigurationInteraction_instance%strings(i)%values(k,b) - z = z + 1 - cycle - end if - end do - if ( diffOrb(2) > 0 ) then - - !Coulomb - auxIndex = ConfigurationInteraction_instance%fourIndexArray(i)%values( & - ConfigurationInteraction_instance%twoIndexArray(i)%values(& - diffOrb(1),diffOrb(3)),& - ConfigurationInteraction_instance%twoIndexArray(i)%values(& - diffOrb(2),diffOrb(4)) ) - - auxCIenergy = auxCIenergy + & - ConfigurationInteraction_instance%fourCenterIntegrals(i,i)%values(auxIndex, 1) - - auxIndex = ConfigurationInteraction_instance%fourIndexArray(i)%values( & - ConfigurationInteraction_instance%twoIndexArray(i)%values(& - diffOrb(1),diffOrb(4)),& - ConfigurationInteraction_instance%twoIndexArray(i)%values(& - diffOrb(2),diffOrb(3)) ) - - auxCIenergy = auxCIenergy + & - MolecularSystem_instance%species(i)%kappa*ConfigurationInteraction_instance%fourCenterIntegrals(i,i)%values(auxIndex, 1) - - end if - !! different species - do j = i + 1, MolecularSystem_instance%numberOfQuantumSpecies - auxnumberOfOtherSpecieSpatialOrbitals = ConfigurationInteraction_instance%numberOfSpatialOrbitals2%values(j) - otherdiffOrb = 0 - a = thisA(j) - b = thisB(j) - - do k = 1, ConfigurationInteraction_instance%numberOfOccupiedOrbitals%values(j) - if ( ConfigurationInteraction_instance%auxstring(n,j)%values(k) .ne. & - ConfigurationInteraction_instance%strings(j)%values(k,b) ) then - otherdiffOrb(1) = ConfigurationInteraction_instance%auxstring(n,j)%values(k) - otherdiffOrb(3) = ConfigurationInteraction_instance%strings(j)%values(k,b) - exit - end if - - end do - - if ( diffOrb(3) .gt. 0 .and. otherdiffOrb(3) .gt. 0 ) then - auxIndex1 = ConfigurationInteraction_instance%twoIndexArray(i)%values(& - diffOrb(1),diffOrb(3) ) - auxIndex2 = ConfigurationInteraction_instance%twoIndexArray(j)%values(& - otherdiffOrb(1),otherdiffOrb(3) ) - auxIndex = auxnumberOfOtherSpecieSpatialOrbitals * (auxIndex1 - 1 ) + auxIndex2 - - auxCIenergy = auxCIenergy + & - ConfigurationInteraction_instance%fourCenterIntegrals(i,j)%values(auxIndex, 1) - - end if - end do - end do - - auxCIenergy= auxCIenergy * factor - - end function ConfigurationInteraction_calculateEnergyTwo - - !> - !! @brief Muestra informacion del objeto - !! - !! @param this - !< - subroutine ConfigurationInteraction_getTransformedIntegrals() - implicit none - - integer :: numberOfSpecies - integer :: i,j,m,n,mu,nu,a,b - integer(8) :: c - integer :: specieID - integer :: otherSpecieID - character(10) :: nameOfSpecie - character(10) :: nameOfOtherSpecie - integer :: ocupationNumber - integer :: ocupationNumberOfOtherSpecie - integer :: numberOfContractions - integer :: numberOfContractionsOfOtherSpecie - type(Matrix) :: hcoreMatrix - type(Matrix) :: coefficients - real(8) :: charge - real(8) :: otherSpecieCharge - - integer :: ssize1, ssize2 - type(Matrix) :: externalPotential - - character(50) :: wfnFile - character(50) :: arguments(20) - integer :: wfnUnit - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - allocate(ConfigurationInteraction_instance%twoCenterIntegrals(numberOfSpecies)) - allocate(ConfigurationInteraction_instance%fourCenterIntegrals(numberOfSpecies,numberOfSpecies)) - - allocate(ConfigurationInteraction_instance%twoIndexArray(numberOfSpecies)) - allocate(ConfigurationInteraction_instance%fourIndexArray(numberOfSpecies)) - -! print *,"" -! print *,"BEGIN INTEGRALS TRANFORMATION:" -! print *,"========================================" -! print *,"" -! print *,"--------------------------------------------------" -! print *," Algorithm Four-index integral tranformation" -! print *," Yamamoto, Shigeyoshi; Nagashima, Umpei. " -! print *," Computer Physics Communications, 2005, 166, 58-65" -! print *,"--------------------------------------------------" -! print *,"" -! -! call TransformIntegrals_constructor( repulsionTransformer ) - - do i=1, numberOfSpecies - nameOfSpecie= trim( MolecularSystem_getNameOfSpecie( i ) ) - specieID = MolecularSystem_getSpecieID( nameOfSpecie=nameOfSpecie ) - ocupationNumber = MolecularSystem_getOcupationNumber( i ) - numberOfContractions = MolecularSystem_getTotalNumberOfContractions( i ) - charge=MolecularSystem_getCharge(i) - -! write (6,"(T10,A)")"ONE PARTICLE INTEGRALS TRANSFORMATION FOR: "//trim(nameOfSpecie) - call Matrix_constructor (ConfigurationInteraction_instance%twoCenterIntegrals(i), & - int(numberOfContractions,8), int(numberOfContractions,8), 0.0_8 ) - - call Matrix_constructor (hcoreMatrix,int(numberOfContractions,8), int(numberOfContractions,8), 0.0_8) - - !! Open file for wavefunction - - wfnFile = "lowdin.wfn" - wfnUnit = 20 - - open(unit=wfnUnit, file=trim(wfnFile), status="old", form="unformatted") - - arguments(2) = MolecularSystem_getNameOfSpecie(i) - arguments(1) = "COEFFICIENTS" - - coefficients = & - Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfContractions,4), & - columns= int(numberOfContractions,4), binary=.true., arguments=arguments(1:2)) - - arguments(1) = "HCORE" - - hcoreMatrix = & - Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfContractions,4), & - columns= int(numberOfContractions,4), binary=.true., arguments=arguments(1:2)) - - !arguments(1) = "FOCK" - !ConfigurationInteraction_instance%FockMatrix(i) = & - ! Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfContractions,4), & - ! columns= int(numberOfContractions,4), binary=.true., arguments=arguments(1:2)) - - !arguments(1) = "ORBITALS" - !call Vector_getFromFile( elementsNum = numberOfContractions, & - ! unit = wfnUnit, binary = .true., arguments = arguments(1:2), & - ! output =ConfigurationInteraction_instance%energyofmolecularorbitals(i) ) - - !do m=1,numberOfContractions - ! ConfigurationInteraction_instance%fockMatrix(i)%values(m,m) = & - ! ConfigurationInteraction_instance%energyofmolecularorbitals(i)%values(m) - !end do - - ! Already saved in hcore - ! if(CONTROL_instance%IS_THERE_EXTERNAL_POTENTIAL) then - ! arguments(1) = "EXTERNAL_POTENTIAL" - - ! externalPotential = & - ! Matrix_getFromFile(unit=wfnUnit, rows= int(numberOfContractions,4), & - ! columns= int(numberOfContractions,4), binary=.true., arguments=arguments(1:2)) - - ! hcoreMatrix%values = hcoreMatrix%values + externalPotential%values - ! end if - !print *, "fock matrix for species", i - !call matrix_show ( ConfigurationInteraction_instance%fockMatrix(i) ) - - do m=1,numberOfContractions - do n=m, numberOfContractions - do mu=1, numberOfContractions - do nu=1, numberOfContractions - ConfigurationInteraction_instance%twoCenterIntegrals(i)%values(m,n) = & - ConfigurationInteraction_instance%twoCenterIntegrals(i)%values(m,n) + & - coefficients%values(mu,m)* & - coefficients%values(nu,n)* & - hcoreMatrix%values(mu,nu) - end do - end do - end do - end do - -!! Not implemented yet -!! if( WaveFunction_HF_instance( specieID )%isThereExternalPotential ) then -!! do m=1,numberOfContractions -!! do n=m, numberOfContractions -!! do mu=1, numberOfContractions -!! do nu=1, numberOfContractions -!! ConfigurationInteraction_instance%twoCenterIntegrals(i)%values(m,n) = & -!! ConfigurationInteraction_instance%twoCenterIntegrals(i)%values(m,n) + & -!! WaveFunction_HF_instance( specieID )%waveFunctionCoefficients%values(mu,m)* & -!! WaveFunction_HF_instance( specieID )%waveFunctionCoefficients%values(nu,n) * & -!! WaveFunction_HF_instance( specieID )%ExternalPotentialMatrix%values(mu,nu) -!! end do -!! end do -!! end do -!! end do -!! end if - - do m = 1,numberOfContractions - do n = m, numberOfContractions - ConfigurationInteraction_instance%twoCenterIntegrals(i)%values(n,m)=& - ConfigurationInteraction_instance%twoCenterIntegrals(i)%values(m,n) - end do - end do - - call Matrix_constructorInteger8(ConfigurationInteraction_instance%twoIndexArray(i), & - int( numberOfContractions,8), int( numberOfContractions,8) , 0_8 ) - - c = 0 - do a=1,numberOfContractions - do b = a, numberOfContractions - c = c + 1 - ConfigurationInteraction_instance%twoIndexArray(i)%values(a,b) = c !IndexMap_tensorR2ToVectorC( a, b, numberOfContractions ) - ConfigurationInteraction_instance%twoIndexArray(i)%values(b,a) = ConfigurationInteraction_instance%twoIndexArray(i)%values(a,b) - end do - end do - - - ssize1 = MolecularSystem_getTotalNumberOfContractions( i ) - ssize1 = ( ssize1 * ( ssize1 + 1 ) ) / 2 - - call Matrix_constructorInteger8(ConfigurationInteraction_instance%fourIndexArray(i), & - int( ssize1,8), int( ssize1,8) , 0_8 ) - c = 0 - do a = 1, ssize1 - do b = a, ssize1 - c = c + 1 - ConfigurationInteraction_instance%fourIndexArray(i)%values(a,b) = c! IndexMap_tensorR2ToVectorC( a, b, numberOfContractions ) - ConfigurationInteraction_instance%fourIndexArray(i)%values(b,a) = & - ConfigurationInteraction_instance%fourIndexArray(i)%values(a,b) - end do - end do - - - call ReadTransformedIntegrals_readOneSpecies( specieID, ConfigurationInteraction_instance%fourCenterIntegrals(i,i) ) - ConfigurationInteraction_instance%fourCenterIntegrals(i,i)%values = & - ConfigurationInteraction_instance%fourCenterIntegrals(i,i)%values * charge * charge - - if ( numberOfSpecies > 1 ) then - do j = 1 , numberOfSpecies - if ( i .ne. j) then - nameOfOtherSpecie = trim( MolecularSystem_getNameOfSpecie( j ) ) - otherSpecieID = MolecularSystem_getSpecieID( nameOfSpecie=nameOfOtherSpecie ) - ocupationNumberOfOtherSpecie = MolecularSystem_getOcupationNumber( j ) - numberOfContractionsOfOtherSpecie = MolecularSystem_getTotalNumberOfContractions( j ) - otherSpecieCharge = MolecularSystem_getCharge(j) - - call ReadTransformedIntegrals_readTwoSpecies( specieID, otherSpecieID, & - ConfigurationInteraction_instance%fourCenterIntegrals(i,j) ) - ConfigurationInteraction_instance%fourCenterIntegrals(i,j)%values = & - ConfigurationInteraction_instance%fourCenterIntegrals(i,j)%values * charge * otherSpeciecharge - - - end if - end do - end if - end do - close (wfnUnit) - call Matrix_destructor (hcoreMatrix) - - end subroutine ConfigurationInteraction_getTransformedIntegrals - - !> - !! @brief Muestra informacion del objeto - !! - !! @param this - !< -! subroutine ConfigurationInteraction_printTransformedIntegralsToFile() -! implicit none -! -!! type(TransformIntegrals) :: repulsionTransformer -! integer :: numberOfSpecies -! integer :: i,j,m,n,mu,nu -! integer :: a,b,r,s,u, auxIndex -! integer :: z -! integer :: stats, recNum -! character(10) :: nameOfSpecie, auxNameOfSpecie -! character(10) :: nameOfOtherSpecie -! integer :: ocupationNumber -! integer :: ocupationNumberOfOtherSpecie -! integer :: numberOfContractions -! integer :: numberOfContractionsOfOtherSpecie -! type(Matrix) :: auxMatrix -! type(Matrix) :: molecularCouplingMatrix -! type(Matrix) :: molecularExtPotentialMatrix -! -! integer :: spin -! -! real(8) :: totalCoupEnergy -! real(8) :: fixedPotEnergy -! real(8) :: fixedIntEnergy -! real(8) :: KineticEnergy -! real(8) :: RepulsionEnergy -! real(8) :: couplingEnergy - - -! numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() -! -! print *,"" -! print *,"BEGIN INTEGRALS TRANFORMATION:" -! print *,"========================================" -! print *,"" -! print *,"--------------------------------------------------" -! print *," Algorithm Four-index integral tranformation" -! print *," Yamamoto, Shigeyoshi; Nagashima, Umpei. " -! print *," Computer Physics Communications, 2005, 166, 58-65" -! print *,"--------------------------------------------------" -! print *,"" -! -! totalCoupEnergy = 0.0_8 -! fixedPotEnergy = 0.0_8 -! fixedIntEnergy = 0.0_8 -! KineticEnergy = 0.0_8 -! RepulsionEnergy = 0.0_8 -! couplingEnergy = 0.0_8 -! spin = 0 -! -! do i=1, numberOfSpecies -! nameOfSpecie= trim( MolecularSystem_getNameOfSpecie( i ) ) -! numberOfContractions = MolecularSystem_getTotalNumberOfContractions( i ) -! spin = MolecularSystem_getMultiplicity(i) - 1 -! -! if(trim(nameOfSpecie) /= "E-BETA" ) then -! -! if(trim(nameOfSpecie) /= "U-" ) then -! -! open(unit=35, file="FCIDUMP-"//trim(nameOfSpecie)//".com", form="formatted", status="replace") -! -! write(35,"(A)")"gprint basis" -! write(35,"(A)")"memory 1000 M" -! write(35,"(A)")"cartesian" -! write(35,"(A)")"gthresh twoint=1e-12 prefac=1e-14 energy=1e-10 edens=1e-10 zero=1e-12" -! write(35,"(A)")"basis={" -! call ConfigurationInteraction_printBasisSetToFile(35) -! write(35,"(A)")"}" -! -! write(35,"(A)")"symmetry nosym" -! write(35,"(A)")"angstrom" -! write(35,"(A)")"geometry={" -! call ConfigurationInteraction_printGeometryToFile(35) -! write(35,"(A)")"}" -! -! write(35,"(A)")"import 21500.2 "//trim(trim(CONTROL_instance%INPUT_FILE)//trim(nameOfSpecie)//"."//"jcoup") -! write(35,"(A)")"import 21510.2 "//trim(trim(CONTROL_instance%INPUT_FILE)//trim(nameOfSpecie)//"."//"icoup") -! write(35,"(A)")"import 21520.2 "//trim(trim(CONTROL_instance%INPUT_FILE)//trim(nameOfSpecie)//"."//"kin") -! write(35,"(A)")"import 21530.2 "//trim(trim(CONTROL_instance%INPUT_FILE)//trim(nameOfSpecie)//"."//"coeff") -! -! if(trim(nameOfSpecie) == "E-ALPHA") then -! -! write(35,"(A)")"import 21550.2 "//trim(trim(CONTROL_instance%INPUT_FILE)//"E-BETA"//"."//"coeff") -! -! end if -! -! write(35,"(A)")"import 21540.2 "//trim(trim(CONTROL_instance%INPUT_FILE)//trim(nameOfSpecie)//"."//"dens") -! !write(35,"(A)")"import 21560.2 "//trim(trim(CONTROL_instance%INPUT_FILE)//trim(nameOfSpecie)//"."//"pot") -! -! write(35,"(A)")"{matrop" -! write(35,"(A)")"load Jcoup, SQUARE 21500.2" -! write(35,"(A)")"load Icoup, SQUARE 21510.2" -! write(35,"(A)")"load K, SQUARE 21520.2" -! !write(35,"(A)")"load Pot, SQUARE 21560.2" -! write(35,"(A)")"add H01, K Icoup Jcoup"! Pot" -! write(35,"(A)")"save H01, 21511.2 H0" -! write(35,"(A)")"}" -! -! if(trim(nameOfSpecie) == "E-ALPHA") then -! write(35,"(A)")"{matrop" -! write(35,"(A)")"load Ca, SQUARE 21530.2" -! write(35,"(A)")"load Cb, SQUARE 21550.2" -! write(35,"(A)")"save Ca, 2100.1 ORBITALS alpha" -! write(35,"(A)")"save Cb, 2100.1 ORBITALS beta" -! write(35,"(A)")"}" -! else -! write(35,"(A)")"{matrop" -! write(35,"(A)")"load C, SQUARE 21530.2" -! write(35,"(A)")"save C, 2100.1 ORBITALS" -! write(35,"(A)")"}" -! end if -! -! write(35,"(A)")"{matrop" -! write(35,"(A)")"load D, SQUARE 21540.2" -! write(35,"(A)")"save D, 21400.1 DENSITY" -! write(35,"(A)")"}" -! -! -! ! write(35,"(A,I3,A,I3,A,I3,A1)")"$FCI NORB=",numberOfContractions, ",NELEC=", MolecularSystem_getNumberOfParticles(i)-spin, ", MS2=", spin,"," -! ! -! ! write(35,"(A)",advance="no") "ORBSYM=" -! ! do z=1, numberOfContractions -! ! write(35,"(I1,A1)",advance="no") 1,"," -! ! end do -! ! write(35,"(A)") "" -! ! -! ! write(35, "(A,I3,A,I9)") "ISYM=",1, ",MEMORY=", 200000000 -! ! -! ! write(35, "(A)") "$" -! ! -! ! print *, "FOUR CENTER INTEGRALS FOR SPECIE: ", trim(nameOfSpecie) -! ! -! ! recNum = 0 -! ! do a = 1, numberOfContractions -! ! n = a -! ! do b=a, numberOfContractions -! ! u = b -! ! do r = n, numberOfContractions -! ! do s = u, numberOfContractions -! ! -! ! auxIndex = IndexMap_tensorR4ToVector( a, b, r, s, numberOfContractions ) -! ! write(35,"(F20.10,4I3)") ConfigurationInteraction_instance%fourCenterIntegrals(i,i)%values(auxIndex, 1), a, b, r, s -! ! -! ! end do -! ! u=r+1 -! ! end do -! ! end do -! ! end do -! ! -! ! -! ! print *, "TWO CENTER TRANSFORMED INTEGRALS FOR SPECIE: ", trim(nameOfSpecie) -! ! -! ! do m=1,numberOfContractions -! ! do n=1, m -! ! write(35,"(F20.10,4I3)") ConfigurationInteraction_instance%twoCenterIntegrals(i)%values(m,n), m, n, 0, 0 -! ! end do -! ! end do -! -! !!Calculating the core energy.... -! -! -! -! totalCoupEnergy = MolecularSystem_instance%totalCouplingEnergy -! fixedPotEnergy = MolecularSystem_instance%puntualInteractionEnergy -! -! do j = 1, numberOfSpecies -! -! auxNameOfSpecie= trim( MolecularSystem_getNameOfSpecie( j ) ) -! -! if(trim(auxNameOfSpecie) == "E-ALPHA" .or. trim(auxNameOfSpecie) == "E-BETA" .or. trim(auxNameOfSpecie) == "e-") cycle -! -! fixedIntEnergy = fixedIntEnergy + MolecularSystem_instance%quantumPuntualInteractionEnergy(j) -! KineticEnergy = KineticEnergy + MolecularSystem_instance%kineticEnergy(j) -! RepulsionEnergy = RepulsionEnergy + MolecularSystem_instance%repulsionEnergy(j) -! couplingEnergy = couplingEnergy + MolecularSystem_instance%couplingEnergy(j) -! -! end do -! -! !!COMO SEA QUE SE META LA ENERGIA DE CORE -! !write(35,"(F20.10,4I3)") (couplingEnergy-totalCoupEnergy+fixedPotEnergy+fixedIntEnergy+KineticEnergy+RepulsionEnergy), 0, 0, 0, 0 -! -! print*, "COREENERGY ", (couplingEnergy-totalCoupEnergy+fixedPotEnergy+fixedIntEnergy+KineticEnergy+RepulsionEnergy) -! -! write(35,"(A)")"{hf" -! write(35,"(A)")"maxit 250" -! write(35,"(A10,I2,A1,A6,I2,A1,A6,I3)")"wf spin=", spin, ",", "charge=",0, ",", "elec=", MolecularSystem_getNumberOfParticles(i)-spin -! write(35,"(A)")"start 2100.1" -! write(35,"(A)")"}" -! -! -! write(35,"(A)")"{fci" -! write(35,"(A)")"maxit 250" -! write(35,"(A)")"dm 21400.1, IGNORE_ERROR" -! write(35,"(A)")"orbit 2100.1, IGNORE_ERROR" -! write(35,"(A10,I2,A1,A6,I2,A1,A6,I3)")"wf spin=", spin, ",", "charge=",0, ",", "elec=", MolecularSystem_getNumberOfParticles(i)-spin -! ! write(35,"(A)")"print, orbital=2 integral = 2" -! ! write(35,"(A)")"CORE" -! write(35,"(A)")"}" -! -! write(35,"(A)")"{matrop" -! write(35,"(A)")"load D, DEN, 21400.1" -! ! write(35,"(A)")"print D" -! write(35,"(A)")"natorb Norb, D" -! write(35,"(A)")"save Norb, 21570.2" -! ! write(35,"(A)")"print Norb" -! write(35,"(A)")"}" -! -! write(35,"(A)")"put molden "//trim(trim(CONTROL_instance%INPUT_FILE)//trim(nameOfSpecie)//"."//"molden")//"; orb, 21570.2" -! -! close(35) -! -! print*, "" -! -! stats = system("molpro "//"FCIDUMP-"//trim(nameOfSpecie)//".com ") -! stats = system("cat "//"FCIDUMP-"//trim(nameOfSpecie)//".out ") -! -! print*, "" -! -! print *,"END" -! -! end if -! -! end if -! -! end do - -! end subroutine ConfigurationInteraction_printTransformedIntegralsToFile - -! subroutine ConfigurationInteraction_printGeometryToFile(unit) -! implicit none -! integer :: unit -! -! integer :: i -! integer :: from, to -! real(8) :: origin(3) -! character(50) :: auxString -! -! -! do i = 1, MolecularSystem_getTotalNumberOfParticles() -! -! origin = MolecularSystem_getOrigin( iterator = i ) * AMSTRONG -! auxString = trim( MolecularSystem_getNickName( iterator = i ) ) -! -! if( String_findSubstring( trim( auxString ), "e-") == 1 ) then -! if( String_findSubstring( trim( auxString ), "BETA") > 1 ) then -! cycle -! end if -! -! from =String_findSubstring( trim(auxString), "[") -! to = String_findSubstring( trim(auxString), "]") -! auxString = auxString(from+1:to-1) -! -! else if( String_findSubstring( trim( auxString ), "_") /= 0 ) then -! cycle -! end if -! -! -! write (unit,"(A10,3F20.10)") trim( auxString ), origin(1), origin(2), origin(3) -! -! end do - -! end subroutine ConfigurationInteraction_printGeometryToFile - - -! subroutine ConfigurationInteraction_printBasisSetToFile(unit) -! implicit none -! -! integer :: unit -! -! integer :: i, j -! character(16) :: auxString -! -! -! do i =1, MolecularSystem_instance%numberOfQuantumSpecies -! -! auxString=trim( Map_getKey( MolecularSystem_instance%speciesID, iterator=i ) ) -! -! if( String_findSubstring( trim(auxString), "e-") == 1 ) then -! -! if( String_findSubstring( trim(auxString), "BETA") > 1 ) then -! -! cycle -! -! end if -! -! -! end if -! -! if(trim(auxString)=="U-") cycle -! -! do j =1, size(MolecularSystem_instance%particlesPtr) -! -! if ( trim(MolecularSystem_instance%particlesPtr(j)%symbol) == trim( Map_getKey( MolecularSystem_instance%speciesID, iterator=i ) ) & -! .and. MolecularSystem_instance%particlesPtr(j)%isQuantum ) then -! -! call BasisSet_showInMolproForm( MolecularSystem_instance%particlesPtr(j)%basis, trim(MolecularSystem_instance%particlesPtr(j)%nickname), unit=unit ) -! -! end if -! -! end do -! -! end do - -! end subroutine ConfigurationInteraction_printBasisSetToFile - - - !** - ! @ Retorna la energia final com correccion Moller-Plesset de orrden dado - !** - function ConfigurationInteraction_getTotalEnergy() result(output) - implicit none - real(8) :: output - - output = ConfigurationInteraction_instance%totalEnergy - - end function ConfigurationInteraction_getTotalEnergy - - - !> - !! @brief Maneja excepciones de la clase - !< - subroutine ConfigurationInteraction_exception( typeMessage, description, debugDescription) - implicit none - integer :: typeMessage - character(*) :: description - character(*) :: debugDescription - - type(Exception) :: ex - - call Exception_constructor( ex , typeMessage ) - call Exception_setDebugDescription( ex, debugDescription ) - call Exception_setDescription( ex, description ) - call Exception_show( ex ) - call Exception_destructor( ex ) - - end subroutine ConfigurationInteraction_exception - - subroutine ConfigurationInteraction_saveEigenVector () - implicit none - character(50) :: nameFile - integer :: unitFile - integer(8) :: i, ia - integer :: ib, nonzero - integer, allocatable :: auxIndexArray(:) - real(8), allocatable :: auxArray(:) - integer :: maxStackSize - - maxStackSize = CONTROL_instance%CI_STACK_SIZE - nameFile = "lowdin.civec" - unitFile = 20 - - nonzero = 0 - do i = 1, ConfigurationInteraction_instance%numberOfConfigurations - if ( abs(ConfigurationInteraction_instance%eigenVectors%values(i,1) ) >= 1E-12 ) nonzero = nonzero + 1 - end do - - write (*,*) "nonzero", nonzero - - allocate(auxArray(nonzero)) - allocate(auxIndexArray(nonzero)) - - ia = 0 - do i = 1, ConfigurationInteraction_instance%numberOfConfigurations - if ( abs(ConfigurationInteraction_instance%eigenVectors%values(i,1) ) >= 1E-12 ) then - ia = ia + 1 - auxIndexArray(ia) = i - auxArray(ia) = ConfigurationInteraction_instance%eigenVectors%values(i,1) - end if - end do - - open(unit=unitFile, file=trim(nameFile), status="replace", form="unformatted") - - write(unitFile) ConfigurationInteraction_instance%eigenValues%values(1) - write(unitFile) nonzero - - do i = 1, ceiling(real(nonzero) / real(maxStackSize) ) - ib = maxStackSize * i - ia = ib - maxStackSize + 1 - if ( ib > nonzero ) ib = nonzero - write(unitFile) auxIndexArray(ia:ib) - end do - deallocate(auxIndexArray) - - do i = 1, ceiling(real(nonzero) / real(maxStackSize) ) - ib = maxStackSize * i - ia = ib - maxStackSize + 1 - if ( ib > nonzero ) ib = nonzero - write(unitFile) auxArray(ia:ib) - end do - deallocate(auxArray) - - close(unitFile) - - end subroutine ConfigurationInteraction_saveEigenVector - - subroutine ConfigurationInteraction_loadEigenVector (eigenValues,eigenVectors) - implicit none - type(Vector8) :: eigenValues - type(Matrix) :: eigenVectors - character(50) :: nameFile - integer :: unitFile - integer :: i, ia, ib, nonzero - real(8) :: eigenValue - integer, allocatable :: auxIndexArray(:) - real(8), allocatable :: auxArray(:) - integer :: maxStackSize - - maxStackSize = CONTROL_instance%CI_STACK_SIZE - - - nameFile = "lowdin.civec" - unitFile = 20 - - - open(unit=unitFile, file=trim(nameFile), status="old", action="read", form="unformatted") - - readvectors : do - read (unitFile) eigenValue - read (unitFile) nonzero - write (*,*) "eigenValue", eigenValue - write (*,*) "nonzero", nonzero - - allocate (auxIndexArray(nonzero)) - auxIndexArray = 0 - - do i = 1, ceiling(real(nonZero) / real(maxStackSize) ) - ib = maxStackSize * i - ia = ib - maxStackSize + 1 - if ( ib > nonZero ) ib = nonZero - read (unitFile) auxIndexArray(ia:ib) - end do - - allocate (auxArray(nonzero)) - auxArray = 0 - - do i = 1, ceiling(real(nonZero) / real(maxStackSize) ) - ib = maxStackSize * i - ia = ib - maxStackSize + 1 - if ( ib > nonZero ) ib = nonZero - read (unitFile) auxArray(ia:ib) - end do - exit readvectors - end do readvectors - - eigenValues%values(1) = eigenValue - do i = 1, nonzero - eigenVectors%values(auxIndexArray(i),1) = auxArray(i) - end do - - deallocate (auxIndexArray ) - deallocate (auxArray ) - - - close(unitFile) - - end subroutine ConfigurationInteraction_loadEigenVector - - subroutine av ( nx, v, w) - - !******************************************************************************* - !! AV computes w <- A * V where A is a discretized Laplacian. - ! Parameters: - ! Input, integer NX, the length of the vectors. - ! Input, real V(NX), the vector to be operated on by A. - ! Output, real W(NX), the result of A*V. - ! - implicit none - - integer(8) nx - real(8) v(nx) - real(8) w(nx) - character(50) :: CIFile - integer :: CIUnit - integer, allocatable :: jj(:) - real(8), allocatable :: CIEnergy(:) - integer :: nonzero,ii, kk - integer :: maxStackSize, i, ia, ib - - CIFile = "lowdin.ci" - CIUnit = 20 - nonzero = 0 - maxStackSize = CONTROL_instance%CI_STACK_SIZE - - w = 0 -#ifdef intel - open(unit=CIUnit, file=trim(CIFile), action = "read", form="unformatted", BUFFERED="YES") -#else - open(unit=CIUnit, file=trim(CIFile), action = "read", form="unformatted") -#endif - - readmatrix : do - read (CIUnit) nonzero - if (nonzero > 0 ) then - - read (CIUnit) ii - - if ( allocated(jj)) deallocate (jj) - allocate (jj(nonzero)) - jj = 0 - - if ( allocated(CIEnergy)) deallocate (CIEnergy) - allocate (CIEnergy(nonzero)) - CIEnergy = 0 - - do i = 1, ceiling(real(nonZero) / real(maxStackSize) ) - - ib = maxStackSize * i - ia = ib - maxStackSize + 1 - if ( ib > nonZero ) ib = nonZero - read (CIUnit) jj(ia:ib) - - end do - - do i = 1, ceiling(real(nonZero) / real(maxStackSize) ) - - ib = maxStackSize * i - ia = ib - maxStackSize + 1 - if ( ib > nonZero ) ib = nonZero - read (CIUnit) CIEnergy(ia:ib) - - end do - - w(ii) = w(ii) + CIEnergy(1)*v(jj(1)) !! disk - do kk = 2, nonzero - !w(ii) = w(ii) + ConfigurationInteraction_calculateCIenergy(ii,jj(kk))*v(jj(kk)) !! direct - w(ii) = w(ii) + CIEnergy(kk)*v(jj(kk)) !! disk - w(jj(kk)) = w(jj(kk)) + CIEnergy(kk)*v(ii) !! disk - end do - - else if ( nonzero == -1 ) then - exit readmatrix - end if - end do readmatrix - -!! memory -! do i = 1, nx -! w(:) = w(:) + ConfigurationInteraction_instance%hamiltonianMatrix%values(:,i)*v(i) -! end do - - close(CIUnit) - - return - end subroutine av - - - subroutine ConfigurationInteraction_jadamiluInterface(n, maxeig, eigenValues, eigenVectors) - implicit none - external DPJDREVCOM - integer(8) :: maxnev - real(8) :: CIenergy - integer(8) :: nproc - type(Vector8), intent(inout) :: eigenValues - type(Matrix), intent(inout) :: eigenVectors - -! N: size of the problem -! MAXEIG: max. number of wanteg eig (NEIG<=MAXEIG) -! MAXSP: max. value of MADSPACE - integer(8) :: n, maxeig, MAXSP - integer(8) :: LX - real(8), allocatable :: EIGS(:), RES(:), X(:)!, D(:) -! arguments to pass to the routines - integer(8) :: NEIG, MADSPACE, ISEARCH, NINIT - integer(8) :: JA(1), IA(1) - integer(8) :: ICNTL(5) - integer(8) :: ITER, IPRINT, INFO - real(8) :: SIGMA, TOL, GAP, MEM, DROPTOL, SHIFT - integer(8) :: NDX1, NDX2, NDX3 - integer(8) :: IJOB! some local variables - integer(8) :: auxSize - integer(4) :: size1,size2 - integer(8) :: I,J,K,ii,jj,jjj - integer(4) :: iiter - logical :: fullMatrix - - maxsp = CONTROL_instance%CI_MADSPACE - !!if ( CONTROL_instance%CI_JACOBI ) then - - LX = N*(3*MAXSP+MAXEIG+1)+4*MAXSP*MAXSP - - if ( allocated ( eigs ) ) deallocate ( eigs ) - allocate ( eigs ( maxeig ) ) - eigs = 0.0_8 - if ( allocated ( res ) ) deallocate ( res ) - allocate ( res ( maxeig ) ) - res = 0.0_8 - if ( allocated ( x ) ) deallocate ( x ) - allocate ( x ( lx ) ) - x = 0.0_8 - - -! set input variables -! the matrix is already in the required format - - IPRINT = 0 ! standard report on standard output - ISEARCH = 1 ! we want the smallest eigenvalues - NEIG = maxeig ! number of wanted eigenvalues - !NINIT = 0 ! no initial approximate eigenvectors - NINIT = NEIG ! initial approximate eigenvectors - MADSPACE = maxsp ! desired size of the search space - ITER = 1000*NEIG ! maximum number of iteration steps - TOL = CONTROL_instance%CI_CONVERGENCE !1.0d-4 ! tolerance for the eigenvector residual - - NDX1 = 0 - NDX2 = 0 - MEM = 0 - -! additional parameters set to default - ICNTL(1)=0 - ICNTL(2)=0 - ICNTL(3)=0 - ICNTL(4)=0 - ICNTL(5)=1 - - IJOB=0 - - JA(1) = -1 - IA(1) = -1 - - ! set initial eigenpairs - if ( CONTROL_instance%CI_LOAD_EIGENVECTOR ) then - print *, "Loading the eigenvector to the initial guess" - do j = 1, n - X(j) = eigenVectors%values(j,1) - end do - - do i = 1, CONTROL_instance%NUMBER_OF_CI_STATES - EIGS(i) = eigenValues%values(i) - end do - else - jj = 0 - do i = 1, CONTROL_instance%NUMBER_OF_CI_STATES - jj = (i - 1) * n - do j = 1, CONTROL_instance%CI_SIZE_OF_GUESS_MATRIX - X(jj + ConfigurationInteraction_instance%auxIndexCIMatrix%values(j)) = ConfigurationInteraction_instance%initialEigenVectors%values(j,i) - end do - end do - - do i = 1, CONTROL_instance%NUMBER_OF_CI_STATES - EIGS(i) = ConfigurationInteraction_instance%initialEigenValues%values(i) - end do - end if - - DROPTOL = 0 - - SIGMA = EIGS(1) - gap = 0 - SHIFT = EIGS(1) - - do i = 1, CONTROL_instance%NUMBER_OF_CI_STATES - write(6,"(T2,A5,I4,2X,A10,F20.10,2X,A11,F20.10)") "State", i, "Eigenvalue", eigs( i ), "Eigenvector", x((i-1)*n + i) - end do - - iiter = 0 - -!10 CALL DPJDREVCOM( N, A, JA, IA,EIGS, RES, X, LX, NEIG, & -! SIGMA, ISEARCH, NINIT, MADSPACE, ITER, TOL, & -! SHIFT, DROPTOL, MEM, ICNTL, & -! IJOB, NDX1, NDX2, IPRINT, INFO, GAP) -10 CALL DPJDREVCOM( N, ConfigurationInteraction_instance%diagonalHamiltonianMatrix%values , JA, IA, EIGS, RES, X, LX, NEIG, & - SIGMA, ISEARCH, NINIT, MADSPACE, ITER, TOL, & - SHIFT, DROPTOL, MEM, ICNTL, & - IJOB, NDX1, NDX2, IPRINT, INFO, GAP) - if (CONTROL_instance%CI_JACOBI ) then - fullMatrix = .false. - else - fullMatrix = .true. - end if -!! your private matrix-vector multiplication - - iiter = iiter +1 - IF (IJOB.EQ.1) THEN - if ( CONTROL_instance%CI_BUILD_FULL_MATRIX ) then - call av ( n, x(ndx1), x(ndx2)) - else - call matvec2 ( N, X(NDX1), X(NDX2), iiter) - end if - - GOTO 10 - END IF - - !! saving the eigenvalues - eigenValues%values = EIGS - - !! saving the eigenvectors - k = 0 - do j = 1, maxeig - do i = 1, N - k = k + 1 - eigenVectors%values(i,j) = X(k) - end do - end do - -! release internal memory and discard preconditioner - CALL PJDCLEANUP - if ( allocated ( x ) ) deallocate ( x ) - - end subroutine ConfigurationInteraction_jadamiluInterface - - subroutine matvec2 ( nx, v, w, iter) - - !******************************************************************************* - !! AV computes w <- A * V where A is a discretized Laplacian. - ! Parameters: - ! Input, integer NX, the length of the vectors. - ! Input, real V(NX), the vector to be operated on by A. - ! Output, real W(NX), the result of A*V. - ! - implicit none - - integer(8) nx - real(8) v(nx) - real(8) w(nx) - real(8) :: CIEnergy - integer(8) :: nonzero - integer(8) :: i, j, ia, ib, ii, jj, iii, jjj - integer(4) :: nproc, n, nn - real(8) :: wi - real(8) :: timeA, timeB - real(8) :: tol - integer(4) :: iter, size1, size2 - !integer(8), allocatable :: indexArray(:) - logical :: fullMatrix - integer :: ci - integer :: auxSize - integer(8) :: a,b,c - integer :: s, numberOfSpecies, auxnumberOfSpecies - integer(1) :: coupling - integer(8) :: numberOfConfigurations - integer(8), allocatable :: cc(:) !! ncore - integer(8), allocatable :: indexConf(:,:) !! ncore, species - integer(8), allocatable :: auxindexConf(:,:) !! ncore, species - integer, allocatable :: cilevel(:,:), auxcilevel(:,:) - - call omp_set_num_threads(omp_get_max_threads()) - nproc = omp_get_max_threads() - - - allocate( cc ( nproc ) ) - cc = 0 - - nonzero = 0 - w = 0 - tol = CONTROL_instance%CI_MATVEC_TOLERANCE - - do i = 1 , nx - if ( abs(v(i) ) >= tol) nonzero = nonzero + 1 - end do - - numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() - - allocate ( indexConf ( numberOfSpecies, nproc ) ) - allocate ( auxindexConf ( numberOfSpecies, nproc ) ) - allocate ( cilevel ( numberOfSpecies, nproc ) ) - allocate ( auxcilevel ( numberOfSpecies, nproc ) ) - - cilevel = 0 - auxcilevel = 0 - indexConf = 0 - auxindexConf = 0 - !! call recursion - s = 0 - c = 0 - n = 1 -!$ timeA = omp_get_wtime() - do ci = 1, ConfigurationInteraction_instance%sizeCiOrderList - do nn = n, nproc - cilevel(:,nn) = ConfigurationInteraction_instance%ciOrderList( ConfigurationInteraction_instance%auxciOrderList(ci), :) - end do - s = 0 - auxnumberOfSpecies = ConfigurationInteraction_buildMatrixRecursion(nproc, s, indexConf, auxindexConf,cc, c, n, v, w, & - cilevel, auxcilevel ) - - end do - - if ( n > 1 ) then - do nn = 1, n-1 - - call ConfigurationInteraction_buildRow( nn, auxindexConf(:,nn), cc(nn), w, v(cc(nn)), auxcilevel(:,nn)) - end do - end if - - ConfigurationInteraction_instance%pindexConf = 0 - -!$ timeB = omp_get_wtime() - deallocate ( cilevel ) - deallocate ( auxindexConf ) - deallocate ( indexConf ) - deallocate ( cc ) -!$ write(*,"(A,I2,A,E10.3,A2,I12)") " ", iter, " ", timeB -timeA ," ", nonzero -! stop - - - return - - end subroutine matvec2 - -end module ConfigurationInteraction_ - From fdba719f6244518444b85dc7f3faa2fe927e54cf Mon Sep 17 00:00:00 2001 From: jacharrym2 Date: Tue, 13 Aug 2024 18:16:24 +0200 Subject: [PATCH 2/4] Renamed CI subroutines according to the module name --- src/CI/CIDiag.f90 | 26 ++++++------ src/CI/CIFullMatrix.f90 | 16 ++++---- src/CI/CIInitial.f90 | 36 ++++++++--------- src/CI/CIJadamilu.f90 | 88 ++++++++++++++++++++--------------------- src/CI/CIOrder.f90 | 34 ++++++++-------- src/CI/CIStrings.f90 | 24 +++++------ src/CI/CImod.f90 | 34 ++++++++-------- 7 files changed, 129 insertions(+), 129 deletions(-) diff --git a/src/CI/CIDiag.f90 b/src/CI/CIDiag.f90 index 58627b96..19ae5a6c 100644 --- a/src/CI/CIDiag.f90 +++ b/src/CI/CIDiag.f90 @@ -18,7 +18,7 @@ module CIDiag_ !! !! @param this !< - subroutine CIcore_buildDiagonal() + subroutine CIDiag_buildDiagonal() implicit none integer(8) :: a,b,c @@ -60,7 +60,7 @@ subroutine CIcore_buildDiagonal() cilevel(:) = CIcore_instance%ciOrderList( CIcore_instance%auxciOrderList(ci), :) s = 0 - auxnumberOfSpecies = CIcore_numberOfConfigurationsRecursion(s, numberOfSpecies, numberOfConfigurations, ciLevel) + auxnumberOfSpecies = CIDiag_numberOfConfigurationsRecursion(s, numberOfSpecies, numberOfConfigurations, ciLevel) end do @@ -86,7 +86,7 @@ subroutine CIcore_buildDiagonal() dd = 0 u = CIcore_instance%auxciOrderList(ci) - auxnumberOfSpecies = CIcore_buildDiagonalRecursion( s, numberOfSpecies, indexConf, c, dd, u, cilevel, auxcilevel ) + auxnumberOfSpecies = CIDiag_buildDiagonalRecursion( s, numberOfSpecies, indexConf, c, dd, u, cilevel, auxcilevel ) end do !stop @@ -100,9 +100,9 @@ subroutine CIcore_buildDiagonal() write (*,*) "Reference energy, H_0: ", CIcore_instance%diagonalHamiltonianMatrix2%values(1) - end subroutine CIcore_buildDiagonal + end subroutine CIDiag_buildDiagonal -recursive function CIcore_numberOfConfigurationsRecursion(s, numberOfSpecies, c, cilevel) result (os) +recursive function CIDiag_numberOfConfigurationsRecursion(s, numberOfSpecies, c, cilevel) result (os) implicit none integer(8) :: a,b,c @@ -116,7 +116,7 @@ recursive function CIcore_numberOfConfigurationsRecursion(s, numberOfSpecies, c if ( is < numberOfSpecies ) then i = cilevel(is) + 1 do a = 1, CIcore_instance%numberOfStrings(is)%values(i) - os = CIcore_numberOfConfigurationsRecursion( is, numberOfSpecies, c, cilevel ) + os = CIDiag_numberOfConfigurationsRecursion( is, numberOfSpecies, c, cilevel ) end do else os = is @@ -127,10 +127,10 @@ recursive function CIcore_numberOfConfigurationsRecursion(s, numberOfSpecies, c end do end if - end function CIcore_numberOfConfigurationsRecursion + end function CIDiag_numberOfConfigurationsRecursion -recursive function CIcore_buildDiagonalRecursion(s, numberOfSpecies, indexConf, c, dd, u, cilevel, auxcilevel) result (os) +recursive function CIDiag_buildDiagonalRecursion(s, numberOfSpecies, indexConf, c, dd, u, cilevel, auxcilevel) result (os) implicit none integer(8) :: a,b,c,cc,d @@ -155,7 +155,7 @@ recursive function CIcore_buildDiagonalRecursion(s, numberOfSpecies, indexConf, indexConf(is) = ssize + a dd(is) =(a + CIcore_instance%ciOrderSize1(u,is))* CIcore_instance%ciOrderSize2(u,is) - os = CIcore_buildDiagonalRecursion( is, numberOfSpecies, indexConf, c, dd, u, cilevel, auxcilevel ) + os = CIDiag_buildDiagonalRecursion( is, numberOfSpecies, indexConf, c, dd, u, cilevel, auxcilevel ) end do else os = is @@ -169,14 +169,14 @@ recursive function CIcore_buildDiagonalRecursion(s, numberOfSpecies, indexConf, d = sum(dd) CIcore_instance%diagonalHamiltonianMatrix2%values(c) = & - CIcore_calculateEnergyZero ( indexConf ) + CIDiag_calculateEnergyZero ( indexConf ) end do end if - end function CIcore_buildDiagonalRecursion + end function CIDiag_buildDiagonalRecursion - function CIcore_calculateEnergyZero( this ) result (auxCIenergy) + function CIDiag_calculateEnergyZero( this ) result (auxCIenergy) implicit none integer(8) :: this(:) @@ -247,7 +247,7 @@ function CIcore_calculateEnergyZero( this ) result (auxCIenergy) auxCIenergy= auxCIenergy + HartreeFock_instance%puntualInteractionEnergy - end function CIcore_calculateEnergyZero + end function CIDiag_calculateEnergyZero end module CIDiag_ diff --git a/src/CI/CIFullMatrix.f90 b/src/CI/CIFullMatrix.f90 index ac78c16d..3e678b92 100644 --- a/src/CI/CIFullMatrix.f90 +++ b/src/CI/CIFullMatrix.f90 @@ -18,7 +18,7 @@ module CIFullMatrix_ !! !! @param this !< - subroutine CIcore_buildHamiltonianMatrix() + subroutine CIFullMatrix_buildHamiltonianMatrix() implicit none integer(8) :: a,b,c @@ -120,12 +120,12 @@ subroutine CIcore_buildHamiltonianMatrix() else if ( coupling == 1 ) then CIcore_instance%hamiltonianMatrix%values(a,b) = & - CIcore_calculateEnergyOne ( n, indexConfA(:,n), indexConfB(:,n) ) + CIFullMatrix_calculateEnergyOne ( n, indexConfA(:,n), indexConfB(:,n) ) else if ( coupling == 2 ) then CIcore_instance%hamiltonianMatrix%values(a,b) = & - CIcore_calculateEnergyTwo ( n, indexConfA(:,n), indexConfB(:,n) ) + CIFullMatrix_calculateEnergyTwo ( n, indexConfA(:,n), indexConfB(:,n) ) end if @@ -155,9 +155,9 @@ subroutine CIcore_buildHamiltonianMatrix() !$ timeB = omp_get_wtime() !$ write(*,"(A,E10.3,A4)") "** TOTAL Elapsed Time for building Hamiltonian Matrix : ", timeB - timeA ," (s)" - end subroutine CIcore_buildHamiltonianMatrix + end subroutine CIFullMatrix_buildHamiltonianMatrix - function CIcore_calculateEnergyOne( n, thisA, thisB ) result (auxCIenergy) + function CIFullMatrix_calculateEnergyOne( n, thisA, thisB ) result (auxCIenergy) implicit none integer(8) :: thisA(:), thisB(:) integer(8) :: a, b @@ -277,9 +277,9 @@ function CIcore_calculateEnergyOne( n, thisA, thisB ) result (auxCIenergy) auxCIenergy= auxCIenergy * factor - end function CIcore_calculateEnergyOne + end function CIFullMatrix_calculateEnergyOne - function CIcore_calculateEnergyTwo( n, thisA, thisB ) result (auxCIenergy) + function CIFullMatrix_calculateEnergyTwo( n, thisA, thisB ) result (auxCIenergy) implicit none integer(8) :: thisA(:), thisB(:) integer(8) :: a, b @@ -394,7 +394,7 @@ function CIcore_calculateEnergyTwo( n, thisA, thisB ) result (auxCIenergy) auxCIenergy= auxCIenergy * factor - end function CIcore_calculateEnergyTwo + end function CIFullMatrix_calculateEnergyTwo end module CIFullMatrix_ diff --git a/src/CI/CIInitial.f90 b/src/CI/CIInitial.f90 index e630c032..9b5c18ee 100644 --- a/src/CI/CIInitial.f90 +++ b/src/CI/CIInitial.f90 @@ -14,7 +14,7 @@ module CIInitial_ contains - subroutine CIcore_buildInitialCIMatrix2() + subroutine CIInitial_buildInitialCIMatrix2() implicit none type(Configuration) :: auxConfigurationA, auxConfigurationB @@ -53,9 +53,9 @@ subroutine CIcore_buildInitialCIMatrix2() int(initialCIMatrixSize,8) , 0.0_8 ) !! get the configurations for the initial hamiltonian matrix - call CIcore_getInitialIndexes() + call CIInitial_getInitialIndexes() - call CIcore_calculateInitialCIMatrix() + call CIInitial_calculateInitialCIMatrix() !! diagonalize the initial matrix call Vector_constructor8 ( CIcore_instance%initialEigenValues, int(CONTROL_instance%NUMBER_OF_CI_STATES,8), 0.0_8) @@ -80,7 +80,7 @@ subroutine CIcore_buildInitialCIMatrix2() !$ timeB = omp_get_wtime() !$ write(*,"(A,F10.3,A4)") "** TOTAL Elapsed Time for Solving Initial CI : ", timeB - timeA ," (s)" - end subroutine CIcore_buildInitialCIMatrix2 + end subroutine CIInitial_buildInitialCIMatrix2 !> !! @brief Muestra informacion del objeto @@ -88,7 +88,7 @@ end subroutine CIcore_buildInitialCIMatrix2 !! @param this !< !! Map the indexes of initial CI matrix to the complete matrix. - subroutine CIcore_getInitialIndexes() + subroutine CIInitial_getInitialIndexes() implicit none integer(8) :: a,b,c @@ -127,7 +127,7 @@ subroutine CIcore_getInitialIndexes() do ci = 1, CIcore_instance%sizeCiOrderList cilevel(:) = CIcore_instance%ciOrderList( CIcore_instance%auxciOrderList(ci), :) s = 0 - auxnumberOfSpecies = CIcore_getIndexesRecursion( s, numberOfSpecies, indexConf, c, cilevel ) + auxnumberOfSpecies = CIInitial_getIndexesRecursion( s, numberOfSpecies, indexConf, c, cilevel ) end do deallocate ( indexConf ) @@ -137,10 +137,10 @@ subroutine CIcore_getInitialIndexes() !$ write(*,"(A,E10.3,A4)") "** TOTAL Elapsed Time for getting initial indexes : ", timeB - timeA ," (s)" - end subroutine CIcore_getInitialIndexes + end subroutine CIInitial_getInitialIndexes -recursive function CIcore_getIndexesRecursion(s, numberOfSpecies, indexConf, c, cilevel) result (os) +recursive function CIInitial_getIndexesRecursion(s, numberOfSpecies, indexConf, c, cilevel) result (os) implicit none integer(8) :: a,b,c @@ -161,7 +161,7 @@ recursive function CIcore_getIndexesRecursion(s, numberOfSpecies, indexConf, c, do a = 1, CIcore_instance%numberOfStrings(is)%values(i) indexConf(is) = ssize + a - os = CIcore_getIndexesRecursion( is, numberOfSpecies, indexConf, c, cilevel) + os = CIInitial_getIndexesRecursion( is, numberOfSpecies, indexConf, c, cilevel) end do else os = is @@ -181,14 +181,14 @@ recursive function CIcore_getIndexesRecursion(s, numberOfSpecies, indexConf, c, end do end if - end function CIcore_getIndexesRecursion + end function CIInitial_getIndexesRecursion !> !! @brief Muestra informacion del objeto !! !! @param this !< - subroutine CIcore_calculateInitialCIMatrix() + subroutine CIInitial_calculateInitialCIMatrix() implicit none integer(8) :: a,b,aa,bb @@ -251,12 +251,12 @@ subroutine CIcore_calculateInitialCIMatrix() else if ( coupling == 1 ) then CIcore_instance%initialHamiltonianMatrix%values(a,b) = & - CI_Initial_calculateEnergyOne ( 1, indexConfA, indexConfB ) + CIInitial_calculateEnergyOne ( 1, indexConfA, indexConfB ) else if ( coupling == 2 ) then CIcore_instance%initialHamiltonianMatrix%values(a,b) = & - CI_Initial_calculateEnergyTwo ( 1, indexConfA, indexConfB ) + CIInitial_calculateEnergyTwo ( 1, indexConfA, indexConfB ) end if @@ -289,9 +289,9 @@ subroutine CIcore_calculateInitialCIMatrix() !!close(318) !$ write(*,"(A,E10.3,A4)") "** TOTAL Elapsed Time for Calculating initial CI matrix : ", timeB1 - timeA1 ," (s)" - end subroutine CIcore_calculateInitialCIMatrix + end subroutine CIInitial_calculateInitialCIMatrix - function CI_Initial_calculateEnergyOne( n, thisA, thisB ) result (auxCIenergy) + function CIInitial_calculateEnergyOne( n, thisA, thisB ) result (auxCIenergy) implicit none integer(8) :: thisA(:), thisB(:) integer(8) :: a, b @@ -411,9 +411,9 @@ function CI_Initial_calculateEnergyOne( n, thisA, thisB ) result (auxCIenergy) auxCIenergy= auxCIenergy * factor - end function CI_Initial_calculateEnergyOne + end function CIInitial_calculateEnergyOne - function CI_Initial_calculateEnergyTwo( n, thisA, thisB ) result (auxCIenergy) + function CIInitial_calculateEnergyTwo( n, thisA, thisB ) result (auxCIenergy) implicit none integer(8) :: thisA(:), thisB(:) integer(8) :: a, b @@ -528,6 +528,6 @@ function CI_Initial_calculateEnergyTwo( n, thisA, thisB ) result (auxCIenergy) auxCIenergy= auxCIenergy * factor - end function CI_Initial_calculateEnergyTwo + end function CIInitial_calculateEnergyTwo end module CIInitial_ diff --git a/src/CI/CIJadamilu.f90 b/src/CI/CIJadamilu.f90 index 4da6fd01..f4b587cd 100644 --- a/src/CI/CIJadamilu.f90 +++ b/src/CI/CIJadamilu.f90 @@ -18,7 +18,7 @@ module CIJadamilu_ !! !! @param this !< - subroutine CIcore_buildCouplingMatrix() + subroutine CIJadamilu_buildCouplingMatrix() implicit none integer(8) :: a,b,c1,c2 @@ -61,10 +61,10 @@ subroutine CIcore_buildCouplingMatrix() end do end do - end subroutine CIcore_buildCouplingMatrix + end subroutine CIJadamilu_buildCouplingMatrix !! Build a list with all possible combinations of number of different orbitals from all quantum species, coupling (0,1,2) - subroutine CIcore_buildCouplingOrderList() + subroutine CIJadamilu_buildCouplingOrderList() implicit none integer(8) :: a,b,c,c1,c2,aa,d @@ -122,7 +122,7 @@ subroutine CIcore_buildCouplingOrderList() ciLevel = 0 !! get all combinations - auxnumberOfSpecies = CIcore_buildCouplingOrderRecursion( s, numberOfSpecies, couplingOrder, cilevel ) + auxnumberOfSpecies = CIJadamilu_buildCouplingOrderRecursion( s, numberOfSpecies, couplingOrder, cilevel ) !! save the index for species (speciesID) just to avoid a lot of conditionals later! @@ -156,11 +156,11 @@ subroutine CIcore_buildCouplingOrderList() deallocate ( ciLevel ) deallocate ( couplingOrder ) - end subroutine CIcore_buildCouplingOrderList + end subroutine CIJadamilu_buildCouplingOrderList !! Get all possible combinations of number of different orbitals from all quantum species. -recursive function CIcore_buildCouplingOrderRecursion( s, numberOfSpecies, couplingOrder, cilevel ) result (os) +recursive function CIJadamilu_buildCouplingOrderRecursion( s, numberOfSpecies, couplingOrder, cilevel ) result (os) implicit none integer(8) :: a,b,c,d @@ -178,7 +178,7 @@ recursive function CIcore_buildCouplingOrderRecursion( s, numberOfSpecies, coup do i = 1, 3 - sum ( couplingOrder ) !! 0,1,2 couplingOrder(is) = i-1 couplingOrder(is+1:) = 0 - os = CIcore_buildCouplingOrderRecursion( is, numberOfSpecies, couplingOrder, cilevel ) + os = CIJadamilu_buildCouplingOrderRecursion( is, numberOfSpecies, couplingOrder, cilevel ) end do end if else @@ -219,9 +219,9 @@ recursive function CIcore_buildCouplingOrderRecursion( s, numberOfSpecies, coup end if end if - end function CIcore_buildCouplingOrderRecursion + end function CIJadamilu_buildCouplingOrderRecursion - subroutine CIcore_jadamiluInterface(n, maxeig, eigenValues, eigenVectors) + subroutine CIJadamilu_jadamiluInterface(n, maxeig, eigenValues, eigenVectors) implicit none external DPJDREVCOM integer(8) :: maxnev @@ -372,7 +372,7 @@ subroutine CIcore_jadamiluInterface(n, maxeig, eigenValues, eigenVectors) CALL PJDCLEANUP if ( allocated ( x ) ) deallocate ( x ) - end subroutine CIcore_jadamiluInterface + end subroutine CIJadamilu_jadamiluInterface subroutine matvec2 ( nx, v, w, iter) @@ -445,7 +445,7 @@ subroutine matvec2 ( nx, v, w, iter) cilevel(:,nn) = CIcore_instance%ciOrderList( CIcore_instance%auxciOrderList(ci), :) end do s = 0 - auxnumberOfSpecies = CIcore_buildMatrixRecursion(nproc, s, indexConf, auxindexConf,cc, c, n, v, w, & + auxnumberOfSpecies = CIJadamilu_buildMatrixRecursion(nproc, s, indexConf, auxindexConf,cc, c, n, v, w, & cilevel, auxcilevel ) end do @@ -453,7 +453,7 @@ subroutine matvec2 ( nx, v, w, iter) if ( n > 1 ) then do nn = 1, n-1 - call CIcore_buildRow( nn, auxindexConf(:,nn), cc(nn), w, v(cc(nn)), auxcilevel(:,nn)) + call CIJadamilu_buildRow( nn, auxindexConf(:,nn), cc(nn), w, v(cc(nn)), auxcilevel(:,nn)) end do end if @@ -557,7 +557,7 @@ subroutine av ( nx, v, w) return end subroutine av -recursive function CIcore_buildMatrixRecursion(nproc, s, indexConf, auxindexConf, cc, c, n, v, w, & +recursive function CIJadamilu_buildMatrixRecursion(nproc, s, indexConf, auxindexConf, cc, c, n, v, w, & cilevel, auxcilevel) result (os) implicit none @@ -581,7 +581,7 @@ recursive function CIcore_buildMatrixRecursion(nproc, s, indexConf, auxindexCon do a = 1, CIcore_instance%numberOfStrings(is)%values(i) indexConf(is,n:) = ssize + a - os = CIcore_buildMatrixRecursion( nproc, is, indexConf, auxindexConf, cc, c, n, v, w, cilevel, auxcilevel ) + os = CIJadamilu_buildMatrixRecursion( nproc, is, indexConf, auxindexConf, cc, c, n, v, w, cilevel, auxcilevel ) end do end do !else @@ -607,7 +607,7 @@ recursive function CIcore_buildMatrixRecursion(nproc, s, indexConf, auxindexCon !$omp& shared(v,w, indexConf, cc, nproc, cilevel) !$omp do schedule (static) do nn = 1, nproc - call CIcore_buildRow( nn, indexConf(:,nn), cc(nn), w, v(cc(nn)), cilevel(:,nn)) + call CIJadamilu_buildRow( nn, indexConf(:,nn), cc(nn), w, v(cc(nn)), cilevel(:,nn)) end do !$omp end do nowait !$omp end parallel @@ -628,11 +628,11 @@ recursive function CIcore_buildMatrixRecursion(nproc, s, indexConf, auxindexCon !end if - end function CIcore_buildMatrixRecursion + end function CIJadamilu_buildMatrixRecursion !! Alternative option to the recursion with the same computational cost... However, it may be helpul some day. - function CIcore_buildMatrixRecursion2(nproc, s, indexConf, auxindexConf, cc, c, n, v, w, & + function CIJadamilu_buildMatrixRecursion2(nproc, s, indexConf, auxindexConf, cc, c, n, v, w, & cilevel, auxcilevel) result (os) implicit none @@ -694,9 +694,9 @@ function CIcore_buildMatrixRecursion2(nproc, s, indexConf, auxindexConf, cc, c, deallocate (counter) - end function CIcore_buildMatrixRecursion2 + end function CIJadamilu_buildMatrixRecursion2 - subroutine CIcore_buildRow( nn, indexConfA, c, w, vc, cilevelA) + subroutine CIJadamilu_buildRow( nn, indexConfA, c, w, vc, cilevelA) implicit none integer(8) :: a,b,c,bb,ci,d,cj @@ -819,7 +819,7 @@ subroutine CIcore_buildRow( nn, indexConfA, c, w, vc, cilevelA) do ci = 1, size(CIcore_instance%numberOfStrings(i)%values, dim = 1) !! 1 is always zero cilevel(i) = ci - 1 - auxos = CIcore_buildRowRecursionFirstOne( i, indexConfA, indexConfB, nn, cilevel ) + auxos = CIJadamilu_buildRowRecursionFirstOne( i, indexConfA, indexConfB, nn, cilevel ) end do end if @@ -853,7 +853,7 @@ subroutine CIcore_buildRow( nn, indexConfA, c, w, vc, cilevelA) uu = CIcore_instance%auxciorderlist(u) dd = 0 - auxos = CIcore_buildRowRecursionSecondOne( i, indexConfB, w, vc, dd, nn, cilevel, uu ) + auxos = CIJadamilu_buildRowRecursionSecondOne( i, indexConfB, w, vc, dd, nn, cilevel, uu ) exit end if @@ -881,9 +881,9 @@ subroutine CIcore_buildRow( nn, indexConfA, c, w, vc, cilevelA) dd = 0 if ( CIcore_instance%pindexConf(i,nn) /= indexConfA(i) ) then - auxos = CIcore_buildRowRecursionSecondTwoCal( i, indexConfA, indexConfB, w, vc, dd, nn, cilevel, uu ) + auxos = CIJadamilu_buildRowRecursionSecondTwoCal( i, indexConfA, indexConfB, w, vc, dd, nn, cilevel, uu ) else - auxos = CIcore_buildRowRecursionSecondTwoGet( i, indexConfA, indexConfB, w, vc, dd, nn, cilevel, uu ) + auxos = CIJadamilu_buildRowRecursionSecondTwoGet( i, indexConfA, indexConfB, w, vc, dd, nn, cilevel, uu ) end if exit @@ -915,7 +915,7 @@ subroutine CIcore_buildRow( nn, indexConfA, c, w, vc, cilevelA) uu = CIcore_instance%auxciOrderList(u) dd = 0 - auxos = CIcore_buildRowRecursionSecondTwoDiff( i, j, indexConfB, w, vc, dd, nn, cilevel, uu ) + auxos = CIJadamilu_buildRowRecursionSecondTwoDiff( i, j, indexConfB, w, vc, dd, nn, cilevel, uu ) exit end if end do @@ -940,9 +940,9 @@ subroutine CIcore_buildRow( nn, indexConfA, c, w, vc, cilevelA) deallocate ( cilevel ) deallocate ( indexConfB ) - end subroutine CIcore_buildRow + end subroutine CIJadamilu_buildRow -recursive function CIcore_buildRowRecursionFirstOne( ii, indexConfA, indexConfB, nn, cilevel ) result (os) +recursive function CIJadamilu_buildRowRecursionFirstOne( ii, indexConfA, indexConfB, nn, cilevel ) result (os) implicit none integer(8) :: a, aa @@ -959,14 +959,14 @@ recursive function CIcore_buildRowRecursionFirstOne( ii, indexConfA, indexConfB a = ssize + aa indexConfB(ii) = CIcore_instance%couplingMatrix(ii,nn)%values(a, 2) - CIenergy = CIcore_calculateEnergyOneSame ( nn, ii, indexConfA, indexConfB ) + CIenergy = CIJadamilu_calculateEnergyOneSame ( nn, ii, indexConfA, indexConfB ) CIcore_instance%couplingMatrixEnergyOne(ii,nn)%values(indexConfB(ii)) = CIenergy end do - end function CIcore_buildRowRecursionFirstOne + end function CIJadamilu_buildRowRecursionFirstOne -recursive function CIcore_buildRowRecursionSecondOne( ii, indexConfB, w, vc, dd, nn, cilevel, u ) result (os) +recursive function CIJadamilu_buildRowRecursionSecondOne( ii, indexConfB, w, vc, dd, nn, cilevel, u ) result (os) implicit none integer(8) :: a,d, aa @@ -1000,7 +1000,7 @@ recursive function CIcore_buildRowRecursionSecondOne( ii, indexConfB, w, vc, dd d = sum(dd) CIenergy = CIcore_instance%couplingMatrixEnergyOne(ii,nn)%values(indexConfB(ii)) - CIenergy = CIenergy + CIcore_calculateEnergyOneDiff ( ii, indexConfB, nn ) + CIenergy = CIenergy + CIJadamilu_calculateEnergyOneDiff ( ii, indexConfB, nn ) CIenergy = vc*CIenergy !$omp atomic @@ -1008,10 +1008,10 @@ recursive function CIcore_buildRowRecursionSecondOne( ii, indexConfB, w, vc, dd !$omp end atomic end do - end function CIcore_buildRowRecursionSecondOne + end function CIJadamilu_buildRowRecursionSecondOne - function CIcore_buildRowRecursionSecondTwoCal( ii, indexConfA, indexConfB, w, vc, dd, nn, cilevel, u ) result (os) + function CIJadamilu_buildRowRecursionSecondTwoCal( ii, indexConfA, indexConfB, w, vc, dd, nn, cilevel, u ) result (os) implicit none integer(8) :: a,d, aa @@ -1045,7 +1045,7 @@ function CIcore_buildRowRecursionSecondTwoCal( ii, indexConfA, indexConfB, w, vc d = sum(dd) !CIenergy = CIcore_instance%couplingMatrixEnergyOne(ii,nn)%values(indexConfB(ii)) - CIenergy = CIcore_calculateEnergyTwoSame ( ii, indexConfA(ii), indexConfB(ii) ) + CIenergy = CIJadamilu_calculateEnergyTwoSame ( ii, indexConfA(ii), indexConfB(ii) ) CIcore_instance%couplingMatrixEnergyOne(ii,nn)%values(indexConfB(ii)) = CIenergy CIenergy = vc*CIenergy @@ -1054,9 +1054,9 @@ function CIcore_buildRowRecursionSecondTwoCal( ii, indexConfA, indexConfB, w, vc !$omp end atomic end do - end function CIcore_buildRowRecursionSecondTwoCal + end function CIJadamilu_buildRowRecursionSecondTwoCal - function CIcore_buildRowRecursionSecondTwoGet( ii, indexConfA, indexConfB, w, vc, dd, nn, cilevel, u ) result (os) + function CIJadamilu_buildRowRecursionSecondTwoGet( ii, indexConfA, indexConfB, w, vc, dd, nn, cilevel, u ) result (os) implicit none integer(8) :: a,d, aa @@ -1098,9 +1098,9 @@ function CIcore_buildRowRecursionSecondTwoGet( ii, indexConfA, indexConfB, w, vc !$omp end atomic end do - end function CIcore_buildRowRecursionSecondTwoGet + end function CIJadamilu_buildRowRecursionSecondTwoGet - function CIcore_buildRowRecursionSecondTwoDiff( ii, jj, indexConfB, w, vc, dd, nn, cilevel, u ) result (os) + function CIJadamilu_buildRowRecursionSecondTwoDiff( ii, jj, indexConfB, w, vc, dd, nn, cilevel, u ) result (os) implicit none integer(8) :: ai,aj,d, aai, aaj @@ -1162,10 +1162,10 @@ function CIcore_buildRowRecursionSecondTwoDiff( ii, jj, indexConfB, w, vc, dd, n end do end do - end function CIcore_buildRowRecursionSecondTwoDiff + end function CIJadamilu_buildRowRecursionSecondTwoDiff - function CIcore_calculateEnergyOneSame( n, ii, thisA, thisB ) result (auxCIenergy) + function CIJadamilu_calculateEnergyOneSame( n, ii, thisA, thisB ) result (auxCIenergy) implicit none integer(8) :: thisA(:), thisB(:) integer(8) :: a, b @@ -1240,9 +1240,9 @@ function CIcore_calculateEnergyOneSame( n, ii, thisA, thisB ) result (auxCIenerg auxCIenergy= auxCIenergy * factor - end function CIcore_calculateEnergyOneSame + end function CIJadamilu_calculateEnergyOneSame - function CIcore_calculateEnergyOneDiff( ii, thisB, nn ) result (auxCIenergy) + function CIJadamilu_calculateEnergyOneDiff( ii, thisB, nn ) result (auxCIenergy) implicit none integer(8) :: thisB(:) integer(8) :: b @@ -1302,10 +1302,10 @@ function CIcore_calculateEnergyOneDiff( ii, thisB, nn ) result (auxCIenergy) auxCIenergy= auxCIenergy * factor - end function CIcore_calculateEnergyOneDiff + end function CIJadamilu_calculateEnergyOneDiff - function CIcore_calculateEnergyTwoSame( ii, a, b ) result (auxCIenergy) + function CIJadamilu_calculateEnergyTwoSame( ii, a, b ) result (auxCIenergy) implicit none integer(8) :: a, b integer :: ii @@ -1359,6 +1359,6 @@ function CIcore_calculateEnergyTwoSame( ii, a, b ) result (auxCIenergy) auxCIenergy= auxCIenergy * factor - end function CIcore_calculateEnergyTwoSame + end function CIJadamilu_calculateEnergyTwoSame end module CIJadamilu_ diff --git a/src/CI/CIOrder.f90 b/src/CI/CIOrder.f90 index b0fc84d0..5db139d8 100644 --- a/src/CI/CIOrder.f90 +++ b/src/CI/CIOrder.f90 @@ -18,7 +18,7 @@ module CIOrder_ !! !! @param this !< - subroutine CIcore_settingCILevel() + subroutine CIOrder_settingCILevel() implicit none integer :: numberOfSpecies @@ -75,7 +75,7 @@ subroutine CIcore_settingCILevel() case ( "CISD+" ) - if ( .not. numberOfSpecies == 3 ) call CIcore_exception( ERROR, "CIOrder setting CI level ", "CISD+ is specific for three quantum species") + if ( .not. numberOfSpecies == 3 ) call CIOrder_exception( ERROR, "CIOrder setting CI level ", "CISD+ is specific for three quantum species") do i=1, numberOfSpecies CIcore_instance%CILevel(i) = 2 @@ -86,7 +86,7 @@ subroutine CIcore_settingCILevel() case ( "CISD+2" ) - if ( .not. numberOfSpecies == 4 ) call CIcore_exception( ERROR, "CIOrder setting CI level", "CISD+2 is specific for three quantum species") + if ( .not. numberOfSpecies == 4 ) call CIOrder_exception( ERROR, "CIOrder setting CI level", "CISD+2 is specific for three quantum species") do i=1, numberOfSpecies CIcore_instance%CILevel(i) = 2 if ( CIcore_instance%numberOfOccupiedOrbitals%values(i) < 2 ) & @@ -123,18 +123,18 @@ subroutine CIcore_settingCILevel() case default - call CIcore_exception( ERROR, "Configuration interactor constructor", "Correction level not implemented") + call CIOrder_exception( ERROR, "Configuration interactor constructor", "Correction level not implemented") end select - end subroutine CIcore_settingCILevel + end subroutine CIOrder_settingCILevel !! Build the CI table with all combinations of excitations between quantum species. - subroutine CIcore_buildCIOrderList() + subroutine CIOrder_buildCIOrderList() implicit none integer :: c @@ -178,7 +178,7 @@ subroutine CIcore_buildCIOrderList() s = 0 c = 0 !! Search which combinations of excitations satifies the desired CI level. - auxnumberOfSpecies = CIcore_buildCIOrderRecursion( s, numberOfSpecies, c, cilevel ) + auxnumberOfSpecies = CIOrder_buildCIOrderRecursion( s, numberOfSpecies, c, cilevel ) !! Print list @@ -207,7 +207,7 @@ subroutine CIcore_buildCIOrderList() do v = 1, u-1 auxcilevel(:) = CIcore_instance%ciOrderList( CIcore_instance%auxciOrderList(v), :) - auxnumberOfSpecies = CIcore_getIndexSize(0, ssize, auxcilevel) + auxnumberOfSpecies = CIOrder_getIndexSize(0, ssize, auxcilevel) end do @@ -236,10 +236,10 @@ subroutine CIcore_buildCIOrderList() deallocate ( auxcilevel ) deallocate ( cilevel ) - end subroutine CIcore_buildCIOrderList + end subroutine CIOrder_buildCIOrderList !! Search which combinations of excitations satifies the desired CI level. -recursive function CIcore_buildCIOrderRecursion( s, numberOfSpecies, c, cilevel ) result (os) +recursive function CIOrder_buildCIOrderRecursion( s, numberOfSpecies, c, cilevel ) result (os) implicit none integer :: u,v,c @@ -253,7 +253,7 @@ recursive function CIcore_buildCIOrderRecursion( s, numberOfSpecies, c, cilevel if ( is < numberOfSpecies ) then do i = 1, size(CIcore_instance%numberOfStrings(is)%values, dim = 1) cilevel(is) = i - 1 - os = CIcore_buildCIOrderRecursion( is, numberOfSpecies, c, cilevel ) + os = CIOrder_buildCIOrderRecursion( is, numberOfSpecies, c, cilevel ) end do cilevel(is) = 0 else @@ -302,9 +302,9 @@ recursive function CIcore_buildCIOrderRecursion( s, numberOfSpecies, c, cilevel cilevel(is) = 0 end if - end function CIcore_buildCIOrderRecursion + end function CIOrder_buildCIOrderRecursion -recursive function CIcore_getIndexSize(s, c, auxcilevel) result (os) +recursive function CIOrder_getIndexSize(s, c, auxcilevel) result (os) implicit none integer(8) :: a,b,c @@ -319,7 +319,7 @@ recursive function CIcore_getIndexSize(s, c, auxcilevel) result (os) i = auxcilevel(is) + 1 ssize = CIcore_instance%numberOfStrings2(is)%values(i) do a = 1, CIcore_instance%numberOfStrings(is)%values(i) - os = CIcore_getIndexSize( is, c, auxcilevel ) + os = CIOrder_getIndexSize( is, c, auxcilevel ) end do end do do ss = 1, CIcore_instance%recursionVector2(is) @@ -329,12 +329,12 @@ recursive function CIcore_getIndexSize(s, c, auxcilevel) result (os) c = c + CIcore_instance%numberOfStrings(is)%values(i) end do - end function CIcore_getIndexSize + end function CIOrder_getIndexSize !> !! @brief Maneja excepciones de la clase !< - subroutine CIcore_exception( typeMessage, description, debugDescription) + subroutine CIOrder_exception( typeMessage, description, debugDescription) implicit none integer :: typeMessage character(*) :: description @@ -348,7 +348,7 @@ subroutine CIcore_exception( typeMessage, description, debugDescription) call Exception_show( ex ) call Exception_destructor( ex ) - end subroutine CIcore_exception + end subroutine CIOrder_exception end module CIOrder_ diff --git a/src/CI/CIStrings.f90 b/src/CI/CIStrings.f90 index 526b61ee..68dcd970 100644 --- a/src/CI/CIStrings.f90 +++ b/src/CI/CIStrings.f90 @@ -13,7 +13,7 @@ module CIStrings_ contains - subroutine CIcore_buildStrings() + subroutine CIStrings_buildStrings() implicit none integer(8) :: a,b,c,c1,c2,aa,d @@ -59,7 +59,7 @@ subroutine CIcore_buildStrings() !! just get the number of strings... ci = 0 - oci = CIcore_buildStringsRecursion( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel) + oci = CIStrings_buildStringsRecursion( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel) write (*,"(A,I4,I8)") " ", cilevel, CIcore_instance%numberOfStrings(i)%values(cilevel+1) @@ -112,7 +112,7 @@ subroutine CIcore_buildStrings() !! recursion to build the strings ci = 0 - oci = CIcore_buildStringsRecursion2( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel, order, c) + oci = CIStrings_buildStringsRecursion2( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel, order, c) end if end do @@ -138,10 +138,10 @@ subroutine CIcore_buildStrings() end do - end subroutine CIcore_buildStrings + end subroutine CIStrings_buildStrings !! This is just to get the total number of strings... -recursive function CIcore_buildStringsRecursion( i, numberOfSpecies, occupiedCode, unoccupiedCode, ici, cilevel ) result (oci) +recursive function CIStrings_buildStringsRecursion( i, numberOfSpecies, occupiedCode, unoccupiedCode, ici, cilevel ) result (oci) implicit none integer :: i, numberOfSpecies @@ -157,7 +157,7 @@ recursive function CIcore_buildStringsRecursion( i, numberOfSpecies, occupiedCo do a = int(unoccupiedCode(i)%values(ci)) + 1, int(CIcore_instance%numberOfOrbitals%values(i) ) occupiedCode(i)%values(ci) = m unoccupiedCode(i)%values(ci) = a - oci = CIcore_buildStringsRecursion( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel ) + oci = CIStrings_buildStringsRecursion( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel ) end do unoccupiedCode(i)%values = CIcore_instance%numberOfOccupiedOrbitals%values(i) end do @@ -166,7 +166,7 @@ recursive function CIcore_buildStringsRecursion( i, numberOfSpecies, occupiedCo do a = int(unoccupiedCode(i)%values(ci-1)) + 1, int(CIcore_instance%numberOfOrbitals%values(i) ) occupiedCode(i)%values(ci) = m unoccupiedCode(i)%values(ci) = a - oci = CIcore_buildStringsRecursion( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel ) + oci = CIStrings_buildStringsRecursion( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel ) end do end do @@ -194,10 +194,10 @@ recursive function CIcore_buildStringsRecursion( i, numberOfSpecies, occupiedCo end do end if - end function CIcore_buildStringsRecursion + end function CIStrings_buildStringsRecursion !! and this is for building the strings -recursive function CIcore_buildStringsRecursion2( i, numberOfSpecies, occupiedCode, unoccupiedCode, & +recursive function CIStrings_buildStringsRecursion2( i, numberOfSpecies, occupiedCode, unoccupiedCode, & ici, cilevel, order, c ) result (oci) implicit none @@ -216,7 +216,7 @@ recursive function CIcore_buildStringsRecursion2( i, numberOfSpecies, occupiedC do a = int(unoccupiedCode(i)%values(ci)) + 1, int(CIcore_instance%numberOfOrbitals%values(i) ) occupiedCode(i)%values(ci) = m unoccupiedCode(i)%values(ci) = a - oci = CIcore_buildStringsRecursion2( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel, order, c ) + oci = CIStrings_buildStringsRecursion2( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel, order, c ) end do unoccupiedCode(i)%values = CIcore_instance%numberOfOccupiedOrbitals%values(i) end do @@ -225,7 +225,7 @@ recursive function CIcore_buildStringsRecursion2( i, numberOfSpecies, occupiedC do a = int(unoccupiedCode(i)%values(ci-1)) + 1, int(CIcore_instance%numberOfOrbitals%values(i) ) occupiedCode(i)%values(ci) = m unoccupiedCode(i)%values(ci) = a - oci = CIcore_buildStringsRecursion2( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel, order, c ) + oci = CIStrings_buildStringsRecursion2( i, numberOfSpecies, occupiedCode, unoccupiedCode, ci, cilevel, order, c ) end do end do @@ -257,6 +257,6 @@ recursive function CIcore_buildStringsRecursion2( i, numberOfSpecies, occupiedC end if - end function CIcore_buildStringsRecursion2 + end function CIStrings_buildStringsRecursion2 end module CIStrings_ diff --git a/src/CI/CImod.f90 b/src/CI/CImod.f90 index 92606243..f7b6c3ed 100644 --- a/src/CI/CImod.f90 +++ b/src/CI/CImod.f90 @@ -168,7 +168,7 @@ subroutine CImod_run() !write (*,*) CIcore_instance%fourCenterIntegrals(1,1)%values(171, 1) a bug... write (*,*) "Setting CI level..." - call CIcore_settingCILevel() + call CIOrder_settingCILevel() !! write (*,*) "Total number of configurations", CIcore_instance%numberOfConfigurations write (*,*) "" @@ -184,20 +184,20 @@ subroutine CImod_run() case ("JADAMILU") write (*,*) "Building Strings..." - call CIcore_buildStrings() + call CIStrings_buildStrings() write (*,*) "Building CI level table..." - call CIcore_buildCIOrderList() + call CIOrder_buildCIOrderList() - call CIcore_buildCouplingMatrix() - call CIcore_buildCouplingOrderList() + call CIJadamilu_buildCouplingMatrix() + call CIJadamilu_buildCouplingOrderList() write (*,*) "Building diagonal..." - call CIcore_buildDiagonal() + call CIDiag_buildDiagonal() write (*,*) "Building initial hamiltonian..." - call CIcore_buildInitialCIMatrix2() - !!call CIcore_buildHamiltonianMatrix() This should be modified to build the CI matrix in memory + call CIInitial_buildInitialCIMatrix2() + !!call CIFullMatrix_buildHamiltonianMatrix() This should be modified to build the CI matrix in memory call Matrix_constructor (CIcore_instance%eigenVectors, & int(CIcore_instance%numberOfConfigurations,8), & @@ -219,7 +219,7 @@ subroutine CImod_run() write(*,*) "=============================================================" - call CIcore_jadamiluInterface(CIcore_instance%numberOfConfigurations, & + call CIJadamilu_jadamiluInterface(CIcore_instance%numberOfConfigurations, & int(CONTROL_instance%NUMBER_OF_CI_STATES,8), & CIcore_instance%eigenvalues, & CIcore_instance%eigenVectors ) @@ -230,16 +230,16 @@ subroutine CImod_run() case ("DSYEVX") write (*,*) "Building Strings..." - call CIcore_buildStrings() + call CIStrings_buildStrings() write (*,*) "Building CI level table..." - call CIcore_buildCIOrderList() + call CIOrder_buildCIOrderList() write (*,*) "Building diagonal..." - call CIcore_buildDiagonal() + call CIDiag_buildDiagonal() write (*,*) "Building Hamiltonian..." - call CIcore_buildHamiltonianMatrix() + call CIFullMatrix_buildHamiltonianMatrix() call Matrix_constructor (CIcore_instance%eigenVectors, & int(CIcore_instance%numberOfConfigurations,8), & @@ -266,16 +266,16 @@ subroutine CImod_run() case ("DSYEVR") write (*,*) "Building Strings..." - call CIcore_buildStrings() + call CIStrings_buildStrings() write (*,*) "Building CI level table..." - call CIcore_buildCIOrderList() + call CIOrder_buildCIOrderList() write (*,*) "Building diagonal..." - call CIcore_buildDiagonal() + call CIDiag_buildDiagonal() write (*,*) "Building Hamiltonian..." - call CIcore_buildHamiltonianMatrix() + call CIFullMatrix_buildHamiltonianMatrix() call Matrix_constructor (CIcore_instance%eigenVectors, & int(CIcore_instance%numberOfConfigurations,8), & From 71551a7156c6e46c0b535f125341597673a519a7 Mon Sep 17 00:00:00 2001 From: jacharrym2 Date: Fri, 16 Aug 2024 00:00:43 +0200 Subject: [PATCH 3/4] Added the iterative diagonal dressed shift to the CISD matrix as a size-extensive correction. See the papers 10.1016/j.chemphys.2007.07.001 and 10.1063/5.0182498 --- lib/basis/T-AUG-CC-PVDZ | 47 +++++++++++++++++++++++++ lib/basis/T-AUG-CC-PVQZ | 51 +++++++++++++++++++++++++++ lib/basis/T-AUG-CC-PVTZ | 37 ++++++++++++++++++++ src/CI/CIFullMatrix.f90 | 47 +++++++++++++++++++++++-- src/CI/CIcore.f90 | 1 + src/CI/CImod.f90 | 68 ++++++++++++++++++++++++++++++------ src/core/CONTROL.f90 | 8 +++++ test/H-e+H-.DD-CISD.lowdin | 29 +++++++++++++++ test/H-e+H-.DD-CISD.py | 62 ++++++++++++++++++++++++++++++++ test/ci-test/H-.cisd.lowdin | 29 --------------- test/ci-test/H-.lowdin | 29 --------------- test/ci-test/PsH.CISD.lowdin | 36 +++++++++---------- test/ci-test/PsH.FCI.lowdin | 35 +++++++++---------- 13 files changed, 370 insertions(+), 109 deletions(-) create mode 100644 lib/basis/T-AUG-CC-PVDZ create mode 100644 test/H-e+H-.DD-CISD.lowdin create mode 100644 test/H-e+H-.DD-CISD.py delete mode 100644 test/ci-test/H-.cisd.lowdin delete mode 100644 test/ci-test/H-.lowdin diff --git a/lib/basis/T-AUG-CC-PVDZ b/lib/basis/T-AUG-CC-PVDZ new file mode 100644 index 00000000..f7044d5b --- /dev/null +++ b/lib/basis/T-AUG-CC-PVDZ @@ -0,0 +1,47 @@ +O-HELIUM HE (T-AUG-CC-PVDZ) BASIS TYPE: 1 +# +9 +1 0 3 +38.36000000 0.02380900 +5.77000000 0.15489100 +1.24000000 0.46998700 +2 0 1 +0.29760000 1.00000000 +3 0 1 +0.07255000 1.00000000 +4 0 1 +0.01770000 1.00000000 +5 0 1 +0.00431826 1.00000000 +6 1 1 +1.27500000 1.00000000 +7 1 1 +0.24730000 1.00000000 +8 1 1 +0.04800000 1.00000000 +9 1 1 +0.00931662 1.00000000 + +O-HELIUM E+ (T-AUG-CC-PVDZ) BASIS TYPE: 1 +# +9 +1 0 3 +38.36000000 0.02380900 +5.77000000 0.15489100 +1.24000000 0.46998700 +2 0 1 +0.29760000 1.00000000 +3 0 1 +0.07255000 1.00000000 +4 0 1 +0.01770000 1.00000000 +5 0 1 +0.00431826 1.00000000 +6 1 1 +1.27500000 1.00000000 +7 1 1 +0.24730000 1.00000000 +8 1 1 +0.04800000 1.00000000 +9 1 1 +0.00931662 1.00000000 diff --git a/lib/basis/T-AUG-CC-PVQZ b/lib/basis/T-AUG-CC-PVQZ index 175e0d9e..3f129b37 100644 --- a/lib/basis/T-AUG-CC-PVQZ +++ b/lib/basis/T-AUG-CC-PVQZ @@ -123,4 +123,55 @@ O-POSITRON E+ (D-AUG-CC-PVQZ) BASIS TYPE: 1 22 3 1 0.02392177 1.0000000 +O-HELIUM HE (D-AUG-CC-PVQZ) BASIS TYPE: 1 +# +22 +1 0 4 +528.50000000 0.00094000 +79.31000000 0.00721400 +18.05000000 0.03597500 +5.08500000 0.12778200 +2 0 1 +1.60900000 1.00000000 +3 0 1 +0.53630000 1.00000000 +4 0 1 +0.18330000 1.00000000 +5 0 1 +0.04819000 1.00000000 +6 0 1 +0.01270000 1.00000000 +7 0 1 +0.00334696 1.00000000 +8 1 1 +5.99400000 1.00000000 +9 1 1 +1.74500000 1.00000000 +10 1 1 +0.56000000 1.00000000 +11 1 1 +0.16260000 1.00000000 +12 1 1 +0.04720000 1.00000000 +13 1 1 +0.01370135 1.00000000 +14 2 1 +4.29900000 1.00000000 +15 2 1 +1.22300000 1.00000000 +16 2 1 +0.35100000 1.00000000 +17 2 1 +0.10100000 1.00000000 +18 2 1 +0.02906268 1.00000000 +19 3 1 +2.68000000 1.00000000 +20 3 1 +0.69060000 1.00000000 +21 3 1 +0.17800000 1.00000000 +22 3 1 +0.04587895 1.00000000 + diff --git a/lib/basis/T-AUG-CC-PVTZ b/lib/basis/T-AUG-CC-PVTZ index 6cab94ae..a0d29169 100644 --- a/lib/basis/T-AUG-CC-PVTZ +++ b/lib/basis/T-AUG-CC-PVTZ @@ -93,3 +93,40 @@ O-POSITRON E+ (D-AUG-CC-PVTZ) BASIS TYPE: 1 0.00704156 1.00000000 15 2 1 0.01347890 1.00000000 + +O-HELIUM HE (D-AUG-CC-PVTZ) BASIS TYPE: 1 +# +15 +1 0 4 +234.00000000 0.00258700 +35.16000000 0.01953300 +7.98900000 0.09099800 +2.21200000 0.27205000 +2 0 1 +0.66690000 1.00000000 +3 0 1 +0.20890000 1.00000000 +4 0 1 +0.05138000 1.00000000 +5 0 1 +0.01260000 1.00000000 +6 0 1 +0.00308992 1.00000000 +7 1 1 +3.04400000 1.00000000 +8 1 1 +0.75800000 1.00000000 +9 1 1 +0.19930000 1.00000000 +10 1 1 +0.05240000 1.00000000 +11 1 1 +0.01377702 1.00000000 +12 2 1 +1.96500000 1.00000000 +13 2 1 +0.45920000 1.00000000 +14 2 1 +0.10700000 1.00000000 +15 2 1 +0.02493250 1.00000000 diff --git a/src/CI/CIFullMatrix.f90 b/src/CI/CIFullMatrix.f90 index 3e678b92..b4d04185 100644 --- a/src/CI/CIFullMatrix.f90 +++ b/src/CI/CIFullMatrix.f90 @@ -18,7 +18,7 @@ module CIFullMatrix_ !! !! @param this !< - subroutine CIFullMatrix_buildHamiltonianMatrix() + subroutine CIFullMatrix_buildHamiltonianMatrix( timeA, timeB) implicit none integer(8) :: a,b,c @@ -153,7 +153,6 @@ subroutine CIFullMatrix_buildHamiltonianMatrix() deallocate ( CIcore_instance%allIndexConf ) !$ timeB = omp_get_wtime() -!$ write(*,"(A,E10.3,A4)") "** TOTAL Elapsed Time for building Hamiltonian Matrix : ", timeB - timeA ," (s)" end subroutine CIFullMatrix_buildHamiltonianMatrix @@ -396,5 +395,49 @@ function CIFullMatrix_calculateEnergyTwo( n, thisA, thisB ) result (auxCIenergy) end function CIFullMatrix_calculateEnergyTwo +!> + !! @brief Muestra informacion del objeto + !! + !! @param this + !< + subroutine CIFullMatrix_PT2() + implicit none + + integer(8) :: a,b,c + integer :: i, j, ii, jj + integer(8) :: numberOfConfigurations + integer :: n,nproc + real(8) :: timeA, timeB + real(8) :: CIEnergy_PT2 + real(8) :: auxEnergy + +!$ timeA = omp_get_wtime() + + numberOfConfigurations = CIcore_instance%numberOfConfigurations + nproc = omp_get_max_threads() + + CIEnergy_PT2 = 0.0_8 +!$omp parallel & +!$omp& private(a,b,n,auxEnergy),& +!$omp& shared(CIcore_instance) reduction(+:CIEnergy_PT2) + n = omp_get_thread_num() + 1 +!$omp do schedule (dynamic) + do a = 2, numberOfConfigurations + auxEnergy = 0.0_8 + do b = 1, numberOfConfigurations + auxEnergy = auxEnergy + CIcore_instance%hamiltonianMatrix%values(b,a) * CIcore_instance%eigenVectors%values(b,1) + end do + print *, ( CIcore_instance%hamiltonianMatrix%values(a,a) - CIcore_instance%eigenvalues%values(1) ) + CIEnergy_PT2 = CIEnergy_PT2 + (auxEnergy**2) / ( CIcore_instance%hamiltonianMatrix%values(a,a) - CIcore_instance%eigenvalues%values(1) ) + end do +!$omp end do nowait +!$omp end parallel + + print *, "PT2 ", CIEnergy_PT2 + +!$ timeB = omp_get_wtime() +!!$ write(*,"(A,E10.3,A4)") "** TOTAL Elapsed Time for calculating PT2 correction : ", timeB - timeA ," (s)" + + end subroutine CIFullMatrix_PT2 end module CIFullMatrix_ diff --git a/src/CI/CIcore.f90 b/src/CI/CIcore.f90 index 8a115080..842580d9 100644 --- a/src/CI/CIcore.f90 +++ b/src/CI/CIcore.f90 @@ -26,6 +26,7 @@ module CIcore_ type(ivector) :: numberOfOrbitals type(vector) :: numberOfSpatialOrbitals2 type(vector8) :: eigenvalues + type(vector) :: groundStateEnergies type(vector) :: lambda !!Number of particles per orbital, module only works for 1 or 2 particles per orbital type(matrix), allocatable :: fourCenterIntegrals(:,:) type(matrix), allocatable :: twoCenterIntegrals(:) diff --git a/src/CI/CImod.f90 b/src/CI/CImod.f90 index f7b6c3ed..98990b55 100644 --- a/src/CI/CImod.f90 +++ b/src/CI/CImod.f90 @@ -92,7 +92,10 @@ module CImod_ subroutine CImod_run() implicit none integer :: i,j,m, numberOfSpecies + integer :: a + real(8) :: timeA, timeB real(8), allocatable :: eigenValues(:) + real(8) :: ecorr ! select case ( trim(CIcore_instance%level) ) numberOfSpecies = MolecularSystem_getNumberOfQuantumSpecies() @@ -238,30 +241,73 @@ subroutine CImod_run() write (*,*) "Building diagonal..." call CIDiag_buildDiagonal() - write (*,*) "Building Hamiltonian..." - call CIFullMatrix_buildHamiltonianMatrix() + !write (*,*) "Building Hamiltonian..." + !call CIFullMatrix_buildHamiltonianMatrix() call Matrix_constructor (CIcore_instance%eigenVectors, & int(CIcore_instance%numberOfConfigurations,8), & int(CONTROL_instance%NUMBER_OF_CI_STATES,8), 0.0_8) - !! deallocate transformed integrals - deallocate(CIcore_instance%twoCenterIntegrals) - deallocate(CIcore_instance%fourCenterIntegrals) - write(*,*) "" write(*,*) "Diagonalizing hamiltonian..." write(*,*) " Using : ", trim(String_getUppercase((CONTROL_instance%CI_DIAGONALIZATION_METHOD))) - call Matrix_eigen_select (CIcore_instance%hamiltonianMatrix, CIcore_instance%eigenvalues, & - int(1), int(CONTROL_instance%NUMBER_OF_CI_STATES), & - eigenVectors = CIcore_instance%eigenVectors, & - flags = int(SYMMETRIC,4)) + !! diagonal correction. See 10.1016/j.chemphys.2007.07.001 + if ( CONTROL_instance%CI_DIAGONAL_DRESSED_SHIFT == "CISD") then + + call Vector_constructor ( CIcore_instance%groundStateEnergies, 30, 0.0_8) + + write (6,*) "" + write (6,"(T2,A50, A12)") " ITERATIVE DIAGONAL DRESSED CISD SHIFT: " , CONTROL_instance%CI_DIAGONAL_DRESSED_SHIFT + write (6,"(T2,A62)") " ( Size-extensive correction) " + write (6,"(T2,A62)") " Based on 10.1016/j.chemphys.2007.07.001 and 10.1063/5.0182498" + write (6,*) "" + write (6,"(T2,A95 )") "Iter Ground-State Energy Correlation Energy Energy Diff. Time(s) " + + ecorr = 0.0_8 + + do i = 2, 31 + + call CIFullMatrix_buildHamiltonianMatrix( timeA, timeB) + + do a = 2, CIcore_instance%numberOfConfigurations + CIcore_instance%hamiltonianMatrix%values(a,a) = CIcore_instance%hamiltonianMatrix%values(a,a) + ecorr + end do + + + call Matrix_eigen_select (CIcore_instance%hamiltonianMatrix, CIcore_instance%eigenvalues, & + int(1), int(CONTROL_instance%NUMBER_OF_CI_STATES), & + eigenVectors = CIcore_instance%eigenVectors, & + flags = int(SYMMETRIC,4)) + + ecorr = CIcore_instance%eigenvalues%values(1) - HartreeFock_instance%totalEnergy + CIcore_instance%groundStateEnergies%values(i) = CIcore_instance%eigenvalues%values(1) + + write (6,"(T2,I2, F25.12, F25.12, F25.12, F16.4 )") i-1, CIcore_instance%groundStateEnergies%values(i), ecorr, (CIcore_instance%groundStateEnergies%values(i-1) - CIcore_instance%groundStateEnergies%values(i)) , timeB - timeA + + if ( abs( CIcore_instance%groundStateEnergies%values(i-1) - CIcore_instance%groundStateEnergies%values(i) ) <= 1e-6) exit + + end do + + else !! no diagonal correction + + call CIFullMatrix_buildHamiltonianMatrix(timeA, timeB) +!$ write(*,"(A,E10.3,A4)") "** TOTAL Elapsed Time for building Hamiltonian Matrix : ", timeB - timeA ," (s)" + + call Matrix_eigen_select (CIcore_instance%hamiltonianMatrix, CIcore_instance%eigenvalues, & + int(1), int(CONTROL_instance%NUMBER_OF_CI_STATES), & + eigenVectors = CIcore_instance%eigenVectors, & + flags = int(SYMMETRIC,4)) + + end if ! call Matrix_eigen_select (CIcore_instance%hamiltonianMatrix, CIcore_instance%eigenvalues, & ! 1, CONTROL_instance%NUMBER_OF_CI_STATES, & ! flags = SYMMETRIC, dm = CIcore_instance%numberOfConfigurations ) + !! deallocate transformed integrals + deallocate(CIcore_instance%twoCenterIntegrals) + deallocate(CIcore_instance%fourCenterIntegrals) case ("DSYEVR") @@ -275,7 +321,7 @@ subroutine CImod_run() call CIDiag_buildDiagonal() write (*,*) "Building Hamiltonian..." - call CIFullMatrix_buildHamiltonianMatrix() + call CIFullMatrix_buildHamiltonianMatrix( timeA, timeB) call Matrix_constructor (CIcore_instance%eigenVectors, & int(CIcore_instance%numberOfConfigurations,8), & diff --git a/src/core/CONTROL.f90 b/src/core/CONTROL.f90 index 0f0848ec..a09c0d89 100644 --- a/src/core/CONTROL.f90 +++ b/src/core/CONTROL.f90 @@ -190,6 +190,7 @@ module CONTROL_ integer :: NUMBER_OF_CI_STATES character(20) :: CI_DIAGONALIZATION_METHOD character(20) :: CI_PRINT_EIGENVECTORS_FORMAT + character(20) :: CI_DIAGONAL_DRESSED_SHIFT real(8) :: CI_PRINT_THRESHOLD integer :: CI_STATES_TO_PRINT integer :: CI_ACTIVE_SPACE @@ -529,6 +530,7 @@ module CONTROL_ integer :: LowdinParameters_numberOfCIStates character(20) :: LowdinParameters_CIdiagonalizationMethod character(20) :: LowdinParameters_CIPrintEigenVectorsFormat + character(20) :: LowdinParameters_CIdiagonalDressedShift real(8) :: LowdinParameters_CIPrintThreshold integer :: LowdinParameters_CIactiveSpace integer :: LowdinParameters_CIstatesToPrint @@ -866,6 +868,7 @@ module CONTROL_ LowdinParameters_configurationInteractionLevel,& LowdinParameters_numberOfCIStates, & LowdinParameters_CIdiagonalizationMethod, & + LowdinParameters_CIdiagonalDressedShift, & LowdinParameters_CIactiveSpace, & LowdinParameters_CIstatesToPrint, & LowdinParameters_CImaxNCV, & @@ -1228,6 +1231,7 @@ subroutine CONTROL_start() LowdinParameters_configurationInteractionLevel = "NONE" LowdinParameters_numberOfCIStates = 1 LowdinParameters_CIdiagonalizationMethod = "DSYEVR" + LowdinParameters_CIdiagonalDressedShift = "NONE" LowdinParameters_CIactiveSpace = 0 !! Full LowdinParameters_CIstatesToPrint = 1 LowdinParameters_CImaxNCV = 30 @@ -1565,6 +1569,7 @@ subroutine CONTROL_start() CONTROL_instance%CONFIGURATION_INTERACTION_LEVEL = "NONE" CONTROL_instance%NUMBER_OF_CI_STATES= 1 CONTROL_instance%CI_DIAGONALIZATION_METHOD = "DSYEVR" + CONTROL_instance%CI_DIAGONAL_DRESSED_SHIFT = "NONE" CONTROL_instance%CI_ACTIVE_SPACE = 0 !! Full CONTROL_instance%CI_STATES_TO_PRINT = 1 CONTROL_instance%CI_MAX_NCV = 30 @@ -1951,6 +1956,7 @@ subroutine CONTROL_load(unit) CONTROL_instance%CONFIGURATION_INTERACTION_LEVEL = LowdinParameters_configurationInteractionLevel CONTROL_instance%NUMBER_OF_CI_STATES = LowdinParameters_numberOfCIStates CONTROL_instance%CI_DIAGONALIZATION_METHOD = LowdinParameters_CIdiagonalizationMethod + CONTROL_instance%CI_DIAGONAL_DRESSED_SHIFT = LowdinParameters_CIdiagonalDressedShift CONTROL_instance%CI_ACTIVE_SPACE = LowdinParameters_CIactiveSpace CONTROL_instance%CI_STATES_TO_PRINT = LowdinParameters_CIstatesToPrint if(CONTROL_instance%CI_STATES_TO_PRINT .gt. CONTROL_instance%NUMBER_OF_CI_STATES) & @@ -2319,6 +2325,7 @@ subroutine CONTROL_save( unit, lastStep, firstStep ) LowdinParameters_configurationInteractionLevel = CONTROL_instance%CONFIGURATION_INTERACTION_LEVEL LowdinParameters_numberOfCIStates = CONTROL_instance%NUMBER_OF_CI_STATES LowdinParameters_CIdiagonalizationMethod = CONTROL_instance%CI_DIAGONALIZATION_METHOD + LowdinParameters_CIdiagonalDressedShift = CONTROL_instance%CI_DIAGONAL_DRESSED_SHIFT LowdinParameters_CIactiveSpace = CONTROL_instance%CI_ACTIVE_SPACE LowdinParameters_CIstatesToPrint = CONTROL_instance%CI_STATES_TO_PRINT @@ -2650,6 +2657,7 @@ subroutine CONTROL_copy(this, otherThis) otherThis%CONFIGURATION_INTERACTION_LEVEL = this%CONFIGURATION_INTERACTION_LEVEL otherThis%NUMBER_OF_CI_STATES = this%NUMBER_OF_CI_STATES otherThis%CI_DIAGONALIZATION_METHOD = this%CI_DIAGONALIZATION_METHOD + otherThis%CI_DIAGONAL_DRESSED_SHIFT = this%CI_DIAGONAL_DRESSED_SHIFT otherThis%CI_ACTIVE_SPACE = this%CI_ACTIVE_SPACE otherThis%CI_STATES_TO_PRINT = this%CI_STATES_TO_PRINT otherThis%CI_MAX_NCV = this%CI_MAX_NCV diff --git a/test/H-e+H-.DD-CISD.lowdin b/test/H-e+H-.DD-CISD.lowdin new file mode 100644 index 00000000..ab79cd66 --- /dev/null +++ b/test/H-e+H-.DD-CISD.lowdin @@ -0,0 +1,29 @@ +GEOMETRY + e-(H) aug-cc-pvdz 0.00 0.00 0.00 addParticles=2 + e-(H) aug-cc-pvdz 0.00 0.00 3.37 + H dirac 0.00 0.00 0.00 + H dirac 0.00 0.00 3.37 + e+ e+aug-cc-pvdz 0.00 0.00 0.00 addParticles=-1 + e+ e+aug-cc-pvdz 0.00 0.00 3.37 +END GEOMETRY + +TASKS + method = "UHF" + !configurationInteractionLevel ="FCI" + configurationInteractionLevel ="CISD" +END TASKS + +CONTROL + readCoefficients=F + numberOfCIstates=1 + CIdiagonalizationMethod = "DSYEVX" + !CIdiagonalizationMethod = "JADAMILU" + CIdiagonalDressedShift = "CISD" +END CONTROL + +INPUT_CI + species="E-ALPHA" core=0 active=0 + species="E-BETA" core=0 active=0 + species="POSITRON" core=0 active=0 +END INPUT_CI + diff --git a/test/H-e+H-.DD-CISD.py b/test/H-e+H-.DD-CISD.py new file mode 100644 index 00000000..8bc5a654 --- /dev/null +++ b/test/H-e+H-.DD-CISD.py @@ -0,0 +1,62 @@ +#!/usr/bin/env python +from __future__ import print_function +import os +import sys +from colorstring import * + +if len(sys.argv)==2: + lowdinbin = sys.argv[1] +else: + lowdinbin = "lowdin2" + +testName = sys.argv[0][:-3] +inputName = testName + ".lowdin" +outputName = testName + ".out" + +# Reference values and tolerance + +refValues = { +"HF energy" : [-1.165428966723,1E-8], +"CISD energy" : [-1.284366244580,1E-8], +} + +testValues = dict(refValues) #copy +for value in testValues: #reset + testValues[value] = 0 #reset + +# Run calculation + +status = os.system(lowdinbin + " -i " + inputName) + +if status: + print(testName + str_red(" ... NOT OK")) + sys.exit(1) + +output = open(outputName, "r") +outputRead = output.readlines() + +# Values +for i in range(0,len(outputRead)): + line = outputRead[i] + if "TOTAL ENERGY =" in line: + testValues["HF energy"] = float(line.split()[3]) + if "STATE: 1 ENERGY =" in line: + testValues["CISD energy"] = float(line.split()[4]) + +passTest = True + +for value in refValues: + diffValue = abs(refValues[value][0] - testValues[value]) + if ( diffValue <= refValues[value][1] ): + passTest = passTest * True + else : + passTest = passTest * False + print("%s %.8f %.8f %.2e" % ( value, refValues[value][0], testValues[value], diffValue)) + +if passTest : + print(testName + str_green(" ... OK")) +else: + print(testName + str_red(" ... NOT OK")) + sys.exit(1) + +output.close() diff --git a/test/ci-test/H-.cisd.lowdin b/test/ci-test/H-.cisd.lowdin deleted file mode 100644 index 06120869..00000000 --- a/test/ci-test/H-.cisd.lowdin +++ /dev/null @@ -1,29 +0,0 @@ -GEOMETRY - e-(H) SHARON-E-6S2P 0.00 0.00 0.00 addParticles=1 - H dirac 0.00 0.00 0.00 -! e+ SHARON-E+6S2P 0.00 0.00 0.00 -END GEOMETRY - -TASKS - method = "UHF" - !configurationInteractionLevel ="FCI" - configurationInteractionLevel ="CISD" -END TASKS - -CONTROL - numberOfCIstates=1 - CIdiagonalizationMethod = "DSYEVX" - !CIdiagonalizationMethod = "ARPACK" - !CIdiagonalizationMethod = "JADAMILU" - CISizeOfGuessMatrix=300 -END CONTROL -INPUT_CI - species="E-ALPHA" core=0 active=0 excitation=2 - species="E-BETA" core=0 active=0 excitation=2 -! species="POSITRON" core=0 active=0 excitation=2 -END INPUT_CI - - - - - diff --git a/test/ci-test/H-.lowdin b/test/ci-test/H-.lowdin deleted file mode 100644 index 4901e4fa..00000000 --- a/test/ci-test/H-.lowdin +++ /dev/null @@ -1,29 +0,0 @@ -GEOMETRY - e-(H) SHARON-E-6S2P 0.00 0.00 0.00 addParticles=1 multiplicity=3 - H dirac 0.00 0.00 0.00 -! e+ SHARON-E+6S2P 0.00 0.00 0.00 -END GEOMETRY - -TASKS - method = "UHF" - configurationInteractionLevel ="FCI" - !configurationInteractionLevel ="CISD" -END TASKS - -CONTROL - numberOfCIstates=1 - CIdiagonalizationMethod = "DSYEVX" - !CIdiagonalizationMethod = "ARPACK" - !CIdiagonalizationMethod = "JADAMILU" - CISizeOfGuessMatrix=300 -END CONTROL -INPUT_CI - species="E-ALPHA" core=0 active=0 excitation=2 - species="E-BETA" core=0 active=0 excitation=2 -! species="POSITRON" core=0 active=0 excitation=2 -END INPUT_CI - - - - - diff --git a/test/ci-test/PsH.CISD.lowdin b/test/ci-test/PsH.CISD.lowdin index 3b1dd16e..96bdb8e5 100644 --- a/test/ci-test/PsH.CISD.lowdin +++ b/test/ci-test/PsH.CISD.lowdin @@ -1,7 +1,7 @@ GEOMETRY - e-(H) SHARON-E-6S2P 0.00 0.00 0.00 addParticles=1 + e-(H) aug-cc-pvdz 0.00 0.00 0.00 addParticles=1 H dirac 0.00 0.00 0.00 - e+ SHARON-E+6S2P 0.00 0.00 0.00 + e+ e+aug-cc-pvdz 0.00 0.00 0.00 END GEOMETRY TASKS @@ -11,24 +11,22 @@ TASKS END TASKS CONTROL - numberOfCIstates=1 - !CIdiagonalizationMethod = "DSYEVX" - !CIdiagonalizationMethod = "ARPACK" - CIdiagonalizationMethod = "JADAMILU" - CISizeOfGuessMatrix=300 - CIConvergence=1E-4 - CIJacobi = F - CIMadSpace = 30 - !CISaveEigenvector=T - !CILoadEigenvector=T +readCoefficients=F +numberOfCIstates=! +CINaturalOrbitals=T + CIStatesToPrint = 1 + CIdiagonalizationMethod = "DSYEVX" + !CIdiagonalizationMethod = "JADAMILU" + !CIPrintEigenVectorsFormat = "NONE" + CIPrintEigenVectorsFormat = "OCCUPIED" + !CIPrintEigenVectorsFormat = "ORBITALS" + CIPrintThreshold = 5e-2 + buildTwoParticlesMatrixForOneParticle=T END CONTROL + INPUT_CI - species="E-ALPHA" core=0 active=0 excitation=2 - species="E-BETA" core=0 active=0 excitation=2 - species="POSITRON" core=0 active=0 excitation=2 + species="E-ALPHA" core=0 active=0 + species="E-BETA" core=0 active=0 + species="POSITRON" core=0 active=0 END INPUT_CI - - - - diff --git a/test/ci-test/PsH.FCI.lowdin b/test/ci-test/PsH.FCI.lowdin index f4ea9f2a..219eab99 100644 --- a/test/ci-test/PsH.FCI.lowdin +++ b/test/ci-test/PsH.FCI.lowdin @@ -1,7 +1,7 @@ GEOMETRY - e-(H) SHARON-E-6S2P 0.00 0.00 0.00 addParticles=1 q = 1.00 - H dirac 0.00 0.00 0.00 q = -1.00 - e+ SHARON-E+6S2P 0.00 0.00 0.00 q = -1.00 + e-(H) aug-cc-pvdz 0.00 0.00 0.00 addParticles=1 + H dirac 0.00 0.00 0.00 + e+ e+aug-cc-pvdz 0.00 0.00 0.00 END GEOMETRY TASKS @@ -11,25 +11,22 @@ TASKS END TASKS CONTROL - numberOfCIstates=1 +readCoefficients=F +numberOfCIstates=! +CINaturalOrbitals=T + CIStatesToPrint = 1 !CIdiagonalizationMethod = "DSYEVX" - !CIdiagonalizationMethod = "ARPACK" CIdiagonalizationMethod = "JADAMILU" -! CISizeOfGuessMatrix=1728 - CISizeOfGuessMatrix=300 - CIConvergence=1E-4 - CIJacobi = F - CIMadSpace = 30 - !CISaveEigenvector=T - !CILoadEigenvector=T + !CIPrintEigenVectorsFormat = "NONE" + CIPrintEigenVectorsFormat = "OCCUPIED" + !CIPrintEigenVectorsFormat = "ORBITALS" + CIPrintThreshold = 5e-2 + buildTwoParticlesMatrixForOneParticle=T END CONTROL + INPUT_CI - species="E-ALPHA" core=0 active=0 excitation=2 - species="E-BETA" core=0 active=0 excitation=2 - species="POSITRON" core=0 active=0 excitation=2 + species="E-ALPHA" core=0 active=0 + species="E-BETA" core=0 active=0 + species="POSITRON" core=0 active=0 END INPUT_CI - - - - From 1a27f5a1a00528f879614240a737b9f2278edd09 Mon Sep 17 00:00:00 2001 From: jacharrym2 Date: Fri, 16 Aug 2024 17:36:16 +0200 Subject: [PATCH 4/4] Extended the DDCISD method to Jadamilu diagonalizer. --- src/CI/CIJadamilu.f90 | 6 +- src/CI/CIOrder.f90 | 6 ++ src/CI/CIcore.f90 | 1 + src/CI/CImod.f90 | 143 ++++++++++++++++++++++++++++++------- test/H-e+H-.DD-CISD.lowdin | 4 +- test/H-e+H-.DD-CISD.py | 2 +- 6 files changed, 131 insertions(+), 31 deletions(-) diff --git a/src/CI/CIJadamilu.f90 b/src/CI/CIJadamilu.f90 index f4b587cd..9e055b72 100644 --- a/src/CI/CIJadamilu.f90 +++ b/src/CI/CIJadamilu.f90 @@ -221,7 +221,7 @@ recursive function CIJadamilu_buildCouplingOrderRecursion( s, numberOfSpecies, end function CIJadamilu_buildCouplingOrderRecursion - subroutine CIJadamilu_jadamiluInterface(n, maxeig, eigenValues, eigenVectors) + subroutine CIJadamilu_jadamiluInterface(n, maxeig, eigenValues, eigenVectors, timeA, timeB) implicit none external DPJDREVCOM integer(8) :: maxnev @@ -249,7 +249,9 @@ subroutine CIJadamilu_jadamiluInterface(n, maxeig, eigenValues, eigenVectors) integer(8) :: I,J,K,ii,jj,jjj integer(4) :: iiter logical :: fullMatrix + real(8) :: timeA, timeB +!$ timeA = omp_get_wtime() maxsp = CONTROL_instance%CI_MADSPACE !!if ( CONTROL_instance%CI_JACOBI ) then @@ -372,6 +374,8 @@ subroutine CIJadamilu_jadamiluInterface(n, maxeig, eigenValues, eigenVectors) CALL PJDCLEANUP if ( allocated ( x ) ) deallocate ( x ) +!$ timeB = omp_get_wtime() + end subroutine CIJadamilu_jadamiluInterface subroutine matvec2 ( nx, v, w, iter) diff --git a/src/CI/CIOrder.f90 b/src/CI/CIOrder.f90 index 5db139d8..398bf1f9 100644 --- a/src/CI/CIOrder.f90 +++ b/src/CI/CIOrder.f90 @@ -127,6 +127,12 @@ subroutine CIOrder_settingCILevel() end select + if ( CONTROL_instance%CI_DIAGONAL_DRESSED_SHIFT == "CISD" .and. trim(CIcore_instance%level) /= "CISD" ) then + + call CIOrder_exception( ERROR, "Configuration interactor constructor", "DDCISD shift are only valid for CISD level!") + + end if + end subroutine CIOrder_settingCILevel diff --git a/src/CI/CIcore.f90 b/src/CI/CIcore.f90 index 842580d9..aacc126b 100644 --- a/src/CI/CIcore.f90 +++ b/src/CI/CIcore.f90 @@ -27,6 +27,7 @@ module CIcore_ type(vector) :: numberOfSpatialOrbitals2 type(vector8) :: eigenvalues type(vector) :: groundStateEnergies + type(vector) :: DDCISDTiming type(vector) :: lambda !!Number of particles per orbital, module only works for 1 or 2 particles per orbital type(matrix), allocatable :: fourCenterIntegrals(:,:) type(matrix), allocatable :: twoCenterIntegrals(:) diff --git a/src/CI/CImod.f90 b/src/CI/CImod.f90 index 98990b55..51164367 100644 --- a/src/CI/CImod.f90 +++ b/src/CI/CImod.f90 @@ -200,7 +200,6 @@ subroutine CImod_run() write (*,*) "Building initial hamiltonian..." call CIInitial_buildInitialCIMatrix2() - !!call CIFullMatrix_buildHamiltonianMatrix() This should be modified to build the CI matrix in memory call Matrix_constructor (CIcore_instance%eigenVectors, & int(CIcore_instance%numberOfConfigurations,8), & @@ -221,15 +220,76 @@ subroutine CImod_run() write(*,*) "Computer Physics Communications, vol. 177, pp. 951-964, 2007." write(*,*) "=============================================================" + !! diagonal correction. See 10.1016/j.chemphys.2007.07.001 + if ( CONTROL_instance%CI_DIAGONAL_DRESSED_SHIFT == "CISD") then + + call Vector_constructor ( CIcore_instance%groundStateEnergies, 30, 0.0_8) + call Vector_constructor ( CIcore_instance%DDCISDTiming, 30, 0.0_8) + + write (6,*) "" + write (6,"(T2,A50, A12)") " ITERATIVE DIAGONAL DRESSED CISD SHIFT: " , CONTROL_instance%CI_DIAGONAL_DRESSED_SHIFT + write (6,"(T2,A62)") " ( Size-extensive correction) " + write (6,"(T2,A62)") " Based on 10.1016/j.chemphys.2007.07.001 and 10.1063/5.0182498" + write (6,*) "" + + ecorr = 0.0_8 - call CIJadamilu_jadamiluInterface(CIcore_instance%numberOfConfigurations, & - int(CONTROL_instance%NUMBER_OF_CI_STATES,8), & - CIcore_instance%eigenvalues, & - CIcore_instance%eigenVectors ) + do i = 2, 31 + + !! add the diagonal shift + do a = 2, CIcore_instance%numberOfConfigurations + CIcore_instance%diagonalHamiltonianMatrix%values(a) = CIcore_instance%diagonalHamiltonianMatrix%values(a) + ecorr + end do + + call CIJadamilu_jadamiluInterface(CIcore_instance%numberOfConfigurations, & + int(CONTROL_instance%NUMBER_OF_CI_STATES,8), & + CIcore_instance%eigenvalues, & + CIcore_instance%eigenVectors, timeA, timeB) + + !! restore the original diagonal + do a = 2, CIcore_instance%numberOfConfigurations + CIcore_instance%diagonalHamiltonianMatrix%values(a) = CIcore_instance%diagonalHamiltonianMatrix%values(a) - ecorr + end do + + ecorr = CIcore_instance%eigenvalues%values(1) - HartreeFock_instance%totalEnergy + CIcore_instance%groundStateEnergies%values(i) = CIcore_instance%eigenvalues%values(1) + CIcore_instance%DDCISDTiming%values(i) = timeB - timeA + + write (6,"(T2,I2, F25.12, F25.12, F25.12, F16.4 )") i-1, CIcore_instance%groundStateEnergies%values(i), ecorr, (CIcore_instance%groundStateEnergies%values(i-1) - CIcore_instance%groundStateEnergies%values(i)) , timeB - timeA + + !! Restart ci matrix diagonalization from previous eigenvectors + CONTROL_instance%CI_LOAD_EIGENVECTOR = .True. + + if ( abs( CIcore_instance%groundStateEnergies%values(i-1) - CIcore_instance%groundStateEnergies%values(i) ) <= 1e-6) exit + + end do + + + write (6,*) "" + write (6,"(T2,A42 )") " ITERATIVE DIAGONAL DRESSED CONVERGENCE " + write (6,"(T2,A95 )") "Iter Ground-State Energy Correlation Energy Energy Diff. Time(s) " + do i = 2, 31 + write (6,"(T2,I2, F25.12, F25.12, F25.12, F16.4 )") i-1, CIcore_instance%groundStateEnergies%values(i), ecorr, (CIcore_instance%groundStateEnergies%values(i-1) - CIcore_instance%groundStateEnergies%values(i)) , CIcore_instance%DDCISDTiming%values(i) + if ( abs( CIcore_instance%groundStateEnergies%values(i-1) - CIcore_instance%groundStateEnergies%values(i) ) <= 1e-6) exit + end do + + if ( CONTROL_instance%CI_SAVE_EIGENVECTOR ) then + call CImod_saveEigenVector () + end if + + else !! standard CI, no diagonal correction + + call CIJadamilu_jadamiluInterface(CIcore_instance%numberOfConfigurations, & + int(CONTROL_instance%NUMBER_OF_CI_STATES,8), & + CIcore_instance%eigenvalues, & + CIcore_instance%eigenVectors, timeA, timeB ) + + if ( CONTROL_instance%CI_SAVE_EIGENVECTOR ) then + call CImod_saveEigenVector () + end if - if ( CONTROL_instance%CI_SAVE_EIGENVECTOR ) then - call CImod_saveEigenVector () end if + case ("DSYEVX") write (*,*) "Building Strings..." @@ -241,9 +301,6 @@ subroutine CImod_run() write (*,*) "Building diagonal..." call CIDiag_buildDiagonal() - !write (*,*) "Building Hamiltonian..." - !call CIFullMatrix_buildHamiltonianMatrix() - call Matrix_constructor (CIcore_instance%eigenVectors, & int(CIcore_instance%numberOfConfigurations,8), & int(CONTROL_instance%NUMBER_OF_CI_STATES,8), 0.0_8) @@ -289,7 +346,7 @@ subroutine CImod_run() end do - else !! no diagonal correction + else !! standard CI, no diagonal correction call CIFullMatrix_buildHamiltonianMatrix(timeA, timeB) !$ write(*,"(A,E10.3,A4)") "** TOTAL Elapsed Time for building Hamiltonian Matrix : ", timeB - timeA ," (s)" @@ -301,10 +358,6 @@ subroutine CImod_run() end if -! call Matrix_eigen_select (CIcore_instance%hamiltonianMatrix, CIcore_instance%eigenvalues, & -! 1, CONTROL_instance%NUMBER_OF_CI_STATES, & -! flags = SYMMETRIC, dm = CIcore_instance%numberOfConfigurations ) - !! deallocate transformed integrals deallocate(CIcore_instance%twoCenterIntegrals) deallocate(CIcore_instance%fourCenterIntegrals) @@ -320,26 +373,62 @@ subroutine CImod_run() write (*,*) "Building diagonal..." call CIDiag_buildDiagonal() - write (*,*) "Building Hamiltonian..." - call CIFullMatrix_buildHamiltonianMatrix( timeA, timeB) - call Matrix_constructor (CIcore_instance%eigenVectors, & int(CIcore_instance%numberOfConfigurations,8), & int(CONTROL_instance%NUMBER_OF_CI_STATES,8), 0.0_8) + !! diagonal correction. See 10.1016/j.chemphys.2007.07.001 + if ( CONTROL_instance%CI_DIAGONAL_DRESSED_SHIFT == "CISD") then + + call Vector_constructor ( CIcore_instance%groundStateEnergies, 30, 0.0_8) + + write (6,*) "" + write (6,"(T2,A50, A12)") " ITERATIVE DIAGONAL DRESSED CISD SHIFT: " , CONTROL_instance%CI_DIAGONAL_DRESSED_SHIFT + write (6,"(T2,A62)") " ( Size-extensive correction) " + write (6,"(T2,A62)") " Based on 10.1016/j.chemphys.2007.07.001 and 10.1063/5.0182498" + write (6,*) "" + write (6,"(T2,A95 )") "Iter Ground-State Energy Correlation Energy Energy Diff. Time(s) " + + ecorr = 0.0_8 + + do i = 2, 31 + + call CIFullMatrix_buildHamiltonianMatrix( timeA, timeB) + + do a = 2, CIcore_instance%numberOfConfigurations + CIcore_instance%hamiltonianMatrix%values(a,a) = CIcore_instance%hamiltonianMatrix%values(a,a) + ecorr + end do + + call Matrix_eigen_dsyevr (CIcore_instance%hamiltonianMatrix, CIcore_instance%eigenvalues, & + 1, CONTROL_instance%NUMBER_OF_CI_STATES, & + eigenVectors = CIcore_instance%eigenVectors, & + flags = SYMMETRIC) + + ecorr = CIcore_instance%eigenvalues%values(1) - HartreeFock_instance%totalEnergy + CIcore_instance%groundStateEnergies%values(i) = CIcore_instance%eigenvalues%values(1) + + write (6,"(T2,I2, F25.12, F25.12, F25.12, F16.4 )") i-1, CIcore_instance%groundStateEnergies%values(i), ecorr, (CIcore_instance%groundStateEnergies%values(i-1) - CIcore_instance%groundStateEnergies%values(i)) , timeB - timeA + + if ( abs( CIcore_instance%groundStateEnergies%values(i-1) - CIcore_instance%groundStateEnergies%values(i) ) <= 1e-6) exit + + end do + + else !! standard CI, no diagonal correction + + call CIFullMatrix_buildHamiltonianMatrix(timeA, timeB) +!$ write(*,"(A,E10.3,A4)") "** TOTAL Elapsed Time for building Hamiltonian Matrix : ", timeB - timeA ," (s)" + + call Matrix_eigen_dsyevr (CIcore_instance%hamiltonianMatrix, CIcore_instance%eigenvalues, & + 1, CONTROL_instance%NUMBER_OF_CI_STATES, & + eigenVectors = CIcore_instance%eigenVectors, & + flags = SYMMETRIC) + + end if + !! deallocate transformed integrals deallocate(CIcore_instance%twoCenterIntegrals) deallocate(CIcore_instance%fourCenterIntegrals) - call Matrix_eigen_dsyevr (CIcore_instance%hamiltonianMatrix, CIcore_instance%eigenvalues, & - 1, CONTROL_instance%NUMBER_OF_CI_STATES, & - eigenVectors = CIcore_instance%eigenVectors, & - flags = SYMMETRIC) - -! call Matrix_eigen_dsyevr (CIcore_instance%hamiltonianMatrix, CIcore_instance%eigenvalues, & -! 1, CONTROL_instance%NUMBER_OF_CI_STATES, & -! flags = SYMMETRIC, dm = CIcore_instance%numberOfConfigurations ) - case default call CImod_exception( ERROR, "CImod run", "Diagonalization method not implemented") diff --git a/test/H-e+H-.DD-CISD.lowdin b/test/H-e+H-.DD-CISD.lowdin index ab79cd66..f2e10528 100644 --- a/test/H-e+H-.DD-CISD.lowdin +++ b/test/H-e+H-.DD-CISD.lowdin @@ -16,8 +16,8 @@ END TASKS CONTROL readCoefficients=F numberOfCIstates=1 - CIdiagonalizationMethod = "DSYEVX" - !CIdiagonalizationMethod = "JADAMILU" + !CIdiagonalizationMethod = "DSYEVX" + CIdiagonalizationMethod = "JADAMILU" CIdiagonalDressedShift = "CISD" END CONTROL diff --git a/test/H-e+H-.DD-CISD.py b/test/H-e+H-.DD-CISD.py index 8bc5a654..743fba81 100644 --- a/test/H-e+H-.DD-CISD.py +++ b/test/H-e+H-.DD-CISD.py @@ -17,7 +17,7 @@ refValues = { "HF energy" : [-1.165428966723,1E-8], -"CISD energy" : [-1.284366244580,1E-8], +"CISD energy" : [-1.284366244580,1E-7], } testValues = dict(refValues) #copy