      SUBROUTINE SB04PY( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
     $                   LDC, SCALE, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve for X the discrete-time Sylvester equation
C
C        op(A)*X*op(B) + ISGN*X = scale*C,
C
C     where op(A) = A or A**T, A and B are both upper quasi-triangular,
C     and ISGN = 1 or -1. A is M-by-M and B is N-by-N; the right hand
C     side C and the solution X are M-by-N; and scale is an output scale
C     factor, set less than or equal to 1 to avoid overflow in X. The
C     solution matrix X is overwritten onto C.
C
C     A and B must be in Schur canonical form (as returned by LAPACK
C     Library routine DHSEQR), that is, block upper triangular with
C     1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has
C     its diagonal elements equal and its off-diagonal elements of
C     opposite sign.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TRANA   CHARACTER*1
C             Specifies the form of op(A) to be used, as follows:
C             = 'N':  op(A) = A    (No transpose);
C             = 'T':  op(A) = A**T (Transpose);
C             = 'C':  op(A) = A**T (Conjugate transpose = Transpose).
C
C     TRANB   CHARACTER*1
C             Specifies the form of op(B) to be used, as follows:
C             = 'N':  op(B) = B    (No transpose);
C             = 'T':  op(B) = B**T (Transpose);
C             = 'C':  op(B) = B**T (Conjugate transpose = Transpose).
C
C     ISGN    INTEGER
C             Specifies the sign of the equation as described before.
C             ISGN may only be 1 or -1.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The order of the matrix A, and the number of rows in the
C             matrices X and C.  M >= 0.
C
C     N       (input) INTEGER
C             The order of the matrix B, and the number of columns in
C             the matrices X and C.  N >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,M)
C             The leading M-by-M part of this array must contain the
C             upper quasi-triangular matrix A, in Schur canonical form.
C             The part of A below the first sub-diagonal is not
C             referenced.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,M).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,N)
C             The leading N-by-N part of this array must contain the
C             upper quasi-triangular matrix B, in Schur canonical form.
C             The part of B below the first sub-diagonal is not
C             referenced.
C
C     LDB     (input) INTEGER
C             The leading dimension of the array B.  LDB >= max(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading M-by-N part of this array must
C             contain the right hand side matrix C.
C             On exit, if INFO >= 0, the leading M-by-N part of this
C             array contains the solution matrix X.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,M).
C
C     SCALE   (output) DOUBLE PRECISION
C             The scale factor, scale, set less than or equal to 1 to
C             prevent the solution overflowing.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (2*M)
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:  A and -ISGN*B have almost reciprocal eigenvalues;
C                   perturbed values were used to solve the equation
C                   (but the matrices A and B are unchanged).
C
C     METHOD
C
C     The solution matrix X is computed column-wise via a back
C     substitution scheme, an extension and refinement of the algorithm
C     in [1], similar to that used in [2] for continuous-time Sylvester
C     equations. A set of equivalent linear algebraic systems of
C     equations of order at most four are formed and solved using
C     Gaussian elimination with complete pivoting.
C
C     REFERENCES
C
C     [1] Bartels, R.H. and Stewart, G.W.  T
C         Solution of the matrix equation A X + XB = C.
C         Comm. A.C.M., 15, pp. 820-826, 1972.
C
C     [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
C         Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
C         Ostrouchov, S., and Sorensen, D.
C         LAPACK Users' Guide: Second Edition.
C         SIAM, Philadelphia, 1995.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is stable and reliable, since Gaussian elimination
C     with complete pivoting is used.
C
C     CONTRIBUTORS
C
C     A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2000.
C     D. Sima, University of Bucharest, April 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000.
C     Partly based on the routine SYLSV, A. Varga, 1992.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Discrete-time system, matrix algebra, Sylvester equation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          TRANA, TRANB
      INTEGER            INFO, ISGN, LDA, LDB, LDC, M, N
      DOUBLE PRECISION   SCALE
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   DWORK( * )
C     ..
C     .. Local Scalars ..
      LOGICAL            NOTRNA, NOTRNB
      INTEGER            IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT,
     $                   MNK1, MNK2, MNL1, MNL2
      DOUBLE PRECISION   A11, BIGNUM, DA11, DB, EPS, P11, P12, P21, P22,
     $                   SCALOC, SGN, SMIN, SMLNUM, SUMR, XNORM
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM( 1 ), VEC( 2, 2 ), X( 2, 2 )
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT, DLAMCH, DLANGE
      EXTERNAL           DDOT, DLAMCH, DLANGE, LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DLABAD, DLALN2, DSCAL, SB04PX, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX, MIN
C     ..
C     .. Executable Statements ..
C
C     Decode and Test input parameters
C
      NOTRNA = LSAME( TRANA, 'N' )
      NOTRNB = LSAME( TRANB, 'N' )
C
      INFO = 0
      IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND.
     $    .NOT.LSAME( TRANA, 'C' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND.
     $         .NOT.LSAME( TRANB, 'C' ) ) THEN
         INFO = -2
      ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -11
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB04PY', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      SCALE = ONE
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
C
C     Set constants to control overflow.
C
      EPS    = DLAMCH( 'Precision' )
      SMLNUM = DLAMCH( 'Safe minimum' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
      SMLNUM = SMLNUM*DBLE( M*N ) / EPS
      BIGNUM = ONE / SMLNUM
C
      SMIN = MAX( SMLNUM, EPS*DLANGE( 'M', M, M, A, LDA, DUM ),
     $                    EPS*DLANGE( 'M', N, N, B, LDB, DUM ) )
C
      SGN = ISGN
C
      IF( NOTRNA .AND. NOTRNB ) THEN
C
C        Solve    A*X*B + ISGN*X = scale*C.
C
C        The (K,L)th block of X is determined starting from
C        bottom-left corner column by column by
C
C           A(K,K)*X(K,L)*B(L,L) + ISGN*X(K,L) = C(K,L) - R(K,L)
C
C        where
C                       M
C           R(K,L) = { SUM [A(K,J)*X(J,L)] } * B(L,L) +
C                     J=K+1
C                       M             L-1
C                      SUM { A(K,J) * SUM [X(J,I)*B(I,L)] }.
C                      J=K            I=1
C
C        Start column loop (index = L)
C        L1 (L2) : column index of the first (last) row of X(K,L).
C
         LNEXT = 1
C
         DO 60 L = 1, N
            IF( L.LT.LNEXT )
     $         GO TO 60
            L1 = L
            IF( L.EQ.N ) THEN
               L2 = L
            ELSE
               IF( B( L+1, L ).NE.ZERO ) THEN
                  L2 = L + 1
               ELSE
                  L2 = L
               END IF
               LNEXT = L2 + 1
            END IF
C
C           Start row loop (index = K)
C           K1 (K2): row index of the first (last) row of X(K,L).
C
            KNEXT = M
C
            DO 50 K = M, 1, -1
               IF( K.GT.KNEXT )
     $            GO TO 50
               K2 = K
               IF( K.EQ.1 ) THEN
                  K1 = K
               ELSE
                  IF( A( K, K-1 ).NE.ZERO ) THEN
                     K1 = K - 1
                  ELSE
                     K1 = K
                  END IF
                  KNEXT = K1 - 1
               END IF
C
               MNK1 = MIN( K1+1, M )
               MNK2 = MIN( K2+1, M )
               P11  = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L1 ), 1 )
               DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ),
     $                             1 )
C
               IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
C
                  SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ),
     $                         1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) )
                  SCALOC = ONE
C
                  A11  = A( K1, K1 )*B( L1, L1 ) + SGN
                  DA11 = ABS( A11 )
                  IF( DA11.LE.SMIN ) THEN
                     A11  = SMIN
                     DA11 = SMIN
                     INFO = 1
                  END IF
                  DB = ABS( VEC( 1, 1 ) )
                  IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
                     IF( DB.GT.BIGNUM*DA11 )
     $                  SCALOC = ONE / DB
                  END IF
                  X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 10 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
   10                CONTINUE
C
                     CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 )
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
C
               ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
C
                  P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ),
     $                        1 )
                  DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ),
     $                                1 )
                  SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ),
     $                         1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) )
C
                  SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ),
     $                         1 )
                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) )
C
                  CALL DLALN2( .FALSE., 2, 1, SMIN, B( L1, L1 ),
     $                         A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN,
     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 )
     $               INFO = 1
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 20 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
   20                CONTINUE
C
                     CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 )
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K2, L1 ) = X( 2, 1 )
C
               ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
C
                  P12  = DDOT( M-K1, A( K1, MNK1 ), LDA, C( MNK1, L2 ),
     $                         1 )
                  SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ),
     $                         1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) +
     $                                                 P12*B( L2, L1 ) )
C
                  DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC,
     $                                  B( 1, L2 ), 1 )
                  SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ),
     $                         1 )
                  VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) +
     $                                                 P12*B( L2, L2 ) )
C
                  CALL DLALN2( .TRUE., 2, 1, SMIN, A( K1, K1 ),
     $                         B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN,
     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 )
     $               INFO = 1
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 30 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
   30                CONTINUE
C
                     CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 )
                     CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 )
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 2, 1 )
C
               ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
C
                  P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ),
     $                        1 )
                  P12 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L2 ),
     $                        1 )
                  P22 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L2 ),
     $                        1 )
C
                  DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ),
     $                                1 )
                  SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ),
     $                         1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) +
     $                                                 P12*B( L2, L1 ) )
C
                  DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC,
     $                                  B( 1, L2 ), 1 )
                  DWORK( K2+M ) = DDOT( L1-1, C( K2, 1 ), LDC,
     $                                  B( 1, L2 ), 1 )
                  SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ),
     $                         1 )
                  VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) +
     $                                                 P12*B( L2, L2 ) )
C
                  SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ),
     $                         1 )
                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) +
     $                                                 P22*B( L2, L1 ) )
C
                  SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1+M ),
     $                         1 )
                  VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L1, L2 ) +
     $                                                 P22*B( L2, L2 ) )
C
                  CALL SB04PX( .FALSE., .FALSE., ISGN, 2, 2,
     $                         A( K1, K1 ), LDA, B( L1, L1 ), LDB, VEC,
     $                         2, SCALOC, X, 2, XNORM, IERR )
                  IF( IERR.NE.0 )
     $               INFO = 1
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 40 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
   40                CONTINUE
C
                     CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 )
                     CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 )
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 1, 2 )
                  C( K2, L1 ) = X( 2, 1 )
                  C( K2, L2 ) = X( 2, 2 )
               END IF
C
   50       CONTINUE
C
   60    CONTINUE
C
      ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN
