Category : Miscellaneous Language Source Code
Archive   : LIBRY51.ZIP
Filename : LIBRY7A.DOC

 
Output of file : LIBRY7A.DOC contained in archive : LIBRY51.ZIP

.de
.pa
EXAMPLE PROGRAM ILLUSTRATING THE USE OF VECTOR INSTRUCTIONS


$STORAGE:2
PROGRAM TEST
C
C this program illustrates how to use the vector instructions
C
IMPLICIT INTEGER*2(I-N),REAL*4(A-H,O-Z)
PARAMETER (N=5)
DIMENSION AS(N,N),BS(N),CS(N),AV(N,N),BV(N),CV(N),JPIVOT(N)
C
C create Vandermonde
C
DO 100 I=1,N
BS(I)=FACT(I-1)
BV(I)=FACT(I-1)
DO 100 J=1,N
AS(I,J)=FLOAT(I)**(J-1)
100 AV(I,J)=FLOAT(I)**(J-1)
C
C scalar solve
C
CALL SCALAR(AS,BS,CS,JPIVOT,N,IER)
C
C vector solve
C
CALL VECTOR(AV,BV,CV,JPIVOT,N,IER)
C
C list solution
C
DO 200 I=1,N
200 WRITE(*,'(1X,I2,1P2E15.5)') I,CS(I),CV(I)
C
STOP
END
SUBROUTINE SCALAR(A,B,X,JPIVOT,N,IER)
C
C GAUSS ELIMINATION WITH FULL PIVOTING (SIMULTANEOUS EQUATIONS)
C SINGLE PRECISION VERSION WITHOUT VECTOR CALLS
C
IMPLICIT INTEGER*2(I-N),REAL*4(A-H,O-Z)
DIMENSION A(N,N),B(N),X(N),JPIVOT(N)
DATA SMALL/1.E-35/
C
C CHECK FOR ERRORS
C
IER=0
IF(N.LT.1) GO TO 900
C
C N=1 SIMULTANEOUS EQUATIONS
C
IF(N.GT.1) GO TO 100
A11=A(1,1)
IF(ABS(A11).LT.SMALL) GO TO 910
X(1)=B(1)/A11
GO TO 999
C
C N>1 SIMULTANEOUS EQUATIONS
C
100 N1=N-1
C
C INITIALIZE THE PIVOT VECTOR
C
DO 110 I=1,N
110 JPIVOT(I)=I
C
C REDUCE THE MATRIX TO UPPER TRIANGULAR FORM
C
DO 160 K=1,N1
K1=K+1
C
C LOCATE THE LARGEST ELEMENT IN THE REDUCED MATRIX
C
IP=K
JP=K
AMAX=ABS(A(IP,JP))
DO 120 I=K,N
DO 120 J=K,N
AIJ=ABS(A(I,J))
IF(AIJ.GT.AMAX) THEN
AMAX=AIJ
IP=I
JP=J
ENDIF
120 CONTINUE
IF(AMAX.LT.SMALL) GO TO 910
C
C SWAP ROWS TO MOVE THE LARGEST ELEMENT INTO THE PIVOT POSITION
C
IF(IP.EQ.K) GO TO 130
BK=B(K)
B(K)=B(IP)
B(IP)=BK
C
DO 121 J=K,N
AKJ=A(K,J)
A(K,J)=A(IP,J)
121 A(IP,J)=AKJ
C
C SWAP COLUMNS TO MOVE THE LARGEST ELEMENT INTO THE PIVOT POSITION
C
130 IF(JP.EQ.K) GO TO 140
J=JPIVOT(JP)
JPIVOT(JP)=JPIVOT(K)
JPIVOT(K)=J
C
DO 131 I=1,N
AIJ=A(I,K)
A(I,K)=A(I,JP)
131 A(I,JP)=AIJ
C
C NORMALIZE THE ROW
C
140 DO 150 I=K1,N
R=A(I,K)/A(K,K)
B(I)=B(I)-R*B(K)
DO 150 J=K1,N
150 A(I,J)=A(I,J)-R*A(K,J)
C
160 CONTINUE
C
C FINAL PIVOT ELEMENT
C
ANN=A(N,N)
IF(ABS(ANN).LT.SMALL) GO TO 910
X(N)=B(N)/ANN
C
C BACKSOLVE THE UPPER TRIANGULAR MATRIX
C
DO 171 IN=2,N
I=N+1-IN
C
BI=0.
DO 170 J=I+1,N
170 BI=BI+A(I,J)*X(J)
C
171 X(I)=(B(I)-BI)/A(I,I)
C
C PIVOT BACK TO THE ORIGINAL ORDER
C
DO 180 I=1,N
180 B(I)=X(I)
C
DO 181 I=1,N
181 X(JPIVOT(I))=B(I)
GO TO 999
C
900 IER=1
GO TO 999
C
910 IER=2
C
999 RETURN
END
SUBROUTINE VECTOR(A,B,X,JPIVOT,N,IER)
C
C GAUSS ELIMINATION WITH FULL PIVOTING (SIMULTANEOUS EQUATIONS)
C SINGLE PRECISION VERSION WITH VECTOR CALLS
C
IMPLICIT INTEGER*2(I-N),REAL*4(A-H,O-Z)
DIMENSION A(N,N),B(N),X(N),JPIVOT(N)
DATA SMALL/1.E-35/
C
C CHECK FOR ERRORS
C
IER=0
IF(N.LT.1) GO TO 900
C
C N=1 SIMULTANEOUS EQUATIONS
C
IF(N.GT.1) GO TO 100
AA=A(1,1)
IF(ABS(AA).LT.SMALL) GO TO 910
X(1)=B(1)/AA
GO TO 999
C
C N>1 SIMULTANEOUS EQUATIONS
C
100 N1=N-1
C
C INITIALIZE THE PIVOT VECTOR
C
DO 110 I=1,N
110 JPIVOT(I)=I
C
C TRANSPOSE MATRIX
C
DO 120 I=1,N1
I1=I+1
120 CALL VSWP(A(I,I1),N,A(I1,I),1,N-I)
C
C REDUCE THE MATRIX TO UPPER TRIANGULAR FORM
C
DO 160 K=1,N1
K1=K+1
C
C LOCATE THE LARGEST ELEMENT IN THE REDUCED MATRIX
C
CALL VMAB(KK,A(1,K),1,(N-K+1)*N)
KK=KK+(K-1)*N
IP=(KK-1)/N+1
JP=KK-(IP-1)*N
C
C SWAP ROWS TO MOVE THE LARGEST ELEMENT INTO THE PIVOT POSITION
C
IF(IP.EQ.K) GO TO 130
BB=B(K)
B(K)=B(IP)
B(IP)=BB
C
CALL VSWP(A(1,IP),1,A(1,K),1,N)
C
C SWAP COLUMNS TO MOVE THE LARGEST ELEMENT INTO THE PIVOT POSITION
C
130 IF(JP.EQ.K) GO TO 140
JJ=JPIVOT(JP)
JPIVOT(JP)=JPIVOT(K)
JPIVOT(K)=JJ
C
CALL VSWP(A(JP,1),N,A(K,1),N,N)
C
C NORMALIZE THE ROW
C
140 DO 150 I=K1,N
R=A(K,I)/A(K,K)
IF(ABS(R).LT.SMALL) GO TO 150
B(I)=B(I)-R*B(K)
CALL VPIV(-R,A(K1,K),1,A(K1,I),1,A(K1,I),1,N-K)
150 A(K,I)=0.
C
160 CONTINUE
C
C FINAL PIVOT ELEMENT
C
AA=A(N,N)
IF(ABS(AA).LT.SMALL) GO TO 910
C
C BACKSOLVE THE UPPER TRIANGULAR MATRIX
C
X(N)=B(N)/AA
C
DO 170 IN=2,N
I=N+1-IN
I1=I+1
CALL VDOT(XI,A(I1,I),1,X(I1),1,N-I)
170 X(I)=(B(I)-XI)/A(I,I)
C
C PIVOT BACK TO THE ORIGINAL ORDER
C
CALL VMOV(X,1,B,1,N)
C
DO 180 I=1,N
180 X(JPIVOT(I))=B(I)
GO TO 999
C
900 IER=1
GO TO 999
C
910 IER=2
C
999 RETURN
END
.ee