Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-02 - 43,50250/datast.f4
There are no other files named datast.f4 in the archive.
      SUBROUTINE DATA(IDATA,KNTDAT,NAME,KNTLTR,
     1IFORMT,MAXLTR,MAXLIN,IOUT)
C     JUL 14, 1970
C     DONALD BARTH, CHEM. DEPT., HARVARD UNIVERSITY
C
C     ROUTINE TO WRITE INTEGER DATA STATEMENTS
C
C     IDATA  = DATA ARRAY TO BE WRITTEN AS DATA STATEMENT
C     KNTDAT = NUMBER OF ENTRIES IN DATA ARRAY
C     NAME   = ALPHAMERIC ARRAY CONTAINING NAME OF ARRAY
C              (READ BY MULTIPLE OF A1 FORMAT)
C     KNTLTR = NUMBER OF LETTERS IN NAME OF ARRAY
C     IFORMT = 0, GIVES COMPACT FORMAT DATA STATEMENT
C            = 1 OR GREATER, GIVES EXPANDED FORMAT AND IS
C              MINIMUM LENGTH OF THE FIELD INTO WHICH
C              EACH ENTRY IS PLACED IF ALL ENTRIES FIT THIS
C              (IFORMT=10 IS EQUIVALENT TO I10 FORMAT)
C     MAXLTR = NUMBER OF CHARACTERS TO BE IN STATEMENT FIELD
C              (66 IF MAXIMUM, IE 72 MINUS LEFT 6 COLUMNS)
C     MAXLIN = MAXIMUM NUMBER OF LINES FOR SINGLE STATEMENT
C     IOUT   = OUTPUT UNIT ON WHICH STATEMENT IS WRITTEN
C
      DIMENSION IDATA(1),NAME(1),LETTER(66),ISTORE(200)
      DATA IBLANK,ISLASH,KOMMA,ILPR,IRPR/
     11H ,1H/,1H,,1H(,1H)/
C
C     JSTORE = DIMENSION OF ISTORE ARRAY.  THIS IS THE
C              MAXIMUM NUMBER OF SMALL ARRAYS WHICH CAN
C              BE USED TO REPRESENT THE IDATA ARRAY.
C
      DATA JSTORE/200/
C
      IF(KNTDAT)93,93,1
    1 LOCK=1
      MOST=0
      MAX1=MAXLTR-1
      MAX2=MAXLTR-2
      LEFT=0
      CALL DANUMB(0,KNTDAT,10,LETTER,LEFT,0,MAXLTR)
      LENGTH=KNTLTR+LEFT
      IF(LENGTH-6)3,3,2
    2 LENGTH=6
    3 IF(IFORMT)66,66,4
C
C     PREPARE FOR EXPANDED FORMAT
    4 MOST=IDATA(1)
      LEAST=MOST
      DO 5 INDEX=1,KNTDAT
      IF(LEAST.GT.IDATA(INDEX))LEAST=IDATA(INDEX)
      IF(MOST.LT.IDATA(INDEX))MOST=IDATA(INDEX)
    5 CONTINUE
      KOUNT=0
      CALL DANUMB(0,MOST,10,LETTER,KOUNT,0,MAXLTR)
      MOST=KOUNT
      KOUNT=0
      CALL DANUMB(0,LEAST,10,LETTER,KOUNT,0,MAXLTR)
      IF(MOST-KOUNT)6,7,7
    6 MOST=KOUNT
    7 IF(MOST-IFORMT)8,9,9
    8 MOST=IFORMT
    9 LIMIT=MAXLIN*((MAXLTR-LENGTH-6)/(MOST+1))
      IF(LIMIT)92,92,10
   10 KNTPRT=1+((KNTDAT-1)/LIMIT)
      IF(KNTPRT-JSTORE)11,11,91
   11 LEAST=1
      DO 12 INDEX=1,KNTPRT
      ISTORE(INDEX)=LEAST
   12 LEAST=LEAST+LIMIT
C
C     TEST IF LABELS ARE OF MINIMUM LENGTH
   13 ITEST=0
      CALL DANUMB(0,ISTORE(KNTPRT),10,LETTER,ITEST,0,MAXLTR)
      IF(KNTLTR+ITEST-LENGTH)14,15,15
   14 LENGTH=KNTLTR+ITEST
      IF(IFORMT)66,66,9
   15 LOCK=0
      IF(IFORMT)16,16,17
   16 LEFT=0
      ITEST=0
