Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
CID BMD06R
C ASYMPTOTIC REGRESSION - MAIN PROGRAM MAY 9, 1966
C THIS IS A SIFTED VERSION OF BMD06R ORIGINALLY WRITTEN IN
C FORTRAN II. SOME MODIFICATIONS WERE MADE TO MAKE IT OPERABLE
C AND SLIGHTLY MORE EFFICIENT THAN THE SIFTED VERSION.
C IT WAS THEN CONVERTED TO 360 FORTRAN IV (H-LEVEL)
C
COMMON X1
COMMON NXY , TXY , NY , D123 , TRANS , LTRANX
COMMON CONST , CONSX , KVT , SWITCH , Y1 , N1
COMMON NS , N2 , NTL , CONT , IPASS , IX
COMMON IY , YV , R0 , C , C1 , TY0
COMMON TY1 , TY2 , R , Y012 , RS , AS
COMMON BS , SUMSQS , AVE , X2 , Y2 , Y3
COMMON I5 , I6
DIMENSION X1(400),X2(400),CF(9), Y2(1700), NTL(
110),CONT(10),Y3(1700),C(3,3),C1(3,3),Y012(3),RS(51),U(400),AS(50)
2,BS(50),SUMSQS(51),AVE(400),PRE(400)
3,N1(400),N2(400)
EQUIVALENCE(X1,PRE,U)
DOUBLE PRECISION A123,B123,TODE,PROB
LOGICAL WRIT
WRIT=.TRUE.
502 FORMAT('1BMD06R - ASYMPTOTIC REGRESSION - REVISED ',
1'OCTOBER 29, 1968'/
2 40H HEALTH SCIENCES COMPUTING FACILITY,UCLA//)
C
I5=5
CALL USAGEB('BMD06R')
I6=6
DATA A123,B123/'FINISH','PROBLM'/
DATA GOOG/3HYES/
D123 = GOOG
100 WRITE(I6,502)
READ(5,501)TODE,PROB,NXY,TXY,RES,SPARE,LTRANX,CONSX,XSORT,GPLOT,
1STEP,XRED,MORE,OUT,RHO1,NTAPE,KVT
C
IF(TODE.EQ.B123)GO TO 303
301 IF(TODE.EQ.A123)WRIT=.FALSE.
C
C
C
302 IF(WRIT)WRITE(I6,304)
IF(I5.NE.5)REWIND I5
STOP
303 CALL TPWD(NTAPE,I5)
332 CONTINUE
C
WRITE (I6,701)
WRITE (I6,503)
WRITE (I6,504)PROB
WRITE (I6,530)NXY,TXY
WRITE (I6,532)XRED,XSORT
WRITE (I6,535)RES
WRITE (I6,537)LTRANX,OUT
WRITE (I6,538)CONSX,KVT
IF((NXY-3)*(NXY-400))305,302,302
305 IF(KVT.GT.0.AND.KVT.LE.10)GO TO 3
KVT=1
WRITE(I6,4000)
3 CONTINUE
SUMSQS(1)=0.0
SWITCH=0
LTRANX=LTRANX+1
CALL READ
NCN=NS
C
C CHECK INPUT DATA
DO 70 I=1,NXY
70 N2(I)=0
N2(1)=N1(1)
DO 71 I=2,NXY
71 N2(I)=N2(I-1)+N1(I)
IF(OUT .NE. D123) GO TO 6
C PRINT INPUT DATA
4 WRITE (I6,505)
WRITE (I6,506)
DO 5 I=1,NXY
NE=N2(I)
NS=NE-N1(I)+1
DO 72 L=NS,NE
72 WRITE (I6,507)I,X1(I),Y2(L)
5 CONTINUE
6 DO 7 I=1,NXY
IF(N1(I))8,8,7
7 CONTINUE
GO TO 10
8 WRITE (I6,508)
IF(TRANS .NE. D123) GO TO 100
9 DO 200 I=1,MORE
200 READ (5,509)
GO TO 100
C TRANSFORM X AND SORT X AND Y
10 IF(LTRANX-1) 302,73,74
74 CALL TRANX
GO TO 75
73 DO 76 I=1,NXY
76 X2(I)=X1(I)
75 IF(XSORT .NE. D123) GO TO 15
11 CALL SORTX
GO TO 20
15 NF=0
DO 16 I=1,NXY
NE=N2(I)
NS=NE-N1(I)+1
DO 17 J=NS,NE
NF=NF+1
17 Y3(NF)=Y2(J)
16 CONTINUE
20 IF(XRED .NE. D123) GO TO 600
C SCALE X
601 RNXY=NXY-1
SMAL=X2(1)
RANGE=X2(NXY)-SMAL
DO 602 I=1,NXY
602 X2(I)=((X2(I)-SMAL)/RANGE)*RNXY
600 IF(MORE) 6001,26,27
6001 WRITE(6,6002)
6002 FORMAT('0ILLEGAL''TRANSGENERATION CARD COUNT'' SPECIFIED, MUST BE
1 .GE. 1 AND .LE. 99. PROGRAM TERMINATED.')
GO TO 302
26 MORE=1
C BEGIN REGRESSION LOOP
27 DO 1000 IMM=1,MORE
WRITE (I6,513)IMM
NF=0
C SET UP Y FOR REGRESSION AND TRANSFORMATION
DO 29 I=1,NXY
NE=N2(I)
NS=NE-N1(I)+1
DO 28 L=NS,NE
NF=NF+1
28 Y2(NF)=Y3(L)
29 CONTINUE
21 CALL TRANSY(JQ)
IF(JQ)25,301,251
251 REWIND 1
READ(1,501)TODE,PROB,NXY,TXY,RES,SPARE,LTRANX,CONSX,XSORT,GPLOT,
1STEP,XRED,MORE,OUT,RHO1,NTAPE,KVT
GO TO 303
C GET START VALUE FOR R
25 CALL FINDR
XN = NXY
XB = 0.0
DO 3993 I=1,NXY
3993 XB = XB + X2(I)
XB = XB/XN
I = XB
XB = I
DO 3994 I=1,NXY
3994 X2(I) = X2(I)-XB
IF(RHO1)2511,2511,2510
2510 R0 = RHO1
2511 CONTINUE
WRITE (I6,520)R0
PRINT = 0.0
IF(STEP .EQ. D123) GO TO 4877
4777 CONTINUE
WRITE (I6,522)
PRINT = 1.0
4877 CONTINUE
C INITIALIZE LOOP
ICOUNT=0
NIT = 100
RS(1)=R0
TY0=0.0
DO 445 I=1,NXY
TY0=TY0+AVE(I)*(FLOAT(N1(I)))
445 CONTINUE
Y012(1)=TY0
R=R0
SUMSQ = 0.0
C BEGIN ITERATION FOR ALPHA, BETA AND R.
996 CONTINUE
ICOUNT = ICOUNT + 1
R0 = R
CALL SETUP
CALL INVERT(C1,3)
A=C1(1,1)*TY0+C1(1,2)*TY1+C1(1,3)*TY2
B=C1(1,2)*TY0+C1(2,2)*TY1+C1(2,3)*TY2
R=R0+(C1(1,3)*TY0+C1(2,3)*TY1+C1(3,3)*TY2)/B
R = ABS(R)
40 CONTINUE
SUMSQ=0.0
DO 45 I=1,NXY
YEST=A+B*(R**X2(I))
DIF=AVE(I)-YEST
SUMSQ=SUMSQ+DIF**2
45 CONTINUE
B = B*R**(-XB)
C PRINT ITERATION RESULTS IF DESIRED
IF (PRINT )477,481,477
477 CONTINUE
WRITE (I6,523)ICOUNT,A, B, R, SUMSQ
GO TO 47
481 CONTINUE
WRITE (I6,923)ICOUNT,A, B, R, SUMSQ
WRITE (I6,518)
DO 39 I=1,3
WRITE (I6,516)
K=I-1
WRITE (I6,517)(C(I,J),J=1,3),K,Y012(I)
39 WRITE (I6,516)
WRITE (I6,519)
DO 49 I=1,3
WRITE (I6,516)
K=I-1
WRITE (I6,517)(C1(I,J),J=1,3),K,Y012(I)
49 WRITE (I6,516)
47 IF(ABS(R-R0)-ABS(R)*1.E-5)60,60,308
308 IF (ICOUNT-NIT+1)99,99,309
99 CONTINUE
GO TO 996
C END OF ITERATION FOR ALPHA, BETA, AND R.
C PRINT RESULTS
309 CONTINUE
WRITE (I6,9309)NIT
60 CONTINUE
DO 6111 I=1,NXY
6111 X2(I) = X2(I) +XB
CALL SETUP
CALL INVERT(C1,3)
WRITE (I6,518)
DO 62 I=1,3
WRITE (I6,516)
K=I-1
WRITE (I6,517)(C(I,J),J=1,3),K,Y012(I)
62 WRITE (I6,516)
WRITE (I6,519)
DO 63 I=1,3
WRITE (I6,516)
K=I-1
WRITE (I6,517)(C1(I,J),J=1,3),K,Y012(I)
63 WRITE (I6,516)
WRITE (I6,524)
WRITE (I6,525)
N=0
SE=0.0
DO101 I=1,NXY
NE=N2(I)
NS=NE-N1(I)+1
PRE(I)=A+B*(R**X2(I))
N=N+N1(I)
DO 101 J=NS,NE
SE=SE+(Y2(J)-PRE(I))**2
101 CONTINUE
FN=N-3
AS(1)= A
BS(1)= B
RS(1)= R
SE=SE/FN
SA=SQRT(C1(1,1)*SE)
SB=SQRT(C1(2,2)*SE)
SR=(SQRT(C1(3,3)*SE))/ABS(B)
WRITE (I6,526)A,SA
WRITE (I6,527)B,SB
WRITE (I6,528)R, SR
CALL ANOVAR
IF(RES .NE. D123) GO TO 641
640 CONTINUE
WRITE (I6,529)
WRITE (I6,630)
DO 64 I=1,NXY
NE=N2(I)
NS=NE-N1(I)+1
DO 65 J=NS,NE
DIFF=Y2(J)-PRE(I)
65 WRITE (I6,631)I,X2(I),Y2(J),PRE(I),DIFF
64 CONTINUE
641 CONTINUE
IF(GPLOT .NE. D123) GO TO 66
67 CALL PLOT (ICOUNT)
66 TRANS=D123
1000 CONTINUE
GO TO 100
C
304 FORMAT(45H0CONTROL CARDS INCORRECTLY ORDERED OR PUNCHED)
501 FORMAT(2A6,I3,A2,A3,A3,I2,F6.0,4A3,I2,A3,F6.0, 14X, 2I2)
503 FORMAT(13H PROBLEM CARD//)
504 FORMAT(13H PROBLEM CODE6X,A6)
505 FORMAT(14H0ORIGINAL DATA//)
506 FORMAT(5H NO.6X,7HX VALUE6X,7HY VALUE//)
507 FORMAT(1H I4,2F13.4)
508 FORMAT(61H0NO Y VALUE FOR SOME X,PROGRAM WILL GO TO NEXT PROBLEM,I
1F ANY)
509 FORMAT(I2)
513 FORMAT(9H0FIT NO. I3)
515 FORMAT(15H0ITERATION NO. I2)
516 FORMAT(2H *62X,1H*)
517 FORMAT(2H *3F20.8,7H * Y(I1,2H)=F20.8)
518 FORMAT(19H0INFORMATION MATRIX//)
519 FORMAT(30H0INVERSE OF INFORMATION MATRIX//)
520 FORMAT(/23H0INITIAL ESTIMATE OF R=F10.4//)
521 FORMAT(/1H 25X,19HPARAMETER ESTIMATES)
522 FORMAT(14H ITERATION NO.8X,1HA14X,1HB14X,1HR9X,20HSUM(E(Y)-MEAN(Y)
1)**2//)
523 FORMAT(1H I9,F19.6,2F15.6,1X,F16.6)
524 FORMAT(/1H04X,5HFINAL6X,8HSTANDARD)
525 FORMAT(1H 4X,9HESTIMATES2X,10HDEVIATIONS//)
526 FORMAT(3H A=F11.4,2X,F10.4//)
527 FORMAT(3H B=F11.4,2X,F10.4//)
528 FORMAT(3H R=F11.4,2X,F10.4)
529 FORMAT(20H1 TABLE OF RESIDUALS//)
530 FORMAT(16H NO. OF X VALUES3X,I6,8X,14H INPUT PATTERN9X,A6)
532 FORMAT(12H X RE-SCALED 10X,A6,8X,5H SORT17X,A6)
535 FORMAT( 16H PRINT RESIDUALS 6X, A3)
537 FORMAT(13H X TRANS CODE6X,I6,8X,12H OUTPUT DATA10X,A3)
538 FORMAT(11H X CONSTANT8X,F11.5,3X,16H VARIABLE FORMAT3X,I6)
630 FORMAT(69H0 NO. X VALUE Y VALUE Y PREDICTED
1 RESIDUAL//)
631 FORMAT(1H I4,4F16.4)
701 FORMAT(20H REGRESSION EQUATION/1H015X,1HX/1H 4X,11HY = A + B.R//)
923 FORMAT(11H0ITERATION=I5, 3X, 2HA=F12.6,3X,2HB=F12.6,3X,2HR=F12.6
1,3X, 23HSUM(E(Y)-MEAN(Y))**2 =F12.6)
4000 FORMAT(1H023X71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPECIF
1IED, ASSUMED TO BE 1.)
9309 FORMAT( 36H0CONVERGENCE CRITERION NOT MET AFTER I5, 11H ITERATION
1S )
END
SUBROUTINE ANOVAR
C SUBROUTINE ANOVAR FOR BMD06R MAY 9, 1966
COMMON X1
COMMON NXY , TXY , NY , D123 , TRANS , LTRANX
COMMON CONST , CONSX , KVT , SWITCH , Y1 , N1
COMMON NS , N2 , NTL , CONT , IPASS , IX
COMMON IY , YV , R0 , C , C1 , TY0
COMMON TY1 , TY2 , R , Y012 , RS , AS
COMMON BS , SUMSQS , AVE , X2 , Y2 , Y3
COMMON I5 , I6
DIMENSION X1(400),X2(400), Y2(1700), NTL(
110),CONT(10),Y3(1700),C(3,3),C1(3,3),Y012(3),RS(51),U(400),AS(50)
2,BS(50),SUMSQS(51),AVE(400),PRE(400)
3,N1(400),N2(400)
EQUIVALENCE(X1,PRE,U)
C
ADD=0.0
TOT=0.0
TMEAN=0.0
YHAT=0.0
C N2(NXY) CONTAINS THE TOTAL NUMBER OF DEPENDENT VARIABLE VALUES AND
C TY0 CONTAINS THE SUM OF ALL DEPENDENT VARIABLE VALUES.
C SUM, THEREFORE, CONTAINS THE GRAND MEAN.
DIV=N2(NXY)
SUM=TY0/DIV
DO 10 I=1,NXY
NE=N2(I)
NS=NE-N1(I)+1
YHAT=YHAT+((AVE(I)-PRE(I))**2)*FLOAT(N1(I))
DO 7 J=NS,NE
ADD=ADD+(Y2(J)-SUM)**2
TOT=TOT+(Y2(J)-AVE(I))**2
7 TMEAN=TMEAN+(Y2(J)-PRE(I))**2
10 CONTINUE
WRITE (I6,100)
WRITE (I6,101)
WRITE (I6,106)
WRITE (I6,102)ADD
WRITE (I6,103)TOT
WRITE (I6,104)TMEAN
WRITE (I6,105)YHAT
WRITE (I6,106)
100 FORMAT(1H020X,20HANALYSIS OF VARIANCE//)
101 FORMAT(11H DEVIATIONS20X,14HSUM OF SQUARES)
102 FORMAT(11H FROM MEAN 20X,F13.4)
103 FORMAT(16H FROM X(I) MEANS15X,F13.4//)
104 FORMAT(11H FROM CURVE20X,F13.4)
105 FORMAT(25H OF X(I) MEANS FROM CURVE6X,F13.4)
106 FORMAT(1H 44(1H*))
RETURN
END
SUBROUTINE FINDR
C SUBROUTINE FINDR FOR BMD06R MAY 9, 1966
COMMON X1
COMMON NXY , TXY , NY , D123 , TRANS , LTRANX
COMMON CONST , CONSX , KVT , SWITCH , Y1 , N1
COMMON NS , N2 , NTL , CONT , IPASS , IX
COMMON IY , YV , R0 , C , C1 , TY0
COMMON TY1 , TY2 , R , Y012 , RS , AS
COMMON BS , SUMSQS , AVE , X2 , Y2 , Y3
COMMON I5 , I6
DIMENSION X1(400),X2(400), Y2(1700), NTL(
110),CONT(10),Y3(1700),C(3,3),C1(3,3),Y012(3),RS(51),U(400),AS(50)
2,BS(50),SUMSQS(51),AVE(400),PRE(400)
3,N1(400),N2(400)
DIMENSIONCF(9)
EQUIVALENCE(X1,PRE,U)
C
DO 1 I=1,NXY
SUM=0.0
NE=N2(I)
NS=NE-N1(I)+1
DO 2 J=NS,NE
2 SUM = SUM + Y2(J)
AVE(I) = SUM/FLOAT(N1(I))
1 CONTINUE
CALL REGRES( X2, AVE,NXY, CF)
IF(ABS(CF(2))-.01)50,50,55
50 R0 = .9999
GO TO 100
55 CONTINUE
IF(CF(5))60,65,60
65 CONTINUE
GO TO 50
60 CONTINUE
R0 = (CF(4)*(X2(2)-X2(NXY))+CF(5)*(X2(2)**2 -X2(NXY)**2))/
1(CF(4)*(X2(1)-X2(NXY-1))+CF(5)*(X2(1)**2-X2(NXY-1)**2))
IF(R0)50, 50,100
100 RETURN
END
SUBROUTINE INVERT(A,N)
C SUBROUTINE INVERT FOR BMD06R MAY 9, 1966
COMMON X1
COMMON NXY , TXY , NY , D123 , TRANS , LTRANX
COMMON CONST , CONSX , KVT , SWITCH , Y1 , N1
COMMON NS , N2 , NTL , CONT , IPASS , IX
COMMON IY , YV , R0 , C , C1 , TY0
COMMON TY1 , TY2 , R , Y012 , RS , AS
COMMON BS , SUMSQS , AVE , X2 , Y2 , Y3
COMMON I5 , I6
DIMENSION X1(400),X2(400), Y2(1700), NTL(
110),CONT(10),Y3(1700),C(3,3),C1(3,3),Y012(3),RS(51),U(400),AS(50)
2,BS(50),SUMSQS(51),AVE(400),PRE(400)
3,N1(400),N2(400)
DIMENSION L(3),M(3),A(3,3)
EQUIVALENCE(X1,PRE,U)
C
D=1.0
DO80 K=1,N
L(K)=K
M(K)=K
BIGA=A(K,K)
DO20 I=K,N
DO20 J=K,N
IF(ABS(BIGA)-ABS(A(I,J))) 10,20,20
10 BIGA=A(I,J)
L(K)=I
M(K)=J
20 CONTINUE
C INTERCHANGE ROWS
J=L(K)
IF(L(K)-K) 35,35,25
25 DO30 I=1,N
HOLD=-A(K,I)
A(K,I)=A(J,I)
30 A(J,I)=HOLD
C INTERCHANGE COLUMNS
35 I=M(K)
IF(M(K)-K) 45,45,37
37 DO40 J=1,N
HOLD=-A(J,K)
A(J,K)=A(J,I)
40 A(J,I)=HOLD
C DIVIDE COLUMN BY MINUS PIVOT
45 DO55 I=1,N
46 IF(I-K)50,55,50
50 A(I,K)=A(I,K)/(-A(K,K))
55 CONTINUE
C REDUCE MATRIX
DO65 I=1,N
DO65 J=1,N
56 IF(I-K) 57,65,57
57 IF(J-K) 60,65,60
60 A(I,J)=A(I,K)*A(K,J)+A(I,J)
65 CONTINUE
C DIVIDE ROW BY PIVOT
DO75 J=1,N
68 IF(J-K)70,75,70
70 A(K,J)=A(K,J)/A(K,K)
75 CONTINUE
C CONTINUED PRODUCT OF PIVOTS
D=D*A(K,K)
C REPLACE PIVOT BY RECIPROCAL
A(K,K)=1.0/A(K,K)
80 CONTINUE
C FINAL ROW AND COLUMN INTERCHANGE
K=N
100 K=(K-1)
IF(K) 150,150,103
103 I=L(K)
IF(I-K) 120,120,105
105 DO110 J=1,N
HOLD=A(J,K)
A(J,K)=-A(J,I)
110 A(J,I)=HOLD
120 J=M(K)
IF(J-K) 100,100,125
125 DO130 I=1,N
HOLD=A(K,I)
A(K,I)=-A(J,I)
130 A(J,I)=HOLD
GO TO 100
150 CONTINUE
IF(D) 160,999,160
999 WRITE (6,995)
995 FORMAT(49H ERROR IN ATTEMPTING TO INVERT A SINGULAR MATRIX. )
160 RETURN
END
SUBROUTINE PLOT (ICOUNT)
C SUBROUTINE PLOT FOR BMD06R MAY 9, 1966
COMMON X1
COMMON NXY , TXY , NY , D123 , TRANS , LTRANX
COMMON CONST , CONSX , KVT , SWITCH , Y1 , N1
COMMON NS , N2 , NTL , CONT , IPASS , IX
COMMON IY , YV , R0 , C , C1 , TY0
COMMON TY1 , TY2 , R , Y012 , RS , AS
COMMON BS , SUMSQS , AVE , X2 , Y2 , Y3
COMMON I5 , I6
DIMENSION X1(400),X2(400), Y2(1700), NTL(
110),CONT(10),Y3(1700),C(3,3),C1(3,3),Y012(3),RS(51),U(400),AS(50)
2,BS(50),SUMSQS(51),AVE(400),PRE(400)
3,N1(400),N2(400)
DIMENSION FMT(120)
DIMENSION SYM(15),YYY(15)
EQUIVALENCE(X1,PRE,U)
C
A=AS(ICOUNT)
B=BS(ICOUNT)
R=RS(ICOUNT+1)
SS=10.0**10
FF=-10.0**10
XS=SS
XL=FF
DO 300 I=1,NXY
XS=AMIN1(XS,X2(I))
XL=AMAX1(XL,X2(I))
SS=AMIN1(SS,AVE(I),PRE(I))
300 FF=AMAX1(FF,AVE(I),PRE(I))
WRITE (I6,100)
WRITE (I6,201)
C DIMENSION SYM(15),YYY(15)
DATA SYM(1),SYM(2)/'A','P'/
302 XX=X2(1)
YYY(2)=PRE(1)
YYY(1)=AVE(1)
NC=2
CALL PLOTR(XX,XS,XL,YYY,SYM,SS,FF,NC,+1)
DO 50 I=2,NXY
XX=X2(I)
YYY(2)=PRE(I)
YYY(1)=AVE(I)
35 CALL PLOTR(XX,XS,XL,YYY,SYM,SS,FF,NC,+1)
50 CONTINUE
NC = 0
CALL PLOTR(XX,XS,XL,YYY,SYM,SS,FF,NC,+1)
100 FORMAT(12H1GRAPH CODES,9X,13H A=AVERAGED Y,5X,14H P=PREDICTED Y,
15X,7H B=BOTH)
201 FORMAT(48H0X AND Y VALUES ARE PLOTTED IN TRANSFORMED UNITS)
403 RETURN
END
SUBROUTINE READ
C SUBROUTINE READ FOR BMD06R MAY 9, 1966
COMMON X1
COMMON NXY , TXY , NY , D123 , TRANS , LTRANX
COMMON CONST , CONSX , KVT , SWITCH , Y1 , N1
COMMON NS , N2 , NTL , CONT , IPASS , IX
COMMON IY , YV , R0 , C , C1 , TY0
COMMON TY1 , TY2 , R , Y012 , RS , AS
COMMON BS , SUMSQS , AVE , X2 , Y2 , Y3
COMMON I5 , I6
DIMENSION X1(400),X2(400),FMT(180),Y2(1700),Z(400), NTL(
110),CONT(10),Y3(1700),C(3,3),C1(3,3),Y012(3),RS(51),U(400),AS(50)
2,BS(50),SUMSQS(51),AVE(400),PRE(400)
3,N1(400),N2(400)
EQUIVALENCE (X1,PRE,U),(IA1,A1),(Z,X2)
DOUBLE PRECISION A1,IA1,ISAM
DATA A1,G123/'SAMSIZ','XY'/
C
NS=0
NCARDS=(NXY+21)/22
L2=0
DO 50 J=1,NCARDS
L1=L2+1
L2=L2+22
IF(NXY-L2)35,36,36
35 L2=NXY
36 READ (5,103)ISAM,(N1(I),I=L1,L2)
IF(ISAM.EQ.IA1)GO TO 50
40 WRITE (6,4000)A1
NXY=-22
50 CONTINUE
IF(NXY)55,55,56
55 STOP
56 NTOT=0
DO 70 I=1,NXY
IF(N1(I))80,80,75
80 N1(I)= 1
75 NTOT=NTOT+N1(I)
70 CONTINUE
IF(NTOT-1700)4,4,300
4 KVT=KVT*18
READ (5,101)(FMT(I),I=1,KVT)
WRITE(6,41) (FMT(I), I=1,KVT)
41 FORMAT(' THE VARIABLE FORMAT IS ',20A4,/(1H0,24X,20A4))
JUMP=1
5 IF(TXY .EQ. G123) GO TO 7
6 JUMP=2
7 DO 25 I=1,NXY
NY=N1(I)
GO TO (9,11), JUMP
9 READ (I5,FMT)D,(Z(J),J=1,NY)
X1(I)=D
DO 19 J=1,NY
16 NS=NS+1
Y2(NS)=Z(J)
19 CONTINUE
GO TO 25
11 READ (I5,FMT)(Z(J),J=1,NY),D
X1(I)=D
DO 24 J=1,NY
26 NS=NS+1
Y2(NS)=Z(J)
24 CONTINUE
25 CONTINUE
101 FORMAT(18A4)
102 FORMAT(12F6.0)
103 FORMAT(A6,22I3)
4000 FORMAT(1H0,A6,33H CARD MISPUNCHED OR OUT OF ORDER.)
4010 FORMAT(84H0TOTAL NUMBER OF VALUES FOR DEPENDENT VARIABLE EXCEEDS 5
1000. PROGRAM CANNOT PROCEED.)
RETURN
300 WRITE (6,4010)
GO TO 55
END
SUBROUTINE REGRES (X, F, N, C)
C SUBROUTINE REGRES FOR BMD06R MAY 9, 1966
DIMENSIONA(9),B(3),C(9),F(1),X(1)
C
DO 1 I=1,9
1 A(I)=0.0
B(1) = 0.0
B(2) = 0.0
B(3) = 0.0
DO 100 I=1,N
X2 = X(I)**2
A(2) = A(2)+X(I)
A(3) = A(3) +X2
A(6) = A(6) + X2*X(I)
A(9) = A(9) + X2**2
B(1) = B(1) + F(I)
B(2) = B(2) +F(I)*X(I)
B(3) = B(3)+ F(I)*X2
100 CONTINUE
A(1) = N
A(4) = A(2)
A(5) = A(3)
A(7) = A(3)
A(8) = A(6)
D = A(1)*A(5)-A(2)**2
C(1) = (A(5)*B(1)-A(2)*B(2))/D
C(2) = (-A(2)*B(1)+A(1)*B(2))/D
CALL INVERT(A,3)
C(3) = A(1)*B(1)+A(2)*B(2) +A(3)*B(3)
C(4) = A(4) *B(1) + A(5)*B(2) + A(6)*B(3)
C(5) = A(7) *B(1) + A(8)*B(2) + A(9)*B(3)
RETURN
C
END
SUBROUTINE SETUP
C SUBROUTINE SETUP FOR BMD06R MAY 9, 1966
COMMON X1
COMMON NXY , TXY , NY , D123 , TRANS , LTRANX
COMMON CONST , CONSX , KVT , SWITCH , Y1 , N1
COMMON NS , N2 , NTL , CONT , IPASS , IX
COMMON IY , YV , R0 , C , C1 , TY0
COMMON TY1 , TY2 , R , Y012 , RS , AS
COMMON BS , SUMSQS , AVE , X2 , Y2 , Y3
COMMON I5 , I6
DIMENSION X1(400),X2(400), Y2(1700), NTL(
110),CONT(10),Y3(1700),C(3,3),C1(3,3),Y012(3),RS(51),U(400),AS(50)
2,BS(50),SUMSQS(51),AVE(400),PRE(400)
3,N1(400),N2(400)
EQUIVALENCE(X1,PRE,U)
C
V=ALOG(R)
DO 10 I=1,3
DO 10 J=1,3
10 C(I,J)=0.0
TY1=0.0
TY2=0.0
DO 20 I=1,NXY
FN=N1(I)
C(1,1)=C(1,1)+FN
U(I)=EXP(X2(I)*V)
U3=X2(I)*U(I)/R
U4=U(I)**2
U5=X2(I)*U4/R
U6=X2(I)*U5/R
C(1,2)=C(1,2)+(U(I)*FN)
C(1,3)=C(1,3)+(U3*FN)
C(2,2)=C(2,2)+(U4*FN)
C(2,3)=C(2,3)+(U5*FN)
C(3,3)=C(3,3)+(U6*FN)
TY1=TY1+U(I)*AVE(I)*FN
15 TY2=TY2+U3*AVE(I)*FN
20 CONTINUE
C(3,1)=C(1,3)
C(3,2)=C(2,3)
C(2,1)=C(1,2)
Y012(2)=TY1
Y012(3)=TY2
DO 30 I=1,3
DO 30 J=1,3
30 C1(I,J)=C(I,J)
RETURN
END
SUBROUTINE SORTX
C SUBROUTINE SORTX FOR BMD06R MAY 9, 1966
COMMON X1
COMMON NXY , TXY , NY , D123 , TRANS , LTRANX
COMMON CONST , CONSX , KVT , SWITCH , Y1 , N1
COMMON NS , N2 , NTL , CONT , IPASS , IX
COMMON IY , YV , R0 , C , C1 , TY0
COMMON TY1 , TY2 , R , Y012 , RS , AS
COMMON BS , SUMSQS , AVE , X2 , Y2 , Y3
COMMON I5 , I6
DIMENSION N3(400),N4(400) ,N1(400),N2(400)
DIMENSION X1(400),X2(400), Y2(1700), NTL(
110),CONT(10),Y3(1700),C(3,3),C1(3,3),Y012(3),RS(51),U(400),AS(50)
2,BS(50),SUMSQS(51),AVE(400),PRE(400)
EQUIVALENCE(X1,PRE,U),(AVE,N3)
C
NF=0
DO 60 I=1,NXY
33 N3(I)=I
60 N4(I)=N1(I)
DO 10 I=1,NXY
DO 5 J=I,NXY
IF(X2(I)-X2(J)) 5,5,4
4 XD=X2(I)
X2(I)=X2(J)
X2(J)=XD
K1=N3(I)
N3(I)=N3(J)
N3(J)=K1
K2=N1(I)
N1(I)=N1(J)
N1(J)=K2
5 CONTINUE
10 CONTINUE
DO 6 I=1,NXY
K1=N3(I)
NE=N2(K1)
NS=NE-N4(K1)+1
DO 3 K=NS,NE
NF=NF+1
3 Y3(NF)=Y2(K)
6 CONTINUE
DO 20 I=1,NXY
20 N2(I)=0
N2(1)=N1(1)
DO 30 I=2,NXY
30 N2(I)=N2(I-1)+N1(I)
RETURN
END
SUBROUTINE TPWD(NT1,NT2)
C SUBROUTINE TPWD FOR BMD06R MAY 9, 1966
C
C
IF(NT1)40,10,12
10 NT1=5
12 IF(NT1-NT2)14,19,14
14 IF(NT2.EQ.5)GO TO 18
17 REWIND NT2
19 IF(NT1-5)18,24,18
18 IF(NT1-6)22,40,22
22 REWIND NT1
24 NT2=NT1
28 RETURN
C
C
C
C
40 WRITE(6,49)
C
C
STOP
49 FORMAT(25H ERROR ON TAPE ASSIGNMENT)
END
SUBROUTINE TRANX
C SUBROUTINE TRANX FOR BMD06R MAY 9, 1966
COMMON X1
COMMON NXY , TXY , NY , D123 , TRANS , LTRANX
COMMON CONST , CONSX , KVT , SWITCH , Y1 , N1
COMMON NS , N2 , NTL , CONT , IPASS , IX
COMMON IY , YV , R0 , C , C1 , TY0
COMMON TY1 , TY2 , R , Y012 , RS , AS
COMMON BS , SUMSQS , AVE , X2 , Y2 , Y3
COMMON I5 , I6
DIMENSION X1(400),X2(400), Y2(1700), NTL(
110),CONT(10),Y3(1700),C(3,3),C1(3,3),Y012(3),RS(51),U(400),AS(50)
2,BS(50),SUMSQS(51),AVE(400),PRE(400)
3,N1(400),N2(400)
EQUIVALENCE(X1,PRE,U)
ASN(XX)=ATAN(XX/SQRT(1.0-XX**2))
C
LTRANX=LTRANX-1
KTRANX=LTRANX
IF(LTRANX*(LTRANX-11))5,150,175
5 DO 100 I=1,NXY
D=X1(I)
GO TO (10,20,30,40,50,60,70,80,90,200,170),LTRANX
10 IF(D)160,11,12
11 X2(I)=0.0
GO TO 100
12 X2(I)=SQRT(D)
GO TO 100
20 IF(D)160,21,22
21 X2(I)=1.0
GO TO 100
22 X2(I)=SQRT(D)+SQRT(D+1.0)
GO TO 100
30 IF(D)160,160,31
31 X2(I) = ALOG10(D)
GO TO 100
40 X2(I)=EXP(D)
GO TO 100
50 IF(D)160,11,51
51 IF(D-1.0)52,53,160
52 A=SQRT(D)
X2(I)=ASN(A)
GO TO 100
53 X2(I)=1.57079633
GO TO 100
60 FN=NXY
A=D/(FN+1.0)
B=A+1.0/(FN+1.0)
IF(A)160,61,62
61 IF(B)160,11,64
62 IF(B)160,65,66
64 X2(I)=ASN(SQRT(B))
GO TO 100
65 X2(I)=ASN(SQRT(A))
GO TO 100
66 X2(I)=ASN(SQRT(A))+ASN(SQRT(B))
GO TO 100
70 IF(D)71,160,71
71 X2(I)=1.0/D
GO TO 100
80 X2(I)=D+CONSX
GO TO 100
90 X2(I)=D*CONSX
GO TO 100
200 IF(D)210,11,210
210 X2(I)=D**CONSX
GO TO 100
170 IF(D)155,155,171
171 X2(I) = ALOG(D)
GO TO 100
150 WRITE (6,4000)
4000 FORMAT(108H0ILLEGAL TRANSGENERATION CODE FOR THE INDEPENDENT VARIA
1BLE. PROGRAM WILL PROCEED LEAVING VARIABLE UNCHANGED.)
X2(I)=D
GO TO 100
155 KTRANX=17
160 WRITE (6,4010)I,KTRANX
X2(I)=D
GO TO 100
4010 FORMAT(4H0THEI4,94HTH. VALUE OF THE INDEPENDENT VARIABLE VIOLATES
1THE RESTRICTION FOR TRANSGENERATION OF THE TYPEI3,1H./52H THE PROG
2RAM CONTINUES LEAVING THIS VALUE UNCHANGED.)
175 IF(LTRANX-17)150,176,150
176 LTRANX=11
GO TO 5
100 CONTINUE
RETURN
END
SUBROUTINE TRANSY(JQ)
C SUBROUTINE TRANSY FOR BMD06R MAY 9, 1966
COMMON X1
COMMON NXY , TXY , NY , D123 , TRANS , LTRANX
COMMON CONST , CONSX , KVT , SWITCH , Y1 , N1
COMMON NS , N2 , NTL , CONT , IPASS , IX
COMMON IY , YV , R0 , C , C1 , TY0
COMMON TY1 , TY2 , R , Y012 , RS , AS
COMMON BS , SUMSQS , AVE , X2 , Y2 , Y3
COMMON I5 , I6
DIMENSION X1(400),X2(400), Y2(1700), NTL(
110),CONT(10),Y3(1700),C(3,3),C1(3,3),Y012(3),RS(51),U(400),AS(50)
2,BS(50),SUMSQS(51),AVE(400),PRE(400)
3,N1(400),N2(400),MT(19)
EQUIVALENCE(X1,PRE,U)
DOUBLE PRECISION TODE,B123,C123
DATA B123,C123/'PROBLM ','SPECTG '/
ASN(XX)=ATAN(XX/SQRT(1.0-XX**2))
JQ=-1
READ(5,1100)TODE,MT
REWIND 1
WRITE(1,1100)TODE,MT
1100 FORMAT(A6,A2,18A4)
IF(TODE.EQ.B123)GO TO 2
IF(TODE.NE.C123)GO TO 1
REWIND 1
READ(1,1101)TODE,NT,(NTL(I),CONT(I),I=1,NT)
300 WRITE (I6,1102)
WRITE (I6,1103)
DO 114 I=1,NT
114 WRITE (I6,1104)NTL(I),CONT(I),I
9 DO 99 I=1,NT
JUMP=NTL(I)+1
FMULY=CONT(I)
IF(JUMP*(JUMP-19))200,203,203
200 IF(11-JUMP)204,201,201
204 IF(JUMP-18)203,202,203
202 JUMP=12
201 DO 98 J=1,NXY
NE=N2(J)
NS=NE-N1(J)+1
GO TO(99,10,20,30,40,50,60,70,80,90,100,110),JUMP
10 DO 11 K=NS,NE
IF(Y2(K))88,13,14
13 Y2(K)=0.0
GO TO 11
14 Y2(K)=SQRT(Y2(K))
11 CONTINUE
GO TO 98
20 DO 21 K=NS,NE
IF(Y2(K))88,22,23
22 Y2(K)=1.0
GO TO 21
23 Y2(K)=SQRT(Y2(K))+SQRT(Y2(K)+1.0)
21 CONTINUE
GO TO 98
30 DO 31 K=NS,NE
IF(Y2(K))88,88,31
31 Y2(K) = ALOG10(Y2(K))
GO TO 98
40 DO 41 K=NS,NE
41 Y2(K)=EXP(Y2(K))
GO TO 98
50 DO 51 K=NS,NE
IF(Y2(K))88,52,53
52 Y2(K)=0.0
GO TO 51
53 IF(Y2(K)-1.0)54,55,88
54 Y2(K)=ASN(SQRT(Y2(K)))
GO TO 51
55 Y2(K)=3.14159265/2.0
51 CONTINUE
GO TO 98
60 DIV=N1(J)
DO 61 K=NS,NE
A=Y2(K)/(DIV+1.0)
B=A+1.0/(DIV+1.0)
IF(A)88,62,63
62 IF(B)88,64,65
64 Y2(K)=0.0
GO TO 61
65 Y2(K)=ASN(SQRT(B))
GO TO 61
63 IF(B)88,66,67
66 Y2(K)=ASN(SQRT(A))
GO TO 61
67 Y2(K)=ASN(SQRT(A))+ASN(SQRT(B))
61 CONTINUE
GO TO 98
70 DO 71 K=NS,NE
IF(Y2(K)) 71,88,71
71 Y2(K)=1.0/Y2(K)
GO TO 98
80 DO 81 K=NS,NE
81 Y2(K)=Y2(K)+FMULY
GO TO 98
90 DO 91 K=NS,NE
91 Y2(K)=Y2(K)*FMULY
GO TO 98
100 DO 101 K=NS,NE
IF(Y2(K))102,103,102
103 Y2(K)=0.0
GO TO 101
102 Y2(K)=Y2(K)**FMULY
101 CONTINUE
GO TO 98
110 DO 111 K=NS,NE
IF(Y2(K))88,88,111
111 Y2(K)=ALOG(Y2(K))
98 CONTINUE
99 CONTINUE
GO TO 1000
203 WRITE (6,4000)NTL(I)
GO TO 99
4000 FORMAT(29H0ILLEGAL TRANSGENERATION CODEI3,93H SPECIFIED FOR THE DE
1PENDENT VARIABLE. THE PROGRAM WILL PROCEED WITHOUT THIS TRANSGENER
2ATION.)
88 N=K-NS+1
WRITE (6,4010)N,J,NTL(I)
GO TO 98
4010 FORMAT(4H0THEI4,56HTH. VALUE OF THE DEPENDENT VARIABLE CORRESPONDI
1NG TO THEI4,37HTH. VALUE OF THE INDEPENDENT VARIABLE/57H VIOLATES
2THE RESTRICTION FOR TRANSGENERATION OF THE TYPEI3,1H.52H THE PROGR
3AM CONTINUES LEAVING THIS VALUE UNCHANGED.)
1101 FORMAT(A6,I1,8(I2,F6.0))
1102 FORMAT(20H0TRANSFORMATION CARD)
1103 FORMAT(27H0 CODE CONSTANT PASS NO.)
1104 FORMAT(1H0I5,F13.4,I5)
2 JQ=JQ+1
1 JQ=JQ+1
1000 RETURN
END
SUBROUTINE PLOTR(X,ZMIN,ZMAX,Y,SYM,WMIN,WMAX,NC,NP)
C
C SUBROUTINE PLOTR (IBM 360) AUGUST 13, 1966
C
C 'PLOTR' IS A UTILITY SUBPROGRAM FOR THE BMD... PROGRAMS WHICH
C PLOTS EITHER SINGLE-LINE OR WHOLE-PAGE GRAPHS AND SETS UP
C APPROPRIATE SCALING. THE CALLING PARAMETERS ARE AS FOLLOWS -
C
C X - THE VALUE OF THE INDEPENDENT VARIABLE
C ZMIN - THE MINIMUM VALUE OF X FOR THIS PLOT
C ZMAX - THE MAXIMUM VALUE OF X FOR THIS PLOT
C Y - THE ARRAY CONTAINING THE VALUES OF UP TO 15 DEPENDENT VAR.'S
C SYM - THE ARRAY CONTAINING THE SYMBOLS TO BE PLOTTED
C WMIN - THE MINIMUM VALUE OF ALL Y'S FOR THIS PLOT
C WMAX - THE MAXIMUM VALUE OF ALL Y'S FOR THIS PLOT
C NC - THE NUMBER OF DEPENDENT VARIABLES
C NC=-1 CLOSES A SINGLE-LINE PLOT
C NC= 0 PRINTS AND CLOSES A WHOLE-PAGE PLOT
C NP - THE CONTROL VARIABLE
C NP=-1 PRINTS A SINGLE LINE
C NP=0 OR NP=1 SETS UP A WHOLE-PAGE PLOT
C
C THE PLOTTING ROUTINE MUST BE CALLED ONCE FOR EACH VALUE OF THE
C INDEPENDENT VARIABLE THAT IS TO BE PLOTTED NO MATTER WHETHER IN
C THE SINGLE-LINE OR WHOLE-PAGE MODE
C
DIMENSION Y(15),CLAB(12),GF(10),FMT(12),XY(51,101),SYM(15)
DATA TC,TP,BLANKS/1H.,1H+,1H /
DATA GF/ 4H 1X,,4H 2X,,4H 3X,,4H 4X,,4H 5X,,4H 6X,,
14H 7X,,4H 8X,,4H 9X,,4H 10X/
DATA FMT/'(17X',' ','5(F1','2.3,','8X)/','7X, ',' ','4(F1','2.3,',
1'8X),','F12.','3) '/
C
100 FORMAT(1H 6X5(F12.3,8X),F12.3/17X,5(F12.3,8X))
101 FORMAT(1H F12.3,1X,103A1,F12.3)
102 FORMAT (1H 13X,103A1)
1000 FORMAT(1H 14X,101A1)
1001 FORMAT(15X,20(5H+....),1H+)
C
DATA NCC/2/
C 'NCC' ON THE INITIAL ENTRY TO PLOTR IS NON-ZERO BECAUSE OF THE DATA
C STATEMENT ABOVE.
C
C 'NCC' IS 0 WHILE A PLOT IS BEING MADE. IT IS 1 OR 2 AT OTHER TIMES
C
IF(NCC) 50,48,50
C
C THE VARIABLE 'KL' CONTROLS THE FUNCTIONING OF THE OPENING AND
C CLOSING SECTIONS OF PLOTR. KL=0 INDICATES OPENING OF THE GRAPH,
C KL=1 INDICATES CLOSING.
C
50 KL=0
CALL SCALE(WMIN,WMAX,100.0,JY,YMIN,YMAX,YIJ)
YR=YMAX-YMIN
230 J=JY
IF(J*(J-10))204,201,201
C
C THE FOLLOWING SECTION OPENS OR CLOSES A PLOT IN FIXED FORMAT
C UNDER CONTROL OF KL
C
201 IF(KL)220,220,231
C
231 WRITE (6,1001)
IF(KL)250,250,220
C
220 CLAB(1)= YMIN
DO 222 I=2,11
222 CLAB(I)=CLAB(I-1)+YIJ
WRITE (6,100)(CLAB(I),I=1,11,2),(CLAB(J),J=2,10,2)
IF(KL)231,231,14
C
C THE FOLLOWING SECTION OPENS OR CLOSES A PLOT IN A VARIABLE
C FORMAT UNDER CONTROL OF KL AND JY FROM 'SCALE'
C
204 IF(J-5)205,221,207
207 J=J-5
205 JYT=5-J
221 CONTINUE
226 FMT(2)=GF(JY)
IF (KL) 225,225,227
C
225 FMT(7)=GF(JY)
TT=JY
TT=TT*YIJ/10.0
CLAB(1)= YMIN+TT
DO 223 I=2,10
223 CLAB(I)=CLAB(I-1) +YIJ
WRITE (6,FMT)(CLAB(I),I=2,10,2),(CLAB(I),I=1,9 ,2)
IF(KL)227,227,14
C
227 IF(JY-5)208,209,208
208 WRITE(6,1000)(TC,I=1,J ),(TP,(TC,I=1,4),K=1,19),TP,(TC,I=1,JYT)
IF (KL) 250,250,225
C
209 WRITE (6,1001)
IF (KL) 250,250,225
C
250 CONTINUE
NCC=0
IC=0
IF(NP)80,11,11
C
C THIS SECTION PREPARES FOR A FULL PAGE PLOT BY FILLING IN XY WITH
C BLANKS AND SETTING UP SCALING FOR THE INDEPENDENT VARIABLE 'X'
C
11 DO 1 I=1,51
DO 1 J=1,101
1 XY(I,J)=BLANKS
CALL SCALE (ZMIN,ZMAX,50.0,JX,XMIN,XMAX,XIJ)
XR=XMAX-XMIN
GO TO 48
C
C
C ENTRY TO PLOTS CAN BE USED ONLY AFTER THE CALLING PARAMETERS
C HAVE BEEN TRANSFERRED BY A CALL ON PLOTR. THE CALL ON PLOTS
C IS IDENTICAL WITH ENTRY TO PLOTR BUT IT ALLOWS THE PROGRAMMER TO
C CALL THE PLOTTING ROUTINE WITHOUT HAVING TO INCLUDE THE PARAMETERS
C
48 IF(NC)52,13,49
49 IF(NP)80,10,10
C THE FOLLOWING SECTION SETS UP A FULL PAGE BUT DOES NO PRINTING.
C THIS SECTION IS REACHED BY SPECIFYING NC POSITIVE AND NP POSITIVE.
C
10 DO 9 N=1,NC
SYMB=SYM(N)
XDIFFR=XMAX-X
IF(XDIFFR)105,106,106
105 XDIFFR=0.0
106 YDIFFR=YMAX-Y(N)
IF(YDIFFR)107,108,108
107 YDIFFR=0.0
108 L=51.0-(50.0*XDIFFR)/XR+.5
K=101.0-(100.0*YDIFFR)/YR+.5
CALL FORM2(SYMB,XY(L,K))
9 CONTINUE
GO TO 15
C
C THE FOLLOWING SECTION CONSTRUCTS AND PLOTS ONE LINE OF A MULTILINE
C GRAPH. LOCATION ALONG THE AXIS OF THE PAPER IS PRINTED AT EVERY
C STEP. THIS SECTION IS ACCESSIBLE BY SPECIFYING NC POSITIVE AND
C NP NEGATIVE.
C
80 DO 86 I=1,101
86 XY(1,I)=BLANKS
L=1
DO 95 N=1,NC
SYMB=SYM(N)
YDIFFR=YMAX-Y(N)
IF(YDIFFR)860,865,865
860 YDIFFR=0.0
865 K=101.0-(100.0*YDIFFR)/YR+.5
95 CALL FORM2(SYMB,XY(L,K))
IF(MOD(IC,5))97,96,97
96 W=TP
GO TO 98
97 W=TC
98 WRITE (6,101)X,W,(XY(1,N),N=1,101),W,X
IC=IC+1
GO TO 15
C
C THIS SECTION PLOTS OUT THE PREVIOUSLY PREPARED WHOLE PAGE GRAPH.
C IT PRINTS LOCATION ALONG THE PAPER'S AXIS EVERY FIFTH STEP. THIS
C SECTION IS ACCESSED BY SPECIFYING NC=0.
C
13 M=6-JX
LL=50+M
T=JX
IF(5-JX)131,131,135
131 T=0.0
135 RLAB=XMAX-(T*XIJ)/5.0
W=TC
K=52
DO 31 L=M,LL
K=K-1
I=MOD(L,5)
IF(I-1)2,3,2
3 W=TP
WRITE (6,101)RLAB,W,(XY(K,N),N=1,101),W,RLAB
RLAB=RLAB-XIJ
W=TC
GO TO 31
2 WRITE (6,102)W,(XY(K,N),N=1,101),W
31 CONTINUE
C
52 KL=1
GO TO 230
C
14 NCC=1
15 RETURN
END
SUBROUTINE SCALE(YMIN,YMAX,YINT,JY,TYMIN,TYMAX,YIJ)
C SUBROUTINE SCALE FOR PLOTR JUNE 21, 1966
C
C SUBROUTINE 'SCALE' CALCULATES THE SCALING FOR 'PLOTR'
C
DIMENSION C(10)
DATA C /1.0,1.5,2.0,3.0,4.0,5.0,7.5,10.0,15.0,20.0/
TEST=1.0/(2.0**17)
50 YR=YMAX-YMIN
TT=YR/YINT
J = ALOG10(TT)+TEST
E=10.0**J
TT=TT/E
I=0
IF(TT-1.0+TEST)205,201,201
205 TT=TT*10.0
E=E/10.0
201 I=I+1
IF(9-I)1,2,2
1 E=E*10.0
I=1
2 IF(TT-C(I))233,202,201
233 YIJ=C(I)*E
GO TO 203
202 Y=YMIN/C(I)
J=Y
T=J
IF(0.0001-ABS(T-Y))204,233,233
204 YIJ=C(I+1)*E
203 X=((YMAX+YMIN)/YIJ-YINT )/2.0+.00001
K=X
IF(K)235,240,240
235 Y=K
IF(X-Y)236,240,236
236 K=K-1
240 TYMIN=K
TYMIN=YIJ*TYMIN
TYMAX=TYMIN+YINT*YIJ
IF (YMAX-TYMAX-TEST)11,11,201
11 YIJJ=C(I)*E
XT=((YMAX+YMIN)/YIJJ-YINT)/2.0+.00001
KT=XT
IF (KT) 1235,1240,1240
1235 YT=KT
IF (XT.NE.YT) KT=KT-1
1240 TYMINT=KT
TYMINT=YIJJ*TYMINT
TYMAXT=TYMINT+YINT*YIJJ
IF (YMAX-TYMAXT.GT.TEST) GO TO 10
TYMIN=TYMINT
TYMAX=TYMAXT
YIJ=YIJJ
K=KT
10 TT=YINT/10.0
JY=TT+.000001
YIJ=YINT*(YIJ/10.0)
J=TYMIN/ YIJ
IF (K)242,241,241
242 J=J-1
241 J=J*JY+JY-K
JY=J
RETURN
END
SUBROUTINE FORM2(SYMB,XY)
C
INTEGER XY,SYMB,BLANK,B
DATA BLANK/' '/,B/'B '/
C
IF(XY.EQ.BLANK)GO TO 50
C
IF(XY.NE.SYMB)XY=B
C
C
GO TO 100
C IF BLANK, PUT IN SYMBOL
50 XY=SYMB
100 RETURN
END
C