      SUBROUTINE AB13MD( FACT, N, Z, LDZ, M, NBLOCK, ITYPE, X, BOUND, D,
     $                   G, IWORK, DWORK, LDWORK, ZWORK, LZWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute an upper bound on the structured singular value for a
C     given square complex matrix and a given block structure of the
C     uncertainty.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     FACT    CHARACTER*1
C             Specifies whether or not an information from the
C             previous call is supplied in the vector X.
C             = 'F':  On entry, X contains information from the
C                     previous call.
C             = 'N':  On entry, X does not contain an information from
C                     the previous call.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix Z.  N >= 0.
C
C     Z       (input) COMPLEX*16 array, dimension (LDZ,N)
C             The leading N-by-N part of this array must contain the
C             complex matrix Z for which the upper bound on the
C             structured singular value is to be computed.
C
C     LDZ     INTEGER
C             The leading dimension of the array Z.  LDZ >= max(1,N).
C
C     M       (input) INTEGER
C             The number of diagonal blocks in the block structure of
C             the uncertainty.  M >= 1.
C
C     NBLOCK  (input) INTEGER array, dimension (M)
C             The vector of length M containing the block structure
C             of the uncertainty. NBLOCK(I), I = 1:M, is the size of
C             each block.
C
C     ITYPE   (input) INTEGER array, dimension (M)
C             The vector of length M indicating the type of each block.
C             For I = 1:M,
C             ITYPE(I) = 1 indicates that the corresponding block is a
C                          real block, and
C             ITYPE(I) = 2 indicates that the corresponding block is a
C                          complex block.
C             NBLOCK(I) must be equal to 1 if ITYPE(I) is equal to 1.
C
C     X       (input/output) DOUBLE PRECISION array, dimension
C             ( M + MR - 1 ), where MR is the number of the real blocks.
C             On entry, if FACT = 'F' and NBLOCK(1) < N, this array
C             must contain information from the previous call to AB13MD.
C             If NBLOCK(1) = N, this array is not used.
C             On exit, if NBLOCK(1) < N, this array contains information
C             that can be used in the next call to AB13MD for a matrix
C             close to Z.
C
C     BOUND   (output) DOUBLE PRECISION
C             The upper bound on the structured singular value.
C
C     D, G    (output) DOUBLE PRECISION arrays, dimension (N)
C             The vectors of length N containing the diagonal entries
C             of the diagonal N-by-N matrices D and G, respectively,
C             such that the matrix
C             Z'*D^2*Z + sqrt(-1)*(G*Z-Z'*G) - BOUND^2*D^2
C             is negative semidefinite.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (MAX(4*M-2,N))
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) contains the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= 2*N*N*M - N*N + 9*M*M + N*M + 11*N + 33*M - 11.
C             For best performance
C             LDWORK >= 2*N*N*M - N*N + 9*M*M + N*M + 6*N + 33*M - 11 +
C                       MAX( 5*N,2*N*NB )
C             where NB is the optimal blocksize returned by ILAENV.
C
C     ZWORK   COMPLEX*16 array, dimension (LZWORK)
C             On exit, if INFO = 0, ZWORK(1) contains the optimal value
C             of LZWORK.
C
C     LZWORK  INTEGER
C             The dimension of the array ZWORK.
C             LZWORK >= 6*N*N*M + 12*N*N + 6*M + 6*N - 3.
C             For best performance
C             LZWORK >= 6*N*N*M + 12*N*N + 6*M + 3*N - 3 +
C                       MAX( 3*N,N*NB )
C             where NB is the optimal blocksize returned by ILAENV.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the block sizes must be positive integers;
C             = 2:  the sum of block sizes must be equal to N;
C             = 3:  the size of a real block must be equal to 1;
C             = 4:  the block type must be either 1 or 2;
C             = 5:  errors in solving linear equations or in matrix
C                   inversion;
C             = 6:  errors in computing eigenvalues or singular values.
C
C     METHOD
C
C     The routine computes the upper bound proposed in [1].
C
C     REFERENCES
C
C     [1] Fan, M.K.H., Tits, A.L., and Doyle, J.C.
C         Robustness in the presence of mixed parametric uncertainty
C         and unmodeled dynamics.
C         IEEE Trans. Automatic Control, vol. AC-36, 1991, pp. 25-38.
C
C     NUMERICAL ASPECTS
C
C     The accuracy and speed of computation depend on the value of
C     the internal threshold TOL.
C
C     CONTRIBUTORS
C
C     P.Hr. Petkov, F. Delebecque, D.W. Gu, M.M. Konstantinov and
C     S. Steer with the assistance of V. Sima, September 2000.
C
C     REVISIONS
C
C     V. Sima, Katholieke Universiteit Leuven, February 2001.
C
C     KEYWORDS
C
C     H-infinity optimal control, Robust control, Structured singular
C     value.
C
C     ******************************************************************
C
C     .. Parameters ..
      COMPLEX*16         CZERO, CONE, CIMAG
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
     $                     CONE  = ( 1.0D+0, 0.0D+0 ),
     $                     CIMAG = ( 0.0D+0, 1.0D+0 ) )
      DOUBLE PRECISION   ZERO, ONE, TWO, FOUR, FIVE, EIGHT, TEN, FORTY,
     $                   FIFTY
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
     $                     FOUR = 4.0D+0, FIVE = 5.0D+0, EIGHT = 8.0D+0,
     $                     TEN  = 1.0D+1, FORTY = 4.0D+1, FIFTY = 5.0D+1
     $                   )
      DOUBLE PRECISION   ALPHA, BETA, THETA
      PARAMETER          ( ALPHA = 100.0D+0, BETA = 1.0D-2,
     $                     THETA = 1.0D-2 )
      DOUBLE PRECISION   C1, C2, C3, C4, C5, C6, C7, C8, C9
      PARAMETER          ( C1 = 1.0D-3, C2 = 1.0D-2, C3 = 0.25D+0,
     $                     C4 = 0.9D+0, C5 = 1.5D+0, C6 = 1.0D+1,
     $                     C7 = 1.0D+2, C8 = 1.0D+3, C9 = 1.0D+4 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          FACT
      INTEGER            INFO, LDWORK, LDZ, LZWORK, M, N
      DOUBLE PRECISION   BOUND
C     ..
C     .. Array Arguments ..
      INTEGER            ITYPE( * ), IWORK( * ), NBLOCK( * )
      COMPLEX*16         Z( LDZ, * ), ZWORK( * )
      DOUBLE PRECISION   D( * ), DWORK( * ), G( * ), X( * )
C     ..
C     .. Local Scalars ..
      INTEGER            I, INFO2, ISUM, ITER, IW2, IW3, IW4, IW5, IW6,
     $                   IW7, IW8, IW9, IW10, IW11, IW12, IW13, IW14,
     $                   IW15, IW16, IW17, IW18, IW19, IW20, IW21, IW22,
     $                   IW23, IW24, IW25, IW26, IW27, IW28, IW29, IW30,
     $                   IW31, IW32, IW33, IWRK, IZ2, IZ3, IZ4, IZ5,
     $                   IZ6, IZ7, IZ8, IZ9, IZ10, IZ11, IZ12, IZ13,
     $                   IZ14, IZ15, IZ16, IZ17, IZ18, IZ19, IZ20, IZ21,
     $                   IZ22, IZ23, IZ24, IZWRK, J, K, L, LWA, LWAMAX,
     $                   LZA, LZAMAX, MINWRK, MINZRK, MR, MT, NSUM, SDIM
      COMPLEX*16         DETF, TEMPIJ, TEMPJI
      DOUBLE PRECISION   C, COLSUM, DELTA, DLAMBD, E, EMAX, EMIN, EPS,
     $                   HN, HNORM, HNORM1, PHI, PP, PROD, RAT, RCOND,
     $                   REGPAR, ROWSUM, SCALE, SNORM, STSIZE, SVLAM,
     $                   T1, T2, T3, TAU, TEMP, TOL, TOL2, TOL3, TOL4,
     $                   TOL5, YNORM1, YNORM2, ZNORM, ZNORM2
      LOGICAL            GTEST, POS, XFACT
C     ..
C     .. Local Arrays ..
      LOGICAL            BWORK( 1 )
C     ..
C     .. External Functions
      DOUBLE PRECISION   DDOT, DLAMCH, DLANGE, ZLANGE
      LOGICAL            LSAME, SELECT
      EXTERNAL           DDOT, DLAMCH, DLANGE, LSAME, SELECT, ZLANGE
C     ..
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMV, DLACPY, DLASET, DSCAL, DSYCON,
     $                   DSYSV, DSYTRF, DSYTRS, XERBLA, ZCOPY, ZGEES,
     $                   ZGEMM, ZGEMV, ZGESVD, ZGETRF, ZGETRI, ZLACPY,
     $                   ZLASCL
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DCMPLX, DCONJG, DFLOAT, DREAL, INT, LOG,
     $                   MAX, SQRT
C     ..
C     .. Executable Statements ..
C
C     Compute workspace.
C
      MINWRK = 2*N*N*M - N*N + 9*M*M + N*M + 11*N + 33*M - 11
      MINZRK = 6*N*N*M + 12*N*N + 6*M + 6*N - 3
C
C     Decode and Test input parameters.
C
      INFO = 0
      XFACT = LSAME( FACT, 'F' )
      IF( .NOT.XFACT .AND. .NOT.LSAME( FACT, 'N' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( M.LT.1 ) THEN
         INFO = -5
      ELSE IF( LDWORK.LT.MINWRK ) THEN
         INFO = -14
      ELSE IF( LZWORK.LT.MINZRK ) THEN
         INFO = -16
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'AB13MD', -INFO )
         RETURN
      END IF
C
      NSUM = 0
      ISUM = 0
      MR = 0
      DO 10 I = 1, M
         IF( NBLOCK( I ).LT.1 ) THEN
            INFO = 1
            RETURN
         END IF
         IF( ITYPE( I ).EQ.1 .AND. NBLOCK( I ).GT.1 ) THEN
            INFO = 3
            RETURN
         END IF
         NSUM = NSUM + NBLOCK( I )
         IF( ITYPE( I ).EQ.1 ) MR = MR + 1
         IF( ITYPE( I ).EQ.1 .OR. ITYPE( I ).EQ.2 ) ISUM = ISUM + 1
   10 CONTINUE
      IF( NSUM.NE.N ) THEN
         INFO = 2
         RETURN
      END IF
      IF( ISUM.NE.M ) THEN
         INFO = 4
         RETURN
      END IF
      MT = M + MR - 1
C
      LWAMAX = 0
      LZAMAX = 0
C
C     Set D = In, G = 0.
C
      CALL DLASET( 'Full', N, 1, ONE, ONE, D, N )
      CALL DLASET( 'Full', N, 1, ZERO, ZERO, G, N )
C
C     Quick return if possible.
C
      ZNORM = ZLANGE( 'F', N, N, Z, LDZ, DWORK )
      IF( ZNORM.EQ.ZERO ) THEN
         BOUND = ZERO
         DWORK( 1 ) = ONE
         ZWORK( 1 ) = CONE
         RETURN
      END IF
C
C     Copy Z into ZWORK.
C
      CALL ZLACPY( 'Full', N, N, Z, LDZ, ZWORK, N )
C
C     Exact bound for the case NBLOCK( 1 ) = N.
C
      IF( NBLOCK( 1 ).EQ.N ) THEN
         IF( ITYPE( 1 ).EQ.1 ) THEN
C
C           1-by-1 real block.
C
            BOUND = ZERO
            DWORK( 1 ) = ONE
            ZWORK( 1 ) = CONE
         ELSE
C
C           N-by-N complex block.
C
            CALL ZGESVD( 'N', 'N', N, N, ZWORK, N, DWORK, ZWORK, 1,
     $                   ZWORK, 1, ZWORK( N*N+1 ), LZWORK,
     $                   DWORK( N+1 ), INFO2 )
            IF( INFO2.GT.0 ) THEN
               INFO = 6
               RETURN
            END IF
            BOUND = DWORK( 1 )
            LZA = N*N + INT( ZWORK( N*N+1 ) )
            DWORK( 1 ) = 5*N
            ZWORK( 1 ) = DCMPLX( LZA )
         END IF
         RETURN
      END IF
C
C     Get machine precision.
C
      EPS = DLAMCH( 'P' )
C
C     Set tolerances.
C
      TOL  = C7*SQRT( EPS )
      TOL2 = C9*EPS
      TOL3 = C6*EPS
      TOL4 = C1
      TOL5 = C1
      REGPAR = C8*EPS
C
C     Real workspace usage.
C
      IW2  = M*M
      IW3  = IW2  + M
      IW4  = IW3  + N
      IW5  = IW4  + M
      IW6  = IW5  + M
      IW7  = IW6  + N
      IW8  = IW7  + N
      IW9  = IW8  + N*( M - 1 )
      IW10 = IW9  + N*N*MT
      IW11 = IW10 + MT
      IW12 = IW11 + MT*MT
      IW13 = IW12 + N
      IW14 = IW13 + MT + 1
      IW15 = IW14 + MT + 1
      IW16 = IW15 + MT + 1
      IW17 = IW16 + MT + 1
      IW18 = IW17 + MT + 1
      IW19 = IW18 + MT
      IW20 = IW19 + MT
      IW21 = IW20 + MT
      IW22 = IW21 + N
      IW23 = IW22 + M - 1
      IW24 = IW23 + MR
      IW25 = IW24 + N
      IW26 = IW25 + 2*MT
      IW27 = IW26 + MT
      IW28 = IW27 + MT
      IW29 = IW28 + M - 1
      IW30 = IW29 + MR
      IW31 = IW30 + N + 2*MT
      IW32 = IW31 + MT*MT
      IW33 = IW32 + MT
      IWRK = IW33 + MT + 1
C
C     Double complex workspace usage.
C
      IZ2  = N*N
      IZ3  = IZ2  + N*N
      IZ4  = IZ3  + N*N
      IZ5  = IZ4  + N*N
      IZ6  = IZ5  + N*N
      IZ7  = IZ6  + N*N*MT
      IZ8  = IZ7  + N*N
      IZ9  = IZ8  + N*N
      IZ10 = IZ9  + N*N
      IZ11 = IZ10 + MT
      IZ12 = IZ11 + N*N
      IZ13 = IZ12 + N
      IZ14 = IZ13 + N*N
      IZ15 = IZ14 + N
      IZ16 = IZ15 + N*N
      IZ17 = IZ16 + N
      IZ18 = IZ17 + N*N
      IZ19 = IZ18 + N*N*MT
      IZ20 = IZ19 + MT
      IZ21 = IZ20 + N*N*MT
      IZ22 = IZ21 + N*N
      IZ23 = IZ22 + N*N
      IZ24 = IZ23 + N*N
      IZWRK = IZ24 + MT
C
C     Compute the cumulative sums of blocks dimensions.
C
      IWORK( 1 ) = 0
      DO 20 I = 2, M+1
         IWORK( I ) = IWORK( I - 1 ) + NBLOCK( I - 1 )
   20 CONTINUE
C
C     Find Osborne scaling if initial scaling is not given.
C
      IF( .NOT.XFACT ) THEN
         CALL DLASET( 'Full', M, M, ZERO, ZERO, DWORK, M )
         CALL DLASET( 'Full', M, 1, ONE, ONE, DWORK( IW2+1 ), M )
         ZNORM = ZLANGE( 'F', N, N, ZWORK, N, DWORK )
         DO 40 J = 1, M
            DO 30 I = 1, M
               IF( I.NE.J ) THEN
                  CALL ZLACPY( 'Full', IWORK( I+1 )-IWORK( I ),
     $                         IWORK( J+1 )-IWORK( J ),
     $                         Z( IWORK( I )+1, IWORK( J )+1 ), LDZ,
     $                         ZWORK( IZ2+1 ), N )
                  CALL ZGESVD( 'N', 'N', IWORK( I+1 )-IWORK( I ),
     $                         IWORK( J+1 )-IWORK( J ), ZWORK( IZ2+1 ),
     $                         N, DWORK( IW3+1 ), ZWORK, 1, ZWORK, 1,
     $                         ZWORK( IZWRK+1 ), LZWORK-IZWRK,
     $                         DWORK( IWRK+1 ), INFO2 )
                  IF( INFO2.GT.0 ) THEN
                     INFO = 6
                     RETURN
                  END IF
                  LZA = INT( ZWORK( IZWRK+1 ) )
                  LZAMAX = MAX( LZA, LZAMAX )
                  ZNORM2 = DWORK( IW3+1 )
                  DWORK( I+(J-1)*M ) = ZNORM2 + ZNORM*TOL2
               END IF
   30       CONTINUE
   40    CONTINUE
         CALL  DLASET( 'Full', M, 1, ZERO, ZERO, DWORK( IW4+1 ), M )
   50    DO 60 I = 1, M
            DWORK( IW5+I ) = DWORK( IW4+I ) - ONE
   60    CONTINUE
         HNORM = DLANGE( 'F', M, 1, DWORK( IW5+1 ), M, DWORK )
         IF( HNORM.LE.TOL2 ) GO TO 120
            DO 110 K = 1, M
               COLSUM = ZERO
               DO 70 I = 1, M
                  COLSUM = COLSUM + DWORK( I+(K-1)*M )
   70          CONTINUE
               ROWSUM = ZERO
               DO 80 J = 1, M
                  ROWSUM = ROWSUM + DWORK( K+(J-1)*M )
   80          CONTINUE
               RAT = SQRT( COLSUM / ROWSUM )
               DWORK( IW4+K ) = RAT
               DO 90 I = 1, M
                  DWORK( I+(K-1)*M ) = DWORK( I+(K-1)*M ) / RAT
   90          CONTINUE
               DO 100 J = 1, M
                  DWORK( K+(J-1)*M ) = DWORK( K+(J-1)*M )*RAT
  100          CONTINUE
               DWORK( IW2+K ) = DWORK( IW2+K )*RAT
  110       CONTINUE
            GO TO 50
  120    SCALE = ONE / DWORK( IW2+1 )
         CALL DSCAL( M, SCALE, DWORK( IW2+1 ), 1 )
      ELSE
         DWORK( IW2+1 ) = ONE
         DO 130 I = 2, M
            DWORK( IW2+I ) = SQRT( X( I-1 ) )
  130    CONTINUE
      END IF
      DO 150 J = 1, M
         DO 140 I = 1, M
            IF( I.NE.J ) THEN
               CALL ZLASCL( 'G', M, M, DWORK( IW2+J ), DWORK( IW2+I ),
     $                      IWORK( I+1 )-IWORK( I ),
     $                      IWORK( J+1 )-IWORK( J ),
     $                      ZWORK( IWORK( I )+1+IWORK( J )*N ), N,
     $                      INFO2 )
            END IF
  140    CONTINUE
  150 CONTINUE
C
C     Scale Z by its 2-norm.
C
      CALL ZLACPY( 'Full', N, N, ZWORK, N, ZWORK( IZ2+1 ), N )
      CALL ZGESVD( 'N', 'N', N, N, ZWORK( IZ2+1 ), N, DWORK( IW3+1 ),
     $             ZWORK, 1, ZWORK, 1, ZWORK( IZWRK+1 ), LZWORK-IZWRK,
     $             DWORK( IWRK+1 ), INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 6
         RETURN
      END IF
      LZA = INT( ZWORK( IZWRK+1 ) )
      LZAMAX = MAX( LZA, LZAMAX )
      ZNORM = DWORK( IW3+1 )
      CALL ZLASCL( 'G', M, M, ZNORM, ONE, N, N, ZWORK, N, INFO2 )
C
C     Set BB.
C
      CALL DLASET( 'Full', N*N, MT, ZERO, ZERO, DWORK( IW9+1 ), N*N )
C
C     Set P.
C
      DO 160 I = 1, NBLOCK( 1 )
         DWORK( IW6+I ) = ONE
  160 CONTINUE
      DO 170 I =  NBLOCK( 1 )+1, N
         DWORK( IW6+I ) = ZERO
  170 CONTINUE
C
C     Compute P*Z.
C
      DO 190 J = 1, N
         DO 180 I = 1, N
            ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )*
     $                               ZWORK( I+(J-1)*N )
  180    CONTINUE
  190 CONTINUE
C
C     Compute Z'*P*Z.
C
      CALL ZGEMM( 'C', 'N', N, N, N, CONE, ZWORK, N, ZWORK( IZ3+1 ), N,
     $            CZERO, ZWORK( IZ4+1 ), N )
C
C     Copy Z'*P*Z into A0.
C
      CALL ZLACPY( 'Full', N, N, ZWORK( IZ4+1 ), N, ZWORK( IZ5+1 ), N )
C
C     Copy diag(P) into B0d.
C
      CALL DCOPY( N, DWORK( IW6+1 ), 1, DWORK( IW7+1 ), 1 )
C
      DO 270 K = 2, M
C
C        Set P.
C
         DO 200 I = 1, IWORK( K )
            DWORK( IW6+I ) = ZERO
  200    CONTINUE
         DO 210 I = IWORK( K )+1, IWORK( K )+NBLOCK( K )
            DWORK( IW6+I ) = ONE
  210    CONTINUE
         IF( K.LT.M ) THEN
            DO 220 I = IWORK( K+1 )+1, N
               DWORK( IW6+I ) = ZERO
  220       CONTINUE
         END IF
C
C        Compute P*Z.
C
         DO 240 J = 1, N
            DO 230 I = 1, N
               ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )*
     $                                  ZWORK( I+(J-1)*N )
  230       CONTINUE
  240    CONTINUE
C
C        Compute t = Z'*P*Z.
C
         CALL ZGEMM( 'C', 'N', N, N, N, CONE, ZWORK, N, ZWORK( IZ3+1 ),
     $               N, CZERO, ZWORK( IZ4+1 ), N )
C
C        Copy t(:) into the (k-1)-th column of AA.
C
         CALL ZCOPY( N*N, ZWORK( IZ4+1 ), 1, ZWORK( IZ6+1+(K-2)*N*N ),
     $               1 )
C
C        Copy diag(P) into the (k-1)-th column of BBd.
C
         CALL DCOPY( N, DWORK( IW6+1 ), 1, DWORK( IW8+1+(K-2)*N ), 1 )
C
C        Copy P(:) into the (k-1)-th column of BB.
C
         DO 260 I = 1, N
            DWORK( IW9+I+(I-1)*N+(K-2)*N*N ) = DWORK( IW6+I )
  260    CONTINUE
  270 CONTINUE
C
      L = 0
C
      DO 350 K = 1, M
         IF( ITYPE( K ).EQ.1 ) THEN
            L = L + 1
C
C           Set P.
C
            DO 280 I = 1, IWORK( K )
               DWORK( IW6+I ) = ZERO
  280       CONTINUE
            DO 290 I =  IWORK( K )+1, IWORK( K )+NBLOCK( K )
               DWORK( IW6+I ) = ONE
  290       CONTINUE
            IF( K.LT.M ) THEN
               DO 300 I = IWORK( K+1 )+1, N
                  DWORK( IW6+I ) = ZERO
  300          CONTINUE
            END IF
C
C           Compute P*Z.
C
            DO 320 J = 1, N
               DO 310 I = 1, N
                  ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )*
     $                                     ZWORK( I+(J-1)*N )
  310          CONTINUE
  320       CONTINUE
