adtUtils.F90

Go to the documentation of this file.

module adtutils
    !
    !      Module, which contains small subroutines which perform useful
    !      tasks.
    !
    use constants
    use adtdata
    implicit none
    !
    !                Variables stored in this module.
    !
    ! nStack:   Number of elements allocated in the stack array;
    !           needed for a more efficient implementation of the
    !           local qsort routines.
    ! stack(:): The corresponding array to store the stack.
    !           This is a pointer, such that the reallocation
    !           is easier.
 
    integer(kind=intType) :: nstack
    integer(kind=intType), dimension(:), pointer :: stack
 
    !=================================================================
 
contains
 
    !===============================================================
 
    subroutine adtterminate(ADT, routineName, errorMessage)
        !
        !        This routine writes the given error message to standard
        !        output and terminates the executation of the program.
        !        Subroutine intent(in) arguments.
        !        --------------------------------
        !        routineName: Name of the routine where the error occured.
        !        ADT:         Currently active ADT.
        !        Subroutine intent(inout) arguments.
        !        -----------------------------------
        !        errorMessage: On input it contains the error message to be
        !                      written. It is modified in this routine, such
        !                      that it fits on one line. On output its
        !                      contents is undefined, which does not matter
        !                      a whole lot.
        !
        implicit none
        !
        !       Subroutine arguments
        !
        type(adttype), intent(in) :: ADT
 
        character(len=*), intent(in) :: routineName
        character(len=*), intent(in) :: errorMessage
        !
        !       Local parameter
        !
        integer, parameter :: maxCharLine = 55
        !
        !       Local variables
        !
        integer :: ierr, len, i2
        logical :: firstTime
 
        character(len=len_trim(errorMessage)) :: message
        character(len=8) :: integerString
 
        ! Copy the errorMessage into message. It is not possible to work
        ! with errorMessage directly, because it is modified in this
        ! routine. Sometimes a constant string is passed to this routine
        ! and some compilers simply fail then.
 
        message = errormessage
 
        ! Print a nice error message. In case of a parallel executable
        ! also the processor ID is printed.
 
        print "(a)", "#"
        print "(a)", "#=========================== !!! Error !!! &
             &============================"
 
#ifndef SEQUENTIAL_MODE
        write (integerstring, "(i8)") adt%myID
        integerstring = adjustl(integerstring)
 
        print "(2a)", "#* adtTerminate called by processor ", &
            trim(integerstring)
