      SUBROUTINE ATEIG(M,A,RR,RI,IANA,IA,B,RRA,RRI)
C
C     ..................................................................
C
C        SUBROUTINE ATEIG
C
C        PURPOSE
C           COMPUTE THE EIGENVALUES OF A REAL ALMOST TRIANGULAR MATRIX
C
C        USAGE
C           CALL ATEIG(M,A,RR,RI,IANA,IA)
C
C        DESCRIPTION OF THE PARAMETERS
C           M      ORDER OF THE MATRIX
C           A      THE INPUT MATRIX, M BY M
C           RR     VECTOR CONTAINING THE REAL PARTS OF THE EIGENVALUES
C                  ON RETURN
C           RI     VECTOR CONTAINING THE IMAGINARY PARTS OF THE EIGEN-
C                  VALUES ON RETURN
C           IANA   VECTOR WHOSE DIMENSION MUST BE GREATER THAN OR EQUAL
C                  TO M, CONTAINING ON RETURN INDICATIONS ABOUT THE WAY
C                  THE EIGENVALUES APPEARED (SEE MATH. DESCRIPTION)
C           IA     SIZE OF THE FIRST DIMENSION ASSIGNED TO THE ARRAY A
C                  IN THE CALLING PROGRAM WHEN THE MATRIX IS IN DOUBLE
C                  SUBSCRIPTED DATA STORAGE MODE.
C                  IA=M WHEN THE MATRIX IS IN SSP VECTOR STORAGE MODE.
C
C        REMARKS
C           THE ORIGINAL MATRIX IS DESTROYED
C           THE DIMENSION OF RR AND RI MUST BE GREATER OR EQUAL TO M
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           NONE
C
C        METHOD
C           QR DOUBLE ITERATION
C
C        REFERENCES
C           J.G.F. FRANCIS - THE QR TRANSFORMATION---THE COMPUTER
C           JOURNAL, VOL. 4, NO. 3, OCTOBER 1961, VOL. 4, NO. 4, JANUARY
C           1962.  J. H. WILKINSON - THE ALGEBRAIC EIGENVALUE PROBLEM -
C           CLARENDON PRESS, OXFORD, 1965.
C
C     ..................................................................
C
      DIMENSION IANA(1)
      DIMENSION RRA(1),RRI(1),B(1)
      DOUBLE PRECISION A(1),RR(1),RI(1),PRR(2),PRI(2)
      DOUBLE PRECISION ALPHA,CAP,D,DELTA,EPS,ETA,E10,E6,E7,G1,G2,G3
      DOUBLE PRECISION PAN,PAN1,PSI1,PSI2,R,RMOD,S,T,U,V
      INTEGER P,P1,Q
C
      E7=1.0E-8
      E6=1.0E-6
      E10=1.0E-10
      DELTA=0.5
      MAXIT=30
C
C        INITIALIZATION
C
      N=M
   20 N1=N-1
      IN=N1*IA
      NN=IN+N
      IF(N1) 30,1300,30
   30 NP=N+1
C
C        ITERATION COUNTER
C
      IT=0
C
C        ROOTS OF THE 2ND ORDER MAIN SUBMATRIX AT THE PREVIOUS
C        ITERATION
C
      DO 40 I=1,2
      PRR(I)=0.0
   40 PRI(I)=0.0
C
C        LAST TWO SUBDIAGONAL ELEMENTS AT THE PREVIOUS ITERATION
C
      PAN=0.0
      PAN1=0.0
C
C        ORIGIN SHIFT
C
      R=0.0
      S=0.0
C
C        ROOTS OF THE LOWER MAIN 2 BY 2 SUBMATRIX
C
      N2=N1-1
      IN1=IN-IA
      NN1=IN1+N
      N1N=IN+N1
      N1N1=IN1+N1
   60 T=A(N1N1)-A(NN)
      U=T*T
      V=4.0D0*A(N1N)*A(NN1)
      IF (DABS(V)-U*E7) 100,100,65
   65 T=U+V
      IF (DABS(T)-DMAX1(U,DABS(V))*E6) 67,67,68
   67 T=0.0
68    U=(A(N1N1)+A(NN))/2.0D0
      V=DSQRT(DABS(T))/2.0D0
      IF(T)140,70,70
   70 IF(U) 80,75,75
   75 RR(N1)=U+V
      RR(N)=U-V
      GO TO 130
   80 RR(N1)=U-V
      RR(N)=U+V
      GO TO 130
  100 IF(T)120,110,110
  110 RR(N1)=A(N1N1)
      RR(N)=A(NN)
      GO TO 130
  120 RR(N1)=A(NN)
      RR(N)=A(N1N1)
  130 RI(N)=0.0
      RI(N1)=0.0
      GO TO 160
  140 RR(N1)=U
      RR(N)=U
      RI(N1)=V
      RI(N)=-V
  160 IF(N2)1280,1280,180
C
C        TESTS OF CONVERGENCE
C
  180 N1N2=N1N1-IA
      RMOD=RR(N1)*RR(N1)+RI(N1)*RI(N1)
      EPS=E10*DSQRT(RMOD)
      IF(DABS(A(N1N2))-EPS)1280,1280,240
240   IF(DABS(A(NN1))-E10*DABS(A(NN))) 1300,1300,250
250   IF(DABS(PAN1-A(N1N2))-DABS(A(N1N2))*E6) 1240,1240,260
260   IF(DABS(PAN-A(NN1))-DABS(A(NN1))*E6) 1240,1240,300
  300 IF(IT-MAXIT) 320,1240,1240
C
C        COMPUTE THE SHIFT
C
  320 J=1
      DO 360 I=1,2
      K=NP-I
      IF(DABS(RR(K)-PRR(I))+DABS(RI(K)-PRI(I))-DELTA*(DABS(RR(K))
     *   +DABS(RI(K)))) 340,360,360
  340 J=J+I
  360 CONTINUE
      GO TO (440,460,460,480),J
  440 R=0.0
      S=0.0
      GO TO 500
  460 J=N+2-J
      R=RR(J)*RR(J)
      S=RR(J)+RR(J)
      GO TO 500
  480 R=RR(N)*RR(N1)-RI(N)*RI(N1)
      S=RR(N)+RR(N1)
C
C        SAVE THE LAST TWO SUBDIAGONAL TERMS AND THE ROOTS OF THE
C        SUBMATRIX BEFORE ITERATION
C
  500 PAN=A(NN1)
      PAN1=A(N1N2)
      DO 520 I=1,2
      K=NP-I
      PRR(I)=RR(K)
  520 PRI(I)=RI(K)
C
C        SEARCH FOR A PARTITION OF THE MATRIX, DEFINED BY P AND Q
C
      P=N2
      IPI = N1N2
      DO 580 J=2,N2
      IPI = IPI - IA - 1
      IF(DABS(A(IPI))-EPS) 600,600,530
  530 IPIP=IPI+IA
      IPIP2=IPIP+IA
      D=A(IPIP)*(A(IPIP)-S)+A(IPIP2)*A(IPIP+1)+R
      IF(D)540,560,540
540   IF(DABS(A(IPI)*A(IPIP+1))*(DABS(A(IPIP)+A(IPIP2+1)-S)+
     * DABS(A(IPIP2+2)))-DABS(D)*EPS) 620,620,560
  560 P=N1-J
  580 CONTINUE
  600 Q=P
      GO TO 680
  620 P1=P-1
      Q = P
      DO 660 I = 1,P1
      IPI = IPI - IA - 1
      IF(DABS(A(IPI))-EPS) 680,680,660
  660 Q=Q-1
C
C        QR DOUBLE ITERATION
C
  680 II=(P-1)*IA+P
      DO 1220 I=P,N1
      II1=II-IA
      IIP=II+IA
      IF(I-P)720,700,720
  700 IPI=II+1
      IPIP=IIP+1
C
C        INITIALIZATION OF THE TRANSFORMATION
C
      G1=A(II)*(A(II)-S)+A(IIP)*A(IPI)+R
      G2=A(IPI)*(A(IPIP)+A(II)-S)
      G3=A(IPI)*A(IPIP+1)
      A(IPI+1)=0.0
      GO TO 780
  720 G1=A(II1)
      G2=A(II1+1)
      IF(I-N2)740,740,760
  740 G3=A(II1+2)
      GO TO 780
  760 G3=0.0
780   CAP=DSQRT(G1*G1+G2*G2+G3*G3)
      IF(CAP)800,860,800
  800 IF(G1)820,840,840
  820 CAP=-CAP
  840 T=G1+CAP
      PSI1=G2/T
      PSI2=G3/T
      ALPHA=2.0D0/(1.0D0+PSI1*PSI1+PSI2*PSI2)
      GO TO 880
  860 ALPHA=2.0
      PSI1=0.0
      PSI2=0.0
  880 IF(I-Q)900,960,900
  900 IF(I-P)920,940,920
  920 A(II1)=-CAP
      GO TO 960
  940 A(II1)=-A(II1)
C
C        ROW OPERATION
C
  960 IJ=II
      DO 1040 J=I,N
      T=PSI1*A(IJ+1)
      IF(I-N1)980,1000,1000
  980 IP2J=IJ+2
      T=T+PSI2*A(IP2J)
 1000 ETA=ALPHA*(T+A(IJ))
      A(IJ)=A(IJ)-ETA
      A(IJ+1)=A(IJ+1)-PSI1*ETA
      IF(I-N1)1020,1040,1040
 1020 A(IP2J)=A(IP2J)-PSI2*ETA
 1040 IJ=IJ+IA