C
C           Compute t = sqrt(-1)*( P*Z - Z'*P ).
C
            DO 340 J = 1, N
               DO 330 I = 1, J
                  TEMPIJ = ZWORK( IZ3+I+(J-1)*N )
                  TEMPJI = ZWORK( IZ3+J+(I-1)*N )
                  ZWORK( IZ4+I+(J-1)*N ) = CIMAG*( TEMPIJ -
     $                                             DCONJG( TEMPJI ) )
                  ZWORK( IZ4+J+(I-1)*N ) = CIMAG*( TEMPJI -
     $                                             DCONJG( TEMPIJ ) )
  330          CONTINUE
  340       CONTINUE
C
C           Copy t(:) into the (m-1+l)-th column of AA.
C
            CALL ZCOPY( N*N, ZWORK( IZ4+1 ), 1,
     $                       ZWORK( IZ6+1+(M-2+L)*N*N ), 1 )
         END IF
  350 CONTINUE
C
C     Set initial X.
C
      DO 360 I = 1, M - 1
         X( I ) = ONE
  360 CONTINUE
      IF( MR.GT.0 ) THEN
         IF( .NOT.XFACT ) THEN
            DO 370 I = 1, MR
               X( M-1+I ) = ZERO
  370       CONTINUE
         ELSE
            L = 0
            DO 380 K = 1, M
               IF( ITYPE( K ).EQ.1 ) THEN
                  L = L + 1
                  X( M-1+L ) = X( M-1+L ) / DWORK( IW2+K )**2
               END IF
  380       CONTINUE
         END IF
      END IF
C
C     Set constants.
C
      SVLAM = ONE / EPS
      C = ONE
C
C     Set H.
C
      CALL  DLASET( 'Full', MT, MT, ZERO, ONE, DWORK( IW11+1 ), MT )
C
      ITER = -1
C
C     Main iteration loop.
C
  390 ITER = ITER + 1
C
C        Compute A(:) = A0 + AA*x.
C
         DO 400 I = 1, MT
            ZWORK( IZ10+I ) = DCMPLX( X( I ) )
  400    CONTINUE
         CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 )
         CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N,
     $               ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 )
C
C        Compute diag( Binv ).
C
         CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW12+1 ), 1 )
         CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, X, 1, ONE,
     $               DWORK( IW12+1 ), 1 )
         DO 410 I = 1, N
            DWORK( IW12+I ) = ONE / DWORK( IW12+I )
  410    CONTINUE
C
C        Compute Binv*A.
C
         DO 430 J = 1, N
            DO 420 I = 1, N
               ZWORK( IZ11+I+(J-1)*N ) = DCMPLX( DWORK( IW12+I ) )*
     $                                   ZWORK( IZ7+I+(J-1)*N )
  420       CONTINUE
  430    CONTINUE
