Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - decus/20-0137/bmd/bmd10s.for
There is 1 other file named bmd10s.for in the archive. Click here to see a list.
C        TRANSPOSE LARGE MATRICES                     JUNE 22, 1966
C        THIS IS A SIFTED VERSION OF BMD10S ORIGINALLY WRITTEN IN
C        FORTRAN II. SOME MODIFICATIONS WERE MADE TO MAKE IT OPERABLE
C        AND SLIGHTLY MORE EFFICIENT THAN THE SIFTED VERSION.
	DOUBLE PRECISION A123,A321,FORM,CODE1,CODE
      DATA A123/'PROBLM'/,A321/'FINISH'/,FORM/'FORMAT'/
      DIMENSION  X(10000)
      DIMENSION FNT(181),FMT(181)
      DIMENSION  JTAPE(15), JON(15)
      DIMENSION  NTAPE(15)
      COMMON  X      , ISTART , ISTOP  , INCR   , FNT    , IN
      COMMON  INCOLS , JON    , NOUT   , KTIMES , KBUNCH , KLEFT
      COMMON  INROWS , FMT    , OPTION
      DATA PCH/'PCH'/,PARAN/'('/
C     SET MAX = MAXIMUM NUMBER OF ROWS AND COLUMNS
      MAX = 10000
	CALL USAGEB('BMD10S')
 1000 B123=A123
  601 FORMAT('1BMD10S - TRANSPOSITION OF LARGE MATRICES - REVISED ',
     1'SEPTEMBER 19, 1968'/
     241H HEALTH SCIENCES COMPUTING FACILITY, UCLA//)
      READ (5,150)CODE1, CODE, INROWS, INCOLS, LUMP, KBUNCH, NFTIN, NFTO
     1UT, IN, ITAPES, (NTAPE(I), I=1,15), OPTION
  150 FORMAT(2A6, 4I5, 2I3, 17I2, A3)
      NOUT = NTAPE(1)
      IF(CODE1 .EQ. A123) GO TO 2
      IF(CODE1 .EQ. A321) GO TO 1916
  602 WRITE (6,605)B123, CODE1, CODE
  605 FORMAT(///// 18H PROGRAM EXPECTS  , A6, 21H  CARD HERE.  INSTEAD
     1 29H IT FINDS THE CARD BEGINNING , / 6X, 2A6 /
     2 55H THIS CARD IS INCORRECTLY PUNCHED AND/OR OUT OF ORDER.
     3 60H SEE BMD MANUAL, 2ND EDITION, FOR INSTRUCTIONS ON THE PROPER
     4 / 58H PREPARATION AND ARRANGEMENT OF CONTROL CARDS FOR  BMD10S. )
      REWIND NOUT
      GO TO 1916
    2 IF  (IN)  606, 606, 607
  606 IN = 11
  607 NSTEP = MIN0(INROWS,  MAX /INCOLS)
C   NSTEP IS THE MAXIMUM NUMBER OF ROWS WHICH CAN BE READ INTO MEMORY
C   AT ONE TIME, GIVEN THAT THERE ARE  INCOLS  ENTRIES PER ROW.
      WRITE (6,601)
      IF(NFTIN .GT. 0 .AND. NFTIN .LE. 10) GO TO 9
      TYPE 7
      NFTIN = 1
    9 IF(NFTOUT.GT. 0 .AND. NFTOUT .LE. 10) GO TO 600
      TYPE 7
      NFTOUT = 1
    7 FORMAT(1H023X71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPECIF
     1IED, ASSUMED TO BE 1.)
  600 KSKIP=1
      IF(OPTION.EQ.PCH)GO TO 6005
      KSKIP=2
 6005 IF(NSTEP-INROWS)12,1,1
   12 WRITE (6,603)CODE, INROWS, INCOLS, IN
  603 FORMAT(///// 16H PROBLEM CODED  , A6, // 20H ENTERING MATRIX HAS
     1 I7, 9H  ROWS OF , I7, 35H  ELEMENTS EACH.  MATRIX IS READ IN
     2 18H FROM LOGICAL TAPE , I4, 2H . )
      MAXOUT =  MAX /INROWS
C   MAXOUT  IS THE MAXIMUM NUMBERS OF OUTPUT ROWS WHICH CAN BE HELD I-
C   MEMORY, GIVEN THAT EACH ROW WILL CONTAIN  INROWS  ENTRIES.
      IF  (MAXOUT - KBUNCH)  22, 24, 24
   22 WRITE (6,156)MAXOUT, NSTEP
  156 FORMAT(52H EITHER THE INPUT OR OUTPUT FORMAT CONTROLS TOO MANY
     1 41H ROWS.  THE MAXIMUM VALUES ALLOWABLE ARE  , I4,
     2 17H  FOR OUTPUT AND  , I4, 12H  FOR INPUT.  )
      REWIND NOUT
      GO TO 1916
   24 CALL  DIVALG(NSTEP, LUMP, INOK, INOFF, 0)
C   THE NUMBER OF ROWS WHICH WILL BE READ IN AT ONE TIME MUST BE A
C   MULTIPLE  (INOK)  OF THE NUMBER OF ROWS CONTROLLED BY THE INPUT
C   FORMAT.
      IF  (INOK)  22, 22, 26
C   IF  INOK = 0, THE MACHINE CANNOT BEAR IN MIND THE NUMBER OF ROWS
C   REQUIRED BY THE INPUT FORMAT.
   26 NSTEP = NSTEP - INOFF
C   NSTEP IS ADJUSTED TO BE A MULTPILE OF LUMP.
      CALL  DIVALG(INCOLS, KBUNCH, KTIMES, KLEFT, 1)
C   KTIMES IS THE NUMBER OF TIMES THE OUTPUT FORMAT WILL BE USED.  KLEFT
C   (NON-ZERO)  IS THE NUMBER OF OUTPUT ROWS LEFT OVER AFTER THESE USES.
      INOK = INOK*LUMP
      IF  (IN - 5)  13, 15, 13
   13 GO TO (214,213),KSKIP
  213 TYPE 14,IN, IN
   14 FORMAT(///// 32H THIS PROGRAM READS LOGICAL TAPE ,  I4,
     1 15H.  LOGICAL TAPE ,  I4,  18H  SHOULD BE SAVED.  )
      GO TO 216
  214 TYPE 215,IN
  215 FORMAT(///// 32H THIS PROGRAM READS LOGICAL TAPE , I4,
     150H. OUTPUT IS PUNCHED. OTHER TAPES MAY BE SCRATCHED. )
  216 REWIND IN
   15 NFTIN = 18*NFTIN+1
      NFTOUT = 18*NFTOUT+1
      CALL  DIVALG(INROWS, NSTEP, NECESS, NEXTRA, 1)
C   NECESS  IS THE NUMBER OF TAPE WRITES REQUIRED USING  NSTEP  ROWS AT
C   A TIME.  NEXTRA  IS THE NUMBER OF ROWS LEFT AFTER THESE TAPE WRITES.
      NTOTAL = NECESS + 1
      NIXTRA = INCOLS*NEXTRA
      NSTOP = INCOLS*NSTEP
      NOUT = NTAPE(1)
      DO  28  I = 1, ITAPES
   28 JON(I) = NSTEP
      READ (5,151)(FNT(I),I=1,19)
      IF(NFTIN.GT.19)READ(5,152) (FNT(I),I=20,NFTIN)
      CODE1=PARAN
      B123=FORM
      IF(FNT(1).EQ.CODE1)GO TO 610
      CODE1=FNT(1)
      CODE=FNT(2)
      GO TO 602
  610 WRITE (6,611)INOK, (FNT(I), I = 1, NFTIN)
611   FORMAT(18H MATRIX IS READ IN,I7,27H ROWS AT A TIME, ACCORDING ,30H
     1 TO THE FOLLOWING INPUT FORMAT,3X/3X,A1,A3,17A4/(3X,18A4))
      READ (5,151)(FMT(I),I=1,19)
      IF(NFTOUT.GT.19)READ(5,152) (FMT(I),I=20,NFTOUT)
      IF(FMT(1).EQ.CODE1)GO TO 612
      CODE1=FMT(1)
      CODE=FMT(2)
      GO TO 602
  151  FORMAT(A1,A3,17A4)
  152 FORMAT(18A4)
  612 IF  (ITAPES - 3)  3, 3, 4
    4 IF  (NTOTAL - ITAPES)  5, 6, 8
C   THERE ARE AT LEAST THREE TAPES AVAILABLE - HOW MANY WILL BE REQUIRED
C   TO FINISH TRANSPOSITION.
    8 LPLUS = ITAPES - 1
C   THERE ARE AT LEAST  FOUR  TAPES, BUT THERE ARE MORE TAPE WRITES
C   REQUIRED THAN THERE ARE TAPES.
      TYPE 78,(NTAPE(I), I = 1,ITAPES)
   78 FORMAT (39H1THIS PROGRAM WRITES ON LOGICAL TAPES  , 29(I2,2H, ))
      GO TO(221,220),KSKIP
  221 TYPE 222
  222 FORMAT (43H PUNCH OUTPUT ONLY. TAPES MAY BE SCRATCHED. )
      GO TO 223
  220 TYPE 77,NOUT
   77 FORMAT(15H LOGICAL TAPE  , I2, 29H  IS TO BE SAVED.  ALL OTHERS
     1 18H CAN BE SCRATCHED.  )
   75 FORMAT (15H LOGICAL TAPES   29(I2,2H, ))
  223 WRITE (6,604)ITAPES
  604 FORMAT(// 11H A TOTAL OF , I3, 27H  TAPES WILL BE USED IN THE
     1 60H TRANSPOSITION (NOT COUNTING THE DATA INPUT TAPE).  THEY ARE )
      WRITE (6,75)(NTAPE(I), I=1,ITAPES)
      GO TO(702,701),KSKIP
  702 WRITE (6,704)INCOLS,INROWS,KBUNCH,(FMT(I),I=1,NFTOUT)
 704  FORMAT(//26H THE TRANSPOSED MATRIX HAS,I7,9H ROWS OF ,I7,42H ELEME
     1NTS EACH. THE MATRIX IS PUNCHED OUT ,I7,
     217H ROWS AT A TIME, /
     3 42H ACCORDING TO THE FOLLOWING OUTPUT FORMAT /3X,A1,A3,17A4/(3X,
     418A4))
      GO TO 703
  701 WRITE (6,613)INCOLS, INROWS, NOUT, KBUNCH, (FMT(I), I = 1, NFTOUT)
  613 FORMAT(// 26H THE TRANSPOSED MATRIX HAS , I7, 9H  ROWS OF , I7,
     1 59H  ELEMENTS EACH.  THE MATRIX IS WRITTEN OUT ON LOGICAL TAPE ,
     2 I4, 2H . / 22H MATRIX IS WRITTEN OUT , I7, 17H  ROWS AT A TIME,,
     3 42H ACCORDING TO THE FOLLOWING OUTPUT FORMAT /3X,A1,A3,17A4/(3X,
     418A4))
  703 LTAPES = ITAPES - 2
C   NUMBER OF TAPES AVAILABLE FOR ACTUAL WRITING.
      LOVE = LTAPES
      CALL  DIVALG(NECESS, LTAPES, NTIMES, LONE, 1)
C   NTIMES  IS THE NUMBER OF COMPLETE PASSES REQUIRED, USING  LTAPES
C   TAPES  ON EACH PASS.  LONE  IS THE (NON-ZERO) NUMBER OF TAPE WRITES
C   REMAINING AFTER ALL THESE PASSES.  SINCE  NTOTAL  IS BIGGER THAN
C   ITAPES, NECESS = NTOTAL - 1  IS  BIGGER THAN  LTAPES = ITAPES - 2,
C   SO WE KNOW THAT  NTIMES  IS NON-ZERO EVEN THOUGH  LONE  IS FORCED TO
C   BE POSITIVE. SUCH FORCING IS POSSIBLE BECAUSE  ITAPES  IS AT LEAST
C   FOUR, WHENCE  LTAPES  IS DIFFERENT FROM  ONE.
      IF  (LTAPES - LONE)  80, 80, 82
C   CHECKING TO MAKE SURE THAT LEFT-OVER PASS DOES NOT REQUIRE ALL
C   LTAPES  TAPES.
   80 LONE = LONE - 1
C   SINCE ALL TAPES ARE REQUIRED ON LAST PASS, ONE EXTRA TAPE WRITE IS
C   TO BE FORCED ON FIRST PASS, SO THAT NUMBER REQUIRED ON LAST PASS
C   WILL NOT BE TOO LARGE.  THIS IS PERMISSABLE BECAUSE IN THIS CASE,
C   LONE = LTAPES, WHICH IS BIGGER THAN  ONE.
      LOVE = LPLUS
   82 KEEP = NTAPE(ITAPES)
      LAST = NTAPE(LPLUS)
      DO  84  I = 1, LOVE
   84 CALL  TRNWRT(NTAPE(I), NSTOP)
      CALL  STACK(KEEP, LOVE, NTAPE, NON)
C   ALL THESE TAPES ARE STACKED ONTO  KEEP ( = NTAPE(ITAPES) ) .
      DO  880  I = 1, LTAPES
  880 JTAPE(I+1) = NTAPE(I)
C   THIS SETS THE VECTOR  JTAPE  FOR FURTHER STACKS.  THE FIRST TAPE OF
C   THIS VECTOR WILL HENCEFORTH BE THE PREVIOUS STACK TAPE.
      IF  (NTIMES - 1)  86, 86, 88
C   CHECKING TO FIND IF THE FOREGOING PASS WAS THE ONLY COMPLETE PASS
C   NEEDED.
   88 DO  90  NDO = 2, NTIMES
C   FINISHING OFF REMAINDER OF REQUIRED COMPLETE PASSES.
      JTAPE(1) = KEEP
C   LAST TIMES STACK TAPE IS MADE THE FIRST TAPE FOR THE NEXT STACK.
      JON(1) = NON
C   NUMBER ON FIRST TAPE (LAST TIMES STACK TAPE) IS SET CORRECTLY.  ALL
C   OTHER NUMBERS ARE AS BEFORE - AS ORIGINALLY SET IN DO LOOP ON  28 .
      KEEP = LAST
      LAST = JTAPE(1)
C   THIS JUGGLING INSURES THAT STACK TAPE WILL ALWAYS BE ONE OF LAST TWO
      DO  92  I = 1, LTAPES
   92 CALL  TRNWRT(NTAPE(I), NSTOP)
   90 CALL  STACK(KEEP, LPLUS, JTAPE, NON)
   86 DO  94  I = 1, LONE
C   ALL FULL PASSES HAVE BEEN COMPLETED.  THIS LOOP WILL HANDLE
C   REMAINING FULL TAPES.  AS ALREADY COMMENTED UPON, THIS NUMBER IS
C   DIFFERENT FROM ZERO.
   94 CALL  TRNWRT(NTAPE(I), NSTOP)
      LONE = LONE + 2
C   THE ONLY TAPES NOW IN USE ARE LAST TIMES  KEEP  TAPE, AND TAPES  1
C   THROUGH  LONE.  THESE DO NOT CONFLICT BECAUSE  LONE  WAS FORCED TO
C   BE STRICTLY LESS THAN  LTAPES, AND  KEEP  IS STRICTLY GREATER THAN
C   LTAPES.  THUS THE TAPE  LONE - 1  (OLD  LONE + 1 )  IS ALSO.
      CALL  TRNWRT(NTAPE(LONE-1), NIXTRA)
C   VERY LAST TAPE TO BE TRANSPOSED IS NOT NECESSARILY FULL.
      JTAPE(1) = KEEP
      JON(1) = NON
C   FIRST TAPE OF THIS STACK IS LAST TIMES STACK TAPE.
      JTAPE(LONE) = NTAPE(LONE-1)
      JON(LONE) = NEXTRA
C   LAST TAPE OF THIS STACK DOES NOT CONTAIN FULL NUMBER (NSTOP) .
      KEEP = LAST
      CALL  STACK(KEEP, LONE, JTAPE, NON)
      GO TO  144
    1 WRITE (6,603)CODE, INROWS, INCOLS, IN
      IF  (IN - 5)  93, 95, 93
   93 TYPE  14,IN, IN
      REWIND  IN
C   MEMORY CAN CONTAIN THE ENTIRE MATRIX, SO NO TAPE JUGGLING WILL BE
C   NECESSARY.
   95 NSTOP = INROWS*INCOLS
      GO TO( 96, 97),KSKIP
   96 TYPE 222
      GO TO   98
   97 TYPE  77,NOUT
98    READ(5,151)(FNT(I),I=1,19)
      IF(NFTIN.GT.1)GO TO 986
      NFTIN=19
  982 READ (5,151)(FMT(I),I=1,19)
      IF(NFTOUT.EQ.1)GO TO 987
      NFTOUT=NFTOUT*18+1
      READ (5,152)(FMT(I),I=20,NFTOUT)
      GO TO 988
  986 NFTIN=NFTIN*18+1
      READ(5,152)(FNT(I),I=20,NFTIN)
      GO TO 982
  987 NFTOUT=19
  988 WRITE (6,611)LUMP,(FNT(I),I=1,NFTIN)
      GO TO(101,102),KSKIP
  101 WRITE (6,704)INCOLS,INROWS,KBUNCH,(FMT(I),I=1,NFTOUT)
      GO TO  103
  102 WRITE (6,613)INCOLS,INROWS,NOUT,KBUNCH,(FMT(I),I=1,NFTOUT)
  103 WRITE (6,615)
615   FORMAT(// 49H NO EXTRA TAPES ARE NEEDED (EXCEPT DATA INPUT AND,57H
     1 OUTPUT TAPES) BECAUSE MATRIX IS SUFFICIENTLY SMALL TO BE/ 30H ENT
     2IRELY CONTAINED IN MEMORY.)
      REWIND  NOUT
      NREAD=INCOLS*LUMP
      NTIMES=NSTOP/NREAD
      L1=0
        DO 444 I=1,NTIMES
      L0=L1+1
      L1=L1+NREAD
  444 READ (IN,FNT)(X(L),L=L0,L1)
      NRITE=INROWS*KBUNCH
      NTIMES=NSTOP/NRITE
      L1=0
      DO 500   I=1,NTIMES
      L0=L1+1
      L1=L1+KBUNCH
      GO TO( 99,555),KSKIP
   99 PUNCH FMT,((X(L), L=LL, NSTOP, INCOLS), LL = L0, L1)
      GO TO 500
  555 WRITE (NOUT,FMT)((X(L),L=LL,NSTOP,INCOLS),LL=L0,L1)
  500 CONTINUE