C
C     CONSTRUCT SINGLE LINE OF DIMENSION STATEMENT
   17 INDEX=0
      DO 18 LEAST=1,10
   18 LETTER(LEAST)=IBLANK
   19 LINE=1
      LAST=INDEX
   20 KOUNT=10
   21 IF(INDEX)22,22,26
C
C     INSERT NAME OF MAIN ARRAY
   22 IF(IFORMT)24,24,23
   23 LIMIT=-LENGTH
      GO TO 25
   24 LIMIT=0
   25 LEAST=KOUNT
      CALL DAWORD(LIMIT,LEFT,NAME,KNTLTR,0,KNTDAT,LETTER,
     1KOUNT,MAX1)
      IF(KOUNT-LEAST)33,33,30
C
C     INSERT NAME OF SMALL ARRAY
   26 IF(INDEX-KNTPRT)28,27,27
   27 LIMIT=KNTDAT-ISTORE(INDEX)+1
      GO TO 29
   28 LIMIT=ISTORE(INDEX+1)-ISTORE(INDEX)
   29 LEAST=KOUNT
      CALL DAWORD(LENGTH,LEFT,NAME,KNTLTR,ISTORE(INDEX),
     1LIMIT,LETTER,KOUNT,MAX1)
      IF(KOUNT-LEAST)31,31,30
   30 INDEX=INDEX+1
      KOUNT=KOUNT+1
      LETTER(KOUNT)=KOMMA
      IF(INDEX-KNTPRT)21,21,32
C
C     OUTPUT SINGLE LINE OF DIMENSION STATEMENT
   31 IF(LINE-MAXLIN)33,32,32
   32 KOUNT=KOUNT-1
   33 IF(LINE-1)34,34,37
   34 IF(KOUNT-10)35,35,36
   35 WRITE(IOUT,96)
      GO TO 39
   36 WRITE(IOUT,96)(LETTER(LEAST),LEAST=11,KOUNT)
      GO TO 39
   37 IF(KOUNT)92,92,38
   38 WRITE(IOUT,99)MANY,(LETTER(LEAST),LEAST=1,KOUNT)
      MANY=MANY+1
      IF(MANY-9)40,40,39
   39 MANY=1
   40 IF(INDEX-KNTPRT)41,41,45
   41 IF(LINE-MAXLIN)43,42,42
   42 IF(INDEX-LAST)92,92,19
   43 LINE=LINE+1
      IF(IFORMT)44,44,20
   44 KOUNT=0
      GO TO 21
C
C     CONSTRUCT SINGLE LINE OF EQUIVALENCE STATEMENT
   45 INDEX=1
      DO 46 LEAST=1,12
   46 LETTER(LEAST)=IBLANK
   47 LINE=1
      LAST=INDEX
   48 KOUNT=12
C
C     INSERT NAME OF SMALL ARRAY
   49 KOUNT=KOUNT+1
      LEAST=KOUNT
      CALL DAWORD(LENGTH,0,NAME,KNTLTR,ISTORE(INDEX),1,
     1LETTER,KOUNT,MAX2)
      IF(KOUNT-LEAST)52,52,50
C
C     INSERT NAME OF MAIN ARRAY
   50 KOUNT=KOUNT+1
      LIMIT=KOUNT
      CALL DAWORD(0,ITEST,NAME,KNTLTR,0,ISTORE(INDEX),
     1LETTER,KOUNT,MAX2)
      IF(KOUNT-LIMIT)52,52,51
   51 LETTER(LEAST)=ILPR
      LETTER(LIMIT)=KOMMA
      KOUNT=KOUNT+1
      LETTER(KOUNT)=IRPR
      KOUNT=KOUNT+1
      LETTER(KOUNT)=KOMMA
      INDEX=INDEX+1
      IF(INDEX-KNTPRT)49,49,53
C
C     OUTPUT SINGLE LINE OF EQUIVALENCE STATEMENT
   52 KOUNT=LEAST-1
      IF(LINE-MAXLIN)54,53,53
   53 KOUNT=KOUNT-1
   54 IF(LINE-1)55,55,58
   55 IF(KOUNT-12)56,56,57
   56 WRITE(IOUT,97)
      GO TO 60
   57 WRITE(IOUT,97)(LETTER(LEAST),LEAST=13,KOUNT)
      GO TO 60
   58 IF(KOUNT)92,92,59
   59 WRITE(IOUT,99)MANY,(LETTER(LEAST),LEAST=1,KOUNT)
      MANY=MANY+1
      IF(MANY-9)61,61,60
   60 MANY=1
   61 IF(INDEX-KNTPRT)62,62,66
   62 IF(LINE-MAXLIN)64,63,63
   63 IF(INDEX-LAST)92,92,47
   64 LINE=LINE+1
      IF(IFORMT)65,65,48
   65 KOUNT=0
      GO TO 49
