!*==zggesx.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  ZGGESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZGGESX + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA,
!                          B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR,
!                          LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK,
!                          IWORK, LIWORK, BWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBVSL, JOBVSR, SENSE, SORT
!       INTEGER            INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N,
!      $                   SDIM
!       ..
!       .. Array Arguments ..
!       LOGICAL            BWORK( * )
!       INTEGER            IWORK( * )
!       DOUBLE PRECISION   RCONDE( 2 ), RCONDV( 2 ), RWORK( * )
!       COMPLEX*16         A( LDA, * ), ALPHA( * ), B( LDB, * ),
!      $                   BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ),
!      $                   WORK( * )
!       ..
!       .. Function Arguments ..
!       LOGICAL            SELCTG
!       EXTERNAL           SELCTG
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZGGESX computes for a pair of N-by-N complex nonsymmetric matrices
!> (A,B), the generalized eigenvalues, the complex Schur form (S,T),
!> and, optionally, the left and/or right matrices of Schur vectors (VSL
!> and VSR).  This gives the generalized Schur factorization
!>
!>      (A,B) = ( (VSL) S (VSR)**H, (VSL) T (VSR)**H )
!>
!> where (VSR)**H is the conjugate-transpose of VSR.
!>
!> Optionally, it also orders the eigenvalues so that a selected cluster
!> of eigenvalues appears in the leading diagonal blocks of the upper
!> triangular matrix S and the upper triangular matrix T; computes
!> a reciprocal condition number for the average of the selected
!> eigenvalues (RCONDE); and computes a reciprocal condition number for
!> the right and left deflating subspaces corresponding to the selected
!> eigenvalues (RCONDV). The leading columns of VSL and VSR then form
!> an orthonormal basis for the corresponding left and right eigenspaces
!> (deflating subspaces).
!>
!> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!> or a ratio alpha/beta = w, such that  A - w*B is singular.  It is
!> usually represented as the pair (alpha,beta), as there is a
!> reasonable interpretation for beta=0 or for both being zero.
!>
!> A pair of matrices (S,T) is in generalized complex Schur form if T is
!> upper triangular with non-negative diagonal and S is upper
!> triangular.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBVSL
!> \verbatim
!>          JOBVSL is CHARACTER*1
!>          = 'N':  do not compute the left Schur vectors;
!>          = 'V':  compute the left Schur vectors.
!> \endverbatim
!>
!> \param[in] JOBVSR
!> \verbatim
!>          JOBVSR is CHARACTER*1
!>          = 'N':  do not compute the right Schur vectors;
!>          = 'V':  compute the right Schur vectors.
!> \endverbatim
!>
!> \param[in] SORT
!> \verbatim
!>          SORT is CHARACTER*1
!>          Specifies whether or not to order the eigenvalues on the
!>          diagonal of the generalized Schur form.
!>          = 'N':  Eigenvalues are not ordered;
!>          = 'S':  Eigenvalues are ordered (see SELCTG).
!> \endverbatim
!>
!> \param[in] SELCTG
!> \verbatim
!>          SELCTG is a LOGICAL FUNCTION of two COMPLEX*16 arguments
!>          SELCTG must be declared EXTERNAL in the calling subroutine.
!>          If SORT = 'N', SELCTG is not referenced.
!>          If SORT = 'S', SELCTG is used to select eigenvalues to sort
!>          to the top left of the Schur form.
!>          Note that a selected complex eigenvalue may no longer satisfy
!>          SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since
!>          ordering may change the value of complex eigenvalues
!>          (especially if the eigenvalue is ill-conditioned), in this
!>          case INFO is set to N+3 see INFO below).
!> \endverbatim
!>
!> \param[in] SENSE
!> \verbatim
!>          SENSE is CHARACTER*1
!>          Determines which reciprocal condition numbers are computed.
!>          = 'N': None are computed;
!>          = 'E': Computed for average of selected eigenvalues only;
!>          = 'V': Computed for selected deflating subspaces only;
!>          = 'B': Computed for both.
!>          If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrices A, B, VSL, and VSR.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX*16 array, dimension (LDA, N)
!>          On entry, the first of the pair of matrices.
!>          On exit, A has been overwritten by its generalized Schur
!>          form S.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is COMPLEX*16 array, dimension (LDB, N)
!>          On entry, the second of the pair of matrices.
!>          On exit, B has been overwritten by its generalized Schur
!>          form T.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of B.  LDB >= max(1,N).
!> \endverbatim
!>
!> \param[out] SDIM
!> \verbatim
!>          SDIM is INTEGER
!>          If SORT = 'N', SDIM = 0.
!>          If SORT = 'S', SDIM = number of eigenvalues (after sorting)
!>          for which SELCTG is true.
!> \endverbatim
!>
!> \param[out] ALPHA
!> \verbatim
!>          ALPHA is COMPLEX*16 array, dimension (N)
!> \endverbatim
!>
!> \param[out] BETA
!> \verbatim
!>          BETA is COMPLEX*16 array, dimension (N)
!>          On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the
!>          generalized eigenvalues.  ALPHA(j) and BETA(j),j=1,...,N  are
!>          the diagonals of the complex Schur form (S,T).  BETA(j) will
!>          be non-negative real.
!>
!>          Note: the quotients ALPHA(j)/BETA(j) may easily over- or
!>          underflow, and BETA(j) may even be zero.  Thus, the user
!>          should avoid naively computing the ratio alpha/beta.
!>          However, ALPHA will be always less than and usually
!>          comparable with norm(A) in magnitude, and BETA always less
!>          than and usually comparable with norm(B).
!> \endverbatim
!>
!> \param[out] VSL
!> \verbatim
!>          VSL is COMPLEX*16 array, dimension (LDVSL,N)
!>          If JOBVSL = 'V', VSL will contain the left Schur vectors.
!>          Not referenced if JOBVSL = 'N'.
!> \endverbatim
!>
!> \param[in] LDVSL
!> \verbatim
!>          LDVSL is INTEGER
!>          The leading dimension of the matrix VSL. LDVSL >=1, and
!>          if JOBVSL = 'V', LDVSL >= N.
!> \endverbatim
!>
!> \param[out] VSR
!> \verbatim
!>          VSR is COMPLEX*16 array, dimension (LDVSR,N)
!>          If JOBVSR = 'V', VSR will contain the right Schur vectors.
!>          Not referenced if JOBVSR = 'N'.
!> \endverbatim
!>
!> \param[in] LDVSR
!> \verbatim
!>          LDVSR is INTEGER
!>          The leading dimension of the matrix VSR. LDVSR >= 1, and
!>          if JOBVSR = 'V', LDVSR >= N.
!> \endverbatim
!>
!> \param[out] RCONDE
!> \verbatim
!>          RCONDE is DOUBLE PRECISION array, dimension ( 2 )
!>          If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the
!>          reciprocal condition numbers for the average of the selected
!>          eigenvalues.
!>          Not referenced if SENSE = 'N' or 'V'.
!> \endverbatim
!>
!> \param[out] RCONDV
!> \verbatim
!>          RCONDV is DOUBLE PRECISION array, dimension ( 2 )
!>          If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the
!>          reciprocal condition number for the selected deflating
!>          subspaces.
!>          Not referenced if SENSE = 'N' or 'E'.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',
!>          LWORK >= MAX(1,2*N,2*SDIM*(N-SDIM)), else
!>          LWORK >= MAX(1,2*N).  Note that 2*SDIM*(N-SDIM) <= N*N/2.
!>          Note also that an error is only returned if
!>          LWORK < MAX(1,2*N), but if SENSE = 'E' or 'V' or 'B' this may
!>          not be large enough.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the bound on the optimal size of the WORK
!>          array and the minimum size of the IWORK array, returns these
!>          values as the first entries of the WORK and IWORK arrays, and
!>          no error message related to LWORK or LIWORK is issued by
!>          XERBLA.
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is DOUBLE PRECISION array, dimension ( 8*N )
!>          Real workspace.
!> \endverbatim
!>
!> \param[out] IWORK
!> \verbatim
!>          IWORK is INTEGER array, dimension (MAX(1,LIWORK))
!>          On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
!> \endverbatim
!>
!> \param[in] LIWORK
!> \verbatim
!>          LIWORK is INTEGER
!>          The dimension of the array IWORK.
!>          If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise
!>          LIWORK >= N+2.
!>
!>          If LIWORK = -1, then a workspace query is assumed; the
!>          routine only calculates the bound on the optimal size of the
!>          WORK array and the minimum size of the IWORK array, returns
!>          these values as the first entries of the WORK and IWORK
!>          arrays, and no error message related to LWORK or LIWORK is
!>          issued by XERBLA.
!> \endverbatim
!>
!> \param[out] BWORK
!> \verbatim
!>          BWORK is LOGICAL array, dimension (N)
!>          Not referenced if SORT = 'N'.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          = 1,...,N:
!>                The QZ iteration failed.  (A,B) are not in Schur
!>                form, but ALPHA(j) and BETA(j) should be correct for
!>                j=INFO+1,...,N.
!>          > N:  =N+1: other than QZ iteration failed in ZHGEQZ
!>                =N+2: after reordering, roundoff changed values of
!>                      some complex eigenvalues so that leading
!>                      eigenvalues in the Generalized Schur form no
!>                      longer satisfy SELCTG=.TRUE.  This could also
!>                      be caused due to scaling.
!>                =N+3: reordering failed in ZTGSEN.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2017
!
!> \ingroup complex16GEeigen
!
!  =====================================================================
      SUBROUTINE ZGGESX(Jobvsl,Jobvsr,Sort,SELCTG,Sense,N,A,Lda,B,Ldb,  &
     &                  Sdim,Alpha,Beta,Vsl,Ldvsl,Vsr,Ldvsr,Rconde,     &
     &                  Rcondv,Work,Lwork,Rwork,Iwork,Liwork,Bwork,Info)
      IMPLICIT NONE
!*--ZGGESX333
!
!  -- LAPACK driver routine (version 3.7.1) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2017
!
!     .. Scalar Arguments ..
      CHARACTER Jobvsl , Jobvsr , Sense , Sort
      INTEGER Info , Lda , Ldb , Ldvsl , Ldvsr , Liwork , Lwork , N ,   &
     &        Sdim
!     ..
!     .. Array Arguments ..
      LOGICAL Bwork(*)
      INTEGER Iwork(*)
      DOUBLE PRECISION Rconde(2) , Rcondv(2) , Rwork(*)
      COMPLEX*16 A(Lda,*) , Alpha(*) , B(Ldb,*) , Beta(*) , Vsl(Ldvsl,*)&
     &           , Vsr(Ldvsr,*) , Work(*)
!     ..
!     .. Function Arguments ..
      LOGICAL SELCTG
      EXTERNAL SELCTG
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE
      PARAMETER (ZERO=0.0D+0,ONE=1.0D+0)
      COMPLEX*16 CZERO , CONE
      PARAMETER (CZERO=(0.0D+0,0.0D+0),CONE=(1.0D+0,0.0D+0))
!     ..
!     .. Local Scalars ..
      LOGICAL cursl , ilascl , ilbscl , ilvsl , ilvsr , lastsl ,        &
     &        lquery , wantsb , wantse , wantsn , wantst , wantsv
      INTEGER i , icols , ierr , ihi , ijob , ijobvl , ijobvr , ileft , &
     &        ilo , iright , irows , irwrk , itau , iwrk , liwmin ,     &
     &        lwrk , maxwrk , minwrk
      DOUBLE PRECISION anrm , anrmto , bignum , bnrm , bnrmto , eps ,   &
     &                 pl , pr , smlnum
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION dif(2)
!     ..
!     .. External Subroutines ..
      EXTERNAL DLABAD , XERBLA , ZGEQRF , ZGGBAK , ZGGBAL , ZGGHRD ,    &
     &         ZHGEQZ , ZLACPY , ZLASCL , ZLASET , ZTGSEN , ZUNGQR ,    &
     &         ZUNMQR
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV
      DOUBLE PRECISION DLAMCH , ZLANGE
      EXTERNAL LSAME , ILAENV , DLAMCH , ZLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , SQRT
!     ..
!     .. Executable Statements ..
!
!     Decode the input arguments
!
      IF ( LSAME(Jobvsl,'N') ) THEN
         ijobvl = 1
         ilvsl = .FALSE.
      ELSEIF ( LSAME(Jobvsl,'V') ) THEN
         ijobvl = 2
         ilvsl = .TRUE.
      ELSE
         ijobvl = -1
         ilvsl = .FALSE.
      ENDIF
!
      IF ( LSAME(Jobvsr,'N') ) THEN
         ijobvr = 1
         ilvsr = .FALSE.
      ELSEIF ( LSAME(Jobvsr,'V') ) THEN
         ijobvr = 2
         ilvsr = .TRUE.
      ELSE
         ijobvr = -1
         ilvsr = .FALSE.
      ENDIF
