! Program Example from "Essential Fortran 90 & 95" by Loren P. Meissner
! Copyright 1996. Copying for sale requires permission from the author.
! Otherwise, distribution is permitted if these three lines are included.

   module H07M
      implicit none
      public :: Create, Push, Pop, Peek, Is_Empty
      integer, parameter, public :: STRING_LENGTH = 12
      type, private :: Node_Type
         character (len = STRING_LENGTH) :: Info
         type (Node_Type), pointer :: Next_NP
      end type Node_Type
      type (Node_Type), pointer, save, private :: Root_NP
   contains
      subroutine Create( )
   !  start subroutine Create
        nullify( Root_NP)
        return
      end subroutine Create
      subroutine Push( Item )
         character (len = *), intent (in) :: Item
         type (Node_Type), pointer :: Temp_NP
         integer :: AS
   !  start subroutine Push
         allocate (Temp_NP, stat = AS)
         if (AS /= 0) then
            write (unit = *, fmt = *) Item, " Allocation failure (Push). "
            stop
         end if
         Temp_NP % Info = Item
         Temp_NP % Next_NP => Root_NP ! Copy Root to new node
         Root_NP => Temp_NP
         nullify (Temp_NP)
         return
      end subroutine Push
      subroutine Pop( Item )
         character (len = *), intent (out) :: Item
         type (Node_Type), pointer :: Temp_NP
   !  start subroutine Pop
         if (Is_Empty( )) then
            write (unit = *, fmt = *) " Attempt to pop from empty stack. "
            Item = " "
         else
            Temp_NP => Root_NP
            Item = Temp_NP % Info
            Root_NP => Root_NP % Next_NP
            deallocate( Temp_NP )
         end if
         return
      end subroutine Pop
      subroutine Peek( Item )
         character (len = *), intent (out) :: Item
   !  start subroutine Peek
         if (Is_Empty( )) then
            write (unit = *, fmt = *) " Attempt to peek at empty stack. "
            Item = " "
         else
            Item = Root_NP % Info
         end if
         return
      end subroutine Peek
      function Is_Empty( ) result ( X )
         logical :: X
   !  start function Is_Empty
         X = .not. associated( Root_NP )
         return
      end function Is_Empty
   end module H07M