C
C        Solve     A'*X*B + ISGN*X = scale*C.
C
C        The (K,L)th block of X is determined starting from
C        upper-left corner column by column by
C
C         A(K,K)'*X(K,L)*B(L,L) + ISGN*X(K,L) = C(K,L) - R(K,L)
C
C        where
C                      K-1
C           R(K,L) = { SUM [A(J,K)'*X(J,L)] } * B(L,L) +
C                      J=1
C                       K              L-1
C                      SUM A(J,K)' * { SUM [X(J,I)*B(I,L)] }.
C                      J=1             I=1
C
C        Start column loop (index = L)
C        L1 (L2): column index of the first (last) row of X(K,L).
C
         LNEXT = 1
C
         DO 120 L = 1, N
            IF( L.LT.LNEXT )
     $         GO TO 120
            L1 = L
            IF( L.EQ.N ) THEN
               L2 = L
            ELSE
               IF( B( L+1, L ).NE.ZERO ) THEN
                  L2 = L + 1
               ELSE
                  L2 = L
               END IF
               LNEXT = L2 + 1
            END IF
C
C           Start row loop (index = K)
C           K1 (K2): row index of the first (last) row of X(K,L).
C
            KNEXT = 1
C
            DO 110 K = 1, M
               IF( K.LT.KNEXT )
     $            GO TO 110
               K1 = K
               IF( K.EQ.M ) THEN
                  K2 = K
               ELSE
                  IF( A( K+1, K ).NE.ZERO ) THEN
                     K2 = K + 1
                  ELSE
                     K2 = K
                  END IF
                  KNEXT = K2 + 1
               END IF
C
               P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
               DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1),
     $                             1 )
C
               IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
C
                  SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) )
                  SCALOC = ONE
C
                  A11  = A( K1, K1 )*B( L1, L1 ) + SGN
                  DA11 = ABS( A11 )
                  IF( DA11.LE.SMIN ) THEN
                     A11  = SMIN
                     DA11 = SMIN
                     INFO = 1
                  END IF
                  DB = ABS( VEC( 1, 1 ) )
                  IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
                     IF( DB.GT.BIGNUM*DA11 )
     $                  SCALOC = ONE / DB
                  END IF
                  X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 70 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
   70                CONTINUE
C
                     CALL DSCAL( K1, SCALOC, DWORK, 1 )
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
C
               ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
C
                  P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
                  DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC,
     $                                B( 1, L1), 1 )
                  SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) )
C
                  SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 )
                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) )
C
                  CALL DLALN2( .TRUE., 2, 1, SMIN, B( L1, L1 ),
     $                         A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN,
     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 )
     $               INFO = 1
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 80 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
   80                CONTINUE
C
                     CALL DSCAL( K2, SCALOC, DWORK, 1 )
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K2, L1 ) = X( 2, 1 )
C
               ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
C
                  P12  = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
                  SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) +
     $                                                 P12*B( L2, L1 ) )
C
                  DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC,
     $                                  B( 1, L2 ), 1 )
                  SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK( M+1 ), 1 )
                  VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) +
     $                                                 P12*B( L2, L2 ) )
C
                  CALL DLALN2( .TRUE., 2, 1, SMIN, A( K1, K1 ),
     $                         B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN,
     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 )
     $               INFO = 1
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 90 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
   90                CONTINUE
C
                     CALL DSCAL( K1, SCALOC, DWORK, 1 )
                     CALL DSCAL( K1, SCALOC, DWORK( M+1 ), 1 )
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 2, 1 )
C
               ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
C
                  P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
                  P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
                  P22 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 )
C
                  DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC,
     $                                B( 1, L1), 1 )
                  SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) +
     $                                                 P12*B( L2, L1 ) )
C
                  SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 )
                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) +
     $                                                 P22*B( L2, L1 ) )
C
                  DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC,
     $                                  B( 1, L2 ), 1 )
                  DWORK( K2+M ) = DDOT( L1-1, C( K2, 1 ), LDC,
     $                                  B( 1, L2 ), 1 )
                  SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK( M+1 ), 1 )
                  VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) +
     $                                                 P12*B( L2, L2 ) )
C
                  SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK( M+1 ), 1 )
                  VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L1, L2 ) +
     $                                                 P22*B( L2, L2 ) )
C
                  CALL SB04PX( .TRUE., .FALSE., ISGN, 2, 2, A( K1, K1 ),
     $                         LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X,
     $                         2, XNORM, IERR )
                  IF( IERR.NE.0 )
     $               INFO = 1
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 100 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
  100                CONTINUE
C
                     CALL DSCAL( K2, SCALOC, DWORK, 1 )
                     CALL DSCAL( K2, SCALOC, DWORK( M+1 ), 1 )
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 1, 2 )
                  C( K2, L1 ) = X( 2, 1 )
                  C( K2, L2 ) = X( 2, 2 )
               END IF
C
  110       CONTINUE
C
  120    CONTINUE
C
      ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN
C
C        Solve    A'*X*B' + ISGN*X = scale*C.
C
C        The (K,L)th block of X is determined starting from
C        top-right corner column by column by
C
C           A(K,K)'*X(K,L)*B(L,L)' + ISGN*X(K,L) = C(K,L) - R(K,L)
C
C        where
C                      K-1
C           R(K,L) = { SUM [A(J,K)'*X(J,L)] } * B(L,L)' +
C                      J=1
C                       K               N
C                      SUM A(J,K)' * { SUM [X(J,I)*B(L,I)'] }.
C                      J=1            I=L+1
C
C        Start column loop (index = L)
C        L1 (L2): column index of the first (last) row of X(K,L).
C
         LNEXT = N
C
         DO 180 L = N, 1, -1
            IF( L.GT.LNEXT )
     $         GO TO 180
            L2 = L
            IF( L.EQ.1 ) THEN
               L1 = L
            ELSE
               IF( B( L, L-1 ).NE.ZERO ) THEN
                  L1 = L - 1
               ELSE
                  L1 = L
               END IF
               LNEXT = L1 - 1
            END IF
C
C           Start row loop (index = K)
C           K1 (K2): row index of the first (last) row of X(K,L).
C
            KNEXT = 1
C
            DO 170 K = 1, M
               IF( K.LT.KNEXT )
     $            GO TO 170
               K1 = K
               IF( K.EQ.M ) THEN
                  K2 = K
               ELSE
                  IF( A( K+1, K ).NE.ZERO ) THEN
                     K2 = K + 1
                  ELSE
                     K2 = K
                  END IF
                  KNEXT = K2 + 1
               END IF
C
               MNL1 = MIN( L1+1, N )
               MNL2 = MIN( L2+1, N )
               P11  = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
               DWORK( K1 ) = DDOT( N-L2, C( K1, MNL2 ), LDC,
     $                             B( L1, MNL2 ), LDB )
C
               IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
                  SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) )
                  SCALOC = ONE
C
                  A11  = A( K1, K1 )*B( L1, L1 ) + SGN
                  DA11 = ABS( A11 )
                  IF( DA11.LE.SMIN ) THEN
                     A11  = SMIN
                     DA11 = SMIN
                     INFO = 1
                  END IF
                  DB = ABS( VEC( 1, 1 ) )
                  IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
                     IF( DB.GT.BIGNUM*DA11 )
     $                  SCALOC = ONE / DB
                  END IF
                  X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 130 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
  130                CONTINUE
C
                     CALL DSCAL( K1, SCALOC, DWORK, 1 )
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
C
               ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
C
                  P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
                  DWORK( K2 ) = DDOT( N-L1, C( K2, MNL1 ), LDC,
     $                                B( L1, MNL1 ), LDB )
                  SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) )
C
                  SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 )
                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) )
C
                  CALL DLALN2( .TRUE., 2, 1, SMIN, B( L1, L1 ),
     $                         A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN,
     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 )
     $               INFO = 1
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 140 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
  140                CONTINUE
C
                     CALL DSCAL( K2, SCALOC, DWORK, 1 )
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K2, L1 ) = X( 2, 1 )
C
               ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
C
                  P12  = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
                  SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) +
     $                                                 P12*B( L1, L2 ) )
C
                  DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC,
     $                                  B( L2, MNL2 ), LDB )
                  SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK( M+1 ), 1 )
                  VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) +
     $                                                 P12*B( L2, L2 ) )
C
                  CALL DLALN2( .FALSE., 2, 1, SMIN, A( K1, K1 ),
     $                         B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN,
     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 )
     $               INFO = 1
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 150 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
  150                CONTINUE
C
                     CALL DSCAL( K1, SCALOC, DWORK, 1 )
                     CALL DSCAL( K1, SCALOC, DWORK(M+1), 1 )
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 2, 1 )
C
               ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
C
                  P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
                  P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
                  P22 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 )
C
                  DWORK( K2 ) = DDOT( N-L2, C( K2, MNL2 ), LDC,
     $                                B( L1, MNL2 ), LDB )
                  SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) +
     $                                                 P12*B( L1, L2 ) )
C
                  SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 )
                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) +
     $                                                 P22*B( L1, L2 ) )
C
                  DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC,
     $                                  B( L2, MNL2 ), LDB )
                  DWORK( K2+M ) = DDOT( N-L2, C( K2, MNL2 ), LDC,
     $                                  B( L2, MNL2 ), LDB )
                  SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK( M+1 ), 1 )
                  VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) +
     $                                                 P12*B( L2, L2 ) )
C
                  SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK( M+1 ), 1 )
                  VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L2, L1 ) +
     $                                                 P22*B( L2, L2 ) )
C
                  CALL SB04PX( .TRUE., .TRUE., ISGN, 2, 2, A( K1, K1 ),
     $                         LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X,
     $                         2, XNORM, IERR )
                  IF( IERR.NE.0 )
     $               INFO = 1
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 160 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
  160                CONTINUE
C
                     CALL DSCAL( K2, SCALOC, DWORK, 1 )
                     CALL DSCAL( K2, SCALOC, DWORK(M+1), 1 )
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 1, 2 )
                  C( K2, L1 ) = X( 2, 1 )
                  C( K2, L2 ) = X( 2, 2 )
               END IF
C
  170       CONTINUE
C
  180    CONTINUE
C
      ELSE
C
C        Solve    A*X*B' + ISGN*X = scale*C.
C
C        The (K,L)th block of X is determined starting from
C        bottom-right corner column by column by
C
C            A(K,K)*X(K,L)*B(L,L)' + ISGN*X(K,L) = C(K,L) - R(K,L)
C
C        where
C                       M
C           R(K,L) = { SUM [A(K,J)*X(J,L)] } * B(L,L)' +
C                     J=K+1
C                       M              N
C                      SUM { A(K,J) * SUM [X(J,I)*B(L,I)'] }.
C                      J=K           I=L+1
C
C        Start column loop (index = L)
C        L1 (L2): column index of the first (last) row of X(K,L).
C
         LNEXT = N
C
         DO 240 L = N, 1, -1
            IF( L.GT.LNEXT )
     $         GO TO 240
            L2 = L
            IF( L.EQ.1 ) THEN
               L1 = L
            ELSE
               IF( B( L, L-1 ).NE.ZERO ) THEN
                  L1 = L - 1
               ELSE
                  L1 = L
               END IF
               LNEXT = L1 - 1
            END IF
C
C           Start row loop (index = K)
C           K1 (K2): row index of the first (last) row of X(K,L).
C
            KNEXT = M
C
            DO 230 K = M, 1, -1
               IF( K.GT.KNEXT )
     $            GO TO 230
               K2 = K
               IF( K.EQ.1 ) THEN
                  K1 = K
               ELSE
                  IF( A( K, K-1 ).NE.ZERO ) THEN
                     K1 = K - 1
                  ELSE
                     K1 = K
                  END IF
                  KNEXT = K1 - 1
               END IF
C
               MNK1 = MIN( K1+1, M )
               MNK2 = MIN( K2+1, M )
               MNL1 = MIN( L1+1, N )
               MNL2 = MIN( L2+1, N )
               P11  = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L1 ), 1 )
               DWORK( K1 ) = DDOT( N-L2, C( K1, MNL2 ), LDC,
     $                             B( L1, MNL2 ), LDB )
