Trailing-Edge
-
PDP-10 Archives
-
decus_20tap2_198111
-
decus/20-0026/nroot.ssp
There are 2 other files named nroot.ssp in the archive. Click here to see a list.
C NROO 10
C ..................................................................NROO 20
C NROO 30
C SUBROUTINE NROOT NROO 40
C NROO 50
C PURPOSE NROO 60
C COMPUTE EIGENVALUES AND EIGENVECTORS OF A REAL NONSYMMETRIC NROO 70
C MATRIX OF THE FORM B-INVERSE TIMES A. THIS SUBROUTINE IS NROO 80
C NORMALLY CALLED BY SUBROUTINE CANOR IN PERFORMING A NROO 90
C CANONICAL CORRELATION ANALYSIS. NROO 100
C NROO 110
C USAGE NROO 120
C CALL NROOT (M,A,B,XL,X) NROO 130
C NROO 140
C DESCRIPTION OF PARAMETERS NROO 150
C M - ORDER OF SQUARE MATRICES A, B, AND X. NROO 160
C A - INPUT MATRIX (M X M). NROO 170
C B - INPUT MATRIX (M X M). NROO 180
C XL - OUTPUT VECTOR OF LENGTH M CONTAINING EIGENVALUES OF NROO 190
C B-INVERSE TIMES A. NROO 200
C X - OUTPUT MATRIX (M X M) CONTAINING EIGENVECTORS COLUMN- NROO 210
C WISE. NROO 220
C NROO 230
C REMARKS NROO 240
C NONE NROO 250
C NROO 260
C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED NROO 270
C EIGEN NROO 280
C NROO 290
C METHOD NROO 300
C REFER TO W. W. COOLEY AND P. R. LOHNES, 'MULTIVARIATE PRO- NROO 310
C CEDURES FOR THE BEHAVIORAL SCIENCES', JOHN WILEY AND SONS, NROO 320
C 1962, CHAPTER 3. NROO 330
C NROO 340
C ..................................................................NROO 350
C NROO 360
SUBROUTINE NROOT (M,A,B,XL,X) NROO 370
DIMENSION A(1),B(1),XL(1),X(1) NROO 380
C NROO 390
C ...............................................................NROO 400
C NROO 410
C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE NROO 420
C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION NROO 430
C STATEMENT WHICH FOLLOWS. NROO 440
C NROO 450
C DOUBLE PRECISION A,B,XL,X,SUMV NROO 460
C NROO 470
C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS NROO 480
C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS NROO 490
C ROUTINE. NROO 500
C NROO 510
C THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO NROO 520
C CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS. SQRT IN STATEMENTSNROO 530
C 110 AND 175 MUST BE CHANGED TO DSQRT. ABS IN STATEMENT 110 NROO 540
C MUST BE CHANGED TO DABS. NROO 550
C NROO 560
C ...............................................................NROO 570
C NROO 580
C COMPUTE EIGENVALUES AND EIGENVECTORS OF B NROO 590
C NROO 600
K=1 NROO 610
DO 100 J=2,M NROO 620
L=M*(J-1) NROO 630
DO 100 I=1,J NROO 640
L=L+1 NROO 650
K=K+1 NROO 660
100 B(K)=B(L) NROO 670
C NROO 680
C THE MATRIX B IS A REAL SYMMETRIC MATRIX. NROO 690
C NROO 700
MV=0 NROO 710
CALL EIGEN (B,X,M,MV) NROO 720
C NROO 730
C FORM RECIPROCALS OF SQUARE ROOT OF EIGENVALUES. THE RESULTS NROO 740
C ARE PREMULTIPLIED BY THE ASSOCIATED EIGENVECTORS. NROO 750
C NROO 760
L=0 NROO 770
DO 110 J=1,M NROO 780
L=L+J NROO 790
110 XL(J)=1.0/ SQRT( ABS(B(L))) NROO 800
K=0 NROO 810
DO 115 J=1,M NROO 820
DO 115 I=1,M NROO 830
K=K+1 NROO 840
115 B(K)=X(K)*XL(J) NROO 850
C NROO 860
C FORM (B**(-1/2))PRIME * A * (B**(-1/2)) NROO 870
C NROO 880
DO 120 I=1,M NROO 890
N2=0 NROO 900
DO 120 J=1,M NROO 910
N1=M*(I-1) NROO 920
L=M*(J-1)+I NROO 930
X(L)=0.0 NROO 940
DO 120 K=1,M NROO 950
N1=N1+1 NROO 960
N2=N2+1 NROO 970
120 X(L)=X(L)+B(N1)*A(N2) NROO 980
L=0 NROO 990
DO 130 J=1,M NROO1000
DO 130 I=1,J NROO1010
N1=I-M NROO1020
N2=M*(J-1) NROO1030
L=L+1 NROO1040
A(L)=0.0 NROO1050
DO 130 K=1,M NROO1060
N1=N1+M NROO1070
N2=N2+1 NROO1080
130 A(L)=A(L)+X(N1)*B(N2) NROO1090
C NROO1100
C COMPUTE EIGENVALUES AND EIGENVECTORS OF A NROO1110
C NROO1120
CALL EIGEN (A,X,M,MV) NROO1130
L=0 NROO1140
DO 140 I=1,M NROO1150
L=L+I NROO1160
140 XL(I)=A(L) NROO1170
C NROO1180
C COMPUTE THE NORMALIZED EIGENVECTORS NROO1190
C NROO1200
DO 150 I=1,M NROO1210
N2=0 NROO1220
DO 150 J=1,M NROO1230
N1=I-M NROO1240
L=M*(J-1)+I NROO1250
A(L)=0.0 NROO1260
DO 150 K=1,M NROO1270
N1=N1+M NROO1280
N2=N2+1 NROO1290
150 A(L)=A(L)+B(N1)*X(N2) NROO1300
L=0 NROO1310
K=0 NROO1320
DO 180 J=1,M NROO1330
SUMV=0.0 NROO1340
DO 170 I=1,M NROO1350
L=L+1 NROO1360
170 SUMV=SUMV+A(L)*A(L) NROO1370
175 SUMV= SQRT(SUMV) NROO1380
DO 180 I=1,M NROO1390
K=K+1 NROO1400
180 X(K)=A(K)/SUMV NROO1410
RETURN NROO1420
END NROO1430