C   MATRIX IS TRANSPOSED AS IT IS WRITTEN OUT.
      GO TO(1000,501),KSKIP
  501 ENDFILE NOUT
      GO TO 1000
    3  IF  (NTOTAL - 2)  5, 5, 30
C   THERE ARE ONLY THREE TAPES AVAILABLE.  CHECKING HERE TO SEE WHETHER
C   MORE THAN  TWO  TAPE WRITES ARE REQUIRED.
   30 LPLUS = 2
      TYPE 78,(NTAPE(I), I=1,3)
      GO TO(104,105),KSKIP
  104 TYPE 222
      GO TO 106
  105 TYPE  77,NOUT
  106 WRITE (6,604)ITAPES
      WRITE (6,75)(NTAPE(I), I=1,ITAPES)
      GO TO(107,108),KSKIP
  107 WRITE (6,704)INCOLS,INROWS,KBUNCH,(FMT(I),I=1,NFTOUT)
      GO TO  109
  108 WRITE (6,613)INCOLS, INROWS, NOUT, KBUNCH, (FMT(I), I = 1, NFTOUT)
  109 KEEP = NTAPE(3)
      CALL  TRNWRT(KEEP, NSTOP)
      JTAPE(2) = NOUT
      NON = NSTEP
      DO  32  I = 2, NECESS