C
C        COLUMN OPERATION
C
      IF(I-N1)1080,1060,1060
 1060 K=N
      GO TO 1100
 1080 K=I+2
 1100 IP=IIP-I
      DO 1180 J=Q,K
      JIP=IP+J
      JI=JIP-IA
      T=PSI1*A(JIP)
      IF(I-N1)1120,1140,1140
 1120 JIP2=JIP+IA
      T=T+PSI2*A(JIP2)
 1140 ETA=ALPHA*(T+A(JI))
      A(JI)=A(JI)-ETA
      A(JIP)=A(JIP)-ETA*PSI1
      IF(I-N1)1160,1180,1180
 1160 A(JIP2)=A(JIP2)-ETA*PSI2
 1180 CONTINUE
      IF(I-N2)1200,1220,1220
 1200 JI=II+3
      JIP=JI+IA
      JIP2=JIP+IA
      ETA=ALPHA*PSI2*A(JIP2)
      A(JI)=-ETA
      A(JIP)=-ETA*PSI1
      A(JIP2)=A(JIP2)-ETA*PSI2
 1220 II=IIP+1
      IT=IT+1
      GO TO 60
C
C        END OF ITERATION
C
1240  IF(DABS(A(NN1))-DABS(A(N1N2))) 1300,1280,1280
C
C        TWO EIGENVALUES HAVE BEEN FOUND
C
 1280 IANA(N)=0
      IANA(N1)=2
      N=N2
      IF(N2)1400,1400,20
C
C        ONE EIGENVALUE HAS BEEN FOUND
C
 1300 RR(N)=A(NN)
      RI(N)=0.0
      IANA(N)=1
      IF(N1)1400,1400,1320
 1320 N=N1
      GO TO 20
1400  CONTINUE
      K=0
      DO 1410 I=1,M
      RRA(I)=RR(I)
      RRI(I)=RI(I)
      DO 1420 J=1,M
      K=K+1
      B(K)=A(K)
1420  CONTINUE
1410  CONTINUE
      RETURN
      END


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_pt_in( n, c, gg, p, in )

!  Return  in=.true. if the point p is in the ellipsoid E.
!  E is given by { x | norm(G^T * (x-c) ) <=1 ),  where G is an
!  n x n lower triangular matrix.  The array gg contains
!  the matrix G in packed format.

!  Note: select below method to be used.

!  S.B. Pope  6/12/04

implicit none

integer, parameter     :: k_dp = kind(1.d0)
integer, intent(in)    :: n
real(k_dp), intent(in) :: c(n), gg((n*(n+1))/2), p(n)
logical, intent(out)   :: in

integer    :: j, lm1, kst, method=2
real(k_dp) :: y(n), ysq1, ysq, yj

in = .false.  !  assume p outside E until found otherwise

! Method 1:  directly evaluate  y = G^T * [p-c] and test y^T * y <= 1.
!            (Simple, but not optimal.)

if( method == 1 ) then

!  Transform to y-space: y = G^T * [x-c]
   y = p-c
   call dtpmv( 'L', 'T', 'N', n, gg, y, 1 )  !  yp = G^T * [p-c]
   ysq1 = sum(y*y)
   if( ysq1 <= 1.d0 ) in = .true.

else

!  Method 2:  successively evaluate components of y = G^T * [p-c]; accumulate sum; test
!             (More involved, but possibly quicker)

   y   = p-c
   ysq = 0.d0
   kst = (n*(n+1))/2
   do j = n, 1, -1  !  loop backwards over columns of G
      lm1 = n-j     !  length of column vector - 1
      yj  = sum( gg(kst:kst+lm1) * y(j:n) )
      ysq = ysq + yj*yj

	  if( ysq > 1.d0 ) return

      kst = kst - lm1 - 2
   end do

   in = .true.

endif

return
end subroutine ell_pt_in


! compute_rhs.f90
! author: sunder

!-----------------------------------------------------------------------
! For a given stencil, find the oscillation indicator
!-----------------------------------------------------------------------

subroutine os_indicator(ul, OS)
    use ader_weno, only : N, OS_M
    implicit none
    ! Argument list
    double precision, intent(in) :: ul(N+1)
    double precision, intent(out) :: OS
    ! Local variables
    integer :: p, m

    OS = 0.0d0

    do p = 1, N+1
        do m = 1, N+1
            OS = OS + OS_M(p,m)*ul(p)*ul(m)
        end do
    end do

end subroutine os_indicator

!-----------------------------------------------------------------------
! Mapping function of Henrick, Aslam and Powers
!-----------------------------------------------------------------------

function OS_map(non_lin_wt, lin_wt)

    implicit none
    double precision :: OS_map
    double precision, intent(in) :: non_lin_wt, lin_wt
    double precision :: num, denom

    num = non_lin_wt*(lin_wt + lin_wt*lin_wt - 3.0d0*lin_wt*non_lin_wt + non_lin_wt*non_lin_wt)
    denom = lin_wt*lin_wt + non_lin_wt*(1.0d0-2.0d0*lin_wt)

    OS_map = num/denom

end function OS_map

!-----------------------------------------------------------------------
! Given stencil in 1D, reconstruct the solution
!-----------------------------------------------------------------------

subroutine reconstruct_1d(lu, luh)
    use ader_weno
    implicit none
    ! Argument list
    double precision, intent(in) :: lu(-N:N)  ! Stencil containing average values
    double precision, intent(out) :: luh(N+1) ! Unknown coefficients to be found
    ! Local variables
    integer :: L, iDOF, i
    double precision :: ustencil(N+1)         ! Local stencil
    double precision, dimension(N+1) :: luh_l, luh_r, luh_cl, luh_cr
    double precision :: OS_L, OS_R, OS_CL, OS_CR
    double precision :: w(nStencils), total, OS_map
    logical, parameter :: map = .false.

    ! Left biased stencil

    L = -N;

    ustencil = lu(L:L+N)
    luh_l = matmul(iML, ustencil)
    call os_indicator(luh_l, OS_L)
    w(1) = lin_wt(1)/(OS_L + small_num)**4

    ! Right biased stencil

    L = 0

    ustencil = lu(L:L+N)
    luh_r = matmul(iMR, ustencil)
    call os_indicator(luh_r, OS_R)
    w(2) = lin_wt(2)/(OS_R + small_num)**4

    ! Center right stencil

    L = -floor(real(N/2))

    ustencil = lu(L:L+N)
    luh_cr = matmul(iMCR, ustencil)
    call os_indicator(luh_cr, OS_CR)
    w(3) = lin_wt(3)/(OS_CR + small_num)**4

    if (nStencils .eq. 4) then
        L = -(floor(real(N/2)) + 1)

        ustencil = lu(L:L+N)
        luh_cl = matmul(iMCL, ustencil)
        call os_indicator(luh_cl, OS_CL)
        w(4) = lin_wt(4)/(OS_CL + small_num)**4

    end if

    ! Normalize the weights

    total = sum(w)
    w = w/total

    if (map) then

        ! Find the maped weights

        do i = 1, nStencils
            w(i) = OS_map(w(i), lin_wt(i))
        end do

        total = sum(w)
        w = w/total

    end if

    do idoF = 1, N+1
        luh(iDOF) = w(1)*luh_l(iDOF) + w(2)*luh_r(iDOF) + w(3)*luh_cr(iDOF)
        if(nStencils .eq. 4) then
            luh(iDOF) = luh(iDOF) + w(4)*luh_cl(iDOF)
        end if
    end do

end subroutine reconstruct_1d

!-----------------------------------------------------------------------
! Find the update coefficients for each cell
!-----------------------------------------------------------------------

subroutine compute_rhs
    use ader_weno
    implicit none

    double precision :: lu(-N:N), luh(n+1), uhi(nVar,N+1), qhi(nVar,N+1)
    integer :: i, k, iVar

    call apply_boundary_conditions

    ! Find boundary extrapolated values of conserved variables in each cell

    do i = 0, IMAX+1
        do iVar = 1, nVar

            do k = -N, N
                lu(k) = uh(iVar, i+k)
            end do

            call reconstruct_1d(lu, luh)

            do k = 1, N+1
                uhi(iVar,k) = luh(k)
            end do

        end do

        call ader_space_time_predictor(qhi, qbnd(:,:,i), Fbnd(:,:,i), uhi)

    end do

    ! Solve riemann problem on each face

    do i = 1, IMAX + 1
        call RiemannFlux(F(:,i), qbnd(:,2,i-1), qbnd(:,1,i), Fbnd(:,2,i-1), Fbnd(:,1,i))
    end do

    ! Find the update values in each cell

    do i = 1, IMAX
        duh(:,i) = -(1.0d0/dx)*( F(:,i+1) - F(:,i) )
    end do

end subroutine compute_rhs


      PROGRAM distance
c    Compute the distance, in meters, of between two points in
c  lat/long.
c

      REAL*8 deg, rmin, dlat1, dlong1, dlat2, dlong2, dtemp, sec
      REAL*8 deltalat, deltalong, dmperlat,dmperlong
      CHARACTER*20 token
      CHARACTER*200 CBUFIN
      COMMON /SIOLN1/ CBUFIN
      COMMON /sioln2/ jchar,NCBUF

      PRINT *,' Enter the latitude of the first point (deg, min, sec)'
      rmin = 0.
      sec = 0.
	 CALL rdline
      CALL getoke( token, nchars )
      CALL ddcode( token, nchars, deg, istat )
      CALL getoke( token, nchars )
      IF( nchars .GT. 0 ) THEN
          CALL ddcode( token, nchars, rmin, istat )
          CALL getoke( token, nchars )
          IF( nchars .GT. 0 ) THEN
              CALL ddcode( token, nchars, sec, istat )
          ENDIF
      ENDIF
c	 print *,' sec=',sec,' rmin=',rmin,' deg=',deg
      IF( deg .LT. 0. ) rmin = -rmin
      IF( deg .LT. 0. ) sec = -sec
      dlat1 = deg + rmin / 60.D0 + sec / (60.D0*60.D0)
c	 print *,' dlat1=',dlat1
c
      PRINT *,' Enter the longitude of the first point (deg, min)'
      rmin = 0.
      sec = 0.
      CALL rdline
      CALL getoke( token, nchars )
      CALL ddcode( token, nchars, deg, istat )
      CALL getoke( token, nchars )
      IF( nchars .GT. 0 ) THEN
          CALL ddcode( token, nchars, rmin, istat )
          CALL getoke( token, nchars )
          IF( nchars .GT. 0 ) THEN
              CALL ddcode( token, nchars, sec, istat )
          ENDIF
      ENDIF
