      SUBROUTINE MB04KD( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC,
     $                   TAU, DWORK )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To calculate a QR factorization of the first block column and
C     apply the orthogonal transformations (from the left) also to the
C     second block column of a structured matrix, as follows
C                          _
C            [ R   0 ]   [ R   C ]
C       Q' * [       ] = [       ]
C            [ A   B ]   [ 0   D ]
C                 _
C     where R and R are upper triangular. The matrix A can be full or
C     upper trapezoidal/triangular. The problem structure is exploited.
C     This computation is useful, for instance, in combined measurement
C     and time update of one iteration of the Kalman filter (square
C     root information filter).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPLO    CHARACTER*1
C             Indicates if the matrix A is or not triangular as follows:
C             = 'U':  Matrix A is upper trapezoidal/triangular;
C             = 'F':  Matrix A is full.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER                 _
C             The order of the matrices R and R.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of the matrices B, C and D.  M >= 0.
C
C     P       (input) INTEGER
C             The number of rows of the matrices A, B and D.  P >= 0.
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,N)
C             On entry, the leading N-by-N upper triangular part of this
C             array must contain the upper triangular matrix R.
C             On exit, the leading N-by-N upper triangular part of this
C                                                        _
C             array contains the upper triangular matrix R.
C             The strict lower triangular part of this array is not
C             referenced.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,N).
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, if UPLO = 'F', the leading P-by-N part of this
C             array must contain the matrix A. If UPLO = 'U', the
C             leading MIN(P,N)-by-N part of this array must contain the
C             upper trapezoidal (upper triangular if P >= N) matrix A,
C             and the elements below the diagonal are not referenced.
C             On exit, the leading P-by-N part (upper trapezoidal or
C             triangular, if UPLO = 'U') of this array contains the
C             trailing components (the vectors v, see Method) of the
C             elementary reflectors used in the factorization.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,P).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading P-by-M part of this array must
C             contain the matrix B.
C             On exit, the leading P-by-M part of this array contains
C             the computed matrix D.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,P).
C
C     C       (output) DOUBLE PRECISION array, dimension (LDC,M)
C             The leading N-by-M part of this array contains the
C             computed matrix C.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,N).
C
C     TAU     (output) DOUBLE PRECISION array, dimension (N)
C             The scalar factors of the elementary reflectors used.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (N)
C
C     METHOD
C
C     The routine uses N Householder transformations exploiting the zero
C     pattern of the block matrix.  A Householder matrix has the form
C
C                                     ( 1 ),
C        H  = I - tau *u *u',    u  = ( v )
C         i          i  i  i      i   (  i)
C
C     where v  is a P-vector, if UPLO = 'F', or an min(i,P)-vector, if
C            i
C     UPLO = 'U'.  The components of v  are stored in the i-th column
C                                     i
C     of A, and tau  is stored in TAU(i).
C                  i
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTORS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary reflector, QR factorization, orthogonal transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         UPLO
      INTEGER           LDA, LDB, LDC, LDR, M, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*),
     $                  R(LDR,*), TAU(*)
C     .. Local Scalars ..
      LOGICAL           LUPLO
      INTEGER           I, IM
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DGEMV, DGER, DLARFG, DSCAL
C     .. Intrinsic Functions ..
      INTRINSIC         MIN
C     .. Executable Statements ..
C
      IF( MIN( N, P ).EQ.0 )
     $   RETURN
C
      LUPLO = LSAME( UPLO, 'U' )
      IM = P
C
      DO 10 I = 1, N
C
C        Annihilate the I-th column of A and apply the transformations
C        to the entire block matrix, exploiting its structure.
C
         IF( LUPLO ) IM = MIN( I, P )
         CALL DLARFG( IM+1, R(I,I), A(1,I), 1, TAU(I) )
         IF( TAU(I).NE.ZERO ) THEN
C
C                                      [ R(I,I+1:N)        0     ]
C           [ w C(I,:) ] := [ 1 v' ] * [                         ]
C                                      [ A(1:IM,I+1:N) B(1:IM,:) ]
C
            IF( I.LT.N ) THEN
               CALL DCOPY( N-I, R(I,I+1), LDR, DWORK, 1 )
               CALL DGEMV( 'Transpose', IM, N-I, ONE, A(1,I+1), LDA,
     $                     A(1,I), 1, ONE, DWORK, 1 )
            END IF
            CALL DGEMV( 'Transpose', IM, M, ONE, B, LDB, A(1,I), 1,
     $                  ZERO, C(I,1), LDC )
C
C           [ R(I,I+1:N)      C(I,:)  ]    [ R(I,I+1:N)        0     ]
C           [                         ] := [                         ]
C           [ A(1:IM,I+1:N) D(1:IM,:) ]    [ A(1:IM,I+1:N) B(1:IM,:) ]
C
C                                                 [ 1 ]
C                                         - tau * [   ] * [ w C(I,:) ]
C                                                 [ v ]
C
            IF( I.LT.N ) THEN
               CALL DAXPY( N-I, -TAU(I), DWORK, 1, R(I,I+1), LDR )
               CALL DGER( IM, N-I, -TAU(I), A(1,I), 1, DWORK, 1,
     $                    A(1,I+1), LDA )
            END IF
            CALL DSCAL( M, -TAU(I), C(I,1), LDC )
            CALL DGER( IM, M, ONE, A(1,I), 1, C(I,1), LDC, B, LDB )
         END IF
   10 CONTINUE
C
      RETURN
C *** Last line of MB04KD ***
      END


      subroutine runCY_00l(k,l,Xtwiddle,Gtwiddle,Shat3,N0)
      implicit none
C---  Expression for Eq. 5.56a
C---  Calculates C00l
C---  Small terms of order Xtwiddle(0,k)*Cii,Xtwiddle(0,0)*Ciii
C---  Denominator Gtwiddle(k,l)
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,l,np
      parameter(np=2)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat3(np,z2max,-2:0)

      do ep=-2,0
      Cv(czzi(l)+N0,ep)=
     . (Gtwiddle(k,1)*Shat3(1,z2(l,l),ep)
     .  +Gtwiddle(k,2)*Shat3(2,z2(l,l),ep)
     .  +Xtwiddle(0,k)*Cv(cii(z2(l,l))+N0,ep)
     .  -Xtwiddle(0,0)*Cv(ciii(z3(k,l,l))+N0,ep))/(4*Gtwiddle(k,l))
      enddo

      return
      end


      SUBROUTINE MB04DS( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To balance a real skew-Hamiltonian matrix
C
C                   [  A   G  ]
C              S =  [       T ] ,
C                   [  Q   A  ]
C
C     where A is an N-by-N matrix and G, Q are N-by-N skew-symmetric
C     matrices. This involves, first, permuting S by a symplectic
C     similarity transformation to isolate eigenvalues in the first
C     1:ILO-1 elements on the diagonal of A; and second, applying a
C     diagonal similarity transformation to rows and columns
C     ILO:2*N-ILO+1 to make the rows and columns as close in 1-norm
C     as possible. Both steps are optional.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the operations to be performed on S:
C             = 'N':  none, set ILO = 1, SCALE(I) = 1.0, I = 1 .. N;
C             = 'P':  permute only;
C             = 'S':  scale only;
C             = 'B':  both permute and scale.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A. N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the matrix A of the balanced skew-Hamiltonian. In
C             particular, the lower triangular part of the first ILO-1
C             columns of A is zero.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     QG      (input/output) DOUBLE PRECISION array, dimension
C                            (LDQG,N+1)
C             On entry, the leading N-by-N+1 part of this array must
C             contain in columns 1:N the strictly lower triangular part
C             of the matrix Q and in columns 2:N+1 the strictly upper
C             triangular part of the matrix G. The parts containing the
C             diagonal and the first supdiagonal of this array are not
C             referenced.
C             On exit, the leading N-by-N+1 part of this array contains
C             the strictly lower and strictly upper triangular parts of
C             the matrices Q and G, respectively, of the balanced
C             skew-Hamiltonian. In particular, the strictly lower
C             triangular part of the first ILO-1 columns of QG is zero.
C
C     LDQG    INTEGER
C             The leading dimension of the array QG.  LDQG >= MAX(1,N).
C
C     ILO     (output) INTEGER
C             ILO-1 is the number of deflated eigenvalues in the
C             balanced skew-Hamiltonian matrix.
C
C     SCALE   (output) DOUBLE PRECISION array of dimension (N)
C             Details of the permutations and scaling factors applied to
C             S.  For j = 1,...,ILO-1 let P(j) = SCALE(j). If P(j) <= N,
C             then rows and columns P(j) and P(j)+N are interchanged
C             with rows and columns j and j+N, respectively. If
C             P(j) > N, then row and column P(j)-N are interchanged with
C             row and column j+N by a generalized symplectic
C             permutation. For j = ILO,...,N the j-th element of SCALE
C             contains the factor of the scaling applied to row and
C             column j.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     REFERENCES
C
C     [1] Benner, P.
C         Symplectic balancing of Hamiltonian matrices.
C         SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, June 2008 (SLICOT version of the HAPACK routine DSHBAL).
C     V. Sima, Oct. 2012.
C
C     KEYWORDS
C
C     Balancing, skew-Hamiltonian matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
      DOUBLE PRECISION  FACTOR
      PARAMETER         ( FACTOR = 0.95D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOB
      INTEGER           ILO, INFO, LDA, LDQG, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), QG(LDQG,*), SCALE(*)
C     .. Local Scalars ..
      LOGICAL           CONV, LPERM, LSCAL
      INTEGER           I, IC, ILOOLD, J
      DOUBLE PRECISION  C, F, G, MAXC, MAXR, R, S, SCLFAC, SFMAX1,
     $                  SFMAX2, SFMIN1, SFMIN2
C     .. External Functions ..
      LOGICAL           LSAME
      INTEGER           IDAMAX
      DOUBLE PRECISION  DASUM, DLAMCH
      EXTERNAL          DASUM, DLAMCH, IDAMAX, LSAME
C     .. External Subroutines ..
      EXTERNAL          DRSCL, DSCAL, DSWAP, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, MAX, MIN
C
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      INFO = 0
      LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' )
      LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' )
C
      IF ( .NOT.LPERM .AND. .NOT.LSCAL .AND.
     $     .NOT.LSAME( JOB, 'N' ) ) THEN
         INFO = -1
      ELSE IF ( N.LT.0 ) THEN
         INFO = -2
      ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN
         INFO = -6
      END IF
C
C     Return if there were illegal values.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04DS', -INFO )
         RETURN
      END IF
C
      ILO = 1
C
C     Quick return if possible.
C
      IF ( N.EQ.0 )
     $   RETURN
      IF ( .NOT.LPERM .AND. .NOT.LSCAL ) THEN
         DO 10  I = 1, N
            SCALE(I) = ONE
   10    CONTINUE
         RETURN
      END IF
C
C     Permutations to isolate eigenvalues if possible.
C
      IF ( LPERM ) THEN
         ILOOLD = 0
C        WHILE ( ILO.NE.ILOOLD )
   20    IF ( ILO.NE.ILOOLD ) THEN
            ILOOLD = ILO
C
C           Scan columns ILO .. N.
C
            I = ILO
C           WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD )
   30       IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN
               DO 40  J = ILO, I-1
                  IF ( A(J,I).NE.ZERO ) THEN
                     I = I + 1
                     GOTO 30
                  END IF
   40          CONTINUE
               DO 50  J = I+1, N
                  IF ( A(J,I).NE.ZERO ) THEN
                     I = I + 1
                     GOTO 30
                  END IF
   50          CONTINUE
               DO 60  J = ILO, I-1
                  IF ( QG(I,J).NE.ZERO ) THEN
                     I = I + 1
                     GOTO 30
                  END IF
   60          CONTINUE
               DO 70  J = I+1, N
                  IF ( QG(J,I).NE.ZERO ) THEN
                     I = I + 1
                     GOTO 30
                  END IF
   70          CONTINUE
C
C              Exchange columns/rows ILO <-> I.
C
               SCALE(ILO) = DBLE( I )
               IF ( ILO.NE.I ) THEN
C
                  CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 )
                  CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA )
C
                  IF ( I.LT.N )
     $               CALL DSWAP( N-I, QG(I+1,I), 1, QG(I+1,ILO), 1 )
                  IF ( I.GT.ILO+1 ) THEN
                     CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,ILO), 1 )
                     CALL DSWAP( I-ILO-1, QG(ILO+1,ILO), 1, QG(I,ILO+1),
     $                           LDQG )
                  END IF
C
                  CALL DSWAP( ILO-1, QG(1,I+1), 1, QG(1,ILO+1), 1 )
                  IF ( N.GT.I )
     $               CALL DSWAP( N-I, QG(I,I+2), LDQG, QG(ILO,I+2),
     $                           LDQG )
                  IF ( I.GT.ILO+1 ) THEN
                     CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,I+1), 1 )
                     CALL DSWAP( I-ILO-1, QG(ILO,ILO+2), LDQG,
     $                           QG(ILO+1,I+1), 1 )
                  END IF
                  CALL DSCAL( I-ILO, -ONE, QG(ILO,I+1), 1 )
               END IF
               ILO = ILO + 1
            END IF
C           END WHILE 30
C
C           Scan columns N+ILO .. 2*N.
C
            I = ILO
C           WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD )
   80       IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN
               DO 90  J = ILO, I-1
                  IF ( A(I,J).NE.ZERO ) THEN
                     I = I + 1
                     GOTO 80
                  END IF
   90          CONTINUE
               DO 100  J = I+1, N
                  IF ( A(I,J).NE.ZERO ) THEN
                     I = I + 1
                     GOTO 80
                  END IF
  100          CONTINUE
               DO 110  J = ILO, I-1
                  IF ( QG(J,I+1).NE.ZERO ) THEN
                     I = I + 1
                     GOTO 80
                  END IF
  110          CONTINUE
               DO 120  J = I+1, N
                  IF ( QG(I,J+1).NE.ZERO ) THEN
                     I = I + 1
                     GOTO 80
                  END IF
  120          CONTINUE
               SCALE(ILO) = DBLE( N+I )
C
C              Exchange columns/rows I <-> I+N with a symplectic
C              generalized permutation.
C
               CALL DSWAP( I-ILO, A(I,ILO), LDA, QG(I,ILO), LDQG )
               CALL DSCAL( I-ILO, -ONE, A(I,ILO), LDA )
               CALL DSWAP( N-I, A(I,I+1), LDA, QG(I+1,I), 1 )
               CALL DSCAL( N-I, -ONE, QG(I+1,I), 1 )
               CALL DSWAP( I-1, A(1,I), 1, QG(1,I+1), 1 )
               CALL DSCAL( I-1, -ONE, A(1,I), 1 )
               CALL DSCAL( N-I, -ONE, A(I+1,I), 1 )
               CALL DSWAP( N-I, A(I+1,I), 1, QG(I,I+2), LDQG )
C
C              Exchange columns/rows ILO <-> I.
C
               IF ( ILO.NE.I ) THEN
C
                  CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 )
                  CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA )
C
                  IF ( I.LT.N )
     $               CALL DSWAP( N-I, QG(I+1,I), 1, QG(I+1,ILO), 1 )
                  IF ( I.GT.ILO+1 ) THEN
                     CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,ILO), 1 )
                     CALL DSWAP( I-ILO-1, QG(ILO+1,ILO), 1, QG(I,ILO+1),
     $                           LDQG )
                  END IF
C
                  CALL DSWAP( ILO-1, QG(1,I+1), 1, QG(1,ILO+1), 1 )
                  IF ( N.GT.I )
     $               CALL DSWAP( N-I, QG(I,I+2), LDQG, QG(ILO,I+2),
     $                           LDQG )
                  IF ( I.GT.ILO+1 ) THEN
                     CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,I+1), 1 )
                     CALL DSWAP( I-ILO-1, QG(ILO,ILO+2), LDQG,
     $                           QG(ILO+1,I+1), 1 )
                  END IF
                  CALL DSCAL( I-ILO, -ONE, QG(ILO,I+1), 1 )
               END IF
               ILO = ILO + 1
            END IF
C           END WHILE 80
            GOTO 20
         END IF
C        END WHILE 20
      END IF
C
      DO 130  I = ILO, N
         SCALE(I) = ONE
  130 CONTINUE
