      SUBROUTINE ZPGEQZ( JOB, COMPQ, K, N, ILO, IHI, S, A, LDA1, LDA2,
     $                   ALPHA, BETA, SCAL, Q, LDQ1, LDQ2, DWORK,
     $                   LDWORK, ZWORK, LZWORK, INFO )
	IMPLICIT NONE
C
C     PURPOSE
C
C     ZPGEQZ implements a single-shift version of the periodic QZ
C     method for finding the eigenvalues of the complex generalized
C     matrix product
C
C                                 S(2)                 S(K)
C          A(:,:,1)     * A(:,:,2)     * ... * A(:,:,K).
C
C     In addition, A may be reduced to periodic Schur form by unitary
C     transformations: all factors A(:,:,i) become upper triangular.
C
C     If COMPQ = 'V' or COMPZ = 'I', then the unitary factors are
C     computed and stored in the array Q so that for S(I) = 1,
C
C                         H
C             Q(:,:,I)(in)   A(:,:,I)(in)   Q(:,:,MOD(I,K)+1)(in)
C                          H                                        (1)
C         =   Q(:,:,I)(out)  A(:,:,I)(out)  Q(:,:,MOD(I,K)+1)(out),
C
C     and for S(I) = -1,
C
C                                  H
C             Q(:,:,MOD(I,K)+1)(in)   A(:,:,I)(in)   Q(:,:,I)(in)
C                                   H                               (2)
C         =   Q(:,:,MOD(I,K)+1)(out)  A(:,:,I)(out)  Q(:,:,I)(out).
C
C     ARGUMEMTS
C
C     Mode Parameters
C
C     JOB     (input) CHARACTER*1
C             = 'E': compute only the eigenvalues; A will not
C                    necessarily be put into periodic Schur form.
C             = 'S': put A into periodic Schur form, as well
C                    as computing the eigenvalues contained in ALPHAR,
C                    ALPHAI, BETA and SCAL.
C
C     COMPQ   (input) CHARACTER*1
C             = 'N': do not modify Q.
C             = 'V': modify the array Q by the unitary transformations
C                    that are applied to the matrices in A to reduce them
C                    to periodic Schur form.
C             = 'I': like COMPQ='V', except that each matrix in Q will
C                    be initialized to the identity first.
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of factors.  K >= 1.
C
C     N       (input)  INTEGER
C             The order of each factor in A.  N >= 0.
C
C     ILO     (input)  INTEGER
C     IHI     (input)  INTEGER
C             It is assumed that each factor in A is already upper
C             triangular in rows and columns 1:ILO-1 and IHI+1:N.
C             1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
C
C     S       (input)  INTEGER array, dimension (K)
C             The leading K elements of this array must contain the
C             signatures of the factors. Each entry in S must be either
C             1 or -1. By definition, S(1) must be set to 1.
C
C     A       (input/output) COMPLEX*16 array, dimension (LDA1,LDA2,K)
C             On entry, the leading N-by-N-by-K part of this array
C             must contain the factors in upper Hessenberg-triangular
C             form, that is, A(:,:,1) is upper Hessenberg and the other
C             factors are upper triangular.
C             On exit, if JOB = 'S' and INFO = 0, the leading
C             N-by-N-by-K part of this array contains the factors of
C             A in periodic Schur form. All factors are reduched to
C             upper triangular form and, moreover, A(:,:,2),...,
C             A(:,:,K) are normalized so that their diagonals contain
C             nonnegative real numbers.
C             On exit, if JOB = 'E', then the leading N-by-N-by-K part
C             of this array contains meaningless elements.
C
C     LDA1    (input) INTEGER
C             The first leading dimension of A.  LDA1 >= MAX(1,N).
C
C     LDA2    (input) INTEGER
C             The second leading dimension of A.  LDA2 >= MAX(1,N).
C
C     ALPHA   (output) COMPLEX*16 array, dimension (N)
C             On exit, if INFO = 0, the leading N elements of this
C             array contain the scaled eigenvalues of A. The i-th
C             eigenvalue of A is given by
C
C             ALPHA(I) / BETA(I) * BASE**(SCAL(I)),
C
C             where 1.0 <= ABS(ALPHA(I)) < BASE and BASE is the machine
C             base (normally 2.0).
C
C     BETA    (output) COMPLEX*16 array, dimension (N)
C             On exit, if INFO = 0, the leading N elements of this
C             array contain indicators for infinite eigenvalues. That
C             is, if BETA(I) = 0.0, then the i-th eigenvalue is
C             infinite. Otherwise BETA(I) is set to 1.0.
C
C     SCAL    (output) INTEGER array, dimension (N)
C             On exit, if INFO = 0, the leading N elements of this
C             array contain the scaling parameters for the eigenvalues
C             of A.
C
C     Q       (input/output) COMPLEX*16 array, dimension (LDQ1,LDQ2,K)
C             On entry, if COMPQ = 'V', the leading N-by-N-by-K part
C             of this array must contain the initial unitary factors
C             as described in (1)-(2).
C             On exit, if COMPQ = 'V' or COMPQ = 'I', the leading
C             N-by-N-by-K part of this array contains the modified
C             orthogonal factors as described in (1)-(2).
C
C     LDQ1    (input)  INTEGER
C             The first leading dimension of Q.  LDQ1 >= MAX(1,N).
C
C     LDQ2    (input)  INTEGER
C             The second leading dimension of Q.  LDQ2 >= MAX(1,N).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the minimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,N).
C
C     ZWORK   COMPLEX*16 array, dimension (LZWORK)
C             On exit, if INFO = 0, ZWORK(1) returns the minimal value
C             of LZWORK.
C
C     LZWORK  INTEGER
C             The length of the array ZWORK.  LZWORK >= MAX(1,N).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0       : succesful exit;
C             < 0       : if INFO = -i, the i-th argument had an
C                         illegal value;
C             = 1,..,N  : the periodic QZ iteration did not converge.
C                         A is not in periodic Schur form, but
C                         ALPHA(I), BETA(I) and SCAL(I), for
C                         I = INFO+1,...,N should be correct.
C
C     METHOD
C
C     A slightly modified version of the periodic QZ algorithm is
C     used. For more details see [2].
C
C     REFERENCES
C
C     [1] Bojanczyk, A. and Golub, G. H. and Van Dooren, P.
C         The periodic Schur decomposition; algorithm and applications.
C         In Proc. SPIE Conference, pg. 31-42, vol. 1770, 1992.
C
C     [2] Kressner, D.
C         An efficient and reliable implementation of the periodic QZ
C         algorithm. In IFAC Workshop on Periodic Control Systems, 2001.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically backward stable.
C                                 3
C     The algorithm requires 0(K N ) floating point operations.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, Dec. 2002.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      COMPLEX*16        CONE, CZERO
      PARAMETER         ( CONE = ( 1.0D+0, 0.0D+0 ),
     $                  CZERO = ( 0.0D+0, 0.0D+0 ) )
C     .. Scalar Arguments ..
      CHARACTER*1       COMPQ, JOB
      INTEGER           K, ILO, IHI, INFO, LDA1, LDA2, LDQ1, LDQ2,
     $                  LDWORK, LZWORK, N
C     .. Array Arguments ..
      INTEGER           S(*), SCAL(*)
	DOUBLE PRECISION  DWORK(*)
      COMPLEX*16        A(LDA1, LDA2, *), ALPHA(*), BETA(*),
     $                  Q(LDQ1, LDQ2, *), ZWORK(*)
C     .. Local Scalars ..
      LOGICAL           INITQ, LSCHR, WANTQ, SOK
      INTEGER           IFIRST, IFRSTM, IITER, ILAST, ILASTM, IN, J, J1,
     $                  JDEF, JITER, JLO, L, LDEF, LN, MAXIT, NTRA,
     $                  ZITER
      DOUBLE PRECISION  ABST, BASE, CS, SAFMIN, SAFMAX, SMLNUM, ULP,
     $                  TOL
	COMPLEX*16        SN, TEMP
C     .. Local Arrays ..
      INTEGER           ISEED(4)
	COMPLEX*16        RND(4)
C     .. External Functions ..
      LOGICAL           LSAME
	DOUBLE PRECISION  DLAMCH, ZLANHS
      EXTERNAL          DLAMCH, LSAME, ZLANHS
C     .. External Subroutines ..
      EXTERNAL          DLABAD, ZLAPR1, ZLARNV, ZLARTG, ZROT, ZSCAL
      INTRINSIC         ABS, DBLE, DCMPLX, DCONJG, INT, LOG, MAX
C
C     .. Executable Statements ..
C
      INFO = 0
      LSCHR = LSAME( JOB,'S' )
      WANTQ = LSAME( COMPQ,'V' ).OR.LSAME( COMPQ,'I' )
      INITQ = LSAME( COMPQ,'I' )