C
C     CONSTRUCT SINGLE LINE OF DATA STATEMENT
   66 INDEX=1
      KNTPRT=0
   67 LINE=1
      LAST=INDEX+1
      KOUNT=5
   68 LIMIT=KOUNT+MOST
   69 LEAST=KOUNT
      IF(LAST-INDEX)73,73,70
C
C     INSERT NAME OF SMALL ARRAY
   70 CALL DAWORD(LENGTH,-1,NAME,KNTLTR,INDEX,0,LETTER,KOUNT,
     1MAX1)
      IF(KOUNT-LEAST)77,77,71
   71 LAST=INDEX
      KOUNT=KOUNT+1
      LETTER(KOUNT)=ISLASH
      IF(KNTPRT-JSTORE)72,91,91
   72 KNTPRT=KNTPRT+1
      ISTORE(KNTPRT)=INDEX
      GO TO 68
C
C     INSERT INTEGER ENTRY
   73 CALL DANUMB(IFORMT,IDATA(INDEX),10,LETTER,KOUNT,
     1LIMIT,MAX1)
      IF(KOUNT-LEAST)75,75,74
   74 KOUNT=KOUNT+1
      LETTER(KOUNT)=KOMMA
      INDEX=INDEX+1
      IF(INDEX-KNTDAT)68,68,76
C
C     OUTPUT SINGLE LINE OF DATA STATEMENT
   75 IF(LINE-MAXLIN)77,76,76
   76 LETTER(KOUNT)=ISLASH
   77 IF(LOCK)78,78,85
   78 IF(LINE-1)79,79,82
   79 IF(KOUNT-5)80,80,81
   80 WRITE(IOUT,98)
      GO TO 84
   81 WRITE(IOUT,98)(LETTER(LEAST),LEAST=6,KOUNT)
      GO TO 84
   82 IF(KOUNT)92,92,83
   83 WRITE(IOUT,99)MANY,(LETTER(LEAST),LEAST=1,KOUNT)
      MANY=MANY+1
      IF(MANY-9)85,85,84
   84 MANY=1
   85 IF(INDEX-KNTDAT)86,86,90
   86 IF(LINE-MAXLIN)88,87,87
   87 IF(INDEX-LAST)92,92,67
   88 LINE=LINE+1
      KOUNT=0
      IF(IFORMT)68,68,89
   89 LIMIT=6+LENGTH+MOST
      GO TO 69
   90 IF(LOCK)93,93,13
C
C     RETURN TO CALLING PROGRAM
   91 WRITE(IOUT,94)
      GO TO 93
   92 WRITE(IOUT,95)
   93 RETURN
   94 FORMAT(26H INCREASE ISTORE DIMENSION)
   95 FORMAT(21H INSUFFICIENT STORAGE)
   96 FORMAT(6X,10HDIMENSION ,66A1)
   97 FORMAT(6X,12HEQUIVALENCE ,66A1)
   98 FORMAT(6X,5HDATA ,61A1)
   99 FORMAT(5X,1I1,66A1)
      END
      SUBROUTINE DAWORD(INDEX,IFORMT,NAME,KNTLTR,NUMBER,
     1IVALUE,LETTER,KOUNT,MAX)
