module Structure

  use Matrix_op
  implicit none

  type :: Input

     ! Select the solver: "LATIN-PGD" or "Newton-Raphson"
     character(len = 50) :: solver = "LATIN-PGD"

     ! NR solver parameters:
     double precision :: NR_error_min = 1e-4 ! norm of the residual equilibrium.
     double precision :: beta = 1.D0/4.D0
     double precision :: gamma = 1.D0/2.D0
     integer :: ntNR ! NR temporal nodes.

     ! LATIN solver parameters:
     double precision :: LATIN_error_min = 1 ! minimun value of the LATIN error [%].
     double precision :: PGD_ind = 0.1 ! PGD indicator (to stop the PGD iterations).
     double precision :: Upd_PGD_ind = 0.1 ! PGD indicator at the Preliminary step.
     integer :: PGD_iter_max = 4 ! Maximum number of PGD iterations at the global stage.
     double precision :: relax = 0.4
     double precision :: sig_factor = (1e-2)
     integer :: interval_act_modes = 1 ! number of modes to be actualized.

     logical :: PGD_eval = .true.
     double precision :: update_limit = 0.1
     double precision :: update_ind = 100
     integer :: N_up_max = 4 ! maximum number of update iterations at the preliminary step.
     integer :: up_iter = 0

     !character(len = 50) :: title="NEPE PAL QUE LEE"

     double precision :: pi = 4.D0*DATAN(1.D0)
     integer :: dim = 1
     character(len = 50) :: material = "Viscoplasticity" ! Viscoplasticity or Concrete
     integer :: value = 8.5

     ! Material parameters:

     double precision :: rho = 7800  ! Kg/m3
     double precision :: sigma_y = 8e7
     double precision :: np = 5
     double precision :: K = 1220e6
     double precision :: ks

     ! Solver Parameters:

     ! Space definition (1D for the moment):

     double precision :: E = 137600e6 !137600e3
     double precision :: Hooke
     double precision :: d1 = 0.2; ! x dimension [m]
     double precision :: d2 = 0.3; ! y dimension [m]
     double precision :: L = 4 ! z dimension [m]
     double precision :: A   ! [m2]
     integer :: Nx = 250  ! number of fem elements in x direction.
     integer :: n ! total nodes
     integer :: ns ! free nodes
     integer :: ne = 2 ! bar elemental
     double precision :: dx
     integer :: ngps = 2
     integer :: Tngps
     integer :: Nsfs = 2  ! Number of shape functions in space.
     !double precision, dimension(:), allocatable :: gps  ! vector of gauss points on a normalized temporal element.
     !double precision, dimension(:,:), allocatable :: gauss_s ! points and weight matrix.

     ! Temporal definition:

     double precision :: Tend = 10.D0
     double precision :: Ti = 0.D0
     integer :: NT = 1000
     integer :: ntc ! temporal nodes
     double precision :: dt
     double precision, dimension(:), allocatable :: t  ! time vector.
     !double precision, dimension(:), allocatable :: gpt  ! vector of gauss points on a normalized temporal element.
     double precision, dimension(:), allocatable :: vect_gpt ! total vector of gauss points in time.
     !double precision, dimension(:,:), allocatable :: gauss_t ! points and weight matrix.
     integer :: ngpt = 4
     integer :: Tngpt ! Total gauss points in time.
     character(len = 50) :: Tmethod = "Lagrange" !"Linear" ! Lagrange or Hermite
     integer :: Nsft  ! Number of shape functions in time.
     !integer :: Nsft = 2  ! Number of shape functions in time.

     ! Boundary conditions:
     double precision, dimension(:), allocatable :: ud ! imposed displacement vector.
     double precision, dimension(:), allocatable :: udNR ! imposed displacement vector.

  end type Input

  type(Input) :: I

contains

  ! Maybe constructor
  subroutine Input_assign()

    ! Newton Raphson parameters:
    !I%NR_error_min = 1e-4 ! norm of the residual equilibrium.
    !I%beta = 1/6
    !I%gamma = 1/2
    I%ntNR = I%NT + 1 ! Newton Raphson temporal nodes.

    if (I%Tmethod .eq. "Linear") then
      I%Nsft = 2
      I%ntc = I%NT + 1
    else if ( I%Tmethod .eq. "Lagrange" ) then ! Lagrange
      I%Nsft = 3
      I%ntc = I%NT*(2) + 1
    else ! Hermite
      I%Nsft = 4
      I%ntc = 2*(I%NT-1) + 4
    end if

    ! Construction and assign of the left variables:
    I%ks = (1/((I%K)**I%np))

    I%dx = I%L/I%Nx
    I%A = I%d1*I%d2
    I%Hooke = I%E  ! Only true for 1D case.

    I%Tngpt = I%NT*I%ngpt   ! Total number of integration points in time.
    I%Tngps = I%Nx*I%ngps   ! Total number of integration points in space.
    I%dt = (I%Tend - I%Ti)/I%NT

    I%n = I%Nx + 1
    I%ns = I%n - 2

    !allocate ( I%t(I%ndt) ) = linspace(I%Ti,I%Te,I%ndt)
    I%vect_gpt = linspace(I%Ti,I%Tend,I%Tngpt)
    I%t = linspace(I%Ti,I%Tend,I%nt)
    !I%ud = (I%t/I%Tend)*(I%sig_factor)*sin(2*I%pi*I%t)
    I%ud = (I%sig_factor)*sin(2*I%pi*I%vect_gpt)
    I%udNR = (I%sig_factor)*sin(2*I%pi*I%t)
    !allocate ( I%ud(I%ndt) ) = (/(i, i=0,I%Tend, I%ndt)/)

  end subroutine Input_assign

end module Structure


c     Subroutine to find integer stats
c     AJ_Kettle, Nov16/2017

      SUBROUTINE find_statf_ei_hour2(l_mlent,l_datalines,f_vec_data,
     +  f_ndflag,
     +  f_stat_data_ngd,f_stat_data_nbd,
     +  f_stat_data_avg,
     +  f_stat_data_min,f_stat_data_max)

      IMPLICIT NONE
c************************************************************************
c     Declare variables

      INTEGER             :: l_datalines
      INTEGER             :: l_mlent
      REAL                :: f_vec_data(l_mlent)

      INTEGER             :: i,j,k,ii,jj,kk

      REAL                :: f_stat_data_ngd
      REAL                :: f_stat_data_nbd
      REAL                :: f_stat_data_avg
      REAL                :: f_stat_data_min
      REAL                :: f_stat_data_max

      REAL                :: f_accum1
      REAL                :: f_accum2

      REAL                :: f_ndflag