C
               IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
C
                  SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ),
     $                         1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) )
                  SCALOC = ONE
C
                  A11  = A( K1, K1 )*B( L1, L1 ) + SGN
                  DA11 = ABS( A11 )
                  IF( DA11.LE.SMIN ) THEN
                     A11  = SMIN
                     DA11 = SMIN
                     INFO = 1
                  END IF
                  DB = ABS( VEC( 1, 1 ) )
                  IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
                     IF( DB.GT.BIGNUM*DA11 )
     $                  SCALOC = ONE / DB
                  END IF
                  X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 190 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
  190                CONTINUE
C
                     CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 )
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
C
               ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
C
                  P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ),
     $                        1 )
                  DWORK( K2 ) = DDOT( N-L1, C( K2, MNL1 ), LDC,
     $                                B( L1, MNL1 ), LDB )
                  SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ),
     $                         1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) )
C
                  SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ),
     $                         1 )
                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) )
C
                  CALL DLALN2( .FALSE., 2, 1, SMIN, B( L1, L1 ),
     $                         A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN,
     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 )
     $               INFO = 1
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 200 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
  200                CONTINUE
C
                     CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 )
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K2, L1 ) = X( 2, 1 )
C
               ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
C
                  P12  = DDOT( M-K1, A( K1, MNK1 ), LDA, C( MNK1, L2 ),
     $                         1 )
                  SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ),
     $                         1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) +
     $                                                 P12*B( L1, L2 ) )
C
                  DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC,
     $                                  B( L2, MNL2 ), LDB )
                  SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ),
     $                         1 )
                  VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) +
     $                                                 P12*B( L2, L2 ) )
C
                  CALL DLALN2( .FALSE., 2, 1, SMIN, A( K1, K1 ),
     $                         B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN,
     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 )
     $               INFO = 1
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 210 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
  210                CONTINUE
C
                     CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 )
                     CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 )
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 2, 1 )
C
               ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
C
                  P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ),
     $                        1 )
                  P12 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L2 ),
     $                        1 )
                  P22 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L2 ),
     $                        1 )
C
                  DWORK( K2 ) = DDOT( N-L2, C( K2, MNL2 ), LDC,
     $                                B( L1, MNL2 ), LDB )
                  SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ),
     $                         1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) +
     $                                                 P12*B( L1, L2 ) )
C
                  SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ),
     $                         1 )
                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) +
     $                                                 P22*B( L1, L2 ) )
C
                  DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC,
     $                                  B( L2, MNL2 ), LDB )
                  DWORK( K2+M ) = DDOT( N-L2, C( K2, MNL2 ), LDC,
     $                                  B( L2, MNL2 ), LDB )
                  SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ),
     $                         1 )
                  VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) +
     $                                                 P12*B( L2, L2 ) )
C
                  SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1+M ),
     $                         1 )
                  VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L2, L1 ) +
     $                                                 P22*B( L2, L2 ) )
C
                  CALL SB04PX( .FALSE., .TRUE., ISGN, 2, 2, A( K1, K1 ),
     $                         LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X,
     $                         2, XNORM, IERR )
                  IF( IERR.NE.0 )
     $               INFO = 1
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 220 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
  220                CONTINUE
C
                     CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 )
                     CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 )
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 1, 2 )
                  C( K2, L1 ) = X( 2, 1 )
                  C( K2, L2 ) = X( 2, 2 )
               END IF
C
  230       CONTINUE
C
  240    CONTINUE
C
      END IF
C
      RETURN
C *** Last line of SB04PY ***
      END


      subroutine runY_i1i2i3i4i5(i,j,i1,i2,i3,i4,i5,f,Xtwiddle,
     . Gtt,Gtwiddle,Shat6,Czero5,N0)
      implicit none
C---  Expression for Eq. 5.61
      include 'TRconstants.f'
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,i,j,i1,i2,i3,i4,i5,n,m,np
      parameter(np=3)
      double precision
     . Xtwiddle(0:np,0:np),Gtwiddle(np,np),f(np),Gtt(np,np,np,np)
      double complex Shat6(np,z5max,-2:0),Czero5(z5max,-2:0),
     . bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gtt(i,n,j,m)*f(n)
     . *(Shat6(m,z5(i1,i2,i3,i4,i5),ep)
     . -2d0*delta(m,i1)*Dv(dzziiii(z4(i2,i3,i4,i5))+N0,ep)
     . -2d0*delta(m,i2)*Dv(dzziiii(z4(i1,i3,i4,i5))+N0,ep)
     . -2d0*delta(m,i3)*Dv(dzziiii(z4(i1,i2,i4,i5))+N0,ep)
     . -2d0*delta(m,i4)*Dv(dzziiii(z4(i1,i2,i3,i5))+N0,ep)
     . -2d0*delta(m,i5)*Dv(dzziiii(z4(i1,i2,i3,i4))+N0,ep))
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=-4d0*Dv(dzziiiii(z5(i1,i2,i3,i4,i5))+N0,ep-1)
      Dv(diiiii(z5(i1,i2,i3,i4,i5))+N0,ep)=
     .  (Gtwiddle(i,j)
     . *(12d0*Dv(dzziiiii(z5(i1,i2,i3,i4,i5))+N0,ep)
     .  +pole-Czero5(z5(i1,i2,i3,i4,i5),ep))
     .  +bit+Xtwiddle(0,j)*Dv(diiiiii(z6(i,i1,i2,i3,i4,i5))+N0,ep)
     .   )/Xtwiddle(i,j)

      enddo
      return
      end


      SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
     $                   LDVR, MM, M, WORK, INFO )
      DOUBLE PRECISION   T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
     $                   WORK( * )
      DOUBLE PRECISION   X( 2, 2 )
      CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
     $                            ZERO, X, 2, SCALE, XNORM, IERR )
      CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
      DO 90 J = KI - 2, 1, -1
      IF( J.GT.JNXT )
     $               GO TO 90
      JNXT = J - 1
      IF( J.GT.1 ) THEN
          IF( T( J, J-1 ).NE.ZERO ) THEN
              IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
                  X( 1, 1 ) = X( 1, 1 ) / XNORM
              END IF
          END IF
          CALL DLALN2( .FALSE., 2, 2, SMIN, ONE,
     $                            T( J-1, J-1 ), LDT, ONE, ONE,
     $                            XNORM, IERR )
          CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
     $                           WORK( 1+N ), 1 )
          CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1,
     $                           WORK( 1+N2 ), 1 )
      END IF
   90          CONTINUE
      END


C    %W% %G%
      real function tzlag (kk,t1,dt,x0,x1,y0,ndivs)

      implicit none
      real kk,t1,dt,x0,x1,y0
      integer ndivs

c     -  solves a first order lag block:
c              kk
c            -------
c            1 + sT1
c
c     -   Sub-time step logic is used if ndivs > 1
c
c     -   subscript 0 means value at start of interval
c             "     1  "      "   "   end  "     "
c     -   x is input var
c         y is output var
c
      real aa,bb,xa,xb,ya,yb,y1
      real rdivs,r0wt,r1wt,dts
      integer ia,ib,la

c     -     begin     begin     begin     begin     begin     begin

      if (t1 .eq. 0.0) then
        tzlag = kk * x1
        return
      endif
      if (dt .eq. 0.0) then
        tzlag = y0
        return
      endif
      if (ndivs .le. 1) then
        aa = dt / 2.0 / t1
        bb = kk * (x0 + x1)
        tzlag = ( y0 - aa * y0 + aa * bb) / (aa + 1.0)
        return
      endif

c     /*  -  here if using sub-time steps  */

      rdivs = ndivs
      r0wt = rdivs
      r1wt = 0.0
      dts = dt / rdivs
      xa = x0
      xb = x1
      ya = y0
      aa = dts / 2.0 / t1
      do la = 1,ndivs
        r0wt = r0wt - 1.0
        r1wt = r1wt + 1.0
        xb = ((r0wt * x0) + (r1wt * x1)) / rdivs
        bb = kk * (xa + xb)
        yb =  ( ya - aa * ya + aa * bb) / (aa + 1.0)
        ya = yb
        xa = xb
      enddo
      tzlag = yb
c     -
      return
      end


!==============================================================================!
  subroutine Compute_Geometry(grid)
!------------------------------------------------------------------------------!
!   Calculates geometrical quantities of the grid.                             !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use all_mod
  use gen_mod
  use Grid_Mod
  use Tokenizer_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
!------------------------------------------------------------------------------!
  include "../Shared/Approx.int"
!----------------------------------[Calling]-----------------------------------!
  real :: Distance
  real :: Distance_Squared
  real :: Tol
!-----------------------------------[Locals]-----------------------------------!
  integer              :: c, c1, c2, n, s, ss, cc2, c_max, nnn, hh, mm, b
  integer              :: c11, c12, c21, c22, s1, s2, bou_cen
  integer              :: new_face_1, new_face_2
  integer              :: type_per, n_per, number_sides, dir, option
  integer              :: wall_mark, rot_dir
  real                 :: xt(4), yt(4), zt(4), angle_face
  real                 :: xs2, ys2, zs2, x_a, y_a, z_a, x_b, y_b, z_b
  real                 :: x_c, y_c, z_c, Det
  real                 :: ab_i, ab_j, ab_k, ac_i, ac_j, ac_k, p_i, p_j, p_k
  real                 :: dsc1, dsc2, per_min, per_max
  real                 :: t, SurTot, angle
  real                 :: xc1, yc1, zc1, xc2, yc2, zc2
  real                 :: max_dis, tot_vol, min_vol, max_vol
  real                 :: xmin, xmax, ymin, ymax, zmin, zmax
  real, allocatable    :: xspr(:), yspr(:), zspr(:)
  real, allocatable    :: b_coor(:), phi_face(:)
  integer, allocatable :: b_face(:), face_copy(:)
  character(len=80)    :: name_per