C
C     ROUTINE TO CREATE ARRAY NAMES WITH DIMENSION NUMBERS
C
C     DONALD BARTH, CHEM. DEPT., HARVARD UNIVERSITY
C
C     INDEX  = NEGATIVE OR 0, A SYMBOL CONTAINING AT LEAST
C              -INDEX CHARACTERS IS PRODUCED IN LETTER ARRAY
C              BY COPYING LOCATIONS 1 THRU KNTLTR OF NAME
C              ARRAY AND INSERTING RIGHT BLANKS IF NECESSARY.
C            = 1 OR GREATER, IS LENGTH OF SYMBOL TO BE
C              OUTPUT IN LETTER ARRAY BY RIGHT JUSTIFYING
C              DIGITS OF NUMBER AND MAKING LEFT CHARACTERS
C              BE THOSE IN NAME ARRAY OR THE LETTER ZERO.
C     IFORMT = -1, NO NUMBER IS GIVEN ENCLOSED IN PARENTHESES.
C            = 0, IVALUE IS REPRESENTED ENCLOSED IN
C              PARENTHESES TO RIGHT OF SYMBOL.
C            = 1 OR GREATER, IVALUE IS REPRESENTED RIGHT
C              JUSTIFIED IN A FIELD OF IFORMT LOCATIONS AND
C              ENCLOSED IN PARENTHESES TO RIGHT OF SYMBOL.
C     NAME   = ALPHAMERIC ARRAY READ BY MULTIPLE OF A1 FORMAT
C              AND CONTAINING THE LETTERS OF THE SYMBOL.
C     KNTLTR = NUMBER OF SYMBOL CHARACTERS IN NAME ARRAY.
C     NUMBER = NUMBER TO BECOME PART OF SYMBOL IF INDEX=1
C              OR GREATER.
C     IVALUE = NUMBER TO FOLLOW SYMBOL IF IFORMT=1 OR GREATER.
C     LETTER = ARRAY TO RECEIVE SYMBOL.
C     KOUNT  = NUMBER OF LOCATIONS OF LETTER ARRAY IN USE.
C     MAX    = MAXIMUM NUMBER OF LOCATIONS IN LETTER WHICH
C              CAN BE FILLED.
C
      DIMENSION LETTER(1),NAME(1)
      DATA IBLANK,IZERO,ILPR,IRPR/1H ,1H0,1H(,1H)/
C
C     COPY SYMBOL WITHOUT RIGHT JUSTIFIED NUMBER
      INIT=KOUNT
      IF(INDEX)1,1,8
    1 IF(KOUNT+KNTLTR-MAX)2,2,17
    2 KOLUMN=0
    3 IF(KOLUMN-KNTLTR)4,5,5
    4 KOUNT=KOUNT+1
      KOLUMN=KOLUMN+1
      LETTER(KOUNT)=NAME(KOLUMN)
      GO TO 3
    5 IF(KOUNT-INDEX-KNTLTR-MAX)7,7,15
    6 KOUNT=KOUNT+1
      KOLUMN=KOLUMN+1
      LETTER(KOUNT)=IBLANK
    7 IF(KOLUMN+INDEX)6,13,13
C
C     COPY SYMBOL WITH RIGHT JUSTIFIED NUMBER
    8 KOLUMN=KOUNT+INDEX
      IF(KOLUMN-MAX)9,9,17
    9 LONG=KOUNT
      CALL DANUMB(1,NUMBER,10,LETTER,KOUNT,KOLUMN,MAX)
      KOLUMN=0
   10 LONG=LONG+1
      IF(LETTER(LONG).NE.IBLANK)GO TO 13
      IF(KOLUMN-KNTLTR)12,11,11
   11 LETTER(LONG)=IZERO
      GO TO 10
   12 KOLUMN=KOLUMN+1
      LETTER(LONG)=NAME(KOLUMN)
      GO TO 10
C
C     INSERT NUMBER ENCLOSED IN PARENTHESES
   13 IF(IFORMT)17,14,14
   14 KOLUMN=KOUNT+IFORMT+1
      CALL DANUMB(IFORMT,IVALUE,10,LETTER,KOUNT,KOLUMN,MAX-1)
      IF(KOUNT-KOLUMN)15,16,16
   15 KOUNT=INIT
      GO TO 17
   16 KOLUMN=KOLUMN-IFORMT
      LETTER(KOLUMN)=ILPR
      KOUNT=KOUNT+1
      LETTER(KOUNT)=IRPR
C
C     RETURN TO CALLING PROGRAM
   17 RETURN
      END
      SUBROUTINE DANUMB(KONTRL,NUMBER,IRADIX,LETTER,
     1KOUNT,LFTCOL,MAX)
C     JAN 2, 1970
C     SUBROUTINE TO PRINT NUMBERS HORIZONTALLY
C
C     DONALD BARTH, CHEM. DEPT., HARVARD UNIVERSITY
C
C     KONTRL = 0 LEFT JUSTIFIES AT LFTCOL OR AT KOUNT+1
C              IF KOUNT IS GREATER THAN LFTCOL.
C     KONTRL = 1 RIGHT JUSTIFIES AT LFTCOL.
C     NUMBER = NUMBER TO BE INSERTED.
C     IRADIX = BASE TO WHICH NUMBER WILL BE EXPRESSED.
C     LETTER = ALPHAMERIC BUFFER ARRAY TO BE CODED.
C     KOUNT  = NUMBER OF LOCATIONS IN LETTER IN USE.
C     LFTCOL = LOCATION OF NEW NUMBER.
C     LFTCOL = CHARACTERS LEFT OF NUMBER IF KONTRL = 0.
C     LFTCOL = POSITION OF RIGHT DIGIT IF KONTRL = 1.
C     MAX    = DIMENSION OF LETTER ARRAY.
C
      DIMENSION LETTER(130),IDGT(10)
      DATA IDGT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
      DATA IBLANK,IMINUS/1H ,1H-/