C   ONE FULL TAPE HAS BEEN WRITTEN.  REMAINING  NECESS - 1  ARE TO BE
C   WRITTEN IN THIS LOOP.
      JTAPE(1) = KEEP
      JON(1) = NON
C   FIRST TAPE OF THIS STACK IS LAST TIMES STACK TAPE.
      JJ = 2 + MOD(I,2)
      KEEP = NTAPE(JJ)
C   THIS TIMES STACK TAPE IS EITHER  NTAPE(2)  OR  NTAPE(3) .
      CALL  TRNWRT(NOUT, NSTOP)
C   MATRIX IS ALWAYS TRANSPOSED ONTO  NTAPE(1) = NOUT = JTAPE(2) .
   32 CALL  STACK(KEEP, 2, JTAPE, NON)
      LAST = JTAPE(1)
C   THIS STACK - THE LAST ONE REQUIRED - WILL BE DONE ONTO  LAST .
      JTAPE(1) = KEEP
      JON(1) = NON
C   JTAPE(1)  IS NOW LAST TIMES STACK TAPE.
      CALL  TRNWRT(NOUT, NIXTRA)
C   NOW TRANSPOSING LAST TAPE, WHICH IS NOT FULL.
      JON(2) = NEXTRA
      CALL  STACK(LAST, 2, JTAPE, NON)
