      SUBROUTINE WGECO(AR,AI,LDA,N,IPVT,RCOND,ZR,ZI)
      INTEGER LDA,N,IPVT(1)
      DOUBLE PRECISION AR(LDA,1),AI(LDA,1),ZR(1),ZI(1)
      DOUBLE PRECISION RCOND
C
C     WGECO FACTORS A DOUBLE-COMPLEX MATRIX BY GAUSSIAN ELIMINATION
C     AND ESTIMATES THE CONDITION OF THE MATRIX.
C
C     IF  RCOND  IS NOT NEEDED, WGEFA IS SLIGHTLY FASTER.
C     TO SOLVE  A*X = B , FOLLOW WGECO BY WGESL.
C     TO COMPUTE  INVERSE(A)*C , FOLLOW WGECO BY WGESL.
C     TO COMPUTE  DETERMINANT(A) , FOLLOW WGECO BY WGEDI.
C     TO COMPUTE  INVERSE(A) , FOLLOW WGECO BY WGEDI.
C
C     ON ENTRY
C
C        A       DOUBLE-COMPLEX(LDA, N)
C                THE MATRIX TO BE FACTORED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C                WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        RCOND   DOUBLE PRECISION
C                AN ESTIMATE OF THE RECIPROCAL CONDITION OF  A .
C                FOR THE SYSTEM  A*X = B , RELATIVE PERTURBATIONS
C                IN  A  AND  B  OF SIZE  EPSILON  MAY CAUSE
C                RELATIVE PERTURBATIONS IN  X  OF SIZE  EPSILON/RCOND .
C                IF  RCOND  IS SO SMALL THAT THE LOGICAL EXPRESSION
C                           1.0 + RCOND .EQ. 1.0
C                IS TRUE, THEN  A  MAY BE SINGULAR TO WORKING
C                PRECISION.  IN PARTICULAR,  RCOND  IS ZERO  IF
C                EXACT SINGULARITY IS DETECTED OR THE ESTIMATE
C                UNDERFLOWS.
C
C        Z       DOUBLE-COMPLEX(N)
C                A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.
C                IF  A  IS CLOSE TO A SINGULAR MATRIX, THEN  Z  IS
C                AN APPROXIMATE NULL VECTOR IN THE SENSE THAT
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C     LINPACK. THIS VERSION DATED 07/01/79 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     LINPACK WGEFA
C     BLAS WAXPY,WDOTC,WASUM
C     FORTRAN DABS,DMAX1
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION WDOTCR,WDOTCI,EKR,EKI,TR,TI,WKR,WKI,WKMR,WKMI
      DOUBLE PRECISION ANORM,S,WASUM,SM,YNORM,FLOP
      INTEGER INFO,J,K,KB,KP1,L
C
      DOUBLE PRECISION ZDUMR,ZDUMI
      DOUBLE PRECISION CABS1
      CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
C
C     COMPUTE 1-NORM OF A
C
      ANORM = 0.0D0
      DO 10 J = 1, N
         ANORM = DMAX1(ANORM,WASUM(N,AR(1,J),AI(1,J),1))
   10 CONTINUE
