Fcalva/OpenLibm
1
0
Fork 0
mirror of https://git.planet-casio.com/Lephenixnoir/OpenLibm.git synced 2025-01-01 06:23:39 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions
OpenLibm/slatec/u11us.f
Viral B. Shah c977aa998f Add Makefile.extras to build libopenlibm-extras. 
Replace amos with slatec
2012-12-31 16:37:05 -05:00

291 lines
6.6 KiB
Fortran
Raw Blame History

*DECK U11US
SUBROUTINE U11US (A, MDA, M, N, UB, DB, MODE, NP, KRANK, KSURE, H,
+ W, EB, IR, IC)
C***BEGIN PROLOGUE U11US
C***SUBSIDIARY
C***PURPOSE Subsidiary to ULSIA
C***LIBRARY SLATEC
C***TYPE SINGLE PRECISION (U11US-S, DU11US-D)
C***AUTHOR (UNKNOWN)
C***DESCRIPTION
C
C This routine performs an LQ factorization of the
C matrix A using Householder transformations. Row
C and column pivots are chosen to reduce the growth
C of round-off and to help detect possible rank
C deficiency.
C
C***SEE ALSO ULSIA
C***ROUTINES CALLED ISAMAX, ISWAP, SAXPY, SDOT, SNRM2, SSCAL, SSWAP,
C XERMSG
C***REVISION HISTORY (YYMMDD)
C 810801 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 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ)
C 900328 Added TYPE section. (WRB)
C***END PROLOGUE U11US
DIMENSION A(MDA,*),UB(*),DB(*),H(*),W(*),EB(*)
INTEGER IC(*),IR(*)
C
C INITIALIZATION
C
C***FIRST EXECUTABLE STATEMENT U11US
J=0
KRANK=M
DO 10 I=1,N
IC(I)=I
10 CONTINUE
DO 12 I=1,M
IR(I)=I
12 CONTINUE
C
C DETERMINE REL AND ABS ERROR VECTORS
C
C
C
C CALCULATE ROW LENGTH
C
DO 30 I=1,M
H(I)=SNRM2(N,A(I,1),MDA)
W(I)=H(I)
30 CONTINUE
C
C INITIALIZE ERROR BOUNDS
C
DO 40 I=1,M
EB(I)=MAX(DB(I),UB(I)*H(I))
UB(I)=EB(I)
DB(I)=0.0
40 CONTINUE
C
C DISCARD SELF DEPENDENT ROWS
C
I=1
50 IF(EB(I).GE.H(I)) GO TO 60
IF(I.EQ.KRANK) GO TO 70
I=I+1
GO TO 50
C
C MATRIX REDUCTION
C
60 CONTINUE
KK=KRANK
KRANK=KRANK-1
IF(MODE.EQ.0) RETURN
IF(I.GT.NP) GO TO 64
CALL XERMSG ('SLATEC', 'U11US',
+ 'FIRST NP ROWS ARE LINEARLY DEPENDENT', 8, 0)
KRANK=I-1
RETURN
64 CONTINUE
IF(I.GT.KRANK) GO TO 70
CALL SSWAP(1,EB(I),1,EB(KK),1)
CALL SSWAP(1,UB(I),1,UB(KK),1)
CALL SSWAP(1,W(I),1,W(KK),1)
CALL SSWAP(1,H(I),1,H(KK),1)
CALL ISWAP(1,IR(I),1,IR(KK),1)
CALL SSWAP(N,A(I,1),MDA,A(KK,1),MDA)
GO TO 50
C
C TEST FOR ZERO RANK
C
70 IF(KRANK.GT.0) GO TO 80
KRANK=0
KSURE=0
RETURN
80 CONTINUE
C
C M A I N L O O P
C
110 CONTINUE
J=J+1
JP1=J+1
JM1=J-1
KZ=KRANK
IF(J.LE.NP) KZ=J
C
C EACH ROW HAS NN=N-J+1 COMPONENTS
C
NN=N-J+1
C
C UB DETERMINES ROW PIVOT
C
115 IMIN=J
IF(H(J).EQ.0.) GO TO 170
RMIN=UB(J)/H(J)
DO 120 I=J,KZ
IF(UB(I).GE.H(I)*RMIN) GO TO 120
RMIN=UB(I)/H(I)
IMIN=I
120 CONTINUE
C
C TEST FOR RANK DEFICIENCY
C
IF(RMIN.LT.1.0) GO TO 200
TT=(EB(IMIN)+ABS(DB(IMIN)))/H(IMIN)
IF(TT.GE.1.0) GO TO 170
C COMPUTE EXACT UB
DO 125 I=1,JM1
W(I)=A(IMIN,I)
125 CONTINUE
L=JM1
130 W(L)=W(L)/A(L,L)
IF(L.EQ.1) GO TO 150
LM1=L-1
DO 140 I=L,JM1
W(LM1)=W(LM1)-A(I,LM1)*W(I)
140 CONTINUE
L=LM1
GO TO 130
150 TT=EB(IMIN)
DO 160 I=1,JM1
TT=TT+ABS(W(I))*EB(I)
160 CONTINUE
UB(IMIN)=TT
IF(UB(IMIN)/H(IMIN).GE.1.0) GO TO 170
GO TO 200
C
C MATRIX REDUCTION
C
170 CONTINUE
KK=KRANK
KRANK=KRANK-1
KZ=KRANK
IF(MODE.EQ.0) RETURN
IF(J.GT.NP) GO TO 172
CALL XERMSG ('SLATEC', 'U11US',
+ 'FIRST NP ROWS ARE LINEARLY DEPENDENT', 8, 0)
KRANK=J-1
RETURN
172 CONTINUE
IF(IMIN.GT.KRANK) GO TO 180
CALL ISWAP(1,IR(IMIN),1,IR(KK),1)
CALL SSWAP(N,A(IMIN,1),MDA,A(KK,1),MDA)
CALL SSWAP(1,EB(IMIN),1,EB(KK),1)
CALL SSWAP(1,UB(IMIN),1,UB(KK),1)
CALL SSWAP(1,DB(IMIN),1,DB(KK),1)
CALL SSWAP(1,W(IMIN),1,W(KK),1)
CALL SSWAP(1,H(IMIN),1,H(KK),1)
180 IF(J.GT.KRANK) GO TO 300
GO TO 115
C
C ROW PIVOT
C
200 IF(IMIN.EQ.J) GO TO 230
CALL SSWAP(1,H(J),1,H(IMIN),1)
CALL SSWAP(N,A(J,1),MDA,A(IMIN,1),MDA)
CALL SSWAP(1,EB(J),1,EB(IMIN),1)
CALL SSWAP(1,UB(J),1,UB(IMIN),1)
CALL SSWAP(1,DB(J),1,DB(IMIN),1)
CALL SSWAP(1,W(J),1,W(IMIN),1)
CALL ISWAP(1,IR(J),1,IR(IMIN),1)
C
C COLUMN PIVOT
C
230 CONTINUE
JMAX=ISAMAX(NN,A(J,J),MDA)
JMAX=JMAX+J-1
IF(JMAX.EQ.J) GO TO 240
CALL SSWAP(M,A(1,J),1,A(1,JMAX),1)
CALL ISWAP(1,IC(J),1,IC(JMAX),1)
240 CONTINUE
C
C APPLY HOUSEHOLDER TRANSFORMATION
C
TN=SNRM2(NN,A(J,J),MDA)
IF(TN.EQ.0.0) GO TO 170
IF(A(J,J).NE.0.0) TN=SIGN(TN,A(J,J))
CALL SSCAL(NN,1.0/TN,A(J,J),MDA)
A(J,J)=A(J,J)+1.0
IF(J.EQ.M) GO TO 250
DO 248 I=JP1,M
BB=-SDOT(NN,A(J,J),MDA,A(I,J),MDA)/A(J,J)
CALL SAXPY(NN,BB,A(J,J),MDA,A(I,J),MDA)
IF(I.LE.NP) GO TO 248
IF(H(I).EQ.0.0) GO TO 248
TT=1.0-(ABS(A(I,J))/H(I))**2
TT=MAX(TT,0.0)
T=TT
TT=1.0+.05*TT*(H(I)/W(I))**2
IF(TT.EQ.1.0) GO TO 244
H(I)=H(I)*SQRT(T)
GO TO 246
244 CONTINUE
H(I)=SNRM2(N-J,A(I,J+1),MDA)
W(I)=H(I)
246 CONTINUE
248 CONTINUE
250 CONTINUE
H(J)=A(J,J)
A(J,J)=-TN
C
C
C UPDATE UB, DB
C
UB(J)=UB(J)/ABS(A(J,J))
DB(J)=(SIGN(EB(J),DB(J))+DB(J))/A(J,J)
IF(J.EQ.KRANK) GO TO 300
DO 260 I=JP1,KRANK
UB(I)=UB(I)+ABS(A(I,J))*UB(J)
DB(I)=DB(I)-A(I,J)*DB(J)
260 CONTINUE
GO TO 110
C
C E N D M A I N L O O P
C
300 CONTINUE
C
C COMPUTE KSURE
C
KM1=KRANK-1
DO 318 I=1,KM1
IS=0
KMI=KRANK-I
DO 315 II=1,KMI
IF(UB(II).LE.UB(II+1)) GO TO 315
IS=1
TEMP=UB(II)
UB(II)=UB(II+1)
UB(II+1)=TEMP
315 CONTINUE
IF(IS.EQ.0) GO TO 320
318 CONTINUE
320 CONTINUE
KSURE=0
SUM=0.0
DO 328 I=1,KRANK
R2=UB(I)*UB(I)
IF(R2+SUM.GE.1.0) GO TO 330
SUM=SUM+R2
KSURE=KSURE+1
328 CONTINUE
330 CONTINUE
C
C IF SYSTEM IS OF REDUCED RANK AND MODE = 2
C COMPLETE THE DECOMPOSITION FOR SHORTEST LEAST SQUARES SOLUTION
C
IF(KRANK.EQ.M .OR. MODE.LT.2) GO TO 360
MMK=M-KRANK
KP1=KRANK+1
I=KRANK
340 TN=SNRM2(MMK,A(KP1,I),1)/A(I,I)
TN=A(I,I)*SQRT(1.0+TN*TN)
CALL SSCAL(MMK,1.0/TN,A(KP1,I),1)
W(I)=A(I,I)/TN+1.0
A(I,I)=-TN
IF(I.EQ.1) GO TO 350
IM1=I-1
DO 345 II=1,IM1
TT=-SDOT(MMK,A(KP1,II),1,A(KP1,I),1)/W(I)
TT=TT-A(I,II)
CALL SAXPY(MMK,TT,A(KP1,I),1,A(KP1,II),1)
A(I,II)=A(I,II)+TT*W(I)
345 CONTINUE
I=I-1
GO TO 340
350 CONTINUE
360 CONTINUE
RETURN
END
Reference in a new issue View git blame Copy permalink