C   STACKING THIS PARTIAL TAPE WITH RESULT OF ALL PREVIOUS TRANSPOSITION
      KEEP = LAST
      GO TO  144
    5 ITAPES = NTOTAL + 1
C   THE TOTAL NUMBER OF TAPE WRITES REQUIRED IS LESS THAN THE NUMBER OF
C   TAPES AVAILABLE.
      TYPE 78,(NTAPE(I), I=1,ITAPES)
      GO TO(110,111),KSKIP
  110 TYPE 222
      GO TO 112
  111 TYPE  77,NOUT
  112 WRITE (6,604)ITAPES
      WRITE (6,75)(NTAPE(I), I=1,ITAPES)
      GO TO(113,114),KSKIP
  113 WRITE (6,704)INCOLS,INROWS,KBUNCH,(FMT(I),I=1,NFTOUT)
      GO TO  115
  114 WRITE (6,613)INCOLS, INROWS, NOUT, KBUNCH, (FMT(I), I = 1, NFTOUT)
  115 DO  50  I = 1, NECESS
C   ALL FULL TAPES ARE WRITTEN IN THIS LOOP.
   50 CALL  TRNWRT(NTAPE(I), NSTOP)
      CALL  TRNWRT(NTAPE(NTOTAL), NIXTRA)
      JON(NTOTAL) = NEXTRA
