mirror of
https://git.planet-casio.com/Lephenixnoir/OpenLibm.git
synced 2025-01-01 06:23:39 +01:00
131 lines
3.7 KiB
Fortran
131 lines
3.7 KiB
Fortran
*DECK LA05BS
|
|
SUBROUTINE LA05BS (A, IND, IA, N, IP, IW, W, G, B, TRANS)
|
|
C***BEGIN PROLOGUE LA05BS
|
|
C***SUBSIDIARY
|
|
C***PURPOSE Subsidiary to SPLP
|
|
C***LIBRARY SLATEC
|
|
C***TYPE SINGLE PRECISION (LA05BS-S, LA05BD-D)
|
|
C***AUTHOR (UNKNOWN)
|
|
C***DESCRIPTION
|
|
C
|
|
C THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM
|
|
C FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE
|
|
C CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING
|
|
C THE FINAL LETTER =S= IN THE NAMES USED HERE.
|
|
C REVISED SEP. 13, 1979.
|
|
C
|
|
C ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES
|
|
C IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL
|
|
C SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN
|
|
C THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES
|
|
C SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED.
|
|
C
|
|
C IP(I,1),IP(I,2) POINT TO START OF ROW/COLUMN I OF U.
|
|
C IW(I,1),IW(I,2) ARE LENGTHS OF ROW/COL I OF U.
|
|
C IW(.,3),IW(.,4) HOLD ROW/COL NUMBERS IN PIVOTAL ORDER.
|
|
C
|
|
C***SEE ALSO SPLP
|
|
C***ROUTINES CALLED XERMSG, XSETUN
|
|
C***COMMON BLOCKS LA05DS
|
|
C***REVISION HISTORY (YYMMDD)
|
|
C 811215 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 900402 Added TYPE section. (WRB)
|
|
C 920410 Corrected second dimension on IW declaration. (WRB)
|
|
C***END PROLOGUE LA05BS
|
|
REAL A(IA), B(*), AM, W(*), G, SMALL
|
|
LOGICAL TRANS
|
|
INTEGER IND(IA,2), IW(N,8)
|
|
INTEGER IP(N,2)
|
|
COMMON /LA05DS/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL
|
|
C***FIRST EXECUTABLE STATEMENT LA05BS
|
|
IF (G.LT.0.) GO TO 130
|
|
KLL = IA - LENL + 1
|
|
IF (TRANS) GO TO 80
|
|
C
|
|
C MULTIPLY VECTOR BY INVERSE OF L
|
|
IF (LENL.LE.0) GO TO 20
|
|
L1 = IA + 1
|
|
DO 10 KK=1,LENL
|
|
K = L1 - KK
|
|
I = IND(K,1)
|
|
IF (B(I).EQ.0.) GO TO 10
|
|
J = IND(K,2)
|
|
B(J) = B(J) + A(K)*B(I)
|
|
10 CONTINUE
|
|
20 DO 30 I=1,N
|
|
W(I) = B(I)
|
|
B(I) = 0.
|
|
30 CONTINUE
|
|
C
|
|
C MULTIPLY VECTOR BY INVERSE OF U
|
|
N1 = N + 1
|
|
DO 70 II=1,N
|
|
I = N1 - II
|
|
I = IW(I,3)
|
|
AM = W(I)
|
|
KP = IP(I,1)
|
|
IF (KP.GT.0) GO TO 50
|
|
KP = -KP
|
|
IP(I,1) = KP
|
|
NZ = IW(I,1)
|
|
KL = KP - 1 + NZ
|
|
K2 = KP + 1
|
|
DO 40 K=K2,KL
|
|
J = IND(K,2)
|
|
AM = AM - A(K)*B(J)
|
|
40 CONTINUE
|
|
50 IF (AM.EQ.0.) GO TO 70
|
|
J = IND(KP,2)
|
|
B(J) = AM/A(KP)
|
|
KPC = IP(J,2)
|
|
KL = IW(J,2) + KPC - 1
|
|
IF (KL.EQ.KPC) GO TO 70
|
|
K2 = KPC + 1
|
|
DO 60 K=K2,KL
|
|
I = IND(K,1)
|
|
IP(I,1) = -ABS(IP(I,1))
|
|
60 CONTINUE
|
|
70 CONTINUE
|
|
GO TO 140
|
|
C
|
|
C MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF U
|
|
80 DO 90 I=1,N
|
|
W(I) = B(I)
|
|
B(I) = 0.
|
|
90 CONTINUE
|
|
DO 110 II=1,N
|
|
I = IW(II,4)
|
|
AM = W(I)
|
|
IF (AM.EQ.0.) GO TO 110
|
|
J = IW(II,3)
|
|
KP = IP(J,1)
|
|
AM = AM/A(KP)
|
|
B(J) = AM
|
|
KL = IW(J,1) + KP - 1
|
|
IF (KP.EQ.KL) GO TO 110
|
|
K2 = KP + 1
|
|
DO 100 K=K2,KL
|
|
I = IND(K,2)
|
|
W(I) = W(I) - AM*A(K)
|
|
100 CONTINUE
|
|
110 CONTINUE
|
|
C
|
|
C MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF L
|
|
IF (KLL.GT.IA) RETURN
|
|
DO 120 K=KLL,IA
|
|
J = IND(K,2)
|
|
IF (B(J).EQ.0.) GO TO 120
|
|
I = IND(K,1)
|
|
B(I) = B(I) + A(K)*B(J)
|
|
120 CONTINUE
|
|
GO TO 140
|
|
C
|
|
130 CALL XSETUN(LP)
|
|
IF (LP .GT. 0) CALL XERMSG ('SLATEC', 'LA05BS',
|
|
+ 'EARLIER ENTRY GAVE ERROR RETURN.', -8, 2)
|
|
140 RETURN
|
|
END
|