C
C     Scale to reduce the 1-norm of the remaining blocks.
C
      IF ( LSCAL ) THEN
         SCLFAC = DLAMCH( 'B' )
         SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' )
         SFMAX1 = ONE / SFMIN1
         SFMIN2 = SFMIN1*SCLFAC
         SFMAX2 = ONE / SFMIN2
C
C        Scale the rows and columns one at a time to minimize the
C        1-norm of the skew-Hamiltonian submatrix.
C        Stop when the 1-norm is very roughly minimal.
C
  140    CONTINUE
            CONV = .TRUE.
            DO 190  I = ILO, N
C
C              Compute 1-norm of row and column I without diagonal
C              elements.
C
               R = DASUM( I-ILO, A(I,ILO), LDA ) +
     $             DASUM( N-I, A(I,I+1), LDA ) +
     $             DASUM( I-ILO, QG(ILO,I+1), 1 ) +
     $             DASUM( N-I, QG(I,I+2), LDQG )
               C = DASUM( I-ILO, A(ILO,I), 1 ) +
     $             DASUM( N-I, A(I+1,I), 1 ) +
     $             DASUM( I-ILO, QG(I,ILO), LDQG ) +
     $             DASUM( N-I, QG(I+1,I), 1 )
C
C              Compute inf-norms of row and column I.
C
               IC = IDAMAX( N-ILO+1, A(I,ILO), LDA )
               MAXR = ABS( A(I,IC+ILO-1) )
               IF ( I.GT.1 ) THEN
                  IC = IDAMAX( I-1, QG(1,I+1), 1 )
                  MAXR = MAX( MAXR, ABS( QG(IC,I+1) ) )
               END IF
               IF ( N.GT.I ) THEN
                  IC = IDAMAX( N-I, QG(I,I+2), LDQG )
                  MAXR = MAX( MAXR, ABS( QG(I,IC+I+1) ) )
               END IF
               IC = IDAMAX( N, A(1,I), 1 )
               MAXC = ABS( A(IC,I) )
               IF ( I.GT.ILO ) THEN
                  IC = IDAMAX( I-ILO, QG(I,ILO), LDQG )
                  MAXC = MAX( MAXC, ABS( QG(I,IC+ILO-1) ) )
               END IF
               IF ( N.GT.I ) THEN
                  IC = IDAMAX( N-I, QG(I+1,I), 1 )
                  MAXC = MAX( MAXC, ABS( QG(IC+I,I) ) )
               END IF
C
               IF ( C.EQ.ZERO .OR. R.EQ.ZERO )
     $            GOTO 190
               G = R / SCLFAC
               F = ONE
               S = C + R
  150          CONTINUE
               IF ( C.GE.G .OR. MAX( F, C, MAXC ).GE.SFMAX2 .OR.
     $              MIN( R, G, MAXR ).LE.SFMIN2 )
     $            GOTO 160
               F = F*SCLFAC
               G = G / SCLFAC
               C = C*SCLFAC
               R = R / SCLFAC
               MAXC = MAXC*SCLFAC
               MAXR = MAXR / SCLFAC
               GOTO 150
C
  160          CONTINUE
               G = C / SCLFAC
  170          CONTINUE
               IF ( G.LT.R .OR. MAX( R, MAXR ).GE.SFMAX2 .OR.
     $              MIN( F, C, G, MAXC ).LE.SFMIN2 )
     $            GOTO 180
               F = F / SCLFAC
               G = G / SCLFAC
               C = C / SCLFAC
               R = R*SCLFAC
               MAXC = MAXC / SCLFAC
               MAXR = MAXR*SCLFAC
               GOTO 170
C
  180          CONTINUE
C
C              Now balance if necessary.
C
               IF ( ( C+R ).GE.FACTOR*S )
     $            GOTO 190
               IF ( F.LT.ONE .AND. SCALE(I).LT.ONE ) THEN
                  IF ( F*SCALE(I).LE.SFMIN1 )
     $               GOTO 190
               END IF
               IF ( F.GT.ONE .AND. SCALE(I).GT.ONE ) THEN
                  IF ( SCALE(I).GE.SFMAX1 / F )
     $               GOTO 190
               END IF
               CONV = .FALSE.
               SCALE(I) = SCALE(I)*F
               CALL DRSCL( I-ILO, F, A(I,ILO), LDA )
               CALL DRSCL( N-I, F, A(I,I+1), LDA )
               CALL DSCAL( I-1, F, A(1,I), 1 )
               CALL DSCAL( N-I, F, A(I+1,I), 1 )
               CALL DRSCL( I-1, F, QG(1,I+1), 1 )
               CALL DRSCL( N-I, F, QG(I,I+2), LDQG )
               CALL DSCAL( I-ILO, F, QG(I,ILO), LDQG )
               CALL DSCAL( N-I, F, QG(I+1,I), 1 )
  190       CONTINUE
         IF ( .NOT.CONV ) GOTO 140
      END IF
      RETURN
C *** Last line of MB04DS ***
      END


      recursive subroutine fpdisc(t,n,k2,b,nest)
      implicit none
c  subroutine fpdisc calculates the discontinuity jumps of the kth
c  derivative of the b-splines of degree k at the knots t(k+2)..t(n-k-1)
c  ..scalar arguments..
      integer n,k2,nest
c  ..array arguments..
      real*8 t(n),b(nest,k2)
c  ..local scalars..
      real*8 an,fac,prod
      integer i,ik,j,jk,k,k1,l,lj,lk,lmk,lp,nk1,nrint
c  ..local array..
      real*8 h(12)
c  ..
      k1 = k2-1
      k = k1-1
      nk1 = n-k1
      nrint = nk1-k
      an = nrint
      fac = an/(t(nk1+1)-t(k1))
      do 40 l=k2,nk1
        lmk = l-k1
        do 10 j=1,k1
          ik = j+k1
          lj = l+j
          lk = lj-k2
          h(j) = t(l)-t(lk)
          h(ik) = t(l)-t(lj)
  10    continue
        lp = lmk
        do 30 j=1,k2
          jk = j
          prod = h(j)
          do 20 i=1,k
            jk = jk+1
            prod = prod*h(jk)*fac
  20      continue
          lk = lp+k1
          b(lmk,j) = (t(lk)-t(lp))/prod
          lp = lp+1
  30    continue
  40  continue
      return
      end


Subroutine xkkann(srt, xsk1, xsk2, xsk3, xsk4, xsk5, xsk6, xsk7, xsk8, xsk9, xsk10, xsk11, sigk, rrkk)
  Parameter (maxstr=150001, maxx=20, maxz=24)
  Parameter (aka=0.498, pimass=0.140, rhom=0.770, omegam=0.7819, etam=0.5473, aphi=1.02)
  Common /aa/r(3, maxstr)
  Common /bb/p(3, maxstr)
  Common /ee/id(maxstr), lb(maxstr)
  Common /dd/rho(-maxx:maxx, -maxx:maxx, -maxz:maxz), rhop(-maxx:maxx, -maxx:maxx, -maxz:maxz), rhon(-maxx:maxx, -maxx:maxx, -maxz:maxz)
  Save
  s = srt**2
  sigk = 1.E-08
  xsk1 = 0.0
  xsk2 = 0.0
  xsk3 = 0.0
  xsk4 = 0.0
  xsk5 = 0.0
  xsk6 = 0.0
  xsk7 = 0.0
  xsk8 = 0.0
  xsk9 = 0.0
  xsk10 = 0.0
  xsk11 = 0.0
  xpion0 = pipik(srt)
  xpion0 = 2.0*xpion0
  pi2 = s*(s-4.0*aka**2)
  If (pi2<=0.0) Return
  xm1 = pimass
  xm2 = pimass
  pf2 = (s-(xm1+xm2)**2)*(s-(xm1-xm2)**2)
  If (pf2>0.0) Then
    xsk1 = 9.0/4.0*pf2/pi2*xpion0
  End If
  xm1 = pimass
  xm2 = etam
  pf2 = (s-(xm1+xm2)**2)*(s-(xm1-xm2)**2)
  If (pf2>0.0) Then
    xsk4 = 3.0/4.0*pf2/pi2*xpion0
  End If
  xm1 = etam
  xm2 = etam
  pf2 = (s-(xm1+xm2)**2)*(s-(xm1-xm2)**2)
  If (pf2>0.0) Then
    xsk10 = 1.0/4.0*pf2/pi2*xpion0
  End If
  xpion0 = rrkk
  xm1 = rhom
  xm2 = rhom
  pf2 = (s-(xm1+xm2)**2)*(s-(xm1-xm2)**2)
  If (pf2>0.0) Then
    xsk5 = 81.0/4.0*pf2/pi2*xpion0
  End If
  xm1 = rhom
  xm2 = omegam
  pf2 = (s-(xm1+xm2)**2)*(s-(xm1-xm2)**2)
  If (pf2>0.0) Then
    xsk6 = 27.0/4.0*pf2/pi2*xpion0
  End If
  xm1 = omegam
  xm2 = omegam
  pf2 = (s-(xm1+xm2)**2)*(s-(xm1-xm2)**2)
  If (pf2>0.0) Then
    xsk8 = 9.0/4.0*pf2/pi2*xpion0
  End If
  fwdp = 1.68*(aphi**2-4.*aka**2)**1.5/6./aphi/aphi
  scheck = srt**2 - 4.0*aka**2
  If (scheck<=0) Then
    Write (99, *) 'scheck47: ', scheck
    Stop
  End If
  pkaon = 0.5*sqrt(scheck)
  xsk11 = 30.*3.14159*0.1973**2*(aphi*fwdp)**2/((srt**2-aphi**2)**2+(aphi*fwdp)**2)/pkaon**2
  sigk = xsk1 + xsk2 + xsk3 + xsk4 + xsk5 + xsk6 + xsk7 + xsk8 + xsk9 + xsk10 + xsk11
  Return