C   LAST TAPE - NTAPE(NTOTAL) - IS NOT FULL.
      KEEP = NTAPE(ITAPES)
      CALL  STACK(KEEP, NTOTAL, NTAPE, NON)
      GO TO  144
    6 TYPE 78,(NTAPE(I), I = 1,ITAPES)
C   PROGRAM REQUIRES EXACTLY  ITAPES  TOTAL TAPES.
      GO TO(116,117),KSKIP
  116 TYPE 222
      GO TO 118
  117 TYPE  77,NOUT
  118 WRITE (6,604)ITAPES
      WRITE (6,75)(NTAPE(I), I=1,ITAPES)
      GO TO(120,121),KSKIP
  120 WRITE (6,704)INCOLS,INROWS,KBUNCH,(FMT(I),I=1,NFTOUT)
      GO TO 122
  121 WRITE (6,613)INCOLS, INROWS, NOUT, KBUNCH, (FMT(I), I = 1, NFTOUT)
  122 DO  60  I = 1, 2
      JTAPE(I) = NTAPE(I+1)
   60 CALL  TRNWRT(JTAPE(I), NSTOP)
      CALL  STACK(NOUT, 2, JTAPE, NON)
C   FIRST TWO TAPES ARE TRANSPOSED AND STACKED ONTO  NOUT = NTAPE(1) .
      DO  62  I = 3, NECESS