C
C     Check the scalar input parameters.
C
      IF ( .NOT. ( LSCHR .OR. LSAME( JOB,'E' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.WANTQ .AND. .NOT.INITQ .AND.
     $         .NOT.LSAME(COMPQ,'N') ) THEN
         INFO = -2
      ELSE IF ( K.LT.1 ) THEN
         INFO = -3
      ELSE IF ( N.LT.0 ) THEN
         INFO = -4
      ELSE IF ( ILO.LT.1 ) THEN
         INFO = -5
      ELSE IF ( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
         INFO = -6
      ELSE
	   SOK = S(1).EQ.1
	   DO 10  L = 2, K
	      SOK = S(L).EQ.1 .OR. S(L).EQ.-1
   10    CONTINUE
         IF ( .NOT.SOK ) THEN
	      INFO = -7
         ELSE IF ( LDA1 .LT. MAX(1, N) ) THEN
            INFO = -9
         ELSE IF ( LDA2 .LT. MAX(1, N) ) THEN
            INFO = -10
         ELSE IF ( WANTQ .AND. LDQ1.LT.MAX(1, N) ) THEN
            INFO = -15
         ELSE IF ( WANTQ .AND. LDQ2.LT.MAX(1, N) ) THEN
            INFO = -16
         ELSE IF ( LDWORK.LT.MAX(1,N) ) THEN
            INFO = -18
	   ELSE IF ( LZWORK.LT.MAX(1,N) ) THEN
            INFO = -20
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZPGEQZ', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         DWORK(1) = ONE
         ZWORK(1) = CONE
         RETURN
      END IF
C
C     Initialize Q.
C
      IF ( INITQ ) THEN
         DO 20  L = 1, K
            CALL ZLASET( 'Full', N, N, CZERO, CONE, Q(1,1,L), LDQ1 )
   20    CONTINUE
      END IF
C
C     Machine Constants
C
      IN = IHI + 1 - ILO
      SAFMIN = DLAMCH( 'SafeMinimum' )
      SAFMAX = ONE / SAFMIN
      ULP = DLAMCH( 'Precision' )
      CALL DLABAD( SAFMIN, SAFMAX )
      SMLNUM = SAFMIN*( IN / ULP )
      BASE = DLAMCH( 'Base' )
      IF ( K.GE.INT( LOG( DLAMCH('Underflow') ) / LOG( ULP ) ) ) THEN
C
C        Start Iteration with a controlled zero shift.
C
         ZITER = -1
      ELSE
         ZITER = 0
      END IF
C
C     Set Eigenvalues IHI+1:N
C
      DO 30  J = IHI + 1, N
	   CALL ZLAPR1( BASE, K, S, A(J,J,1), LDA1*LDA2, ALPHA(J),
     $                BETA(J), SCAL(J) )
   30 CONTINUE
C
C     If IHI < ILO, skip QZ steps
C
      If ( IHI.LT.ILO )  GOTO 470
C
C     MAIN PERIODIC QZ ITERATION LOOP
C
C     Initialize dynamic indices
C
C     Eigenvalues ILAST+1:N have been found.
C        Column operations modify rows IFRSTM:whatever.
C        Row operations modify columns whatever:ILASTM.
C
C     If only eigenvalues are being computed, then
C        IFRSTM is the row of the last splitting row above row ILAST;
C        this is always at least ILO.
C     IITER counts iterations since the last eigenvalue was found,
C        to tell when to use an observed zero or random shift.
C     MAXIT is the maximum number of QZ sweeps allowed.
C
      ILAST = IHI
      IF ( LSCHR ) THEN
         IFRSTM = 1
         ILASTM = N
      ELSE
         IFRSTM = ILO
         ILASTM = IHI
      END IF
      IITER = 0
      ISEED(1) = 1
      ISEED(2) = 0
      ISEED(3) = 0
      ISEED(4) = 0
      MAXIT = 30 * IN
C
      DO  460 JITER = 1, MAXIT
C
C        Special Case: ILAST = ILO
C
         IF ( ILAST.EQ.ILO )  GOTO 400
C
C        **************************************************************
C        *                     CHECK FOR DEFLATION                    *
C        **************************************************************
C
C        Test 1:  Deflation in the Hessenberg matrix.
C
         JLO = ILO
         DO 40  J = ILAST, ILO+1, -1
            TOL = ABS( A(J-1,J-1,1) ) + ABS( A(J,J,1) )
            IF ( TOL.EQ.ZERO )
     $         TOL = ZLANHS( '1',J-ILO+1, A(ILO,ILO,1), LDA1,
     $                       DWORK(1) )
            TOL = MAX( ULP*TOL, SMLNUM )
            IF ( ABS( A(J,J-1,1) ).LE.TOL ) THEN
               A(J,J-1,1) = CZERO
               JLO = J
               IF ( J.EQ.ILAST )  GOTO 400
               GOTO 50
            END IF
   40    CONTINUE
C
   50    CONTINUE
C
C        Test 2:  Deflation in the triangular matrices with index 1.
C
         DO 70  LDEF = 2,K
            IF ( S(LDEF).EQ.1 ) THEN
               DO 60  J = ILAST, JLO, -1
                  IF ( J.EQ.ILAST ) THEN
                     TOL = ABS( A(J-1,J,LDEF) )
                  ELSE IF ( J.EQ.JLO ) THEN
                     TOL = ABS( A(J,J+1,LDEF) )
                  ELSE
                     TOL = ABS( A(J-1,J,LDEF) ) + ABS( A(J,J+1,LDEF) )
                  END IF
                  IF ( TOL.EQ.ZERO )
     $               TOL = ZLANHS( '1', J-JLO+1, A(JLO,JLO,LDEF), LDA1,
     $                             DWORK(1) )
                  TOL = MAX( ULP*TOL, SMLNUM )
                  IF ( ABS( A(J,J,LDEF) ).LE.TOL ) THEN
                     A(J,J,LDEF) = CZERO
                     GOTO 180
                  END IF
   60          CONTINUE
            END IF
   70    CONTINUE
C
C        Test 3:  Deflation in the triangular matrices with index -1.
C
         DO 90  LDEF = 2,K
            IF ( S(LDEF).EQ.-1 ) THEN
               DO 80  J = ILAST, JLO, -1
                  IF ( J.EQ.ILAST ) THEN
                     TOL = ABS( A(J-1,J,LDEF) )
                  ELSE IF ( J.EQ.JLO ) THEN
                     TOL = ABS( A(J,J+1,LDEF) )
                  ELSE
                     TOL = ABS( A(J-1,J,LDEF) ) + ABS( A(J,J+1,LDEF) )
                  END IF
                  IF ( TOL.EQ.ZERO )
     $                TOL = ZLANHS( '1', J-JLO+1, A(JLO,JLO,LDEF), LDA1,
     $                              DWORK(1) )
                  TOL = MAX( ULP*TOL, SMLNUM )
                  IF ( ABS( A(J,J,LDEF) ).LE.TOL ) THEN
                     A(J,J,LDEF) = CZERO
                     GOTO 330
                  END IF
   80          CONTINUE
            END IF
   90    CONTINUE
C
C        Test 4:  Controlled zero shift.
C
         IF ( ZITER.GE.7 .OR. ZITER.LT.0 ) THEN
C
C           Make Hessenberg matrix upper triangular.
C
            DO 100 J = JLO, ILAST-1
               TEMP = A(J,J,1)
               CALL ZLARTG( TEMP, A(J+1,J,1), CS, SN, A(J,J,1) )
               A(J+1,J,1) = CZERO
               CALL ZROT( ILASTM-J, A(J,J+1,1), LDA1,
     $                    A(J+1,J+1,1), LDA1, CS, SN )
               DWORK(J) = CS
               ZWORK(J) = SN
  100       CONTINUE
            IF ( WANTQ ) THEN
               DO 110  J = JLO, ILAST-1
                  CALL ZROT( N, Q(1,J,1), 1, Q(1,J+1,1), 1, DWORK(J),
     $                      DCONJG( ZWORK(J) ) )
  110          CONTINUE
            END IF
C
C           Propagate Transformations back to A_1.
C
            DO 150  L = K, 2, -1
               IF ( S(L).EQ.1 ) THEN
                  DO 120  J = JLO, ILAST-1
                     CS = DWORK(J)
                     SN = ZWORK(J)
                     IF ( SN.NE.CZERO ) THEN
                        CALL ZROT( J+2-IFRSTM, A(IFRSTM,J,L), 1,
     $                             A(IFRSTM,J+1,L), 1, CS,
     $                             DCONJG( SN ) )
C
C                       Check for deflation
C
                        TOL = ABS( A(J,J,L) ) + ABS( A(J+1,J+1,L) )
                        IF ( TOL.EQ.ZERO )
     $                     TOL = ZLANHS( '1',J-JLO+2, A(JLO,JLO,L),
     $                                   LDA1, DWORK(1) )
                        TOL = MAX( ULP*TOL, SMLNUM )
                        IF ( ABS( A(J+1,J,L) ).LE.TOL ) THEN
                           CS = ONE
                           SN = CZERO
                           A(J+1,J,L) = CZERO
                        END IF
C
                        TEMP = A(J,J,L)
                        CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN,
     $                               A(J,J,L) )
                        A(J+1,J,L) = CZERO
                        CALL ZROT( ILASTM-J, A(J,J+1,L), LDA1,
     $                             A(J+1,J+1,L), LDA1, CS, SN )
                     END IF
                     DWORK(J) = CS
                     ZWORK(J) = SN
  120             CONTINUE
               ELSE
                  DO 130  J = JLO, ILAST-1
                     CS = DWORK(J)
                     SN = ZWORK(J)
                     IF ( SN.NE.CZERO ) THEN
                        CALL ZROT( ILASTM-J+1, A(J,J,L), LDA1,
     $                             A(J+1,J,L), LDA1, CS, SN )
C
C                       Check for deflation
C
                        TOL = ABS( A(J,J,L) ) + ABS( A(J+1,J+1,L) )
                        IF ( TOL.EQ.ZERO )
     $                     TOL = ZLANHS( '1',J-JLO+2, A(JLO,JLO,L),
     $                                   LDA1, DWORK(1) )
                        TOL = MAX( ULP*TOL, SMLNUM )
                        IF ( ABS( A(J+1,J,L) ).LE.TOL ) THEN
                           CS = ONE
                           SN = CZERO
                           A(J+1,J,L) = CZERO
                        END IF
C
                        TEMP = A(J+1,J+1,L)
                        CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN,
     $                               A(J+1,J+1,L) )
                        A(J+1,J,L) = CZERO
                        CALL ZROT( J+1-IFRSTM, A(IFRSTM,J+1,L), 1,
     $                             A(IFRSTM,J,L), 1, CS, SN )
                        DWORK(J) = CS
                        ZWORK(J) = -SN
                     END IF
  130             CONTINUE
               END IF
C
               IF ( WANTQ ) THEN
                  DO 140  J = JLO, ILAST-1
                     CALL ZROT( N, Q(1,J,L), 1, Q(1,J+1,L), 1, DWORK(J),
     $                          DCONJG( ZWORK(J) ) )
  140             CONTINUE
               END IF
  150       CONTINUE

C
C           Apply the transformations to the right hand side of the
C           Hessenberg factor.
C
            ZITER = 0
            DO 160  J = JLO, ILAST-1
               CS = DWORK(J)
               SN = ZWORK(J)
               CALL ZROT( J+2-IFRSTM, A(IFRSTM,J,1), 1,
     $                    A(IFRSTM,J+1,1), 1, CS, DCONJG( SN ) )
	         IF ( SN.EQ.CZERO )
     $            ZITER = 1
  160       CONTINUE
C
C           No QZ iteration.
C
            GOTO 450
         END IF
C
C        **************************************************************
C        *                     HANDLE DEFLATIONS                      *
C        **************************************************************
C
C        Case I: Deflation occurs in the Hessenberg matrix. The QZ
C                iteration is only applied to the JLO:ILAST part.
C
  170    CONTINUE
         IFIRST = JLO
C
C        Go to the periodic QZ steps
C
         GOTO 410
C
C        Case II: Deflation occurs in a triangular matrix with index 1.
C
C        Do an unshifted periodic QZ step.
C
  180    JDEF = J
         DO 190  J = JLO, JDEF-1
            TEMP = A(J,J,1)
            CALL ZLARTG( TEMP, A(J+1,J,1), CS, SN, A(J,J,1) )
            A(J+1,J,1) = CZERO
            CALL ZROT( ILASTM-J, A(J,J+1,1), LDA1, A(J+1,J+1,1), LDA1,
     $                 CS, SN )
            DWORK(J) = CS
            ZWORK(J) = SN
  190    CONTINUE
         IF ( WANTQ ) THEN
            DO 200  J = JLO, JDEF-1
               CALL ZROT( N, Q(1,J,1), 1, Q(1,J+1,1), 1, DWORK(J),
     $                    DCONJG( ZWORK(J) ) )
  200       CONTINUE
         END IF
C
C        Propagate the transformations through the triangular matrices.
C        Due to the zero element on the diagonal of the LDEF-th
C        factor the number of transformations drops by one.
C
         DO 240  L = K, 2, -1
            IF ( L.LT.LDEF ) THEN
               NTRA = JDEF-2
            ELSE
               NTRA = JDEF-1
            END IF
            IF ( S(L).EQ.1 ) THEN
               DO 210  J = JLO, NTRA
                  CALL ZROT( J+2-IFRSTM, A(IFRSTM,J,L), 1,
     $                       A(IFRSTM,J+1,L), 1, DWORK(J),
     $                       DCONJG( ZWORK (J) ) )
                  TEMP = A(J,J,L)
                  CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, A(J,J,L) )
                  A(J+1,J,L) = CZERO
                  CALL ZROT( ILASTM-J, A(J,J+1,L), LDA1,
     $                       A(J+1,J+1,L), LDA1, CS, SN )
                  DWORK(J) = CS
                  ZWORK(J) = SN
  210          CONTINUE
            ELSE
               DO 220  J = JLO, NTRA
                  CALL ZROT( ILASTM-J+1, A(J,J,L), LDA1, A(J+1,J,L),
     $                       LDA1, DWORK(J), ZWORK(J) )
                  TEMP = A(J+1,J+1,L)
                  CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, A(J+1,J+1,L) )
                  A(J+1,J,L) = CZERO
                  CALL ZROT( J+1-IFRSTM, A(IFRSTM,J+1,L), 1,
     $                       A(IFRSTM,J,L), 1, CS, SN )
                  DWORK(J) = CS
                  ZWORK(J) = -SN
  220          CONTINUE
            END IF
            IF ( WANTQ ) THEN
               DO 230  J = JLO, NTRA
                  CALL ZROT( N, Q(1,J,L), 1, Q(1,J+1,L), 1, DWORK(J),
     $                       DCONJG( ZWORK(J) ) )
  230          CONTINUE
            END IF
  240    CONTINUE
C
C        Apply the transformations to the right hand side of the
C        Hessenberg factor.
C
         DO 250  J = JLO, JDEF-2
            CALL ZROT( J+2-IFRSTM, A(IFRSTM,J,1), 1, A(IFRSTM,J+1,1),
     $                 1, DWORK(J), DCONJG( ZWORK(J) ) )
  250    CONTINUE
C
C        Do an unshifted periodic ZQ step.
C
         DO 260  J = ILAST, JDEF+1, -1
            TEMP = A(J,J,1)
            CALL ZLARTG( TEMP, A(J,J-1,1), CS, SN, A(J,J,1) )
            A(J,J-1,1) = CZERO
            CALL ZROT( J-IFRSTM, A(IFRSTM,J,1), 1,
     $                 A(IFRSTM,J-1,1), 1, CS, SN )
            DWORK(J) = CS
            ZWORK(J) = -SN
  260    CONTINUE
         IF ( WANTQ ) THEN
            DO 270  J = ILAST, JDEF+1, -1
               CALL ZROT( N, Q(1,J-1,2), 1, Q(1,J,2),
     $                    1, DWORK(J), DCONJG( ZWORK(J) ) )
  270       CONTINUE
         END IF

C
C        Propagate the transformations through the triangular matrices.
C
         DO 310  L = 2, K
            IF ( L.GT.LDEF ) THEN
               NTRA = JDEF+2
            ELSE
               NTRA = JDEF+1
            END IF
            IF ( S(L).EQ.-1 ) THEN
               DO 280  J = ILAST, NTRA, -1
                  CS = DWORK(J)
                  SN = ZWORK(J)
                  CALL ZROT( J+1-IFRSTM, A(IFRSTM,J-1,L), 1,
     $                       A(IFRSTM,J,L), 1, CS, DCONJG( SN ) )
                  TEMP = A(J-1,J-1,L)
                  CALL ZLARTG( TEMP, A(J,J-1,L), CS, SN, A(J-1,J-1,L) )
                  A(J,J-1,L) = CZERO
                  CALL ZROT( ILASTM-J+1, A(J-1,J,L), LDA1, A(J,J,L),
     $                       LDA1, CS, SN )
                  DWORK(J) = CS
                  ZWORK(J) = SN
  280          CONTINUE
            ELSE
               DO 290  J = ILAST, NTRA, -1
                  CALL ZROT( ILASTM-J+2, A(J-1,J-1,L), LDA1,
     $                       A(J,J-1,L), LDA1, DWORK(J), ZWORK(J) )
                  TEMP = A(J,J,L)
                  CALL ZLARTG( TEMP, A(J,J-1,L), CS, SN, A(J,J,L) )
                  A(J,J-1,L) = CZERO
                  CALL ZROT( J-IFRSTM, A(IFRSTM,J,L), 1,
     $                       A(IFRSTM,J-1,L), 1, CS, SN )
                  DWORK(J) = CS
                  ZWORK(J) = -SN
  290          CONTINUE
            END IF
            IF ( WANTQ ) THEN
               LN = L+1
               IF ( L.EQ.K )  LN = 1
               DO 300  J = ILAST, NTRA, -1
                  CALL ZROT( N, Q(1,J-1,LN), 1, Q(1,J,LN), 1, DWORK(J),
     $                       DCONJG( ZWORK(J) ) )
  300          CONTINUE
            END IF
  310    CONTINUE
C
C        Apply the transformations to the left hand side of the
C        Hessenberg factor.
C
         DO 320  J = ILAST, JDEF+2, -1
            CALL ZROT( ILASTM-J+2, A(J-1,J-1,1), LDA1, A(J,J-1,1),
     $                 LDA1, DWORK(J), ZWORK(J) )
  320    CONTINUE
C
C        No QZ iteration.
C
         GOTO 450
C
C        Case III: Deflation occurs in a triangular matrix with
C                  index -1.
C
  330    CONTINUE
         JDEF = J
         IF ( JDEF.GT.( (ILAST-JLO+1)/2 ) ) THEN
