!*==dorcsd2by1.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022

!> \brief \b DORCSD2BY1
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DORCSD2BY1 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
!                              X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
!                              LDV1T, WORK, LWORK, IWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBU1, JOBU2, JOBV1T
!       INTEGER            INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
!      $                   M, P, Q
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   THETA(*)
!       DOUBLE PRECISION   U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
!      $                   X11(LDX11,*), X21(LDX21,*)
!       INTEGER            IWORK(*)
!       ..
!
!
!> \par Purpose:
!  =============
!>
!>\verbatim
!>
!> DORCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with
!> orthonormal columns that has been partitioned into a 2-by-1 block
!> structure:
!>
!>                                [  I1 0  0 ]
!>                                [  0  C  0 ]
!>          [ X11 ]   [ U1 |    ] [  0  0  0 ]
!>      X = [-----] = [---------] [----------] V1**T .
!>          [ X21 ]   [    | U2 ] [  0  0  0 ]
!>                                [  0  S  0 ]
!>                                [  0  0  I2]
!>
!> X11 is P-by-Q. The orthogonal matrices U1, U2, and V1 are P-by-P,
!> (M-P)-by-(M-P), and Q-by-Q, respectively. C and S are R-by-R
!> nonnegative diagonal matrices satisfying C^2 + S^2 = I, in which
!> R = MIN(P,M-P,Q,M-Q). I1 is a K1-by-K1 identity matrix and I2 is a
!> K2-by-K2 identity matrix, where K1 = MAX(Q+P-M,0), K2 = MAX(Q-P,0).
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBU1
!> \verbatim
!>          JOBU1 is CHARACTER
!>          = 'Y':      U1 is computed;
!>          otherwise:  U1 is not computed.
!> \endverbatim
!>
!> \param[in] JOBU2
!> \verbatim
!>          JOBU2 is CHARACTER
!>          = 'Y':      U2 is computed;
!>          otherwise:  U2 is not computed.
!> \endverbatim
!>
!> \param[in] JOBV1T
!> \verbatim
!>          JOBV1T is CHARACTER
!>          = 'Y':      V1T is computed;
!>          otherwise:  V1T is not computed.
!> \endverbatim
!>
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows in X.
!> \endverbatim
!>
!> \param[in] P
!> \verbatim
!>          P is INTEGER
!>          The number of rows in X11. 0 <= P <= M.
!> \endverbatim
!>
!> \param[in] Q
!> \verbatim
!>          Q is INTEGER
!>          The number of columns in X11 and X21. 0 <= Q <= M.
!> \endverbatim
!>
!> \param[in,out] X11
!> \verbatim
!>          X11 is DOUBLE PRECISION array, dimension (LDX11,Q)
!>          On entry, part of the orthogonal matrix whose CSD is desired.
!> \endverbatim
!>
!> \param[in] LDX11
!> \verbatim
!>          LDX11 is INTEGER
!>          The leading dimension of X11. LDX11 >= MAX(1,P).
!> \endverbatim
!>
!> \param[in,out] X21
!> \verbatim
!>          X21 is DOUBLE PRECISION array, dimension (LDX21,Q)
!>          On entry, part of the orthogonal matrix whose CSD is desired.
!> \endverbatim
!>
!> \param[in] LDX21
!> \verbatim
!>          LDX21 is INTEGER
!>          The leading dimension of X21. LDX21 >= MAX(1,M-P).
!> \endverbatim
!>
!> \param[out] THETA
!> \verbatim
!>          THETA is DOUBLE PRECISION array, dimension (R), in which R =
!>          MIN(P,M-P,Q,M-Q).
!>          C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and
!>          S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).
!> \endverbatim
!>
!> \param[out] U1
!> \verbatim
!>          U1 is DOUBLE PRECISION array, dimension (P)
!>          If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1.
!> \endverbatim
!>
!> \param[in] LDU1
!> \verbatim
!>          LDU1 is INTEGER
!>          The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
!>          MAX(1,P).
!> \endverbatim
!>
!> \param[out] U2
!> \verbatim
!>          U2 is DOUBLE PRECISION array, dimension (M-P)
!>          If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal
!>          matrix U2.
!> \endverbatim
!>
!> \param[in] LDU2
!> \verbatim
!>          LDU2 is INTEGER
!>          The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
!>          MAX(1,M-P).
!> \endverbatim
!>
!> \param[out] V1T
!> \verbatim
!>          V1T is DOUBLE PRECISION array, dimension (Q)
!>          If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal
!>          matrix V1**T.
!> \endverbatim
!>
!> \param[in] LDV1T
!> \verbatim
!>          LDV1T is INTEGER
!>          The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
!>          MAX(1,Q).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>          If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),
!>          ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
!>          define the matrix in intermediate bidiagonal-block form
!>          remaining after nonconvergence. INFO specifies the number
!>          of nonzero PHI's.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the work array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] IWORK
!> \verbatim
!>          IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q))
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  DBBCSD did not converge. See the description of WORK
!>                above for details.
!> \endverbatim
!
!> \par References:
!  ================
!>
!>  [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
!>      Algorithms, 50(1):33-65, 2009.
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date July 2012
!
!> \ingroup doubleOTHERcomputational
!
!  =====================================================================
      SUBROUTINE DORCSD2BY1(Jobu1,Jobu2,Jobv1t,M,P,Q,X11,Ldx11,X21,     &
     &                      Ldx21,Theta,U1,Ldu1,U2,Ldu2,V1t,Ldv1t,Work, &
     &                      Lwork,Iwork,Info)
      IMPLICIT NONE
!*--DORCSD2BY1238
!
!  -- LAPACK computational routine (3.5.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     July 2012
!
!     .. Scalar Arguments ..
      CHARACTER Jobu1 , Jobu2 , Jobv1t
      INTEGER Info , Ldu1 , Ldu2 , Ldv1t , Lwork , Ldx11 , Ldx21 , M ,  &
     &        P , Q
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION Theta(*)
      DOUBLE PRECISION U1(Ldu1,*) , U2(Ldu2,*) , V1t(Ldv1t,*) , Work(*) &
     &                 , X11(Ldx11,*) , X21(Ldx21,*)
      INTEGER Iwork(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ONE , ZERO
      PARAMETER (ONE=1.0D0,ZERO=0.0D0)
!     ..
!     .. Local Scalars ..
      INTEGER childinfo , i , ib11d , ib11e , ib12d , ib12e , ib21d ,   &
     &        ib21e , ib22d , ib22e , ibbcsd , iorbdb , iorglq ,        &
     &        iorgqr , iphi , itaup1 , itaup2 , itauq1 , j , lbbcsd ,   &
     &        lorbdb , lorglq , lorglqmin , lorglqopt , lorgqr ,        &
     &        lorgqrmin , lorgqropt , lworkmin , lworkopt , r
      LOGICAL lquery , wantu1 , wantu2 , wantv1t
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION dum1(1) , dum2(1,1)
!     ..
!     .. External Subroutines ..
      EXTERNAL DBBCSD , DCOPY , DLACPY , DLAPMR , DLAPMT , DORBDB1 ,    &
     &         DORBDB2 , DORBDB3 , DORBDB4 , DORGLQ , DORGQR , XERBLA
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. Intrinsic Function ..
      INTRINSIC INT , MAX , MIN
!     ..
!     .. Executable Statements ..
!
!     Test input arguments
!
      Info = 0
      wantu1 = LSAME(Jobu1,'Y')
      wantu2 = LSAME(Jobu2,'Y')
      wantv1t = LSAME(Jobv1t,'Y')
      lquery = Lwork== - 1
!
      IF ( M<0 ) THEN
         Info = -4
      ELSEIF ( P<0 .OR. P>M ) THEN
         Info = -5
      ELSEIF ( Q<0 .OR. Q>M ) THEN
         Info = -6
      ELSEIF ( Ldx11<MAX(1,P) ) THEN
         Info = -8
      ELSEIF ( Ldx21<MAX(1,M-P) ) THEN
         Info = -10
      ELSEIF ( wantu1 .AND. Ldu1<MAX(1,P) ) THEN
         Info = -13
      ELSEIF ( wantu2 .AND. Ldu2<MAX(1,M-P) ) THEN
         Info = -15
      ELSEIF ( wantv1t .AND. Ldv1t<MAX(1,Q) ) THEN
         Info = -17
      ENDIF
!
      r = MIN(P,M-P,Q,M-Q)
!
!     Compute workspace
!
!       WORK layout:
!     |-------------------------------------------------------|
!     | LWORKOPT (1)                                          |
!     |-------------------------------------------------------|
!     | PHI (MAX(1,R-1))                                      |
!     |-------------------------------------------------------|
!     | TAUP1 (MAX(1,P))                        | B11D (R)    |
!     | TAUP2 (MAX(1,M-P))                      | B11E (R-1)  |
!     | TAUQ1 (MAX(1,Q))                        | B12D (R)    |
!     |-----------------------------------------| B12E (R-1)  |
!     | DORBDB WORK | DORGQR WORK | DORGLQ WORK | B21D (R)    |
!     |             |             |             | B21E (R-1)  |
!     |             |             |             | B22D (R)    |
!     |             |             |             | B22E (R-1)  |
!     |             |             |             | DBBCSD WORK |
!     |-------------------------------------------------------|
!
      IF ( Info==0 ) THEN
         iphi = 2
         ib11d = iphi + MAX(1,r-1)
         ib11e = ib11d + MAX(1,r)
         ib12d = ib11e + MAX(1,r-1)
         ib12e = ib12d + MAX(1,r)
         ib21d = ib12e + MAX(1,r-1)
         ib21e = ib21d + MAX(1,r)
         ib22d = ib21e + MAX(1,r-1)
         ib22e = ib22d + MAX(1,r)
         ibbcsd = ib22e + MAX(1,r-1)
         itaup1 = iphi + MAX(1,r-1)
         itaup2 = itaup1 + MAX(1,P)
         itauq1 = itaup2 + MAX(1,M-P)
         iorbdb = itauq1 + MAX(1,Q)
         iorgqr = itauq1 + MAX(1,Q)
         iorglq = itauq1 + MAX(1,Q)
         lorgqrmin = 1
         lorgqropt = 1
         lorglqmin = 1
         lorglqopt = 1
         IF ( r==Q ) THEN
            CALL DORBDB1(M,P,Q,X11,Ldx11,X21,Ldx21,Theta,dum1,dum1,dum1,&
     &                   dum1,Work,-1,childinfo)
            lorbdb = INT(Work(1))
            IF ( wantu1 .AND. P>0 ) THEN
               CALL DORGQR(P,P,Q,U1,Ldu1,dum1,Work(1),-1,childinfo)
               lorgqrmin = MAX(lorgqrmin,P)
               lorgqropt = MAX(lorgqropt,INT(Work(1)))
            ENDIF
            IF ( wantu2 .AND. M>P ) THEN
               CALL DORGQR(M-P,M-P,Q,U2,Ldu2,dum1,Work(1),-1,childinfo)
               lorgqrmin = MAX(lorgqrmin,M-P)
               lorgqropt = MAX(lorgqropt,INT(Work(1)))
            ENDIF
            IF ( wantv1t .AND. Q>0 ) THEN
               CALL DORGLQ(Q-1,Q-1,Q-1,V1t,Ldv1t,dum1,Work(1),-1,       &
     &                     childinfo)
               lorglqmin = MAX(lorglqmin,Q-1)
               lorglqopt = MAX(lorglqopt,INT(Work(1)))
            ENDIF
            CALL DBBCSD(Jobu1,Jobu2,Jobv1t,'N','N',M,P,Q,Theta,dum1,U1, &
     &                  Ldu1,U2,Ldu2,V1t,Ldv1t,dum2,1,dum1,dum1,dum1,   &
     &                  dum1,dum1,dum1,dum1,dum1,Work(1),-1,childinfo)
            lbbcsd = INT(Work(1))
         ELSEIF ( r==P ) THEN
            CALL DORBDB2(M,P,Q,X11,Ldx11,X21,Ldx21,Theta,dum1,dum1,dum1,&
     &                   dum1,Work(1),-1,childinfo)
            lorbdb = INT(Work(1))
            IF ( wantu1 .AND. P>0 ) THEN
               CALL DORGQR(P-1,P-1,P-1,U1(2,2),Ldu1,dum1,Work(1),-1,    &
     &                     childinfo)
               lorgqrmin = MAX(lorgqrmin,P-1)
               lorgqropt = MAX(lorgqropt,INT(Work(1)))
            ENDIF
            IF ( wantu2 .AND. M>P ) THEN
               CALL DORGQR(M-P,M-P,Q,U2,Ldu2,dum1,Work(1),-1,childinfo)
               lorgqrmin = MAX(lorgqrmin,M-P)
               lorgqropt = MAX(lorgqropt,INT(Work(1)))
            ENDIF
            IF ( wantv1t .AND. Q>0 ) THEN
               CALL DORGLQ(Q,Q,r,V1t,Ldv1t,dum1,Work(1),-1,childinfo)
               lorglqmin = MAX(lorglqmin,Q)
               lorglqopt = MAX(lorglqopt,INT(Work(1)))
            ENDIF
            CALL DBBCSD(Jobv1t,'N',Jobu1,Jobu2,'T',M,Q,P,Theta,dum1,V1t,&
     &                  Ldv1t,dum2,1,U1,Ldu1,U2,Ldu2,dum1,dum1,dum1,    &
     &                  dum1,dum1,dum1,dum1,dum1,Work(1),-1,childinfo)
            lbbcsd = INT(Work(1))
         ELSEIF ( r==M-P ) THEN
            CALL DORBDB3(M,P,Q,X11,Ldx11,X21,Ldx21,Theta,dum1,dum1,dum1,&
     &                   dum1,Work(1),-1,childinfo)
            lorbdb = INT(Work(1))
            IF ( wantu1 .AND. P>0 ) THEN
               CALL DORGQR(P,P,Q,U1,Ldu1,dum1,Work(1),-1,childinfo)
               lorgqrmin = MAX(lorgqrmin,P)
               lorgqropt = MAX(lorgqropt,INT(Work(1)))
            ENDIF
            IF ( wantu2 .AND. M>P ) THEN
               CALL DORGQR(M-P-1,M-P-1,M-P-1,U2(2,2),Ldu2,dum1,Work(1), &
     &                     -1,childinfo)
               lorgqrmin = MAX(lorgqrmin,M-P-1)
               lorgqropt = MAX(lorgqropt,INT(Work(1)))
            ENDIF
            IF ( wantv1t .AND. Q>0 ) THEN
               CALL DORGLQ(Q,Q,r,V1t,Ldv1t,dum1,Work(1),-1,childinfo)
               lorglqmin = MAX(lorglqmin,Q)
               lorglqopt = MAX(lorglqopt,INT(Work(1)))
            ENDIF
            CALL DBBCSD('N',Jobv1t,Jobu2,Jobu1,'T',M,M-Q,M-P,Theta,dum1,&
     &                  dum2,1,V1t,Ldv1t,U2,Ldu2,U1,Ldu1,dum1,dum1,dum1,&
     &                  dum1,dum1,dum1,dum1,dum1,Work(1),-1,childinfo)
            lbbcsd = INT(Work(1))
         ELSE
            CALL DORBDB4(M,P,Q,X11,Ldx11,X21,Ldx21,Theta,dum1,dum1,dum1,&
     &                   dum1,dum1,Work(1),-1,childinfo)
            lorbdb = M + INT(Work(1))
            IF ( wantu1 .AND. P>0 ) THEN
               CALL DORGQR(P,P,M-Q,U1,Ldu1,dum1,Work(1),-1,childinfo)
               lorgqrmin = MAX(lorgqrmin,P)
               lorgqropt = MAX(lorgqropt,INT(Work(1)))
            ENDIF
            IF ( wantu2 .AND. M>P ) THEN
               CALL DORGQR(M-P,M-P,M-Q,U2,Ldu2,dum1,Work(1),-1,         &
     &                     childinfo)
               lorgqrmin = MAX(lorgqrmin,M-P)
               lorgqropt = MAX(lorgqropt,INT(Work(1)))
            ENDIF
            IF ( wantv1t .AND. Q>0 ) THEN
               CALL DORGLQ(Q,Q,Q,V1t,Ldv1t,dum1,Work(1),-1,childinfo)
               lorglqmin = MAX(lorglqmin,Q)
               lorglqopt = MAX(lorglqopt,INT(Work(1)))
            ENDIF
            CALL DBBCSD(Jobu2,Jobu1,'N',Jobv1t,'N',M,M-P,M-Q,Theta,dum1,&
     &                  U2,Ldu2,U1,Ldu1,dum2,1,V1t,Ldv1t,dum1,dum1,dum1,&
     &                  dum1,dum1,dum1,dum1,dum1,Work(1),-1,childinfo)
            lbbcsd = INT(Work(1))
         ENDIF
         lworkmin = MAX(iorbdb+lorbdb-1,iorgqr+lorgqrmin-1,             &
     &              iorglq+lorglqmin-1,ibbcsd+lbbcsd-1)
         lworkopt = MAX(iorbdb+lorbdb-1,iorgqr+lorgqropt-1,             &
     &              iorglq+lorglqopt-1,ibbcsd+lbbcsd-1)
         Work(1) = lworkopt
         IF ( Lwork<lworkmin .AND. .NOT.lquery ) Info = -19
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('DORCSD2BY1',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
      lorgqr = Lwork - iorgqr + 1
      lorglq = Lwork - iorglq + 1
!
!     Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q,
!     in which R = MIN(P,M-P,Q,M-Q)
!
      IF ( r==Q ) THEN
!
!        Case 1: R = Q
!
!        Simultaneously bidiagonalize X11 and X21
!
         CALL DORBDB1(M,P,Q,X11,Ldx11,X21,Ldx21,Theta,Work(iphi),       &
     &                Work(itaup1),Work(itaup2),Work(itauq1),           &
     &                Work(iorbdb),lorbdb,childinfo)
!
!        Accumulate Householder reflectors
!
         IF ( wantu1 .AND. P>0 ) THEN
            CALL DLACPY('L',P,Q,X11,Ldx11,U1,Ldu1)
            CALL DORGQR(P,P,Q,U1,Ldu1,Work(itaup1),Work(iorgqr),lorgqr, &
     &                  childinfo)
         ENDIF
         IF ( wantu2 .AND. M>P ) THEN
            CALL DLACPY('L',M-P,Q,X21,Ldx21,U2,Ldu2)
            CALL DORGQR(M-P,M-P,Q,U2,Ldu2,Work(itaup2),Work(iorgqr),    &
     &                  lorgqr,childinfo)
         ENDIF
         IF ( wantv1t .AND. Q>0 ) THEN
            V1t(1,1) = ONE
            DO j = 2 , Q
               V1t(1,j) = ZERO
               V1t(j,1) = ZERO
            ENDDO
            CALL DLACPY('U',Q-1,Q-1,X21(1,2),Ldx21,V1t(2,2),Ldv1t)
            CALL DORGLQ(Q-1,Q-1,Q-1,V1t(2,2),Ldv1t,Work(itauq1),        &
     &                  Work(iorglq),lorglq,childinfo)
         ENDIF
!
!        Simultaneously diagonalize X11 and X21.
!
         CALL DBBCSD(Jobu1,Jobu2,Jobv1t,'N','N',M,P,Q,Theta,Work(iphi), &
     &               U1,Ldu1,U2,Ldu2,V1t,Ldv1t,dum2,1,Work(ib11d),      &
     &               Work(ib11e),Work(ib12d),Work(ib12e),Work(ib21d),   &
     &               Work(ib21e),Work(ib22d),Work(ib22e),Work(ibbcsd),  &
     &               lbbcsd,childinfo)
!
!        Permute rows and columns to place zero submatrices in
!        preferred positions
!
         IF ( Q>0 .AND. wantu2 ) THEN
            DO i = 1 , Q
               Iwork(i) = M - P - Q + i
            ENDDO
            DO i = Q + 1 , M - P
               Iwork(i) = i - Q
            ENDDO
            CALL DLAPMT(.FALSE.,M-P,M-P,U2,Ldu2,Iwork)
         ENDIF
      ELSEIF ( r==P ) THEN
!
!        Case 2: R = P
!
!        Simultaneously bidiagonalize X11 and X21
!
         CALL DORBDB2(M,P,Q,X11,Ldx11,X21,Ldx21,Theta,Work(iphi),       &
     &                Work(itaup1),Work(itaup2),Work(itauq1),           &
     &                Work(iorbdb),lorbdb,childinfo)
!
!        Accumulate Householder reflectors
!
         IF ( wantu1 .AND. P>0 ) THEN
            U1(1,1) = ONE
            DO j = 2 , P
               U1(1,j) = ZERO
               U1(j,1) = ZERO
            ENDDO
            CALL DLACPY('L',P-1,P-1,X11(2,1),Ldx11,U1(2,2),Ldu1)
            CALL DORGQR(P-1,P-1,P-1,U1(2,2),Ldu1,Work(itaup1),          &
     &                  Work(iorgqr),lorgqr,childinfo)
         ENDIF
         IF ( wantu2 .AND. M>P ) THEN
            CALL DLACPY('L',M-P,Q,X21,Ldx21,U2,Ldu2)
            CALL DORGQR(M-P,M-P,Q,U2,Ldu2,Work(itaup2),Work(iorgqr),    &
     &                  lorgqr,childinfo)
         ENDIF
         IF ( wantv1t .AND. Q>0 ) THEN
            CALL DLACPY('U',P,Q,X11,Ldx11,V1t,Ldv1t)
            CALL DORGLQ(Q,Q,r,V1t,Ldv1t,Work(itauq1),Work(iorglq),      &
     &                  lorglq,childinfo)
         ENDIF
!
!        Simultaneously diagonalize X11 and X21.
!
         CALL DBBCSD(Jobv1t,'N',Jobu1,Jobu2,'T',M,Q,P,Theta,Work(iphi), &
     &               V1t,Ldv1t,dum2,1,U1,Ldu1,U2,Ldu2,Work(ib11d),      &
     &               Work(ib11e),Work(ib12d),Work(ib12e),Work(ib21d),   &
     &               Work(ib21e),Work(ib22d),Work(ib22e),Work(ibbcsd),  &
     &               lbbcsd,childinfo)
!
!        Permute rows and columns to place identity submatrices in
!        preferred positions
!
         IF ( Q>0 .AND. wantu2 ) THEN
            DO i = 1 , Q
               Iwork(i) = M - P - Q + i
            ENDDO
            DO i = Q + 1 , M - P
               Iwork(i) = i - Q
            ENDDO
            CALL DLAPMT(.FALSE.,M-P,M-P,U2,Ldu2,Iwork)
         ENDIF
      ELSEIF ( r==M-P ) THEN
!
!        Case 3: R = M-P
!
!        Simultaneously bidiagonalize X11 and X21
!
         CALL DORBDB3(M,P,Q,X11,Ldx11,X21,Ldx21,Theta,Work(iphi),       &
     &                Work(itaup1),Work(itaup2),Work(itauq1),           &
     &                Work(iorbdb),lorbdb,childinfo)
!
!        Accumulate Householder reflectors
!
         IF ( wantu1 .AND. P>0 ) THEN
            CALL DLACPY('L',P,Q,X11,Ldx11,U1,Ldu1)
            CALL DORGQR(P,P,Q,U1,Ldu1,Work(itaup1),Work(iorgqr),lorgqr, &
     &                  childinfo)
         ENDIF
         IF ( wantu2 .AND. M>P ) THEN
            U2(1,1) = ONE
            DO j = 2 , M - P
               U2(1,j) = ZERO
               U2(j,1) = ZERO
            ENDDO
            CALL DLACPY('L',M-P-1,M-P-1,X21(2,1),Ldx21,U2(2,2),Ldu2)
            CALL DORGQR(M-P-1,M-P-1,M-P-1,U2(2,2),Ldu2,Work(itaup2),    &
     &                  Work(iorgqr),lorgqr,childinfo)
         ENDIF
         IF ( wantv1t .AND. Q>0 ) THEN
            CALL DLACPY('U',M-P,Q,X21,Ldx21,V1t,Ldv1t)
            CALL DORGLQ(Q,Q,r,V1t,Ldv1t,Work(itauq1),Work(iorglq),      &
     &                  lorglq,childinfo)
         ENDIF
!
!        Simultaneously diagonalize X11 and X21.
!
         CALL DBBCSD('N',Jobv1t,Jobu2,Jobu1,'T',M,M-Q,M-P,Theta,        &
     &               Work(iphi),dum2,1,V1t,Ldv1t,U2,Ldu2,U1,Ldu1,       &
     &               Work(ib11d),Work(ib11e),Work(ib12d),Work(ib12e),   &
     &               Work(ib21d),Work(ib21e),Work(ib22d),Work(ib22e),   &
     &               Work(ibbcsd),lbbcsd,childinfo)
!
!        Permute rows and columns to place identity submatrices in
!        preferred positions
!
         IF ( Q>r ) THEN
            DO i = 1 , r
               Iwork(i) = Q - r + i
            ENDDO
            DO i = r + 1 , Q
               Iwork(i) = i - r
            ENDDO
            IF ( wantu1 ) CALL DLAPMT(.FALSE.,P,Q,U1,Ldu1,Iwork)
            IF ( wantv1t ) CALL DLAPMR(.FALSE.,Q,Q,V1t,Ldv1t,Iwork)
         ENDIF
      ELSE
!
!        Case 4: R = M-Q
!
!        Simultaneously bidiagonalize X11 and X21
!
         CALL DORBDB4(M,P,Q,X11,Ldx11,X21,Ldx21,Theta,Work(iphi),       &
     &                Work(itaup1),Work(itaup2),Work(itauq1),           &
     &                Work(iorbdb),Work(iorbdb+M),lorbdb-M,childinfo)
!
!        Accumulate Householder reflectors
!
         IF ( wantu2 .AND. M>P ) CALL DCOPY(M-P,Work(iorbdb+P),1,U2,1)
         IF ( wantu1 .AND. P>0 ) THEN
            CALL DCOPY(P,Work(iorbdb),1,U1,1)
            DO j = 2 , P
               U1(1,j) = ZERO
            ENDDO
            CALL DLACPY('L',P-1,M-Q-1,X11(2,1),Ldx11,U1(2,2),Ldu1)
            CALL DORGQR(P,P,M-Q,U1,Ldu1,Work(itaup1),Work(iorgqr),      &
     &                  lorgqr,childinfo)
         ENDIF
         IF ( wantu2 .AND. M>P ) THEN
            DO j = 2 , M - P
               U2(1,j) = ZERO
            ENDDO
            CALL DLACPY('L',M-P-1,M-Q-1,X21(2,1),Ldx21,U2(2,2),Ldu2)
            CALL DORGQR(M-P,M-P,M-Q,U2,Ldu2,Work(itaup2),Work(iorgqr),  &
     &                  lorgqr,childinfo)
         ENDIF
         IF ( wantv1t .AND. Q>0 ) THEN
            CALL DLACPY('U',M-Q,Q,X21,Ldx21,V1t,Ldv1t)
            CALL DLACPY('U',P-(M-Q),Q-(M-Q),X11(M-Q+1,M-Q+1),Ldx11,     &
     &                  V1t(M-Q+1,M-Q+1),Ldv1t)
            CALL DLACPY('U',-P+Q,Q-P,X21(M-Q+1,P+1),Ldx21,V1t(P+1,P+1), &
     &                  Ldv1t)
            CALL DORGLQ(Q,Q,Q,V1t,Ldv1t,Work(itauq1),Work(iorglq),      &
     &                  lorglq,childinfo)
         ENDIF
!
!        Simultaneously diagonalize X11 and X21.
!
         CALL DBBCSD(Jobu2,Jobu1,'N',Jobv1t,'N',M,M-P,M-Q,Theta,        &
     &               Work(iphi),U2,Ldu2,U1,Ldu1,dum2,1,V1t,Ldv1t,       &
     &               Work(ib11d),Work(ib11e),Work(ib12d),Work(ib12e),   &
     &               Work(ib21d),Work(ib21e),Work(ib22d),Work(ib22e),   &
     &               Work(ibbcsd),lbbcsd,childinfo)
!
!        Permute rows and columns to place identity submatrices in
!        preferred positions
!
         IF ( P>r ) THEN
            DO i = 1 , r
               Iwork(i) = P - r + i
            ENDDO
            DO i = r + 1 , P
               Iwork(i) = i - r
            ENDDO
            IF ( wantu1 ) CALL DLAPMT(.FALSE.,P,P,U1,Ldu1,Iwork)
            IF ( wantv1t ) CALL DLAPMR(.FALSE.,P,Q,V1t,Ldv1t,Iwork)
         ENDIF
      ENDIF
!
!
!     End of DORCSD2BY1
!
      END SUBROUTINE DORCSD2BY1


module zFunOriginal

contains

      subroutine zfun(z,fu)
!
!     routine which evaluates the plasma dispersion function.  uses
!     numerical integration (absolute value of the complex argument, z,
!     less than 5) or asymptotic expansion.
!
      complex z,fu,temp1,temp2,z2,tpiiod
      dimension c(21),d(21),e(21),f(21),w(21)
      data delta/5.0e-1/, yi/-1.0e+0/, n/21/, itest/0/
      data zero/0.0e+0/, osqpi/5.6418958355e-1/, tpi/6.28318530718e+0/
!
      if(itest .eq. 1) go to 1
      itest=1
!***     define weights and store constants used for integration.
!***     weights are derived from a 3 point integration scheme.
      nm3=n-3
      conoi=delta*osqpi
      w(1)=conoi*3.75e-1
      w(2)=conoi*1.1666666667e+0
      w(3)=conoi*9.5833333333e-1
      do 20 i=1,3
        nmip1=n-i+1
   20 w(nmip1)=w(i)
      do 30 i=4,nm3
   30 w(i)=conoi
      no2=n/2
      no2p1=no2+1
      x=zero
      y=yi
      e(no2p1)=x
      f(no2p1)=y
      temp1=cmplx(x,y)
      temp2=cexp(-temp1*temp1)
      c(no2p1)=real(temp2)*w(no2p1)
      d(no2p1)=aimag(temp2)*w(no2p1)
      do 200 i=1,no2
      x=delta*float(i)
      npi=no2p1+i
      nmi=no2p1-i
      temp1=cmplx(x,y)
      temp2=cexp(-temp1*temp1)
      c(npi)=real(temp2)*w(npi)
      c(nmi)=real(temp2)*w(nmi)
      d(npi)=aimag(temp2)*w(npi)
      d(nmi)=aimag(temp2)*w(nmi)*(-1.0e+0)
      e(nmi)=-x
      e(npi)=x
      f(npi)=y
      f(nmi)=y
  200 continue
      tpiod=tpi/delta
      tpiiod=cmplx(zero,tpiod)
!***     begin calculations.
    1 g=real(z)
      yy=aimag(z)
      h=abs(yy)
      za=z*conjg(z)
      if(za .ge. 2.5e+1) go to 5
      z2=z*z
!***     numerical integration.
!***     f=1/sqrt(pi)*sum of...w(i)*exp(-x(i)**2)/(x(i)-z)...i=1,n.
!***     integration is along a line x(i) in the complex plane, where
!***     the imaginary part of x(i)=yi and the difference between
!***     successive real parts of x(i)=delta.  limits of integration
!***     are from -delta*n/2 to delta*n/2.
!***     compute the integral by taking the sum from 1 to n of the
!***     constants divided by x(i)-z.  uses real arithmetic.
      zr=0.0e+0
      zi=0.0e+0
      do 7 i=1,n
      a=e(i)-g
      b=f(i)-h
      den=a*a+b*b
      oden=1.0e+0/den
      zr=zr+(a*c(i)+b*d(i))*oden
      zi=zi+(a*d(i)-b*c(i))*oden
    7 continue
!***     add the correction term.
      fu=cmplx(zr,zi)+(0.0e+0,-3.5449077018e+0)*cexp(-z2-tpiod* &
         (h-yi)+tpiiod*g)
      if(yy .ge. zero) go to 6
!***     imaginary part of argument is negative.
      fu=conjg(fu)+(0.0e+0,3.5449077018e+0)*cexp(-z2)
      go to 6
!***     magnitude of argument is greater than 5, use
!***     asymptotic expansion.
    5 call aexpan(z,g,h,yy,fu)
    6 return
      end subroutine zfun

      subroutine aexpan(z,g,h,yy,fu)
!
!     routine which computes the plasma dispersion function using
!     asymptotic expansion.  if the imaginary part of the argument, yy,
!     is equal to zero real arithmetic is used.
!
      complex z,fu,a,z2,oz2
      data zero/0.0e+0/, n/8/
!
      if(yy .eq. zero) go to 1
!***     complex arithmetic.
      z2=z*z
      oz2=1.0e+0/z2
      fu=-1.0e+0/z
      a=fu
      en=5.0e-1
      do 10 i=1,n
      a=en*a*oz2
      fu=fu+a
   10 en=en+1.0e+0
      if(yy .gt. zero) go to 30
      if(h .gt. sqrt(g*g+1.72e+2)) go to 20
      fu=fu+(0.0e+0,3.5449077018e+0)*cexp(-z2)
      go to 30
!***     error stop to avoid overflow.
   20 write (51,100) z
  100 format(//1x,'*** error stop in frdcnt routine, argument is', &
       ' too small,  arg =',1p2e14.6)
      stop
!***     real arithmetic.
    1 x2=g*g
      ox2=1.0e+0/x2
      f=-1.0e+0/g
      b=f
      en=5.0e-1
      do 11 i=1,n
      b=en*b*ox2
      f=f+b
   11 en=en+1.0e+0
      c=1.7724538509e+0*exp(-x2)
      fu=cmplx(f,c)
   30 return
      end subroutine aexpan
!
!

end module zfunOriginal


MODULE m_obsorbT2C

! ----------------------------------------------------------------------
! MODULE: m_obsorbT2C.f03
! ----------------------------------------------------------------------
! Purpose:
!  Module for calling the orbT2C subroutine
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	12 April 2018
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE obsorbT2C (orbT, time, orbC)

! ----------------------------------------------------------------------
! SUBROUTINE: obsorbT2C
! ----------------------------------------------------------------------
! Purpose:
!  Orbit (position vector only) transformation from terrestrial (ITRF) to inertial (ICRF) reference frame
! ----------------------------------------------------------------------
! Input arguments:
! - orbT: 		Satellite orbit array in ITRF including the following per epoch:
!               - Modified Julian Day number (including the fraction of the day)
!				- Seconds since 00h
!				- Position vector (m)
! - time:		Time scale of the input orbit array (2 first collumns); Options
!				TT  (Terrestrial Time)
! 				GPS (GPS Time)
! 				TAI
! 				UTC
!
! Output arguments:
! - orbC: 		Satellite orbit array in ICRF including the following per epoch:
!               - Modified Julian Day number in the input time scale (including the fraction of the day)
!				- Seconds since 00h in the input time scale
!				- Position vector (m)
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	6 November 2017
! ----------------------------------------------------------------------

      USE mdl_precision
!      USE mdl_num
!      USE mdl_param
      use pod_yaml
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), DIMENSION(:,:), ALLOCATABLE, INTENT(IN) :: orbT
      INTEGER*2, INTENT(IN) :: time
! ----------------------------------------------------------------------
! OUT
      REAL (KIND = prec_d), DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) :: orbC
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int8) :: Nepochs, i, j
      INTEGER (KIND = prec_int8) :: sz1, sz2
      INTEGER (KIND = prec_int2) :: AllocateStatus, DeAllocateStatus
	  REAL (KIND = prec_d) :: mjd , mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC
      DOUBLE PRECISION EOP_cr(7)
      DOUBLE PRECISION CRS2TRS(3,3), TRS2CRS(3,3), d_CRS2TRS(3,3), d_TRS2CRS(3,3)
      REAL (KIND = prec_d) :: r_TRS(3), v_TRS(3)
      REAL (KIND = prec_d) :: r_CRS(3), v_CRS(3)
      REAL (KIND = prec_d) :: v_TRS_1(3), v_TRS_2(3), v_CRS_1(3), v_CRS_2(3)
! ----------------------------------------------------------------------
      INTEGER IY, IM, ID, J_flag
      DOUBLE PRECISION DJM0, sec, FD, Sec0

sz1 = size(orbT, DIM = 1)
sz2 = size(orbT, DIM = 2)

Nepochs = sz1

! Dynamic allocatable array
ALLOCATE (orbC(sz1,sz2), STAT = AllocateStatus)

! ----------------------------------------------------------------------
! Computations per epoch loop
Do i = 1 , Nepochs

!print *, "i", i

! MJD
mjd = orbT(i,1)

! Time scale transformation to TT
If (time == TT_time) Then
	CALL time_TT (mjd , mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC)
Else If (time == GPS_time) then
	CALL time_GPS (mjd , mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC)
Else if (time == UTC_time) then
	CALL time_UTC (mjd , mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC)
Else if (time == TAI_time) then
	CALL time_TAI (mjd , mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC)
End If

! Position vector in ICRF
r_TRS(1:3) = orbT(i,3:5)

! ----------------------------------------------------------------------
! Orbit Tranformation: ITRF to ICRF
! ----------------------------------------------------------------------
! ICRF-ITRF transformation matrix (including derivatives) based on EOP data
CALL EOP (mjd_TT, EOP_cr, CRS2TRS, TRS2CRS, d_CRS2TRS, d_TRS2CRS)

! r_CRS = TRS2CRS * r_TRS
CALL matrix_Rr (TRS2CRS, r_TRS , r_CRS)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! orbC array per epoch
! ----------------------------------------------------------------------
orbC(i,1)   = orbT(i,1)
orbC(i,2)   = orbT(i,2)
orbC(i,3:5) = r_CRS
! ----------------------------------------------------------------------

End Do
! ----------------------------------------------------------------------

END SUBROUTINE

End


       INTEGER SEED
       DATA SEED/987654321/
       DATA EXACT/.78540/
       FUNC(X)=1./(1.+X**2)

10     PRINT *, ' Enter number of points (0 to stop)'
       READ *, N
       IF (N .EQ. 0) STOP

       SUMF=0.
       SUMF2=0.
       DO 20 IX=1,N
          FX=FUNC(RAN(SEED))
          SUMF=SUMF+FX
          SUMF2=SUMF2+FX**2
20     CONTINUE
       FAVE=SUMF/N
       F2AVE=SUMF2/N
       SIGMA=SQRT((F2AVE-FAVE**2)/N)
       PRINT *,' integral =',FAVE,' +- ',SIGMA,'  error = ',EXACT-FAVE

       GOTO 10
       END


      FUNCTION GERFC(Y)

!PURPOSE: This routine returns the Complementary ERROR Function of a single precision variable (Y)

      INCLUDE       '../INCLDS/COPYRIGT.FOR'

!CALLING ARGUMENTS:

      REAL*4        Y                   !
      REAL*4        GERFC                !Result

!INCLUDE STATEMENTS:

      DIMENSION     P(5),Q(4),P1(9),Q1(8),P2(6),Q2(5)
      REAL*4        P,Q,P1,Q1,P2,Q2,XMIN,XLARGE,SQRPI,X,
     1                RES,XSQ,XNUM,XDEN,XI
      INTEGER       ISW,I

!DATA STATEMENTS:

      DATA P(1)/113.86415/,
     1  P(2)/377.48524/,
     1  P(3)/3209.3776/,
     1  P(4)/.18577771/,
     1  P(5)/3.1611237/
      DATA Q(1)/244.02464/,
     1  Q(2)/1282.6165/,
     1  Q(3)/2844.2368/,
     1  Q(4)/23.601291/
      DATA P1(1)/8.8831498/,
     1  P1(2)/66.119190/,
     1  P1(3)/298.63514/,
     1  P1(4)/881.95222/,
     1  P1(5)/1712.0476/,
     1  P1(6)/2051.0784/,
     1  P1(7)/1230.3394/,
     1  P1(8)/2.1531154E-8/,
     1  P1(9)/.56418850/
      DATA Q1(1)/117.69395/,
     1  Q1(2)/537.18110/,
     1  Q1(3)/1621.3896/,
     1  Q1(4)/3290.7992/,
     1  Q1(5)/4362.6191/,
     1  Q1(6)/3439.3677/,
     1  Q1(7)/1230.3394/,
     1  Q1(8)/15.744926/
      DATA P2(1)/-3.6034490E-01/,
     1  P2(2)/-1.2578173E-01/,
     1  P2(3)/-1.6083785E-02/,
     1  P2(4)/-6.5874916E-04/,
     1  P2(5)/-1.6315387E-02/,
     1  P2(6)/-3.0532663E-01/
      DATA Q2(1)/1.8729528/,
     1  Q2(2)/5.2790510E-01/,
     1  Q2(3)/6.0518341E-02/,
     1  Q2(4)/2.3352050E-03/,
     1  Q2(5)/2.5685202/
      DATA XMIN/1.0E-10/,XLARGE/6.375/
      DATA SQRPI/.56418958/

!CODE:

      IF ( Y.GT.0.0 ) THEN
        X = Y
        ISW = 1
      ELSE
        X = -Y
        ISW = -1
      END IF
      XSQ = X*X
      IF ( X.LT.0.477 ) THEN
        IF ( X.LT.XMIN ) THEN
          RES = X*P(3)/Q(3)
        ELSE
          XNUM = P(4)*XSQ+P(5)
          XDEN = XSQ+Q(4)
          DO I = 1,3
            XNUM = XNUM*XSQ+P(I)
            XDEN = XDEN*XSQ+Q(I)
          END DO
          RES = X*XNUM/XDEN
        END IF
        IF ( ISW.EQ.-1 ) RES = -RES
        RES = 1.0-RES
      ELSE
        IF ( X.LT.XLARGE ) THEN
          IF ( X.LE.4.0 ) THEN
            XNUM = P1(8)*X+P1(9)
            XDEN = X+Q1(8)
            DO I=1,7
              XNUM = XNUM*X+P1(I)
              XDEN = XDEN*X+Q1(I)
            END DO
            RES = XNUM/XDEN
          ELSE
            XI = 1.0/XSQ
            XNUM = P2(5)*XI+P2(6)
            XDEN = XI+Q2(5)
            DO I = 1,4
              XNUM = XNUM*XI+P2(I)
              XDEN = XDEN*XI+Q2(I)
            END DO
            RES = (SQRPI+XI*XNUM/XDEN)/X
          END IF
          RES = RES*EXP(-XSQ)
        ELSE
          RES = 0.0
        END IF
        IF ( ISW.EQ.-1 ) RES = 2.0-RES
      END IF
      GERFC = RES
      RETURN
      END


!*==spbtrf.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SPBTRF
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SPBTRF + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SPBTRF( UPLO, N, KD, AB, LDAB, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          UPLO
!       INTEGER            INFO, KD, LDAB, N
!       ..
!       .. Array Arguments ..
!       REAL               AB( LDAB, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SPBTRF computes the Cholesky factorization of a real symmetric
!> positive definite band matrix A.
!>
!> The factorization has the form
!>    A = U**T * U,  if UPLO = 'U', or
!>    A = L  * L**T,  if UPLO = 'L',
!> where U is an upper triangular matrix and L is lower triangular.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in] KD
!> \verbatim
!>          KD is INTEGER
!>          The number of superdiagonals of the matrix A if UPLO = 'U',
!>          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
!> \endverbatim
!>
!> \param[in,out] AB
!> \verbatim
!>          AB is REAL array, dimension (LDAB,N)
!>          On entry, the upper or lower triangle of the symmetric band
!>          matrix A, stored in the first KD+1 rows of the array.  The
!>          j-th column of A is stored in the j-th column of the array AB
!>          as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!>
!>          On exit, if INFO = 0, the triangular factor U or L from the
!>          Cholesky factorization A = U**T*U or A = L*L**T of the band
!>          matrix A, in the same storage format as A.
!> \endverbatim
!>
!> \param[in] LDAB
!> \verbatim
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, the leading minor of order i is not
!>                positive definite, and the factorization could not be
!>                completed.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup realOTHERcomputational
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  The band storage scheme is illustrated by the following example, when
!>  N = 6, KD = 2, and UPLO = 'U':
!>
!>  On entry:                       On exit:
!>
!>      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
!>      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
!>     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
!>
!>  Similarly, if UPLO = 'L' the format of A is as follows:
!>
!>  On entry:                       On exit:
!>
!>     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
!>     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
!>     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
!>
!>  Array elements marked * are not used by the routine.
!> \endverbatim
!
!> \par Contributors:
!  ==================
!>
!>  Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
!
!  =====================================================================
      SUBROUTINE SPBTRF(Uplo,N,Kd,Ab,Ldab,Info)
      IMPLICIT NONE
!*--SPBTRF146
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Uplo
      INTEGER Info , Kd , Ldab , N
!     ..
!     .. Array Arguments ..
      REAL Ab(Ldab,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ONE , ZERO
      PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
      INTEGER NBMAX , LDWORK
      PARAMETER (NBMAX=32,LDWORK=NBMAX+1)
!     ..
!     .. Local Scalars ..
      INTEGER i , i2 , i3 , ib , ii , j , jj , nb
!     ..
!     .. Local Arrays ..
      REAL work(LDWORK,NBMAX)
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV
      EXTERNAL LSAME , ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL SGEMM , SPBTF2 , SPOTF2 , SSYRK , STRSM , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      Info = 0
      IF ( (.NOT.LSAME(Uplo,'U')) .AND. (.NOT.LSAME(Uplo,'L')) ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Kd<0 ) THEN
         Info = -3
      ELSEIF ( Ldab<Kd+1 ) THEN
         Info = -5
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('SPBTRF',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) RETURN
!
!     Determine the block size for this environment
!
      nb = ILAENV(1,'SPBTRF',Uplo,N,Kd,-1,-1)
!
!     The block size must not exceed the semi-bandwidth KD, and must not
!     exceed the limit set by the size of the local array WORK.
!
      nb = MIN(nb,NBMAX)
!
      IF ( nb<=1 .OR. nb>Kd ) THEN
!
!        Use unblocked code
!
         CALL SPBTF2(Uplo,N,Kd,Ab,Ldab,Info)
!
!        Use blocked code
!
      ELSEIF ( LSAME(Uplo,'U') ) THEN
!
!           Compute the Cholesky factorization of a symmetric band
!           matrix, given the upper triangle of the matrix in band
!           storage.
!
!           Zero the upper triangle of the work array.
!
         DO j = 1 , nb
            DO i = 1 , j - 1
               work(i,j) = ZERO
            ENDDO
         ENDDO
!
!           Process the band matrix one diagonal block at a time.
!
         DO i = 1 , N , nb
            ib = MIN(nb,N-i+1)
!
!              Factorize the diagonal block
!
            CALL SPOTF2(Uplo,ib,Ab(Kd+1,i),Ldab-1,ii)
            IF ( ii/=0 ) THEN
               Info = i + ii - 1
               GOTO 99999
            ENDIF
            IF ( i+ib<=N ) THEN
!
!                 Update the relevant part of the trailing submatrix.
!                 If A11 denotes the diagonal block which has just been
!                 factorized, then we need to update the remaining
!                 blocks in the diagram:
!
!                    A11   A12   A13
!                          A22   A23
!                                A33
!
!                 The numbers of rows and columns in the partitioning
!                 are IB, I2, I3 respectively. The blocks A12, A22 and
!                 A23 are empty if IB = KD. The upper triangle of A13
!                 lies outside the band.
!
               i2 = MIN(Kd-ib,N-i-ib+1)
               i3 = MIN(ib,N-i-Kd+1)
!
               IF ( i2>0 ) THEN
!
!                    Update A12
!
                  CALL STRSM('Left','Upper','Transpose','Non-unit',ib,  &
     &                       i2,ONE,Ab(Kd+1,i),Ldab-1,Ab(Kd+1-ib,i+ib), &
     &                       Ldab-1)
!
!                    Update A22
!
                  CALL SSYRK('Upper','Transpose',i2,ib,-ONE,            &
     &                       Ab(Kd+1-ib,i+ib),Ldab-1,ONE,Ab(Kd+1,i+ib), &
     &                       Ldab-1)
               ENDIF
!
               IF ( i3>0 ) THEN
!
!                    Copy the lower triangle of A13 into the work array.
!
                  DO jj = 1 , i3
                     DO ii = jj , ib
                        work(ii,jj) = Ab(ii-jj+1,jj+i+Kd-1)
                     ENDDO
                  ENDDO
!
!                    Update A13 (in the work array).
!
                  CALL STRSM('Left','Upper','Transpose','Non-unit',ib,  &
     &                       i3,ONE,Ab(Kd+1,i),Ldab-1,work,LDWORK)
!
!                    Update A23
!
                  IF ( i2>0 ) CALL SGEMM('Transpose','No Transpose',i2, &
     &                 i3,ib,-ONE,Ab(Kd+1-ib,i+ib),Ldab-1,work,LDWORK,  &
     &                 ONE,Ab(1+ib,i+Kd),Ldab-1)
!
!                    Update A33
!
                  CALL SSYRK('Upper','Transpose',i3,ib,-ONE,work,LDWORK,&
     &                       ONE,Ab(Kd+1,i+Kd),Ldab-1)
!
!                    Copy the lower triangle of A13 back into place.
!
                  DO jj = 1 , i3
                     DO ii = jj , ib
                        Ab(ii-jj+1,jj+i+Kd-1) = work(ii,jj)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
      ELSE
!
!           Compute the Cholesky factorization of a symmetric band
!           matrix, given the lower triangle of the matrix in band
!           storage.
!
!           Zero the lower triangle of the work array.
!
         DO j = 1 , nb
            DO i = j + 1 , nb
               work(i,j) = ZERO
            ENDDO
         ENDDO
!
!           Process the band matrix one diagonal block at a time.
!
         DO i = 1 , N , nb
            ib = MIN(nb,N-i+1)
!
!              Factorize the diagonal block
!
            CALL SPOTF2(Uplo,ib,Ab(1,i),Ldab-1,ii)
            IF ( ii/=0 ) THEN
               Info = i + ii - 1
               GOTO 99999
            ENDIF
            IF ( i+ib<=N ) THEN
!
!                 Update the relevant part of the trailing submatrix.
!                 If A11 denotes the diagonal block which has just been
!                 factorized, then we need to update the remaining
!                 blocks in the diagram:
!
!                    A11
!                    A21   A22
!                    A31   A32   A33
!
!                 The numbers of rows and columns in the partitioning
!                 are IB, I2, I3 respectively. The blocks A21, A22 and
!                 A32 are empty if IB = KD. The lower triangle of A31
!                 lies outside the band.
!
               i2 = MIN(Kd-ib,N-i-ib+1)
               i3 = MIN(ib,N-i-Kd+1)
!
               IF ( i2>0 ) THEN
!
!                    Update A21
!
                  CALL STRSM('Right','Lower','Transpose','Non-unit',i2, &
     &                       ib,ONE,Ab(1,i),Ldab-1,Ab(1+ib,i),Ldab-1)
!
!                    Update A22
!
                  CALL SSYRK('Lower','No Transpose',i2,ib,-ONE,         &
     &                       Ab(1+ib,i),Ldab-1,ONE,Ab(1,i+ib),Ldab-1)
               ENDIF
!
               IF ( i3>0 ) THEN
!
!                    Copy the upper triangle of A31 into the work array.
!
                  DO jj = 1 , ib
                     DO ii = 1 , MIN(jj,i3)
                        work(ii,jj) = Ab(Kd+1-jj+ii,jj+i-1)
                     ENDDO
                  ENDDO
!
!                    Update A31 (in the work array).
!
                  CALL STRSM('Right','Lower','Transpose','Non-unit',i3, &
     &                       ib,ONE,Ab(1,i),Ldab-1,work,LDWORK)
!
!                    Update A32
!
                  IF ( i2>0 ) CALL SGEMM('No transpose','Transpose',i3, &
     &                 i2,ib,-ONE,work,LDWORK,Ab(1+ib,i),Ldab-1,ONE,    &
     &                 Ab(1+Kd-ib,i+ib),Ldab-1)
!
!                    Update A33
!
                  CALL SSYRK('Lower','No Transpose',i3,ib,-ONE,work,    &
     &                       LDWORK,ONE,Ab(1,i+Kd),Ldab-1)
!
!                    Copy the upper triangle of A31 back into place.
!
                  DO jj = 1 , ib
                     DO ii = 1 , MIN(jj,i3)
                        Ab(Kd+1-jj+ii,jj+i-1) = work(ii,jj)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
      ENDIF
      RETURN
!
!
!     End of SPBTRF
!
99999 END SUBROUTINE SPBTRF


        subroutine stp_interp(s,t,p,n,s0,t0,p0)
ccc
ccc
ccc
ccc     DESCRIPTION :   Interpolate salinity and in situ temperature
ccc                     on a cast by linearly interpolating salinity
ccc                     and potential temperature
ccc
ccc     PRECISION :     Double
ccc
ccc     INPUT :         s(n)            array of cast salinities
ccc                     t(n)            array of cast in situ temperatures
ccc                     p(n)            array of cast pressures
ccc                     n               length of cast
ccc                     p0              pressure for which salinity and
ccc                                     in situ temperature are required
ccc
ccc     OUTPUT :        s0              interpolated value of salinity
ccc                     t0              interpolated value of situ temperature
ccc
ccc     UNITS :         salinities      psu (IPSS-78)
ccc                     temperatures    degrees C (IPTS-68)
ccc                     pressures       db
ccc
ccc
ccc     AUTHOR :        David Jackett
ccc
ccc     CREATED :       June 1993
ccc
ccc     REVISION :      1.1             30/6/93
ccc
ccc
ccc
        implicit double precision (a-h,o-z)

        dimension s(n),t(n),p(n)

        external indx

        data pr0/0.0/

        call indx(p,n,p0,k)

        r = (p0-p(k))/(p(k+1)-p(k))

        s0 = s(k) + r*(s(k+1)-s(k))

        thk = theta(s(k),t(k),p(k),pr0)

        th0 = thk + r*(theta(s(k+1),t(k+1),p(k+1),pr0)-thk)

        t0 = theta(s0,th0,pr0,p0)

        return
        end


      program drdgami
c>>   2001-05-25 DRDGAMI Krogh Minor change for making .f90 version.
c>>   1996-05-28 DRDGAMI Krogh  Changed Fortran 90 code.
c>>   1994-10-19 DRDGAMI Krogh  Changes to use M77CON
c>>   1994-08-15 DRDGAMI WV Snyder JPL set up for chgtyp
c>>   1993-08-03 DRDGAMI WV Snyder JPL Original code
c--D replaces "?": DR?GAMI, ?ERF, ?ERFC, ?GAMI, ?GAMIK
c
c     Demo driver for incomplete gamma function.
c     Evaluate the identity P(1/2,x) = erf(sqrt(x)) and Q(1/2,x) =
c     erfc(sqrt(x)) for several values of x.
c
      double precision A, X, P, Q, DERF, DERFC, S, SC, SX
      external DERF, DERFC
      integer I, IND
      double precision XS(5)
      data XS /1.0d0, 2.0d0, 3.0d0, 4.0d0, 5.0d0/
c
10    format ('          X         P(1/2,X)       ERF(SQRT(X))  ',
     1        '    Q(1/2,X)      ERFC(SQRT(X))')
20    format (1p,5e16.8)
      print 10
      a = 0.5d0
      ind = 0
      call dgamik (0.0d0, 0.0d0, 0.0d0, 0)
      do 30 i = 1, 5
         x = xs(i)
         call dgami (a, x, p, q, ind)
         sx = sqrt(x)
         s = derf(sx)
         sc = derfc(sx)
         print 20, x, p, s, q, sc
30    continue
      stop
      end


      subroutine pderhs(n)
************************************************************************
*
*   TRIRHS -- RHS inner products over triangles.
*
*   Inner products for Burgers' equation,
*
*      du/dt = - u*du/dx - v*du/dx + visc*Lapl(u)
*      dv/dt = - u*dv/dx - v*dv/dx + visc*Lapl(v)
*
************************************************************************
      integer npde
      parameter(npde=2)

      double precision wpde
      common /mfe020/ wpde(npde)

      double precision visc,usera
      common /mfe100/ visc,usera(24)

      double precision u0,v0,x0,y0,u1,v1,x1,y1,u2,v2,x2,y2
      common /loc010/ u0(65),v0(65),x0(65),y0(65),
     +                u1(65),v1(65),x1(65),y1(65),
     +                u2(65),v2(65),x2(65),y2(65)

      double precision gu0,gv0,gx0,gy0,gu1,gv1,gx1,gy1,gu2,gv2,gx2,gy2
      common /loc012/ gu0(65),gv0(65),gx0(65),gy0(65),
     +                gu1(65),gv1(65),gx1(65),gy1(65),
     +                gu2(65),gv2(65),gx2(65),gy2(65)

      double precision a,n1,n2,n3,ayu,aux,axy
      common /loc020/ a(65,npde)
      common /loc021/ n1(65,npde),n2(65,npde),n3(65,npde)
      common /loc022/ ayu(65,npde),aux(65,npde),axy(65)

      integer n,j
      double precision cu,cv,su,sv,tu,tv

      cu = wpde(1)/12.
      cv = wpde(2)/12.

      do 10 j=1,n
       su = u0(j) + u1(j) + u2(j)
       sv = v0(j) + v1(j) + v2(j)

       tu = cu*(ayu(j,1)*(u0(j)+su) + aux(j,1)*(v0(j)+sv))
       tv = cv*(ayu(j,2)*(u0(j)+su) + aux(j,2)*(v0(j)+sv))
       gx0(j) = tu*n1(j,1) + tv*n1(j,2)
       gy0(j) = tu*n2(j,1) + tv*n2(j,2)
       gu0(j) = tu*n3(j,1)
       gv0(j) = tv*n3(j,2)

       tu = cu*(ayu(j,1)*(u1(j)+su) + aux(j,1)*(v1(j)+sv))
       tv = cv*(ayu(j,2)*(u1(j)+su) + aux(j,2)*(v1(j)+sv))
       gx1(j) = tu*n1(j,1) + tv*n1(j,2)
       gy1(j) = tu*n2(j,1) + tv*n2(j,2)
       gu1(j) = tu*n3(j,1)
       gv1(j) = tv*n3(j,2)

       tu = cu*(ayu(j,1)*(u2(j)+su) + aux(j,1)*(v2(j)+sv))
       tv = cv*(ayu(j,2)*(u2(j)+su) + aux(j,2)*(v2(j)+sv))
       gx2(j) = tu*n1(j,1) + tv*n1(j,2)
       gy2(j) = tu*n2(j,1) + tv*n2(j,2)
       gu2(j) = tu*n3(j,1)
       gv2(j) = tv*n3(j,2)
   10 continue

      call lapl(n,1,visc)
      call lapl(n,2,visc)

      return
      end


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! DOFGRD (Double Orthogonal hessenberg Factored Givens Rotation Deflation)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine checks for deflations in an orthogonal upper hessenberg
! matrix that is stored as a product of givens rotations and a complex
! diagonal matrix. When a deflation occurs the corresponding rotation
! is set to the identity matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  N               INTEGER
!                    dimension of matrix
!
!  STR             INTEGER
!                    index of the top most givens rotation where
!                    deflation should be checked
!
!  STP             INTEGER
!                    index of the bottom most givens rotation where
!                    deflation should be checked
!
!  Q               REAL(8) array of dimension (2*(N-1))
!                    array of generators for givens rotations
!                    generators must be orthogonal to working precision
!
!  D               REAL(8) array of dimension (2*N)
!                    array of generators for complex diagonal matrix
!                    generators must be orthogonal to working precision
!
!  ITCNT           INTEGER
!                    number of iterations since last deflation
!
! OUTPUT VARIABLES:
!
!  ZERO            INTEGER
!                     index of the last known deflation
!                     on output contains index of newest deflation
!
!  ITS             INTEGER array of dimension (N-1)
!                    Contains the number of iterations per deflation
!
!  INFO            INTEGER
!                    INFO = 0 implies successful computation
!                    INFO = -1 implies N is invalid
!                    INFO = -2 implies STR is invalid
!                    INFO = -3 implies STP is invalid
!                    INFO = -7 implies ITCNT is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine DOFGRD(N,STR,STP,ZERO,Q,D,ITCNT,ITS,INFO)

  implicit none

  ! input variables
  integer, intent(in) :: N
  integer, intent(inout) :: STR, STP, ZERO, ITCNT, INFO
  real(8), intent(inout) :: Q(2*(N-1)), D(2*N)
  integer, intent(inout) :: ITS(N-1)

  ! compute variables
  integer :: ii, ind, ll, jj, k
  real(8), parameter :: tol = epsilon(1d0)
  real(8) :: td, tc, ts, nrm

  ! initialize info
  INFO = 0

  ! check input in debug mode
  if (DEBUG) then

    ! check N
    if (N < 2) then
      INFO = -1
      call UARERR(__FILE__,__LINE__,"N must be at least 2",INFO,INFO)
      return
    end if

    ! check STR
    if ((STR < 1).OR.(STR > N-1)) then
      INFO = -2
      call UARERR(__FILE__,__LINE__,"STR must be 1 <= STR <= N-1",INFO,INFO)
      return
    end if

    ! check STP
    if ((STP < STR).OR.(STP > N-1)) then
      INFO = -3
      call UARERR(__FILE__,__LINE__,"STP must be STR <= STP <= N-1",INFO,INFO)
      return
    end if

    ! check ITCNT
    if (ITCNT < 0) then
      INFO = -7
      call UARERR(__FILE__,__LINE__,"ITCNT must be positive",INFO,INFO)
      return
    end if

  end if

  ! check for deflation
  do ii=1,(STP-STR+1)

    ! one less than the index of the rotation being checked
    ind = 2*(STP-ii)

    ! deflate if subdiagonal is small enough
    nrm = abs(Q(ind+2))
    if(nrm < tol)then

      ! set sub-diagonal to 0
      Q(ind+2) = 0d0

      ! update first Q
      tc = sign(1d0,Q(ind+1))
      Q(ind+1) = 1d0

      ! return if tc == -1
      if (tc < 0d0) then

        ! update first diagonal
        D(ind+1) = -D(ind+1)

        ! update second diagonal
        D(ind+3) = -D(ind+3)

        ! update rest of Q
        if ((ind+4) <= 2*(N-1)) then
          Q(ind+4) = -Q(ind+4)
        end if

      end if

      ! update indices
      ZERO = STP+1-ii
      STR = ZERO + 1

      ! store it_count
      ITS(ZERO) = ITCNT
      ITCNT = 0

      ! exit loop
      exit

    end if
  end do

end subroutine DOFGRD


        SUBROUTINE LNSGI1 ( x1, y1, x2, y2, nlpts, xlins, ylins,
     +                      xint, yint, iret )
C************************************************************************
C* LNSGI1                                                               *
C*                                                                      *
C* This subroutine calculates the intersection point(s) between a 	*
C* polygon (xlins,ylins) & the ray					*
C*									*
C*	RAY = [ (x1,y1) - (x2,y2) ) i.e., from (x1,y1) thru (x2,y2)	*
C*									*
C* and returns the intersection point closest to the point (x1,y1).	*
C* If no intersection points meet the criteria, (RMISSD,RMISSD)		*
C* is returned for (xint,yint).						*
C*									*
C*                                                                      *
C* LNSGI1 ( XLIN, YLIN, XLINS, YLINS, NPTS, XINT, YINT, IRET )		*
C*                                                                      *
C* Input parameters:                                                    *
C*      X1              REAL            Ray starting X coord		*
C*      Y1              REAL            Ray starting Y coord		*
C*      X2              REAL            Ray ending X coord		*
C*      Y2              REAL            Ray ending Y coord		*
C*	NLPTS		INTEGER		Number of points along X/YLINS	*
C*      XLINS (NLPTS)   REAL            Poly line X input coords	*
C*      YLINS (NLPTS)   REAL            Poly line Y input coords	*
C*                                                                      *
C* Output parameters:                                                   *
C*      XINT            REAL            X intersection                  *
C*      YINT            REAL            Y intersection                  *
C*      IRET            INTEGER         Return code                     *
C**                                                                     *
C* Log:                                                                 *
C* D.W.Plummer/NCEP	 9/03						*
C************************************************************************
	INCLUDE         'GEMPRM.PRM'
	INCLUDE         'grphgd.cmn'
C
	REAL	xlins(*), ylins(*)
	REAL	xint, yint
	REAL	xlin(2), ylin(2)
C
	REAL	xints(50), yints(50)
C
C------------------------------------------------------------------------
C
	iret = 0
C
	xint = RMISSD
	yint = RMISSD
C
	xlin ( 1 ) = x1
	xlin ( 2 ) = x2
	ylin ( 1 ) = y1
	ylin ( 2 ) = y2
	CALL LNSGIN ( xlin, ylin, xlins, ylins, nlpts, MAXINT, numint,
     &		xints, yints, iret )
C
	IF ( numint .eq. 0 )  THEN
	    RETURN
	END IF
C
	DO  ii = 1, numint
C
	    IF ( xlin(1) .gt. xlin(2) )  THEN
	    	IF ( ii .eq. 1 )  xint = 0
		IF ( xints(ii) .gt. xint .and.
     &		     xints(ii) .lt. xlin(1) )  THEN
		    xint = xints(ii)
		    yint = yints(ii)
	        END IF
	    ELSE IF ( xlin(1) .lt. xlin(2) )  THEN
	    	IF ( ii .eq. 1 )  xint = 1000
		IF ( xints(ii) .lt. xint .and.
     &		     xints(ii) .gt. xlin(1) )  THEN
		    xint = xints(ii)
		    yint = yints(ii)
	        END IF
	    ELSE
	        IF ( ylin(1) .gt. ylin(2) )  THEN
	    	    IF ( ii .eq. 1 )  yint = 0
		    IF ( yints(ii) .gt. yint .and.
     &		         yints(ii) .lt. ylin(1) )  THEN
		        xint = xints(ii)
		        yint = yints(ii)
	            END IF
	        ELSE IF ( ylin(1) .lt. ylin(2) )  THEN
	    	    IF ( ii .eq. 1 )  yint = 1000
		    IF ( yints(ii) .lt. yint .and.
     &		         yints(ii) .gt. ylin(1) )  THEN
		        xint = xints(ii)
		        yint = yints(ii)
	            END IF
	        END IF
	    END IF
C
	END DO
C
	RETURN
	END


      subroutine f_f77(neq, t, X, Y)
Cf2py intent(hide) neq
Cf2py intent(out) Y
      integer neq
      double precision t, X, Y
      dimension X(neq), Y(neq)
      Y(1)=1.0d0*X(3)
      Y(2)=1.0d0*X(4)/(X(1)*X(5)+1)**2
      Y(3)=-1.0d0*X(1)+1.0d0*X(4)**2*X(5)/(X(1)*X(5)+1)**3
      Y(4)=-1.0d0*X(2)*X(6)**2
      Y(5)=0
      Y(6)=0
      return
      end


module equations_mod

use constants_mod
use equations_const_mod

interface cons2entr
    procedure cons2entr_elemental
    procedure cons2entr_0d
    procedure cons2entr_1d
    procedure cons2entr_2d
    procedure cons2entr_3d
end interface

interface soundspeed
    procedure soundspeed_elemental
    procedure soundspeed_0d
    procedure soundspeed_1d
    procedure soundspeed_2d
    procedure soundspeed_3d
end interface

interface pressure
    procedure pressure_elemental
    procedure pressure_0d
    procedure pressure_1d
    procedure pressure_2d
    procedure pressure_3d
end interface

interface xlambdaMax
    procedure xlambdaMax_elemental
    procedure xlambdaMax_0d
    procedure xlambdaMax_1d
    procedure xlambdaMax_2d
    procedure xlambdaMax_3d
end interface

interface ylambdaMax
    procedure ylambdaMax_elemental
    procedure ylambdaMax_0d
    procedure ylambdaMax_1d
    procedure ylambdaMax_2d
    procedure ylambdaMax_3d
end interface

interface zlambdaMax
    procedure zlambdaMax_elemental
    procedure zlambdaMax_0d
    procedure zlambdaMax_1d
    procedure zlambdaMax_2d
    procedure zlambdaMax_3d
end interface

interface isvalid
    procedure isvalid_elemental
    procedure isvalid_0d
    procedure isvalid_1d
    procedure isvalid_2d
    procedure isvalid_3d
end interface

contains

pure function xflux(u) result(f)

    real(dp), intent(in)    :: u(N_VARS)
    real(dp)                :: f(N_VARS)
    real(dp)                :: pres,velx

    pres = pressure(u)
    velx = u(MOMX_VAR)/u(DENS_VAR)

    f(DENS_VAR) = u(MOMX_VAR)
    f(MOMX_VAR) = velx*u(MOMX_VAR) + pres
    f(MOMY_VAR) = velx*u(MOMY_VAR)
    f(MOMZ_VAR) = velx*u(MOMZ_VAR)
    f(ENER_VAR) = velx*(u(ENER_VAR) + pres)

end function

pure function yflux(u) result(f)

    real(dp), intent(in)    :: u(N_VARS)
    real(dp)                :: f(N_VARS)
    real(dp)                :: ru(N_VARS), rf(N_VARS) !! rotated

    !! rotating to x-direction
    ru(DENS_VAR) = u(DENS_VAR)
    ru(MOMX_VAR) = u(MOMY_VAR)
    ru(MOMY_VAR) = u(MOMZ_VAR)
    ru(MOMZ_VAR) = u(MOMX_VAR)
    ru(ENER_VAR) = u(ENER_VAR)

    rf = xflux(ru)

    !! rotating back
    f(DENS_VAR) = rf(DENS_VAR)
    f(MOMX_VAR) = rf(MOMZ_VAR)
    f(MOMY_VAR) = rf(MOMX_VAR)
    f(MOMZ_VAR) = rf(MOMY_VAR)
    f(ENER_VAR) = rf(ENER_VAR)

end function

pure function zflux(u) result(f)

    real(dp), intent(in)    :: u(N_VARS)
    real(dp)                :: f(N_VARS)
    real(dp)                :: ru(N_VARS), rf(N_VARS) !! rotated

    !! rotating to x-direction
    ru(DENS_VAR) = u(DENS_VAR)
    ru(MOMX_VAR) = u(MOMZ_VAR)
    ru(MOMY_VAR) = u(MOMX_VAR)
    ru(MOMZ_VAR) = u(MOMY_VAR)
    ru(ENER_VAR) = u(ENER_VAR)

    rf = xflux(ru)

    !! rotating back
    f(DENS_VAR) = rf(DENS_VAR)
    f(MOMX_VAR) = rf(MOMY_VAR)
    f(MOMY_VAR) = rf(MOMZ_VAR)
    f(MOMZ_VAR) = rf(MOMX_VAR)
    f(ENER_VAR) = rf(ENER_VAR)

end function

!! ========================================================================== !!

pure elemental function pressure_elemental(dens, momx, momy, momz, ener) result(pres)

    use setup_config_mod, only: kappa

    real(dp),intent(in)    :: dens, momx, momy, momz, ener
    real(dp)               :: pres

    pres = (kappa-1.0_dp) * (ener - 0.5_dp/dens * (momx*momx + momy*momy + momz*momz))

end function

pure function pressure_0d(u) result(res)

    use setup_config_mod, only: kappa

    real(dp),intent(in)    :: u(N_VARS)
    real(dp)               :: res

    res = pressure(u(DENS_VAR),u(MOMX_VAR),u(MOMY_VAR),u(MOMZ_VAR),u(ENER_VAR))

end function

pure function pressure_1d(u) result(p)

    real(dp),intent(in)    :: u(:,:)
    real(dp)               :: p(size(u,dim=1))

    p = pressure(u(:,DENS_VAR),u(:,MOMX_VAR),u(:,MOMY_VAR),u(:,MOMZ_VAR),u(:,ENER_VAR))

end function

pure function pressure_2d(u) result(p)

    real(dp),intent(in)    :: u(:,:,:)
    real(dp)               :: p(size(u,dim=1),size(u,dim=2))

    p = pressure(u(:,:,DENS_VAR),u(:,:,MOMX_VAR),u(:,:,MOMY_VAR),u(:,:,MOMZ_VAR),u(:,:,ENER_VAR))

end function

pure function pressure_3d(u) result(p)

    real(dp),intent(in)    :: u(:,:,:,:)
    real(dp)               :: p(size(u,dim=1),size(u,dim=2),size(u,dim=3))

    p = pressure(u(:,:,:,DENS_VAR),u(:,:,:,MOMX_VAR),u(:,:,:,MOMY_VAR),u(:,:,:,MOMZ_VAR),u(:,:,:,ENER_VAR))

end function

!! ========================================================================== !!

pure function cons2prim(u) result(p)

    real(dp),intent(in)    :: u(N_VARS)
    real(dp)               :: p(N_VARS)

    p(DENS_VAR) = u(DENS_VAR)
    p(VELX_VAR) = u(MOMX_VAR)/u(DENS_VAR)
    p(VELY_VAR) = u(MOMY_VAR)/u(DENS_VAR)
    p(VELZ_VAR) = u(MOMZ_VAR)/u(DENS_VAR)
    p(PRES_VAR) = pressure(u)

end function

pure function prim2cons(p) result(u)

    use setup_config_mod, only: kappa

    real(dp),intent(in)    :: p(N_VARS)
    real(dp)               :: u(N_VARS)

    u(DENS_VAR) = p(DENS_VAR)
    u(MOMX_VAR) = p(VELX_VAR)*p(DENS_VAR)
    u(MOMY_VAR) = p(VELY_VAR)*p(DENS_VAR)
    u(MOMZ_VAR) = p(VELZ_VAR)*p(DENS_VAR)
    u(ENER_VAR) = p(PRES_VAR)/(kappa-1.0_dp) + 0.5_dp*p(DENS_VAR)*(p(VELX_VAR)**2 + p(VELY_VAR)**2 + p(VELZ_VAR)**2)

end function

!! ========================================================================== !!

pure elemental function cons2entr_elemental(dens,momx,momy,momz,ener) result(s)

    use setup_config_mod, only: kappa

    real(dp),intent(in)    :: dens,momx,momy,momz,ener
    real(dp)               :: s

    !! entropy density
    s = log(pressure(dens,momx,momy,momz,ener)) - kappa*log(dens)
    s = -dens*s/(kappa-1.0_dp)

end function

pure function cons2entr_0d(u) result(s)

    real(dp),intent(in)    :: u(N_VARS)
    real(dp)               :: s

    s = cons2entr(u(DENS_VAR),u(MOMX_VAR),u(MOMY_VAR),u(MOMZ_VAR),u(ENER_VAR))

end function

pure function cons2entr_1d(u) result(s)

    real(dp),intent(in)    :: u(N_NODES,N_VARS)
    real(dp)               :: s(N_NODES)

    s = cons2entr(u(:,DENS_VAR),u(:,MOMX_VAR),u(:,MOMY_VAR),u(:,MOMZ_VAR),u(:,ENER_VAR))

end function

pure function cons2entr_2d(u) result(s)

    real(dp),intent(in)    :: u(N_NODES,N_NODES,N_VARS)
    real(dp)               :: s(N_NODES,N_NODES)

    s = cons2entr(u(:,:,DENS_VAR),u(:,:,MOMX_VAR),u(:,:,MOMY_VAR),u(:,:,MOMZ_VAR),u(:,:,ENER_VAR))

end function

pure function cons2entr_3d(u) result(s)

    real(dp),intent(in)    :: u(N_NODES,N_NODES,N_NODES,N_VARS)
    real(dp)               :: s(N_NODES,N_NODES,N_NODES)

    s = cons2entr(u(:,:,:,DENS_VAR),u(:,:,:,MOMX_VAR),u(:,:,:,MOMY_VAR),u(:,:,:,MOMZ_VAR),u(:,:,:,ENER_VAR))

end function

pure function cons2evec(u) result(w)

    use setup_config_mod, only: kappa

    real(dp),intent(in)    :: u(N_VARS)
    real(dp)               :: w(N_VARS)

    real(dp) :: p(N_VARS),s,b

    !! primitive variables
    p = cons2prim(u)

    !! compressible gas dynamics entropy
    s = log(p(PRES_VAR)) - kappa*log(p(DENS_VAR))

    !! beta
    b = p(DENS_VAR)/p(PRES_VAR)

    !! entropy variables
    w(DENS_VAR) = (kappa - s)/(kappa-1.0_dp) - 0.5_dp*b*(p(VELX_VAR)**2 + p(VELY_VAR)**2 + p(VELZ_VAR)**2)
    w(VELX_VAR) = b*p(VELX_VAR)
    w(VELY_VAR) = b*p(VELY_VAR)
    w(VELZ_VAR) = b*p(VELZ_VAR)
    w(PRES_VAR) = -b

end function

pure elemental function soundspeed_elemental(dens,momx,momy,momz,ener) result(c)

    use setup_config_mod, only: kappa

    real(dp),intent(in)    :: dens,momx,momy,momz,ener
    real(dp)               :: c

    c = sqrt(kappa*pressure(dens,momx,momy,momz,ener)/dens)

end function

pure function soundspeed_0d(u) result(c)

    real(dp),intent(in)    :: u(N_VARS)
    real(dp)               :: c

    c = soundspeed(u(DENS_VAR),u(MOMX_VAR),u(MOMY_VAR),u(MOMZ_VAR),u(ENER_VAR))

end function

pure function soundspeed_1d(u) result(c)

    real(dp),intent(in)    :: u(:,:)
    real(dp)               :: c(size(u,dim=1))

    c = soundspeed(u(:,DENS_VAR),u(:,MOMX_VAR),u(:,MOMY_VAR),u(:,MOMZ_VAR),u(:,ENER_VAR))

end function

pure function soundspeed_2d(u) result(c)

    real(dp),intent(in)    :: u(:,:,:)
    real(dp)               :: c(size(u,dim=1),size(u,dim=2))

    c = soundspeed(u(:,:,DENS_VAR),u(:,:,MOMX_VAR),u(:,:,MOMY_VAR),u(:,:,MOMZ_VAR),u(:,:,ENER_VAR))

end function

pure function soundspeed_3d(u) result(c)

    real(dp),intent(in)    :: u(:,:,:,:)
    real(dp)               :: c(size(u,dim=1),size(u,dim=2),size(u,dim=3))

    c = soundspeed(u(:,:,:,DENS_VAR),u(:,:,:,MOMX_VAR),u(:,:,:,MOMY_VAR),u(:,:,:,MOMZ_VAR),u(:,:,:,ENER_VAR))

end function

!! ========================================================================== !!

pure elemental function isvalid_elemental(dens,momx,momy,momz,ener) result(rest)

    real(dp),intent(in)     :: dens,momx,momy,momz,ener
    logical                 :: rest

    rest = (dens > 0.0_dp) .and. (pressure(dens,momx,momy,momz,ener) > 0.0_dp)

end function

pure function isvalid_0d(u) result(ok)

    real(dp),intent(in) :: u(N_VARS)
    logical             :: ok

    ok = isvalid(u(DENS_VAR),u(MOMX_VAR),u(MOMY_VAR),u(MOMZ_VAR),u(ENER_VAR))

end function

pure function isvalid_1d(u) result(ok)

    real(dp),intent(in)     :: u(:,:)
    logical                 :: ok

    ok = all(isvalid(u(:,DENS_VAR),u(:,MOMX_VAR),u(:,MOMY_VAR),u(:,MOMZ_VAR),u(:,ENER_VAR)))

end function

pure function isvalid_2d(u) result(ok)

    real(dp),intent(in)     :: u(:,:,:)
    logical                 :: ok

    ok = all(isvalid(u(:,:,DENS_VAR),u(:,:,MOMX_VAR),u(:,:,MOMY_VAR),u(:,:,MOMZ_VAR),u(:,:,ENER_VAR)))

end function

pure function isvalid_3d(u) result(ok)

    real(dp),intent(in)     :: u(:,:,:,:)
    logical                 :: ok

    ok = all(isvalid(u(:,:,:,DENS_VAR),u(:,:,:,MOMX_VAR),u(:,:,:,MOMY_VAR),u(:,:,:,MOMZ_VAR),u(:,:,:,ENER_VAR)))

end function

!! ========================================================================== !!

pure elemental function xlambdaMax_elemental(dens,momx,momy,momz,ener) result(res)

    use setup_config_mod, only: kappa

    real(dp),intent(in)    :: dens,momx,momy,momz,ener
    real(dp)               :: res

    res = abs(momx/dens) + soundspeed(dens,momx,momy,momz,ener)

end function

pure function xlambdaMax_0d(u) result(res)

    use setup_config_mod, only: kappa

    real(dp),intent(in)    :: u(N_VARS)
    real(dp)               :: res

    res = xlambdaMax(u(DENS_VAR),u(MOMX_VAR),u(MOMY_VAR),u(MOMZ_VAR),u(ENER_VAR))

end function

pure function xlambdaMax_1d(u) result(l)

    real(dp),intent(in)    :: u(:,:)
    real(dp)               :: l(size(u,dim=1))

    l = xlambdaMax(u(:,DENS_VAR),u(:,MOMX_VAR),u(:,MOMY_VAR),u(:,MOMZ_VAR),u(:,ENER_VAR))

end function

pure function xlambdaMax_2d(u) result(l)

    real(dp),intent(in)    :: u(:,:,:)
    real(dp)               :: l(size(u,dim=1),size(u,dim=2))

    l = xlambdaMax(u(:,:,DENS_VAR),u(:,:,MOMX_VAR),u(:,:,MOMY_VAR),u(:,:,MOMZ_VAR),u(:,:,ENER_VAR))

end function

pure function xlambdaMax_3d(u) result(l)

    real(dp),intent(in)    :: u(:,:,:,:)
    real(dp)               :: l(size(u,dim=1),size(u,dim=2),size(u,dim=3))

    l = xlambdaMax(u(:,:,:,DENS_VAR),u(:,:,:,MOMX_VAR),u(:,:,:,MOMY_VAR),u(:,:,:,MOMZ_VAR),u(:,:,:,ENER_VAR))

end function

!! ========================================================================== !!

pure elemental function ylambdaMax_elemental(dens,momx,momy,momz,ener) result(res)

    real(dp),intent(in)    :: dens, momx, momy, momz, ener
    real(dp)               :: res

    res = xlambdaMax(dens,momy,momz,momx,ener)

end function

pure function ylambdaMax_0d(u) result(res)

    use setup_config_mod, only: kappa

    real(dp),intent(in)    :: u(N_VARS)
    real(dp)               :: res

    res = ylambdaMax(u(DENS_VAR),u(MOMX_VAR),u(MOMY_VAR),u(MOMZ_VAR),u(ENER_VAR))

end function

pure function ylambdaMax_1d(u) result(l)

    real(dp),intent(in)    :: u(:,:)
    real(dp)               :: l(size(u,dim=1))

    l = ylambdaMax(u(:,DENS_VAR),u(:,MOMX_VAR),u(:,MOMY_VAR),u(:,MOMZ_VAR),u(:,ENER_VAR))

end function

pure function ylambdaMax_2d(u) result(l)

    real(dp),intent(in)    :: u(:,:,:)
    real(dp)               :: l(size(u,dim=1),size(u,dim=2))

    l = ylambdaMax(u(:,:,DENS_VAR),u(:,:,MOMX_VAR),u(:,:,MOMY_VAR),u(:,:,MOMZ_VAR),u(:,:,ENER_VAR))

end function

pure function ylambdaMax_3d(u) result(l)

    real(dp),intent(in)    :: u(:,:,:,:)
    real(dp)               :: l(size(u,dim=1),size(u,dim=2),size(u,dim=3))

    l = ylambdaMax(u(:,:,:,DENS_VAR),u(:,:,:,MOMX_VAR),u(:,:,:,MOMY_VAR),u(:,:,:,MOMZ_VAR),u(:,:,:,ENER_VAR))

end function

!! ========================================================================== !!

pure elemental function zlambdaMax_elemental(dens, momx, momy, momz, ener) result(res)

    real(dp),intent(in)    :: dens, momx, momy, momz, ener
    real(dp)               :: res

    res = xlambdaMax(dens,momz,momx,momy,ener)

end function

pure function zlambdaMax_0d(u) result(res)

    use setup_config_mod, only: kappa

    real(dp),intent(in)    :: u(N_VARS)
    real(dp)               :: res

    res = zlambdaMax(u(DENS_VAR),u(MOMX_VAR),u(MOMY_VAR),u(MOMZ_VAR),u(ENER_VAR))

end function

pure function zlambdaMax_1d(u) result(l)

    real(dp),intent(in)    :: u(:,:)
    real(dp)               :: l(size(u,dim=1))

    l = zlambdaMax(u(:,DENS_VAR),u(:,MOMX_VAR),u(:,MOMY_VAR),u(:,MOMZ_VAR),u(:,ENER_VAR))

end function

pure function zlambdaMax_2d(u) result(l)

    real(dp),intent(in)    :: u(:,:,:)
    real(dp)               :: l(size(u,dim=1),size(u,dim=2))

    l = zlambdaMax(u(:,:,DENS_VAR),u(:,:,MOMX_VAR),u(:,:,MOMY_VAR),u(:,:,MOMZ_VAR),u(:,:,ENER_VAR))

end function

pure function zlambdaMax_3d(u) result(l)

    real(dp),intent(in)    :: u(:,:,:,:)
    real(dp)               :: l(size(u,dim=1),size(u,dim=2),size(u,dim=3))

    l = zlambdaMax(u(:,:,:,DENS_VAR),u(:,:,:,MOMX_VAR),u(:,:,:,MOMY_VAR),u(:,:,:,MOMZ_VAR),u(:,:,:,ENER_VAR))

end function

end module


*> \brief \b CGET54
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE CGET54( N, A, LDA, B, LDB, S, LDS, T, LDT, U, LDU, V,
*                          LDV, WORK, RESULT )
*
*       .. Scalar Arguments ..
*       INTEGER            LDA, LDB, LDS, LDT, LDU, LDV, N
*       REAL               RESULT
*       ..
*       .. Array Arguments ..
*       COMPLEX            A( LDA, * ), B( LDB, * ), S( LDS, * ),
*      $                   T( LDT, * ), U( LDU, * ), V( LDV, * ),
*      $                   WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CGET54 checks a generalized decomposition of the form
*>
*>          A = U*S*V'  and B = U*T* V'
*>
*> where ' means conjugate transpose and U and V are unitary.
*>
*> Specifically,
*>
*>   RESULT = ||( A - U*S*V', B - U*T*V' )|| / (||( A, B )||*n*ulp )
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The size of the matrix.  If it is zero, SGET54 does nothing.
*>          It must be at least zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is COMPLEX array, dimension (LDA, N)
*>          The original (unfactored) matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of A.  It must be at least 1
*>          and at least N.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is COMPLEX array, dimension (LDB, N)
*>          The original (unfactored) matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of B.  It must be at least 1
*>          and at least N.
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*>          S is COMPLEX array, dimension (LDS, N)
*>          The factored matrix S.
*> \endverbatim
*>
*> \param[in] LDS
*> \verbatim
*>          LDS is INTEGER
*>          The leading dimension of S.  It must be at least 1
*>          and at least N.
*> \endverbatim
*>
*> \param[in] T
*> \verbatim
*>          T is COMPLEX array, dimension (LDT, N)
*>          The factored matrix T.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*>          LDT is INTEGER
*>          The leading dimension of T.  It must be at least 1
*>          and at least N.
*> \endverbatim
*>
*> \param[in] U
*> \verbatim
*>          U is COMPLEX array, dimension (LDU, N)
*>          The orthogonal matrix on the left-hand side in the
*>          decomposition.
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*>          LDU is INTEGER
*>          The leading dimension of U.  LDU must be at least N and
*>          at least 1.
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*>          V is COMPLEX array, dimension (LDV, N)
*>          The orthogonal matrix on the left-hand side in the
*>          decomposition.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*>          LDV is INTEGER
*>          The leading dimension of V.  LDV must be at least N and
*>          at least 1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX array, dimension (3*N**2)
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*>          RESULT is REAL
*>          The value RESULT, It is currently limited to 1/ulp, to
*>          avoid overflow. Errors are flagged by RESULT=10/ulp.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex_eig
*
*  =====================================================================
      SUBROUTINE CGET54( N, A, LDA, B, LDB, S, LDS, T, LDT, U, LDU, V,
     $                   LDV, WORK, RESULT )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            LDA, LDB, LDS, LDT, LDU, LDV, N
      REAL               RESULT
*     ..
*     .. Array Arguments ..
      COMPLEX            A( LDA, * ), B( LDB, * ), S( LDS, * ),
     $                   T( LDT, * ), U( LDU, * ), V( LDV, * ),
     $                   WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
      COMPLEX            CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      REAL               ABNORM, ULP, UNFL, WNORM
*     ..
*     .. Local Arrays ..
      REAL               DUM( 1 )
*     ..
*     .. External Functions ..
      REAL               CLANGE, SLAMCH
      EXTERNAL           CLANGE, SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           CGEMM, CLACPY
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, REAL
*     ..
*     .. Executable Statements ..
*
      RESULT = ZERO
      IF( N.LE.0 )
     $   RETURN
*
*     Constants
*
      UNFL = SLAMCH( 'Safe minimum' )
      ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
*
*     compute the norm of (A,B)
*
      CALL CLACPY( 'Full', N, N, A, LDA, WORK, N )
      CALL CLACPY( 'Full', N, N, B, LDB, WORK( N*N+1 ), N )
      ABNORM = MAX( CLANGE( '1', N, 2*N, WORK, N, DUM ), UNFL )
*
*     Compute W1 = A - U*S*V', and put in the array WORK(1:N*N)
*
      CALL CLACPY( ' ', N, N, A, LDA, WORK, N )
      CALL CGEMM( 'N', 'N', N, N, N, CONE, U, LDU, S, LDS, CZERO,
     $            WORK( N*N+1 ), N )
*
      CALL CGEMM( 'N', 'C', N, N, N, -CONE, WORK( N*N+1 ), N, V, LDV,
     $            CONE, WORK, N )
*
*     Compute W2 = B - U*T*V', and put in the workarray W(N*N+1:2*N*N)
*
      CALL CLACPY( ' ', N, N, B, LDB, WORK( N*N+1 ), N )
      CALL CGEMM( 'N', 'N', N, N, N, CONE, U, LDU, T, LDT, CZERO,
     $            WORK( 2*N*N+1 ), N )
*
      CALL CGEMM( 'N', 'C', N, N, N, -CONE, WORK( 2*N*N+1 ), N, V, LDV,
     $            CONE, WORK( N*N+1 ), N )
*
*     Compute norm(W)/ ( ulp*norm((A,B)) )
*
      WNORM = CLANGE( '1', N, 2*N, WORK, N, DUM )
*
      IF( ABNORM.GT.WNORM ) THEN
         RESULT = ( WNORM / ABNORM ) / ( 2*N*ULP )
      ELSE
         IF( ABNORM.LT.ONE ) THEN
            RESULT = ( MIN( WNORM, 2*N*ABNORM ) / ABNORM ) / ( 2*N*ULP )
         ELSE
            RESULT = MIN( WNORM / ABNORM, REAL( 2*N ) ) / ( 2*N*ULP )
         END IF
      END IF
*
      RETURN
*
*     End of CGET54
*
      END


!
! Copyright 2020-2022 Fluid Numerics LLC
! Author : Joseph Schoonover (joe@fluidnumerics.com)
! Support : support@fluidnumerics.com
!
! //////////////////////////////////////////////////////////////////////////////////////////////// !
MODULE SELF_ShallowWater1D

  USE SELF_Metadata
  USE SELF_Mesh
  USE SELF_MappedData
  USE SELF_Model

  TYPE,EXTENDS(Model1D) :: ShallowWater1D
    !! iVar = 1 ~> u velocity component
    !! iVar = 2 ~> free surface height
    REAL(prec) :: g     ! gravity ( m/s^2)
    TYPE(MappedScalar1D) :: H ! bottom topography ( m )
    TYPE(MappedScalar1D) :: gradH ! bottom topography gradient ( m/m )

    CONTAINS

    ! Overridden Methods
    PROCEDURE :: Init => Init_ShallowWater1D
    PROCEDURE :: CalculateEntropy => CalculateEntropy_ShallowWater1D

    PROCEDURE :: PreTendency => PreTendency_ShallowWater1D

    ! Concretized Methods
    PROCEDURE :: SourceMethod => Source_ShallowWater1D
    PROCEDURE :: FluxMethod => Flux_ShallowWater1D
    PROCEDURE :: RiemannSolver => RiemannSolver_ShallowWater1D
    PROCEDURE :: SetBoundaryCondition => SetBoundaryCondition_ShallowWater1D

    ! New Methods
    GENERIC :: SetTopography => SetTopographyFromChar_ShallowWater1D,&
                              SetTopographyFromEqn_ShallowWater1D
    PROCEDURE,PRIVATE :: SetTopographyFromChar_ShallowWater1D
    PROCEDURE,PRIVATE :: SetTopographyFromEqn_ShallowWater1D

  END TYPE ShallowWater1D

!  INTERFACE
!    SUBROUTINE SetBoundaryCondition_ShallowWater1D_gpu_wrapper(solution, extBoundary, nHat, sideInfo, N, nVar, nEl) &
!      bind(c,name="SetBoundaryCondition_ShallowWater1D_gpu_wrapper")
!      USE iso_c_binding
!      USE SELF_Constants
!      IMPLICIT NONE
!      TYPE(c_ptr) :: solution, extBoundary, nHat, sideInfo
!      INTEGER(C_INT),VALUE :: N,nVar,nEl
!    END SUBROUTINE SetBoundaryCondition_ShallowWater1D_gpu_wrapper
!  END INTERFACE
!
  INTERFACE
    SUBROUTINE Source_ShallowWater1D_gpu_wrapper(source, solution, gradH, g, N, nVar, nEl) &
      bind(c,name="Source_ShallowWater1D_gpu_wrapper")
      USE iso_c_binding
      USE SELF_Constants
      IMPLICIT NONE
      TYPE(c_ptr) :: source, solution, gradH
      INTEGER(C_INT),VALUE :: N,nVar,nEl
      REAL(c_prec),VALUE :: g
    END SUBROUTINE Source_ShallowWater1D_gpu_wrapper
  END INTERFACE
!
!  INTERFACE
!    SUBROUTINE Flux_ShallowWater1D_gpu_wrapper(flux, solution, g, H, N, nVar, nEl) &
!      bind(c,name="Flux_ShallowWater1D_gpu_wrapper")
!      USE iso_c_binding
!      USE SELF_Constants
!      IMPLICIT NONE
!      TYPE(c_ptr) :: flux, solution
!      INTEGER(C_INT),VALUE :: N,nVar,nEl
!      REAL(c_prec),VALUE :: g, H
!    END SUBROUTINE Flux_ShallowWater1D_gpu_wrapper
!  END INTERFACE
!
!  INTERFACE
!    SUBROUTINE RiemannSolver_ShallowWater1D_gpu_wrapper(flux, solution, extBoundary, nHat, nScale, g, H, N, nVar, nEl) &
!      bind(c,name="RiemannSolver_ShallowWater1D_gpu_wrapper")
!      USE iso_c_binding
!      USE SELF_Constants
!      IMPLICIT NONE
!      TYPE(c_ptr) :: flux, solution, extBoundary, nHat, nScale
!      INTEGER(C_INT),VALUE :: N,nVar,nEl
!      REAL(c_prec),VALUE :: g, H
!    END SUBROUTINE RiemannSolver_ShallowWater1D_gpu_wrapper
!  END INTERFACE

CONTAINS

  SUBROUTINE Init_ShallowWater1D(this,nvar,mesh,geometry,decomp)
    IMPLICIT NONE
    CLASS(ShallowWater1D),INTENT(out) :: this
    INTEGER,INTENT(in) :: nvar
    TYPE(Mesh1D),INTENT(in),TARGET :: mesh
    TYPE(Geometry1D),INTENT(in),TARGET :: geometry
    TYPE(MPILayer),INTENT(in),TARGET :: decomp
    ! Local
    INTEGER :: ivar
    CHARACTER(LEN=3) :: ivarChar
    CHARACTER(LEN=25) :: varname
    INTEGER :: nvarloc

    ! Ensure that the number of variables is 3
    ! nvar is unused in this class extension
    nvarloc = 2

    this % decomp => decomp
    this % mesh => mesh
    this % geometry => geometry
    this % gpuAccel = .FALSE.
    this % fluxDivMethod = SELF_CONSERVATIVE_FLUX
    this % g = 1.0_prec

    CALL this % solution % Init(geometry % x % interp,nvarloc,this % mesh % nElem)
    CALL this % H % Init(geometry % x % interp,1,this % mesh % nElem)
    CALL this % gradH % Init(geometry % x % interp,1,this % mesh % nElem)
    CALL this % workSol % Init(geometry % x % interp,nVar,this % mesh % nElem)
    CALL this % velocity % Init(geometry % x % interp,1,this % mesh % nElem)
    CALL this % dSdt % Init(geometry % x % interp,nvarloc,this % mesh % nElem)
    CALL this % solutionGradient % Init(geometry % x % interp,nvarloc,this % mesh % nElem)
    CALL this % flux % Init(geometry % x % interp,nvarloc,this % mesh % nElem)
    CALL this % source % Init(geometry % x % interp,nvarloc,this % mesh % nElem)
    CALL this % fluxDivergence % Init(geometry % x % interp,nvarloc,this % mesh % nElem)

    ! First three variables are treated as u, v, eta
    ! Any additional are treated as passive tracers
    CALL this % solution % SetName(1,"Hu")
    CALL this % solution % SetUnits(1,"m^2/s")
    CALL this % solution % SetDescription(1,"x-component of the volume flux")

    CALL this % solution % SetName(2,"H")
    CALL this % solution % SetUnits(2,"m")
    CALL this % solution % SetDescription(2,"Total fluid thickness")

  END SUBROUTINE Init_ShallowWater1D

  SUBROUTINE CalculateEntropy_ShallowWater1D(this)
  !! Base method for calculating entropy of a model
  !! Calculates the entropy as the integration of the
  !! squared tracer over the domain
    IMPLICIT NONE
    CLASS(ShallowWater1D), INTENT(inout) :: this
    ! Local
    INTEGER :: i, j, iVar, iEl
    REAL(prec) :: Jacobian, Hu, H, b
    REAL(prec) :: wi

    this % entropy = 0.0_prec

    DO iEl = 1, this % geometry % x % nElem
      DO i = 0, this % geometry % x % interp % N

        ! Coordinate mapping Jacobian
        Jacobian = this % geometry % dxds % interior % hostData(i,1,iEl)

        ! Quadrature weights
        wi = this % geometry % x % interp % qWeights % hostData(i)

        ! Solution
        Hu = this % solution % interior % hostData(i,1,iEl)
        H = this % solution % interior % hostData(i,2,iEl)
        b = this % H % interior % hostData(i,1,iEl)

        this % entropy = this % entropy + ( 0.5_prec*Hu*Hu/H + &
                                            0.5_prec*this % g*H*H - this % g*H*b )*Jacobian*wi

      ENDDO
    ENDDO

  END SUBROUTINE CalculateEntropy_ShallowWater1D

  SUBROUTINE PreTendency_ShallowWater1D(this)
    !! Calculate the velocity at element interior and element boundaries
    !! PreTendency is a template routine that is used to house any additional calculations
    !! that you want to execute at the beginning of the tendency calculation routine.
    !! This default PreTendency simply returns back to the caller without executing any instructions
    !!
    !! The intention is to provide a method that can be overridden through type-extension, to handle
    !! any steps that need to be executed before proceeding with the usual tendency calculation methods.
    !!
    IMPLICIT NONE
    CLASS(ShallowWater1D),INTENT(inout) :: this
    !
    INTEGER :: iEl, i
    REAL(prec) :: H

      DO iEl = 1, this % solution % nElem
        DO i = 0, this % solution % interp % N

          H = this % solution % interior % hostData(i,2,iEl)

          this % velocity % interior % hostData(i,1,iEl) = &
                  this % solution % interior % hostData(i,1,iEl)/H

        ENDDO
      ENDDO

      CALL this % velocity % BoundaryInterp( gpuAccel = this % gpuAccel )
      CALL this % velocity % SideExchange(this % mesh, this % decomp, this % gpuAccel)

  END SUBROUTINE PreTendency_ShallowWater1D

  SUBROUTINE SetTopographyFromChar_ShallowWater1D(this, eqnChar)
    IMPLICIT NONE
    CLASS(ShallowWater1D),INTENT(inout) :: this
    CHARACTER(*),INTENT(in) :: eqnChar

      CALL this % H % SetEquation(1, eqnChar)

      CALL this % H % SetInteriorFromEquation( this % geometry, this % t )

      CALL this % H % BoundaryInterp( gpuAccel = .FALSE. )

      CALL this % H % Derivative( this % geometry, &
                                this % gradH, &
                                selfStrongForm, &
                                .FALSE.)

      IF( this % gpuAccel )THEN
        CALL this % H % UpdateDevice()
      ENDIF

  END SUBROUTINE SetTopographyFromChar_ShallowWater1D

  SUBROUTINE SetTopographyFromEqn_ShallowWater1D(this, eqn)
    IMPLICIT NONE
    CLASS(ShallowWater1D),INTENT(inout) :: this
    TYPE(EquationParser),INTENT(in) :: eqn

      ! Copy the equation parser
      CALL this % H % SetEquation(1, eqn % equation)

      CALL this % H % SetInteriorFromEquation( this % geometry, this % t )

      CALL this % H % BoundaryInterp( gpuAccel = .FALSE. )

      CALL this % H % Derivative( this % geometry, &
                                this % gradH, &
                                selfStrongForm, &
                                .FALSE.)

      IF( this % gpuAccel )THEN
        CALL this % H % UpdateDevice()
      ENDIF

  END SUBROUTINE SetTopographyFromEqn_ShallowWater1D

  SUBROUTINE SetBoundaryCondition_ShallowWater1D(this)
    IMPLICIT NONE
    CLASS(ShallowWater1D),INTENT(inout) :: this
    ! Local
    INTEGER :: iEl, iSide, i
    INTEGER :: bcid, e2
    REAL(prec) :: u, v, nhat(1:2)

     ! Only do radiation condition (for now)
     ! Left most boundary
     this % solution % extBoundary % hostData(1,1,1) = 0.0_prec
     this % solution % extBoundary % hostData(2,1,1) = this % H % boundary % hostData(1,1,1)

     ! Right most boundary
     this % solution % extBoundary % hostData(1,2,this % solution % nElem) = 0.0_prec
     this % solution % extBoundary % hostData(2,2,this % solution % nElem) = &
             this % H % boundary % hostData(1,2,this % solution % nElem)

  END SUBROUTINE SetBoundaryCondition_ShallowWater1D

  SUBROUTINE Source_ShallowWater1D(this)
    IMPLICIT NONE
    CLASS(ShallowWater1D),INTENT(inout) :: this
    ! Local
    INTEGER :: i,j,iEl,iVar

      IF( this % gpuAccel )THEN

       CALL Source_ShallowWater1D_gpu_wrapper(this % source % interior % deviceData, &
                                              this % solution % interior % deviceData, &
                                              this % gradH % interior % deviceData, &
                                              this % g, &
                                              this % source % interp % N, &
                                              this % solution % nVar, &
                                              this % solution % nElem )

      ELSE
        DO iEl = 1, this % source % nElem
          DO i = 0, this % source % interp % N

            this % source % interior % hostData(i,1,iEl) = &
                    this % g*this % solution % interior % hostData(i,2,iEl)*&
                    this % gradH % interior % hostData(i,1,iEl)

            this % source % interior % hostData(i,2,iEl) = 0.0_prec

          ENDDO
        ENDDO
      ENDIF

  END SUBROUTINE Source_ShallowWater1D

  SUBROUTINE Flux_ShallowWater1D(this)
    IMPLICIT NONE
    CLASS(ShallowWater1D),INTENT(inout) :: this
    ! Local
    INTEGER :: i,j,iEl,iVar

      DO iEl = 1, this % solution % nElem
        DO iVar = 1, this % solution % nVar
          DO i = 0, this % solution % interp % N

            IF ( iVar == 1 )THEN ! Hu

              ! Hu^2 + (gH^2)/2
              this % flux % interior % hostData(i,iVar,iEl) = &
                    this % velocity % interior % hostData(i,1,iEl)*& ! u
                    this % solution % interior % hostData(i,1,iEl)+& ! Hu
                    0.5_prec*this % g*this % solution % interior % hostData(i,2,iEl)*&
                    this % solution % interior % hostData(i,2,iEl)

            ELSEIF ( iVar == 2 )THEN ! H - total fluid thickness
              this % flux % interior % hostData(i,iVar,iEl) = &
                    this % solution % interior % hostData(i,1,iEl)

            ENDIF

          ENDDO
        ENDDO
      ENDDO

  END SUBROUTINE Flux_ShallowWater1D

  SUBROUTINE RiemannSolver_ShallowWater1D(this)
    IMPLICIT NONE
    CLASS(ShallowWater1D),INTENT(inout) :: this
    ! Local
    INTEGER :: i,iSide,iEl
    REAL(prec) :: cL, cR, unL, unR, HL, HR, HuL, HuR, HvL, HvR
    REAL(prec) :: alpha, nhat
    REAL(prec) :: fluxL(1:2)
    REAL(prec) :: fluxR(1:2)

      DO iEl = 1, this % solution % nElem
        DO iSide = 1, 2

           ! Get the boundary normals on cell edges from the mesh geometry
           IF( iSide ==  1)THEN
             nhat = -1.0_prec
           ELSE
             nhat = 1.0_prec
           ENDIF

           ! Calculate the normal velocity at the cell edges
           unL = this % velocity % boundary % hostData(1,iSide,iEl)
           unR = this % velocity % extBoundary % hostData(1,iSide,iEl)

           cL = sqrt( this % g * this % solution % boundary % hostData(2,iSide,iEl))
           cR = sqrt( this % g * this % solution % extBoundary % hostData(2,iSide,iEl))

           HuL = this % solution % boundary % hostData(1,iSide,iEl)
           HuR = this % solution % extBoundary % hostData(1,iSide,iEl)

           HL = this % solution % boundary % hostData(2,iSide,iEl)
           HR = this % solution % extBoundary % hostData(2,iSide,iEl)

           fluxL(1) = (HuL*unL + this % g*HL*HL*0.5_prec)*nHat
           fluxL(2) = HuL*nHat

           fluxR(1) = (HuR*unR + this % g*HR*HR*0.5_prec)*nHat
           fluxR(2) = HuR*nHat

           alpha = MAX( ABS(unL+cL), ABS(unR+cR), &
                        ABS(unL-cL), ABS(unR-cR) )

           ! Pull external and internal state for the Riemann Solver (Lax-Friedrichs)
           this % flux % boundary % hostData(1,iSide,iEl) = 0.5_prec*( &
                   fluxL(1) + fluxR(1) + alpha*( HuL - HuR ) )
           this % flux % boundary % hostData(2,iSide,iEl) = 0.5_prec*( &
                   fluxL(2) + fluxR(2) + alpha*( HL - HR ) )

        ENDDO
      ENDDO

!    ENDIF

  END SUBROUTINE RiemannSolver_ShallowWater1D

END MODULE SELF_ShallowWater1D