FreezeUMatCacheInt Subroutine

private subroutine FreezeUMatCacheInt(OrbTrans, nOld, nNew, onSlots, onPairs)

Arguments

Type IntentOptional Attributes Name
integer :: OrbTrans(nOld)
integer :: nOld
integer :: nNew
integer :: onSlots
integer :: onPairs

Contents

Source Code


Source Code

    SUBROUTINE FreezeUMatCacheInt(OrbTrans, nOld, nNew, onSlots, onPairs)
        INTEGER nOld, nNew, OrbTrans(nOld)
        HElement_t(dp), Pointer :: NUMat2D(:, :) !(nNew/2,nNew/2)
        integer(TagIntType) :: tagNUMat2D = 0
        HElement_t(dp) El(0:nTypes - 1)
        INTEGER i, j, k, l, m, n
        INTEGER ni, nj, nk, nl, nm, nn, A, B, iType
        HElement_t(dp), Pointer :: OUMatCacheData(:, :, :) !(0:nTypes-1,onSlots,onPairs)
        INTEGER, Pointer :: OUMatLabels(:, :) !(onSlots,onPairs)

        INTEGER onSlots, onPairs, ierr
        LOGICAL toSmallUMat, tlog, toUMat2D, tmpl
        character(len=*), parameter :: thisroutine = 'FreezeUMatCacheInt'

        toUMat2D = tUMat2D
        IF (tUMat2D) then
            allocate(NUMat2D(nNew / 2, nNew / 2), STAT=ierr)
            call LogMemAlloc('UMat2D',(nNew / 2)**2, 8 * HElement_t_size, thisroutine, tagNUMat2D, ierr)
! /2 because UMat2D works in states, not in orbitals
            DO i = 1, nOld / 2
                IF (OrbTrans(i * 2) /= 0) THEN
                    DO j = 1, nOld / 2
                        IF (OrbTrans(j * 2) /= 0) THEN
                            NUMat2D(OrbTrans(i * 2) / 2, OrbTrans(j * 2) / 2) = UMat2D(i, j)
                        end if
                    end do
                end if
            end do
            CALL LogMemDealloc(thisroutine, tagUMat2D)
            Deallocate(UMat2D)
            UMat2D => NUMat2D
            nullify(NUMat2D)
            tagUMat2D = tagNUMat2D
        end if
! Now go through the other cache.
! First save the memory used for it.
!         onSlots=nSlots
!         onPairs=nPairs
        OUMatCacheData => UMatCacheData
        tagOUMatCacheData = tagUMatCacheData
        OUMatLabels => UMatLabels
        tagOUMatLabels = tagUMatLabels
        toSmallUMat = tSmallUMat
        Nullify(UMatCacheData)
        Nullify(UMatLabels)
!Now reinitialize the cache.
        CALL SetupUMatCache(nNew / 2, .FALSE.)
        TUMAT2D = toUMat2D
        CALL SetUMatcacheFlag(1)
        DO i = 1, nOld / 2
            IF (OrbTrans(i * 2) /= 0) THEN
                DO k = i, nOld / 2
                    IF (OrbTrans(k * 2) /= 0) THEN
                        CALL GetCacheIndex(i, k, m)
                        DO n = 1, onSlots

                            tmpl = .true.
                            if (n /= 1) then
                                if (OUMatLabels(n, m) /= OUMatLabels(n - 1, m)) tmpl = .false.
                            end if
                            if ((onSlots == onPairs .or. toSmallUMat) .or. &
                                (onSlots /= onPairs .and. tmpl)) then
                                IF (OUMatLabels(n, m) /= 0) THEN
                                    ni = OrbTrans(i * 2) / 2
                                    nk = OrbTrans(k * 2) / 2
!Now get the label of the slot and convert to orbitals
                                    IF (onSlots == onPairs) THEN
                                        CALL GetCacheIndexStates(n, j, l)
                                    else if (toSmallUMat) THEN
                                        j = n
                                        l = n
                                    ELSE
                                        CALL GetCacheIndexStates(OUMatLabels(n, m), j, l)
                                    end if
                                    nj = OrbTrans(j * 2) / 2
                                    nl = OrbTrans(l * 2) / 2
                                    IF (nj /= 0 .AND. nl /= 0) THEN
                                        ! JSS: Alex, please check!
                                        ! GetCachedUMatEl called for cache indices: El(O) is
                                        ! a dummy argument.
                                        Tlog = GetCachedUmatEl(ni, nj, nk, nl, El(0), nm, nn, A, B, iType)
                                        CALL CacheUMatEl(B, OUMatCacheData(0, n:n + nTypes, m:m + nTypes), nm, nn, iType)
                                    end if
                                end if
                            end if
                        end do
                    end if
                end do
            end if
        end do
        CALL LogMemDealloc(thisroutine, tagOUMatLabels)
        Deallocate(OUMatLabels)
        CALL LogMemDealloc(thisroutine, tagOUMatCacheData)
        Deallocate(OUMatCacheData)
        CALL SetUMatCacheFlag(0)
    END SUBROUTINE FreezeUMatCacheInt