!==============================================================================!
!
!                                n3
!                 +---------------!---------------+
!                /|              /|              /|
!               / |             / |             / |
!              /  |          n2/  |            /  |
!             +---------------!---------------+   |
!             |   |           |   |           |   |
!             |   |     o---- | s-------o     |   |
!             |   +---- c1 ---|   !---- c2 ---|   +
!             |  /            |  /n4          |  /
!             | /             | /             | /
!             |/              |/              |/
!             +---------------!---------------+
!                            n1
!
!   Notes:
!
!     ! side s is oriented from cell center c1 to cell center c2
!     ! c2 is greater then c1 inside the domain or smaller then 0
!       on the boundary
!     ! nodes are denoted with n1 - n4
!
!            c3
!             \  4-----3
!              \/ \  . |
!              /   \  +---c2
!             /  .  \  |
!            / .     \ |
!           /.        \|
!          1-----------2
!                   |
!                   c1
!
!                                n3
!                 +---------------!-------+
!                /|            n2/|      /|
!               / |             !-------+ |
!              /  |            /|s|  c2 | |
!             +---------------+ | !-----| +
!             |   |           | |/n4    |/
!             |   |     c1    | !-------+
!             |   +-----------|n1 +
!             |  /            |  /
!             | /             | /
!             |/              |/
!             +---------------+
!                            n1
!
!------------------------------------------------------------------------------!
!   Generaly:
!
!   the equation of plane reads: A*x_node + B*y_node + C*z_node + D = 0
!
!   and the equation of line:  x_node = x0 + t*rx
!                              y_node = y0 + t*ry
!                              z_node = z0 + t*rz
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!   In our case:
!
!     line is a connection between the two cell centers:
!
!     x_node = xc(c1) + t*(xc(c2)-xc(c1)) = xc(c1) + t*rx
!     y_node = yc(c1) + t*(yc(c2)-yc(c1)) = yc(c1) + t*ry
!     z_node = zc(c1) + t*(zc(c2)-zc(c1)) = zc(c1) + t*rz
!
!
!     plane is a cell face:
!
!     Sx * x_node + Sy * y_node + Sz * z_node =
!     Sx * xsp(s) + Sy * ysp(s) + Sz * zsp(s)
!
!     and the intersection is at:
!
!         Sx*(xsp(s)-xc(c1)) + Sy*(ysp(s)-yc(c1) + Sz*(zsp(s)-zc(c1))
!     t = -----------------------------------------------------------
!                           rx*Sx + ry*Sy + rz*Sz
!
!------------------------------------------------------------------------------!

  !-----------------------------------------!
  !   Calculate the cell centers            !
  !-----------------------------------------!
  !   => depends on: x_node,y_node,z_node   !
  !   <= gives:      xc,yc,zc c>0           !
  !-----------------------------------------!
  do c = 1, grid % n_cells
    do n = 1, grid % cells_n_nodes(c)
      grid % xc(c) = grid % xc(c) + grid % xn(grid % cells_n(n,c))  &
                   / (1.0*grid % cells_n_nodes(c))
      grid % yc(c) = grid % yc(c) + grid % yn(grid % cells_n(n,c))  &
                   / (1.0*grid % cells_n_nodes(c))
      grid % zc(c) = grid % zc(c) + grid % zn(grid % cells_n(n,c))  &
                   / (1.0*grid % cells_n_nodes(c))
    end do
  end do

  write(*,*) '# Cell centers calculated !'

  !-----------------------------------------------------!
  !   Calculate:                                        !
  !      components of cell sides, cell side centers.   !
  !-----------------------------------------------------!
  !   => depends on: x_node,y_node,z_node               !
  !   <= gives:      Sx,Sy,Sz,xsp,yzp,zsp               !
  !-----------------------------------------------------!
  do s = 1, grid % n_faces
    do n = 1, grid % faces_n_nodes(s)    ! for quadrilateral an triangular faces
      xt(n)=grid % xn(grid % faces_n(n,s))
      yt(n)=grid % yn(grid % faces_n(n,s))
      zt(n)=grid % zn(grid % faces_n(n,s))
    end do

    ! Cell side components
    if( grid % faces_n_nodes(s)  ==  4 ) then
      grid % sx(s)= 0.5 * ( (yt(2)-yt(1))*(zt(2)+zt(1))   &
                           +(yt(3)-yt(2))*(zt(2)+zt(3))   &
                           +(yt(4)-yt(3))*(zt(3)+zt(4))   &
                           +(yt(1)-yt(4))*(zt(4)+zt(1)) )
      grid % sy(s)= 0.5 * ( (zt(2)-zt(1))*(xt(2)+xt(1))   &
                           +(zt(3)-zt(2))*(xt(2)+xt(3))   &
                           +(zt(4)-zt(3))*(xt(3)+xt(4))   &
                           +(zt(1)-zt(4))*(xt(4)+xt(1)) )
      grid % sz(s)= 0.5 * ( (xt(2)-xt(1))*(yt(2)+yt(1))   &
                           +(xt(3)-xt(2))*(yt(2)+yt(3))   &
                           +(xt(4)-xt(3))*(yt(3)+yt(4))   &
                           +(xt(1)-xt(4))*(yt(4)+yt(1)) )
    else if( grid % faces_n_nodes(s)  ==  3 ) then
      grid % sx(s)= 0.5 * ( (yt(2)-yt(1))*(zt(2)+zt(1))   &
                           +(yt(3)-yt(2))*(zt(2)+zt(3))   &
                           +(yt(1)-yt(3))*(zt(3)+zt(1)) )
      grid % sy(s)= 0.5 * ( (zt(2)-zt(1))*(xt(2)+xt(1))   &
                           +(zt(3)-zt(2))*(xt(2)+xt(3))   &
                           +(zt(1)-zt(3))*(xt(3)+xt(1)) )
      grid % sz(s)= 0.5 * ( (xt(2)-xt(1))*(yt(2)+yt(1))   &
                           +(xt(3)-xt(2))*(yt(2)+yt(3))   &
                           +(xt(1)-xt(3))*(yt(3)+yt(1)) )
    else
      write(*,*) 'calc4: something horrible has happened !'
      stop
    end if

    ! Barycenters
    if(grid % faces_n_nodes(s) == 4) then
      grid % xf(s) = (xt(1)+xt(2)+xt(3)+xt(4))/4.0
      grid % yf(s) = (yt(1)+yt(2)+yt(3)+yt(4))/4.0
      grid % zf(s) = (zt(1)+zt(2)+zt(3)+zt(4))/4.0
    else if(grid % faces_n_nodes(s) == 3) then
      grid % xf(s) = (xt(1)+xt(2)+xt(3))/3.0
      grid % yf(s) = (yt(1)+yt(2)+yt(3))/3.0
      grid % zf(s) = (zt(1)+zt(2)+zt(3))/3.0
    end if

  end do ! through sides

  write(*,*) '# Cell face components calculated !'

  !--------------------------------------!
  !   Calculate boundary cell centers    !
  !--------------------------------------!
  !   => depends on: xc,yc,zc,Sx,Sy,Sz   !
  !   <= gives:      xc,yc,zc for c<0    !
  !--------------------------------------!
  write(*,*) '#===================================='
  write(*,*) '# Position the boundary cell centres:'
  write(*,*) '#------------------------------------'
  write(*,*) '# Type 1 for barycentric placement'
  write(*,*) '# Type 2 for orthogonal placement'
  write(*,*) '#------------------------------------'
  read(*,*) bou_cen

  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)

    SurTot = sqrt(  grid % sx(s)*grid % sx(s)  &
                  + grid % sy(s)*grid % sy(s)  &
                  + grid % sz(s)*grid % sz(s) )

    if(c2  < 0) then
      t = (   grid % sx(s)*(grid % xf(s) - grid % xc(c1))        &
            + grid % sy(s)*(grid % yf(s) - grid % yc(c1))        &
            + grid % sz(s)*(grid % zf(s) - grid % zc(c1)) ) / SurTot
      grid % xc(c2) = grid % xc(c1) + grid % sx(s)*t / SurTot
      grid % yc(c2) = grid % yc(c1) + grid % sy(s)*t / SurTot
      grid % zc(c2) = grid % zc(c1) + grid % sz(s)*t / SurTot
      if(bou_cen == 1) then
        grid % xc(c2) = grid % xf(s)
        grid % yc(c2) = grid % yf(s)
        grid % zc(c2) = grid % zf(s)
      end if
    endif
  end do ! through sides

  !---------------------------------------------------------------!
  !   Move the centers of co-planar molecules towards the walls   !
  !---------------------------------------------------------------!
  !   => depends on: xc,yc,zc                                     !
  !   <= gives:      xc,yc,zc                                     !
  !   +  uses:       Dx,Dy,Dz                                     !
  !---------------------------------------------------------------!
  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)

    if(c2 > 0) then
      grid % dx(c1) = max( grid % dx(c1), abs( grid % xc(c2) - grid % xc(c1) ) )
      grid % dy(c1) = max( grid % dy(c1), abs( grid % yc(c2) - grid % yc(c1) ) )
      grid % dz(c1) = max( grid % dz(c1), abs( grid % zc(c2) - grid % zc(c1) ) )
      grid % dx(c2) = max( grid % dx(c2), abs( grid % xc(c2) - grid % xc(c1) ) )
      grid % dy(c2) = max( grid % dy(c2), abs( grid % yc(c2) - grid % yc(c1) ) )
      grid % dz(c2) = max( grid % dz(c2), abs( grid % zc(c2) - grid % zc(c1) ) )
    end if
  end do ! through sides

  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)

    if(c2 < 0) then
      if( Approx(grid % dx(c1), 0.0, 1.e-6) )  &
        grid % xc(c1) = 0.75*grid % xc(c1) + 0.25*grid % xc(c2)
      if( Approx(grid % dy(c1), 0.0, 1.e-6) )  &
        grid % yc(c1) = 0.75*grid % yc(c1) + 0.25*grid % yc(c2)
      if( Approx(grid % dz(c1), 0.0, 1.e-6) )  &
        grid % zc(c1) = 0.75*grid % zc(c1) + 0.25*grid % zc(c2)
    end if
  end do ! through sides

  ! Why are the following three lines needed?
  grid % dx = 0.0
  grid % dy = 0.0
  grid % dz = 0.0

  !--------------------------------------------!
  !   Find the sides on the periodic boundary  !
  !--------------------------------------------!
  !   => depends on: xc,yc,zc,Sx,Sy,Sz         !
  !   <= gives:      Dx,Dy,Dz                  !
  !--------------------------------------------!
  allocate(b_coor(grid % n_faces)); b_coor=0.0
  allocate(b_face(grid % n_faces)); b_face=0

  !--------------------------------------------------------!
  !                                                        !
  !   Phase I  ->  find the sides on periodic boundaries   !
  !                                                        !
  !--------------------------------------------------------!
  option = 2

  allocate(face_copy(grid % n_faces)); face_copy=0

  write(*,*) 'Number of boundary conditions: ', grid % n_boundary_conditions