c      print *,' sec=',sec,' rmin=',rmin,' deg=',deg
      IF( deg .LT. 0. ) rmin = -rmin
      IF( deg .LT. 0. ) sec = -sec
      dlong1 = deg + rmin / 60.D0 + sec / (60.D0*60.D0)
c	 print *,' dlong1=',dlong1
c
      PRINT *,' Enter the latitude of the second point (deg, min)'
      rmin = 0.
      sec = 0.
      CALL rdline
      CALL getoke( token, nchars )
      CALL ddcode( token, nchars, deg, istat )
      CALL getoke( token, nchars )
      IF( nchars .GT. 0 ) THEN
          CALL ddcode( token, nchars, rmin, istat )
          CALL getoke( token, nchars )
          IF( nchars .GT. 0 ) THEN
              CALL ddcode( token, nchars, sec, istat )
          ENDIF
      ENDIF
c      print *,' sec=',sec,' rmin=',rmin,' deg=',deg
      IF( deg .LT. 0. ) rmin = -rmin
      IF( deg .LT. 0. ) sec = -sec
      dlat2 = deg + rmin / 60.D0 + sec / (60.D0*60.D0)
c	 print *,' dlat2=',dlat2
c
      PRINT *,' Enter the longitude of the second point (deg, min)'
      rmin = 0.
      sec = 0.
      CALL rdline
      CALL getoke( token, nchars )
      CALL ddcode( token, nchars, deg, istat )
      CALL getoke( token, nchars )
      IF( nchars .GT. 0 ) THEN
          CALL ddcode( token, nchars, rmin, istat )
          CALL getoke( token, nchars )
          IF( nchars .GT. 0 ) THEN
              CALL ddcode( token, nchars, sec, istat )
          ENDIF
      ENDIF
c      print *,' sec=',sec,' rmin=',rmin,' deg=',deg
      IF( deg .LT. 0. ) rmin = -rmin
      IF( deg .LT. 0. ) sec = -sec
      dlong2 = deg + rmin / 60.D0 + sec / (60.D0*60.D0)
c	 print *,' dlong2=',dlong2
c
      CALL dlendeg(dlat1,dmperlat,dmperlong)
      deltalat = (dlat2-dlat1) * dmperlat
      deltalong = (dlong2-dlong1) * dmperlong
c	 print *,' dmperlat=',dmperlat,' dmperlong=',dmperlong
c	 print *,' deltalat=',deltalat,' deltalong=',deltalong
      dtemp = DSQRT(deltalat*deltalat +deltalong*deltalong)
      PRINT *,' The distance between the two points is',dtemp,
     & ' meters.'
      temp = dtemp / 1852.D0
      PRINT *,' The distance between the two points is',temp,
     & ' nautical miles.'
      STOP
      END


      SUBROUTINE qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(in) :: m, n, lda, lipvt
      LOGICAL, INTENT(in) :: pivot
      INTEGER, DIMENSION(lipvt), INTENT(out) :: ipvt
      REAL(rprec), DIMENSION(lda,n), INTENT(inout) :: a
      REAL(rprec), DIMENSION(n), INTENT(out) :: rdiag, acnorm, wa
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: one = 1, p05 = 0.05_dp,
     1    zero = 0
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: j, jp1, k, kmax, MINmn
      REAL(rprec) :: ajnorm, epsmch, SUM0, temp, enorm, dpmpar
      REAL(rprec) , ALLOCATABLE :: temp1u(:)
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      EXTERNAL dpmpar,enorm
C-----------------------------------------------
c
c     SUBROUTINE qrfac
c
c     this SUBROUTINE uses householder transformations with column
c     pivoting (optional) to compute a qr factorization of the
c     m by n matrix a. that is, qrfac determines an orthogonal
c     matrix q, a permutation matrix p, and an upper trapezoidal
c     matrix r with diagonal elements of nonincreasing magnitude,
c     such that a*p = q*r. the householder transformation for
c     column k, k = 1,2,...,MIN(m,n), is of the form
c
c                           t
c           i - (1/u(k))*u*u
c
c     WHERE u has zeros in the first k-1 positions. the form of
c     this transformation and the method of pivoting first
c     appeared in the corresponding linpack SUBROUTINE.
c
c     the SUBROUTINE statement is
c
c       SUBROUTINE qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)
c
c     WHERE
c
c       m is a positive INTEGER input variable set to the number
c         of rows of a.
c
c       n is a positive INTEGER input variable set to the number
c         of columns of a.
c
c       a is an m by n array. on input a CONTAINS the matrix for
c         which the qr factorization is to be computed. on output
c         the strict upper trapezoidal part of a CONTAINS the strict
c         upper trapezoidal part of r, and the lower trapezoidal
c         part of a CONTAINS a factored form of q (the non-trivial
c         elements of the u vectors described above).
c
c       lda is a positive INTEGER input variable not less than m
c         which specifies the leading DIMENSION of the array a.
c
c       pivot is a LOGICAL input variable. IF pivot is set true,
c         THEN column pivoting is enforced. IF pivot is set false,
c         THEN no column pivoting is done.
c
c       ipvt is an INTEGER output array of length lipvt. ipvt
c         defines the permutation matrix p such that a*p = q*r.
c         column j of p is column ipvt(j) of the identity matrix.
c         IF pivot is false, ipvt is not referenced.
c
c       lipvt is a positive integer input variable. if pivot is false,
c         then lipvt may be as small as 1. if pivot is true, then
c         lipvt must be at least n.
c
c       rdiag is an output array of length n which CONTAINS the
c         diagonal elements of r.
c
c       acnorm is an output array of length n which CONTAINS the
c         norms of the corresponding columns of the input matrix a.
c         IF this information is not needed, THEN acnorm can coincide
c         with rdiag.
c
c       wa is a work array of length n. IF pivot is false, THEN wa
c         can coincide with rdiag.
c
c     subprograms called
c
c       MINpack-supplied ... dpmpar,enorm
c
c       fortran-supplied ... MAX,sqrt,min
c
c     argonne national laboratory. MINpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
c
c     epsmch is the machine precision.
c
      epsmch = dpmpar(1)
c
c     compute the initial column norms and initialize several arrays.
c
      DO j = 1, n
         acnorm(j) = enorm(m,a(1,j))
         rdiag(j) = acnorm(j)
         wa(j) = rdiag(j)
         IF (pivot) ipvt(j) = j
      END DO
c
c     reduce a to r with householder transformations.
c
      MINmn = MIN(m,n)
      ALLOCATE (temp1u(m))

      DO j = 1, MINmn
         IF (pivot) THEN
c
c        bring the column of largest norm into the pivot position.
c
            kMAX = j
            DO k = j,n
               IF (rdiag(k) .gt. rdiag(kmax)) kMAX = k
            END DO
            IF (kMAX .ne. j) THEN
               temp1u(:m) = a(:m,j)
               a(:m,j) = a(:m,kmax)
               a(:m,kmax) = temp1u(:m)
               rdiag(kmax) = rdiag(j)
               wa(kmax) = wa(j)
               k = ipvt(j)
               ipvt(j) = ipvt(kmax)
               ipvt(kmax) = k
            END IF
         END IF
c
c        compute the householder transformation to reduce the
c        j-th column of a to a multiple of the j-th unit vector.
c
         ajnorm = enorm(m-j+1,a(j,j))
         IF (ajnorm .ne. zero) THEN
            IF (a(j,j) .lt. zero) ajnorm = -ajnorm
            a(j:m,j) = a(j:m,j)/ajnorm
            a(j,j) = a(j,j) + one
c
c        apply the transformation to the remaining columns
c        and update the norms.
c
            jp1 = j + 1
            IF (n .ge. jp1) THEN
               DO k = jp1, n
                  SUM0 = SUM(a(j:m,j)*a(j:m,k))
                  temp = SUM0/a(j,j)
                  a(j:m,k) = a(j:m,k) - temp*a(j:m,j)
                  IF (pivot .and. rdiag(k).ne.zero) THEN
                     temp = a(j,k)/rdiag(k)
                     rdiag(k) = rdiag(k)*SQRT(MAX(zero,one-temp**2))
                     IF (p05*(rdiag(k)/wa(k))**2 .le. epsmch) THEN
                        rdiag(k) = enorm(m - j,a(jp1,k))
                        wa(k) = rdiag(k)
                     END IF
                  END IF
               END DO
            END IF
         END IF
         rdiag(j) = -ajnorm
      END DO

      DEALLOCATE (temp1u)

      END SUBROUTINE qrfac


module regcoil_compute_offset_surface_mod

  use stel_kinds

  implicit none

  private

  public :: regcoil_compute_offset_surface_xyz_of_thetazeta

  real(dp) :: theta_rootSolve, zeta_rootSolve_target, separation
  !$OMP threadprivate(theta_rootSolve, zeta_rootSolve_target, separation)