C
C           Chase the zero downwards to the last position
C
            DO 350  J1 = JDEF, ILAST-1
               J = J1
               TEMP = A(J,J+1,LDEF)
               CALL ZLARTG( TEMP, A(J+1,J+1,LDEF), CS, SN,
     $                      A(J,J+1,LDEF) )
               A(J+1,J+1,LDEF) = CZERO
               CALL ZROT( ILASTM-J-1, A(J,J+2,LDEF), LDA1,
     $                    A(J+1,J+2,LDEF), LDA1, CS, SN )
               LN = LDEF+1
               IF ( LDEF.EQ.K )  LN = 1
               IF ( WANTQ ) THEN
                  CALL ZROT( N, Q(1,J,LN), 1, Q(1,J+1,LN), 1, CS,
     $                       DCONJG( SN ) )
	         END IF
               DO 340  L = 1, K-1
                  IF ( LN.EQ.1 ) THEN
                     CALL ZROT( ILASTM-J+2, A(J,J-1,LN), LDA1,
     $                          A(J+1,J-1,LN), LDA1, CS, SN )
                     TEMP = A(J+1,J,LN)
                     CALL ZLARTG( TEMP, A(J+1,J-1,LN), CS, SN,
     $                            A(J+1,J,LN) )
                     A(J+1,J-1,LN) = CZERO
                     CALL ZROT( J-IFRSTM+1, A(IFRSTM,J,LN), 1,
     $                          A(IFRSTM,J-1,LN), 1, CS, SN )
	               SN = -SN
                     J = J - 1
                  ELSE IF ( S(LN).EQ.1 ) THEN
                     CALL ZROT( ILASTM-J+1, A(J,J,LN), LDA1,
     $                          A(J+1,J,LN), LDA1, CS, SN )
                     TEMP = A(J+1,J+1,LN)
                     CALL ZLARTG( TEMP, A(J+1,J,LN), CS, SN,
     $                            A(J+1,J+1,LN) )
                     A(J+1,J,LN) = CZERO
                     CALL ZROT( J-IFRSTM+1, A(IFRSTM,J+1,LN), 1,
     $                          A(IFRSTM,J,LN), 1, CS, SN )
                     SN = -SN
                  ELSE
                     CALL ZROT( J-IFRSTM+2, A(IFRSTM,J,LN), 1,
     $                          A(IFRSTM,J+1,LN), 1, CS, DCONJG( SN ) )
                     TEMP = A(J,J,LN)
                     CALL ZLARTG( TEMP, A(J+1,J,LN), CS, SN, A(J,J,LN) )
                     A(J+1,J,LN) = CZERO
                     CALL ZROT( ILASTM-J, A(J,J+1,LN), LDA1,
     $                          A(J+1,J+1,LN), LDA1, CS, SN )
                  END IF
                  LN = LN+1
                  IF ( LN.GT.K )  LN = 1
                  IF ( WANTQ ) THEN
                     CALL ZROT( N, Q(1,J,LN), 1, Q(1,J+1,LN), 1, CS,
     $                          DCONJG( SN ) )
	            END IF
  340          CONTINUE
               CALL ZROT( J-IFRSTM+1, A(IFRSTM,J,LDEF), 1,
     $                    A(IFRSTM,J+1,LDEF), 1, CS, DCONJG( SN ) )
  350       CONTINUE
C
C           Deflate the last element in the Hessenberg matrix.
C
            J = ILAST
            TEMP = A(J,J,1)
            CALL ZLARTG( TEMP, A(J,J-1,1), CS, SN, A(J,J,1) )
            A(J,J-1,1) = CZERO
            CALL ZROT( J-IFRSTM, A(IFRSTM,J,1), 1,
     $                 A(IFRSTM,J-1,1), 1, CS, SN )
            SN = -SN
   !         IF ( WANTQ.NE.0 ) THEN
            IF ( WANTQ ) THEN
               CALL ZROT( N, Q(1,J-1,2), 1, Q(1,J,2), 1, CS,
     $                    DCONJG( SN ) )
            END IF
            DO 360  L = 2, LDEF-1
               IF ( S(L).EQ.-1 ) THEN
                  CALL ZROT( J+1-IFRSTM, A(IFRSTM,J-1,L), 1,
     $                       A(IFRSTM,J,L), 1, CS, DCONJG( SN ) )
                  TEMP = A(J-1,J-1,L)
                  CALL ZLARTG( TEMP, A(J,J-1,L), CS, SN,
     $                         A(J-1,J-1,L) )
                  A(J,J-1,L) = CZERO
                  CALL ZROT( ILASTM-J+1, A(J-1,J,L), LDA1,
     $                       A(J,J,L), LDA1, CS, SN )
               ELSE
                  CALL ZROT( ILASTM-J+2, A(J-1,J-1,L), LDA1,
     $                       A(J,J-1,L), LDA1, CS, SN )
                  TEMP = A(J,J,L)
                  CALL ZLARTG( TEMP, A(J,J-1,L), CS, SN,
     $                         A(J,J,L) )
                  A(J,J-1,L) = CZERO
                  CALL ZROT( J-IFRSTM, A(IFRSTM,J,L), 1,
     $                       A(IFRSTM,J-1,L), 1, CS, SN )
                  SN = -SN
               END IF
               IF ( WANTQ ) THEN
                  LN = L+1
                  IF ( L.EQ.K )  LN = 1
                  CALL ZROT( N, Q(1,J-1,LN), 1, Q(1,J,LN), 1, CS,
     $                       DCONJG( SN ) )
               END IF
 360        CONTINUE
            CALL ZROT( J+1-IFRSTM, A(IFRSTM,J-1,LDEF), 1,
     $                 A(IFRSTM,J,LDEF), 1, CS, DCONJG( SN ) )
         ELSE
C
C           Chase the zero upwards to the first position.
C
            DO 380  J1 = JDEF, JLO+1,-1
               J = J1
               TEMP = A(J-1,J,LDEF)
               CALL ZLARTG( TEMP, A(J-1,J-1,LDEF), CS, SN,
     $                      A(J-1,J,LDEF) )
               A(J-1,J-1,LDEF) = CZERO
               CALL ZROT( J-IFRSTM-1, A(IFRSTM,J,LDEF), 1,
     $                    A(IFRSTM,J-1,LDEF), 1, CS, SN )
               SN = -SN
               IF ( WANTQ ) THEN
                  CALL ZROT( N, Q(1,J-1,LDEF), 1, Q(1,J,LDEF), 1, CS,
     $                       DCONJG( SN ) )
	         END IF
               LN = LDEF - 1
               DO 370  L = 1, K-1
                  IF ( LN.EQ.1 ) THEN
                     CALL ZROT( J-IFRSTM+2, A(IFRSTM,J-1,LN), 1,
     $                          A(IFRSTM,J,LN), 1, CS, DCONJG( SN ) )
                     TEMP = A(J,J-1,LN)
                     CALL ZLARTG( TEMP, A(J+1,J-1,LN), CS, SN,
     $                            A(J,J-1,LN) )
                     A(J+1,J-1,LN) = CZERO
                     CALL ZROT( ILASTM-J+1, A(J,J,LN), LDA1,
     $                          A(J+1,J,LN), LDA1, CS, SN )
                     J = J + 1
                  ELSE IF ( S(LN).EQ.-1 ) THEN
                     CALL ZROT( ILASTM-J+2, A(J-1,J-1,LN), LDA1,
     $                          A(J,J-1,LN), LDA1, CS, SN )
                     TEMP = A(J,J,LN)
                     CALL ZLARTG( TEMP, A(J,J-1,LN), CS, SN,
     $                            A(J,J,LN) )
                     A(J,J-1,LN) = CZERO
                     CALL ZROT( J-IFRSTM, A(IFRSTM,J,LN), 1,
     $                          A(IFRSTM,J-1,LN), 1, CS, SN )
                     SN = -SN
                  ELSE
                     CALL ZROT( J-IFRSTM+1, A(IFRSTM,J-1,LN), 1,
     $                          A(IFRSTM,J,LN), 1, CS, DCONJG( SN ) )
                     TEMP = A(J-1,J-1,LN)
                     CALL ZLARTG( TEMP, A(J,J-1,LN), CS, SN,
     $                            A(J-1,J-1,LN) )
                     A(J,J-1,LN) = CZERO
                     CALL ZROT( ILASTM-J+1, A(J-1,J,LN), LDA1,
     $                          A(J,J,LN), LDA1, CS, SN )
                  END IF
	            IF ( WANTQ ) THEN
                     CALL ZROT( N, Q(1,J-1,LN), 1, Q(1,J,LN), 1, CS,
     $                          DCONJG( SN ) )
	            END IF
                  LN = LN - 1
                  IF ( LN.LE.0 )  LN = K
  370          CONTINUE
               CALL ZROT( ILASTM-J+1, A(J-1,J,LDEF), LDA1, A(J,J,LDEF),
     $                    LDA1, CS, SN )
  380       CONTINUE
C
C           Deflate the first element in the Hessenberg matrix.
C
            J = JLO
            TEMP = A(J,J,1)
            CALL ZLARTG( TEMP, A(J+1,J,1), CS, SN, A(J,J,1) )
            A(J+1,J,1) = CZERO
            CALL ZROT( ILASTM-J, A(J,J+1,1), LDA1, A(J+1,J+1,1),
     $                 LDA1, CS, SN )
            IF ( WANTQ ) THEN
               CALL ZROT( N, Q(1,J,1), 1, Q(1,J+1,1), 1, CS,
     $                    DCONJG( SN ) )
            END IF
            DO 390  L = K, LDEF+1, -1
               IF ( S(L).EQ.1 ) THEN
                  CALL ZROT( J+2-IFRSTM, A(IFRSTM,J,L), 1,
     $                       A(IFRSTM,J+1,L), 1, CS, DCONJG( SN ) )
                  TEMP = A(J,J,L)
                  CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, A(J,J,L) )
                  A(J+1,J,L) = CZERO
                  CALL ZROT( ILASTM-J, A(J,J+1,L), LDA1,
     $                       A(J+1,J+1,L), LDA1, CS, SN )
               ELSE
                  CALL ZROT( ILASTM-J+1, A(J,J,L), LDA1,
     $                       A(J+1,J,L), LDA1, CS, SN )
                  TEMP = A(J+1,J+1,L)
                  CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN,
     $                         A(J+1,J+1,L) )
                  A(J+1,J,L) = CZERO
                  CALL ZROT( J+1-IFRSTM, A(IFRSTM,J+1,L), 1,
     $                       A(IFRSTM,J,L), 1, CS, SN )
                  SN = -SN
               END IF
               IF ( WANTQ ) THEN
                  CALL ZROT( N, Q(1,J,L), 1, Q(1,J+1,L), 1, CS,
     $                       DCONJG( SN ) )
               END IF
  390       CONTINUE
            CALL ZROT( ILASTM-J, A(J,J+1,LDEF), LDA1, A(J+1,J+1,LDEF),
     $                 LDA1, CS, SN )
         END IF
C
C        No QZ iteration.
C
         GOTO 450
C
C        Special case: A 1x1 block splits off at the bottom
C
  400    CONTINUE
         CALL ZLAPR1( BASE, K, S, A(ILAST,ILAST,1), LDA1*LDA2,
     $                ALPHA(ILAST), BETA(ILAST), SCAL(ILAST) )
C
C        Go to next block - exit if finished.
C
         ILAST = ILAST - 1
         IF ( ILAST.LT.ILO )  GOTO 470
C
C        Reset iteration counters.
C
         IITER = 0
         IF ( ZITER.NE.-1 )  ZITER = 0
         IF ( .NOT.LSCHR ) THEN
            ILASTM = ILAST
            IF ( IFRSTM.GT.ILAST )  IFRSTM = ILO
         END IF
C
C        No QZ iteration.
C
         GOTO 450
C
C        **************************************************************
C        *                      PERIODIC QZ STEP                      *
C        **************************************************************
C
C        It is assumed that IFIRST < ILAST.
C
  410    CONTINUE
C
         IITER = IITER + 1
         ZITER = ZITER + 1
         IF( .NOT.LSCHR ) THEN
            IFRSTM = IFIRST
         END IF
C
C        Complex single shift.
C
         IF ( ( IITER / 10 )*10.EQ.IITER ) THEN
C
C           Exceptional shift.
C
            CALL ZLARNV( 2, ISEED, 2, RND )
            CALL ZLARTG( RND(1), RND(2), CS, SN, TEMP )
         ELSE
	      CALL ZLARTG( CONE, CONE, CS, SN, TEMP )
            DO 420  L = K, 2, -1
               IF ( S(L).EQ.1 ) THEN
	            CALL ZLARTG( A(IFIRST,IFIRST,L)*CS,
     $                         A(ILAST,ILAST,L)*DCONJG(SN),
     $                         CS, SN, TEMP )
               ELSE
	            CALL ZLARTG( A(ILAST,ILAST,L)*CS,
     $                         -A(IFIRST,IFIRST,L)*DCONJG(SN),
     $                         CS, SN, TEMP )
	            SN = -SN
               END IF
  420       CONTINUE
            CALL ZLARTG( A(IFIRST,IFIRST,1)*CS
     $                   -DCONJG(SN)*A(ILAST,ILAST,1),
     $                   A(IFIRST+1,IFIRST,1)*CS, CS, SN, TEMP )
         END IF
C
C        Do the sweeps.
C
         DO 440  J1 = IFIRST-1, ILAST-2
            J = J1 + 1
C
C           Create bulge if J1 = IFIRST - 1, otherwise chase bulge.
C
            IF ( J1.LT.IFIRST ) THEN
               CALL ZROT( ILASTM-J+1, A(J,J,1), LDA1, A(J+1,J,1), LDA1,
     $                    CS, SN )
            ELSE
               TEMP = A(J,J-1,1)
               CALL ZLARTG( TEMP, A(J+1,J-1,1), CS, SN, A(J,J-1,1) )
               A(J+1,J-1,1) = CZERO
               CALL ZROT( ILASTM-J+1, A(J,J,1), LDA1, A(J+1,J,1),
     $                    LDA1, CS, SN )
            END IF
            IF ( WANTQ ) THEN
               CALL ZROT( N, Q(1,J,1), 1, Q(1,J+1,1), 1, CS,
     $                    DCONJG( SN ) )
            END IF