c************************************************************************
      ii=0
      jj=0
      f_accum1=0.0
      f_accum2=0.0
      f_stat_data_min=10000
      f_stat_data_max=-10000

      DO i=1,l_datalines
       IF (f_vec_data(i).NE.f_ndflag) THEN
        ii=ii+1
        f_accum1=f_accum1+f_vec_data(i)
        f_accum2=f_accum2+1.0
        f_stat_data_min=MIN(f_stat_data_min,f_vec_data(i))
        f_stat_data_max=MAX(f_stat_data_max,f_vec_data(i))
       ENDIF
       IF (f_vec_data(i).LT.0.0) THEN
        jj=jj+1
       ENDIF
      ENDDO

      f_stat_data_avg=f_accum1/f_accum2
      f_stat_data_ngd=FLOAT(ii)
      f_stat_data_nbd=FLOAT(jj)
c************************************************************************
      RETURN
      END


      SUBROUTINE MB03JZ( COMPQ, N, A, LDA, D, LDD, B, LDB, F, LDF, Q,
     $                   LDQ, NEIG, TOL, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To move the eigenvalues with strictly negative real parts of an
C     N-by-N complex skew-Hamiltonian/Hamiltonian pencil aS - bH in
C     structured Schur form to the leading principal subpencil, while
C     keeping the triangular form. On entry, we have
C
C           (  A  D  )      (  B  F  )
C       S = (        ), H = (        ),
C           (  0  A' )      (  0 -B' )
C
C     where A and B are upper triangular.
C     S and H are transformed by a unitary matrix Q such that
C
C                            (  Aout  Dout  )
C       Sout = J Q' J' S Q = (              ), and
C                            (    0   Aout' )
C                                                                    (1)
C                            (  Bout  Fout  )           (  0  I  )
C       Hout = J Q' J' H Q = (              ), with J = (        ),
C                            (    0  -Bout' )           ( -I  0  )
C
C     where Aout and Bout remain in upper triangular form. The notation
C     M' denotes the conjugate transpose of the matrix M.
C     Optionally, if COMPQ = 'I' or COMPQ = 'U', the unitary matrix Q
C     that fulfills (1) is computed.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPQ   CHARACTER*1
C             Specifies whether or not the unitary transformations
C             should be accumulated in the array Q, as follows:
C             = 'N':  Q is not computed;
C             = 'I':  the array Q is initialized internally to the unit
C                     matrix, and the unitary matrix Q is returned;
C             = 'U':  the array Q contains a unitary matrix Q0 on
C                     entry, and the matrix Q0*Q is returned, where Q
C                     is the product of the unitary transformations
C                     that are applied to the pencil aS - bH to reorder
C                     the eigenvalues.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the pencil aS - bH.  N >= 0, even.
C
C     A       (input/output) COMPLEX*16 array, dimension (LDA, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular matrix A.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Aout.
C             The strictly lower triangular part of this array is not
C             referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1, N/2).
C
C     D       (input/output) COMPLEX*16 array, dimension (LDD, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular part of the skew-Hermitian
C             matrix D.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Dout.
C             The strictly lower triangular part of this array is not
C             referenced.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= MAX(1, N/2).
C
C     B       (input/output) COMPLEX*16 array, dimension (LDB, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular matrix B.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Bout.
C             The strictly lower triangular part of this array is not
C             referenced.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1, N/2).
C
C     F       (input/output) COMPLEX*16 array, dimension (LDF, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular part of the Hermitian matrix
C             F.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Fout.
C             The strictly lower triangular part of this array is not
C             referenced.
C
C     LDF     INTEGER
C             The leading dimension of the array F.  LDF >= MAX(1, N/2).
C
C     Q       (input/output) COMPLEX*16 array, dimension (LDQ, N)
C             On entry, if COMPQ = 'U', then the leading N-by-N part of
C             this array must contain a given matrix Q0, and on exit,
C             the leading N-by-N part of this array contains the product
C             of the input matrix Q0 and the transformation matrix Q
C             used to transform the matrices S and H.
C             On exit, if COMPQ = 'I', then the leading N-by-N part of
C             this array contains the unitary transformation matrix Q.
C             If COMPQ = 'N' this array is not referenced.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.
C             LDQ >= 1,         if COMPQ = 'N';
C             LDQ >= MAX(1, N), if COMPQ = 'I' or COMPQ = 'U'.
C
C     NEIG    (output) INTEGER
C             The number of eigenvalues in aS - bH with strictly
C             negative real part.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance used to decide the sign of the eigenvalues.
C             If the user sets TOL > 0, then the given value of TOL is
C             used. If the user sets TOL <= 0, then an implicitly
C             computed, default tolerance, defined by MIN(N,10)*EPS, is
C             used instead, where EPS is the machine precision (see
C             LAPACK Library routine DLAMCH). A larger value might be
C             needed for pencils with multiple eigenvalues.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: succesful exit;
C             < 0: if INFO = -i, the i-th argument had an illegal value.
C
C     METHOD
C
C     The algorithm reorders the eigenvalues like the following scheme:
C
C     Step 1: Reorder the eigenvalues in the subpencil aA - bB.
C          I. Reorder the eigenvalues with negative real parts to the
C             top.
C         II. Reorder the eigenvalues with positive real parts to the
C             bottom.
C
C     Step 2: Reorder the remaining eigenvalues with negative real parts.
C          I. Exchange the eigenvalues between the last diagonal block
C             in aA - bB and the last diagonal block in aS - bH.
C         II. Move the eigenvalues in the N/2-th place to the (MM+1)-th
C             place, where MM denotes the current number of eigenvalues
C             with negative real parts in aA - bB.
C
C     The algorithm uses a sequence of unitary transformations as
C     described on page 43 in [1]. To achieve those transformations the
C     elementary SLICOT Library subroutines MB03DZ and MB03HZ are called
C     for the corresponding matrix structures.
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
C         Numerical Computation of Deflating Subspaces of Embedded
C         Hamiltonian Pencils.
C         Tech. Rep. SFB393/99-15, Technical University Chemnitz,
C         Germany, June 1999.
C
C     NUMERICAL ASPECTS
C                                                               3
C     The algorithm is numerically backward stable and needs O(N )
C     complex floating point operations.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, April 6, 2009.
C     V. Sima, Aug. 2009 (SLICOT version of the routine ZHAUNX).
C
C     REVISIONS
C
C     V. Sima, Dec. 2010, Jan. 2011.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Eigenvalue reordering, upper triangular matrix,
C     skew-Hamiltonian/Hamiltonian pencil, structured Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, TEN
      PARAMETER          ( ZERO = 0.0D+0, TEN = 1.0D+1 )
      COMPLEX*16         CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ), CONE = ( 1.0D+0,
     $                     0.0D+0 ) )
C
C     .. Scalar Arguments ..
      CHARACTER          COMPQ
      INTEGER            INFO, LDA, LDB, LDD, LDF, LDQ, N, NEIG
      DOUBLE PRECISION   TOL
C
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), B( LDB, * ), D( LDD, * ),
     $                   F( LDF, * ), Q( LDQ, * )
C
C     .. Local Scalars ..
      LOGICAL            LCMPQ, LINIQ, LUPDQ
      INTEGER            IUPD, J, K, M, MM, MP, UPDS
      DOUBLE PRECISION   CO1, CO2, EPS
      COMPLEX*16         CJF, SI1, SI2, TMP
C
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, LSAME
C
C     .. External Subroutines ..
      EXTERNAL           MB03DZ, MB03HZ, XERBLA, ZLASET, ZROT
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, CONJG, DBLE, IMAG, MAX, MIN, MOD
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C
      M     = N/2
      NEIG  = 0
      LINIQ = LSAME( COMPQ, 'I' )
      LUPDQ = LSAME( COMPQ, 'U' )
      LCMPQ = LINIQ .OR. LUPDQ
C
C     Test the input arguments.
C
      INFO = 0
      IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
         INFO = -8
      ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N ) ) THEN
         INFO = -12
      END IF
      IF( INFO.NE.0) THEN
         CALL XERBLA( 'MB03JZ', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
      EPS = TOL
      IF ( EPS.LE.ZERO ) THEN
C
C        Use the default tolerance.
C
         EPS = MIN( DBLE( N ), TEN )*DLAMCH( 'Precision' )
      END IF
C
C     STEP 0. Initializations.
C
      IF( LINIQ ) THEN
         IUPD = M + 1
         UPDS = M
         CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
      ELSE IF( LUPDQ ) THEN
         IUPD = 1
         UPDS = N
      END IF
C
C     STEP 1. Reorder the eigenvalues in the subpencil aA - bB.
C
      MM = 0
      MP = M + 1
C
C     I. Reorder the eigenvalues with negative real parts to the top.
C
      DO 20 K = 1, M
         IF( DBLE( A( K, K ) )*DBLE( B( K, K ) ) +
     $       IMAG( A( K, K ) )*IMAG( B( K, K ) ).LT.
     $       -ABS( A( K, K ) )*ABS(  B( K, K ) )*EPS ) THEN
C
            DO 10 J = K - 1, MM + 1, -1
C
C              Perform eigenvalue exchange.
C
               CALL MB03DZ( A( J, J ), LDA, B( J, J ), LDB, CO1, SI1,
     $                      CO2, SI2 )
C
C              Update A and D.
C
               CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 )
               A( J, J )     = CO2*A( J, J ) +
     $                         SI2*A( J+1, J+1 )*CONJG( SI1 )
               A( J+1, J+1 ) = CO1*A( J+1, J+1 )
               CALL ZROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA,
     $                    CO2, -SI2 )