contains

  subroutine regcoil_compute_offset_surface_xyz_of_thetazeta(theta_rootSolve_in,zeta_rootSolve_target_in,x_offsetSurface,y_offsetSurface,z_offsetSurface,separation_in)

    use stel_kinds

    implicit none

    real(dp), intent(in) :: theta_rootSolve_in, zeta_rootSolve_target_in, separation_in
    real(dp), intent(out) :: x_offsetSurface, y_offsetSurface, z_offsetSurface

    integer :: fzeroFlag
    real(dp) :: rootSolve_abserr, rootSolve_relerr, zeta_rootSolve_min, zeta_rootSolve_max
    real(dp) :: zeta_plasma_rootSolveSolution

    theta_rootSolve = theta_rootSolve_in
    zeta_rootSolve_target = zeta_rootSolve_target_in
    separation = separation_in

    !rootSolve_abserr = 0
    !rootSolve_relerr = 0
    rootSolve_abserr = 1.0e-10_dp
    rootSolve_relerr = 1.0e-10_dp

    zeta_rootSolve_min = zeta_rootSolve_target - 1.0
    zeta_rootSolve_max = zeta_rootSolve_target + 1.0
    call regcoil_fzero(regcoil_fzero_residual, zeta_rootSolve_min, zeta_rootSolve_max, zeta_rootSolve_target, &
         rootSolve_relerr, rootSolve_abserr, fzeroFlag)
    ! Note: fzero returns its answer in zeta_rootSolve_min
    zeta_plasma_rootSolveSolution = zeta_rootSolve_min
    if (fzeroFlag == 4) then
       stop "ERROR: fzero returned error 4: no sign change in residual"
    else if (fzeroFlag > 2) then
       print *,"WARNING in cosm: fzero returned an error code:",fzeroFlag
    end if

    call regcoil_expand_plasma_surface(theta_rootSolve, zeta_plasma_rootSolveSolution, separation, x_offsetSurface, y_offsetSurface, z_offsetSurface)

  contains
    !------------------------------------------------------------------------------------

    function regcoil_fzero_residual(zeta_plasma_test)

      use regcoil_variables, only: nfp
      use stel_constants

      implicit none

      real(dp) :: zeta_plasma_test, regcoil_fzero_residual
      real(dp) :: x_outer, y_outer, z_outer, zeta_outer_new, zeta_error

      call regcoil_expand_plasma_surface(theta_rootSolve, zeta_plasma_test, separation, x_outer, y_outer, z_outer)
      zeta_outer_new = atan2(y_outer,x_outer)
      zeta_error = zeta_outer_new - zeta_rootSolve_target
      if (zeta_error < -pi) then
         zeta_error = zeta_error + twopi
      end if
      if (zeta_error > pi) then
         zeta_error = zeta_error - twopi
      end if
      regcoil_fzero_residual = zeta_error

    end function regcoil_fzero_residual

  end subroutine regcoil_compute_offset_surface_xyz_of_thetazeta

end module regcoil_compute_offset_surface_mod


!==============================================================================!
  subroutine Prec_Solve(A, x, b, prec)
!------------------------------------------------------------------------------!
! Solves the preconditioning system [D]{x}={b}                                 !
!------------------------------------------------------------------------------!
!   Allows preconditioning of the system by:                                   !
!     1. Diagonal preconditioning                                              !
!     2. Incomplete Cholesky preconditioning                                   !
!                                                                              !
!   The type of precondtioning is chosen by setting the variable prec to 0     !
!   (for no preconditioning), 1 (for diagonal preconditioning) or 2 (for       !
!   incomplete Cholesky preconditioning)                                       !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use par_mod
  use Matrix_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Matrix_Type) :: A
  real              :: x(-A % pnt_grid % n_bnd_cells : A % pnt_grid % n_cells)
  real              :: b( A % pnt_grid % n_cells)
  integer           :: prec
!-----------------------------------[Locals]-----------------------------------!
  integer :: i, j, k, N, NB
  real    :: sum1
!==============================================================================!

  N  = A % pnt_grid % n_cells
  NB = A % pnt_grid % n_bnd_cells

  !---------------------------------!
  !   1) diagonal preconditioning   !
  !---------------------------------!
  if(prec == 1) then
    do i=1,N
      x(i)=b(i)/D % val(D % dia(i))
    end do

  !--------------------------------------------!
  !   2) incomplete cholesky preconditioning   !
  !--------------------------------------------!
  else if(prec == 2) then

    ! Forward substitutionn
    do i=1,N
      sum1=b(i)
      do j=A % row(i),A % dia(i)-1  ! only the lower triangular
        k = A % col(j)
        sum1 = sum1- A % val(j)*x(k)
      end do
      x(i) = sum1 * D % val(D % dia(i))         ! BUG ?
    end do

    do i=1,N
      x(i) = x(i) / ( D % val(D % dia(i)) + TINY )
    end do

    ! Backward substitution
    do i=N,1,-1
      sum1=x(i)
      do j = A % dia(i)+1, A % row(i+1)-1 ! upper triangular
        k = A % col(j)
        sum1 = sum1 - A % val(j)*x(k)
      end do
      x(i) = sum1* D % val(D % dia(i))               ! BUG ?
    end do

  !---------------------------!
  !   .) no preconditioning   !
  !---------------------------!
  else
    do i=1,N
      x(i)=b(i)
    end do
  end if

  end subroutine


C#######################################################################
C#
C#    SUBROUTINE ORTHO
C#
C#    CHECKS ORTHOGONALITY OF BASISFUNCTIONS
C#
C#    CALLED BY: STSWM
C#
      SUBROUTINE ORTHO
C
C***********************************************************************
C     DEFINE PARAMETERS
      INCLUDE 'params.i'
C***********************************************************************
C
C     GLOBAL QUANTITIES (COMMON BLOCKS)
C
C***********************************************************************
C     TRANSFORM ARRAYS
      INCLUDE 'trnsfm.i'
C
C***********************************************************************
C
C     DUMMY STORAGE (SUBROUTINE SHTRNS)
C
C     ORTHONORMALITY/ORTHOGONALITY CHECKSUMS
C
      REAL ALPON(NALP),ALPOG(NALP),TMP(0:NN)
      REAL PLOTON(0:MM,0:NN),PLOTOG(0:MM,0:NN)
C
C     TEMPORARIES
C
      INTEGER NL, JM, JN, IS, ISO
      REAL COEFF1,COEFF2, VMAX, VMIN
C
C-----------------------------------------------------------------------
C
C     INITIALIZE ORTHONORMAL ARRAY
C
      DO 100 IS = 1, NALP
         ALPON(IS) = 0.0
         ALPOG(IS) = 0.0
  100 CONTINUE
C
C     COMPUTE ORTHONORMAL SUM
C
      DO 300 NL = 1, NLAT/2
         DO 200 IS = 1, NALP
            ALPON(IS) = ALPON(IS) + ALP(IS,NL)*ALP(IS,NL)*WTS(NL)
  200    CONTINUE
  300 CONTINUE
C
      DO 390 JN = 0, NN
         IS = LDIAG(JN,2)
         DO 389 JM = 1,LDIAG(JN,1)
         IF (MOD(JN,2) .EQ. 0) THEN
            COEFF1 = 1.0
         ELSE
            COEFF1 = -1.0
         ENDIF
C
C        INITIALIZE
C
         DO 330 ISO = 0,JN-1
            TMP(ISO) = 0.0
  330    CONTINUE
C
C        INTEGRATE
C
         DO 380 NL = 1, NLAT/2
            DO 350 ISO = 0,JN-1
               IF (MOD(ISO,2) .EQ. 0) THEN
                  COEFF2 = 1.0
               ELSE
                  COEFF2 = -1.0
               ENDIF
               TMP(ISO) = TMP(ISO) +
     &         (1.0+COEFF1*COEFF2)*ALP(LDIAG(ISO,2)+JM,NL)
     &                    *ALP(IS+JM,NL)* WTS(NL)
  350       CONTINUE
  380    CONTINUE
C
C        GET MAXIMUM
C
         VMAX = 0.0
         VMIN = 0.0
         DO 385 ISO = 0, JN-1
            VMIN = MIN(TMP(ISO),VMIN)
            VMAX = MAX(TMP(ISO),VMAX)
  385    CONTINUE
         IF (ABS(VMIN) .GT. ABS(VMAX)) THEN
            ALPOG(IS+JM) = VMIN
         ELSE
            ALPOG(IS+JM) = VMAX
         ENDIF
  389    CONTINUE
  390 CONTINUE
C
C     NORMALIZE
C
      DO 400 IS = 1, NALP
         ALPON(IS) = 2.0*ALPON(IS)
  400 CONTINUE
C
C     PLOT FIELDS & OUTPUT VALUES
C
      DO 600 JN=0,NN
         DO 550 JM=0,MM
            PLOTON(JM,JN) = 0.0
            PLOTOG(JM,JN) = 0.0
  550    CONTINUE
  600 CONTINUE

      DO 500 JN = 0,NN
         IS = LDIAG(JN,2)
         WRITE (6,999) (JN+JM-1,JM-1,ALPON(IS+JM)-1.0,ALPOG(IS+JM),
     &                  JM=1,LDIAG(JN,1))
         DO 525 JM=1,LDIAG(JN,1)
            PLOTON(JM-1,JN+JM-1) = ALPON(IS+JM)-1.0
            PLOTOG(JM-1,JN+JM-1) = ALPOG(IS+JM)
  525    CONTINUE
  500 CONTINUE
C
      CALL CPCNRC(PLOTON,MM+1,MM+1,NN+1,0.0,0)
      CALL LABTOP('Orthonormality Error',0.015)
      CALL FRAME
      CALL CPCNRC(PLOTOG,MM+1,MM+1,NN+1,0.0,0)
      CALL LABTOP('Orthogonality Error',0.015)
      CALL FRAME
C
      RETURN
C
  999 FORMAT('N = ',I4,' M = ',I4,' ALPON-1.0 = ',F18.16,
     &       ' ALPOG = ',F18.16)
      END


c function factor.f
c
c source
c   Bevington, page 32.
c
c purpose
c   calculates factorial function for integers
c
c usage
c   result = factor (n)
c
c description of parameters
c   n      - integer argument
c
c subroutines and function subprograms required
c   none
c
	function factor (n)
	double precision fi,sum
11	factor=1.
	if (n-1) 40,40,13
13	if (n-10) 21,21,31
c
c n less than 11
c
21	do 23 i=2,n
	fi=i
23	factor=factor*fi
	goto 40
c
c n greater than 10
c
31	sum=0.
	do 34 i=11,n
	fi=i
34	sum=sum+dlog(fi)
35	factor=3628800.*dexp(sum)
40	return
	end