!
      wantst = LSAME(Sort,'S')
      wantsn = LSAME(Sense,'N')
      wantse = LSAME(Sense,'E')
      wantsv = LSAME(Sense,'V')
      wantsb = LSAME(Sense,'B')
      lquery = (Lwork==-1 .OR. Liwork==-1)
      IF ( wantsn ) THEN
         ijob = 0
      ELSEIF ( wantse ) THEN
         ijob = 1
      ELSEIF ( wantsv ) THEN
         ijob = 2
      ELSEIF ( wantsb ) THEN
         ijob = 4
      ENDIF
!
!     Test the input arguments
!
      Info = 0
      IF ( ijobvl<=0 ) THEN
         Info = -1
      ELSEIF ( ijobvr<=0 ) THEN
         Info = -2
      ELSEIF ( (.NOT.wantst) .AND. (.NOT.LSAME(Sort,'N')) ) THEN
         Info = -3
      ELSEIF ( .NOT.(wantsn .OR. wantse .OR. wantsv .OR. wantsb) .OR.   &
     &         (.NOT.wantst .AND. .NOT.wantsn) ) THEN
         Info = -5
      ELSEIF ( N<0 ) THEN
         Info = -6
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -8
      ELSEIF ( Ldb<MAX(1,N) ) THEN
         Info = -10
      ELSEIF ( Ldvsl<1 .OR. (ilvsl .AND. Ldvsl<N) ) THEN
         Info = -15
      ELSEIF ( Ldvsr<1 .OR. (ilvsr .AND. Ldvsr<N) ) THEN
         Info = -17
      ENDIF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       NB refers to the optimal block size for the immediately
!       following subroutine, as returned by ILAENV.)
!
      IF ( Info==0 ) THEN
         IF ( N>0 ) THEN
            minwrk = 2*N
            maxwrk = N*(1+ILAENV(1,'ZGEQRF',' ',N,1,N,0))
            maxwrk = MAX(maxwrk,N*(1+ILAENV(1,'ZUNMQR',' ',N,1,N,-1)))
            IF ( ilvsl ) maxwrk = MAX(maxwrk,N*(1+ILAENV(1,'ZUNGQR',' ',&
     &                            N,1,N,-1)))
            lwrk = maxwrk
            IF ( ijob>=1 ) lwrk = MAX(lwrk,N*N/2)
         ELSE
            minwrk = 1
            maxwrk = 1
            lwrk = 1
         ENDIF
         Work(1) = lwrk
         IF ( wantsn .OR. N==0 ) THEN
            liwmin = 1
         ELSE
            liwmin = N + 2
         ENDIF
         Iwork(1) = liwmin
!
         IF ( Lwork<minwrk .AND. .NOT.lquery ) THEN
            Info = -21
         ELSEIF ( Liwork<liwmin .AND. .NOT.lquery ) THEN
            Info = -24
         ENDIF
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('ZGGESX',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) THEN
         Sdim = 0
         RETURN
      ENDIF
!
!     Get machine constants
!
      eps = DLAMCH('P')
      smlnum = DLAMCH('S')
      bignum = ONE/smlnum
      CALL DLABAD(smlnum,bignum)
      smlnum = SQRT(smlnum)/eps
      bignum = ONE/smlnum
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      anrm = ZLANGE('M',N,N,A,Lda,Rwork)
      ilascl = .FALSE.
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
         anrmto = smlnum
         ilascl = .TRUE.
      ELSEIF ( anrm>bignum ) THEN
         anrmto = bignum
         ilascl = .TRUE.
      ENDIF
      IF ( ilascl ) CALL ZLASCL('G',0,0,anrm,anrmto,N,N,A,Lda,ierr)
!
!     Scale B if max element outside range [SMLNUM,BIGNUM]
!
      bnrm = ZLANGE('M',N,N,B,Ldb,Rwork)
      ilbscl = .FALSE.
      IF ( bnrm>ZERO .AND. bnrm<smlnum ) THEN
         bnrmto = smlnum
         ilbscl = .TRUE.
      ELSEIF ( bnrm>bignum ) THEN
         bnrmto = bignum
         ilbscl = .TRUE.
      ENDIF
      IF ( ilbscl ) CALL ZLASCL('G',0,0,bnrm,bnrmto,N,N,B,Ldb,ierr)
!
!     Permute the matrix to make it more nearly triangular
!     (Real Workspace: need 6*N)
!
      ileft = 1
      iright = N + 1
      irwrk = iright + N
      CALL ZGGBAL('P',N,A,Lda,B,Ldb,ilo,ihi,Rwork(ileft),Rwork(iright), &
     &            Rwork(irwrk),ierr)
!
!     Reduce B to triangular form (QR decomposition of B)
!     (Complex Workspace: need N, prefer N*NB)
!
      irows = ihi + 1 - ilo
      icols = N + 1 - ilo
      itau = 1
      iwrk = itau + irows
      CALL ZGEQRF(irows,icols,B(ilo,ilo),Ldb,Work(itau),Work(iwrk),     &
     &            Lwork+1-iwrk,ierr)
!
!     Apply the unitary transformation to matrix A
!     (Complex Workspace: need N, prefer N*NB)
!
      CALL ZUNMQR('L','C',irows,icols,irows,B(ilo,ilo),Ldb,Work(itau),  &
     &            A(ilo,ilo),Lda,Work(iwrk),Lwork+1-iwrk,ierr)
!
!     Initialize VSL
!     (Complex Workspace: need N, prefer N*NB)
!
      IF ( ilvsl ) THEN
         CALL ZLASET('Full',N,N,CZERO,CONE,Vsl,Ldvsl)
         IF ( irows>1 ) CALL ZLACPY('L',irows-1,irows-1,B(ilo+1,ilo),   &
     &                              Ldb,Vsl(ilo+1,ilo),Ldvsl)
         CALL ZUNGQR(irows,irows,irows,Vsl(ilo,ilo),Ldvsl,Work(itau),   &
     &               Work(iwrk),Lwork+1-iwrk,ierr)
      ENDIF
!
!     Initialize VSR
!
      IF ( ilvsr ) CALL ZLASET('Full',N,N,CZERO,CONE,Vsr,Ldvsr)
!
!     Reduce to generalized Hessenberg form
!     (Workspace: none needed)
!
      CALL ZGGHRD(Jobvsl,Jobvsr,N,ilo,ihi,A,Lda,B,Ldb,Vsl,Ldvsl,Vsr,    &
     &            Ldvsr,ierr)
!
      Sdim = 0
!
!     Perform QZ algorithm, computing Schur vectors if desired
!     (Complex Workspace: need N)
!     (Real Workspace:    need N)
!
      iwrk = itau
      CALL ZHGEQZ('S',Jobvsl,Jobvsr,N,ilo,ihi,A,Lda,B,Ldb,Alpha,Beta,   &
     &            Vsl,Ldvsl,Vsr,Ldvsr,Work(iwrk),Lwork+1-iwrk,          &
     &            Rwork(irwrk),ierr)
      IF ( ierr/=0 ) THEN
         IF ( ierr>0 .AND. ierr<=N ) THEN
            Info = ierr
         ELSEIF ( ierr>N .AND. ierr<=2*N ) THEN
            Info = ierr - N
         ELSE
            Info = N + 1
         ENDIF
         GOTO 100
      ENDIF
!
!     Sort eigenvalues ALPHA/BETA and compute the reciprocal of
!     condition number(s)
!
      IF ( wantst ) THEN
!
!        Undo scaling on eigenvalues before SELCTGing
!
         IF ( ilascl ) CALL ZLASCL('G',0,0,anrmto,anrm,N,1,Alpha,N,ierr)
         IF ( ilbscl ) CALL ZLASCL('G',0,0,bnrmto,bnrm,N,1,Beta,N,ierr)
!
!        Select eigenvalues
!
         DO i = 1 , N
            Bwork(i) = SELCTG(Alpha(i),Beta(i))
         ENDDO
!
!        Reorder eigenvalues, transform Generalized Schur vectors, and
!        compute reciprocal condition numbers
!        (Complex Workspace: If IJOB >= 1, need MAX(1, 2*SDIM*(N-SDIM))
!                            otherwise, need 1 )
!
         CALL ZTGSEN(ijob,ilvsl,ilvsr,Bwork,N,A,Lda,B,Ldb,Alpha,Beta,   &
     &               Vsl,Ldvsl,Vsr,Ldvsr,Sdim,pl,pr,dif,Work(iwrk),     &
     &               Lwork-iwrk+1,Iwork,Liwork,ierr)
!
         IF ( ijob>=1 ) maxwrk = MAX(maxwrk,2*Sdim*(N-Sdim))
         IF ( ierr==-21 ) THEN
!
!            not enough complex workspace
!
            Info = -21
         ELSE
            IF ( ijob==1 .OR. ijob==4 ) THEN
               Rconde(1) = pl
               Rconde(2) = pr
            ENDIF
            IF ( ijob==2 .OR. ijob==4 ) THEN
               Rcondv(1) = dif(1)
               Rcondv(2) = dif(2)
            ENDIF
            IF ( ierr==1 ) Info = N + 3
         ENDIF
!
      ENDIF
!
!     Apply permutation to VSL and VSR
!     (Workspace: none needed)
!
      IF ( ilvsl ) CALL ZGGBAK('P','L',N,ilo,ihi,Rwork(ileft),          &
     &                         Rwork(iright),N,Vsl,Ldvsl,ierr)
!
      IF ( ilvsr ) CALL ZGGBAK('P','R',N,ilo,ihi,Rwork(ileft),          &
     &                         Rwork(iright),N,Vsr,Ldvsr,ierr)
!
!     Undo scaling
!
      IF ( ilascl ) THEN
         CALL ZLASCL('U',0,0,anrmto,anrm,N,N,A,Lda,ierr)
         CALL ZLASCL('G',0,0,anrmto,anrm,N,1,Alpha,N,ierr)
      ENDIF
!
      IF ( ilbscl ) THEN
         CALL ZLASCL('U',0,0,bnrmto,bnrm,N,N,B,Ldb,ierr)
         CALL ZLASCL('G',0,0,bnrmto,bnrm,N,1,Beta,N,ierr)
      ENDIF
!
      IF ( wantst ) THEN
!
!        Check if reordering is correct
!
         lastsl = .TRUE.
         Sdim = 0
         DO i = 1 , N
            cursl = SELCTG(Alpha(i),Beta(i))
            IF ( cursl ) Sdim = Sdim + 1
            IF ( cursl .AND. .NOT.lastsl ) Info = N + 2
            lastsl = cursl
         ENDDO
!
      ENDIF
!
!
 100  Work(1) = maxwrk
      Iwork(1) = liwmin
!
!
!     End of ZGGESX
!
      END SUBROUTINE ZGGESX


subroutine SHReturnTapersM(theta0, lmax, m, tapers, eigenvalues, shannon, &
                           exitstatus)