C
               CJF = -CONJG( D( J, J+1 ) )
               TMP = CO2*CJF - CONJG( SI2 )*D( J+1, J+1 )
               CALL ZROT( J, D( 1, J+1 ), 1, D( 1, J ), 1, CO2, SI2 )
               D( J, J )     = CO2*D( J, J )     - SI2*TMP
               D( J+1, J+1 ) = CO2*D( J+1, J+1 ) + SI2*CJF
               CALL ZROT( M-J, D( J, J+1 ), LDD, D( J+1, J+1 ), LDD,
     $                    CO2, -SI2 )
C
C              Update B and F.
C
               CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 )
               B( J, J )     = CO2*B( J, J ) +
     $                         SI2*B( J+1, J+1 )*CONJG( SI1 )
               B( J+1, J+1 ) = CO1*B( J+1, J+1 )
               CALL ZROT( M-J, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB,
     $                    CO2, -SI2 )
C
               CJF = CONJG( F( J, J+1 ) )
               TMP = CO2*CJF - CONJG( SI2 )*F( J+1, J+1 )
               CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO2, SI2 )
               F( J, J )     = CO2*F( J, J )     - SI2*TMP
               F( J+1, J+1 ) = CO2*F( J+1, J+1 ) + SI2*CJF
               CALL ZROT( M-J, F( J, J+1 ), LDF, F( J+1, J+1 ), LDF,
     $                    CO2, -SI2 )
C
               IF( LCMPQ ) THEN
C
C                 Update Q.
C
                  CALL ZROT( UPDS, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1,
     $                       SI1 )
                  CALL ZROT( UPDS, Q( IUPD, M+J+1 ), 1, Q( IUPD, M+J ),
     $                       1, CO2, SI2 )
               END IF
   10       CONTINUE
            MM = MM + 1
         END IF
   20 CONTINUE
C
C     II. Reorder the eigenvalues with positive real parts to the bottom.
C
      DO 40 K = M, MM + 1, -1
         IF( DBLE( A( K, K ) )*DBLE( B( K, K ) ) +
     $       IMAG( A( K, K ) )*IMAG( B( K, K ) ).GT.
     $        ABS( A( K, K ) )*ABS(  B( K, K ) )*EPS ) THEN
C
            DO 30 J = K, MP - 2
C
C              Perform eigenvalue exchange.
C
               CALL MB03DZ( A( J, J ), LDA, B( J, J ), LDB, CO1, SI1,
     $                      CO2, SI2 )
C
C              Update A and D.
C
               CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 )
               A( J, J )     = CO2*A( J, J ) +
     $                         SI2*A( J+1, J+1 )*CONJG( SI1 )
               A( J+1, J+1 ) = CO1*A( J+1, J+1 )
               CALL ZROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA,
     $                    CO2, -SI2 )
C
               CJF = -CONJG( D( J, J+1 ) )
               TMP = CO2*CJF - CONJG( SI2 )*D( J+1, J+1 )
               CALL ZROT( J, D( 1, J+1 ), 1, D( 1, J ), 1, CO2, SI2 )
               D( J, J )     = CO2*D( J, J )     - SI2*TMP
               D( J+1, J+1 ) = CO2*D( J+1, J+1 ) + SI2*CJF
               CALL ZROT( M-J, D( J, J+1 ), LDD, D( J+1, J+1 ), LDD,
     $                    CO2, -SI2 )
