mirror of
https://git.planet-casio.com/Lephenixnoir/OpenLibm.git
synced 2025-01-01 06:23:39 +01:00
146 lines
4.4 KiB
Fortran
146 lines
4.4 KiB
Fortran
*DECK STRSL
|
|
SUBROUTINE STRSL (T, LDT, N, B, JOB, INFO)
|
|
C***BEGIN PROLOGUE STRSL
|
|
C***PURPOSE Solve a system of the form T*X=B or TRANS(T)*X=B, where
|
|
C T is a triangular matrix.
|
|
C***LIBRARY SLATEC (LINPACK)
|
|
C***CATEGORY D2A3
|
|
C***TYPE SINGLE PRECISION (STRSL-S, DTRSL-D, CTRSL-C)
|
|
C***KEYWORDS LINEAR ALGEBRA, LINPACK, TRIANGULAR LINEAR SYSTEM,
|
|
C TRIANGULAR MATRIX
|
|
C***AUTHOR Stewart, G. W., (U. of Maryland)
|
|
C***DESCRIPTION
|
|
C
|
|
C STRSL solves systems of the form
|
|
C
|
|
C T * X = B
|
|
C or
|
|
C TRANS(T) * X = B
|
|
C
|
|
C where T is a triangular matrix of order N. Here TRANS(T)
|
|
C denotes the transpose of the matrix T.
|
|
C
|
|
C On Entry
|
|
C
|
|
C T REAL(LDT,N)
|
|
C T contains the matrix of the system. The zero
|
|
C elements of the matrix are not referenced, and
|
|
C the corresponding elements of the array can be
|
|
C used to store other information.
|
|
C
|
|
C LDT INTEGER
|
|
C LDT is the leading dimension of the array T.
|
|
C
|
|
C N INTEGER
|
|
C N is the order of the system.
|
|
C
|
|
C B REAL(N).
|
|
C B contains the right hand side of the system.
|
|
C
|
|
C JOB INTEGER
|
|
C JOB specifies what kind of system is to be solved.
|
|
C If JOB is
|
|
C
|
|
C 00 solve T*X=B, T lower triangular,
|
|
C 01 solve T*X=B, T upper triangular,
|
|
C 10 solve TRANS(T)*X=B, T lower triangular,
|
|
C 11 solve TRANS(T)*X=B, T upper triangular.
|
|
C
|
|
C On Return
|
|
C
|
|
C B B contains the solution, if INFO .EQ. 0.
|
|
C Otherwise B is unaltered.
|
|
C
|
|
C INFO INTEGER
|
|
C INFO contains zero if the system is nonsingular.
|
|
C Otherwise INFO contains the index of
|
|
C the first zero diagonal element of T.
|
|
C
|
|
C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
|
|
C Stewart, LINPACK Users' Guide, SIAM, 1979.
|
|
C***ROUTINES CALLED SAXPY, SDOT
|
|
C***REVISION HISTORY (YYMMDD)
|
|
C 780814 DATE WRITTEN
|
|
C 890831 Modified array declarations. (WRB)
|
|
C 890831 REVISION DATE from Version 3.2
|
|
C 891214 Prologue converted to Version 4.0 format. (BAB)
|
|
C 900326 Removed duplicate information from DESCRIPTION section.
|
|
C (WRB)
|
|
C 920501 Reformatted the REFERENCES section. (WRB)
|
|
C***END PROLOGUE STRSL
|
|
INTEGER LDT,N,JOB,INFO
|
|
REAL T(LDT,*),B(*)
|
|
C
|
|
C
|
|
REAL SDOT,TEMP
|
|
INTEGER CASE,J,JJ
|
|
C***FIRST EXECUTABLE STATEMENT STRSL
|
|
C
|
|
C CHECK FOR ZERO DIAGONAL ELEMENTS.
|
|
C
|
|
DO 10 INFO = 1, N
|
|
IF (T(INFO,INFO) .EQ. 0.0E0) GO TO 150
|
|
10 CONTINUE
|
|
INFO = 0
|
|
C
|
|
C DETERMINE THE TASK AND GO TO IT.
|
|
C
|
|
CASE = 1
|
|
IF (MOD(JOB,10) .NE. 0) CASE = 2
|
|
IF (MOD(JOB,100)/10 .NE. 0) CASE = CASE + 2
|
|
GO TO (20,50,80,110), CASE
|
|
C
|
|
C SOLVE T*X=B FOR T LOWER TRIANGULAR
|
|
C
|
|
20 CONTINUE
|
|
B(1) = B(1)/T(1,1)
|
|
IF (N .LT. 2) GO TO 40
|
|
DO 30 J = 2, N
|
|
TEMP = -B(J-1)
|
|
CALL SAXPY(N-J+1,TEMP,T(J,J-1),1,B(J),1)
|
|
B(J) = B(J)/T(J,J)
|
|
30 CONTINUE
|
|
40 CONTINUE
|
|
GO TO 140
|
|
C
|
|
C SOLVE T*X=B FOR T UPPER TRIANGULAR.
|
|
C
|
|
50 CONTINUE
|
|
B(N) = B(N)/T(N,N)
|
|
IF (N .LT. 2) GO TO 70
|
|
DO 60 JJ = 2, N
|
|
J = N - JJ + 1
|
|
TEMP = -B(J+1)
|
|
CALL SAXPY(J,TEMP,T(1,J+1),1,B(1),1)
|
|
B(J) = B(J)/T(J,J)
|
|
60 CONTINUE
|
|
70 CONTINUE
|
|
GO TO 140
|
|
C
|
|
C SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR.
|
|
C
|
|
80 CONTINUE
|
|
B(N) = B(N)/T(N,N)
|
|
IF (N .LT. 2) GO TO 100
|
|
DO 90 JJ = 2, N
|
|
J = N - JJ + 1
|
|
B(J) = B(J) - SDOT(JJ-1,T(J+1,J),1,B(J+1),1)
|
|
B(J) = B(J)/T(J,J)
|
|
90 CONTINUE
|
|
100 CONTINUE
|
|
GO TO 140
|
|
C
|
|
C SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR.
|
|
C
|
|
110 CONTINUE
|
|
B(1) = B(1)/T(1,1)
|
|
IF (N .LT. 2) GO TO 130
|
|
DO 120 J = 2, N
|
|
B(J) = B(J) - SDOT(J-1,T(1,J),1,B(1),1)
|
|
B(J) = B(J)/T(J,J)
|
|
120 CONTINUE
|
|
130 CONTINUE
|
|
140 CONTINUE
|
|
150 CONTINUE
|
|
RETURN
|
|
END
|