!------------------------------------------------------------------------------
!
!   This subroutine will return all the eigenvalues and eigenfunctions for the
!   space concentration problem of a spherical cap of angular radius theta0. The
!   returned eigenfunctions correspond to "geodesy" normalized spherical
!   harmonic coefficients, and the eigenfunctions are further normalized such
!   that they have unit power (i.e., the integral of the function squared over
!   the sphere divided by 4 pi is 1, and the sum of the squares of their
!   coefficients is 1).
!
!   Note that the eigenfunctions are calculated using the kernel of Grunbaum et
!   al. 1982, and that the eigenvalues are then calculated using the definition
!   of the the space concentration problem with its corresponding space
!   concentration kerel. This is done because the eigenfunctions of the former
!   are unreliable when the there are several eigenvalues identical (to machine
!   precision) to either 1 or zero.
!
!   Calling Parameters
!
!       IN
!           theta0          Angular radius of spherical cap in RADIANS.
!           lmax            Maximum spherical harmonic degree
!                           for the concentration problem.
!           m               Angular order of the concentration
!                           problem (m=0 corresponds to isotropic case).
!
!       OUT
!           tapers          An (lmax+1) by (lmax+1) array containing
!                           all the eigenfunctions of the space-
!                           concentration kernel. Eigenfunctions
!                           are listed by columns in decreasing order
!                           corresponding to value of their eigenvalue.
!           eigenvalues     A vector of length lmax+1 containing the
!                           eigenvalued corresponding to the individual
!                           eigenfunctions.
!
!       OPTIONAL
!           shannon         Shannon number as calculated from the trace of the
!                           kernel.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Dependencies: LAPACK, BLAS, ComputeDG82, EigValVecSymTri, PreGLQ, PlmBar
!
!   Copyright (c) 2016, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS, only: ComputeDG82, EigValVecSymTri, PreGLQ, PlmBar, PlmIndex

    implicit none

    real*8, intent(in) :: theta0
    integer, intent(in) :: lmax, m
    real*8, intent(out) :: tapers(:,:), eigenvalues(:)
    real*8, intent(out), optional :: shannon
    integer, intent(out), optional :: exitstatus
    integer ::  l, n, n_int, j, i, astat(3)
    real*8 :: eval(lmax+1), pi, upper, lower, zero(lmax+1), w(lmax+1), h
    real*8, allocatable :: evec(:,:), dllmtri(:,:), p(:)

    if (present(exitstatus)) exitstatus = 0

    if (size(tapers(:,1)) < (lmax+1) .or. size(tapers(1,:)) < (lmax+1) ) then
        print*, "Error --- SHReturnTapersM"
        print*, "TAPERS must be dimensioned as ( LMAX+1, LMAX+1) " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned as ", size(tapers(:,1)), &
                size(tapers(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if(size(eigenvalues) < (lmax+1) ) then
        print*, "Error --- SHReturnTapersM"
        print*, "EIGENVALUES must be dimensioned as (LMAX+1) " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned as ", size(eigenvalues)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (m > lmax) then
        print*, "Error --- SHReturnTapersM"
        print*, "M must be less than or equal to LMAX."
        print*, "M = ", m
        print*, "LMAX = ", lmax
        if (present(exitstatus)) then
            exitstatus = 2
            return
        else
            stop
        end if

    end if

    allocate (evec(lmax+1, lmax+1), stat = astat(1))
    allocate (dllmtri(lmax+1, lmax+1), stat = astat(2))
    allocate (p((lmax+1)*(lmax+2)/2), stat = astat(3))

    if (astat(1) /= 0 .or. astat(2) /= 0 .or. astat(3) /= 0) then
        print*, "Error --- SHReturnTapersM"
        print*, "Problem allocating arrays EVEC, DLLMTRI, and P", &
            astat(1), astat(2), astat(3)
        if (present(exitstatus)) then
            exitstatus = 3
            return
        else
            stop
        end if

    end if

    pi = acos(-1.0d0)

    tapers = 0.0d0
    eigenvalues = 0.0d0
    eval = 0.0d0
    evec = 0.0d0

    !--------------------------------------------------------------------------
    !
    !   Calculate space concentration Kernel, and the
    !   corresponding eigenfunctions of the Grunbaum et al. kernel.
    !   Calculate eigenvalues using concentration criter.
    !
    !--------------------------------------------------------------------------
    n = lmax + 1 - abs(m)

    if (present(exitstatus)) then
        call ComputeDG82(dllmtri(1:n,1:n), lmax, m, theta0, &
                         exitstatus = exitstatus)
        if (exitstatus /= 0) return
        call EigValVecSymTri(dllmtri(1:n,1:n), n, eval(1:n), &
                             evec(1+abs(m):lmax+1,1:n), &
                             exitstatus = exitstatus)
        if (exitstatus /= 0) return
    else
        call ComputeDG82(dllmtri(1:n,1:n), lmax, m, theta0)
        call EigValVecSymTri(dllmtri(1:n,1:n), n, eval(1:n), &
                             evec(1+abs(m):lmax+1,1:n))
    end if

    !---------------------------------------------------------------------------
    !
    !   Calculate true eigenvalues
    !
    !---------------------------------------------------------------------------
    upper = 1.0d0
    lower = cos(theta0)
    n_int = lmax + 1

    if (present(exitstatus)) then
        call PreGLQ(lower, upper, n_int, zero, w, exitstatus = exitstatus)
        if (exitstatus /= 0) return
    else
        call PreGLQ(lower, upper, n_int, zero, w)
    end if

    do i=1, n_int
        if (present(exitstatus)) then
            call PlmBar(p, lmax, zero(i), exitstatus = exitstatus)
            if (exitstatus /= 0) return
        else
            call PlmBar(p, lmax, zero(i))
        end if

        do j = 1, lmax + 1
            h = 0.0d0

            do l = abs(m), lmax
                h = h + p(PlmIndex(l, abs(m))) * evec(l+1, j)

            end do

            eigenvalues(j) = eigenvalues(j) + w(i) * h**2

        end do

    end do

    if (m == 0) then
        eigenvalues(1:lmax+1) = eigenvalues(1:lmax+1) / 2.0d0

    else
        eigenvalues(1:lmax+1) = eigenvalues(1:lmax+1) / 4.0d0

    end if

    if (present(shannon)) then
        shannon = sum(eigenvalues(1:lmax+1))

    end if

    !--------------------------------------------------------------------------
    !
    !   Normalize eigenvectors. By default, the eigenvectors have
    !   an L2 norm of 1, which corresponds to a total unit power
    !   (function^2 integreated over all space / 4pi = 1) when
    !   using the geodesy spherical harmonic normalization convenction.
    !   Modify sign convention of the eigenvectors such that the eigenfunction
    !   has a positive value at the north pole (form m=0 only).
    !
    !--------------------------------------------------------------------------
    if (m == 0) then
        do l = 0, lmax
            p(l+1) = sqrt(dble(2*l+1))
            ! values of normalized Legendre Polynomials at north pole

        end do

        do l = 1, lmax+1
            if (dot_product(evec(1:lmax+1,l), p(1:lmax+1)) < 0.0d0) &
                evec(:,l) = -evec(:,l)

        end do

    end if

    tapers(1:lmax+1,1:lmax+1) = evec(1:lmax+1,1:lmax+1)

    ! deallocate memory
    call PlmBar (p, -1, zero(1))
    deallocate (evec)
    deallocate (dllmtri)
    deallocate (p)

end subroutine SHReturnTapersM


c----- perturbation field
      SUBROUTINE PERTUR
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMMON/S0/R(5,16000),T(5,16000),R1(5,16000),T1(5,16000),DIST,K,L
      COMMON VMAX,GAP,SIV,ER0(4),ET0(4),ER1(4),ET1(4),
     1DERDR(4),DETDT(4),BS0(4),DBSDR(4),DBSDT(4),BBM,DBM,
     2RO0,TETA0,RRM,AAM,AMAX,WIDTH,POTINT,POTEX,EN,
     3DERDT(4),DETDR(4),EP,ITEST
      SINA=DSIN(TETA0-T(K,L))
      COSA=DCOS(TETA0-T(K,L))
      SINO=DSIN(AAM-TETA0)
      COSO=DCOS(AAM-TETA0)
      AAA=RO0*SINO-R(K,L)*DSIN(AAM-T(K,L))
      BBB=-RO0*COSO+R(K,L)*DCOS(AAM-T(K,L))
      ECA=DATAN(AAA/BBB)
      RRMP2=AAA*AAA+BBB*BBB
      DDD=DSQRT(RRMP2)
      DI=DDD-RRM
      GGG=(2.*ECA+AMAX)*RRM/GAP+1.
      IF(GGG.GT.80.) GGG=80.
      IF(GGG.LT.-80.) GGG=-80.
      HHH=(2.*ECA-AMAX)*RRM/GAP-1.
      IF(HHH.GT.80.) HHH=80.
      IF(HHH.LT.-80.) HHH=-80.
      FFF=(DTANH(GGG)-DTANH(HHH))*.5
      DX=WIDTH*.5-DI
      FF=.66*GAP*GAP/DX/DX
      BS0(K)=BBM*FF*FFF
      DECADR=RO0*SINA/RRMP2
      DECADT=R(K,L)*(R(K,L)-RO0*COSA)/RRMP2
      U1=DCOSH(GGG)
      U2=DCOSH(HHH)
      UU=RRM*(1./U1/U1-1./U2/U2)/GAP
      DFFFDR=DECADR*UU
      DFFFDT=DECADT*UU
      DIDR=(R(K,L)-RO0*COSA)/DDD
      DIDT=-R(K,L)*RO0*SINA/DDD
      U=1.32*GAP*GAP/DX
      DFFDR=DIDR*U
      DFFDT=DIDT*U
      DBSDR(K)=BBM*(FF*DFFFDR+FFF*DFFDR)
      DBSDT(K)=BBM*(FF*DFFFDT+FFF*DFFDT)
      RETURN
      END


module crystal_orientations_mod
use Tensors_module
use orientation_mod
    implicit none
    private
    public  :: rotate_input
    public  :: rotate_output
    public  :: get_rotation_matrices

    integer, parameter, dimension(9)    :: aba6_2_v9_pos = (/1, 2, 3, 4, 6, 5, 5, 4, 6/) ! Index conversion
    integer, parameter, dimension(6)    :: v9_2_aba6_pos = (/1, 2, 3, 4, 6, 5/)          ! Index conversion

    contains

subroutine rotate_input(dfgrad, dfgrad_rot, qvec)
implicit none
    double precision    :: dfgrad(3,3), dfgrad_rot(3,3), qvec(9), qmat(3,3)

    qmat = v9_2_m(qvec)

    dfgrad_rot = matmul(transpose(qmat), matmul(dfgrad, qmat))

end subroutine

subroutine rotate_output(stress, ddsdde, qvec)
implicit none
    double precision    :: stress(6), ddsdde(6,6), qvec(9)
    double precision    :: stressmat(3,3), ddsdde9(9,9), qmat(3,3), rot9x9(9,9)

    ! Rotate stress
    qmat = v9_2_m(qvec)
    stressmat = v9_2_m(sigma_abaqus_2_sigma_v9(stress))             ! Convert stress abaqus voigt to matrix
    stressmat = matmul(qmat, matmul(stressmat, transpose(qmat)))    ! Rotate stress matrix
    stress = sigma_v9_2_sigma_abaqus(m_2_v9(stressmat))             ! Convert stress matrix to abaqus voigt

    rot9x9 = op_a_V9(qvec, qvec)                                    ! Create rotation matrix in voigt for 4th order tensor
    ddsdde9 = ddsdde(aba6_2_v9_pos, aba6_2_v9_pos)                  ! Convert ddsdde in abaqus indicies to 9-voigt indicies from tensor module
    ddsdde9 = matmul(rot9x9, matmul(ddsdde9, transpose(rot9x9)))    ! Rotate ddsdde9
    ddsdde = ddsdde9(v9_2_aba6_pos,v9_2_aba6_pos)                   ! Convert ddsdde9 in 9-voigt indicies to abaqus indices (6-voigt)

end subroutine

end module


module flow_shear

   implicit none

   public :: flow_shear_initialized
   public :: init_flow_shear, finish_flow_shear
   public :: prl_shear, prl_shear_p, prp_shear
   public :: advance_parallel_flow_shear, advance_perp_flow_shear
   public :: v_edge, v_shift
   public :: shift_times

   private

   logical :: flow_shear_initialized = .false.

   complex, dimension(:, :), allocatable :: upwind_advect
   real, dimension(:, :, :), allocatable :: prl_shear, prl_shear_p
   real, dimension(:), allocatable :: prp_shear, shift_times

   integer :: shift_sign, shift_start

   real :: v_edge, v_shift = 0.

contains

   subroutine init_flow_shear
      use stella_layouts, only: vmu_lo
      use stella_layouts, only: iv_idx, imu_idx, is_idx
      use stella_time, only: code_dt
      use species, only: spec
      use constants, only: zi, pi
      use zgrid, only: nzgrid
      use kt_grids, only: x, x_d, nalpha, nx, nakx, naky, akx, aky, ikx_max, zonal_mode, box
      use fields_arrays, only: shift_state
      use stella_geometry, only: q_as_x, geo_surf, bmag, btor, rmajor, dBdrho, dIdrho
      use stella_geometry, only: dydalpha, drhodpsi
      use physics_parameters, only: g_exb, g_exbfac, omprimfac
      use vpamu_grids, only: vperp2, vpa, mu
      use vpamu_grids, only: maxwell_vpa, maxwell_mu, maxwell_fac
      use physics_flags, only: radial_variation, prp_shear_enabled, hammett_flow_shear
      use file_utils, only: runtype_option_switch, runtype_multibox
      use job_manage, only: njobs
      use mp, only: job, send, receive, crossdomprocs, subprocs, scope

      implicit none

      integer :: is, imu, iv, ivmu, iz, ia
      real, dimension(:, :), allocatable :: energy

      if (flow_shear_initialized) return
      flow_shear_initialized = .true.

      if (abs(g_exb * g_exbfac) > epsilon(0.)) prp_shear_enabled = .true.
      if (runtype_option_switch == runtype_multibox .and. job == 1) then
         hammett_flow_shear = .false.
      end if

      if (runtype_option_switch == runtype_multibox) then
         call scope(crossdomprocs)
         if (job == 1) then
            call send(g_exbfac * g_exb * x(1), 0, 120)
            call send(g_exbfac * g_exb * x(nx), njobs - 1, 121)
            v_shift = 0.0
         elseif (job == 0) then
            call receive(v_edge, 1, 120)
            v_shift = v_edge - g_exbfac * g_exb * x(1)
         elseif (job == njobs - 1) then
            call receive(v_edge, 1, 121)
            v_shift = v_edge - g_exbfac * g_exb * x(nx)
         end if
         call scope(subprocs)
      end if

      ia = 1

      !parallel flow shear

      allocate (energy(nalpha, -nzgrid:nzgrid))

      if (.not. allocated(prl_shear)) then
         allocate (prl_shear(nalpha, -nzgrid:nzgrid, vmu_lo%llim_proc:vmu_lo%ulim_alloc))
         prl_shear = 0.0
      end if

      if (radial_variation .and. .not. allocated(prl_shear_p)) &
         allocate (prl_shear_p(nalpha, -nzgrid:nzgrid, vmu_lo%llim_proc:vmu_lo%ulim_alloc))

      do ivmu = vmu_lo%llim_proc, vmu_lo%ulim_proc
         is = is_idx(vmu_lo, ivmu)
         iv = iv_idx(vmu_lo, ivmu)
         imu = imu_idx(vmu_lo, ivmu)
         do iz = -nzgrid, nzgrid
            prl_shear(ia, iz, ivmu) = -omprimfac * g_exb * code_dt * vpa(iv) * spec(is)%stm_psi0 &
                                      * dydalpha * drhodpsi &
                                      * (geo_surf%qinp_psi0 / geo_surf%rhoc_psi0) &
                                      * (btor(iz) * rmajor(iz) / bmag(ia, iz)) * (spec(is)%mass / spec(is)%temp) &
                                      * maxwell_vpa(iv, is) * maxwell_mu(ia, iz, imu, is) * maxwell_fac(is)
         end do
         if (radial_variation) then
            energy = (vpa(iv)**2 + vperp2(:, :, imu)) * (spec(is)%temp_psi0 / spec(is)%temp)
            prl_shear_p(:, :, ivmu) = prl_shear(:, :, ivmu) * (dIdrho / spread(rmajor * btor, 1, nalpha) &
                                                               - spread(dBdrho, 1, nalpha) / bmag &
                                                               - spec(is)%fprim - spec(is)%tprim * (energy - 2.5) &
                                                               - 2.*mu(imu) * spread(dBdrho, 1, nalpha))
         end if
      end do

      if (q_as_x) prl_shear = prl_shear / geo_surf%shat_psi0

      deallocate (energy)

      !perpendicular flow shear

      if (.not. allocated(shift_times)) allocate (shift_times(naky))
      if (.not. allocated(upwind_advect)) allocate (upwind_advect(naky, nakx))

      if (.not. allocated(shift_state)) then
         allocate (shift_state(naky))
         shift_state = 0.
      end if

      if (nakx > 1 .and. abs(g_exb * g_exbfac) > 0) then
         shift_times = abs(akx(2) / (aky * g_exb * g_exbfac))
      end if
      if (zonal_mode(1)) shift_times(1) = huge(0.)

      if (g_exb * g_exbfac > 0.) then
         shift_sign = -1
         shift_start = ikx_max
      else
         shift_sign = 1
         shift_start = ikx_max + 1
      end if

      if (box) upwind_advect = exp(-zi * g_exbfac * g_exb * code_dt * spread(aky, 2, nakx) * spread(x_d, 1, naky))

   end subroutine init_flow_shear

   subroutine advance_parallel_flow_shear(gout)

      use mp, only: proc0, mp_abort
      use physics_flags, only: full_flux_surface
      use stella_layouts, only: vmu_lo
      use zgrid, only: nzgrid, ntubes
      use kt_grids, only: nakx, naky
      use fields, only: get_dchidy
      use fields_arrays, only: phi, apar

      implicit none

      complex, dimension(:, :, -nzgrid:, :, vmu_lo%llim_proc:), intent(in out) :: gout

      complex, dimension(:, :), allocatable :: g0k

      integer :: ivmu, iz, it, ia

      ia = 1

      allocate (g0k(naky, nakx))

      if (full_flux_surface) then
         if (proc0) write (*, *) '!!!WARNING: flow shear not currently supported for full_flux_surface=T!!!'
         call mp_abort("flow shear not currently supported for full_flux_surface=T.")
      end if
      do ivmu = vmu_lo%llim_proc, vmu_lo%ulim_proc
         do it = 1, ntubes
            do iz = -nzgrid, nzgrid
               call get_dchidy(iz, ivmu, phi(:, :, iz, it), apar(:, :, iz, it), g0k)

               !parallel flow shear
               gout(:, :, iz, it, ivmu) = gout(:, :, iz, it, ivmu) + prl_shear(ia, iz, ivmu) * g0k
            end do
         end do
      end do

      deallocate (g0k)

   end subroutine advance_parallel_flow_shear

   subroutine advance_perp_flow_shear(g)

      use stella_layouts, only: vmu_lo
      use constants, only: zi
      use physics_flags, only: prp_shear_enabled, hammett_flow_shear
      use stella_transforms, only: transform_kx2x_unpadded, transform_x2kx_unpadded
      use zgrid, only: nzgrid, ntubes
      use fields_arrays, only: shift_state
      use kt_grids, only: aky, nakx, naky, ikx_max, zonal_mode
      use file_utils, only: runtype_option_switch, runtype_multibox
      use stella_time, only: code_dt

      implicit none

      complex, dimension(:, :, -nzgrid:, :, vmu_lo%llim_proc:), intent(in out) :: g
      complex, dimension(:, :), allocatable :: g0k, g0x

      real :: shift_fac

      integer :: ivmu, iz, it, iky

      if (.not. prp_shear_enabled) return

      allocate (g0k(naky, nakx))
      allocate (g0x(naky, nakx))

      if (hammett_flow_shear) then
         !TODO (DSO) - This assumes the timestep is small enough so that a shift is never
         !             more than a single cell
         do ivmu = vmu_lo%llim_proc, vmu_lo%ulim_proc
            do it = 1, ntubes
               do iz = -nzgrid, nzgrid
                  do iky = 1, naky
                     if (zonal_mode(iky)) cycle
                     if (shift_state(iky) > 0.5 * shift_times(iky)) then
                        if (shift_sign < 0) then
                           !shift everything left by one
                           g(iky, (ikx_max + 1):(nakx - 1), iz, it, ivmu) = g(iky, ikx_max + 2:, iz, it, ivmu)
                           g(iky, nakx, iz, it, ivmu) = g(iky, 1, iz, it, ivmu)
                           g(iky, :ikx_max - 1, iz, it, ivmu) = g(iky, 2:ikx_max, iz, it, ivmu)
                        else
                           !shift everything right by one
                           g(iky, 2:ikx_max, iz, it, ivmu) = g(iky, 1:(ikx_max - 1), iz, it, ivmu)
                           g(iky, 1, iz, it, ivmu) = g(iky, nakx, iz, it, ivmu)
                           g(iky, ikx_max + 2:, iz, it, ivmu) = g(iky, (ikx_max + 1):(nakx - 1), iz, it, ivmu)
                        end if
                        g(iky, shift_start, iz, it, ivmu) = 0.
                     end if
                  end do
               end do
            end do
         end do
      else
         do ivmu = vmu_lo%llim_proc, vmu_lo%ulim_proc
            do it = 1, ntubes
               do iz = -nzgrid, nzgrid

                  g0k = g(:, :, iz, it, ivmu)

                  call transform_kx2x_unpadded(g0k, g0x)
                  g0x = upwind_advect * g0x

                  call transform_x2kx_unpadded(g0x, g0k)

                  do iky = 1, naky
                     if (zonal_mode(iky)) cycle
                     if (shift_state(iky) > shift_times(iky)) then
                        g0k(iky, shift_start) = 0.0
                     end if
                  end do

                  g(:, :, iz, it, ivmu) = g0k

               end do
            end do
         end do
      end if

      shift_fac = 1.0
      if (hammett_flow_shear) shift_fac = 0.5

      do iky = 1, naky
         if (zonal_mode(iky)) cycle
         if (shift_state(iky) > shift_fac * shift_times(iky)) then
            shift_state(iky) = shift_state(iky) - shift_times(iky)
         end if
      end do

      shift_state = shift_state + code_dt
      if (zonal_mode(1)) shift_state(1) = 0.

      if (runtype_option_switch == runtype_multibox) then
      do ivmu = vmu_lo%llim_proc, vmu_lo%ulim_proc
         do it = 1, ntubes
            do iz = -nzgrid, nzgrid
               g(:, :, iz, it, ivmu) = g(:, :, iz, it, ivmu) * exp(-code_dt * zi * spread(aky, 2, nakx) * v_shift)
            end do
         end do
      end do
      end if

      deallocate (g0k, g0x)

   end subroutine advance_perp_flow_shear

   subroutine finish_flow_shear
      use fields_arrays, only: shift_state

      implicit none

      if (allocated(prl_shear)) deallocate (prl_shear)
      if (allocated(prl_shear_p)) deallocate (prl_shear_p)
      if (allocated(shift_times)) deallocate (shift_times)
      if (allocated(shift_state)) deallocate (shift_state)
      if (allocated(upwind_advect)) deallocate (upwind_advect)

      flow_shear_initialized = .false.

   end subroutine finish_flow_shear

end module flow_shear


      SUBROUTINE spline_akima(x,y,xx,yy,npts,iflag)
! 2012-07-27: Typo correction, J Geiger
      USE stel_kinds
      implicit none
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      integer, intent(in) :: npts        ! number of active points
      integer, intent(inout) :: iflag
      real(rprec), intent(in)  :: x
      real(rprec), intent(out) :: y
      real(rprec), dimension(npts), intent(in) :: xx, yy
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      real(rprec), dimension(-1:size(xx)+2) :: a, b, c, d
      real(rprec), dimension(-1:size(xx)+2) :: xloc, yloc
      real(rprec), dimension(-1:size(xx)+2) :: m, t, dm, p, q
      integer :: i, ix, iv, ivm1
      real(rprec) :: cl,bl,cr,br,dx
!-----------------------------------------------

!     print * , x, y
!     print * , npts
!     print * , xx
!     print * , yy
!     stop 'Test!'

      iflag = 0  !initialization
      ix = size(xx)
!     print *, size(xx)
!     print *, size(yy)
      if(npts > ix)
     >   stop'spline_akima: more active points requested than available'
      if(ix /= size(yy)) stop 'size mismatch of xx and yy!'
      iv=npts
      ivm1  = iv-1
! initialize local variables
      a = 0._DP ; b = 0._DP ; c = 0._DP ; d = 0._DP
      xloc = 0._DP ; yloc = 0._DP
      m = 0._DP ; t = 0._DP ; dm = 0._DP
      p = 0._DP ; q = 0._DP

      xloc(1:iv)=xx
      xloc(-1)= 2*xloc(1)-xloc(3)
      xloc( 0)= xloc(1)+xloc(2)-xloc(3)
      xloc(iv+2)= 2*xloc(iv)-xloc(iv-2)
      xloc(iv+1)= xloc(iv)+xloc(iv-1)-xloc(iv-2)
      yloc(1:iv)=yy
! calculate linear derivatives as far as existent
      m(1:iv-1) = (yloc(2:iv)-yloc(1:iv-1))/
     >            (xloc(2:iv)-xloc(1:iv-1))
! values for i=0, -1 and iv, iv+1 by quadratic extrapolation:
      cl = (m(2)-m(1))/(xloc(3)-xloc(1))
      bl = m(1) - cl*(xloc(2)-xloc(1))
      cr = (m(iv-2)-m(iv-1))/(xloc(iv)-xloc(iv-2))
      br = m(iv-2) - cr*(xloc(iv-1)-xloc(iv-2))
      yloc( 0)=yloc(1)+bl*(xloc( 0)-xloc(1))+
     >               cl*(xloc( 0)-xloc(1))**2
      yloc(-1)=yloc(1)+bl*(xloc(-1)-xloc(1))+
     >               cl*(xloc(-1)-xloc(1))**2
      yloc(iv+1)=yloc(iv)+br*(xloc(iv+1)-xloc(iv))+
     >               cr*(xloc(iv+1)-xloc(iv))**2
      yloc(iv+2)=yloc(iv)+br*(xloc(iv+2)-xloc(iv))+
     >               cr*(xloc(iv+2)-xloc(iv))**2
! rest of linear derivatives
      m(-1) = (yloc(0)-yloc(-1))/(xloc(0)-xloc(-1))
      m( 0) = (yloc(1)-yloc( 0))/(xloc(1)-xloc( 0))
      m(iv  ) = (yloc(iv+1)-yloc(iv  ))/(xloc(iv+1)-xloc(iv  ))
      m(iv+1) = (yloc(iv+2)-yloc(iv+1))/(xloc(iv+2)-xloc(iv+1))
! calculate weights for derivatives
      dm(-1:iv)= abs(m(0:iv+1)-m(-1:iv))
      where (dm /= 0._DP) !exclude division by zero
        p(1:iv) = dm(1:iv)/(dm(1:iv)+dm(-1:iv-2))
      end where
      where (dm /= 0._DP) !exclude division by zero
        q(1:iv) = dm(-1:iv-2)/(dm(1:iv)+dm(-1:iv-2))
      end where
      t(1:iv) = p(1:iv)*m(0:iv-1)+q(1:iv)*m(1:iv)
      where ( p(1:iv)+q(1:iv) < TINY(1._DP)) ! in case of two zeros give equal weight
        t(1:iv) = 0.5_DP*m(0:iv-1)+0.5_DP*m(1:iv)
      end where
! fix coefficients
      a = yloc
      b = t
      c(1:iv-1) = (3*m(1:iv-1)-t(2:iv)-2*t(1:iv-1))/
     >               (xloc(2:iv)-xloc(1:iv-1))
      d(1:iv-1) = (t(2:iv)+t(1:iv-1)-2*m(1:iv-1))/
     >               (xloc(2:iv)-xloc(1:iv-1))**2

! calculation
      if(x<xloc(1) .or. x>xloc(iv))then
        y=0.0
        iflag=-1
        return
      endif
      if(x == xloc(iv)) then
        y = yy(iv)
        iflag = 0
        return
      endif
      do i=1,iv-1
        if(x >= xloc(i) .and. x < xloc(i+1))then
          dx=x-xloc(i)
          y=a(i)+dx*(b(i)+dx*(c(i)+d(i)*dx))
          iflag = 0
          return
        endif
      enddo

      END SUBROUTINE spline_akima


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine relaxval_al(gcontfull, nacti, ncdim)

!
      implicit none
C !
      integer i,j, nacti, ncdim, nsize
      integer ksv(ncdim)
C !
      real*8 gcontfull(*), dssd2, r_al(nacti*ncdim) ! ?? TODO: can I declear fixed size if I know it already?
      real*8 gmatrix(nacti*ncdim,nacti*ncdim), vssd1(ncdim)

      logical isDiagDomi ! is strictly diagionally dominant

      nsize = nacti*ncdim

      do i=1,nsize
        do j=1,nsize
            gmatrix(j,i) = gcontfull(  (i-1)*nsize + j  )
        enddo
      enddo

      isDiagDomi=.true.

! WE CHECK IF ITS "STRICTLY DIAGONALLY DOMINANT"
!_strictly_diagonal_dominant = ...
!   all((2*abs(diag(G))) >= sum(abs(G),2));

      do i=1,nsize
!       dssd2=0.0d0
!       do j=1,nsize
!           dssd2 = dssd2 + abs(gmatrix(j,i))
!       enddo
        dssd2 = sum(gmatrix(:,1))

        if ( 2.0d0*gmatrix(i,i) < dssd2 ) then
            isDiagDomi=.false.
            exit
        endif
      enddo

      do i=1,ncdim
        ksv(i) = i
      enddo

      do i=1,nacti
C         II = nCdim*(ii-1)+(1:nCdim);
        do j = 1,ncdim
            ksv(j) = nCdim*(i-1) + j
        enddo

        if(isDiagDomi) then
C             r_al(ii) = 1/max(diag(G(II,II)));
            do j=1,ncdim
                vssd1(j)=gmatrix(ksv(j),ksv(j))
            enddo
        else
C             r_al(ii) = 1/max(sum(abs(G(II,:)),2));
            do j=1,ncdim
                vssd1(j)=sum(abs(gmatrix(:,ksv(j))))!F90
            enddo
        endif

        dssd2 = 1.0d0/maxval(vssd1)!F90

        do j=1,ncdim
            r_al(ksv(j)) = dssd2
        enddo

      enddo

      return
      end


!-------------------------------------------------------------------------------
!
!> \file    CorrectMolFraction.f90
!> \brief   Correct mole fractions of minor species by defining them from the
!!           element potentials.
!> \author  M.H.A. Piro
!> \date    August 20, 2015
!
!
! Revisions:
! ==========
!
!   Date            Programmer      Description of change
!   ----            ----------      ---------------------
!   20/08/2015      M.H.A. Piro     Original code
!
!
! Purpose:
! ========
!
!> \details The purpose of this subroutine is to correct the mole fractions
!! of minor species.  At equilibrium, the chemical potential of every stable
!! species and phase must be related to the chemical potentials of the system
!! components.  However, there might be some residual, which often happens
!! with minor species.  This subroutine corrects for that error.
!
!
!
! Pertinent variables:
! ====================
!
!> \param[in]       k       Absolute solution phase index.
!
! nSolnPhasesSys            Number of solution phases in the system.
! nSpeciesPhase             Index of last species in a particular solution phase.
! dMolFraction              Double real vector representing the current
!                            estimated mole fraction.
! dSumMolFractionSoln       Sum of all mole fractions within a solution phase.
! dEffStoichSolnPhase       Effective stoichiometry of a particular element in
!                            a solution phase.
! dPartialExcessGibbs       The partial molar excess Gibbs energy of mixing of
!                            a phase constituent.
! dChemicalPotential        A double real vector representing the chemical
!                            potential of each species.  To be precise, this is
!                            defined as the difference between the standard
!                            molar Gibbs energy and the chemical potential
!                            defined by the element potentials (represented in
!                            dimensionless units and per formula mass).
! iParticlesPerMole         The number of particles per mole of constituent.
! dStoichSpecies            The number of atoms of a particular element for a
!                            particular species.
! dSpeciesTotalAtoms        The total number of atoms per formula mass of a
!                            species.
! cSolnPhaseType            Character vector representing the type of solution
!                            phase (see above).
!
!-------------------------------------------------------------------------------

subroutine CorrectMolFraction

    ! USE ModuleThermoIO, ONLY: INFOThermo
    USE ModuleThermo
    USE ModuleGEMSolver

    implicit none

    integer :: i, j, k, l
    real(8) :: dTemp, dURF
    logical :: lCompEverything

    ! Initialize variables:
    lCompEverything = .FALSE.
    dURF = 0.5D0

    if (dGEMFunctionNorm > 1D-5) return

    print *, 'CorrectMolFraction'
    print *

    LOOP_PHASE: do j = 1, nSolnPhases
        k = -iAssemblage(nElements - j + 1)

        ! Compute the residual terms:
        LOOP_SPECIES: do i = nSpeciesPhase(k-1)+1, nSpeciesPhase(k)

            ! Compute the chemical potential term from the element potentials:
            dTemp = 0D0
            do l = 1, nElements
                dTemp = dTemp + dElementPotential(l) * dStoichSpecies(i,l)
            end do

            ! Normalize this quantity by the number of particles per mole:
            dTemp = dTemp / DFLOAT(iParticlesPerMole(i))

            ! Compute correction factor to mole fraction:
            dTemp = dTemp - dChemicalPotential(i)

print *, csolnPhaseName(k), cSpeciesName(i), dTemp, dMolFraction(i), dMolFraction(i) * DSQRT(DEXP(dTemp))

            dMolFraction(i) = DSQRT(DEXP(dTemp)) * dMolFraction(i)
            !dMolFraction(i)  = DEXP(dTemp) * dMolFraction(i)
            dMolesSpecies(i) = dMolesPhase(nElements-j+1) * dMolFraction(i)
            !dMolesSpecies(i) = dURF * dTemp + (1D0 - dURF) * dMolesSpecies(i)

        end do LOOP_SPECIES

    end do LOOP_PHASE

    call CompChemicalPotential(lCompEverything)

    return

end subroutine CorrectMolFraction


C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C     TRANSFO.FOR : Transforme le problème primal -> dual
C
C Dernière modification : 08.02.97
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE TRANSFO(A,b,C,d,x,A2,b2,x2,N,m,F2)
C
C     Déclaration des variables
C     -------------------------
      IMPLICIT REAL*8(a-h,o-z)
      DIMENSION A(*),b(*),C(N,m),d(m),A2(*),b2(*),x(*),x2(*)
C
C     Calcul de -l(lamda)
C     -------------------
C
C     -- Termes quadratiques --
C
      OPEN(UNIT=3,FILE='MAT.M',STATUS='UNKNOWN')
      k=0
      F2=0.0D0
      DO i=1,m
         DO j=1,i
            k=k+1
            A2(k)=0.
            ll=1
            IF(i.EQ.j) THEN
               DO l=1,N
                  A2(k)=A2(k)-c(l,j)**2/A(ll)
                  ll=ll+l+1
               ENDDO
            ELSE
               DO l=1,N
                  A2(k)=A2(k)-c(l,j)*c(l,i)/A(ll)
                  ll=ll+l+1
               ENDDO
            ENDIF
            A2(k)=-A2(k)
            WRITE(3,*)'A2(',i,',',j,')=',A2(k),';'
            WRITE(3,*)'A2(',j,',',i,')=',A2(k),';'
         ENDDO
      ENDDO
C
C     -- Termes linéaires --
C
      DO i=1,m
         b2(i)=0.0D0
         ll=1
         DO l=1,N
            b2(i)=b2(i)+b(l)*c(l,i)/A(ll)
            ll=ll+l+1
         ENDDO
         b2(i)=b2(i)-d(i)
         WRITE(3,*)'b2(',i,')=',b2(i),';'
      ENDDO
C
C     Initialisation du vecteur lamda0 à 0.0
C     --------------------------------------
      DO i=1,m
         x2(i)=0.0D0
      ENDDO
      CLOSE(UNIT=3)
C
      RETURN
      END


      SUBROUTINE WNOISEF(NRA,IR,SD1,X2)
C
      INCLUDE 'timsac_f.h'
C
cc      PROGRAM WNOISE
C     PROGRAM 5.5.3   WHITE NOISE GENERATOR
C-----------------------------------------------------------------------
C     ** DESIGNED BY H. AKAIKE, THE INSTITUTE OF STATISTICAL MATHEMATICS
C     ** PROGRAMMED BY E. ARAHATA, THE INSTITUTE OF STATISTICAL MATHEMAT
C         TOKYO
C     ** DATE OF THE LATEST REVISION: MARCH 25, 1977
C     ** THIS PROGRAM WAS ORIGINALLY PUBLISHED IN
C         "DAINAMIKKU SISTEMU NO TOKEI-TEKI KAISEKI TO SEIGYO (STATISTICA
C         ANALYSIS AND CONTROL OF DYNAMIC SYSTEMS)" BY H. AKAIKE AND
C         T. NAKAGAWA, SAIENSU-SHA, TOKYO, 1972 (IN JAPANESE)
C-----------------------------------------------------------------------
C     THIS PROGRAM GENERATES APPROXIMATELY GAUSSIAN VECTOR WHITE NOISE
C     TO BE USED AS INPUT W OF PROGRAM 5.5.2 OPTSIM.
C     ON TOP OF THE OUTPUT OF PROGRAM 5.3.2 FPEC, WHICH IS TO BE USED
C     AS INPUT TO PROGRAM 5.5.2 OPTSIM, ONE CARD WITH SPECIFICATION
C     OF THE LENGTH NRA OF WHITE NOISE RECORD TO BE GENERATED SHOULD
C     BE ADDED TO FORM THE INPUT TO THIS PROGRAM.
C     NRA: LENGTH OF WHITE NOISE RECORD TO BE GENERATED
C
cc      !DEC$ ATTRIBUTES DLLEXPORT :: WNOISEF
cc      USE DFLIB
C
cxx      IMPLICIT REAL*8(A-H,O-Z)
      PARAMETER (MJ0=100)
cc      REAL*4 RANDOM
ccc	 REAL*4	 RANDM
cxx      REAL*8 RANDM
cc      DIMENSION SD(5,5),A(10),Y(5),Z(5)
cc      DIMENSION X1(100,5)
cxx      DIMENSION SD1(IR,IR),SD(IR,IR),Y(IR),Z(IR)
cxx      DIMENSION X1(MJ0,IR),X2(IR,NRA)
      INTEGER :: NRA, IR
      REAL(8) :: SD1(IR,IR), X2(IR,NRA)
      REAL(8) :: RANDM, SD(IR,IR), Y(IR), Z(IR), X1(MJ0,IR), CST0,
     1           RC, RCONST, XX, SUM
C     INPUT / OUTPUT DATA FILE OPEN
cc      CHARACTER(100) DFNAM
cc      DFNAM = 'wnoise.out'
cc      CALL SETWND
cc      CALL FLOPN3(DFNAM,NFL)
cc      IF (NFL.EQ.0) GO TO 999
C     ABSOLUTE DIMENSIONS USED FOR SUBROUTINE CALL
cc      MJ0=100
cc      MJ=5
      CST0=0.0D-00
C     NRA SPECIFICATION
cc      READ(5,1) NRA
C     READING THE OUTPUTS OF PROGRAM 5.3.2 FPEC
cc      READ(5,1) N,M,IR,IL
cc      CALL REMATX(SD,IR,IR,1,MJ,MJ)
cxx      DO 5 I=1,IR
      DO 6 I=1,IR
         DO 5 J=1,IR
            SD(I,J)=SD1(I,J)
    5    CONTINUE
    6 CONTINUE
C     FOLLOWING INPUT IS NONEFFECTIVE.
cc      IP=IR+IL
cc      MR=M*IR
cc      DO 8 JJ=1,MR
cc    8 READ(5,2) (A(II),II=1,IP)
cc      WRITE(6,60)
cc      WRITE(6,61)
cc      WRITE(6,62) NRA,N,M,IR
cc      WRITE(6,63)
cc      CALL SUBMPR(SD,IR,IR,MJ,MJ)
cc      WRITE(6,100)
C     MATRIX L COMPUTATION
cc      CALL LTINV(SD,IR,MJ)
      CALL LTINV(SD,IR)
C     MATRIX L ARRANGEMENT
      IF(IR.EQ.1) GO TO 260
cxx      DO 12 I=2,IR
      DO 13 I=2,IR
      IM1=I-1
      DO 12 J=1,IM1
cxx   12 SD(I,J)=SD(J,I)
      SD(I,J)=SD(J,I)
   12 CONTINUE
   13 CONTINUE
C     RANDOM NUMBER GENERATION
  260 RC=4.0D-00/3.0D-00
      RCONST=DSQRT(RC)
cc      XX=RANDOM(1)
ccc      XX=RANDM(1)
      XX=RANDM(1,K1,K2,K3,K4)
cc      IND=99
      IND=MJ0-1
      IND1=IND+1
      I1=0
      I2=0
      IIC=0
  160 I1=I2+1
      I2=I1+IND
      IF(I2.LE.NRA) GO TO 130
      I2=NRA
  130 DO 14 I=I1,I2
      II=I-IIC
      DO 15 J=1,IR
      SUM=CST0
      DO 20 JJ=1,9
cc   20 SUM=SUM+RANDOM(0)
ccc   20 SUM=SUM+RANDM(0)
cxx   20 SUM=SUM+RANDM(0,K1,K2,K3,K4)
      SUM=SUM+RANDM(0,K1,K2,K3,K4)
   20 CONTINUE
      SUM=SUM-4.5D-00
cxx   15 X1(II,J)=SUM*RCONST
      X1(II,J)=SUM*RCONST
   15 CONTINUE
   14 CONTINUE
C     WHITE NOISE GENERATION
      DO 16 I=I1,I2
      II=I-IIC
      DO 17 J=1,IR
cxx   17 Y(J)=X1(II,J)
      Y(J)=X1(II,J)
   17 CONTINUE
cc      CALL LTRVEC(SD,Y,Z,IR,IR,MJ,MJ)
      CALL LTRVEC(SD,Y,Z,IR,IR)
      DO 18 J=1,IR
cxx   18 X1(II,J)=Z(J)
      X1(II,J)=Z(J)
   18 CONTINUE
   16 CONTINUE
C     WHITE NOISE PRINT AND PUNCH OUT
cc      WRITE(6,101) IIC
      I3=I2-IIC
cc      CALL SUBMPR(X1,I3,IR,MJ0,MJ)
cxx      DO 40 I=I1,I2
      DO 41 I=I1,I2
         II=I-IIC
cc   40 WRITE(7,3) (X1(II,J),J=1,IR)
      DO 40 J=1,IR
cxx   40 X2(J,I)=X1(II,J)
      X2(J,I)=X1(II,J)
   40 CONTINUE
   41 CONTINUE
      IIC=IIC+IND1
      IF(I2.LT.NRA) GO TO 160
cc      CALL FLCLS3(NFL)
cc  999 CONTINUE
      RETURN
cxx    1 FORMAT(10I5)
cxx    2 FORMAT(4D20.10)
cxx    3 FORMAT(6D12.3)
cxx   60 FORMAT(1H ,27HPROGRAM 5.5.3   WHITE NOISE)
cxx   61 FORMAT(1H ,17HINITIAL CONDITION)
cxx   62 FORMAT(1H ,4HNRA=,I5,5X,2HN=,I5,5X,2HM=,I5,5X,3HIR=,I5)
cxx   63 FORMAT(/1H ,7HSD(I,J))
cxx  100 FORMAT(////1H ,11HWHITE NOISE)
cxx  101 FORMAT(1H ,4HIIC=,I5,5X,11HX1(IIC+I,J))
      END


!
!   FnVFV.f90
!
!
!
!   Created by Kurt Mitman on 10/10/14.
!
!

DOUBLE PRECISION FUNCTION FnVFB(bsav)

USE Params
USE Globals
USE funcs
USE Procedures

IMPLICIT NONE

DOUBLE PRECISION, INTENT(IN) :: bsav
DOUBLE PRECISION             :: cons
DOUBLE PRECISION             :: vals(2)
INTEGER                      :: inds(2)

call basefun(GridB,nb,bsav,vals,inds)

cons=gliq+(vals(1)*(qm(inds(1),gil,gim,gih,giW,giAgg,gij+1)*gmort+ql(inds(1),gil,gim,gih,giW,giAgg,gij+1)*gloc)+(vals(2)*(qm(inds(2),gil,gim,gih,giW,giAgg,gij+1)*gmort+ql(inds(2),gil,gim,gih,giW,giAgg,gij+1)*gloc)))*ghouse-FnQb(bsav,0.0d0)*bsav

if(cons .GT. cmin) then

FnVFB = -1.0d0*(uown(cons,ghouse,gij)+bet*(vals(1)*EVown(inds(1),gil,gim,gih,giW,giAgg,gij)+vals(2)*EVown(inds(2),gil,gim,gih,giW,giAgg,gij)))

else

FnVFB = 1.0d10+10.0d0*(cmin-cons)

endif

END FUNCTION FnVFB


C     LAST UPDATE 02/09/94
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE BESSD(X,F,DF)
      IMPLICIT NONE
C
C Purpose: Calculates the value and derivative of a bessel function
C          order NBESS (passed in common) at X.
C
C Calls   1: BESSJ
C Called by:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Arguments:
C
      REAL X,F,DF
C
C External function:
C
      REAL BESSJ
      EXTERNAL BESSJ
C
C Common block variables:
C
      INTEGER NBESS
C
C Common blocks:
C
      COMMON /BORDER/NBESS
C
C-----------------------------------------------------------------------
      F = BESSJ(NBESS,X)
      IF(ABS(X).GT.0.0)THEN
         DF = BESSJ(NBESS-1,X) - FLOAT(NBESS)*F/X
      ELSE
         IF(ABS(NBESS).EQ.1)THEN
            DF = FLOAT(NBESS)/2.0
         ELSE
            DF = 0.0
         ENDIF
      ENDIF
      RETURN
      END


           program demo_dprod
           use, intrinsic :: iso_fortran_env, only : real_kinds, &
           & real32, real64, real128
           implicit none
           integer,parameter :: dp=kind(0.0d0)
           real :: x = 5.2
           real :: y = 2.3
           real(kind=dp) :: dd
              dd = dprod(x,y)
              print *, dd, x*y, kind(x), kind(dd), kind(dprod(x,y))
              ! interesting comparisons
              print *, 52*23
              print *, 52*23/100.0
              print *, 52*23/100.0d0

              !! common extension is to take doubleprecision arguments
              !! and return higher precision
              bigger: block
              doubleprecision :: xx = 5.2d0
              doubleprecision :: yy = 2.3d0
              real(kind=real128) :: ddd
              !ddd = dprod(xx,yy)
              !print *, ddd, xx*yy, kind(xx), kind(ddd), kind(dprod(xx,yy))
              endblock bigger

           end program demo_dprod


C++------------------------------------------------------------
C Program ECO
C To compute the price of a car, comparing with inflation, and
C interest rates
C
C JLP
C Version 02-05-89
C--------------------------------------------------------------
	PROGRAM ECO
	REAL MONEY,TIME,BUDGET
	REAL INI_PRICE,INF_RATE,SAV_RATE,KM_YEAR,INSUR
	REAL KM_MAX,L_100KM,L_PRICE
	REAL C_PETROL,EXPEND
	INTEGER LIFE
	CHARACTER NAME*40
	DATA KM_MAX/90000./

10	FORMAT(A)
	OPEN(1,FILE='eco.log',STATUS='unknown')

	PRINT 70
70	FORMAT(' Program to compute the following problem:',/,
     1	' Asssume that you have the amount MONEY now.',/,
     1	' To compare 2 solutions during the period TIME :',/,
     1	' Buying a new car, or old cars regularly')

	PRINT *,' Amount of money available:'
	READ(5,*) MONEY
	PRINT *,' Yearly budget for the car:'
	READ(5,*) BUDGET
	PRINT *,' Price of the car ?'
	READ(5,*) INI_PRICE
	PRINT *,' Is it :  1=new car   2=old car ?'
	READ(5,*) IOPTION
	PRINT *,' Inflation rate ? (%)'
	READ(5,*) INF_RATE
	PRINT *,' Interest rate in a saving account ? (%)'
	READ(5,*) SAV_RATE
	PRINT *,' Number of km/year :'
	READ(5,*) KM_YEAR
	PRINT *,' Cons. in liter/100km?'
	READ(5,*) L_100KM
	PRINT *,' Price per liter ?'
	READ(5,*) L_PRICE
	PRINT *,' Cost of insurance per year ?'
	READ(5,*) INSUR
	PRINT *,' Average expenditures per year (repairs, etc) ?'
	READ(5,*) EXPEND

	PRINT *,' Name of the car:'
	READ(5,10) NAME

	WRITE(1,88) MONEY,BUDGET,INF_RATE,SAV_RATE,NAME,
     1	INI_PRICE,KM_YEAR,L_100KM,L_PRICE,INSUR,EXPEND
88	FORMAT('       ECO Version 02-05-89',/,
     1	' Money available:',F9.0,T38,
     1	' Yearly budget for the car:',F9.0,/,
     1	' Inflation rate : ',F5.2,T38,
     1	' Saving interest rate : ',F5.2,/,
     1	'       NAME :',A,/,
     1	' Initial price of the car:',F9.0,T38,
     1	' Km/year : ',F7.0,/,
     1	' Cons. in liter/100km : ',F4.1,T38,
     1	' Price per liter :',F6.2,/,
     1	' Insurance per year :',F9.0,T38,
     1	' Average expen./year (repairs,...):',
     1	F8.0)

C******************************************************************
C 1. Computes the number of years before reaching KM_MAX:
	IF(IOPTION.EQ.1)THEN
	  LIFE=NINT(KM_MAX/KM_YEAR)
	  PRINT 80,LIFE
	  WRITE(1,*) 'New car'
	ELSE
	  PRINT *,' Number of years the old car is expected to live?'
	  READ(5,*) LIFE
	  WRITE(1,*) 'Old car'
	ENDIF
	  WRITE(1,80) LIFE
80	  FORMAT(5X,' Life time : ',I2,' years')

C******************************************************************
C Computes the yearly cost of the car:

C 2. Petrol:
	C_PETROL=L_PRICE*L_100KM*(KM_YEAR/100.)
	PRINT 82,C_PETROL,C_PETROL*LIFE,LIFE
	WRITE(1,82) C_PETROL,C_PETROL*LIFE,LIFE
82	FORMAT(5X,' Cost of petrol : ',F10.1,'/year, and ',
     1	F10.1,' for ',I2,' years')

C 3. Total integrated cost, per year, and after LIFE years:
	C_TOTAL=C_PETROL+(INI_PRICE/FLOAT(LIFE))+EXPEND+INSUR
	PRINT 83,C_TOTAL,C_TOTAL*LIFE,LIFE
	WRITE(1,83) C_TOTAL,C_TOTAL*LIFE,LIFE
83	FORMAT(5X,' Total cost : ',F10.1,'/year, and ',F10.1,
     1	' for ',I2,' years')

C******************************************************************
C Compares with another solution, and the implications of
C the immobilisation of the price of the car during this period:

C 4. Interests provided by the difference of money:
	SUM=MONEY-INI_PRICE
	DO I=1,LIFE
C Car expenditures, and budget:
	  SUM=SUM-C_TOTAL+BUDGET
C Interests:
	  SUM=SUM*(1.+(SAV_RATE-INF_RATE)/100)
	END DO
	PRINT 84,LIFE,SUM
	WRITE(1,84) LIFE,SUM
84	FORMAT(5X,' Total reactualised sum available after ',
     1	I2,' years:',F10.1)

        PRINT *,' Logfile in "eco.log"'
	END


! ers_euler_ideal_1d.f90
!
! Exact Riemann Solver for ideal 1D euler equations, producing a
! converged exact solution.
!
! https://github.com/JOThurgood/SimpleCFD/wiki/ers_euler_1d.f90

module shared_data ! a common block essentially

  implicit none

  integer, parameter :: num=selected_real_kind(p=15) !p=6 or 15
  integer :: niter !debug

  real(num) :: rhol, ul, pl, rhor, ur, pr !W_l and W_r
  real(num) :: gamma, gm, gp, g1, g2, g3, g4, g5, g6, g7 !gamma + const
  real(num) :: al,ar, bl, br !more constants
  real(num) :: cl, cr !sound speeds
  real(num) :: ps, us, rhosl, rhosr !star region vars

  integer :: nx !sampling stuff
  real(num) :: x_min, x_max
  real(num) :: t, x0
  real(num), allocatable, dimension(:) :: x, rho_x, u_x, p_x, en_x

  public

  contains

  subroutine constants
    !gamma
    gm = gamma - 1.0_num
    gp = gamma + 1.0_num
    g1 = gm / 2.0_num / gamma
    g2 = gp / 2.0_num / gamma
    g3 = 2.0_num * gamma / gm
    g4 = 2.0_num / gm
    g5 = 2.0_num / gp
    g6 = gm / gp
    g7 = gm / 2.0_num
    !data dependant constants for finding the root of the "f" function
    al = g5 / rhol !only used in pressure function - move out of shared?
    ar = g5 / rhor
    bl = g6 * pl
    br = g6 * pr
    !sound speeds
    cl = sqrt(gamma * pl /rhol)
    cr = sqrt(gamma * pr / rhor)
  end subroutine constants

end module shared_data

module user

  use shared_data

  implicit none

  public

  contains

  subroutine initial_conditions

    ! set these for your problem - default is Sod
    rhol = 1.0_num
    ul = 0.0_num
    pl = 1.0_num
    rhor = 0.125_num
    ur = 0.0_num
    pr = 0.10_num
    gamma = 1.4_num

  end subroutine initial_conditions

  subroutine control !sampling and output options
    t = 0.25_num
    x_min = 0.0_num
    x_max = 1.0_num
    x0 = 0.5_num
    nx = 1000
  end subroutine

end module user

module riemann !subroutines related to calculating star states

  use shared_data

  implicit none

  private

  public :: check_positivity, pstar, ustar, rhostar, sample, &
    newton_raphson

  !if when all is said and done there are any vars only used at
  ! this stage it would be sensible to move here from shared_data

  contains

  subroutine check_positivity
    real(num) :: du, du_crit
    du = ul - ur
    du_crit = cl * g4 + cr * g4
    if (du_crit < du) then
      print *, 'warning - pressure positivity condition violated'
      print *, 'your ICs will create vacuum'
      print *, 'STOP'
      STOP
    else
      print *, 'initial conditions pass p. positivity test OK'
    endif
  end subroutine check_positivity

  subroutine pstar
    call guess_ps
    call newton_raphson
  end subroutine pstar

  subroutine ustar
    us = 0.5_num * (ul + ur) + &
      & 0.5_num * (f(ps,rightonly=1) - f(ps,leftonly=1))
  end subroutine ustar

  subroutine rhostar
    integer :: i
    real(num) :: ck, pk, prat, rhok
    real(num) :: rhos !temp => rhosl or rhosr

    rhosl = 1e15_num !make errors obvious
    rhosr = 1e15_num
    do i = 0,1
      rhos = 1e15_num
      if (i == 0) then
        ck = cl
        pk =  pl
        rhok = rhol
        prat = ps / pk
      else
        ck = cr
        pk = pr
        rhok = rhor
        prat = ps / pk
      endif
      if (ps > pk) then
        rhos = rhok * ( (prat + g6) / (g6 * prat + 1.0_num) )
      else
        rhos = rhok * prat**(1.0_num/gamma)
      endif
      if (i == 0) then
        rhosl = rhos
      else
        rhosr = rhos
      endif
    enddo

  end subroutine rhostar

  subroutine guess_ps !initial guess on pstar
    ! in the interests of speed you, can base your guess on the value of
    ! pstar as the  given by an appropriate choice of approximate
    ! R solver. This should mean that the Newton-Raphson iterates in as
    ! few steps as possible.

    ps = 0.5_num * (pl + pr) ! For now just always use arithmetic mean
  end subroutine guess_ps

  subroutine newton_raphson

    integer :: i
    real(num) :: pold, delta
    real(num) :: tol = 1.0e-6_num
    real(num) :: rpc

    i = 0 !need to define these instead of header
    rpc = 1e15_num ! for sake of test module

    do
      if (rpc <= tol) exit !condition on tolerance
      pold = ps
      delta = f(pold)/fprime(pold)
      ps = pold - delta !f(pold)/fprime(pold)
      rpc = 2.0_num * abs((ps - pold) / (ps + pold))
      i = i + 1
      if (ps < 0.0_num) ps = tol !to correct -ve p guesses
      if (i > 20) print *,'nonconvergence of pstar iteration'
      if (i > 20) exit
    enddo

    niter = i !for test module
  end subroutine newton_raphson

  real(num) function f(p,leftonly,rightonly) !root function
    real(num), intent(in) :: p
    integer, intent(in), optional :: leftonly, rightonly
    real(num) :: ak,bk, pk, prat, ck
    integer :: i, i0, i1

    f = 0.0_num
    i0 = 0
    i1 = 1

    if (present(leftonly)) i1 = 0
    if (present(rightonly)) i0 = 1
    if (present(leftonly) .and. present(rightonly)) then
      PRINT *, 'what are you doing!?'
      STOP
    endif

    do i = i0,i1

      if (i == 0) then
        ak = al
        bk = bl
        ck = cl
        pk =  pl
        prat = p / pk
      else
        ak = ar
        bk = br
        ck = cr
        pk = pr
        prat = p / pk
      endif

      if (p > pk) then
        f = f + (p - pk) * sqrt(ak / (p + bk))
      else
        f = f + g4 * ck * (prat**g1 - 1.0_num)
      endif

    enddo

    f = f + (ur - ul)

    return
  end function

  real(num) function fprime(p) ! 1st derivative
    real(num), intent(in) :: p
    real(num) :: ak,bk,ck, pk, rhok, prat
    integer :: i

    fprime = 0.0_num

    do i = 0,1

      if (i == 0) then
        ak = al
        bk = bl
        ck = cl
        pk = pl
        rhok = rhol
        prat = p / pk
      else
        ak = ar
        bk = br
        ck = cr
        pk = pr
        rhok = rhor
        prat = p / pk
      endif

      if (p > pk) then
        fprime = fprime + &
          & sqrt(ak / (bk + p)) * (1.0_num - 0.5_num * (p-pk)/(bk+p))
      else
        fprime = fprime + prat**(-g2) / (rhok * ck)
      endif

    enddo

    return
  end function

  subroutine sample

    real(num) :: S
    real(num) :: Sk,Shk, Stk
    real(num) :: Sl,Shl, Stl
    real(num) :: Sr,Shr, Str
    real(num) :: ck, pk, rhok, rhosk, uk
    integer :: ix
    real(num) :: dx

    allocate(x(1:nx))
    allocate(rho_x(1:nx))
    allocate(p_x(1:nx))
    allocate(u_x(1:nx))
    allocate(en_x(1:nx))

    dx = (x_max - x_min) / REAL(nx,num)
    do ix = 1, nx
     x(ix) = x_min + REAL(ix,num) * dx
    enddo

    !sampling constants
    Sl = ul - cl * sqrt(g2*ps/pl + g1)
    Sr = ur + cr * sqrt(g2*ps/pr + g1)
    Shl = ul - cl
    Shr = ur + cr
    Stl = us - cl * (ps/pl)**(g1)
    Str = us + cr * (ps/pr)**(g1)

    do ix = 1, nx
      S = (x(ix)-x0) / t

      if (S < us) then !left of contact
!        print *, x(ix),'left of contact'
        Sk = Sl !set stuff like S_k to s_l
        Shk = Shl
        Stk = Stl
        pk = pl
        rhok = rhol
        rhosk = rhosl
        ck = cl
        uk = ul
        if (ps > pk) then !left shock
          if (S < Sk) then !W=Wk
!            print *, x(ix), 'region undisturbed (shock moving into it)'
            rho_x(ix) = rhok
            p_x(ix) = pk
            u_x(ix) = uk
          else !W=W*k
!            print *, x(ix), 'region shocked'
            rho_x(ix) = rhosk
            p_x(ix) = ps
            u_x(ix) = us
          endif
        else  !left rarefaction
          if (S < Shk) then !W=Wk
 !           print *, x(ix), 'region undisturbed (rarefaction moving into it)'
            rho_x(ix) = rhok
            p_x(ix) = pk
            u_x(ix) = uk
          else
            if (S>Stk) then !W = W*k
!            print *, x(ix), 'region between rarefaction tail and CD'
              rho_x(ix) = rhosk
              p_x(ix) = ps
              u_x(ix) = us
            else  !W = Wfan
!            print *, x(ix), 'rarefaction fan'
              rho_x(ix) = rhok * ( g5 + g6 / ck * (uk-S))**g4
              p_x(ix) = pk *  ( g5  + g6 / ck * (uk-S))**g3
              u_x(ix) = g5 * (ck + g7*uk + S)
            endif
          endif
        endif

      else !right of contact
!        print *,x(ix), 'right of contact'
        Sk = Sr
        Shk = Shr
        Stk = Str
        pk = pr
        rhok = rhor
        rhosk = rhosr
        ck = cr
        uk = ur

        if (ps > pk) then !right shock
          if (S > Sk) then !W=Wk
 !           print *, x(ix), 'region undisturbed (shock moving into it)'
            rho_x(ix) = rhok
            p_x(ix) = pk
            u_x(ix) = uk
          else !W=W*k
 !           print *, x(ix), 'region shocked'
            rho_x(ix) = rhosk
            p_x(ix) = ps
            u_x(ix) = us
          endif
        else  !right rarefaction
          if (S > Shk) then !W=Wk
 !           print *, x(ix), 'region undisturbed (rarefaction moving into it)'
            rho_x(ix) = rhok
            p_x(ix) = pk
            u_x(ix) = uk
          else
            if (S<Stk) then !W = W*k
  !          print *, x(ix), 'region between rarefaction tail and CD'
              rho_x(ix) = rhosk
              p_x(ix) = ps
              u_x(ix) = us
            else  !W = Wfan
  !          print *, x(ix), 'rarefaction fan'
              rho_x(ix) = rhok * ( g5 - g6 / ck * (uk-S))**g4
              p_x(ix) = pk *  ( g5 - g6 / ck * (uk-S))**g3
              u_x(ix) = g5 * (-ck + g7 * uk + S)
            endif
          endif
        endif

      endif !left or right
    end do !ix

    en_x = p_x / gm / rho_x

  end subroutine sample

end module riemann

module tests !subroutines for automatic testing

  use shared_data
  use riemann

  implicit none

  private

  public :: test_starvals, test_1,test_2,test_3,test_4,test_5

  logical :: test_star = .true.
  logical :: verbose = .false.

  contains

  subroutine test_starvals
    call test_pstar
    call test_ustar
    call test_rhostar
    if (test_star) then
      print *, 'passed all comparison tests for star vals'
    else
      print *, 'failed a star test - run with verbose to debug'
    endif
  end subroutine test_starvals
  subroutine test_pstar !check pstar and iteration info
    logical :: test1 = .true.
    real(num) :: tol = 1e-6_num
    real(num), dimension(5) :: p_toro
    real(num), dimension(4,5) :: p0_toro
    integer, dimension(4,5) :: i_toro
    integer :: i

    !toro
    p_toro = (/0.30313_num, 0.00189_num, 460.894_num, 46.0950_num, &
      & 1691.64_num /)

    i_toro = reshape( (/3,5,3,5, &
                      1, 8, 8 ,9, &
                      5, 4, 3, 4, &
                      5, 4, 3, 4, &
                      4, 5, 4, 6/), shape(i_toro))!, order = (/2,1/) )

    p0_toro = reshape((/0.30677_num, 0.55_num, 0.31527_num, 0.55_num, &
      & 0.00189387344_num, tol, tol, 0.4_num, &
      & 912.449_num, 500.005_num, 464.108_num, 500.005_num, &
      & 82.9831_num, 50.005_num, 46.4162_num, 50.005_num, &
      & 2322.65_num, 781.353_num, 1241.21_num, 253.494_num/), &
      & shape(p0_toro) )

!    do i=1,5
!      print *,'i_toro',i_toro(:,i)
!      print *,'p0_toro',p0_toro(:,i)
!    enddo

    call test_1 ! initialise  Sods' test
    do i = 1, 4
      ps = p0_toro(i,1)
      call newton_raphson
      if (verbose) &
        & print *, 'test 1: ','p0', p0_toro(i,1), 'ps',ps,'niter',niter
      if (niter .ne. i_toro(i,1)) then
        print *,'fail'
        test1 = .false.
      endif
    enddo

    call test_2
    do i = 1, 4
      ps = p0_toro(i,2)
      call newton_raphson
      if (verbose) &
        & print *, 'test 2: ','p0', p0_toro(i,2), 'ps',ps,'niter',niter
      if (niter .ne. i_toro(i,2)) print *,'fail'
    enddo

    call test_3
    do i = 1, 4
      ps = p0_toro(i,3)
      call newton_raphson
      if (verbose) &
        & print *, 'test 3: ','p0', p0_toro(i,3), 'ps',ps,'niter',niter
      if (niter .ne. i_toro(i,3)) print *,'fail'
    enddo

    call test_4
    do i = 1, 4
      ps = p0_toro(i,4)
      call newton_raphson
      if (verbose) &
        & print *, 'test 4: ','p0', p0_toro(i,4), 'ps',ps,'niter',niter
      if (niter .ne. i_toro(i,4)) print *,'fail'
    enddo

    call test_5
    do i = 1, 4
      ps = p0_toro(i,5)
      call newton_raphson
      if (verbose) &
        & print *, 'test 5: ','p0', p0_toro(i,5), 'ps',ps,'niter',niter
      if (niter .ne. i_toro(i,5)) print *,'fail'
    enddo

    if (test1) then
      print *,'passed pstar test'
    else
      print *,'failed pstar test'
      test_star = .false.
    endif

  end subroutine test_pstar

  subroutine test_ustar
    real (num) :: diff, utoro
    logical :: test2 = .true.

    call test_1
    call pstar
    call ustar
    utoro = 0.92745_num
    diff = 2.0_num * (us - utoro) / (us + utoro)
    if (verbose) print *, 'ustar-test1 and diff',us,diff
    if (abs(diff) > 5e-6_num) then
      if (verbose) print *,  'ustar fail on test1',diff
      test2 = .false.
    endif

    call test_2
    call pstar
    call ustar
    utoro =  0.00000_num
    diff = 2.0_num * (us - utoro) / (us + utoro)
    if (verbose) print *, 'ustar-test2 and diff',us,diff
    if (abs(diff) > 5e-6_num) then
      if (verbose) print *, 'ustar fail on test2',diff
      test2 = .false.
    endif

    call test_3
    call pstar
    call ustar
    utoro = 19.5975_num
    diff = 2.0_num * (us - utoro) / (us + utoro)
    if (verbose) print *, 'ustar-test3 and diff',us,diff
    if (abs(diff) > 5e-6_num) then
      if (verbose) print *, 'ustar fail on test3',diff
      test2 = .false.
    endif

    call test_4
    call pstar
    call ustar
    utoro = -6.19633_num
    diff = 2.0_num * (us - utoro) / (us + utoro)
    if (verbose) print *, 'ustar-test4 and diff',us,diff
    if (abs(diff) > 5e-6_num) then
      if (verbose) print *, 'ustar fail on test4',diff
      test2 = .false.
    endif

    call test_5
    call pstar
    call ustar
    utoro = 8.68975_num
    diff = 2.0_num * (us - utoro) / (us + utoro)
    if (verbose) print *, 'ustar-test5 and diff',us,diff
    if (abs(diff) > 5e-6_num) then
      if (verbose) print *, 'ustar fail on test4',diff
      test2 = .false.
    endif

    if (test2) then
      print *,'passed ustar test'
    else
      print *,'failed ustar test'
      test_star = .false.
    endif
  end subroutine test_ustar

  subroutine test_rhostar

    real (num) :: diff, ltoro, rtoro
    logical :: test3 = .true.

    call test_1
    call pstar
    call ustar
    call rhostar

    ltoro = 0.42632_num
    diff = rhosl-ltoro
!    diff = 2.0_num * (rhosl - ltoro) / (rhosl + ltoro)
    if (verbose) print *, 'rhostar left-test1 and diff',rhosl,diff
    if (abs(diff) > 5e-6_num) then
      if (verbose) print *,  'rhostar fail on test1 left'
      test3 = .false.
    endif

    rtoro = 0.26557_num
    diff = rhosr-rtoro
!   diff = 2.0_num * (rhosr - rtoro) / (rhosr + rtoro)
    if (verbose) print *, 'rhostar right -test1 and diff',rhosr,diff
    if (abs(diff) > 5e-6_num) then
      if (verbose) print *,  'rhostar fail on test1 right'
      test3 = .false.
    endif

    call test_2
    call pstar
    call ustar
    call rhostar

    ltoro = 0.02185_num
    diff = rhosl-ltoro
    !diff = 2.0_num * (rhosl - ltoro) / (rhosl + ltoro)
    if (verbose) print *, 'rhostar left-test2 and diff',rhosl,diff
    if (abs(diff) > 5e-6_num) then
      if (verbose) print *,  'rhostar fail on test2 left'
      test3 = .false.
    endif

    rtoro = ltoro
    diff = rhosr-rtoro
!    diff = 2.0_num * (rhosr - rtoro) / (rhosr + rtoro)
    if (verbose) print *, 'rhostar right -test2 and diff',rhosr,diff
    if (abs(diff) > 5e-6_num) then
      if (verbose) print *,  'rhostar fail on test2 right'
      test3 = .false.
    endif

    call test_3
    call pstar
    call ustar
    call rhostar

    ltoro = 0.57506_num
    diff = rhosl-ltoro
    !diff = 2.0_num * (rhosl - ltoro) / (rhosl + ltoro)
    if (verbose) print *, 'rhostar left-test3 and diff',rhosl,diff
    if (abs(diff) > 5e-6_num) then
      if (verbose) print *,  'rhostar fail on test3 left'
      test3 = .false.
    endif

    rtoro = 5.99924_num
    diff = rhosr-rtoro
!    diff = 2.0_num * (rhosr - rtoro) / (rhosr + rtoro)
    if (verbose) print *, 'rhostar right -test3 and diff',rhosr,diff
    if (abs(diff) > 5e-6_num) then
      if (verbose) print *,  'rhostar fail on test3 right'
      test3 = .false.
    endif

    call test_4
    call pstar
    call ustar
    call rhostar

    ltoro = 5.99242_num
    diff = rhosl-ltoro
    !diff = 2.0_num * (rhosl - ltoro) / (rhosl + ltoro)
    if (verbose) print *, 'rhostar left-test4 and diff',rhosl,diff
    if (abs(diff) > 5e-6_num) then
      if (verbose) print *,  'rhostar fail on test4 left'
      test3 = .false.
    endif

    rtoro = 0.57511_num
    diff = rhosr-rtoro
!    diff = 2.0_num * (rhosr - rtoro) / (rhosr + rtoro)
    if (verbose) print *, 'rhostar right -test4 and diff',rhosr,diff
    if (abs(diff) > 5e-6_num) then
      if (verbose) print *,  'rhostar fail on test4 rightt'
      test3 = .false.
    endif

    call test_5
    call pstar
    call ustar
    call rhostar

    ltoro = 14.2823_num
    diff = rhosl-ltoro
    !diff = 2.0_num * (rhosl - ltoro) / (rhosl + ltoro)
    if (verbose) print *, 'rhostar left-test5 and diff',rhosl,diff
    if (abs(diff) > 5e-5_num) then
      if (verbose) print *,  'rhostar fail on test5 left'
      test3 = .false.
    endif

    rtoro = 31.0426_num
    diff = rhosr-rtoro
!    diff = 2.0_num * (rhosr - rtoro) / (rhosr + rtoro)
    if (verbose) print *, 'rhostar right -test5 and diff',rhosr,diff
    if (abs(diff) > 5e-5_num) then !bit higher tol
      !Toro gives only to certain sf's - by inspection this is
      !acceptable within roundoff
      if (verbose) print *,  'rhostar fail on test5 right'
      test3 = .false.
    endif
    if (test3) then
      print *,'passed rhostar test'
    else
      print *,'failed rhostar test'
      test_star = .false.
    endif
  endsubroutine test_rhostar

  ! predefined initial conditions

  subroutine test_1 !Sod's test
    rhol = 1.0_num
    ul = 0.0_num
    pl = 1.0_num
    rhor = 0.125_num
    ur = 0.0_num
    pr = 0.10_num
    gamma = 1.4_num
    call constants !reset constants
  end subroutine test_1

  subroutine test_1_r !Reverse Sod's test for symmetry test in p*
    rhor = 1.0_num
    ur = 0.0_num
    pr = 1.0_num
    rhol = 0.125_num !1.0_num / 8.0_num
    ul = 0.0_num
    pl = 0.10_num
    gamma = 1.4_num
    call constants !reset constants
    t = 0.25_num
  end subroutine test_1_r

  subroutine test_2 !1,2,3 problem
    rhol = 1.0_num
    ul = -2.0_num
    pl = 0.4_num
    rhor = 1.0_num
    ur = 2.0_num
    pr = 0.4_num
    gamma = 1.4_num
    call constants !reset constants
    t = 0.15_num
  end subroutine test_2

  subroutine test_3 !left half blast
    rhol = 1.0_num
    ul = 0.0_num
    pl = 1000.0_num
    rhor = 1.0_num
    ur = 0.0_num
    pr = 0.01_num
    gamma = 1.4_num
    call constants !reset constants
    t = 0.012_num
  end subroutine test_3

  subroutine test_4 !right half
    rhol = 1.0_num
    ul = 0.0_num
    pl = 0.01_num
    rhor = 1.0_num
    ur = 0.0_num
    pr = 100.0_num
    gamma = 1.4_num
    call constants !reset constants
    t = 0.035_num
  end subroutine test_4

  subroutine test_5 !both halfs of the W+C blast
    rhol = 5.99924_num
    ul = 19.5975_num
    pl = 460.894_num
    rhor= 5.99242_num
    ur = -6.19633_num
    pr = 46.0950_num
    gamma = 1.4_num
    call constants !reset constants
    t = 0.035_num
  end subroutine

end module tests

module diagnostics

  use shared_data

  implicit none

  contains

  subroutine do_io
    integer :: out_unit =10
    call execute_command_line("rm -rf x.dat rho.dat p.dat u.dat en.dat")
       !^ dont stream to existing
    open(out_unit, file="x.dat", access="stream")
    write(out_unit) x
    close(out_unit)
    open(out_unit, file="rho.dat", access="stream")
    write(out_unit) rho_x
    close(out_unit)
    open(out_unit, file="p.dat", access="stream")
    write(out_unit) p_x
    close(out_unit)
    open(out_unit, file="u.dat", access="stream")
    write(out_unit) u_x
    close(out_unit)
    open(out_unit, file="en.dat", access="stream")
    write(out_unit) en_x
    close(out_unit)
    call execute_command_line("python plot1.py")
  end subroutine do_io

end module diagnostics

program ers_euler_ideal_1d

  use shared_data
  use riemann
  use user
  use tests
  use diagnostics

  implicit none

  call test_starvals !check passes all numerical tests

  call initial_conditions
  call constants
  call control

!  print *, 'warning: overwrite user initial conditions with test case'
!  call test_5 !_1, _2, _3, _4, _5
!  uncomment above to qualitatively test
!  sampling routines against Figs 4.7- 4.11 in Toro

  call check_positivity

  call pstar
  call ustar
  call rhostar

  call sample

  call do_io

end program ers_euler_ideal_1d


program track2gmt
  integer :: ipunit = 30
  integer :: ifunit = 31
  integer :: opunit = 40
  integer :: ofunit = 41

  integer :: ifmax
  character(len=128) :: tmpdir = "/tmp/"
  character(len=128) :: ipfile
  character(len=128) :: iffile
  character(len=128) :: opfile
  character(len=128) :: offile
  real    :: lat, lon
  real    :: dlat, dlon, mlat, mlon
  character(len=1)   :: NS, WE
  integer :: io
  ipfile = trim(tmpdir)//"position.csv"
  iffile = trim(tmpdir)//"futurepath.csv"
  opfile = trim(tmpdir)//"position.txt"
  offile = trim(tmpdir)//"futurepath.txt"
  open(ipunit,file=trim(ipfile),action='read' ,form='formatted')
  open(ifunit,file=trim(iffile),action='read' ,form='formatted')
  open(opunit,file=trim(opfile),action='write',form='formatted')
  open(ofunit,file=trim(offile),action='write',form='formatted')
  read(ipunit,'(f2.0,f9.5,A,f5.0,f9.5,A)') dlat,mlat,NS,dlon,mlon,WE
  lat = dlat + (mlat / 60.)
  if(WE == 'E') then
    lon = dlon + (mlon / 60.)
  else
    lon = - dlon + (mlon / 60.)
  endif
  write(opunit,*) lon,  lat

  do while (io==0)
    read(ifunit,'(f2.0,f8.4,A,f4.0,f8.4,A)', IOSTAT=io) dlat,mlat,NS,dlon,mlon,WE
    lat = dlat + (mlat / 60.)
    if(WE == 'E') then
      lon = dlon + (mlon / 60.)
    else
      lon = - dlon + (mlon / 60.)
    endif
    write(ofunit,*) lon, lat
    write(*,*) lon, lat
  enddo
  close(opunit)
  close(ofunit)
  close(ipunit)
  close(ifunit)
end program track2gmt