C
C           Propagate rotation through AK, ..., A2 to A1.
C
            DO 430  L = K, 2, -1
               IF ( S(L).EQ.1 ) THEN
                  CALL ZROT( J+2-IFRSTM, A(IFRSTM,J,L), 1,
     $                       A(IFRSTM,J+1,L), 1, CS, DCONJG( SN ) )
                  TEMP = A(J,J,L)
                  CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, A(J,J,L) )
                  A(J+1,J,L) = CZERO
                  CALL ZROT( ILASTM-J, A(J,J+1,L), LDA1,
     $                       A(J+1,J+1,L), LDA1, CS, SN )
               ELSE
                  CALL ZROT( ILASTM-J+1, A(J,J,L), LDA1, A(J+1,J,L),
     $                       LDA1, CS, SN )
                  TEMP = A(J+1,J+1,L)
                  CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, A(J+1,J+1,L) )
                  A(J+1,J,L) = CZERO
                  CALL ZROT( J+1-IFRSTM, A(IFRSTM,J+1,L), 1,
     $                       A(IFRSTM,J,L), 1, CS, SN )
                  SN = -SN
               END IF
               IF ( WANTQ ) THEN
                  CALL ZROT( N, Q(1,J,L), 1, Q(1,J+1,L), 1, CS,
     $                       DCONJG( SN ) )
               END IF
  430       CONTINUE
            CALL ZROT( MIN(J+2,ILASTM)-IFRSTM+1, A(IFRSTM,J,1), 1,
     $                 A(IFRSTM,J+1,1), 1, CS, DCONJG( SN ) )
  440    CONTINUE
C
C        End of iteration loop.
C
  450    CONTINUE
  460 CONTINUE
C
C     Drop through = non-convergence
C
      INFO = ILAST
      GO TO 550
C
C     Successful completion of all QZ steps
C
  470 CONTINUE
C
C     Set eigenvalues 1:ILO-1
C
      DO 480  J = 1,ILO-1
         CALL ZLAPR1( BASE, K, S, A(J,J,1), LDA1*LDA2, ALPHA(J),
     $                BETA(J), SCAL(J) )
  480 CONTINUE
      IF ( LSCHR ) THEN
C
C        Scale A(2,:,:) .. A(K,:,:).
C
         DO 540  L = K, 2, -1
	      IF ( S(L).EQ.1 )  THEN
	         DO 490 J = 1, N
                  ABST = ABS( A(J,J,L) )
                  IF ( ABST.GT.SAFMIN ) THEN
                     TEMP = DCONJG( A(J,J,L) / ABST )
                     A(J,J,L ) = ABST
                     IF ( J.LT.N )
     $                  CALL ZSCAL( N-J, TEMP, A(J,J+1,L), LDA1 )
	            ELSE
	               TEMP = CONE
	            END IF
                  ZWORK(J) = TEMP
  490          CONTINUE
	      ELSE
               DO 500  J = 1, N
                  ABST = ABS( A(J,J,L) )
                  IF ( ABST.GT.SAFMIN ) THEN
                     TEMP = DCONJG( A(J,J,L) / ABST )
                     A(J,J,L ) = ABST
                     CALL ZSCAL( J-1, TEMP, A(1,J,L), 1 )
	            ELSE
	               TEMP = CONE
	            END IF
                  ZWORK(J) = DCONJG(TEMP)
  500          CONTINUE
	      END IF
            IF ( WANTQ ) THEN
	         DO 510  J = 1, N
                  CALL ZSCAL( N, DCONJG( ZWORK(J) ), Q(1,J,L), 1 )
  510          CONTINUE
            END IF
         	IF ( S(L-1).EQ.1 )  THEN
	         DO 520  J = 1, N
	            CALL ZSCAL( J, DCONJG( ZWORK(J) ), A(1,J,L-1), 1 )
  520          CONTINUE
            ELSE
	         DO 530  J = 1, N
	            CALL ZSCAL( N-J+1, ZWORK(J), A(J,J,L-1), LDA1 )
  530          CONTINUE
	      END IF
  540    CONTINUE
	END IF
      INFO = 0
C
  550 CONTINUE
C
      DWORK(1) = DBLE( N )
      ZWORK(1) = DCMPLX( N, 0 )
      RETURN
C *** Last line of ZPGEQZ ***
      END


!  SW4 LICENSE
! # ----------------------------------------------------------------------
! # SW4 - Seismic Waves, 4th order
! # ----------------------------------------------------------------------
! # Copyright (c) 2013, Lawrence Livermore National Security, LLC.
! # Produced at the Lawrence Livermore National Laboratory.
! #
! # Written by:
! # N. Anders Petersson (petersson1@llnl.gov)
! # Bjorn Sjogreen      (sjogreen2@llnl.gov)
! #
! # LLNL-CODE-643337
! #
! # All rights reserved.
! #
! # This file is part of SW4, Version: 1.0
! #
! # Please also read LICENCE.txt, which contains "Our Notice and GNU General Public License"
! #
! # This program is free software; you can redistribute it and/or modify
! # it under the terms of the GNU General Public License (as published by
! # the Free Software Foundation) version 2, dated June 1991.
! #
! # This program is distributed in the hope that it will be useful, but
! # WITHOUT ANY WARRANTY; without even the IMPLIED WARRANTY OF
! # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the terms and
! # conditions of the GNU General Public License for more details.
! #
! # You should have received a copy of the GNU General Public License
! # along with this program; if not, write to the Free Software
! # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
c-----------------------------------------------------------------------
      subroutine METRIC( ifirst, ilast, jfirst, jlast, kfirst, klast,
     *                   x, y, z, met, jac, ierr )
      implicit none
      real*8 c1, c2
      parameter( c1=2d0/3, c2=-1d0/12 )
      real*8 fs, ot, ft, os, d3
      parameter( fs= 5d0/6, ot=1d0/12, ft=4d0/3, os=1d0/6, d3=14d0/3 )

      integer i, j, k, ifirst, ilast, jfirst, jlast, ierr
      integer kfirst, klast
      real*8 x(ifirst:ilast,jfirst:jlast,kfirst:klast)
      real*8 y(ifirst:ilast,jfirst:jlast,kfirst:klast)
      real*8 z(ifirst:ilast,jfirst:jlast,kfirst:klast)
      real*8 met(4,ifirst:ilast,jfirst:jlast,kfirst:klast)
      real*8 jac(ifirst:ilast,jfirst:jlast,kfirst:klast)
      real*8 h, zr, zp, zq, sqzr

      ierr=0
      h = x(ifirst+1,jfirst,kfirst)-x(ifirst,jfirst,kfirst)
      do k=kfirst,klast
         do j=jfirst,jlast
            do i=ifirst,ilast

*** k-derivatives
               if( k.ge.kfirst+2 .and. k.le.klast-2 )then
                  zr = c2*(z(i,j,k+2)-z(i,j,k-2)) +
     *                 c1*(z(i,j,k+1)-z(i,j,k-1))
               elseif( k.eq.kfirst )then
c                  zr = -(2+ot)*z(i,j,k)+4*z(i,j,k+1)-3*z(i,j,k+2)+
c     *                               ft*z(i,j,k+3)-0.25d0*z(i,j,k+4)
                  zr=-2.25d0*z(i,j,k)+(4+fs)*z(i,j,k+1)-d3*z(i,j,k+2)+
     *                   3*z(i,j,k+3)-(1+ot)*z(i,j,k+4) +os*z(i,j,k+5)
               elseif( k.eq.kfirst+1 )then
c                  zr = -0.25d0*z(i,j,k-1)-fs*z(i,j,k)+1.5d0*z(i,j,k+1)-
c     *                                   0.5d0*z(i,j,k+2)+ot*z(i,j,k+3)
                  zr = -os*z(i,j,k-1) -1.25d0*z(i,j,k)+(1+ft)*z(i,j,k+1)
     *                - ft*z(i,j,k+2) + 0.5d0*z(i,j,k+3) -ot*z(i,j,k+4)
               elseif( k.eq.klast-1 )then
c                  zr = 0.25d0*z(i,j,klast)+fs*z(i,j,klast-1)
c     *      -1.5d0*z(i,j,klast-2)+0.5d0*z(i,j,klast-3)-ot*z(i,j,klast-4)
                  zr =  os*z(i,j,k+1) +1.25d0*z(i,j,k)-(1+ft)*z(i,j,k-1)
     *                + ft*z(i,j,k-2) - 0.5d0*z(i,j,k-3) + ot*z(i,j,k-4)
               elseif( k.eq.klast )then
c                  zr = (2+ot)*z(i,j,klast)-4*z(i,j,klast-1)
c     *         +3*z(i,j,klast-2)-ft*z(i,j,klast-3)+0.25d0*z(i,j,klast-4)
                  zr= 2.25d0*z(i,j,k)-(4+fs)*z(i,j,k-1)+d3*z(i,j,k-2)-
     *                   3*z(i,j,k-3)+(1+ot)*z(i,j,k-4) -os*z(i,j,k-5)
               endif

*** j-derivatives
               if( j.ge.jfirst+2 .and. j.le.jlast-2 )then
                  zq = c2*(z(i,j+2,k)-z(i,j-2,k)) +
     *                 c1*(z(i,j+1,k)-z(i,j-1,k))
               elseif( j.eq.jfirst )then
c                  zq = -(2+ot)*z(i,j,k)+4*z(i,j+1,k)-3*z(i,j+2,k)+
c     *                               ft*z(i,j+3,k)-0.25d0*z(i,j+4,k)
                  zq=-2.25d0*z(i,j,k)+(4+fs)*z(i,j+1,k)-d3*z(i,j+2,k)+
     *                   3*z(i,j+3,k)-(1+ot)*z(i,j+4,k) +os*z(i,j+5,k)
               elseif( j.eq.jfirst+1 )then
c                  zq = -0.25d0*z(i,j-1,k)-fs*z(i,j,k)+1.5d0*z(i,j+1,k)-
c     *                                   0.5d0*z(i,j+2,k)+ot*z(i,j+3,k)
                  zq = -os*z(i,j-1,k) -1.25d0*z(i,j,k)+(1+ft)*z(i,j+1,k)
     *                 - ft*z(i,j+2,k) + 0.5d0*z(i,j+3,k) -ot*z(i,j+4,k)
               elseif( j.eq.jlast-1 )then
c                  zq = 0.25d0*z(i,jlast,k)+fs*z(i,jlast-1,k)
c     *     -1.5d0*z(i,jlast-2,k)+0.5d0*z(i,jlast-3,k)-ot*z(i,jlast-4,k)
                  zq = os*z(i,j+1,k) +1.25d0*z(i,j,k)-(1+ft)*z(i,j-1,k)
     *               + ft*z(i,j-2,k) - 0.5d0*z(i,j-3,k) + ot*z(i,j-4,k)
               elseif( j.eq.jlast )then
c                  zq = (2+ot)*z(i,jlast,k)-4*z(i,jlast-1,k)
c     *      + 3*z(i,jlast-2,k)- ft*z(i,jlast-3,k)+0.25d0*z(i,jlast-4,k)
                  zq= 2.25d0*z(i,j,k)-(4+fs)*z(i,j-1,k)+d3*z(i,j-2,k)-
     *                   3*z(i,j-3,k)+(1+ot)*z(i,j-4,k) -os*z(i,j-5,k)
               endif

*** i-derivatives
               if( i.ge.ifirst+2 .and. i.le.ilast-2 )then
                  zp= c2*(z(i+2,j,k)-z(i-2,j,k)) +
     *                c1*(z(i+1,j,k)-z(i-1,j,k))
               elseif( i.eq.ifirst )then
c                  zp = -(2+ot)*z(i,j,k)+4*z(i+1,j,k)-3*z(i+2,j,k)+
c     *                               ft*z(i+3,j,k)-0.25d0*z(i+4,j,k)
                  zp=-2.25d0*z(i,j,k)+(4+fs)*z(i+1,j,k)-d3*z(i+2,j,k)+
     *                   3*z(i+3,j,k)-(1+ot)*z(i+4,j,k) +os*z(i+5,j,k)
               elseif( i.eq.ifirst+1 )then
c                  zp =-0.25d0*z(i-1,j,k)-fs*z(i,j,k)+1.5d0*z(i+1,j,k)-
c     *                                  0.5d0*z(i+2,j,k)+ot*z(i+3,j,k)
                  zp = -os*z(i-1,j,k) -1.25d0*z(i,j,k)+(1+ft)*z(i+1,j,k)
     *                - ft*z(i+2,j,k) + 0.5d0*z(i+3,j,k) - ot*z(i+4,j,k)
               elseif( i.eq.ilast-1)then
c                  zp = 0.25d0*z(ilast,j,k)+fs*z(ilast-1,j,k)
c     *      -1.5d0*z(ilast-2,j,k)+0.5d0*z(ilast-3,j,k)-ot*z(ilast-4,j,k)
                  zp =  os*z(i+1,j,k) +1.25d0*z(i,j,k)-(1+ft)*z(i-1,j,k)
     *                + ft*z(i-2,j,k) - 0.5d0*z(i-3,j,k) + ot*z(i-4,j,k)
               elseif( i.eq.ilast)then
c                  zp = (2+ot)*z(ilast,j,k)-4*z(ilast-1,j,k)
c     *       +3*z(ilast-2,j,k)-  ft*z(ilast-3,j,k)+0.25d0*z(ilast-4,j,k)
                  zp= 2.25d0*z(i,j,k)-(4+fs)*z(i-1,j,k)+d3*z(i-2,j,k)-
     *                   3*z(i-3,j,k)+(1+ot)*z(i-4,j,k) -os*z(i-5,j,k)
               endif

*** Compute the metric
               if( zr.le.0 )then
c                  write(*,101) 'Error, zr = ' , zr, ' at ', i, j, k
c 101              format(' ', a, g12.5, a, 3(tr1,i3) )
c are you kidding me?                  stop
                  ierr=-1
                  return
               endif