End Subroutine xkkann


c###nommuf.for
      SUBROUTINE NOMMUF
C--------------------------------
C
C     THIS ROUTINE CALCULATES MUF FOR ALL LAYERS AND CIRCUIT MUF (NO ES)
C     BY THE MANUAL METHOD PROGRAMMED FOR COMPUTER USE
C
      COMMON/MUFS/EMUF(24),F1MUF(24),F2MUF(24),ESMUF(24),ALLMUF(24)
     1,FOT(24),XLUF(24),HPF(24),ANGMUF(24),MODMUF,SIGL(4),SIGU(4),DELMU
     2F(4),HPMUF(4),HTMUF(4),FVMUF(4),AFMUF(4),NHOPMF(4),YFOT(4),YHPF(4)
     3 ,YMUF(4)
      COMMON/ES/FS(3,5),HS(5)
      COMMON /RON /CLAT(5), CLONG(5), GLAT(5), RD(5), FI(3,5), YI(3,5),
     1HI(3,5), HPRIM(30,5), HTRUE(30,5), FVERT(30,5),KM,KFX, AFAC(30,5),
     2HTR(50,3), FNSQ(50,3)
      COMMON / TIME / IT, GMT, UTIME(24), GMTR, XLMT(24), ITIM, JTX
      COMMON /DON /ALATD, AMIN, AMIND, BTR, BTRD, DLONG, DMP, ERTR, GCD,
     1 GCDKM, PMP, PWR, TLAT, TLATD, TLONG, TLONGD, RSN, SIGTR, RLAT,
     2 RLATD,RLONG,RLONGD,BRTD,FLUX,ULAT,ULATD,ULONG,ULONGD,SSN,D90R,
     3 D50R,D10R,D90S,D50S,D10S
      COMMON / MFAC / F2M3(5),HPF2(5),ZENANG(5),ZENMAX(5),IEDP,FSECV(3)
      COMMON / CON / D2R, DCL, GAMA, PI, PI2, PIO2, R2D, RZ, VOFL
      DIMENSION AE(7),AF(7)
      DATA AE /-1.133200756E-2, 3.761385053E-2, -5.038476266E-3,
     1 2.624808315E-4, -5.976618436E-6, 1.334494261E-7, -4.368460907E-9/
      DATA AF / 4.699243101E-3, 2.264634341E-3, 9.202437332E-5,
     1 6.865259817E-5, -9.985831104E-6, 4.49151441E-7, -6.712654756E-9/
      ARC= GCDKM* 0.0062137
C
C THIS IS THE MANUAL METHOD PROGRAMMED FOR COMPUTER USE. SEE NBS REPORT
C 7619. MAXIMUM USABLE FREQUENCY FACTORS USING A COMPLETE ELECTRON
C DENSITY PROFILES ARE IN SUBROUTINE CURMUF
C
C
C  E-F1 LAYER DISTANCE FACTOR
C
      IF(ARC.lt.16.) then
         ELFC=((((((AE(7)*ARC+AE(6))*ARC+AE(5))*ARC+AE(4))*ARC
     A         + AE(3) )*ARC + AE(2))* ARC + AE(1) ) *ARC +  0.2085
      else
         ELFC = 1.02
      end if
C
C  F2  LAYER DISTANCE FACTOR
C
      IF(24..le.ARC) then
         FLFC = 1.0
      else
         FLFC=((((((AF(7)*ARC +AF(6))*ARC +AF(5) )*ARC + AF(4) )*ARC +
     A        AF(3) )*ARC + AF(2) )* ARC + AF(1) )*ARC
      end if
      EC = 1000.
      DO 135 K=1,KM
C E LAYER MUF
      IF(EC.gt.FI(1,K)) EC=FI(1,K)
  135 CONTINUE
      EMUF(IT) = 4.871 * EC * ELFC
      F2MUF(IT)= 1000.
C F LAYER MUF
      DO 145 K=1,KM
      FOUR= F2M3(K)*FI(3,K) * 1.1
      FMUF= FI(3,K) + FLFC*(FOUR - FI(3,K))
      IF(FMUF.lt.F2MUF(IT) ) F2MUF(IT)=FMUF
  145 CONTINUE
C  NO SEPERATE F1
      F1MUF(IT)= -1.
C  CIRCUIT MUF
      IF(EMUF(IT).ge.F2MUF(IT)) then
         ALLMUF(IT) =EMUF(IT)
      else
         ALLMUF(IT) =F2MUF(IT)
      end if
      FOTFY= 0.85* F2MUF(IT)
      FOT(IT) =AMAX1 (FOTFY,EMUF(IT))
      HPFFY = 1.15 * F2MUF(IT)
      HPF(IT) = AMAX1(HPFFY, EMUF(IT))
      ESMUF(IT)= 1000.
C
C SPORADIC E  MUF, PROBABILITY  OF REFLECTION IS 0.5
C
      DO 170 K=1,KM
      IF(FS(2,K).le.0.) go to 170
      DMAX= 225.*SQRT(HS(K) )
      HOP = GCDKM/DMAX +1.
      PSI = 0.5* GCD/HOP
      TDEL = (COS(PSI) - RZ / (RZ + HS(K))) / SIN(PSI)
      CDEL = 1. / SQRT(1. + TDEL * TDEL)
      SPHE = RZ * CDEL / (RZ + HS(K))
      SECP = 1. / SQRT(1. - SPHE * SPHE)
      ESD = FS(2,K) * SECP
      IF(ESMUF(IT).gt.ESD) ESMUF(IT)=ESD
  170 CONTINUE
      RETURN
      END
C--------------------------------


      subroutine runF_00ii(i1,i2,f,Gr,Shat4,N0)
C---  Expression for rearrangement of Eq. 5.70
C---  Calculates D00ii
C---  Small terms of order f(i)*Dijk,Gr(i,j)*Dijkl
      implicit none
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      include 'pvweenumber.f'
      integer ep,N0,i1,i2,np
      parameter(np=3)
      double precision f(np),Gr(np,np),den
      double complex Shat4(np,z3max,-2:0)

      do ep=-2,0
      if (i1 .eq. i2) then
        den=6d0
      else
        den=4d0
      endif
      Dv(dzzii(z2(i1,i2))+N0,ep)=
     . (Shat4(i1,z3(i1,i1,i2),ep)
     . -f(i1)*Dv(diii(z3(i1,i1,i2))+N0,ep)
     . -Gr(i1,1)*Dv(diiii(z4(1,i1,i1,i2))+N0,ep)
     . -Gr(i1,2)*Dv(diiii(z4(2,i1,i1,i2))+N0,ep)
     . -Gr(i1,3)*Dv(diiii(z4(3,i1,i1,i2))+N0,ep))/den

      enddo

      return
      end


!!**.****|****.****|****.****|****.****|****.****|****.****|****.****|****.****|
!! * e_loss_compton.f *                            galprop package * 4/14/2000
!!**"****!****"****!****"****!****"****!****"****!****"****!****"****!****"****|

      function e_loss_compton(w,gam)