C
C        Compute eig( Binv*A ).
C
         CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ11+1 ), N, SDIM,
     $               ZWORK( IZ12+1 ), ZWORK, N, ZWORK( IZWRK+1 ),
     $               LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 )
         IF( INFO2.GT.0 ) THEN
            INFO = 6
            RETURN
         END IF
         LZA = INT( ZWORK( IZWRK+1 ) )
         LZAMAX = MAX( LZA, LZAMAX )
         E = DREAL( ZWORK( IZ12+1 ) )
         IF( N.GT.1 ) THEN
            DO 440 I = 2, N
               IF( DREAL( ZWORK( IZ12+I ) ).GT.E )
     $                                   E = DREAL( ZWORK( IZ12+I ) )
  440       CONTINUE
         END IF
C
C        Set tau.
C
         IF( MR.GT.0 ) THEN
            SNORM = ABS( X( M ) )
            IF( MR.GT.1 ) THEN
               DO 450 I = M+1, MT
                  IF( ABS( X( I ) ).GT.SNORM ) SNORM = ABS( X( I ) )
  450          CONTINUE
            END IF
            IF( SNORM.GT.FORTY ) THEN
               TAU = C7
            ELSE IF( SNORM.GT.EIGHT ) THEN
               TAU = FIFTY
            ELSE IF( SNORM.GT.FOUR ) THEN
               TAU = TEN
            ELSE IF( SNORM.GT.ONE ) THEN
               TAU = FIVE
            ELSE
               TAU = TWO
            END IF
         END IF
         IF( ITER.EQ.0 ) THEN
            DLAMBD = E + C1
         ELSE
            DWORK( IW13+1 ) = E
            CALL DCOPY( MT, X, 1, DWORK( IW13+2 ), 1 )
            DLAMBD = ( ONE - THETA )*DWORK( IW13+1 ) +
     $                                         THETA*DWORK( IW14+1 )
            CALL DCOPY( MT, DWORK( IW13+2 ), 1, DWORK( IW18+1 ), 1 )
            CALL DCOPY( MT, DWORK( IW14+2 ), 1, DWORK( IW19+1 ), 1 )
            L = 0
  460       DO 470 I = 1, MT
               X( I ) = ( ONE - THETA / TWO**L )*DWORK( IW18+I ) +
     $                        ( THETA / TWO**L )*DWORK( IW19+I )
  470       CONTINUE
C
C           Compute At(:) = A0 + AA*x.
C
            DO 480 I = 1, MT
               ZWORK( IZ10+I ) = DCMPLX( X( I ) )
  480       CONTINUE
            CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ9+1 ), 1 )
            CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N,
     $                  ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ9+1 ), 1 )
C
C           Compute diag(Bt).
C
            CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW21+1 ), 1 )
            CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, X, 1, ONE,
     $                  DWORK( IW21+1 ), 1 )
C
C           Compute W.
C
            DO 500 J = 1, N
               DO 490 I = 1, N
                  IF( I.EQ.J ) THEN
                     ZWORK( IZ13+I+(I-1)*N ) = DCMPLX( THETA*BETA*
     $                      ( DWORK( IW14+1 ) - DWORK( IW13+1 ) ) /TWO -
     $                      DLAMBD*DWORK( IW21+I ) ) +
     $                      ZWORK( IZ9+I+(I-1)*N )
                  ELSE
                     ZWORK( IZ13+I+(J-1)*N ) = ZWORK( IZ9+I+(J-1)*N )
                  END IF
  490          CONTINUE
  500       CONTINUE
C
C           Compute eig( W ).
C
            CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ13+1 ), N, SDIM,
     $                  ZWORK( IZ14+1 ), ZWORK, N, ZWORK( IZWRK+1 ),
     $                  LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 )
            IF( INFO2.GT.0 ) THEN
               INFO = 6
               RETURN
            END IF
            LZA = INT( ZWORK( IZWRK+1 ) )
            LZAMAX = MAX( LZA, LZAMAX )
            EMAX = DREAL( ZWORK( IZ14+1 ) )
            IF( N.GT.1 ) THEN
               DO 510 I = 2, N
                  IF( DREAL( ZWORK( IZ14+I ) ).GT.EMAX )
     $               EMAX = DREAL( ZWORK( IZ14+I ) )
  510          CONTINUE
            END IF
            IF( EMAX.LE.ZERO ) THEN
               GO TO 515
            ELSE
               L = L + 1
               GO TO 460
            END IF
         END IF
C
C        Set y.
C
  515    DWORK( IW13+1 ) = DLAMBD
         CALL DCOPY( MT, X, 1, DWORK( IW13+2 ), 1 )
C
         IF( ( SVLAM - DLAMBD ).LT.TOL ) THEN
            BOUND = SQRT( MAX( E, ZERO ) )*ZNORM
            DO 520 I = 1, M - 1
               X( I ) = X( I )*DWORK( IW2+I+1 )**2
  520       CONTINUE
C
C           Compute sqrt( x ).
C
            DO 530 I = 1, M-1
               DWORK( IW20+I ) = SQRT( X( I ) )
  530       CONTINUE
C
C           Compute diag( D ).
C
            CALL DCOPY( N, DWORK( IW7+1 ), 1, D, 1 )
            CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N,
     $                  DWORK( IW20+1 ), 1, ONE, D, 1 )
C
C           Compute diag( G ).
C
            J = 0
            L = 0
            DO 540 K = 1, M
               J = J + NBLOCK( K )
               IF( ITYPE( K ).EQ.1 ) THEN
                  L = L + 1
                  X( M-1+L ) = X( M-1+L )*DWORK( IW2+K )**2
                  G( J ) = X( M-1+L )
               END IF
  540       CONTINUE
            CALL DSCAL( N, ZNORM, G, 1 )
            DWORK( 1 ) = DFLOAT( MINWRK - 5*N + LWAMAX )
            ZWORK( 1 ) = DCMPLX( MINZRK - 3*N + LZAMAX )
            RETURN
         END IF
         SVLAM = DLAMBD
         DO 800 K = 1, M
C
C           Store xD.
C
            CALL DCOPY( M-1, X, 1, DWORK( IW22+1 ), 1 )
            IF( MR.GT.0 ) THEN
C
C              Store xG.
C
               CALL DCOPY( MR, X( M ), 1, DWORK( IW23+1 ), 1 )
            END IF
C
C           Compute A(:) = A0 + AA*x.
C
            DO 550 I = 1, MT
               ZWORK( IZ10+I ) = DCMPLX( X( I ) )
  550       CONTINUE
            CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 )
            CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N,
     $                  ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 )
C
C           Compute B = B0d + BBd*xD.
C
            CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 )
            CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N,
     $                  DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 )
C
C           Compute F.
C
            DO 556 J = 1, N
               DO 555 I = 1, N
                  IF( I.EQ.J ) THEN
                     ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD*
     $                      DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N )
                  ELSE
                     ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N )
                  END IF
  555          CONTINUE
  556       CONTINUE
            CALL ZLACPY( 'Full', N, N, ZWORK( IZ15+1 ), N,
     $                   ZWORK( IZ17+1 ), N )
C
C           Compute det( F ).
C
            CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM,
     $                  ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ),
     $                  LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 )
            IF( INFO2.GT.0 ) THEN
               INFO = 6
               RETURN
            END IF
            LZA = INT( ZWORK( IZWRK+1 ) )
            LZAMAX = MAX( LZA, LZAMAX )
            DETF = CONE
            DO 560 I = 1, N
               DETF = DETF*ZWORK( IZ16+I )
  560       CONTINUE
C
C           Compute Finv.
C
            CALL ZGETRF( N, N, ZWORK( IZ17+1 ), N, IWORK, INFO2 )
            IF( INFO2.GT.0 ) THEN
               INFO = 5
               RETURN
            END IF
            CALL ZGETRI( N, ZWORK( IZ17+1 ), N, IWORK, ZWORK( IZWRK+1 ),
     $                   LDWORK-IWRK, INFO2 )
            LZA = INT( ZWORK( IZWRK+1 ) )
            LZAMAX = MAX( LZA, LZAMAX )
C
C           Compute phi.
C
            DO 570 I = 1, M-1
               DWORK( IW25+I ) = DWORK( IW22+I ) - BETA
               DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I )
  570       CONTINUE
            IF( MR.GT.0 ) THEN
               DO 580 I = 1, MR
                  DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU
                  DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I )
  580          CONTINUE
            END IF
            PROD = ONE
            DO 590 I = 1, 2*MT
               PROD = PROD*DWORK( IW25+I )
  590       CONTINUE
            TEMP = DREAL( DETF )
            IF( TEMP.LT.EPS ) TEMP = EPS
            PHI = -LOG( TEMP ) - LOG( PROD )
C
C           Compute g.
C
            DO 610 J = 1, MT
               DO 600 I = 1, N*N
                  ZWORK( IZ18+I+(J-1)*N*N ) = DCMPLX( DLAMBD*
     $            DWORK( IW9+I+(J-1)*N*N ) ) - ZWORK( IZ6+I+(J-1)*N*N )
  600          CONTINUE
  610       CONTINUE
            CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ18+1 ), N*N,
     $                  ZWORK( IZ17+1 ), 1, CZERO, ZWORK( IZ19+1 ), 1 )
            DO 620 I = 1, M-1
               DWORK( IW26+I ) = ONE / ( DWORK( IW22+I ) - BETA ) -
     $                           ONE / ( ALPHA - DWORK( IW22+I ) )
  620       CONTINUE
            IF( MR.GT.0 ) THEN
               DO 630 I = 1, MR
                  DWORK( IW26+M-1+I ) = ONE / ( DWORK( IW23+I ) + TAU )
     $                                 -ONE / ( TAU - DWORK( IW23+I ) )
  630          CONTINUE
            END IF
            DO 640 I = 1, MT
               DWORK( IW26+I ) = -DREAL( ZWORK( IZ19+I ) ) -
     $                                                   DWORK( IW26+I )
  640       CONTINUE
C
C           Compute h.
C
            CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT,
     $                   DWORK( IW31+1 ), MT )
            CALL DCOPY( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 )
            CALL DSYSV( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK,
     $                  DWORK( IW27+1 ), MT, DWORK( IWRK+1 ),
     $                  LDWORK-IWRK, INFO2 )
            IF( INFO2.GT.0 ) THEN
               INFO = 5
               RETURN
            END IF
            LWA = INT( DWORK( IWRK+1 ) )
            LWAMAX = MAX( LWA, LWAMAX )
            STSIZE = ONE
C
C           Store hD.
C
            CALL DCOPY( M-1, DWORK( IW27+1 ), 1, DWORK( IW28+1 ), 1 )
C
C           Determine stepsize.
C
            L = 0
            DO 650 I = 1, M-1
               IF( DWORK( IW28+I ).GT.ZERO ) THEN
                  L = L + 1
                  IF( L.EQ.1 ) THEN
                     TEMP = ( DWORK( IW22+I ) - BETA ) / DWORK( IW28+I )
                  ELSE
                     TEMP = MIN( TEMP, ( DWORK( IW22+I ) - BETA ) /
     $                                   DWORK( IW28+I ) )
                  END IF
               END IF
  650       CONTINUE
            IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP )
            L = 0
            DO 660 I = 1, M-1
               IF( DWORK( IW28+I ).LT.ZERO ) THEN
                  L = L + 1
                  IF( L.EQ.1 ) THEN
                     TEMP = ( ALPHA - DWORK( IW22+I ) ) /
     $                      ( -DWORK( IW28+I ) )
                  ELSE
                     TEMP = MIN( TEMP, ( ALPHA - DWORK( IW22+I ) ) /
     $                                 ( -DWORK( IW28+I ) ) )
                  END IF
               END IF
  660       CONTINUE
            IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP )
            IF( MR.GT.0 ) THEN
C
C              Store hG.
C
               CALL DCOPY( MR, DWORK( IW27+M ), 1, DWORK( IW29+1 ), 1 )
C
C              Determine stepsize.
C
               L = 0
               DO 670 I = 1, MR
                  IF( DWORK( IW29+I ).GT.ZERO ) THEN
                     L = L + 1
                     IF( L.EQ.1 ) THEN
                        TEMP = ( DWORK( IW23+I ) + TAU ) /
     $                           DWORK( IW29+I )
                     ELSE
                        TEMP = MIN( TEMP, ( DWORK( IW23+I ) + TAU ) /
     $                                      DWORK( IW29+I ) )
                     END IF
                  END IF
  670          CONTINUE
               IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP )
               L = 0
               DO 680 I = 1, MR
                  IF( DWORK( IW29+I ).LT.ZERO ) THEN
                     L = L + 1
                     IF( L.EQ.1 ) THEN
                        TEMP = ( TAU - DWORK( IW23+I ) ) /
     $                         ( -DWORK( IW29+I ) )
                     ELSE
                        TEMP = MIN( TEMP, ( TAU - DWORK( IW23+I ) ) /
     $                                    ( -DWORK( IW29+I ) ) )
                     END IF
                  END IF
  680          CONTINUE
            END IF
            IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP )
            STSIZE = C4*STSIZE
            IF( STSIZE.GE.TOL4 ) THEN
C
C              Compute x_new.
C
               DO 700 I = 1, MT
                  DWORK( IW20+I ) = X( I ) - STSIZE*DWORK( IW27+I )
  700          CONTINUE
C
C              Store xD.
C
               CALL DCOPY( M-1, DWORK( IW20+1 ), 1, DWORK( IW22+1 ), 1 )
               IF( MR.GT.0 ) THEN
