Trailing-Edge
-
PDP-10 Archives
-
decuslib20-01
-
decus/20-0025/eigsr.for
There is 1 other file named eigsr.for in the archive. Click here to see a list.
01000 C DRIVING PROGRAM FOR EIG1X.SRC
01010 C THS IS CALLED EIGSR IN THE VOL II WRITE-UP
01020 DIMENSION A(25,25),B(25,25),AM(25),IR(25),D(25)
01022 DIMENSION BB(625)
01024 EQUIVALENCE (B(1,1),BB(1))
01030 C
01040 C
01050 TYPE 9000
01060 ACCEPT 9001,IREPLY
01070 IF(IREPLY-'YES')201,101,201
01080 101 TYPE 9101
01090 TYPE 9102
01100 TYPE 9103
01110 TYPE 9104
01120 TYPE 9105
01130 TYPE 9106
01140 TYPE 9107
01170 9000 FORMAT(' DO YOU DESIRE USER INSTRUCTIONS,
01180 + TYPE "YES" OR "NO"--',$)
01190 9001 FORMAT(A3)
01200 9101 FORMAT(/' THIS PROGRAM FINDS THE EIGENVALUES AND
01210 + EIGENVECTORS OF A'/' REAL SYMMETRIC MATRIX BY THE
01220 + JACOBI-CORBATO METHOD.'/)
01230 9102 FORMAT(' THE MATRIX IS OF THE FORM'/
01240 +' A11 A12 ... A1N WHERE THE A(I,J) ARE
01250 + REAL (FLOATING POINT)'/' A21 A22 ...
01260 + A2N AND N (FIXED POINT) CANNOT EXCEED
01270 + 25:'/' .'/' .'/' AN1 AN2 ...
01280 + ANN'/)
01310 9103 FORMAT(' SINCE THE MATRIX IS SYMMETRIC, ONLY THE
01320 + ELEMENTS ON AND ABOVE'/' THE DIAGONAL NEED BE
01330 + ENTERED'/)
01350 9104 FORMAT(' THE PROGRAM TYPES A(1,1)? THE USER
01370 + TYPES THE FIRST ROW ELEMENTS.'/' THE PROGRAM
01380 + TYPES A(2,2)? THE USER TYPES THE SECOND ROW'/
01390 + ' STARTING WITH THE DIAGONAL ELEMENT. THIS
01400 + CONTINUES UNTIL A(N,N) HAS BEEN ENTERED.'/)
01410 9105 FORMAT(' INPUT IS TYPED IN FREE FIELD FORMAT, A
01420 + BLANK ENDS THE FIELD.'/)
01430 9106 FORMAT(' AFTER A(N,N) HAS BEEN ENTERED, THE
01440 + PROGRAM PROVIDES THE OPPORTUNITY'/
01450 +' AND INSTRUCTIONS FOR CORRECTION OF TYPING ERRORS.'/)
01460 9107 FORMAT(' NOW YOU TRY IT.'/)
01470 C
01471 9201 FORMAT(' ORDER? ',$)
01472 9202 FORMAT(I)
01480 201 TYPE 9201
01490 ACCEPT 9202,N
01500 IF(N)399,399,203
01520 203 IF(N-25)205,205,301
01530 205 NIJ=N*(N+1)/2
01540 NM1=N-1
01545 LIMIT=8
01550 IF(N-LIMIT)242,242,240
01560 240 TYPE 9240,LIMIT
01570 9240 FORMAT(' PROGRAM CAN ACCEPT ONLY',I2,' VALUES
01580 + PER LINE. OBSERVE CAREFULLY'/' THE LABELS AS YOU
01590 + ENTER DATA. TYPE AT MOST',I2,' VALUES PER LINE.'/
01600 + ' REMEMBER THAT YOU WILL HAVE A CHANCE TO MAKE
01610 + CORRECTIONS BEFORE CALCULATION BEGINS.'/)
01611 9260 FORMAT(14X,'A(',I2,',',I2,')? ',$)
01613 9270 FORMAT(' A(',I2,',',I2,') TO A(',I2,',',I2,')? ',$)
01615 9280 FORMAT(10F)
01620 242 DO 280 I=1,N
01630 K=I
01640 L=K-1+LIMIT
01650 250 L=MIN0(L,N)
01660 IF(K-N)270,260,280
01670 260 TYPE 9260,I,N
01690 ACCEPT 9280,A(I,N)
01700 GO TO 280
01710 270 TYPE 9270,I,K,I,L
01720 ACCEPT 9280,(A(I,J),J=K,L)
01730 K=K+LIMIT
01740 L=L+LIMIT
01750 GO TO 250
01760 280 CONTINUE
01770 GO TO 400
01800 301 TYPE 9301
01820 GO TO 201
01830 9301 FORMAT(/' N MUST BE BETWEEN 1 AND 25. TRY AGAIN.'/)
01840 399 CALL EXIT
02000 400 TYPE 9400
02010 9400 FORMAT(' ARE ANY OF THE ABOVE A(I,J) ELEMENTS
02020 + TYPED INCORRECTLY? IF THE USER'/
02021 + ' WISHES TO CORRECT AN ELEMENT, TYPE "YES".'/)
02023 401 TYPE 9401
02024 9401 FORMAT(/' ANY CORRECTIONS?--',$)
02030 ACCEPT 9001,IREPLY
02040 IF(IREPLY-'YES')500,402,500
02050 402 TYPE 9402
02051 403 TYPE 9403
02052 9402 FORMAT(' CORRECT AN ELEMENT BY TYPING I (ROW
02054 + SUBSCRIPT),'/' A COMMA, J (COLUMN SUBSCRIPT),
02056 + A COMMA, AND THE VALUE.')
02058 9403 FORMAT(/' WHAT ARE I, J, A(I,J)?--',$)
02060 9425 FORMAT(2I,F)
02062 9436 FORMAT(/' ILLEGAL SUBSCRIPT. EITHER I GREATER
02064 + J, I MORE THAN N, OR J MORE THAN N. TRY AGAIN.')
02066 9446 FORMAT(/' ILLEGAL COMMAND. TRY AGAIN.')
02080 425 ACCEPT 9425,I,J,ATEMP
02100 435 IF(I-J) 440,440,436
02110 436 TYPE 9436
02120 GO TO 403
02140 440 IF(I-N) 441,441,436
02150 441 IF(J-N) 442,442,436
02160 442 A(I,J)=ATEMP
02170 443 TYPE 9401
02190 ACCEPT 9001,IREPLY
02200 IF(IREPLY-'NO')445,500,445
02210 445 IF(IREPLY-'YES')446,403,446
02220 446 TYPE 9446
02230 GO TO 443
02240 C
02260 500 NA=25
02270 NB=25
02280 EPS=0.
02290 DO 652 I=1,N
02300 D(I)=A(I,I)
02310 DO 652 J=I,N
02320 652 A(J,I)=A(I,J)
02330 C
02340 CALL EIG1(A,B,N,EPS,AM,IR,NA,NB)
02341 C
02342 9469 FORMAT(///' ORDER =',I3)
02344 9470 FORMAT(//6X,'EIGENVALUE',I3,5X,'EIGENVECTOR')
02346 9471 FORMAT(1P2E19.7/(1PE38.7))
02348 9472 FORMAT(1PE38.7)
02350 9630 FORMAT(/' SUM OF SQUARES OF THE OFF-DIAGONAL
02352 + ELEMENTS OF XT A X =',1PE16.7,','/' WHERE XT
02354 + MEANS X-TRANSPOSE.'/)
02355 DO 9711 I=1,N
02356 9711 TYPE 8711,I,(A(I,J),J=1,N)
02357 DO 9712 I=1,N
02358 9712 TYPE 8712,I,(B(I,J),J=1,N)
02359 8711 FORMAT(' A',I3,8F9.5)
02360 8712 FORMAT(' B',I3,8F9.5)
02368 TYPE 9469,N
02370 DO 600 I=1,N
02380 TYPE 9470,I
02410 600 TYPE 9471,A(I,I),(B(J,I),J=1,N)
02411 K=1
02412 L=N
02413 DO 602 I=1,N
02414 TYPE 9602,I,A(I,I),(BB(J),J=K,L)
02415 9602 FORMAT(/' E',I3,1PE16.8/(1PE22.8))
02416 K=K+25
02417 602 L=L+25
02420 DO 610 I=1,N
02440 A(I,I)=D(I)
02450 DO 610 J=I,N
02460 610 A(I,J)=A(J,I)
02465 T=0.
02470 DO 630 I=1,N
02480 DO 620 J=1,N
02500 D(J)=0.
02510 DO 620 K=1,N
02520 620 D(J)=D(J)+A(J,K)*B(K,I)
02530 DO 630 J=1,N
02540 IF(J-I)622,630,630
02550 622 TS=0.
02560 DO 625 K=1,N
02570 625 TS=TS+B(K,J)*D(K)
02580 T=T+TS*TS
02590 630 CONTINUE
02600 C
02610 TYPE 9630,T
02620 GO TO 201
02630 END