C
C              Update B and F.
C
               CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 )
               B( J, J )     = CO2*B( J, J ) +
     $                         SI2*B( J+1, J+1 )*CONJG( SI1 )
               B( J+1, J+1 ) = CO1*B( J+1, J+1 )
               CALL ZROT( M-J, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB,
     $                    CO2, -SI2 )
C
               CJF = CONJG( F( J, J+1 ) )
               TMP = CO2*CJF - CONJG( SI2 )*F( J+1, J+1 )
               CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO2, SI2 )
               F( J, J )     = CO2*F( J, J )     - SI2*TMP
               F( J+1, J+1 ) = CO2*F( J+1, J+1 ) + SI2*CJF
               CALL ZROT( M-J, F( J, J+1 ), LDF, F( J+1, J+1 ), LDF,
     $                    CO2, -SI2 )
C
               IF( LCMPQ ) THEN
C
C                 Update Q.
C
                  CALL ZROT( UPDS, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1,
     $                       SI1 )
                  CALL ZROT( UPDS, Q( IUPD, M+J+1 ), 1, Q( IUPD, M+J ),
     $                       1, CO2, SI2 )
               END IF
   30       CONTINUE
            MP = MP - 1
         END IF
   40 CONTINUE
C
C     The remaining M-MP+1 eigenvalues with negative real part are now in
C     the bottom right subpencil of aS - bH.
C
C     STEP 2. Reorder the remaining M-MP+1 eigenvalues.
C
      DO 60 K = M, MP, -1
C
C        I. Exchange the eigenvalues between two diagonal blocks.
C
C        Perform eigenvalue exchange.
C
         CALL MB03HZ( A( M, M ), D( M, M ), B( M, M ), F( M, M ), CO1,
     $                SI1 )
C
C        Update A and D.
C
         TMP = CONJG( A( M, M ) )
         CALL ZROT( M, D( 1, M ), 1, A( 1, M ), 1, CO1, SI1 )
         A( M, M ) = A( M, M )*CO1 + TMP*CONJG( SI1 )**2
         D( M, M ) = D( M, M )*CO1 - TMP*CONJG( SI1 )*CO1
C
C        Update B and F.
C
         TMP = -CONJG( B( M, M ) )
         CALL ZROT( M, F( 1, M ), 1, B( 1, M ), 1, CO1, SI1 )
         B( M, M ) = B( M, M )*CO1 + TMP*CONJG( SI1 )**2
         F( M, M ) = F( M, M )*CO1 - TMP*CONJG( SI1 )*CO1
C
         IF( LCMPQ ) THEN
C
C           Update Q.
C
            CALL ZROT( N, Q( 1, N ), 1, Q( 1, M ), 1, CO1, SI1 )
         END IF
C
C        II. Move the eigenvalue in the M-th diagonal position to the
C            (MM+1)-th position.
C
         MM = MM + 1
         DO 50 J = M - 1, MM, -1
C
C           Perform eigenvalue exchange.
C
            CALL MB03DZ( A( J, J ), LDA, B( J, J ), LDB, CO1, SI1, CO2,
     $                   SI2 )
C
C           Update A and D.
C
            CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 )
            A( J, J )     = CO2*A( J, J ) +
     $                      SI2*A( J+1, J+1 )*CONJG( SI1 )
            A( J+1, J+1 ) = CO1*A( J+1, J+1 )
            CALL ZROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA, CO2,
     $                 -SI2 )
C
            CJF = -CONJG( D( J, J+1 ) )
            TMP = CO2*CJF - CONJG( SI2 )*D( J+1, J+1 )
            CALL ZROT( J, D( 1, J+1 ), 1, D( 1, J ), 1, CO2, SI2 )
            D( J, J )     = CO2*D( J, J )     - SI2*TMP
            D( J+1, J+1 ) = CO2*D( J+1, J+1 ) + SI2*CJF
            CALL ZROT( M-J, D( J, J+1 ), LDD, D( J+1, J+1 ), LDD, CO2,
     $                 -SI2 )
C
C           Update B and F.
C
            CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 )
            B( J, J )     = CO2*B( J, J ) +
     $                      SI2*B( J+1, J+1 )*CONJG( SI1 )
            B( J+1, J+1 ) = CO1*B( J+1, J+1 )
            CALL ZROT( M-J, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB, CO2,
     $                 -SI2 )
C
            CJF = CONJG( F( J, J+1 ) )
            TMP = CO2*CJF - CONJG( SI2 )*F( J+1, J+1 )
            CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO2, SI2 )
            F( J, J )     = CO2*F( J, J )     - SI2*TMP
            F( J+1, J+1 ) = CO2*F( J+1, J+1 ) + SI2*CJF
            CALL ZROT( M-J, F( J, J+1 ), LDF, F( J+1, J+1 ), LDF, CO2,
     $                 -SI2 )
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C
               CALL ZROT( N, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1, SI1 )
               CALL ZROT( N, Q( 1, M+J+1 ), 1, Q( 1, M+J ), 1, CO2, SI2
     $                     )
            END IF
   50    CONTINUE
   60 CONTINUE
C
      NEIG = MM
C
      RETURN
C *** Last line of MB03JZ ***
      END


! Anantua 2019 semianalytic jet model
! Check conversion to cgs units!

module fluid_model_rrjet

      use class_four_vector
      use interpolate, only: interp
      use kerr, only: kerr_metric, calc_u0
      use phys_constants, only: pi, c2, m
      implicit none

      namelist /fluiddata/ betaeconst, ximax

      real :: betaeconst, ximax

      interface init_rrjet
        module procedure init_rrjet
      end interface

      interface rrjet_vals
        module procedure rrjet_vals
      end interface

      contains

        subroutine rrjet_vals(x0,a,rho,p,b,u,bmag)
        type (four_Vector), intent(in), dimension(:) :: x0
        real, intent(in) :: a
        real(kind=8), dimension(size(x0)) :: done
        real, dimension(size(x0)) :: x2,x1,zm,zr,theta,s,z,logz,xi,fone
        real, dimension(size(x0)) :: omega, phi, phiprime, current, Bs, Bz, Bphi,Vs,Vz,Vphi,V0z,Vr,Vth,Br,Bth
        real, dimension(size(x0)) ::  u0,b0,vpl0,vrl0,vtl0,p0,rho0,bph0,bth0,rd,td,dzero,vr0,vth0,vph0,dummy
        real(8), dimension(size(x0),10) :: metric
        integer :: npts,nx1,nx2
        real, dimension(size(x0)), intent(out) :: rho,p,bmag
        type (four_Vector), intent(out), dimension(size(x0)) :: u,b