c               if(i.eq.(ifirst+ilast)/2.and.j.eq.(jfirst+jlast)/2 )then
c                  write(*,102) k, zr, z(i,j,k)
c 102              format(' ', i3, tr2, 2(g15.7,tr2))
c               endif

               sqzr = sqrt(zr)
               jac(i,j,k) = h*h*zr
               met(1,i,j,k) = sqzr
               met(2,i,j,k) = -zp/sqzr
               met(3,i,j,k) = -zq/sqzr
               met(4,i,j,k) = h/sqzr
            enddo
         enddo
      enddo
      end

c-----------------------------------------------------------------------
      subroutine METRICEXGH( ifirst, ilast, jfirst, jlast, kfirst,
     *                       klast, nx, ny, nz, x, y, z, met, jac,
     *                       order, sb, zmax, amp, xc, yc, xl, yl )
*** Exact metric derivatives for the Gaussian hill topography

      implicit none
      real*8 c1, c2
      parameter( c1=2d0/3, c2=-1d0/12 )
      real*8 fs, ot, ft, os, d3
      parameter( fs= 5d0/6, ot=1d0/12, ft=4d0/3, os=1d0/6, d3=14d0/3 )

      integer i, j, k, ifirst, ilast, jfirst, jlast
      integer kfirst, klast, nx, ny, nz, order, l
      real*8 x(ifirst:ilast,jfirst:jlast,kfirst:klast)
      real*8 y(ifirst:ilast,jfirst:jlast,kfirst:klast)
      real*8 z(ifirst:ilast,jfirst:jlast,kfirst:klast)
      real*8 met(4,ifirst:ilast,jfirst:jlast,kfirst:klast)
      real*8 jac(ifirst:ilast,jfirst:jlast,kfirst:klast)
      real*8 zmax, amp, xc, yc, xl, yl, ixl2, iyl2, zz
      real*8 h, zr, zp, zq, sqzr, s, tau, taup, tauq, sb, sdb, p1, p2
      h = x(ifirst+1,jfirst,kfirst)-x(ifirst,jfirst,kfirst)
      ixl2 = 1/(xl*xl)
      iyl2 = 1/(yl*yl)
      do k=kfirst,klast
         do j=jfirst,jlast
            do i=ifirst,ilast
               s = (k-1d0)/(nz-1)
               if( s.lt.sb )then
                  sdb = s/sb
                  tau  = amp*EXP( - (x(i,j,1)-xc)**2*ixl2 -
     *                 (y(i,j,1)-yc)**2*iyl2 )
                  taup = -2*(x(i,j,1)-xc)*ixl2*tau
                  tauq = -2*(y(i,j,1)-yc)*iyl2*tau
                  p1 = 1-sdb
                  p2 = 1
                  do l=2,order-1
                     p1 = p1 + (1-sdb)**l
                     p2 = p2 + l*(1-sdb)**(l-1)
                  enddo
                  zp = taup*( -(1-sdb)+sdb*p1 )
                  zq = tauq*( -(1-sdb)+sdb*p1)
                  zr = (tau+zmax+(zmax+tau-h*sb*(nz-1))*p1 -
     *                       sdb*(zmax+tau-h*sb*(nz-1))*p2 )/sb
                  zz = (1-sdb)*(-tau) +
     *                     sdb*(zmax+(zmax+tau-h*sb*(nz-1))*p1)
               else
                  zp = 0
                  zq = 0
                  zr = h*(nz-1)
                  zz = zmax + (s-sb)*h*(nz-1)
               endif

c               if(i.eq.(ifirst+ilast)/2.and.j.eq.(jfirst+jlast)/2 )then
c                  write(*,101) k, zr, zr/(nz-1), z(i,j,k), zz
c 101              format(' ', i3, tr2, 4( g15.7,tr2 ) )
c               endif

*** Convert to 'undivided differences'
               zp = zp*h
               zq = zq*h
               zr = zr/(nz-1)

*** Formulas from metric evaluation numerically
               sqzr = sqrt(zr)
               jac(i,j,k)   = h*h*zr
               met(1,i,j,k) = sqzr
               met(2,i,j,k) = -zp/sqzr
               met(3,i,j,k) = -zq/sqzr
               met(4,i,j,k) = h/sqzr
            enddo
         enddo
      enddo
      end


      module MOD_PRICOLR
      contains
C**********  MODULNAME: PRICOLR   ******* 21/05/87  12.36.48.******    78 KARTEN
      SUBROUTINE PRICOLR (NF,XLAMBDA,EMFLUX,RSTAR)
C***  CALCULATION AND PRINTOUT OF MAGNITUDES AND COLOR INDICES
C***  REFERENCES: SMITH,L.: 1968, MNRAS 140, P. 409
C***              HAYES,D.S. + LATHAM,D.W.: 1975, AP.J. 197, P. 593
C***              MASSEY,P.: 1984, AP.J. 281, P. 789
C***              WAMSTEKER,W.: 1981, A+A 97, P. 329
      use MOD_XRUDI
      use MOD_TCOLOR
      implicit real*8(a-h,o-z)

      DIMENSION XLAMBDA(NF),EMFLUX(NF)
      DIMENSION CENTER (13), ABAND(13), COLOR(13), CALCON(13), ADIFF(13)
	CHARACTER ITCOL*8
      DATA PI/3.1415926535898d0/
C***  1 PARSEC IN CM
      DATA PARSEC / 3.08561d18 /
C***  NAMES OF THE CONSIDERED COLOR BANDS
      DATA ABAND /3HUV1,3HUV2,
     $            7HSMITH U,7HSMITH B,7HSMITH V,8HMASSEY R,
     $            8HJ WE=.02,8HH WE=.02,8HK WE=.02,8HL WE=.02,8HM WE=.02
     $           ,8H(10) BSW,8HJOHNSONV/
      DATA ADIFF /1H ,7HUV1-UV2,1H ,3HU-B,3HB-V,3HV-R,7*1H /
C***  CENTER FREQUENCIES OF THE COLOR BANDS
      DATA CENTER /1445.,1940.,
     $             3650.,4270.,5160.,6000.,1.26E4,1.60E4,2.22E4,
     $             3.54E4,4.8E4,1.E5,5448./
C***  CALIBRATION CONSTANTS OF THE COLOR BANDS IN MAGNITUDES
      DATA CALCON / 6*48.64,
     $              49.488,49.921,50.440,51.605,51.924,53.574,
     $              48.593/
C***  SOURCES: U,B,V,R : HAYES + LATHAM
C***           V-Johns': Bessel & Brett 1988, PASP 100, 1134
C***                     central wavelength Bessel 1990
C***           JHKLM   : CAMPINS ET AL. 1985 ASTRON,J. 90,896
C***           (10)    : BARLOW,SMITH+WILLIS 1981 MNRAS 196,101
C***  DISTANCE MODULUS OF 10 PARSEC
      DISMO=-2.5d0*LOG10(RSTAR*RSTAR/100.d0/PARSEC/PARSEC )

      PRINT 1
    1 FORMAT (//,10X,'ABSOLUTE MONOCHROMATIC MAGNITUDES AND ',
     $      'COLOR INDICES',/,10X,51('='),//,
     $      10X,'BAND      WAVELENTH   MAGNITUDE',
     $ 8X,'MAG DIFFERENCES',3X,'COLOR TEMP',8X,'LOG F-L/F-L',/)

      DO 2 I=1,13
C***  INTERPOLATION OF THE EMERGENT FLUX AT CENTER FREQUENCY
      WAVENUM=1.E8/CENTER(I)
      IF (CENTER(I).GT.XLAMBDA(NF)) GOTO 2
      CALL XRUDI (FCENTER,WAVENUM,EMFLUX,XLAMBDA,1,NF,1)
C***  NOTE THAT THE ATROPHYSICAL FLUX MUST BE MULTIPLIED BY PI !!
      COLOR(I)=-2.5*LOG10(FCENTER*PI)+DISMO-CALCON(I)
      IF (CENTER(I) .LE. 10000.) THEN
         IF (ADIFF(I).EQ.1H ) THEN
         PRINT 3,ABAND(I),CENTER(I),COLOR(I)
    3    FORMAT (10X,A8,F10.0,' A ',F10.3)
         ELSE
         ITCOL='        '
         CALL TCOLOR (CENTER(I-1),CENTER(I),FCM1,FCENTER,ITCOL)
         COLDIF=COLOR(I-1)-COLOR(I)
         WAVFAC=LOG10(CENTER(I)/CENTER(I-1))*2.
         FLDIFF=COLDIF/(-2.5)+WAVFAC
         PRINT 6,ABAND(I),CENTER(I),COLOR(I),ADIFF(I),
     $           COLDIF,ITCOL,FLDIFF
    6    FORMAT(10X,A8,F10.0,' A ',F10.3,8X,A8,F7.3,5X,A8,8X,F7.3)
         ENDIF
         ELSE
         PRINT 4,ABAND(I),CENTER(I)/10000.,COLOR(I)
    4    FORMAT (10X,A8,F10.2,' MU',F10.3)
         ENDIF
      FCM1=FCENTER
    2 CONTINUE

C***  REDDENING-FREE COLOR INDICES (MASSEY, 1984)
C***  U-B STATT U-V WIE IN PAPER VON MASSEY         KORRIGIERT AM 27.11.85
C***  DELTA = (U-B) - 0.68* (B-V)
      DELTA=COLOR(3)-COLOR(4)-0.68*(COLOR(4)-COLOR(5))
C***  ETA = (B-V) - 1.46 * (V-R)
      ETA=COLOR(4)-COLOR(5)-1.46*(COLOR(5)-COLOR(6))
      PRINT 5,ETA,DELTA
    5 FORMAT (/,10X,'REDDENING-FREE INDICES (MASSEY, 1984):  ETA=',
     $      F7.3,10X,'DELTA=',F7.3)

      RETURN
      END subroutine
      end module


      subroutine chand (xphi,xmuv,xmus,xtau
     s                  ,xrray)
!*
!Description: routine used to compute the intrinsic reflectance of a pure
! molecular atmosphere.

!Input parameters:

!	float xphi:  relative azimuth angle: difference between the sun azimuth
!  	and the sensor azimuth (in degree)

!	float xmuv:  cosine of the view zenith angle (unitless).

!	float xmus:  cosine of the sun zenith angle (unitless).

!	float xtau:  optical depth of the molecules (unitless).

!Output Parameters:

!	float xrray:  intrinsic atmospheric reflectance in case of
!	pure molecular scattering.

!Revision History:
!$LOG: CHAND.f,v1.0$

!Original version: Wed Dec 13 09:33:38 EST 1995
!E. VERMOTE (eric@kratmos.gsfc.nasa.gov)

!Developer Header:

!DEVELOPPERS:  Eric F Vermote, eric@kratmos.gsfc.nasa.gov, 301-286-6232

!References and Credits:

!Design Notes: this is a 6S routine.
!END****************************************************************************
*/
c input parameters: xphi,xmus,xmuv,xtau
c xphi: azimuthal difference between sun and observation (xphi=0,
c in backscattering) and expressed in degree (0.:360.)
c xmus: cosine of the sun zenith angle
c xmuv: cosine of the observation zenith angle
c xtau: molecular optical depth
c output parameter: xrray : molecular reflectance (0.:1.)
c constant : xdep: depolarization factor (0.0279)
      real xdep,pl(10)
      real fs0,fs1,fs2
      real as0(10),as1(2),as2(2)
      real xphi,xmus,fac,xmuv,xtau,xrray,pi,phios,xcosf1,xcosf2
      real xcosf3,xbeta2,xfd,xph1,xph2,xph3,xitm, xp1, xp2, xp3
      real cfonc1,cfonc2,cfonc3,xlntau,xitot1,xitot2,xitot3
      integer i
      data (as0(i),i=1,10) /.33243832,-6.777104e-02,.16285370
     s      ,1.577425e-03,-.30924818,-1.240906e-02,-.10324388
     s      ,3.241678e-02,.11493334,-3.503695e-02/
      data (as1(i),i=1,2) /.19666292, -5.439061e-02/
      data (as2(i),i=1,2) /.14545937,-2.910845e-02/
      pi=3.1415927
      fac=pi/180.
      phios=180.-xphi
      xcosf1=1.
      xcosf2=cos(phios*fac)
      xcosf3=cos(2*phios*fac)
      xbeta2=0.5
      xdep=0.0279
      xfd=xdep/(2-xdep)
      xfd=(1-xfd)/(1+2*xfd)
      xph1=1+(3*xmus*xmus-1)*(3*xmuv*xmuv-1)*xfd/8.
      xph2=-xmus*xmuv*sqrt(1-xmus*xmus)*sqrt(1-xmuv*xmuv)
      xph2=xph2*xfd*xbeta2*1.5
      xph3=(1-xmus*xmus)*(1-xmuv*xmuv)
      xph3=xph3*xfd*xbeta2*0.375
      xitm=(1-exp(-xtau*(1/xmus+1/xmuv)))*xmus/(4*(xmus+xmuv))
      xp1=xph1*xitm
      xp2=xph2*xitm
      xp3=xph3*xitm
      xitm=(1-exp(-xtau/xmus))*(1-exp(-xtau/xmuv))
      cfonc1=xph1*xitm
      cfonc2=xph2*xitm
      cfonc3=xph3*xitm
      xlntau=log(xtau)
      pl(1)=1.
      pl(2)=xlntau
      pl(3)=xmus+xmuv
      pl(4)=xlntau*pl(3)
      pl(5)=xmus*xmuv
      pl(6)=xlntau*pl(5)
      pl(7)=xmus*xmus+xmuv*xmuv
      pl(8)=xlntau*pl(7)
      pl(9)=xmus*xmus*xmuv*xmuv
      pl(10)=xlntau*pl(9)
      fs0=0.
      do i=1,10
        fs0=fs0+pl(i)*as0(i)
      enddo
      fs1=pl(1)*as1(1)+pl(2)*as1(2)
      fs2=pl(1)*as2(1)+pl(2)*as2(2)
      xitot1=xp1+cfonc1*fs0*xmus
      xitot2=xp2+cfonc2*fs1*xmus
      xitot3=xp3+cfonc3*fs2*xmus
      xrray=xitot1*xcosf1
      xrray=xrray+xitot2*xcosf2*2
      xrray=xrray+xitot3*xcosf3*2
      xrray=xrray/xmus
      return
      end