C
C                 Store xG.
C
                  CALL DCOPY( MR, DWORK( IW20+M ), 1, DWORK( IW23+1 ),
     $                        1 )
               END IF
C
C              Compute A(:) = A0 + AA*x_new.
C
               DO 710 I = 1, MT
                  ZWORK( IZ10+I ) = DCMPLX( DWORK( IW20+I ) )
  710          CONTINUE
               CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 )
               CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N,
     $                     ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 )
C
C              Compute B = B0d + BBd*xD.
C
               CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 )
               CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N,
     $                     DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 )
C
C              Compute lambda*diag(B) - A.
C
               DO 730 J = 1, N
                  DO 720 I = 1, N
                     IF( I.EQ.J ) THEN
                        ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD*
     $                       DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N )
                     ELSE
                        ZWORK( IZ15+I+(J-1)*N ) =
     $                                          -ZWORK( IZ7+I+(J-1)*N )
                     END IF
  720             CONTINUE
  730          CONTINUE
C
C              Compute eig( lambda*diag(B)-A ).
C
               CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N,
     $                     SDIM, ZWORK( IZ16+1 ), ZWORK, N,
     $                     ZWORK( IZWRK+1 ), LZWORK-IZWRK,
     $                     DWORK( IWRK+1 ), BWORK, INFO2 )
               IF( INFO2.GT.0 ) THEN
                  INFO = 6
                  RETURN
               END IF
               LZA = INT( ZWORK( IZWRK+1 ) )
               LZAMAX = MAX( LZA, LZAMAX )
               EMIN = DREAL( ZWORK( IZ16+1 ) )
               IF( N.GT.1 ) THEN
                  DO 740 I = 2, N
                     IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN )
     $                  EMIN = DREAL( ZWORK( IZ16+I ) )
  740             CONTINUE
               END IF
               DO 750 I = 1, N
                  DWORK( IW30+I ) = DREAL( ZWORK( IZ16+I ) )
  750          CONTINUE
               DO 760 I = 1, M-1
                  DWORK( IW30+N+I ) = DWORK( IW22+I ) - BETA
                  DWORK( IW30+N+M-1+I ) = ALPHA - DWORK( IW22+I )
  760          CONTINUE
               IF( MR.GT.0 ) THEN
                  DO 770 I = 1, MR
                     DWORK( IW30+N+2*(M-1)+I ) = DWORK( IW23+I ) + TAU
                     DWORK( IW30+N+2*(M-1)+MR+I ) = TAU -
     $                      DWORK( IW23+I )
  770             CONTINUE
               END IF
               PROD = ONE
               DO 780 I = 1, N+2*MT
                  PROD = PROD*DWORK( IW30+I )
  780          CONTINUE
               IF( EMIN.LE.ZERO .OR. ( -LOG( PROD ) ).GE.PHI ) THEN
                  STSIZE = STSIZE / TEN
               ELSE
                  CALL DCOPY( MT, DWORK( IW20+1 ), 1, X, 1 )
               END IF
            END IF
            IF( STSIZE.LT.TOL4 ) GO TO 810
  800    CONTINUE
C
  810    CONTINUE
C
C           Store xD.
C
            CALL DCOPY( M-1, X, 1, DWORK( IW22+1 ), 1 )
            IF( MR.GT.0 ) THEN
C
C              Store xG.
C
               CALL DCOPY( MR, X( M ), 1, DWORK( IW23+1 ), 1 )
            END IF
C
C           Compute A(:) = A0 + AA*x.
C
            DO 820 I = 1, MT
               ZWORK( IZ10+I ) = DCMPLX( X( I ) )
  820       CONTINUE
            CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 )
            CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N,
     $                  ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 )
C
C           Compute diag( B ) = B0d + BBd*xD.
C
            CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 )
            CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N,
     $                  DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 )
C
C           Compute F.
C
            DO 840 J = 1, N
               DO 830 I = 1, N
                  IF( I.EQ.J ) THEN
                     ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD*
     $                      DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N )
                  ELSE
                     ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N )
                  END IF
  830          CONTINUE
  840       CONTINUE
            CALL ZLACPY( 'Full', N, N, ZWORK( IZ15+1 ), N,
     $                   ZWORK( IZ17+1 ), N )
C
C           Compute det( F ).
C
            CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM,
     $                  ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ),
     $                  LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 )
            IF( INFO2.GT.0 ) THEN
               INFO = 6
               RETURN
            END IF
            LZA = INT( ZWORK( IZWRK+1 ) )
            LZAMAX = MAX( LZA, LZAMAX )
            DETF = CONE
            DO 850 I = 1, N
               DETF = DETF*ZWORK( IZ16+I )
  850       CONTINUE
C
C           Compute Finv.
C
            CALL ZGETRF( N, N, ZWORK( IZ17+1 ), N, IWORK, INFO2 )
            IF( INFO2.GT.0 ) THEN
               INFO = 5
               RETURN
            END IF
            CALL ZGETRI( N, ZWORK( IZ17+1 ), N, IWORK, ZWORK( IZWRK+1 ),
     $                   LDWORK-IWRK, INFO2 )
            LZA = INT( ZWORK( IZWRK+1 ) )
            LZAMAX = MAX( LZA, LZAMAX )
C
C           Compute the barrier function.
C
            DO 860 I = 1, M-1
               DWORK( IW25+I ) = DWORK( IW22+I ) - BETA
               DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I )
  860       CONTINUE
            IF( MR.GT.0 ) THEN
               DO 870 I = 1, MR
                  DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU
                  DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I )
  870          CONTINUE
            END IF
            PROD = ONE
            DO 880 I = 1, 2*MT
               PROD = PROD*DWORK( IW25+I )
  880       CONTINUE
            TEMP = DREAL( DETF )
            IF( TEMP.LT.EPS ) TEMP = EPS
            PHI = -LOG( TEMP ) - LOG( PROD )
C
C           Compute the gradient of the barrier function.
C
            DO 900 J = 1, MT
               DO 890 I = 1, N*N
                  ZWORK( IZ18+I+(J-1)*N*N ) = DCMPLX( DLAMBD*
     $            DWORK(  IW9+I+(J-1)*N*N ) ) - ZWORK( IZ6+I+(J-1)*N*N )
  890          CONTINUE
  900       CONTINUE
            CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ18+1 ), N*N,
     $                  ZWORK( IZ17+1 ), 1, CZERO, ZWORK( IZ19+1 ), 1 )
            DO 910 I = 1, M-1
               DWORK( IW26+I ) = ONE / ( DWORK( IW22+I ) - BETA ) -
     $                           ONE / ( ALPHA - DWORK( IW22+I ) )
  910       CONTINUE
            IF( MR.GT.0 ) THEN
               DO 920 I = 1, MR
                  DWORK( IW26+M-1+I ) = ONE / ( DWORK( IW23+I ) + TAU )
     $                                 -ONE / ( TAU - DWORK( IW23+I ) )
  920          CONTINUE
            END IF
            DO 925 I = 1, MT
               DWORK( IW26+I ) = -DREAL( ZWORK( IZ19+I ) ) -
     $                                                 DWORK( IW26+I )
  925       CONTINUE
C
C           Compute the Hessian of the barrier function.
C
            CALL ZGEMM( 'N', 'N', N, N*MT, N, CONE, ZWORK( IZ17+1 ), N,
     $                  ZWORK( IZ18+1 ), N, CZERO, ZWORK( IZ20+1 ), N )

            CALL  DLASET( 'Full', MT, MT, ZERO, ZERO, DWORK( IW11+1 ),
     $                    MT )
            DO 960 K = 1, MT
               CALL ZCOPY( N*N, ZWORK( IZ20+1+(K-1)*N*N ), 1,
     $                          ZWORK( IZ22+1 ), 1 )
               DO 940 J = 1, N
                  DO 930 I = 1, N
                     ZWORK( IZ23+I+(J-1)*N ) =
     $                              DCONJG( ZWORK( IZ22+J+(I-1)*N ) )
  930             CONTINUE
  940          CONTINUE
               CALL ZGEMV( 'C', N*N, K, CONE, ZWORK( IZ20+1 ), N*N,
     $                     ZWORK( IZ23+1 ), 1, CZERO, ZWORK( IZ24+1 ),
     $                     1 )
               DO 950 J = 1, K
                  DWORK( IW11+K+(J-1)*MT ) =
     $                               DREAL( DCONJG( ZWORK( IZ24+J ) ) )
  950          CONTINUE
  960       CONTINUE
            DO 970 I = 1, M-1
               DWORK( IW10+I ) = ONE / ( DWORK( IW22+I ) - BETA )**2 +
     $                           ONE / ( ALPHA - DWORK( IW22+I ) )**2
  970       CONTINUE
            IF( MR.GT.0 ) THEN
               DO 980 I = 1, MR
                  DWORK( IW10+M-1+I ) =
     $                           ONE / ( DWORK( IW23+I ) + TAU )**2 +
     $                           ONE / ( TAU - DWORK( IW23+I ) )**2
  980          CONTINUE
            END IF
            DO 990 I = 1, MT
               DWORK( IW11+I+(I-1)*MT ) = DWORK( IW11+I+(I-1)*MT ) +
     $                                    DWORK( IW10+I )
  990       CONTINUE
            DO 1100 J = 1, MT
               DO 1000 I = 1, J
                  IF( I.NE.J ) THEN
                     T1 = DWORK( IW11+I+(J-1)*MT )
                     T2 = DWORK( IW11+J+(I-1)*MT )
                     DWORK( IW11+I+(J-1)*MT ) = T1 + T2
                     DWORK( IW11+J+(I-1)*MT ) = T1 + T2
                  END IF
 1000          CONTINUE
 1100       CONTINUE
C
C           Compute norm( H ).
C
 1110       HNORM = DLANGE( 'F', MT, MT, DWORK( IW11+1 ), MT, DWORK )
C
C           Compute rcond( H ).
C
            CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT,
     $                   DWORK( IW31+1 ), MT )
            HNORM1 = DLANGE( '1', MT, MT, DWORK( IW31+1 ), MT, DWORK )
            CALL DSYTRF( 'U', MT, DWORK( IW31+1 ), MT, IWORK,
     $                   DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 )
            IF( INFO2.GT.0 ) THEN
               INFO = 5
               RETURN
            END IF
            LWA = INT( DWORK( IWRK+1 ) )
            LWAMAX = MAX( LWA, LWAMAX )
            CALL DSYCON( 'U', MT, DWORK( IW31+1 ), MT, IWORK, HNORM1,
     $                  RCOND, DWORK( IWRK+1 ), IWORK( MT+1 ), INFO2 )
            IF( RCOND.LT.TOL3 ) THEN
               DO 1120 I = 1, MT
                  DWORK( IW11+I+(I-1)*MT ) = DWORK( IW11+I+(I-1)*MT ) +
     $                                       HNORM*REGPAR
 1120          CONTINUE
               GO TO 1110
            END IF
C
C           Compute the tangent line to path of center.
C
            CALL DCOPY( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 )
            CALL DSYTRS( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK,
     $                   DWORK( IW27+1 ), MT, INFO2 )
C
C           Check if x-h satisfies the Goldstein test.
C
            GTEST = .FALSE.
            DO 1130 I = 1, MT
               DWORK( IW20+I ) = X( I ) - DWORK( IW27+I )
 1130       CONTINUE
C
C           Store xD.
C
            CALL DCOPY( M-1, DWORK( IW20+1 ), 1, DWORK( IW22+1 ), 1 )
            IF( MR.GT.0 ) THEN
C
C              Store xG.
C
               CALL DCOPY( MR, DWORK( IW20+M ), 1, DWORK( IW23+1 ), 1 )
            END IF
C
C           Compute A(:) = A0 + AA*x_new.
C
            DO 1140 I = 1, MT
               ZWORK( IZ10+I ) = DCMPLX( DWORK( IW20+I ) )
 1140       CONTINUE
            CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 )
            CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N,
     $                  ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 )
C
C           Compute diag( B ) = B0d + BBd*xD.
C
            CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 )
            CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N,
     $                  DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 )
C
C           Compute lambda*diag(B) - A.
C
            DO 1160 J = 1, N
               DO 1150 I = 1, N
                  IF( I.EQ.J ) THEN
                     ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD*
     $                     DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N )
                  ELSE
                     ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N )
                  END IF
 1150          CONTINUE
 1160       CONTINUE
C
C           Compute eig( lambda*diag(B)-A ).
C
            CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM,
     $                  ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ),
     $                  LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 )
            IF( INFO2.GT.0 ) THEN
               INFO = 6
               RETURN
            END IF
            LZA = INT( ZWORK( IZWRK+1 ) )
            LZAMAX = MAX( LZA, LZAMAX )
            DO 1190 I = 1, N
               DWORK( IW30+I ) = DREAL( ZWORK( IZ16+I ) )
 1190       CONTINUE
            DO 1200 I = 1, M-1
               DWORK( IW30+N+I ) = DWORK( IW22+I ) - BETA
               DWORK( IW30+N+M-1+I ) = ALPHA - DWORK( IW22+I )
 1200       CONTINUE
            IF( MR.GT.0 ) THEN
               DO 1210 I = 1, MR
                  DWORK( IW30+N+2*(M-1)+I ) = DWORK( IW23+I ) + TAU
                  DWORK( IW30+N+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I )
 1210          CONTINUE
            END IF
            EMIN = DWORK( IW30+1 )
            DO 1220 I = 1, N+2*MT
               IF( DWORK( IW30+I ).LT.EMIN ) EMIN = DWORK( IW30+I )
 1220       CONTINUE
            IF( EMIN.LE.ZERO ) THEN
               GTEST = .FALSE.
            ELSE
               PP = DDOT( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 )
               PROD = ONE
               DO 1230 I = 1, N+2*MT
                  PROD = PROD*DWORK( IW30+I )
 1230          CONTINUE
               T1 = -LOG( PROD )
               T2 = PHI - C2*PP
               T3 = PHI - C4*PP
               IF( T1.GE.T3 .AND. T1.LT.T2 ) GTEST = .TRUE.
            END IF