!        write(6,*) 'rrjet: ',size(x0)
        dzero=0d0; done=1d0; fone=1.;

        ! Get spherical coordinates
        npts=size(x0)
        theta=x0%data(3)
        zm=cos(theta)

        ! Jet solution is symmetric about xy plane
        ! ANDREW ?? -- is this ok?
        x2=acos(abs(zm)); theta=x2
        zr=x0%data(2)

        ! Get cylindrical coordinates
        s = zr*sin(theta)
        z = zr*cos(theta)
        xi = s*s / z
        where(z.eq.0)
          xi=1.e10
        endwhere

        ! Get magnetic flux, fluid line angular velocity, and current
        omega = 0.15*exp(-0.3*xi*xi)
        phi = tanh(0.3*xi)
        phiprime = 0.3*(1.- phi*phi)
        current = -2.*xi*omega*phiprime

        ! Get the B-field vector in cylindrical coordinates
        ! !AC - in dimensionless units, the flux through the horizon is 1
        ! !AC - we convert to physical units in  convert_fluidvars_rrjet in fluid.f90
        Bs = 1.02e4 * s * phiprime / (2.*pi*z*z)
        Bz = 1.02e4 * phiprime / (pi*z)
        !Bz = 1.02e4 * phiprime / (2.*pi*z)
        Bphi = 1.02e4 * current / (2*pi*s)
        Bphi = Bphi / s !AC -- put in coordinate basis

        ! Get the three-velocity in cylindrical coordinates
        logz = log10(z)
        V0z = -1.2 + 2.2*tanh(0.84*logz)
        Vz = V0z * exp(-0.001 * xi**4)
        Vs = s*Vz / (2.* z)
        Vphi = s*omega*(1.-Vz)
        Vphi = Vphi / s !AC -- put in coordinate basis

        ! Transform the velocity and B-field to spherical coordinates
        Br = s*Bs/zr + z*Bz/zr
        Bth = z*Bs/(zr*zr) - s*Bz/(zr*zr)
        Vr = s*Vs/zr + z*Vz/zr
        Vth = z*Vs/(zr*zr) - s*Vz/(zr*zr)

        ! Find the timelike u0 and convert V -> u
        metric = kerr_metric(zr,real(x0%data(3)),a)
        u0 = calc_u0(metric,dble(Vr),dble(Vth),dble(Vphi))

        u%data(1)=u0
        u%data(2)=Vr*u0
        u%data(3)=Vth*u0
        u%data(4)=Vphi*u0
        call assign_metric(u,transpose(kerr_metric(zr,real(x0%data(3)),a)))

        ! Find b0 and convert B -> b
        b%data(1)=dzero
        b%data(2)=Br
        b%data(3)=Bth
        b%data(4)=Bphi
        call assign_metric(b,transpose(kerr_metric(zr,real(x0%data(3)),a)))

        b0 = b*u

        b%data(1)=b0
        b%data(2)=(Br + b0*u%data(2))/u0
        b%data(3)=(Bth + b0*u%data(3))/u0
        b%data(4)=(Bphi + b0*u%data(4))/u0
        !b%data(2)=u0*(Br + b0*u%data(2))
        !b%data(3)=u0*(Bth + b0*u%data(3))
        !b%data(4)=u0*(Bphi + b0*u%data(4))

        ! Protect azimuthal velocities at poles
        ! Compute magnitude of interpolated b-field
        ! and force b^2 > 0 (need to look into numerical issues here):
        call assign_metric(b,transpose(kerr_metric(zr,real(x0%data(3)),a)))
        bmag=b*b;
        bmag=merge(bmag,dzero,bmag.ge.0d0)
        bmag=sqrt(bmag)
!        write(6,*) 'maxr: ',maxval(uniqr),maxval(zr)
!        write(6,*) 'bmag: ',maxval(bmag),minval(bmag)
!        write(6,*) 'bmag: ',bmag

        ! Find the nonthermal electron pressure (betae * magnetic pressure)
        p = 0.5 * betaeconst * (bmag*bmag) !/ (8*pi)
        rho = p ! Convert pressure to number density in  convert_fluidvars_rrjet using emis params

        ! Zero everything where xi>ximax and z<2
        where((xi.gt.ximax).or.(abs(z).le.2d0))
           !u%data(1) = dzero;
           !u%data(2) = dzero;
           !u%data(3) = dzero;
           !u%data(4) = dzero;
           !b%data(1) = dzero;
           !b%data(2) = dzero;
           !b%data(3) = dzero;
           !b%data(4) = dzero;
           rho = dzero;
           bmag=dzero;
           p=dzero;
        endwhere

        ! !AC Cut off emission from below the eq. plane:
        rho=merge(rho,rho*0.,zm.ge.0)
        p = merge(p,p*0.,zm.ge.0)
        end subroutine rrjet_vals

        subroutine init_rrjet(betaeconst0, ximax0)
        !character(len=20), intent(in) :: ifile
        !open(unit=8,file=ifile,form='formatted',status='old')
          !read(8,nml=fluiddata)
          real(8), intent(in) :: betaeconst0,  ximax0
          betaeconst = betaeconst0
          ximax=ximax0
        write(6,*) 'read: ',betaeconst,ximax
        close(unit=8)
        end subroutine init_rrjet

      end module fluid_model_rrjet


      SUBROUTINE MB03BB( BASE, LGBAS, ULP, K, AMAP, S, SINV, A, LDA1,
     $                   LDA2, ALPHAR, ALPHAI, BETA, SCAL, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the eigenvalues of a general 2-by-2 matrix product via
C     a complex single shifted periodic QZ algorithm.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     BASE    (input)  DOUBLE PRECISION
C             Machine base.
C
C     LGBAS   (input)  DOUBLE PRECISION
C             Logarithm of BASE.
C
C     ULP     (input)  DOUBLE PRECISION
C             Machine precision.
C
C     K       (input)  INTEGER
C             The number of factors.  K >= 1.
C
C     AMAP    (input) INTEGER array, dimension (K)
C             The map for accessing the factors, i.e., if AMAP(I) = J,
C             then the factor A_I is stored at the J-th position in A.
C
C     S       (input)  INTEGER array, dimension (K)
C             The signature array. Each entry of S must be 1 or -1.
C
C     SINV    (input) INTEGER
C             Signature multiplier. Entries of S are virtually
C             multiplied by SINV.
C
C     A       (input)  DOUBLE PRECISION array, dimension (LDA1,LDA2,K)
C             On entry, the leading 2-by-2-by-K part of this array must
C             contain a 2-by-2 product (implicitly represented by its K
C             factors) in upper Hessenberg-triangular form.
C
C     LDA1    INTEGER
C             The first leading dimension of the array A.  LDA1 >= 2.
C
C     LDA2    INTEGER
C             The second leading dimension of the array A.  LDA2 >= 2.
C
C     ALPHAR  (output)  DOUBLE PRECISION array, dimension (2)
C             On exit, this array contains the scaled real part of the
C             two eigenvalues. If BETA(I) <> 0, then the I-th eigenvalue
C             (I = 1 : 2) is given by
C                 (ALPHAR(I) + ALPHAI(I)*SQRT(-1) ) * (BASE)**SCAL(I).
C
C     ALPHAI  (output)  DOUBLE PRECISION array, dimension (2)
C             On exit, this array contains the scaled imaginary part of
C             the two eigenvalues. ALPHAI(1) >= 0.
C
C     BETA    (output)  DOUBLE PRECISION array, dimension (2)
C             On exit, this array contains information about infinite
C             eigenvalues. If BETA(I) = 0, then the I-th eigenvalue is
C             infinite. Otherwise, BETA(I) = 1.0.
C
C     SCAL    (output)  INTEGER array, dimension (2)
C             On exit, this array contains the scaling exponents for the
C             two eigenvalues.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (8*K)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             = 1:  the periodic QZ algorithm did not converge;
C             = 2:  the computed eigenvalues might be inaccurate.
C                   Both values might be taken as warnings, since
C                   approximations of eigenvalues are returned.
C
C     METHOD
C
C     A complex single shifted periodic QZ iteration is applied.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, June 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     July 2009, SLICOT Library version of the routine PLACP2.
C     V. Sima, June 2010, July 2010, Aug. 2011, Sep. 2011, Oct. 2011.
C
C     KEYWORDS
C
C     Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal
C     transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      COMPLEX*16        CZERO, CONE
      PARAMETER         ( CZERO = ( 0.0D0, 0.0D0 ),
     $                    CONE  = ( 1.0D0, 0.0D0 ) )
      DOUBLE PRECISION  ZERO, ONE, TWO
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, K, LDA1, LDA2, SINV
      DOUBLE PRECISION  BASE, LGBAS, ULP
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA1,LDA2,*), ALPHAI(2), ALPHAR(2), BETA(2),
     $                  DWORK(*)
      INTEGER           AMAP(*), S(*), SCAL(2)