c**********************************************************************
c   pi.f - compute pi by integrating f(x) = 4/(1 + x**2)
c
c   Each node:
c    1) receives the number of rectangles used in the approximation.
c    2) calculates the areas of it's rectangles.
c    3) Synchronizes for a global summation.
c   Node 0 prints the result.
c
c  Variables:
c
c    pi  the calculated result
c    n   number of points of integration.
c    x           midpoint of each rectangle's interval
c    f           function to integrate
c    sum,pi      area of rectangles
c    i           do loop index
c****************************************************************************
      program main

      include 'mpif.h'

      double precision  PI25DT
      parameter        (PI25DT = 3.141592653589793238462643d0)

      double precision  mypi, pi, h, sum, x, f, a
      integer n, myid, numprocs, i, rc
c                                 function to integrate
      f(a) = 4.d0 / (1.d0 + a*a)

      call MPI_INIT( ierr )
      call MPI_COMM_RANK( MPI_COMM_WORLD, myid, ierr )
      call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr )
      print *, "Process ", myid, " of ", numprocs, " is alive"

 10   n = 10000

      call MPI_BCAST(n,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)

c                                 check for quit signal
      if ( n .le. 0 ) goto 30

c                                 calculate the interval size
      h = 1.0d0/n

      sum  = 0.0d0
      do 20 i = myid+1, n, numprocs
         x = h * (dble(i) - 0.5d0)
         sum = sum + f(x)
 20   continue
      mypi = h * sum

c                                 collect all the partial sums
      call MPI_REDUCE(mypi,pi,1,MPI_DOUBLE_PRECISION,MPI_SUM,0,
     $     MPI_COMM_WORLD,ierr)

c                                 node 0 prints the answer.
      if (myid .eq. 0) then
         write(6, 97) pi, abs(pi - PI25DT)
 97      format('  pi is approximately: ', F18.16,
     +          '  Error is: ', F18.16)
      endif

 30   call MPI_FINALIZE(rc)
      stop
      end


subroutine do_concurrent2(a, b)
real, intent(inout) :: a(:), b(:)
integer :: i
real :: x
x = 1.0
do concurrent (i=1:10) shared(i) local(x) default(none)
    if (a(i) > 0) then
        x = sqrt(a(i))
        a(i) = a(i) - x**2
    end if
    b(i) = b(i) - a(i)
end do
print *, x
end subroutine


	real*4 function zx(tx, h, q, lamb)

c	Returns the value of Z = ZX (redshift) corresponding to a given
c	light travel time TX (measured in Gyr).

c	H = Ho in km/sec/Mpc
c	Q = qo (if problems with qo = 0, try 0.0001)

	implicit none
	real*4 ltt, z(47), age, tx, h, q, hh0, dz, t, omega0, omegainv, lamb, zi
	integer j
	external t
	data z /0.,.001,.002,.004,.006,.008,.01,.02,.04,.06,.08,.1,.2,.3,
     &      .4,.5,.545,.6,.7,.8,.9,.945,1.,1.2,1.4,1.6,1.8,2.,3.,4.,5.,6.,
     &      7.,8.,9.,10.,12.,14.,16.,18.,20.,30.,40.,60.,80.,100.,1000./

c     data z / 0., .001, .002, .004, .006, .008, .01, .02, .04, .06, .08
c    &, .1, .2, .3, .4, .5, .545, .6, .7, .8, .9, .945, 1., 1.2, 1.4,
c    &1.6, 1.8, 2., 3., 4., 5., 6., 7., 8., 9., 10., 12., 14., 16., 18.
c    &, 20., 25., 30., 35., 40., 45., 50., 55., 60., 65., 70., 75., 80.
c    &, 85., 90., 95., 100., 500., 1000. /

c	Define light travel time
	ltt(q,zi) = age - t(h,q,zi,lamb)

c	Compute omega
	if (lamb .ne. 0.) then
		omega0 = (2. * (q + 1.)) / 3.
		omegainv = 1. / omega0
	endif

c	Check for zero value
	zx = 0.
	if (tx .eq. 0.) return

c	Check for maximum age of universe
	age = t(h,q,0.,lamb)
	zx = -2.
	if (tx .ge. age) return

c	Express Ho in billion years ** (-1)
	hh0 = h * 0.001022

c	Check for q=0.5 case
	if (q .eq. 0.5) then
		zx = ((1. - (((3. * hh0) * tx) / 2.)) ** (- (2. / 3.))) - 1.
		return
	endif

c	General case
	do j = 1, 47
	if (tx .le. ltt(q,z(j))) goto 2
	enddo
2	if (j > 1) then
		zx = z(j - 1)
	else
		zx = z(1)
	endif
	zi=zx

c	Iterate to find best value
	do j = 1, 100000
	if (q .ge. 0.) then
c		zero cosmological constant
		dz = ((hh0 * ((tx - t(h,q,0.,lamb)) + t(h,q,zx,lamb))) *
     *		     ((1. + zx) ** 2)) * ((1. + ((2. * q) * zx)) ** 0.5)
	elseif (q .lt. 0.) then
c		non-zero cosmological constant
		dz = ((hh0 * ((tx - t(h,q,0.,lamb)) + t(h,q,zx,lamb))) *
     *		     (1. + zx)) * sqrt(omega0)
		dz = dz * sqrt((((1. + zx) ** 3.) + omegainv) - 1.)
	endif
c	if (abs(dz / zx) .lt. 0.00001) return
c	if (abs(dz / zx) .lt. 0.00005) return
c	if (abs(dz / zx) .lt. 0.00010)  return
	if (abs(dz / zx) .lt. 0.00003) return
	zx = zx + dz
	enddo
	return
	end


module lagmod
!$$$   module documentation block
!                .      .    .                                       .
! module:  lagmod
! prgmmr:  purser/cucurull           org: np23            date: 2005-12-01
!
! abstract: This module contains routines (including tangent linear and adjoint code)
!           to perform basic operations related to Lagrange polynomial interpolation.
!
! program history log:
!   2003        purser   - routines for the forward code
!   2005-12-01  cucurull - implement tangent linear and adjoint code
!                        - adapt the code to GSI standards
!   2008-05-09  safford  - complete documentation block
!
! subroutines included:
!   setq
!   setq_TL
!   setq_AD
!   lagdw
!   lagdw_TL
!   lagdw_AD
!   slagdw
!   slagdw_TL
!   slagdw_AD
!
! variables defined:
!
! attributes:
!   language:  f90
!   machine:   ibm RS/6000 SP
!
!$$$ end documentation block

!============================================================================
use kinds, only: r_kind,i_kind
use constants, only: zero,one
implicit none

! set default to private
  private
! set subroutines to public
  public :: setq
  public :: setq_TL
  public :: setq_AD
  public :: lagdw
  public :: lagdw_TL
  public :: lagdw_AD
  public :: slagdw
  public :: slagdw_TL
  public :: slagdw_AD

contains

subroutine setq(q,x,n)
!$$$  subprogram documentation block
!                .      .    .
! subprogram:    setq
!
!   prgrmmr:
!
! abstract:      Precompute the N constant denominator factors of the N-point
!                Lagrange polynomial interpolation formula.
!
! program history log:
!   2008-05-09  safford - add subprogram doc block, rm unused uses
!
!   input argument list:
!     X -    The N abscissae.
!     N -    The number of points involved.
!
!   output argument list:
!     Q -    The N denominator constants.
!
! attributes:
!   language:  f90
!   machine:   ibm RS/6000 SP
!
!$$$ end documentation block

IMPLICIT NONE

INTEGER(i_kind)          ,INTENT(in   ) :: n
REAL(r_kind),DIMENSION(n),INTENT(  out) :: q
REAL(r_kind),DIMENSION(n),INTENT(in   ) :: x
!-----------------------------------------------------------------------------
INTEGER(i_kind)                      :: i,j
!=============================================================================
DO i=1,n
   q(i)=one
   DO j=1,n
      IF(j /= i)q(i)=q(i)/(x(i)-x(j))
   ENDDO
ENDDO
end subroutine setq

!============================================================================
subroutine setq_TL(q,q_TL,x,x_TL,n)
!$$$  subprogram documentation block
!                .      .    .
! subprogram:    setq_TL
!
!   prgrmmr:
!
! abstract:
!
! program history log:
!   2008-05-09  safford - add subprogram doc block, rm unused uses
!
!   input argument list:
!     x     -
!     x_TL  -
!     n     -    The number of points involved.
!
!   output argument list:
!     q    -
!     Q_TL
!
! attributes:
!   language:  f90
!   machine:   ibm RS/6000 SP
!
!$$$ end documentation block

!============================================================================
IMPLICIT NONE

INTEGER(i_kind)          ,INTENT(in   ) :: n
REAL(r_kind),DIMENSION(n),INTENT(  out) :: q,q_TL
REAL(r_kind),DIMENSION(n),INTENT(in   ) :: x,x_TL
!-----------------------------------------------------------------------------
INTEGER(i_kind)                      :: i,j
REAL(r_kind)                         :: rat
!=============================================================================
DO i=1,n
   q(i)=one
   q_TL(i)=zero
   DO j=1,n
      IF(j /= i) THEN
         rat=one/(x(i)-x(j))
         q_TL(i)=(q_TL(i)-q(i)*(x_TL(i)-x_TL(j))*rat)*rat
         q(i)=q(i)*rat
      ENDIF
   ENDDO
ENDDO
end subroutine setq_TL

!============================================================================
subroutine setq_AD(q_AD,x,x_AD,n)
!$$$  subprogram documentation block
!                .      .    .
! subprogram:    setq_AD
!
!   prgrmmr:
!
! abstract:
!
! program history log:
!   2008-05-09  safford - add subprogram doc block, rm unused uses
!
!   input argument list:
!     q_AD -
!     x    -
!     x_AD -
!     n    -    The number of points involved.
!
!   output argument list:
!     x_AD -
!     q_AD -
!
! attributes:
!   language:  f90
!   machine:   ibm RS/6000 SP
!
!$$$ end documentation block

