      SUBROUTINE TG01AD( JOB, L, N, M, P, THRESH, A, LDA, E, LDE,
     $                   B, LDB, C, LDC, LSCALE, RSCALE, DWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To balance the matrices of the system pencil
C
C             S =  ( A  B ) - lambda ( E  0 ) :=  Q - lambda Z,
C                  ( C  0 )          ( 0  0 )
C
C     corresponding to the descriptor triple (A-lambda E,B,C),
C     by balancing. This involves diagonal similarity transformations
C     (Dl*A*Dr - lambda Dl*E*Dr, Dl*B, C*Dr) applied to the system
C     (A-lambda E,B,C) to make the rows and columns of system pencil
C     matrices
C
C                  diag(Dl,I) * S * diag(Dr,I)
C
C     as close in norm as possible. Balancing may reduce the 1-norms
C     of the matrices of the system pencil S.
C
C     The balancing can be performed optionally on the following
C     particular system pencils
C
C              S = A-lambda E,
C
C              S = ( A-lambda E  B ),    or
C
C              S = ( A-lambda E ).
C                  (     C      )
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Indicates which matrices are involved in balancing, as
C             follows:
C             = 'A':  All matrices are involved in balancing;
C             = 'B':  B, A and E matrices are involved in balancing;
C             = 'C':  C, A and E matrices are involved in balancing;
C             = 'N':  B and C matrices are not involved in balancing.
C
C     Input/Output Parameters
C
C     L       (input) INTEGER
C             The number of rows of matrices A, B, and E.  L >= 0.
C
C     N       (input) INTEGER
C             The number of columns of matrices A, E, and C.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The number of rows of matrix C.  P >= 0.
C
C     THRESH  (input) DOUBLE PRECISION
C             Threshold value for magnitude of elements:
C             elements with magnitude less than or equal to
C             THRESH are ignored for balancing. THRESH >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading L-by-N part of this array must
C             contain the state dynamics matrix A.
C             On exit, the leading L-by-N part of this array contains
C             the balanced matrix Dl*A*Dr.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,L).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading L-by-N part of this array must
C             contain the descriptor matrix E.
C             On exit, the leading L-by-N part of this array contains
C             the balanced matrix Dl*E*Dr.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,L).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading L-by-M part of this array must
C             contain the input/state matrix B.
C             On exit, if M > 0, the leading L-by-M part of this array
C             contains the balanced matrix Dl*B.
C             The array B is not referenced if M = 0.
C
C     LDB     INTEGER
C             The leading dimension of array B.
C             LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix C.
C             On exit, if P > 0, the leading P-by-N part of this array
C             contains the balanced matrix C*Dr.
C             The array C is not referenced if P = 0.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     LSCALE  (output) DOUBLE PRECISION array, dimension (L)
C             The scaling factors applied to S from left.  If Dl(j) is
C             the scaling factor applied to row j, then
C             SCALE(j) = Dl(j), for j = 1,...,L.
C
C     RSCALE  (output) DOUBLE PRECISION array, dimension (N)
C             The scaling factors applied to S from right.  If Dr(j) is
C             the scaling factor applied to column j, then
C             SCALE(j) = Dr(j), for j = 1,...,N.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (3*(L+N))
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit.
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Balancing consists of applying a diagonal similarity
C     transformation
C                            -1
C                  diag(Dl,I)  * S * diag(Dr,I)
C
C     to make the 1-norms of each row of the first L rows of S and its
C     corresponding N columns nearly equal.
C
C     Information about the diagonal matrices Dl and Dr are returned in
C     the vectors LSCALE and RSCALE, respectively.
C
C     REFERENCES
C
C     [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
C         Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
C         Ostrouchov, S., and Sorensen, D.
C         LAPACK Users' Guide: Second Edition.
C         SIAM, Philadelphia, 1995.
C
C     [2] R.C. Ward, R. C.
C         Balancing the generalized eigenvalue problem.
C         SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     March 1999. Based on the LAPACK routine DGGBAL.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, July 1999,
C     May 2003, March 2004, Jan. 2009, May 2012.
C
C     KEYWORDS
C
C     Balancing, eigenvalue, matrix algebra, matrix operations,
C     similarity transformation.
C
C  *********************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   HALF, ONE, ZERO
      PARAMETER          ( HALF = 0.5D+0, ONE = 1.0D+0, ZERO = 0.0D+0 )
      DOUBLE PRECISION   SCLFAC, THREE
      PARAMETER          ( SCLFAC = 1.0D+1, THREE = 3.0D+0 )
C     .. Scalar Arguments ..
      CHARACTER          JOB
      INTEGER            INFO, L, LDA, LDB, LDC, LDE, M, N, P
      DOUBLE PRECISION   THRESH
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   DWORK( * ), E( LDE, * ), LSCALE( * ),
     $                   RSCALE( * )
C     .. Local Scalars ..
      LOGICAL            WITHB, WITHC
      INTEGER            I, ICAB, IR, IRAB, IT, J, JC, KOUNT, KW1, KW2,
     $                   KW3, KW4, KW5, LCAB, LRAB, LSFMAX, LSFMIN,
     $                   NRP2
      DOUBLE PRECISION   ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2,
     $                   COEF5, COR, EPS, EW, EWC, GAMMA, PGAMMA, RAB,
     $                   SFMAX, SFMIN, SUM, T, TA, TB, TC, TE
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM( 1 )
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DDOT, DLAMCH
      EXTERNAL           DDOT, DLAMCH, IDAMAX, LSAME
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DSCAL, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, LOG10, MAX, MIN, SIGN
C
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO  = 0
      WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' )
      WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' )
C
      IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) )
     $   THEN
         INFO = -1
      ELSE IF( L.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( THRESH.LT.ZERO ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, L ) ) THEN
         INFO = -8
      ELSE IF( LDE.LT.MAX( 1, L ) ) THEN
         INFO = -10
      ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN
         INFO = -12
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -14
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'TG01AD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( L.EQ.0 .OR. N.EQ.0 ) THEN
         DUM( 1 ) = ONE
         IF( L.GT.0 ) THEN
            CALL DCOPY( L, DUM, 0, LSCALE, 1 )
         ELSE IF( N.GT.0 ) THEN
            CALL DCOPY( N, DUM, 0, RSCALE, 1 )
         END IF
         RETURN
      END IF
C
C     Initialize balancing and allocate work storage.
C
      KW1 = N
      KW2 = KW1 + L
      KW3 = KW2 + L
      KW4 = KW3 + N
      KW5 = KW4 + L
      DUM( 1 ) = ZERO
      CALL DCOPY( L, DUM, 0, LSCALE, 1 )
      CALL DCOPY( N, DUM, 0, RSCALE, 1 )
      CALL DCOPY( 3*(L+N), DUM, 0, DWORK, 1 )
C
C     Compute right side vector in resulting linear equations.
C
      BASL = LOG10( SCLFAC )
      DO 20 I = 1, L
         DO 10 J = 1, N
            TE = ABS( E( I, J ) )
            TA = ABS( A( I, J ) )
            IF( TA.GT.THRESH ) THEN
               TA = LOG10( TA ) / BASL
            ELSE
               TA = ZERO
            END IF
            IF( TE.GT.THRESH ) THEN
               TE = LOG10( TE ) / BASL
            ELSE
               TE = ZERO
            END IF
            DWORK( I+KW4 ) = DWORK( I+KW4 ) - TA - TE
            DWORK( J+KW5 ) = DWORK( J+KW5 ) - TA - TE
  10     CONTINUE
  20  CONTINUE
C
      IF( M.EQ.0 ) THEN
         WITHB = .FALSE.
         TB    = ZERO
      END IF
      IF( P.EQ.0 ) THEN
         WITHC = .FALSE.
         TC    = ZERO
      END IF
C
      IF( WITHB ) THEN
         DO 30 I = 1, L
            J = IDAMAX( M, B( I, 1 ), LDB )
            TB = ABS( B( I, J ) )
            IF( TB.GT.THRESH ) THEN
               TB = LOG10( TB ) / BASL
               DWORK( I+KW4 ) = DWORK( I+KW4 ) - TB
            END IF
  30     CONTINUE
      END IF
C
      IF( WITHC ) THEN
         DO 40 J = 1, N
            I = IDAMAX( P, C( 1, J ), 1 )
            TC = ABS( C( I, J ) )
            IF( TC.GT.THRESH ) THEN
               TC = LOG10( TC ) / BASL
               DWORK( J+KW5 ) = DWORK( J+KW5 ) - TC
            END IF
  40     CONTINUE
      END IF
C
      COEF  = ONE / DBLE( L+N )
      COEF2 = COEF*COEF
      COEF5 = HALF*COEF2
      NRP2 = MAX( L, N ) + 2
      BETA = ZERO
      EPS  = DLAMCH( 'Precision' )
      IT = 1
C
C     Start generalized conjugate gradient iteration.
C
  50  CONTINUE
C
      GAMMA = DDOT( L, DWORK( 1+KW4 ), 1, DWORK( 1+KW4 ), 1 ) +
     $        DDOT( N, DWORK( 1+KW5 ), 1, DWORK( 1+KW5 ), 1 )
C
      EW = ZERO
      DO 60 I = 1, L
         EW = EW + DWORK( I+KW4 )
  60  CONTINUE
C
      EWC = ZERO
      DO 70 I = 1, N
         EWC = EWC + DWORK( I+KW5 )
  70  CONTINUE
C
      GAMMA = COEF*GAMMA - COEF2*( EW**2 + EWC**2 ) -
     $                     COEF5*( EW - EWC )**2
      IF( ABS( GAMMA ).LE.EPS )
     $   GO TO 160
      IF( IT.NE.1 )
     $   BETA = GAMMA / PGAMMA
      T  = COEF5*( EWC - THREE*EW  )
      TC = COEF5*( EW  - THREE*EWC )