2 n_per = 0
  write(*,*) '#======================================================'
  write(*,*) '# Enter the periodic-boundary-condition name.'
  write(*,*) '# Type skip if there is none !'
  write(*,*) '#------------------------------------------------------'
  write(*,*) '# (Please note that the periodic boundaries have to be'
  write(*,*) '#  the last on the list of the boundary conditions.'
  write(*,*) '#  Their BC markers have to be larger than the markers'
  write(*,*) '#  of all the other boundary conditions.)'
  write(*,*) '#------------------------------------------------------'
  call Tokenizer_Mod_Read_Line(5)
  name_per = line % tokens(1)
  call To_Upper_Case(name_per)
  if( name_per == 'SKIP' ) then
    type_per = 0
    goto 1
  end if
  type_per = -1
  do b=1, grid % n_boundary_conditions
    if( name_per == grid % boundary_conditions(b) % name ) then
      type_per = b
    end if
  end do
  if( type_per == -1 ) then
    write(*,*) '# Critical error: boundary condition ', trim(name_per),  &
               ' can''t be found!'
    write(*,*) '# Exiting! '
    stop
  end if

  if(option == 2) then

    write(*,*) '#========================================================'
    write(*,*) '# Insert the periodic direction (1 -> x, 2 -> y, 3 -> z)'
    write(*,*) '#--------------------------------------------------------'
    read(*,*) dir
    write(*,*)
    write(*,*) '#=============================================================='
    write(*,*) '# Enter the angle for the rotation of the coordiante system (in'
    write(*,*) '# degrees) and the axes of rotation (1 -> x, 2 -> y, 3 -> z)'
    write(*,*) '#--------------------------------------------------------------'
    write(*,*) '# (If the periodic direction is not parallel to the Caresian '
    write(*,*) '#  axis (x, y and z), the coordinate system has to be rotated'
    write(*,*) '#  in 2D'
    write(*,*) '#--------------------------------------------------------------'
    read(*,*) angle, rot_dir

    angle = angle * PI / 180.0

    if(dir == 1) then
      x_a = 0.0
      y_a = 0.0
      z_a = 0.0
      x_b = 0.0
      y_b = 1.0
      z_b = 0.0
      x_c = 0.0
      y_c = 0.0
      z_c = 1.0
    else if(dir == 2) then
      x_a = 0.0
      y_a = 0.0
      z_a = 0.0
      x_b = 1.0
      y_b = 0.0
      z_b = 0.0
      x_c = 0.0
      y_c = 0.0
      z_c = 1.0
    else if(dir == 3) then
      x_a = 0.0
      y_a = 0.0
      z_a = 0.0
      x_b = 1.0
      y_b = 0.0
      z_b = 0.0
      x_c = 0.0
      y_c = 1.0
      z_c = 0.0
    end if

    ab_i = x_b - x_a
    ab_j = y_b - y_a
    ab_k = z_b - z_a

    ac_i = x_c - x_a
    ac_j = y_c - y_a
    ac_k = z_c - z_a

    p_i =  ab_j*ac_k - ac_j*ab_k
    p_j = -ab_i*ac_k + ac_i*ab_k
    p_k =  ab_i*ac_j - ac_i*ab_j

    angle_face = angle_face * PI / 180.0

    allocate(phi_face(grid % n_faces)); phi_face=0.0
    allocate(xspr(grid % n_faces)); xspr=0.0
    allocate(yspr(grid % n_faces)); yspr=0.0
    allocate(zspr(grid % n_faces)); zspr=0.0

    do s = 1, grid % n_faces
      c2 = grid % faces_c(2,s)
      if(c2 < 0) then
        if(BCmark(c2) == type_per) then
          if( Approx(angle, 0.0, 1.e-6) ) then
            xspr(s) = grid % xf(s)
            yspr(s) = grid % yf(s)
            zspr(s) = grid % zf(s)
          else
            if(rot_dir==3) then
              xspr(s) = grid % xf(s)*cos(angle) + grid % yf(s)*sin(angle)
              yspr(s) =-grid % xf(s)*sin(angle) + grid % yf(s)*cos(angle)
            else if(rot_dir==2) then
              xspr(s) = grid % xf(s)*cos(angle) + grid % zf(s)*sin(angle)
              zspr(s) =-grid % xf(s)*sin(angle) + grid % zf(s)*cos(angle)
            else if(rot_dir==1) then
              yspr(s) = grid % yf(s)*cos(angle) + grid % zf(s)*sin(angle)
              zspr(s) =-grid % yf(s)*sin(angle) + grid % zf(s)*cos(angle)
            end if
          end if
        end if
      end if
    end do
  end if

  xmin = +HUGE
  ymin = +HUGE
  zmin = +HUGE
  xmax = -HUGE
  ymax = -HUGE
  zmax = -HUGE

  b_coor=0.0
  b_face=0

  c = 0

  if(option == 1) then
    do s=1,grid % n_faces
      c2 = grid % faces_c(2,s)
      if(c2 < 0) then
        if(BCmark(c2) == type_per) then
          c = c + 1
          if(dir==1) b_coor(c) = grid % xf(s)*1000000.0   &
                               + grid % yf(s)*10000.0     &
                               + grid % zf(s)
          if(dir==2) b_coor(c) = grid % yf(s)*1000000.0   &
                               + grid % xf(s)*10000.0     &
                               + grid % zf(s)
          if(dir==3) b_coor(c) = grid % zf(s)*1000000.0   &
                               + grid % xf(s)*10000.0     &
                               + grid % yf(s)
          b_face(c) = s
        end if
      end if
    end do
    call Sort_Double_Carry_Int(b_coor,b_face,c,2)
  else if(option == 2) then
    c_max = 0
    do s=1,grid % n_faces
      c2 = grid % faces_c(2,s)
      if(c2 < 0) then
        if(BCmark(c2) == type_per) then
          c_max = c_max + 1
        end if
      end if
    end do
    Tol = 0.0001

10 continue

    nnn = 0
    hh = 0
    mm = 0
    c = 0

    per_max = -HUGE
    per_min =  HUGE

    do s=1,grid % n_faces
      c2 = grid % faces_c(2,s)
      if(c2 < 0) then
        if(BCmark(c2) == type_per) then
          Det = (  p_i*(grid % xf(s))  &
                 + p_j*(grid % yf(s))  &
                 + p_k*(grid % zf(s)))  &
              / sqrt(p_i*p_i + p_j*p_j + p_k*p_k)
          per_min = min(per_min, Det)
          per_max = max(per_max, Det)
        end if
      end if
    end do

    per_max = 0.5*(per_max + per_min)

    do s=1,grid % n_faces
      c2 = grid % faces_c(2,s)
      if(c2 < 0) then
        if(BCmark(c2) == type_per) then
          c = c + 1
          Det = (  p_i*(grid % xf(s))   &
                 + p_j*(grid % yf(s))   &
                 + p_k*(grid % zf(s)))  &
              / sqrt(p_i*p_i + p_j*p_j + p_k*p_k)

          if(dir==1) then
            if((Det) < (per_max)) then
              hh = hh + 1
              b_coor(hh) = hh
              b_face(hh) = s
              do ss=1,grid % n_faces
                cc2 = grid % faces_c(2,ss)
                if(cc2 < 0) then
                  if(BCmark(cc2) == type_per) then
                    Det = (  p_i * (grid % xf(ss))   &
                           + p_j * (grid % yf(ss))   &
                           + p_k * (grid % zf(ss)))  &
                        / sqrt(p_i*p_i + p_j*p_j + p_k*p_k)
                    if((Det) > (per_max)) then
                      if((abs(grid % zf(ss)  - grid % zf(s))) < Tol .and.   &
                         (abs(yspr(ss) - yspr(s))) < Tol) then
                         mm = hh + c_max/2
                         b_coor(mm) = mm
                         b_face(mm) = ss
                         nnn = nnn + 1
                      end if
                    end if
                  end if
                end if
              end do
            end if
          end if

          if(dir==2) then
            if((Det) < (per_max)) then
              hh = hh + 1
              b_coor(hh) = hh
              b_face(hh) = s
              do ss=1,grid % n_faces
                cc2 = grid % faces_c(2,ss)
                if(cc2 < 0) then
                  if(BCmark(cc2) == type_per) then

                    Det = (  p_i * (grid % xf(ss))  &
                           + p_j * (grid % yf(ss))  &
                           + p_k * (grid % zf(ss))) &
                        / sqrt(p_i*p_i + p_j*p_j + p_k*p_k)

                    if((Det) > (per_max)) then
                      if(abs((grid % zf(ss)  - grid % zf(s))) < Tol .and.  &
                         abs((xspr(ss) - xspr(s))) < Tol) then
                        mm = hh + c_max/2
                        b_coor(mm) = mm
                        b_face(mm) = ss
                        nnn = nnn + 1
                      end if
                    end if

                  end if
                end if
              end do
            end if
          end if

          if(dir==3) then
            if((Det) < (per_max)) then
              hh = hh + 1
              b_coor(hh) = hh
              b_face(hh) = s
              do ss=1,grid % n_faces
                cc2 = grid % faces_c(2,ss)
                if(cc2 < 0) then
                  if(BCmark(cc2) == type_per) then
                    Det = (  p_i*(grid % xf(ss))  &
                           + p_j*(grid % yf(ss))  &
                           + p_k*(grid % zf(ss)))  &
                        / sqrt(p_i*p_i + p_j*p_j + p_k*p_k)
                    if((Det) > (per_max)) then
!                     write(*,*) '# Warning!  Potentially a bug in ...'
!                     write(*,*) '# ... Compute_Geometry, line 557'
!                     write(*,*) '# Contact developers, and if you ... '
!                     write(*,*) '# ... are one of them, fix it!'
                      if(abs((grid % xf(ss) - grid % xf(s))) < Tol .and.  &
                         abs((grid % yf(ss) - grid % yf(s))) < Tol) then
                        mm = hh + c_max/2
                        b_coor(mm) = mm
                        b_face(mm) = ss
                        nnn = nnn + 1
                      end if
                    end if
                  end if
                end if
              end do
            end if
          end if

        end if
      end if
    end do

    write(*,*)'Iterating search for periodic cells: ',  &
    'Target: ', c_max/2, 'Result: ',nnn, 'Tolerance: ',Tol

    if(nnn == c_max/2) then
      continue
    else
      Tol = Tol*0.5
      go to 10
    end if

    deallocate(phi_face)
    deallocate(xspr)
    deallocate(yspr)
    deallocate(zspr)

    call Sort_Double_Carry_Int(b_coor,b_face,c,2)
  end if  ! end option

  do s = 1, c/2
    s1 = b_face(s)
    s2 = b_face(s+c/2)
    c11 = grid % faces_c(1,s1)  ! cell 1 for side 1
    c21 = grid % faces_c(2,s1)  ! cell 2 for cell 1
    c12 = grid % faces_c(1,s2)  ! cell 1 for side 2
    c22 = grid % faces_c(2,s2)  ! cell 2 for side 2
    face_copy(s1) = s2   ! just to remember where it was coppied from
    grid % faces_c(2,s1) = c12
    grid % faces_c(1,s2) = 0    ! c21
    grid % faces_c(2,s2) = 0    ! c21
  end do

  n_per = c/2
  write(*,*) '# Phase I: periodic cells: ', n_per
  go to 2

  !----------------------------------------------------!
  !                                                    !
  !   Phase II  ->  similar to the loop in Generator   !
  !                                                    !
  !----------------------------------------------------!