C     .. Local Scalars ..
      INTEGER           AI, I, IITER, J, PDM, PDW, SL
      DOUBLE PRECISION  CS, CST, LHS, MISC, MISR, RHS, TEMPI, TEMPR
      COMPLEX*16        SN, SNT, TEMP
C     .. Local Arrays ..
      COMPLEX*16        T(2,2), Z(3,3)
C     .. External Functions ..
      DOUBLE PRECISION  DLAPY2
      EXTERNAL          DLAPY2
C     .. External Subroutines ..
      EXTERNAL          DLADIV, ZLARTG, ZROT
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DCMPLX, DCONJG, DBLE, DIMAG, DREAL, INT,
     $                  LOG, MAX, MIN, MOD, SQRT
C
C     .. Executable Statements ..
C
C     Apply a complex single shifted periodic QZ iteration.
C     This might not be efficient but it seems to be reliable.
C
      INFO = 0
      PDW  = 0
C
      DO 10 I = 1, K
         AI = AMAP(I)
         DWORK(PDW+1) = A(1,1,AI)
         DWORK(PDW+2) = ZERO
         DWORK(PDW+3) = A(2,1,AI)
         DWORK(PDW+4) = ZERO
         DWORK(PDW+5) = A(1,2,AI)
         DWORK(PDW+6) = ZERO
         DWORK(PDW+7) = A(2,2,AI)
         DWORK(PDW+8) = ZERO
         PDW = PDW + 8
   10 CONTINUE
C
      PDM = PDW
C
      DO 40  IITER = 1, 80
C
C        Test for deflation.
C
         LHS = DLAPY2( DWORK(3), DWORK(4) )
         RHS = MAX( DLAPY2( DWORK(1), DWORK(2) ),
     $              DLAPY2( DWORK(7), DWORK(8) ) )
         IF ( RHS.EQ.ZERO )
     $      RHS = DLAPY2( DWORK(5), DWORK(6) )
         IF ( LHS.LE.ULP*RHS )
     $      GO TO 50
C
C        Start Iteration.
C
         IF ( IITER.EQ.1 ) THEN
C
C           Compute a randomly chosen initial unitary shift.
C
            CALL ZLARTG( DCMPLX( ONE, -TWO ), DCMPLX( TWO, TWO ), CS,
     $                   SN, TEMP )
         ELSE IF ( MOD( IITER, 40 ).EQ.0 ) THEN
C
C           Ad hoc shift.
C
            CALL ZLARTG( DCMPLX( DBLE( I ), ONE ), DCMPLX( ONE, -TWO ),
     $                   CS, SN, TEMP )
         ELSE
C
C           Compute the shift by a product QR decomposition.
C
            CS = ONE
            SN = CZERO
            CALL ZLARTG( CONE, CONE, CST, SNT, TEMP )
            PDW = PDM
C
            DO 20  I = K, 2, -1
               PDW = PDW - 8
               TEMP = DCMPLX( DWORK(PDW+1), DWORK(PDW+2) )
               Z(1,1) = TEMP
               Z(2,1) = CZERO
               Z(3,1) = CZERO
               Z(1,2) = CZERO
               Z(2,2) = TEMP
               Z(3,2) = DCMPLX( DWORK(PDW+3), DWORK(PDW+4) )
               Z(1,3) = CZERO
               Z(2,3) = DCMPLX( DWORK(PDW+5), DWORK(PDW+6) )
               Z(3,3) = DCMPLX( DWORK(PDW+7), DWORK(PDW+8) )
               IF ( S(AMAP(I)).EQ.SINV ) THEN
                  CALL ZROT( 3, Z(1,1), 1, Z(1,3), 1, CST, DCONJG( SNT )
     $                      )
                  CALL ZROT( 3, Z(1,1), 1, Z(1,2), 1, CS,  DCONJG( SN )
     $                      )
                  CALL ZLARTG( Z(1,1), Z(3,1), CST, SNT, TEMP )
                  CALL ZLARTG( TEMP, Z(2,1), CS, SN, TEMP )
               ELSE
                  CALL ZROT( 3, Z(1,1), 3, Z(3,1), 3, CST, SNT )
                  CALL ZROT( 3, Z(1,1), 3, Z(2,1), 3, CS, SN )
                  TEMP = Z(3,3)
                  CALL ZLARTG( TEMP, Z(3,1), CST, SNT, Z(3,3) )
                  SNT = -SNT
                  CALL ZROT( 2, Z(1,1), 1, Z(1,3), 1, CST, DCONJG( SNT )
     $                      )
                  TEMP = Z(2,2)
                  CALL ZLARTG( TEMP, Z(2,1), CS, SN, Z(2,2) )
                  SN = -SN
               END IF
   20       CONTINUE
