SUBROUTINE CEPSPM(AP,N,B,KPVT,RCOND,Z,WK)
C
C*****************************************************************
C *
C Condition estimate for a symmetric matrix AP which is given*
C in factored and condensed form from SUBROUTINE ZSPMMK. *
C If a condition estimate is not required, the SUBROUTINE *
C ZSPMOK is more time efficient. *
C In order to solve A*X = B, a subsequent call of SESSPM *
C is necessary with WK as input matrix. *
C *
C *
C INPUT PARAMETERS: *
C ================= *
C AP DOUBLE PRECISION vector AP(1:N*(N+1)/2), that *
C contains the symmetric matrix A in condensed form. *
C The columns of the upper triangle of A are stored in *
C sequence in the vector AP as subvectors of length *
C N*(N+1)/2 *
C N dimension of the matrix A *
C B DOUBLE PRECISION vector B(1:N) containing the *
C right-hand side of the system of equations A*X = B. *
C The right-hand side is required for the SUBROUTINE *
C ZSPMMK, since the decomposition and possible alter- *
C ation of the right-hand side is performed in this *
C subroutine in order to save arithmetic operations. *
C *
C *
C OUTPUT PARAMETERS: *
C ================== *
C AP DOUBLE PRECISION vector AP(1:N*(N+1)/2), representing*
C a block diagonal matrix that contains the factors of *
C a decomposition in condensed form. The decomposition *
C is given as A = U*D*TRANS(U). Here U is the product *
C of the permutation matrix and a unit upper triangular*
C matrix, TRANS(U) denotes the transpose of U and D is *
C a block diagonal matrix composed of 1 x 1 and 2 x 2 *
C blocks *
C KPVT INTEGER vector KPVT(1:N) containing the PIVOT indices*
C RCOND DOUBLE PRECISION estimate of the reciprocal condi- *
C tion number of A. For the system A*X = B, with *
C relative input errors of size EPSILON in A and B, *
C the relative error in the solution X will have the *
C size EPSILON/RCOND. *
C If RCOND is smaller than the machine constant, then *
C the matrix A is numerically singular. *
C Z DOUBLE PRECISION auxiliary vector Z(1:N). Usually *
C the contents of Z has no significance. In case A is *
C close to being singular then Z is an approximated *
C null-vector for A, i.e., *
C NORM(A*Z) = RCOND*NORM(A)*NORM(Z). *
C B DOUBLE PRECISION vector B(1:N) containing the right- *
C side of the system of equations A*X = B for use in *
C the SUBROUTINE SESSPM in the necessary form. *
C WK DOUBLE PRECISION vector WK(1:N*(N+1)/2) (input *
C parameter for SESSPM), auxiliary vector containing *
C entries that are required for solving the system of *
C equations A*X = B. This way the solution of A*X = B*
C can be determined in one, instead of two elimination *
C steps by the SUBROUTINE SESSPM. *
C *
C *
C condensed form *
C *
C The following code condenses the upper triangular *
C part of a symmetric matrix A to a vector AP *
C *
C K = 0 *
C DO 20 J = 1, N *
C DO 10 I= 1, N *
C K = K + 1 *
C AP(K) = A(I,J) *
C 10 CONTINUE *
C 20 CONTINUE *
C *
C----------------------------------------------------------------*
C *
C subroutines required: ZSPMMK, PCOSOL, PCOLTG, VECADD, *
C VECMWC, SCAPRO, ABSSUM, INDMAX, *
C VECXCH *
C *
C *
C source : Linpack User's Guide, SIAM, Philadelphia, 1979 *
C *
C The source was converted to FORTRAN 77. In some *
C instances it had to be modified and adjusted for *
C the requirements of our specific calling programs.*
C This program and the corresponding subprograms *
C are not compatible with the originals from the *
C Linpack User's Guide. *
C *
C*****************************************************************
C *
C authors : Michael Groenheim, Ina Hinze *
C date : 10.25.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
INTEGER N,KPVT(N)
DOUBLE PRECISION AP(N*(N+1)/2),Z(N),B(N),WK(N*(N+1)/2)
DOUBLE PRECISION RCOND
DOUBLE PRECISION EK,ANORM,S,ABSSUM,YNORM
INTEGER I,IJ,IERR,J,JM1,J1
C
C determine the norm of A making use of symmetry
C
J1 = 1
DO 20 J = 1, N
Z(J) = ABSSUM(J,AP(J1))
IJ = J1
J1 = J1 + J
JM1 = J - 1
IF (JM1 .GE. 1) THEN
DO 10 I = 1, JM1
Z(I) = Z(I) + DABS(AP(IJ))
IJ = IJ + 1
10 CONTINUE
ENDIF
20 CONTINUE
ANORM = 0.0D0
DO 30 J = 1, N
ANORM = DMAX1(ANORM,Z(J))
30 CONTINUE
IF (ANORM .EQ. 0.0D0) THEN
RCOND = 0.0D0
RETURN
ENDIF
C
C factor the matrix by using SUBROUTINE ZSPMMK
C
CALL ZSPMMK(AP,N,B,KPVT,WK,IERR)
C
C RCOND = 1/(NORM(A)*(ESTIMATE OF THE NORM(INVERSE(A)))).
C ESTIMATE = NORM(Z)/NORM(Y). Here A*Z = Y and A*Y = E.
C The elements of E are chosen in such a way that the elements
C of W become as large as possible, where U*D*W = E.
C
EK = 1.0D0
DO 40 J = 1, N
Z(J) = 0.0D0
40 CONTINUE
C
C solve U*D*W = E
C
CALL PCOSOL (1,AP,N,Z,KPVT,S,EK,YNORM)
C
C solve TRANS(U) * Y = W
C
CALL PCOLTG(AP,N,Z,KPVT,S)
S = 1.0D0/ABSSUM(N,Z)
CALL VECMWC(N,S,Z)
C
YNORM = 1.0D0
C
C solve U*D*V = Y
C
CALL PCOSOL (2,AP,N,Z,KPVT,S,EK,YNORM)
C
C solve TRANS(U) * Z = V
C
CALL PCOLTG(AP,N,Z,KPVT,S)
YNORM = S * YNORM
C
C set ZNORM = 1.0
C
S = 1.0D0/ABSSUM(N,Z)
CALL VECMWC(N,S,Z)
YNORM = S*YNORM
C
RCOND = YNORM/ANORM
RETURN
END
C
C
SUBROUTINE ZSPMMK (AP,N,B,KPVT,WK,IERR)
C
C*****************************************************************
C *
C Factorization of a symmetric matrix, given in condensed *
C format, by elimination that relies on symmetric pivoting. *
C If a condition estimate is not required, the SUBROUTINE *
C ZSPMOK will perform the task faster. *
C In order to solve A*X = B the subsequent call of SESSPM is *
C necessary. *
C *
C *
C INPUT PARAMETERS: *
C ================= *
C AP DOUBLE PRECISION vector AP(1:(N*(N+1)/2)), contain- *
C ing the symmetric matrix A in condensed form. *
C The columns of its upper triangle are stored sequen- *
C tially in the vector AP of length N*(N+1)/2 *
C N dimension of the matrix A *
C B DOUBLE PRECISION vector B(1:N), the right-hand side. *
C The right-hand side is required in SUBROUTINE ZSPMMK *
C in order to save arithmetic operations. *
C *
C *
C OUTPUT PARAMETERS: *
C ================== *
C AP DOUBLE PRECISION vector AP(1:N*(N+1)/2), representing*
C a block diagonal matrix that contains the factors of *
C a decomposition in condensed form. The decomposition *
C is given as A = U*D*TRANS(U). Here U is the product *
C of the permutation matrix and a unit upper triangular*
C matrix, TRANS(U) denotes the transpose of U and D is *
C a block diagonal matrix composed of 1 x 1 and 2 x 2 *
C blocks *
C KPVT INTEGER vector KPVT(1:N) containing the PIVOT indices*
C B DOUBLE PRECISION vector B(1:N) containing the right- *
C side of the system of equations A*X = B for use in *
C the SUBROUTINE SESSPM in the necessary form. *
C WK DOUBLE PRECISION vector WK(1:N*(N+1)/2) (input *
C parameter for SESSPM), auxiliary vector containing *
C entries that are required for solving the system of *
C equations A*X = B. This way the solution of A*X = B*
C can be determined in one, instead of two elimination *
C steps by the SUBROUTINE SESSPM. *
C IERR error parameter *
C = 0, everything is o.k *
C = K, the K-th PIVOT block is singular. *
C For the current subroutine, this does not denote*
C an error; however, it indicates that the *
C SUBROUTINE SESSPM may encounter division by zero*
C *
C *
C condensed form *
C *
C The following code condenses the upper triangular *
C part of a symmetric matrix A to a vector AP *
C *
C K = 0 *
C DO 20 J = 1, N *
C DO 10 I= 1, N *
C K = K + 1 *
C AP(K) = A(I,J) *
C 10 CONTINUE *
C 20 CONTINUE *
C 20 CONTINUE *
C *
C----------------------------------------------------------------*
C *
C subroutines required: VECADD, VECXCH, INDMAX *
C *
C *
C source : Linpack User's Guide, SIAM, Philadelphia, 1979 *
C *
C*****************************************************************
C *
C authors : Michael Groenheim, Ina Hinze *
C date : 10.25.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
INTEGER N,KPVT(N),IERR
DOUBLE PRECISION AP(N*(N+1)/2),B(N),WK(N*(N+1)/2)
DOUBLE PRECISION D,D1,D2,T
DOUBLE PRECISION ABSAKK,ALPHA,COLMAX,ROWMAX
INTEGER INDMAX,IJ,IJJ,IK,IKM1,IM,IMAX,IMAXP1,IMIM,IMJ,IMK
INTEGER J,JJ,JK,JKM1,JMAX,JMIM,K,KK,KM1,KM1K,KM1KM1,KM2,KSTEP
LOGICAL SWAP
C
C store condensed vector AP in auxiliary vector WK
C
DO 5 I = 1,N*(N+1)/2
WK(I) = AP(I)
5 CONTINUE
C
C initialization
C
C ALPHA is used to determine the PIVOT block size
C
ALPHA = (1.0D0 + SQRT(17.0D0))/8.0D0
C
IERR = 0
C
C main loop over K; K runs from N back to 1
C
K = N
IK = (N*(N - 1))/2
10 CONTINUE
C
C leave the loop if K=0 or K=1
C
IF (K .EQ. 0) RETURN
IF (K .LE. 1) THEN
KPVT(1) = 1
IF (AP(1) .EQ. 0.0D0) IERR = 1
RETURN
ENDIF
C
C this part of the program determines the elimination method to be
C used. After this part has been executed, KSTEP is set to be the size
C of the PIVOT block and SWAP is set to .TRUE., if swapping is
C necessary.
C
KM1 = K - 1
KK = IK + K
ABSAKK = DABS(AP(KK))
C
C determine the largest off-diagonal element in
C magnitude in column K
C
IMAX = INDMAX(K-1,AP(IK+1))
IMK = IK + IMAX
COLMAX = DABS(AP(IMK))
IF (ABSAKK .LT. ALPHA*COLMAX) THEN
C
C determine the largest off-diagonal element
C in magnitude in row IMAX
C
ROWMAX = 0.0D0
IMAXP1 = IMAX + 1
IM = IMAX*(IMAX - 1)/2
IMJ = IM + 2*IMAX
DO 20 J = IMAXP1, K
ROWMAX = DMAX1(ROWMAX,DABS(AP(IMJ)))
IMJ = IMJ + J
20 CONTINUE
IF (IMAX .NE. 1) THEN
JMAX = INDMAX(IMAX-1,AP(IM+1))
JMIM = JMAX + IM
ROWMAX = DMAX1(ROWMAX,DABS(AP(JMIM)))
ENDIF
IMIM = IMAX + IM
IF (DABS(AP(IMIM)) .LT. ALPHA*ROWMAX) THEN
IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) THEN
KSTEP = 2
SWAP = IMAX .NE. KM1
ELSE
KSTEP = 1
SWAP = .FALSE.
ENDIF
ELSE
KSTEP = 1
SWAP = .TRUE.
ENDIF
ELSE
KSTEP = 1
SWAP = .FALSE.
ENDIF
IF (DMAX1(ABSAKK,COLMAX) .EQ. 0.0D0) THEN
C
C column K is the zero column. Modify IERR and reiterate loop
C
KPVT(K) = K
IERR = K
IK = IK - (K - 1)
IF (KSTEP .EQ. 2) IK = IK - (K - 2)
K = K - KSTEP
GOTO 10
ENDIF
IF (KSTEP .EQ. 2) THEN
C
C 2 x 2 PIVOT block
C
KM1K = IK + K - 1
IKM1 = IK - (K - 1)
IF (SWAP) THEN
C
C perform swap
C
CALL VECXCH(IMAX,AP(IM+1),AP(IKM1+1))
CALL VECXCH(IMAX,WK(IM+1),WK(IKM1+1))
IMJ = IKM1 + IMAX
DO 30 JJ = IMAX, KM1
J = KM1 + IMAX - JJ
JKM1 = IKM1 + J
T = AP(JKM1)
T1 = WK(JKM1)
AP(JKM1) = AP(IMJ)
WK(JKM1) = WK(IMJ)
AP(IMJ) = T
WK(IMJ) = T1
IMJ = IMJ - (J - 1)
30 CONTINUE
T = AP(KM1K)
AP(KM1K) = AP(IMK)
AP(IMK) = T
T = WK(KM1K)
WK(KM1K) = WK(IMK)
WK(IMK) = T
T = B(K-1)
B(K-1) = B(IMAX)
B(IMAX) = T
ENDIF
\hbox{\JDhspace\verb`
C
C perform elimination
C
KM2 = K - 2
IF (KM2 .NE. 0) THEN
KM1KM1 = IKM1 + K - 1
D = AP(KM1K) * AP(KM1K) - AP(KK) * AP (KM1KM1)
IJ = IK - (K - 1) - (K - 2)
DO 40 JJ = 1, KM2
J = KM1 - JJ
JK = IK + J
JKM1 = IKM1 + J
D1 = (AP(KM1KM1) * AP(JK) - AP(JKM1) * AP(KM1K)) / D
D2 = (AP(KK) * AP(JKM1) - AP(JK) * AP(KM1K)) / D
CALL VECADD(J,D1,AP(IK+1),AP(IJ+1))
CALL VECADD(1,D1,B(K),B(J))
CALL VECADD(J,D2,AP(IKM1+1),AP(IJ+1))
CALL VECADD(1,D2,B(K-1),B(J))
IF (IKM1 .EQ. 1) WK(IKM1) = AP(IKM1)
DO 45 ID = 1 , J
WK(IJ+ID) = AP(IJ+ID)
45 CONTINUE
AP(JK) = D1
AP(JKM1) = D2
IJJ = IJ + J
IJ = IJ - (J - 1)
40 CONTINUE
ENDIF
C
C set up PIVOT vector
C
KPVT(K) = 1 - K
IF (SWAP) KPVT(K) = -IMAX
KPVT(K-1) = KPVT(K)
ELSE
C
C 1 x 1 PIVOT block
C
IF (SWAP) THEN
C
C perform swap
C
CALL VECXCH(IMAX,AP(IM+1),AP(IK+1))
CALL VECXCH(IMAX,WK(IM+1),WK(IK+1))
IMJ = IK + IMAX
DO 50 JJ = IMAX, K
J = K + IMAX - JJ
JK = IK + J
T = AP(JK)
AP(JK) = AP(IMJ)
AP(IMJ) = T
T = WK(JK)
WK(JK) = WK(IMJ)
WK(IMJ) = T
IMJ = IMJ - (J - 1)
50 CONTINUE
T = B(K)
B(K) = B(IMAX)
B(IMAX) = T
ENDIF
C
C perform elimination
C
IJ = IK - (K - 1)
DO 60 JJ = 1, KM1
J = K - JJ
JK = IK + J
D1 = -AP(JK) / AP(KK)
CALL VECADD(J,D1,AP(IK+1),AP(IJ+1))
CALL VECADD(1,D1,B(K),B(J))
DO 70 ID = 1 , J
WK(IJ+ID) = AP(IJ+ID)
70 CONTINUE
IJJ = IJ + J
AP(JK) = D1
IJ = IJ - (J - 1)
60 CONTINUE
C
C set up PIVOT vector
C
KPVT(K) = K
IF (SWAP) KPVT(K) = IMAX
ENDIF
IK = IK - (K - 1)
IF (KSTEP .EQ. 2) IK = IK - (K - 2)
K = K - KSTEP
GOTO 10
END
C
C
SUBROUTINE VECADD (N,SA,SX,SY)
C
C*****************************************************************
C *
C Multiplies the vector SX by the constant SA and then adds *
C the vector SX to the vector SY. *
C *
C----------------------------------------------------------------*
C *
C subroutines required: none *
C *
C*****************************************************************
C *
C authors : Michael Groenheim, Ina Hinze *
C date : 10.25.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
DOUBLE PRECISION SX(N),SY(N),SA
INTEGER I,N
C
IF (N .LE. 0) RETURN
C
IF (SA .EQ. 0.0D0) RETURN
C
DO 10 I = 1,N
SY(I) = SY(I) + SA * SX(I)
10 CONTINUE
RETURN
END
C
C
SUBROUTINE VECXCH (N,SX,SY)
C
C*****************************************************************
C *
C Swaps the vectors SX and SY. *
C *
C----------------------------------------------------------------*
C *
C subroutines required: none *
C *
C*****************************************************************
C *
C authors : Michael Groenheim, Ina Hinze *
C date : 10.25.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
DOUBLE PRECISION SX(N),SY(N),DUMMY
INTEGER I,N
C
DO 10 I = 1,N
DUMMY = SX(I)
SX(I) = SY(I)
SY(I) = DUMMY
10 CONTINUE
RETURN
END
C
C
INTEGER FUNCTION INDMAX (N,SX)
C
C*****************************************************************
C *
C Determines the index of the element of the vector SX that *
C has the largest entry in magnitude. *
C *
C----------------------------------------------------------------*
C *
C subroutines required: none *
C *
C*****************************************************************
C *
C authors : Michael Groenheim, Ina Hinze *
C date : 10.25.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
DOUBLE PRECISION SX(N),SMAX
INTEGER I,N
C
INDMAX = 0
C
IF (N .LT. 1) RETURN
C
INDMAX = 1
C
IF (N .EQ. 1) RETURN
C
SMAX = DABS (SX(1))
C
DO 10 I = 2,N
IF (DABS (SX(I)) .GT. SMAX ) THEN
INDMAX = I
SMAX = DABS (SX(I))
ENDIF
10 CONTINUE
RETURN
END
C
C
SUBROUTINE PCOSOL (IPOINT,AP,N,Z,KPVT,S,EK,YNORM)
C
C*****************************************************************
C *
C Subroutine of CEPSPM. *
C This subroutine helps to solve a system of equations *
C U*D*W = E or U*D*V = Y. *
C It is called twice by ZSPM.. . *
C The method of solving the *
C equations above is identical except for small variations. *
C In order to combine both tasks in one subroutine, we *
C introduce the parameter IPOINT, which, depending on the *
C kind of call, initiates branches at the relevant places in *
C this subroutine. *
C *
C *
C INPUT PARAMETERS: *
C ================= *
C IPOINT flag *
C = 1 , in case PCOSOL is called for solving *
C U*D*W = E *
C = 2 , in case PCOSOL is called for solving *
C U*D*V = Y *
C N dimension of the matrix A *
C KPVT INTEGER vector KVPT(1:N) containing the PIVOT *
C indices *
C Z DOUBLE PRECISION auxiliary vector Z(1:N), needed *
C for solving U*D*W = E or U*D*V = Y. *
C AP vector containing the factors of the decomposition *
C of the symmetric matrix A in condensed form. *
C S DOUBLE PRECISION auxiliary variable *
C EK DOUBLE PRECISION auxiliary variable *
C *
C *
C OUTPUT PARAMETERS: *
C ================== *
C S DOUBLE PRECISION auxiliary variable *
C YNORM DOUBLE PRECISION norm of Y *
C EK DOUBLE PRECISION auxiliary variable *
C *
C----------------------------------------------------------------*
C *
C subroutines required: VECADD, VECMWC *
C *
C *
C source : Linpack User's Guide, SIAM, Philadelphia, 1979 *
C *
C*****************************************************************
C *
C authors : Michael Groenheim, Ina Hinze *
C date : 10.25.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
INTEGER N,IPOINT,KPVT(N)
DOUBLE PRECISION AP(N*(N+1)/2),Z(N)
DOUBLE PRECISION D,D1,D2,EK,T
DOUBLE PRECISION S,YNORM
INTEGER IK,IKM1,K,KK,KM1K,KM1KM1,KP,KPS,KSTEP
K = N
IK = N*(N - 1)/2
10 IF (K .EQ. 0) RETURN
KK = IK + K
IKM1 = IK - (K - 1)
KSTEP = 1
IF (KPVT(K) .LT. 0) KSTEP = 2
IF (IPOINT .EQ. 1) THEN
C
C call was for solving U*D*W = E
C
KP = IABS(KPVT(K))
KPS = K + 1 - KSTEP
IF (KP .NE. KPS) THEN
T = Z(KPS)
Z(KPS) = Z(KP)
Z(KP) = T
ENDIF
IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,Z(K))
Z(K) = Z(K) + EK
CALL VECADD(K-KSTEP,Z(K),AP(IK+1),Z(1))
ENDIF
IF (IPOINT .EQ. 2) THEN
C
C call was for solving U*D*V = Y
C
IF (K .NE. KSTEP) THEN
KP = IABS(KPVT(K))
KPS = K + 1 - KSTEP
IF (KP .NE. KPS) THEN
T = Z(KPS)
Z(KPS) = Z(KP)
Z(KP) = T
ENDIF
CALL VECADD(K-KSTEP,Z(K),AP(IK+1),Z(1))
IF (KSTEP .EQ. 2) THEN
CALL VECADD(K-KSTEP,Z(K-1),AP(IKM1+1),Z(1))
ENDIF
ENDIF
ENDIF
C
C 1 x 1 PIVOT block
C
IF (KSTEP .EQ. 1) THEN
IF (DABS(Z(K)) .GT. DABS(AP(KK))) THEN
S = DABS(AP(KK))/DABS(Z(K))
CALL VECMWC (N,S,Z)
IF (IPOINT .EQ. 1) EK = S * EK
IF (IPOINT .EQ. 2) YNORM = S * YNORM
ENDIF
IF (AP(KK) .NE. 0.0D0) Z(K) = Z(K)/AP(KK)
IF (AP(KK) .EQ. 0.0D0) Z(K) = 1.0D0
K = K - KSTEP
IK = IK - K
GOTO 10
ENDIF
C
C 2 x 2 PIVOT block
C
IF (KSTEP .EQ. 2) THEN
IF (IPOINT .EQ. 1) THEN
IF (Z(K-1) .NE. 0.0D0) EK = DSIGN(EK,Z(K-1))
Z(K-1) = Z(K-1) + EK
CALL VECADD(K-KSTEP,Z(K-1),AP(IKM1+1),Z(1))
ENDIF
KM1K = IK + K - 1
KM1KM1 = IKM1 + K - 1
D1 = AP(KM1KM1) * Z(K) - AP(KM1K) * Z(K-1)
D2 = AP(KK) * Z(K-1) - AP(KM1K) * Z(K)
D = AP(KK) * AP(KM1KM1) - AP(KM1K) * AP(KM1K)
Z(K) = D1 / D
Z(K-1) = D2 / D
K = K - KSTEP
IK = IK - K - (K + 1)
GOTO 10
ENDIF
END
C
C
SUBROUTINE VECMWC (N,SA,SX)
C
C*****************************************************************
C *
C Multiplies the vector SX by the constant SA. *
C *
C----------------------------------------------------------------*
C *
C subroutines required: none *
C *
C*****************************************************************
C *
C authors : Michael Groenheim, Ina Hinze *
C date : 10.25.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
DOUBLE PRECISION SA,SX(N)
INTEGER I,N
C
IF (N. LE. 0) RETURN
C
DO 10 I = 1,N
SX(I) = SA * SX(I)
10 CONTINUE
RETURN
END
C
C
SUBROUTINE PCOLTG(AP,N,Z,KPVT,S)
C
C*****************************************************************
C *
C Subroutine of CEPSPM. *
C This subroutine helps to solve the system the equations *
C TRANS(U) * Y = W or TRANS(U) * Z = V. *
C *
C *
C INPUT PARAMETERS: *
C ================= *
C N dimension of the matrix A *
C Z DOUBLE PRECISION auxiliary vector Z(1:N), needed *
C to solve TRANS(U) * Y = W or TRANS(U) * Z = V *
C KPVT INTEGER vector KPVT(1:N) containing the PIVOT *
C indices *
C AP vector containing the factors of the decomposition *
C of the symmetric matrix A in condensed form *
C *
C *
C OUTPUT PARAMETER: *
C ================= *
C S DOUBLE PRECISION auxiliary variable *
C *
C----------------------------------------------------------------*
C *
C subroutines required: SCAPRO, VECMWC, ABSSUM *
C *
C *
C source : Linpack User's Guide, SIAM, Philadelphia, 1979 *
C *
C*****************************************************************
C *
C authors : Michael Groenheim, Ina Hinze *
C date : 10.25.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
INTEGER N,KPVT(N)
DOUBLE PRECISION AP(N*(N+1)/2),Z(N)
DOUBLE PRECISION SCAPRO,T,S,ABSSUM
INTEGER IK,IKP1,K,KP,KSTEP
S = 1.0D0 / ABSSUM(N,Z)
CALL VECMWC(N,S,Z)
K = 1
IK = 0
10 IF (K .LE. N) THEN
KSTEP = 1
IF (KPVT(K) .LT. 0) KSTEP = 2
IF (K .NE. 1) THEN
Z(K) = Z(K) + SCAPRO(K-1,AP(IK+1),Z(1))
IKP1 = IK + K
IF (KSTEP .EQ. 2)
* Z(K+1) = Z(K+1) + SCAPRO(K-1,AP(IKP1+1),Z(1))
KP = IABS(KPVT(K))
IF (KP .NE. K) THEN
T = Z(K)
Z(K) = Z(KP)
Z(KP) = T
ENDIF
ENDIF
IK = IK + K
IF (KSTEP .EQ. 2) IK = IK + (K + 1)
K = K + KSTEP
GOTO 10
ENDIF
RETURN
END
C
C
DOUBLE PRECISION FUNCTION SCAPRO (N,SX,SY)
C
C*****************************************************************
C *
C Determines the scalar product of two vectors SX and SY. *
C *
C----------------------------------------------------------------*
C *
C subroutines required: none *
C *
C*****************************************************************
C *
C authors : Michael Groenheim, Ina Hinze *
C date : 10.25.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
DOUBLE PRECISION SX(N),SY(N)
INTEGER I,N
C
SCAPRO = 0.0D0
C
DO 10 I = 1,N
SCAPRO = SCAPRO + SX(I) * SY(I)
10 CONTINUE
RETURN
END
C
C
DOUBLE PRECISION FUNCTION ABSSUM (N,SX)
C
C*****************************************************************
C *
C Forms the sum of the absolute values of the entries in SX. *
C *
C----------------------------------------------------------------*
C *
C subroutine required: none *
C *
C*****************************************************************
C *
C authors : Michael Groenheim, Ina Hinze *
C date : 10.25.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
DOUBLE PRECISION SX(N)
INTEGER I,N
C
ABSSUM = 0.0D0
C
IF (N .LE. 0) RETURN
C
DO 10 I=1,N
ABSSUM = ABSSUM + DABS(SX(I))
10 CONTINUE
RETURN
END