mirror of
https://git.planet-casio.com/Lephenixnoir/OpenLibm.git
synced 2025-01-01 06:23:39 +01:00
58 lines
2 KiB
Fortran
58 lines
2 KiB
Fortran
*DECK DOHTRL
|
|
SUBROUTINE DOHTRL (Q, N, NRDA, DIAG, IRANK, DIV, TD)
|
|
C***BEGIN PROLOGUE DOHTRL
|
|
C***SUBSIDIARY
|
|
C***PURPOSE Subsidiary to DBVSUP and DSUDS
|
|
C***LIBRARY SLATEC
|
|
C***TYPE DOUBLE PRECISION (OHTROL-S, DOHTRL-D)
|
|
C***AUTHOR Watts, H. A., (SNLA)
|
|
C***DESCRIPTION
|
|
C
|
|
C For a rank deficient problem, additional orthogonal
|
|
C HOUSEHOLDER transformations are applied to the left side
|
|
C of Q to further reduce the triangular form.
|
|
C Thus, after application of the routines DORTHR and DOHTRL
|
|
C to the original matrix, the result is a nonsingular
|
|
C triangular matrix while the remainder of the matrix
|
|
C has been zeroed out.
|
|
C
|
|
C***SEE ALSO DBVSUP, DSUDS
|
|
C***ROUTINES CALLED DDOT
|
|
C***REVISION HISTORY (YYMMDD)
|
|
C 750601 DATE WRITTEN
|
|
C 890531 Changed all specific intrinsics to generic. (WRB)
|
|
C 890831 Modified array declarations. (WRB)
|
|
C 891214 Prologue converted to Version 4.0 format. (BAB)
|
|
C 900328 Added TYPE section. (WRB)
|
|
C 910722 Updated AUTHOR section. (ALS)
|
|
C***END PROLOGUE DOHTRL
|
|
DOUBLE PRECISION DDOT
|
|
INTEGER IRANK, IRP, J, K, KIR, KIRM, L, N, NMIR, NRDA
|
|
DOUBLE PRECISION DD, DIAG(*), DIAGK, DIV(*), Q(NRDA,*), QS, SIG,
|
|
1 SQD, TD(*), TDV
|
|
C***FIRST EXECUTABLE STATEMENT DOHTRL
|
|
NMIR = N - IRANK
|
|
IRP = IRANK + 1
|
|
DO 40 K = 1, IRANK
|
|
KIR = IRP - K
|
|
DIAGK = DIAG(KIR)
|
|
SIG = (DIAGK*DIAGK) + DDOT(NMIR,Q(IRP,KIR),1,Q(IRP,KIR),1)
|
|
DD = SIGN(SQRT(SIG),-DIAGK)
|
|
DIV(KIR) = DD
|
|
TDV = DIAGK - DD
|
|
TD(KIR) = TDV
|
|
IF (K .EQ. IRANK) GO TO 30
|
|
KIRM = KIR - 1
|
|
SQD = DD*DIAGK - SIG
|
|
DO 20 J = 1, KIRM
|
|
QS = ((TDV*Q(KIR,J))
|
|
1 + DDOT(NMIR,Q(IRP,J),1,Q(IRP,KIR),1))/SQD
|
|
Q(KIR,J) = Q(KIR,J) + QS*TDV
|
|
DO 10 L = IRP, N
|
|
Q(L,J) = Q(L,J) + QS*Q(L,KIR)
|
|
10 CONTINUE
|
|
20 CONTINUE
|
|
30 CONTINUE
|
|
40 CONTINUE
|
|
RETURN
|
|
END
|