1 continue
  grid % n_sh = 0
  do s = 1, grid % n_faces

    ! Initialize
    grid % dx(s)=0.0
    grid % dy(s)=0.0
    grid % dz(s)=0.0

    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)
    if(c2   >  0) then

      ! Scalar product of the side with line c1-c2 is good criteria
      if( (grid % sx(s) * (grid % xc(c2)-grid % xc(c1) )+                  &
           grid % sy(s) * (grid % yc(c2)-grid % yc(c1) )+                  &
           grid % sz(s) * (grid % zc(c2)-grid % zc(c1) ))  < 0.0 ) then

        grid % n_sh = grid % n_sh + 2

        ! Find the coordinates of ...
        if(grid % faces_n_nodes(s) == 4) then

          ! Coordinates of the shadow face
          xs2=grid % xf(face_copy(s))
          ys2=grid % yf(face_copy(s))
          zs2=grid % zf(face_copy(s))

          ! Add shadow faces
          new_face_1 = grid % n_faces+grid % n_sh-1
          new_face_2 = grid % n_faces+grid % n_sh
          grid % faces_n_nodes(new_face_1) = 4
          grid % faces_c(1, new_face_1) = c1
          grid % faces_c(2, new_face_1) = -grid % n_bnd_cells-1
          grid % faces_n(1, new_face_1) = grid % faces_n(1,s)
          grid % faces_n(2, new_face_1) = grid % faces_n(2,s)
          grid % faces_n(3, new_face_1) = grid % faces_n(3,s)
          grid % faces_n(4, new_face_1) = grid % faces_n(4,s)
          grid % sx(new_face_1) = grid % sx(s)
          grid % sy(new_face_1) = grid % sy(s)
          grid % sz(new_face_1) = grid % sz(s)
          grid % xf(new_face_1) = grid % xf(s)
          grid % yf(new_face_1) = grid % yf(s)
          grid % zf(new_face_1) = grid % zf(s)
          grid % faces_n_nodes(new_face_2) = 4
          grid % faces_c(1, new_face_2) = c2
          grid % faces_c(2, new_face_2) = -grid % n_bnd_cells-1
          grid % faces_n(1, new_face_2) = grid % faces_n(1,face_copy(s))
          grid % faces_n(2, new_face_2) = grid % faces_n(2,face_copy(s))
          grid % faces_n(3, new_face_2) = grid % faces_n(3,face_copy(s))
          grid % faces_n(4, new_face_2) = grid % faces_n(4,face_copy(s))
          grid % sx(new_face_2) = grid % sx(s)
          grid % sy(new_face_2) = grid % sy(s)
          grid % sz(new_face_2) = grid % sz(s)
          grid % xf(new_face_2) = xs2
          grid % yf(new_face_2) = ys2
          grid % zf(new_face_2) = zs2
        else if(grid % faces_n_nodes(s) == 3) then

          ! Coordinates of the shadow face
          xs2=grid % xf(face_copy(s))
          ys2=grid % yf(face_copy(s))
          zs2=grid % zf(face_copy(s))

          ! Add shadow faces
          new_face_1 = grid % n_faces+grid % n_sh-1
          new_face_2 = grid % n_faces+grid % n_sh
          grid % faces_n_nodes(new_face_1) = 3
          grid % faces_c(1, new_face_1) = c1
          grid % faces_c(2, new_face_1) = -grid % n_bnd_cells-1
          grid % faces_n(1, new_face_1) = grid % faces_n(1,s)
          grid % faces_n(2, new_face_1) = grid % faces_n(2,s)
          grid % faces_n(3, new_face_1) = grid % faces_n(3,s)
          grid % sx(new_face_1) = grid % sx(s)
          grid % sy(new_face_1) = grid % sy(s)
          grid % sz(new_face_1) = grid % sz(s)
          grid % xf(new_face_1) = grid % xf(s)
          grid % yf(new_face_1) = grid % yf(s)
          grid % zf(new_face_1) = grid % zf(s)
          grid % faces_n_nodes(new_face_2) = 3
          grid % faces_c(1, new_face_2) = c2
          grid % faces_c(2, new_face_2) = -grid % n_bnd_cells-1
          grid % faces_n(1, new_face_2) = grid % faces_n(1,face_copy(s))
          grid % faces_n(2, new_face_2) = grid % faces_n(2,face_copy(s))
          grid % faces_n(3, new_face_2) = grid % faces_n(3,face_copy(s))
          grid % sx(new_face_2) = grid % sx(s)
          grid % sy(new_face_2) = grid % sy(s)
          grid % sz(new_face_2) = grid % sz(s)
          grid % xf(new_face_2) = xs2
          grid % yf(new_face_2) = ys2
          grid % zf(new_face_2) = zs2
        end if

        grid % dx(s) = grid % xf(s) - xs2  !
        grid % dy(s) = grid % yf(s) - ys2  ! later: xc2 = xc2 + Dx
        grid % dz(s) = grid % zf(s) - zs2  !

      endif !  S*(c2-c1) < 0.0
    end if  !  c2 > 0
  end do    !  sides
  write(*,*) '# Phase II: number of shadow faces: ', grid % n_sh

  deallocate(face_copy)

  !-------------------------------------------------------!
  !                                                       !
  !   Phase III  ->  find the new numbers of cell faces   !
  !                                                       !
  !-------------------------------------------------------!
  number_sides = 0
  do s = 1, grid % n_faces+grid % n_sh
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)
    if(c1 > 0) then
      number_sides = number_sides  + 1
      NewS(s) = number_sides
    else
      NewS(s) = -1
    end if
  end do
  write(*,'(A22,I9,Z9)') ' # Old number of sides: ', &
                          grid % n_faces, grid % n_faces
  write(*,'(A22,I9,Z9)') ' # New number of sides: ', &
                          number_sides-grid % n_sh,number_sides-grid % n_sh

  !--------------------------------------!
  !                                      !
  !   Phase IV  ->  compress the sides   !
  !                                      !
  !--------------------------------------!
  do s = 1, grid % n_faces+grid % n_sh
    if(NewS(s) > 0) then
      grid % faces_c(1,NewS(s)) = grid % faces_c(1,s)
      grid % faces_c(2,NewS(s)) = grid % faces_c(2,s)
      grid % faces_n_nodes(NewS(s)) = grid % faces_n_nodes(s)
      grid % faces_n(1,NewS(s)) = grid % faces_n(1,s)
      grid % faces_n(2,NewS(s)) = grid % faces_n(2,s)
      grid % faces_n(3,NewS(s)) = grid % faces_n(3,s)
      grid % faces_n(4,NewS(s)) = grid % faces_n(4,s)
      grid % xf(NewS(s)) = grid % xf(s)
      grid % yf(NewS(s)) = grid % yf(s)
      grid % zf(NewS(s)) = grid % zf(s)
      grid % sx(NewS(s)) = grid % sx(s)
      grid % sy(NewS(s)) = grid % sy(s)
      grid % sz(NewS(s)) = grid % sz(s)
      grid % dx(NewS(s)) = grid % dx(s)
      grid % dy(NewS(s)) = grid % dy(s)
      grid % dz(NewS(s)) = grid % dz(s)
    end if
  end do
  grid % n_faces = number_sides-grid % n_sh

  !-----------------------------------!
  !   Check the periodic boundaries   !
  !-----------------------------------!
  max_dis = 0.0
  do s = 1, grid % n_faces-grid % n_sh
    max_dis = max(max_dis, (  grid % dx(s)*grid % dx(s)  &
                            + grid % dy(s)*grid % dy(s)  &
                            + grid % dz(s)*grid % dz(s) ) )
  end do
  write(*,*) '# Maximal distance of periodic boundary is:', sqrt(max_dis)

  !----------------------------------!
  !   Calculate the cell volumes     !
  !----------------------------------!
  !   => depends on: xc,yc,zc,       !
  !                  Dx,Dy,Dz,       !
  !                  xsp, ysp, zsp   !
  !   <= gives:      volume          !
  !----------------------------------!
  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)

    grid % vol(c1) = grid % vol(c1)               &
                   + grid % xf(s) * grid % sx(s)  &
                   + grid % yf(s) * grid % sy(s)  &
                   + grid % zf(s) * grid % sz(s)

    if(c2 > 0) then
      grid % vol(c2) = grid % vol(c2)                                &
                     - (grid % xf(s) - grid % dx(s)) * grid % sx(s)  &
                     - (grid % yf(s) - grid % dy(s)) * grid % sy(s)  &
                     - (grid % zf(s) - grid % dz(s)) * grid % sz(s)
    end if
  end do
  grid % vol = grid % vol * ONE_THIRD
  c1 = 0
  min_vol =  HUGE
  max_vol = -HUGE
  tot_vol = 0.0
  do c = 1, grid % n_cells
    tot_vol = tot_vol + grid % vol(c)
    min_vol = min(min_vol, grid % vol(c))
    max_vol = max(max_vol, grid % vol(c))
  end do
  write(*,*) '# Minimal cell volume is: ', min_vol
  write(*,*) '# Maximal cell volume is: ', max_vol
  write(*,*) '# Total domain volume is: ', tot_vol
  write(*,*) '# Cell volumes calculated !'

  if(min_vol < 0.0) then
    write(*,*) '# Negative volume occured! Slower, algoritham should be run !'
    write(*,*) '# Execution will halt now! '
    stop
  end if

  deallocate(b_coor)
  deallocate(b_face)

  !------------------------------------------!
  !     Calculate delta                      !
  !------------------------------------------!
  !     => depends on: x_node,y_node,z_node  !
  !     <= gives:      delta                 !
  !------------------------------------------!
  allocate(delta(-grid % n_bnd_cells:grid % n_cells));  delta=0.0

  do c = 1, grid % n_cells
    delta(c)=0.0
    xmin = +HUGE
    ymin = +HUGE
    zmin = +HUGE
    xmax = -HUGE
    ymax = -HUGE
    zmax = -HUGE
    do n = 1, grid % cells_n_nodes(c)
      xmin = min(xmin, grid % xn(grid % cells_n(n,c)))
      ymin = min(ymin, grid % yn(grid % cells_n(n,c)))
      zmin = min(zmin, grid % zn(grid % cells_n(n,c)))
      xmax = max(xmax, grid % xn(grid % cells_n(n,c)))
      ymax = max(ymax, grid % yn(grid % cells_n(n,c)))
      zmax = max(zmax, grid % zn(grid % cells_n(n,c)))
    end do
    delta(c) = xmax-xmin
    delta(c) = max(delta(c), (ymax-ymin))
    delta(c) = max(delta(c), (zmax-zmin))
  end do

  !------------------------------------------------------------------!
  !   Calculate distance from the cell center to the nearest wall.   !
  !------------------------------------------------------------------!
  !     => depends on: xc,yc,zc inside and on the boundary.          !
  !     <= gives:      WallDs i                                      !
  !------------------------------------------------------------------!
  allocate(WallDs(-grid % n_bnd_cells:grid % n_cells)); WallDs = HUGE

  write(*,*) '#================================================================'
  write(*,*) '# Type the total number of wall boundary conditions:'
  write(*,*) '#----------------------------------------------------------------'
  write(*,*) '# (Please note that the walls have to be the first on the list)'
  write(*,*) '# of the boundary conditions. Their BC markers have to be smaller'
  write(*,*) '# than the markers of the other boundary conditions.)'
  write(*,*) '#----------------------------------------------------------------'
  read(*,*) wall_mark

  if(wall_mark == 0) then
    WallDs = 1.0
    write(*,*) '# Distance to the wall set to 1.0 everywhere !'
  else
    do c1 = 1, grid % n_cells
      if(mod(c1,10000) == 0) then
        write(*,'(a2, f5.0, a14)') ' #', (100.*c1/(1.*grid % n_cells)),  &
                                   ' % complete...'
      endif
      do c2=-1,-grid % n_bnd_cells,-1
        if(BCmark(c2) <= wall_mark) then
          WallDs(c1)=min(WallDs(c1),                                      &
          Distance_Squared(grid % xc(c1), grid % yc(c1), grid % zc(c1),   &
                           grid % xc(c2), grid % yc(c2), grid % zc(c2)))
        end if
      end do
    end do

    WallDs = sqrt(WallDs)

    write(*,*) '# Distance to the wall calculated !'
  end if

  !------------------------------------------------------------!
  !   Calculate the interpolation factors for the cell sides   !
  !------------------------------------------------------------!
  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)

    ! First cell
    xc1  = grid % xc(c1)
    yc1  = grid % yc(c1)
    zc1  = grid % zc(c1)
    dsc1 = Distance(xc1, yc1, zc1,   &
                    grid % xf(s), grid % yf(s), grid % zf(s))

    ! Second cell (pls. check if xsi=xc on the boundary)
    xc2  = grid % xc(c2) + grid % dx(s)
    yc2  = grid % yc(c2) + grid % dy(s)
    zc2  = grid % zc(c2) + grid % dz(s)
    dsc2 = Distance(xc2, yc2, zc2,   &
                    grid % xf(s), grid % yf(s), grid % zf(s))

    ! Interpolation factor
    grid % f(s) = dsc2 / (dsc1 + dsc2)
  end do

  write(*,*) '# Interpolation factors calculated !'

  return

  write(*,*) '# Horror ! Negative volume between cells ', c1, ' and ', c2
  stop

  end subroutine


      PROGRAM TSTMIV