c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: slaqrb
c
c\Description:
c  Compute the eigenvalues and the Schur decomposition of an upper
c  Hessenberg submatrix in rows and columns ILO to IHI.  Only the
c  last component of the Schur vectors are computed.
c
c  This is mostly a modification of the LAPACK routine slahqr.
c
c\Usage:
c  call slaqrb
c     ( WANTT, N, ILO, IHI, H, LDH, WR, WI,  Z, INFO )
c
c\Arguments
c  WANTT   Logical variable.  (INPUT)
c          = .TRUE. : the full Schur form T is required;
c          = .FALSE.: only eigenvalues are required.
c
c  N       Integer.  (INPUT)
c          The order of the matrix H.  N >= 0.
c
c  ILO     Integer.  (INPUT)
c  IHI     Integer.  (INPUT)
c          It is assumed that H is already upper quasi-triangular in
c          rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless
c          ILO = 1). SLAQRB works primarily with the Hessenberg
c          submatrix in rows and columns ILO to IHI, but applies
c          transformations to all of H if WANTT is .TRUE..
c          1 <= ILO <= max(1,IHI); IHI <= N.
c
c  H       Real array, dimension (LDH,N).  (INPUT/OUTPUT)
c          On entry, the upper Hessenberg matrix H.
c          On exit, if WANTT is .TRUE., H is upper quasi-triangular in
c          rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in
c          standard form. If WANTT is .FALSE., the contents of H are
c          unspecified on exit.
c
c  LDH     Integer.  (INPUT)
c          The leading dimension of the array H. LDH >= max(1,N).
c
c  WR      Real array, dimension (N).  (OUTPUT)
c  WI      Real array, dimension (N).  (OUTPUT)
c          The real and imaginary parts, respectively, of the computed
c          eigenvalues ILO to IHI are stored in the corresponding
c          elements of WR and WI. If two eigenvalues are computed as a
c          complex conjugate pair, they are stored in consecutive
c          elements of WR and WI, say the i-th and (i+1)th, with
c          WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
c          eigenvalues are stored in the same order as on the diagonal
c          of the Schur form returned in H, with WR(i) = H(i,i), and, if
c          H(i:i+1,i:i+1) is a 2-by-2 diagonal block,
c          WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).
c
c  Z       Real array, dimension (N).  (OUTPUT)
c          On exit Z contains the last components of the Schur vectors.
c
c  INFO    Integer.  (OUPUT)
c          = 0: successful exit
c          > 0: SLAQRB failed to compute all the eigenvalues ILO to IHI
c               in a total of 30*(IHI-ILO+1) iterations; if INFO = i,
c               elements i+1:ihi of WR and WI contain those eigenvalues
c               which have been successfully computed.
c
c\Remarks
c  1. None.
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c     xxxxxx  real
c
c\Routines called:
c     slabad  LAPACK routine that computes machine constants.
c     slamch  LAPACK routine that determines machine constants.
c     slanhs  LAPACK routine that computes various norms of a matrix.
c     slanv2  LAPACK routine that computes the Schur factorization of
c             2 by 2 nonsymmetric matrix in standard form.
c     slarfg  LAPACK Householder reflection construction routine.
c     scopy   Level 1 BLAS that copies one vector to another.
c     srot    Level 1 BLAS that applies a rotation to a 2 by 2 matrix.

c
c\Author
c     Danny Sorensen               Phuong Vu
c     Richard Lehoucq              CRPC / Rice University
c     Dept. of Computational &     Houston, Texas
c     Applied Mathematics
c     Rice University
c     Houston, Texas
c
c\Revision history:
c     xx/xx/92: Version ' 2.4'
c               Modified from the LAPACK routine slahqr so that only the
c               last component of the Schur vectors are computed.
c
c\SCCS Information: @(#)
c FILE: laqrb.F   SID: 2.2   DATE OF SID: 8/27/96   RELEASE: 2
c
c\Remarks
c     1. None
c
c\EndLib
c
c-----------------------------------------------------------------------
c
      subroutine slaqrb ( wantt, n, ilo, ihi, h, ldh, wr, wi,
     &                    z, info )
c
c     %------------------%
c     | Scalar Arguments |
c     %------------------%
c
      logical    wantt
      integer    ihi, ilo, info, ldh, n
c
c     %-----------------%
c     | Array Arguments |
c     %-----------------%
c
      Real
     &           h( ldh, * ), wi( * ), wr( * ), z( * )
c
c     %------------%
c     | Parameters |
c     %------------%
c
      Real
     &           zero, one, dat1, dat2
      parameter (zero = 0.0E+0, one = 1.0E+0, dat1 = 7.5E-1,
     &           dat2 = -4.375E-1)
c
c     %------------------------%
c     | Local Scalars & Arrays |
c     %------------------------%
c
      integer    i, i1, i2, itn, its, j, k, l, m, nh, nr
      Real
     &           cs, h00, h10, h11, h12, h21, h22, h33, h33s,
     &           h43h34, h44, h44s, ovfl, s, smlnum, sn, sum,
     &           t1, t2, t3, tst1, ulp, unfl, v1, v2, v3
      Real
     &           v( 3 ), work( 1 )
c
c     %--------------------%
c     | External Functions |
c     %--------------------%
c
      Real
     &           slamch, slanhs
      external   slamch, slanhs
c
c     %----------------------%
c     | External Subroutines |
c     %----------------------%
c
      external   scopy, slabad, slanv2, slarfg, srot
c
c     %-----------------------%
c     | Executable Statements |
c     %-----------------------%
c
      info = 0
c
c     %--------------------------%
c     | Quick return if possible |
c     %--------------------------%
c
      if( n.eq.0 )
     &   return
      if( ilo.eq.ihi ) then
         wr( ilo ) = h( ilo, ilo )
         wi( ilo ) = zero
         return
      end if
c
c     %---------------------------------------------%
c     | Initialize the vector of last components of |
c     | the Schur vectors for accumulation.         |
c     %---------------------------------------------%
c
      do 5 j = 1, n-1
         z(j) = zero
  5   continue
      z(n) = one
c
      nh = ihi - ilo + 1
c
c     %-------------------------------------------------------------%
c     | Set machine-dependent constants for the stopping criterion. |
c     | If norm(H) <= sqrt(OVFL), overflow should not occur.        |
c     %-------------------------------------------------------------%
c
      unfl = slamch( 'safe minimum' )
      ovfl = one / unfl
      call slabad( unfl, ovfl )
      ulp = slamch( 'precision' )
      smlnum = unfl*( nh / ulp )
c
c     %---------------------------------------------------------------%
c     | I1 and I2 are the indices of the first row and last column    |
c     | of H to which transformations must be applied. If eigenvalues |
c     | only are computed, I1 and I2 are set inside the main loop.    |
c     | Zero out H(J+2,J) = ZERO for J=1:N if WANTT = .TRUE.          |
c     | else H(J+2,J) for J=ILO:IHI-ILO-1 if WANTT = .FALSE.          |
c     %---------------------------------------------------------------%
c
      if( wantt ) then
         i1 = 1
         i2 = n
         do 8 i=1,i2-2
            h(i1+i+1,i) = zero
 8       continue
      else
         do 9 i=1, ihi-ilo-1
            h(ilo+i+1,ilo+i-1) = zero
 9       continue
      end if
c
c     %---------------------------------------------------%
c     | ITN is the total number of QR iterations allowed. |
c     %---------------------------------------------------%
c
      itn = 30*nh
c
c     ------------------------------------------------------------------
c     The main loop begins here. I is the loop index and decreases from
c     IHI to ILO in steps of 1 or 2. Each iteration of the loop works
c     with the active submatrix in rows and columns L to I.
c     Eigenvalues I+1 to IHI have already converged. Either L = ILO or
c     H(L,L-1) is negligible so that the matrix splits.
c     ------------------------------------------------------------------
c
      i = ihi
   10 continue
      l = ilo
      if( i.lt.ilo )
     &   go to 150

c     %--------------------------------------------------------------%
c     | Perform QR iterations on rows and columns ILO to I until a   |
c     | submatrix of order 1 or 2 splits off at the bottom because a |
c     | subdiagonal element has become negligible.                   |
c     %--------------------------------------------------------------%

      do 130 its = 0, itn
c
c        %----------------------------------------------%
c        | Look for a single small subdiagonal element. |
c        %----------------------------------------------%
c
         do 20 k = i, l + 1, -1
            tst1 = abs( h( k-1, k-1 ) ) + abs( h( k, k ) )
            if( tst1.eq.zero )
     &         tst1 = slanhs( '1', i-l+1, h( l, l ), ldh, work )
            if( abs( h( k, k-1 ) ).le.max( ulp*tst1, smlnum ) )
     &         go to 30
   20    continue
   30    continue
         l = k
         if( l.gt.ilo ) then
c
c           %------------------------%
c           | H(L,L-1) is negligible |
c           %------------------------%
c
            h( l, l-1 ) = zero
         end if
c
c        %-------------------------------------------------------------%
c        | Exit from loop if a submatrix of order 1 or 2 has split off |
c        %-------------------------------------------------------------%
c
         if( l.ge.i-1 )
     &      go to 140
c
c        %---------------------------------------------------------%
c        | Now the active submatrix is in rows and columns L to I. |
c        | If eigenvalues only are being computed, only the active |
c        | submatrix need be transformed.                          |
c        %---------------------------------------------------------%
c
         if( .not.wantt ) then
            i1 = l
            i2 = i
         end if
c
         if( its.eq.10 .or. its.eq.20 ) then
c
c           %-------------------%
c           | Exceptional shift |
c           %-------------------%
c
            s = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) )
            h44 = dat1*s
            h33 = h44
            h43h34 = dat2*s*s
c
         else
c
c           %-----------------------------------------%
c           | Prepare to use Wilkinson's double shift |
c           %-----------------------------------------%
c
            h44 = h( i, i )
            h33 = h( i-1, i-1 )
            h43h34 = h( i, i-1 )*h( i-1, i )
         end if
c
c        %-----------------------------------------------------%
c        | Look for two consecutive small subdiagonal elements |
c        %-----------------------------------------------------%
c
         do 40 m = i - 2, l, -1
c
c           %---------------------------------------------------------%
c           | Determine the effect of starting the double-shift QR    |
c           | iteration at row M, and see if this would make H(M,M-1) |
c           | negligible.                                             |
c           %---------------------------------------------------------%
c
            h11 = h( m, m )
            h22 = h( m+1, m+1 )
            h21 = h( m+1, m )
            h12 = h( m, m+1 )
            h44s = h44 - h11
            h33s = h33 - h11
            v1 = ( h33s*h44s-h43h34 ) / h21 + h12
            v2 = h22 - h11 - h33s - h44s
            v3 = h( m+2, m+1 )
            s = abs( v1 ) + abs( v2 ) + abs( v3 )
            v1 = v1 / s
            v2 = v2 / s
            v3 = v3 / s
            v( 1 ) = v1
            v( 2 ) = v2
            v( 3 ) = v3
            if( m.eq.l )
     &         go to 50
            h00 = h( m-1, m-1 )
            h10 = h( m, m-1 )
            tst1 = abs( v1 )*( abs( h00 )+abs( h11 )+abs( h22 ) )
            if( abs( h10 )*( abs( v2 )+abs( v3 ) ).le.ulp*tst1 )
     &         go to 50
   40    continue
   50    continue
c
c        %----------------------%
c        | Double-shift QR step |
c        %----------------------%
c
         do 120 k = m, i - 1
c
c           ------------------------------------------------------------
c           The first iteration of this loop determines a reflection G
c           from the vector V and applies it from left and right to H,
c           thus creating a nonzero bulge below the subdiagonal.
c
c           Each subsequent iteration determines a reflection G to
c           restore the Hessenberg form in the (K-1)th column, and thus
c           chases the bulge one step toward the bottom of the active
c           submatrix. NR is the order of G.
c           ------------------------------------------------------------
c
            nr = min( 3, i-k+1 )
            if( k.gt.m )
     &         call scopy( nr, h( k, k-1 ), 1, v, 1 )
            call slarfg( nr, v( 1 ), v( 2 ), 1, t1 )
            if( k.gt.m ) then
               h( k, k-1 ) = v( 1 )
               h( k+1, k-1 ) = zero
               if( k.lt.i-1 )
     &            h( k+2, k-1 ) = zero
            else if( m.gt.l ) then
               h( k, k-1 ) = -h( k, k-1 )
            end if
            v2 = v( 2 )
            t2 = t1*v2
            if( nr.eq.3 ) then
               v3 = v( 3 )
               t3 = t1*v3
c
c              %------------------------------------------------%
c              | Apply G from the left to transform the rows of |
c              | the matrix in columns K to I2.                 |
c              %------------------------------------------------%
c
               do 60 j = k, i2
                  sum = h( k, j ) + v2*h( k+1, j ) + v3*h( k+2, j )
                  h( k, j ) = h( k, j ) - sum*t1
                  h( k+1, j ) = h( k+1, j ) - sum*t2
                  h( k+2, j ) = h( k+2, j ) - sum*t3
   60          continue
c
c              %----------------------------------------------------%
c              | Apply G from the right to transform the columns of |
c              | the matrix in rows I1 to min(K+3,I).               |
c              %----------------------------------------------------%
c
               do 70 j = i1, min( k+3, i )
                  sum = h( j, k ) + v2*h( j, k+1 ) + v3*h( j, k+2 )
                  h( j, k ) = h( j, k ) - sum*t1
                  h( j, k+1 ) = h( j, k+1 ) - sum*t2
                  h( j, k+2 ) = h( j, k+2 ) - sum*t3
   70          continue
