Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - decus/20-0141/darome.for
There are 2 other files named darome.for in the archive. Click here to see a list.
      SUBROUTINE DAROME(KONTRL,NUMBER,LETTER,KOUNT,LFTCOL,
     1MAX)
C     RENBR(/ROMAN NUMERAL GENERATOR)
C
C     DONALD BARTH, CHEMISTRY DEPT., HARVARD UNIVERISTY
C
C     KONTRL = 0, LEFT JUSTIFIES AT LFTCOL OR AT KOUNT+1
C              IF KOUNT IS GREATER THAN LFTCOL.
C            = 1, RIGHT JUSTIFIES AT LFTCOL.
C     NUMBER = NUMBER TO BE REPRESENTED.
C     LETTER = ARRAY TO RECIEVE ALPHAMERIC CODES.
C     KOUNT  = INPUT CONTAINING THE NUMBER OF LOCATIONS
C              IN LETTER ARRAY ALREADY IN USE AND TO BE
C              PRESERVED.  OUTPUT CONTAINING NUMBER OF
C              LOCATIONS IN USE INCLUDING THOSE USED
C              FOR THE ROMAN NUMERAL.  KOUNT IS RETURNED
C              UNCHANGED IF AN ERROR TOOK PLACE
C              (EITHER A NUMBER OUTSIDE RANGE WHICH CAN
C              BE REPRESENTED, OR INSUFFICIENT ROOM).
C     LFTCOL = LOCATION OF NEW NUMBER.
C            = CHARACTERS LEFT OF NUMBER IF KONTRL = 0.
C            = POSITION OF RIGHT DIGIT IF KONTRL = 1.
C     MAX    = DIMENSION OF LETTER ARRAY.
C
      DIMENSION LETTER(MAX),IROME(7)
      DATA IROME/1HI,1HV,1HX,1HL,1HC,1HD,1HM/
      DATA IBLANK/1H /
C
C     DISECT NUMBER
      IF(NUMBER.GT.3999)GO TO 15
C     REMOVE FOLLOWING STATEMENT TO SHOW ZERO AS SPACES
      IF(NUMBER.LE.0)GO TO 15
      N=KOUNT+1
      I=NUMBER
      K=-1
    1 M=KOUNT
      IF(I.LT.0)GO TO 15
      IF(I.EQ.0)GO TO 5
      J=I
      I=I/10
      J=J-10*I
      K=K+2
      L=0
      IF(J.LE.3)GO TO 4
      L=K+1
      J=J-5
      IF(J.NE.4)GO TO 2
      L=L+1
      J=-1
C
C     INSERT INITIAL ONE'S CHARACTER
    2 IF(J.NE.-1)GO TO 3
      IF(KOUNT.GE.MAX)GO TO 14
      KOUNT=KOUNT+1
      LETTER(KOUNT)=IROME(K)
C
C     INSERT FIVE'S OR TEN'S CHARACTER
    3 IF(L.EQ.0)GO TO 4
      IF(KOUNT.GE.MAX)GO TO 14
      KOUNT=KOUNT+1
      LETTER(KOUNT)=IROME(L)
C
C     INSERT UP TO 3 ONE'S CHARACTERS
    4 IF(J.LE.0)GO TO 9
      IF(KOUNT.GE.MAX)GO TO 14
      KOUNT=KOUNT+1
      LETTER(KOUNT)=IROME(K)
      J=J-1
      GO TO 4
C
C     ADJUST MARGINS AND INSERT FILLER BLANKS IF NEEDED
    5 IF(KONTRL.EQ.0)GO TO 6
      IF(KOUNT.GT.LFTCOL)GO TO 14
      KOUNT=LFTCOL
      GO TO 7
    6 KOUNT=KOUNT+LFTCOL-N+1
      IF(LFTCOL.LT.(N-1))KOUNT=M+1
    7 IF(KOUNT.EQ.M)GO TO 15
      IF(KOUNT.GT.MAX)GO TO 14
      J=M+1
      DO 8 I=J,KOUNT
    8 LETTER(I)=IBLANK
      I=-1
C
C     SHIFT NEW NUMERALS INTO LEFT END OF ARRAY.
C     THIS IS A GENERAL PROCEDURE TO SWAP ADJACENT
C     SECTIONS WITHIN AN ARRAY.  THE LOWER SECTION
C     EXTENDS FROM N THROUGH M.  THE UPPER SECION
C     EXTENDS FROM M+1 THROUGH KOUNT.
    9 IF(N.GT.M)GO TO 1
      IF(M.EQ.KOUNT)GO TO 1
      II=0
      JJ=KOUNT
   10 J=N+JJ-M-1
      KK=LETTER(JJ)
   11 II=II+1
      L=LETTER(J)
      LETTER(J)=KK
      KK=L
      IF(J.GT.M)GO TO 12
      J=J+KOUNT-M
      GO TO 11
   12 IF(J.EQ.JJ)GO TO 13
      J=N+J-M-1
      GO TO 11
   13 IF(II.EQ.(KOUNT-N+1))GO TO 1
      JJ=JJ-1
      GO TO 10
C
C     RETURN TO CALLING PROGRAM
   14 KOUNT=N-1
   15 RETURN
C336670692127
      END