C   SINCE  NTOTAL  IS AT LEAST  FOUR, THIS IS A LEGITIMATE DO LOOP.
   62 CALL  TRNWRT(NTAPE(I-1), NSTOP)
C   THE REMAINING FULL TAPES ARE TRANSPOSED ONTO TAPES  2  THROUGH
C   NECESS - 1 , TAPE  1  BEING THE STACK TAPE CONTAINING TWO TAPES.
      CALL  TRNWRT(NTAPE(NECESS), NIXTRA)
      JON(NECESS) = NEXTRA
C   LAST TAPE = NTAPE(NECESS)  IS NOT A FULL TAPE.
      JON(1) = NON
C   FIRST TAPE CONTAINS ENTRIES FROM TWO TAPES.
      KEEP = NTAPE(ITAPES)
      CALL  STACK(KEEP, NECESS, NTAPE, NON)
  144 CALL  OUT(KEEP)
 1914 REWIND NOUT
 1915 GO TO 1000
 1916 STOP
      END
C         SUBROUTINE  BLOKIO(IOP, ITAPNO) - SEE GENE ALBRIGHT
      SUBROUTINE  BLOKIO(IOP, ITAPNO)
      DIMENSION  X(10000), BU(15,255), IPOP(15), IBUFAD(15)
      COMMON  X      , ISTART , ISTOP  , INCR   , OPTION
      IBUFMX=255
      IBA=IBUFAD(ITAPNO)
      GO TO (10,10,1,1,1,1),IOP