C
C           Use x-h if Goldstein test is satisfied. Otherwise use
C           Nesterov-Nemirovsky's stepsize length.
C
            PP = DDOT( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 )
            DELTA = SQRT( PP )
            IF( GTEST .OR. DELTA.LE.C3 ) THEN
               DO 1240 I = 1, MT
                  X( I ) = X( I ) - DWORK( IW27+I )
 1240          CONTINUE
            ELSE
               DO 1250 I = 1, MT
                  X( I ) = X( I ) - DWORK( IW27+I ) / ( ONE + DELTA )
 1250          CONTINUE
            END IF
C
C           Analytic center is found if delta is sufficiently small.
C
            IF( DELTA.LT.TOL5 ) GO TO 1260
         GO TO 810
C
C        Set yf.
C
 1260    DWORK( IW14+1 ) = DLAMBD
         CALL DCOPY( MT, X, 1, DWORK( IW14+2 ), 1 )
C
C        Set yw.
C
         CALL DCOPY( MT+1, DWORK( IW14+1 ), 1, DWORK( IW15+1 ), 1 )
C
C        Compute Fb.
C
         DO 1280 J = 1, N
            DO 1270 I = 1, N
               ZWORK( IZ21+I+(J-1)*N ) = DCMPLX( DWORK( IW24+I ) )*
     $                                 DCONJG( ZWORK( IZ17+J+(I-1)*N ) )
 1270       CONTINUE
 1280    CONTINUE
         CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ20+1 ), N*N,
     $               ZWORK( IZ21+1 ), 1, CZERO, ZWORK( IZ24+1 ), 1 )
         DO 1300 I = 1, MT
            DWORK( IW32+I ) = DREAL( ZWORK( IZ24+I ) )
 1300    CONTINUE
C
C        Compute h1.
C
         CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT,
     $                DWORK( IW31+1 ), MT )
         CALL DSYSV( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK,
     $               DWORK( IW32+1 ), MT, DWORK( IWRK+1 ),
     $               LDWORK-IWRK, INFO2 )
         IF( INFO2.GT.0 ) THEN
            INFO = 5
            RETURN
         END IF
         LWA = INT( DWORK( IWRK+1 ) )
         LWAMAX = MAX( LWA, LWAMAX )
C
C        Compute hn.
C
         HN = DLANGE( 'F', MT, 1, DWORK( IW32+1 ), MT, DWORK )
C
C        Compute y.
C
         DWORK( IW13+1 ) = DLAMBD - C / HN
         DO 1310 I = 1, MT
            DWORK( IW13+1+I ) = X( I ) + C*DWORK( IW32+I ) / HN
 1310    CONTINUE
C
C        Store xD.
C
         CALL DCOPY( M-1, DWORK( IW13+2 ), 1, DWORK( IW22+1 ), 1 )
         IF( MR.GT.0 ) THEN
C
C           Store xG.
C
            CALL DCOPY( MR, DWORK( IW13+M+1 ), 1, DWORK( IW23+1 ), 1 )
         END IF
C
C        Compute A(:) = A0 + AA*y(2:mt+1).
C
         DO 1320 I = 1, MT
            ZWORK( IZ10+I ) = DCMPLX( DWORK( IW13+1+I ) )
 1320    CONTINUE
         CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 )
         CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N,
     $               ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 )
C
C        Compute B = B0d + BBd*xD.
C
         CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 )
         CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N,
     $               DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 )
C
C        Compute y(1)*diag(B) - A.
C
         DO 1340 J = 1, N
            DO 1330 I = 1, N
               IF( I.EQ.J ) THEN
                  ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW13+1 )*
     $                   DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N )
               ELSE
                  ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N )
               END IF
 1330       CONTINUE
 1340    CONTINUE
C
C        Compute eig( y(1)*diag(B)-A ).
C
         CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM,
     $               ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ),
     $               LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 )
         IF( INFO2.GT.0 ) THEN
            INFO = 6
            RETURN
         END IF
         LZA = INT( ZWORK( IZWRK+1 ) )
         LZAMAX = MAX( LZA, LZAMAX )
         EMIN = DREAL( ZWORK( IZ16+1 ) )
         IF( N.GT.1 ) THEN
            DO 1350 I = 2, N
               IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN )
     $            EMIN = DREAL( ZWORK( IZ16+I ) )
 1350       CONTINUE
         END IF
         POS = .TRUE.
         DO 1360 I = 1, M-1
            DWORK( IW25+I ) = DWORK( IW22+I ) - BETA
            DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I )
 1360    CONTINUE
         IF( MR.GT.0 ) THEN
            DO 1370 I = 1, MR
               DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU
               DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I )
 1370       CONTINUE
         END IF
         TEMP = DWORK( IW25+1 )
         DO 1380 I = 2, 2*MT
            IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I )
 1380    CONTINUE
         IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE.
 1390    IF( POS ) THEN
C
C           Set y2 = y.
C
            CALL DCOPY( MT+1, DWORK( IW13+1 ), 1, DWORK( IW17+1 ), 1 )
C
C           Compute y = y + 1.5*( y - yw ).
C
            DO 1400 I = 1, MT+1
               DWORK( IW13+I ) = DWORK( IW13+I ) +
     $                 C5*( DWORK( IW13+I ) - DWORK( IW15+I ) )
 1400       CONTINUE
C
C           Store xD.
C
            CALL DCOPY( M-1, DWORK( IW13+2 ), 1, DWORK( IW22+1 ), 1 )
            IF( MR.GT.0 ) THEN
C
C              Store xG.
C
               CALL DCOPY( MR, DWORK( IW13+M+1 ), 1,
     $                                            DWORK( IW23+1 ), 1 )
            END IF
C
C           Compute A(:) = A0 + AA*y(2:mt+1).
C
            DO 1420 I = 1, MT
               ZWORK( IZ10+I ) = DCMPLX( DWORK( IW13+1+I ) )
 1420       CONTINUE
            CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 )
            CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N,
     $                  ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 )
C
C           Compute diag( B ) = B0d + BBd*xD.
C
            CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 )
            CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N,
     $                  DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 )
C
C           Set yw = y2.
C
            CALL DCOPY( MT+1, DWORK( IW17+1 ), 1, DWORK( IW15+1 ), 1 )
C
C           Compute y(1)*diag(B) - A.
C
            DO 1440 J = 1, N
               DO 1430 I = 1, N
                  IF( I.EQ.J ) THEN
                     ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW13+1 )*
     $                      DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N )
                  ELSE
                     ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N )
                  END IF
 1430          CONTINUE
 1440       CONTINUE
C
C           Compute eig( y(1)*diag(B)-A ).
C
            CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM,
     $                  ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ),
     $                  LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 )
            IF( INFO2.GT.0 ) THEN
               INFO = 6
               RETURN
            END IF
            LZA = INT( ZWORK( IZWRK+1 ) )
            LZAMAX = MAX( LZA, LZAMAX )
            EMIN = DREAL( ZWORK( IZ16+1 ) )
            IF( N.GT.1 ) THEN
               DO 1450 I = 2, N
                  IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN )
     $               EMIN = DREAL( ZWORK( IZ16+I ) )
 1450          CONTINUE
            END IF
            POS = .TRUE.
            DO 1460 I = 1, M-1
               DWORK( IW25+I ) = DWORK( IW22+I ) - BETA
               DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I )
 1460       CONTINUE
            IF( MR.GT.0 ) THEN
               DO 1470 I = 1, MR
                  DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU
                  DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I )
 1470          CONTINUE
            END IF
            TEMP = DWORK( IW25+1 )
            DO 1480 I = 2, 2*MT
               IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I )
 1480       CONTINUE
            IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE.
            GO TO 1390
         END IF
 1490    CONTINUE
C
C        Set y1 = ( y + yw ) / 2.
C
         DO 1500 I = 1, MT+1
            DWORK( IW16+I ) = ( DWORK( IW13+I ) + DWORK( IW15+I ) )
     $                         / TWO
 1500    CONTINUE
C
C        Store xD.
C
         CALL DCOPY( M-1, DWORK( IW16+2 ), 1, DWORK( IW22+1 ), 1 )
         IF( MR.GT.0 ) THEN
C
C           Store xG.
C
            CALL DCOPY( MR, DWORK( IW16+M+1 ), 1, DWORK( IW23+1 ), 1 )
         END IF
C
C        Compute A(:) = A0 + AA*y1(2:mt+1).
C
         DO 1510 I = 1, MT
            ZWORK( IZ10+I ) = DCMPLX( DWORK( IW16+1+I ) )
 1510    CONTINUE
         CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 )
         CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N,
     $               ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 )
C
C        Compute diag( B ) = B0d + BBd*xD.
C
         CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 )
         CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N,
     $               DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 )
C
C        Compute y1(1)*diag(B) - A.
C
         DO 1530 J = 1, N
            DO 1520 I = 1, N
               IF( I.EQ.J ) THEN
                  ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW16+1 )*
     $                   DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N )
               ELSE
                  ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N )
               END IF
 1520       CONTINUE
 1530    CONTINUE
C
C        Compute eig( y1(1)*diag(B)-A ).
C
         CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM,
     $               ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ),
     $               LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 )
         IF( INFO2.GT.0 ) THEN
            INFO = 6
            RETURN
         END IF
         LZA = INT( ZWORK( IZWRK+1 ) )
         LZAMAX = MAX( LZA, LZAMAX )
         EMIN = DREAL( ZWORK( IZ16+1 ) )
         IF( N.GT.1 ) THEN
            DO 1540 I = 2, N
               IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN )
     $            EMIN = DREAL( ZWORK( IZ16+I ) )
 1540       CONTINUE
         END IF
         POS = .TRUE.
         DO 1550 I = 1, M-1
            DWORK( IW25+I ) = DWORK( IW22+I ) - BETA
            DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I )
 1550    CONTINUE
         IF( MR.GT.0 ) THEN
            DO 1560 I = 1, MR
               DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU
               DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I )
 1560       CONTINUE
         END IF
         TEMP = DWORK( IW25+1 )
         DO 1570 I = 2, 2*MT
            IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I )
 1570    CONTINUE
         IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE.
         IF( POS ) THEN
C
C           Set yw = y1.
C
            CALL DCOPY( MT+1, DWORK( IW16+1 ), 1, DWORK( IW15+1 ), 1 )
         ELSE
C
C           Set y = y1.
C
            CALL DCOPY( MT+1, DWORK( IW16+1 ), 1, DWORK( IW13+1 ), 1 )
         END IF
         DO 1580 I = 1, MT+1
            DWORK( IW33+I ) = DWORK( IW13+I ) - DWORK( IW15+I )
 1580    CONTINUE
         YNORM1 = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK )
         DO 1590 I = 1, MT+1
            DWORK( IW33+I ) = DWORK( IW13+I ) - DWORK( IW14+I )
 1590    CONTINUE
         YNORM2 = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK )
         IF( YNORM1.LT.YNORM2*THETA ) GO TO 1600
         GO TO 1490
C
C        Compute c.
C
 1600    DO 1610 I = 1, MT+1
            DWORK( IW33+I ) = DWORK( IW15+I ) - DWORK( IW14+I )
 1610    CONTINUE
         C = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK )
C
C        Set x = yw(2:mt+1).
C
         CALL DCOPY( MT, DWORK( IW15+2 ), 1, X, 1 )
      GO TO 390
C
C *** Last line of AB13MD ***
      END


      MODULE CONSTANTS
      !** speed of light in SI units (m/s)
      real*8,parameter :: CLIGHT_SI = 299792458d0 !(2.99792458d8)
      !** speed of light in CGS units (cm/s)
      real*8,parameter :: CLIGHT_CGS = 299792458d2
      real*8,parameter :: PI =  3.14159265358979323846_8

      real*8, parameter :: kBoltzmann = 0.69503476 ! in cm^(-1)/K

      ! Boltzamnn constant (erg / K)
      REAL*8, PARAMETER :: BoltzmannConstantCGS = 1.3806488D-16

      ! Boltzmann constant (eV / K)
      REAL*8, PARAMETER :: BoltzmannConstantEV = 8.6173324D-5

      ! Planck constant (eV * s)
      REAL*8, PARAMETER :: PlanckConstantEV =    6.58211928D-16

      ! Solar radius (cm)
      REAL*8, PARAMETER :: SolarRadiusKM =       6.955D+5

      END MODULE


