! 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.

! Example 7.8. GENERIC STACK implementation.
  module H08M
    implicit none
    public :: Create, Push, Pop, Peek, Is_Empty
    private :: Create1, Create2, Create3
    private :: Push1, Push2, Push3
    private :: Pop1, Pop2, Pop3
    private :: Peek1, Peek2, Peek3
    private :: Is_Empty1, Is_Empty2, Is_Empty3

    type, public :: Node_Type1
      private
      character (len = 12) :: Info
      type (Node_Type1), pointer :: Next_NP
    end type Node_Type1

    type, public :: Node_Type2
      private
      integer :: Info
      type (Node_Type2), pointer :: Next_NP
    end type Node_Type2

    type, public :: Info_Type
      integer :: I
      character (len = 12) :: S
    end type Info_Type

    type, public :: Node_Type3
      private
      type (Info_Type) :: Info
      type (Node_Type3), pointer :: Next_NP
    end type Node_Type3

    interface Create
      module procedure Create1, Create2, Create3
    end interface

    interface Push
      module procedure Push1, Push2, Push3
    end interface

    interface Pop
      module procedure Pop1, Pop2, Pop3
    end interface

    interface Peek
      module procedure Peek1, Peek2, Peek3
    end interface

    interface Is_Empty
      module procedure Is_Empty1, Is_Empty2, Is_Empty3
    end interface

    integer, private :: AS

  contains

    subroutine Create1( Arg_NP )
      type (Node_Type1), pointer :: Arg_NP
  ! start subroutine Create1
      nullify (Arg_NP)
      return
    end subroutine Create1

    subroutine Push1( Arg_NP, Item )
      type (Node_Type1), pointer :: Arg_NP
      character (len = *), intent(in) :: Item
      type (Node_Type1), pointer :: Temp_NP
  ! start subroutine Push1
      allocate (Temp_NP, stat = AS)
      if (AS /= 0) then
        write (unit = *, fmt = *) " Allocation failure (Push 1): ", Item
        stop
      end if
      Temp_NP % Info = Item
      Temp_NP % Next_NP => Arg_NP ! Copy Root to new node
      Arg_NP => Temp_NP
      nullify (Temp_NP)
      return
    end subroutine Push1

    subroutine Pop1( Arg_NP, Item )
      type (Node_Type1), pointer :: Arg_NP
      character (len = *), intent(out) :: Item
      type (Node_Type1), pointer :: Temp_NP
  ! start subroutine Pop1
      if (Is_Empty( Arg_NP )) then
        write (unit = *, fmt = *) " Attempt to pop from empty stack 1. "
        Item = " "
      else
        Temp_NP => Arg_NP
        Item = Temp_NP % Info
        Arg_NP => Arg_NP % Next_NP
        deallocate( Temp_NP )
      end if
      return
    end subroutine Pop1

    subroutine Peek1( Arg_NP, Item )
      type (Node_Type1), pointer :: Arg_NP
      character (len = *), intent(out) :: Item
  ! start subroutine Peek1
      if (Is_Empty( Arg_NP )) then
        write (unit = *, fmt = *) " Attempt to peek at empty stack 1. "
        Item = " "
      else
        Item = Arg_NP % Info
      end if
      return
    end subroutine Peek1

    function Is_Empty1( Arg_NP ) result ( X )
      type (Node_Type1), pointer :: Arg_NP
      logical :: X
  ! start function Is_Empty1
      X = .not. associated( Arg_NP )
      return
    end function Is_Empty1

