Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0137/bmd/bmd02m.for
There is 1 other file named bmd02m.for in the archive. Click here to see a list.
C REGRESSION ON PRINCIPLE COMPONENTS JUNE 11,1967
C THIS IS A SYSTEM/360 FORTRAN IV (LEVEL H) VERSION OF BMD02M
C ORIGINALLY WRITTEN IN FORTRAN II. THE PROGRAM HAS BEEN SIFTED
C AND SLIGHTLY MODIFIED TO MAKE IT OPERABLE ON THE 7094.
C IT HAS BEEN FURTHER MODIFIED TO ALLOW ITS EXECUTION ON THE 360.
C
DIMENSION X(200,30),XMEAN(45),COV(200,15),VALU(25),SCALE(45),
1C(200,15),Z(25,25),INDEX(20),YMEAN(20),SQ(20),RES(20),FMT(180)
2,NAMES(45),CCC(25,25),DUMY1(6000),DUMY2(45)
DOUBLE PRECISION TODE,B123, NPROB,A123,NAMES
COMMON X , XMEAN , COV
COMMON VALU , SCALE , C , Z , INDEX , YMEAN
COMMON SQ , RES , NK , NY , NV , N
COMMON NT
EQUIVALENCE (DUMY1,X),(DUMY2,XMEAN),(COV,CCC)
NTAPE=5
CALL USAGEB('BMD02M')
DATA A123/6HPROBLM/,B123/6HFINISH/,D123/3HYES/
204 FORMAT (' EXPECTED PROBLM CARD, BUT READ ',A6)
213 FORMAT(55H1BMD02M-REGRESSION ON PRINCIPAL COMPONENTS - VERSION OF,
118H JUNE 11, 1967 ,/
240H HEALTH SCIENCES COMPUTING FACILITY,UCLA/
314H PROBLEM CODE A6,/
427H NO. OF ORIGINAL VARIABLES I3,/
520H NO. OF X VARIABLES I3,/
620H NO. OF Y VARIABLES I3,//)
10 READ (5,921)TODE,NPROB,NT,NV,NK,N,PNCR,GCK,NVG,NLV,MTAPE,KVR
IERROR=0
IF(TODE.NE.B123)GO TO 200
GO TO 201
202 WRITE (6,204) TODE
201 IF(NTAPE-5)7,7,6
6 REWIND NTAPE
7 STOP
200 IF(TODE.NE.A123)GO TO 202
203 CALL TPWD(MTAPE,NTAPE)
9 IF(NV*(NV-26))205,944,944
205 IF(NK*(NK-20)) 206,206,946
206 IF(NV+NK-45) 207,207,948
207 IF((N-2)*(N-201)) 208,950,950
208 IF(KVR.GT.0.AND.KVR.LE.10)GO TO 209
KVR=1
WRITE (6,4000)
209 NT1=NV+NK
WRITE (6,213)NPROB,NT,NV,NK
CALL RDLBL(NLV,NT1,NAMES)
17 KVR=KVR*18
READ (5,942)(FMT(I),I=1,KVR)
WRITE (6,943) (FMT(I),I=1,KVR)
943 FORMAT (' VARIABLE FORMAT IS '/(5X,18A4))
DO 13 I=1,N
13 READ (NTAPE,FMT)(X(I,J),J=1,NT)
IF(NVG) 952,19,1000
1000 CALL TRANS(X,NT,N,IERROR,NVG)
IF(IERROR)10,19,19
19 IF(NT) 954,954,212
212 NT=NT1
ON=N
DO 21 J=1,NT
XMEAN(J)=0.0
DO 20 I=1,N
20 XMEAN(J)=XMEAN(J)+X(I,J)
21 XMEAN(J)=XMEAN(J)/ON
DO 90 I=1,NK
IJ=NV+I
90 YMEAN(I)=XMEAN(IJ)
DO 22 I=1,NV
DO 22 J=1,NV
COV(I,J)=0.0
DO 22 K=1,N
22 COV(I,J)=COV(I,J)+(X(K,I)-XMEAN(I))*(X(K,J)-XMEAN(J))
DO 23 I=1,NV
23 SCALE(I)=SQRT(COV(I,I))
DO 24 I=1,NV
DO 24 J=1,NV
24 Z(I,J)=COV(I,J)/(SCALE(I)*SCALE(J))
WRITE (6,936)
WRITE (6,904)
CALL PATTY2(Z,NV,NAMES,1)
CALL EIGEN(VALU,NV,NV)
WRITE (6,936)
WRITE (6,907)
WRITE (6,906)(VALU(I),I=1,NV)
RANK=0.0
DO 26 I=1,NV
26 RANK=RANK+VALU(I)
SMALL=0.0
DO 18 I=1,NV
SMALL=SMALL+VALU(I)
18 C(I,1)=SMALL/RANK
WRITE (6,937)
WRITE (6,936)
WRITE (6,938)(C(I,1),I=1,NV)
WRITE (6,908)
CALL PATTY2(Z,NV,NAMES,0)
DO 29 J=1,NV
DO 29 I=1,N
29 X(I,J)=(X(I,J)-XMEAN(J))/SCALE(J)
HIP= N-1
SQT=SQRT(HIP)
DO 43 I=1,N
DO 43 J=1,NV
C(I,J)=0.0
DO 43 K=1,NV
43 C(I,J)=C(I,J)+X(I,K)*Z(K,J)
IF(D123.NE.GCK)GO TO 57
41 DO 51 J=1,NV
XMEAN(J)=0.0
DO 50 I=1,N
50 XMEAN(J)=XMEAN(J)+C(I,J)
51 XMEAN(J)=XMEAN(J)/ON
DO 52 I=1,NV
DO 52 J=1,NV
CCC(I,J)=0.0
DO 52 K=1,N
52 CCC(I,J)=CCC(I,J)+(C(K,I)-XMEAN(I))*(C(K,J)-XMEAN(J))
WRITE (6,936)
WRITE (6,922)
CALL PATTY2(CCC,NV,NAMES,1)
57 DO 58 I=1,N
DO 58 J=1,NV
58 COV(I,J)=C(I,J)
IF(D123.NE.PNCR)GO TO 40
30 WRITE (6,936)
WRITE (6,909)
WRITE (6,910)
SMALL=-(10.0**36.0)
DO 39 II=1,NV
WRITE (6,912)II
DO 32 I=1,N
C(I,1)=0.0
C(I,2)=0.0
DO 31 K=1,NV
31 C(I,1)=C(I,1)+X(I,K)*Z(K,II)
32 C(I,1)=C(I,1)*SQT
DO 39 I=1,N
RANK=SMALL
DO 38 J=1,N
IF(C(J,1)-RANK)38,38,36
36 IF(C(J,2)-999.0)37,38,38
37 RANK=C(J,1)
NJ=J
38 CONTINUE
C(NJ,2)=999.0
WRITE (6,911)RANK,NJ
39 CONTINUE
IF(NK.EQ.0) GO TO 10
40 CALL REGRES
GO TO 10
900 FORMAT(12F6.0)
903 FORMAT(12H PROBLEM NO.I4)
904 FORMAT(31H0CORRELATION COEFFICIENT MATRIX)
906 FORMAT(8F12.4)
907 FORMAT(12H0EIGENVALUES/)
908 FORMAT(13H0EIGENVECTORS/)
909 FORMAT(48H0RANK ORDER OF EACH STANDARDIZED CASE ORDERED BY)
910 FORMAT(44H SIZE OF EACH PRINCIPAL COMPONENT SEPARATELY)
911 FORMAT(F18.6,I10)
912 FORMAT(16H0 COMPONENT NO.I3,12H CASE NO.)
920 FORMAT(43H0REGRESSION ON PRIMARY PRINCIPAL COMPONENTS)
921 FORMAT(2A6,3I2,I3,2A3,2I2,37X,2I2)
922 FORMAT(25H0EIGEN VALUE CHECK MATRIX)
936 FORMAT(1H0)
937 FORMAT(40H0CUMULATIVE PROPORTION OF TOTAL VARIANCE)
938 FORMAT(1H F11.2,7F15.2)
939 FORMAT(7H VECTORI3)
942 FORMAT (18A4)
944 WRITE (6,945) NV
945 FORMAT (1X,I3,' INDEPENDENT VARIABLES IS ILLEGAL ')
GO TO 201
946 WRITE (6,947) NK
947 FORMAT (1X,I3,' DEPENDENT VARIABLES IS ILLEGAL')
GO TO 201
948 NVNK=NV+NK
WRITE (6,949) NVNK
949 FORMAT (' TOTAL OF ',I4,' VARIABLES IS ILLEGAL')
GO TO 201
950 WRITE (6,951) N
951 FORMAT (1X,I4,' CASES IS ILLEGAL')
GO TO 201
952 WRITE (6,953) NVG
953 FORMAT (1X,I3,' TRANSGENERATION CARDS IS ILLEGAL')
GO TO 201
954 WRITE (6,955) NT
955 FORMAT (1X,I3,' ORIGINAL VARIABLES IS ILLEGAL')
GO TO 201
4000 FORMAT(1H023X71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPECIF
1IED, ASSUMED TO BE 1.)
END
SUBROUTINE EIGEN(VALU,N,M)
C
C SUBROUTINE EIGEN FOR BMD02M AUGUST 17, 1966
C EIGENVALUES AND EIGENVECTORS OF A REAL SYMMETRIC MATRIX
C
DOUBLE PRECISION ANORM2
DIMENSION A(25,25), B(25,25), VALU(25), DIAG(25), SUPERD(24),
1 Q(24), VALL(25), S(24), C(24), D(25), IND(25), U(25)
DIMENSION DUMY4(3070)
DIMENSION X123(200,30),DUMY1(45),XMEAN(45),DUMY2(3000),DUMY3(6000)
COMMON X123 , XMEAN , DUMY2
COMMON DUMY4 , A
EQUIVALENCE (X123,DUMY3),(XMEAN,DUMY1),(DUMY2,B),(SUPERD,DUMY2(675
1)),(DIAG,DUMY2(700)),(VALL,D,DUMY2(725)),(Q,S,DUMY2(750)),(IND,U,D
2UMY2(775)),(C,DUMY2(800)),(TAU,BETA),(ANORM,ANORM2),(P,PRODS),(T,S
3MALLD),(II,MATCH)
C
C CALCULATE NORM OF MATRIX
C
3 ANORM2=0.0
4 DO 6 I=1,N
5 DO 6 J=1,N
6 ANORM2=ANORM2+A(I,J)**2
7 ANORM=ANORM2
ANORM=SQRT(ANORM)
C
C GENERATE IDENTITY MATRIX
C
9 IF (M) 10, 45, 10
10 DO 40 I=1,N
12 DO 40 J=1,N
20 IF(I-J) 35, 25, 35
25 B(I,J)=1.0
30 GO TO 40
35 B(I,J)=0.0
40 CONTINUE
C
C PERFORM ROTATIONS TO REDUCE MATRIX TO JACOBI FORM
C
45 IEXIT=1
50 NN=N-2
52 IF (NN) 890, 170, 55
55 DO 160 I=1,NN
60 II=I+2
65 DO 160 J=II,N
70 T1=A(I,I+1)
75 T2=A(I,J)
80 GO TO 900
90 DO 105 K=I,N
95 T2=COS*A(K,I+1)+SIN*A(K,J)
100 A(K,J)=COS*A(K,J)-SIN*A(K,I+1)
105 A(K,I+1)=T2
110 DO 125 K=I,N
115 T2=COS*A(I+1,K)+SIN*A(J,K)
120 A(J,K)=COS*A(J,K)-SIN*A(I+1,K)
125 A(I+1,K)=T2
128 IF (M) 130, 160, 130
130 DO 150 K=1,N
135 T2=COS*B(K,I+1)+SIN*B(K,J)
140 B(K,J)=COS*B(K,J)-SIN*B(K,I+1)
150 B(K,I+1)=T2
160 CONTINUE
C
C MOVE JACOBI FORM ELEMENTS AND INITIALIZE EIGENVALUE BOUNDS
C
170 DO 200 I=1,N
180 DIAG(I)=A(I,I)
190 VALU(I)=ANORM
200 VALL(I)=-ANORM
210 DO 230 I=2,N
220 SUPERD(I-1)=A(I-1,I)
230 Q(I-1)=(SUPERD(I-1))**2
C
C DETERMINE SIGNS OF PRINCIPAL MINORS
C
235 TAU=0.0
240 I=1
260 MATCH=0
270 T2=0.0
275 T1=1.0
277 DO 450 J=1,N
280 P=DIAG(J)-TAU
290 IF(T2) 300, 330, 300
300 IF(T1) 310, 370, 310
310 T=P*T1-Q(J-1)*T2
320 GO TO 410
330 IF(T1) 335, 350, 350
335 T1=-1.0
340 T=-P
345 GO TO 410
350 T1=1.0
355 T=P
360 GO TO 410
370 IF(Q(J-1)) 380, 350, 380
380 IF(T2) 400, 390, 390
390 T=-1.0
395 GO TO 410
400 T=1.0
C
C COUNT AGREEMENTS IN SIGN
C
410 IF(T1) 425, 420, 420
420 IF(T) 440, 430, 430
425 IF(T) 430, 440, 440
430 MATCH=MATCH+1
440 T2=T1
450 T1=T
C
C ESTABLISH TIGHTER BOUNDS ON EIGENVALUES
C
460 DO 530 K=1,N
465 IF (K-MATCH) 470, 470, 520
470 IF(TAU-VALL(K)) 530, 530, 480
480 VALL(K)=TAU
490 GO TO 530
520 IF(TAU-VALU(K)) 525, 530, 530
525 VALU(K)=TAU
530 CONTINUE
540 IF(ABS(VALU(I)-VALL(I)).GT.ABS(VALU(I)+VALL(I))/1.E+6) GO TO 580
570 I=I+1
575 IF(I-N) 540, 540, 590
580 TAU=(VALL(I)+VALU(I))/2.0
585 GO TO 260
C
C JACOBI EIGENVECTORS BY ROTATIONAL TRIANGULARIZATION
C
590 IF (M) 593, 890, 593
593 IEXIT=2
595 DO 610 I=1,N
600 DO 610 J=1,N
610 A(I,J)=0.0
615 DO 850 I=1,N
620 IF (I-1) 625, 625, 621
621 IF(ABS(VALU(I-1)-VALU(I)).LT.ABS(VALU(I-1)+VALU(I))/1.E+6) GOTO730
625 COS=1.0
628 SIN=0.0
630 DO 700 J=1,N
635 IF(J-1) 680, 680, 640
640 GO TO 900
650 S(J-1)=SIN
660 C(J-1)=COS
670 D(J-1)=T1*COS+T2*SIN
680 T1=(DIAG(J)-VALU(I))*COS-BETA*SIN
690 T2=SUPERD(J)
700 BETA=SUPERD(J)*COS
710 D(N)=T1
720 DO 725 J=1,N
725 IND(J)=0
730 SMALLD=ANORM
735 DO 780 J=1,N
740 IF (IND(J)-1) 750, 780, 780
750 IF (ABS(SMALLD)-ABS(D(J)))780, 780, 760
760 SMALLD=D(J)
770 NN=J
780 CONTINUE
790 IND(NN)=1
800 PRODS=1.0
805 IF (NN-1) 810, 850, 810
810 DO 840 K=2,NN
820 II=NN+1-K
830 A(II+1,I)=C(II)*PRODS
840 PRODS=-PRODS*S(II)
850 A(1,I)=PRODS
C
C FORM MATRIX PRODUCT OF ROTATION MATRIX WITH JACOBI VECTOR MATRIX
C
855 DO 885 J=1,N
860 DO 865 K=1,N
865 U(K)=A(K,J)
870 DO 885 I=1,N
875 A(I,J)=0.0
880 DO 885 K=1,N
885 A(I,J)=B(I,K)*U(K)+A(I,J)
890 GO TO 941
C
C CALCULATE SINE AND COSINE OF ANGLE OF ROTATION
C
900 IF (T2) 910, 940, 910
910 T=SQRT(T1**2+T2**2)
920 COS=T1/T
925 SIN=T2/T
930 GO TO (90,650), IEXIT
940 GO TO (160,910), IEXIT
941 CONTINUE
RETURN
END
SUBROUTINE PATTY2(A,N,NAMES,JK)
C SUBROUTINE PATTY2 FOR BMD02M AUGUST 17, 1966
DOUBLE PRECISION NAMES,NN
DIMENSION A(25,25),NAMES(45),NN(8)
IT=1
KK=0
K1=IT
K2=MIN0(8,N)
5 KK=KK+8
IF(N-KK)3,3,4
4 IT=IT+1
GO TO 5
3 DO 50 JX=1,IT
LLL=K2-K1+1
LL=0
IF(JK)35,35,37
35 WRITE (6,350)(IG,IG=1,LLL)
GO TO 45
37 DO 40 JJ=K1,K2
LL=LL+1
40 NN(LL)=NAMES(JJ)
WRITE (6,300)(NN(II),II=1,LLL)
45 DO 10 I=1,N
10 WRITE (6,20)NAMES(I),(A(I,J),J=K1,K2)
K1=K2+1
K2=K1+7
K2=MIN0(K2,N)
50 CONTINUE
RETURN
300 FORMAT(1H013X,A6,7(8X,A6)/)
20 FORMAT(1H A6,1X,8F14.4)
350 FORMAT(1H017X,I2,7(12X,I2)/)
END
DOUBLE PRECISION FUNCTION ANUMB(I)
DOUBLE PRECISION X
DIMENSION B(2)
ENCODE(8,10,B)I
10 FORMAT(4X,I4)
DECODE(8,11,B)X
11 FORMAT(A8)
ANUMB=X
RETURN
END
SUBROUTINE RDLBL(NLBVAR,NVAR,ARRAY)
C
C SUBROUTINE RDLBL FOR BMD02M AUGUST 17, 1966
C SUBROUTINE TO READ IN LABELS CARDS, STORE THEM IN ARRAY,
C AND SUBSTITUTE NUMBERS FOR UNLABELED VARIABLES
C NVAR IS TOTAL NUMBER OF VARIABLES
C NLBVAR IS NUMBER OF LABELED VARIABLES EXPECTED
DOUBLE PRECISION ARRAY,ANUMB,DUMY
DIMENSION ARRAY (45),IDUM(7),DUMY(7)
DATA ALABEL/3HLAB/
C NUMBER VARIABLES
DO 1 I=1,NVAR
1 ARRAY(I)=ANUMB(I)
C IF NO LABELS, RETURN
IF(NLBVAR) 9,9,2
2 N=0
C READ 1 LABELS CARD
20 READ (5,3) TEST,(IDUM(J),DUMY(J),J=1,7)
3 FORMAT(A3,3X,7(I4,A6))
C TEST FOR 'LAB' IN FIRST 3 COLS.
IF(TEST.EQ.ALABEL)GO TO 6
C ERROR--PRINT MESSAGE AND QUIT
4 WRITE (6,5)
5 FORMAT(36H0LABELS CARD NOT FOUND WHEN EXPECTED)
STOP
C EXAMINE 7 FIELDS
6 DO 8 J=1,7
K=IDUM(J)
C TEST INDEX. IF 0, IGNORE. IF ILLEGAL, PRINT MESSAGE AND
C IGNORE EXCEPT TO COUNT
IF(K) 11,8,10
10 IF(K-NVAR) 7,7,11
11 WRITE (6,12)K,DUMY(J)
12 FORMAT(18H0LABELS CARD INDEX,I7,18H INCORRECT. LABEL ,A6,9H IGNORE
1D.)
GO TO 13
C MOVE LABEL TO ARRAY
7 ARRAY(K)=DUMY(J)
C STEP NUMBER OF VARIABLES
13 N=N+1
C TEST FOR END. IF END, RETURN. IF NOT, SCAN OTHER FIELDS.
IF(N-NLBVAR) 8,9,9
8 CONTINUE
WRITE (6,7000)(ARRAY (I),I=1,15)
7000 FORMAT (9X,A6,5X,A6,5X,A6,5X,A6,5X,A6)
GO TO 20
9 RETURN
END
SUBROUTINE REGRES
C SUBROUTINE REGRES FOR BMD02M AUGUST 17,1966
DIMENSION X(200,30),XMEAN(45),COV(200,15),VALU(25),SCALE(45),
1C(200,15),Z(25,25),INDEX(20),YMEAN(20),SQ(20),RES(20)
COMMON X , XMEAN , COV , VALU , SCALE , C
COMMON Z , INDEX , YMEAN , SQ , RES , NK
COMMON NY , NV , N , NT
DO 61 I=1,NK
NY=NV+I
DO 61 J=1,NV
C(I,J)=0.0
DO 61 K=1,N
61 C(I,J)=C(I,J)+X(K,NY)*COV(K,J)
DO 63 J=1,NV
DO 63 I=1,NK
63 C(I,J)=C(I,J)/VALU(J)
WRITE (6,936)
WRITE (6,923)
WRITE (6,924)
DO 98 I=1,NK
98 INDEX(I)=I
ASSIGN 106 TO NNN
200 NNK=NK
KF=1
KL=0
99 IF(NNK-6) 97, 101, 101
97 KL=KL+NNK
GO TO 102
101 KL=KL+6
102 WRITE (6,925)(INDEX(I), I=KF,KL)
WRITE (6,940)(YMEAN(I), I=KF,KL)
WRITE (6,941)
DO 103 J=1,NV
103 WRITE (6,942)J,(C(I,J), I=KF,KL)
WRITE (6,936)
NNK=NNK-6
IF(NNK) 105, 105, 104
104 KF=KF+6
GO TO 99
105 GO TO NNN, (106,135,145,155,10)
106 DO 161 J=1,NK
NY=NV+J
SQ(J)=0.0
DO 161 I=1,N
161 SQ(J)=SQ(J)+(X(I,NY)-YMEAN(J))**2
DO 165 I=1,NK
DO 165 J=1,NV
165 COV(I,J)=C(I,J)
DO 66 J=1,NV
DO 66 I=1,NK
66 C(I,J)=(COV(I,J)*COV(I,J))*VALU(J)
WRITE (6,927)
DO 164 I=1,NK
SUM=0.0
DO 163 J=1,NV
163 SUM=SUM+C(I,J)
164 RES(I)=SQ(I)-SUM
NNK=NK
KF=1
KL=0
119 IF(NNK-6) 120, 120, 121
120 KL=KL+NNK
GO TO 122
121 KL=KL+6
122 WRITE (6,925)(INDEX(I), I=KF,KL)
WRITE (6,928)(RES(I), I=KF,KL)
WRITE (6,943)(SQ(I), I=KF,KL)
WRITE (6,944)
DO 123 J=1,NV
123 WRITE (6,942)J,(C(I,J), I=KF,KL)
WRITE (6,936)
NNK=NNK-6
IF(NNK) 125, 125, 124
124 KF=KF+6
GO TO 119
125 WRITE (6,930)
WRITE (6,931)
WRITE (6,932)
C
C
C
DO 68 I=1,NK
DO 68 J=1,NV
68 C(I,J)=COV(I,1)*Z(J,1)
ASSIGN 135 TO NNN
GO TO 200
135 IF(NV-2)10,70,70
70 WRITE (6,933)
DO 71 I=1,NK
DO 71 J=1,NV
71 C(I,J)=C(I,J)+COV(I,2)*Z(J,2)
ASSIGN 145 TO NNN
GO TO 200
145 IF(NV-3)10,73,73
73 WRITE (6,934)
DO 74 I=1,NK
DO 74 J=1,NV
74 C(I,J)=C(I,J)+COV(I,3)*Z(J,3)
ASSIGN 155 TO NNN
GO TO 200
155 IF(NV-4)10,76,76
76 WRITE (6,935)
DO 77 II=4,NV
DO 77 I=1,NK
DO 77 J=1,NV
77 C(I,J)=C(I,J)+COV(I,II)*Z(J,II)
ASSIGN 10 TO NNN
GO TO 200
923 FORMAT(54H0COEFFICIENTS OF REGRESSION EQUATIONS USING ORTHOGONAL)
924 FORMAT(50H COMPONENTS FOR STANDARDIZED INDEPENDENT VARIABLES)
925 FORMAT(15H0 Y 6I15)
927 FORMAT(80H0REDUCTION IN SUM OF SQUARES OF THE RESIDUALS DUE TO USI
1NG ORTHOGONAL COMPONENTS)
928 FORMAT(20H0RESIDUAL SUM SQ. 6F15.7)
930 FORMAT(99H0COEFFICIENTS OF REGRESSION EQUATION WHEN ONLY FIRST, FI
1RST TWO, FIRST THREE AND ALL COMPONENTS ARE)
931 FORMAT(99H USED AS INDEPENDENT VARIABLES, WHERE EACH COMPONENT IS
1EXPRESSED IN TERMS OF THE STANDARDIZED DATA)
932 FORMAT(26H0FIRST PRINCIPAL COMPONENT)
933 FORMAT(38H0FIRST AND SECOND PRINCIPAL COMPONENTS)
934 FORMAT(45H0FIRST, SECOND AND THIRD PRINCIPAL COMPONENTS)
935 FORMAT(25H0ALL PRINCIPAL COMPONENTS)
936 FORMAT(1H0)
940 FORMAT(20H0MEAN (INTERCEPT) 6F15.7)
941 FORMAT(15H0COEFF. OF VAR.)
942 FORMAT(1H I7,12H 6F15.7)
943 FORMAT(20H0TOTAL SUM SQ. 6F15.7)
944 FORMAT(27H0REDUCTION DUE TO COMPONENT)
10 RETURN
END
SUBROUTINE TPWD(NT1,NT2)
C SUBROUTINE TPWD FOR BMD02M JUNE 20, 1966
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
40 WRITE (6,49)
STOP
49 FORMAT(25H ERROR ON TAPE ASSIGNMENT)
END
C SUBROUTINE TRANS FOR BMD02M AUGUST 17, 1966
SUBROUTINE TRANS(DATA,NVAR,NSAM,IERROR,NVG)
DOUBLE PRECISION C123,TODE
DIMENSION DATA (200,30)
ASN(XX)=ATAN(XX/SQRT(1.0-XX**2))
DATA C123/6HTRNGEN/
MARY=0
FN=NSAM
WRITE (6,1403)
WRITE (6,1400)
DO1000 J=1,NVG
READ (5,1100)TODE,NEWA,LCODE,LVA,BNEW
IF(C123.EQ.TODE)GO TO 201
200 NVAR=-NVAR
201 WRITE (6,1402)J,NEWA,LCODE,LVA,BNEW
IF(LCODE*(15-LCODE)) 710,710,714
710 WRITE (6,712)
712 FORMAT(29HERROR ON TRANSGENERATION CODE)
GO TO 1000
714 IF(LCODE-10)4,5,5
5 NEWB=BNEW
4 DO 300 I=1,NSAM
D=DATA(I,LVA)
202 GOTO(10,20,30,40,50,60,70,80,90,100,110,120,130,140),LCODE
10 IF(D)99,7,8
7 D2=0.0
GO TO 3
8 D2=SQRT(D)
GO TO 3
20 IF(D)99,11,12
11 D2=1.0
GO TO 3
12 D2=SQRT(D)+SQRT(D+1.0)
GO TO 3
30 IF(-D)14,99,99
14 D2=ALOG10(D)
GO TO 3
40 D2=EXP(D)
GO TO 3
50 IF(-D)17,7,99
17 IF(D-1.0)18,19,99
19 D2=3.14159265/2.0
GO TO 3
18 D2=ASN(SQRT(D))
GO TO 3
60 A=D/(FN+1.0)
B=A+1.0/(FN+1.0)
IF(A)99,23,24
23 IF(-B)27,7,99
27 D2=ASN(SQRT(B))
GO TO 3
24 IF(B)99,28,29
28 D2=ASN(SQRT(A))
GO TO 3
29 D2=ASN(SQRT(A))+ASN(SQRT(B))
GO TO 3
70 IF(D)31,99,31
31 D2=1.0/D
GO TO 3
80 D2=D+BNEW
GO TO 3
90 D2=D*BNEW
GO TO 3
100 IF(-D)33,7,99
33 D2=D**NEWB
GO TO 3
110 D2=D+DATA(I,NEWB)
GO TO 3
120 D2=D-DATA(I,NEWB)
GO TO 3
130 D2=D*DATA(I,NEWB)
GO TO 3
140 IF(DATA(I,NEWB))34,99,34
34 D2=D/DATA(I,NEWB)
GO TO 3
99 IF(MARY)43,44,44
44 MARY=-999
IERROR=-999
WRITE (6,1404)J
43 WRITE (6,1405)I
GO TO 300
3 DATA(I,NEWA)=D2
300 CONTINUE
IF(IERROR)42,1000,1000
1000 CONTINUE
1100 FORMAT(A6,I3,I2,I3,F6.0)
1402 FORMAT(2H I2,I8,2I9,F15.5)
1403 FORMAT(1H06X,23HTRANS GENERATOR CARD(S))
1405 FORMAT(10H ITEM NO. I3)
1400 FORMAT(46H0CARD NEW TRANS ORIG. ORIG. VAR(B)/45H NO.
1VARIABLE CODE VAR(A) OR CONSTANT)
1404 FORMAT(30H0THE INSTRUCTIONS INDICATED ON/25H TRANS GENERATOR CARD
1NO.I2,4H RE-/29H SULTED IN THE VIOLATION OF A/31H RESTRICTION FOR
2THIS TRANSFOR-/31H MATION. THE VIOLATION OCCURRED/28H FOR THE ITEM
3S LISTED BELOW./)
1401 FORMAT(41H0PROGRAM CANNOT CONTINUE FOR THIS PROBLEM)
IF(IERROR)42,1111,1111
42 WRITE (6,1401)
1111 RETURN
END