C
            PDW = 0
            Z(1,1) =  DCMPLX( DWORK(PDW+1), DWORK(PDW+2) )
            Z(2,1) =  DCMPLX( DWORK(PDW+3), DWORK(PDW+4) )
            Z(1,2) = -DCMPLX( DWORK(PDW+3), DWORK(PDW+4) )
            Z(2,2) =  CZERO
            Z(1,3) = -DCMPLX( DWORK(PDW+7), DWORK(PDW+8) )
            Z(2,3) =  CZERO
            CALL ZROT( 2, Z(1,1), 1, Z(1,3), 1, CST, DCONJG( SNT ) )
            CALL ZROT( 2, Z(1,1), 1, Z(1,2), 1, CS,  DCONJG( SN ) )
            CALL ZLARTG( Z(1,1), Z(2,1), CS, SN, TEMP )
         END IF
         CST = CS
         SNT = SN
         PDW = PDM
C
         DO 30 I = K, 2, -1
            PDW = PDW - 8
            T(1,1) = DCMPLX( DWORK(PDW+1), DWORK(PDW+2) )
            T(2,1) = DCMPLX( DWORK(PDW+3), DWORK(PDW+4) )
            T(1,2) = DCMPLX( DWORK(PDW+5), DWORK(PDW+6) )
            T(2,2) = DCMPLX( DWORK(PDW+7), DWORK(PDW+8) )
            IF ( S(AMAP(I)).EQ.SINV) THEN
               CALL ZROT( 2, T(1,1), 1, T(1,2), 1, CS, DCONJG( SN ) )
               TEMP = T(1,1)
               CALL ZLARTG( TEMP, T(2,1), CS, SN, T(1,1) )
               T(2,1) = CZERO
               CALL ZROT( 1, T(1,2), 2, T(2,2), 2, CS, SN )
            ELSE
               CALL ZROT( 2, T(1,1), 2, T(2,1), 2, CS, SN )
               TEMP = T(2,2)
               CALL ZLARTG( TEMP, T(2,1), CS, SN, T(2,2) )
               T(2,1) = CZERO
               SN = -SN
               CALL ZROT( 1, T(1,1), 1, T(1,2), 1, CS, DCONJG( SN ) )
            END IF
            DWORK(PDW+1) = DREAL( T(1,1) )
            DWORK(PDW+2) = DIMAG( T(1,1) )
            DWORK(PDW+3) = DREAL( T(2,1) )
            DWORK(PDW+4) = DIMAG( T(2,1) )
            DWORK(PDW+5) = DREAL( T(1,2) )
            DWORK(PDW+6) = DIMAG( T(1,2) )
            DWORK(PDW+7) = DREAL( T(2,2) )
            DWORK(PDW+8) = DIMAG( T(2,2) )
   30    CONTINUE
C
         PDW = 0
         T(1,1) = DCMPLX( DWORK(PDW+1), DWORK(PDW+2) )
         T(2,1) = DCMPLX( DWORK(PDW+3), DWORK(PDW+4) )
         T(1,2) = DCMPLX( DWORK(PDW+5), DWORK(PDW+6) )
         T(2,2) = DCMPLX( DWORK(PDW+7), DWORK(PDW+8) )
         CALL ZROT( 2, T(1,1), 2, T(2,1), 2, CST, SNT )
         CALL ZROT( 2, T(1,1), 1, T(1,2), 1, CS, DCONJG( SN ) )
         DWORK(PDW+1) = DREAL( T(1,1) )
         DWORK(PDW+2) = DIMAG( T(1,1) )
         DWORK(PDW+3) = DREAL( T(2,1) )
         DWORK(PDW+4) = DIMAG( T(2,1) )
         DWORK(PDW+5) = DREAL( T(1,2) )
         DWORK(PDW+6) = DIMAG( T(1,2) )
         DWORK(PDW+7) = DREAL( T(2,2) )
         DWORK(PDW+8) = DIMAG( T(2,2) )
   40 CONTINUE
C
C     Not converged. Set INFO = 1, but continue.
C
      INFO = 1
C
   50 CONTINUE
C
C     Converged.
C
      DO 70  J = 1, 2
         PDW = 0
         IF ( J.EQ.2 )
     $      PDW  = 6
         TEMPI   = ZERO
         TEMPR   = ONE
         BETA(J) = ONE
         SCAL(J) = 0
C
         DO 60  I = 1, K
            RHS = DLAPY2( DWORK(PDW+1), DWORK(PDW+2) )
            IF ( RHS.NE.ZERO ) THEN
               SL = INT( LOG( RHS ) / LGBAS )
               DWORK(PDW+1) = DWORK(PDW+1) / ( BASE**DBLE( SL ) )
               DWORK(PDW+2) = DWORK(PDW+2) / ( BASE**DBLE( SL ) )
            ELSE
               SL = 0
            END IF
            IF ( S(AMAP(I)).EQ.1 ) THEN
               LHS = TEMPI
               TEMPI = TEMPR*DWORK(PDW+2) + TEMPI*DWORK(PDW+1)
               TEMPR = TEMPR*DWORK(PDW+1) -   LHS*DWORK(PDW+2)
               SCAL(J) = SCAL(J) + SL
            ELSE IF ( RHS.EQ.ZERO ) THEN
               BETA(J) = ZERO
            ELSE
               LHS = TEMPR
               RHS = TEMPI
               CALL DLADIV( LHS, RHS, DWORK(PDW+1), DWORK(PDW+2),
     $                      TEMPR, TEMPI )
               SCAL(J) = SCAL(J) - SL
            END IF
            IF ( ( MOD( I, 10 ).EQ.0 ) .OR. ( I.EQ.K ) ) THEN
               RHS = DLAPY2( TEMPR, TEMPI )
               IF ( RHS.EQ.ZERO ) THEN
                  SCAL(J) = 0
               ELSE
                  SL = INT( LOG( RHS ) / LGBAS )
                  TEMPR = TEMPR / ( BASE**DBLE( SL ) )
                  TEMPI = TEMPI / ( BASE**DBLE( SL ) )
                  SCAL(J) = SCAL(J) + SL
               END IF
            END IF
            PDW = PDW + 8
   60    CONTINUE