! ====================================================================

    subroutine Create2( Arg_NP )
      type (Node_Type2), pointer :: Arg_NP
  ! start subroutine Create2
      nullify (Arg_NP)
      return
    end subroutine Create2

    subroutine Push2( Arg_NP, Item )
      type (Node_Type2), pointer :: Arg_NP
      integer, intent(in) :: Item
      type (Node_Type2), pointer :: Temp_NP
  ! start subroutine Push2
      allocate (Temp_NP, stat = AS)
      if (AS /= 0) then
        write (unit = *, fmt = *) " Allocation failure (Push 2): ", Item
        stop
      end if
      Temp_NP % Info = Item
      Temp_NP % Next_NP => Arg_NP ! Copy Root to new node
      Arg_NP => Temp_NP
      nullify (Temp_NP)
      return
    end subroutine Push2

    subroutine Pop2( Arg_NP, Item )
      type (Node_Type2), pointer :: Arg_NP
      integer, intent(out) :: Item
      type (Node_Type2), pointer :: Temp_NP
  ! start subroutine Pop2
      if (Is_Empty( Arg_NP )) then
        write (unit = *, fmt = *) " Attempt to pop from empty stack 2. "
        Item = 0
      else
        Temp_NP => Arg_NP
        Item = Temp_NP % Info
        Arg_NP => Arg_NP % Next_NP
        deallocate( Temp_NP )
      end if
      return
    end subroutine Pop2

    subroutine Peek2( Arg_NP, Item )
      type (Node_Type2), pointer :: Arg_NP
      integer, intent(out) :: Item
  ! start subroutine Peek2
      if (Is_Empty( Arg_NP )) then
        write (unit = *, fmt = *) " Attempt to peek at empty stack 2. "
        Item = 0
      else
        Item = Arg_NP % Info
      end if
      return
    end subroutine Peek2

    function Is_Empty2( Arg_NP ) result ( X )
      type (Node_Type2), pointer :: Arg_NP
      logical :: X
  ! start function Is_Empty2
      X = .not. associated( Arg_NP )
      return
    end function Is_Empty2
! ====================================================================

    subroutine Create3( Arg_NP )
      type (Node_Type3), pointer :: Arg_NP
  ! start subroutine Create3
      nullify (Arg_NP)
      return
    end subroutine Create3

    subroutine Push3( Arg_NP, Item )
      type (Node_Type3), pointer :: Arg_NP
      type (Info_Type), intent(in) :: Item
      type (Node_Type3), pointer :: Temp_NP
  ! start subroutine Push3
      allocate (Temp_NP, stat = AS)
      if (AS /= 0) then
        write (unit = *, fmt = *) " Allocation failure (Push 3). ", Item
        stop
      end if
      Temp_NP % Info = Item
      Temp_NP % Next_NP => Arg_NP ! Copy Root to new node
      Arg_NP => Temp_NP
      nullify (Temp_NP)
      return
    end subroutine Push3

    subroutine Pop3( Arg_NP, Item )
      type (Node_Type3), pointer :: Arg_NP
      type (Info_Type), intent(out) :: Item
      type (Node_Type3), pointer :: Temp_NP
  ! start subroutine Pop3
      if (Is_Empty( Arg_NP )) then
        write (unit = *, fmt = *) " Attempt to pop from empty stack 3. "
        Item = Info_Type(0, " ")
      else
        Temp_NP => Arg_NP
        Item = Temp_NP % Info
        Arg_NP => Arg_NP % Next_NP
        deallocate( Temp_NP )
      end if
      return
    end subroutine Pop3

    subroutine Peek3( Arg_NP, Item )
      type (Node_Type3), pointer :: Arg_NP
      type (Info_Type), intent(out) :: Item
  ! start subroutine Peek3
      if (Is_Empty( Arg_NP )) then
        write (unit = *, fmt = *) " Attempt to peek at empty stack 3. "
        Item = Info_Type(0, " ")
      else
        Item = Arg_NP % Info
      end if
      return
    end subroutine Peek3

    function Is_Empty3( Arg_NP ) result ( X )
      type (Node_Type3), pointer :: Arg_NP
      logical :: X
  ! start function Is_Empty3
      X = .not. associated( Arg_NP )
      return
    end function Is_Empty3

  end module H08M

