Google
 

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