C     REWIND/BACKSPACE/END FILE/FLUSH BUFFER SECTION
    1 IF  (IPOP(ITAPNO) - 2)  3, 7, 3
    7 IF  (IBA)  2, 100, 2
2     WRITE(ITAPNO,1000)(BU(ITAPNO,I),I=1,IBUFMX)
1000  FORMAT(20A4)
3     IBA=0
      GO TO (4,4,4,5,6,100),IOP
4     REWIND ITAPNO
      GO TO 100
5     BACKSPACE ITAPNO
      GO TO 100
6     END FILE ITAPNO
      GO TO 100
C     READ/WRITE
10    IF(IPOP(ITAPNO)-IOP) 11,20,11
11    IF(IPOP(ITAPNO)-2) 13,14,13
14    IF(IBA) 12,20,12
12    WRITE(ITAPNO,1000)(BU(ITAPNO,J),J=1,IBUFMX)
13    IBA=0
C     READ/WRITE LOOP
20    DO 50 I=ISTART,ISTOP,INCR
      GO TO (30,40),IOP
C     READ
30    IF(IBA-IBUFMX) 32,31,31
31    IBA=0
      GO TO 33
32    IF(IBA) 34,33,34
33    READ(ITAPNO,1000)(BU(ITAPNO,J),J=1,IBUFMX)
34    IBA=IBA+1
      X(I) = BU(ITAPNO,IBA)
      GO TO 50
C     WRITE
40    IBA=IBA+1
      BU(ITAPNO,IBA) = X(I)
      IF(IBA-IBUFMX) 50,41,41
41    WRITE(ITAPNO,1000)(BU(ITAPNO,J),J=1,IBUFMX)
      IBA=0
C     END READ/WRITE LOOP
50    CONTINUE
C     COMMON RETURN
100   IPOP(ITAPNO)=IOP
      IBUFAD(ITAPNO)=IBA
      RETURN
      END
C           DIVISION ALGORTHM FOR BMD10S              JUNE 22, 1966
      SUBROUTINE  DIVALG(NA, NB, NQ, NR, NCODE)
      NN = NA
      IF(NCODE .LE. 0) GO TO 1
      NN = NN - 1
    1 NQ = NN/NB
      NR = NA - NB*NQ
      RETURN
      END
C         SUBROUTINE  OUT(KEEP) FOR BMD10S            JUNE 22, 1966
      SUBROUTINE  OUT(KEEP)
      DIMENSION  X(10000)
      DIMENSION FNT(181),FMT(181)
      DIMENSION  JTAPE(15), JON(15)
      COMMON  X      , ISTART , ISTOP  , INCR   , FNT    , IN
      COMMON  INCOLS , JON    , NOUT   , KTIMES , KBUNCH , KLEFT
      COMMON  INROWS , FMT    , OPTION
      DATA PCH/3HPCH/
      CALL  BLOKIO(3, KEEP)
      INCR = 1
      CALL  BLOKIO(3, NOUT)
      DO 11  I=1,KTIMES
      ISTOP = 0
      DO  3  L = 1, KBUNCH
      ISTART = ISTOP + 1
