Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
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