!***********************************************************************************************************************************
!
!                                                          R O M A N
!
!  Program:      ROMAN
!
!  Author:       Dr. David G. Simpson
!                Laurel, Maryland
!
!  Date:         November 1, 2002
!
!  Language:     Fortran-90
!
!  Description:  This program contains two subroutines for converting to and from Roman numerals:
!
!                ROM2AR  -  Roman to Arabic
!                AR2ROM  -  Arabic to Roman
!
!                Also included is a simple driver program to call these two subroutines.
!
!***********************************************************************************************************************************

      PROGRAM ROMAN

      IMPLICIT NONE

      INTEGER :: CHOICE
      CHARACTER(LEN=80) :: ROMN
      INTEGER :: ARABIC
      LOGICAL :: VALID

!
!     Start of code.
!
!     Ask whether to convert Roman to Arabic or vice versa.
!

      WRITE (UNIT=*, FMT='(A)') ' Convert which way?'
      WRITE (UNIT=*, FMT='(A)') '   1.  Roman to Arabic'
      WRITE (UNIT=*, FMT='(A)') '   2.  Arabic to Roman  '
      WRITE (UNIT=*, FMT='(A)', ADVANCE='NO') ' ?  '
      READ (UNIT=*, FMT=*) CHOICE

!
!     Convert Roman to Arabic.
!

      IF (CHOICE .EQ. 1) THEN
         WRITE (UNIT=*, FMT='(A)', ADVANCE='NO') ' Enter Roman numeral:  '
         READ (UNIT=*, FMT='(A)') ROMN
         CALL ROM2AR (ROMN, ARABIC, VALID)
         IF (VALID) THEN
            WRITE (UNIT=*, FMT='(1X,I12)') ARABIC
         ELSE
            WRITE (UNIT=*, FMT='(A)') ' Invalid Roman numeral'
         END IF

!
!     Convert Arabic to Roman.
!

      ELSE
         WRITE (UNIT=*, FMT='(A)', ADVANCE='NO') ' Enter Arabic numeral:  '
         READ (UNIT=*, FMT=*) ARABIC
         CALL AR2ROM (ARABIC, ROMN, VALID)
         IF (VALID) THEN
            WRITE (UNIT=*, FMT='(1X,A)') ROMN
         ELSE
            WRITE (UNIT=*, FMT='(A)') ' Invalid Arabic numeral'
         END IF
      END IF

!
!     End of program.
!

      STOP

      END PROGRAM ROMAN




!***********************************************************************************************************************************
!  ROM2AR
!
!  This function converts a Roman numeral to an Arabic numeral.
!
!  Input:
!     ROM    -  Roman numeral (character string)
!  Outputs:
!     ARB    -  Arabic numeral (integer)
!     VALID  -  Returns .TRUE. if input was valid, .FALSE. if invalid
!
!   This function will automatically remove any leading spaces from the Roman numeral, and will accept both uppercase and
!   lowercase letters.  If an invalid Roman numeral input is given, the 'valid' flag is set to .false..
!***********************************************************************************************************************************

      SUBROUTINE ROM2AR (ROM, ARB, VALID)

      IMPLICIT NONE

      CHARACTER(LEN=*), INTENT(IN) :: ROM                                           ! input Roman numeral string
      INTEGER, INTENT(OUT) :: ARB                                                   ! output Arabic numeral
      LOGICAL, INTENT(OUT) :: VALID                                                 ! output valid flag

      INTEGER :: I, VALUE, IDX1, IDX2, DEL
      CHARACTER :: CH1, CH2
      LOGICAL :: FORNIN, FOUND

      CHARACTER(LEN=7), PARAMETER :: RIDX = 'IVXLCDM'
      INTEGER, PARAMETER :: VIDX(7) = (/ 1, 5, 10, 50, 100, 500, 1000 /)

!
!     Start of code.
!     Initialize variables.
!

      ARB = 0
      VALID = .TRUE.
      FOUND = .FALSE.
      DEL = IACHAR('a') - IACHAR('A')

!
!     Loop on each character in Roman numeral string.
!

      DO I = 1, LEN(ROM)

!
!     Convert to letters to uppercase.
!

         CH1 = ROM(I:I)
         IF (LGE(CH1,'a').AND.LLE(CH1,'z')) CH1 = ACHAR(IACHAR(CH1)-DEL)
         CH2 = ROM(I+1:I+1)
         IF (LGE(CH2,'a').AND.LLE(CH2,'z')) CH2 = ACHAR(IACHAR(CH2)-DEL)

!
!     Skip initial blanks, and exit loop when ending blank is found.
!     (FOUND = .TRUE. when start of Roman numeral has been found.)
!

         IF (.NOT. FOUND) THEN
            IF (CH1 .EQ. ' ') THEN
               CYCLE
            ELSE
               FOUND = .TRUE.
            END IF
         ELSE
            IF (CH1 .EQ. ' ') EXIT
         END IF

!
!     Set FORNIN = .TRUE. if we've found one of the combinations:
!        IV=4, IX=9, XL=40, XC=90, CD=400, or CM=900.
!

         IDX1 = INDEX(RIDX, CH1)
         IF (IDX1 .EQ. 0) VALID = .FALSE.
         IDX2 = INDEX(RIDX, CH2)
         FORNIN = ((IDX1.EQ.1) .AND. ((IDX2.EQ.2) .OR. (IDX2.EQ.3)))
         FORNIN = FORNIN .OR. ((IDX1.EQ.3) .AND. ((IDX2.EQ.4) .OR. (IDX2.EQ.5)))
         FORNIN = FORNIN .OR. ((IDX1.EQ.5) .AND. ((IDX2.EQ.6) .OR. (IDX2.EQ.7)))