c
c              %----------------------------------%
c              | Accumulate transformations for Z |
c              %----------------------------------%
c
               sum      = z( k ) + v2*z( k+1 ) + v3*z( k+2 )
               z( k )   = z( k ) - sum*t1
               z( k+1 ) = z( k+1 ) - sum*t2
               z( k+2 ) = z( k+2 ) - sum*t3

            else if( nr.eq.2 ) then
c
c              %------------------------------------------------%
c              | Apply G from the left to transform the rows of |
c              | the matrix in columns K to I2.                 |
c              %------------------------------------------------%
c
               do 90 j = k, i2
                  sum = h( k, j ) + v2*h( k+1, j )
                  h( k, j ) = h( k, j ) - sum*t1
                  h( k+1, j ) = h( k+1, j ) - sum*t2
   90          continue
c
c              %----------------------------------------------------%
c              | Apply G from the right to transform the columns of |
c              | the matrix in rows I1 to min(K+3,I).               |
c              %----------------------------------------------------%
c
               do 100 j = i1, i
                  sum = h( j, k ) + v2*h( j, k+1 )
                  h( j, k ) = h( j, k ) - sum*t1
                  h( j, k+1 ) = h( j, k+1 ) - sum*t2
  100          continue
c
c              %----------------------------------%
c              | Accumulate transformations for Z |
c              %----------------------------------%
c
               sum      = z( k ) + v2*z( k+1 )
               z( k )   = z( k ) - sum*t1
               z( k+1 ) = z( k+1 ) - sum*t2
            end if
  120    continue

  130 continue
c
c     %-------------------------------------------------------%
c     | Failure to converge in remaining number of iterations |
c     %-------------------------------------------------------%
c
      info = i
      return

  140 continue

      if( l.eq.i ) then
c
c        %------------------------------------------------------%
c        | H(I,I-1) is negligible: one eigenvalue has converged |
c        %------------------------------------------------------%
c
         wr( i ) = h( i, i )
         wi( i ) = zero

      else if( l.eq.i-1 ) then
c
c        %--------------------------------------------------------%
c        | H(I-1,I-2) is negligible;                              |
c        | a pair of eigenvalues have converged.                  |
c        |                                                        |
c        | Transform the 2-by-2 submatrix to standard Schur form, |
c        | and compute and store the eigenvalues.                 |
c        %--------------------------------------------------------%
c
         call slanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ),
     &                h( i, i ), wr( i-1 ), wi( i-1 ), wr( i ), wi( i ),
     &                cs, sn )

         if( wantt ) then
c
c           %-----------------------------------------------------%
c           | Apply the transformation to the rest of H and to Z, |
c           | as required.                                        |
c           %-----------------------------------------------------%
c
            if( i2.gt.i )
     &         call srot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh,
     &                    cs, sn )
            call srot( i-i1-1, h( i1, i-1 ), 1, h( i1, i ), 1, cs, sn )
            sum      = cs*z( i-1 ) + sn*z( i )
            z( i )   = cs*z( i )   - sn*z( i-1 )
            z( i-1 ) = sum
         end if
      end if
c
c     %---------------------------------------------------------%
c     | Decrement number of remaining iterations, and return to |
c     | start of the main loop with new value of I.             |
c     %---------------------------------------------------------%
c
      itn = itn - its
      i = l - 1
      go to 10

  150 continue
      return
c
c     %---------------%
c     | End of slaqrb |
c     %---------------%
c
      end


module orbit
  use do_magfie_mod, only: do_magfie, q, iota, psi_pr, Bphcov, Bthcov
  !use do_magfie_neo_mod, only: do_magfie, q, psi_pr
  use driftorbit, only: v, vth, eta, mi, c, qi, Om_tE

  implicit none
  save

contains

  function vecprod(u,v)
    real(8) :: vecprod(3)
    real(8), intent(in) :: u(3), v(3)

    ! this is for right-handed system x(1)-x(3)-x(2) and not 123 !!
    vecprod(1) = u(3)*v(2) - u(2)*v(3)
    vecprod(3) = u(2)*v(1) - u(1)*v(2)
    vecprod(2) = u(1)*v(3) - u(3)*v(1)
  end function vecprod

  subroutine step_zeroorder(neq, t, y, ydot)
    integer, intent (in) :: neq
    real(8), intent (in) :: t
    real(8), intent (in) :: y(neq)
    real(8), intent (out) :: ydot(neq)

    real(8) :: bmod, sqrtg, hder(3), hcovar(3), hctrvr(3), hcurl(3)

    call do_magfie(y(1:3), bmod, sqrtg, hder, hcovar, hctrvr, hcurl)

    ydot(1) = 0d0                                               ! r
    ydot(2) = y(4)*hctrvr(2)                                    ! phi
    ydot(3) = y(4)*hctrvr(3)                                    ! theta
    ydot(4) = -v**2*eta/2d0*hctrvr(3)*hder(3)*bmod              ! v_par

  end subroutine step_zeroorder

  subroutine step_full(neq, t, y, ydot)
    ! TODO: add gradPhi for fast rotation

    integer, intent (in) :: neq
    real(8), intent (in) :: t
    real(8), intent (in) :: y(neq)
    real(8), intent (out) :: ydot(neq)

    real(8) :: bmod, sqrtg, hder(3), hcovar(3), hctrvr(3), hcurl(3)

    real(8) :: hstar(3)       ! hstar = h + vpar/(omc)*curl(h)
    real(8) :: gradH(3)       ! gradH = (mu*gradB + e*gradPhi)
    real(8) :: hstarpar       ! hstar_par = h*hstar
    real(8) :: Er             ! Er = dphi/dr = psi_pr/(q*c)*Om_tE, no fast rotation yet
    real(8) :: sqgbmod2

    call do_magfie(y(1:3), bmod, sqrtg, hder, hcovar, hctrvr, hcurl)
    sqgbmod2 = psi_pr*(Bphcov+iota*Bthcov)

    hstar = hctrvr + mi*c/(qi*bmod)*y(4)*hcurl
    hstarpar = 1d0 + mi*c/(qi*bmod)*y(4)*sum(hcovar*hcurl)

    !Er = psi_pr/(q*c)*Om_tE
    Er = 0.0
    gradH = mi*v**2/2d0*eta*bmod*hder+(/qi*Er,0d0,0d0/)

    ydot(1:3) = 1d0/hstarpar*(y(4)*hstar + c/(qi*sqgbmod2)*bmod*vecprod(hcovar,gradH))
    ydot(4) = -1d0/(mi*hstarpar)*sum(ydot(1:3)/y(4)*gradH)

    !print *, eta, (1d0-y(4)**2/v**2)/bmod

  end subroutine step_full

  subroutine step_rela(neq, t, y, ydot)
    integer, intent (in) :: neq
    real(8), intent (in) :: t
    real(8), intent (in) :: y(neq)
    real(8), intent (out) :: ydot(neq)

    real(8) :: tau, z(neq), zdot(neq)

    tau = vth*t
    z(1:3) = y(1:3)
    z(4) = v/vth
    z(5) = y(4)/v

    call velo(tau,z,zdot)

    ydot(1:3) = zdot(1:3)*vth
    ydot(4) = zdot(5)*v*vth

  end subroutine step_rela

  !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
  subroutine velo(tau,z,vz)
!
!
!  Computes the components of the 5-D velocity          -  vz
!  for given set of phase space coordinates             -  z.
!
!  Warning !!!  The dimensionless time is used (see below)
!
!  Order of the coordinates is the following:
!  z(i) = x(i)  for i=1,2,3     - spatial coordinates with real
!                                 dimension of the general covariant
!                                 space coordinate system
!  z(4) = p                     - momentum  module normalized to
!                                 thermal momentum and sqrt(2);
!  z(5) = alambd                - cosine of the pitch-angle
!
!  Input parameters:
!            formal:  tau    -   dimensionless time: tau=sqrt(2*T/m)*t
!                     z      -   see above
!            common:  rmu    -   inverse relativistic temperature
!                     ro0    -   Larmor radius for the reference
!                                magnetic field and temperature:
!                                ro0=sqrt(2*T/m)/(e*B_ref/m*c)
!                     p0     -   dimensionless momentum module in the
!                                initial point
!                     alamb0 -   cos of pitch-angle in the initial point
!  Output parameters:
!            formal:  vz     -   see above
!
!  Called routines: magfie, elefie
!
!
      implicit none
!
      integer :: i
!
      double precision tau,z,vz
      double precision x,bmod,sqrtg,bder,hcovar,hctrvr,hcurl
      double precision derphi
      double precision p,alambd,p2,ovmu,gamma2,gamma,ppar,vpa,coala
      double precision rmumag,rovsqg,rosqgb,rovbm
      double precision a_phi,a_b,a_c,hstar
      double precision s_hc,hpstar,phidot,blodot,bra
      double precision pardeb
      double precision ro0
      double precision rmu
!
      dimension z(5),vz(5)
      dimension x(3),bder(3),hcovar(3),hctrvr(3),hcurl(3)
      dimension derphi(3)
      dimension a_phi(3),a_b(3),a_c(3),hstar(3)

      ro0 = vth*mi*c/qi ! Larmor radius scaling
      rmu = 1d5         ! non-relativistic limit
!
      do 1 i=1,3
        x(i)=z(i)
 1    continue
