LogMemDealloc Subroutine

public subroutine LogMemDealloc(DeallocRoutine, tag, err)

Arguments

Type IntentOptional Attributes Name
character(len=*), intent(in) :: DeallocRoutine
integer(kind=TagIntType), intent(inout) :: tag
integer, intent(in), optional :: err

Contents

Source Code


Source Code

    subroutine LogMemDealloc(DeallocRoutine, tag, err)
        ! Log a memory deallocation.
        ! INPUT:
        !       DeallocRoutine - routine in which object is deallocated.
        !       tag - position in memory log the object is stored at.
        !       err (optional) - error output from deallocate statement (checked if present).
        ! OUTPUT:
        !       tag - 0 if successfully logged (or noted that it wasn't stored in
        !             the log in the first place).

        character(len=*), intent(in) :: DeallocRoutine
        integer(TagIntType), intent(inout) :: tag
        integer, intent(in), optional :: err
        integer :: i, ismallloc(1)
        character(len=25) :: ObjectName
        if (.not. initialised) then
            if (err_output) write (stdout, *) 'Memory manager not initialised. Cannot log deallocation.'
            return
        end if

        ObjectName = 'Unknown'

        if (tag == 0) then
            if (err_output) write (stdout, *) 'Warning: attempting to log deallocation but never logged allocation.'
            tag = -1
        else if (tag > MaxLen .or. tag < -1) then
            if (err_output) write (stdout, *) 'Warning: attempting to log deallocation but tag does not exist: ', tag
            tag = -1
        else

            if (MemoryUsed == MaxMemoryUsed) then
                ! Are at peak memory usage.  Copy the memory log.
                ! Useful to see what's around when memory usage is at a maximum.
                PeakMemLog(:) = MemLog(:)
            end if

            if (tag == -1) then
                ! No record of it in the log: can only print out a debug message.
                if (debug) then
                    write (stdout, "(2A,I5)") 'Deallocating memory in: ', DeallocRoutine, tag
                end if
            else
                MemoryUsed = MemoryUsed - MemLog(tag)%ObjectSize
                MemoryLeft = MaxMemory - MemoryUsed

                ! Object was stored in the cache.
                MemLog(tag)%DeallocRoutine = DeallocRoutine
                ObjectName = MemLog(tag)%ObjectName

                ! Check to see if object is larger than the smallest of the large
                ! objects: if so, keep a record of it.
                if (MemLog(tag)%ObjectSize > LargeObjLog(ismall)%ObjectSize) then
                    LargeObjLog(ismall) = MemLog(tag)
                    ismallloc = minloc(LargeObjLog(:)%ObjectSize)
                    ismall = ismallloc(1)
                end if

                if (CachingMemLog) then
                    ! Then we free up this slot and slots of all objects directly below it in
                    ! the log that have also been deallocated.  This is not the most
                    ! efficient storage (we still can have a fractured log) but
                    ! works well for LIFO approaches, which are most common for us.
                    MemLog(tag)%ObjectSize = 0 ! Nothing to see here now.
                    if (tag == ipos - 1) then
                        do i = tag, 1, -1
                            if (MemLog(i)%ObjectSize == 0) then
                                ipos = ipos - 1
                            else
                                exit
                            end if
                        end do
                    end if
                end if
                if (debug) then
                    write (stdout, "(A,I5,' ',A,' ',A,' ',A,' ',I12)") 'Deallocating memory: ', tag, MemLog(tag)
                end if
            end if

            ! Set tag to zero: there was no problem with the logging deallocation
            ! (apart from maybe a too small cache).
            tag = 0

        end if

        if (present(err)) then
            if (err /= 0) then
                call Stop_All('LogMemAlloc', 'Failed to deallocate array '//ObjectName//' in '//DeallocRoutine)
            end if
        end if
    end subroutine LogMemDealloc