c         Test cases for MIEV0 from NCAR Tech Note, with, in addition,
c         calculations of Legendre coefficients

c     NOTE:  set NoPMOM = True if using NoPMOM version of MIEV0

      IMPLICIT  NONE

c ----------------------------------------------------------------------
c --------  I / O SPECIFICATIONS FOR SUBROUTINE MIEV0  -----------------
c ----------------------------------------------------------------------
      INTEGER  MAXANG, MOMDIM
      PARAMETER  ( MAXANG = 40, MOMDIM = 10 )
      LOGICAL  ANYANG, PERFCT, PRNT(2)
      INTEGER  IPOLZN( 4,2 ), NUMANG, NMOM
      REAL     GQSC, MIMCUT, PMOM( 0:MOMDIM, 4 ), QEXT, QSCA, SPIKE,
     $         XMU(MAXANG), XX(4)
      COMPLEX  CREFIN( 2 ), SFORW, SBACK, S1( MAXANG ), S2( MAXANG ),
     $         TFORW( 2 ), TBACK( 2 )
c ----------------------------------------------------------------------

c     .. Local Scalars ..

      LOGICAL   NOPMOM
      INTEGER   I, NIOR, NXX
      REAL      PI
c     ..
c     .. External Subroutines ..

      EXTERNAL  MIEV0
c     ..
c     .. Intrinsic Functions ..

      INTRINSIC ASIN, COS
c     ..
      DATA  CREFIN / (1.5,0.0), (1.5,-0.1) /,
     $      XX / 10., 100., 1000., 5000. /,
     $      IPOLZN / 13, 24, 1234, 0, -13, -24, -1234, 0 /,
     $      PRNT / 2*.TRUE. /,
     $      PERFCT /.FALSE./,
     $      MIMCUT / 1.E-6 /,
     $      ANYANG /.TRUE./,
     $      NUMANG / 19 /

      NOPMOM = .False.
      PI     = 2.*ASIN( 1.0 )

      IF( NUMANG.GT.MAXANG ) STOP 'numang'

      DO 10 I = 1, NUMANG
         XMU( I ) = COS( (I-1)*PI / ( NUMANG - 1 ) )
   10 CONTINUE

      XMU( NUMANG ) = -1.0

      DO 30 NIOR = 1, 2

         DO 20 NXX = 1, 4

            NMOM = 10
            IF( NOPMOM .OR. NXX.EQ.4 ) NMOM = 0

            CALL MIEV0( XX( NXX ), CREFIN( NIOR ), PERFCT, MIMCUT,
     &                  ANYANG, NUMANG, XMU, NMOM, IPOLZN( NXX,NIOR ),
     &                  MOMDIM, PRNT, QEXT, QSCA, GQSC, PMOM, SFORW,
     &                  SBACK, S1, S2, TFORW, TBACK, SPIKE )

   20    CONTINUE

   30 CONTINUE

      STOP

      END


      SUBROUTINE SINCOS                                                 ABSH0979
C***********************************************************************ABSH0980
C*****SINCOS SETS UP THE SINE AND COSINE ARRAYS FOR THE MHD MOMENTS.   *ABSH0981
C*****REFERENCES:                                                      *ABSH0982
C*****L.L.LAO,S.P.HIRSHMAN,R.M.WIELAND,ORNL/TM-7616 (1981).            *ABSH0983
C*****                                ,PHYS FLUIDS 24 (1981) AUG       *ABSH0984
C*****L.L.LAO,R.M.WIELAND,W.A.HOULBERG,S.P.HIRSHMAN,ORNL/TM-7871 (1981)*ABSH0985
C*****LAST REVISION: 6/81 L.L.LAO, R.M.WIELAND, AND W.A.HOULBERG ORNL. *ABSH0986
C***********************************************************************ABSH0987
      PARAMETER MTHETA=11,MM1=10,MNMOMS=3                               ABSH0988
      PARAMETER MNEQ=6                                                  ABSH0989
      COMMON /SCFUNC/ S1TH(MTHETA), S2TH(MTHETA), C1TH(MTHETA),         ABSH0990
     *     C2TH(MTHETA)                                                 ABSH0991
      PI = ACOS(-1.0)                                                   ABSH0992
      DTH = PI/(MTHETA-1)                                               ABSH0993
      DO 10 I=1,MTHETA                                                  ABSH0994
           X1 = (I-1)*DTH                                               ABSH0995
           X2 = 2.0*X1                                                  ABSH0996
           S1TH(I) = SIN(X1)                                            ABSH0997
           S2TH(I) = SIN(X2)                                            ABSH0998
           C1TH(I) = COS(X1)                                            ABSH0999
           C2TH(I) = COS(X2)                                            ABSH1000
   10 CONTINUE                                                          ABSH1001
      RETURN                                                            ABSH1002
      END                                                               ABSH1003


c               Copyright 1993 Colorado State University
c                       All Rights Reserved

      subroutine rateconv(rate1, rate2, t1, t2)

      implicit none

c ...

c ... FORMAL PARAMETERS
      double precision rate1, rate2, t1, t2

c ... Local Variables
      double precision kcont

      if (rate1 .gt. 1.0) then
          rate2 = rate1 * t2 / t1
      else
          kcont = -alog(1.0 - rate1)
          rate2 = 1.0 - exp(-kcont * t2 / t1)
      endif

      return
      end


      subroutine dchdc(a,lda,p,work,jpvt,job,info)
      integer lda,p,jpvt(1),job,info
      double precision a(lda,1),work(1)
c
c     dchdc computes the cholesky decomposition of a positive definite
c     matrix.  a pivoting option allows the user to estimate the
c     condition of a positive definite matrix or determine the rank
c     of a positive semidefinite matrix.
c
c     on entry
c
c         a      double precision(lda,p).
c                a contains the matrix whose decomposition is to
c                be computed.  onlt the upper half of a need be stored.
c                the lower part of the array a is not referenced.
c
c         lda    integer.
c                lda is the leading dimension of the array a.
c
c         p      integer.
c                p is the order of the matrix.
c
c         work   double precision.
c                work is a work array.
c
c         jpvt   integer(p).
c                jpvt contains integers that control the selection
c                of the pivot elements, if pivoting has been requested.
c                each diagonal element a(k,k)
c                is placed in one of three classes according to the
c                value of jpvt(k).
c
c                   if jpvt(k) .gt. 0, then x(k) is an initial
c                                      element.
c
c                   if jpvt(k) .eq. 0, then x(k) is a free element.
c
c                   if jpvt(k) .lt. 0, then x(k) is a final element.
c
c                before the decomposition is computed, initial elements
c                are moved by symmetric row and column interchanges to
c                the beginning of the array a and final
c                elements to the end.  both initial and final elements
c                are frozen in place during the computation and only
c                free elements are moved.  at the k-th stage of the
c                reduction, if a(k,k) is occupied by a free element
c                it is interchanged with the largest free element
c                a(l,l) with l .ge. k.  jpvt is not referenced if
c                job .eq. 0.
c
c        job     integer.
c                job is an integer that initiates column pivoting.
c                if job .eq. 0, no pivoting is done.
c                if job .ne. 0, pivoting is done.
c
c     on return
c
c         a      a contains in its upper half the cholesky factor
c                of the matrix a as it has been permuted by pivoting.
c
c         jpvt   jpvt(j) contains the index of the diagonal element
c                of a that was moved into the j-th position,
c                provided pivoting was requested.
c
c         info   contains the index of the last positive diagonal
c                element of the cholesky factor.
c
c     for positive definite matrices info = p is the normal return.
c     for pivoting with positive semidefinite matrices info will
c     in general be less than p.  however, info may be greater than
c     the rank of a, since rounding error can cause an otherwise zero
c     element to be positive. indefinite systems will always cause
c     info to be less than p.
c
c     linpack. this version dated 08/14/78 .
c     j.j. dongarra and g.w. stewart, argonne national laboratory and
c     university of maryland.
c
c
c     blas daxpy,dswap
c     fortran dsqrt
c
c     internal variables
c
      integer pu,pl,plp1,i,j,jp,jt,k,kb,km1,kp1,l,maxl
      double precision temp
      double precision maxdia
      logical swapk,negk
c
      pl = 1
      pu = 0
      info = p
      if (job .eq. 0) go to 160
c
c        pivoting has been requested. rearrange the
c        the elements according to jpvt.
c
         do 70 k = 1, p
            swapk = jpvt(k) .gt. 0
            negk = jpvt(k) .lt. 0
            jpvt(k) = k
            if (negk) jpvt(k) = -jpvt(k)
            if (.not.swapk) go to 60
               if (k .eq. pl) go to 50
                  call dswap(pl-1,a(1,k),1,a(1,pl),1)
                  temp = a(k,k)
                  a(k,k) = a(pl,pl)
                  a(pl,pl) = temp
                  plp1 = pl + 1
                  if (p .lt. plp1) go to 40
                  do 30 j = plp1, p
                     if (j .ge. k) go to 10
                        temp = a(pl,j)
                        a(pl,j) = a(j,k)
                        a(j,k) = temp
                     go to 20
   10                continue
                     if (j .eq. k) go to 20
                        temp = a(k,j)
                        a(k,j) = a(pl,j)
                        a(pl,j) = temp
   20                continue
   30             continue
   40             continue
                  jpvt(k) = jpvt(pl)
                  jpvt(pl) = k
   50          continue
               pl = pl + 1
   60       continue
   70    continue
         pu = p
         if (p .lt. pl) go to 150
         do 140 kb = pl, p
            k = p - kb + pl
            if (jpvt(k) .ge. 0) go to 130
               jpvt(k) = -jpvt(k)
               if (pu .eq. k) go to 120
                  call dswap(k-1,a(1,k),1,a(1,pu),1)
                  temp = a(k,k)
                  a(k,k) = a(pu,pu)
                  a(pu,pu) = temp
                  kp1 = k + 1
                  if (p .lt. kp1) go to 110
                  do 100 j = kp1, p
                     if (j .ge. pu) go to 80
                        temp = a(k,j)
                        a(k,j) = a(j,pu)
                        a(j,pu) = temp
                     go to 90
   80                continue
                     if (j .eq. pu) go to 90
                        temp = a(k,j)
                        a(k,j) = a(pu,j)
                        a(pu,j) = temp
   90                continue
  100             continue
  110             continue
                  jt = jpvt(k)
                  jpvt(k) = jpvt(pu)
                  jpvt(pu) = jt
  120          continue
               pu = pu - 1
  130       continue
  140    continue
  150    continue
  160 continue
      do 270 k = 1, p
c
c        reduction loop.
c
         maxdia = a(k,k)
         kp1 = k + 1
         maxl = k
c
c        determine the pivot element.
c
         if (k .lt. pl .or. k .ge. pu) go to 190
            do 180 l = kp1, pu
               if (a(l,l) .le. maxdia) go to 170
                  maxdia = a(l,l)
                  maxl = l
  170          continue
  180       continue
  190    continue