c***********************************************************************
c                            *** I.Moskalenko, version of 25.02.1998 ***
c ELECTRON/POSITRON energy losses due to the inverse Compton, dE/dt.
c    INPUT:
c w - photon energy (in mc^2 units);
c gam - electron/positron Lorentz factor;
c The normalization of photon distrib. should be Int{dw f(w)}=number density.
c    OUTPUT:
c FCOMPT the energy losses, normalization [dE/dt]/Ne [MeV cm^3/c]
c    REFERENCES:
c Jones, F.C. 1965, Phys. Rev. 137, B1306
c Moskalenko, I.V., Jourdain E. 1997, A&A 325, 401
c Strong A.W., Moskalenko I.V. 1998, ApJ 509, 212
c***********************************************************************
      implicit real*8 (A-H,M,O-Z), integer (i-l,n)
      FC(A)=gam*((A+6.d0+3.d0/A)*dlog(2.d0*A+1.d0)-(22.d0/3.d0*A**3
     +      +24.d0*A**2+18.d0*A+4.d0)/(2.d0*A+1.d0)**2)
     -      -w*((A+31.d0/6.d0+5.d0/A+3.d0/2.d0/A**2)*dlog(2.d0*A+1.d0)
     -      -(22.d0/3.d0*A**3+28.d0*A**2+103.d0/3.d0*A+17.d0+3.d0/A)
     /      /(2.d0*A+1.d0)**2)
      POW2(w)=                        !! expansion series !!
     +  +56.d0/25.d0*w**5*gambet*gam*(7.d0*gambet**4                    ! w5
     +     +5.d0*gam**2*(-5.d0+7.d0*gam**2)
     +     +5.d0*gambet**2*(-5.d0+14.d0*gam**2))
     -  -16.d0/45.d0*w**4*gambet*gam**2*(-48.d0 +63.d0*gam**2           ! w4
     +     +bet2*(-16.d0+63.d0*gam**2))
     +  +16.d0/9.d0*w**3*gambet*gam*(-3.d0+(3.d0+bet2)*gam**2)          ! w3

      Pi = 3.14159265359d0
      R02 = 2.81794d-13**2 ! classical electron radius square (cm^2)
      mc2 = 0.511   ! MeV, electron rest mass
      cc = 2.99792d10   ! cm/s, light speed

      gambet = dsqrt(gam**2-1.d0)
      bet2 = 1.d0-1.d0/gam**2
c normalization of the gamma-ray spectra is int{dw f(w)*w**2} = Ngam,
c number density.
      FCOMPT = 1.d0/w/w

c $v$ calcs of Int_A^B {dx ln(2x+1)/x} = Li2(-2A)-Li2(-2B)
      A = w*(gam-gambet)
      if(gam .gt. 1.d5) A = w/2.d0/gam
      B = w*(gam+gambet)
      C = 0.2d0
c	     A = 0.d0
c	     B = 0.3d0
      if((A-C)*(B-C).gt.0.d0) then
         if(B.lt.C) C = B
         if(A.gt.C) C = A
      endif
      sum = 0.d0
      if(A.lt.C) then
         j = -13.*alog(10.)/dlog(2.*C)+3
         up   = C*2.d0/(j+1)**2
         down = A*2.d0/(j+1)**2
         do k = j,1,-1
            up   = 2.d0*C*(1.d0/k**2-up)
            down = 2.d0*A*(1.d0/k**2-down)
         enddo
         sum = up-down
      endif
      if(C.lt.B) then
         up   = 2.d0*B+1.d0
         down = 2.d0*C+1.d0
         j = 15.*alog(10.)/dlog(down)+3
         sum1 = 1.d0/(j+1)**2/up
         z    = 1.d0/(j+1)**2/down
         do k = j,1,-1
            sum1 = (1.d0/k**2+sum1)/up
	    z	 = (1.d0/k**2+z)/down
         enddo
         up   = dlog(2.d0*B+1.d0)
         down = dlog(2.d0*C+1.d0)
	 sum=sum+up*(dlog(2.d0*B)-up/2.d0)-sum1
     -	     -(down*(dlog(2.d0*C)-down/2.d0)-z)
      endif
c #!attention! u(b)=1.6449340668482+y*(dlog(2.d0*b)-y/2.d0)-v; a=0, b>0.2#
c $^$
c $$      call SIM1(A,B,(B-A)/1.d3,1.d-5,1.d-18,FL,sum)
      FBA = FC(B)-FC(A)-(2.d0*gam-w)*sum
      if(gam*(w*gam)**3 .le. 4.d-5) FBA = POW2(w)
      e_loss_compton = FCOMPT*FBA  *Pi*R02*mc2*cc    /2.d0/gam/gambet
      return
      end


