!
!-----------------------------------------------------------!
! The Abstract Data Type Heap in the form a Binary Heap.    !
! The Abstract Data Type Priority Queue is also covered by  !
! this implementation.                                      !
!-----------------------------------------------------------!
! (c) 1992-2010, A. Migdalas @ MSCC                         !
!-----------------------------------------------------------!
! version 0.8 @ 2010/12/05

MODULE HeapObject

!
!------------------------------------------------------------
!The Heap is implemented as an integer array of
!pointers (cursors, pseudopointers) to an array of objects. 
!That is, we do not move objects, we rather permute the 
!pseudopointers. An integer to keep the size of the heap.
!------------------------------------------------------------
!
!------------------------------------------------------------
!The heap is a complete binary tree represented as
!an array. The root is in position 1. Any element I
!has its left child in position 2I, and its right
!child located immediately after, in position 2I+1.
!Finally, the parent is in position INT(i/2). Of course,
!the root has no parent.
!------------------------------------------------------------
!
!----------------------------------------------------------------
! ASSUMPTION: There is an external module ObjectTDef defining 
!  the type ObjectT. This type contains a component Value of type
!  INTEGER (or some other type for which partial order is or
!  has been defined, possibly by overloading the comparison
!  operators). Value is used to compare objects. For instance,
!  in an application where ObjectT is a record of employee, 
!  ObjectT%Value may be the employee's ID (or her LastName, but
!  then overloading of the string operators is required in ObjectT).
!----------------------------------------------------------------
!  
!-----------------------------------------------------------------------
! The HeapT TYPE has seven components, an INTEGER array Heap
! to hold the heap tree, an INTEGER scalar Size to hold the true
! size of the heap tree, an INTEGER scalar MaxSize to hold the
! reserved heap size, an INTEGER scalar Case to hold the case of
! minimization or maximization heap, an INTEGER scalar ErrorNr to hold
! an error number identifying the case,  a LOGICAL scalar
! Error being .TRUE. if some error occured, a LOGICAL scalar PrAllocated 
! which tells us whether the pointer ObjectP has been allocated or not, 
! and finally a array pointer of type ObjectT which points to mentioned 
! objects. All components are PRIVATE, thus, not explicitly available to
! the client.
!-------------------------------------------------------------------------
!


!------------------------------------------------------------!
!------! Client defined ObjectT is in Module ObjectTDef !----!
!------------------------------------------------------------!

  USE ObjectTDef

!------------------------------------------------------------!
!--------! Structure for Binary Heap and relatives !---------!
!------------------------------------------------------------!
!

  TYPE HeapT
     PRIVATE
     INTEGER, DIMENSION(:), ALLOCATABLE :: Heap
     INTEGER :: Size, MaxSize, ErrorNr, Case
     LOGICAL :: Error, PrAllocated
     TYPE(ObjectT), POINTER, DIMENSION(:) :: ObjectP
  END TYPE HeapT

!------------------------------------------------------------!
!---------------! Interface Definition !---------------------!
!------------------------------------------------------------!

  ! The following public routines are available to client 
  ! under the new names as defined by the INTERFACE block.
  ! Overloading occurs whenever more than one procedure
  ! appears in the block.

  INTERFACE Memory2Heap
     MODULE PROCEDURE AssociateHeap
     MODULE PROCEDURE AllocateHeapMemory
  END INTERFACE

  INTERFACE PopHeap
     MODULE PROCEDURE GetDeleteHeapRoot
  END INTERFACE

  INTERFACE MakeHeap
     MODULE PROCEDURE InitialHeap
  END INTERFACE

  ! These routines are private and available to client

  PRIVATE :: SetErrorFlags, To_Upper, AdjustHeap

  ! All other module procedures are public and available to client

  !-------------! Heap "Methods" Implemented below !-----------!