module interpolpot
  use numeric_kinds

  implicit none
  private

  ! calculate potential phi at (x,y,z)
  public:: ip_potent

  ! calculate accel ax,ay,ax at (x,y,z)
  public:: ip_accel

  ! setup the constants for the potential
  public:: ip_setup

  ! setup the constants for the potential
  public:: ip_stop

  integer(kind=i4b),private,parameter :: nRadius=640,nTheta=64,nPhi=64
  !integer(kind=i4b),private,parameter :: nRadius=768,nTheta=64,nPhi=64
  !integer(kind=i4b),private,parameter :: nRadius=8,nTheta=4,nPhi=4
  real (kind=dp),private,allocatable,dimension(:,:,:,:) :: grid

  real (kind=dp),private::thetastep,phistep,rlogstep,rlogminp	,rmin2,rmax2

  ! Counters to check if the interpolation range was suffiecient
  integer(kind=i4b),private :: count_Rmin,count_Rmax

  ! BUGS: uses sig_intr_km from triaxpotent module
  !       Big speed penalty for converting cartesion coordinates to spherical.
  !           (Optimal fix: integrate in spherical coordinates)

contains

subroutine ip_setup()
  use dmpotent, only : dm_setup
  use initial_parameters, only:conversion_factor
  integer (kind=i4b) :: error

  error=1

  allocate(grid(3,nphi,ntheta,nradius))

  call dm_setup()
  call ip_read(error)
  if (error == 0) call ip_testaccuracy(error)
  if (error /= 0) then
     call ip_setup_grid()
     call ip_save()
     call ip_testaccuracy(error)
     if (error /=0) stop "failed to setup interpolation grid"
  endif

  print*,"  * Potential interpolation setup"
end subroutine ip_setup

subroutine ip_stop()
  use dmpotent, only : dm_stop
  print*,"  * Number of times the points where inside the interpolation:",count_Rmin
  print*,"  * Number of times the points where outside the interpolation:",count_Rmax
  deallocate(grid)
  print*,"  * Potential interpolation stopped"
  call dm_stop()
end subroutine ip_stop

subroutine ip_setup_grid()
  use initial_parameters, only:sigobs_km,rlogmax,conversion_factor,rlogmin
  use dmpotent, only : dm_setup, dm_accel
  use triaxpotent, only : sigintr_km
  integer (kind=i4b) :: i,j,k
  real (kind=dp) :: x,y,z,theta,phi,r,vx,vy,vz,rlogpolmax,t1,t2,t3, &
       maxdiff,t4,meandiff,tinyval
  real(kind=sp) :: time1, time2

  print*," Setting up interpolating grid"
  call cpu_time(time1)

  ! choose minimum from the sigobs (because sigobs<sigintr)
  rmin2 = (minval(sigobs_km)/10.0_dp)**2
  ! choose maximum from sigintr    (because sigintr>sigobs)
  rmax2 = (maxval(sigintr_km)*6.0_dp)**2

  ! try to ensure the inner radius is small enough for smallest orbits
  rmin2 = minval( (/ ((10**rlogmin)*0.01)**2 , rmin2 /))

  ! let the grid go out far enough to encompass all orbits in the library
   rmax2 = maxval( (/ ((10.0_dp**rlogmax)*1.05)**2 , rmax2*2.0_dp /))
  rlogminp = log10(sqrt(rmin2))
  rlogpolmax = log10(sqrt(rmax2))

  thetastep = pio2_d/(ntheta-1)
  phistep   = pio2_d/(nphi-1)
  rlogstep  =(rlogpolmax-rlogminp)/(nradius-1)

  print*,"inner and outer radius of interpolation"
  print*,sqrt(rmin2)/conversion_factor,sqrt(rmax2)/conversion_factor

  grid(:,:,:,:)=log(tiny(grid(1,1,1,1))) ! ~ log(tiny)
  tinyval=tiny(grid(1,1,1,1))

  do i=1,nradius
     r     = 10 ** (rlogminp + (i-1) * rlogstep)
     do j=1,ntheta
        theta = (j-1.0_dp)*thetastep
        if (j == 1     ) theta=(j-0.5_dp)*thetastep
        if (j == ntheta) theta=(j-1.1_dp)*thetastep
        z = r * cos (theta)
        do k=1,nphi
           phi   = (k-1.0_dp)*phistep
           if (k == 1   ) phi=(k-0.5_dp)*phistep
           if (k == nphi) phi=(k-1.1_dp)*phistep
           x = r * sin (theta) * cos (phi)
           y = r * sin (theta) * sin (phi)
           call dm_accel(x,y,z,vx,vy,vz)
           if (-vx > tinyval*x) grid(1,k,j,i)=log(-vx/x)
           if (-vy > tinyval*y) grid(2,k,j,i)=log(-vy/y)
           if (-vz > tinyval*z) grid(3,k,j,i)=log(-vz/z)
           !print*,grid(1,k,j,i),log(-vx/x),log(tiny(grid(1,1,1,1))),vx,x
        end do
     end do
  end do

  !initialize Counters
  count_Rmin=0
  count_Rmax=0

  call cpu_time(time2)
  print*,"   Time spent initializing :",time2-time1,"seconds"
end subroutine ip_setup_grid

subroutine ip_testaccuracy(error)
  use dmpotent, only : dm_accel
  integer(kind=i4b),intent(out)::error
  integer (kind=i4b) :: i,j,k
  real (kind=dp) :: x,y,z,theta,phi,r,vx,vy,vz,rlogpolmax,t1,t2,t3, &
       maxdiff,t4,meandiff,len,diff
  real (kind=dp) :: ran1

  !
  ! test the accuracy of the interpolation
  !
  error=0
  print*,"  * Testing accuracy of interpolation"

  rlogpolmax = log10(sqrt(rmax2))

  maxdiff=0.0_dp
  meandiff=0.0_dp
  t4=0.0_dp
  ! START reproducible orbit library
  ! uncomment the following line for stochastic orbit library creation
  !call random_seed()
  ! END reproducible orbit library
  do i=1,20000

      r = ran1(1)
      theta = ran1(1)
      phi = ran1(1)
!       call random_number(r)
!       call random_number(theta)
!       call random_number(phi)

     r  =  10 ** (rlogminp + (rlogpolmax-rlogminp) * r)
     theta=theta*pio2_d
     phi  =phi  *pio2_d

     x = r * sin (theta) * cos (phi)
     y = r * sin (theta) * sin (phi)
     z = r * cos (theta)

     call dm_accel(x,y,z,vx,vy,vz)
     call ip_accel(x,y,z,t1,t2,t3)

     len=sqrt(vx**2+vy**2+vz**2)
     diff=sqrt(abs(vx-t1)**2+ abs(vy-t2)**2+ abs(vz-t3)**2)/len
     maxdiff = max( maxdiff , diff)
     meandiff = meandiff +  diff
     if (diff > 1.0e-3) then
       write(unit=*,fmt="(1es15.3,4f15.3,4e15.3)"),diff,theta*180/pi_d,phi*180/pi_d,log10(r),rlogminp,&
              (vx-t1)/t1,(vy-t2)/t2,(vz-t3)/t3,len
     endif
  end do

  close (unit=30)
  meandiff = meandiff/(20000.0)
  print*,"  * Max relative acceleration error" ,maxdiff
  print*,"  * Mean relative acceleration error",meandiff
  if ( maxdiff >= 1.0e-2) error=1
  if ( meandiff >= 1.0e-4) error=1
  if (error == 1) print*,"  * Required accuracy not reached"
end subroutine ip_testaccuracy

!+++++++++++++++++++++++++++++++++++
subroutine ip_accel(x,y,z,vx,vy,vz)
  use dmpotent, only : dm_accel
  real(kind=dp), intent(in) ::  x, y, z
  real(kind=dp), intent(out):: vx,vy,vz
  !------------------------------------
  real(kind=dp) :: r2,rlog,theta,phi,tf,pf,rf
  real(kind=dp),dimension(3) :: acc
  integer(kind=i4b) :: t,p,r
  real(kind=dp),parameter :: I=1.0_dp
  real(kind=dp),external ::  pow

  r2=x*x+y*y+z*z
  if (r2 > rmin2 .and. r2 < rmax2 ) then
     theta=atan2(sqrt(x*x+y*y),abs(z))
     phi=atan2(abs(y),abs(x))
     rlog=0.5_dp * log10(r2) ! = log10(sqrt(r2))

     t=floor(theta         / thetastep) + 1
     p=floor(phi           / phistep  ) + 1
     r=floor((rlog-rlogminp)/ rlogstep ) + 1
     tf=theta         /thetastep - floor(theta         / thetastep)
     pf=phi           /phistep   - floor(phi           / phistep  )
     rf=(rlog-rlogminp)/rlogstep  - floor((rlog-rlogminp)/ rlogstep )

     !if (p>1) then
     !   if (t>1) then ! p>1 and t>1
           acc(:)= abs((pf-I) * (tf-I) * (rf-I)) * grid(:,p  ,t  ,r  ) + &
                   abs((pf-I) * (tf-I) * (rf  )) * grid(:,p  ,t  ,r+1) + &
                   abs((pf-I) * (tf  ) * (rf  )) * grid(:,p  ,t+1,r+1) + &
                   abs((pf-I) * (tf  ) * (rf-I)) * grid(:,p  ,t+1,r  ) + &
                   abs((pf  ) * (tf-I) * (rf-I)) * grid(:,p+1,t  ,r  ) + &
                   abs((pf  ) * (tf-I) * (rf  )) * grid(:,p+1,t  ,r+1) + &
                   abs((pf  ) * (tf  ) * (rf  )) * grid(:,p+1,t+1,r+1) + &
                   abs((pf  ) * (tf  ) * (rf-I)) * grid(:,p+1,t+1,r  )
     !   else !p>1 and t=1
     !       acc(:)=abs((pf-I) * (rf  )) * grid(:,p  ,t+1,r+1) + &
     !              abs((pf-I) * (rf-I)) * grid(:,p  ,t+1,r  ) + &
     !              abs((pf  ) * (rf  )) * grid(:,p+1,t+1,r+1) + &
     !              abs((pf  ) * (rf-I)) * grid(:,p+1,t+1,r  )
     !   endif
     !else !p=1
     !   if (t>1) then ! p=1 and t>1
     !      acc(:)= abs((tf-I) * (rf-I)) * grid(:,p+1,t  ,r  ) + &
     !              abs((tf-I) * (rf  )) * grid(:,p+1,t  ,r+1) + &
     !              abs((tf  ) * (rf  )) * grid(:,p+1,t+1,r+1) + &
     !              abs((tf  ) * (rf-I)) * grid(:,p+1,t+1,r  )
     !   else     !p=1 and t=1
     !      acc(:)= abs((rf  )) * grid(:,p+1,t+1,r+1) + &
     !              abs((rf-I)) * grid(:,p+1,t+1,r  )
     !   endif
     !
     !endif
     vx = -x * exp(acc(1))
     vy = -y * exp(acc(2))
     vz = -z * exp(acc(3))
  else
	 if (r2 < rmin2) count_Rmin =count_Rmin + 1_i4b
	 if (r2 > rmax2) count_Rmax =count_Rmax + 1_i4b
	 call dm_accel(x,y,z,vx,vy,vz)
  endif
end subroutine ip_accel

subroutine ip_potent(x,y,z,pot)
use dmpotent, only : dm_potent
!use triaxpotent, only : tp_potent

  real(kind=dp), intent(in) ::  x, y, z
  real(kind=dp), intent(out):: pot
  call dm_potent(x,y,z,pot)
end subroutine ip_potent

subroutine ip_save()
  print*,"  *  Writing interpolation table to disk."
  open  (unit=35, file="interpolgrid", status="replace",action="write",form="unformatted")
  write (unit=35) 3_i4b,nphi,ntheta,nradius
  write (unit=35) 6_i4b,thetastep,phistep,rlogstep,rlogminp,rmin2,rmax2
  write (unit=35) grid(:,:,:,:)
  close (unit=35)
end subroutine ip_save

subroutine ip_read(error)
  integer(kind=i4b),intent(out)::error
  integer(kind=i4b) :: t1,t2,t3,t4
  print*,"  *  Reading interpolation table from disk."
  open  (unit=34, file="interpolgrid", status="old",position="rewind", &
       action="read",form="unformatted",iostat=error)
  if (error == 0 ) &
       read (unit=34,iostat=error) t1,t2,t3,t4
  if (error /= 0 .or. t1/=3 .or. t2/=nphi .or. t3/=ntheta &
       .or. t4/=nradius) error = 1
  if (error == 0 ) &
       read (unit=34,iostat=error) t1,thetastep,phistep,rlogstep,rlogminp,rmin2,rmax2
  if (error /= 0 .or. t1/=6) error=1
  if (error == 0 ) &
       read (unit=34,iostat=error) grid(:,:,:,:)
  close (unit=34)
  if (error /= 0 ) &
       print*,"  *  Interpolation file could not be read"

end subroutine ip_read

end module interpolpot


c     !! This is used to get the error
      double precision function qexact(blockno,xc,yc,t)
      implicit none

      integer blockno
      double precision xc,yc,t
      double precision x0, y0, u0, v0
      double precision q0,qc

      double precision u0_comm,v0_comm,revs_comm
      common /comm_velocity/ u0_comm,v0_comm, revs_comm

      u0 = revs_comm*u0_comm
      v0 = revs_comm*v0_comm