C
C     FACTOR
C
      CALL WGEFA(AR,AI,LDA,N,IPVT,INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  CTRANS(A)*Y = E .
C     CTRANS(A)  IS THE CONJUGATE TRANSPOSE OF A .
C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C     GROWTH IN THE ELEMENTS OF W  WHERE  CTRANS(U)*W = E .
C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
C
C     SOLVE CTRANS(U)*W = E
C
      EKR = 1.0D0
      EKI = 0.0D0
      DO 20 J = 1, N
         ZR(J) = 0.0D0
         ZI(J) = 0.0D0
   20 CONTINUE
      DO 110 K = 1, N
         CALL WSIGN(EKR,EKI,-ZR(K),-ZI(K),EKR,EKI)
         IF (CABS1(EKR-ZR(K),EKI-ZI(K))
     *       .LE. CABS1(AR(K,K),AI(K,K))) GO TO 40
            S = CABS1(AR(K,K),AI(K,K))
     *          /CABS1(EKR-ZR(K),EKI-ZI(K))
            CALL WRSCAL(N,S,ZR,ZI,1)
            EKR = S*EKR
            EKI = S*EKI
   40    CONTINUE
         WKR = EKR - ZR(K)
         WKI = EKI - ZI(K)
         WKMR = -EKR - ZR(K)
         WKMI = -EKI - ZI(K)
         S = CABS1(WKR,WKI)
         SM = CABS1(WKMR,WKMI)
         IF (CABS1(AR(K,K),AI(K,K)) .EQ. 0.0D0) GO TO 50
            CALL WDIV(WKR,WKI,AR(K,K),-AI(K,K),WKR,WKI)
            CALL WDIV(WKMR,WKMI,AR(K,K),-AI(K,K),WKMR,WKMI)
         GO TO 60
   50    CONTINUE
            WKR = 1.0D0
            WKI = 0.0D0
            WKMR = 1.0D0
            WKMI = 0.0D0
   60    CONTINUE
         KP1 = K + 1
         IF (KP1 .GT. N) GO TO 100
            DO 70 J = KP1, N
               CALL WMUL(WKMR,WKMI,AR(K,J),-AI(K,J),TR,TI)
               SM = FLOP(SM + CABS1(ZR(J)+TR,ZI(J)+TI))
               CALL WAXPY(1,WKR,WKI,AR(K,J),-AI(K,J),1,
     $                    ZR(J),ZI(J),1)
               S = FLOP(S + CABS1(ZR(J),ZI(J)))
   70       CONTINUE
            IF (S .GE. SM) GO TO 90
               TR = WKMR - WKR
               TI = WKMI - WKI
               WKR = WKMR
               WKI = WKMI
               DO 80 J = KP1, N
                  CALL WAXPY(1,TR,TI,AR(K,J),-AI(K,J),1,
     $                       ZR(J),ZI(J),1)
   80          CONTINUE
   90       CONTINUE
  100    CONTINUE
         ZR(K) = WKR
         ZI(K) = WKI
  110 CONTINUE
      S = 1.0D0/WASUM(N,ZR,ZI,1)
      CALL WRSCAL(N,S,ZR,ZI,1)
C
C     SOLVE CTRANS(L)*Y = W
C
      DO 140 KB = 1, N
         K = N + 1 - KB
         IF (K .GE. N) GO TO 120
            ZR(K) = ZR(K)
     *            + WDOTCR(N-K,AR(K+1,K),AI(K+1,K),1,ZR(K+1),ZI(K+1),1)
            ZI(K) = ZI(K)
     *            + WDOTCI(N-K,AR(K+1,K),AI(K+1,K),1,ZR(K+1),ZI(K+1),1)
  120    CONTINUE
         IF (CABS1(ZR(K),ZI(K)) .LE. 1.0D0) GO TO 130
            S = 1.0D0/CABS1(ZR(K),ZI(K))
            CALL WRSCAL(N,S,ZR,ZI,1)
  130    CONTINUE
         L = IPVT(K)
         TR = ZR(L)
         TI = ZI(L)
         ZR(L) = ZR(K)
         ZI(L) = ZI(K)
         ZR(K) = TR
         ZI(K) = TI
  140 CONTINUE
      S = 1.0D0/WASUM(N,ZR,ZI,1)
      CALL WRSCAL(N,S,ZR,ZI,1)
C
      YNORM = 1.0D0
C
C     SOLVE L*V = Y
C
      DO 160 K = 1, N
         L = IPVT(K)
         TR = ZR(L)
         TI = ZI(L)
         ZR(L) = ZR(K)
         ZI(L) = ZI(K)
         ZR(K) = TR
         ZI(K) = TI
         IF (K .LT. N)
     *      CALL WAXPY(N-K,TR,TI,AR(K+1,K),AI(K+1,K),1,ZR(K+1),ZI(K+1),
     *                 1)
         IF (CABS1(ZR(K),ZI(K)) .LE. 1.0D0) GO TO 150
            S = 1.0D0/CABS1(ZR(K),ZI(K))
            CALL WRSCAL(N,S,ZR,ZI,1)
            YNORM = S*YNORM
  150    CONTINUE
  160 CONTINUE
      S = 1.0D0/WASUM(N,ZR,ZI,1)
      CALL WRSCAL(N,S,ZR,ZI,1)
      YNORM = S*YNORM
C
C     SOLVE  U*Z = V
C
      DO 200 KB = 1, N
         K = N + 1 - KB
         IF (CABS1(ZR(K),ZI(K))
     *       .LE. CABS1(AR(K,K),AI(K,K))) GO TO 170
            S = CABS1(AR(K,K),AI(K,K))
     *          /CABS1(ZR(K),ZI(K))
            CALL WRSCAL(N,S,ZR,ZI,1)
            YNORM = S*YNORM
  170    CONTINUE
         IF (CABS1(AR(K,K),AI(K,K)) .EQ. 0.0D0) GO TO 180
            CALL WDIV(ZR(K),ZI(K),AR(K,K),AI(K,K),ZR(K),ZI(K))
  180    CONTINUE
         IF (CABS1(AR(K,K),AI(K,K)) .NE. 0.0D0) GO TO 190
            ZR(K) = 1.0D0
            ZI(K) = 0.0D0
  190    CONTINUE
         TR = -ZR(K)
         TI = -ZI(K)
         CALL WAXPY(K-1,TR,TI,AR(1,K),AI(1,K),1,ZR(1),ZI(1),1)
  200 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0D0/WASUM(N,ZR,ZI,1)
      CALL WRSCAL(N,S,ZR,ZI,1)
      YNORM = S*YNORM
C
      IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM
      IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0
      RETURN
      END
      SUBROUTINE WGEFA(AR,AI,LDA,N,IPVT,INFO)
      INTEGER LDA,N,IPVT(1),INFO
      DOUBLE PRECISION AR(LDA,1),AI(LDA,1)
C
C     WGEFA FACTORS A DOUBLE-COMPLEX MATRIX BY GAUSSIAN ELIMINATION.
C
C     WGEFA IS USUALLY CALLED BY WGECO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C     (TIME FOR WGECO) = (1 + 9/N)*(TIME FOR WGEFA) .
C
C     ON ENTRY
C
C        A       DOUBLE-COMPLEX(LDA, N)
C                THE MATRIX TO BE FACTORED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C                WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                = 0  NORMAL VALUE.
C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C                     INDICATE THAT WGESL OR WGEDI WILL DIVIDE BY ZERO
C                     IF CALLED.  USE  RCOND  IN WGECO FOR A RELIABLE
C                     INDICATION OF SINGULARITY.
C
C     LINPACK. THIS VERSION DATED 07/01/79 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS WAXPY,WSCAL,IWAMAX
C     FORTRAN DABS
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION TR,TI
      INTEGER IWAMAX,J,K,KP1,L,NM1
C
      DOUBLE PRECISION ZDUMR,ZDUMI
      DOUBLE PRECISION CABS1
      CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
      INFO = 0
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 K = 1, NM1
         KP1 = K + 1
C
C        FIND L = PIVOT INDEX
C
         L = IWAMAX(N-K+1,AR(K,K),AI(K,K),1) + K - 1
         IPVT(K) = L
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (CABS1(AR(L,K),AI(L,K)) .EQ. 0.0D0) GO TO 40
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. K) GO TO 10
               TR = AR(L,K)
               TI = AI(L,K)
               AR(L,K) = AR(K,K)
               AI(L,K) = AI(K,K)
               AR(K,K) = TR
               AI(K,K) = TI
   10       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            CALL WDIV(-1.0D0,0.0D0,AR(K,K),AI(K,K),TR,TI)
            CALL WSCAL(N-K,TR,TI,AR(K+1,K),AI(K+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            DO 30 J = KP1, N
               TR = AR(L,J)
               TI = AI(L,J)
               IF (L .EQ. K) GO TO 20
                  AR(L,J) = AR(K,J)
                  AI(L,J) = AI(K,J)
                  AR(K,J) = TR
                  AI(K,J) = TI
   20          CONTINUE
               CALL WAXPY(N-K,TR,TI,AR(K+1,K),AI(K+1,K),1,AR(K+1,J),
     *                    AI(K+1,J),1)
   30       CONTINUE
         GO TO 50
   40    CONTINUE
            INFO = K
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      IPVT(N) = N
      IF (CABS1(AR(N,N),AI(N,N)) .EQ. 0.0D0) INFO = N
      RETURN
      END
      SUBROUTINE WGEDI(AR,AI,LDA,N,IPVT,DETR,DETI,WORKR,WORKI,JOB)
      INTEGER LDA,N,IPVT(1),JOB
      DOUBLE PRECISION AR(LDA,1),AI(LDA,1),DETR(2),DETI(2),WORKR(1),
     *                 WORKI(1)
C
C     WGEDI COMPUTES THE DETERMINANT AND INVERSE OF A MATRIX
C     USING THE FACTORS COMPUTED BY WGECO OR WGEFA.
C
C     ON ENTRY
C
C        A       DOUBLE-COMPLEX(LDA, N)
C                THE OUTPUT FROM WGECO OR WGEFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM WGECO OR WGEFA.
C
C        WORK    DOUBLE-COMPLEX(N)
C                WORK VECTOR.  CONTENTS DESTROYED.
C
C        JOB     INTEGER
C                = 11   BOTH DETERMINANT AND INVERSE.
C                = 01   INVERSE ONLY.
C                = 10   DETERMINANT ONLY.
C
C     ON RETURN
C
C        A       INVERSE OF ORIGINAL MATRIX IF REQUESTED.
C                OTHERWISE UNCHANGED.
C
C        DET     DOUBLE-COMPLEX(2)
C                DETERMINANT OF ORIGINAL MATRIX IF REQUESTED.
C                OTHERWISE NOT REFERENCED.
C                DETERMINANT = DET(1) * 10.0**DET(2)
C                WITH  1.0 .LE. CABS1(DET(1) .LT. 10.0
C                OR  DET(1) .EQ. 0.0 .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS
C        A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED.
C        IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY
C        AND IF WGECO HAS SET RCOND .GT. 0.0 OR WGEFA HAS SET
C        INFO .EQ. 0 .
C
C     LINPACK. THIS VERSION DATED 07/01/79 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS WAXPY,WSCAL,WSWAP
C     FORTRAN DABS,MOD
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION TR,TI
      DOUBLE PRECISION TEN
      INTEGER I,J,K,KB,KP1,L,NM1
C
      DOUBLE PRECISION ZDUMR,ZDUMI
      DOUBLE PRECISION CABS1
      CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
C
C     COMPUTE DETERMINANT
C
      IF (JOB/10 .EQ. 0) GO TO 80
         DETR(1) = 1.0D0
         DETI(1) = 0.0D0
         DETR(2) = 0.0D0
         DETI(2) = 0.0D0
         TEN = 10.0D0
         DO 60 I = 1, N
            IF (IPVT(I) .EQ. I) GO TO 10
               DETR(1) = -DETR(1)
               DETI(1) = -DETI(1)
   10       CONTINUE
            CALL WMUL(AR(I,I),AI(I,I),DETR(1),DETI(1),DETR(1),DETI(1))
C           ...EXIT
C        ...EXIT
            IF (CABS1(DETR(1),DETI(1)) .EQ. 0.0D0) GO TO 70
   20       IF (CABS1(DETR(1),DETI(1)) .GE. 1.0D0) GO TO 30
               DETR(1) = TEN*DETR(1)
               DETI(1) = TEN*DETI(1)
               DETR(2) = DETR(2) - 1.0D0
               DETI(2) = DETI(2) - 0.0D0
            GO TO 20
   30       CONTINUE
   40       IF (CABS1(DETR(1),DETI(1)) .LT. TEN) GO TO 50
               DETR(1) = DETR(1)/TEN
               DETI(1) = DETI(1)/TEN
               DETR(2) = DETR(2) + 1.0D0
               DETI(2) = DETI(2) + 0.0D0
            GO TO 40
   50       CONTINUE
   60    CONTINUE
   70    CONTINUE
   80 CONTINUE
C
C     COMPUTE INVERSE(U)
C
      IF (MOD(JOB,10) .EQ. 0) GO TO 160
         DO 110 K = 1, N
            CALL WDIV(1.0D0,0.0D0,AR(K,K),AI(K,K),AR(K,K),AI(K,K))
            TR = -AR(K,K)
            TI = -AI(K,K)
            CALL WSCAL(K-1,TR,TI,AR(1,K),AI(1,K),1)
            KP1 = K + 1
            IF (N .LT. KP1) GO TO 100
            DO 90 J = KP1, N
               TR = AR(K,J)
               TI = AI(K,J)
               AR(K,J) = 0.0D0
               AI(K,J) = 0.0D0
               CALL WAXPY(K,TR,TI,AR(1,K),AI(1,K),1,AR(1,J),AI(1,J),1)
   90       CONTINUE
  100       CONTINUE
  110    CONTINUE
C
C        FORM INVERSE(U)*INVERSE(L)
C
         NM1 = N - 1
         IF (NM1 .LT. 1) GO TO 150
         DO 140 KB = 1, NM1
            K = N - KB
            KP1 = K + 1
            DO 120 I = KP1, N
               WORKR(I) = AR(I,K)
               WORKI(I) = AI(I,K)
               AR(I,K) = 0.0D0
               AI(I,K) = 0.0D0
  120       CONTINUE
            DO 130 J = KP1, N
               TR = WORKR(J)
               TI = WORKI(J)
               CALL WAXPY(N,TR,TI,AR(1,J),AI(1,J),1,AR(1,K),AI(1,K),1)
  130       CONTINUE
            L = IPVT(K)
            IF (L .NE. K)
     *         CALL WSWAP(N,AR(1,K),AI(1,K),1,AR(1,L),AI(1,L),1)
  140    CONTINUE
  150    CONTINUE
  160 CONTINUE
      RETURN
      END
C
      SUBROUTINE WAXPY(N,SR,SI,XR,XI,INCX,YR,YI,INCY)
      DOUBLE PRECISION SR,SI,XR(1),XI(1),YR(1),YI(1),FLOP
      IF (N .LE. 0) RETURN
      IF (SR .EQ. 0.0D0 .AND. SI .EQ. 0.0D0) RETURN
      IX = 1
      IY = 1
      IF (INCX.LT.0) IX = (-N+1)*INCX + 1
      IF (INCY.LT.0) IY = (-N+1)*INCY + 1
      DO 10 I = 1, N
         YR(IY) = FLOP(YR(IY) + SR*XR(IX) - SI*XI(IX))
         YI(IY) = YI(IY) + SR*XI(IX) + SI*XR(IX)
         IF (YI(IY) .NE. 0.0D0) YI(IY) = FLOP(YI(IY))
         IX = IX + INCX
         IY = IY + INCY
   10 CONTINUE
      RETURN
      END
C
      DOUBLE PRECISION FUNCTION WDOTCR(N,XR,XI,INCX,YR,YI,INCY)
      DOUBLE PRECISION XR(1),XI(1),YR(1),YI(1),S,FLOP
      S = 0.0D0
      IF (N .LE. 0) GO TO 20
      IX = 1
      IY = 1
      IF (INCX.LT.0) IX = (-N+1)*INCX + 1
      IF (INCY.LT.0) IY = (-N+1)*INCY + 1
      DO 10 I = 1, N
         S = FLOP(S + XR(IX)*YR(IY) + XI(IX)*YI(IY))
         IX = IX + INCX
         IY = IY + INCY
   10 CONTINUE
   20 WDOTCR = S
      RETURN
      END
C
      DOUBLE PRECISION FUNCTION WDOTCI(N,XR,XI,INCX,YR,YI,INCY)
      DOUBLE PRECISION XR(1),XI(1),YR(1),YI(1),S,FLOP
      S = 0.0D0
      IF (N .LE. 0) GO TO 20
      IX = 1
      IY = 1
      IF (INCX.LT.0) IX = (-N+1)*INCX + 1
      IF (INCY.LT.0) IY = (-N+1)*INCY + 1
      DO 10 I = 1, N
         S = S + XR(IX)*YI(IY) - XI(IX)*YR(IY)
         IF (S .NE. 0.0D0) S = FLOP(S)
         IX = IX + INCX
         IY = IY + INCY
   10 CONTINUE
   20 WDOTCI = S
      RETURN
      END
C
      DOUBLE PRECISION FUNCTION WASUM(N,XR,XI,INCX)
      DOUBLE PRECISION XR(1),XI(1),S,FLOP
C     NORM1(X)
      S = 0.0D0
      IF (N .LE. 0) GO TO 20
      IX = 1
      DO 10 I = 1, N
         S = FLOP(S + DABS(XR(IX)) + DABS(XI(IX)))
         IX = IX + INCX
   10 CONTINUE
   20 WASUM = S
      RETURN
      END
C
      INTEGER FUNCTION IWAMAX(N,XR,XI,INCX)
      DOUBLE PRECISION XR(1),XI(1),S,P
C     INDEX OF NORMINF(X)
      K = 0
      IF (N .LE. 0) GO TO 20
      K = 1
      S = 0.0D0
      IX = 1
      DO 10 I = 1, N
         P = DABS(XR(IX)) + DABS(XI(IX))
         IF (P .GT. S) K = I
         IF (P .GT. S) S = P
         IX = IX + INCX
   10 CONTINUE
   20 IWAMAX = K
      RETURN
      END
      SUBROUTINE WRSCAL(N,S,XR,XI,INCX)
      DOUBLE PRECISION S,XR(1),XI(1),FLOP
      IF (N .LE. 0) RETURN
      IX = 1
      DO 10 I = 1, N
         XR(IX) = FLOP(S*XR(IX))
         IF (XI(IX) .NE. 0.0D0) XI(IX) = FLOP(S*XI(IX))
         IX = IX + INCX
   10 CONTINUE
      RETURN
      END
C
      SUBROUTINE WSCAL(N,SR,SI,XR,XI,INCX)
      DOUBLE PRECISION SR,SI,XR(1),XI(1)
      IF (N .LE. 0) RETURN
      IX = 1
      DO 10 I = 1, N
         CALL WMUL(SR,SI,XR(IX),XI(IX),XR(IX),XI(IX))
         IX = IX + INCX
   10 CONTINUE
      RETURN
      END
C
      SUBROUTINE WMUL(AR,AI,BR,BI,CR,CI)
      DOUBLE PRECISION AR,AI,BR,BI,CR,CI,T,FLOP
C     C = A*B
      T = AR*BI + AI*BR
      IF (T .NE. 0.0D0) T = FLOP(T)
      CR = FLOP(AR*BR - AI*BI)
      CI = T
      RETURN
      END
C
      SUBROUTINE WSWAP(N,XR,XI,INCX,YR,YI,INCY)
      DOUBLE PRECISION XR(1),XI(1),YR(1),YI(1),T
      IF (N .LE. 0) RETURN
      IX = 1
      IY = 1
      IF (INCX.LT.0) IX = (-N+1)*INCX + 1
      IF (INCY.LT.0) IY = (-N+1)*INCY + 1
      DO 10 I = 1, N
         T = XR(IX)
         XR(IX) = YR(IY)
         YR(IY) = T
         T = XI(IX)
         XI(IX) = YI(IY)
         YI(IY) = T
         IX = IX + INCX
         IY = IY + INCY
   10 CONTINUE
      RETURN
      END
C
      DOUBLE PRECISION FUNCTION FLOP(A)
      DOUBLE PRECISION A
      FLOP = A
      RETURN
      END
C
      SUBROUTINE WDIV(AR,AI,BR,BI,CR,CI)
      DOUBLE PRECISION AR,AI,BR,BI,CR,CI
C     C = A/B
      DOUBLE PRECISION S,D,ARS,AIS,BRS,BIS,FLOP
      S = DABS(BR) + DABS(BI)
      IF (S .EQ. 0.0D0) CALL ERROR(27)
      IF (S .EQ. 0.0D0) RETURN
      ARS = AR/S
      AIS = AI/S
      BRS = BR/S
      BIS = BI/S
      D = BRS**2 + BIS**2
      CR = FLOP((ARS*BRS + AIS*BIS)/D)
      CI = (AIS*BRS - ARS*BIS)/D
      IF (CI .NE. 0.0D0) CI = FLOP(CI)
      RETURN
      END
C
      SUBROUTINE WSIGN(XR,XI,YR,YI,ZR,ZI)
      DOUBLE PRECISION XR,XI,YR,YI,ZR,ZI,PYTHAG,T
C     IF Y .NE. 0, Z = X*Y/ABS(Y)
C     IF Y .EQ. 0, Z = X
      T = PYTHAG(YR,YI)
      ZR = XR
      ZI = XI
      IF (T .NE. 0.0D0) CALL WMUL(YR/T,YI/T,ZR,ZI,ZR,ZI)
      RETURN
      END
C
      DOUBLE PRECISION FUNCTION PYTHAG(A,B)
      DOUBLE PRECISION A,B
      DOUBLE PRECISION P,Q,R,S,T
      P = DMAX1(DABS(A),DABS(B))
      Q = DMIN1(DABS(A),DABS(B))
      IF (Q .EQ. 0.0D0) GO TO 20
   10 R = (Q/P)**2
      T = 4.0D0 + R
      IF (T .EQ. 4.0D0) GO TO 20
      S = R/T
      P = P + 2.0D0*P*S
      Q = Q*S
      GO TO 10
   20 PYTHAG = P
      RETURN
      END
    