CONTAINS 

  !------------------------------------------------------------!
  !-------- Management of the Data Structure (Public) ---------!
  !    Needed because of Information Hiding                    !
  !------------------------------------------------------------!

  !------------------------------------------------------------!
  ! (1) Constructor and initializer of  a Heap

  FUNCTION NewHeap(MaxHeapSize) RESULT(HeapObj)
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: MaxHeapSize
    TYPE(HeapT) :: HeapObj
    INTEGER :: ierror
    
    IF ( .NOT. ALLOCATED( HeapObj%Heap ) ) THEN
       ALLOCATE( HeapObj%Heap(MaxHeapSize), STAT=ierror )
       IF ( ierror /= 0 ) THEN
          CALL SetErrorFlags(HeapObj,.TRUE.,-2)
       ELSE ! Could have used automatic constructor here.
          HeapObj%Case = 1; ! Minimization Heap by Default
          HeapObj%Size = 0; HeapObj%MaxSize = MaxHeapSize
          HeapObj%ErrorNr = 0; HeapObj%Error = .FALSE.
          HeapObj%PrAllocated = .FALSE.; HeapObj%ObjectP => NULL()
          CALL SetErrorFlags(HeapObj,.FALSE.,0)
       ENDIF
    ELSE
       CALL SetErrorFlags(HeapObj,.TRUE.,-1)
    ENDIF

  END FUNCTION NewHeap

  !-------------------------------------------------------------!
  ! (2) Destroy a heap object and free the memory it occupies

  SUBROUTINE DisposeHeap(HeapObj)
    IMPLICIT NONE
    TYPE(HeapT) :: HeapObj
    INTEGER :: ierror, kerror = 0
    
    CALL SetErrorFlags(HeapObj,.FALSE.,0)

    IF ( ALLOCATED( HeapObj%Heap ) ) THEN
       DEALLOCATE(  HeapObj%Heap, STAT=ierror )
       IF ( ierror /= 0 ) THEN
          CALL SetErrorFlags(HeapObj,.TRUE.,-3)
          kerror = -3
       ENDIF
    ENDIF

    IF ( HeapObj%PrAllocated ) THEN   ! ALLOCATED( HeapObj%ObjectP )?
       DEALLOCATE(  HeapObj%ObjectP, STAT=ierror )
       HeapObj%PrAllocated = .FALSE.
       IF ( ierror /= 0 ) THEN
          CALL SetErrorFlags(HeapObj,.TRUE.,-4+kerror)
       ENDIF
    ELSE IF ( ASSOCIATED( HeapObj%ObjectP ) ) THEN
       HeapObj%ObjectP => NULL()
    ENDIF
    HeapObj%Case = 0; 
    HeapObj%Size = 0; HeapObj%MaxSize = 0
    HeapObj%ErrorNr = 0; HeapObj%Error = .FALSE.
    HeapObj%PrAllocated = .FALSE.

  END SUBROUTINE DisposeHeap

  !-------------------------------------------------------------
  ! (3) Associate pointer ObjectP with a client specified Array
  !     or Allocate memory to it.
  !     To be available to the client through overloading
  !     as Memory2Heap

  ! (3a)  Association

  SUBROUTINE AssociateHeap( HeapObj, Array )
    IMPLICIT NONE
    TYPE(HeapT) :: HeapObj
    TYPE(ObjectT), TARGET, DIMENSION(1:) :: Array
    INTEGER :: i

    HeapObj%ObjectP => Array

    HeapObj%MaxSize = SIZE(Array)

    HeapObj%Heap = (/ ( i, i = 1, HeapObj%MaxSize ) /)

    HeapObj%PrAllocated = .FALSE.

    CALL SetErrorFlags(HeapObj,.FALSE.,0)
       
  END SUBROUTINE AssociateHeap

  ! (3b) Allocation

  SUBROUTINE AllocateHeapMemory( HeapObj )
    IMPLICIT NONE
    TYPE(HeapT) :: HeapObj
    INTEGER :: ierror, i

    CALL SetErrorFlags(HeapObj,.FALSE.,0)

    ALLOCATE( HeapObj%ObjectP( HeapObj%MaxSize ), STAT=ierror )

    IF ( ierror /= 0 ) THEN 
       CALL SetErrorFlags(HeapObj,.TRUE.,-5)
       RETURN
    ENDIF

    HeapObj%PrAllocated = .TRUE.

    HeapObj%Heap = (/ ( i, i = 1, HeapObj%MaxSize ) /)

  END SUBROUTINE AllocateHeapMemory


  !----------------------------------------------------------!
  ! (4) Select Minimization or Maximization Heap

  SUBROUTINE SelectHeapCase(HeapObj, icase)
    IMPLICIT NONE
    TYPE(HeapT) :: HeapObj
    CHARACTER(LEN=*) :: icase
    CHARACTER(LEN=LEN_TRIM(icase)) :: ic

    ic = To_Upper(icase)    ! Convert to upper case

    CALL SetErrorFlags(HeapObj,.FALSE.,0)
    
    SELECT CASE(ic)
       CASE("MIN")
          HeapObj%Case = 1  ! Minimization heap
       CASE("MAX")
          HeapObj%Case = 2  ! Maximization heap
       CASE DEFAULT         ! You must be kidding
          CALL SetErrorFlags(HeapObj,.TRUE.,-8)
    END SELECT

  END SUBROUTINE SelectHeapCase

  !---------------------------------------------------------!
  !------------- True Heap Operators -----------------------!
  !         This where the work is done.                    !
  !---------------------------------------------------------!

  !---------------------------------------------------------!
  ! (5) Insert a new element into the Heap

  SUBROUTINE Insert2Heap(index,HeapObj)

    !
    ! Inserts VALUE(INDEX) in the HEAP.
    ! The SIZE of HEAP is increased by 1.
    ! An empty HEAP, i.e. one of size 0 is allowed.
    ! Complexity: O(log(n))
    !

    IMPLICIT NONE
    TYPE(HeapT) :: HeapObj
    INTEGER, INTENT(IN) :: index
    INTEGER :: i, position

    CALL SetErrorFlags(HeapObj,.FALSE.,0)

     i = HeapObj%Size + 1                 
     IF ( i <= HeapObj%MaxSize ) THEN        ! Within MaxSize bounds
        CALL SetErrorFlags(HeapObj,.FALSE.,0)
        HeapObj%Size=i
     ELSE                                    ! Heap MaxSize exceeded
        CALL SetErrorFlags(HeapObj,.TRUE.,-6)
        RETURN
     ENDIF

     DO WHILE(i <= HeapObj%Size .AND. i >= 1) ! Search for a place
       IF(i.EQ.1) THEN
          position=i                          ! Insertion at the root
          EXIT
       ENDIF
       SELECT CASE( HeapObj%Case )
       CASE(1)                             ! Minimization Heap
          IF(HeapObj%ObjectP(index)%Value >= HeapObj%ObjectP(HeapObj%Heap(i/2))%Value)THEN
             position=i
             EXIT
          ENDIF
       CASE(2)                             ! Maximization Heap
          IF(HeapObj%ObjectP(index )%Value <= HeapObj%ObjectP(HeapObj%Heap(i/2))%Value)THEN
             position=i
             EXIT
          ENDIF
       END SELECT
       HeapObj%Heap(i)=HeapObj%Heap(i/2)      ! Move to parent of i
       i = i/2
    ENDDO
    
    HeapObj%Heap(position) = index            ! Place found. Insert.

  END SUBROUTINE Insert2Heap

  !--------------------------------------------------------------------!
  ! (6) Get the root of the heap and remove it. Then adjust heap
  
  INTEGER FUNCTION GetDeleteHeapRoot(HeapObj)

    !
    ! Removes the root of the heap, then adjusts
    ! the heap. Returns the root contents, i.e. HEAP(1).
    ! Heap cannot be emty, i.e. SIZE > 0 is expected.
    ! Complexity: O(log(n))
    !

    IMPLICIT NONE

    TYPE(HeapT) :: HeapObj
    INTEGER :: k, i, j

    CALL SetErrorFlags(HeapObj,.FALSE.,0)

    IF ( HeapObj%Size == 0 ) THEN
       CALL SetErrorFlags(HeapObj,.TRUE.,-9)
       RETURN
    ENDIF

    GetDeleteHeapRoot = HeapObj%Heap(1) ! Get root contents
    k = HeapObj%Heap(HeapObj%Size)      ! Last element must be moved
    HeapObj%Size = HeapObj%Size - 1     ! Reduce heap size by 1

    ! Adjust  heap

    i = 1; j = 2
    DO WHILE(j <= HeapObj%Size)
       IF(j < HeapObj%Size) THEN
          SELECT CASE ( HeapObj%Case )
          CASE(1)                       ! Minimization heap
            IF(HeapObj%ObjectP(HeapObj%Heap(j))%Value > HeapObj%ObjectP(HeapObj%Heap(j+1))%Value) j=j+1
          CASE(2)                       ! Maximization heap
            IF(HeapObj%ObjectP(HeapObj%Heap(j))%Value < HeapObj%ObjectP(HeapObj%Heap(j+1))%Value) j=j+1
          END SELECT
       ENDIF                           ! j points to the smallest/largest child
       SELECT CASE ( HeapObj%Case )
          CASE(1)                      ! Minimizaton heap
             IF(HeapObj%ObjectP(k)%Value <= HeapObj%ObjectP(HeapObj%Heap(j))%Value) EXIT
          CASE(2)
             IF(HeapObj%ObjectP(k)%Value >= HeapObj%ObjectP(HeapObj%Heap(j))%Value) EXIT
       END SELECT
       HeapObj%Heap(i)=HeapObj%Heap(j) ! Move child up
       i = j; j = 2*j                  ! Move i and j down
    ENDDO
    HeapObj%Heap(i)=k                  ! Position found

  END FUNCTION GetDeleteHeapRoot

  !-------------------------------------------------------------------!
  ! (7) Adjust a heap

  SUBROUTINE AdjustHeap(root,HeapObj,length)

    !
    ! Adjusts a heap. Operation also known as siftdown.
    ! The assumption is that the sons of ROOT are already
    ! roots of subtrees that are in heap order. Then it adjusts
    ! HEAP so that ROOT also gets in heap order.
    ! Please note that the HEAP array must have values
    ! in it, i.e. pointers to VALUE.
    ! Complexity: O(d), where d = length of tree.
    !

    TYPE(HeapT) :: HeapObj
    INTEGER, INTENT(IN) :: root, length

    INTEGER :: e, k, j

    IF(HeapObj%MaxSize < 1 .OR. length < 1 .OR. length > HeapObj%MaxSize)THEN
       CALL SetErrorFlags(HeapObj,.TRUE.,-10)
       RETURN
    ELSE
       CALL SetErrorFlags(HeapObj,.FALSE.,0)
    ENDIF

    e=HeapObj%Heap(root); k=HeapObj%ObjectP(HeapObj%Heap(root))%Value

    j=2*root
    DO WHILE(j <= length)
       IF(j < length) THEN
          SELECT CASE( HeapObj%Case )
          CASE(1)           ! Minimization Heap
             IF(HeapObj%ObjectP(HeapObj%Heap(j))%Value > HeapObj%ObjectP(HeapObj%Heap(j+1))%Value) j=j+1
          CASE(2)           ! Maximization Heap
             IF(HeapObj%ObjectP(HeapObj%Heap(j))%Value < HeapObj%ObjectP(HeapObj%Heap(j+1))%Value) j=j+1
          END SELECT
       ENDIF
       SELECT CASE( HeapObj%Case )
       CASE(1)              ! Minimization Heap
          IF(k <= HeapObj%ObjectP(HeapObj%Heap(j))%Value) EXIT
       CASE(2)              ! Maximization Heap
          IF(k >= HeapObj%ObjectP(HeapObj%Heap(j))%Value) EXIT
       END SELECT
       HeapObj%Heap(j/2) = HeapObj%Heap(j)
       j=j*2
    ENDDO
    HeapObj%Heap(j/2)=e

  END SUBROUTINE AdjustHeap

  !------------------------------------------------------------------!
  ! (8) Convert the Initial Array Indices  to Heap

  SUBROUTINE InitialHeap(HeapObj)

    !
    ! Converts the initial array cursors to a heap, 
    ! with the least/greatest element at the root.
    ! Complexity: O(size*d), d as above
    !

    IMPLICIT NONE
    TYPE(HeapT) :: HeapObj

    INTEGER:: i

    IF ( HeapObj%MaxSize < 1 ) THEN
       CALL SetErrorFlags(HeapObj,.TRUE.,-11)
       RETURN
    ELSE
       CALL SetErrorFlags(HeapObj,.FALSE.,0)
    ENDIF

    i=HeapObj%MaxSize/2
    DO WHILE(i >= 1)
       CALL AdjustHeap(i,HeapObj,HeapObj%MaxSize)
       i=i-1
    ENDDO

    HeapObj%Size = HeapObj%MaxSize

  END SUBROUTINE InitialHeap

  !-----------------------------------------------------------------!
  ! (9)  Heap Sorting in Descend Order

  SUBROUTINE HeapSortDescend(HeapObj)

    !
    ! Sorts using a heap. No need to call InitialHeap separately.
    ! Heap should not be empty, of course!
    ! Complexity: O(nlog(n))
    !

    IMPLICIT NONE
    TYPE(HeapT) :: HeapObj

    INTEGER :: i, t

    IF ( HeapObj%MaxSize < 1 ) THEN
       CALL SetErrorFlags(HeapObj,.TRUE.,-12)
       RETURN
    ELSE
       CALL SetErrorFlags(HeapObj,.FALSE.,0)
    ENDIF

    ! Make sure that it is a Minimization Heap (Silently)

    HeapObj%Case = 1

    ! Create the initial heap
    
    CALL InitialHeap(HeapObj)

    ! Swap cursors with root and re-adjust a smaller heap

    DO i = HeapObj%MaxSize-1, 1, -1
       t = HeapObj%Heap(i+1)
       HeapObj%Heap(i+1)=HeapObj%Heap(1)
       HeapObj%Heap(1)=t
       CALL AdjustHeap(1,HeapObj,i)
    ENDDO

  END SUBROUTINE HeapSortDescend

  !--------------------------------------------------------------------!
  ! (10)  Heap Sorting in Ascend Order

  SUBROUTINE HeapSortAscend(HeapObj)

    !
    ! Sorts using a heap. Demonstrates that it can be done 
    ! using only calls to Insert2Heap and GetDeleteHeapRoot, 
    ! the two basic heap operations.
    ! Complexity: Unfortunately higher than O(nlog(n))
    !

    IMPLICIT NONE

    TYPE(HeapT) :: HeapObj

    INTEGER :: i, k

    ! Ensure maximization heap (Silently)

    HeapObj%Case = 2

    ! Ensure zero size heap (Silently)

    HeapObj%Size = 0  

    ! Insert one element at a time

    DO i = 1, HeapObj%MaxSize
       CALL Insert2Heap(i,HeapObj) ! insert i
    END DO

    ! Remove one element at a time

    k=HeapObj%MaxSize

    DO i = 1,HeapObj%MaxSize
       HeapObj%Heap(k) = GetDeleteHeapRoot(HeapObj) ! delete root
       k = k - 1
    END DO

  END SUBROUTINE HeapSortAscend

  !------------------------------------------------------------------
  ! (11) Adjust heap after VALUE(INDEX) got an increased value (in case of
  !      Max Heap) or a decreased value (in case of Min Heap)
  !

  SUBROUTINE HeapOnValueChange(index,HeapObj)
    IMPLICIT NONE
    TYPE(HeapT) :: HeapObj
    INTEGER, INTENT(IN) ::index
    INTEGER ::current

    current = index ! The subtrees rooted at the sons of INDEX are already heaps

    DO WHILE(current >= 1) ! Follow the path to the root 
       CALL AdjustHeap(current,HeapObj,HeapObj%Size) ! and adjust heap.
       current = INT(current/2) ! Subtree rooted at current is heap, move to parent.
    ENDDO

  END SUBROUTINE HeapOnValueChange


  !------------------------------------------------------------------!
  !-------------- Interrogation routines (Public) -------------------!
  !     Needed because of Information Hiding                         !
  !------------------------------------------------------------------!

  !-------------------------------------------------------------------
  ! (12) Let client check whether he has chosen maximization
  !      or minimization heap

  FUNCTION HeapCase(HeapObj) RESULT(icase)
    IMPLICIT NONE
    TYPE(HeapT), INTENT(IN) :: HeapObj
    CHARACTER(LEN=3) :: icase
    
    SELECT CASE( HeapObj%Case )
       CASE(1)
          icase="MIN"
       CASE(2)
          icase="MAX"
    END SELECT

  END FUNCTION HeapCase

  !-----------------------------------------------------------------
  ! (13) Let client check the error flag
  !
  
  FUNCTION IsHeapError(HeapObj) RESULT(ierror)
    IMPLICIT NONE
    TYPE(HeapT), INTENT(IN) :: HeapObj
    LOGICAL :: ierror

    ierror = HeapObj%Error

  END FUNCTION IsHeapError

  !------------------------------------------------------------------
  ! (14) Let client check the error number

  FUNCTION WhatHeapError(HeapObj) RESULT(ierror)
    IMPLICIT NONE
    TYPE(HeapT), INTENT(IN) :: HeapObj
    INTEGER :: ierror

    ierror = HeapObj%ErrorNr

  END FUNCTION WhatHeapError

  !-------------------------------------------------------------------
  ! (15) Let client check the current heap size

  FUNCTION HeapSize(HeapObj) RESULT(isize)
    IMPLICIT NONE
    TYPE(HeapT), INTENT(IN) :: HeapObj
    INTEGER :: isize

    isize = HeapObj%Size

  END FUNCTION HeapSize

  !-----------------------------------------------------------------!
  !-------------- Copy data back and forth -------------------------!
  !---------- Necessary due to Information Hiding ------------------!
  !-----------------------------------------------------------------!

  !-------------------------------------------------------------------
  ! (16) Copy Heap to Cursor Array

  SUBROUTINE Heap2Index ( HeapObj, Array )
    IMPLICIT NONE
    TYPE(HeapT) :: HeapObj
    INTEGER, DIMENSION(1:), INTENT(OUT) :: Array

    CALL SetErrorFlags(HeapObj,.FALSE.,0)

    IF ( SIZE(Array) < HeapObj%MaxSize ) THEN
       Array = HeapObj%Heap( 1:SIZE(Array) )
       CALL SetErrorFlags(HeapObj,.TRUE.,-13)
    ELSE
       Array(1:HeapObj%MaxSize) = HeapObj%Heap
    ENDIF

  END SUBROUTINE Heap2Index

  !--------------------------------------------------------------------
  ! (17) Copy Values in Heap Order to Array

  SUBROUTINE HeapValue2Value ( HeapObj, Array )
    IMPLICIT NONE
    TYPE(HeapT) :: HeapObj
    TYPE(ObjectT), DIMENSION(1:), INTENT(OUT) :: Array

    CALL SetErrorFlags(HeapObj,.FALSE.,0)

    IF ( SIZE(Array) < HeapObj%MaxSize ) THEN
       Array%Value = HeapObj%ObjectP(HeapObj%Heap(1:SIZE(Array)))%Value
       CALL SetErrorFlags(HeapObj,.TRUE.,-14)
    ELSE
       Array(1:HeapObj%MaxSize)%Value = HeapObj%ObjectP(HeapObj%Heap)%Value
    ENDIF

  END SUBROUTINE HeapValue2Value

  !--------------------------------------------------------------------
  ! (18) Copy Array Values to Heap Values. This is an alternative to the
  !      association in (3a), particularly useful in case (3b).

  SUBROUTINE Value2HeapValue ( Array, HeapObj )
    IMPLICIT NONE
    TYPE(ObjectT), DIMENSION(1: ), INTENT(IN) :: Array
    TYPE(HeapT) :: HeapObj

    CALL SetErrorFlags(HeapObj,.FALSE.,0)

    IF ( SIZE(Array) < HeapObj%MaxSize ) THEN
       HeapObj%ObjectP(1:SIZE(Array))%Value = Array%Value
       CALL SetErrorFlags(HeapObj,.TRUE.,-15)
    ELSE
       HeapObj%ObjectP(1:HeapObj%MaxSize)%Value =  Array(1:HeapObj%MaxSize)%Value
    ENDIF
  
  END SUBROUTINE Value2HeapValue
  


  !------------------------------------------------------------------!
  !------------------- Service routines (Private) -------------------!
  !------------------------------------------------------------------!

  !------------------------------------------------------------------!
  ! (A)  Set error flags and error numbers of Heap

  SUBROUTINE SetErrorFlags(HeapObj, Happened, Value)
    IMPLICIT NONE
    LOGICAL :: Happened
    INTEGER :: Value
    TYPE(HeapT) :: HeapObj
  
    HeapObj%Error = Happened
    HeapObj%ErrorNr = Value

  END SUBROUTINE SetErrorFlags

  !------------------------------------------------------------------!
  ! (B) Transform lower case string to upper case

  FUNCTION To_Upper(string)  RESULT(newstring)
      IMPLICIT NONE
      CHARACTER(LEN = *), INTENT(IN) :: string
      CHARACTER(LEN  = LEN_TRIM(string)) :: newstring
      INTEGER, PARAMETER :: ic1 = 97, ic2 = 122, ic3 = 32
      INTEGER :: i, n, ic

      n = LEN_TRIM(string)
      DO i = 1, n
         ic = IACHAR( string(i:i) )
         IF ( ( ic .GE. ic1) .AND. ( ic .LE. ic2 ) ) THEN
            newstring(i:i) = ACHAR( ic - ic3 )
         ELSE
            newstring(i:i) = string(i:i)
         ENDIF
      ENDDO

    END FUNCTION To_Upper

END MODULE HeapObject