subroutine mysub(Y, Yout, alpha_1, alpha_2, alpha_3, alpha_4, h, h_angle, eps)
    implicit none

    real, parameter :: PI = 3.1415926
    double precision, intent(in) :: alpha_1, alpha_2, alpha_3, alpha_4, h, h_angle, eps
    double precision, dimension(8, 2, 2), intent(in) :: Y
    double precision, dimension(8, 2, 2), intent(out) :: Yout

    double precision, dimension(2, 2) :: Reg, Img, Regt, Imgt, Redg, Imdg, Redgt, Imdgt, s0, sx, sz, A_1, A_3
    double complex, dimension(2, 2) :: g, gt, dg, dgt, n, nt, rhs, rhst

    Reg   = Y(1,:,:)
    Img   = Y(2,:,:)
    Regt  = Y(3,:,:)
    Imgt  = Y(4,:,:)
    Redg  = Y(5,:,:)
    Imdg  = Y(6,:,:)
    Redgt = Y(7,:,:)
    Imdgt = Y(8,:,:)
    s0    = reshape((/ 1, 0, 0, 1 /), shape(s0))
    sx    = reshape((/ 0, 1, 1, 0 /), shape(sx))
    sz    = reshape((/ 1, 0, 0,-1 /), shape(sz))

    A_1   = alpha_1*sx + alpha_2*sz ! 1st component of the spin-orbit vector potential
    A_3   = alpha_3*sx + alpha_4*sz ! 3rd component of the spin-orbit vector potential
    ! 2nd component is zero.

    g   = Reg   + (0d0,1d0)*Img
    gt  = Regt  + (0d0,1d0)*Imgt
    dg  = Redg  + (0d0,1d0)*Imdg
    dgt = Redgt + (0d0,1d0)*Imdgt

    ! These are the inverse matrices defined in the equation 3.26 in my Master's thesis

    n(1,1)  = ( 1 + g(2,1)*gt(1,2) + g(2,2)*gt(2,2) ) / ( 1 + g(1,1)*gt(1,1) + g(2,1)*gt(1,2) + g(1,2)*gt(2,1)&
    + g(1,2)*g(2,1)*gt(1,2)*gt(2,1) - g(1,1)*g(2,2)*gt(1,2)*gt(2,1) + g(2,2)*gt(2,2) - g(1,2)*g(2,1)*gt(1,1)*gt(2,2)&
    + g(1,1)*g(2,2)*gt(1,1)*gt(2,2) )

    n(1,2)  = -( g(1,1)*gt(1,2) + g(1,2)*gt(2,2) ) / ( 1 + g(1,1)*gt(1,1) + g(2,1)*gt(1,2) + g(1,2)*gt(2,1)&
    + g(1,2)*g(2,1)*gt(1,2)*gt(2,1) - g(1,1)*g(2,2)*gt(1,2)*gt(2,1) + g(2,2)*gt(2,2) - g(1,2)*g(2,1)*gt(1,1)*gt(2,2)&
    + g(1,1)*g(2,2)*gt(1,1)*gt(2,2) )

    n(2,1)  = -( g(2,1)*gt(1,1) + g(2,2)*gt(2,1) ) / ( 1 + g(1,1)*gt(1,1) + g(2,1)*gt(1,2) + g(1,2)*gt(2,1)&
    + g(1,2)*g(2,1)*gt(1,2)*gt(2,1) - g(1,1)*g(2,2)*gt(1,2)*gt(2,1) + g(2,2)*gt(2,2) - g(1,2)*g(2,1)*gt(1,1)*gt(2,2)&
    + g(1,1)*g(2,2)*gt(1,1)*gt(2,2) )

    n(2,2)  = ( 1 + g(1,1)*gt(1,1) + g(1,2)*gt(2,1) ) / ( 1 + g(1,1)*gt(1,1) + g(2,1)*gt(1,2) + g(1,2)*gt(2,1)&
    + g(1,2)*g(2,1)*gt(1,2)*gt(2,1) - g(1,1)*g(2,2)*gt(1,2)*gt(2,1) + g(2,2)*gt(2,2) - g(1,2)*g(2,1)*gt(1,1)*gt(2,2)&
    + g(1,1)*g(2,2)*gt(1,1)*gt(2,2) )

    nt(1,1) = ( 1 + g(1,2)*gt(2,1) + g(2,2)*gt(2,2) ) / ( 1 + g(1,1)*gt(1,1) + g(2,1)*gt(1,2) + g(1,2)*gt(2,1)&
    + g(1,2)*g(2,1)*gt(1,2)*gt(2,1) - g(1,1)*g(2,2)*gt(1,2)*gt(2,1) + g(2,2)*gt(2,2) - g(1,2)*g(2,1)*gt(1,1)*gt(2,2)&
    + g(1,1)*g(2,2)*gt(1,1)*gt(2,2) )

    nt(1,2) = -( g(1,2)*gt(1,1) + g(2,2)*gt(1,2) ) / ( 1 + g(1,1)*gt(1,1) + g(2,1)*gt(1,2) + g(1,2)*gt(2,1)&
    + g(1,2)*g(2,1)*gt(1,2)*gt(2,1) - g(1,1)*g(2,2)*gt(1,2)*gt(2,1) + g(2,2)*gt(2,2) - g(1,2)*g(2,1)*gt(1,1)*gt(2,2)&
    + g(1,1)*g(2,2)*gt(1,1)*gt(2,2) )

    nt(2,1) = -( g(1,1)*gt(2,1) + g(2,1)*gt(2,2) ) / ( 1 + g(1,1)*gt(1,1) + g(2,1)*gt(1,2) + g(1,2)*gt(2,1)&
    + g(1,2)*g(2,1)*gt(1,2)*gt(2,1) - g(1,1)*g(2,2)*gt(1,2)*gt(2,1) + g(2,2)*gt(2,2) - g(1,2)*g(2,1)*gt(1,1)*gt(2,2)&
    + g(1,1)*g(2,2)*gt(1,1)*gt(2,2) )

    nt(2,2) = ( 1 + g(1,1)*gt(1,1) + g(2,1)*gt(1,2) ) / ( 1 + g(1,1)*gt(1,1) + g(2,1)*gt(1,2) + g(1,2)*gt(2,1)&
    + g(1,2)*g(2,1)*gt(1,2)*gt(2,1) - g(1,1)*g(2,2)*gt(1,2)*gt(2,1) + g(2,2)*gt(2,2) - g(1,2)*g(2,1)*gt(1,1)*gt(2,2)&
    + g(1,1)*g(2,2)*gt(1,1)*gt(2,2) )

    ! This is the equation 4.2 in my Master's thesis. The 1st term on the LHS is not here as we want to give the solver
    ! the derivative terms.

    rhs = - (0d0,1d0)*2*eps*MATMUL(s0,g)& ! This is the energy term. 1st on the RHS.

    ! The 2nd term on the LHS coming from the normal gradient part of the covariant derivative.
    + 2*MATMUL(dg, MATMUL(gt, MATMUL(n, dg)))&

    ! These two terms are the exchange field. With angle 0 you only get sigma_3 and with angle 90 you only get sigma_1.
    + (0d0,1d0)*h*COS(h_angle*PI/180)*(MATMUL(g, sz) - MATMUL(sz, g))&
    + (0d0,1d0)*h*SIN(h_angle*PI/180)*(MATMUL(g, sx) - MATMUL(sx, g))&

    ! These are the second order spin-orbit terms. Both A1 and A3 components from the vector potential contribute.
    + MATMUL(A_3, MATMUL(A_3, g)) - MATMUL(g, MATMUL(A_3, A_3)) + 2*MATMUL(g, MATMUL(A_3, MATMUL(nt, A_3)))&
    - 2*MATMUL(g, MATMUL(A_3, MATMUL(nt, MATMUL(gt, MATMUL(A_3, g))))) + 2*MATMUL(A_3, MATMUL(g, MATMUL(nt, A_3)))&
    - 2*MATMUL(A_3, MATMUL(g, MATMUL(nt, MATMUL(gt, MATMUL(A_3, g)))))&

    + MATMUL(A_1, MATMUL(A_1, g)) - MATMUL(g, MATMUL(A_1, A_1)) + 2*MATMUL(g, MATMUL(A_1, MATMUL(nt, A_1)))&
    - 2*MATMUL(g, MATMUL(A_1, MATMUL(nt, MATMUL(gt, MATMUL(A_1, g))))) + 2*MATMUL(A_1, MATMUL(g, MATMUL(nt, A_1)))&
    - 2*MATMUL(A_1, MATMUL(g, MATMUL(nt, MATMUL(gt, MATMUL(A_1, g)))))&

    ! This is the term where the A3 component couples to the gradient terms. Only A3 couples to the gradients
    ! since it is in the direction of the nanowire and gradients to other directions are assumed small.
    + (0d0,1d0)*2*(MATMUL(dg, MATMUL(nt, A_3)) - MATMUL(dg, MATMUL(nt, MATMUL(gt, MATMUL(A_3, g))))&
    + MATMUL(A_3, MATMUL(n, dg)) - MATMUL(g, MATMUL(A_3, MATMUL(gt, MATMUL(n, dg)))))

    ! This is the tilde counterpart to the equation 4.2. Change g <-> gt, n <-> nt and take complex conjugate
    ! of the scalars. The explanations of the terms are as above.

    rhst = -(0d0,1d0)*2*eps*MATMUL(s0,gt)&

    + 2*MATMUL(dgt, MATMUL(g, MATMUL(nt, dgt)))&

    - (0d0,1d0)*h*COS(h_angle*PI/180)*(MATMUL(gt, sz) - MATMUL(sz, gt))&
    - (0d0,1d0)*h*SIN(h_angle*PI/180)*(MATMUL(gt, sx) - MATMUL(sx, gt))&

    + MATMUL(A_3, MATMUL(A_3, gt)) - MATMUL(gt, MATMUL(A_3, A_3)) + 2*MATMUL(gt, MATMUL(A_3, MATMUL(n, A_3)))&
    - 2*MATMUL(gt, MATMUL(A_3, MATMUL(n, MATMUL(g, MATMUL(A_3, gt))))) + 2*MATMUL(A_3, MATMUL(gt, MATMUL(n, A_3)))&
    - 2*MATMUL(A_3, MATMUL(gt, MATMUL(n, MATMUL(g, MATMUL(A_3, gt)))))&

    + MATMUL(A_1, MATMUL(A_1, gt)) - MATMUL(gt, MATMUL(A_1, A_1)) + 2*MATMUL(gt, MATMUL(A_1, MATMUL(n, A_1)))&
    - 2*MATMUL(gt, MATMUL(A_1, MATMUL(n, MATMUL(g, MATMUL(A_1, gt))))) + 2*MATMUL(A_1, MATMUL(gt, MATMUL(n, A_1)))&
    - 2*MATMUL(A_1, MATMUL(gt, MATMUL(n, MATMUL(g, MATMUL(A_1, gt)))))&

    - (0d0,1d0)*2*(MATMUL(dgt, MATMUL(n, A_3)) - MATMUL(dgt, MATMUL(n, MATMUL(g, MATMUL(A_3, gt))))&
    + MATMUL(A_3, MATMUL(nt, dgt)) - MATMUL(gt, MATMUL(A_3, MATMUL(g, MATMUL(nt, dgt)))))

    Yout(1,:,:) = Redg
    Yout(2,:,:) = Imdg
    Yout(3,:,:) = Redgt
    Yout(4,:,:) = Imdgt
    Yout(5,:,:) = REALPART(rhs)
    Yout(6,:,:) = IMAGPART(rhs)
    Yout(7,:,:) = REALPART(rhst)
    Yout(8,:,:) = IMAGPART(rhst)

end subroutine mysub


module linalg_wrapper_mod
    use global_defs