!
!     Check for invalid Roman numeral (Repeated V, L, or D; or
!     letters in increasing order except for IV, IX, XL, XC, CD, or CM).
!     Set VALID = .FALSE. if invalid combination found.
!

         IF ((IDX1 .EQ. IDX2) .AND. ((IDX1.EQ.2) .OR. (IDX1.EQ.4) .OR. (IDX1.EQ.6))) VALID = .FALSE.
         IF ((IDX1 .LT. IDX2) .AND. (.NOT. FORNIN)) VALID = .FALSE.
         VALUE = VIDX(IDX1)

!
!     If one of the valid double-letter combinations (IV, IX, XL, XC,
!     CD, CM) is found, then negate the value of the first character.
!

         IF (FORNIN) VALUE = -VALUE

!
!     Add letter value into running sum.
!

         ARB = ARB + VALUE
      END DO

!
!     End of loop - return Roman numeral value and VALID flag.
!

      RETURN

      END SUBROUTINE ROM2AR




!***********************************************************************************************************************************
!  AR2ROM
!
!  This function converts an Arabic numeral to a Roman numeral.
!
!  Input:
!     ARB    -  Arabic numeral (integer)
!  Outputs:
!     ROM    -  Roman numeral (character string)
!     VALID  -  Returns .TRUE. if input was valid, .FALSE. if invalid
!
!   This function will set the VALID flag to .FALSE. if the input Arabic numeral is negative or zero.
!***********************************************************************************************************************************

      SUBROUTINE AR2ROM (ARB, ROM, VALID)

      IMPLICIT NONE

      INTEGER, INTENT(IN) :: ARB                                                    ! input Arabic numeral
      CHARACTER(LEN=*), INTENT(OUT) :: ROM                                          ! output Roman numeral string
      LOGICAL, INTENT(OUT) :: VALID                                                 ! output valid flag

      INTEGER :: I, J, LEFT


!
!     Start of code.
!     Check for invalid Arabic numeral (non-positive).
!     If invalid, set VALID flag to .FALSE. and exit.
!

      IF (ARB .LE. 0) THEN
         VALID = .FALSE.
         ROM = '0'
         RETURN
      END IF

!
!     Initialize variables.
!

      VALID = .TRUE.
      LEFT = ARB
      J = 1

!
!     Begin successive subtractions from Arabic numeral to find corresponding Roman numerals.
!     Note that multiple I, X, C, or M may occur, but only (at most) one each of:  IV, V, IX, XL, L, XC, CD, D, CM.
!
!     Account for 1000's (M).
!

      DO WHILE (LEFT .GE. 1000)
         LEFT = LEFT - 1000
         ROM(J:J) = 'M'
         J = J + 1
      END DO

!
!     Account for 900 (CM).
!

      IF (LEFT .GE. 900) THEN
         LEFT = LEFT - 900
         ROM(J:J+1) = 'CM'
         J = J + 2
      END IF

!
!     Account for 500 (D).
!

      IF (LEFT .GE. 500) THEN
         LEFT = LEFT - 500
         ROM(J:J) = 'D'
         J = J + 1
      END IF

!
!     Account for 400 (CD).
!

      IF (LEFT .GE. 400) THEN
         LEFT = LEFT - 400
         ROM(J:J+1) = 'CD'
         J = J + 2
      END IF

!
!     Account for 100's (C).
!

      DO WHILE (LEFT .GE. 100)
         LEFT = LEFT - 100
         ROM(J:J) = 'C'
         J = J + 1
      END DO

!
!     Account for 90 (XC).
!

      IF (LEFT .GE. 90) THEN
      LEFT = LEFT - 90
         ROM(J:J+1) = 'XC'
         J = J + 2
      END IF

!
!     Account for 50 (L).
!

      IF (LEFT .GE. 50) THEN
         LEFT = LEFT - 50
         ROM(J:J) = 'L'
         J = J + 1
      END IF

!
!     Account for 40 (XL).
!

      IF (LEFT .GE. 40) THEN
         LEFT = LEFT - 40
         ROM(J:J+1) = 'XL'
         J = J + 2
      END IF

!
!     Account for 10's (X).
!

      DO WHILE (LEFT .GE. 10)
         LEFT = LEFT - 10
         ROM(J:J) = 'X'
         J = J + 1
      END DO

!
!     Account for 9 (IX).
!

      IF (LEFT .GE. 9) THEN
         LEFT = LEFT - 9
         ROM(J:J+1) = 'IX'
         J = J + 2
      END IF

!
!     Account for 5 (V).
!

      IF (LEFT .GE. 5) THEN
         LEFT = LEFT - 5
         ROM(J:J) = 'V'
         J = J + 1
      END IF

!
!     Account for 4 (IV).
!

      IF (LEFT .GE. 4) THEN
         LEFT = LEFT - 4
         ROM(J:J+1) = 'IV'
         J = J + 2
      END IF

!
!     Account for 1's (I).
!

      DO WHILE (LEFT .GE. 1)
         LEFT = LEFT - 1
         ROM(J:J) = 'I'
         J = J + 1
      END DO

!
!     End of code - return Roman numeral string and VALID flag.
!

      RETURN

      END SUBROUTINE AR2ROM