GENSymStatePairs Subroutine

public subroutine GENSymStatePairs(NSTATES, FRZ)

Arguments

Type IntentOptional Attributes Name
integer :: NSTATES
logical :: FRZ

Contents

Source Code


Source Code

    SUBROUTINE GENSymStatePairs(NSTATES, FRZ)
        IMPLICIT NONE
        INTEGER I, TOT, NSTATES
        INTEGER TEMPLIST(NSTATES), lo, hi
        LOGICAL FRZ
        character(*), parameter :: this_routine = 'GenSymStatePairs'

        if (tAbelianFastExcitGen .AND. .NOT. tAbelian) THEN
            write(stdout, *) "Fast Abelian excitation generators specified,", &
                "but abelian symmetry not in use.  Using slow generators."
            tAbelianFastExcitGen = .false.
        end if

        if (.not. tAbelianFastExcitGen) THEN
!We are not in abelian fast excitgen - we are always storing state pairs, whether specified or not.
            tStoreStateList = .true.
        end if

        !May need to deallocate, since this info is allocated in storage of UMAT before freezing
        if (allocated(SymPairProds)) then
            deallocate(SymPairProds)
            call LogMemDealloc(this_routine, tagSymPairProds)
        end if
        if (allocated(SymLabelList)) then
            deallocate(SymLabelList)
            call LogMemDealloc(this_routine, tagSymLabelList)
        end if
        if (allocated(SymLabelCounts)) then
            deallocate(SymLabelCounts)
            call LogMemDealloc(this_routine, tagSymLabelCounts)
        end if
        if (allocated(SymStatePairs)) then
            deallocate(SymStatePairs)
            call LogMemDealloc(this_routine, tagSymStatePairs)
        end if

        allocate(SymLabelList(nStates))
        call LogMemAlloc('SymLabelList', nStates, 4, this_routine, tagSymLabelList)
        allocate(SymLabelCounts(2, nSymLabels))
        call LogMemAlloc('SymLabelCounts', 2 * nSymLabels, 4, this_routine, tagSymLabelCounts)
!   First deal with listing single states
        DO I = 1, NSTATES
            SYMLABELLIST(I) = I
            IF (FRZ) THEN
                TEMPLIST(I) = SymClasses2(I)
            ELSE
                TEMPLIST(I) = SymClasses(I)
            end if
        end do
!   order according to sym label, so SYMLABELLIST gets a list of states grouped under SYMLABEL
        call sort(tempList, symLabelList) ! 1:nStates
        SYMLABELCOUNTS(:, :) = 0
        SYMLABELCOUNTS(1, TEMPLIST(1)) = 1
        SYMLABELCOUNTS(2, TEMPLIST(1)) = 1
        DO I = 2, NSTATES
            IF (TEMPLIST(I) /= TEMPLIST(I - 1)) THEN
!   add a new sym label
                SYMLABELCOUNTS(2, TEMPLIST(I)) = 1
                SYMLABELCOUNTS(1, TEMPLIST(I)) = I
!   sort the symlabellist
                lo = symLabelcounts(1, tempList(i - 1))
                hi = lo + symLabelCounts(2, tempList(i - 1)) - 1
                call sort(symLabelList(lo:hi))
            ELSE
                SYMLABELCOUNTS(2, TEMPLIST(I)) = SYMLABELCOUNTS(2, TEMPLIST(I)) + 1
            end if
        end do
        lo = symLabelcounts(1, tempList(i - 1))
        hi = lo + symLabelCounts(2, tempList(i - 1)) - 1
        call sort(symLabelList(lo:hi))
!         DO I=1,NSYMLABELS
!            write(stdout,*) "NSL",I,SYMLABELCOUNTS(1,I),SYMLABELCOUNTS(2,I)
!     &         SymLabels(I)
!         end do

!   Now deal with pairs of states

        if (.not. tStoreStateList) then
!.. We don't bother listing all pairs of orbs, because we can calculate the number
!.. and they're easy to generate.
!.. Instead of listing all pairs of states, we can list all pairs of sym classes (labels),
!..  ordered according to their sym prod.
            allocate(SymPairProds(nSymLabels**2))
            call LogMemAlloc('SymPairProds', nSymLabels**2, &
                             SymPairProdSize * 8, this_routine, tagSymPairProds)
            SymPairProds(:) = SymPairProd(Symmetry(0), 0, 0, 0, 0)
!   Now enumerate all pairs, and classify their product, but don't store them.
            nSymPairProds = 0
            CALL GenSymPairs(nSymLabels, 0)

!   Now sort the SymPairProds into order
            call sort(symPairProds(1:nSymPairProds))
            TOT = 0
            DO I = 1, nSymPairProds
!               write(stdout,"(I4,Z8,4I4)")
!     &             I,SymPairProds(I)%Sym,SymPairProds(I)%nPairs,
!     &           SymPairProds(I)%nIndex, SymPairProds(I)%nPairsStateSS,
!     &           SymPairProds(I)%nPairsStateOS
                SymPairProds(I)%nIndex = TOT
                TOT = TOT + SymPairProds(I)%nPairs
                SymPairProds(I)%nPairs = 0
                SymPairProds(I)%nPairsStateSS = 0
                SymPairProds(I)%nPairsStateOS = 0
            end do
            write(stdout, *) TOT, " Symmetry PAIRS"
            write(stdout, *) NSYMPAIRPRODS, " DISTINCT ORBITAL PAIR PRODUCT SYMS"
            allocate(SymStatePairs(2, 0:TOT - 1))
            call LogMemAlloc('SymStatePairs', 2 * TOT, 4, this_routine, tagSymStatePairs)
            SymStatePairs(:, :) = 0
            CALL GenSymPairs(nSymLabels, 1)
!            write(stdout,*) "Sym State Pairs"
!            DO I=0,TOT-1
!               write(stdout,*) I,SymStatePairs(1:2,I)
!            end do

!            write(stdout,*) "SymLabelList: ",SymLabelList(:)
!            write(stdout,*) "***","SymLabelCounts..."
!            write(stdout,*) SymLabelCounts(1,:)
!            write(stdout,*) "***"
!            write(stdout,*) SymLabelCounts(2,:)

        else
!.. Non-abelian symmetry requires us to go through and work out all the possible pairs of orbs.
            allocate(SymPairProds(nSymLabels**2))
            call LogMemAlloc('SymPairProds', nSymLabels**2, SymPairProdSize * 8, this_routine, tagSymPairProds)
            SymPairProds = SymPairProd(Symmetry(0), 0, 0, 0, 0)
!   Now enumerate all pairs, and classify their product, but don't store them.
            nSymPairProds = 0
            CALL GENALLSymStatePairs(NSTATES, .FALSE., FRZ)

!   Now sort the SymPairProds into order
            call sort(symPairProds(1:nSymPairProds))
            TOT = 0
!            write(stdout,*) "SymPairs",nSymPairProds
            DO I = 1, nSymPairProds
                SymPairProds(I)%nIndex = TOT
                TOT = TOT + SymPairProds(I)%nPairs
                SymPairProds(I)%nPairs = 0
            end do
            write(stdout, *) TOT, " STATE PAIRS"
            write(stdout, *) NSYMPAIRPRODS, " DISTINCT ORBITAL PAIR PRODUCT SYMS"
            allocate(SymStatePairs(2, 0:TOT - 1))
            call LogMemAlloc('SymStatePairs', 2 * TOT, 4, this_routine, tagSymStatePairs)
            SymStatePairs(:, :) = 0
            CALL GENALLSymStatePairs(NSTATES, .TRUE., FRZ)
        end if
    END SUBROUTINE GENSymStatePairs