c     # Assume velocity is horizontal;  unit speed.
      qc = q0(blockno, xc - u0*t,yc - v0*t)

      qexact = qc

      end

      double precision function  q0(blockno,xc1,yc1)
      implicit none

      double precision xc,yc, xp, yp, zp, rp
      double precision xc1, yc1

      integer blockno
      integer*8 cont, get_context

      double precision r,r0
      double precision Hsmooth

      cont = get_context()

      xc = xc1
      yc = yc1
      call fclaw2d_map_c2m(cont,
     &      blockno,xc,yc,xp,yp,zp)

c     # Sphere centered at (1,0,r0) on torus
      r0 = 0.4d0
      r = sqrt((xp - 1.0)**2 + yp**2 + (zp-r0)**2)
      q0 = Hsmooth(r + r0) - Hsmooth(r - r0)

      end

      double precision function Hsmooth(r)
      implicit none

      double precision r

      Hsmooth = (tanh(r/0.02d0) + 1)/2.d0

      end


!
! wavy - A spectral ocean wave modeling and development framework
! Copyright (c) 2017, Wavebit Scientific LLC
! All rights reserved.
!
! Licensed under the BSD-3-clause license. See LICENSE for details.
!
program test_dhh_directional

use mod_const
use mod_utility
use mod_precision,only:rk => realkind
use mod_spectrum,only:spectrum_type
use mod_spectral_shapes,only:donelanHamiltonHui,&
                             donelanHamiltonHuiDirectionalSpectrum,&
                             donelanHamiltonHuiDirectionalSpreading,&
                             jonswapPeakFrequency
use mod_nondimensional,only:nondimensionalFrequency
use mod_functional,only:arange

implicit none

type(spectrum_type) :: spec
real(kind=rk),dimension(:),allocatable :: wspd
real(kind=rk),dimension(:),allocatable :: fetch
real(kind=rk),dimension(:),allocatable :: dirs
real(kind=rk),dimension(:,:),allocatable :: spreading
real(kind=rk),parameter :: grav = 9.8_rk
integer :: m,n,ndir,ndirs,nfreqs

write(*,*)
write(*,*)'Test omnidirectional spectrum with Donelan et al. (1985) shape;'
write(*,*)'Vary wind speed from 5 to 60 m/s with 5 m/s increments.'
write(*,*)'Vary fetch between 1, 10, and 100 km.'
write(*,*)'Peak frequency based on JONSWAP.'
write(*,*)

! Initialize spectrum
spec = spectrum_type(fmin=0.0313_rk,fmax=2._rk,df=1.1_rk,ndirs=36,depth=1e3_rk)

dirs = spec % getDirections()

ndirs  = size(spec % getDirections())
nfreqs = size(spec % getFrequency())

allocate(spreading(nfreqs,ndirs))
spreading = 0

! Set array of wind speed and fetch values:
wspd = arange(5,60,5)
fetch = [1e3_rk,1e4_rk,1e5_rk]

do m = 1,size(fetch)

  write(*,*)
  write(*,fmt='(a,f5.1,a)')'fetch = ',fetch(m)/1e3_rk,' km'
  write(*,fmt='(a)')'   wspd      Hs      Tp       Tm1      Tm2      mss      m0(f)'&
                  //'    m1(f)    m2(f)'
  write(*,fmt='(a)')'----------------------------------------------------------'&
                  //'----------------------'
  do n = 1,size(wspd)

    ! DHH directional spectral shape:
    spec = donelanHamiltonHuiDirectionalSpectrum(f = spec % getFrequency(),&
                              theta = spec % getDirections(),&
                              wspd  = wspd(n),&
                              fpeak = jonswapPeakFrequency(wspd(n),fetch(m),grav),&
                              theta_mean = 0._rk,&
                              grav  = grav)

    write(*,fmt='(9(f8.4,1x))')wspd(n),spec % significantWaveHeight(),&
      1./spec % peakFrequency(),spec % meanPeriod(),&
      spec % meanPeriodZeroCrossing(),spec % meanSquareSlope(),&
      spec % frequencyMoment(0),spec % frequencyMoment(1),&
      spec % frequencyMoment(2)

  enddo

enddo

endprogram test_dhh_directional


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Spherepack                            *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(gradient_routines) invert_gradient_regular_grid_saved