#ifdef LINALG_F95
    use blas95
    use lapack95
#endif
    implicit none
    public

contains

#ifndef LINALG_F95
    function dot(x, y) result(z)
        real(dp) :: x(:)
        real(dp) :: y(:)
        real(dp) :: z
        z = sum(x*y)
    end function dot

    subroutine gemv(a, x, y, trans, alpha, beta)
        real(dp) :: a(:, :)
        real(dp) :: x(:)
        real(dp) :: y(:)
        character(len=1), optional :: trans
        real(dp), optional :: alpha
        real(dp), optional :: beta
        character(len=1) :: wrk_trans
        real(dp) :: wrk_alpha
        real(dp) :: wrk_beta
        integer :: m, n
        external dgemv
        m = size(a, 1)
        n = size(a, 2)
        wrk_trans = 'N'
        if (present(trans)) wrk_trans = trans
        wrk_alpha = num1
        if (present(alpha)) wrk_alpha = alpha
        wrk_beta = num0
        if (present(beta)) wrk_beta = beta
        call dgemv(wrk_trans, m, n, wrk_alpha, a, m, x, 1, wrk_beta, y, 1)
    end subroutine gemv

    subroutine gemm(a, b, c, transa, transb, alpha, beta)
        !> @todo add complex version
        real(dp) :: a(:, :)
        real(dp) :: b(:, :)
        real(dp) :: c(:, :)
        character(len=1), optional :: transa
        character(len=1), optional :: transb
        real(dp), optional :: alpha
        real(dp), optional :: beta
        character(len=1) :: wrk_transa
        character(len=1) :: wrk_transb
        real(dp) :: wrk_alpha
        real(dp) :: wrk_beta
        integer :: m, n, k, lda, ldb, ldc
        external dgemm
        lda = size(a, 1)
        ldb = size(b, 1)
        ldc = size(c, 1)
        n = size(c, 2)
        wrk_transa = 'N'
        if (present(transa)) wrk_transa = transa
        wrk_transb = 'N'
        if (present(transb)) wrk_transb = transb
        wrk_alpha = num1
        if (present(alpha)) wrk_alpha = alpha
        wrk_beta = num0
        if (present(beta)) wrk_beta = beta
        m = lda
        if (wrk_transa /= 'N') then
            m = size(a, 2)
            k = lda
        else
            m = lda
            k = size(a, 2)
        end if
        call dgemm(wrk_transa, wrk_transb, m, n, k, wrk_alpha, a, lda, b, ldb, wrk_beta, c, ldc)
    end subroutine gemm

    subroutine cgemm(a, b, c, transa, transb, alpha, beta)
        complex(dp) :: a(:, :)
        complex(dp) :: b(:, :)
        complex(dp) :: c(:, :)
        character(len=1), optional :: transa
        character(len=1), optional :: transb
        complex(dp), optional :: alpha
        complex(dp), optional :: beta
        character(len=1) :: wrk_transa
        character(len=1) :: wrk_transb
        complex(dp) :: wrk_alpha
        complex(dp) :: wrk_beta
        integer :: m, n, k, lda, ldb, ldc
        external zgemm
        lda = size(a, 1)
        ldb = size(b, 1)
        ldc = size(c, 1)
        n = size(c, 2)
        wrk_transa = 'N'
        if (present(transa)) wrk_transa = transa
        wrk_transb = 'N'
        if (present(transb)) wrk_transb = transb
        wrk_alpha = cmplx(num1, num0, dp)
        if (present(alpha)) wrk_alpha = alpha
        wrk_beta = cmplx(num0, num0, dp)
        if (present(beta)) wrk_beta = beta
        m = lda
        if (transa /= 'N') then
            m = size(a, 2)
            k = lda
        else
            m = lda
            k = size(a, 2)
        end if
        call zgemm(wrk_transa, wrk_transb, m, n, k, wrk_alpha, a, lda, b, ldb, wrk_beta, c, ldc)
    end subroutine cgemm

    subroutine ger(a, x, y, alpha)
        real(dp) :: x(:)
        real(dp) :: y(:)
        real(dp) :: a(:, :)
        real(dp), optional :: alpha
        integer :: m
        integer :: n
        real(dp) :: wrk_alpha
        external dger
        m = size(x)
        n = size(y)
        wrk_alpha = num1
        if (present(alpha)) wrk_alpha = alpha
        call dger(m, n, wrk_alpha, x, 1, y, 1, a, m)
    end subroutine ger

    subroutine gesvd(a, s, u, vt, job, info)
        real(dp) :: a(:, :)
        real(dp) :: s(:)
        real(dp), optional :: u(:, :)
        real(dp), optional :: vt(:, :)
        character(len=1), optional :: job
        integer, optional :: info
        real(dp), allocatable :: wrk_u(:, :)
        real(dp), allocatable :: wrk_vt(:, :)
        real(dp), allocatable :: work(:)
        character(len=1) :: wrk_job
        character(len=1) :: jobu
        character(len=1) :: jobvt
        integer :: wrk_info
        integer :: m, n, ldvt, ldu, lwork
        external :: dgesvd

        m = size(a, 1)
        n = size(a, 2)
        wrk_job = 'N'
        if (present(job)) wrk_job = job
        if (present(u)) then
            allocate(wrk_u, source=u)
            ldu = size(wrk_u, 1)
            if (size(u, 2) == m) then
                jobu = 'A'
            else
                jobu = 'S'
            end if
        else
            if (wrk_job == 'U') then
                jobu = 'O'
            else
                jobu = 'N'
            end if
        end if
        if (present(vt)) then
            allocate(wrk_vt, source=vt)
            ldvt = size(wrk_vt, 1)
            if (size(vt, 1) == n) then
                jobvt = 'A'
            else
                jobvt = 'S'
            end if
        else
            if (wrk_job == 'V') then
                jobvt = 'O'
            else
                jobvt = 'N'
            end if
        end if

        ! Determine size of work array.
        allocate(work(1))
        lwork = -1
        call dgesvd(jobu, jobvt, m, n, a, m, s, wrk_u, ldu, wrk_vt, ldvt, work, lwork, wrk_info)
        lwork = int(work(1))
        deallocate(work)
        allocate(work(lwork))

        ! Call DGESVD.
        call dgesvd(jobu, jobvt, m, n, a, m, s, wrk_u, ldu, wrk_vt, ldvt, work, lwork, wrk_info)
        if (present(u)) u = wrk_u
        if (present(vt)) vt = wrk_vt
        if (present(info)) then
            info = wrk_info
        else
            if (wrk_info /= 0) then
                write(stderr, *) 'Error. GESVD call failed.'
                write(stderr, '(a, i0)') '        Info: ', wrk_info
                stop
            end if
        end if
    end subroutine gesvd

    subroutine getrf(a, ipiv, info)
        real(dp) :: a(:, :)
        integer, optional :: ipiv(:)
        integer, optional :: info
        integer :: wrk_info
        integer, allocatable :: wrk_ipiv(:)
        integer :: n, m
        external :: dgetrf

        m = size(a, 1)
        n = size(a, 2)
        if (present(ipiv)) then
            allocate(wrk_ipiv, source=ipiv)
        else
            allocate(wrk_ipiv(min(m, n)))
        end if

        ! Call DGETRF
        call dgetrf(m, n, a, n, wrk_ipiv, wrk_info)
        if (present(ipiv)) ipiv = wrk_ipiv
        if (present(info)) then
            info = wrk_info
        else
            if (wrk_info /= 0) then
                write(stderr, *) 'Error. GETRF call failed.'
                write(stderr, '(a, i0)') '        Info: ', wrk_info
                stop
            end if
        end if
    end subroutine getrf

    subroutine syev(a, w, jobz, uplo, info)
        real(dp) :: a(:, :)
        real(dp) :: w(:)
        character(len=1), optional :: jobz
        character(len=1), optional :: uplo
        integer, optional :: info
        real(dp), allocatable :: work(:)
        character(len=1) :: wrk_jobz
        character(len=1) :: wrk_uplo
        integer :: wrk_info
        integer :: n, lwork
        external :: dsyev

        n = size(a, 1)
        wrk_jobz = 'N'
        if (present(jobz)) wrk_jobz = jobz
        wrk_uplo = 'U'
        if (present(uplo)) wrk_uplo = uplo

        ! Determine size of work array.
        allocate(work(1))
        call dsyev(wrk_jobz, wrk_uplo, n, a, n, w, work, -1, info)
        lwork = int(work(1))
        deallocate(work)
        allocate(work(lwork))

        ! Call DSYEV.
        call dsyev(wrk_jobz, wrk_uplo, n, a, n, w, work, lwork, info)
        if (present(info)) then
            info = wrk_info
        else
            if (wrk_info /= 0) then
                write(stderr, *) 'Error. SYEV call failed.'
                write(stderr, '(a, i0)') '        Info: ', wrk_info
                stop
            end if
        end if
    end subroutine syev