C   THE MATRIX IS ON TAPE  KEEP  IN ONE ROW LUMPS.  THE OUTPUT FORMAT
C   REQUIRES THAT OUTPUT BE IN  KBUNCH-ROW LUMPS.  THEREFORE, INDICES
C   MUST BE PREPARED TO ALLOW READ-IN OF THE CORRECT NUMBER OF ENTRIES.
      ISTOP = ISTOP + INROWS
    3 CALL  BLOKIO(1, KEEP)
      IF(OPTION.NE.PCH)GO TO 2
    5 PUNCH FMT,(X(J), J=1,ISTOP)
      GO TO 11
    2 WRITE (NOUT,FMT)(X(J), J = 1, ISTOP)
   11 CONTINUE
    6 ISTOP = 0
      DO  4  L = 1, KLEFT
      ISTART = ISTOP + 1
      ISTOP = ISTOP + INROWS
    4 CALL  BLOKIO(1, KEEP)
      IF(OPTION.NE.PCH)GO TO 8
    7 PUNCH FMT,(X(J), J=1,ISTOP)
      GO TO 9
    8 WRITE (NOUT,FMT)(X(J), J = 1, ISTOP)
    9 CALL  BLOKIO(5, NOUT)
      CALL  BLOKIO(3, KEEP)
      CALL  BLOKIO(3, NOUT)
      RETURN
      END
C          SUBROUTINE  STACK FOR BMD10S               JUNE 22, 1966
      SUBROUTINE  STACK(NSTACK, NUMTAP, JTAPE, NON)
      DIMENSION  X(10000)
      DIMENSION JTAPE(15),JON(15),JNDX(15),INDX(15),FNT(181)
      COMMON  X      , ISTART , ISTOP  , INCR   , FNT    , IN
      COMMON  INCOLS , JON
      INCR = 1
      NON = 0
      DO  1  L = 1, NUMTAP
      CALL  BLOKIO(3, JTAPE(L))
      INDX(L) = NON + 1
C   FIRST ON THIS TAPE = LAST ON PREVIOUS TAPE + 1 .
      NON = NON + JON(L)
C    LAST ON THIS TAPE = LAST ON PREVIOUS TAPE + NUMBER ON THIS TAPE.
    1 JNDX(L) = NON
      CALL  BLOKIO(3, NSTACK)
      DO  2  I = 1, INCOLS
      DO  3  L = 1, NUMTAP
      ISTART = INDX(L)
      ISTOP = JNDX(L)
C   READ EACH TAPE (ONE LINE AT A TIME, OF COURSE), INTO MEMORY.
    3 CALL  BLOKIO(1, JTAPE(L))
C   AFTER ALL ARE READ, WRITE ENTIRE LINE ONTO STACK TAPE.
      ISTART = 1
    2 CALL  BLOKIO(2, NSTACK)
      DO  4  L = 1, NUMTAP
    4 CALL  BLOKIO(3, JTAPE(L))
      CALL  BLOKIO(5, NSTACK)
      CALL  BLOKIO(3, NSTACK)
      RETURN
      END
C           SUBROUTINE  TRNWRT FOR BMD10S             JUNE 22, 1966
      SUBROUTINE  TRNWRT(LL, NALL)
      DIMENSION  X(10000)
      DIMENSION FNT(181),FMT(181)
      COMMON  X      , ISTART , ISTOP  , INCR   , FNT    , IN
      COMMON  INCOLS
      READ (IN,FNT)(X(I), I = 1, NALL)
      INCR = INCOLS
      ISTOP = NALL
      CALL  BLOKIO(3, LL)
      DO  10  I = 1, INCR
      ISTART = I
   10 CALL  BLOKIO(2, LL)
C   THIS WRITE STATEMENT TRANSPOSES THE MATRIX.  THE RESULT APPEARS
C   AS  INCOLS  SHORT RECORDS - THAT IS, AS A MATRIX WITH  INCOLS  ROWS,
C   AND  NALL/INCOLS  COLUMNS.
      CALL  BLOKIO(5, LL)
      CALL  BLOKIO(3, LL)
      RETURN
      END