!============================================================================
IMPLICIT NONE

INTEGER(i_kind)          ,INTENT(in   ) :: n
REAL(r_kind),DIMENSION(n),INTENT(in   ) :: x
REAL(r_kind),DIMENSION(n),INTENT(inout) :: x_AD
REAL(r_kind),DIMENSION(n),INTENT(inout) :: q_AD
!-----------------------------------------------------------------------------
INTEGER(i_kind)                      :: i,j
REAL(r_kind),DIMENSION(n)            :: q
REAL(r_kind),DIMENSION(n,n)          :: jac
!=============================================================================
call setq(q,x,n)
jac=zero
DO i=1,n
   DO j=1,n
      IF(j /= i) THEN
         jac(j,i)=q(i)/(x(i)-x(j))
         jac(i,i)=jac(i,i)-jac(j,i)
      ENDIF
   ENDDO
ENDDO
x_AD=x_AD+matmul(jac,q_AD)
end subroutine setq_AD

!============================================================================
subroutine lagdw(x,xt,q,w,dw,n)
!$$$  subprogram documentation block
!                .      .    .
! subprogram:    lagdw
!
!   prgrmmr:
!
! abstract:      Construct the Lagrange weights and their derivatives when
!                target abscissa is known and denominators Q have already
!                been precomputed
!
! program history log:
!   2008-05-09  safford - add subprogram doc block, rm unused uses
!
!   input argument list:
!     X   - Grid abscissae
!     XT  - Target abscissa
!     Q   - Q factors (denominators of the Lagrange weight formula)
!     N   - Number of grid points involved in the interpolation
!
!   output argument list:
!     W   - Lagrange weights
!     DW  - Derivatives, dW/dX, of Lagrange weights W
!
! attributes:
!   language:  f90
!   machine:   ibm RS/6000 SP
!
!$$$ end documentation block

!============================================================================
IMPLICIT NONE

INTEGER(i_kind)          ,INTENT(IN   ) :: n
REAL(r_kind)             ,INTENT(IN   ) :: xt
REAL(r_kind),DIMENSION(n),INTENT(IN   ) :: x,q
REAL(r_kind),DIMENSION(n),INTENT(  OUT) :: w,dw
!-----------------------------------------------------------------------------
REAL(r_kind),DIMENSION(n)            :: d,pa,pb,dpa,dpb
INTEGER(i_kind)                      :: j
!============================================================================
pa(1)=one
dpa(1)=zero
do j=1,n-1
   d(j)=xt-x(j)
   pa (j+1)=pa (j)*d(j)
   dpa(j+1)=dpa(j)*d(j)+pa(j)
enddo
d(n)=xt-x(n)

pb(n)=one
dpb(n)=zero
do j=n,2,-1
   pb (j-1)=pb (j)*d(j)
   dpb(j-1)=dpb(j)*d(j)+pb(j)
enddo
do j=1,n
   w (j)= pa(j)*pb (j)*q(j)
   dw(j)=(pa(j)*dpb(j)+dpa(j)*pb(j))*q(j)
enddo
end subroutine lagdw

!============================================================================
subroutine lagdw_TL(x,x_TL,xt,q,q_TL,w,w_TL,dw,dw_TL,n)
!$$$  subprogram documentation block
!                .      .    .
! subprogram:    lagdw_TL
!
!   prgrmmr:
!
! abstract:
!
! program history log:
!   2008-05-09  safford - add subprogram doc block, rm unused uses
!
!   input argument list:
!     x     -
!     xt    -
!     q     -
!     q_TL  -
!     n     - The number of points involved.
!
!   output argument list:
!     w     -
!     dw    -
!     w_TL  -
!     dw_TL -
!
! attributes:
!   language:  f90
!   machine:   ibm RS/6000 SP
!
!$$$ end documentation block

!============================================================================
IMPLICIT NONE

INTEGER(i_kind)          ,INTENT(IN   ) :: n
REAL(r_kind)             ,INTENT(IN   ) :: xt
REAL(r_kind),DIMENSION(n),INTENT(IN   ) :: x,q,x_TL,q_TL
REAL(r_kind),DIMENSION(n),INTENT(  OUT) :: w,dw,w_TL,dw_TL
!-----------------------------------------------------------------------------
REAL(r_kind),DIMENSION(n)            :: d,pa,pb,dpa,dpb
REAL(r_kind),DIMENSION(n)            :: d_TL,pa_TL,pb_TL,dpa_TL,dpb_TL
INTEGER(i_kind)                      :: j
!============================================================================
pa(1)=one
dpa(1)=zero
pa_TL(1)=zero
dpa_TL(1)=zero

do j=1,n-1
   d(j)=xt-x(j)
   d_TL(j)=-x_TL(j)
   pa    (j+1)=pa    (j)*d(j)
   pa_TL (j+1)=pa_TL (j)*d(j)+pa(j)*d_TL(j)
   dpa   (j+1)=dpa   (j)*d(j)+pa(j)
   dpa_TL(j+1)=dpa_TL(j)*d(j)+dpa(j)*d_TL(j)+pa_TL(j)
enddo
d(n)=xt-x(n)
d_TL(n)=-x_TL(n)

pb(n)=one
dpb(n)=zero
pb_TL(n)=zero
dpb_TL(n)=zero
do j=n,2,-1
   pb    (j-1)=pb    (j)*d(j)
   pb_TL (j-1)=pb_TL (j)*d(j)+pb (j)*d_TL(j)
   dpb   (j-1)=dpb   (j)*d(j)+pb (j)
   dpb_TL(j-1)=dpb_TL(j)*d(j)+dpb(j)*d_TL(j)+pb_TL(j)
enddo
do j=1,n
   w    (j)= pa   (j)*pb (j)*q(j)
   dw   (j)=(pa   (j)*dpb(j)+dpa(j)*pb    (j))*q(j)
   w_TL (j)=(pa_TL(j)*pb (j)+pa (j)*pb_TL (j))*q(j)+pa(j)*pb(j)*q_TL(j)
   dw_TL(j)=(pa_TL(j)*dpb(j)+pa (j)*dpb_TL(j)+dpa_TL(j)*pb(j)+dpa(j)*pb_TL(j))*q(j)+ &
            (pa   (j)*dpb(j)+dpa(j)*pb    (j))*q_TL(j)
enddo
end subroutine lagdw_TL

!============================================================================
subroutine lagdw_AD(x,x_AD,xt,q,q_AD,w_AD,dw_AD,n)
!$$$  subprogram documentation block
!                .      .    .
! subprogram:    lagdw_AD
!
!   prgrmmr:
!
! abstract:
!
! program history log:
!   2008-05-09  safford - add subprogram doc block, rm unused uses
!
!   input argument list:
!     n     -
!     xt    -
!     x     -
!     q     -
!     q_AD  -
!     x_AD  -
!     w_AD  -
!     dw_AD -
!
!   output argument list:
!     q_AD  -
!     x_AD  -
!     w_AD  -
!     dw_AD -
!
! attributes:
!   language:  f90
!   machine:   ibm RS/6000 SP
!
!$$$ end documentation block

!============================================================================
IMPLICIT NONE

INTEGER(i_kind)          ,INTENT(IN   ) :: n
REAL(r_kind)             ,INTENT(IN   ) :: xt
REAL(r_kind),DIMENSION(n),INTENT(IN   ) :: x,q
REAL(r_kind),DIMENSION(n),INTENT(INOUT) :: q_AD,x_AD,w_AD,dw_AD
!-----------------------------------------------------------------------------
REAL(r_kind),DIMENSION(n)            :: d,pa,pb,dpa,dpb
REAL(r_kind),DIMENSION(n)            :: d_AD,pa_AD,pb_AD,dpa_AD,dpb_AD
INTEGER(i_kind)                      :: j
!============================================================================

pa_AD=zero; dpb_AD=zero; dpa_AD=zero; pb_AD=zero
d_AD=zero

! passive variables
pa(1)=one
dpa(1)=zero
do j=1,n-1
   d(j)=xt-x(j)
   pa (j+1)=pa (j)*d(j)
   dpa(j+1)=dpa(j)*d(j)+pa(j)
enddo
d(n)=xt-x(n)
pb(n)=one
dpb(n)=zero
do j=n,2,-1
   pb (j-1)=pb (j)*d(j)
   dpb(j-1)=dpb(j)*d(j)+pb(j)
enddo
!
do j=n,1,-1
   pa_AD (j)=pa_AD (j)+ dpb(j)*q  (j)*dw_AD(j)
   dpb_AD(j)=dpb_AD(j)+ pa (j)*q  (j)*dw_AD(j)
   dpa_AD(j)=dpa_AD(j)+ pb (j)*q  (j)*dw_AD(j)
   pb_AD (j)=pb_AD (j)+ dpa(j)*q  (j)*dw_AD(j)
   q_AD  (j)=q_AD  (j)+(pa (j)*dpb(j)+dpa  (j)*pb(j))*dw_AD(j)
   pa_AD (j)=pa_AD (j)+ pb (j)*q  (j)*w_AD (j)
   pb_AD (j)=pb_AD (j)+ pa (j)*q  (j)*w_AD (j)
   q_AD  (j)=q_AD  (j)+ pa (j)*pb (j)*w_AD (j)
end do
do j=2,n
   dpb_AD(j)=dpb_AD(j)+d  (j)*dpb_AD(j-1)
   d_AD  (j)=d_AD  (j)+dpb(j)*dpb_AD(j-1)
   pb_AD (j)=pb_AD (j)       +dpb_AD(j-1)
   pb_AD (j)=pb_AD (j)+d  (j)*pb_AD (j-1)
   d_AD  (j)=d_AD  (j)+pb (j)*pb_AD (j-1)
enddo

dpb_AD(n)=zero ! not sure about it
pb_AD(n) =zero ! not sure about it

