      subroutine r8vecbicub_bmag(ict,ivec,xvec,yvec,ivd,fvalBR,
     >     fvalBPHI,fvalBZ,
     >     nx,xpkg,ny,ypkg,fsplBR,fsplBPHI,fsplBZ,
     >     inf2,iwarn,ier)
c
c  vectorized spline evaluation routine -- 2d *compact* spline
c  1.  call vectorized zone lookup routine
c  2.  call vectorized spline evaluation routine
c
c--------------------------
c  input:
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER iwarn1,iwarn2
!============
      integer ict(6)                    ! selector:
c        ict(1)=1 for f      (don't evaluate if ict(1)=0)
c        ict(2)=1 for df/dx  (don't evaluate if ict(2)=0)
c        ict(3)=1 for df/dy  (don't evaluate if ict(3)=0)
c        ict(4)=1 for d2f/dx2 (don't evaluate if ict(4)=0)
c        ict(5)=1 for d2f/dy2 (don't evaluate if ict(5)=0)
c        ict(6)=1 for d2f/dxdy (don't evaluate if ict(6)=0)
c
      integer ivec                      ! vector dimensioning
c
c    ivec-- number of vector pts (spline values to look up)
c
c  list of (x,y) pairs:
c
      REAL*8 xvec(ivec)                   ! x-locations at which to evaluate
      REAL*8 yvec(ivec)                   ! y-locations at which to evaluate
c
      integer ivd                       ! 1st dimension of output array
c
c    ivd -- 1st dimension of fval, .ge.ivec
c
c output:
      REAL*8 fvalBR(ivd,*)      ! output array
      REAL*8 fvalBPHI(ivd,*)    ! output array
      REAL*8 fvalBZ(ivd,*)      ! output array

c
c  fval(1:ivec,1) -- values as per 1st non-zero ict(...) element
c  fval(1:ivec,2) -- values as per 2nd non-zero ict(...) element
c   --etc--
c
c input:
      integer nx,ny                     ! dimension of spline grids
      REAL*8 xpkg(nx,4)                   ! x grid "package" (cf genxpkg)
      REAL*8 ypkg(ny,4)                   ! y grid "package" (cf genxpkg)
      integer inf2                      ! fspl 3rd array dimension, .ge.nx
      REAL*8 fsplBR(0:3,inf2,ny)  ! (compact) spline coefficients
      REAL*8 fsplBPHI(0:3,inf2,ny)! (compact) spline coefficients
      REAL*8 fsplBZ(0:3,inf2,ny)  ! (compact) spline coefficients

c
c output:
c condition codes, 0 = normal return
      integer iwarn                     ! =1 if an x value was out of range
      integer ier                       ! =1 if argument error detected
c
c---------------------------------------------------------------
c  local arrays
c
      integer ix(ivec)                  ! zone indices {j}
      REAL*8 dxn(ivec)                    ! normalized displacements w/in zones
      REAL*8 hx(ivec)                     ! h(j) vector
      REAL*8 hxi(ivec)                    ! 1/h(j) vector
c
      integer iy(ivec)                  ! zone indices {j}
      REAL*8 dyn(ivec)                    ! normalized displacements w/in zones
      REAL*8 hy(ivec)                     ! h(j) vector
      REAL*8 hyi(ivec)                    ! 1/h(j) vector
c
c---------------------------------------------------------------
c
c  error checks
c
      ier=0
c
      if(nx.lt.2) then
         write(6,*) ' ?vecbicub:  nx.lt.2:  nx = ',nx
         ier=1
      endif
c
      if(ny.lt.2) then
         write(6,*) ' ?vecbicub:  ny.lt.2:  ny = ',ny
         ier=1
      endif
c
      if(ivec.le.0) then
         write(6,*) ' ?vecbicub:  vector dimension .le. 0:  ivec = ',
     >      ivec
         ier=1
      endif
c
      if(ivd.lt.ivec) then
         write(6,*)
     >      ' ?vecbicub:  output vector dimension less than input ',
     >      'vector dimension.'
         write(6,*) ' ivec=',ivec,' ivd=',ivd
         ier=1
      endif
c
      if(ier.ne.0) return
c
c  vectorized lookup
c
      ix=0
      iy=0
      call r8xlookup(ivec,xvec,nx,xpkg,2,ix,dxn,hx,hxi,iwarn1)
      call r8xlookup(ivec,yvec,ny,ypkg,2,iy,dyn,hy,hyi,iwarn2)
      iwarn=iwarn1+iwarn2
c
c  vectorized evaluation
c
      call r8fvbicub(ict,ivec,ivd,fvalBR,ix,iy,dxn,dyn,
     >     hx,hxi,hy,hyi,fsplBR,inf2,ny)
      call r8fvbicub(ict,ivec,ivd,fvalBPHI,ix,iy,dxn,dyn,
     >     hx,hxi,hy,hyi,fsplBPHI,inf2,ny)
      call r8fvbicub(ict,ivec,ivd,fvalBZ,ix,iy,dxn,dyn,
     >     hx,hxi,hy,hyi,fsplBZ,inf2,ny)

      return
      end


      SUBROUTINE PW92C( NSPIN, DENS, EC, VC )

C ********************************************************************
C Implements the Perdew-Wang'92 local correlation (beyond RPA).
C Ref: J.P.Perdew & Y.Wang, PRB, 45, 13244 (1992)
C Written by L.C.Balbas and J.M.Soler. Dec'96.  Version 0.5.
C ********* INPUT ****************************************************
C INTEGER NSPIN       : Number of spin polarizations (1 or 2)
C REAL*8  DENS(NSPIN) : Local (spin) density
C ********* OUTPUT ***************************************************
C REAL*8  EC        : Correlation energy density
C REAL*8  VC(NSPIN) : Correlation (spin) potential
C ********* UNITS ****************************************************
C Densities in electrons per Bohr**3
C Energies in Hartrees
C ********* ROUTINES CALLED ******************************************
C None
C ********************************************************************

C Next line is nonstandard but may be supressed
      IMPLICIT          NONE

C Argument types and dimensions
      INTEGER           NSPIN
      DOUBLE PRECISION  DENS(NSPIN), EC, VC(NSPIN)

C Internal variable declarations
      INTEGER           IG
      DOUBLE PRECISION  A(0:2), ALPHA1(0:2), B, BETA(0:2,4), C,
     .                  DBDRS, DECDD(2), DECDRS, DECDZ, DENMIN, DFDZ,
     .                  DGDRS(0:2), DCDRS, DRSDD, DTOT, DZDD(2),
     .                  F, FPP0, FOUTHD, G(0:2), HALF,
     .                  P(0:2), PI, RS, THD, THRHLF, ZETA

C Fix lower bound of density to avoid division by zero
      PARAMETER ( DENMIN = 1.D-12 )

C Fix some numerical constants
      PARAMETER ( FOUTHD=4.D0/3.D0, HALF=0.5D0,
     .            THD=1.D0/3.D0, THRHLF=1.5D0 )

C Parameters from Table I of Perdew & Wang, PRB, 45, 13244 (92)
      DATA P      / 1.00,     1.00,     1.00     /
      DATA A      / 0.031091, 0.015545, 0.016887 /
      DATA ALPHA1 / 0.21370,  0.20548,  0.11125  /
      DATA BETA   / 7.5957,  14.1189,  10.357,
     .              3.5876,   6.1977,   3.6231,
     .              1.6382,   3.3662,   0.88026,
     .              0.49294,  0.62517,  0.49671 /

C Find rs and zeta
      PI = 4 * ATAN(1.D0)
      IF (NSPIN .EQ. 1) THEN
        DTOT = MAX( DENMIN, DENS(1) )
        ZETA = 0
        RS = ( 3 / (4*PI*DTOT) )**THD
C       Find derivatives dRs/dDens and dZeta/dDens
        DRSDD = - RS / DTOT / 3
        DZDD(1) = 0
      ELSE
        DTOT = MAX( DENMIN, DENS(1)+DENS(2) )
        ZETA = ( DENS(1) - DENS(2) ) / DTOT
        RS = ( 3 / (4*PI*DTOT) )**THD
        DRSDD = - RS / DTOT / 3
        DZDD(1) =   1 / DTOT - ZETA / DTOT
        DZDD(2) = - 1 / DTOT - ZETA / DTOT
      ENDIF

C Find eps_c(rs,0)=G(0), eps_c(rs,1)=G(1) and -alpha_c(rs)=G(2)
C using eq.(10) of cited reference (Perdew & Wang, PRB, 45, 13244 (92))
      DO 20 IG = 0,2
        B = BETA(IG,1) * RS**HALF   +
     .      BETA(IG,2) * RS         +
     .      BETA(IG,3) * RS**THRHLF +
     .      BETA(IG,4) * RS**(P(IG)+1)
        DBDRS = BETA(IG,1) * HALF      / RS**HALF +
     .          BETA(IG,2)                         +
     .          BETA(IG,3) * THRHLF    * RS**HALF +
     .          BETA(IG,4) * (P(IG)+1) * RS**P(IG)
        C = 1 + 1 / (2 * A(IG) * B)
        DCDRS = - (C-1) * DBDRS / B
        G(IG) = - 2 * A(IG) * ( 1 + ALPHA1(IG)*RS ) * LOG(C)
        DGDRS(IG) = - 2*A(IG) * ( ALPHA1(IG) * LOG(C) +
     .                            (1+ALPHA1(IG)*RS) * DCDRS / C )
   20 CONTINUE

C Find f''(0) and f(zeta) from eq.(9)
      C = 1 / (2**FOUTHD - 2)
      FPP0 = 8 * C / 9
      F = ( (1+ZETA)**FOUTHD + (1-ZETA)**FOUTHD - 2 ) * C
      DFDZ = FOUTHD * ( (1+ZETA)**THD - (1-ZETA)**THD ) * C

C Find eps_c(rs,zeta) from eq.(8)
      EC = G(0) - G(2) * F / FPP0 * (1-ZETA**4) +
     .    (G(1)-G(0)) * F * ZETA**4
      DECDRS = DGDRS(0) - DGDRS(2) * F / FPP0 * (1-ZETA**4) +
     .        (DGDRS(1)-DGDRS(0)) * F * ZETA**4
      DECDZ = - G(2) / FPP0 * ( DFDZ*(1-ZETA**4) - F*4*ZETA**3 ) +
     .        (G(1)-G(0)) * ( DFDZ*ZETA**4 + F*4*ZETA**3 )

C Find correlation potential
      IF (NSPIN .EQ. 1) THEN
        DECDD(1) = DECDRS * DRSDD
        VC(1) = EC + DTOT * DECDD(1)
      ELSE
        DECDD(1) = DECDRS * DRSDD + DECDZ * DZDD(1)
        DECDD(2) = DECDRS * DRSDD + DECDZ * DZDD(2)
        VC(1) = EC + DTOT * DECDD(1)
        VC(2) = EC + DTOT * DECDD(2)
      ENDIF

      END


      double precision function DBINOM(N, K)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1998-01-23 DBINOM  Krogh  Work around for HP compiler bug.
c>> 1997-04-14 DBINOM  Krogh  Added external statement, aint => anint.
c>> 1995-12-14 DBINOM  Krogh  Initial Code
c--D replaces "?": ?BINOM, ?LGAMA
c
c                                    ( N }
c  Computes the binomial coefficient (   }.  Require 0 .le. K .le. N.
c                                    ( K )
c
c **************** Variable Definitions ********************************
c
c D1MACH D1MACH returns the largest floating point number
c DBINOM The result returned for the Binomial Coefficient.  If an error
c    returns, this is set to -1.
c DLGAMA MATH77 library for computing the log of the gamma function.
c BIG    Used in testing for possible overflow.
c BIGTST BIG / MAXN, used to test for overflow when computing factorials
c BIGLOG Used to checking for overflow before exponentiating.
c EXERR  If the result is bigger than EXERR some extra work is done
c    to eliminate the effect of small round off errors.
c FAC    Array of factorials.  For N .le. LBND(1), N! = FAC(N). For
c    LBND(1) .lt. N .le. LBND(2), N! = FAC(LBND(1)) * FAC(N).  For
c    LBND(j) .lt. N .le. LBND(j+1), N! = FAC(LBND(1)) * ... *
c    FAC(LBND(j)) * FAC(N).]
c FNI    Floating value for NI.
c I      Temporary index.
c IERR   Index for error message.
c K      Formal argumtent, see description above.
c K1,K2,K3  Indices used in untangling factorials.  K1 is originally for
c        NI, K2 for NMK, and K3 for KI.
c KI     Intenal value for K = min (K, N - K)
c LBND   Array used to obtain large factorials, see FAC above.
c KBND   Last index used in LBND.
c MAXL   Size of the array LBND.  This is a little larger than needed
c        to handle N = MAXN in single precision IEEE arithmetic.  May
c        need to be bigger if MAXN is increased.
c MAXN   Size of the array FAC.  This is probably larger than needed for
c        single precision in most cases.
c N      Formal argumtent, see description above.
c NC     Highest factorial that has been computed.
c NI     Internal value for N.
c NMK    NI - KI
c PRIMES A table of primes.  The last entry must be equal to the third
c        to the last entry.
c TP     Used for temporary storage.
c TP1    Used for temporary storage.
c
c **************** Variable Declarations *******************************
c
      external D1MACH, DLGAMA
      integer N, K
      integer MAXN, MAXL
      parameter (MAXN = 150, MAXL = 12)
      integer I, IERR, K1, K2, K3, KBND, KI, LBND(MAXL), NC, NI, NMK,
     2  PRIMES(3:33)
      double precision BIG, BIGTST, BIGLOG, EXERR, FAC(MAXN), FNI,
     1  D1MACH, TP, TP1, DLGAMA
      character ERMSG(2)*32
      save BIG, BIGTST, BIGLOG, EXERR, FAC, KBND, LBND, NC
      data NC, KBND / 0, 1 /
      data ERMSG / 'Bad value for N or K, ', 'Result would overflow,' /
      data PRIMES / 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61,
     1  67, 71, 73, 79, 83, 89, 97,101,103,107,109,113,127,131,137,139,
     2 149, 139 /
c      151,157,163,167, 173,179,181,191,193,197,199
c
c **************** Start of Executable Code ****************************
c
      NI = N
      if (NI .lt. 0) go to 300
      KI = min(K, NI - K)
      if (KI .le. 2) then
         if (KI .lt. 1) then
            TP = 1.D0
            if (KI .ne. 0) go to 300
         else
            FNI = NI
            if (KI .eq. 1) then
               TP = FNI
            else
               TP = .5D0 * (FNI * (FNI - 1.D0))
            end if
         end if
      else
         NMK = NI - KI
         if (NI .gt. NC) then
            if (NC .eq. 0) then
               BIG = D1MACH(2)
               BIGTST = BIG / dble(MAXN)
               BIGLOG = log(BIG) - .1D0
               EXERR = .01D0 / D1MACH(4)
               FAC(1) = 1.D0
               FAC(2) = 2.D0
               NC = 2
            end if
            if (NI .gt. MAXN) then
                TP = DLGAMA(dble(NI+1)) - DLGAMA(dble(KI+1)) -
     1              DLGAMA(dble(NMK+1))
                if (TP .gt. BIGLOG) go to 320
                TP = exp(TP)
                go to 250
            end if
            TP = NC
            do 100 I = NC, NI - 1
               TP = TP + 1.D0
               if (FAC(I).ge.BIGTST) then
                  LBND(KBND) = I
                  KBND = KBND + 1
                  FAC(I+1) = TP
               else
                  FAC(I+1) = TP * FAC(I)
               end if
  100       continue
            NC = NI
            LBND(KBND) = NI
         end if
         if (NI .le. LBND(1)) then
            TP = FAC(NI) / (FAC(KI) * FAC(NMK))
         else if (NMK .le. LBND(1)) then
            TP = FAC(NI) * ((FAC(LBND(1)) / (FAC(KI)) / FAC(NMK)))
            if (NI .gt. LBND(2)) TP = TP * FAC(LBND(2))
         else
            K2 = 1
            K3 = 1
            I = 1
            do 120 K1 = 1, MAXL
               if (NI .le. LBND(K1)) go to 140
               if (NMK .gt. LBND(K1)) then
                  K2 = K2 + 1
                  if (KI .gt. LBND(K1)) K3 = K3 + 1
               end if
  120       continue
  140       if (K2 .eq. K1) then
               TP = FAC(NI) / (FAC(NMK) * FAC(KI))
            else
               TP = FAC(LBND(K2)) / FAC(NMK)
  150          K2 = K2 + 1
  160          if (TP .gt. 1.D0) then
                  if (I .lt. K3) then
                     TP = TP / FAC(LBND(I))
                     I = I + 1
                     go to 160
                  end if
                  TP = TP / FAC(KI)
                  do 180 I = K2, K1 - 1
                     if (TP .gt. BIG / FAC(LBND(I))) go to 320
                     TP = TP * FAC(LBND(I))
  180             continue
                  if (TP .gt. BIG / FAC(NI)) go to 320
                  TP = TP * FAC(NI)
               else if (K2 .ne. K1) then
                  TP = TP * FAC(LBND(K2))
                  go to 150
               else
                  TP = TP * FAC(NI) / FAC(KI)
               end if
            end if
         end if
         if (TP .ge. EXERR) then
            I = .2199D0 * dble(NI)
  200       if (PRIMES(I) .le. NMK) then
               I = I + 1
               go to 200
            end if
            if (PRIMES(I) .le. NI) then
               TP1 = PRIMES(I)
               if (PRIMES(I+1) .le. NI) TP1 = TP1 * PRIMES(I+1)
c    anint(TP) avoided below due to bugs in recent HP Fortran compilers.
c               TP = TP1 * anint(TP / TP1)
                TP = .5D0 + (TP / TP1)
                TP = TP1 * (TP - mod(TP, 1.D0))
            end if
         end if
      end if
  250 continue
c     TP = anint(TP)
      TP = (TP + .5D0) - mod(TP + .5D0, 1.D0)
      DBINOM = TP
      return
c
c           Error processing  -- Default is to stop in IERV1.
  300 IERR = 1
      go to 340
  320 IERR = 2
  340 call IERM1('DBINOM', IERR, 2, ERMSG(IERR), ' N ', N, ',')
      call IERV1(' K ', K, '.')
      DBINOM = -1.D0
      return
      end


*DECK SROTMG
      SUBROUTINE SROTMG (SD1, SD2, SX1, SY1, SPARAM)
C***BEGIN PROLOGUE  SROTMG
C***PURPOSE  Construct a modified Givens transformation.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1B10
C***TYPE      SINGLE PRECISION (SROTMG-S, DROTMG-D)
C***KEYWORDS  BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C      SD1  single precision scalar
C      SD2  single precision scalar
C      SX1  single precision scalar
C      SY2  single precision scalar
C   SPARAM  S.P. 5-vector. SPARAM(1)=SFLAG defined below.
C           Locations 2-5 contain the rotation matrix.
C
C     --Output--
C      SD1  changed to represent the effect of the transformation
C      SD2  changed to represent the effect of the transformation
C      SX1  changed to represent the effect of the transformation
C      SY2  unchanged
C
C     Construct the modified Givens transformation matrix H which zeros
C     the second component of the 2-vector  (SQRT(SD1)*SX1,SQRT(SD2)*
C     SY2)**T.
C     With SPARAM(1)=SFLAG, H has one of the following forms:
C
C     SFLAG=-1.E0     SFLAG=0.E0        SFLAG=1.E0     SFLAG=-2.E0
C
C       (SH11  SH12)    (1.E0  SH12)    (SH11  1.E0)    (1.E0  0.E0)
C     H=(          )    (          )    (          )    (          )
C       (SH21  SH22),   (SH21  1.E0),   (-1.E0 SH22),   (0.E0  1.E0).
C
C     Locations 2-5 of SPARAM contain SH11, SH21, SH12, and SH22,
C     respectively.  (Values of 1.E0, -1.E0, or 0.E0 implied by the
C     value of SPARAM(1) are not stored in SPARAM.)
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   780301  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920316  Prologue corrected.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SROTMG
      DIMENSION SPARAM(5)
      SAVE ZERO, ONE, TWO, GAM, GAMSQ, RGAMSQ
      DATA ZERO, ONE, TWO /0.0E0, 1.0E0, 2.0E0/
      DATA GAM, GAMSQ, RGAMSQ /4096.0E0, 1.67772E7, 5.96046E-8/
C***FIRST EXECUTABLE STATEMENT  SROTMG
      IF (.NOT. SD1 .LT. ZERO) GO TO 10
C       GO ZERO-H-D-AND-SX1..
          GO TO 60
   10 CONTINUE
C     CASE-SD1-NONNEGATIVE
      SP2=SD2*SY1
      IF (.NOT. SP2 .EQ. ZERO) GO TO 20
          SFLAG=-TWO
          GO TO 260
C     REGULAR-CASE..
   20 CONTINUE
      SP1=SD1*SX1
      SQ2=SP2*SY1
      SQ1=SP1*SX1
C
      IF (.NOT. ABS(SQ1) .GT. ABS(SQ2)) GO TO 40
          SH21=-SY1/SX1
          SH12=SP2/SP1
C
          SU=ONE-SH12*SH21
C
          IF (.NOT. SU .LE. ZERO) GO TO 30
C         GO ZERO-H-D-AND-SX1..
               GO TO 60
   30     CONTINUE
               SFLAG=ZERO
               SD1=SD1/SU
               SD2=SD2/SU
               SX1=SX1*SU
C         GO SCALE-CHECK..
               GO TO 100
   40 CONTINUE
          IF (.NOT. SQ2 .LT. ZERO) GO TO 50
C         GO ZERO-H-D-AND-SX1..
               GO TO 60
   50     CONTINUE
               SFLAG=ONE
               SH11=SP1/SP2
               SH22=SX1/SY1
               SU=ONE+SH11*SH22
               STEMP=SD2/SU
               SD2=SD1/SU
               SD1=STEMP
               SX1=SY1*SU
C         GO SCALE-CHECK
               GO TO 100
C     PROCEDURE..ZERO-H-D-AND-SX1..
   60 CONTINUE
          SFLAG=-ONE
          SH11=ZERO
          SH12=ZERO
          SH21=ZERO
          SH22=ZERO
C
          SD1=ZERO
          SD2=ZERO
          SX1=ZERO
C         RETURN..
          GO TO 220
C     PROCEDURE..FIX-H..
   70 CONTINUE
      IF (.NOT. SFLAG .GE. ZERO) GO TO 90
C
          IF (.NOT. SFLAG .EQ. ZERO) GO TO 80
          SH11=ONE
          SH22=ONE
          SFLAG=-ONE
          GO TO 90
   80     CONTINUE
          SH21=-ONE
          SH12=ONE
          SFLAG=-ONE
   90 CONTINUE
      GO TO IGO,(120,150,180,210)
C     PROCEDURE..SCALE-CHECK
  100 CONTINUE
  110     CONTINUE
          IF (.NOT. SD1 .LE. RGAMSQ) GO TO 130
               IF (SD1 .EQ. ZERO) GO TO 160
               ASSIGN 120 TO IGO
C              FIX-H..
               GO TO 70
  120          CONTINUE
               SD1=SD1*GAM**2
               SX1=SX1/GAM
               SH11=SH11/GAM
               SH12=SH12/GAM
          GO TO 110
  130 CONTINUE
  140     CONTINUE
          IF (.NOT. SD1 .GE. GAMSQ) GO TO 160
               ASSIGN 150 TO IGO
C              FIX-H..
               GO TO 70
  150          CONTINUE
               SD1=SD1/GAM**2
               SX1=SX1*GAM
               SH11=SH11*GAM
               SH12=SH12*GAM
          GO TO 140
  160 CONTINUE
  170     CONTINUE
          IF (.NOT. ABS(SD2) .LE. RGAMSQ) GO TO 190
               IF (SD2 .EQ. ZERO) GO TO 220
               ASSIGN 180 TO IGO
C              FIX-H..
               GO TO 70
  180          CONTINUE
               SD2=SD2*GAM**2
               SH21=SH21/GAM
               SH22=SH22/GAM
          GO TO 170
  190 CONTINUE
  200     CONTINUE
          IF (.NOT. ABS(SD2) .GE. GAMSQ) GO TO 220
               ASSIGN 210 TO IGO
C              FIX-H..
               GO TO 70
  210          CONTINUE
               SD2=SD2/GAM**2
               SH21=SH21*GAM
               SH22=SH22*GAM
          GO TO 200
  220 CONTINUE
          IF (SFLAG) 250,230,240
  230     CONTINUE
               SPARAM(3)=SH21
               SPARAM(4)=SH12
               GO TO 260
  240     CONTINUE
               SPARAM(2)=SH11
               SPARAM(5)=SH22
               GO TO 260
  250     CONTINUE
               SPARAM(2)=SH11
               SPARAM(3)=SH21
               SPARAM(4)=SH12
               SPARAM(5)=SH22
  260 CONTINUE
          SPARAM(1)=SFLAG
          RETURN
      END


      subroutine zsphbesj(lmax,x,as,ac,x1,bj,bscrat)
c_______________________________________________________________________
c calculate spherical bessel functions j_l
c input: lmax integer scalar, max l for j_l
c        x    compex*16 scalar, argument of j_l
c returns: as complex*16 scalar, sin(x)
c          ac complex*16 scalar, cos(x)
c          x1 complex*16 scalar, 1/x
c          bj complex*16 array of (0:lmax), j_l
c          bscrat complex*16 array of (0:lmax), scratch space

c  xgz ornl 1994

      implicit complex*16(a-h,o-z)
      complex*16 bj(0:lmax),bscrat(0:lmax)

      as=sin(x)
      ac=cos(x)
      x1=1.0d0/x
      bj(0)=as*x1
c   Forward recursion for small L
    1 k=ishft(int(0.75d0*(abs(dreal(x))+abs(dimag(x))))+2,-2)
      bscrat(0)=as
      if(k.ge.1) then
        if(k.gt.lmax) k=lmax
        bscrat(1)=bj(0)-ac
        bj(1)=bscrat(1)*x1
        do l=2,k
          bscrat(l)=(2*l-1)*bj(l-1)-bscrat(l-2)
          bj(l)=bscrat(l)*x1
        end do
        if(k.eq.lmax) return
      endif
c   Backward recursion from very large L down to L=k
      a=bscrat(k)
      nm=ishft(lmax,4)
      aj=2*nm+3
      x2=x*x
      do l=nm,lmax+2,-1
         aj=(2*l+1)-x2/aj
      end do
      bscrat(lmax)=(2*lmax+3)*aj*x1-x
      bj(lmax)=bscrat(lmax)*x1
      bscrat(lmax-1)=(2*lmax+1)*bj(lmax)-aj
      do l=lmax-1,k+1,-1
         bj(l)=bscrat(l)*x1
         bscrat(l-1)=(2*l+1)*bj(l)-bscrat(l+1)
      end do
c scale to give correct bj(k)
      aj=a/bscrat(k)
      do l=k+1,lmax
        bj(l)=aj*bj(l)
      end do
      return
      end


C++**********************************************************************
C RESAMPLE1
C  From "RESAMPLE" (EDRS, R.F. Warren-Smith)
C  Resamples an image at points defined by transforming the
C  pixel coordinates of the output image.
C  For interpolation 3 options are available:
C     -- nearest-neighbour
C     -- linear interpolation between the 4 nearest pixels,
C     -- constant noise interpolation (between the 9 nearest pixels).
C
C  First gets the input, output image filenames and transform coefficients.
C  Calls rebin to resample the image by the required method.
C
C SYNTAX:
C     RUNS RESAMPLE1 in_image coeff_file out_image
C Example:
C     RUNS RESAMPLE1 name name.XYF name_SHIFT
C
C Nota1: the coefficient file is simply an ASCII file with 6 values.
C        This file is generally produced by XYFIT1.
C
C new_coordinates= matrix old_coordinates:
C    input(x_new) = input(C1 + C2 x_old + C3 y_old)
C         (y_new)        (C4 + C5 x_old + C6 y_old)
C
C JLP
C Version of 17-12-98
C--**********************************************************************
	PROGRAM RESAMPLE1
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
*
*STARLINK PARAMETERS
*       INPUT
*               THE INPUT IMAGE
*       METHOD
*               SPECIFIES THE RESAMPLING INTERPOLATION METHOD
*       CONSERVE
*               (LOGICAL) IF SET TRUE, THE IMAGE IS RESCALED TO
*               CONSERVE TOTAL DATA SUM
*       NPIXOUT
*               NUMBER OF PIXELS PER LINE IN THE OUTPUT IMAGE
*       NLINEOUT
*               NUMBER OF LINES IN THE OUTPUT IMAGE
*       OUTPUT
*               OUTPUT IMAGE
*
*WRITTEN BY
*       R.F. WARREN-SMITH
*
* Calls EDRS routine (included here): REBIN
*-----------------------------------------------------------------------
*
        REAL ANGLE,COEF1(6),WX,WY
	INTEGER*4 NAXIS(2),METHOD,ISIZE
        INTEGER*4 NX_IN,NY_IN,NX_OUT,NY_OUT
	INTEGER*4 PNTR_IN,PNTR_OUT,MADRID(1)
	CHARACTER IMAGE_IN*40,IMAGE_OUT*40,NAME*40,COMMENTS*80
        CHARACTER BUFFER*80
        COMMON/VMR/MADRID

10	FORMAT(A)

	CALL JLP_BEGIN

* Inquire the format of the images :
	CALL JLP_INQUIFMT
        WRITE(6,11)
11      FORMAT('Resample1, version 17/12/98',/,
     1         ' new_coordinates= matrix * old_coordinates: '/,
     1         ' image(x_new, y_new) = image(C1 + C2 x_old + C3 y_old,',/,
     1                                     ' C4 + C5 x_old + C6 y_old)')

	  DO K=1,6
           COEF1(K)=0.
          END DO
          COEF1(2)=1.
          COEF1(6)=1.
*
* Obtain input image
*
	PRINT *,' Input image ?'
	READ(5,10) IMAGE_IN
	CALL JLP_VM_READIMAG(PNTR_IN,NX_IN,NY_IN,IMAGE_IN,COMMENTS)

* Obtain position transformation coefficients
*
16        WRITE(6,12)
12      FORMAT(' Menu: ',/,
     1         ' 1,x   : Rotation of xx degrees (0=horizontal, 90=vertical)',/,
     1         ' 2     : Symmetry left-right in X (look at MIRROR.FOR)',/,
     1         ' 3     : Symmetry top-bottom in Y (look at MIRROR.FOR)',/,
     1         ' 4,x,y : Shift of x,y',/,
     1         ' 5,filename     : File with 6 coefficients',/,
     1         ' Enter your choice: ',$)
        READ(5,10) BUFFER
        IF(BUFFER(1:1).EQ.'1')THEN
          READ(BUFFER(3:80),*) ANGLE
          ANGLE = ANGLE*3.14159/180.
          COEF1(2)=COS(ANGLE)
          COEF1(3)=SIN(ANGLE)
          COEF1(5)=-SIN(ANGLE)
          COEF1(6)=COS(ANGLE)
C Keep center in the middle:
          WX = COEF1(2)*NX_IN/2. + COEF1(3)*NY_IN/2.
          WY = COEF1(5)*NX_IN/2. + COEF1(6)*NY_IN/2.
          COEF1(1)=NX_IN/2.-WX
          COEF1(4)=NY_IN/2.-WY
        ELSE IF(BUFFER(1:1).EQ.'2')THEN
          COEF1(1)=NX_IN
          COEF1(2)=-1.
        ELSE IF(BUFFER(1:1).EQ.'3')THEN
          COEF1(4)=NY_IN
          COEF1(6)=-1.
        ELSE IF(BUFFER(1:1).EQ.'4')THEN
          READ(BUFFER(3:80),*)WX,WY
          COEF1(1)=-WX
          COEF1(4)=-WY
        ELSE IF(BUFFER(1:1).EQ.'5')THEN
	  OPEN(1,FILE=NAME,STATUS='OLD',ERR=16)
	  READ(1,*)(COEF1(K),K=1,6)
	  CLOSE(1)
        ELSE
          GOTO 16
        ENDIF
C Output just to check:
	WRITE(6,35)(COEF1(K),K=1,6)
35      FORMAT(' OK: coefficients are:',/,2(2X,3(1X,G10.3),/))

*
* Obtain type of interpolation required (2=linear)
* and determine if total data count is to be conserved
*
         WRITE(6,32)
32       FORMAT(' Interpolation method:   1=nearest   2=linear  3=constant noise ',/,
     1     ' and total count conserved:   0=NO      1=YES    (Example: 2,0) ?')
	 READ(5,*) METHOD,ICONSERV
         WRITE(6,*) ' METHOD :=',METHOD,' (2=LINEAR)'
*
* Obtain size of output image, using input size as default
*
	 NX_OUT=NX_IN
	 NY_OUT=NY_IN
	 WRITE(6,*) ' Size of the output image',NX_OUT,NY_OUT

* Obtain output image
*
	WRITE(6,*) ' Output image ?'
	READ(5,10) IMAGE_OUT

* Get memory space for output image:
       ISIZE=NX_OUT*NY_OUT*4
       CALL JLP_GETVM(PNTR_OUT,ISIZE)
*
* Defines the parameters used by EDRSLIB (integer files)
	INVALA=-100000
	INVALB=0.

* By default flux scale is set to unity
	SCALE=1.0
*
* Call REBIN to resample the input image over the entire area
* covered by the output image
*
	CALL REBIN(MADRID(PNTR_IN),NX_IN,NY_IN,INVALA,INVALB,1,NX_OUT,1,
     1	NY_OUT,COEF1,SCALE,METHOD,MADRID(PNTR_OUT),NX_OUT,NY_OUT,IERR)

* If conservation of total flux, rescale the intensities:
        IF(ICONSERV.EQ.1.AND.IERR.EQ.0)THEN
          WRITE(6,*) ' Rescaling the image intensity'
          NPIX_TOTAL=NX_OUT*NY_OUT
          CALL CMULT_IMAGE(MADRID(PNTR_OUT),MADRID(PNTR_OUT),SCALE,NPIX_TOTAL)
        ENDIF

        IF(IERR.NE.0)THEN
          WRITE(6,33) IERR
33        FORMAT(' Fatal error in REBIN, error flag=',I4)
        ELSE
* Write the output image :
	  IMAX=MAX(INDEX(IMAGE_IN,'  '),1)
	  IMAX=MIN(10,IMAX)
	  WRITE(COMMENTS,25)IMAGE_IN(1:IMAX),(COEF1(IK),IK=1,6)
25	  FORMAT(A,'resampled ',6(G9.2))
	  CALL JLP_WRITEIMAG(MADRID(PNTR_OUT),NX_OUT,NY_OUT,NX_OUT,
     1                    IMAGE_OUT,COMMENTS)
        ENDIF

	CALL JLP_END
	STOP
	END
C@**********************************************************************
C REBIN
C@**********************************************************************
	subroutine rebin(input1,npixa,nlinea,invala,invalb,minx,maxx,miny,
     1	maxy,coef1,scale,mode,output1,npixb,nlineb,ierr)
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
*PURPOSE
*       To resample an image at positions given by a linear
*       transformation of the output pixel positions
*
*METHOD
*       Scan the output image, transforming the pixel positions.
*       Interpolate in the input image to determine the image value
*       at these points. The routine uses nearest-neighbour or linear
*       interpolation between the 4 nearest pixels
*
*ARGUMENTS
*       INPUT1 (IN)
*       REAL*4(NPIXA,NLINEA)
*               The input image
*       NPIXA,NLINEA (IN)
*       INTEGER
*               The dimensions of input
*       INVALA (IN)
*       INTEGER
*               Invalid pixel flag for input
*       INVALB (IN)
*       INTEGER
*               Invalid pixel flag for output1
*       MINX,MAXX,MINY,MAXY (IN)
*       INTEGER
*               Range of output pixels to be replaced
*       COEF1(IN)
*       REAL(6)
*               Coefficients giving the transformation from output
*               positions to input positions
*       SCALE (OUT)
*       REAL
*               Scale factor which is needed if total image intensity
*               is to be conserved
*       MODE (IN)
*       INTEGER
*               Type of interpolation
*               1: Nearest neighbour
*               2: Linear
*               3: Constant noise
*       OUTPUT1 (IN/OUT)
*       REAL*4(NPIXB,NLINEB)
*               Output image
*       NPIXB,NLINEB (IN)
*       INTEGER
*               Dimensions of output1
*       IERR (OUT)
*       INTEGER
*               Error flag: zero for success
*
*CALLS
*       NONE
*
*WRITTEN BY
*       R.F. WARREN-SMITH
*-----------------------------------------------------------------------
*
	real*4 input1(npixa,*),output1(npixb,*)
	integer xmin,xmax,ymin,ymax,x,y,xcen,ycen
	real coef1(6),wx(-1:+1),wy(-1:+1)

* Set up weight arrays for constant noise interpolation
*
	data wx(0)/1.0/,wy(0)/1.0/

* Check argument validity
*
	if(minx.gt.maxx) then
	   ierr=1
	else if(miny.gt.maxy) then
	   ierr=2
	else
	   ierr=0
*
* Restrict max and min x,y limits to lie in output image
*
	   xmin=min(max(1,minx),npixb)
	   xmax=min(max(1,maxx),npixb)
	   ymin=min(max(1,miny),nlineb)
	   ymax=min(max(1,maxy),nlineb)

*
* Restrict interpolation method to be 1 to 3
*
	   method=min(max(1,mode),3)

* Scale factor to conserve counts is (abs. value of determinant)
*
	   scale=abs(coef1(2)*coef1(6)-coef1(3)*coef1(5))

* debug:
           write(6,34) xmin,xmax,ymin,ymax,scale
34         format(' xmin, xmax, ymin, ymax :',4I5,' scale factor:',G10.3)
           write(6,35) (coef1(i),i=1,6)
35         format(2(2X,3(1X,G10.3),/))
           if(scale.eq.0.) then
              ierr=-3
              write(6,36)
36            format('REBIN/Fatal error, wrong transformation, null determinant!')
              return
           endif

* Scan the selected area of the output image (location x,y) and
* calculate the transformed position (xdash,ydash) in the input
* image
*
	   do 12 y=ymin,ymax
	      xref=coef1(1)+coef1(3)*y
	      yref=coef1(4)+coef1(6)*y

	      do 11 x=xmin,xmax
	 	  xdash=xref+coef1(2)*x
	 	  ydash=yref+coef1(5)*x

*
* Find nearest pixel location
*
	         xcen=nint(xdash)
	         ycen=nint(ydash)

* If nearest pixel lies outside input image, output pixel is invalid
* otherwise continue with interpolation
*

	         if((xcen.lt.1).or.(xcen.gt.npixa).or.(ycen.lt.1).or.
     1	            (ycen.gt.nlinea)) then
	            output1(x,y)=invalb
	         else

* ---------------------------------------------------------------------
* 1. FOR NEAREST-NEIGHBOUR INTERPOLATION, output pixel=nearest pixel,
* or is invalid if input pixel is invalid
* ---------------------------------------------------------------------

	            if(method.eq.1) then

	               if(input1(xcen,ycen).eq.invala) then
	                  output1(x,y)=invalb

	               else
 	                 output1(x,y)=input1(xcen,ycen)
	               endif

* ---------------------------------------------------------------------
* 2. FOR LINEAR INTERPOLATION, output pixel is invalid if nearest input
* pixel is invalid. Otherwise continue with interpolation
* ---------------------------------------------------------------------

	            else if(method.eq.2) then

	               if(input1(xcen,ycen).eq.invala) then
 	                 output1(x,y)=invalb

	               else

*
* Find shift from next lowest pixel,line location
*
	                  i=xdash
	                  j=ydash
	                  dx=xdash-i
	                  dy=ydash-j

*
* Initiallise sums for forming weighted mean
*
	                  sum=0.0
	                  wtsum=0.0

*
* Form weighted mean of adjacent 4 pixels, checking that each lies
* within the input image and is not invalid
*

	                  if(j.ge.1) then

	                     if(i.ge.1) then

	                        if(input1(i,j).ne.invala) then

*
* Weight is calculated from the X,Y shift from integer pixel locations
*
	                           wt=(1.0-dx)*(1.0-dy)
	                           sum=sum+input1(i,j)*wt
	                           wtsum=wtsum+wt
	                        endif

	                     endif

	                     if(i+1.le.npixa) then

	                        if(input1(i+1,j).ne.invala) then
	                           wt=dx*(1.0-dy)
	                           sum=sum+input1(i+1,j)*wt
	                           wtsum=wtsum+wt
	                        endif

	                     endif

	                  endif

	                  if(j+1.le.nlinea) then

	                     if(i.ge.1) then

	                        if(input1(i,j+1).ne.invala) then
	                           wt=(1.0-dx)*dy
	                           sum=sum+input1(i,j+1)*wt
	                           wtsum=wtsum+wt
	                        endif

	                     endif

	                     if(i+1.le.npixa) then

                              if(input1(i+1,j+1).ne.invala) then
                                 wt=dx*dy
                                 sum=sum+input1(i+1,j+1)*wt
                                 wtsum=wtsum+wt
                              endif

                           endif

                        endif

*
* Assign weighted mean to output pixel (WTSUM cannot be zero, since
* at least 1 input pixel must be valid)
*
                        output1(x,y)=sum/wtsum
                     endif

* ---------------------------------------------------------------------
* 3. FOR CONSTANT NOISE INTERPOLATION (output noise independent of
* resampling phase)
* ---------------------------------------------------------------------

                  else if(method.eq.3) then

*
* If nearest pixel is invalid, so is output pixel. otherwise continue
* with interpolation
*

                     if(input1(xcen,ycen).eq.invala) then
                        output1(x,y)=invalb

                     else

*
* Calculate the shift from the nearest pixel,line position
*
                        dx=xdash-xcen
                        dy=ydash-ycen

*
* Calculate the X and Y weight arrays (dependent on the phase DX,DY)
*
                        r1=dx*dx+0.25
                        r2=dy*dy+0.25
                        wx(-1)=r1-dx
                        wx(1)=r1+dx
                        wy(-1)=r2-dy
                        wy(1)=r2+dy

*
* Now scan the 9 nearest pixels, forming a weighted sum of all the
* valid ones
*
                        sum=0.0
                        wtsum=0.0

                        do 22 jshift=-1,1
                           jj=ycen+jshift

*
* Check we are still in the image
*

                           if(jj.ge.1.and.jj.le.nlinea) then

                              do 21 ishift=-1,1
                                 ii=xcen+ishift

                                 if(ii.ge.1.and.ii.le.npixa) then

*
* Include the pixel if it is valid
*

                                    if(input1(ii,jj).ne.invala) then
                                       wt=wx(ishift)*wy(jshift)
                                       sum=sum+input1(ii,jj)*wt
                                       wtsum=wtsum+wt
                                    endif

                                 endif

21                            continue

                           endif

22                      continue

*
* Assign the interpolated value to the output pixel
*
                        output1(x,y)=sum/wtsum
                     endif

                  endif

               endif

11	    continue

12	 continue

	endif

	return

	end
C******************************************************************
C Multiplication of the whole image by a constant:
        SUBROUTINE CMULT_IMAGE(OUT,IN,SCALE,NPIX_TOTAL)
        REAL*4 OUT(*), IN(*)
        REAL*4 SCALE
        DO I=1,NPIX_TOTAL
          OUT(I)=IN(I)*SCALE
        END DO
        RETURN
        END


!##################################################################
!##################################################################
!######                                                      ######
!######                  SUBROUTINE CALC_UH                  ######
!######                                                      ######
!######                     Developed by                     ######
!######     Center for Analysis and Prediction of Storms     ######
!######                University of Oklahoma                ######
!######                                                      ######
!##################################################################
!##################################################################
!
!  Calculates updraft helicity (UH) to detect rotating updrafts.
!  Formula follows Kain et al, 2008, Wea. and Forecasting, 931-952,
!  but this version has controls for the limits of integration
!  uhminhgt to uhmxhgt, in m AGL.  Kain et al used 2000 to 5000 m.
!  Units of UH are m^2/s^2.
!
!  Note here that us and vs are at ARPS scalar points.
!  w is at w-point (scalar pt in horiz, staggered vertical)
!
!  Keith Brewster, CAPS/Univ. of Oklahoma
!  March, 2010

!NCLFORTSTART
SUBROUTINE DCALCUH(nx, ny, nz, nzp1, zp, mapfct, dx, dy, uhmnhgt, uhmxhgt, us, &
                   vs, w, uh, tem1, tem2)

    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: uh

    INTEGER, INTENT(IN) :: nx, ny, nz, nzp1
    REAL(KIND=8), DIMENSION(nx,ny,nzp1), INTENT(IN)  :: zp
    REAL(KIND=8), DIMENSION(nx,ny), INTENT(IN) :: mapfct
    REAL(KIND=8), INTENT(IN) :: dx, dy
    REAL(KIND=8), INTENT(IN) :: uhmnhgt, uhmxhgt
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(IN)  :: us
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(IN)  :: vs
    REAL(KIND=8), DIMENSION(nx,ny,nzp1), INTENT(IN)  :: w
    REAL(KIND=8), DIMENSION(nx,ny), INTENT(OUT) :: uh
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(INOUT) :: tem1
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(INOUT) :: tem2

!NCLEND

    ! Misc local variables
    INTEGER :: i, j, k, kbot, ktop
    REAL(KIND=8) :: twodx, twody, wgtlw, sum, wmean, wsum !,wavg
    REAL(KIND=8) :: helbot, heltop, wbot, wtop
    REAL(KIND=8) :: zbot, ztop

    ! Initialize arrays
    uh = 0.0
    tem1 = 0.0

    ! Calculate vertical component of helicity at scalar points
    !   us: u at scalar points
    !   vs: v at scalar points

    twodx = 2.0*dx
    twody = 2.0*dy

    !$OMP PARALLEL

    !$OMP DO COLLAPSE(3) SCHEDULE(runtime)
    DO k=2,nz-2
        DO j=2,ny-1
            DO i=2,nx-1
                !wavg = 0.5*(w(i,j,k)+w(i,j,k+1))
                tem1(i,j,k) = (0.5*(w(i,j,k)+w(i,j,k+1)))*((vs(i+1,j,k) - &
                              vs(i-1,j,k))/(twodx*mapfct(i,j)) - &
                              (us(i,j+1,k) - us(i,j-1,k))/(twody*mapfct(i,j)))
                tem2(i,j,k) = 0.5*(zp(i,j,k) + zp(i,j,k+1))
            END DO
        END DO
    END DO
    !$OMP END DO

    ! Integrate over depth uhminhgt to uhmxhgt AGL
    !
    !  WRITE(6,'(a,f12.1,a,f12.1,a)') &
    !        'Calculating UH from ',uhmnhgt,' to ',uhmxhgt,' m AGL'
    !$OMP DO COLLAPSE(2) PRIVATE(i, j, k, zbot, ztop, kbot, ktop, &
    !$OMP wgtlw, wbot, wtop, wsum, wmean, sum, helbot, heltop) SCHEDULE(runtime)
    DO j=2,ny-2
        DO i=2,nx-2
            zbot = zp(i,j,2) + uhmnhgt
            ztop = zp(i,j,2) + uhmxhgt
            !
            ! Find wbar, weighted-mean vertical velocity in column
            ! Find w at uhmnhgt AGL (bottom)
            !
            DO k=2,nz-3
                IF(zp(i,j,k) > zbot) EXIT
            END DO
            kbot = k
            wgtlw = (zp(i,j,kbot) - zbot)/(zp(i,j,kbot) - zp(i,j,kbot-1))
            wbot = (wgtlw*w(i,j,kbot-1)) + ((1. - wgtlw)*w(i,j,kbot))

            ! Find w at uhmxhgt AGL (top)
            DO k=2,nz-3
                IF(zp(i,j,k) > ztop) EXIT
            END DO
            ktop = k
            wgtlw = (zp(i,j,ktop) - ztop)/(zp(i,j,ktop) - zp(i,j,ktop-1))
            wtop = (wgtlw*w(i,j,ktop-1)) + ((1. - wgtlw)*w(i,j,ktop))

            ! First part, uhmnhgt to kbot
            wsum = 0.5*(w(i,j,kbot) + wbot)*(zp(i,j,kbot) - zbot)

            ! Integrate up through column
            DO k=(kbot+1),(ktop-1)
                wsum = wsum + 0.5*(w(i,j,k) + w(i,j,k-1))*(zp(i,j,k) - zp(i,j,k-1))
            END DO

            ! Last part, ktop-1 to uhmxhgt
            wsum = wsum + 0.5*(wtop + w(i,j,ktop-1))*(ztop - zp(i,j,ktop-1))
            wmean = wsum/(uhmxhgt - uhmnhgt)

            IF (wmean > 0.) THEN    ! column updraft, not downdraft

                ! Find helicity at uhmnhgt AGL (bottom)
                DO k=2,nz-3
                    IF (tem2(i,j,k) > zbot) EXIT
                END DO
                kbot = k
                wgtlw = (tem2(i,j,kbot) - zbot)/(tem2(i,j,kbot) - tem2(i,j,kbot-1))
                helbot = (wgtlw*tem1(i,j,kbot-1)) + ((1. - wgtlw)*tem1(i,j,kbot))

                ! Find helicity at uhmxhgt AGL (top)
                DO k=2,nz-3
                    IF (tem2(i,j,k) > ztop) EXIT
                END DO
                ktop = k
                wgtlw = (tem2(i,j,ktop) - ztop)/(tem2(i,j,ktop) - tem2(i,j,ktop-1))
                heltop = (wgtlw*tem1(i,j,ktop-1)) + ((1. - wgtlw)*tem1(i,j,ktop))

                ! First part, uhmnhgt to kbot
                sum = 0.5*(tem1(i,j,kbot) + helbot)*(tem2(i,j,kbot) - zbot)

                ! Integrate up through column
                DO k=(kbot+1),(ktop-1)
                    sum = sum + 0.5*(tem1(i,j,k) + tem1(i,j,k-1))*(tem2(i,j,k) - tem2(i,j,k-1))
                END DO

                ! Last part, ktop-1 to uhmxhgt
                uh(i,j) = sum + 0.5*(heltop + tem1(i,j,ktop-1))*(ztop - tem2(i,j,ktop-1))
            END IF
        END DO
    END DO
    !$OMP END DO

    !$OMP END PARALLEL

    RETURN

END SUBROUTINE DCALCUH


	FUNCTION PS_SWET  ( t850, td850, t500, spd850, spd500, dir850,
     +			    dir500 )
C************************************************************************
C* PS_SWET 								*
C*									*
C* This function computes the SWEAT index.  Winds must be input in	*
C* meters/sec.  They are converted to knots for the computation.	*
C*									*
C*     SWET = 12 * TD850 + 20 * TERM2 + 2 * SKT850 + SKT500 + SHEAR	*
C*									*
C*          TERM2  = MAX ( TOTL - 49, 0 )				*
C*          TOTL   = Total totals index					*
C*          SKT850 = 850 mb wind speed in knots				*
C*          SKT500 = 500 mb wind speed in knots				*
C*          SHEAR  = 125 * [SIN ( DIR500 - DIR850 ) + .2]		*
C*									*
C* If TD850 is negative, then TD850 is set to 0.  SHEAR is set to 0	*
C* if any of the following conditions is met:				*
C*									*
C*      wind direction at 850mb is < 130 or > 250			*
C*      wind direction at 500mb is < 210 or > 310			*
C*      DIR500 - DIR850 < 0						*
C*      SKT500 < 15  or  SKT850 < 15 knots				*
C*									*
C* Miller, R.C., 1972: Notes on Severe Storm Forecasting Procedures of	*
C* the Air Force Global Weather Central, AWS Tech. Report 200.		*
C*                                                                      *
C* REAL PS_SWET  ( T850, TD850, T500, SPD850, SPD500, DIR850, DIR500 )	*
C*									*
C* Input parameters:							*
C*	T850		REAL		850 mb temperature at 850 mb	*
C*	TD850		REAL		850 mb dewpoint at 850 mb	*
C*	T500		REAL		500 mb temperature at 500 mb	*
C*	SPD850		REAL		850 mb wind speed in m/sec	*
C*	SPD500		REAL		500 mb wind speed in m/sec	*
C*	DIR850		REAL		850 mb wind direction		*
C*	DIR500		REAL		500 mb wind direction		*
C*									*
C* Output parameters:							*
C*	PS_SWET		REAL		SWET index			*
C**	                                                            	*
C* Log:									*
C* P. Kocin/GSFC	1980						*
C* M. Goodman/RDS	11/84	Corrected errors			*
C* M. desJardins/GSFC	 3/88	Documentation				*
C* J. Whistler/NCEP	 1/96	Changed speed check to use knots	*
C************************************************************************
        INCLUDE    'GEMPRM.PRM'
        INCLUDE    'ERMISS.FNC'
C------------------------------------------------------------------------
	IF ( ERMISS ( t850 ) .or. ERMISS ( td850 ) .or. ERMISS ( t500 )
     +		.or. ERMISS ( spd850 ) .or. ERMISS ( spd500 ) .or.
     +		     ERMISS ( dir850 ) .or. ERMISS ( dir500 ) )  THEN
	    PS_SWET = RMISSD
	  ELSE
C
C*	    Convert meters per second to knots.
C
	    skt850 = PR_MSKN ( spd850 )
	    skt500 = PR_MSKN ( spd500 )
C
C*	    Compute the total totals index.  If < 49, set term to zero.
C
	    total = PS_TOTL ( t850, td850, t500 )
	    term2 = total - 49.
	    IF  ( total .lt. 49. )  term2 = 0.
C
C*	    Compute shear term.
C
	    dif   = dir500 - dir850
	    s     = SIN ( dif * DTR )
	    shear = 125. * ( s + .2 )
C
C*	    Make various wind checks.
C
	    IF ((dir850 .lt. 130.) .or. (dir850 .gt. 250.)) shear = 0.
	    IF ((dir500 .lt. 210.) .or. (dir500 .gt. 310.)) shear = 0.
	    IF ((skt500 .lt. 15.)  .or. (skt850 .lt. 15. )) shear = 0.
	    IF (dif .le. 0.) shear = 0.
C
C*	    Check for subzero dewpoint.
C
	    dwp850 = td850
	    IF  ( dwp850 .lt. 0. )  dwp850 = 0.
C
C*	    Calculate SWEAT index.
C
	    PS_SWET = 12. * dwp850 + 20. * term2 + 2. * skt850 +
     +		      skt500 + shear
	END IF
C*
	RETURN
	END


      subroutine sheart(q,sslope,shear)
c
c     + + + PURPOSE + + +
c     Compute top rill width adjustments, Chezy's coefficient for rill
c     flow, flow depth, wetted area, wetted perimeter, hydraulic
c     radius, and shear stress at the end of the slope
c
c     Called from PARAM
c     Author(s): Flanagan
c     Reference in User Guide:
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
      include 'pmxnsl.inc'
      include 'pmxpln.inc'
      include 'pmxtls.inc'
      include 'pmxtil.inc'
      include 'pmxhil.inc'
      include 'pmxelm.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
      real q, sslope, shear
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     q      : flow discharge (m**3/s)
c     sslope : channel slope (m/m)
c     shear  : flow shear stress (Pa)
c
c     + + + COMMON BLOCKS + + +
c
      include 'cclim.inc'
      include 'cconsta.inc'
c
      include 'cends.inc'
c      modify: wdhtop(mxplan)
c
      include 'cffact.inc'
c
      include 'cslpopt.inc'
c     modify: dpthch(mxplan)
c
      include 'csolvar.inc'
      include 'cstruc.inc'
      include 'cupdate.inc'
c
c     + + + LOCAL VARIABLES + + +
      real dz, tol, u, chezch, sinang, wdthck, wp,
     1    xsarea,dpthch
c
c     + + + LOCAL DEFINITIONS + + +
c
c      u      : portion of uniform flow equation
c      wdthck : test width to check against to see if wider than
c               current rill width
c      chezch : Chezy C - roughness factor
c      dz     : trial valve for channel depth (m)
c      xsarea : cross sectional area of the flow (m**2)
c      wp     : wetted perimeter of the flow (m)
c      hydrad : hydraulic radius (m)
c      sinang : sine of slope angle
c      tol    : tolerance value
c
      save
c
c********************************************************************
c
c     Tolerance value changed by Baffaut, 1996.  dcf 3/97
c     tol = 5.0e-05
      tol = 5.0e-06
      q = abs(q)
c
c     SSLOPE value changed by Baffaut, 1996.  dcf 3/97
c     if (sslope.le.0.0) sslope = 0.00001
      if (sslope.le.0.0) sslope = 0.000001
c
c     compute top rill width (wdhtop). Note that when tillage occurs
c     top rill wdhtop is set to zero in SR CONTIN
c
c     Using Gilley's relationship
c
      if (rwflag(iplane).eq.1) then
        wdthck = 1.13 * q ** 0.303
        if (wdhtop(iplane).lt.wdthck) wdhtop(iplane) = wdthck
      end if
c
      if (wdhtop(iplane).gt.rspace(iplane)) wdhtop(iplane) =
     1    rspace(iplane)
c
c     compute Chezy's coefficient:
c
      chezch = sqrt(8.0*accgav/frctrl(iplane))
c
c     compute rill flow depth (dpthch(iplane)). This is an iterative
c     process to solve the uniform flow equation:
c
c     dpthch(iplane)=((Q/chezch/sqrt(sslope)**
c                    (2/3)/width)*(width+2*dpthch(iplane))**(1/3)
c
      if (q.le.0.) then
        dpthch = 0.0
      else
        u = (q/chezch/sqrt(sslope)) ** (2./3.) / wdhtop(iplane)
        dpthch = 0.2 * q ** .36
   10   dz = dpthch
        dpthch = u * (wdhtop(iplane)+dz+dz) ** (1./3.)
        if (abs(dz/dpthch-1.).gt.tol) go to 10
      end if
c
c     compute wetted area (xsarea), wetted perimeter (wp), and
c     hydraulic radius (hydrad):
c
      xsarea = dpthch * wdhtop(iplane)
      wp = wdhtop(iplane) + 2.0 * dpthch
c
c     check for rill width of 0 causing 0 wetted perimeter
c     4-24-2008 jrf
c      if (wp.ne.0.0) then
         hydrad(iplane) = xsarea / wp
c      else
c         hydrad(iplane) = 0.0
c      endif
c
c     compute shear stress:
c
c     Correction made to compute shear stress using the SINE of the
c     slope angle, not the tangent of the slope angle as has previously
c     been computed.  This should only impact results greatly on steeper
c     hillslopes.   dcf   1/21/93
c     shears=wtdens*sslope*hydrad*frcsol(iplane)/frctrl(iplane)
c
      sinang = sin(atan(sslope))
      shear = wtdens * sinang * hydrad(iplane) * frcsol(iplane) /
     1    frctrl(iplane)
      return
      end


program fnc
    implicit none
    real :: x, y
    real, external :: f
    x = 0.1
    y = f(x, 0.5)

    write(*,*)y
end program

real function f(x, t)
    implicit none
    real, intent(in) :: x, t

    f = sin(x - t)
end function


module parent
real, parameter :: pi = 4.*atan(1.)
real :: tau

interface
module elemental real function pi2tau(pi)
  real, intent(in) :: pi
end function pi2tau

module subroutine good()
end subroutine good
end interface

end module parent

use parent

tau = pi2tau(pi)

print *,'pi=',pi, 'tau=', tau

call good()

end program


program scaleTest_coretran

!! Test program for the coretran library
  use iso_fortran_env
  use variableKind
  use m_array1D
  use m_errors
  use m_fileIO, only: openFile, closeFile
  use m_indexing
  use m_random
  use m_readLine
  use m_strings
  use m_writeLine
  use m_time
  use m_allocate
  use m_reallocate
  use m_copy
  ! Sorting routines
  use m_Sort
  !use m_PartialQuicksort
  use m_Select
  use m_maths

  use m_searching, only: binarySearch

  use Stopwatch_Class
  use ProgressBar_Class
  use m_KdTree

  implicit none

  character(len=100) :: fName
  character(len=128) :: sa
  character(len=:), allocatable :: cTest
  logical :: lTest
  integer(i32) :: iTest,istat,N, nIterations
  real(r32) :: ar, br, cr
  real(r32),allocatable :: ar1D(:),br1D(:),cr1D(:)
  real(r32),allocatable :: ar2D(:,:),br2D(:,:)
  real(r32),allocatable :: ar3D(:,:,:),br3D(:,:,:)
  real(r64) :: a,b,c
  real(r64),allocatable :: a1D(:),b1D(:),c1D(:)
  real(r64),allocatable :: a2D(:,:),b2D(:,:)
  real(r64),allocatable :: a3D(:,:,:),b3D(:,:,:)
  integer(i32) :: ia,ib,ic,id,ie
  integer(i32), allocatable :: ia1D(:),ib1D(:),ic1D(:)
  integer(i32), allocatable :: ia2D(:,:),ib2D(:,:)
  integer(i32), allocatable :: ia3D(:,:,:),ib3D(:,:,:)
  integer(i64) :: iad,ibd,icd
  integer(i64), allocatable :: iad1D(:),ibd1D(:),icd1D(:)
  integer(i64), allocatable :: iad2D(:,:),ibd2D(:,:)
  integer(i64), allocatable :: iad3D(:,:,:),ibd3D(:,:,:)
  complex(r32) :: x,y,z
  complex(r32), allocatable :: za1D(:),zb1D(:)
  complex(r32), allocatable :: za2D(:,:),zb2D(:,:)
  complex(r32), allocatable :: za3D(:,:,:),zb3D(:,:,:)
  complex(r64), allocatable :: zza1D(:),zzb1D(:)
  complex(r64), allocatable :: zza2D(:,:),zzb2D(:,:)
  complex(r64), allocatable :: zza3D(:,:,:),zzb3D(:,:,:)
  logical :: la,lb,lc
  logical, allocatable :: la1D(:),lb1D(:)
  logical, allocatable :: la2D(:,:),lb2D(:,:)
  logical, allocatable :: la3D(:,:,:),lb3D(:,:,:)
  integer(i32) :: passCount = 0
  integer(i32) :: testTotal = 0
  type(Stopwatch) :: clk
  type(ProgressBar) :: P
  type(KdTree) :: tree
  type(KdTreeSearch) :: search

  integer(i32) :: iunit
  integer(i32) :: maxSize = 25
  integer(i32), parameter :: nSizes = 6
  integer(i32) :: sizes(nSizes)
  real(r64) :: times(nSizes)

  ! Open a file for python plotting
  call openFile('scale_results.txt', iunit, 'unknown', istat)

  ! Set the max length of the tests
  N = 2**maxSize
  ! Set a repetition for very quick algorithms
  ic = 1e6

  ! Set the sizes
  do ia = 0, nSizes-1
    sizes(ia+1) = 2**(maxSize-ia)
  enddo

  write(iunit, '(a)') str(sizes)

  ! Set a fixed seed
  ! call random_seed(size = ia)
  ! call allocate(ia1D, ia)
  ! ia1D = 546420601
  call setPrng(big = .true., display=.true.)

    ! Initial setup for testing
  call allocate(ar1D, N)
  call allocate(br1D, N)
  call allocate(a1D, N)
  call allocate(b1D, N)
  call allocate(c1D, N)
  call allocate(ia1D,N)

  call rngNormal(a1D)
  ar1D = real(a1D)

  call Msg('==========================')
  call Msg('Testing : Sorting')
  call Msg('==========================')

  call Msg('Size  Time(s)')
  call Msg('Double precision introspection sort', iunit)

  b1D = a1D
  call clk%restart()
  call sort(b1D)
  call clk%stop()
  write(*,*) clk%elapsedInSeconds()

  do ia = 0, nSizes-1
    ib = sizes(ia+1)
    b1D(1:ib) = a1D(1:ib)

    call clk%restart()
    call sort(b1D(1:ib))
    call clk%stop()
    times(ia+1) = clk%elapsedInSeconds()
    call msg(str(ib)//' '//str(times(ia+1)))

    if (ia == 0) c1D=b1D
  enddo

  ! Write the times
  write(iunit, '(a)') str(times)

  call Msg('Already sorted double precision introspection sort', iunit)

  b1D = c1D

  do ia = 0, 5
    ib = 2**(24-ia)
    call clk%restart()
    call sort(b1D(1:ib))
    call clk%stop()
    times(ia+1) = clk%elapsedInSeconds()
    call msg(str(ib)//' '//str(times(ia+1)))
  enddo

  ! Write the times
  write(iunit, '(a)') str(times)

  call Msg('Double precision merge sort', iunit)
  do ia = 0, 5
    ib = 2**(24-ia)
    b1D(1:ib) = a1D(1:ib)

    call clk%restart()
    call sort(b1D(1:ib), stable=.true.)
    call clk%stop()
    times(ia+1) = clk%elapsedInSeconds()
    call msg(str(ib)//' '//str(times(ia+1)))
  enddo

  ! Write the times
  write(iunit, '(a)') str(times)

  call Msg('Already sorted double precision merge sort', iunit)
  b1D = c1D
  do ia = 0, 5
    ib = 2**(24-ia)

    call clk%restart()
    call sort(b1D(1:ib), stable=.true.)
    call clk%stop()
    times(ia+1) = clk%elapsedInSeconds()
    call msg(str(ib)//' '//str(times(ia+1)))
  enddo

  ! Write the times
  write(iunit, '(a)') str(times)

  call Msg('==========================')
  call Msg('Testing : Binary Search')
  call Msg('==========================')

  call allocate(ia1D, ic)
  b1D = c1D

  call Msg('Double precision binary search', iunit)
  do ia = 0, 5
    ib = sizes(ia+1)
    call rngInteger(ia1D, 1, ib)

    call clk%restart()
    do id = 1, ic
      a = b1D(ia1D(id))
      ie = binarySearch(b1D(1:ib), a, 1, ib)
    enddo
    call clk%stop()
    times(ia+1) = clk%elapsedInSeconds()/dble(ic)
    call msg(str(ib)//' '//str(times(ia+1)))

  enddo

  write(iunit,'(a)') str(times)

  call allocate(ia1D,N)

  call Msg('==========================')
  call Msg('Testing : Selection')
  call Msg('==========================')

  call Msg('Double precision quick select', iunit)

  ic = 1
  do ia = 0, 5
    ib = 2**(24-ia)

    ie = (ib+1)/2

    call clk%restart()
    do id = 1, ic
      b1D(1:ib) = a1D(1:ib)
      call select(b1D(1:ib), ie, a)
    enddo
    call clk%stop()
    times(ia+1) = clk%elapsedInSeconds()/dble(ic)
    call msg(str(ib)//' '//str(times(ia+1)))
  enddo
  write(iunit,'(a)') str(times)

  call Msg('Already sorted double precision quick select', iunit)
  b1D = c1D
  do ia = 0, 5
    ib = 2**(24-ia)

    ic = (ib+1)/2

    call clk%restart()
    call select(b1D(1:ib), ic, a)
    call clk%stop()
    times(ia+1) = clk%elapsedInSeconds()/dble(ic)
    call msg(str(ib)//' '//str(times(ia+1)))
  enddo
  write(iunit,'(a)') str(times)

  call Msg('==========================')
  call Msg('Testing : Spatial')
  call Msg('==========================')
  call Msg('---  Timing the 2D KdTree ---')
  call rngNormal(a1D)
  call rngNormal(b1D)
  do ia = 0, 5
    ib = 2**(24-ia)

    call clk%restart()
    tree = KdTree(a1D(1:ib), b1D(1:ib))
    call clk%stop()
    write(*,'(i10,1x,f0.3)') ib,clk%elapsedInSeconds()
  enddo
  call tree%deallocate()

  call Msg('---  Timing the 3D KdTree ---')
  call rngNormal(c1D)
  do ia = 0, 5
    ib = 2**(24-ia)

    call clk%restart()
    tree = KdTree(a1D(1:ib), b1D(1:ib), c1D(1:ib))
    call clk%stop()
    write(*,'(i10,1x,f0.3)') ib,clk%elapsedInSeconds()
  enddo
  call tree%deallocate()

  call allocate(a2D, [N, 5])
  call Msg('---  Timing the ND KdTree ---')
  call rngNormal(a2D)
  do ia = 0, 5
    ib = 2**(24-ia)

    call clk%restart()
    tree = KdTree(a2D(1:ib,:))
    call clk%stop()
    write(*,'(i10,1x,f0.3)') ib,clk%elapsedInSeconds()
  enddo
  call tree%deallocate()

  call closeFile('scale_results.txt',iunit,'',istat)

  stop
1 format(a)
contains

  subroutine test(l,msg)
  logical :: l
  character(len=*) :: msg
    testTotal = testTotal + 1
    if (l) then
      write(output_unit,1) msg//' Passed!'
      passCount = passCount + 1
    else
      write(output_unit,1) msg//' Failed!'
    endif
  1 format(a)
  end subroutine

end program


      module fem_geometry
      use linearsolvers
      implicit none

      integer::npe !number of nodes in element
      integer::nem !number of elements
      integer::nnm !number of nodes
      integer::iel   !element type tag
      integer::ipdf  !element type tag
      integer::neq !number of equations
      integer::nn !number of degrees of freedom in an element
      integer::nhbw !half band width
      integer::nw
      integer::nbw !band width
      real*8,parameter  :: pi = 3.14159265 !the pie number
!     ================================================================
!                      geormetry variables
!     ================================================================
      real*8,allocatable  ::coords(:,:) !the nodes geometry array
      integer,allocatable ::nod(:,:) !the connectivity matrix
!     ================================================================
!                      boundary condition variables
!     ================================================================
      integer,allocatable::ispv(:,:)!the primary boundary condition array
      real*8,allocatable::vspv(:),vspvt(:)!the primary boundary condition array
      integer,allocatable::issv(:,:)!the secondry boundary condition
      real*8,allocatable::vssv(:),vssvt(:)!the secondry boundary conditi

      integer,allocatable::bnd_no_pr_vec(:) !the secondry boundary conditi
      real,allocatable::bnd_va_pr_vec(:) !the secondry boundary conditi

      integer,allocatable::bnd_no_se_vec(:) !the secondry boundary conditi
      real,allocatable::bnd_va_se_vec(:) !the secondry boundary conditi

      integer::nspv,np,nb  !number of specified primary boundary condition
      integer::nssv  !number of specified secondry boundary condition

      contains

    subroutine geometry_1D(neldirectional,length)
    integer::neldirectional(:);
    real*8::length(:)
    real*8::delta_l
    integer::i,in,id

    delta_l=length(1)/neldirectional(1)
!     ===============================================================
!     mesh and fem information number of elements and number of nodes
!     ===============================================================

!     ===============================================================
!     define the solution parameters
!     ===============================================================
      iel=1;npe=2;
      nem=neldirectional(1)
      nnm=(iel*neldirectional(1) + 1)

    allocate(nod(nem,npe),coords(nnm,dimen))
    id=1;
    do in=1,nnm
    coords(in,id)=(in-1)*delta_l;enddo
!     ===============================================================
!     the connectivity matrix
!     ===============================================================
     do i=1,nem;nod(i,1)=1+(i-1);nod(i,2)=2+(i-1);enddo

      end subroutine geometry_1D

      subroutine bounday_1D()
      nspv=3       !reading primary variables

    if(nspv.gt.0)then
    allocate(ispv(nspv,2),vspv(nspv))
    ispv(1,:)=[1,1];
    ispv(2,:)=[1,2];
    vspv=0.0d0;

    ispv(3,:)=[nnm,2];
    vspv(3)=0.1d0;
      endif

      nssv=1 !reading secondry variables
      if (nssv.gt.0)then
    allocate(issv(nssv,2),vssv(nssv))
    issv(1,:)=[nnm,1];
    vssv=0*5.0e-1;
      endif

!      write(*,*)nssv,nspv

      allocate(bnd_va_pr_vec(nspv),bnd_no_pr_vec(nspv))
      allocate(bnd_va_se_vec(nssv),bnd_no_se_vec(nssv))

         do np=1,nspv
            nb=(ispv(np,1)-1)*ndf+ispv(np,2)
            bnd_va_pr_vec(np)=vspv(np)
            bnd_no_pr_vec(np)=nb
            enddo

         do np=1,nssv
           nb=(issv(np,1)-1)*ndf+issv(np,2)
           bnd_va_se_vec(np)=vssv(np)
           bnd_no_se_vec(np)=nb
         enddo

!write(*,*)bnd_va_pr_vec
!write(*,*)vssv

      end subroutine bounday_1D

      end module fem_geometry


*DECK DFZERO
      SUBROUTINE DFZERO (F, B, C, R, RE, AE, IFLAG)
C***BEGIN PROLOGUE  DFZERO
C***PURPOSE  Search for a zero of a function F(X) in a given interval
C            (B,C).  It is designed primarily for problems where F(B)
C            and F(C) have opposite signs.
C***LIBRARY   SLATEC
C***CATEGORY  F1B
C***TYPE      DOUBLE PRECISION (FZERO-S, DFZERO-D)
C***KEYWORDS  BISECTION, NONLINEAR, ROOTS, ZEROS
C***AUTHOR  Shampine, L. F., (SNLA)
C           Watts, H. A., (SNLA)
C***DESCRIPTION
C
C     DFZERO searches for a zero of a DOUBLE PRECISION function F(X)
C     between the given DOUBLE PRECISION values B and C until the width
C     of the interval (B,C) has collapsed to within a tolerance
C     specified by the stopping criterion,
C        ABS(B-C) .LE. 2.*(RW*ABS(B)+AE).
C     The method used is an efficient combination of bisection and the
C     secant rule and is due to T. J. Dekker.
C
C     Description Of Arguments
C
C   F     :EXT   - Name of the DOUBLE PRECISION external function.  This
C                  name must be in an EXTERNAL statement in the calling
C                  program.  F must be a function of one DOUBLE
C                  PRECISION argument.
C
C   B     :INOUT - One end of the DOUBLE PRECISION interval (B,C).  The
C                  value returned for B usually is the better
C                  approximation to a zero of F.
C
C   C     :INOUT - The other end of the DOUBLE PRECISION interval (B,C)
C
C   R     :IN    - A (better) DOUBLE PRECISION guess of a zero of F
C                  which could help in speeding up convergence.  If F(B)
C                  and F(R) have opposite signs, a root will be found in
C                  the interval (B,R);  if not, but F(R) and F(C) have
C                  opposite signs, a root will be found in the interval
C                  (R,C);  otherwise, the interval (B,C) will be
C                  searched for a possible root.  When no better guess
C                  is known, it is recommended that R be set to B or C,
C                  since if R is not interior to the interval (B,C), it
C                  will be ignored.
C
C   RE    :IN    - Relative error used for RW in the stopping criterion.
C                  If the requested RE is less than machine precision,
C                  then RW is set to approximately machine precision.
C
C   AE    :IN    - Absolute error used in the stopping criterion.  If
C                  the given interval (B,C) contains the origin, then a
C                  nonzero value should be chosen for AE.
C
C   IFLAG :OUT   - A status code.  User must check IFLAG after each
C                  call.  Control returns to the user from DFZERO in all
C                  cases.
C
C                1  B is within the requested tolerance of a zero.
C                   The interval (B,C) collapsed to the requested
C                   tolerance, the function changes sign in (B,C), and
C                   F(X) decreased in magnitude as (B,C) collapsed.
C
C                2  F(B) = 0.  However, the interval (B,C) may not have
C                   collapsed to the requested tolerance.
C
C                3  B may be near a singular point of F(X).
C                   The interval (B,C) collapsed to the requested tol-
C                   erance and the function changes sign in (B,C), but
C                   F(X) increased in magnitude as (B,C) collapsed, i.e.
C                     ABS(F(B out)) .GT. MAX(ABS(F(B in)),ABS(F(C in)))
C
C                4  No change in sign of F(X) was found although the
C                   interval (B,C) collapsed to the requested tolerance.
C                   The user must examine this case and decide whether
C                   B is near a local minimum of F(X), or B is near a
C                   zero of even multiplicity, or neither of these.
C
C                5  Too many (.GT. 500) function evaluations used.
C
C***REFERENCES  L. F. Shampine and H. A. Watts, FZERO, a root-solving
C                 code, Report SC-TM-70-631, Sandia Laboratories,
C                 September 1970.
C               T. J. Dekker, Finding a zero by means of successive
C                 linear interpolation, Constructive Aspects of the
C                 Fundamental Theorem of Algebra, edited by B. Dejon
C                 and P. Henrici, Wiley-Interscience, 1969.
C***ROUTINES CALLED  D1MACH
C***REVISION HISTORY  (YYMMDD)
C   700901  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DFZERO
      DOUBLE PRECISION A,ACBS,ACMB,AE,AW,B,C,CMB,D1MACH,ER,
     +                 F,FA,FB,FC,FX,FZ,P,Q,R,RE,RW,T,TOL,Z
      INTEGER IC,IFLAG,KOUNT
C
C***FIRST EXECUTABLE STATEMENT  DFZERO
C
C   ER is two times the computer unit roundoff value which is defined
C   here by the function D1MACH.
C
      ER = 2.0D0 * D1MACH(4)
C
C   Initialize.
C
      Z = R
      IF (R .LE. MIN(B,C)  .OR.  R .GE. MAX(B,C)) Z = C
      RW = MAX(RE,ER)
      AW = MAX(AE,0.D0)
      IC = 0
      T = Z
      FZ = F(T)
      FC = FZ
      T = B
      FB = F(T)
      KOUNT = 2
      IF (SIGN(1.0D0,FZ) .EQ. SIGN(1.0D0,FB)) GO TO 1
      C = Z
      GO TO 2
    1 IF (Z .EQ. C) GO TO 2
      T = C
      FC = F(T)
      KOUNT = 3
      IF (SIGN(1.0D0,FZ) .EQ. SIGN(1.0D0,FC)) GO TO 2
      B = Z
      FB = FZ
    2 A = C
      FA = FC
      ACBS = ABS(B-C)
      FX = MAX(ABS(FB),ABS(FC))
C
    3 IF (ABS(FC) .GE. ABS(FB)) GO TO 4
C
C   Perform interchange.
C
      A = B
      FA = FB
      B = C
      FB = FC
      C = A
      FC = FA
C
    4 CMB = 0.5D0*(C-B)
      ACMB = ABS(CMB)
      TOL = RW*ABS(B) + AW
C
C   Test stopping criterion and function count.
C
      IF (ACMB .LE. TOL) GO TO 10
      IF (FB .EQ. 0.D0) GO TO 11
      IF (KOUNT .GE. 500) GO TO 14
C
C   Calculate new iterate implicitly as B+P/Q, where we arrange
C   P .GE. 0.  The implicit form is used to prevent overflow.
C
      P = (B-A)*FB
      Q = FA - FB
      IF (P .GE. 0.D0) GO TO 5
      P = -P
      Q = -Q
C
C   Update A and check for satisfactory reduction in the size of the
C   bracketing interval.  If not, perform bisection.
C
    5 A = B
      FA = FB
      IC = IC + 1
      IF (IC .LT. 4) GO TO 6
      IF (8.0D0*ACMB .GE. ACBS) GO TO 8
      IC = 0
      ACBS = ACMB
C
C   Test for too small a change.
C
    6 IF (P .GT. ABS(Q)*TOL) GO TO 7
C
C   Increment by TOLerance.
C
      B = B + SIGN(TOL,CMB)
      GO TO 9
C
C   Root ought to be between B and (C+B)/2.
C
    7 IF (P .GE. CMB*Q) GO TO 8
C
C   Use secant rule.
C
      B = B + P/Q
      GO TO 9
C
C   Use bisection (C+B)/2.
C
    8 B = B + CMB
C
C   Have completed computation for new iterate B.
C
    9 T = B
      FB = F(T)
      KOUNT = KOUNT + 1
C
C   Decide whether next step is interpolation or extrapolation.
C
      IF (SIGN(1.0D0,FB) .NE. SIGN(1.0D0,FC)) GO TO 3
      C = A
      FC = FA
      GO TO 3
C
C   Finished.  Process results for proper setting of IFLAG.
C
   10 IF (SIGN(1.0D0,FB) .EQ. SIGN(1.0D0,FC)) GO TO 13
      IF (ABS(FB) .GT. FX) GO TO 12
      IFLAG = 1
      RETURN
   11 IFLAG = 2
      RETURN
   12 IFLAG = 3
      RETURN
   13 IFLAG = 4
      RETURN
   14 IFLAG = 5
      RETURN
      END


c***********************************************************************
c  Copyright 2006 John A. Trangenstein
c
c  This software is made available for research and instructional use
c  only.
c  You may copy and use this software without charge for these
c  non-commercial purposes, provided that the copyright notice and
c  associated text is reproduced on all copies.
c  For all other uses (including distribution of modified versions),
c  please contact the author at
c    John A. Trangenstein
c    Department of Mathematics
c    Duke University
c    Durham, NC 27708-0320
c    USA
c  or
c    johnt@math.duke.edu
c
c  This software is made available "as is" without any assurance that it
c  is completely correct, or that it will work for your purposes.
c  Use the software at your own risk.
c***********************************************************************
      subroutine consdiff(fic,lac,fif,laf,fix,lax,ifirst,ilast,
     &  x,flux,
     &  conservd)
      integer fic,lac,fif,laf,fix,lax,ifirst,ilast
      double precision
     &  x(fix:lax+1),
     &  flux(fif:laf+1)
      double precision
     &  conservd(fic:lac)
      integer ic
c     ******************************************************************
c     update conservd to new time
c     ******************************************************************
      do ic=ifirst,ilast
        conservd(ic) = conservd(ic)
     &               - (flux(ic+1)-flux(ic)) / (x(ic+1)-x(ic))
      enddo
      return
      end

      function stabledt(fc,lc,fm,lm,ifirst,ilast,
     &  conserved,lambda_cell,x)
c     ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      include "./const.i"
c     ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      double precision stabledt
      integer fc,lc,fm,lm,ifirst,ilast
      double precision conserved(fc:lc),lambda_cell(fc:lc),x(fm:lm+1)
      integer ic
      double precision abs_lambda,dx
c     ******************************************************************
c     compute stable timestep
c     ******************************************************************
      stabledt=huge
      do ic=ifirst,ilast
        abs_lambda=abs(lambda_cell(ic))
        dx = x(ic+1)-x(ic)
        if (abs_lambda.gt.roundoff*dx) then
          stabledt=min(stabledt,dx/abs_lambda)
        endif
      enddo
c     if (stabledt.le.0.) call abort()
      return
      end


! Matrix packing using the COO format.

module matrix_coo_module
    implicit none

    ! Packed matrix type.
    type packed_mat
        integer, dimension (:), allocatable :: rows, cols, vals
        integer :: n = 0, size = 0
    end type packed_mat

    ! Function declarations.
    public :: pack_matrix, unpack_matrix, destroy_packed
    private :: init_packed

contains

    ! Constructs a packed matrix.
    subroutine pack_matrix (mat, n, packed)
        integer, dimension (n, n), intent (in) :: mat
        integer, intent (in) :: n
        type (packed_mat), intent (out) :: packed

        integer :: i, j, k, cnt = 0

        ! Count the number of entries.
        do i = 1, n
            do j = 1, n
                if (mat(i, j) /= 0) then
                    cnt = cnt + 1
                end if
            end do
        end do

        ! Initialize the packed matrix.
        call init_packed(packed, cnt, n)

        ! Populate packed matrix.
        k = 1
        do i = 1, n
            do j = 1, n
                if (mat(i, j) /= 0) then
                    packed%cols(k) = i
                    packed%rows(k) = j
                    packed%vals(k) = mat(i, j)

                    k = k + 1
                end if
            end do
        end do

    end subroutine pack_matrix

    subroutine unpack_matrix (packed, dense)
        type (packed_mat), intent (in) :: packed
        integer, dimension (packed%n, packed%n), intent (out) :: dense
        integer :: i

        ! Unpack the matrix.
        dense = 0
        do i = 1, packed%size
            dense(packed%cols(i), packed%rows(i)) = packed%vals(i)
        end do

    end subroutine unpack_matrix

    ! Initialize a packed matrix.
    subroutine init_packed (packed, cnt, n)
        integer, intent (in) :: n, cnt
        type (packed_mat), intent (inout) :: packed

        packed%n = n
        packed%size = cnt

        allocate (packed%rows(cnt))
        allocate (packed%cols(cnt))
        allocate (packed%vals(cnt))
    end subroutine init_packed

    ! Deallocates a packed matrix.
    subroutine destroy_packed (packed)
        type (packed_mat), intent (inout) :: packed

        deallocate (packed%rows)
        deallocate (packed%cols)
        deallocate (packed%vals)
    end subroutine

end module matrix_coo_module

! Driver code.
program main
    use matrix_coo_module
    implicit none

    ! Size of the matrices.
    integer, parameter :: n = 10, m = 2000

    ! Declarations.
    integer, dimension (n, n) :: a = 0, c
    integer, dimension (m, m) :: b = 0
    type (packed_mat) :: pa, pb
    integer :: i, j

    ! Assign a few entries to build a sparse matrix.
    a(1, 1) = 1
    a(2, 6) = -5
    a(5, 10) = 4
    a(2, 2) = 5
    a(8, :) = (/1, 2, 3, 4, 5, 6, 7, 8, 9, 10/)

    ! Assign a bunch of values in a much larger sparse matrix.
    do i = 1, m, 10
        do j = 1, m, 5
            b(i, j) = i + j
        end do
    end do

    ! Pack each matrix.
    call pack_matrix(a, n, pa)
    call pack_matrix(b, m, pb)

    ! Print results.
    print '(a, i0)', 'Size of first dense matrix: ', size(a)
    print '(a, i0)', 'Size of first packed matrix: ', size(pa%rows) + size(pa%cols) + size(pa%vals) + 2

    print *, ''
    print '(a, i0)', 'Size of second dense matrix: ', size(b)
    print '(a, i0)', 'Size of second packed matrix: ', size(pb%rows) + size(pb%cols) + size(pb%vals) + 2

    ! We can also unpack a matrix.
    call unpack_matrix(pa, c)

    print '(a)', 'Unpacking A into a new matrix C:'
    do i = 1, n
        do j = 1, n
            write (*, '(i3, x)', advance='no') c(j, i)
        end do
        print *, ''
    end do

    ! Finally destroy the packed matrices to free up the memory.
    call destroy_packed(pa)
    call destroy_packed(pb)

end program main


c
c program topomap
c
      include 'VICMAIN_FOR'
      subroutine main44

      parameter (maxnl=1000, maxns=1000)
      character*132 msg
      integer*4 def,count,status,unit1,unit2,unit3,ounit
      real*4 buf(maxns,maxnl),bufnew(maxns,maxnl)
      real*4 mark(4,1000),linedisp(4000)
      real*4 sampdisp(4000),dn(1000),r(1000)
      real*8 length(-3:362),lpf_length(-3:362)
      integer*4 hist(0:359),pass

      call xvpcnt('INP',nids)
      call xvparm('RADIUS',nw,count,def,1)
      call xvparm('MINPTS',minpts,count,def,1)
      call xvparm('MAXPASS',maxpass,count,def,1)

      call xvunit(unit1,'INP',1,status,' ')
      call xvopen(unit1,status,' ')
      call xvget(unit1,status,'NL',nl1,'NS',ns1,' ')
      call xvunit(unit2,'INP',2,status,' ')
      call xvopen(unit2,status,'U_FORMAT','REAL',' ')
      call xvget(unit2,status,'NL',nl2,'NS',ns2,' ')
      if(nids.eq.3)then
        call xvunit(unit3,'INP',3,status,' ')
        call xvopen(unit3,status,'U_FORMAT','REAL',' ')
      endif

      call xvunit(ounit,'OUT',1,status,' ')
      call xvopen(ounit,status,'O_FORMAT','REAL','U_FORMAT','REAL',
     +    'OP','WRITE',' ')

c     Checks
      if(nl1.gt.maxnl)then
        call xvmessage('Too many input lines',' ')
        call abend()
      endif
      if(ns1.gt.maxns)then
        call xvmessage('Too many input samples',' ')
        call abend()
      endif

c     Clear image buffer.
      do j=1,nl1
        do i=1,ns1
          buf(i,j)=0.0
          bufnew(i,j)=0.0
        enddo
      enddo

c     Determine histogram of vector direction.
      do i=0,359
        hist(i)=0
        length(i)=0.d0
      enddo
      if(nids.eq.2)then   ! MARK input
        do j=1,nl2
          call xvread(unit2,mark,status,'LINE',j,' ')
          do i=1,ns2/4
            difs=mark(4,i)-mark(2,i)
            difl=mark(3,i)-mark(1,i)
            if((difs.ne.0.0).or.(difl.ne.0.0))then
              angle=atan2(-difl,difs)*57.29578
              if(angle.lt.0.0)angle=360.+angle
              k=angle
              if(k.gt.359)k=359
              if(k.lt.0)k=0
              hist(k)=hist(k)+1
              length(k)=length(k)+sqrt(difs*difs+difl*difl)
            endif
          enddo
        enddo
      else                 ! DISPARITY inputs
        do j=1,nl2
          call xvread(unit2,linedisp,status,'LINE',j,' ')
          call xvread(unit3,sampdisp,status,'LINE',j,' ')
          do i=1,ns2
            difs=sampdisp(i)-i
            difl=linedisp(i)-j
            if((difs.ne.0.0).or.(difl.ne.0.0))then
              angle=atan2(-difl,difs)*57.29578
              if(angle.lt.0.0)angle=360.+angle
              k=angle
              if(k.gt.359)k=359
              if(k.lt.0)k=0
              hist(k)=hist(k)+1
              length(k)=length(k)+sqrt(difs*difs+difl*difl)
            endif
          enddo
        enddo
      endif

c     Determine major vector direction
      length(-1)=length(359)
      length(-2)=length(358)
      length(-3)=length(357)
      length(360)=length(0)
      length(361)=length(1)
      length(362)=length(2)
      call uniflt(8,366,length(-3),lpf_length(-3),7)
      max_length=0
      k=-1
      do i=0,359
c       write(*,*)i,hist(i),length(i),lpf_length(i)
        if(lpf_length(i).gt.max_length)then
          max_length=lpf_length(i)
          k=i
        endif
      enddo
      if(k.eq.-1)then
        call xvmessage('All disparities are zero',' ')
        call abend()
      endif
      write(*,*)'Mean disparity is at ',k,' degrees'
      vector_angle=k
      if(vector_angle.gt.180.)vector_angle=vector_angle-360.
      vector_angle=vector_angle/57.29578
      vector_length=lpf_length(k)/hist(k)
      write(*,*)'Mean component vector length is ',
     +           vector_length,' pixels'

c     Compute the topomap at specific input values.
      if(nids.eq.2)then   ! MARK input
        do j=1,nl2
          call xvread(unit2,mark,status,'LINE',j,' ')
          do i=1,ns2/4
            difs=mark(4,i)-mark(2,i)
            difl=mark(3,i)-mark(1,i)
            if((difs.ne.0.0).or.(difl.ne.0.0))then
              dangle=atan2(-difl,difs)-vector_angle
              vlength=sqrt(difs*difs+difl*difl)
              ii=nint(mark(2,i))
              jj=nint(mark(1,i))
              buf(ii,jj)=vlength*cos(dangle)
            endif
          enddo
        enddo
      else                 ! DISPARITY inputs
        do j=1,nl2
          call xvread(unit2,linedisp,status,'LINE',j,' ')
          call xvread(unit3,sampdisp,status,'LINE',j,' ')
          do i=1,ns2
            difs=sampdisp(i)-i
            difl=linedisp(i)-j
            if((difs.ne.0.0).or.(difl.ne.0.0))then
              dangle=atan2(-difl,difs)-vector_angle
              vlength=sqrt(difs*difs+difl*difl)
              buf(i,j)=vlength*cos(dangle)
            endif
          enddo
        enddo
      endif

c     Fillin the missing pixels.
      rnw=nw*nw+.1 ! radius squared of collection circle + a bit
      pass=0
100   count=0
      pass=pass+1
      do j=1,nl1
        do i=1,ns1
          if(buf(i,j).ne.0.0)goto 10
          k=0
          do jj=max(j-nw,1),min(j+nw,nl1)
            j2=(j-jj)**2
            do ii=max(i-nw,1),min(i+nw,ns1)
              if(buf(ii,jj).ne.0.0)then
c               rad=(i-ii)**2+(j-jj)**2
                rad=(i-ii)**2+j2
                if(rad.le.rnw)then
                  k=k+1
                  dn(k)=buf(ii,jj)
                  r(k)=rad
                endif
              endif
            enddo
          enddo
          if(k.lt.minpts)goto 10
          sum1=0.0
          sum2=0.0
          do n=1,k
            sum1=sum1+dn(n)/r(n)
            sum2=sum2+1.0/r(n)
          enddo
          bufnew(i,j)=sum1/sum2
          count=count+1
10        continue
        enddo
      enddo
      do j=1,nl1
        do i=1,ns1
          if(bufnew(i,j).ne.0.0)then
            buf(i,j)=bufnew(i,j)
            bufnew(i,j)=0.0
          endif
        enddo
      enddo
      write(*,*)count,' pixels interpolated'
      if((count.gt.0).and.(pass.lt.maxpass))then
        goto 100
      endif

c     Write output
      do j=1,nl1
        call xvwrit(ounit,buf(1,j),status,' ')
      enddo

      return
      end