#endif
 
        print "(2a)", "#* Run-time error in procedure ", &
            trim(routinename)
 
        ! Loop to write the error message. If the message is too long it
        ! is split over several lines.
 
        firsttime = .true.
        do
            ! Determine the remaining error message to be written.
            ! If longer than the maximum number of characters allowed
            ! on a line, it is attempted to split the message.
 
            message = adjustl(message)
            len = len_trim(message)
            i2 = min(maxcharline, len)
 
            if (i2 < len) i2 = index(message(:i2), " ", .true.) - 1
            if (i2 < 0) i2 = index(message, " ") - 1
            if (i2 < 0) i2 = len
 
            ! Write this part of the error message. If it is the first
            ! line of the message some additional stuff is printed.
 
            if (firsttime) then
                print "(2a)", "#* Error message: ", trim(message(:i2))
                firsttime = .false.
            else
                print "(2a)", "#*                ", trim(message(:i2))
            end if
 
            ! Exit the loop if the entire message has been written.
 
            if (i2 == len) exit
 
            ! Adapt the string for the next part to be written.
 
            message = message(i2 + 1:)
 
        end do
 
        ! Write the trailing message.
 
        print "(a)", "#*"
        print "(a)", "#* Now exiting"
        print "(a)", "#==========================================&
             &============================"
        print "(a)", "#"
 
        ! Call abort and stop the program. This stop should be done in
        ! abort, but just to be sure.
 
        call mpi_abort(adt%comm, 1, ierr)
        stop
 
    end subroutine adtterminate
 
    subroutine allocateadts
        !
        !        This routine allocates the memory for the first ADT and is
        !        only called when no other ADT's are present.
        !
        implicit none
        !
        !       Local variables.
        !
        integer :: ierr
 
        ! Allocate the memory for 1 ADT. Note that adtTerminate is not
        ! called when the memory allocation fails. The reason is that
        ! the processor ID for the current tree is used in this routine
        ! and that value has not been set yet.
 
        allocate (adts(1), stat=ierr)
        if (ierr /= 0) stop "Allocation failure for ADTs"
 
        ! Nullify the pointers of ADTs(1).
 
        nullify (adts(1)%coor)
 
        nullify (adts(1)%triaConn)
        nullify (adts(1)%quadsConn)
        nullify (adts(1)%tetraConn)
        nullify (adts(1)%pyraConn)
        nullify (adts(1)%prismsConn)
        nullify (adts(1)%hexaConn)
 
        nullify (adts(1)%rootLeavesProcs)
        nullify (adts(1)%rootBBoxes)
 
        nullify (adts(1)%elementType)
        nullify (adts(1)%elementID)
        nullify (adts(1)%xBBox)
 
        nullify (adts(1)%ADTree)
 
    end subroutine allocateadts
 
    subroutine deallocateadts(adtID)
        !
        !        This routine deallocates the memory for the given entry in
        !        the array ADTs and it tries to reallocate ADTs itself
        !        accordingly.
        !        Subroutine intent(in) arguments.
        !        --------------------------------
        !        adtID: The entry in ADTs to be deallocated.
        !
        implicit none
        !
        !       Subroutine arguments.
        !
        character(len=*), intent(in) :: adtID
        !
        !       Local variables.
        !
        integer :: ierr
 
        integer(kind=intType) :: jj, nn, nAlloc, nAllocNew
 
        type(adttype), dimension(:), allocatable :: tmpADTs
 
        ! Determine the index in the array ADTs, which stores the given
        ! ID. As the number of trees stored is limited, a linear search
        ! algorithm is okay.
 
        if (allocated(adts)) then
            nalloc = ubound(adts, 1)
        else
            nalloc = 0
        end if
 
        do jj = 1, nalloc
            if (adtid == adts(jj)%adtID) exit
        end do
 
        ! Return immediately if the ID is not present.
 
        if (jj > nalloc) return
 
        ! Deallocate the data for this ADT entry. Note that the memory
        ! for the nodal coordinates and the connectivity should not be
        ! deallocated, because these pointers are just set to the given
        ! input. The deallocation only takes place if the tree is active.
 
        if (adts(jj)%isActive) then
 
            deallocate (adts(jj)%rootLeavesProcs, adts(jj)%rootBBoxes, &
                        adts(jj)%elementType, adts(jj)%elementID, &
                        adts(jj)%xBBox, adts(jj)%ADTree, &
                        stat=ierr)
            if (ierr /= 0) &
                call adtterminate(adts(jj), "deallocateADTs", &
                                  "Deallocation failure for the ADT data")
        end if
 
        ! Make sure the ADT is inactive and nullify the pointers.
 
        adts(jj)%isActive = .false.
 
        nullify (adts(jj)%coor)
 
        nullify (adts(jj)%triaConn)
        nullify (adts(jj)%quadsConn)
        nullify (adts(jj)%tetraConn)
        nullify (adts(jj)%pyraConn)
        nullify (adts(jj)%prismsConn)
        nullify (adts(jj)%hexaConn)
 
        nullify (adts(jj)%rootLeavesProcs)
        nullify (adts(jj)%rootBBoxes)
 
        nullify (adts(jj)%elementType)
        nullify (adts(jj)%elementID)
        nullify (adts(jj)%xBBox)
 
        nullify (adts(jj)%ADTree)
 
        ! Determine the highest entry in ADTs which is still valid.
 
        do nn = nalloc, 1, -1
            if (adts(nn)%isActive) exit
        end do
 
        ! Determine the situation we are having here.
 
        if (nn == 0) then
 
            ! No active ADT's anymore. Deallocte the entire array.
            ! Note that adtTerminate cannot be called when something
            ! goes wrong.
 
            deallocate (adts, stat=ierr)
            if (ierr /= 0) stop "Deallocation failure for ADTs"
 
        else if (nn < nalloc) then
 
            ! There are still some active ADT's, but the highest ones
            ! are inactive. Therefore ADTs is reallocated. First allocate
            ! the memory for tmpADTs to be able to retrieve the currently
            ! stored data later on.
 
            nallocnew = nn
            allocate (tmpadts(nallocnew), stat=ierr)
            if (ierr /= 0) &
                call adtterminate(adts(jj), "adtDeallocateADTs", &
                                  "Memory allocation failure for tmpADTs")
 
            ! Copy the data from ADTs to tmpADTs.
 
            do nn = 1, nallocnew
                tmpadts(nn) = adts(nn)
            end do
 
            ! Deallocate and allocate the memory for ADTs. Note that
            ! adtTerminate is not called when the memory allocation fails.
            ! The reason is that the processor ID for the current tree is
            ! used in this routine and that value may not be available
            ! anymore.
 
            deallocate (adts, stat=ierr)
            if (ierr /= 0) stop "Deallocation failure for ADTs"
 
            allocate (adts(nallocnew), stat=ierr)
            if (ierr /= 0) stop "Allocation failure for ADTs"
 
            ! Copy the data back into ADTs and release the memory of
            ! tmpADTs afterwards.
 
            do nn = 1, nallocnew
                adts(nn) = tmpadts(nn)
            end do
 
            deallocate (tmpadts, stat=ierr)
            if (ierr /= 0) stop "Deallocation failure for tmpADTs"
 
        end if
 
    end subroutine deallocateadts
 
    subroutine qsortbboxes(arr, nn, ADT, dir)
        !
        !        This routine sorts the integer array arr, such that the
        !        coordinate of the corresponding bounding box in the
        !        direction dir is in increasing order. Note that the array to
        !        store the stack is stored in this module. The reason is that
        !        this routine is called quite often and in this way constant
        !        allocation, deallocation and reallocation of stack is
        !        avoided.
        !        Subroutine intent(in) arguments.
        !        --------------------------------
        !        nn:  Size of the array to be sorted.
        !        ADT: The ADTfrom which the coordinate of
        !             the bounding box must be taken.
        !        dir: Index of the coordinate, which must be sorted.
        !        Subroutine intent(inout) arguments.
        !        -----------------------------------
        !        arr(:): On input it contains the bounding box ID's which
        !                must be sorted. On output these ID's are sorted,
        !                such that the given coordinate is in increasing
        !                order.
        !
        implicit none
        !
        !       Subroutine arguments.
        !
        type(adttype), intent(in) :: ADT
        integer(kind=intType), intent(in) :: nn, dir
 
        integer(kind=intType), dimension(:), intent(inout) :: arr
        !
        !       Local parameters.
        !
        integer(kind=intType), parameter :: m = 7
        !
        !       Local variables.
        !
        integer(kind=intType) :: i, j, k, r, l, jStack
        integer(kind=intType) :: a, tmp
 
        real(kind=realtype) :: ra
        real(kind=realtype), dimension(:, :), pointer :: xbbox
 
        ! Set the pointer for the coordinates of the bounding boxes.
 
        xbbox => adt%xBBox
 
        ! Initialize the variables that control the sorting.
 
        jstack = 0
        l = 1
        r = nn
 
        ! Start of the algorithm.
 
        sortloop: do
 
            ! Check for the size of the subarray.
 
            testinsertion: if ((r - l) < m) then
 
                ! Perform the insertion sort.
 
                do j = (l + 1), r
                    a = arr(j)
                    ra = xbbox(dir, a)
                    do i = (j - 1), l, -1
                        if (xbbox(dir, arr(i)) <= ra) exit
                        arr(i + 1) = arr(i)
                    end do
                    arr(i + 1) = a
                end do
 
                ! In case there are no more elements on the stack, exit from
                ! the outermost do-loop. Algorithm has finished.
 
                if (jstack == 0) exit sortloop
 
                ! Pop stack and begin a new round of partitioning.
 
                r = stack(jstack)
                l = stack(jstack - 1)
                jstack = jstack - 2
 
                else testinsertion
 
                ! Subarray is larger than the threshold for a linear sort.
                ! Choose median of left, center and right elements as
                ! partitioning element a. Also rearrange so that
                ! (l) <= (l+1) <= (r).
 
                k = (l + r) / 2
                tmp = arr(k)      ! Swap the elements
                arr(k) = arr(l + 1)    ! k and l+1.
                arr(l + 1) = tmp
 
                if (xbbox(dir, arr(r)) < xbbox(dir, arr(l))) then
                    tmp = arr(l)             ! Swap the elements
                    arr(l) = arr(r)             ! r and l.
                    arr(r) = tmp
                end if
 
                if (xbbox(dir, arr(r)) < xbbox(dir, arr(l + 1))) then
                    tmp = arr(l + 1)         ! Swap the elements
                    arr(l + 1) = arr(r)           ! r and l+1.
                    arr(r) = tmp
                end if
 
                if (xbbox(dir, arr(l + 1)) < xbbox(dir, arr(l))) then
                    tmp = arr(l + 1)         ! Swap the elements
                    arr(l + 1) = arr(l)           ! l and l+1.
                    arr(l) = tmp
                end if
 
                ! Initialize the pointers for partitioning.
 
                i = l + 1
                j = r
                a = arr(l + 1)
                ra = xbbox(dir, a)
 
                ! The innermost loop.
 
                innerloop: do
 
                    ! Scan up to find element >= a.
                    do
                        i = i + 1
                        if (ra <= xbbox(dir, arr(i))) exit
                    end do
 
                    ! Scan down to find element <= a.
                    do
                        j = j - 1
                        if (xbbox(dir, arr(j)) <= ra) exit
                    end do
 
                    ! Exit the loop in case the pointers i and j crossed.
 
                    if (j < i) exit innerloop
 
                    ! Swap the element i and j.
 
                    tmp = arr(i)
                    arr(i) = arr(j)
                    arr(j) = tmp
 
                end do innerloop
 
                ! Swap the entries j and l+1. Remember that a equals
                ! arr(l+1).
 
                arr(l + 1) = arr(j)
                arr(j) = a
 
                ! Push pointers to larger subarray on stack; process smaller
                ! subarray immediately. Check if enough memory is available.
                ! If not reallocate it.
 
                jstack = jstack + 2
 
                if (jstack > nstack) call reallocplus(stack, nstack, 100, adt)
 
                if ((r - i + 1) >= (j - l)) then
                    stack(jstack) = r
                    r = j - 1
                    stack(jstack - 1) = j
                else
                    stack(jstack) = j - 1
                    stack(jstack - 1) = l
                    l = j
                end if
 
            end if testinsertion
        end do sortloop
 
        ! Check in debug mode if the sort has been done correctly.
 
        if (debug) then
            do i = 1, (nn - 1)
                if (xbbox(dir, arr(i + 1)) < xbbox(dir, arr(i))) then
                    call adtterminate(adt, "qsortBBoxes", &
                                      "Array is not sorted correctly")
                end if
            end do
        end if
 
    end subroutine qsortbboxes
 
    subroutine qsortbboxtargets(arr, nn, ADT)
        !
        !        This routine sorts the given number of bounding box targets
        !        in increasing order, based on the generalized < operator.
        !
        implicit none
        !
        !       Subroutine arguments
        !
        type(adttype), intent(in) :: adt
        integer(kind=intType), intent(in) :: nn
 
        type(adtbboxtargettype), dimension(:), pointer :: arr
        !
        !       Local variables
        !
        integer(kind=intType), parameter :: m = 7
 
        integer(kind=intType) :: i, j, k, r, l, jStack
 
        type(adtbboxtargettype) :: a, tmp
 
        ! Initialize the variables that control the sorting.
 
        jstack = 0
        l = 1
        r = nn
 
        ! Start of the algorithm
 
        sortloop: do
 
            ! Check for the size of the subarray.
 
            testinsertion: if ((r - l) < m) then
 
                ! Perform insertion sort
 
                do j = l + 1, r
                    a = arr(j)
                    do i = (j - 1), l, -1
                        if (arr(i) <= a) exit
                        arr(i + 1) = arr(i)
                    end do
                    arr(i + 1) = a
                end do
 
                ! In case there are no more elements on the stack, exit from
                ! the outermost do-loop. Algorithm has finished.
 
                if (jstack == 0) exit sortloop
 
                ! Pop stack and begin a new round of partitioning.
 
                r = stack(jstack)
                l = stack(jstack - 1)
                jstack = jstack - 2
 
                else testinsertion
 
                ! Subarray is larger than the threshold for a linear sort.
                ! Choose median of left, center and right elements as
                ! partitioning element a. Also rearrange so that
                ! (l) <= (l+1) <= (r).
 
                k = (l + r) / 2
                tmp = arr(k)      ! Swap the elements
                arr(k) = arr(l + 1)    ! k and l+1.
                arr(l + 1) = tmp
 
                if (arr(r) < arr(l)) then
                    tmp = arr(l)             ! Swap the elements
                    arr(l) = arr(r)             ! r and l.
                    arr(r) = tmp
                end if
 
                if (arr(r) < arr(l + 1)) then
                    tmp = arr(l + 1)         ! Swap the elements
                    arr(l + 1) = arr(r)           ! r and l+1.
                    arr(r) = tmp
                end if
 
                if (arr(l + 1) < arr(l)) then
                    tmp = arr(l + 1)         ! Swap the elements
                    arr(l + 1) = arr(l)           ! l and l+1.
                    arr(l) = tmp
                end if
 
                ! Initialize the pointers for partitioning.
 
                i = l + 1
                j = r
                a = arr(l + 1)
 
                ! The innermost loop
 
                innerloop: do
 
                    ! Scan up to find element >= a.
                    do
                        i = i + 1
                        if (a <= arr(i)) exit
                    end do
 
                    ! Scan down to find element <= a.
                    do
                        j = j - 1
                        if (arr(j) <= a) exit
                    end do
 
                    ! Exit the loop in case the pointers i and j crossed.
 
                    if (j < i) exit innerloop
 
                    ! Swap the element i and j.
 
                    tmp = arr(i)
                    arr(i) = arr(j)
                    arr(j) = tmp
 
                end do innerloop
 
                ! Swap the entries j and l+1. Remember that a equals
                ! arr(l+1).
 
                arr(l + 1) = arr(j)
                arr(j) = a
 
                ! Push pointers to larger subarray on stack; process smaller
                ! subarray immediately. Check if enough memory is available.
                ! If not reallocate it.
 
                jstack = jstack + 2
 
                if (jstack > nstack) call reallocplus(stack, nstack, 100, adt)
 
                if ((r - i + 1) >= (j - l)) then
                    stack(jstack) = r
                    r = j - 1
                    stack(jstack - 1) = j
                else
                    stack(jstack) = j - 1
                    stack(jstack - 1) = l
                    l = j
                end if
 
            end if testinsertion
        end do sortloop
 
        ! Check in debug mode whether the array is really sorted.
 
        if (debug) then
            do i = 1, (nn - 1)
                if (arr(i + 1) < arr(i)) &
                    call adtterminate(adt, "qsortBBoxTargets", &
                                      "Array is not sorted correctly")
            end do
        end if
 
    end subroutine qsortbboxtargets
 
    subroutine reallocateadts(adtID, jj)
        !
        !        This routine reallocates the memory for the ADTs array, such
        !        that it is possible to store a new ADT. First it is tried to
        !        find an empty spot in the currently allocated array. If this
        !        is not present a true reallocation takes place.
        !        Subroutine intent(in) arguments.
        !        --------------------------------
        !        adtID: The ID of the ADT.
        !        Subroutine intent(out) arguments.
        !        ---------------------------------
        !        jj: The index in the array ADTs, where the new entry will be
        !            stored.
        !
        implicit none
        !
        !       Subroutine arguments.
        !
        character(len=*), intent(in) :: adtID
        integer(kind=intType), intent(out) :: jj
        !
        !       Local variables.
        !
        integer :: ierr
 
        integer(kind=intType) :: nn, nAlloc
 
        type(adttype), dimension(:), allocatable :: tmpADTs
 
        ! Determine the current size of ADTs and look for an empty spot
        ! in the currently allocated array. Also check if an ADT with
        ! the given ID is not already active. A linear search algorithm
        ! is used, because the number of ADT's stored is limited.
 
        nalloc = ubound(adts, 1)
        jj = nalloc + 1
        do nn = 1, nalloc
            if (adts(nn)%isActive) then
                if (adtid == adts(nn)%adtID) exit
            else if (jj > nalloc) then
                jj = nn
            end if
        end do
 
        ! If the given ID corresponds to an already active tree,
        ! terminate. To avoid a messy output only processor 0 prints
        ! an error message while the other ones wait to get killed.
 
        if (nn <= nalloc) then
            if (adts(nn)%myID == 0) &
                 call adtterminate(adts(nn), "reallocateADTs", &
                 "Given ID corresponds to an already &
                 &active ADT")
            call mpi_barrier(adts(nn)%comm, ierr)
        end if
 
        ! Check if a reallocate must be done.
 
        checkreallocate: if (jj > nalloc) then
 
            ! No empty spot present in ADTs. A true reallocation must be
            ! performed. First allocate the memory for tmpADTs to be able
            ! to retrieve the currently stored data later on. Note that
            ! adtTerminate is not called when the memory allocation fails.
            ! The reason is that the processor ID for the current tree is
            ! used in this routine and that value has not been set yet.
 
            allocate (tmpadts(nalloc), stat=ierr)
            if (ierr /= 0) stop "Allocation failure for tmpADTs"
 
            ! Copy the data from ADTs to tmpADTs.
 
            do nn = 1, nalloc
                tmpadts(nn) = adts(nn)
            end do
 
            ! Release the memory of ADTs and allocate it again with
            ! increased size.
 
            deallocate (adts, stat=ierr)
            if (ierr /= 0) stop "Deallocation failure for ADTs"
 
            allocate (adts(jj), stat=ierr)
            if (ierr /= 0) stop "Allocation failure for ADTs"
 
            ! Copy the data back from tmpADTs.
 
            do nn = 1, nalloc
                adts(nn) = tmpadts(nn)
            end do
 
            ! Release the memory of tmpADTs.
 
            deallocate (tmpadts, stat=ierr)
            if (ierr /= 0) stop "Deallocation failure for tmpADTs"
 
            ! Nullify the pointers of the new entry.
 
            nullify (adts(jj)%coor)
 
            nullify (adts(jj)%triaConn)
            nullify (adts(jj)%quadsConn)
            nullify (adts(jj)%tetraConn)
            nullify (adts(jj)%pyraConn)
            nullify (adts(jj)%prismsConn)
            nullify (adts(jj)%hexaConn)
 
            nullify (adts(jj)%rootLeavesProcs)
            nullify (adts(jj)%rootBBoxes)
 
            nullify (adts(jj)%elementType)
            nullify (adts(jj)%elementID)
            nullify (adts(jj)%xBBox)
 
            nullify (adts(jj)%ADTree)
 
        end if checkreallocate
 
    end subroutine reallocateadts
 
    subroutine reallocbboxtargettypeplus(arr, nSize, nInc, ADT)
        !
        !        This routine reallocates the memory of the given
        !        adtBBoxTargetType pointer array.
        !        Subroutine intent(in) arguments.
        !        --------------------------------
        !        ADT:         Currently active ADT.
        !        nInc: Increment of the size of the array.
        !        Subroutine intent(inout) arguments.
        !        -----------------------------------
        !        nSize: On input it contains the size of the given array.
        !               On output this value is incremented by nInc.
        !        Subroutine pointer arguments.
        !        -----------------------------
        !        arr: Array to be reallocated.
        !
        implicit none
        !
        !       Subroutine arguments.
        !
        type(adttype), intent(in) :: ADT
        integer, intent(in) :: nInc
        integer(kind=intType), intent(inout) :: nSize
 
        type(adtbboxtargettype), dimension(:), pointer :: arr
        !
        !       Local variables.
        !
        integer :: ierr
        integer(kind=intType) :: i, nOld
 
        type(adtbboxtargettype), dimension(:), pointer :: tmp
 
        ! Store the input value of nSize and set the pointer tmp to the
        ! original array.
 
        nold = nsize
        tmp => arr
 
        ! Allocate the new memory for the array.
 
        nsize = nsize + ninc
        allocate (arr(nsize), stat=ierr)
        if (ierr /= 0) &
            call adtterminate(adt, "reallocBBoxTargetTypePlus", &
                              "Memory allocation failure for arr.")
 
        ! Copy the data from the original array into arr.
 
        nold = min(nold, nsize)
        do i = 1, nold
            arr(i) = tmp(i)
        end do
 
        ! Release the memory of tmp, which points to the original
        ! memory of the given array.
 
        deallocate (tmp, stat=ierr)
        if (ierr /= 0) &
            call adtterminate(adt, "reallocBBoxTargetTypePlus", &
                              "Deallocation failure for tmp.")
 
    end subroutine reallocbboxtargettypeplus
 
    subroutine reallocplus(arr, nSize, nInc, ADT)
        !
        !        This internal routine reallocates the memory of the given
        !        pointer array.
        !        Subroutine intent(in) arguments.
        !        --------------------------------
        !        ADT:         Currently active ADT.
        !        nInc: Increment of the size of the array.
        !        Subroutine intent(inout) arguments.
        !        -----------------------------------
        !        nSize: On input it contains the size of the given array.
        !               On output this value is incremented by nInc.
        !        Subroutine pointer arguments.
        !        -----------------------------
        !        arr: Array to be reallocated.
        !
        implicit none
        !
        !       Subroutine arguments.
        !
        type(adttype), intent(in) :: ADT
        integer, intent(in) :: nInc
        integer(kind=intType), intent(inout) :: nSize
 
        integer(kind=intType), dimension(:), pointer :: arr
        !
        !       Local variables.
        !
        integer :: ierr
        integer(kind=intType) :: i, nOld
 
        integer(kind=intType), dimension(:), pointer :: tmp
 
        ! Store the input value of nSize and set the pointer tmp to the
        ! original array.
 
        nold = nsize
        tmp => arr
 
        ! Allocate the new memory for the array.
 
        nsize = nsize + ninc
        allocate (arr(nsize), stat=ierr)
        if (ierr /= 0) &
            call adtterminate(adt, "reallocPlus", &
                              "Memory allocation failure for arr.")
 
        ! Copy the data from the original array into arr.
 
        nold = min(nold, nsize)
        do i = 1, nold
            arr(i) = tmp(i)
        end do
 
        ! Release the memory of tmp, which points to the original
        ! memory of the given array.
 
        deallocate (tmp, stat=ierr)
        if (ierr /= 0) &
            call adtterminate(adt, "reallocPlus", &
                              "Deallocation failure for tmp.")
 
    end subroutine reallocplus
 
end module adtutils