x_AD(n)=x_AD(n)-d_AD(n)
do j=n-1,1,-1
   dpa_AD(j)=dpa_AD(j)+d  (j)*dpa_AD(j+1)
   d_AD  (j)=d_AD  (j)+dpa(j)*dpa_AD(j+1)
   pa_AD (j)=pa_AD (j)       +dpa_AD(j+1)
   pa_AD (j)=pa_AD (j)+d  (j)*pa_AD (j+1)
   d_AD  (j)=d_AD  (j)+pa (j)*pa_AD (j+1)
   x_AD  (j)=x_AD  (j)       -d_AD  (j  )
enddo

end subroutine lagdw_AD

!============================================================================
subroutine slagdw(x,xt,aq,bq,w,dw,n)
!$$$  subprogram documentation block
!                .      .    .
! subprogram:    slagdw
!
!   prgrmmr:
!
! abstract:      Construct weights and their derivatives for interpolation
!                to a given target based on a linearly weighted mixture of
!                the pair of Lagrange interpolators which omit the respective
!                end points of the source nodes provided. The number of source
!                points provided must be even and the nominal target interval
!                is the unique central one. The linear weighting pair is
!                determined by the relative location of the target within
!                this central interval, or else the extreme values, 0 and 1,
!                when target lies outside this interval.  The objective is to
!                provide an interpolator whose derivative is continuous.
!
! program history log:
!   2008-05-09  safford - add subprogram doc block, rm unused uses
!
!   input argument list:
!     X     - Grid abscissae (N points)
!     XT    - Target abscissa
!     AQ,BQ - Q factors (denominators of the Lagrange weight formula for
!             the two respective consecutive subsets of N-1 grid points)
!     N     - Even number of grid points involved in the interpolation
!
!   output argument list:
!     W     - Final weights (N values)
!     DW    - Final derivatives, dW/dX, of weights W (N values)
!
! attributes:
!   language:  f90
!   machine:   ibm RS/6000 SP
!
!$$$ end documentation block

!============================================================================
IMPLICIT NONE

INTEGER(i_kind)            ,INTENT(IN   ) :: n
REAL(r_kind)               ,INTENT(IN   ) :: xt
REAL(r_kind),DIMENSION(n)  ,INTENT(IN   ) :: x
REAL(r_kind),DIMENSION(n-1),INTENT(IN   ) :: aq,bq
REAL(r_kind),DIMENSION(n)  ,INTENT(  OUT) :: w,dw
!-----------------------------------------------------------------------------
REAL(r_kind),DIMENSION(n)               :: aw,bw,daw,dbw
REAL(r_kind)                            :: xa,xb,dwb,wb
INTEGER(i_kind)                         :: na
!============================================================================
CALL lagdw(x(1:n-1),xt,aq,aw(1:n-1),daw(1:n-1),n-1)
CALL lagdw(x(2:n  ),xt,bq,bw(2:n  ),dbw(2:n  ),n-1)
aw(n)=zero
daw(n)=zero
bw(1)=zero
dbw(1)=zero
na=n/2
IF(na*2 /= n)STOP 'In slagdw; n must be even'
xa =x(na     )
xb =x(na+1)
dwb=one/(xb-xa)
wb =(xt-xa)*dwb
IF    (wb>one )THEN
   wb =one
   dwb=zero
ELSEIF(wb<zero)THEN
   wb =zero
   dwb=zero
ENDIF
bw =bw -aw
dbw=dbw-daw

w =aw +wb*bw
dw=daw+wb*dbw+dwb*bw
end subroutine slagdw

!============================================================================
subroutine slagdw_TL(x,x_TL,xt,aq,aq_TL,bq,bq_TL,dw,dw_TL,n)
!$$$  subprogram documentation block
!                .      .    .
! subprogram:    slagdw_TL
!
!   prgrmmr:
!
! abstract:
!
! program history log:
!   2008-05-09  safford - add subprogram doc block, rm unused uses
!
!   input argument list:
!     n
!     xt
!     x,x_TL
!     aq,bq,aq_TL,bq_TL
!     dw_TL,dw
!
!   output argument list:
!     dw_TL,dw
!
! attributes:
!   language:  f90
!   machine:   ibm RS/6000 SP
!
!$$$ end documentation block

!============================================================================
IMPLICIT NONE

INTEGER(i_kind)            ,INTENT(IN   ) :: n
REAL(r_kind)               ,INTENT(IN   ) :: xt
REAL(r_kind),DIMENSION(n)  ,INTENT(IN   ) :: x,x_TL
REAL(r_kind),DIMENSION(n-1),INTENT(IN   ) :: aq,bq,aq_TL,bq_TL
REAL(r_kind),DIMENSION(n)  ,INTENT(  OUT) :: dw_TL,dw
!-----------------------------------------------------------------------------
REAL(r_kind),DIMENSION(n)               :: aw,bw,daw,dbw
REAL(r_kind),DIMENSION(n)               :: aw_TL,bw_TL,daw_TL,dbw_TL
REAL(r_kind)                            :: xa,xb,dwb,wb
REAL(r_kind)                            :: xa_TL,xb_TL,dwb_TL,wb_TL
INTEGER(i_kind)                         :: na
!============================================================================
CALL lagdw_TL(x(1:n-1),x_TL(1:n-1),xt,aq,aq_TL,aw(1:n-1),aw_TL(1:n-1),&
             daw(1:n-1),daw_TL(1:n-1),n-1)
CALL lagdw_TL(x(2:n     ),x_TL(2:n     ),xt,bq,bq_TL,bw(2:n     ),bw_TL(2:n     ),&
             dbw(2:n     ),dbw_TL(2:n     ),n-1)
aw(n) =zero
daw(n)=zero
bw(1) =zero
dbw(1)=zero
!
aw_TL(n) =zero
daw_TL(n)=zero
bw_TL(1) =zero
dbw_TL(1)=zero
na=n/2
IF(na*2 /= n)STOP 'In slagdw; n must be even'
xa   =x   (na)
xa_TL=x_TL(na)
xb   =x   (na+1)
xb_TL=x_TL(na+1)
dwb   = one          /(xb-xa)
dwb_TL=-(xb_TL-xa_TL)/(xb-xa)**2
wb   =             (xt-xa)*dwb
wb_TL=(-xa_TL)*dwb+(xt-xa)*dwb_TL
IF    (wb > one)THEN
   wb    =one
   dwb   =zero
   wb_TL =zero
   dwb_TL=zero
ELSEIF(wb < zero)THEN
   wb    =zero
   dwb   =zero
   wb_TL =zero
   dwb_TL=zero

ENDIF

bw    =bw    -aw
bw_TL =bw_TL -aw_TL
dbw   =dbw   -daw
dbw_TL=dbw_TL-daw_TL

!w=aw+wb*bw
dw   =daw   + wb   *dbw           + dwb   *bw
dw_TL=daw_TL+(wb_TL*dbw+wb*dbw_TL)+(dwb_TL*bw+dwb*bw_TL)
end subroutine slagdw_TL

!============================================================================
SUBROUTINE slagdw_AD(x,x_AD,xt,aq,aq_AD,bq,bq_AD,w_AD,dw,dw_AD,n)
!$$$  subprogram documentation block
!                .      .    .
! subprogram:    slagdw_AD
!
!   prgrmmr:
!
! abstract:
!
! program history log:
!   2008-05-09  safford - add subprogram doc block, rm unused uses
!
!   input argument list:
!     n
!     xt
!     x
!     aq,bq
!     aq_AD,bq_AD
!     x_AD,dw_AD,w_AD
!
!   output argument list:
!     aq_AD,bq_AD
!     dw
!     x_AD,dw_AD,w_AD
!
! attributes:
!   language:  f90
!   machine:   ibm RS/6000 SP
!
!$$$ end documentation block

!============================================================================
IMPLICIT NONE
INTEGER(i_kind)            ,INTENT(IN   ) :: n
REAL(r_kind)               ,INTENT(IN   ) :: xt
REAL(r_kind),DIMENSION(n)  ,INTENT(IN   ) :: x
REAL(r_kind),DIMENSION(n-1),INTENT(IN   ) :: aq,bq
REAL(r_kind),DIMENSION(n-1),INTENT(INOUT) :: aq_AD,bq_AD
REAL(r_kind),DIMENSION(n)  ,INTENT(  OUT) :: dw
REAL(r_kind),DIMENSION(n)  ,INTENT(INOUT) :: x_AD,dw_AD,w_AD
!-----------------------------------------------------------------------------
REAL(r_kind),DIMENSION(n)                 :: aw,bw,daw,dbw
REAL(r_kind),DIMENSION(n)                 :: aw_AD,bw_AD,daw_AD,dbw_AD
REAL(r_kind)                              :: xa,xb,dwb,wb
REAL(r_kind)                              :: xa_AD,xb_AD,wb_AD,dwb_AD
INTEGER(i_kind)                           :: na
!============================================================================
daw_AD=zero;wb_AD=zero;dbw_AD=zero;dwb_AD=zero;bw_AD=zero
aw_AD =zero;xb_AD=zero;xa_AD =zero

! passive variables needed (from forward code)
CALL lagdw(x(1:n-1),xt,aq,aw(1:n-1),daw(1:n-1),n-1)
CALL lagdw(x(2:n  ),xt,bq,bw(2:n  ),dbw(2:n  ),n-1)

aw(n) =zero
daw(n)=zero
bw(1) =zero
dbw(1)=zero
na=n/2
IF(na*2 /= n)STOP 'In slagdw; n must be even'
xa =x(na     )
xb =x(na+1)
dwb=one/(xb-xa)
wb =(xt-xa)*dwb
IF    (wb>one)THEN
   wb =one
   dwb=zero
ELSEIF(wb<zero)THEN
   wb =zero
   dwb=zero