c
c        quit if the pivot element is not positive.
c
         if (maxdia .gt. 0.0d0) go to 200
            info = k - 1
c     ......exit
            go to 280
  200    continue
         if (k .eq. maxl) go to 210
c
c           start the pivoting and update jpvt.
c
            km1 = k - 1
            call dswap(km1,a(1,k),1,a(1,maxl),1)
            a(maxl,maxl) = a(k,k)
            a(k,k) = maxdia
            jp = jpvt(maxl)
            jpvt(maxl) = jpvt(k)
            jpvt(k) = jp
  210    continue
c
c        reduction step. pivoting is contained across the rows.
c
         work(k) = dsqrt(a(k,k))
         a(k,k) = work(k)
         if (p .lt. kp1) go to 260
         do 250 j = kp1, p
            if (k .eq. maxl) go to 240
               if (j .ge. maxl) go to 220
                  temp = a(k,j)
                  a(k,j) = a(j,maxl)
                  a(j,maxl) = temp
               go to 230
  220          continue
               if (j .eq. maxl) go to 230
                  temp = a(k,j)
                  a(k,j) = a(maxl,j)
                  a(maxl,j) = temp
  230          continue
  240       continue
            a(k,j) = a(k,j)/work(k)
            work(j) = a(k,j)
            temp = -a(k,j)
            call daxpy(j-k,temp,work(kp1),1,a(kp1,j),1)
  250    continue
  260    continue
  270 continue
  280 continue
      return
      end


      SUBROUTINE COVGENF(L,K,F,G,C,CN)
C
      INCLUDE 'timsac_f.h'
C
cc	PROGRAM COVGEN
C     PROGRAM 74.1.3. COVARIANCE GENERATION FROM GAIN FUNCTION.
C-----------------------------------------------------------------------
C     ** DESIGNED BY H. AKAIKE, THE INSTITUTE OF STATISTICAL MATHEMATICS
C     ** PROGRAMMED BY E. ARAHATA, THE INSTITUTE OF STATISTICAL MATHEMAT
C         TOKYO
C     ** DATE OF THE LATEST REVISION: MARCH 25, 1977
C     ** THIS PROGRAM WAS ORIGINALLY PUBLISHED IN
C         "TIMSAC-74 A TIME SERIES ANALYSIS AND CONTROL PROGRAM PACKAGE(1
C         BY H. AKAIKE, E. ARAHATA AND T. OZAKI, COMPUTER SCIENCE MONOGRA
C         NO.5, MARCH 1975, THE INSTITUTE OF STATISTICAL MATHEMATICS
C     ** FOR THE BASIC THEORY SEE "CANONICAL CORRELATION ANALYSIS OF TIM
C         AND THE USE OF AN INFORMATION CRITERION" BY H. AKAIKE, IN
C         "SYSTEM IDENTIFICATION: ADVANCES AND CASE STUDIES" R. K. MEHRA
C         D. G. LAINIOTIS EDS. ACADEMIC PRESS, NEW YORK, 1976
C-----------------------------------------------------------------------
C     THIS PROGRAM PRODUCES THE FOURIER TRANSFORM OF A POWER
C     GAIN FUNCTION IN THE FORM OF AN AUTOCOVARIANCE SEQUENCE.
C     THE GAIN FUNCTION IS DEFINED AS A RECTILINEAR FUNCTION WITH
C     THE VALUES G(I) SPECIFIED AT THE FREQUENCIES F(I),I=1,K.
C     THE OUTPUTS OF THIS PROGRAM ARE USED AS THE INPUTS TO THE CANONICA
C     CORRELATION ANALYSIS PROGRAM CANARM, TO REALIZE A FILTER WITH
C     THE DESIRED GAIN FUNCTION.
C
C     THE FOLLOWING INPUTS ARE REQUIRED:
C     (L,K): L, DESIRED MAXIMUM LAG OF COVARIANCE (AT MOST 1024)
C            K, NUMBER OF DATA POINTS (LESS THAN OR EQUAL TO 500)
C     (F(I),G(I))(I=1,K): F(I), FREQUENCY. BY DEFINITION F(1)=0.0 AND F(
C                           F(I)'S ARE ARRANGED IN INCREASING ORDER.
C                           G(I), POWER GAIN OF THE FILTER AT THE FREQUEN
C
C     OUTPUTS:
C     (N,LAGH): N=2048
C     C(I)(I=0,LAGH):
C
cc      !DEC$ ATTRIBUTES DLLEXPORT :: COVGENF
C
      PARAMETER (LMAX=1024)
cxx      IMPLICIT REAL*8 (O-Y)
cc      REAL*8 C(1025),CN(1025),CX0
cc      COMPLEX*16 A(2048)
cc      DIMENSION F(500),G(500)
cc      DATA F / 500*0.0 /, G / 500*0.0 /
cxx      REAL*8  C(L+1),CN(L+1),CX0
cxx      COMPLEX*16 A(LMAX*2)
cxx      REAL*8  F(K),G(K)
      INTEGER :: L, K
      REAL(8) :: F(K), G(K), C(L+1), CN(L+1)
      REAL(8) :: CX0, Q00, AN, BN, CM, Q1, Q2, Q3, Q4, Q25
      COMPLEX(kind(0d0)) :: A(LMAX*2)
C
C     INPUT / OUTPUT DATA FILE OPEN
cc      CHARACTER(100) DFNAM
cc      CALL SETWND
cc      DFNAM='covgen.out'
cc      CALL FLOPN3(DFNAM,NFL)
cc      IF (NFL.EQ.0) GO TO 999
C
      Q00=0.0D-00
C     INITIAL CONDITION INPUT
cc      READ(5,800) L,K
cc      WRITE(6,900) L,K
cc      DO  100 I=1,K
cc  100 READ(5,801) F(I),G(I)
cc      DO  101 I=1,K
cc  101 WRITE(6,901) F(I),G(I)
cc  105 N=2048
      N=LMAX*2
      N2P=11
cc      AN=2048.0
cc      NN=1023
      AN=N
      NN=LMAX-1
      DO  200 I=1,NN
      BN=I
      CM=BN/AN
      J=K
cc  106 IF(CM-F(J)) 107,108,108
  106 CONTINUE
      IF(CM-F(J) .GE. 0) GO TO 108
cxx  107 J=J-1
      J=J-1
      GO TO 106
  108 J1=J+1
      Q1=(F(J1)-CM)*G(J)
      Q2=(CM-F(J))*G(J1)
      Q3=F(J1)-F(J)
      Q4=(Q1+Q2)/Q3
      I1=I+1
      Q1=Q4
      A(I1)=DCMPLX(Q1,Q00)
      I2=N-I+1
cxx  200 A(I2)=A(I1)
      A(I2)=A(I1)
  200 CONTINUE
      Q25=G(1)
      A(1)=DCMPLX(Q25,Q00)
      Q25=G(K)
      A(NN+2)=DCMPLX(Q25,Q00)
C     FAST FOURIER TRANSFORM OF A
C     COMMON SUBROUTINE CALL
      CALL MIXRAD(A,N,N2P,+1)
      LAGH1=L+1
      DO  201 I=1,LAGH1
cxx  201 C(I)=DREAL(A(I))
      C(I)=DREAL(A(I))
  201 CONTINUE
C     C(I+1),I=0,L     ARE THE DESIRED AUTOCOVARIANCES.
C     NORMARIZED COVARIANCES ARE GIVEN AS CN(I+1),I=0,L.
      CX0=C(1)
C     COMMON SUBROUTINE CALL
      CALL CORNOM(C,CN,LAGH1,CX0,CX0)
cc      WRITE(6,902)
cc      DO  210 I=1,LAGH1
cc      J=I-1
cc  210 WRITE(6,903) J,C(I),CN(I)
cc      LAGH=LAGH1-1
cc      WRITE(7,800) N,LAGH
cc      WRITE(7,904) (C(I),I=1,LAGH1)
cc      CALL FLCLS3(NFL)
      RETURN
cxx  800 FORMAT(2I5)
cxx  801 FORMAT(2F10.5)
cxx  900 FORMAT(1H ,' PROGRAM 74.1.3. COVGEN: L=',I5,5X,'K=',I5/1H )
cxx  901 FORMAT(1H ,' FREQUENCY(',F10.5,')',20X,'DESIRED GAIN = ',F10.5)
cxx  902 FORMAT(//1H ,20X,'AUTO COVARIANCE',25X,
cxx     *'AUTO COVARIANCE NORMALIZED')
cxx  903 FORMAT(1H ,'LAG =',I5,5X,D20.10,31X,D20.10)
cxx  904 FORMAT(4D20.10)
      END


program test_n
  ! program to simulate planetary system with N objects
  use body
  use velocity_verlet
  implicit none

  integer :: nsteps
  real(8) :: duration, step
  real(8), dimension(:,:), allocatable :: vel, pos
  real(8), dimension(:), allocatable :: mass
  type(planetary_body), dimension(:), allocatable :: bodies
  integer :: n, nbodies
  character(len=1024) :: input_file

  input_file = 'input.txt'

  ! read input values
  call read_input_parameters(input_file,nbodies,duration,step,mass,vel,pos)

  ! allocate planetary objects
  allocate(bodies(nbodies))

  ! number of steps in this simulation
  nsteps = ceiling(duration*60.0*60.0*24.0/step)

  ! init objects
  do n=1,nbodies
     call init_body(bodies(n),pos(n,:),vel(n,:),mass(n),nsteps)
  end do

  ! initial forces
  call init_n_body_system(bodies,nbodies)

  ! run simulation
  do n=1,nsteps
     call verlet_n(bodies,nbodies,n,step)
  end do

  ! write output
  call write_output(bodies)

contains

  subroutine read_input_parameters(fname,nbodies,duration,step,mass,vel,pos)
    ! Read input values from a file
    implicit none
    character(len=1024), intent(in) :: fname
    integer, intent(out) :: nbodies
    real(8), intent(out) :: duration, step
    real(8), dimension(:,:), allocatable, intent(out) :: vel, pos
    real(8), dimension(:), allocatable, intent(out) :: mass
    open(unit=10,file=fname,status='old')
    read(10,'(/,I6,///,F10.3,///,F10.3,//)') nbodies, duration, step
    allocate(mass(nbodies), vel(nbodies,3), pos(nbodies,3))
    do n=1,nbodies
       read(10,*) mass(n)
    end do
    read(10,'(/)')
    do n=1,nbodies
       read(10,*) pos(n,:)
    end do
    read(10,'(/)')
    do n=1,nbodies
       read(10,*) vel(n,:)
    end do
    close(10)
  end subroutine read_input_parameters

  subroutine write_output(bodies)
    ! writes positions for each time steps
    ! for all objects
    implicit none
    type(planetary_body), dimension(:), intent(in) :: bodies
    integer :: n, m
    character(len=1024) :: ofile
    ! write positions
    do n=1, size(bodies,1)
       write(ofile,'(I1)') n
       ofile = 'results/pos_' // trim(ofile) // '.dat'
       open(unit=10,file=ofile)
       do m=1,size(bodies(n)%pos,1)
          write(10,*) bodies(n)%pos(m,:)
       end do
       close(10)
    end do
    ! write number of steps in a separate file
    open(unit=10,file='results/n_steps.dat')
    write(10,*) size(bodies(1)%pos,1)
    close(10)
  end subroutine write_output

end program test_n