!
! in magfie: x(i)   - set of 3 curvilinear space coordinates (input)
!            bmod   - dimensionless magnetic field module: bmod=B/B_ref
!            sqrtg  - Jacobian of space coordinates (square root of
!                     metric tensor
!            bder   - derivatives of logarithm of bmod over space coords
!                     (covariant vector)
!            hcovar - covariant components of the unit vector along
!                     the magnetic field
!            hctrvr - contravariant components of the unit vector along
!                     the magnetic field
!            hcurl  - contravariant components of the curl of this vector
!
      call do_magfie(x,bmod,sqrtg,bder,hcovar,hctrvr,hcurl)
! in elefie: x(i)   - space coords (input, see above)
!            derphi - derivatives of the dimensionless electric potential
!                     phihat=e*phi/T over space coords (covar. vector)
!
      derphi = 0d0
!      derphi(1) = psi_pr/(q*c)*Om_tE*qi/(mi*vth**2/2d0)
!
      p=z(4)
      alambd=z(5)
!
      p2=p*p
      ovmu=2.d0/rmu
      gamma2=p2*ovmu+1.d0
      gamma=dsqrt(gamma2)
      ppar=p*alambd
! vpa - dimensionless parallel velocity: vpa=v_parallel/sqrt(2*T/m)
      vpa=ppar/gamma
      coala=(1.d0-alambd**2)
! rmumag - magnetic moment
      rmumag=.5d0*p2*coala/bmod
!
      rovsqg=ro0/sqrtg
      rosqgb=.5d0*rovsqg/bmod
      rovbm=ro0/bmod
!
! minus signs due to right-handed system r,theta,phi = x(1,3,2)
      a_phi(1)=-(hcovar(2)*derphi(3)-hcovar(3)*derphi(2))*rosqgb
      a_b(1)=-(hcovar(2)*bder(3)-hcovar(3)*bder(2))*rovsqg
      a_phi(2)=-(hcovar(3)*derphi(1)-hcovar(1)*derphi(3))*rosqgb
      a_b(2)=-(hcovar(3)*bder(1)-hcovar(1)*bder(3))*rovsqg
      a_phi(3)=-(hcovar(1)*derphi(2)-hcovar(2)*derphi(1))*rosqgb
      a_b(3)=-(hcovar(1)*bder(2)-hcovar(2)*bder(1))*rovsqg
!
      s_hc=0.d0
      do i=1,3
        a_c(i)=hcurl(i)*rovbm
        s_hc=s_hc+a_c(i)*hcovar(i)
        hstar(i)=hctrvr(i)+ppar*a_c(i)
      end do
      hpstar=1.d0+ppar*s_hc
!
! velocities in the coordinate space
!
! phidot - derivative of the dmls el. potential over dmls time
! blodot - derivative of the logarith of the mag. field module over dmls time
      phidot=0.d0
      blodot=0.d0
      do i=1,3
        bra=vpa*hstar(i)+a_phi(i)+a_b(i)*rmumag/gamma
        vz(i)=bra/hpstar
        phidot=phidot+vz(i)*derphi(i)
        blodot=blodot+vz(i)*bder(i)
      end do
!
! velocities in the phase space
!
      vz(4)=-0.5d0*gamma*phidot/p
!      vz(5)=coala/(alambd+dsign(1.d-32,alambd))*(vz(4)/p-0.5d0*blodot)
      vz(5)=-(0.5d0*coala/hpstar)*(sum(hstar*derphi)/p                 &
            + p*sum(hstar*bder)/gamma+alambd*sum(a_phi*bder))
!
!    print *, mi*v**2/2d0*eta, mi*v**2*(1d0-z(5)**2)/(2d0*bmod)
    end subroutine velo

end module orbit


      Real Function C0(x,mu)
      Implicit none
      Real x,mu,xmin,xmax
      Real*8 A,B,C,D,Ratio,C00,x1,mu1,tmp
      Integer K,Niter
      Real mu0,p0
      Common/C0com/K,mu0,p0,Niter
      Integer M
      K=0
      If(mu.le.0.) Then
         C0=0.
         Write(6,*) "Illegal value of mu:",mu
         Return
      EndIf
      Call C0range(mu,xmin,xmax)
      If(x.lt.xmin) Then
         C0=0.
         Return
      Elseif(x.gt.xmax) Then
         C0=1.
         Return
      EndIf
      x1=x
      mu1=mu
      D=dexp(-x1)
      A=x1*D
      B=mu1*D
      M=mu1/x1 ! M is the largest integer < mu/x
      If(mu.gt.500.) Then
C If mu is large enough, the calculation can be done approximately
         C0=Dexp(-B)*( (1.D0+a*(1.D0-B) + .5D0*a*a*(B*B-5.D0*B+4.D0) )
     1      - D*(1.D0+a*(2.D0-B) + .5D0*a*a*(B*B-7.D0*B+9.D0) ) )
      Else
C Go ahead and do the calculation
         C00=1.D0 -D
         If(M.eq.1) Then
            C00=C00-D*(mu1-x1)
         ElseIf(M.gt.1) Then
             C=A/B
             Ratio=-B
             Do K=1,M-1
                tmp=Ratio*(  (1.D0-dfloat(K)*C)**K -
     1              D*(1.D0-dfloat(K+1)*C)**K  )
                C00=C00+tmp
               If(K.gt.10 .and. abs(tmp).lt.1.D-6 .and.
     1          B.lt..7*dfloat(K)) Go to 10
                Ratio=(-B)*Ratio/dfloat(K+1)
             EndDo
             C00=C00+Ratio*(1.D0-dfloat(M)*C)**M
 10          Continue
         EndIf
         C0=C00
      EndIf
      Return
      End
      Real Function dC0dx(x,mu)
      Implicit none
      Real x,mu,xmin,xmax
      Real*8 A,B,C,D,D2,tmp,C00,x1,mu1,Ratio
      Integer M
      Integer K,Niter
      Real mu0,p0
      Common/C0com/K,mu0,p0,Niter
       K=0
      If(mu.le.0.) Then
         Write(6,*) "Illegal value of mu:",mu
         dC0dx=0.
         Return
      EndIf
      Call C0range(mu,xmin,xmax)
      If(x.lt.xmin .or. x.gt.xmax) Then
         dC0dx=0.
         Return
      Endif
      x1=x
      mu1=mu
      D=dexp(-x1)
      D2=D*D
      A=x1*D
      B=mu1*D
      M=mu1/x1 ! M is the largest integer < mu/x
      If(mu.gt.1000.) Then
C If mu is large enough, the calculation can be done approximately
         C00=2.D0*D*(  (1.D0-B)*( 1.D0+A*(4.D0-B) )  )
         C00=C00-D2*( 2.D0-B+A*(B*B-7.D0*B+9.D0) )
         C00=Dexp(-B)*( C00-A*(B*B-3.D0*B+1.D0) +B )
      Else
C Go ahead and do the calculation
         If(M.lt.3) Then
            C00=D*(2.D0+mu1-x1)
            If(M.EQ.2) Then
               C00=C00-D2*(4.D0*(mu1-x1*2.D0) +2.D0 +(mu1-x1*2.D0)**2)
            EndIf
         Else
            C00=2.D0*D*(1.D0-D)
            Ratio=-B
            C=A/B
            Do K=1,M-2
               tmp=(2.D0*D*dfloat(K+1)*(1.D0-dfloat(K+1)*C)**K -
     1            D2*dfloat(K+2)*(1.D0-dfloat(K+2)*C)**K -
     2            dfloat(K)*(1.D0-C*dfloat(K))**K)*Ratio
               C00=C00+tmp
               If(K.gt.10 .and. abs(tmp).lt.1.D-6 .and.
     1          B.lt..7*dfloat(K)) Go to 10
               Ratio=(-B)*Ratio/dfloat(K+1)
            EndDo
            tmp=(dfloat(2*M)*D +
     1        B*(1.D0-dfloat(M)*C))*(1.D0-dfloat(M)*C)**(M-1)
            tmp=tmp-dfloat(M-1)*(1.D0-dfloat(M-1)*C)**(M-1)
            C00=C00+Ratio*tmp
 10         Continue
C           Write(6,*) K
         EndIf
      EndIf
      dC0dx=C00
      Return
      End
      Subroutine C0range(mu,xmin,xmax)
C For a given mu finds the x range over which C0 and dC0/dx differ
C significantly from zero.
      Implicit None
      Real mu,xmin,xmax,logmu
      If(mu.le.10.) Then
         xmin=.12*(mu**.75)
         xmax=mu
      Else
         logmu=log(mu)
         xmin=logmu -3. + 5./(logmu*logmu) + 3.5/mu
         If(mu.lt.17.) Then
            xmax=mu
         Else
            xmax=logmu + 15.7 -30./mu
         EndIf
      Endif
      Return
      End
      Real Function C0Int(A,B,mu1,mu2,z,Icode)
C Uses Simpson's rule to integrate dC0(x,mu1)/dx * C0(z-x,mu2) from
C A to B.
C Icode=0 means "normal" integration
C Icode=1 means part of the range had C0=1
C Icode=2 means all of the range with dC0/dx > 0 had C0=1
C Icode=3 means zero integrand everywhere
C Icode=4 means A .ge. B or one of the mu's or z is negative
C
      Implicit none
      Real A,B,mu1,mu2,z,C0,dC0dx
      Integer Icode
      Real x,xmin,xmax,xmin1,xmax1,xmin2,xmax2,dx,twodx,Two,Four
      Integer I,N/1000/ ! 2N+1 values of x in the Simpson's sum.
      If(A.ge.B .or. mu1.le. 0. .or. mu2.le. 0. .or. z.le. 0.) Then
         Write(6,*) "Bad input to C0Int"
         C0Int=0.
         Icode=4
         Return
      EndIf
C Find the range over which the integral is to be done.
      Call C0range(mu1,xmin1,xmax1)
      Call C0range(mu2,xmin2,xmax2)
      xmin=max(A,xmin1)
C If z-x > xmax2 C0(z-x,mu2)=1.  I.e. C0=1 if x < z-xmax2
      xmax=min(B,xmax1,z-xmin2)
C It's ok if z-x is so large (maybe even larger than mu2) that
C C0(z-x,mu2) = 1.  x should be included in the integral so long as neither
C dC0/dx nor C0 is essentially zero.  But if C0=1, it's easy to integrate
C dC0/dx * C0, so that part (small x) shouldn't be numerically integrated.
      C0Int=0.
      Icode=3
      If(xmin.lt.xmax) Then
         Icode=0
C For x < z-xmax2 we have z-x > xmax2, so C0(z-x,mu2)=1.
         If(z-xmax2 .gt.xmin) Then
            If(z-xmax2.lt.xmax) Then
               Icode=1
               C0Int=C0(z-xmax2,mu1)-C0(xmin,mu1)
               xmin=z-xmax2
            Else
               Icode=2
               C0Int=C0(xmax,mu1)-C0(xmin,mu1)
               Return
            EndIf
         EndIf
C dx = distance between adjacent values of x.
C xmin                           xmax
C  |                             |
C  1  4  1     1  4  1     1  4  1   times function values  +
C        1  4  1     1  4  1         times function values  =
C  1  4  2  4  2  4  2  4  2  4  1   times function values (2N+1 values of x)
C  |twodx|twodx|                     (xmax-xmin) = N*twodx
C     1     2      ...        N
C Simpson's rule adds together approximate average function values over each of
C the N twodx long intervals.  This pattern makes 1+4+1 times function values
C in each twodx interval, while for an integral we want 2*dx*(mean value of
C the function in the 2*dx interval).  So multiply the sum by twodx/6.
C
C    Note that C0 and dC0/dx are not analytic.  For example, dC0(x,mu)/dx has a
C discontinuity at x=mu/2.  So Simpson's rule might be no better than the
C pattern 1 1 1 1 1 1 1 +
C           1 1 1 1 1   =
C         1 2 2 2 2 2 1
C with the sum multiplied by dx/2 to make it into an integral.
         twodx=(xmax-xmin)/float(N)
         dx=.5*twodx
         x=xmax-dx
         Four=dC0dx(x,mu1)*C0(z-x,mu2)
         Two=0.
         do I=1,N-1
            x=xmin+twodx*float(I)
            Two=Two+dC0dx(x,mu1)*C0(z-x,mu2)
            x=x-dx
            Four=Four+dC0dx(x,mu1)*C0(z-x,mu2)
         EndDo
         C0Int=(4.*Four+2.*Two+dC0dx(xmin,mu1)*C0(z-xmin,mu2)
     1        + dC0dx(xmax,mu1)*C0(z-xmax,mu2))*(dx/3.) + C0Int
      EndIf
      Return
      End
      Real Function XC0(p,mu,ICode)
C Finds the value of x for which C0(x,mu)=p
C Needs the real function RZERO(A,B,x_0,R,EPS,MAXF,F), where F(x,I) =
C C0(x,mu)-p, and I is supplied by RZERO: 1=first reference, 3=final reference
C ICode=0: all is well
C ICode=1: p out of range
      Implicit None
      Common/C0Com/K,mu0,p0,Niter
      Integer K,Niter
      Real p,mu,p0,mu0
      External FXC0
      Real EPS/0.00001/,R,cut
      Integer MAXF/50/,Icode
      Icode=0
      cut=1.-exp(-mu)
      If(p .le. 0. .or. p .ge. cut-EPS) Then
         Niter=0
         If(p.le.0.) then
            XC0=0.
         Else
            XC0=mu
         EndIf
         If(p.gt.1. .or. p.lt.-EPS) ICode=1
         Return
      EndIf
      mu0=mu
      p0=p
      Call RZERO(EPS,mu,XC0,R,EPS,MAXF,FXC0)
      Return
      End
C
      Real Function FXC0(x,I)
      Implicit None
      Common/C0Com/K,mu,p,Niter
      Real mu,p,x,C0
      Integer I,K,Niter
      If(I.eq.1) Then
         Niter=0
      Else
         Niter=Niter+1
      EndIf
      FXC0=C0(x,mu)-p
      Return
      End


c***********************************************************
c Rejection Data with path length defining by inequality:
c Delta < nwavep*Lambda, where
c        Lambda - c*T,
c        c      - phase/group velocities,
c        T      - period,
c        Lambda - wave length,
c        Delta  - path length,
c        nwavep - number of wave periods
c        N      - number of paths for processing
c***********************************************************
      SUBROUTINE REJEDEL
      IMPLICIT NONE
      include "tomo.h"
      include "line.h"
c TYPE definitions ++++++++++++++++++++++++++++++++++++++
      real*8    x1(3),x2(3),xn(3),delt,period,slo
cxx   real*4    pe_re(16),c_re(16),am_re(20)
cxx   real*4    delta,dum,dum1,phv_re
      real*4    delta,phv_re
      integer*4 i,j,ierr
c END TYPE definitions ++++++++++++++++++++++++++++++++++
cxx   data pe_re/10.,20.,40.,60.,80.,100.,125.,150.,175.,200.,225.,
cxx  +250.,275.,300.,350.,400./
cxx   data c_re/3.05,3.42,3.875,4.00,4.06,4.115,4.19,4.29,4.40,4.53,
cxx  +4.69,4.89,5.05,5.24,5.585,5.88/
cxx   dpi=4.0d0*DATAN(1.0d0)
cxx   drad=dpi/180.d0
c
c---    Rejection
c
cxx   CALL SPLINE(16,pe_re,c_re,am_re,2,0.,2,0.)
cxx   CALL SPLDER(1,16,pe_re,c_re,am_re,Tper,phv_re,dum,dum1,*993)

      period=tper
      CALL GET_SLOW(re_la,period,slo,ierr)
      if(ierr.ne.0) stop '(R0015) 1-D model period is out of range'
      phv_re=1.0d0/slo

      j=0
      do i=1,n
        reject=phv_re*Tper*FLOAT(nwavep)
        CALL TO_CART(TE0(i),FI0(i),TE(i),FI(i),IRAY2(i),x1,x2,xn,delt)
        delta=delt*DBLE(R)
        if(delta.gt.reject) then
          j=j+1
          TE0(j)=TE0(i)
          FI0(j)=FI0(i)
          TE(j)=TE(i)
          FI(j)=FI(i)
          T(j)=T(i)
          WEIGHT(j)=WEIGHT(i)
          IRAY2(j)=IRAY2(i)
        else
          write(8,*) ' REJEDEL: Path ',IIII(i), ' is rejected: Delta=',
     +    delta,'; Threshold=  ',reject
          write(*,*) ' REJEDEL: Path ',IIII(i), ' is rejected: Delta=',
     +    delta,'; Threshold=  ',reject
        endif
      enddo
C------- End of Rejection ---------------------------------------
      nout=j
      write(8,*) ' REJEDEL: There were', n, ' paths; only ',nout,
     +' paths left after cleaning'
      write(*,*) ' REJEDEL: There were', n, ' paths; only ',nout,
     +' paths left after cleaning'
      return
 993  write(*,*)' REJEDEL: WRONG PERIOD=',Tper,'; STOP'
      stop
      end


      subroutine psplint(ncat,x,y)
      include "interp.h"
      integer ncat,klo,khi,k
      real*8 h,a,b,y,x
c
c  this started out as numerical recipies splint, uses
c  derivitives and points passed in splinearray through interp.h
c
      if(x .lt. splinearray(ncat,1,1) .or.
     $     x .gt. splinearray(ncat,1,npoints)) then
         print *,'interpolation out of range, for category ',ncat,
     $        ' asking for: ',x,'range is: ',splinearray(ncat,1,1),
     $        splinearray(ncat,1,npoints)
         stop
      endif

      klo=1
      khi=npoints
 1    if (khi-klo.gt.1) then
         k=(khi+klo)/2
         if(splinearray(ncat,1,k).gt.x)then
            khi=k
         else
            klo=k
         endif
         goto 1
      endif
      h=splinearray(ncat,1,khi)-splinearray(ncat,1,klo)
c     if (h.eq.0.) pause 'bad splinearray input.'
      a=(splinearray(ncat,1,khi)-x)/h
      b=(x-splinearray(ncat,1,klo))/h
      y=a*splinearray(ncat,2,klo)+b*splinearray(ncat,2,khi)+
     *     ((a**3-a)*splinearray(ncat,3,klo)+(b**3-b)
     $     *splinearray(ncat,3,khi))*(h**2)/6.
      return
      end