contains

    !     subroutine igrades(nlat, nlon, isym, nt, sf, isf, jsf, br, bi, mdb, ndb, &
    !                        wshses, ierror)
    !
    !     let br, bi, cr, ci be the vector spherical harmonic coefficients
    !     precomputed by vhaes for a vector field (v, w).  let (v', w') be
    !     the irrotational component of (v, w) (i.e., (v', w') is generated
    !     by assuming cr, ci are zero and synthesizing br, bi with vhses).
    !     then subroutine igrades computes a scalar field sf such that
    !
    !            gradient(sf) = (v', w').
    !
    !     i.e.,
    !
    !            v'(i, j) = d(sf(i, j))/dtheta          (colatitudinal component of
    !                                                 the gradient)
    !     and
    !
    !            w'(i, j) = 1/sint*d(sf(i, j))/dlambda  (east longitudinal component
    !                                                 of the gradient)
    !
    !     at colatitude
    !
    !            theta(i) = (i-1)*pi/(nlat-1)
    !
    !     and longitude
    !
    !            lambda(j) = (j-1)*2*pi/nlon
    !
    !     where sint = sin(theta(i)).  required associated legendre polynomials
    !     are stored rather than recomputed as they are in subroutine igradec.
    !
    !     note:  for an irrotational vector field (v, w), subroutine igrades
    !     computes a scalar field whose gradient is (v, w).  in ay case,
    !     subroutine igrades "inverts" the gradient subroutine grades.
    !
    !
    !     input parameters
    !
    !     nlat   the number of colatitudes on the full sphere including the
    !            poles. for example, nlat = 37 for a five degree grid.
    !            nlat determines the grid increment in colatitude as
    !            pi/(nlat-1).  if nlat is odd the equator is located at
    !            grid point i=(nlat + 1)/2. if nlat is even the equator is
    !            located half way between points i=nlat/2 and i=nlat/2+1.
    !            nlat must be at least 3. note: on the half sphere, the
    !            number of grid points in the colatitudinal direction is
    !            nlat/2 if nlat is even or (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct londitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater than
    !            3.  the efficiency of the computation is improved when nlon
    !            is a product of small prime numbers.
    !
    !
    !     isym   a parameter which determines whether the scalar field sf is
    !            computed on the full or half sphere as follows:
    !
    !      = 0
    !
    !            the symmetries/antsymmetries described in isym=1, 2 below
    !            do not exist in (v, w) about the equator.  in this case sf
    !            is neither symmetric nor antisymmetric about the equator.
    !            sf is computed on the entire sphere.  i.e., in the array
    !            sf(i, j) for i=1, ..., nlat and  j=1, ..., nlon
    !
    !      = 1
    !
    !            w is antisymmetric and v is symmetric about the equator.
    !            in this case sf is antisymmetyric about the equator and
    !            is computed for the northern hemisphere only.  i.e.,
    !            if nlat is odd sf is computed in the array sf(i, j) for
    !            i=1, ..., (nlat + 1)/2 and for j=1, ..., nlon.  if nlat is even
    !            sf is computed in the array sf(i, j) for i=1, ..., nlat/2
    !            and j=1, ..., nlon.
    !
    !      = 2
    !
    !            w is symmetric and v is antisymmetric about the equator.
    !            in this case sf is symmetyric about the equator and
    !            is computed for the northern hemisphere only.  i.e.,
    !            if nlat is odd sf is computed in the array sf(i, j) for
    !            i=1, ..., (nlat + 1)/2 and for j=1, ..., nlon.  if nlat is even
    !            sf is computed in the array sf(i, j) for i=1, ..., nlat/2
    !            and j=1, ..., nlon.
    !
    !
    !     nt     nt is the number of scalar and vector fields.  some
    !            computational efficiency is obtained for multiple fields.
    !            the arrays br, bi, and sf can be three dimensional corresponding
    !            to an indexed multiple vector field (v, w).  in this case,
    !            multiple scalar synthesis will be performed to compute each
    !            scalar field.  the third index for br, bi, and sf is the synthesis
    !            index which assumes the values k = 1, ..., nt.  for a single
    !            synthesis set nt = 1.  the description of the remaining
    !            parameters is simplified by assuming that nt=1 or that br, bi,
    !            and sf are two dimensional arrays.
    !
    !     isf    the first dimension of the array sf as it appears in
    !            the program that calls igrades. if isym = 0 then isf
    !            must be at least nlat.  if isym = 1 or 2 and nlat is
    !            even then isf must be at least nlat/2. if isym = 1 or 2
    !            and nlat is odd then isf must be at least (nlat + 1)/2.
    !
    !     jsf    the second dimension of the array sf as it appears in
    !            the program that calls igrades. jsf must be at least nlon.
    !
    !     br, bi  two or three dimensional arrays (see input parameter nt)
    !            that contain vector spherical harmonic coefficients
    !            of the vector field (v, w) as computed by subroutine vhaes.
    !     ***    br, bi must be computed by vhaes prior to calling igrades.
    !
    !     mdb    the first dimension of the arrays br and bi as it appears in
    !            the program that calls igrades (and vhaes). mdb must be at
    !            least min(nlat, nlon/2) if nlon is even or at least
    !            min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !     ndb    the second dimension of the arrays br and bi as it appears in
    !            the program that calls igrades (and vhaes). ndb must be at
    !            least nlat.
    !
    !
    !  wshses    an array which must be initialized by subroutine igradesi
    !            (or equivalently by subroutine shsesi).  once initialized,
    !            wshses can be used repeatedly by igrades as long as nlon
    !            and nlat remain unchanged.  wshses must not be altered
    !            between calls of igrades.
    !
    !
    !  lshses    the dimension of the array wshses as it appears in the
    !            program that calls igrades. define
    !
    !               l1 = min(nlat, (nlon+2)/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd.
    !
    !
    !            then lshses must be greater than or equal to
    !
    !               (l1*l2*(2*nlat-l1+1))/2+nlon+15
    !
    !     output parameters
    !
    !
    !     sf    a two or three dimensional array (see input parameter nt) that
    !           contain a scalar field whose gradient is the irrotational
    !           component of the vector field (v, w).  the vector spherical
    !           harmonic coefficients br, bi were precomputed by subroutine
    !           vhaes.  sf(i, j) is given at the gaussian colatitude theta(i)
    !           and longitude lambda(j) = (j-1)*2*pi/nlon.  the index ranges
    !           are defined at input parameter isym.
    !
    !
    !  ierror   = 0  no errors
    !           = 1  error in the specification of nlat
    !           = 2  error in the specification of nlon
    !           = 3  error in the specification of isym
    !           = 4  error in the specification of nt
    !           = 5  error in the specification of isf
    !           = 6  error in the specification of jsf
    !           = 7  error in the specification of mdb
    !           = 8  error in the specification of ndb
    !           = 9  error in the specification of lshses
    !
    subroutine igrades(nlat, nlon, isym, nt, sf, isf, jsf, br, bi, mdb, ndb, &
        wshses, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: isym
        integer(ip), intent(in)  :: nt
        real(wp),    intent(out) :: sf(isf, jsf, nt)
        integer(ip), intent(in)  :: isf
        integer(ip), intent(in)  :: jsf
        real(wp),    intent(in)  :: br(mdb, ndb, nt)
        real(wp),    intent(in)  :: bi(mdb, ndb, nt)
        integer(ip), intent(in)  :: mdb
        integer(ip), intent(in)  :: ndb
        real(wp),    intent(in)  :: wshses(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip) :: imid, lpimn, mmax
        integer(ip) :: required_wavetable_size

        ! Check calling arguments
        ierror = 1
        if (nlat < 3) return
        ierror = 2
        if (nlon < 4) return
        ierror = 3
        if (isym < 0 .or. isym > 2) return
        ierror = 4
        if (nt < 0) return
        ierror = 5
        imid = (nlat + 1)/2
        if ((isym == 0 .and. isf<nlat) .or. &
            (isym /= 0 .and. isf<imid)) return
        ierror = 6
        if (jsf < nlon) return
        ierror = 7
        mmax = min(nlat, (nlon+2)/2)
        if (mdb < min(nlat, (nlon + 1)/2)) return
        ierror = 8
        if (ndb < nlat) return
        ierror = 9
        !
        !     verify saved workspace length
        !
        imid = (nlat + 1)/2
        lpimn = (imid*mmax*(2*nlat-mmax+1))/2
        required_wavetable_size = lpimn+nlon+15
        if (size(wshses) < required_wavetable_size) return
        ierror = 0

        call invert_gradient_lower_utility_routine(nlat, nlon, isym, nt, sf, &
            br, bi, wshses, shses, ierror)

    end subroutine igrades

end  submodule invert_gradient_regular_grid_saved


! Copyright (c) 2017-2018 Etienne Descamps
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation and/or
!    other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be
!    used to endorse or promote products derived from this software without specific prior
!    written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
! INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Module mlf_matrix
  Use ieee_arithmetic
  Use iso_c_binding
  Use mlf_utils
  Use mlf_rand
  IMPLICIT NONE
  PRIVATE
  Public :: MatrixOuter, SymMatrixEigenDecomposition, InverseSymMatrix, SqrtSymMatrix
  Public :: SymmetrizeMatrix, SymmetrizeMatrixUp, TensorAddVectDown, IdentityMatrix
  Public :: GECovMatrix, randOrthogonal, SymMatrixSelectEigenValues
Contains

  ! Easier to use that dsyr or dsyr2
  Function MatrixOuter(V, W) Result(M)
    real(c_double), intent(in) :: V(:)
    real(c_double), intent(in), optional :: W(:)
    real(c_double) :: M(SIZE(V, 1),SIZE(V, 1))
    integer :: N
    N = SIZE(V, 1)
    If(PRESENT(W)) then
      M = MATMUL(RESHAPE(V, (/ N,1 /)), RESHAPE(W, (/ 1,N /)))
    Else
      M = MATMUL(RESHAPE(V, (/ N,1 /)), RESHAPE(V, (/ 1,N /)))
    Endif
  End Function MatrixOuter

  ! Symmetrize matrix (using the lower part) ('L' to full)
  Subroutine SymmetrizeMatrix(M)
    real(c_double), intent(inout) :: M(:,:)
    integer(c_int) :: i, j, N
    N = size(M,1)
    Do i = 1,N
      FORALL (j=(i+1):N) M(i,j) = M(j,i)
    End Do
  End Subroutine SymmetrizeMatrix

  ! Symmetrize matrix (using the upper part) ('U' to full)
  Subroutine SymmetrizeMatrixUp(M)
    real(c_double), intent(inout) :: M(:,:)
    integer(c_int) :: i, j, N
    N = size(M,1)
    Do i = 1,N
      FORALL (j=(i+1):N) M(j,i) = M(i,j)
    End Do
  End Subroutine SymmetrizeMatrixUp

  ! Procedure that proceed add to a matrix the matrix product of vect*transpose(vect)
  ! (It is faster to use this method and symmetrized the matrix thereafter)
  Subroutine TensorAddVectDown(N, V, M, w)
    integer(c_int), intent(in) :: N
    integer(c_int) :: i, j
    real(c_double), intent(in) :: V(N), w
    real(c_double), intent(inout) :: M(N,N)
    real(c_double) :: x
    Do i=1,N
      x = w*V(i)
      FORALL (j=i:N) M(j,i) = M(j,i) + x*V(j)
    End Do
  End Subroutine TensorAddVectDown

  ! Utility function for initializing a matrix as the Identity
  Subroutine IdentityMatrix(M)
    real(c_double) :: M(:,:)
    integer(c_int) :: i
    M = 0
    FORALL (i= 1:SIZE(M,1)) M(i,i) = 1
  End Subroutine IdentityMatrix

  ! Generate a covariance matrix and compute the mean of the individuals
  ! If W is provided, W shall be normalized (sum(W) == 1)
  Subroutine GECovMatrix(C, A, Mu, W, minW, Mu0)
    real(c_double), intent(in) :: A(:,:)
    real(c_double), intent(in), optional :: minW, W(:)
    real(c_double), intent(in), target, optional :: Mu0(:)
    real(c_double), intent(out) :: C(:,:)
    real(c_double), intent(out), target :: Mu(:)
    real(c_double), allocatable :: B(:,:)
    real(c_double), pointer :: MuX(:)
    real(c_double) :: minW0, ms
    integer :: i,j,N,M
    external :: dsyrk
    N = SIZE(A,1); M = SIZE(A,2)
    ALLOCATE(B(N,M))
    If(PRESENT(Mu0)) Then
      ! Mu0 is provided, so no Bessel's correction is required
      MuX => Mu0
      ms = 1.0
    Else
      ! Use Bessel's correction for getting an unbiased covariance
      If(PRESENT(W)) Then
        ms = 1d0/(1d0-SUM(W*W))
      Else
        ms = 1d0/REAL(M-1,kind=8)
      Endif
      MuX => Mu
    Endif
    If(PRESENT(W)) Then
      If(PRESENT(minW)) Then
        minW0 = minW
      Else
        ! Remove vector that are beyond the precision limit of the main vector
        minW0 = EPSILON(1d0)*MAXVAL(W)
      Endif
      Mu = MATMUL(A,W)
      j = 0
      Do i=1,M
        if(W(i)<minW0) CYCLE
        j = j+1
        B(:,j) = ms*SQRT(W(i))*(A(:,i)-MuX)
      End Do
    Else
      Mu = Mean(A,2)
      FORALL(i=1:M) B(:,i) = ms*(A(:,i)-MuX)
      j = M
    Endif
    ! Slowest part (in O(j*N²))
    CALL dsyrk('L', 'N', N, j, 1d0, B, N, 0d0, C, N)
    CALL SymmetrizeMatrix(C)
  End Subroutine GECovMatrix

  ! Random orthogonal matrix using the Haar distribution (Stewart 1980)
  ! Inspired by SciPy code (rvs method of _multivariate.py)
  ! (seems that Python is not as clear as FORTRAN for matrix computation)
  ! If Sigma is defined, returns O*diag(Sigma) (useful for MV random sampling)
  Subroutine randOrthogonal(H, Sigma)
    real(c_double), intent(out) :: H(:,:)
    real(c_double), intent(in), optional :: Sigma(:)
    integer :: N, k
    real(c_double), allocatable, target :: D(:), U(:), Mat(:,:)
    real(c_double), pointer :: x(:), Hx(:,:)
    N = SIZE(H, 1)
    ALLOCATE(D(N), U(N), Mat(N,N))
    CALL IdentityMatrix(H)
    D = 1d0
    Do k=1,N-1
      x => U(k:)
      Hx => Mat(k:,k:)
      CALL RandN(x)
      D(k) = SIGN(1d0, x(1))
      x(1) = x(1) - D(k)*NORM2(x)
      ! Householder matrix generated by x
      CALL IdentityMatrix(Hx)
      Hx = Hx- 2d0*MatrixOuter(x)/SUM(x*x)
      ! Most complex operation (O(N*k²))
      H(k:,:)=MATMUL(Hx,H(k:,:))
    End Do
    ! Fix last element of diagonal such as determinant = 1
    D(N) = PRODUCT(D)*(2*MODULO(N,2)-1)
    If(PRESENT(Sigma)) D= D*Sigma
    ! H = H*diag(H) (*diag(Sigma))
    FORALL (k=1:N) H(:,k) = H(:,k)*D(k)
  End Subroutine randOrthogonal

  Integer Function SymMatrixEigenDecomposition(C, LD, LB) result(info)
    ! Get orthogonal eigenvectors (LB) and eigenvalue (LD) from the symmetric matrix C
    ! (eigenvalues in ascending order)
    integer :: ND, LWORK
    real(c_double), intent(in) :: C(:,:)
    real(c_double), intent(out) :: LD(:), LB(:,:)
    real(c_double), allocatable :: LE(:), TAU(:), WORK(:,:)
    ND = SIZE(C,1)
    ALLOCATE(LE(ND-1), TAU(ND), WORK(ND,ND))
    LWORK = ND*ND
    LB = C
    ! Use same functions as dsyev
    ! Bidiagonal symmetric transformation
    CALL dsytrd('U', ND, LB, ND, LD, LE, TAU, WORK, LWORK, info)
    If(info /= 0) RETURN
    ! Generate orthogonal matrix using reflectors generated by dsytrd
    CALL dorgtr('U', ND, LB, ND, TAU, WORK, LWORK, info)
    If(info /= 0) RETURN
    ! Compute eigen values and orthogonal matrix
    CALL dsteqr('V', ND, LD, LE, LB, ND, WORK, info)
  End Function SymMatrixEigenDecomposition

  !
  Integer Function SymMatrixSelectEigenValues(C, SLD, SLB) result(info)
    ! Get the most prominent eigenvectors (SLB) and eigenvalue (SLD) from the symmetric matrix C
    ! (eigenvalues in ascending order)
    real(c_double), intent(in) :: C(:,:)
    real(c_double), intent(out) :: SLD(:), SLB(:,:)
    real(c_double), allocatable :: LD(:), A(:,:), WORK(:,:)
    integer, allocatable :: IWORK(:), ISUPPZ(:)
    integer :: K, ND, nR
    ND = SIZE(C,1); nR = SIZE(SLD)
    ALLOCATE(LD(ND), A(ND,ND), WORK(ND,ND+6), IWORK(10*ND), ISUPPZ(2*nR))
    A = C
    ! Compute eigen values and orthogonal matrix
    CALL dsyevr('V', 'I', 'U', ND, A, ND, 0d0, HUGE(0d0), ND-nR+1, ND, 1d-12, K, LD, SLB, ND, iSUPPZ, &
      WORK, SIZE(WORK), IWORK, SIZE(IWORK), info)
    If(info /= 0) RETURN
    If(K < nR) Then
      info = -1
      RETURN
    Endif
    SLD = LD(1:nR)
  End Function SymMatrixSelectEigenValues

  ! Inverse covariance matrix (using pseudo inverse when singular)
  !   output lnDet = 0.5*log(determinant(2*pi*C))
  Integer Function InverseSymMatrix(C, invC, lnDet, doEigen) Result(info)
    real(c_double), intent(in) :: C(:,:)
    real(c_double), intent(out) :: invC(:,:)
    real(c_double), intent(out) :: lnDet
    logical, intent(in), optional :: doEigen
    logical :: eigen
    integer :: ND, i
    external :: dsytrd, dorgtr, dsteqr, dpotrf, dpotri
    ND = size(C,1)
    eigen = .FALSE.
    If(present(doEigen)) eigen = doEigen
    invC = C
    info = 1
    ! Compute Cholesky's decomposition (if eigen decomposition not requested)
    If(.NOT. eigen) CALL dpotrf('U', ND, invC, ND, info)
    If(info == 0) Then
      ! The fastest method for matrix inversion
      ! At this step invC contains the Cholesky decomposition
      ! So det(invC) = prod invC_ii = sqrt(det(C))
      ! ln(sqrt(det(2*pi*C))) = ND/2*ln(2*pi) + sum(ln(invC_ii))
      lnDet = 0.5d0*ND*log(2.0*mlf_PI)
      Do i=1,ND
        lnDet = lnDet + log(invC(i,i))
      End Do
      ! Compute inverse of C using inversion of the triangular Cholesky's decomposition
      CALL dpotri('U', ND, invC, ND, info)
      CALL SymmetrizeMatrixUp(invC)
    Else
      ! More stable method for inversing matrix
      BLOCK
        ! If the matrix is singular, we use the more stable eigenvalue decomposition
        ! Can occurs when ND is greater or equivalent to dataset size
        ! If lots of problem occurs in this case, you shall reduce the dimensionality (with e.g. PCA)
        real(c_double) :: LD(ND), LE(ND-1), TAU(ND), WORK(ND,ND), valM, penality
        integer :: LWORK
        LWORK = ND*ND
        ! Reinit matrix with C (if Cholesky's decomposition has been iterated)
        If(.NOT. eigen) invC = C
        ! Use same functions as dsyev
        ! Bidiagonal symmetric transformation
        CALL dsytrd('U', ND, invC, ND, LD, LE, TAU, WORK, LWORK, info)
        If(info /= 0) RETURN
        ! Generate orthogonal matrix using reflectors generated by dsytrd
        CALL dorgtr('U', ND, invC, ND, TAU, WORK, LWORK, info)
        If(info /= 0) RETURN
        ! Compute eigen values and orthogonal matrix
        CALL dsteqr('V', ND, LD, LE, invC, ND, WORK, info)
        If(info /= 0) RETURN
        ! invC contains the orthogonal matrix and LD the diagonal of the matrix

        ! Set a penality factor that will be used on null diagonal elements
        ! This factor sets probability of elements outside the hyper plane to a tiny value
        ! (useful in high dimension cases)
        ! We replace all diagonal value below valM = 10e-9*max(LD) by valM
        valM = 10e-9*MAXVAL(LD)
        penality = 1d0/valM ! Inverse of valM
        WHERE (LD <= valM)
          LD = penality
        ELSEWHERE
          LD = 1d0/LD
        END WHERE
        lnDet = 0.5d0*(ND*LOG(2.0*mlf_PI)+SUM(LOG(LD)))
        ! For a symmetric matrix, the pseudo determinant is the product of non null eigenvalues
        ! We compute the pseudo-inverse matrix with a penality value on element that are nul
        ! invC = O * diag(pseudoInv(D)) * O**T
        Do i=1,ND
          work(:,i) = invC(:,i)*LD(i)
        End Do
        invC = MATMUL(work, TRANSPOSE(invC))
      END BLOCK
    Endif
  End Function InverseSymMatrix

  Integer Function SqrtSymMatrix(C, C12) Result(info)
    integer :: ND, i
    real(c_double), intent(in) :: C(:,:)
    real(c_double), intent(out) :: C12(:,:)
    real(c_double), allocatable :: LD(:)
    ND = size(C,1)
    ALLOCATE(LD(ND))
    info = SymMatrixEigenDecomposition(C, LD, C12)
    If(info /= 0) RETURN
    LD = sqrt(LD)
    FORALL (i=1:ND) C12(:, i) = C12(:, i)*LD(i)
  End Function SqrtSymMatrix
End Module mlf_matrix