#endif

end module linalg_wrapper_mod


c
c	Program determines the fit parameters for a power-law function
c	that is matched to the ionosphere at the point of maximum slope
c     and to the slope of the plasmaspheric interior density. This used
c     to be matched to the slope at the point of the maximum density
c     but that sometimes results in the power law function not falling
c     to the interior plasmaspheric densities. That won't work, so now
c     what is being done is to find the point of maximum slope, calculate
c     a power law function that matches the slope at that point, then
c     find where that function has the same slope as the interior plasmaspheric
c     density profile, then use that point and the point of maximum slope
c     to recalculate the power function. That will result in the power law
c     having a slope close to that of the topside ionosphere at the maximum slope
c     but still drop to interior plasmaspheric densities.
c
c     First, then, find the location
c	in the topside ionosphere where the slope is a maximum.  It
c	starts looking at the F2 peak and stops when the slope starts
c	to decrease.  It steps upward with an interval of delh.
c
c	This version of the code only looks along the magnetic equator
c     for producing a smooth equatorial density profile.
c	d.l. gallagher    March 13, 1999.
c
c     d.l.g. November 24, 2007 changed to calculate a power law that insures
c     it falls to the interior plasmaspheric density.
c
	subroutine iri_ps_eq_bridge(al,amlt,itime,transh,alpha,ano,
     &                            am1,b1,x234,psL)
c
	real re,delh,delr,amltrad,tot_delh,r
	parameter (re=6371.0,tot_delh=600.0/re)
	parameter (r=200.0/re+1.0)
	parameter (amltrad=3.1415927/12.0)
c
	real outf(20,100),oarr(50),alatr,along
	real pi,hs,amlt,rs,diff,diff_old,dens_old,dens
	real ano,alpha,transh,x234
      real rz12,f107,neiri,nhoiri,nheiri,noiri
	integer*4 itime(2)
	data pi/3.1415927/

	common /irioutput/ rz12,f107,neiri,nhoiri,nheiri,noiri

c	  print*,'entering iri_ps_eq_bridge',amlt,itime,am1,b1,x234

	alatr=0.0
	along=(amlt+12.0)*amltrad
	along=along - (1.0-sign(1.0,(12.0-amlt)))*pi

c  get height and densiy of the f2 peak
c	  print*,'iri_ps_eq_bridge calling iri_sm @r',r,along
	call iri_sm(alatr,along,r,itime,outf,oarr)
	rf2=oarr(2)/re+1.0
c	  print*,'f2:',rf2

c In an effort to reduce the cals to iri2007 the following is used
c to approximate the point of maximum negative slope in the topside
c ionosphere. This has been obtained from a linear fit to this location
c (derived from the search algorithm above) as a function of returned
c rz12 value from IRI2007. That analysis obtained this relationship:
c     ro = (1.05454+-0.000102) + (8.62678e-5+-1.20975e-6)*rz12
      ro = 1.05454 + 8.62678e-5*rz12
c	  print*,'eq_bridge:',rz12,ro,rf2
c      if (ro .le. rf2) ro=rf2+0.01
      ro=amax1((rf2+0.01),ro)
	transh=(ro-1.0)*re
c	ah1=(rposold-1.0)*re
c	ah2=(rposold+diffr-1.0)*re
      ah1=transh-1.0
      ah2=transh+1.0

c get the density at the maximum slope height
	call iri_sm(alatr,along,ro,itime,outf,oarr)
	dens=outf(1,1)

c since only calculating ro from a fitted function, need to separately
c determine the ionospheric densities above and below to support initial
c calculation of the power law function.
	call iri_sm(alatr,along,(ah1/re+1.0),itime,outf,oarr)
	an1old=outf(1,1)
	call iri_sm(alatr,along,(ah2/re+1.0),itime,outf,oarr)
	an2old=outf(1,1)

c	  print*,'power law foder:',an1old,an2old,ah1,ah2

c calculate the initial equatorial power law transition function
	alphao=-log(an1old/an2old)/log(ah1/ah2)
	ano=dens/transh**(-alphao)
c	  print*,'bridge init:',alphao,ano,dens,transh
c calculate where this initial power law intersects the plasmasphere profile
      psh=2000.0
      do ii=1,5
c 	  print*,'psh interation:',ii,psh,ano,alphao,am1,b1
        psh=10.0**((am1*(psh/re+1.0)+b1+x234+6.0-alog10(ano))/(-alphao))
                          ! inner plasmasphere density calculation
      enddo
      psL=psh/re+1.0
c Check to see whether psh is too large, meaning it was continously increasing
c during the 5 iterations. If it is too large, then these two curves did not
c intersect and we have to force a more steep topside ionosphere.
      if (psh .ge.0.5*re) then
c Instead calculate the location along the equator where this power law function
c matches the slope of the interior plasmaspheric density
        psL=1.0 - alphao/am1/alog(10.0)
        psh=(psL-1.0)*re
      endif
c	  print*,'psh final:',psh
      psden=10.0**(am1*psL+b1+x234+6.0) !inner plasmasphere density calculation

c new power law value, alpha, needs to match the ionosphere at the point
c of maximum slope and the interior plasmaspheric density where the initial
c power law slope matches the plasmasphere interior density slope
      alpha=-alog10(dens/psden)/alog10(transh/psh)
      ano=dens/transh**(-alpha)
c	  print*,'reworked bridge:',psL,psh,psden,am1,b1
c	  print*,'leaving iri_ps_eq_bridge',alpha,ano,dens,ro,transh

	return
	end


!-----------------------------------------------------------------------------
        subroutine getmat(t, rmu, rlm, con, dmu, d2mu, dlm, d2lm, dcon, d2con)

!.... Calculate the Navier-Stokes material properties
!.... Note: everything is nondimensional

        use stuff
        implicit none
        real t(:), rmu(:), rlm(:), con(:), dmu(:), d2mu(:)
        real dlm(:), d2lm(:), dcon(:), d2con(:)

        if (mattyp .eq. 0) then         ! constant visc
          rmu  = one
          dmu  = zero
          d2mu = zero
          dlm  = zero
          d2lm = zero
        else                            ! Sutherland's law
          rmu  = t**onept5*(one+S0)/(t+S0)
          dmu  = sqrt(t)*(one+S0)*(3.0*S0+t)*pt5/(S0+t)**2
          d2mu = (one+S0)*(3.0*S0**2-6.0*S0*t-t**2)*pt25/sqrt(t)/(S0+t)**3
        end if

        con   = rmu
        dcon  = dmu
        d2con = d2mu

        rlm  = -pt66 * rmu
        dlm  = -pt66 * dmu
        d2lm = -pt66 * d2mu

        return
        end

!-----------------------------------------------------------------------------
        subroutine sgetmat(t, rmu, rlm, con, dmu, d2mu, dlm, d2lm, dcon, d2con)

!.... Calculate the Navier-Stokes material properties

        use stuff
        implicit none
        real t, rmu, rlm, con, dmu, d2mu
        real dlm, d2lm, dcon, d2con

        if (mattyp .eq. 0) then         ! constant visc
          rmu  = one
          dmu  = zero
          d2mu = zero
          dlm  = zero
          d2lm = zero
        else                            ! Sutherland's law
          rmu  = t**onept5*(one+S0)/(t+S0)
          dmu  = sqrt(t)*(one+S0)*(3.0*S0+t)*pt5/(S0+t)**2
          d2mu = (one+S0)*(3.0*S0**2-6.0*S0*t-t**2)*pt25/sqrt(t)/(S0+t)**3
        end if

        con = rmu
        dcon = dmu
        d2con = d2mu

        rlm = -pt66 * rmu
        dlm = -pt66 * dmu
        d2lm = -pt66 * d2mu

        return
        end