mirror of
https://git.planet-casio.com/Lephenixnoir/OpenLibm.git
synced 2025-01-01 06:23:39 +01:00
52 lines
1.6 KiB
Fortran
52 lines
1.6 KiB
Fortran
*DECK OHTROL
|
|
SUBROUTINE OHTROL (Q, N, NRDA, DIAG, IRANK, DIV, TD)
|
|
C***BEGIN PROLOGUE OHTROL
|
|
C***SUBSIDIARY
|
|
C***PURPOSE Subsidiary to BVSUP
|
|
C***LIBRARY SLATEC
|
|
C***TYPE SINGLE 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 ORTHOR and OHTROL
|
|
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 BVSUP
|
|
C***ROUTINES CALLED SDOT
|
|
C***REVISION HISTORY (YYMMDD)
|
|
C 750601 DATE WRITTEN
|
|
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 OHTROL
|
|
DIMENSION Q(NRDA,*),DIAG(*),DIV(*),TD(*)
|
|
C***FIRST EXECUTABLE STATEMENT OHTROL
|
|
NMIR=N-IRANK
|
|
IRP=IRANK+1
|
|
DO 30 K=1,IRANK
|
|
KIR=IRP-K
|
|
DIAGK=DIAG(KIR)
|
|
SIG=(DIAGK*DIAGK)+SDOT(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))+SDOT(NMIR,Q(IRP,J),1,Q(IRP,KIR),1))
|
|
1 /SQD
|
|
Q(KIR,J)=Q(KIR,J)+QS*TDV
|
|
DO 10 L=IRP,N
|
|
10 Q(L,J)=Q(L,J)+QS*Q(L,KIR)
|
|
20 CONTINUE
|
|
30 CONTINUE
|
|
RETURN
|
|
END
|