C
         ALPHAR(J) = TEMPR
         ALPHAI(J) = TEMPI
   70 CONTINUE
C
      IF ( TEMPI.GT.ZERO ) THEN
         ALPHAR(2) = ALPHAR(1)
         ALPHAI(2) = ALPHAI(1)
         ALPHAR(1) = TEMPR
         ALPHAI(1) = TEMPI
         TEMPR     = BETA(2)
         BETA(2)   = BETA(1)
         BETA(1)   = TEMPR
         TEMPR     = SCAL(2)
         SCAL(2)   = SCAL(1)
         SCAL(1)   = TEMPR
      END IF
C
C     Enforce the needed eigenvalue structure for real matrices.
C
      IF ( ALPHAI(1).NE.ZERO .OR. ALPHAI(2).NE.ZERO ) THEN
C
C        Decide if there are two real or complex conjugate eigenvalues.
C
         IF ( SCAL(1).GE.SCAL(2) ) THEN
            SL    = SCAL(1) - SCAL(2)
            TEMPR = ALPHAR(2) / BASE**DBLE( SL )
            TEMPI = ALPHAI(2) / BASE**DBLE( SL )
            LHS   = ALPHAR(1) - TEMPR
            RHS   = ALPHAI(1) + TEMPI
            CST   = ALPHAI(1)
         ELSE
            SL    = SCAL(2) - SCAL(1)
            TEMPR = ALPHAR(1) / BASE**DBLE( SL )
            TEMPI = ALPHAI(1) / BASE**DBLE( SL )
            LHS   = ALPHAR(2) - TEMPR
            RHS   = ALPHAI(2) + TEMPI
            CST   = ALPHAI(2)
         END IF
C
         MISR = DLAPY2( CST, TEMPI )
         MISC = DLAPY2( LHS, RHS ) / TWO
C
         CS = MAX( DLAPY2( ALPHAR(1), ALPHAI(1) ), ONE,
     $             DLAPY2( ALPHAR(2), ALPHAI(2) ) )
         IF ( MIN( MISR, MISC ).GT.CS*SQRT( ULP ) )
     $      INFO = 2
C
         IF ( MISR.GT.MISC ) THEN
C
C           Conjugate eigenvalues.
C
            IF ( SCAL(1).GE.SCAL(2) ) THEN
               ALPHAR(1) =    ( ALPHAR(1) + TEMPR ) / TWO
               ALPHAI(1) = ABS( ALPHAI(1) - TEMPI ) / TWO
               SCAL(2)   = SCAL(1)
            ELSE
               ALPHAR(1) =    ( ALPHAR(2) + TEMPR ) / TWO
               ALPHAI(1) = ABS( ALPHAI(2) - TEMPI ) / TWO
               SCAL(1)   = SCAL(2)
            END IF
            ALPHAR(2) =  ALPHAR(1)
            ALPHAI(2) = -ALPHAI(1)
         ELSE
C
C           Two real eigenvalues.
C
            ALPHAI(1) = ZERO
            ALPHAI(2) = ZERO
         END IF
      END IF
C
      RETURN
C *** Last line of MB03BB ***
      END


      SUBROUTINE W3FS21(IDATE, NMIN)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:   W3FS21       NUMBER OF MINUTES SINCE JAN 1, 1978
C   PRGMMR: REJONES          ORG: NMC421     DATE: 89-07-17
C
C ABSTRACT: CALCULATES THE NUMBER OF MINUTES SINCE 0000,
C   1 JANUARY 1978.
C
C PROGRAM HISTORY LOG:
C   84-06-21  A. DESMARAIS
C   89-07-14  R.E.JONES    CONVERT TO CYBER 205 FORTRAN 200,
C                          CHANGE LOGIC SO IT WILL WORK IN
C                          21 CENTURY.
C   89-11-02  R.E.JONES    CONVERT TO CRAY CFT77 FORTRAN
C
C USAGE:    CALL W3FS21 (IDATE, NMIN)
C   INPUT ARGUMENT LIST:
C     IDATE    - INTEGER  SIZE 5 ARRAY CONTAINING YEAR OF CENTURY,
C                MONTH, DAY, HOUR AND MINUTE.  IDATE(1) MAY BE
C                A TWO DIGIT YEAR OR 4. IF 2 DIGITS AND GE THAN 78
C                1900 IS ADDED TO IT. IF LT 78 THEN 2000 IS ADDED
C                TO IT. IF 4 DIGITS THE SUBROUTINE WILL WORK
C                CORRECTLY TO THE YEAR 3300 A.D.
C
C   OUTPUT ARGUMENT LIST:
C     NMIN     - INTEGER NUMBER OF MINUTES SINCE 1 JANUARY 1978
C
C   SUBPROGRAMS CALLED:
C     LIBRARY:
C       W3LIB    - IW3JDN
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY Y-MP8/832
C
C$$$
C
      INTEGER  IDATE(5)
      INTEGER  NMIN
      INTEGER  JDN78
C
      DATA  JDN78 / 2443510 /
C
C***   IDATE(1)       YEAR OF CENTURY
C***   IDATE(2)       MONTH OF YEAR
C***   IDATE(3)       DAY OF MONTH
C***   IDATE(4)       HOUR OF DAY
C***   IDATE(5)       MINUTE OF HOUR
C
      NMIN  = 0
C
      IYEAR = IDATE(1)
C
      IF (IYEAR.LE.99) THEN
        IF (IYEAR.LT.78) THEN
          IYEAR = IYEAR + 2000
        ELSE
          IYEAR = IYEAR + 1900
        ENDIF
      ENDIF
C
C     COMPUTE JULIAN DAY NUMBER FROM YEAR, MONTH, DAY
C
      IJDN  = IW3JDN(IYEAR,IDATE(2),IDATE(3))
C
C     SUBTRACT JULIAN DAY NUMBER OF JAN 1,1978 TO GET THE
C     NUMBER OF DAYS BETWEEN DATES
C
      NDAYS = IJDN - JDN78
C
C***  NUMBER OF MINUTES
C
      NMIN = NDAYS * 1440 + IDATE(4) * 60 + IDATE(5)
C
      RETURN
      END