ENDIF
bw =bw -aw
dbw=dbw-daw
!w=aw+wb*bw ! not needed
dw=daw+wb*dbw+dwb*bw ! not needed
!
!
daw_AD=daw_AD+dw_AD
wb_AD =wb_AD +dot_product(dbw,dw_AD)
dbw_AD=dbw_AD+wb*dw_AD
dwb_AD=dwb_AD+dot_product(bw,dw_AD)
bw_AD =bw_AD +dwb*dw_AD

aw_AD=aw_AD+w_AD
wb_AD=wb_AD+dot_product(bw,w_AD)
bw_AD=bw_AD+wb*w_AD

daw_AD=daw_AD-dbw_AD
aw_AD =aw_AD -bw_AD

IF(wb>one)THEN
   wb_AD =zero
   dwb_AD=zero
ELSEIF(wb<zero)THEN
   wb_AD =zero
   dwb_AD=zero
ENDIF

xa_AD        =xa_AD-wb_AD*dwb
dwb_AD       =dwb_AD+(xt-xa)*wb_AD
xb_AD        =xb_AD-(dwb_AD/(xb-xa)**2)
xa_AD        =xa_AD+(dwb_AD/(xb-xa)**2)
x_AD(na+1)=x_AD(na+1)+xb_AD
x_AD(na  )=x_AD(na  )+xa_AD

dbw_AD(1)=zero;bw_AD(1)=zero
daw_AD(n)=zero;aw_AD(n)=zero

CALL lagdw_AD(x(2:n     ),x_AD(2:n     ),xt,bq,bq_AD,bw_AD(2:n     ),&
             dbw_AD(2:n     ),n-1)

CALL lagdw_AD(x(1:n-1),x_AD(1:n-1),xt,aq,aq_AD,aw_AD(1:n-1),&
             daw_AD(1:n-1),n-1)

end subroutine slagdw_AD
!============================================================================
end module lagmod


C***********************************************************************
      SUBROUTINE SPLINE (N,X,Y,FDP)
C***********************************************************************
C-----THIS SUBROUTINE COMPUTES THE SECOND DERIVATIVES NEEDED
C-----IN CUBIC SPLINE INTERPOLATION.  THE INPUT DATA ARE:
C-----N = NUMBER OF DATA POINTS
C-----X = ARRAY CONTAINING THE VALUES OF THE INDEPENDENT VARIABLE
C-----    (ASSUMED TO BE IN ASCENDING ORDER)
C-----Y = ARRAY CONTAINING THE VALUES OF THE FUNCTION AT THE
C-----    DATA POINTS GIVEN IN THE X ARRAY
C-----THE OUTPUT IS THE ARRAY FDP WHICH CONTAINS THE SECOND
C-----DERIVATIVES OF THE INTERPOLATING CUBIC SPLINE.
      DIMENSION X(N),Y(N),A(N),B(N),C(N),R(N),FDP(N)
C-----COMPUTE THE COEFFICIENTS AND THE RHS OF THE EQUATIONS.
C-----THIS ROUTINE USES THE CANTILEVER CONDITION.  THE PARAMETER
C-----ALAMDA (LAMBDA) IS SET TO 1. BUT THIS CAN BE USER-MODIFIED.
C-----A,B,C ARE THE THREE DIAGONALS OF THE TRIDIAGONAL SYSTEM;
C-----R IS THE RIGHT HAND SIDE.  THESE ARE NOW ASSEMBLED.
      ALAMDA = 1.
      NM2 = N - 2
      NM1 = N - 1
      C(1) = X(2) - X(1)
      DO 1 I=2,NM1
      C(I) = X(I+1) - X(I)
      A(I) = C(I-1)
      B(I) = 2.*(A(I) + C(I))
      R(I) = 6.*((Y(I+1) - Y(I))/C(I) - (Y(I) - Y(I-1))/C(I-1))
    1 CONTINUE
      B(2) = B(2) + ALAMDA * C(1)
      B(NM1) = B(NM1) + ALAMDA * C(NM1)
C-----AT THIS POINT WE COULD CALL A TRIDIAGONAL SOLVER SUBROUTINE
C-----BUT THE NOTATION IS CLUMSY SO WE WILL SOLVE DIRECTLY.  THE
C-----NEXT SECTION SOLVES THE SYSTEM WE HAVE JUST SET UP.
      DO 2 I=3,NM1
      T = A(I)/B(I-1)
      B(I) = B(I) - T * C(I-1)
      R(I) = R(I) - T * R(I-1)
    2 CONTINUE
      FDP(NM1) = R(NM1)/B(NM1)
      DO 3 I=2,NM2
      NMI = N - I
      FDP(NMI) = (R(NMI) - C(NMI)*FDP(NMI+1))/B(NMI)
    3 CONTINUE
      FDP(1) = ALAMDA * FDP(2)
      FDP(N) = ALAMDA * FDP(NM1)
C-----WE NOW HAVE THE DESIRED DERIVATIVES SO WE RETURN TO THE
C-----MAIN PROGRAM.
      RETURN
      END
C***********************************************************************
      SUBROUTINE SPEVAL (N,X,Y,FDP,XX,F)
C***********************************************************************
C-----THIS SUBROUTINE EVALUATES THE CUBIC SPLINE GIVEN
C-----THE DERIVATIVE COMPUTED BY SUBROUTINE SPLINE.
C-----THE INPUT PARAMETERS N,X,Y,FDP HAVE THE SAME
C-----MEANING AS IN SPLINE.
C-----XX = VALUE OF INDEPENDENT VARIABLE FOR WHICH
C-----     AN INTERPOLATED VALUE IS REQUESTED
C-----F =  THE INTERPOLATED RESULT
      DIMENSION X(N),Y(N),FDP(N)
C-----THE FIRST JOB IS TO FIND THE PROPER INTERVAL.
      NM1 = N - 1
      DO 1 I=1,NM1
      IF (XX.LE.X(I+1)) GO TO 10
    1 CONTINUE
C-----NOW EVALUATE THE CUBIC
   10 DXM = XX - X(I)
      DXP = X(I+1) - XX
      DEL = X(I+1) - X(I)
      F = FDP(I)*DXP*(DXP*DXP/DEL - DEL)/6.
     1   +FDP(I+1)*DXM*(DXM*DXM/DEL - DEL)/6.
     2   +Y(I)*DXP/DEL + Y(I+1)*DXM/DEL
      RETURN
      END


C NCLFORTSTART
      SUBROUTINE DMIXHUM1(P,TK,RH,ISWIT,QW)
      IMPLICIT NONE
C NCL: qw = mixhum_ptrh(p:numeric,tk:numeric,rh:numeric,iswit:integer)

c input
      INTEGER ISWIT
      DOUBLE PRECISION P,TK,RH
c output
      DOUBLE PRECISION QW
c NCLEND

c computes qw (specific humidity or mixing ratio) from p, t and rh

c definition of mixing ratio
c if,
c    es  - is the saturation mixing ratio
c    ep  - is the ratio of the molecular weights of water vapor to
c          dry air
c    p   - is the atmospheric pressure
c    rh  - is the relative humidity (given as a percent)

c    q =   rh * ( (ep*es)/(p-es) )

c input-
c    p      - pressure (hPa or mb)
c    tk     - temperature (k)
c    rh     - rel hum in percent
c    iswit  - if iswit=1 qw will contain mix ratio
c                iswit=2 qw will contain spc humidity
c                if iswit is negative the units will be kg/kg else g/kg

c output-
c    qw     - mixing ratio or specific hum

c local
      DOUBLE PRECISION T0,EP,ONEMEP,ES0,A,B,EST,QST
      DATA T0,EP,ONEMEP,ES0,A,B/273.15D0,0.622D0,0.378D0,6.11D0,
     +     17.269D0,35.86D0/

      EST = ES0*EXP((A* (TK-T0))/ (TK-B))
      QST = (EP*EST)/ (P-ONEMEP*EST)
c                                    mix ratio
      QW = QST* (RH*.01D0)
c                                    ?specific hum?
      IF (ABS(ISWIT).EQ.2) THEN
          QW = QW/ (1.D0+QW)
      END IF

      IF (ISWIT.LT.0) THEN
          QW = QW*1000.D0
      END IF

      RETURN
      END


C$Procedure            APPROX ( Approximate equality )

      LOGICAL FUNCTION APPROX ( X, Y, TOL )

C$ Abstract
C
C     True if two double precision numbers are equal to within some
C     tolerance.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     COMPARE
C     NUMBERS
C
C$ Declarations

      DOUBLE PRECISION      X
      DOUBLE PRECISION      Y
      DOUBLE PRECISION      TOL

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     X,
C     Y          I   Double precision numbers.
C     TOL        I   Tolerance.
C
C     The function is true whenever |X - Y| < TOL.
C                                           -
C
C$ Detailed_Input
C
C     X,
C     Y           are arbitrary double precision numbers.
C
C     TOL         is a tolerance. X and Y are considered to be equal
C                 if they differ by no more than this amount. If TOL
C                 is negative, X and Y are never considered equal.
C
C$ Detailed_Output
C
C     The function is true whenever |X - Y| < TOL, and is false
C     otherwise.                            -
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C      Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     None.
C
C$ Examples
C
C     C
C     C     If the eccentricity is near one, this a parabola.
C     C
C           IF ( APPROX ( ECC, 1.D0, 10.D-12 ) ) THEN
C              TYPE = 'PARABOLA'
C
C           ELSE IF ( ECC .LT. 1 ) THEN
C              TYPE = 'ELLIPSE'
C
C           ELSE
C              TYPE = 'HYPERBOLA'
C           END IF
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     I.M. Underwood  (JPL)
C
C$ Version
C
C-     SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C         Comment section for permuted index source lines was added
C         following the header.
C
C-     SPICELIB Version 1.0.0, 31-JAN-1990  (IMU)
C
C-&

C$ Index_Entries
C
C     approximate equality
C
C-&

C
C     Just shorthand, really.
C
      APPROX = ( ABS ( X - Y ) .LE. TOL )

      RETURN
      END