CacheFCIDUMP Subroutine

public subroutine CacheFCIDUMP(I, J, K, L, Z, CacheInd, ZeroedInt, NonZeroInt)

Arguments

Type IntentOptional Attributes Name
integer :: I
integer :: J
integer :: K
integer :: L
real(kind=dp) :: Z
integer :: CacheInd(nPairs)
integer(kind=int64) :: ZeroedInt
integer(kind=int64) :: NonZeroInt

Contents

Source Code


Source Code

    SUBROUTINE CacheFCIDUMP(I, J, K, L, Z, CacheInd, ZeroedInt, NonZeroInt)
        INTEGER :: I, J, K, L, CacheInd(nPairs)
        INTEGER(int64) :: ZeroedInt, NonZeroInt
        INTEGER :: A, B
        HElement_t(dp) :: Z

        IF (abs(Z) < UMatEps) THEN
!We have an epsilon cutoff for the size of the two-electron integrals - UMatEps
            ZeroedInt = ZeroedInt + 1
            RETURN
        ELSE
            NonZeroInt = NonZeroInt + 1
        end if

!Find unique indices within permutational symmetry.
        IF (K < I) THEN
            CALL SWAP(I, K)
        end if
        IF (L < J) THEN
            CALL SWAP(J, L)
        end if
        CALL GETCACHEINDEX(I, K, A)
        CALL GETCACHEINDEX(J, L, B)
        IF (A > B) THEN
            CALL SWAP(A, B)
            CALL SWAP(I, J)
            CALL SWAP(K, L)
        end if

!          write(stdout,*) "Final Phys ordering: ",I,J,K,L
!          write(stdout,*) "Pair indices: ",A,B

        IF (A > nPairs) THEN
            write(stdout, *) "Final Phys ordering: ", I, J, K, L
            write(stdout, *) "Pair indices: ", A, B
            write(stdout, *) "nPairs,nSlots: ", nPairs, nSlots
            CALL Stop_All("CacheFCIDUMP", "Error in caching")
        end if

!Store the integral in a contiguous fashion. A is the index for the i,k pair
        IF (UMATLABELS(CacheInd(A), A) /= 0) THEN
            IF ((abs(REAL(UMatCacheData(nTypes - 1, CacheInd(A), A), dp) - Z)) > 1.0e-7_dp) THEN
                write(stdout, *) i, j, k, l, z, UMatCacheData(nTypes - 1, CacheInd(A), A)
                CALL Stop_All("CacheFCIDUMP", "Same integral cached in same place with different value")
            end if

            CALL Stop_All("CacheFCIDUMP", "Overwriting UMATLABELS")
        end if
        UMATLABELS(CacheInd(A), A) = B
        IF (.not. near_zero(REAL(UMatCacheData(nTypes - 1, CacheInd(A), A), dp))) THEN
            CALL Stop_All("CacheFCIDUMP", "Overwriting when trying to fill cache.")
        end if
        UMatCacheData(nTypes - 1, CacheInd(A), A) = Z

        CacheInd(A) = CacheInd(A) + 1
        IF (CacheInd(A) > nSlots) THEN
            CALL Stop_All("CacheFCIDUMP", "Error in filling cache")
        end if

!After we have filled all of the cache, this will want to be sorted.
    END SUBROUTINE CacheFCIDUMP