End of file
Contents
Index

      SUBROUTINE ZSPMOK (AP,N,B,KPVT,INFO)
C
C*****************************************************************
C                                                                *
C     Decomposition of a symmetric matrix A given in condensed   *
C     form using symmetric pivoting for elimination.             *
C                                                                *
C     To solve A*X = B one call of LGSSPM is required.           *
C                                                                *
C                                                                *
C     INPUT PARAMETERS:                                          *
C     =================                                          *
C     AP    DOUBLE PRECISION vector AP(1:(N*(N+1)/2)), containing*
C           the symmetric matrix A in condensed form.            *
C           The columns of its upper triangle are stored cosecu- *
C           tively in this vector 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 B*
C           of the linear system A*X = B.                        *
C           The right-hand side is needed in SUBROUTINE ZSPMMK   *
C           since the elimination and updating steps are per-    *
C           formed there for both A and B in order to save time. *
C                                                                *
C                                                                *
C     OUTPUT PARAMETERS:                                         *
C     ==================                                         *
C     AP    DOUBLE PRECISION vector AP(1:N*(N+1)/2) which holds  *
C           the essential information needed to solve A*X = B.   *
C           Hence A*X = B can be solved via SUBROUTINE LGSSPM in *
C           one pass instead of two.                             *
C     KPVT  INTEGER vector KPVT(1:N) of the PIVOT indices.       *
C     B     DOUBLE PRECISION vector B(1:N), the right-hand side  *
C           of the linear system A*X = B in a form suitable for  *
C           applying SUBROUTINE LGSSPM.                          *
C     INFO  error parameter                                      *
C           = 0, all is o.k.                                     *
C           = k, the K-th PIVOT block is numerically singular.   *
C                This error message is irrelevant for this sub-  *
C                routine. However, the SUBROUTINE LGSSPM might   *
C                encounter division by zero.                     *
C                                                                *
C                                                                *
C     condensed form                                             *
C                                                                *
C           The following code condenses the upper triangle of a *
C           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     required subroutines: VECADD, VECXCH, INDMAX               *
C                                                                *
C                                                                *
C     Source : Linpack User's Guide , SIAM, Philadelphia, 1979   *
C                                                                *
C              The sourcecode in FORTRAN 4 was translated into   *
C              FORTRAN 77. Several details were modified and     *
C              adapted to the needs of the calling program.      *
C              Hence this and the related subroutines will not   *
C              be compatible with the original codes in LINPACK. *
C                                                                *
C*****************************************************************
C                                                                *
C     Authors   :  Michael Grönheim, Ina Hinze                   *
C     Date      :  10.25.1989                                    *
C     Source    :  FORTRAN 77                                    *
C                                                                *
C*****************************************************************
C
      INTEGER N,KPVT(*),INFO
      DOUBLE PRECISION AP(*),B(*)
      DOUBLE PRECISION D,D1,D2,T
      DOUBLE PRECISION ABSAKK,ALPHA,SPAMAX,ZEIMAX
      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     Initializing
C
C     ALPHA is used to determine the PIVOT block size
C
      ALPHA = (1.0D0 + SQRT(17.0D0))/8.0D0
C
      INFO = 0
C
C     Main loop over K, K from N to 1
C
      K = N
      IK = (N*(N - 1))/2
10    CONTINUE
C
C     leave this 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) INFO = 1
            RETURN
      ENDIF
C
C     This section determines the kind of elimination employed.
C     At the end of this section, KSTEP is assigned the size of the
C     PIVOT block and SWAP is set to .TRUE. in case a swap has taken place.
C
      KM1 = K - 1
      KK = IK + K
      ABSAKK = DABS(AP(KK))
C
C     Compute the largest off-diagonal element in magnitude
C     in column K
C
      IMAX = INDMAX(K-1,AP(IK+1))
      IMK = IK + IMAX
      SPAMAX = DABS(AP(IMK))
      IF (ABSAKK .LT. ALPHA*SPAMAX) THEN
C
C          Compute the largest off-diagonal element in magnitude
C          in row IMAX
C
           ZEIMAX = 0.0D0
           IMAXP1 = IMAX + 1
           IM = IMAX*(IMAX - 1)/2
           IMJ = IM + 2*IMAX
           DO 20 J = IMAXP1, K
                 ZEIMAX = DMAX1(ZEIMAX,DABS(AP(IMJ)))
                 IMJ = IMJ + J
20         CONTINUE
           IF (IMAX .NE. 1) THEN
                 JMAX = INDMAX(IMAX-1,AP(IM+1))
                 JMIM = JMAX + IM
                 ZEIMAX = DMAX1(ZEIMAX,DABS(AP(JMIM)))
           ENDIF
           IMIM = IMAX + IM
           IF (DABS(AP(IMIM)) .LT. ALPHA*ZEIMAX) THEN
                IF (ABSAKK .LT. ALPHA*SPAMAX*(SPAMAX/ZEIMAX)) THEN
                      KSTEP = 2
                      SWAP = IMAX .NE. KM1
\hbox{\JDhspace\verb`
                ELSE
                      KSTEP = 1
                      SWAP = .FALSE.
                ENDIF
           ELSE
                KSTEP = 1
                SWAP = .TRUE.
           ENDIF
      ELSE
           KSTEP = 1
           SWAP = .FALSE.
      ENDIF
      IF (DMAX1(ABSAKK,SPAMAX) .EQ. 0.0D0) THEN
C
C         Column  K is the zero vector. Record error in INFO
C         and repeat loop
C
          KPVT(K) = K
          INFO = 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               swap
C
                CALL VECXCH(IMAX,AP(IM+1),AP(IKM1+1))
                IMJ = IKM1 + IMAX
                DO 30 JJ = IMAX, KM1
                      J = KM1 + IMAX - JJ
                      JKM1 = IKM1 + J
                      T = AP(JKM1)
                      AP(JKM1) = AP(IMJ)
                      AP(IMJ) = T
                      IMJ = IMJ - (J - 1)
30              CONTINUE
                T = AP(KM1K)
                AP(KM1K) = AP(IMK)
                AP(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) *
     1                     AP(KM1K)) / D
                      D2 = (AP(KK) * AP(JKM1) - AP(JK) *
     1                     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))
                      IJJ = IJ + J
                      IJ = IJ - (J - 1)
40               CONTINUE
            ENDIF
C
C           Set up PIVOT vector K
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                swap
C
                 CALL VECXCH(IMAX,AP(IM+1),AP(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
                       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))
                  IJJ = IJ + J
                  IJ = IJ - (J - 1)
60          CONTINUE
C
C           Adjust 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


Begin of file
Contents
Index