MODULE pinomoduuli
  ! Tämä moduuli toteuttaa yksinkertaisen pinon
  IMPLICIT NONE
  PRIVATE
  INTEGER, PARAMETER :: maksimikoko = 100
  TYPE, PUBLIC :: pinotyyppi
    PRIVATE
    REAL, DIMENSION(maksimikoko) :: arvot
    INTEGER :: huippu
  END TYPE pinotyyppi
  TYPE(pinotyyppi) :: pino = pinotyyppi(0.0, 1)
  PUBLIC :: pop, push
CONTAINS
  SUBROUTINE push(arvo) 
    ! Laitetaan pinoon reaaliluku 
    IMPLICIT NONE
    REAL, INTENT(IN) :: arvo
    IF (pino%huippu > maksimikoko) THEN
      WRITE (*,*) "Pino on täysi"
    ELSE
      pino%arvot(pino%huippu) = arvo
      pino%huippu = pino%huippu + 1
    END IF
  END SUBROUTINE push

  REAL FUNCTION pop()
    ! Pinon päällimmäinen luku palautetaan
    IMPLICIT NONE
    IF (pino%huippu <= 1) THEN
      WRITE (*,*) "Pino on tyhjä"
      pop = 0
    ELSE
      pino%huippu = pino%huippu - 1
      pop = pino%arvot(pino%huippu)
    END IF
  END FUNCTION pop
END MODULE pinomoduuli

PROGRAM nelilaskin
  ! Yksinkertainen rpn-laskin

  ! Pinon käsittelyoperaatiot:
  USE pinomoduuli, ONLY : push, pop

  IMPLICIT NONE

  CHARACTER (LEN=*), PARAMETER :: kehote = 'rpn> '
  CHARACTER (LEN=80) :: rivi
  REAL :: a, b

  silmukka: DO 
    WRITE(UNIT=*,FMT='(A)',ADVANCE='no') kehote
    READ (*,'(A)') rivi 
    rivi = ADJUSTL(rivi)
    IF (LEN_TRIM(rivi) /= 1) THEN
      CALL lue_syote(rivi)
    ELSE 
      SELECT CASE (rivi(1:1))
        CASE ('+')
          a = pop(); b = pop(); CALL push(b+a)
        CASE ('-')
          a = pop(); b = pop(); CALL push(b-a)
        CASE ('*')
          a = pop(); b = pop(); CALL push(b*a)
        CASE ('/')
          a = pop(); b = pop(); CALL push(b/a)
        CASE ('P', 'p')
          a = pop(); WRITE (*,*) a
        CASE ('Q', 'q')
          STOP
        CASE DEFAULT
          CALL lue_syote(rivi)
      END SELECT
    END IF
  END DO silmukka

CONTAINS

  SUBROUTINE lue_syote(rivi)
    IMPLICIT NONE
    CHARACTER (LEN=*), INTENT(IN) :: rivi
    INTEGER :: tila
    REAL :: luku
    tila = 0
    READ (rivi,*,IOSTAT=tila) luku
    IF (tila == 0) THEN
      CALL push(luku)
    ELSE
      WRITE (*,*) 'Syntaksivirhe - viimeisin &
          &syöttötietorivi hylätty!'
    END IF
  END SUBROUTINE lue_syote

END PROGRAM nelilaskin