C
      CALL DSCAL( N+L, BETA, DWORK, 1 )
C
      CALL DAXPY( L, COEF, DWORK( 1+KW4 ), 1, DWORK( 1+KW1 ), 1 )
      CALL DAXPY( N, COEF, DWORK( 1+KW5 ), 1, DWORK, 1 )
C
      DO 80 J = 1, N
         DWORK( J ) = DWORK( J ) + TC
   80 CONTINUE
C
      DO 90 I = 1, L
         DWORK( I+KW1 ) = DWORK( I+KW1 ) + T
   90 CONTINUE
C
C     Apply matrix to vector.
C
      DO 110 I = 1, L
         KOUNT = 0
         SUM = ZERO
         DO 100 J = 1, N
            IF( ABS( A( I, J ) ).GT.THRESH ) THEN
               KOUNT = KOUNT + 1
               SUM = SUM + DWORK( J )
            END IF
            IF( ABS( E( I, J ) ).GT.THRESH ) THEN
               KOUNT = KOUNT + 1
               SUM = SUM + DWORK( J )
            END IF
  100    CONTINUE
         IF( WITHB ) THEN
            J = IDAMAX( M, B( I, 1 ), LDB )
            IF( ABS( B( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1
         END IF
         DWORK( I+KW2 ) = DBLE( KOUNT )*DWORK( I+KW1 ) + SUM
  110 CONTINUE
C
      DO 130 J = 1, N
         KOUNT = 0
         SUM = ZERO
         DO 120 I = 1, L
            IF( ABS( A( I, J ) ).GT.THRESH ) THEN
               KOUNT = KOUNT + 1
               SUM = SUM + DWORK( I+KW1 )
            END IF
            IF( ABS( E( I, J ) ).GT.THRESH ) THEN
               KOUNT = KOUNT + 1
               SUM = SUM + DWORK( I+KW1 )
            END IF
  120    CONTINUE
         IF( WITHC ) THEN
            I = IDAMAX( P, C( 1, J ), 1 )
            IF( ABS( C( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1
         END IF
         DWORK( J+KW3 ) = DBLE( KOUNT )*DWORK( J ) + SUM
  130 CONTINUE
C
      SUM = DDOT( L, DWORK( 1+KW1 ), 1, DWORK( 1+KW2 ), 1 ) +
     $      DDOT( N, DWORK, 1, DWORK( 1+KW3 ), 1 )
      ALPHA = GAMMA / SUM
C
C     Determine correction to current iteration.
C
      CMAX = ZERO
      DO 140 I = 1, L
         COR = ALPHA*DWORK( I+KW1 )
         IF( ABS( COR ).GT.CMAX )
     $      CMAX = ABS( COR )
         LSCALE( I ) = LSCALE( I ) + COR
  140 CONTINUE
C
      DO 150 J = 1, N
         COR = ALPHA*DWORK( J )
         IF( ABS( COR ).GT.CMAX )
     $      CMAX = ABS( COR )
         RSCALE( J ) = RSCALE( J ) + COR
  150 CONTINUE
      IF( CMAX.LT.HALF )
     $   GO TO 160
C
      CALL DAXPY( L, -ALPHA, DWORK( 1+KW2 ), 1, DWORK( 1+KW4 ), 1 )
      CALL DAXPY( N, -ALPHA, DWORK( 1+KW3 ), 1, DWORK( 1+KW5 ), 1 )
C
      PGAMMA = GAMMA
      IT = IT + 1
      IF( IT.LE.NRP2 )
     $   GO TO 50
C
C     End generalized conjugate gradient iteration.
C
  160 CONTINUE
      SFMIN = DLAMCH( 'Safe minimum' )
      SFMAX = ONE / SFMIN
      LSFMIN = INT( LOG10( SFMIN ) / BASL + ONE )
      LSFMAX = INT( LOG10( SFMAX ) / BASL )
C
C     Compute left diagonal scaling matrix.
C
      DO 170 I = 1, L
         IRAB = IDAMAX( N, A( I, 1 ), LDA )
         RAB  = ABS( A( I, IRAB ) )
         IRAB = IDAMAX( N, E( I, 1 ), LDE )
         RAB  = MAX( RAB, ABS( E( I, IRAB ) ) )
         IF( WITHB ) THEN
            IRAB = IDAMAX( M, B( I, 1 ), LDB )
            RAB  = MAX( RAB, ABS( B( I, IRAB ) ) )
         END IF
         LRAB = INT( LOG10( RAB+SFMIN ) / BASL + ONE )
         IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) )
         IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB )
         LSCALE( I ) = SCLFAC**IR
  170 CONTINUE
C
C     Compute right diagonal scaling matrix.
C
      DO 180 J = 1, N
         ICAB = IDAMAX( L, A( 1, J ), 1 )
         CAB  = ABS( A( ICAB, J ) )
         ICAB = IDAMAX( L, E( 1, J ), 1 )
         CAB  = MAX( CAB, ABS( E( ICAB, J ) ) )
         IF( WITHC ) THEN
            ICAB = IDAMAX( P, C( 1, J ), 1 )
            CAB  = MAX( CAB, ABS( C( ICAB, J ) ) )
         END IF
         LCAB = INT( LOG10( CAB+SFMIN ) / BASL + ONE )
         JC = RSCALE( J ) + SIGN( HALF, RSCALE( J ) )
         JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB )
         RSCALE( J ) = SCLFAC**JC
  180 CONTINUE
C
C     Row scaling of matrices A, E and B.
C
      DO 190 I = 1, L
         CALL DSCAL( N, LSCALE( I ), A( I, 1 ), LDA )
         CALL DSCAL( N, LSCALE( I ), E( I, 1 ), LDE )
         IF( WITHB )
     $      CALL DSCAL( M, LSCALE( I ), B( I, 1 ), LDB )
  190 CONTINUE
C
C     Column scaling of matrices A, E and C.
C
      DO 200 J = 1, N
         CALL DSCAL( L, RSCALE( J ), A( 1, J ), 1 )
         CALL DSCAL( L, RSCALE( J ), E( 1, J ), 1 )
         IF( WITHC )
     $      CALL DSCAL( P, RSCALE( J ), C( 1, J ), 1 )
  200 CONTINUE
C
      RETURN
C *** Last line of TG01AD ***
      END


subroutine driver(jm, im, srf_rad_flx, srf_lat_flx, srf_sen_flx, qflx, Hslab, rowl, Cl, dt, &
                             Tsinc, Tsdot )

implicit none

! Input
integer, intent(in)                   :: jm,im
real(8), intent(in), dimension(jm,im) :: srf_rad_flx, srf_lat_flx, srf_sen_flx, qflx
real(8), intent(in)                   :: Hslab, rowl, Cl, dt
!f2py intent(in,hide)  jm,im

! Output
real(8), intent(out), dimension(jm,im) :: Tsinc, Tsdot

! Local
real(8) :: invCslab

invCslab = 1. / (Hslab*rowl*Cl)
Tsdot = (srf_rad_flx + srf_lat_flx + srf_sen_flx + qflx) * invCslab
Tsinc = 2.*dt*Tsdot

end subroutine driver


      subroutine sourceph(xp,yp,zp,nxp,nyp,nzp,
     +                    sint,cost,sinp,cosp,phi,fi,fq,fu,fv,
     +                    xmax,ymax,zmax,twopi,
     +                    xcell,ycell,zcell,nxg,nyg,nzg,iseed)

      implicit none

      include 'photon.txt'

      integer xcell,ycell,zcell,nxg,nyg,nzg,iseed
      real*8 xmax,ymax,zmax,twopi
      real ran2

c***** emit photon isotropically from origin
      xp=0.
      yp=0.
      zp=0.

      cost=2.*ran2(iseed)-1.
      sint=(1.-cost*cost)
      if(sint.le.0.)then
        sint=0.
      else
        sint=sqrt(sint)
      endif

      xp=0.
      yp=0.
      zp=0.

      phi=twopi*ran2(iseed)
      cosp=cos(phi)
      sinp=sin(phi)

c***** Set photon direction cosines for direction of travel *********
      nxp=sint*cosp
      nyp=sint*sinp
      nzp=cost

c***** Set Stokes fluxes ********************************************
      fi=1.
      fq=0.
      fu=0.
      fv=0.

c*************** Linear Grid *************************
      xcell=int(nxg*(xp+xmax)/(2.*xmax))+1
      ycell=int(nyg*(yp+ymax)/(2.*ymax))+1
      zcell=int(nzg*(zp+zmax)/(2.*zmax))+1
c*****************************************************

      return
      end


c
c -----------------------------------------------------------
c
      subroutine conck(level, nvar, time, rest)
c
      implicit double precision (a-h,o-z)

      include  "call.i"
      logical  rest

      iadd(i,j,ivar)  = loc + i - 1 + mitot*((ivar-1)*mjtot+j-1)
      iaddaux(i,j,iaux) = locaux + i - 1 + mitot*((iaux-1)*mjtot+j-1)
c
c ******************************************************************
c conck - conservation check  for specified level
c         mostly a debugging tool
c         this assumes grids don't overlap
c ******************************************************************
c
c
c  grid loop for given level
c
      hx      = hxposs(level)
      hy      = hyposs(level)
      dt      = possk(level)
      totmass = 0.d0
      totvol  = 0.d0
      totarea = 0.d0
      totkinetic = 0.0
      centermassx = 0.0
      centermassy = 0.0
      totpotential = 0.0
      totwork = 0.0
      grav = 9.81
      F_x = 0.0
      F_y = 0.0
      F_z = 0.0

      mptr = lstart(level)
 20   if (mptr .eq. 0) go to 85
         loc    = node(store1,mptr)
         locaux = node(storeaux,mptr)
         nx     = node(ndihi,mptr) - node(ndilo,mptr) + 1
         ny     = node(ndjhi,mptr) - node(ndjlo,mptr) + 1
         mitot  = nx + 2*nghost
         mjtot  = ny + 2*nghost
         xlow   = rnode(cornxlo,mptr)
         ylow   = rnode(cornylo,mptr)
         xhi    = rnode(cornxhi,mptr)
         yhi    = rnode(cornyhi,mptr)
c
         if (mcapa .eq. 0) then
           do 50 j  = nghost+1, mjtot-nghost
           do 50 i  = nghost+1, mitot-nghost
              x = xlow + (i-0.5)*hx
              y = ylow + (j-0.5)*hy
              if (dabs(alloc(iadd(i,j,1))).gt.1.d-3) then
                  depth = alloc(iadd(i,j,1))
                  topo = alloc(iaddaux(i,j,1)) - 70.0
                  sv = alloc(iadd(i,j,4))/alloc(iadd(i,j,1))
                  rho = 1000.d0*(1.d0-sv) + 2700.d0*sv
                  hvnorm =
     &              sqrt(alloc(iadd(i,j,2))**2 + alloc(iadd(i,j,3))**2)
                  totpotential = totpotential +
     &                  0.5*grav*rho*depth*(depth+2.0*topo)
                  totwork = totwork + rho*grav*hvnorm
                  totmass = totmass + rho*alloc(iadd(i,j,1))
                  centermassx = centermassx+rho*alloc(iadd(i,j,1))*x
                  centermassy = centermassy+rho*alloc(iadd(i,j,1))*y
                  totarea = totarea + hx*hy
                  totkinetic = totkinetic + rho*0.5*
     &               (alloc(iadd(i,j,2))**2 + alloc(iadd(i,j,3))**2)
     &                  /alloc(iadd(i,j,1))

c             !=========begin ==========================================
                  vu = (alloc(iadd(i,j,2)))/depth
                  vv = (alloc(iadd(i,j,3)))/depth
                  if ((vu**2+vv*2).le.0.0) cycle
                  b_x =(alloc(iaddaux(i+1,j,1))
     &                  -alloc(iaddaux(i-1,j,1)))/(2.d0*hx)
                  b_y =(alloc(iaddaux(i,j+1,1))
     &                  -alloc(iaddaux(i,j-1,1)))/(2.d0*hy)

                  b_xx=(alloc(iaddaux(i+1,j,1))-2.d0*alloc(iaddaux
     &                     (i,j,1))+alloc(iaddaux(i-1,j,1)))/(hx**2)
                  b_yy=(alloc(iaddaux(i,j+1,1))-2.d0*alloc(iaddaux
     &                     (i,j,1))+alloc(iaddaux(i,j-1,1)))/(hy**2)
                  b_xy= (alloc(iaddaux(i+1,j+1,1))
     &                  -alloc(iaddaux(i-1,j+1,1))
     &                  -alloc(iaddaux(i+1,j-1,1))
     &                  +alloc(iaddaux(i-1,j-1,1)))/(4.0*hx*hy)

                  c = 1.d0/dsqrt(b_x**2 + b_y**2 + 1.d0)
                  un_x = -c*b_x
                  un_y = -c*b_y
                  un_z = c
                  alpha = 1.0/dsqrt(vu**2+vv**2+(vu*b_x+vv*b_y)**2)
                  t_x = alpha*vu
                  t_y = alpha*vv
                  t_z = alpha*(vu*b_x + vv*b_y)
                  if ((b_x**2+b_y*2).gt.0.0) then
                  alpha = 1.0/dsqrt(b_x**2+b_y**2+(b_x**2+b_y**2)**2)
                  else
                  alpha = 0.0
                  endif
                  d_x = -alpha*b_x
                  d_y = -alpha*b_y
                  d_z = -alpha*(b_x**2 + b_y**2)
                  sina = alpha*(b_x**2 + b_y**2)
                  chi = (vu**2*b_xx + vv**2*b_yy + 2.0*vu*vv*b_xy)/grav
                  chi = max(chi,-1.0)

                  phi = alloc(iaddaux(i,j,4))
                  rgh = rho*grav*depth
                  gamma = alloc(iadd(i,j,5))/rgh

                  F_x = F_x + c*rgh*chi*un_x
                  F_y = F_y + c*rgh*chi*un_y
                  F_z = F_z + c*rgh*chi*un_z

                  shearmag = -c*rgh*(1.0+chi)*max(0.0,(1.0-gamma))
     &                                                   *dtan(phi)
                  F_x = F_x + shearmag*t_x
                  F_y = F_y + shearmag*t_y
                  F_z = F_z + shearmag*t_z

                  F_x = F_x + sina*rgh*d_x
                  F_y = F_y + sina*rgh*d_y
                  F_z = F_z + sina*rgh*d_z

cc             !=========end ============================================
              endif
              totvol = totvol + alloc(iadd(i,j,1))
 50           continue
          else
c          # with capa array:

          endif
c
       mptr = node(levelptr,mptr)
       go to 20
c
 85    totmass = totmass * hx * hy
 86    totvol = totvol * hx * hy
       totkinetic = totkinetic*hx*hy
       totpotential = totpotential*hx*hy
       totwork = totwork*hx*hy
       centermassx = hx*hy*centermassx/totmass
       centermassy = hx*hy*centermassy/totmass
       F_x = F_x*hx*hy
       F_y = F_y*hx*hy
       F_z = F_z*hx*hy
       if (time.eq.tstart .and. (level.eq.1) .and. .not. rest) then
           tmass0 = totmass
           tvol0 = totvol
           totarea0 = totarea
           write(6,*) 'Total mass at initial time: ',tmass0
           write(6,*) 'Total volume at initial time: ',tvol0
           write(6,*) 'Total area at initial time: ',totarea0
       endif

       if (level.eq.3) then
       write(outunit,777) time, totmass, 100.0*(totmass-tmass0)/tmass0
       write(outunit,778) time, totvol, 100.0*(totvol-tvol0)/tvol0
       write(outunit,779) time, totarea
       write(outunit,780) time, totkinetic
       write(outunit,781) time, centermassx,centermassy
       write(outunit,782) time, totpotential,totwork
       write(outunit,783) time, F_x,F_y,F_z
       endif
 777   format('time t = ',e12.5,'  total mass = ',e22.15, ' diff % = ',
     &         e11.4)
 778   format('time t = ',e12.5,'  total vol = ',e22.15, '  diff % = ',
     &         e11.4)
 779   format('time t = ',e12.5,'  total area = ',e22.15)
 780   format('time t = ',e12.5,'  total kinetic = ',e22.15)
 781   format('time t = ',e12.5,'  center of mass = ',e22.15,e22.15)
 782   format('time t = ',e12.5,'  total potential work = ',e22.15,
     &            e22.15)
 783   format('time t = ',e12.5,'  F_net = ',e22.14,e22.14,e22.14)
c
 99   return
      end


subroutine rkf45a(neqn,t0,tf,u0,nsteps,u)
!
! Subroutine rkf45a computes an ODE solution by a fixed
! step rkf45 method for a series of points along the
! solution by repeatedly calling subroutine ssrkf45 for
! a single rkf45 step.
!
! Argument list
!
! neqn number of first order ODEs
!
! t0 initial value of independent variable
!
! tf final value of independent variable
!
! u0 initial condition vector of length neqn
!
! nsteps number of rkf45 steps
!
! u ODE solution vector of length neqn after
! nsteps steps
!
! Double precision coding is used
implicit double precision(a-h,o-z)
!
!
! Size arrays
parameter(neq=500)
dimension e(neq)
dimension u0(neqn), u(neqn)
!
! Integration step
h=(tf-t0)/dfloat(nsteps)
!
! nsteps rkf45 steps
do j=1,nsteps
!
! Single rkf45 step
call ssrkf45(neqn,t0,u0,h,t,u,e)
!
! Reset base point values for the next rkf45 step
do i=1,neqn
u0(i)=u(i)
end do
t0=t
!
! Next rkf45 step
end do
!
! nsteps rkf45 steps completed
return
!
! End of rkf45a
end


PROGRAM fptest
  !--------- -------- --------- --------- --------- --------- --------- --------- -----
  !
  ! Example program 2 for using the function parser module
  !
  !--------- -------- --------- --------- --------- --------- --------- --------- -----
  USE FortranParser_parameters, ONLY: rn
  USE FortranParser,    ONLY: EquationParser
  IMPLICIT NONE
  type(EquationParser) :: eqParser
  INTEGER,                             PARAMETER :: nfunc = 3
  CHARACTER (LEN=*), DIMENSION(nfunc), PARAMETER :: func = (/ 'vel*COS(beta)           ', &
                                                              'vel*SIN(beta)*COS(alpha)', &
                                                              'vel*SIN(beta)*SIN(alpha)' /)
  INTEGER,                             PARAMETER :: nvar = 3
  CHARACTER (LEN=*), DIMENSION(nvar),  PARAMETER :: var  = (/ 'vel  ', &
                                                              'alpha', &
                                                              'beta ' /)
  REAL(rn),          DIMENSION(nvar),  PARAMETER :: val  = (/  10., 1.5, 2.0  /)
  REAL(rn)                                       :: res
  INTEGER                                        :: i
  REAL(rn)                                       :: vel,alpha,beta
  !--------- -------- --------- --------- --------- --------- --------- --------- -----
  !
  WRITE(*,*)'==> Bytecode evaluation:'
  DO i=1,nfunc
     eqParser = EquationParser(func(i), var)
     res = eqParser%evaluate(val)
     WRITE(*,*) func(i),'=',res
  END DO

  WRITE(*,*)'==> Direct evaluation:'
  vel   = val(1)
  alpha = val(2)
  beta  = val(3)
  WRITE(*,*)'res=',vel*COS(beta)
  WRITE(*,*)'res=',vel*SIN(beta)*COS(alpha)
  WRITE(*,*)'res=',vel*SIN(beta)*SIN(alpha)
  !
END PROGRAM fptest


program cov_test
  use m_util
  use m_cov_sqexp

  implicit none

  integer, parameter :: Ndims = 2
  real(kind=dp), dimension(Ndims) :: x1, y1
  real(dp) r1(Ndims+1)

  x1 = (/ 1.0_dp, 1.0_dp /)
  y1 = (/ 2.0_dp, 1.4_dp /)
  r1 = (/ 1.0_dp, 1.0_dp, 0.3_dp /)

  call cov_test1
  call cov_test2
  call cov_test3
  call cov_test4

contains
  ! expected values in the routines below are from finite differences
  subroutine cov_test1
    type(cov_sqexp) cf
    real(dp) :: actual, expected
    actual = cf%cov_val(x1, y1, r1)
    expected = 0.24935220877729633_dp
    if (abs(actual - expected) > 1d-15) stop 1
  end subroutine cov_test1

  subroutine cov_test2
    type(cov_sqexp) cf
    real(kind=dp), dimension(Ndims) :: actual, expected
    integer :: n
    actual = (/ (cf%dcov_x1(n, x1, y1, r1), n=1,2) /)
    expected = (/ .2493522088_dp, 1.108232039_dp /)
    if (maxval(abs(actual - expected)) > 1d-10) stop 2
  end subroutine cov_test2

  subroutine cov_test3
    type(cov_sqexp) cf
    real(kind=dp), dimension(Ndims) :: actual, expected
    integer :: n
    actual = (/ (cf%dcov_x2(n, x1, y1, r1), n=1,2) /)
    expected = (/ -0.2493522088_dp, -1.108232039_dp /)
    if (maxval(abs(actual - expected)) > 1d-10) stop 3
  end subroutine cov_test3

  subroutine cov_test4
    type(cov_sqexp) cf
    real(kind=dp), dimension(Ndims*Ndims) :: actual, expected
    integer :: n, m
    actual = (/ ((cf%d2cov_xx(n, m, x1, y1, r1), n=1,2), m=1,2) /)
    expected = (/ 0.0_dp, -1.10823209_dp, -1.10823209_dp, -2.1548956_dp /)
    if (maxval(abs(actual - expected)) > 1d-7) stop 4
  end subroutine cov_test4

end program cov_test


SUBROUTINE clawpack5_rpn2adv(ixy,maxm,meqn,mwaves,maux,mbc, &
    mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
    IMPLICIT NONE

    INTEGER ixy,maxm,meqn,mwaves,maux,mbc,mx
    DOUBLE PRECISION wave(meqn, mwaves, 1-mbc:maxm+mbc)
    DOUBLE PRECISION    s(mwaves, 1-mbc:maxm+mbc)
    DOUBLE PRECISION   ql(meqn, 1-mbc:maxm+mbc)
    DOUBLE PRECISION   qr(meqn, 1-mbc:maxm+mbc)
    DOUBLE PRECISION apdq(meqn,1-mbc:maxm+mbc)
    DOUBLE PRECISION amdq(meqn,1-mbc:maxm+mbc)
    DOUBLE PRECISION auxl(maux,1-mbc:maxm+mbc)
    DOUBLE PRECISION auxr(maux,1-mbc:maxm+mbc)

    INTEGER iface, i, mq, mw

    double precision delta(meqn)

    iface = ixy
    DO i = 2-mbc, mx+mbc
        do mq = 1,meqn
            do mw = 1,mwaves
                wave(mq,mw,i) = 0
            end do
        end do

        do mq = 1,meqn
            delta(mq) = ql(mq,i) - qr(mq,i-1)
            do mw = 1,mwaves
                wave(mq,mw,i) = delta(mq)
            end do
        end do

        do mw = 1,mwaves
            s(mw,i) = auxl(iface,i)
        end do

        do mq = 1,meqn
            amdq(mq,i) = 0
            apdq(mq,i) = 0
            do mw = 1,mwaves
               amdq(mq,i) = amdq(mq,i) + min(s(mw,i), 0.d0) * wave(mq,mw,i)
               apdq(mq,i) = apdq(mq,i) + max(s(mw,i), 0.d0) * wave(mq,mw,i)
            end do
        end do
    END DO

    RETURN
END SUBROUTINE clawpack5_rpn2adv


!=====================================================
SUBROUTINE spfper(np1,amx1,amx2,amx3)

! Helper routine for splfi

  USE neo_precision

  IMPLICIT NONE

  INTEGER,                       INTENT(in)  :: np1
  REAL(kind=dp), DIMENSION(np1), INTENT(out) :: amx1, amx2, amx3
  REAL(kind=dp)                              :: beta, ss
  INTEGER                                    :: n, n1, i, i1

  n = np1-1

  n1 = n-1
  amx1(1) = 2
  amx2(1) = 0.5_dp
  amx3(1) = 0.5_dp
  amx1(2) = sqrt(15._dp)/2
  amx2(2) = ONE/amx1(2)
  amx3(2) = -.25_dp/amx1(2)
  beta = 3.75_dp
  DO i = 3,n1
     i1 = i-1
     beta = 4-ONE/beta
     amx1(i) = sqrt(beta)
     amx2(i) = ONE/amx1(i)
     amx3(i) = -amx3(i1)/amx1(i)/amx1(i1)
  END DO
  amx3(n1) = amx3(n1)+ONE/amx1(n1)
  amx2(n1) = amx3(n1)
  ss = 0
  DO i = 1,n1
     ss = ss+amx3(i)*amx3(i)
  END DO
  amx1(n) = sqrt(4-ss)

  RETURN
END SUBROUTINE spfper


c---------------------------------------------------------------------
c---------------------------------------------------------------------

       subroutine  initialize

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c This subroutine initializes the field variable u using
c tri-linear transfinite interpolation of the boundary values
c---------------------------------------------------------------------

       include 'header.h'

       integer i, j, k, m, ix, iy, iz
       double precision  xi, eta, zeta, Pface(5,3,2), Pxi, Peta,
     >                   Pzeta, temp(5)

c---------------------------------------------------------------------
c  Later (in compute_rhs) we compute 1/u for every element. A few of
c  the corner elements are not used, but it convenient (and faster)
c  to compute the whole thing with a simple loop. Make sure those
c  values are nonzero by initializing the whole thing here.
c---------------------------------------------------------------------
      do k = 0, grid_points(3)-1
         do j = 0, grid_points(2)-1
            do i = 0, grid_points(1)-1
               u(1,i,j,k) = 1.0
               u(2,i,j,k) = 0.0
               u(3,i,j,k) = 0.0
               u(4,i,j,k) = 0.0
               u(5,i,j,k) = 1.0
            end do
         end do
      end do

c---------------------------------------------------------------------
c first store the "interpolated" values everywhere on the grid
c---------------------------------------------------------------------
          do  k = 0, grid_points(3)-1
             zeta = dble(k) * dnzm1
             do  j = 0, grid_points(2)-1
                eta = dble(j) * dnym1
                do   i = 0, grid_points(1)-1
                   xi = dble(i) * dnxm1

                   do ix = 1, 2
                      Pxi = dble(ix-1)
                      call exact_solution(Pxi, eta, zeta,
     >                                    Pface(1,1,ix))
                   end do

                   do    iy = 1, 2
                      Peta = dble(iy-1)
                      call exact_solution(xi, Peta, zeta,
     >                                    Pface(1,2,iy))
                   end do

                   do    iz = 1, 2
                      Pzeta = dble(iz-1)
                      call exact_solution(xi, eta, Pzeta,
     >                                    Pface(1,3,iz))
                   end do

                   do   m = 1, 5
                      Pxi   = xi   * Pface(m,1,2) +
     >                        (1.0d0-xi)   * Pface(m,1,1)
                      Peta  = eta  * Pface(m,2,2) +
     >                        (1.0d0-eta)  * Pface(m,2,1)
                      Pzeta = zeta * Pface(m,3,2) +
     >                        (1.0d0-zeta) * Pface(m,3,1)

                      u(m,i,j,k) = Pxi + Peta + Pzeta -
     >                          Pxi*Peta - Pxi*Pzeta - Peta*Pzeta +
     >                          Pxi*Peta*Pzeta

                   end do
                end do
             end do
          end do

c---------------------------------------------------------------------
c now store the exact values on the boundaries
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c west face
c---------------------------------------------------------------------

       xi = 0.0d0
       i  = 0
       do  k = 0, grid_points(3)-1
          zeta = dble(k) * dnzm1
          do   j = 0, grid_points(2)-1
             eta = dble(j) * dnym1
             call exact_solution(xi, eta, zeta, temp)
             do   m = 1, 5
                u(m,i,j,k) = temp(m)
             end do
          end do
       end do

c---------------------------------------------------------------------
c east face
c---------------------------------------------------------------------

       xi = 1.0d0
       i  = grid_points(1)-1
       do   k = 0, grid_points(3)-1
          zeta = dble(k) * dnzm1
          do   j = 0, grid_points(2)-1
             eta = dble(j) * dnym1
             call exact_solution(xi, eta, zeta, temp)
             do   m = 1, 5
                u(m,i,j,k) = temp(m)
             end do
          end do
       end do

c---------------------------------------------------------------------
c south face
c---------------------------------------------------------------------

       eta = 0.0d0
       j   = 0
       do  k = 0, grid_points(3)-1
          zeta = dble(k) * dnzm1
          do   i = 0, grid_points(1)-1
             xi = dble(i) * dnxm1
             call exact_solution(xi, eta, zeta, temp)
             do   m = 1, 5
                u(m,i,j,k) = temp(m)
             end do
          end do
       end do

c---------------------------------------------------------------------
c north face
c---------------------------------------------------------------------

       eta = 1.0d0
       j   = grid_points(2)-1
       do   k = 0, grid_points(3)-1
          zeta = dble(k) * dnzm1
          do   i = 0, grid_points(1)-1
             xi = dble(i) * dnxm1
             call exact_solution(xi, eta, zeta, temp)
             do   m = 1, 5
                u(m,i,j,k) = temp(m)
             end do
          end do
       end do

c---------------------------------------------------------------------
c bottom face
c---------------------------------------------------------------------

       zeta = 0.0d0
       k    = 0
       do   j = 0, grid_points(2)-1
          eta = dble(j) * dnym1
          do   i =0, grid_points(1)-1
             xi = dble(i) *dnxm1
             call exact_solution(xi, eta, zeta, temp)
             do   m = 1, 5
                u(m,i,j,k) = temp(m)
             end do
          end do
       end do

c---------------------------------------------------------------------
c top face
c---------------------------------------------------------------------

       zeta = 1.0d0
       k    = grid_points(3)-1
       do   j = 0, grid_points(2)-1
          eta = dble(j) * dnym1
          do   i =0, grid_points(1)-1
             xi = dble(i) * dnxm1
             call exact_solution(xi, eta, zeta, temp)
             do   m = 1, 5
                u(m,i,j,k) = temp(m)
             end do
          end do
       end do

       return
       end

       subroutine lhsinit(ni, nj)

       include 'header.h'

       integer ni, nj

       integer j, m

c---------------------------------------------------------------------
c     zap the whole left hand side for starters
c     set all diagonal values to 1. This is overkill, but convenient
c---------------------------------------------------------------------
       do j = 1, nj
          do   m = 1, 5
             lhs (m,0,j) = 0.0d0
             lhsp(m,0,j) = 0.0d0
             lhsm(m,0,j) = 0.0d0
             lhs (m,ni,j) = 0.0d0
             lhsp(m,ni,j) = 0.0d0
             lhsm(m,ni,j) = 0.0d0
          end do
          lhs (3,0,j) = 1.0d0
          lhsp(3,0,j) = 1.0d0
          lhsm(3,0,j) = 1.0d0
          lhs (3,ni,j) = 1.0d0
          lhsp(3,ni,j) = 1.0d0
          lhsm(3,ni,j) = 1.0d0
       end do

       return
       end

       subroutine lhsinitj(nj, ni)

       include 'header.h'

       integer nj, ni

       integer i, m

c---------------------------------------------------------------------
c     zap the whole left hand side for starters
c     set all diagonal values to 1. This is overkill, but convenient
c---------------------------------------------------------------------
       do i = 1, ni
          do   m = 1, 5
             lhs (m,i,0) = 0.0d0
             lhsp(m,i,0) = 0.0d0
             lhsm(m,i,0) = 0.0d0
             lhs (m,i,nj) = 0.0d0
             lhsp(m,i,nj) = 0.0d0
             lhsm(m,i,nj) = 0.0d0
          end do
          lhs (3,i,0) = 1.0d0
          lhsp(3,i,0) = 1.0d0
          lhsm(3,i,0) = 1.0d0
          lhs (3,i,nj) = 1.0d0
          lhsp(3,i,nj) = 1.0d0
          lhsm(3,i,nj) = 1.0d0
       end do

       return
       end


*	Program to list wavefunctions
*
*	Created by C. Froese Fischer June 30, 1987
*	Vanderbilt University

      PROGRAM PLOTW
      IMPLICIT REAL*8(A-H,O-Z)
      CHARACTER AT*6,TT*6,EL1*3,EL*3,NEW*3,INPUT*24,OUTPUT*24,
     :          ATOM*6,TERM*6
      DIMENSION P(220,30),EL(30),R(220),R2(220)
*
      iarg = iargc()
*     if (iarg .gt. 0) then
*	 call getarg(1,INPUT)
*     else
	 INPUT = 'wfn.inp'
*     end if
*     if (iarg .gt. 1) then
*	 call getarg(1,OUTPUT)
*     else
	 OUTPUT = 'plot.dat'
*     end if
      inc = 1
*     if (iarg .gt. 3) call getarg(3,inc)
      OPEN(UNIT=3,FILE=INPUT,STATUS='OLD',
     :   FORM='UNFORMATTED')
      OPEN(UNIT=4,FILE=OUTPUT,STATUS='UNKNOWN')
      IUF=3
      nwf=1
      MM = 0
2     P(1,nwf) = 0.D0
      READ(IUF,END=5) AT,TT,EL1,M,ZT,ETI,EKI,AZI,(P(J,NWF),J=2,M+1)
      WRITE(6,'($,2x,A,A)') EL1,' = '
      READ(5,'(A)') NEW
      IF ( NEW .NE. 'd  ' .AND. NEW .NE. 'D  ' ) THEN
         IF ( NEW .NE. '   ') THEN
            EL1 = NEW
         ENDIF
         EL(NWF) = EL1
	 NWF = NWF + 1
         Z = ZT
	 ATOM = AT
	 TERM = TT
	 MM = MAX(M,MM)
      END IF
      GO TO 2
5     CLOSE(UNIT=3)
      RHO = -4.0
      H = 1/16.
      R(1) = 0.d0
      R2(1) = 0.d0
      DO 10 J = 2,220
	 R(J) = EXP(RHO)/Z
	 R2(J) = SQRT(R(J))
	 RHO = RHO + H
10    CONTINUE
*
*	LIST TABLES OF RADIAL FUNCTIONS
*
      NWF = NWF -1
      write(4,*) ' sqrt(r)    P(nl;r)'
      DO 20 I = 1,NWF
	 write(4,*) EL(I)
	 DO 21 J = 1,MM,inc
	    Pwave = P(J,I)*R2(J)
	    IF (abs(Pwave) .gt. 0.0005 .OR. J.EQ.1)
     :         WRITE(4,'(F10.4,F12.3)') R2(J),Pwave
21       CONTINUE
20    CONTINUE
      END


c
c-----------------------------------------------------------------------
c subroutine: fftaoh
c compute dft for real, antisymmetric, odd harmonic, n-point sequence
c using n/4-point fft
c antisymmetric sequence means x(m)=-x(n-m), m=1,...,n/2-1
c odd harmonic means x(2*k)=0, all k, where x(k) is the dft of x(m)
c x(m) has the property x(m)=x(n/2-m), m=0,1,...,n/4-1,  x(0)=0
c note: index m is sequence index--not fortran index
c-----------------------------------------------------------------------
c
      subroutine fftaoh(x, n, y)
      dimension x(1), y(1)
c
c  x = real array which on input contains the (n/4+1) points of the
c      input sequence (antisymmetrical)
c      on output x contains the n/4 imaginary points of the odd
c      harmonics of the transform of the input--i.e. the zero
c      valued real parts are not given nor are the zero-valued
c      even harmonics
c  n = true size of input
c  y = scratch array of size n/4+2
c
c
c handle n = 2 and n = 4 cases separately
c
      if (n.gt.4) go to 20
      if (n.eq.4) go to 10
c
c for n=2, assume x(1)=0, x(2)=0, compute dft directly
c
      x(1) = 0.
      return
c
c n = 4 case, assume x(1)=x(3)=0, x(2)=-x(4)=x0, compute dft directly
c
  10  x(1) = -2.*x(2)
      return
  20  twopi = 8.*atan(1.0)
c
c form new sequence, y(m)=x(2*m)+(x(2*m+1)-x(2*m-1))
c
      no2 = n/2
      no4 = n/4
      no8 = n/8
      if (no8.eq.1) go to 40
      do 30 i=2,no8
        ind = 2*i
        t1 = x(ind) - x(ind-2)
        y(i) = x(ind-1) + t1
        ind1 = n/4 + 2 - i
        y(ind1) = x(ind-1) - t1
  30  continue
  40  y(1) = 2.*x(2)
      y(no8+1) = x(no4+1)
c
c the sequence y (n/4 points) has only odd harmonics
c call subroutine fftohm to exploit odd harmonics
c
      call fftohm(y, no2)
c
c form original dft from complex odd harmonics of y(k)
c by unscrambling y(k)
c
      tpn = twopi/float(n)
      cosi = 2.*cos(tpn)
      sini = 2.*sin(tpn)
      cosd = cos(tpn*2.)
      sind = sin(tpn*2.)
      do 50 i=1,no8
        ind = 2*i
        bk = y(ind-1)/sini
        temp = cosi*cosd - sini*sind
        sini = cosi*sind + sini*cosd
        cosi = temp
        ak = y(ind)
        x(i) = ak - bk
        ind1 = n/4 + 1 - i
        x(ind1) = -ak - bk
  50  continue
      return
      end


      subroutine lpp(p1,p2,l)
       real      p1(2),p2(2),l(3)
       det=p2(1)*p1(2)-p1(1)*p2(2)
      if(abs(det).ge.1e-6) go to 3
      detx=p2(1)-p1(1)
      if(abs(detx).ge.1e-6) go to 1
      l(1)=1.
      l(2)=0.
      l(3)=0.
       return
  1   dety=p2(2)-p1(2)
      if(abs(dety).ge.1e-6) go to 2
      l(1)=0.
      l(2)=1.
      l(3)=0.
       return
  2   l(1)=1.
      l(2)=-detx/dety
       l(3)=0.
       return
  3   l(1)=(p2(2)-p1(2))/det
      l(2)=(p1(1)-p2(1))/det
      l(3)=1.
       return
      end


C
C $Id:$
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
C NOTE: If you make any changes to this software, please remember to
C make the same changes to the corresponding double precision routine.
C
      subroutine curvpp (n,x,y,p,d,isw,s,eps,ys,ysp,sigma,
     *                   td,tsd1,hd,hsd1,hsd2,rd,rsd1,rsd2,
     *                   rnm1,rn,v,ierr)
C
      integer n,isw,ierr
      real x(n),y(n),p,d(n),s,eps,ys(n),ysp(n),sigma,td(n),
     *     tsd1(n),hd(n),hsd1(n),hsd2(n),rd(n),rsd1(n),
     *     rsd2(n),rnm1(n),rn(n),v(n)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute a periodic smoothing spline under tension. for a
c given increasing sequence of abscissae (x(i)), i = 1,...,n
c and associated ordinates (y(i)), i = 1,...,n, letting p be
c the period, x(n+1) = x(1)+p, and y(n+1) = y(1), the
c function determined minimizes the summation from i = 1 to
c n of the square of the second derivative of f plus sigma
c squared times the difference of the first derivative of f
c and (f(x(i+1))-f(x(i)))/(x(i+1)-x(i)) squared, over all
c functions f with period p and two continuous derivatives
c such that the summation of the square of
c (f(x(i))-y(i))/d(i) is less than or equal to a given
c constant s, where (d(i)), i = 1,...,n are a given set of
c observation weights. the function determined is a periodic
c spline under tension with third derivative discontinuities
c at (x(i)) i = 1,...,n (and all periodic translations of
c these values). for actual computation of points on the
c curve it is necessary to call the function curvp2.
c
c on input--
c
c   n is the number of values to be smoothed (n.ge.2).
c
c   x is an array of the n increasing abscissae of the
c   values to be smoothed.
c
c   y is an array of the n ordinates of the values to be
c   smoothed, (i. e. y(k) is the functional value
c   corresponding to x(k) ).
c
c   p is the period (p .gt. x(n)-x(1)).
c
c   d is a parameter containing the observation weights.
c   this may either be an array of length n or a scalar
c   (interpreted as a constant). the value of d
c   corresponding to the observation (x(k),y(k)) should
c   be an approximation to the standard deviation of error.
c
c   isw contains a switch indicating whether the parameter
c   d is to be considered a vector or a scalar,
c          = 0 if d is an array of length n,
c          = 1 if d is a scalar.
c
c   s contains the value controlling the smoothing. this
c   must be non-negative. for s equal to zero, the
c   subroutine does interpolation, larger values lead to
c   smoother funtions. if parameter d contains standard
c   deviation estimates, a reasonable value for s is
c   float(n).
c
c   eps contains a tolerance on the relative precision to
c   which s is to be interpreted. this must be greater than
c   or equal to zero and less than equal or equal to one. a
c   reasonable value for eps is sqrt(2./float(n)).
c
c   ys is an array of length at least n.
c
c   ysp is an array of length at least n.
c
c   sigma contains the tension factor. this value indicates
c   the degree to which the first derivative part of the
c   smoothing functional is emphasized. if sigma is nearly
c   zero (e. g. .001) the resulting curve is approximately a
c   cubic spline. if sigma is large (e. g. 50.) the
c   resulting curve is nearly a polygonal line. if sigma
c   equals zero a cubic spline results. a standard value for
c   sigma is approximately 1.
c
c and
c
c   td, tsd1, hd, hsd1, hsd2, rd, rsd1, rsd2, rnm1, rn, and
c   v are arrays of length at least n which are used for
c   scratch storage.
c
c on output--
c
c   ys contains the smoothed ordinate values.
c
c   ysp contains the values of the second derivative of the
c   smoothed curve at the given nodes.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 2 if s is negative,
c        = 3 if eps is negative or greater than one,
c        = 4 if x-values are not strictly increasing,
c        = 5 if a d-value is non-positive,
c        = 6 if p is less than or equal to x(n)-x(1).
c
c and
c
c   n, x, y, d, isw, s, eps, and sigma are unaltered.
c
c this subroutine references package modules ftstore, terms,
c and snhcsh.
c
c-----------------------------------------------------------
c
      if (n .lt. 2) go to 25
      if (s .lt. 0.) go to 26
      if (eps .lt. 0. .or. eps .gt. 1.) go to 27
      if (p .le. x(n)-x(1)) go to 30
      ierr = 0
      q = 0.
      rsd1(1) = 0.
      rsd2(1) = 0.
      rsd2(2) = 0.
      rsd1(n-1) = 0.
      rsd2(n-1) = 0.
      rsd2(n) = 0.
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n)/p
c
c form t matrix and second differences of y into ys
c
      nm1 = n-1
      nm2 = n-2
      nm3 = n-3
      delxi1 = x(1)+p-x(n)
      delyi1 = (y(1)-y(n))/delxi1
      call terms (dim1,tsd1(1),sigmap,delxi1)
      hsd1(1) = 1./delxi1
      do 1 i = 1,n
        ip1 = i+1
        if (i .eq. n) ip1 = 1
        delxi = x(ip1)-x(i)
        if (i .eq. n) delxi = x(1)+p-x(n)
        if (delxi .le. 0.) go to 28
        delyi = (y(ip1)-y(i))/delxi
        ys(i) = delyi-delyi1
        call terms (di,tsd1(ip1),sigmap,delxi)
        td(i) = di+dim1
        hd(i) = -(1./delxi+1./delxi1)
        hsd1(ip1) = 1./delxi
        delxi1 = delxi
        delyi1 = delyi
    1   dim1 = di
      hsd11 = hsd1(1)
      if (n .ge. 3) go to 2
      tsd1(2) = tsd1(1)+tsd1(2)
      tsd1(1) = 0.
      hsd1(2) = hsd1(1)+hsd1(2)
      hsd1(1) = 0.
c
c calculate lower and upper tolerances
c
    2 sl = s*(1.-eps)
      su = s*(1.+eps)
      if (d(1) .le. 0.) go to 29
      if (isw .eq. 1) go to 5
c
c form h matrix - d array
c
      betapp = hsd1(n)*d(n)*d(n)
      betap = hsd1(1)*d(1)*d(1)
      alphap = hd(n)*d(n)*d(n)
      im1 = n
      sumd = 0.
      sumy = 0.
      do 3 i = 1,n
        disq = d(i)*d(i)
        sumd = sumd+1./disq
        sumy = sumy+y(i)/disq
        ip1 = i+1
        if (i .eq. n) ip1 = 1
        alpha = hd(i)*disq
        if (d(ip1) .le. 0.) go to 29
        hsd1ip = hsd1(ip1)
        if (i .eq. n) hsd1ip = hsd11
        beta = hsd1ip*d(ip1)*d(ip1)
        hd(i) = (hsd1(i)*d(im1))**2+alpha*hd(i)
     *                             +beta*hsd1ip
        hsd2(i) = hsd1(i)*betapp
        hsd1(i) = hsd1(i)*(alpha+alphap)
        im1 = i
        alphap = alpha
        betapp = betap
    3   betap = beta
      if (n .eq. 3) hsd1(3) = hsd1(3)+hsd2(2)
c
c test for straight line fit
c
      con = sumy/sumd
      sum = 0.
      do 4 i = 1,n
    4   sum = sum+((y(i)-con)/d(i))**2
      if (sum .le. su) go to 23
      go to 8
c
c form h matrix - d constant
c
    5 sl = d(1)*d(1)*sl
      su = d(1)*d(1)*su
      hsd1p = hsd1(n)
      hdim1 = hd(n)
      sumy = 0.
      do 6 i = 1,n
        sumy = sumy+y(i)
        hsd1ip = hsd11
        if (i .lt. n) hsd1ip = hsd1(i+1)
        hdi = hd(i)
        hd(i) = hsd1(i)*hsd1(i)+hdi*hdi+hsd1ip*hsd1ip
        hsd2(i) = hsd1(i)*hsd1p
        hsd1p = hsd1(i)
        hsd1(i) = hsd1p*(hdi+hdim1)
    6   hdim1 = hdi
      if (n .eq. 3) hsd1(3) = hsd1(3)+hsd2(2)
c
c test for straight line fit
c
      con = sumy/float(n)
      sum = 0.
      do 7 i = 1,n
    7   sum = sum+(y(i)-con)**2
      if (sum .le. su) go to 23
c
c top of iteration
c cholesky factorization of q*t+h into r
c
c
c i = 1
c
    8 rd(1) = 1./(q*td(1)+hd(1))
      rnm1(1) = hsd2(1)
      yspnm1 = ys(nm1)
      rn(1) = q*tsd1(1)+hsd1(1)
      yspn = ys(n)
      ysp(1) = ys(1)
      rsd1i = q*tsd1(2)+hsd1(2)
      rsd1(2) = rsd1i*rd(1)
      sumnm1 = 0.
      sum2 = 0.
      sumn = 0.
      if (n .eq. 3) go to 11
      if (n .eq. 2) go to 12
c
c i = 2
c
      rd(2) = 1./(q*td(2)+hd(2)-rsd1i*rsd1(2))
      rnm1(2) = -rnm1(1)*rsd1(2)
      rn(2) = hsd2(2)-rn(1)*rsd1(2)
      ysp(2) = ys(2)-rsd1(2)*ysp(1)
      if (n .eq. 4) go to 10
      do 9 i = 3,nm2
        rsd2i = hsd2(i)
        rsd1i = q*tsd1(i)+hsd1(i)-rsd2i*rsd1(i-1)
        rsd2(i) = rsd2i*rd(i-2)
        rsd1(i) = rsd1i*rd(i-1)
        rd(i) = 1./(q*td(i)+hd(i)-rsd1i*rsd1(i)
     *                           -rsd2i*rsd2(i))
        rnm1(i) = -rnm1(i-2)*rsd2(i)-rnm1(i-1)*rsd1(i)
        rnm1t = rnm1(i-2)*rd(i-2)
        sumnm1 = sumnm1+rnm1t*rnm1(i-2)
        rnm1(i-2) = rnm1t
        sum2 = sum2+rnm1t*rn(i-2)
        yspnm1 = yspnm1-rnm1t*ysp(i-2)
        rn(i) = -rn(i-2)*rsd2(i)-rn(i-1)*rsd1(i)
        rnt = rn(i-2)*rd(i-2)
        sumn = sumn+rnt*rn(i-2)
        rn(i-2) = rnt
        yspn = yspn-rnt*ysp(i-2)
    9   ysp(i) = ys(i)-rsd1(i)*ysp(i-1)-rsd2(i)*ysp(i-2)
c
c i = n-3
c
   10 rnm1(nm3) = hsd2(nm1)+rnm1(nm3)
      rnm1(nm2) = rnm1(nm2)-hsd2(nm1)*rsd1(nm2)
      rnm1t = rnm1(nm3)*rd(nm3)
      sumnm1 = sumnm1+rnm1t*rnm1(nm3)
      rnm1(nm3) = rnm1t
      sum2 = sum2+rnm1t*rn(nm3)
      yspnm1 = yspnm1-rnm1t*ysp(nm3)
      rnt = rn(nm3)*rd(nm3)
      sumn = sumn+rnt*rn(nm3)
      rn(nm3) = rnt
      yspn = yspn-rnt*ysp(nm3)
c
c i = n-2
c
   11 rnm1(nm2) = q*tsd1(nm1)+hsd1(nm1)+rnm1(nm2)
      rnm1t = rnm1(nm2)*rd(nm2)
      sumnm1 = sumnm1+rnm1t*rnm1(nm2)
      rnm1(nm2) = rnm1t
      rn(nm2) = hsd2(n)+rn(nm2)
      sum2 = sum2+rnm1t*rn(nm2)
      yspnm1 = yspnm1-rnm1t*ysp(nm2)
      rnt = rn(nm2)*rd(nm2)
      sumn = sumn+rnt*rn(nm2)
      rn(nm2) = rnt
      yspn = yspn-rnt*ysp(nm2)
c
c i = n-1
c
   12 rd(nm1) = 1./(q*td(nm1)+hd(nm1)-sumnm1)
      ysp(nm1) = yspnm1
      rn(nm1) = q*tsd1(n)+hsd1(n)-sum2
      rnt = rn(nm1)*rd(nm1)
      sumn = sumn+rnt*rn(nm1)
      rn(nm1) = rnt
      yspn = yspn-rnt*ysp(nm1)
c
c i = n
c
      rdn = q*td(n)+hd(n)-sumn
      rd(n) = 0.
c
c Modified test based on communication with Alan Cline, 21-May-2002.
c Problems with the original test (rdn .gt. 0.) surfaced in a demo
c example run on a Linux system.
c
      if (rdn .gt. 0. .and. q .ne. 0.) rd(n) = 1./rdn
      ysp(n) = yspn
c
c back solve of r(transpose)* r * ysp = ys
c
      ysp(n) = rd(n)*ysp(n)
      ysp(nm1) = rd(nm1)*ysp(nm1)-rn(nm1)*ysp(n)
      if (n .eq. 2) go to 14
      yspn = ysp(n)
      yspnm1 = ysp(nm1)
      do 13 ibak = 1,nm2
        i = nm1-ibak
   13   ysp(i) = rd(i)*ysp(i)-rsd1(i+1)*ysp(i+1)
     *                  -rsd2(i+2)*ysp(i+2)-rnm1(i)*yspnm1
     *                  -rn(i)*yspn
   14 sum = 0.
      delyi1 = (ysp(1)-ysp(n))/(x(1)+p-x(n))
      if (isw .eq. 1) go to 16
c
c calculation of residual norm
c  - d array
c
      do 15 i = 1,nm1
        delyi = (ysp(i+1)-ysp(i))/(x(i+1)-x(i))
        v(i) = (delyi-delyi1)*d(i)*d(i)
        sum = sum+v(i)*(delyi-delyi1)
   15   delyi1 = delyi
      delyi = (ysp(1)-ysp(n))/(x(1)+p-x(n))
      v(n) = (delyi-delyi1)*d(n)*d(n)
      go to 18
c
c calculation of residual norm
c  - d constant
c
   16 do 17 i = 1,nm1
        delyi = (ysp(i+1)-ysp(i))/(x(i+1)-x(i))
        v(i) = delyi-delyi1
        sum = sum+v(i)*(delyi-delyi1)
   17   delyi1 = delyi
      delyi = (ysp(1)-ysp(n))/(x(1)+p-x(n))
      v(n) = delyi-delyi1
   18   sum = sum+v(n)*(delyi-delyi1)
c
c test for convergence
c
      if (sum .le. su) go to 21
c
c calculation of newton correction
c
      f = 0.
      g = 0.
      rnm1sm = 0.
      rnsm = 0.
      im1 = n
      if (n .eq. 2) go to 20
      wim2 = 0.
      wim1 = 0.
      do 19 i = 1,nm2
        tui = tsd1(i)*ysp(im1)+td(i)*ysp(i)
     *                        +tsd1(i+1)*ysp(i+1)
        wi = tui-rsd1(i)*wim1-rsd2(i)*wim2
        rnm1sm = rnm1sm-rnm1(i)*wi
        rnsm = rnsm-rn(i)*wi
        f = f+tui*ysp(i)
        g = g+wi*wi*rd(i)
        im1 = i
        wim2 = wim1
   19   wim1 = wi
   20 tui = tsd1(nm1)*ysp(im1)+td(nm1)*ysp(nm1)
     *      +tsd1(n)*ysp(n)
      wi = tui+rnm1sm
      f = f+tui*ysp(nm1)
      g = g+wi*wi*rd(nm1)
      tui = tsd1(n)*ysp(nm1)+td(n)*ysp(n)
     *      +tsd1(1)*ysp(1)
      wi = tui+rnsm-rn(nm1)*wi
      f = f+tui*ysp(n)
      g = g+wi*wi*rd(n)
      h = f-q*g
      if (h .le. 0.) go to 21
c
c update q - newton step
c
      step = (sum-sqrt(sum*sl))/h
      if (sl .ne. 0.) step = step*sqrt(sum/sl)
      if (ftstore(q+step) .eq. q) go to 21
      q = q+step
      go to 8
c
c store smoothed y-values and second derivatives
c
   21 do 22 i = 1,n
        ys(i) = y(i)-v(i)
   22   ysp(i) = q*ysp(i)
      return
c
c store constant ys and zero ysp
c
   23 do 24 i = 1,n
        ys(i) = con
   24   ysp(i) = 0.
      return
c
c n less than 2
c
   25 ierr = 1
      return
c
c s negative
c
   26 ierr = 2
      return
c
c eps negative or greater than 1
c
   27 ierr = 3
      return
c
c x-values not strictly increasing
c
   28 ierr = 4
      return
c
c weight non-positive
c
   29 ierr = 5
      return
c
c incorrect period
c
   30 ierr = 6
      return
      end


C
C	VICAR program ASTERTEMP, used to convert from upwelling radiance at
C	surface to spectral kinetic temperature of the surface, assuming a
C	given spectral emissivity and downwelling sky irradiance.  This
C	program works on the thermal IR bands of ASTER (Channels 10-14).
C
C	Ron Alley	11 June 2000
C
	INCLUDE 'VICMAIN_FOR'
	SUBROUTINE MAIN44
C
	REAL EMIS(5),SKY(5),RAD(2000),RLUT(32767,5)
	REAL PI/3.141593/
	INTEGER*2 ITEMP(2000)
	LOGICAL QINTERP,XVPTST
	CHARACTER*80 INP_NAMES(2)
C						Open datasets, get size field
	CALL XVUNIT(IN,'INP',1,ISTAT,' ')
	CALL XVOPEN(IN,ISTAT,'IO_ACT','SA','OPEN_ACT','SA',
     +		    'U_FORMAT','REAL',' ')
	CALL XVUNIT(INLUT,'INP',2,ISTAT,' ')
	CALL XVOPEN(INLUT,ISTAT,'IO_ACT','SA','OPEN_ACT','SA',' ')
	CALL XVUNIT(IOUT,'OUT',1,ISTAT,' ')
	CALL XVOPEN(IOUT,ISTAT,'IO_ACT','SA','OPEN_ACT','SA',
     +	           'OP','WRITE','U_FORMAT','HALF','O_FORMAT','HALF',
     +		   'U_NB',5,'U_NL',NL,'U_NS',NS,'U_ORG','BSQ',' ')
	CALL XVSIZE(ISL,ISS,NL,NS,NLIN,NSIN)
C							      update VICAR label
	CALL XLADD(IOUT,'HISTORY','LBL1',
     +		 'ASTER Temperature Image',ISTAT,'FORMAT','STRING',' ')
	CALL XLADD(IOUT,'HISTORY','LBL2','DN = 100*Degrees Celsius',
     +		   ISTAT,'FORMAT','STRING',' ')
	CALL XVPARM('INP',INP_NAMES,NUM,IDEF,2)
	CALL XLADD(IOUT,'HISTORY','TEMP_LUT',INP_NAMES(2),ISTAT,
     +		   'FORMAT','STRING',' ')
C							      Get the parameters
	CALL XVPARM('SKYRAD',SKY,NUM,IDEF,5)
	CALL XVPARM('EMIS',EMIS,NUM,IDEF,5)
	QINTERP = .NOT. XVPTST('NO')
C
C					    Convert downwelling radiances to the
C						 amount of radiance reflected up
	DO ICHAN=1,5
	    SKY(ICHAN) = (1.0-EMIS(ICHAN))*SKY(ICHAN)/PI
	END DO
C					       Load the temperature lookup table
	DO ICHAN=1,5
	    CALL XVREAD(INLUT,RLUT(1,ICHAN),ISTAT,' ')
	END DO
	CALL XVCLOSE(INLUT,ISTAT,' ')
C								   Do conversion
	IF (QINTERP) THEN
	    CALL XVMESSAGE(' Interpolating lookup table values',' ')
	    DO ICHAN=1,5
		DO ILINE=ISL,ISL+NL-1
		    CALL XVREAD(IN,RAD,ISTAT,'LINE',ILINE,'BAND',ICHAN,
     +				'SAMP',ISS,'NSAMPS',NS,' ')
		    DO ISAMP=1,NS
			IF (RAD(ISAMP) .LE. 0.0) THEN
			    ITEMP(ISAMP) = -27315
			ELSE
			    RADX = (RAD(ISAMP)-SKY(ICHAN)) / EMIS(ICHAN)
			    INDEX = MAX(MIN(INT(RADX),32766),1)
			    FRAC = RADX - FLOAT(INDEX)
			    TEMP = (1.0-FRAC)*RLUT(INDEX,ICHAN) +
     +				   FRAC*RLUT(INDEX+1,ICHAN) - 273.15
			    ITEMP(ISAMP) = MAX(MIN(NINT(100.0*TEMP),
     +						   32767), -32768)
			END IF
		    END DO
		    CALL XVWRIT(IOUT,ITEMP,ISTAT,' ')
		END DO
	    END DO
	ELSE
	    CALL XVMESSAGE(' Using closest lookup table values',' ')
	    DO ICHAN=1,5
		DO ILINE=ISL,ISL+NL-1
		    CALL XVREAD(IN,RAD,ISTAT,'LINE',ILINE,'BAND',ICHAN,
     +				'SAMP',ISS,'NSAMPS',NS,' ')
		    DO ISAMP=1,NS
			IF (RAD(ISAMP) .LE. 0.0) THEN
			    ITEMP(ISAMP) = -27315
			ELSE
			    RADX = (RAD(ISAMP)-SKY(ICHAN)) / EMIS(ICHAN)
			    INDEX = MAX(MIN(NINT(RADX),32767),1)
			    TEMP = RLUT(INDEX,ICHAN) - 273.15
			    ITEMP(ISAMP) = MAX(MIN(NINT(100.0*TEMP),
     +					       32767),-32768)
			END IF
		    END DO
		    CALL XVWRIT(IOUT,ITEMP,ISTAT,' ')
		END DO
	    END DO
	END IF
C								Close datasets
	CALL XVCLOSE(IN,ISTAT,' ')
	CALL XVCLOSE(IOUT,ISTAT,' ')
	RETURN
	END


      SUBROUTINE STPPHI(CA,BLOC,PM,NS)
C     PHI-FUNCTIONS FOR EACH STRIP (NACA TM 991, PG 19).
C     THE FOLLOWING FUNCTIONS ARE NOT COMPUTED, THEY ARE LEFT ZEROED
C         - NUMBERS  20, 22-30, 33, 34
      DIMENSION CA(1),BLOC(1),PM(37,NS)
      DIMENSION P(37)
      PI=3.141593
      DO 100 N=1,NS
      DO 10 I=1,37
   10 P(I)=0.0
      CT=CA(N)/BLOC(N)
      IF(CT.LE.1.0E-03) GO TO 50
      C=CT-1.0
      C2=C*C
      S2=1.0-C2
      S =SQRT(S2)
      X=ATAN2(S,C)
C     WATCH THIS TRIG
      PMX=PI-X
      P(1)  = PMX + S
      P(2)  = PMX*(1.+2.*C) + S*(2.+C)
      P(3)  = PMX + S*C
      P(4)  = PMX*2.*C  + S*2.*(2.+C2)/3.
      P(5)  = S*(1.-C)
      P(6)  = 2.*PMX + S*2.*(2.-C)*(1.+2.*C)/3.
      P(7)  = PMX*(0.5+2.*C) + S*(8.+5.*C+4.*C2-2.*C2*C)/6.
      P(8)  = PMX*(-1.+2.*C) + S*(2.-C)
      P(9)  = PMX*(1.+2.*C) + S*(2.+3.*C+4.*C2)/3.
      P(11) = P(2)*P(3)
      P(12) = PMX*PMX*(0.5+4.*C2) + PMX*S*C*(7.+2.*C2) + S2*(2.+2.5*C2)
      P(13) = SIN(0.5*X)/COS(0.5*X)
      P(14) = 2.*S
      P(15) = P(13)-P(14)
      P(16) = P(1)*P(14)
      P(17) = P(3)**2 +S2*S2
      P(18) = -P(13)*(PMX*(1.+2.*C)-S*C)
      P(19) = P(3)*S
      P(21) = -2.*(C + ALOG(S2) )
      P(31) = PMX - S
      P(32) = PMX + S*(1.+2.*C)
      P(35) = 2.*S2
      P(36) = P(32)*P(3) + 2.*S2*S2
      P(37) = P(3)*( P(2) - P(3) )
      P(10) = P(31)*P(5)
   50 DO 60 I=1,37
   60 PM(I,N)= P(I)
  100 CONTINUE
      RETURN
      END


      INTEGER N_HK, N_RT, N_TPPT
      REAL, CLDIMENSION(1,6) :: HK_RANGE
      REAL, DIMENSION(1,5) :: RT_RANGE
      REAL, DIMENSION(1,3) :: TPPT_RANGE
      REAL, DIMENSION(6,5,3) :: CEI_TABLE

      N_HK   = 6
      N_RT   = 5
      N_TPPT = 3

      HK_RANGE(1,1) = 7.0E0/5.0E0
      HK_RANGE(1,2) = 8.0E0/5.0E0
      HK_RANGE(1,3) = 9.0E0/5.0E0
      HK_RANGE(1,4) = 2.0E0
      HK_RANGE(1,5) = 1.1E1/5.0E0
      HK_RANGE(1,6) = 1.2E1/5.0E0

      RT_RANGE(1,1) = 8.0E2
      RT_RANGE(1,2) = 1.6E3
      RT_RANGE(1,3) = 3.2E3
      RT_RANGE(1,4) = 6.4E3
      RT_RANGE(1,5) = 1.28E4

      TPPT_RANGE(1,2) = 5.0E1
      TPPT_RANGE(1,3) = 1.0E2

      CEI_TABLE(1,1,2) = 2.872680733645279E-1
      CEI_TABLE(1,1,3) = 7.749716029388073E-1
      CEI_TABLE(1,2,2) = 2.039644535775086E-1
      CEI_TABLE(1,2,3) = 5.924318712770024E-1
      CEI_TABLE(1,3,2) = 1.443700895511554E-1
      CEI_TABLE(1,3,3) = 4.633605499494066E-1
      CEI_TABLE(1,4,2) = 1.004911816583118E-1
      CEI_TABLE(1,4,3) = 3.699178360235265E-1
      CEI_TABLE(1,5,2) = 6.733821510084832E-2
      CEI_TABLE(1,5,3) = 3.001150710959782E-1
      CEI_TABLE(2,1,2) = 2.15679590997346E-1
      CEI_TABLE(2,1,3) = 7.032901821333088E-1
      CEI_TABLE(2,2,2) = 1.38804898233508E-1
      CEI_TABLE(2,2,3) = 5.190092839824512E-1
      CEI_TABLE(2,3,2) = 8.540581665774229E-2
      CEI_TABLE(2,3,3) = 3.955784955811628E-1
      CEI_TABLE(2,4,2) = 4.687087515554092E-2
      CEI_TABLE(2,4,3) = 3.083346385006999E-1
      CEI_TABLE(2,5,2) = 1.823657536308939E-2
      CEI_TABLE(2,5,3) = 2.440957040061711E-1
      CEI_TABLE(3,1,2) = 1.351465804725244E-1
      CEI_TABLE(3,1,3) = 5.944539142560507E-1
      CEI_TABLE(3,2,2) = 6.948210676888233E-2
      CEI_TABLE(3,2,3) = 4.287398277454012E-1
      CEI_TABLE(3,3,2) = 2.446511411233687E-2
      CEI_TABLE(3,3,3) = 3.186820261578073E-1
      CEI_TABLE(3,4,3) = 2.413596674968999E-1
      CEI_TABLE(3,5,3) = 1.847296324018285E-1
      CEI_TABLE(4,1,2) = 5.497866179885413E-2
      CEI_TABLE(4,1,3) = 4.803653864888552E-1
      CEI_TABLE(4,2,2) = 1.021202577184958E-3
      CEI_TABLE(4,2,3) = 3.363622877434947E-1
      CEI_TABLE(4,3,3) = 2.409694933687837E-1
      CEI_TABLE(4,4,3) = 1.741794817845234E-1
      CEI_TABLE(4,5,3) = 1.254740804951762E-1
      CEI_TABLE(5,1,3) = 3.674090874850944E-1
      CEI_TABLE(5,2,3) = 2.450395028559258E-1
      CEI_TABLE(5,3,3) = 1.641449222712615E-1
      CEI_TABLE(5,4,3) = 1.077346391909527E-1
      CEI_TABLE(5,5,3) = 6.682986734578829E-2
      CEI_TABLE(6,1,3) = 2.566658710465144E-1
      CEI_TABLE(6,2,3) = 1.54999205732387E-1
      CEI_TABLE(6,3,3) = 8.805729195880023E-2
      CEI_TABLE(6,4,3) = 4.168825812144024E-2
      CEI_TABLE(6,5,3) = 8.364384007724771E-3