C
C     EVEN UP RIGHT MARGIN IF NEEDED
      KSAVE=KOUNT
      IF(LFTCOL-MAX)1,1,26
    1 IF(KOUNT-MAX)2,26,26
    2 IF(KONTRL)26,4,3
    3 IF(KOUNT-LFTCOL)6,26,26
    4 IF(KOUNT-LFTCOL)5,6,5
    5 KOUNT=KOUNT+1
      LETTER(KOUNT)=IBLANK
      IF(KOUNT-LFTCOL)5,6,6
C
C     SET INITIAL POINTERS
    6 KNT=0
      KEEP=KOUNT+1
      IF(NUMBER)8,7,7
C
C     POSITIVE NUMBER
    7 NUMB=NUMBER
      IF(KOUNT-MAX)12,25,25
C
C     NEGATIVE NUMBER
    8 IF(KEEP-MAX)9,25,25
    9 KOUNT=KOUNT+1
      LETTER(KOUNT)=IMINUS
C     ABSOLUTE VALUE OF A NEGATIVE NUMBER IS DECREMENTED
C     BY ONE SINCE, ON A TWO'S COMPLEMENT COMPUTER, THE
C     ABSOLUTE VALUE OF THE LARGEST NEGATIVE NUMBER (SIGN
C     BIT ON AND ALL OTHER BITS OFF) CANNOT BE REPRESENTED.
C     THIS NUMBER CAN BE EASILY OBTAINED IF SIGN BIT IS
C     USED FOR STORING INFORMATION IN SETS.
      INDEX=NUMBER+1
      NUMB=-INDEX
      GO TO 12
C
C     INSERT DIGITS OF NUMBER
   10 INDEX=KOUNT+KNT
   11 LETTER(INDEX+1)=LETTER(INDEX)
      INDEX=INDEX-1
      IF(INDEX-KOUNT)26,12,11
   12 KNT=KNT+1
      INDEX=NUMB
      NUMB=NUMB/IRADIX
      INDEX=INDEX-IRADIX*NUMB
      IF(NUMBER)13,16,16
   13 IF(KNT-1)26,14,16
   14 INDEX=INDEX+1
      IF(INDEX-IRADIX)16,15,26
   15 INDEX=0
      NUMB=NUMB+1
   16 LETTER(KOUNT+1)=IDGT(INDEX+1)
      IF(NUMB)26,18,17
   17 IF(KNT+KOUNT-MAX)10,25,25
   18 KOUNT=KOUNT+KNT
C
C     EVEN UP LEFT MARGIN IF NEEDED
      IF(KONTRL)26,26,19
   19 IF(KOUNT-LFTCOL)20,26,23
C
C     ADD BLANKS TO LEFT MARGIN
   20 DO 21 KNT=KEEP,KOUNT
      INDEX=LFTCOL-KNT+KEEP
      NUMB=KOUNT-KNT+KEEP
   21 LETTER(INDEX)=LETTER(NUMB)
      INDEX=LFTCOL-KOUNT+KEEP-1
      DO 22 KNT=KEEP,INDEX
   22 LETTER(KNT)=IBLANK
      KOUNT=LFTCOL
      GO TO 26
C
C     REMOVE EXCESS DIGITS FROM LEFT MARGIN
   23 DO 24 KNT=KEEP,LFTCOL
      INDEX=KNT+KOUNT-LFTCOL
   24 LETTER(KNT)=LETTER(INDEX)
      KOUNT=LFTCOL
      GO TO 26
   25 KOUNT=KSAVE
   26 RETURN
C     KEEP   = SUBSCRIPT AT WHICH INSERT 1ST CHARACTER.
C     KNT    = NUMBER OF DIGITS ADDED TO ARRAY.
C     KSAVE  = NUMBER OF CHARACTERS IN ORIGINAL ARRAY.
C     NUMB   = ABSOLUTE VALUE OF UNUSED PART OF NUMBER.
      END